diff --git a/compiler/GHC.hs b/compiler/GHC.hs --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -310,6 +310,7 @@ import GHC.Driver.CmdLine import GHC.Driver.Session import GHC.Driver.Backend +import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Config.Logger (initLogFlags) import GHC.Driver.Config.Diagnostic @@ -381,7 +382,7 @@ import GHC.Types.Name.Reader import GHC.Types.SourceError import GHC.Types.SafeHaskell -import GHC.Types.Error hiding ( getMessages, getErrorMessages ) +import GHC.Types.Error import GHC.Types.Fixity import GHC.Types.Target import GHC.Types.Basic @@ -404,7 +405,6 @@ import Data.Foldable import qualified Data.Map.Strict as Map import Data.Set (Set) -import qualified Data.Set as S import qualified Data.Sequence as Seq import Data.Maybe import Data.Typeable ( Typeable ) @@ -420,7 +420,7 @@ import GHC.Data.Maybe import System.IO.Error ( isDoesNotExistError ) -import System.Environment ( getEnv ) +import System.Environment ( getEnv, getProgName ) import System.Directory import Data.List (isPrefixOf) @@ -465,9 +465,13 @@ (\ge -> liftIO $ do flushOut case ge of - Signal _ -> exitWith (ExitFailure 1) - _ -> do fm (show ge) - exitWith (ExitFailure 1) + Signal _ -> return () + ProgramError _ -> fm (show ge) + CmdLineError _ -> fm (": " ++ show ge) + _ -> do + progName <- getProgName + fm (progName ++ ": " ++ show ge) + exitWith (ExitFailure 1) ) $ inner @@ -530,8 +534,9 @@ let logger = hsc_logger hsc_env let tmpfs = hsc_tmpfs hsc_env liftIO $ do - cleanTempFiles logger tmpfs dflags - cleanTempDirs logger tmpfs dflags + unless (gopt Opt_KeepTmpFiles dflags) $ do + cleanTempFiles logger tmpfs + cleanTempDirs logger tmpfs traverse_ stopInterp (hsc_interp hsc_env) -- exceptions will be blocked while we clean the temporary files, -- so there shouldn't be any difficulty if we receive further @@ -585,10 +590,10 @@ checkBrokenTablesNextToCode' :: MonadIO m => Logger -> DynFlags -> m Bool checkBrokenTablesNextToCode' logger dflags - | not (isARM arch) = return False - | WayDyn `S.notMember` ways dflags = return False - | not tablesNextToCode = return False - | otherwise = do + | not (isARM arch) = return False + | ways dflags `hasNotWay` WayDyn = return False + | not tablesNextToCode = return False + | otherwise = do linkerInfo <- liftIO $ getLinkerInfo logger dflags case linkerInfo of GnuLD _ -> return True @@ -1583,7 +1588,7 @@ let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream (initParserOpts dflags) source startLoc of POk _ ts -> return ts - PFailed pst -> throwErrors (GhcPsMessage <$> getErrorMessages pst) + PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst) -- | Give even more information on the source than 'getTokenStream' -- This function allows reconstructing the source completely with @@ -1594,7 +1599,7 @@ let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream (initParserOpts dflags) source startLoc of POk _ ts -> return $ addSourceToTokens startLoc source ts - PFailed pst -> throwErrors (GhcPsMessage <$> getErrorMessages pst) + PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst) -- | Given a source location and a StringBuffer corresponding to this -- location, return a rich token stream with the source associated to the @@ -1655,9 +1660,10 @@ let home_unit = hsc_home_unit hsc_env let units = hsc_units hsc_env let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags case maybe_pkg of Just pkg | not (isHomeUnit home_unit (fsToUnit pkg)) && pkg /= fsLit "this" -> liftIO $ do - res <- findImportedModule fc units home_unit dflags mod_name maybe_pkg + res <- findImportedModule fc fopts units home_unit mod_name maybe_pkg case res of Found _ m -> return m err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err @@ -1666,12 +1672,14 @@ case home of Just m -> return m Nothing -> liftIO $ do - res <- findImportedModule fc units home_unit dflags mod_name maybe_pkg + res <- findImportedModule fc fopts units home_unit mod_name maybe_pkg case res of Found loc m | not (isHomeModule home_unit m) -> return m | otherwise -> modNotLoadedError dflags m loc err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err + where + modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $ text "module is not loaded:" <+> @@ -1695,7 +1703,8 @@ let fc = hsc_FC hsc_env let units = hsc_units hsc_env let dflags = hsc_dflags hsc_env - res <- findExposedPackageModule fc units dflags mod_name Nothing + let fopts = initFinderOpts dflags + res <- findExposedPackageModule fc fopts units mod_name Nothing case res of Found _ m -> return m err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err @@ -1773,11 +1782,11 @@ case unP Parser.parseModule (initParserState (initParserOpts dflags) buf loc) of PFailed pst -> - let (warns,errs) = getMessages pst in + let (warns,errs) = getPsMessages pst in (GhcPsMessage <$> warns, Left $ GhcPsMessage <$> errs) POk pst rdr_module -> - let (warns,_) = getMessages pst in + let (warns,_) = getPsMessages pst in (GhcPsMessage <$> warns, Right rdr_module) -- ----------------------------------------------------------------------------- diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs --- a/compiler/GHC/Builtin/Names/TH.hs +++ b/compiler/GHC/Builtin/Names/TH.hs @@ -72,7 +72,7 @@ classDName, instanceWithOverlapDName, standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName, pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, - pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, + pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, defaultDName, dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName, dataInstDName, newtypeInstDName, tySynInstDName, infixLDName, infixRDName, infixNDName, @@ -353,7 +353,7 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, - pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, + pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, defaultDName, dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName, infixNDName, roleAnnotDName, patSynDName, patSynSigDName, @@ -368,6 +368,7 @@ standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey sigDName = libFun (fsLit "sigD") sigDIdKey kiSigDName = libFun (fsLit "kiSigD") kiSigDIdKey +defaultDName = libFun (fsLit "defaultD") defaultDIdKey defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey forImpDName = libFun (fsLit "forImpD") forImpDIdKey pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey @@ -878,7 +879,7 @@ newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey, infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey, patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey, - kiSigDIdKey :: Unique + kiSigDIdKey, defaultDIdKey :: Unique funDIdKey = mkPreludeMiscIdUnique 320 valDIdKey = mkPreludeMiscIdUnique 321 dataDIdKey = mkPreludeMiscIdUnique 322 @@ -912,6 +913,7 @@ pragCompleteDIdKey = mkPreludeMiscIdUnique 350 implicitParamBindDIdKey = mkPreludeMiscIdUnique 351 kiSigDIdKey = mkPreludeMiscIdUnique 352 +defaultDIdKey = mkPreludeMiscIdUnique 353 -- type Cxt = ... cxtIdKey :: Unique diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs --- a/compiler/GHC/ByteCode/Asm.hs +++ b/compiler/GHC/ByteCode/Asm.hs @@ -459,7 +459,7 @@ JMP l -> emit bci_JMP [LabelOp l] ENTER -> emit bci_ENTER [] RETURN -> emit bci_RETURN [] - RETURN_UBX rep -> emit (return_ubx rep) [] + RETURN_UNLIFTED rep -> emit (return_unlifted rep) [] RETURN_TUPLE -> emit bci_RETURN_T [] CCALL off m_addr i -> do np <- addr m_addr emit bci_CCALL [SmallOp off, Op np, SmallOp i] @@ -527,16 +527,16 @@ push_alts V32 = error "push_alts: vector" push_alts V64 = error "push_alts: vector" -return_ubx :: ArgRep -> Word16 -return_ubx V = bci_RETURN_V -return_ubx P = bci_RETURN_P -return_ubx N = bci_RETURN_N -return_ubx L = bci_RETURN_L -return_ubx F = bci_RETURN_F -return_ubx D = bci_RETURN_D -return_ubx V16 = error "return_ubx: vector" -return_ubx V32 = error "return_ubx: vector" -return_ubx V64 = error "return_ubx: vector" +return_unlifted :: ArgRep -> Word16 +return_unlifted V = bci_RETURN_V +return_unlifted P = bci_RETURN_P +return_unlifted N = bci_RETURN_N +return_unlifted L = bci_RETURN_L +return_unlifted F = bci_RETURN_F +return_unlifted D = bci_RETURN_D +return_unlifted V16 = error "return_unlifted: vector" +return_unlifted V32 = error "return_unlifted: vector" +return_unlifted V64 = error "return_unlifted: vector" {- we can only handle up to a fixed number of words on the stack, diff --git a/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs --- a/compiler/GHC/ByteCode/Instr.hs +++ b/compiler/GHC/ByteCode/Instr.hs @@ -172,9 +172,9 @@ -- To Infinity And Beyond | ENTER - | RETURN -- return a lifted value - | RETURN_UBX ArgRep -- return an unlifted value, here's its rep - | RETURN_TUPLE -- return an unboxed tuple (info already on stack) + | RETURN -- return a lifted value + | RETURN_UNLIFTED ArgRep -- return an unlifted value, here's its rep + | RETURN_TUPLE -- return an unboxed tuple (info already on stack) -- Breakpoints | BRK_FUN Word16 Unique (RemotePtr CostCentre) @@ -310,7 +310,7 @@ <+> text "by" <+> ppr n ppr ENTER = text "ENTER" ppr RETURN = text "RETURN" - ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk + ppr (RETURN_UNLIFTED pk) = text "RETURN_UNLIFTED " <+> ppr pk ppr (RETURN_TUPLE) = text "RETURN_TUPLE" ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "" @@ -390,7 +390,7 @@ bciStackUse JMP{} = 0 bciStackUse ENTER{} = 0 bciStackUse RETURN{} = 0 -bciStackUse RETURN_UBX{} = 1 -- pushes stg_ret_X for some X +bciStackUse RETURN_UNLIFTED{} = 1 -- pushes stg_ret_X for some X bciStackUse RETURN_TUPLE{} = 1 -- pushes stg_ret_t header bciStackUse CCALL{} = 0 bciStackUse SWIZZLE{} = 0 diff --git a/compiler/GHC/Cmm/Opt.hs b/compiler/GHC/Cmm/Opt.hs --- a/compiler/GHC/Cmm/Opt.hs +++ b/compiler/GHC/Cmm/Opt.hs @@ -108,10 +108,6 @@ intconv True = MO_SS_Conv intconv False = MO_UU_Conv --- ToDo: a narrow of a load can be collapsed into a narrow load, right? --- but what if the architecture only supports word-sized loads, should --- we do the transformation anyway? - cmmMachOpFoldM platform mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)] = case mop of -- for comparisons: don't forget to narrow the arguments before @@ -357,7 +353,7 @@ CmmReg _ <- x -> -- We duplicate x in signedQuotRemHelper, hence require -- it is a reg. FIXME: remove this restriction. Just $! (cmmMachOpFold platform (MO_S_Shr rep) - [signedQuotRemHelper rep p, CmmLit (CmmInt p rep)]) + [signedQuotRemHelper rep p, CmmLit (CmmInt p $ wordWidth platform)]) MO_S_Rem rep | Just p <- exactLog2 n, CmmReg _ <- x -> -- We duplicate x in signedQuotRemHelper, hence require @@ -391,7 +387,7 @@ where bits = fromIntegral (widthInBits rep) - 1 shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep - x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)] + x1 = CmmMachOp shr [x, CmmLit (CmmInt bits $ wordWidth platform)] x2 = if p == 1 then x1 else CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)] 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 @@ -1509,7 +1509,7 @@ -- in there we don't want. case unPD cmmParse dflags home_unit init_state of PFailed pst -> do - let (warnings,errors) = getMessages pst + let (warnings,errors) = getPsMessages pst return (warnings, errors, Nothing) POk pst code -> do st <- initC @@ -1520,7 +1520,7 @@ ((), cmm2) <- getCmm $ mapM_ emitInfoTableProv used_info return (cmm ++ cmm2, used_info) (cmm, _) = runC dflags no_module st fcode - (warnings,errors) = getMessages pst + (warnings,errors) = getPsMessages pst if not (isEmptyMessages errors) then return (warnings, errors, Nothing) else return (warnings, errors, Just cmm) diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs --- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -1281,6 +1281,37 @@ MO_F32_Fabs -> mkCCall "fasbf" MO_F32_Sqrt -> mkCCall "sqrtf" + -- 64-bit primops + MO_I64_ToI -> mkCCall "hs_int64ToInt" + MO_I64_FromI -> mkCCall "hs_intToInt64" + MO_W64_ToW -> mkCCall "hs_word64ToWord" + MO_W64_FromW -> mkCCall "hs_wordToWord64" + MO_x64_Neg -> mkCCall "hs_neg64" + MO_x64_Add -> mkCCall "hs_add64" + MO_x64_Sub -> mkCCall "hs_sub64" + MO_x64_Mul -> mkCCall "hs_mul64" + MO_I64_Quot -> mkCCall "hs_quotInt64" + MO_I64_Rem -> mkCCall "hs_remInt64" + MO_W64_Quot -> mkCCall "hs_quotWord64" + MO_W64_Rem -> mkCCall "hs_remWord64" + MO_x64_And -> mkCCall "hs_and64" + MO_x64_Or -> mkCCall "hs_or64" + MO_x64_Xor -> mkCCall "hs_xor64" + MO_x64_Not -> mkCCall "hs_not64" + MO_x64_Shl -> mkCCall "hs_uncheckedShiftL64" + MO_I64_Shr -> mkCCall "hs_uncheckedIShiftRA64" + MO_W64_Shr -> mkCCall "hs_uncheckedShiftRL64" + MO_x64_Eq -> mkCCall "hs_eq64" + MO_x64_Ne -> mkCCall "hs_ne64" + MO_I64_Ge -> mkCCall "hs_geInt64" + MO_I64_Gt -> mkCCall "hs_gtInt64" + MO_I64_Le -> mkCCall "hs_leInt64" + MO_I64_Lt -> mkCCall "hs_ltInt64" + MO_W64_Ge -> mkCCall "hs_geWord64" + MO_W64_Gt -> mkCCall "hs_gtWord64" + MO_W64_Le -> mkCCall "hs_leWord64" + MO_W64_Lt -> mkCCall "hs_ltWord64" + -- Conversion MO_UF_Conv w -> mkCCall (word2FloatLabel w) 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 @@ -285,14 +285,11 @@ -- when generating PIC code, all cross-module data references must -- must go via a symbol pointer, too, because the assembler -- cannot generate code for a label difference where one - -- label is undefined. Doesn't apply t x86_64. - -- Unfortunately, we don't know whether it's cross-module, - -- so we do it for all externally visible labels. - -- This is a slight waste of time and space, but otherwise - -- we'd need to pass the current Module all the way in to - -- this function. + -- label is undefined. Doesn't apply to x86_64 (why?). | arch /= ArchX86_64 - , ncgPIC config && externallyVisibleCLabel lbl + , not (isLocalCLabel (ncgThisModule config) lbl) + , ncgPIC config + , externallyVisibleCLabel lbl = AccessViaSymbolPtr | otherwise diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs --- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs @@ -2006,6 +2006,39 @@ MO_F64_Acosh -> (fsLit "acosh", False) MO_F64_Atanh -> (fsLit "atanh", False) + MO_I64_ToI -> (fsLit "hs_int64ToInt", False) + MO_I64_FromI -> (fsLit "hs_intToInt64", False) + MO_W64_ToW -> (fsLit "hs_word64ToWord", False) + MO_W64_FromW -> (fsLit "hs_wordToWord64", False) + + MO_x64_Neg -> (fsLit "hs_neg64", False) + MO_x64_Add -> (fsLit "hs_add64", False) + MO_x64_Sub -> (fsLit "hs_sub64", False) + MO_x64_Mul -> (fsLit "hs_mul64", False) + MO_I64_Quot -> (fsLit "hs_quotInt64", False) + MO_I64_Rem -> (fsLit "hs_remInt64", False) + MO_W64_Quot -> (fsLit "hs_quotWord64", False) + MO_W64_Rem -> (fsLit "hs_remWord64", False) + + MO_x64_And -> (fsLit "hs_and64", False) + MO_x64_Or -> (fsLit "hs_or64", False) + MO_x64_Xor -> (fsLit "hs_xor64", False) + MO_x64_Not -> (fsLit "hs_not64", False) + MO_x64_Shl -> (fsLit "hs_uncheckedShiftL64", False) + MO_I64_Shr -> (fsLit "hs_uncheckedIShiftRA64", False) + MO_W64_Shr -> (fsLit "hs_uncheckedShiftRL64", False) + + MO_x64_Eq -> (fsLit "hs_eq64", False) + MO_x64_Ne -> (fsLit "hs_ne64", False) + MO_I64_Ge -> (fsLit "hs_geInt64", False) + MO_I64_Gt -> (fsLit "hs_gtInt64", False) + MO_I64_Le -> (fsLit "hs_leInt64", False) + MO_I64_Lt -> (fsLit "hs_ltInt64", False) + MO_W64_Ge -> (fsLit "hs_geWord64", False) + MO_W64_Gt -> (fsLit "hs_gtWord64", False) + MO_W64_Le -> (fsLit "hs_leWord64", False) + MO_W64_Lt -> (fsLit "hs_ltWord64", False) + MO_UF_Conv w -> (word2FloatLabel w, False) MO_Memcpy _ -> (fsLit "memcpy", False) @@ -2053,7 +2086,7 @@ genSwitch config expr targets | OSAIX <- platformOS platform = do - (reg,e_code) <- getSomeReg (cmmOffset platform expr offset) + (reg,e_code) <- getSomeReg indexExpr let fmt = archWordFormat $ target32Bit platform sha = if target32Bit platform then 2 else 3 tmp <- getNewRegNat fmt @@ -2070,7 +2103,7 @@ | (ncgPIC config) || (not $ target32Bit platform) = do - (reg,e_code) <- getSomeReg (cmmOffset platform expr offset) + (reg,e_code) <- getSomeReg indexExpr let fmt = archWordFormat $ target32Bit platform sha = if target32Bit platform then 2 else 3 tmp <- getNewRegNat fmt @@ -2087,7 +2120,7 @@ return code | otherwise = do - (reg,e_code) <- getSomeReg (cmmOffset platform expr offset) + (reg,e_code) <- getSomeReg indexExpr let fmt = archWordFormat $ target32Bit platform sha = if target32Bit platform then 2 else 3 tmp <- getNewRegNat fmt @@ -2101,6 +2134,12 @@ ] return code where + indexExpr = cmmOffset platform exprWidened offset + -- We widen to a native-width register to santize the high bits + exprWidened = CmmMachOp + (MO_UU_Conv (cmmExprWidth platform expr) + (platformWordWidth platform)) + [expr] (offset, ids) = switchTargetsToTable targets platform = ncgPlatform config diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs @@ -313,7 +313,7 @@ = error "MachCodeGen: sparc genSwitch PIC not finished\n" | otherwise - = do (e_reg, e_code) <- getSomeReg (cmmOffset (ncgPlatform config) expr offset) + = do (e_reg, e_code) <- getSomeReg indexExpr base_reg <- getNewRegNat II32 offset_reg <- getNewRegNat II32 @@ -334,7 +334,15 @@ , LD II32 (AddrRegReg base_reg offset_reg) dst , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label , NOP ] - where (offset, ids) = switchTargetsToTable targets + where + indexExpr = cmmOffset platform exprWidened offset + -- We widen to a native-width register to santize the high bits + exprWidened = CmmMachOp + (MO_UU_Conv (cmmExprWidth platform expr) + (platformWordWidth platform)) + [expr] + (offset, ids) = switchTargetsToTable targets + platform = ncgPlatform config generateJumpTableForInstr :: Platform -> Instr -> Maybe (NatCmmDecl RawCmmStatics Instr) @@ -657,6 +665,36 @@ MO_F64_Asinh -> fsLit "asinh" MO_F64_Acosh -> fsLit "acosh" MO_F64_Atanh -> fsLit "atanh" + + MO_I64_ToI -> fsLit "hs_int64ToInt" + MO_I64_FromI -> fsLit "hs_intToInt64" + MO_W64_ToW -> fsLit "hs_word64ToWord" + MO_W64_FromW -> fsLit "hs_wordToWord64" + MO_x64_Neg -> fsLit "hs_neg64" + MO_x64_Add -> fsLit "hs_add64" + MO_x64_Sub -> fsLit "hs_sub64" + MO_x64_Mul -> fsLit "hs_mul64" + MO_I64_Quot -> fsLit "hs_quotInt64" + MO_I64_Rem -> fsLit "hs_remInt64" + MO_W64_Quot -> fsLit "hs_quotWord64" + MO_W64_Rem -> fsLit "hs_remWord64" + MO_x64_And -> fsLit "hs_and64" + MO_x64_Or -> fsLit "hs_or64" + MO_x64_Xor -> fsLit "hs_xor64" + MO_x64_Not -> fsLit "hs_not64" + MO_x64_Shl -> fsLit "hs_uncheckedShiftL64" + MO_I64_Shr -> fsLit "hs_uncheckedIShiftRA64" + MO_W64_Shr -> fsLit "hs_uncheckedShiftRL64" + MO_x64_Eq -> fsLit "hs_eq64" + MO_x64_Ne -> fsLit "hs_ne64" + MO_I64_Ge -> fsLit "hs_geInt64" + MO_I64_Gt -> fsLit "hs_gtInt64" + MO_I64_Le -> fsLit "hs_leInt64" + MO_I64_Lt -> fsLit "hs_ltInt64" + MO_W64_Ge -> fsLit "hs_geWord64" + MO_W64_Gt -> fsLit "hs_gtWord64" + MO_W64_Le -> fsLit "hs_leWord64" + MO_W64_Lt -> fsLit "hs_ltWord64" MO_UF_Conv w -> word2FloatLabel w diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -2476,18 +2476,17 @@ mask_r <- getNewRegNat format let dst_r = getRegisterReg platform (CmmLocal dst) return $ code_src src_r `appOL` code_mask mask_r `appOL` - (if width == W8 then - -- The PDEP instruction doesn't take a r/m8 - unitOL (MOVZxL II8 (OpReg src_r ) (OpReg src_r )) `appOL` - unitOL (MOVZxL II8 (OpReg mask_r) (OpReg mask_r)) `appOL` - unitOL (PDEP II16 (OpReg mask_r) (OpReg src_r ) dst_r) - else - unitOL (PDEP format (OpReg mask_r) (OpReg src_r) dst_r)) `appOL` - (if width == W8 || width == W16 then - -- We used a 16-bit destination register above, - -- so zero-extend - unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r)) - else nilOL) + -- PDEP only supports > 32 bit args + ( if width == W8 || width == W16 then + toOL + [ MOVZxL format (OpReg src_r ) (OpReg src_r ) + , MOVZxL format (OpReg mask_r) (OpReg mask_r) + , PDEP II32 (OpReg mask_r) (OpReg src_r ) dst_r + , MOVZxL format (OpReg dst_r) (OpReg dst_r) -- Truncate to op width + ] + else + unitOL (PDEP format (OpReg mask_r) (OpReg src_r) dst_r) + ) else do targetExpr <- cmmMakeDynamicReference config CallReference lbl @@ -2509,18 +2508,17 @@ mask_r <- getNewRegNat format let dst_r = getRegisterReg platform (CmmLocal dst) return $ code_src src_r `appOL` code_mask mask_r `appOL` - (if width == W8 then - -- The PEXT instruction doesn't take a r/m8 - unitOL (MOVZxL II8 (OpReg src_r ) (OpReg src_r )) `appOL` - unitOL (MOVZxL II8 (OpReg mask_r) (OpReg mask_r)) `appOL` - unitOL (PEXT II16 (OpReg mask_r) (OpReg src_r) dst_r) - else - unitOL (PEXT format (OpReg mask_r) (OpReg src_r) dst_r)) `appOL` (if width == W8 || width == W16 then - -- We used a 16-bit destination register above, - -- so zero-extend - unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r)) - else nilOL) + -- The PEXT instruction doesn't take a r/m8 or 16 + toOL + [ MOVZxL format (OpReg src_r ) (OpReg src_r ) + , MOVZxL format (OpReg mask_r) (OpReg mask_r) + , PEXT II32 (OpReg mask_r) (OpReg src_r ) dst_r + , MOVZxL format (OpReg dst_r) (OpReg dst_r) -- Truncate to op width + ] + else + unitOL (PEXT format (OpReg mask_r) (OpReg src_r) dst_r) + ) else do targetExpr <- cmmMakeDynamicReference config CallReference lbl @@ -3390,6 +3388,36 @@ MO_F64_Acosh -> fsLit "acosh" MO_F64_Atanh -> fsLit "atanh" + MO_I64_ToI -> fsLit "hs_int64ToInt" + MO_I64_FromI -> fsLit "hs_intToInt64" + MO_W64_ToW -> fsLit "hs_word64ToWord" + MO_W64_FromW -> fsLit "hs_wordToWord64" + MO_x64_Neg -> fsLit "hs_neg64" + MO_x64_Add -> fsLit "hs_add64" + MO_x64_Sub -> fsLit "hs_sub64" + MO_x64_Mul -> fsLit "hs_mul64" + MO_I64_Quot -> fsLit "hs_quotInt64" + MO_I64_Rem -> fsLit "hs_remInt64" + MO_W64_Quot -> fsLit "hs_quotWord64" + MO_W64_Rem -> fsLit "hs_remWord64" + MO_x64_And -> fsLit "hs_and64" + MO_x64_Or -> fsLit "hs_or64" + MO_x64_Xor -> fsLit "hs_xor64" + MO_x64_Not -> fsLit "hs_not64" + MO_x64_Shl -> fsLit "hs_uncheckedShiftL64" + MO_I64_Shr -> fsLit "hs_uncheckedIShiftRA64" + MO_W64_Shr -> fsLit "hs_uncheckedShiftRL64" + MO_x64_Eq -> fsLit "hs_eq64" + MO_x64_Ne -> fsLit "hs_ne64" + MO_I64_Ge -> fsLit "hs_geInt64" + MO_I64_Gt -> fsLit "hs_gtInt64" + MO_I64_Le -> fsLit "hs_leInt64" + MO_I64_Lt -> fsLit "hs_ltInt64" + MO_W64_Ge -> fsLit "hs_geWord64" + MO_W64_Gt -> fsLit "hs_gtWord64" + MO_W64_Le -> fsLit "hs_leWord64" + MO_W64_Lt -> fsLit "hs_ltWord64" + MO_Memcpy _ -> fsLit "memcpy" MO_Memset _ -> fsLit "memset" MO_Memmove _ -> fsLit "memmove" @@ -3448,9 +3476,16 @@ genSwitch expr targets = do config <- getConfig let platform = ncgPlatform config + -- We widen to a native-width register because we cannot use arbitry sizes + -- in x86 addressing modes. + exprWidened = CmmMachOp + (MO_UU_Conv (cmmExprWidth platform expr) + (platformWordWidth platform)) + [expr] + indexExpr = cmmOffset platform exprWidened offset if ncgPIC config then do - (reg,e_code) <- getNonClobberedReg (cmmOffset platform expr offset) + (reg,e_code) <- getNonClobberedReg indexExpr -- getNonClobberedReg because it needs to survive across t_code lbl <- getNewLabelNat let is32bit = target32Bit platform @@ -3491,7 +3526,7 @@ JMP_TBL (OpReg tableReg) ids rosection lbl ] else do - (reg,e_code) <- getSomeReg (cmmOffset platform expr offset) + (reg,e_code) <- getSomeReg indexExpr lbl <- getNewLabelNat let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl)) code = e_code `appOL` toOL [ 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 @@ -199,7 +199,11 @@ -- Moves. | MOV Format Operand Operand | CMOV Cond Format Operand Reg - | MOVZxL Format Operand Operand -- format is the size of operand 1 + | MOVZxL Format Operand Operand + -- ^ The format argument is the size of operand 1 (the number of bits we keep) + -- We always zero *all* high bits, even though this isn't how the actual instruction + -- works. The code generator also seems to rely on this behaviour and it's faster + -- to execute on many cpus as well so for now I'm just documenting the fact. | MOVSxL Format Operand Operand -- format is the size of operand 1 -- x86_64 note: plain mov into a 32-bit register always zero-extends -- into the 64-bit reg, in contrast to the 8 and 16-bit movs which diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -341,15 +341,17 @@ where (pairs, mbdef) = switchTargetsFallThrough ids + rep = typeWidth (cmmExprType platform e) + -- fall through case caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix where do_fallthrough ix = - hsep [ text "case" , pprHexVal platform ix (wordWidth platform) <> colon , + hsep [ text "case" , pprHexVal platform ix rep <> colon , text "/* fall through */" ] final_branch ix = - hsep [ text "case" , pprHexVal platform ix (wordWidth platform) <> colon , + hsep [ text "case" , pprHexVal platform ix rep <> colon , text "goto" , (pprBlockId ident) <> semi ] caseify (_ , _ ) = panic "pprSwitch: switch with no cases!" @@ -861,6 +863,35 @@ (MO_Prefetch_Data _ ) -> unsupported --- we could support prefetch via "__builtin_prefetch" --- Not adding it for now + MO_I64_ToI -> text "hs_int64ToInt" + MO_I64_FromI -> text "hs_intToInt64" + MO_W64_ToW -> text "hs_word64ToWord" + MO_W64_FromW -> text "hs_wordToWord64" + MO_x64_Neg -> text "hs_neg64" + MO_x64_Add -> text "hs_add64" + MO_x64_Sub -> text "hs_sub64" + MO_x64_Mul -> text "hs_mul64" + MO_I64_Quot -> text "hs_quotInt64" + MO_I64_Rem -> text "hs_remInt64" + MO_W64_Quot -> text "hs_quotWord64" + MO_W64_Rem -> text "hs_remWord64" + MO_x64_And -> text "hs_and64" + MO_x64_Or -> text "hs_xor64" + MO_x64_Xor -> text "hs_xor64" + MO_x64_Not -> text "hs_not64" + MO_x64_Shl -> text "hs_uncheckedShiftL64" + MO_I64_Shr -> text "hs_uncheckedIShiftRA64" + MO_W64_Shr -> text "hs_uncheckedShiftRL64" + MO_x64_Eq -> text "hs_eq64" + MO_x64_Ne -> text "hs_ne64" + MO_I64_Ge -> text "hs_geInt64" + MO_I64_Gt -> text "hs_gtInt64" + MO_I64_Le -> text "hs_leInt64" + MO_I64_Lt -> text "hs_ltInt64" + MO_W64_Ge -> text "hs_geWord64" + MO_W64_Gt -> text "hs_gtWord64" + MO_W64_Le -> text "hs_leWord64" + MO_W64_Lt -> text "hs_ltWord64" where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop ++ " not supported!") diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs --- a/compiler/GHC/CmmToLlvm/CodeGen.hs +++ b/compiler/GHC/CmmToLlvm/CodeGen.hs @@ -911,6 +911,37 @@ MO_Cmpxchg _ -> unsupported MO_Xchg _ -> unsupported + MO_I64_ToI -> fsLit "hs_int64ToInt" + MO_I64_FromI -> fsLit "hs_intToInt64" + MO_W64_ToW -> fsLit "hs_word64ToWord" + MO_W64_FromW -> fsLit "hs_wordToWord64" + MO_x64_Neg -> fsLit "hs_neg64" + MO_x64_Add -> fsLit "hs_add64" + MO_x64_Sub -> fsLit "hs_sub64" + MO_x64_Mul -> fsLit "hs_mul64" + MO_I64_Quot -> fsLit "hs_quotInt64" + MO_I64_Rem -> fsLit "hs_remInt64" + MO_W64_Quot -> fsLit "hs_quotWord64" + MO_W64_Rem -> fsLit "hs_remWord64" + MO_x64_And -> fsLit "hs_and64" + MO_x64_Or -> fsLit "hs_or64" + MO_x64_Xor -> fsLit "hs_xor64" + MO_x64_Not -> fsLit "hs_not64" + MO_x64_Shl -> fsLit "hs_uncheckedShiftL64" + MO_I64_Shr -> fsLit "hs_uncheckedIShiftRA64" + MO_W64_Shr -> fsLit "hs_uncheckedShiftRL64" + MO_x64_Eq -> fsLit "hs_eq64" + MO_x64_Ne -> fsLit "hs_ne64" + MO_I64_Ge -> fsLit "hs_geInt64" + MO_I64_Gt -> fsLit "hs_gtInt64" + MO_I64_Le -> fsLit "hs_leInt64" + MO_I64_Lt -> fsLit "hs_ltInt64" + MO_W64_Ge -> fsLit "hs_geWord64" + MO_W64_Gt -> fsLit "hs_gtWord64" + MO_W64_Le -> fsLit "hs_leWord64" + MO_W64_Lt -> fsLit "hs_ltWord64" + + -- | Tail function calls genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData 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 @@ -691,8 +691,8 @@ -- about to begin, with '1' for the first | iteration_no > max_iterations -- Stop if we've run out of iterations = warnPprTrace (debugIsOn && (max_iterations > 2)) - ( hang (text "Simplifier bailing out after" <+> int max_iterations - <+> text "iterations" + ( hang (ppr this_mod <> colon <+> text "simplifier bailing out after" + <+> int max_iterations <+> text "iterations" <+> (brackets $ hsep $ punctuate comma $ map (int . simplCountN) (reverse counts_so_far))) 2 (text "Size =" <+> ppr (coreBindsStats binds))) $ 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 @@ -57,15 +57,13 @@ import GHC.Types.Basic 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 GHC.Data.Maybe ( isNothing, orElse ) import GHC.Data.FastString import GHC.Unit.Module ( moduleName, pprModuleName ) - import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain @@ -292,33 +290,30 @@ simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs | Just env' <- preInlineUnconditionally env top_lvl old_bndr rhs env = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-} - trace_bind "pre-inline-uncond" $ + simplTrace env "SimplBindr:inline-uncond" (ppr old_bndr) $ do { tick (PreInlineUnconditionally old_bndr) ; return ( emptyFloats env, env' ) } | Just cont <- mb_cont = {-#SCC "simplRecOrTopPair-join" #-} assert (isNotTopLevel top_lvl && isJoinId new_bndr ) - trace_bind "join" $ + simplTrace env "SimplBind:join" (ppr old_bndr) $ simplJoinBind env cont old_bndr new_bndr rhs env | otherwise = {-#SCC "simplRecOrTopPair-normal" #-} - trace_bind "normal" $ + simplTrace env "SimplBind:normal" (ppr old_bndr) $ simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env +simplTrace :: SimplEnv -> String -> SDoc -> a -> a +simplTrace env herald doc thing_inside + | not (logHasDumpFlag logger Opt_D_verbose_core2core) + = thing_inside + | otherwise + = logTraceMsg logger herald doc thing_inside where 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 (logHasDumpFlag logger Opt_D_verbose_core2core) - = thing_inside - | otherwise - = logTraceMsg logger ("SimplBind " ++ what) - (ppr old_bndr) thing_inside - -------------------------- simplLazyBind :: SimplEnv -> TopLevelFlag -> RecFlag @@ -366,16 +361,17 @@ -- ANF-ise a constructor or PAP rhs -- We get at most one float per argument here + ; let body_env1 = body_env `setInScopeFromF` body_floats1 + -- body_env1: add to in-scope set the binders from body_floats1 + -- so that prepareBinding knows what is in scope in body1 ; (let_floats, body2) <- {-#SCC "prepareBinding" #-} - prepareBinding env top_lvl bndr1 body1 + prepareBinding body_env1 top_lvl bndr1 body1 ; let body_floats2 = body_floats1 `addLetFloats` let_floats - ; (rhs_floats, rhs') + ; (rhs_floats, body3) <- if not (doFloatFromRhs top_lvl is_rec False body_floats2 body2) then -- No floating, revert to body1 - {-#SCC "simplLazyBind-no-floating" #-} - do { rhs' <- mkLam env tvs' (wrapFloats body_floats2 body1) rhs_cont - ; return (emptyFloats env, rhs') } + return (emptyFloats env, wrapFloats body_floats2 body1) else if null tvs then -- Simple floating {-#SCC "simplLazyBind-simple-floating" #-} @@ -388,11 +384,11 @@ ; (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl tvs' body_floats2 body2 ; let floats = foldl' extendFloats (emptyFloats env) poly_binds - ; rhs' <- mkLam env tvs' body3 rhs_cont - ; return (floats, rhs') } + ; return (floats, body3) } - ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats) - top_lvl Nothing bndr bndr1 rhs' + ; let env' = env `setInScopeFromF` rhs_floats + ; rhs' <- mkLam env' tvs' body3 rhs_cont + ; (bind_float, env2) <- completeBind env' top_lvl Nothing bndr bndr1 rhs' ; return (rhs_floats `addFloats` bind_float, env2) } -------------------------- @@ -427,6 +423,12 @@ | Coercion co <- new_rhs = return (emptyFloats env, extendCvSubst env bndr co) + | exprIsTrivial new_rhs -- Short-cut for let x = y in ... + -- This case would ultimately land in postInlineUnconditionally + -- but it seems not uncommon, and avoids a lot of faff to do it here + = return (emptyFloats env + , extendIdSubst env bndr (DoneEx new_rhs Nothing)) + | otherwise = do { (env', bndr') <- simplBinder env bndr ; completeNonRecX NotTopLevel env' (isStrictId bndr') bndr bndr' new_rhs } @@ -607,7 +609,7 @@ , 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 + = do { (rhs_floats, work_rhs) <- prepareRhs env top_lvl occ_fs rhs ; uniq <- getUniqueM ; let work_name = mkSystemVarName uniq occ_fs work_id = mkLocalIdWithInfo work_name Many rhs_ty worker_info @@ -690,7 +692,7 @@ -> OutId -> OutExpr -> SimplM (LetFloats, OutExpr) prepareBinding env top_lvl bndr rhs - = prepareRhs (getMode env) top_lvl (getOccFS bndr) rhs + = prepareRhs env top_lvl (getOccFS bndr) rhs {- Note [prepareRhs] ~~~~~~~~~~~~~~~~~~~~ @@ -710,17 +712,17 @@ That's what the 'go' loop in prepareRhs does -} -prepareRhs :: SimplMode -> TopLevelFlag +prepareRhs :: SimplEnv -> TopLevelFlag -> FastString -- Base for any new variables -> OutExpr -> SimplM (LetFloats, OutExpr) -- Transforms a RHS into a better RHS by ANF'ing args -- for expandable RHSs: constructors and PAPs -- e.g x = Just e --- becomes a = e +-- becomes a = e -- 'a' is fresh -- x = Just a -- See Note [prepareRhs] -prepareRhs mode top_lvl occ rhs0 +prepareRhs env top_lvl occ rhs0 = do { (_is_exp, floats, rhs1) <- go 0 rhs0 ; return (floats, rhs1) } where @@ -735,7 +737,7 @@ = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun ; case is_exp of False -> return (False, emptyLetFloats, App fun arg) - True -> do { (floats2, arg') <- makeTrivial mode top_lvl topDmd occ arg + True -> do { (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } } go n_val_args (Var fun) = return (is_exp, emptyLetFloats, Var fun) @@ -764,58 +766,64 @@ go _ other = return (False, emptyLetFloats, other) -makeTrivialArg :: SimplMode -> ArgSpec -> SimplM (LetFloats, ArgSpec) -makeTrivialArg mode arg@(ValArg { as_arg = e, as_dmd = dmd }) - = do { (floats, e') <- makeTrivial mode NotTopLevel dmd (fsLit "arg") e +makeTrivialArg :: SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec) +makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd }) + = do { (floats, e') <- makeTrivial env NotTopLevel dmd (fsLit "arg") e ; return (floats, arg { as_arg = e' }) } makeTrivialArg _ arg = return (emptyLetFloats, arg) -- CastBy, TyArg -makeTrivial :: SimplMode -> TopLevelFlag -> Demand +makeTrivial :: SimplEnv -> TopLevelFlag -> Demand -> FastString -- ^ A "friendly name" to build the new binder from -> OutExpr -- ^ This expression satisfies the let/app invariant -> SimplM (LetFloats, OutExpr) -- Binds the expression to a variable, if it's not trivial, returning the variable -- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A] -makeTrivial mode top_lvl dmd occ_fs expr +makeTrivial env top_lvl dmd occ_fs expr | exprIsTrivial expr -- Already trivial || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise -- See Note [Cannot trivialise] = return (emptyLetFloats, expr) | Cast expr' co <- expr - = do { (floats, triv_expr) <- makeTrivial mode top_lvl dmd occ_fs expr' + = do { (floats, triv_expr) <- makeTrivial env top_lvl dmd occ_fs expr' ; return (floats, Cast triv_expr co) } | otherwise - = do { (floats, new_id) <- makeTrivialBinding mode top_lvl occ_fs + = do { (floats, new_id) <- makeTrivialBinding env top_lvl occ_fs id_info expr expr_ty ; return (floats, Var new_id) } where id_info = vanillaIdInfo `setDemandInfo` dmd expr_ty = exprType expr -makeTrivialBinding :: SimplMode -> TopLevelFlag +makeTrivialBinding :: SimplEnv -> TopLevelFlag -> FastString -- ^ a "friendly name" to build the new binder from -> IdInfo -> OutExpr -- ^ This expression satisfies the let/app invariant -> OutType -- Type of the expression -> SimplM (LetFloats, OutId) -makeTrivialBinding mode top_lvl occ_fs info expr expr_ty - = do { (floats, expr1) <- prepareRhs mode top_lvl occ_fs expr +makeTrivialBinding env top_lvl occ_fs info expr expr_ty + = do { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr ; uniq <- getUniqueM ; let name = mkSystemVarName uniq occ_fs var = mkLocalIdWithInfo name Many expr_ty info -- Now something very like completeBind, -- but without the postInlineUnconditionally part - ; (arity_type, expr2) <- tryEtaExpandRhs mode var expr1 + ; (arity_type, expr2) <- tryEtaExpandRhs env var expr1 + -- Technically we should extend the in-scope set in 'env' with + -- the 'floats' from prepareRHS; but they are all fresh, so there is + -- no danger of introducing name shadowig in eta expansion + ; unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs var expr2 ; let final_id = addLetBndrInfo var arity_type unf bind = NonRec final_id expr2 ; return ( floats `addLetFlts` unitLetFloat bind, final_id ) } + where + mode = getMode env bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool -- True iff we can have a binding of this expression at this level @@ -899,11 +907,10 @@ do { let old_info = idInfo old_bndr 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, eta_rhs) <- tryEtaExpandRhs mode new_bndr new_rhs + ; (new_arity, eta_rhs) <- tryEtaExpandRhs env new_bndr new_rhs -- Simplify the unfolding ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr @@ -916,9 +923,12 @@ then -- Inline and discard the binding do { tick (PostInlineUnconditionally old_bndr) - ; return ( emptyFloats env + ; let unf_rhs = maybeUnfoldingTemplate new_unfolding `orElse` eta_rhs + -- See Note [Use occ-anald RHS in postInlineUnconditionally] + ; simplTrace env "PostInlineUnconditionally" (ppr new_bndr <+> ppr unf_rhs) $ + return ( emptyFloats env , extendIdSubst env old_bndr $ - DoneEx eta_rhs (isJoinId_maybe new_bndr)) } + DoneEx unf_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 @@ -1022,7 +1032,22 @@ (for example) be no longer strictly demanded. The solution here is a bit ad hoc... +Note [Use occ-anald RHS in postInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we postInlineUnconditionally 'f in + let f = \x -> x True in ...(f blah)... +then we'd like to inline the /occ-anald/ RHS for 'f'. If we +use the non-occ-anald version, we'll end up with a + ...(let x = blah in x True)... +and hence an extra Simplifier iteration. +We already /have/ the occ-anald version in the Unfolding for +the Id. Well, maybe not /quite/ always. If the binder is Dead, +postInlineUnconditionally will return True, but we may not have an +unfolding because it's too big. Hence the belt-and-braces `orElse` +in the defn of unf_rhs. The Nothing case probably never happens. + + ************************************************************************ * * \subsection[Simplify-simplExpr]{The main function: simplExpr} @@ -1632,8 +1657,8 @@ -- Not enough args, so there are real lambdas left to put in the result simplLam env bndrs body cont = do { (env', bndrs') <- simplLamBndrs env bndrs - ; body' <- simplExpr env' body - ; new_lam <- mkLam env bndrs' body' cont + ; body' <- simplExpr env' body + ; new_lam <- mkLam env' bndrs' body' cont ; rebuild env' new_lam cont } ------------- @@ -2684,6 +2709,27 @@ We could try and be more clever (like maybe wfloats only contain let binders, so we could float them). But the need for the extra complication is not clear. + +Note [Do not duplicate constructor applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#20125) + let x = (a,b) + in ...(case x of x' -> blah)...x...x... + +We want that `case` to vanish (since `x` is bound to a data con) leaving + let x = (a,b) + in ...(let x'=x in blah)...x..x... + +In rebuildCase, `exprIsConApp_maybe` will succeed on the scrutinee `x`, +since is bound to (a,b). But in eliminating the case, if the scrutinee +is trivial, we want to bind the case-binder to the scrutinee, /not/ to +the constructor application. Hence the case_bndr_rhs in rebuildCase. + +This applies equally to a non-DEFAULT case alternative, say + let x = (a,b) in ...(case x of x' { (p,q) -> blah })... +This variant is handled by bind_case_bndr in knownCon. + +We want to bind x' to x, and not to a duplicated (a,b)). -} --------------------------------------------------------- @@ -2717,19 +2763,21 @@ , let env0 = setInScopeSet env in_scope' = do { tick (KnownBranch case_bndr) ; let scaled_wfloats = map scale_float wfloats + -- case_bndr_unf: see Note [Do not duplicate constructor applications] + case_bndr_rhs | exprIsTrivial scrut = scrut + | otherwise = con_app + con_app = Var (dataConWorkId con) `mkTyApps` ty_args + `mkApps` other_args ; case findAlt (DataAlt con) alts of - Nothing -> missingAlt env0 case_bndr alts cont - Just (Alt DEFAULT bs rhs) -> let con_app = Var (dataConWorkId con) - `mkTyApps` ty_args - `mkApps` other_args - in simple_rhs env0 scaled_wfloats con_app bs rhs - Just (Alt _ bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args other_args - case_bndr bs rhs cont + Nothing -> missingAlt env0 case_bndr alts cont + Just (Alt DEFAULT bs rhs) -> simple_rhs env0 scaled_wfloats case_bndr_rhs bs rhs + Just (Alt _ bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args + other_args case_bndr bs rhs cont } where - simple_rhs env wfloats scrut' bs rhs = + simple_rhs env wfloats case_bndr_rhs bs rhs = assert (null bs) $ - do { (floats1, env') <- simplNonRecX env case_bndr scrut' + do { (floats1, env') <- simplNonRecX env case_bndr case_bndr_rhs -- scrut is a constructor application, -- hence satisfies let/app invariant ; (floats2, expr') <- simplExprF env' rhs cont @@ -3295,6 +3343,7 @@ | isDeadBinder bndr = return (emptyFloats env, env) | exprIsTrivial scrut = return (emptyFloats env , extendIdSubst env bndr (DoneEx scrut Nothing)) + -- See Note [Do not duplicate constructor applications] | otherwise = do { dc_args <- mapM (simplVar env) bs -- dc_ty_args are already OutTypes, -- but bs are InBndrs @@ -3428,13 +3477,14 @@ (StrictArg { sc_fun = fun, sc_cont = cont , sc_fun_ty = fun_ty }) -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - | thumbsUpPlanA cont + | isNothing (isDataConId_maybe (ai_fun fun)) + , thumbsUpPlanA cont -- See point (3) of Note [Duplicating join points] = -- Use Plan A of Note [Duplicating StrictArg] do { let (_ : dmds) = ai_dmds fun ; (floats1, cont') <- mkDupableContWithDmds env dmds cont -- Use the demands from the function to add the right -- demand info on any bindings we make for further args - ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg (getMode env)) + ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg env) (ai_args fun) ; return ( foldl' addLetFloats floats1 floats_s , StrictArg { sc_fun = fun { ai_args = args' } @@ -3480,7 +3530,7 @@ ; (floats1, cont') <- mkDupableContWithDmds env dmds cont ; let env' = env `setInScopeFromF` floats1 ; (_, se', arg') <- simplArg env' dup se arg - ; (let_floats2, arg'') <- makeTrivial (getMode env) NotTopLevel dmd (fsLit "karg") arg' + ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' ; let all_floats = floats1 `addLetFloats` let_floats2 ; return ( all_floats , ApplyToVal { sc_arg = arg'' @@ -3537,7 +3587,7 @@ mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType -> SimplM (SimplFloats, SimplCont) mkDupableStrictBind env arg_bndr join_rhs res_ty - | exprIsDupable (targetPlatform (seDynFlags env)) join_rhs + | exprIsTrivial join_rhs -- See point (2) of Note [Duplicating join points] = return (emptyFloats env , StrictBind { sc_bndr = arg_bndr, sc_bndrs = [] , sc_body = join_rhs @@ -3564,8 +3614,8 @@ mkDupableAlt :: Platform -> OutId -> JoinFloats -> OutAlt -> SimplM (JoinFloats, OutAlt) -mkDupableAlt platform case_bndr jfloats (Alt con bndrs' rhs') - | exprIsDupable platform rhs' -- Note [Small alternative rhs] +mkDupableAlt _platform case_bndr jfloats (Alt con bndrs' rhs') + | exprIsTrivial rhs' -- See point (2) of Note [Duplicating join points] = return (jfloats, Alt con bndrs' rhs') | otherwise @@ -3632,6 +3682,77 @@ See #4957 a fuller example. +Note [Duplicating join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +IN #19996 we discovered that we want to be really careful about +inlining join points. Consider + case (join $j x = K f x ) + (in case v of ) + ( p1 -> $j x1 ) of + ( p2 -> $j x2 ) + ( p3 -> $j x3 ) + K g y -> blah[g,y] + +Here the join-point RHS is very small, just a constructor +application (K x y). So we might inline it to get + case (case v of ) + ( p1 -> K f x1 ) of + ( p2 -> K f x2 ) + ( p3 -> K f x3 ) + K g y -> blah[g,y] + +But now we have to make `blah` into a join point, /abstracted/ +over `g` and `y`. In contrast, if we /don't/ inline $j we +don't need a join point for `blah` and we'll get + join $j x = let g=f, y=x in blah[g,y] + in case v of + p1 -> $j x1 + p2 -> $j x2 + p3 -> $j x3 + +This can make a /massive/ difference, because `blah` can see +what `f` is, instead of lambda-abstracting over it. + +To achieve this: + +1. Do not postInlineUnconditionally a join point, until the Final + phase. (The Final phase is still quite early, so we might consider + delaying still more.) + +2. In mkDupableAlt and mkDupableStrictBind, generate an alterative for + all alternatives, except for exprIsTrival RHSs. Previously we used + exprIsDupable. This generates a lot more join points, but makes + them much more case-of-case friendly. + + It is definitely worth checking for exprIsTrivial, otherwise we get + an extra Simplifier iteration, because it is inlined in the next + round. + +3. By the same token we want to use Plan B in + Note [Duplicating StrictArg] when the RHS of the new join point + is a data constructor application. That same Note explains why we + want Plan A when the RHS of the new join point would be a + non-data-constructor application + +4. You might worry that $j will be inlined by the call-site inliner, + but it won't because the call-site context for a join is usually + extremely boring (the arguments come from the pattern match). + And if not, then perhaps inlining it would be a good idea. + + You might also wonder if we get UnfWhen, because the RHS of the + join point is no bigger than the call. But in the cases we care + about it will be a little bigger, because of that free `f` in + $j x = K f x + So for now we don't do anything special in callSiteInline + +There is a bit of tension between (2) and (3). Do we want to retain +the join point only when the RHS is +* a constructor application? or +* just non-trivial? +Currently, a bit ad-hoc, but we definitely want to retain the join +point for data constructors in mkDupalbleALt (point 2); that is the +whole point of #19996 described above. + Historical Note [Case binders and join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB: this entire Note is now irrelevant. In Jun 21 we stopped @@ -3686,24 +3807,6 @@ but zapping it (as we do in mkDupableCont, the Select case) is safe, and at worst delays the join-point inlining. -Note [Small alternative rhs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is worth checking for a small RHS because otherwise we -get extra let bindings that may cause an extra iteration of the simplifier to -inline back in place. Quite often the rhs is just a variable or constructor. -The Ord instance of Maybe in PrelMaybe.hs, for example, took several extra -iterations because the version with the let bindings looked big, and so wasn't -inlined, but after the join points had been inlined it looked smaller, and so -was inlined. - -NB: we have to check the size of rhs', not rhs. -Duplicating a small InAlt might invalidate occurrence information -However, if it *is* dupable, we return the *un* simplified alternative, -because otherwise we'd need to pair it up with an empty subst-env.... -but we only have one env shared between all the alts. -(Remember we must zap the subst-env before re-simplifying something). -Rather than do this we simply agree to re-simplify the original (small) thing later. - Note [Funky mkLamTypes] ~~~~~~~~~~~~~~~~~~~~~~ Notice the funky mkLamTypes. If the constructor has existentials @@ -3749,10 +3852,18 @@ join $j x = f e1 x e3 in case x of { True -> jump $j r1 ; False -> jump $j r2 } - Notice that Plan B is very like the way we handle strict - bindings; see Note [Duplicating StrictBind]. -Plan A is good. Here's an example from #3116 + Notice that Plan B is very like the way we handle strict bindings; + see Note [Duplicating StrictBind]. And Plan B is exactly what we'd + get if we turned use a case expression to evaluate the strict arg: + + case (case x of { True -> r1; False -> r2 }) of + r -> f e1 r e3 + + So, looking at Note [Duplicating join points], we also want Plan B + when `f` is a data constructor. + +Plan A is often good. Here's an example from #3116 go (n+1) (case l of 1 -> bs' _ -> Chunk p fpc (o+1) (l-1) bs') @@ -3913,8 +4024,7 @@ mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource -> InId -> OutExpr -> SimplM Unfolding mkLetUnfolding !uf_opts top_lvl src id new_rhs - = is_bottoming `seq` -- See Note [Force bottoming field] - return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs) + = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs) -- We make an unfolding *even for loop-breakers*. -- Reason: (a) It might be useful to know that they are WHNF -- (b) In GHC.Iface.Tidy we currently assume that, if we want to @@ -3922,8 +4032,11 @@ -- to expose. (We could instead use the RHS, but currently -- we don't.) The simple thing is always to have one. where - is_top_lvl = isTopLevel top_lvl - is_bottoming = isDeadEndId id + -- Might as well force this, profiles indicate up to 0.5MB of thunks + -- just from this site. + !is_top_lvl = isTopLevel top_lvl + -- See Note [Force bottoming field] + !is_bottoming = isDeadEndId id ------------------- simplStableUnfolding :: SimplEnv -> TopLevelFlag @@ -3960,11 +4073,17 @@ , ug_boring_ok = boring_ok } -- Happens for INLINE things - -> let guide' = + -- Really important to force new_boring_ok as otherwise + -- `ug_boring_ok` is a thunk chain of + -- inlineBoringExprOk expr0 + -- || inlineBoringExprOk expr1 || ... + -- See #20134 + -> let !new_boring_ok = boring_ok || inlineBoringOk expr' + guide' = UnfWhen { ug_arity = arity , ug_unsat_ok = sat_ok - , ug_boring_ok = - boring_ok || inlineBoringOk expr' + , ug_boring_ok = new_boring_ok + } -- Refresh the boring-ok flag, in case expr' -- has got small. This happens, notably in the inlinings @@ -3985,7 +4104,9 @@ | otherwise -> return noUnfolding -- Discard unstable unfoldings where uf_opts = seUnfoldingOpts env - is_top_lvl = isTopLevel top_lvl + -- Forcing this can save about 0.5MB of max residency and the result + -- is small and easy to compute so might as well force it. + !is_top_lvl = isTopLevel top_lvl act = idInlineActivation id unf_env = updMode (updModeForStableUnfoldings act) env -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils @@ -3994,7 +4115,7 @@ eta_expand expr | not eta_on = expr | exprIsTrivial expr = expr - | otherwise = etaExpandAT id_arity expr + | otherwise = etaExpandAT (getInScope env) id_arity expr eta_on = sm_eta_expand (getMode env) {- Note [Eta-expand stable unfoldings] @@ -4126,3 +4247,4 @@ than necesary. Allowing some inlining might, for example, eliminate a binding. -} + diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -576,10 +576,13 @@ -- Add the let-floats for env2 to env1; -- *plus* the in-scope set for env2, which is bigger -- than that for env1 -addLetFloats floats let_floats@(LetFloats binds _) +addLetFloats floats let_floats = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats - , sfInScope = foldlOL extendInScopeSetBind - (sfInScope floats) binds } + , sfInScope = sfInScope floats `extendInScopeFromLF` let_floats } + +extendInScopeFromLF :: InScopeSet -> LetFloats -> InScopeSet +extendInScopeFromLF in_scope (LetFloats binds _) + = foldlOL extendInScopeSetBind in_scope binds addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats addJoinFloats floats join_floats 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 @@ -409,6 +409,7 @@ contIsRhs :: SimplCont -> Bool contIsRhs (Stop _ RhsCtxt) = True +contIsRhs (CastIt _ k) = contIsRhs k -- For f = e |> co, treat e as Rhs context contIsRhs _ = False ------------------- @@ -1386,6 +1387,8 @@ | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally] | isTopLevel top_lvl = False -- Note [Top level and postInlineUnconditionally] | exprIsTrivial rhs = True + | isJoinId bndr -- See point (1) of Note [Duplicating join points] + , not (phase == FinalPhase) = False -- in Simplify.hs | otherwise = case occ_info of OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt, occ_n_br = n_br } @@ -1440,7 +1443,8 @@ where unfolding = idUnfolding bndr uf_opts = seUnfoldingOpts env - active = isActive (sm_phase (getMode env)) (idInlineActivation bndr) + phase = sm_phase (getMode env) + active = isActive phase (idInlineActivation bndr) -- See Note [pre/postInlineUnconditionally in gentle mode] {- Note [Inline small things to avoid creating a thunk] @@ -1554,11 +1558,13 @@ -- mkLam tries three things -- a) eta reduction, if that gives a trivial expression -- b) eta expansion [only if there are some value lambdas] - +-- +-- NB: the SimplEnv already includes the [OutBndr] in its in-scope set mkLam _env [] body _cont = return body mkLam env bndrs body cont - = do { dflags <- getDynFlags + = {-#SCC "mkLam" #-} + do { dflags <- getDynFlags ; mkLam' dflags bndrs body } where mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr @@ -1592,13 +1598,16 @@ , let body_arity = exprEtaExpandArity dflags body , expandableArityType body_arity = do { tick (EtaExpansion (head bndrs)) - ; let res = mkLams bndrs (etaExpandAT body_arity body) + ; let res = mkLams bndrs $ + etaExpandAT in_scope body_arity body ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body) , text "after" <+> ppr res]) ; return res } | otherwise = return (mkLams bndrs body) + where + in_scope = getInScope env -- Includes 'bndrs' {- Note [Eta expanding lambdas] @@ -1661,13 +1670,13 @@ ************************************************************************ -} -tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr +tryEtaExpandRhs :: SimplEnv -> OutId -> OutExpr -> SimplM (ArityType, OutExpr) -- See Note [Eta-expanding at let bindings] -- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then -- (a) rhs' has manifest arity n -- (b) if is_bot is True then rhs' applied to n args is guaranteed bottom -tryEtaExpandRhs mode bndr rhs +tryEtaExpandRhs env bndr rhs | Just join_arity <- isJoinId_maybe bndr = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs oss = [idOneShotInfo id | id <- join_bndrs, isId id] @@ -1683,12 +1692,14 @@ , new_arity > old_arity -- And the current manifest arity isn't enough , want_eta rhs = do { tick (EtaExpansion bndr) - ; return (arity_type, etaExpandAT arity_type rhs) } + ; return (arity_type, etaExpandAT in_scope arity_type rhs) } | otherwise = return (arity_type, rhs) where + mode = getMode env + in_scope = getInScope env dflags = sm_dflags mode old_arity = exprArity rhs diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -61,7 +61,6 @@ import Control.Monad (ap) import Data.Maybe (fromMaybe) import Data.Tuple (swap) -import qualified Data.Set as Set -- Note [Live vs free] -- ~~~~~~~~~~~~~~~~~~~ @@ -248,7 +247,7 @@ then collectDebugInformation dflags ml pgm' else (pgm', emptyInfoTableProvMap) - prof = WayProf `Set.member` ways dflags + prof = ways dflags `hasWay` WayProf final_ccs | prof && gopt Opt_AutoSccsOnIndividualCafs dflags 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,6 +21,7 @@ -- In a separate module because it hooks into the parser. import GHC.Driver.Backpack.Syntax +import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Config.Diagnostic import GHC.Driver.Monad @@ -107,7 +108,7 @@ buf <- liftIO $ hGetStringBuffer src_filename let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of - PFailed pst -> throwErrors (GhcPsMessage <$> getErrorMessages pst) + PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst) POk _ pkgname_bkp -> do -- OK, so we have an LHsUnit PackageName, but we want an -- LHsUnit HsComponentId. So let's rename it. @@ -742,9 +743,10 @@ hsc_env <- getSession let dflags = hsc_dflags hsc_env let home_unit = hsc_home_unit hsc_env + let fopts = initFinderOpts dflags let PackageName pn_fs = pn - location <- liftIO $ mkHomeModLocation2 dflags mod_name + location <- liftIO $ mkHomeModLocation2 fopts mod_name (unpackFS pn_fs moduleNameSlashes mod_name) "hsig" env <- getBkpEnv @@ -769,6 +771,7 @@ ms_hie_date = hie_timestamp, ms_srcimps = [], ms_textual_imps = extra_sig_imports, + ms_ghc_prim_import = False, ms_parsed_mod = Just (HsParsedModule { hpm_module = L loc (HsModule { hsmodAnn = noAnn, @@ -827,13 +830,14 @@ -- Use the PACKAGE NAME to find the location let PackageName unit_fs = pn dflags = hsc_dflags hsc_env + fopts = initFinderOpts dflags -- Unfortunately, we have to define a "fake" location in -- order to appease the various code which uses the file -- name to figure out where to put, e.g. object files. -- To add insult to injury, we don't even actually use -- these filenames to figure out where the hi files go. -- A travesty! - location0 <- liftIO $ mkHomeModLocation2 dflags modname + location0 <- liftIO $ mkHomeModLocation2 fopts modname (unpackFS unit_fs moduleNameSlashes modname) (case hsc_src of @@ -854,8 +858,9 @@ let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps -- GHC.Prim doesn't exist physically, so don't go looking for it. - ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) - ord_idecls + (ordinary_imps, ghc_prim_import) + = partition ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) + ord_idecls implicit_prelude = xopt LangExt.ImplicitPrelude dflags implicit_imports = mkPrelImports modname loc @@ -884,6 +889,7 @@ ms_hspp_opts = dflags, ms_hspp_buf = Nothing, ms_srcimps = map convImport src_idecls, + ms_ghc_prim_import = not (null ghc_prim_import), ms_textual_imps = normal_imports -- We have to do something special here: -- due to merging, requirements may end up with 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.Finder (initFinderOpts) import GHC.Driver.Config.CmmToAsm (initNCGConfig) import GHC.Driver.Ppr import GHC.Driver.Backend @@ -209,8 +210,8 @@ Maybe FilePath) -- C file created outputForeignStubs logger tmpfs dflags unit_state mod location stubs = do - let stub_h = mkStubPaths dflags (moduleName mod) location - stub_c <- newTempName logger tmpfs dflags TFL_CurrentModule "c" + let stub_h = mkStubPaths (initFinderOpts dflags) (moduleName mod) location + stub_c <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c" case stubs of NoStubs -> 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 @@ -121,7 +121,7 @@ import GHC.HsToCore -import GHC.StgToByteCode ( byteCodeGen, stgExprToBCOs ) +import GHC.StgToByteCode ( byteCodeGen ) import GHC.IfaceToCore ( typecheckIface ) @@ -193,8 +193,7 @@ import GHC.Types.SafeHaskell import GHC.Types.ForeignStubs import GHC.Types.Var.Env ( emptyTidyEnv ) -import GHC.Types.Error hiding ( getMessages ) -import qualified GHC.Types.Error as Error.Types +import GHC.Types.Error import GHC.Types.Fixity.Env import GHC.Types.CostCentre import GHC.Types.IPE @@ -224,7 +223,6 @@ import qualified GHC.SysTools import Data.Data hiding (Fixity, TyCon) -import Data.Maybe ( fromJust ) import Data.List ( nub, isPrefixOf, partition ) import Control.Monad import Data.IORef @@ -236,6 +234,7 @@ import Data.Functor import Control.DeepSeq (force) import Data.Bifunctor (first) +import GHC.Data.Maybe {- ********************************************************************** %* * @@ -413,9 +412,9 @@ case unP parseMod (initParserState (initParserOpts dflags) buf loc) of PFailed pst -> - handleWarningsThrowErrors (getMessages pst) + handleWarningsThrowErrors (getPsMessages pst) POk pst rdr_module -> do - let (warns, errs) = getMessages pst + let (warns, errs) = getPsMessages pst logDiagnostics (GhcPsMessage <$> warns) liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser" FormatHaskell (ppr rdr_module) @@ -438,7 +437,8 @@ -- - filter out the .hs/.lhs source filename if we have one -- let n_hspp = FilePath.normalise src_filename - srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`)) + TempDir tmp_dir = tmpDir dflags + srcs0 = nub $ filter (not . (tmp_dir `isPrefixOf`)) $ filter (not . (== n_hspp)) $ map FilePath.normalise $ filter (not . isPrefixOf "<") @@ -565,15 +565,13 @@ hsc_env <- getHscEnv 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 diag_opts (getLoc (hpm_module mod)) $ - GhcDriverMessage $ DriverUnknownMessage $ - mkPlainDiagnostic reason noHints warnMissingSafeHaskellMode + GhcDriverMessage $ DriverMissingSafeHaskellMode (ms_mod sum) tcg_res <- {-# SCC "Typecheck-Rename" #-} ioMsgMaybe $ hoistTcRnMessage $ @@ -602,25 +600,14 @@ | safeHaskell dflags == Sf_Safe -> return () | otherwise -> (logDiagnostics $ singleMessage $ mkPlainMsgEnvelope diag_opts (warnSafeOnLoc dflags) $ - GhcDriverMessage $ DriverUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnSafe) noHints $ - errSafe tcg_res') + GhcDriverMessage $ DriverInferredSafeModule (tcg_mod tcg_res')) False | safeHaskell dflags == Sf_Trustworthy && wopt Opt_WarnTrustworthySafe dflags -> (logDiagnostics $ singleMessage $ mkPlainMsgEnvelope diag_opts (trustworthyOnLoc dflags) $ - GhcDriverMessage $ DriverUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnTrustworthySafe) noHints $ - errTwthySafe tcg_res') + GhcDriverMessage $ DriverMarkedTrustworthyButInferredSafe (tcg_mod tcg_res')) False -> return () return tcg_res' - where - pprMod t = ppr $ moduleName $ tcg_mod t - errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!" - errTwthySafe t = quotes (pprMod t) - <+> text "is marked as Trustworthy but has been inferred as safe!" - warnMissingSafeHaskellMode = ppr (moduleName (ms_mod sum)) - <+> text "is missing Safe Haskell mode" -- | Convert a typechecked module to Core hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts @@ -1175,12 +1162,8 @@ warns diag_opts rules = mkMessages $ listToBag $ map (warnRules diag_opts) rules 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" $+$ - text "User defined rules are disabled under Safe Haskell" + warnRules diag_opts (L loc rule) = + mkPlainMsgEnvelope diag_opts (locA loc) $ DriverUserDefinedRuleIgnored rule -- | Validate that safe imported modules are actually safe. For modules in the -- HomePackage (the package the module we are compiling in resides) this just @@ -1256,9 +1239,7 @@ | imv_is_safe v1 /= imv_is_safe v2 = throwOneError $ mkPlainErrorMsgEnvelope (imv_span v1) $ - GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $ - text "Module" <+> ppr (imv_name v1) <+> - (text $ "is imported both as a safe and unsafe import!") + GhcDriverMessage $ DriverMixedSafetyImport (imv_name v1) | otherwise = return v1 @@ -1327,9 +1308,7 @@ -- can't load iface to check trust! Nothing -> throwOneError $ mkPlainErrorMsgEnvelope l $ - GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $ - text "Can't load the interface file for" <+> ppr m - <> text ", to check that it can be safely imported" + GhcDriverMessage $ DriverCannotLoadInterfaceFile m -- got iface, check trust Just iface' -> @@ -1361,30 +1340,13 @@ state = hsc_units hsc_env inferredImportWarn diag_opts = singleMessage $ mkMsgEnvelope diag_opts l (pkgQual state) - $ GhcDriverMessage $ DriverUnknownMessage - $ mkPlainDiagnostic (WarningWithFlag Opt_WarnInferredSafeImports) noHints - $ sep - [ text "Importing Safe-Inferred module " - <> ppr (moduleName m) - <> text " from explicitly Safe module" - ] + $ GhcDriverMessage $ DriverInferredSafeImport m pkgTrustErr = singleMessage $ mkErrorMsgEnvelope l (pkgQual state) - $ GhcDriverMessage $ DriverUnknownMessage - $ mkPlainError noHints - $ sep [ ppr (moduleName m) - <> text ": Can't be safely imported!" - , text "The package (" - <> (pprWithUnitState state $ ppr (moduleUnit m)) - <> text ") the module resides in isn't trusted." - ] + $ GhcDriverMessage $ DriverCannotImportFromUntrustedPackage state m modTrustErr = singleMessage $ mkErrorMsgEnvelope l (pkgQual state) - $ GhcDriverMessage $ DriverUnknownMessage - $ mkPlainError noHints - $ sep [ ppr (moduleName m) - <> text ": Can't be safely imported!" - , text "The module itself isn't safe." ] + $ GhcDriverMessage $ DriverCannotImportUnsafeModule m -- | Check the package a module resides in is trusted. Safe compiled -- modules are trusted without requiring that their package is trusted. For @@ -1430,12 +1392,7 @@ = (`consBag` acc) $ mkErrorMsgEnvelope noSrcSpan (pkgQual state) $ GhcDriverMessage - $ DriverUnknownMessage - $ mkPlainError noHints - $ pprWithUnitState state - $ text "The package (" - <> ppr pkg - <> text ") is required to be trusted but it isn't!" + $ DriverPackageNotTrusted state pkg if isEmptyBag errors then return () else liftIO $ throwErrors $ mkMessages errors @@ -1478,7 +1435,7 @@ whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" , text "Reason:" , nest 4 $ (vcat $ badFlags df) $+$ - (vcat $ pprMsgEnvelopeBagWithLoc (Error.Types.getMessages whyUnsafe)) $+$ + (vcat $ pprMsgEnvelopeBagWithLoc (getMessages whyUnsafe)) $+$ (vcat $ badInsts $ tcg_insts tcg_env) ] badFlags df = concatMap (badFlag df) unsafeFlagsForInfer @@ -1564,7 +1521,7 @@ -- | Compile to hard-code. hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos) - -- ^ @Just f@ <=> _stub.c is f + -- ^ @Just f@ <=> _stub.c is f hscGenHardCode hsc_env cgguts location output_filename = do let CgGuts{ -- This is the last use of the ModGuts in a compilation. -- From now on, we just use the bits we need. @@ -1815,7 +1772,8 @@ myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext -> Module -> ModLocation -> CoreExpr - -> IO ( StgRhs + -> IO ( Id + , [StgTopBinding] , InfoTableProvMap , CollectedCCs ) myCoreToStgExpr logger dflags ictxt this_mod ml prepd_expr = do @@ -1825,14 +1783,14 @@ (mkPseudoUniqueE 0) Many (exprType prepd_expr) - ([StgTopLifted (StgNonRec _ stg_expr)], prov_map, collected_ccs) <- + (stg_binds, prov_map, collected_ccs) <- myCoreToStg logger dflags ictxt this_mod ml [NonRec bco_tmp_id prepd_expr] - return (stg_expr, prov_map, collected_ccs) + return (bco_tmp_id, stg_binds, prov_map, collected_ccs) myCoreToStg :: Logger -> DynFlags -> InteractiveContext -> Module -> ModLocation -> CoreProgram @@ -2001,7 +1959,7 @@ stg_binds data_tycons mod_breaks let src_span = srcLocSpan interactiveSrcLoc - liftIO $ loadDecls interp hsc_env (src_span, Nothing) cbc + _ <- liftIO $ loadDecls interp hsc_env (src_span, Nothing) cbc {- Load static pointer table entries -} liftIO $ hscAddSptEntries hsc_env Nothing (cg_spt_entries tidy_cg) @@ -2129,9 +2087,9 @@ case unP parser (initParserState (initParserOpts dflags) buf loc) of PFailed pst -> - handleWarningsThrowErrors (getMessages pst) + handleWarningsThrowErrors (getPsMessages pst) POk pst thing -> do - logWarningsReportErrors (getMessages pst) + logWarningsReportErrors (getPsMessages pst) liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser" FormatHaskell (ppr thing) liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST" @@ -2172,7 +2130,7 @@ ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" } ; let ictxt = hsc_IC hsc_env - ; (stg_expr, _, _) <- + ; (binding_id, stg_expr, _, _) <- myCoreToStgExpr (hsc_logger hsc_env) (hsc_dflags hsc_env) ictxt @@ -2181,13 +2139,16 @@ prepd_expr {- Convert to BCOs -} - ; bcos <- stgExprToBCOs hsc_env + ; bcos <- byteCodeGen hsc_env (icInteractiveModule ictxt) - (exprType prepd_expr) stg_expr + [] Nothing {- load it -} - ; loadExpr (hscInterp hsc_env) hsc_env srcspan bcos } + ; fv_hvs <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos + {- Get the HValue for the root -} + ; return (expectJust "hscCompileCoreExpr'" + $ lookup (idName binding_id) fv_hvs) } {- ********************************************************************** 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 @@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE FlexibleContexts #-} -- ----------------------------------------------------------------------------- -- @@ -41,6 +42,7 @@ ) where import GHC.Prelude +import GHC.Platform import GHC.Tc.Utils.Backpack import GHC.Tc.Utils.Monad ( initIfaceCheck ) @@ -51,6 +53,7 @@ import GHC.Runtime.Context +import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Config.Logger (initLogFlags) import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Config.Diagnostic @@ -78,7 +81,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.Exception ( AsyncException(..), evaluate ) -import GHC.Utils.Monad ( allM ) +import GHC.Utils.Monad ( allM, MonadIO ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain @@ -87,7 +90,6 @@ import GHC.Utils.Logger import GHC.Utils.Fingerprint import GHC.Utils.TmpFs -import GHC.Utils.Constants (isWindowsHost) import GHC.Types.Basic import GHC.Types.Error @@ -102,7 +104,6 @@ import GHC.Types.Name.Env import GHC.Unit -import GHC.Unit.External import GHC.Unit.Finder import GHC.Unit.Module.ModSummary import GHC.Unit.Module.ModIface @@ -124,7 +125,7 @@ import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) import qualified Control.Monad.Catch as MC import Data.IORef -import Data.List (nub, sort, sortBy, partition) +import Data.List (sortBy, partition) import qualified Data.List as List import Data.Foldable (toList) import Data.Maybe @@ -338,7 +339,7 @@ load how_much = do (errs, mod_graph) <- depanalE [] False -- #17459 success <- load' how_much (Just batchMsg) mod_graph - warnUnusedPackages + warnUnusedPackages mod_graph if isEmptyMessages errs then pure success else throwErrors (fmap GhcDriverMessage errs) @@ -350,24 +351,21 @@ -- actually loaded packages. All the packages, specified on command line, -- but never loaded, are probably unused dependencies. -warnUnusedPackages :: GhcMonad m => m () -warnUnusedPackages = do +warnUnusedPackages :: GhcMonad m => ModuleGraph -> m () +warnUnusedPackages mod_graph = do hsc_env <- getSession - eps <- liftIO $ hscEPS hsc_env let dflags = hsc_dflags hsc_env state = hsc_units hsc_env - pit = eps_PIT eps diag_opts = initDiagOpts dflags + us = hsc_units hsc_env - let loadedPackages - = map (unsafeLookupUnit state) - . nub . sort - . map moduleUnit - . moduleEnvKeys - $ pit + -- Only need non-source imports here because SOURCE imports are always HPT + let loadedPackages = concat $ + mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs) + $ concatMap ms_imps (mgModSummaries mod_graph) - requestedArgs = mapMaybe packageArg (packageFlags dflags) + let requestedArgs = mapMaybe packageArg (packageFlags dflags) unusedArgs = filter (\arg -> not $ any (matching state arg) loadedPackages) @@ -541,7 +539,7 @@ -- Clean up after ourselves hsc_env1 <- getSession - liftIO $ cleanCurrentModuleTempFiles logger (hsc_tmpfs hsc_env1) dflags + liftIO $ cleanCurrentModuleTempFilesMaybe logger (hsc_tmpfs hsc_env1) dflags -- Issue a warning for the confusing case where the user -- said '-o foo' but we're not going to do any linking. @@ -608,7 +606,7 @@ ] tmpfs <- hsc_tmpfs <$> getSession liftIO $ changeTempFilesLifetime tmpfs TFL_CurrentModule unneeded_temps - liftIO $ cleanCurrentModuleTempFiles logger tmpfs dflags + liftIO $ cleanCurrentModuleTempFilesMaybe logger tmpfs dflags let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) hpt4 @@ -697,6 +695,7 @@ guessOutputFile :: GhcMonad m => m () guessOutputFile = modifySession $ \env -> let dflags = hsc_dflags env + platform = targetPlatform dflags -- Force mod_graph to avoid leaking env !mod_graph = hsc_mod_graph env mainModuleSrcPath :: Maybe String @@ -709,7 +708,7 @@ -- we must add the .exe extension unconditionally here, otherwise -- when name has an extension of its own, the .exe extension will -- not be added by GHC.Driver.Pipeline.exeFileName. See #2248 - name' <- if isWindowsHost --FIXME: should be the target platform + name' <- if platformOS platform == OSMinGW32 then fmap (<.> "exe") name else name mainModuleSrcPath' <- mainModuleSrcPath @@ -1337,9 +1336,9 @@ return (hsc_env'', localize_hsc_env hsc_env'') -- Clean up any intermediate files. - cleanCurrentModuleTempFiles (hsc_logger lcl_hsc_env') - (hsc_tmpfs lcl_hsc_env') - (hsc_dflags lcl_hsc_env') + cleanCurrentModuleTempFilesMaybe (hsc_logger lcl_hsc_env') + (hsc_tmpfs lcl_hsc_env') + (hsc_dflags lcl_hsc_env') return Succeeded where @@ -1437,9 +1436,9 @@ hsc_env <- getSession -- Remove unwanted tmp files between compilations - liftIO $ cleanCurrentModuleTempFiles (hsc_logger hsc_env) - (hsc_tmpfs hsc_env) - (hsc_dflags hsc_env) + liftIO $ cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) + (hsc_tmpfs hsc_env) + (hsc_dflags hsc_env) -- Get ready to tie the knot type_env_var <- liftIO $ newIORef emptyNameEnv @@ -1557,7 +1556,7 @@ compile_it :: Maybe Linkable -> IO HomeModInfo compile_it mb_linkable = - compileOne' Nothing mHscMessage hsc_env summary mod_index nmods + compileOne' mHscMessage hsc_env summary mod_index nmods mb_old_iface mb_linkable in @@ -2177,7 +2176,7 @@ , ms_mod `Set.member` needs_codegen_set = do let new_temp_file suf dynsuf = do - tn <- newTempName logger tmpfs dflags staticLife suf + tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf let dyn_tn = tn -<.> dynsuf addFilesToClean tmpfs dynLife [dyn_tn] return tn @@ -2313,9 +2312,10 @@ preimps@PreprocessedImports {..} <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf + let fopts = initFinderOpts (hsc_dflags hsc_env) -- Make a ModLocation for this file - location <- liftIO $ mkHomeModLocation (hsc_dflags hsc_env) pi_mod_name src_fn + location <- liftIO $ mkHomeModLocation fopts pi_mod_name src_fn -- Tell the Finder cache where it is, so that subsequent calls -- to findModule will find it, even if it's not on any search path @@ -2430,6 +2430,7 @@ | otherwise = find_it where dflags = hsc_dflags hsc_env + fopts = initFinderOpts dflags home_unit = hsc_home_unit hsc_env fc = hsc_FC hsc_env units = hsc_units hsc_env @@ -2441,7 +2442,7 @@ old_summary location find_it = do - found <- findImportedModule fc units home_unit dflags wanted_mod Nothing + found <- findImportedModule fc fopts units home_unit wanted_mod Nothing case found of Found location mod | isJust (ml_hs_file location) -> @@ -2540,6 +2541,7 @@ , ms_hspp_buf = Just pi_hspp_buf , ms_parsed_mod = Nothing , ms_srcimps = pi_srcimps + , ms_ghc_prim_import = pi_ghc_prim_import , ms_textual_imps = pi_theimps ++ extra_sig_imports ++ @@ -2558,6 +2560,7 @@ { pi_local_dflags :: DynFlags , pi_srcimps :: [(Maybe FastString, Located ModuleName)] , pi_theimps :: [(Maybe FastString, Located ModuleName)] + , pi_ghc_prim_import :: Bool , pi_hspp_fn :: FilePath , pi_hspp_buf :: StringBuffer , pi_mod_name_loc :: SrcSpan @@ -2577,7 +2580,7 @@ (pi_local_dflags, pi_hspp_fn) <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn - (pi_srcimps, pi_theimps, L pi_mod_name_loc pi_mod_name) + (pi_srcimps, pi_theimps, pi_ghc_prim_import, L pi_mod_name_loc pi_mod_name) <- ExceptT $ do let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags popts = initParserOpts pi_local_dflags @@ -2711,3 +2714,9 @@ ppr_ms :: ModSummary -> SDoc ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+> (parens (text (msHsFilePath ms))) + + +cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m () +cleanCurrentModuleTempFilesMaybe logger tmpfs dflags = + unless (gopt Opt_KeepTmpFiles dflags) $ + liftIO $ cleanCurrentModuleTempFiles logger tmpfs 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 @@ -16,6 +16,7 @@ import GHC.Prelude import qualified GHC +import GHC.Driver.Config.Finder import GHC.Driver.Monad import GHC.Driver.Session import GHC.Driver.Ppr @@ -136,7 +137,7 @@ beginMkDependHS logger tmpfs dflags = do -- open a new temp file in which to stuff the dependency info -- as we go along. - tmp_file <- newTempName logger tmpfs dflags TFL_CurrentModule "dep" + tmp_file <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "dep" tmp_hdl <- openFile tmp_file WriteMode -- open the makefile @@ -291,9 +292,10 @@ let home_unit = hsc_home_unit hsc_env let units = hsc_units hsc_env let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags -- Find the module; this will be fast because -- we've done it once during downsweep - r <- findImportedModule fc units home_unit dflags imp pkg + r <- findImportedModule fc fopts units home_unit imp pkg case r of Found loc _ -- Home package: just depend on the .hi or hi-boot file 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 @@ -1,2251 +1,969 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - ------------------------------------------------------------------------------ --- --- GHC Driver --- --- (c) The University of Glasgow 2005 --- ------------------------------------------------------------------------------ - -module GHC.Driver.Pipeline ( - -- Run a series of compilation steps in a pipeline, for a - -- collection of source files. - oneShot, compileFile, - - -- Interfaces for the compilation manager (interpreted/batch-mode) - preprocess, - compileOne, compileOne', - link, - - -- Exports for hooks to override runPhase and link - PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..), - phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv, - hscPostBackendPhase, getLocation, setModLocation, setDynFlags, - runPhase, - doCpp, - linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode - ) where - -#include "ghcplatform.h" -import GHC.Prelude - -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.Parser (initParserOpts) -import GHC.Driver.Config.Diagnostic -import GHC.Driver.Phases -import GHC.Driver.Session -import GHC.Driver.Backend -import GHC.Driver.Ppr -import GHC.Driver.Hooks - -import GHC.Platform.Ways -import GHC.Platform.ArchOS - -import GHC.Parser.Header - -import GHC.SysTools -import GHC.Utils.TmpFs - -import GHC.Linker.ExtraObj -import GHC.Linker.Dynamic -import GHC.Linker.Static -import GHC.Linker.Types - -import GHC.Utils.Outputable -import GHC.Utils.Error -import GHC.Utils.Fingerprint -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Misc -import GHC.Utils.Exception as Exception -import GHC.Utils.Logger - -import GHC.CmmToLlvm ( llvmFixupAsm, llvmVersionList ) -import qualified GHC.LanguageExtensions as LangExt -import GHC.Settings - -import GHC.Data.FastString ( mkFastString ) -import GHC.Data.StringBuffer ( hGetStringBuffer, hPutStringBuffer ) -import GHC.Data.Maybe ( expectJust ) - -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 -import GHC.Types.Target -import GHC.Types.SrcLoc -import GHC.Types.SourceFile -import GHC.Types.SourceError - -import GHC.Unit -import GHC.Unit.Env -import GHC.Unit.Finder -import GHC.Unit.Module.ModSummary -import GHC.Unit.Module.ModIface -import GHC.Unit.Module.Graph (needsTemplateHaskellOrQQ) -import GHC.Unit.Module.Deps -import GHC.Unit.Home.ModInfo - -import System.Directory -import System.FilePath -import System.IO -import Control.Monad -import qualified Control.Monad.Catch as MC (handle) -import Data.IORef -import Data.List ( isInfixOf, intercalate ) -import Data.Maybe -import Data.Version -import Data.Either ( partitionEithers ) - -import Data.Time ( getCurrentTime ) - --- --------------------------------------------------------------------------- --- Pre-process - --- | Just preprocess a file, put the result in a temp. file (used by the --- compilation manager during the summary phase). --- --- We return the augmented DynFlags, because they contain the result --- of slurping in the OPTIONS pragmas - -preprocess :: HscEnv - -> FilePath -- ^ input filename - -> Maybe InputFileBuffer - -- ^ optional buffer to use instead of reading the input file - -> Maybe Phase -- ^ starting phase - -> IO (Either DriverMessages (DynFlags, FilePath)) -preprocess hsc_env input_fn mb_input_buf mb_phase = - handleSourceError (\err -> return $ Left $ to_driver_messages $ srcErrorMessages err) $ - MC.handle handler $ - fmap Right $ do - massertPpr (isJust mb_phase || isHaskellSrcFilename input_fn) (text input_fn) - (dflags, fp, mb_iface, mb_linkable) <- runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase) - Nothing - -- We keep the processed file for the whole session to save on - -- duplicated work in ghci. - (Temporary TFL_GhcSession) - Nothing{-no ModLocation-} - []{-no foreign objects-} - -- We stop before Hsc phase so we shouldn't generate an interface - massert (isNothing mb_iface) - massert (isNothing mb_linkable) - return (dflags, fp) - where - srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1 - handler (ProgramError msg) = - return $ Left $ singleMessage $ - mkPlainErrorMsgEnvelope srcspan $ - DriverUnknownMessage $ mkPlainError noHints $ text msg - handler ex = throwGhcExceptionIO ex - - to_driver_messages :: Messages GhcMessage -> Messages DriverMessage - to_driver_messages msgs = case traverse to_driver_message msgs of - Nothing -> pprPanic "non-driver message in preprocess" - (vcat $ pprMsgEnvelopeBagWithLoc (getMessages msgs)) - Just msgs' -> msgs' - - to_driver_message = \case - GhcDriverMessage msg - -> Just msg - GhcPsMessage (PsHeaderMessage msg) - -> Just (DriverPsHeaderMessage (PsHeaderMessage msg)) - _ -> Nothing - --- --------------------------------------------------------------------------- - --- | Compile --- --- Compile a single module, under the control of the compilation manager. --- --- This is the interface between the compilation manager and the --- compiler proper (hsc), where we deal with tedious details like --- reading the OPTIONS pragma from the source file, converting the --- C or assembly that GHC produces into an object file, and compiling --- FFI stub files. --- --- NB. No old interface can also mean that the source has changed. - -compileOne :: HscEnv - -> ModSummary -- ^ summary for module being compiled - -> Int -- ^ module N ... - -> Int -- ^ ... of M - -> Maybe ModIface -- ^ old interface, if we have one - -> Maybe Linkable -- ^ old linkable, if we have one - -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful - -compileOne = compileOne' Nothing (Just batchMsg) - -compileOne' :: Maybe TcGblEnv - -> Maybe Messager - -> HscEnv - -> ModSummary -- ^ summary for module being compiled - -> Int -- ^ module N ... - -> Int -- ^ ... of M - -> Maybe ModIface -- ^ old interface, if we have one - -> Maybe Linkable -- ^ old linkable, if we have one - -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful - -compileOne' m_tc_result mHscMessage - hsc_env0 summary mod_index nmods mb_old_iface mb_old_linkable - = do - - debugTraceMsg logger 2 (text "compile: input file" <+> text input_fnpp) - - let flags = hsc_dflags hsc_env0 - in do unless (gopt Opt_KeepHiFiles flags) $ - addFilesToClean tmpfs TFL_CurrentModule $ - [ml_hi_file $ ms_location summary] - unless (gopt Opt_KeepOFiles flags) $ - addFilesToClean tmpfs TFL_GhcSession $ - [ml_obj_file $ ms_location summary] - - plugin_hsc_env <- initializePlugins hsc_env (Just (ms_mnwib summary)) - let runPostTc = compileOnePostTc plugin_hsc_env summary - - case m_tc_result of - Just tc_result - | not always_do_basic_recompilation_check -> do - runPostTc (FrontendTypecheck tc_result) emptyMessages Nothing - _ -> do - status <- hscRecompStatus mHscMessage plugin_hsc_env summary - mb_old_iface mb_old_linkable (mod_index, nmods) - - case status of - 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 old_linkable - HscRecompNeeded mb_old_hash -> do - (tc_result, warnings) <- hscTypecheckAndGetWarnings plugin_hsc_env summary - runPostTc tc_result warnings mb_old_hash - - 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 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 - - -- #8180 - when using TemplateHaskell, switch on -dynamic-too so - -- the linker can correctly load the object files. This isn't necessary - -- when using -fexternal-interpreter. - dflags1 = if hostIsDynamic && internalInterpreter && - not isDynWay && not isProfWay && needsLinker - 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 - -- turn on -fexternal-interpreter. - dflags2 = if not internalInterpreter && needsLinker - then gopt_set dflags1 Opt_ExternalInterpreter - else dflags1 - - basename = dropExtension input_fn - - -- We add the directory in which the .hs files resides) to the import - -- path. This is needed when we try to compile the .hc file later, if it - -- imports a _stub.h file that we created here. - current_dir = takeDirectory basename - old_paths = includePaths dflags2 - loadAsByteCode - | Just Target { targetAllowObjCode = obj } <- findTarget summary (hsc_targets hsc_env0) - , not obj - = True - | otherwise = False - -- Figure out which backend we're using - (bcknd, dflags3) - -- #8042: When module was loaded with `*` prefix in ghci, but DynFlags - -- suggest to generate object code (which may happen in case -fobject-code - -- was set), force it to generate byte-code. This is NOT transitive and - -- only applies to direct targets. - | loadAsByteCode - = (Interpreter, gopt_set (dflags2 { backend = Interpreter }) Opt_ForceRecomp) - | otherwise - = (backend dflags, dflags2) - dflags = dflags3 { includePaths = addImplicitQuoteInclude old_paths [current_dir] } - hsc_env = hscSetFlags dflags hsc_env0 - - always_do_basic_recompilation_check = case bcknd of - Interpreter -> True - _ -> False - --- | Do the post typechecking compilation of a module in the --make mode -compileOnePostTc - :: HscEnv - -> ModSummary - -> FrontendResult - -> WarningMessages - -> Maybe Fingerprint - -> IO HomeModInfo -compileOnePostTc hsc_env summary tc_result warnings mb_old_hash = do - output_fn <- getOutputFilename logger tmpfs next_phase - (Temporary TFL_CurrentModule) - basename dflags next_phase (Just location) - (_, _, Just iface, mb_linkable) <- runPipeline StopLn hsc_env - (output_fn, - Nothing, - Just (HscPostTc summary tc_result warnings mb_old_hash)) - (Just basename) - pipelineOutput - (Just location) - [] - -- TODO: figure out a way to set this in runPipeline for HsSrcFile - mLinkable <- case () of - _ | Just l <- mb_linkable -> return $ Just l - | bcknd == NoBackend -> return Nothing - | src_flavour == HsSrcFile -> do - -- The object filename comes from the ModLocation - o_time <- getModificationUTCTime object_filename - let !linkable = LM o_time this_mod [DotO object_filename] - return $ Just linkable - | otherwise -> return Nothing - -- See Note [ModDetails and --make mode] - details <- initModDetails hsc_env summary iface - return $! HomeModInfo iface details mLinkable - - where dflags = hsc_dflags hsc_env - this_mod = ms_mod summary - location = ms_location summary - input_fn = expectJust "compile:hs" (ml_hs_file location) - - logger = hsc_logger hsc_env - tmpfs = hsc_tmpfs hsc_env - src_flavour = ms_hsc_src summary - next_phase = hscPostBackendPhase src_flavour bcknd - bcknd = backend dflags - object_filename = ml_obj_file location - - basename = dropExtension input_fn - - pipelineOutput = case bcknd of - Interpreter -> NoOutputFile - NoBackend -> NoOutputFile - _ -> Persistent - ------------------------------------------------------------------------------ --- stub .h and .c files (for foreign export support), and cc files. - --- The _stub.c file is derived from the haskell source file, possibly taking --- into account the -stubdir option. --- --- The object file created by compiling the _stub.c file is put into a --- temporary file, which will be later combined with the main .o file --- (see the MergeForeigns phase). --- --- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files --- from TH, that are then compiled and linked to the module. This is --- useful to implement facilities such as inline-c. - -compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath -compileForeign _ RawObject object_file = return object_file -compileForeign hsc_env lang stub_c = do - let phase = case lang of - LangC -> Cc - LangCxx -> Ccxx - LangObjc -> Cobjc - LangObjcxx -> Cobjcxx - LangAsm -> As True -- allow CPP -#if __GLASGOW_HASKELL__ < 811 - RawObject -> panic "compileForeign: should be unreachable" -#endif - (_, stub_o, _, _) <- runPipeline StopLn hsc_env - (stub_c, Nothing, Just (RealPhase phase)) - Nothing (Temporary TFL_GhcSession) - Nothing{-no ModLocation-} - [] - return stub_o - -compileStub :: HscEnv -> FilePath -> IO FilePath -compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c - -compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO () -compileEmptyStub dflags hsc_env basename location mod_name = do - -- To maintain the invariant that every Haskell file - -- compiles to object code, we make an empty (but - -- valid) stub object file for signatures. However, - -- we make sure this object file has a unique symbol, - -- so that ranlib on OS X doesn't complain, see - -- https://gitlab.haskell.org/ghc/ghc/issues/12673 - -- and https://github.com/haskell/cabal/issues/2257 - let logger = hsc_logger hsc_env - let tmpfs = hsc_tmpfs hsc_env - empty_stub <- newTempName logger tmpfs dflags TFL_CurrentModule "c" - let home_unit = hsc_home_unit hsc_env - src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" - writeFile empty_stub (showSDoc dflags (pprCode CStyle src)) - _ <- runPipeline StopLn hsc_env - (empty_stub, Nothing, Nothing) - (Just basename) - Persistent - (Just location) - [] - return () - --- --------------------------------------------------------------------------- --- Link --- --- Note [Dynamic linking on macOS] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Since macOS Sierra (10.14), the dynamic system linker enforces --- a limit on the Load Commands. Specifically the Load Command Size --- Limit is at 32K (32768). The Load Commands contain the install --- name, dependencies, runpaths, and a few other commands. We however --- only have control over the install name, dependencies and runpaths. --- --- The install name is the name by which this library will be --- referenced. This is such that we do not need to bake in the full --- absolute location of the library, and can move the library around. --- --- The dependency commands contain the install names from of referenced --- libraries. Thus if a libraries install name is @rpath/libHS...dylib, --- that will end up as the dependency. --- --- Finally we have the runpaths, which informs the linker about the --- directories to search for the referenced dependencies. --- --- The system linker can do recursive linking, however using only the --- direct dependencies conflicts with ghc's ability to inline across --- packages, and as such would end up with unresolved symbols. --- --- Thus we will pass the full dependency closure to the linker, and then --- ask the linker to remove any unused dynamic libraries (-dead_strip_dylibs). --- --- We still need to add the relevant runpaths, for the dynamic linker to --- lookup the referenced libraries though. The linker (ld64) does not --- have any option to dead strip runpaths; which makes sense as runpaths --- can be used for dependencies of dependencies as well. --- --- The solution we then take in GHC is to not pass any runpaths to the --- linker at link time, but inject them after the linking. For this to --- work we'll need to ask the linker to create enough space in the header --- to add more runpaths after the linking (-headerpad 8000). --- --- After the library has been linked by $LD (usually ld64), we will use --- otool to inspect the libraries left over after dead stripping, compute --- the relevant runpaths, and inject them into the linked product using --- the install_name_tool command. --- --- This strategy should produce the smallest possible set of load commands --- while still retaining some form of relocatability via runpaths. --- --- The only way I can see to reduce the load command size further would be --- by shortening the library names, or start putting libraries into the same --- folders, such that one runpath would be sufficient for multiple/all --- libraries. -link :: GhcLink -- ^ interactive or batch - -> Logger -- ^ Logger - -> TmpFs - -> Hooks - -> DynFlags -- ^ dynamic flags - -> UnitEnv -- ^ unit environment - -> Bool -- ^ attempt linking in batch mode? - -> HomePackageTable -- ^ what to link - -> IO SuccessFlag - --- For the moment, in the batch linker, we don't bother to tell doLink --- which packages to link -- it just tries all that are available. --- batch_attempt_linking should only be *looked at* in batch mode. It --- should only be True if the upsweep was successful and someone --- exports main, i.e., we have good reason to believe that linking --- will succeed. - -link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking hpt = - case linkHook hooks of - Nothing -> case ghcLink of - NoLink -> return Succeeded - LinkBinary -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt - LinkStaticLib -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt - LinkDynLib -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt - LinkInMemory - | platformMisc_ghcWithInterpreter $ platformMisc dflags - -> -- Not Linking...(demand linker will do the job) - return Succeeded - | otherwise - -> panicBadLink LinkInMemory - Just h -> h ghcLink dflags batch_attempt_linking hpt - - -panicBadLink :: GhcLink -> a -panicBadLink other = panic ("link: GHC not built to link this way: " ++ - show other) - -link' :: Logger - -> TmpFs - -> DynFlags -- ^ dynamic flags - -> UnitEnv -- ^ unit environment - -> Bool -- ^ attempt linking in batch mode? - -> HomePackageTable -- ^ what to link - -> IO SuccessFlag - -link' logger tmpfs dflags unit_env batch_attempt_linking hpt - | batch_attempt_linking - = do - let - staticLink = case ghcLink dflags of - LinkStaticLib -> True - _ -> False - - home_mod_infos = eltsHpt hpt - - -- the packages we depend on - pkg_deps = concatMap (dep_direct_pkgs . mi_deps . hm_iface) home_mod_infos - - -- the linkables to link - linkables = map (expectJust "link".hm_linkable) home_mod_infos - - 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 3 (text "link(batch): linking omitted (-c flag given).") - return Succeeded - else do - - let getOfiles LM{ linkableUnlinked } = map nameOfObject (filter isObject linkableUnlinked) - obj_files = concatMap getOfiles linkables - platform = targetPlatform dflags - exe_file = exeFileName platform staticLink (outputFile dflags) - - linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps - - if not (gopt Opt_ForceRecomp dflags) && not linking_needed - then do debugTraceMsg logger 2 (text exe_file <+> text "is up to date, linking not required.") - return Succeeded - else do - - 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 - LinkBinary -> linkBinary logger tmpfs - LinkStaticLib -> linkStaticLib logger - LinkDynLib -> linkDynLibCheck logger tmpfs - other -> panicBadLink other - link dflags unit_env obj_files pkg_deps - - debugTraceMsg logger 3 (text "link: done") - - -- linkBinary only returns if it succeeds - return Succeeded - - | otherwise - = do debugTraceMsg logger 3 (text "link(batch): upsweep (partially) failed OR" $$ - text " Main.main not exported; not linking.") - return Succeeded - - -linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO Bool -linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do - -- if the modification time on the executable is later than the - -- modification times on all of the objects and libraries, then omit - -- linking (unless the -fforce-recomp flag was given). - let platform = ue_platform unit_env - unit_state = ue_units unit_env - exe_file = exeFileName platform staticLink (outputFile dflags) - e_exe_time <- tryIO $ getModificationUTCTime exe_file - case e_exe_time of - Left _ -> return True - Right t -> do - -- first check object files and extra_ld_inputs - let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] - e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs - let (errs,extra_times) = partitionEithers e_extra_times - let obj_times = map linkableTime linkables ++ extra_times - if not (null errs) || any (t <) obj_times - then return True - else do - - -- next, check libraries. XXX this only checks Haskell libraries, - -- not extra_libraries or -l things from the command line. - let pkg_hslibs = [ (collectLibraryDirs (ways dflags) [c], lib) - | Just c <- map (lookupUnitId unit_state) pkg_deps, - lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ] - - pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs - if any isNothing pkg_libfiles then return True else do - e_lib_times <- mapM (tryIO . getModificationUTCTime) - (catMaybes pkg_libfiles) - let (lib_errs,lib_times) = partitionEithers e_lib_times - if not (null lib_errs) || any (t <) lib_times - then return True - else checkLinkInfo logger dflags unit_env pkg_deps exe_file - -findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath) -findHSLib platform ws dirs lib = do - let batch_lib_file = if WayDyn `notElem` ws - then "lib" ++ lib <.> "a" - else platformSOName platform lib - found <- filterM doesFileExist (map ( batch_lib_file) dirs) - case found of - [] -> return Nothing - (x:_) -> return (Just x) - --- ----------------------------------------------------------------------------- --- Compile files in one-shot mode. - -oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO () -oneShot hsc_env stop_phase srcs = do - o_files <- mapM (compileFile hsc_env stop_phase) srcs - doLink hsc_env stop_phase o_files - -compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath -compileFile hsc_env stop_phase (src, mb_phase) = do - exists <- doesFileExist src - when (not exists) $ - throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src)) - - let - dflags = hsc_dflags hsc_env - mb_o_file = outputFile dflags - ghc_link = ghcLink dflags -- Set by -c or -no-link - - -- When linking, the -o argument refers to the linker's output. - -- otherwise, we use it as the name for the pipeline's output. - output - | NoBackend <- backend dflags = NoOutputFile - | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent - -- -o foo applies to linker - | isJust mb_o_file = SpecificFile - -- -o foo applies to the file we are compiling now - | otherwise = Persistent - - ( _, out_file, _, _) <- runPipeline stop_phase hsc_env - (src, Nothing, fmap RealPhase mb_phase) - Nothing - output - Nothing{-no ModLocation-} [] - return out_file - - -doLink :: HscEnv -> Phase -> [FilePath] -> IO () -doLink hsc_env stop_phase o_files - | not (isStopLn stop_phase) - = return () -- We stopped before the linking phase - - | otherwise - = let - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - unit_env = hsc_unit_env hsc_env - tmpfs = hsc_tmpfs hsc_env - in case ghcLink dflags of - NoLink -> return () - LinkBinary -> linkBinary logger tmpfs dflags unit_env o_files [] - LinkStaticLib -> linkStaticLib logger dflags unit_env o_files [] - LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env o_files [] - other -> panicBadLink other - - --- --------------------------------------------------------------------------- - --- | Run a compilation pipeline, consisting of multiple phases. --- --- This is the interface to the compilation pipeline, which runs --- a series of compilation steps on a single source file, specifying --- at which stage to stop. --- --- The DynFlags can be modified by phases in the pipeline (eg. by --- OPTIONS_GHC pragmas), and the changes affect later phases in the --- pipeline. -runPipeline - :: Phase -- ^ When to stop - -> HscEnv -- ^ Compilation environment - -> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus) - -- ^ Pipeline input file name, optional - -- buffer and maybe -x suffix - -> Maybe FilePath -- ^ original basename (if different from ^^^) - -> PipelineOutput -- ^ Output filename - -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module - -> [FilePath] -- ^ foreign objects - -> IO (DynFlags, FilePath, Maybe ModIface, Maybe Linkable) - -- ^ (final flags, output filename, interface, linkable) -runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) - mb_basename output maybe_loc foreign_os - - = do let - -- Decide where dump files should go based on the pipeline output - 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 . - basename | Just b <- mb_basename = b - | otherwise = input_basename - - -- If we were given a -x flag, then use that phase to start from - start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase - - isHaskell (RealPhase (Unlit _)) = True - isHaskell (RealPhase (Cpp _)) = True - isHaskell (RealPhase (HsPp _)) = True - isHaskell (RealPhase (Hsc _)) = True - isHaskell (HscPostTc {}) = True - isHaskell (HscBackend {}) = True - isHaskell _ = False - - isHaskellishFile = isHaskell start_phase - - env = PipeEnv{ stop_phase, - src_filename = input_fn, - src_basename = basename, - src_suffix = suffix', - output_spec = output } - - when (isBackpackishSuffix suffix') $ - throwGhcExceptionIO (UsageError - ("use --backpack to process " ++ input_fn)) - - -- We want to catch cases of "you can't get there from here" before - -- we start the pipeline, because otherwise it will just run off the - -- end. - let happensBefore' = happensBefore (targetPlatform dflags) - case start_phase of - RealPhase start_phase' -> - -- See Note [Partial ordering on phases] - -- Not the same as: (stop_phase `happensBefore` start_phase') - when (not (start_phase' `happensBefore'` stop_phase || - start_phase' `eqPhase` stop_phase)) $ - throwGhcExceptionIO (UsageError - ("cannot compile this file to desired target: " - ++ input_fn)) - HscPostTc {} -> return () - HscBackend {} -> return () - - -- Write input buffer to temp file if requested - input_fn' <- case (start_phase, mb_input_buf) of - (RealPhase real_start_phase, Just input_buf) -> do - let suffix = phaseInputExt real_start_phase - fn <- newTempName logger tmpfs dflags TFL_CurrentModule suffix - hdl <- openBinaryFile fn WriteMode - -- Add a LINE pragma so reported source locations will - -- mention the real input file, not this temp file. - hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}" - hPutStringBuffer hdl input_buf - hClose hdl - return fn - (_, _) -> return input_fn - - debugTraceMsg logger 4 (text "Running the pipeline") - r <- runPipeline' start_phase hsc_env env input_fn' - maybe_loc foreign_os - - when isHaskellishFile $ - dynamicTooState dflags >>= \case - DT_Dont -> return () - DT_Dyn -> return () - DT_OK -> return () - -- If we are compiling a Haskell module with -dynamic-too, we - -- first try the "fast path": that is we compile the non-dynamic - -- version and at the same time we check that interfaces depended - -- on exist both for the non-dynamic AND the dynamic way. We also - -- check that they have the same hash. - -- If they don't, dynamicTooState is set to DT_Failed. - -- See GHC.Iface.Load.checkBuildDynamicToo - -- If they do, in the end we produce both the non-dynamic and - -- dynamic outputs. - -- - -- If this "fast path" failed, we execute the whole pipeline - -- again, this time for the dynamic way *only*. To do that we - -- just set the dynamicNow bit from the start to ensure that the - -- dynamic DynFlags fields are used and we disable -dynamic-too - -- (its state is already set to DT_Failed so it wouldn't do much - -- anyway). - DT_Failed - -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987) - | OSMinGW32 <- platformOS (targetPlatform dflags) -> return () - | otherwise -> do - debugTraceMsg logger 4 - (text "Running the full pipeline again for -dynamic-too") - let dflags0 = flip gopt_unset Opt_BuildDynamicToo - $ setDynamicNow - $ dflags - hsc_env' <- newHscEnv dflags0 - (dbs,unit_state,home_unit,mconstants) <- initUnits logger dflags0 Nothing - dflags1 <- updatePlatformConstants dflags0 mconstants - unit_env0 <- initUnitEnv (ghcNameVersion dflags1) (targetPlatform dflags1) - let unit_env = unit_env0 - { ue_home_unit = Just home_unit - , ue_units = unit_state - , ue_unit_dbs = Just dbs - } - 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 () - return r - -runPipeline' - :: PhasePlus -- ^ When to start - -> HscEnv -- ^ Compilation environment - -> PipeEnv - -> FilePath -- ^ Input filename - -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module - -> [FilePath] -- ^ foreign objects, if we have one - -> IO (DynFlags, FilePath, Maybe ModIface, Maybe Linkable) - -- ^ (final flags, output filename, interface, linkable) -runPipeline' start_phase hsc_env env input_fn - maybe_loc foreign_os - = do - -- Execute the pipeline... - let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os, iface = Nothing - , maybe_linkable = Nothing } - (pipe_state, fp) <- evalP (pipeLoop start_phase input_fn) env state - return (pipeStateDynFlags pipe_state, fp, pipeStateModIface pipe_state - , pipeStateLinkable pipe_state ) - --- --------------------------------------------------------------------------- --- outer pipeline loop - --- | pipeLoop runs phases until we reach the stop phase -pipeLoop :: PhasePlus -> FilePath -> CompPipeline FilePath -pipeLoop phase input_fn = do - env <- getPipeEnv - dflags <- getDynFlags - logger <- getLogger - -- See Note [Partial ordering on phases] - let happensBefore' = happensBefore (targetPlatform dflags) - stopPhase = stop_phase env - case phase of - RealPhase realPhase | realPhase `eqPhase` stopPhase -- All done - -> -- Sometimes, a compilation phase doesn't actually generate any output - -- (eg. the CPP phase when -fcpp is not turned on). If we end on this - -- stage, but we wanted to keep the output, then we have to explicitly - -- copy the file, remembering to prepend a {-# LINE #-} pragma so that - -- further compilation stages can tell what the original filename was. - case output_spec env of - Temporary _ -> - return input_fn - NoOutputFile -> return input_fn - output -> - do pst <- getPipeState - tmpfs <- hsc_tmpfs <$> getPipeSession - final_fn <- liftIO $ getOutputFilename logger tmpfs - stopPhase output (src_basename env) - dflags stopPhase (maybe_loc pst) - 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 msg - liftIO $ copyWithHeader line_prag input_fn final_fn - return final_fn - - - | not (realPhase `happensBefore'` stopPhase) - -- Something has gone wrong. We'll try to cover all the cases when - -- this could happen, so if we reach here it is a panic. - -- eg. it might happen if the -C flag is used on a source file that - -- has {-# OPTIONS -fasm #-}. - -> panic ("pipeLoop: at phase " ++ show realPhase ++ - " but I wanted to stop at phase " ++ show stopPhase) - - _ - -> do liftIO $ debugTraceMsg logger 4 - (text "Running phase" <+> ppr phase) - - case phase of - HscBackend {} -> do - -- Depending on the dynamic-too state, we first run the - -- backend to generate the non-dynamic objects and then - -- re-run it to generate the dynamic ones. - let noDynToo = do - (next_phase, output_fn) <- runHookedPhase phase input_fn - pipeLoop next_phase output_fn - let dynToo = do - -- we must run the non-dynamic way before the dynamic - -- one because there may be interfaces loaded only in - -- the backend (e.g., in CorePrep). See #19264 - r <- noDynToo - - -- we must check the dynamic-too state again, because - -- we may have failed to load a dynamic interface in - -- the backend. - dynamicTooState dflags >>= \case - DT_OK -> do - let dflags' = setDynamicNow dflags -- set "dynamicNow" - setDynFlags dflags' - (next_phase, output_fn) <- runHookedPhase phase input_fn - _ <- pipeLoop next_phase output_fn - -- TODO: we probably shouldn't ignore the result of - -- the dynamic compilation - setDynFlags dflags -- restore flags without "dynamicNow" set - return r - _ -> return r - - dynamicTooState dflags >>= \case - DT_Dont -> noDynToo - DT_Failed -> noDynToo - DT_OK -> dynToo - DT_Dyn -> noDynToo - -- it shouldn't be possible to be in this last case - -- here. It would mean that we executed the whole - -- pipeline with DynamicNow and Opt_BuildDynamicToo set. - -- - -- When we restart the whole pipeline for -dynamic-too - -- we set DynamicNow but we unset Opt_BuildDynamicToo so - -- it's weird. - _ -> do - (next_phase, output_fn) <- runHookedPhase phase input_fn - pipeLoop next_phase output_fn - -runHookedPhase :: PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath) -runHookedPhase pp input = do - hooks <- hsc_hooks <$> getPipeSession - case runPhaseHook hooks of - Nothing -> runPhase pp input - Just h -> h pp input - --- ----------------------------------------------------------------------------- --- In each phase, we need to know into what filename to generate the --- output. All the logic about which filenames we generate output --- into is embodied in the following function. - --- | Computes the next output filename after we run @next_phase@. --- Like 'getOutputFilename', but it operates in the 'CompPipeline' monad --- (which specifies all of the ambient information.) -phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath -phaseOutputFilename next_phase = do - PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv - PipeState{maybe_loc,hsc_env} <- getPipeState - dflags <- getDynFlags - logger <- getLogger - let tmpfs = hsc_tmpfs hsc_env - liftIO $ getOutputFilename logger tmpfs stop_phase output_spec - src_basename dflags next_phase maybe_loc - --- | Computes the next output filename for something in the compilation --- pipeline. This is controlled by several variables: --- --- 1. 'Phase': the last phase to be run (e.g. 'stopPhase'). This --- is used to tell if we're in the last phase or not, because --- in that case flags like @-o@ may be important. --- 2. 'PipelineOutput': is this intended to be a 'Temporary' or --- 'Persistent' build output? Temporary files just go in --- a fresh temporary name. --- 3. 'String': what was the basename of the original input file? --- 4. 'DynFlags': the obvious thing --- 5. 'Phase': the phase we want to determine the output filename of. --- 6. @Maybe ModLocation@: the 'ModLocation' of the module we're --- compiling; this can be used to override the default output --- of an object file. (TODO: do we actually need this?) -getOutputFilename - :: Logger - -> TmpFs - -> Phase - -> PipelineOutput - -> String - -> DynFlags - -> Phase -- next phase - -> Maybe ModLocation - -> IO FilePath -getOutputFilename logger tmpfs stop_phase output basename dflags next_phase maybe_location - | is_last_phase, Persistent <- output = persistent_fn - | is_last_phase, SpecificFile <- output = case outputFile dflags of - Just f -> return f - Nothing -> - panic "SpecificFile: No filename" - | keep_this_output = persistent_fn - | Temporary lifetime <- output = newTempName logger tmpfs dflags lifetime suffix - | otherwise = newTempName logger tmpfs dflags TFL_CurrentModule - suffix - where - hcsuf = hcSuf dflags - odir = objectDir dflags - osuf = objectSuf dflags - keep_hc = gopt Opt_KeepHcFiles dflags - keep_hscpp = gopt Opt_KeepHscppFiles dflags - keep_s = gopt Opt_KeepSFiles dflags - keep_bc = gopt Opt_KeepLlvmFiles dflags - - myPhaseInputExt HCc = hcsuf - myPhaseInputExt MergeForeign = osuf - myPhaseInputExt StopLn = osuf - myPhaseInputExt other = phaseInputExt other - - is_last_phase = next_phase `eqPhase` stop_phase - - -- sometimes, we keep output from intermediate stages - keep_this_output = - case next_phase of - As _ | keep_s -> True - LlvmOpt | keep_bc -> True - HCc | keep_hc -> True - HsPp _ | keep_hscpp -> True -- See #10869 - _other -> False - - suffix = myPhaseInputExt next_phase - - -- persistent object files get put in odir - persistent_fn - | StopLn <- next_phase = return odir_persistent - | otherwise = return persistent - - persistent = basename <.> suffix - - odir_persistent - | Just loc <- maybe_location = ml_obj_file loc - | Just d <- odir = d persistent - | otherwise = persistent - - --- | LLVM Options. These are flags to be passed to opt and llc, to ensure --- consistency we list them in pairs, so that they form groups. -llvmOptions :: DynFlags - -> [(String, String)] -- ^ pairs of (opt, llc) arguments -llvmOptions dflags = - [("-enable-tbaa -tbaa", "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ] - ++ [("-relocation-model=" ++ rmodel - ,"-relocation-model=" ++ rmodel) | not (null rmodel)] - ++ [("-stack-alignment=" ++ (show align) - ,"-stack-alignment=" ++ (show align)) | align > 0 ] - - -- Additional llc flags - ++ [("", "-mcpu=" ++ mcpu) | not (null mcpu) - , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ] - ++ [("", "-mattr=" ++ attrs) | not (null attrs) ] - ++ [("", "-target-abi=" ++ abi) | not (null abi) ] - - where target = platformMisc_llvmTarget $ platformMisc dflags - Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets $ llvmConfig dflags) - - -- Relocation models - rmodel | gopt Opt_PIC dflags = "pic" - | positionIndependent dflags = "pic" - | WayDyn `elem` ways dflags = "dynamic-no-pic" - | otherwise = "static" - - platform = targetPlatform dflags - - align :: Int - align = case platformArch platform of - ArchX86_64 | isAvxEnabled dflags -> 32 - _ -> 0 - - attrs :: String - attrs = intercalate "," $ mattr - ++ ["+sse42" | isSse4_2Enabled dflags ] - ++ ["+sse2" | isSse2Enabled platform ] - ++ ["+sse" | isSseEnabled platform ] - ++ ["+avx512f" | isAvx512fEnabled dflags ] - ++ ["+avx2" | isAvx2Enabled dflags ] - ++ ["+avx" | isAvxEnabled dflags ] - ++ ["+avx512cd"| isAvx512cdEnabled dflags ] - ++ ["+avx512er"| isAvx512erEnabled dflags ] - ++ ["+avx512pf"| isAvx512pfEnabled dflags ] - ++ ["+bmi" | isBmiEnabled dflags ] - ++ ["+bmi2" | isBmi2Enabled dflags ] - - abi :: String - abi = case platformArch (targetPlatform dflags) of - ArchRISCV64 -> "lp64d" - _ -> "" - --- ----------------------------------------------------------------------------- --- | Each phase in the pipeline returns the next phase to execute, and the --- name of the file in which the output was placed. --- --- We must do things dynamically this way, because we often don't know --- what the rest of the phases will be until part-way through the --- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning --- of a source file can change the latter stages of the pipeline from --- taking the LLVM route to using the native code generator. --- -runPhase :: PhasePlus -- ^ Run this phase - -> FilePath -- ^ name of the input file - -> CompPipeline (PhasePlus, -- next phase to run - FilePath) -- output filename - - -- Invariant: the output filename always contains the output - -- Interesting case: Hsc when there is no recompilation to do - -- Then the output filename is still a .o file - - -------------------------------------------------------------------------------- --- Unlit phase - -runPhase (RealPhase (Unlit sf)) input_fn = do - let - -- escape the characters \, ", and ', but don't try to escape - -- Unicode or anything else (so we don't use Util.charToC - -- here). If we get this wrong, then in - -- GHC.HsToCore.Coverage.isGoodTickSrcSpan where we check that the filename in - -- a SrcLoc is the same as the source filenaame, the two will - -- look bogusly different. See test: - -- libraries/hpc/tests/function/subdir/tough2.hs - escape ('\\':cs) = '\\':'\\': escape cs - escape ('\"':cs) = '\\':'\"': escape cs - escape ('\'':cs) = '\\':'\'': escape cs - escape (c:cs) = c : escape cs - escape [] = [] - - output_fn <- phaseOutputFilename (Cpp sf) - - let flags = [ -- The -h option passes the file name for unlit to - -- put in a #line directive - GHC.SysTools.Option "-h" - -- See Note [Don't normalise input filenames]. - , GHC.SysTools.Option $ escape input_fn - , GHC.SysTools.FileOption "" input_fn - , GHC.SysTools.FileOption "" output_fn - ] - - dflags <- getDynFlags - logger <- getLogger - liftIO $ GHC.SysTools.runUnlit logger dflags flags - - return (RealPhase (Cpp sf), output_fn) - -------------------------------------------------------------------------------- --- Cpp phase : (a) gets OPTIONS out of file --- (b) runs cpp if necessary - -runPhase (RealPhase (Cpp sf)) input_fn - = do - dflags0 <- getDynFlags - 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) $ 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. - return (RealPhase (HsPp sf), input_fn) - else do - output_fn <- phaseOutputFilename (HsPp sf) - hsc_env <- getPipeSession - logger <- getLogger - liftIO $ doCpp logger - (hsc_tmpfs hsc_env) - (hsc_dflags hsc_env) - (hsc_unit_env hsc_env) - True{-raw-} - input_fn output_fn - -- re-read the pragmas now that we've preprocessed the file - -- See #2464,#3457 - 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) $ do - logger <- getLogger - liftIO $ handleFlagWarnings logger (initDiagOpts dflags2) warns - -- the HsPp pass below will emit warnings - - return (RealPhase (HsPp sf), output_fn) - -------------------------------------------------------------------------------- --- HsPp phase - -runPhase (RealPhase (HsPp sf)) input_fn = do - dflags <- getDynFlags - logger <- getLogger - if not (gopt Opt_Pp dflags) then - -- no need to preprocess, just pass input file along - -- to the next phase of the pipeline. - return (RealPhase (Hsc sf), input_fn) - else do - PipeEnv{src_basename, src_suffix} <- getPipeEnv - let orig_fn = src_basename <.> src_suffix - output_fn <- phaseOutputFilename (Hsc sf) - liftIO $ GHC.SysTools.runPp logger dflags - ( [ GHC.SysTools.Option orig_fn - , GHC.SysTools.Option input_fn - , GHC.SysTools.FileOption "" output_fn - ] - ) - - -- re-read pragmas now that we've parsed the file (see #3674) - 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 (initDiagOpts dflags1) warns - - return (RealPhase (Hsc sf), output_fn) - ------------------------------------------------------------------------------ --- Hsc phase - --- Compilation of a single module, in "legacy" mode (_not_ under --- the direction of the compilation manager). -runPhase (RealPhase (Hsc src_flavour)) input_fn - = do -- normal Hsc mode, not mkdependHS - dflags0 <- getDynFlags - PipeEnv{ src_basename=basename, - src_suffix=suff } <- getPipeEnv - - -- we add the current directory (i.e. the directory in which - -- the .hs files resides) to the include path, since this is - -- what gcc does, and it's probably what you want. - let current_dir = takeDirectory basename - new_includes = addImplicitQuoteInclude paths [current_dir] - paths = includePaths dflags0 - dflags = dflags0 { includePaths = new_includes } - - setDynFlags dflags - - -- gather the imports and module name - (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do - buf <- hGetStringBuffer input_fn - let imp_prelude = xopt LangExt.ImplicitPrelude dflags - popts = initParserOpts dflags - eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff) - case eimps of - Left errs -> throwErrors (GhcPsMessage <$> errs) - Right (src_imps,imps,L _ mod_name) -> return - (Just buf, mod_name, imps, src_imps) - - -- Take -o into account if present - -- Very like -ohi, but we must *only* do this if we aren't linking - -- (If we're linking then the -o applies to the linked thing, not to - -- the object file for one module.) - -- Note the nasty duplication with the same computation in compileFile above - location <- getLocation src_flavour mod_name - let o_file = ml_obj_file location -- The real object file - hi_file = ml_hi_file location - hie_file = ml_hie_file location - dyn_o_file = dynamicOutputFile dflags o_file - - 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 - - -- Tell the finder cache about this module - mod <- liftIO $ do - let home_unit = hsc_home_unit hsc_env' - let fc = hsc_FC hsc_env' - addHomeModuleToFinder fc home_unit mod_name location - - -- Make the ModSummary to hand to hscMain - let - mod_summary = ModSummary { ms_mod = mod, - ms_hsc_src = src_flavour, - ms_hspp_file = input_fn, - ms_hspp_opts = dflags, - ms_hspp_buf = hspp_buf, - ms_location = location, - ms_hs_hash = src_hash, - ms_obj_date = o_mod, - ms_dyn_obj_date = dyn_o_mod, - ms_parsed_mod = 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_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. - -- See also Note [hsc_type_env_var hack] - type_env_var <- liftIO $ newIORef emptyNameEnv - 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 - Nothing Nothing (1, 1) - - logger <- getLogger - case status of - 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) - -- but we touch it anyway, to keep 'make' happy (we think). - setIface iface - return (RealPhase StopLn, o_file) - HscRecompNeeded mb_old_hash -> do - (tc_result, warnings) <- liftIO $ - hscTypecheckAndGetWarnings plugin_hsc_env mod_summary - - -- In the rest of the pipeline use the loaded plugins - setPlugins (hsc_plugins plugin_hsc_env) - (hsc_static_plugins plugin_hsc_env) - -- "driver" plugins may have modified the DynFlags so we update them - setDynFlags (hsc_dflags plugin_hsc_env) - - return (HscPostTc mod_summary tc_result warnings mb_old_hash, - panic "HscPostTc doesn't have an input filename") - -runPhase (HscPostTc mod_summary tc_result tc_warnings mb_old_hash) _ = do - PipeState{hsc_env=hsc_env'} <- getPipeState - hscBackendAction <- liftIO $ runHsc hsc_env' $ do - hscDesugarAndSimplify mod_summary tc_result tc_warnings mb_old_hash - - dflags <- getDynFlags - let hscBackendPhase = HscBackend mod_summary hscBackendAction - next_phase <- case hscBackendAction of - HscUpdate iface -> do - setIface iface - case backend dflags of - NoBackend -> return $ RealPhase StopLn - Interpreter -> return $ RealPhase StopLn - _ -> return hscBackendPhase -- Need to create .o, and handle -dynamic-too - _ -> return hscBackendPhase - - return (next_phase, - panic "HscBackend doesn't have an input filename") - -runPhase (HscBackend mod_summary result) _ = do - let mod_name = moduleName (ms_mod mod_summary) - src_flavour = (ms_hsc_src mod_summary) - - dflags <- getDynFlags - logger <- getLogger - location <- getLocation src_flavour mod_name - setModLocation location - - let o_file = ml_obj_file location -- The real object file - next_phase = hscPostBackendPhase src_flavour (backend dflags) - - case result of - HscUpdate iface -> - do - case src_flavour of - HsigFile -> do - -- We need to create a REAL but empty .o file - -- because we are going to attempt to put it in a library - PipeState{hsc_env=hsc_env'} <- getPipeState - let input_fn = expectJust "runPhase" (ml_hs_file location) - basename = dropExtension input_fn - liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name - - -- In the case of hs-boot files, generate a dummy .o-boot - -- stamp file for the benefit of Make - HsBootFile -> liftIO $ touchObjectFile logger dflags o_file - HsSrcFile -> panic "HscUpdate not relevant for HscSrcFile" - - setIface iface - return (RealPhase StopLn, o_file) - HscRecomp { hscs_guts = cgguts, - hscs_mod_location = mod_location, - hscs_partial_iface = partial_iface, - hscs_old_iface_hash = mb_old_iface_hash - } - -> case backend dflags of - NoBackend -> panic "HscRecomp not relevant for NoBackend" - Interpreter -> do - PipeState{hsc_env=hsc_env'} <- getPipeState - -- In interpreted mode the regular codeGen backend is not run so we - -- generate a interface without codeGen info. - final_iface <- liftIO $ mkFullIface hsc_env' partial_iface Nothing - liftIO $ hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location - - (hasStub, comp_bc, spt_entries) <- liftIO $ hscInteractive hsc_env' cgguts mod_location - - stub_o <- liftIO $ case hasStub of - Nothing -> return [] - Just stub_c -> do - stub_o <- compileStub hsc_env' stub_c - return [DotO stub_o] - - let hs_unlinked = [BCOs comp_bc spt_entries] - 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 - -- with the filesystem's clock. It's just as accurate: - -- if the source is modified, then the linkable will - -- be out of date. - let !linkable = LM unlinked_time (ms_mod mod_summary) - (hs_unlinked ++ stub_o) - setIface final_iface - setLinkable linkable - return (RealPhase StopLn, - panic "Interpreter backend doesn't have an output file") - _ -> do - output_fn <- phaseOutputFilename next_phase - - PipeState{hsc_env=hsc_env'} <- getPipeState - - (outputFilename, mStub, foreign_files, cg_infos) <- liftIO $ - hscGenHardCode hsc_env' cgguts mod_location output_fn - - let dflags = hsc_dflags hsc_env' - final_iface <- liftIO (mkFullIface hsc_env' partial_iface (Just cg_infos)) - setIface final_iface - - -- See Note [Writing interface files] - liftIO $ hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location - - stub_o <- liftIO (mapM (compileStub hsc_env') mStub) - foreign_os <- liftIO $ - mapM (uncurry (compileForeign hsc_env')) foreign_files - setForeignOs (maybe [] return stub_o ++ foreign_os) - - return (RealPhase next_phase, outputFilename) - ------------------------------------------------------------------------------ --- Cmm phase - -runPhase (RealPhase CmmCpp) input_fn = do - hsc_env <- getPipeSession - logger <- getLogger - output_fn <- phaseOutputFilename Cmm - liftIO $ doCpp logger - (hsc_tmpfs hsc_env) - (hsc_dflags hsc_env) - (hsc_unit_env hsc_env) - False{-not raw-} - input_fn output_fn - return (RealPhase Cmm, output_fn) - -runPhase (RealPhase Cmm) input_fn = do - hsc_env <- getPipeSession - let dflags = hsc_dflags hsc_env - let next_phase = hscPostBackendPhase HsSrcFile (backend dflags) - output_fn <- phaseOutputFilename next_phase - PipeState{hsc_env} <- getPipeState - mstub <- liftIO $ hscCompileCmmFile hsc_env input_fn output_fn - stub_o <- liftIO (mapM (compileStub hsc_env) mstub) - setForeignOs (maybeToList stub_o) - return (RealPhase next_phase, output_fn) - ------------------------------------------------------------------------------ --- Cc phase - -runPhase (RealPhase cc_phase) input_fn - | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx] - = do - hsc_env <- getPipeSession - let dflags = hsc_dflags hsc_env - let unit_env = hsc_unit_env hsc_env - let home_unit = hsc_home_unit hsc_env - let tmpfs = hsc_tmpfs hsc_env - let platform = ue_platform unit_env - let hcc = cc_phase `eqPhase` HCc - - let cmdline_include_paths = includePaths dflags - - -- HC files have the dependent packages stamped into them - pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return [] - - -- add package include paths even if we're just compiling .c - -- files; this is the Value Add(TM) that using ghc instead of - -- gcc gives you :) - ps <- liftIO $ mayThrowUnitErr (preloadUnitsInfo' unit_env pkgs) - let pkg_include_dirs = collectIncludeDirs ps - let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] - (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) - let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] - (includePathsQuote cmdline_include_paths ++ - includePathsQuoteImplicit cmdline_include_paths) - let include_paths = include_paths_quote ++ include_paths_global - - -- pass -D or -optP to preprocessor when compiling foreign C files - -- (#16737). Doing it in this way is simpler and also enable the C - -- compiler to perform preprocessing and parsing in a single pass, - -- but it may introduce inconsistency if a different pgm_P is specified. - let more_preprocessor_opts = concat - [ ["-Xpreprocessor", i] - | not hcc - , i <- getOpts dflags opt_P - ] - - let gcc_extra_viac_flags = extraGccViaCFlags dflags - let pic_c_flags = picCCOpts dflags - - let verbFlags = getVerbFlags dflags - - -- cc-options are not passed when compiling .hc files. Our - -- hc code doesn't not #include any header files anyway, so these - -- options aren't necessary. - let pkg_extra_cc_opts - | hcc = [] - | otherwise = collectExtraCcOpts ps - - let framework_paths - | platformUsesFrameworks platform - = let pkgFrameworkPaths = collectFrameworksDirs ps - cmdlineFrameworkPaths = frameworkPaths dflags - in map ("-F"++) (cmdlineFrameworkPaths ++ pkgFrameworkPaths) - | otherwise - = [] - - let cc_opt | optLevel dflags >= 2 = [ "-O2" ] - | optLevel dflags >= 1 = [ "-O" ] - | otherwise = [] - - -- Decide next phase - let next_phase = As False - output_fn <- phaseOutputFilename next_phase - - let - more_hcc_opts = - -- on x86 the floating point regs have greater precision - -- than a double, which leads to unpredictable results. - -- By default, we turn this off with -ffloat-store unless - -- the user specified -fexcess-precision. - (if platformArch platform == ArchX86 && - not (gopt Opt_ExcessPrecision dflags) - then [ "-ffloat-store" ] - else []) ++ - - -- gcc's -fstrict-aliasing allows two accesses to memory - -- to be considered non-aliasing if they have different types. - -- This interacts badly with the C code we generate, which is - -- very weakly typed, being derived from C--. - ["-fno-strict-aliasing"] - - ghcVersionH <- liftIO $ getGhcVersionPathName dflags unit_env - - logger <- getLogger - liftIO $ GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags ( - [ GHC.SysTools.FileOption "" input_fn - , GHC.SysTools.Option "-o" - , GHC.SysTools.FileOption "" output_fn - ] - ++ map GHC.SysTools.Option ( - pic_c_flags - - -- Stub files generated for foreign exports references the runIO_closure - -- and runNonIO_closure symbols, which are defined in the base package. - -- These symbols are imported into the stub.c file via RtsAPI.h, and the - -- way we do the import depends on whether we're currently compiling - -- the base package or not. - ++ (if platformOS platform == OSMinGW32 && - isHomeUnitId home_unit baseUnitId - then [ "-DCOMPILING_BASE_PACKAGE" ] - else []) - - -- We only support SparcV9 and better because V8 lacks an atomic CAS - -- instruction. Note that the user can still override this - -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag - -- regardless of the ordering. - -- - -- This is a temporary hack. See #2872, commit - -- 5bd3072ac30216a505151601884ac88bf404c9f2 - ++ (if platformArch platform == ArchSPARC - then ["-mcpu=v9"] - else []) - - -- GCC 4.6+ doesn't like -Wimplicit when compiling C++. - ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx) - then ["-Wimplicit"] - else []) - - ++ (if hcc - then gcc_extra_viac_flags ++ more_hcc_opts - else []) - ++ verbFlags - ++ [ "-S" ] - ++ cc_opt - ++ [ "-include", ghcVersionH ] - ++ framework_paths - ++ include_paths - ++ more_preprocessor_opts - ++ pkg_extra_cc_opts - )) - - return (RealPhase next_phase, output_fn) - ------------------------------------------------------------------------------ --- As, SpitAs phase : Assembler - --- This is for calling the assembler on a regular assembly file -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 - - -- LLVM from version 3.0 onwards doesn't support the OS X system - -- assembler, so we use clang as the assembler instead. (#5636) - let (as_prog, get_asm_info) | backend dflags == LLVM - , platformOS platform == OSDarwin - = (GHC.SysTools.runClang, pure Clang) - | otherwise - = (GHC.SysTools.runAs, liftIO $ getAssemblerInfo logger dflags) - - asmInfo <- get_asm_info - - let cmdline_include_paths = includePaths dflags - let pic_c_flags = picCCOpts dflags - - next_phase <- maybeMergeForeign - output_fn <- phaseOutputFilename next_phase - - -- we create directories for the object file, because it - -- might be a hierarchical module. - liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) - - let global_includes = [ GHC.SysTools.Option ("-I" ++ p) - | p <- includePathsGlobal cmdline_include_paths ] - let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p) - | p <- includePathsQuote cmdline_include_paths ++ - includePathsQuoteImplicit cmdline_include_paths] - let runAssembler inputFilename outputFilename - = liftIO $ - withAtomicRename outputFilename $ \temp_outputFilename -> - as_prog - logger dflags - (local_includes ++ global_includes - -- See Note [-fPIC for assembler] - ++ map GHC.SysTools.Option pic_c_flags - -- See Note [Produce big objects on Windows] - ++ [ GHC.SysTools.Option "-Wa,-mbig-obj" - | platformOS (targetPlatform dflags) == OSMinGW32 - , not $ target32Bit (targetPlatform dflags) - ] - - -- We only support SparcV9 and better because V8 lacks an atomic CAS - -- instruction so we have to make sure that the assembler accepts the - -- instruction set. Note that the user can still override this - -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag - -- regardless of the ordering. - -- - -- This is a temporary hack. - ++ (if platformArch (targetPlatform dflags) == ArchSPARC - then [GHC.SysTools.Option "-mcpu=v9"] - else []) - ++ (if any (asmInfo ==) [Clang, AppleClang, AppleClang51] - then [GHC.SysTools.Option "-Qunused-arguments"] - else []) - ++ [ GHC.SysTools.Option "-x" - , if with_cpp - then GHC.SysTools.Option "assembler-with-cpp" - else GHC.SysTools.Option "assembler" - , GHC.SysTools.Option "-c" - , GHC.SysTools.FileOption "" inputFilename - , GHC.SysTools.Option "-o" - , GHC.SysTools.FileOption "" temp_outputFilename - ]) - - liftIO $ debugTraceMsg logger 4 (text "Running the assembler") - runAssembler input_fn output_fn - - return (RealPhase next_phase, output_fn) - - ------------------------------------------------------------------------------ --- LlvmOpt phase -runPhase (RealPhase LlvmOpt) input_fn = do - dflags <- getDynFlags - logger <- getLogger - let -- we always (unless -optlo specified) run Opt since we rely on it to - -- fix up some pretty big deficiencies in the code we generate - optIdx = max 0 $ min 2 $ optLevel dflags -- ensure we're in [0,2] - llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig dflags of - Just passes -> passes - Nothing -> panic ("runPhase LlvmOpt: llvm-passes file " - ++ "is missing passes for level " - ++ show optIdx) - defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst - $ unzip (llvmOptions dflags) - - -- don't specify anything if user has specified commands. We do this - -- for opt but not llc since opt is very specifically for optimisation - -- passes only, so if the user is passing us extra options we assume - -- they know what they are doing and don't get in the way. - optFlag = if null (getOpts dflags opt_lo) - then map GHC.SysTools.Option $ words llvmOpts - else [] - - output_fn <- phaseOutputFilename LlvmLlc - - liftIO $ GHC.SysTools.runLlvmOpt logger dflags - ( optFlag - ++ defaultOptions ++ - [ GHC.SysTools.FileOption "" input_fn - , GHC.SysTools.Option "-o" - , GHC.SysTools.FileOption "" output_fn] - ) - - return (RealPhase LlvmLlc, output_fn) - - ------------------------------------------------------------------------------ --- LlvmLlc phase - -runPhase (RealPhase LlvmLlc) input_fn = do - -- Note [Clamping of llc optimizations] - -- - -- See #13724 - -- - -- we clamp the llc optimization between [1,2]. This is because passing -O0 - -- to llc 3.9 or llc 4.0, the naive register allocator can fail with - -- - -- Error while trying to spill R1 from class GPR: Cannot scavenge register - -- without an emergency spill slot! - -- - -- Observed at least with target 'arm-unknown-linux-gnueabihf'. - -- - -- - -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile - -- rts/HeapStackCheck.cmm - -- - -- llc -O3 '-mtriple=arm-unknown-linux-gnueabihf' -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s - -- 0 llc 0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40 - -- 1 llc 0x0000000102ae69a6 SignalHandler(int) + 358 - -- 2 libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26 - -- 3 libsystem_c.dylib 0x00007fffc226498b __vfprintf + 17876 - -- 4 llc 0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699 - -- 5 llc 0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381 - -- 6 llc 0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457 - -- 7 llc 0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20 - -- 8 llc 0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134 - -- 9 llc 0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498 - -- 10 llc 0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67 - -- 11 llc 0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920 - -- 12 llc 0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133 - -- 13 llc 0x000000010195bf0b main + 491 - -- 14 libdyld.dylib 0x00007fffc21e5235 start + 1 - -- Stack dump: - -- 0. Program arguments: llc -O3 -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s - -- 1. Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'. - -- 2. Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"' - -- - -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa - -- - dflags <- getDynFlags - logger <- getLogger - let - llvmOpts = case optLevel dflags of - 0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient. - 1 -> "-O1" - _ -> "-O2" - - defaultOptions = map GHC.SysTools.Option . concatMap words . snd - $ unzip (llvmOptions dflags) - optFlag = if null (getOpts dflags opt_lc) - then map GHC.SysTools.Option $ words llvmOpts - else [] - - next_phase <- if -- hidden debugging flag '-dno-llvm-mangler' to skip mangling - | gopt Opt_NoLlvmMangler dflags -> return (As False) - | otherwise -> return LlvmMangle - - output_fn <- phaseOutputFilename next_phase - - liftIO $ GHC.SysTools.runLlvmLlc logger dflags - ( optFlag - ++ defaultOptions - ++ [ GHC.SysTools.FileOption "" input_fn - , GHC.SysTools.Option "-o" - , GHC.SysTools.FileOption "" output_fn - ] - ) - - return (RealPhase next_phase, output_fn) - - - ------------------------------------------------------------------------------ --- LlvmMangle phase - -runPhase (RealPhase LlvmMangle) input_fn = do - let next_phase = As False - output_fn <- phaseOutputFilename next_phase - platform <- (ue_platform . hsc_unit_env) <$> getPipeSession - logger <- getLogger - liftIO $ withTiming logger (text "LLVM Mangler") id $ - llvmFixupAsm platform input_fn output_fn - return (RealPhase next_phase, output_fn) - ------------------------------------------------------------------------------ --- merge in stub objects - -runPhase (RealPhase MergeForeign) input_fn = do - PipeState{foreign_os,hsc_env} <- getPipeState - output_fn <- phaseOutputFilename StopLn - liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) - if null foreign_os - then panic "runPhase(MergeForeign): no foreign objects" - else do - dflags <- getDynFlags - logger <- getLogger - let tmpfs = hsc_tmpfs hsc_env - liftIO $ joinObjectFiles logger tmpfs dflags (input_fn : foreign_os) output_fn - return (RealPhase StopLn, output_fn) - --- warning suppression -runPhase (RealPhase other) _input_fn = - panic ("runPhase: don't know how to run phase " ++ show other) - -maybeMergeForeign :: CompPipeline Phase -maybeMergeForeign - = do - PipeState{foreign_os} <- getPipeState - if null foreign_os then return StopLn else return MergeForeign - -getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation -getLocation src_flavour mod_name = do - dflags <- getDynFlags - - PipeEnv{ src_basename=basename, - src_suffix=suff } <- getPipeEnv - location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff - - -- Boot-ify it if necessary - let location2 - | HsBootFile <- src_flavour = addBootSuffixLocnOut location1 - | otherwise = location1 - - - -- Take -ohi into account if present - -- This can't be done in mkHomeModuleLocation because - -- it only applies to the module being compiles - let ohi = outputHi dflags - location3 | Just fn <- ohi = location2{ ml_hi_file = fn } - | otherwise = location2 - - -- Take -o into account if present - -- Very like -ohi, but we must *only* do this if we aren't linking - -- (If we're linking then the -o applies to the linked thing, not to - -- the object file for one module.) - -- Note the nasty duplication with the same computation in compileFile - -- above - let expl_o_file = outputFile dflags - location4 | Just ofile <- expl_o_file - , isNoLink (ghcLink dflags) - = location3 { ml_obj_file = ofile } - | otherwise = location3 - return location4 - ------------------------------------------------------------------------------ --- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file - -getHCFilePackages :: FilePath -> IO [UnitId] -getHCFilePackages filename = - Exception.bracket (openFile filename ReadMode) hClose $ \h -> do - l <- hGetLine h - case l of - '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest -> - return (map stringToUnitId (words rest)) - _other -> - return [] - - -linkDynLibCheck :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () -linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do - when (haveRtsOptsFlags dflags) $ - 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.") - linkDynLib logger tmpfs dflags unit_env o_files dep_units - - --- ----------------------------------------------------------------------------- --- Running CPP - --- | Run CPP --- --- 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 - let cmdline_include_paths = includePaths dflags - let unit_state = ue_units unit_env - pkg_include_dirs <- mayThrowUnitErr - (collectIncludeDirs <$> preloadUnitsInfo unit_env) - let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] - (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) - let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] - (includePathsQuote cmdline_include_paths ++ - includePathsQuoteImplicit cmdline_include_paths) - let include_paths = include_paths_quote ++ include_paths_global - - let verbFlags = getVerbFlags dflags - - let cpp_prog args | raw = GHC.SysTools.runCpp logger dflags args - | otherwise = GHC.SysTools.runCc Nothing logger tmpfs dflags - (GHC.SysTools.Option "-E" : args) - - let platform = targetPlatform dflags - targetArch = stringEncodeArch $ platformArch platform - targetOS = stringEncodeOS $ platformOS platform - isWindows = platformOS platform == OSMinGW32 - let target_defs = - [ "-D" ++ HOST_OS ++ "_BUILD_OS", - "-D" ++ HOST_ARCH ++ "_BUILD_ARCH", - "-D" ++ targetOS ++ "_HOST_OS", - "-D" ++ targetArch ++ "_HOST_ARCH" ] - -- remember, in code we *compile*, the HOST is the same our TARGET, - -- and BUILD is the same as our HOST. - - let io_manager_defs = - [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] ++ - [ "-D__IO_MANAGER_MIO__=1" ] - - let sse_defs = - [ "-D__SSE__" | isSseEnabled platform ] ++ - [ "-D__SSE2__" | isSse2Enabled platform ] ++ - [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] - - let avx_defs = - [ "-D__AVX__" | isAvxEnabled dflags ] ++ - [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ - [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++ - [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++ - [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ - [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] - - backend_defs <- getBackendDefs logger dflags - - let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] - -- Default CPP defines in Haskell source - ghcVersionH <- getGhcVersionPathName dflags unit_env - let hsSourceCppOpts = [ "-include", ghcVersionH ] - - -- MIN_VERSION macros - let uids = explicitUnits unit_state - pkgs = catMaybes (map (lookupUnit unit_state) uids) - mb_macro_include <- - if not (null pkgs) && gopt Opt_VersionMacros dflags - then do macro_stub <- newTempName logger tmpfs dflags TFL_CurrentModule "h" - writeFile macro_stub (generatePackageVersionMacros pkgs) - -- Include version macros for every *exposed* package. - -- Without -hide-all-packages and with a package database - -- size of 1000 packages, it takes cpp an estimated 2 - -- milliseconds to process this file. See #10970 - -- comment 8. - return [GHC.SysTools.FileOption "-include" macro_stub] - else return [] - - cpp_prog ( map GHC.SysTools.Option verbFlags - ++ map GHC.SysTools.Option include_paths - ++ map GHC.SysTools.Option hsSourceCppOpts - ++ map GHC.SysTools.Option target_defs - ++ map GHC.SysTools.Option backend_defs - ++ map GHC.SysTools.Option th_defs - ++ map GHC.SysTools.Option hscpp_opts - ++ map GHC.SysTools.Option sse_defs - ++ map GHC.SysTools.Option avx_defs - ++ map GHC.SysTools.Option io_manager_defs - ++ mb_macro_include - -- Set the language mode to assembler-with-cpp when preprocessing. This - -- alleviates some of the C99 macro rules relating to whitespace and the hash - -- operator, which we tend to abuse. Clang in particular is not very happy - -- about this. - ++ [ GHC.SysTools.Option "-x" - , GHC.SysTools.Option "assembler-with-cpp" - , GHC.SysTools.Option input_fn - -- We hackily use Option instead of FileOption here, so that the file - -- name is not back-slashed on Windows. cpp is capable of - -- dealing with / in filenames, so it works fine. Furthermore - -- if we put in backslashes, cpp outputs #line directives - -- with *double* backslashes. And that in turn means that - -- our error messages get double backslashes in them. - -- In due course we should arrange that the lexer deals - -- with these \\ escapes properly. - , GHC.SysTools.Option "-o" - , GHC.SysTools.FileOption "" output_fn - ]) - -getBackendDefs :: Logger -> DynFlags -> IO [String] -getBackendDefs logger dflags | backend dflags == LLVM = do - llvmVer <- figureLlvmVersion logger dflags - return $ case fmap llvmVersionList llvmVer of - Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ] - Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] - _ -> [] - where - format (major, minor) - | minor >= 100 = error "getBackendDefs: Unsupported minor version" - | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int - -getBackendDefs _ _ = - return [] - --- --------------------------------------------------------------------------- --- Macros (cribbed from Cabal) - -generatePackageVersionMacros :: [UnitInfo] -> String -generatePackageVersionMacros pkgs = concat - -- Do not add any C-style comments. See #3389. - [ generateMacros "" pkgname version - | pkg <- pkgs - , let version = unitPackageVersion pkg - pkgname = map fixchar (unitPackageNameString pkg) - ] - -fixchar :: Char -> Char -fixchar '-' = '_' -fixchar c = c - -generateMacros :: String -> String -> Version -> String -generateMacros prefix name version = - concat - ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" - ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" - ," (major1) < ",major1," || \\\n" - ," (major1) == ",major1," && (major2) < ",major2," || \\\n" - ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" - ,"\n\n" - ] - where - (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) - --- --------------------------------------------------------------------------- --- join object files into a single relocatable object file, using ld -r - -{- -Note [Produce big objects on Windows] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The Windows Portable Executable object format has a limit of 32k sections, which -we tend to blow through pretty easily. Thankfully, there is a "big object" -extension, which raises this limit to 2^32. However, it must be explicitly -enabled in the toolchain: - - * the assembler accepts the -mbig-obj flag, which causes it to produce a - bigobj-enabled COFF object. - - * the linker accepts the --oformat pe-bigobj-x86-64 flag. Despite what the name - suggests, this tells the linker to produce a bigobj-enabled COFF object, no a - PE executable. - -We must enable bigobj output in a few places: - - * When merging object files (GHC.Driver.Pipeline.joinObjectFiles) - - * When assembling (GHC.Driver.Pipeline.runPhase (RealPhase As ...)) - -Unfortunately the big object format is not supported on 32-bit targets so -none of this can be used in that case. - - -Note [Merging object files for GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHCi can usually loads standard linkable object files using GHC's linker -implementation. However, most users build their projects with -split-sections, -meaning that such object files can have an extremely high number of sections. -As the linker must map each of these sections individually, loading such object -files is very inefficient. - -To avoid this inefficiency, we use the linker's `-r` flag and a linker script -to produce a merged relocatable object file. This file will contain a singe -text section section and can consequently be mapped far more efficiently. As -gcc tends to do unpredictable things to our linker command line, we opt to -invoke ld directly in this case, in contrast to our usual strategy of linking -via gcc. - --} - -joinObjectFiles :: Logger -> TmpFs -> DynFlags -> [FilePath] -> FilePath -> IO () -joinObjectFiles logger tmpfs dflags o_files output_fn = do - let toolSettings' = toolSettings dflags - ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings' - osInfo = platformOS (targetPlatform dflags) - ld_r args = GHC.SysTools.runMergeObjects logger tmpfs dflags ( - -- See Note [Produce big objects on Windows] - concat - [ [GHC.SysTools.Option "--oformat", GHC.SysTools.Option "pe-bigobj-x86-64"] - | OSMinGW32 == osInfo - , not $ target32Bit (targetPlatform dflags) - ] - ++ map GHC.SysTools.Option ld_build_id - ++ [ GHC.SysTools.Option "-o", - GHC.SysTools.FileOption "" output_fn ] - ++ args) - - -- suppress the generation of the .note.gnu.build-id section, - -- which we don't need and sometimes causes ld to emit a - -- warning: - ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"] - | otherwise = [] - - if ldIsGnuLd - then do - script <- newTempName logger tmpfs dflags TFL_CurrentModule "ldscript" - cwd <- getCurrentDirectory - let o_files_abs = map (\x -> "\"" ++ (cwd x) ++ "\"") o_files - writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")" - ld_r [GHC.SysTools.FileOption "" script] - else if toolSettings_ldSupportsFilelist toolSettings' - then do - filelist <- newTempName logger tmpfs dflags TFL_CurrentModule "filelist" - writeFile filelist $ unlines o_files - ld_r [GHC.SysTools.Option "-filelist", - GHC.SysTools.FileOption "" filelist] - else - ld_r (map (GHC.SysTools.FileOption "") o_files) - --- ----------------------------------------------------------------------------- --- Misc. - - --- | What phase to run after one of the backend code generators has run -hscPostBackendPhase :: HscSource -> Backend -> Phase -hscPostBackendPhase HsBootFile _ = StopLn -hscPostBackendPhase HsigFile _ = StopLn -hscPostBackendPhase _ bcknd = - case bcknd of - ViaC -> HCc - NCG -> As False - LLVM -> LlvmOpt - NoBackend -> StopLn - Interpreter -> StopLn - -touchObjectFile :: Logger -> DynFlags -> FilePath -> IO () -touchObjectFile logger dflags path = do - createDirectoryIfMissing True $ takeDirectory path - GHC.SysTools.touch logger dflags "Touching object file" path - --- | Find out path to @ghcversion.h@ file -getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath -getGhcVersionPathName dflags unit_env = do - candidates <- case ghcVersionFile dflags of - Just path -> return [path] - Nothing -> do - ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId]) - return (( "ghcversion.h") <$> collectIncludeDirs ps) - - found <- filterM doesFileExist candidates - case found of - [] -> throwGhcExceptionIO (InstallationError - ("ghcversion.h missing; tried: " - ++ intercalate ", " candidates)) - (x:_) -> return x - --- Note [-fPIC for assembler] --- When compiling .c source file GHC's driver pipeline basically --- does the following two things: --- 1. ${CC} -S 'PIC_CFLAGS' source.c --- 2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S --- --- Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler? --- Because on some architectures (at least sparc32) assembler also chooses --- the relocation type! --- Consider the following C module: --- --- /* pic-sample.c */ --- int v; --- void set_v (int n) { v = n; } --- int get_v (void) { return v; } --- --- $ gcc -S -fPIC pic-sample.c --- $ gcc -c pic-sample.s -o pic-sample.no-pic.o # incorrect binary --- $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o # correct binary --- --- $ objdump -r -d pic-sample.pic.o > pic-sample.pic.o.od --- $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od --- $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od --- --- Most of architectures won't show any difference in this test, but on sparc32 --- the following assembly snippet: --- --- sethi %hi(_GLOBAL_OFFSET_TABLE_-8), %l7 --- --- generates two kinds or relocations, only 'R_SPARC_PC22' is correct: --- --- 3c: 2f 00 00 00 sethi %hi(0), %l7 --- - 3c: R_SPARC_PC22 _GLOBAL_OFFSET_TABLE_-0x8 --- + 3c: R_SPARC_HI22 _GLOBAL_OFFSET_TABLE_-0x8 - -{- Note [Don't normalise input filenames] - -Summary - We used to normalise input filenames when starting the unlit phase. This - broke hpc in `--make` mode with imported literate modules (#2991). - -Introduction - 1) --main - When compiling a module with --main, GHC scans its imports to find out which - other modules it needs to compile too. It turns out that there is a small - difference between saying `ghc --make A.hs`, when `A` imports `B`, and - specifying both modules on the command line with `ghc --make A.hs B.hs`. In - the former case, the filename for B is inferred to be './B.hs' instead of - 'B.hs'. - - 2) unlit - When GHC compiles a literate haskell file, the source code first needs to go - through unlit, which turns it into normal Haskell source code. At the start - of the unlit phase, in `Driver.Pipeline.runPhase`, we call unlit with the - option `-h` and the name of the original file. We used to normalise this - filename using System.FilePath.normalise, which among other things removes - an initial './'. unlit then uses that filename in #line directives that it - inserts in the transformed source code. - - 3) SrcSpan - A SrcSpan represents a portion of a source code file. It has fields - linenumber, start column, end column, and also a reference to the file it - originated from. The SrcSpans for a literate haskell file refer to the - filename that was passed to unlit -h. - - 4) -fhpc - At some point during compilation with -fhpc, in the function - `GHC.HsToCore.Coverage.isGoodTickSrcSpan`, we compare the filename that a - `SrcSpan` refers to with the name of the file we are currently compiling. - For some reason I don't yet understand, they can sometimes legitimally be - different, and then hpc ignores that SrcSpan. - -Problem - When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate - module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the - start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2). - Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are - still compiling `./B.lhs`. Hpc thinks these two filenames are different (4), - doesn't include ticks for B, and we have unhappy customers (#2991). - -Solution - Do not normalise `input_fn` when starting the unlit phase. - -Alternative solution - Another option would be to not compare the two filenames on equality, but to - use System.FilePath.equalFilePath. That function first normalises its - arguments. The problem is that by the time we need to do the comparison, the - filenames have been turned into FastStrings, probably for performance - reasons, so System.FilePath.equalFilePath can not be used directly. - -Archeology - The call to `normalise` was added in a commit called "Fix slash - direction on Windows with the new filePath code" (c9b6b5e8). The problem - that commit was addressing has since been solved in a different manner, in a - commit called "Fix the filename passed to unlit" (1eedbc6b). So the - `normalise` is no longer necessary. +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} + +----------------------------------------------------------------------------- +-- +-- GHC Driver +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module GHC.Driver.Pipeline ( + -- * Run a series of compilation steps in a pipeline, for a + -- collection of source files. + oneShot, compileFile, + + -- * Interfaces for the compilation manager (interpreted/batch-mode) + preprocess, + compileOne, compileOne', + compileForeign, compileEmptyStub, + + -- * Linking + link, linkingNeeded, checkLinkInfo, + + -- * PipeEnv + PipeEnv(..), mkPipeEnv, phaseOutputFilenameNew, + + -- * Running individual phases + TPhase(..), runPhase, + hscPostBackendPhase, + + -- * Constructing Pipelines + TPipelineClass, MonadUse(..), + + preprocessPipeline, fullPipeline, hscPipeline, hscBackendPipeline, hscPostBackendPipeline, + hscGenBackendPipeline, asPipeline, viaCPipeline, cmmCppPipeline, cmmPipeline, + llvmPipeline, llvmLlcPipeline, llvmManglePipeline, pipelineStart, + + -- * Default method of running a pipeline + runPipeline +) where + + +#include "ghcplatform.h" +import GHC.Prelude + +import GHC.Platform + +import GHC.Utils.Monad ( MonadIO(liftIO), mapMaybeM ) + +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.Diagnostic +import GHC.Driver.Phases +import GHC.Driver.Pipeline.Phases +import GHC.Driver.Session +import GHC.Driver.Backend +import GHC.Driver.Ppr +import GHC.Driver.Hooks + +import GHC.Platform.Ways + +import GHC.SysTools +import GHC.Utils.TmpFs + +import GHC.Linker.ExtraObj +import GHC.Linker.Static +import GHC.Linker.Types + +import GHC.Utils.Outputable +import GHC.Utils.Error +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Exception as Exception +import GHC.Utils.Logger + +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Data.FastString ( mkFastString ) +import GHC.Data.StringBuffer ( hPutStringBuffer ) +import GHC.Data.Maybe ( expectJust ) + +import GHC.Iface.Make ( mkFullIface ) +import GHC.Runtime.Loader ( initializePlugins ) + + +import GHC.Types.Basic ( SuccessFlag(..), ForeignSrcLang(..) ) +import GHC.Types.Error ( singleMessage, getMessages ) +import GHC.Types.Target +import GHC.Types.SrcLoc +import GHC.Types.SourceFile +import GHC.Types.SourceError + +import GHC.Unit +import GHC.Unit.Env +--import GHC.Unit.Finder +--import GHC.Unit.State +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Graph (needsTemplateHaskellOrQQ) +import GHC.Unit.Module.Deps +import GHC.Unit.Home.ModInfo + +import System.Directory +import System.FilePath +import System.IO +import Control.Monad +import qualified Control.Monad.Catch as MC (handle) +import Data.Maybe +import Data.Either ( partitionEithers ) + +import Data.Time ( getCurrentTime ) +import GHC.Driver.Pipeline.Execute + +-- Simpler type synonym for actions in the pipeline monad +type P m = TPipelineClass TPhase m + +-- --------------------------------------------------------------------------- +-- Pre-process + +-- | Just preprocess a file, put the result in a temp. file (used by the +-- compilation manager during the summary phase). +-- +-- We return the augmented DynFlags, because they contain the result +-- of slurping in the OPTIONS pragmas + +preprocess :: HscEnv + -> FilePath -- ^ input filename + -> Maybe InputFileBuffer + -- ^ optional buffer to use instead of reading the input file + -> Maybe Phase -- ^ starting phase + -> IO (Either DriverMessages (DynFlags, FilePath)) +preprocess hsc_env input_fn mb_input_buf mb_phase = + handleSourceError (\err -> return $ Left $ to_driver_messages $ srcErrorMessages err) $ + MC.handle handler $ + fmap Right $ do + massertPpr (isJust mb_phase || isHaskellSrcFilename input_fn) (text input_fn) + input_fn_final <- mkInputFn + let preprocess_pipeline = preprocessPipeline pipe_env (setDumpPrefix pipe_env hsc_env) input_fn_final + runPipeline (hsc_hooks hsc_env) preprocess_pipeline + + where + srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1 + handler (ProgramError msg) = + return $ Left $ singleMessage $ + mkPlainErrorMsgEnvelope srcspan $ + DriverUnknownMessage $ mkPlainError noHints $ text msg + handler ex = throwGhcExceptionIO ex + + to_driver_messages :: Messages GhcMessage -> Messages DriverMessage + to_driver_messages msgs = case traverse to_driver_message msgs of + Nothing -> pprPanic "non-driver message in preprocess" + (vcat $ pprMsgEnvelopeBagWithLoc (getMessages msgs)) + Just msgs' -> msgs' + + to_driver_message = \case + GhcDriverMessage msg + -> Just msg + GhcPsMessage (PsHeaderMessage msg) + -> Just (DriverPsHeaderMessage (PsHeaderMessage msg)) + _ -> Nothing + + pipe_env = mkPipeEnv StopPreprocess input_fn (Temporary TFL_GhcSession) + mkInputFn = + case mb_input_buf of + Just input_buf -> do + fn <- newTempName (hsc_logger hsc_env) + (hsc_tmpfs hsc_env) + (tmpDir (hsc_dflags hsc_env)) + TFL_CurrentModule + ("buf_" ++ src_suffix pipe_env) + hdl <- openBinaryFile fn WriteMode + -- Add a LINE pragma so reported source locations will + -- mention the real input file, not this temp file. + hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}" + hPutStringBuffer hdl input_buf + hClose hdl + return fn + Nothing -> return input_fn + +-- --------------------------------------------------------------------------- + +-- | Compile +-- +-- Compile a single module, under the control of the compilation manager. +-- +-- This is the interface between the compilation manager and the +-- compiler proper (hsc), where we deal with tedious details like +-- reading the OPTIONS pragma from the source file, converting the +-- C or assembly that GHC produces into an object file, and compiling +-- FFI stub files. +-- +-- NB. No old interface can also mean that the source has changed. + + +compileOne :: HscEnv + -> ModSummary -- ^ summary for module being compiled + -> Int -- ^ module N ... + -> Int -- ^ ... of M + -> Maybe ModIface -- ^ old interface, if we have one + -> Maybe Linkable -- ^ old linkable, if we have one + -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful + +compileOne = compileOne' (Just batchMsg) + +compileOne' :: Maybe Messager + -> HscEnv + -> ModSummary -- ^ summary for module being compiled + -> Int -- ^ module N ... + -> Int -- ^ ... of M + -> Maybe ModIface -- ^ old interface, if we have one + -> Maybe Linkable -- ^ old linkable, if we have one + -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful + +compileOne' mHscMessage + hsc_env0 summary mod_index nmods mb_old_iface mb_old_linkable + = do + + debugTraceMsg logger 2 (text "compile: input file" <+> text input_fnpp) + + let flags = hsc_dflags hsc_env0 + in do unless (gopt Opt_KeepHiFiles flags) $ + addFilesToClean tmpfs TFL_CurrentModule $ + [ml_hi_file $ ms_location summary] + unless (gopt Opt_KeepOFiles flags) $ + addFilesToClean tmpfs TFL_GhcSession $ + [ml_obj_file $ ms_location summary] + + plugin_hsc_env <- initializePlugins hsc_env (Just (ms_mnwib summary)) + let pipe_env = mkPipeEnv NoStop input_fn pipelineOutput + status <- hscRecompStatus mHscMessage plugin_hsc_env summary + mb_old_iface mb_old_linkable (mod_index, nmods) + let pipeline = hscPipeline pipe_env (setDumpPrefix pipe_env plugin_hsc_env, summary, status) + (iface, old_linkable) <- runPipeline (hsc_hooks hsc_env) pipeline + -- See Note [ModDetails and --make mode] + details <- initModDetails plugin_hsc_env summary iface + return $! HomeModInfo iface details old_linkable + + 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 = hasWay (ways lcl_dflags) WayDyn + isProfWay = hasWay (ways lcl_dflags) WayProf + internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags) + + pipelineOutput = case bcknd of + Interpreter -> NoOutputFile + NoBackend -> NoOutputFile + _ -> Persistent + + logger = hsc_logger hsc_env0 + tmpfs = hsc_tmpfs hsc_env0 + + -- #8180 - when using TemplateHaskell, switch on -dynamic-too so + -- the linker can correctly load the object files. This isn't necessary + -- when using -fexternal-interpreter. + dflags1 = if hostIsDynamic && internalInterpreter && + not isDynWay && not isProfWay && needsLinker + 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 + -- turn on -fexternal-interpreter. + dflags2 = if not internalInterpreter && needsLinker + then gopt_set dflags1 Opt_ExternalInterpreter + else dflags1 + + basename = dropExtension input_fn + + -- We add the directory in which the .hs files resides) to the import + -- path. This is needed when we try to compile the .hc file later, if it + -- imports a _stub.h file that we created here. + current_dir = takeDirectory basename + old_paths = includePaths dflags2 + loadAsByteCode + | Just Target { targetAllowObjCode = obj } <- findTarget summary (hsc_targets hsc_env0) + , not obj + = True + | otherwise = False + -- Figure out which backend we're using + (bcknd, dflags3) + -- #8042: When module was loaded with `*` prefix in ghci, but DynFlags + -- suggest to generate object code (which may happen in case -fobject-code + -- was set), force it to generate byte-code. This is NOT transitive and + -- only applies to direct targets. + | loadAsByteCode + = (Interpreter, gopt_set (dflags2 { backend = Interpreter }) Opt_ForceRecomp) + | otherwise + = (backend dflags, dflags2) + dflags = dflags3 { includePaths = addImplicitQuoteInclude old_paths [current_dir] } + hsc_env = hscSetFlags dflags hsc_env0 + +-- --------------------------------------------------------------------------- +-- Link +-- +-- Note [Dynamic linking on macOS] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Since macOS Sierra (10.14), the dynamic system linker enforces +-- a limit on the Load Commands. Specifically the Load Command Size +-- Limit is at 32K (32768). The Load Commands contain the install +-- name, dependencies, runpaths, and a few other commands. We however +-- only have control over the install name, dependencies and runpaths. +-- +-- The install name is the name by which this library will be +-- referenced. This is such that we do not need to bake in the full +-- absolute location of the library, and can move the library around. +-- +-- The dependency commands contain the install names from of referenced +-- libraries. Thus if a libraries install name is @rpath/libHS...dylib, +-- that will end up as the dependency. +-- +-- Finally we have the runpaths, which informs the linker about the +-- directories to search for the referenced dependencies. +-- +-- The system linker can do recursive linking, however using only the +-- direct dependencies conflicts with ghc's ability to inline across +-- packages, and as such would end up with unresolved symbols. +-- +-- Thus we will pass the full dependency closure to the linker, and then +-- ask the linker to remove any unused dynamic libraries (-dead_strip_dylibs). +-- +-- We still need to add the relevant runpaths, for the dynamic linker to +-- lookup the referenced libraries though. The linker (ld64) does not +-- have any option to dead strip runpaths; which makes sense as runpaths +-- can be used for dependencies of dependencies as well. +-- +-- The solution we then take in GHC is to not pass any runpaths to the +-- linker at link time, but inject them after the linking. For this to +-- work we'll need to ask the linker to create enough space in the header +-- to add more runpaths after the linking (-headerpad 8000). +-- +-- After the library has been linked by $LD (usually ld64), we will use +-- otool to inspect the libraries left over after dead stripping, compute +-- the relevant runpaths, and inject them into the linked product using +-- the install_name_tool command. +-- +-- This strategy should produce the smallest possible set of load commands +-- while still retaining some form of relocatability via runpaths. +-- +-- The only way I can see to reduce the load command size further would be +-- by shortening the library names, or start putting libraries into the same +-- folders, such that one runpath would be sufficient for multiple/all +-- libraries. +link :: GhcLink -- ^ interactive or batch + -> Logger -- ^ Logger + -> TmpFs + -> Hooks + -> DynFlags -- ^ dynamic flags + -> UnitEnv -- ^ unit environment + -> Bool -- ^ attempt linking in batch mode? + -> HomePackageTable -- ^ what to link + -> IO SuccessFlag + +-- For the moment, in the batch linker, we don't bother to tell doLink +-- which packages to link -- it just tries all that are available. +-- batch_attempt_linking should only be *looked at* in batch mode. It +-- should only be True if the upsweep was successful and someone +-- exports main, i.e., we have good reason to believe that linking +-- will succeed. + +link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking hpt = + case linkHook hooks of + Nothing -> case ghcLink of + NoLink -> return Succeeded + LinkBinary -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt + LinkStaticLib -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt + LinkDynLib -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt + LinkInMemory + | platformMisc_ghcWithInterpreter $ platformMisc dflags + -> -- Not Linking...(demand linker will do the job) + return Succeeded + | otherwise + -> panicBadLink LinkInMemory + Just h -> h ghcLink dflags batch_attempt_linking hpt + + +panicBadLink :: GhcLink -> a +panicBadLink other = panic ("link: GHC not built to link this way: " ++ + show other) + +link' :: Logger + -> TmpFs + -> DynFlags -- ^ dynamic flags + -> UnitEnv -- ^ unit environment + -> Bool -- ^ attempt linking in batch mode? + -> HomePackageTable -- ^ what to link + -> IO SuccessFlag + +link' logger tmpfs dflags unit_env batch_attempt_linking hpt + | batch_attempt_linking + = do + let + staticLink = case ghcLink dflags of + LinkStaticLib -> True + _ -> False + + home_mod_infos = eltsHpt hpt + + -- the packages we depend on + pkg_deps = concatMap (dep_direct_pkgs . mi_deps . hm_iface) home_mod_infos + + -- the linkables to link + linkables = map (expectJust "link".hm_linkable) home_mod_infos + + 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 3 (text "link(batch): linking omitted (-c flag given).") + return Succeeded + else do + + let getOfiles LM{ linkableUnlinked } = map nameOfObject (filter isObject linkableUnlinked) + obj_files = concatMap getOfiles linkables + platform = targetPlatform dflags + exe_file = exeFileName platform staticLink (outputFile dflags) + + linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps + + if not (gopt Opt_ForceRecomp dflags) && not linking_needed + then do debugTraceMsg logger 2 (text exe_file <+> text "is up to date, linking not required.") + return Succeeded + else do + + 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 + LinkBinary -> linkBinary logger tmpfs + LinkStaticLib -> linkStaticLib logger + LinkDynLib -> linkDynLibCheck logger tmpfs + other -> panicBadLink other + link dflags unit_env obj_files pkg_deps + + debugTraceMsg logger 3 (text "link: done") + + -- linkBinary only returns if it succeeds + return Succeeded + + | otherwise + = do debugTraceMsg logger 3 (text "link(batch): upsweep (partially) failed OR" $$ + text " Main.main not exported; not linking.") + return Succeeded + + +linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO Bool +linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do + -- if the modification time on the executable is later than the + -- modification times on all of the objects and libraries, then omit + -- linking (unless the -fforce-recomp flag was given). + let platform = ue_platform unit_env + unit_state = ue_units unit_env + exe_file = exeFileName platform staticLink (outputFile dflags) + e_exe_time <- tryIO $ getModificationUTCTime exe_file + case e_exe_time of + Left _ -> return True + Right t -> do + -- first check object files and extra_ld_inputs + let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] + e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs + let (errs,extra_times) = partitionEithers e_extra_times + let obj_times = map linkableTime linkables ++ extra_times + if not (null errs) || any (t <) obj_times + then return True + else do + + -- next, check libraries. XXX this only checks Haskell libraries, + -- not extra_libraries or -l things from the command line. + let pkg_hslibs = [ (collectLibraryDirs (ways dflags) [c], lib) + | Just c <- map (lookupUnitId unit_state) pkg_deps, + lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ] + + pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs + if any isNothing pkg_libfiles then return True else do + e_lib_times <- mapM (tryIO . getModificationUTCTime) + (catMaybes pkg_libfiles) + let (lib_errs,lib_times) = partitionEithers e_lib_times + if not (null lib_errs) || any (t <) lib_times + then return True + else checkLinkInfo logger dflags unit_env pkg_deps exe_file + +findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath) +findHSLib platform ws dirs lib = do + let batch_lib_file = if ws `hasNotWay` WayDyn + then "lib" ++ lib <.> "a" + else platformSOName platform lib + found <- filterM doesFileExist (map ( batch_lib_file) dirs) + case found of + [] -> return Nothing + (x:_) -> return (Just x) + +-- ----------------------------------------------------------------------------- +-- Compile files in one-shot mode. + +oneShot :: HscEnv -> StopPhase -> [(String, Maybe Phase)] -> IO () +oneShot hsc_env stop_phase srcs = do + o_files <- mapMaybeM (compileFile hsc_env stop_phase) srcs + case stop_phase of + StopPreprocess -> return () + StopC -> return () + StopAs -> return () + NoStop -> doLink hsc_env o_files + +compileFile :: HscEnv -> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe FilePath) +compileFile hsc_env stop_phase (src, _mb_phase) = do + exists <- doesFileExist src + when (not exists) $ + throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src)) + + let + dflags = hsc_dflags hsc_env + mb_o_file = outputFile dflags + ghc_link = ghcLink dflags -- Set by -c or -no-link + + -- When linking, the -o argument refers to the linker's output. + -- otherwise, we use it as the name for the pipeline's output. + output + | NoBackend <- backend dflags = NoOutputFile + | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent + -- -o foo applies to linker + | isJust mb_o_file = SpecificFile + -- -o foo applies to the file we are compiling now + | otherwise = Persistent + pipe_env = mkPipeEnv stop_phase src output + pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) src + runPipeline (hsc_hooks hsc_env) pipeline + + +doLink :: HscEnv -> [FilePath] -> IO () +doLink hsc_env o_files = + let + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + unit_env = hsc_unit_env hsc_env + tmpfs = hsc_tmpfs hsc_env + in case ghcLink dflags of + NoLink -> return () + LinkBinary -> linkBinary logger tmpfs dflags unit_env o_files [] + LinkStaticLib -> linkStaticLib logger dflags unit_env o_files [] + LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env o_files [] + other -> panicBadLink other + +----------------------------------------------------------------------------- +-- stub .h and .c files (for foreign export support), and cc files. + +-- The _stub.c file is derived from the haskell source file, possibly taking +-- into account the -stubdir option. +-- +-- The object file created by compiling the _stub.c file is put into a +-- temporary file, which will be later combined with the main .o file +-- (see the MergeForeigns phase). +-- +-- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files +-- from TH, that are then compiled and linked to the module. This is +-- useful to implement facilities such as inline-c. + +compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath +compileForeign _ RawObject object_file = return object_file +compileForeign hsc_env lang stub_c = do + let pipeline = case lang of + LangC -> viaCPipeline Cc + LangCxx -> viaCPipeline Ccxx + LangObjc -> viaCPipeline Cobjc + LangObjcxx -> viaCPipeline Cobjcxx + LangAsm -> \pe hsc_env ml fp -> Just <$> asPipeline True pe hsc_env ml fp +#if __GLASGOW_HASKELL__ < 811 + RawObject -> panic "compileForeign: should be unreachable" +#endif + pipe_env = mkPipeEnv NoStop stub_c (Temporary TFL_GhcSession) + res <- runPipeline (hsc_hooks hsc_env) (pipeline pipe_env hsc_env Nothing stub_c) + case res of + -- This should never happen as viaCPipeline should only return `Nothing` when the stop phase is `StopC`. + -- Future refactoring to not check StopC for this case + Nothing -> pprPanic "compileForeign" (ppr stub_c) + Just fp -> return fp + +compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO () +compileEmptyStub dflags hsc_env basename location mod_name = do + -- To maintain the invariant that every Haskell file + -- compiles to object code, we make an empty (but + -- valid) stub object file for signatures. However, + -- we make sure this object file has a unique symbol, + -- so that ranlib on OS X doesn't complain, see + -- https://gitlab.haskell.org/ghc/ghc/issues/12673 + -- and https://github.com/haskell/cabal/issues/2257 + let logger = hsc_logger hsc_env + let tmpfs = hsc_tmpfs hsc_env + empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c" + let home_unit = hsc_home_unit hsc_env + src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" + writeFile empty_stub (showSDoc dflags (pprCode CStyle src)) + let pipe_env = (mkPipeEnv NoStop empty_stub Persistent) { src_basename = basename} + pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub + _ <- runPipeline (hsc_hooks hsc_env) pipeline + return () + + +{- Environment Initialisation -} + +mkPipeEnv :: StopPhase -- End phase + -> FilePath -- input fn + -> PipelineOutput -- Output + -> PipeEnv +mkPipeEnv stop_phase input_fn output = + let (basename, suffix) = splitExtension input_fn + suffix' = drop 1 suffix -- strip off the . + env = PipeEnv{ stop_phase, + src_filename = input_fn, + src_basename = basename, + src_suffix = suffix', + output_spec = output } + in env + +setDumpPrefix :: PipeEnv -> HscEnv -> HscEnv +setDumpPrefix pipe_env hsc_env = + hscUpdateFlags (\dflags -> dflags { dumpPrefix = Just (src_basename pipe_env ++ ".")}) hsc_env + +{- The Pipelines -} + +phaseIfFlag :: Monad m + => HscEnv + -> (DynFlags -> Bool) + -> a + -> m a + -> m a +phaseIfFlag hsc_env flag def action = + if flag (hsc_dflags hsc_env) + then action + else return def + +-- | Check if the start is *before* the current phase, otherwise skip with a default +phaseIfAfter :: P m => Platform -> Phase -> Phase -> a -> m a -> m a +phaseIfAfter platform start_phase cur_phase def action = + if start_phase `eqPhase` cur_phase + || happensBefore platform start_phase cur_phase + + then action + else return def + +-- | The preprocessor pipeline +preprocessPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (DynFlags, FilePath) +preprocessPipeline pipe_env hsc_env input_fn = do + unlit_fn <- + runAfter (Unlit HsSrcFile) input_fn $ do + use (T_Unlit pipe_env hsc_env input_fn) + + + (dflags1, warns1) <- use (T_FileArgs hsc_env unlit_fn) + let hsc_env1 = hscSetFlags dflags1 hsc_env + + (cpp_fn, hsc_env2) + <- runAfterFlag hsc_env1 (Cpp HsSrcFile) (xopt LangExt.Cpp) (unlit_fn, hsc_env1) $ do + cpp_fn <- use (T_Cpp pipe_env hsc_env1 unlit_fn) + (dflags2, _) <- use (T_FileArgs hsc_env1 cpp_fn) + let hsc_env2 = hscSetFlags dflags2 hsc_env1 + return (cpp_fn, hsc_env2) + + + pp_fn <- runAfterFlag hsc_env2 (HsPp HsSrcFile) (gopt Opt_Pp) cpp_fn $ + use (T_HsPp pipe_env hsc_env2 input_fn cpp_fn) + + (dflags3, warns3) + <- if pp_fn == unlit_fn + -- Didn't run any preprocessors so don't need to reparse, would be nicer + -- if `T_FileArgs` recognised this. + then return (dflags1, warns1) + else do + -- Reparse with original hsc_env so that we don't get duplicated options + use (T_FileArgs hsc_env pp_fn) + + liftIO (handleFlagWarnings (hsc_logger hsc_env) (initDiagOpts dflags3) warns3) + return (dflags3, pp_fn) + + + -- This won't change through the compilation pipeline + where platform = targetPlatform (hsc_dflags hsc_env) + runAfter :: P p => Phase + -> a -> p a -> p a + runAfter = phaseIfAfter platform start_phase + start_phase = startPhase (src_suffix pipe_env) + runAfterFlag :: P p + => HscEnv + -> Phase + -> (DynFlags -> Bool) + -> a + -> p a + -> p a + runAfterFlag hsc_env phase flag def action = + runAfter phase def + $ phaseIfFlag hsc_env flag def action + +-- | The complete compilation pipeline, from start to finish +fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, Maybe Linkable) +fullPipeline pipe_env hsc_env pp_fn src_flavour = do + (dflags, input_fn) <- preprocessPipeline pipe_env hsc_env pp_fn + let hsc_env' = hscSetFlags dflags hsc_env + (hsc_env_with_plugins, mod_sum, hsc_recomp_status) + <- use (T_HscRecomp pipe_env hsc_env' input_fn src_flavour) + res <- hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) + checkDynamicToo pipe_env hsc_env pp_fn src_flavour res + -- Once the pipeline has finished, check to see if -dynamic-too failed and + -- rerun again if it failed but just the `--dynamic` way. + +checkDynamicToo :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> (ModIface, Maybe Linkable) -> m (ModIface, Maybe Linkable) +checkDynamicToo pipe_env hsc_env pp_fn src_flavour res = do + liftIO (dynamicTooState (hsc_dflags hsc_env)) >>= \case + DT_Dont -> return res + DT_Dyn -> return res + DT_OK -> return res + -- If we are compiling a Haskell module with -dynamic-too, we + -- first try the "fast path": that is we compile the non-dynamic + -- version and at the same time we check that interfaces depended + -- on exist both for the non-dynamic AND the dynamic way. We also + -- check that they have the same hash. + -- If they don't, dynamicTooState is set to DT_Failed. + -- See GHC.Iface.Load.checkBuildDynamicToo + -- If they do, in the end we produce both the non-dynamic and + -- dynamic outputs. + -- + -- If this "fast path" failed, we execute the whole pipeline + -- again, this time for the dynamic way *only*. To do that we + -- just set the dynamicNow bit from the start to ensure that the + -- dynamic DynFlags fields are used and we disable -dynamic-too + -- (its state is already set to DT_Failed so it wouldn't do much + -- anyway). + DT_Failed + -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987) + | OSMinGW32 <- platformOS (targetPlatform dflags) -> return res + | otherwise -> do + liftIO (debugTraceMsg logger 4 + (text "Running the full pipeline again for -dynamic-too")) + hsc_env' <- liftIO (resetHscEnv hsc_env) + fullPipeline pipe_env hsc_env' pp_fn src_flavour + where + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + +-- | Enable dynamic-too, reset EPS +resetHscEnv :: HscEnv -> IO HscEnv +resetHscEnv hsc_env = do + let dflags0 = flip gopt_unset Opt_BuildDynamicToo + $ setDynamicNow + $ (hsc_dflags hsc_env) + hsc_env' <- newHscEnv dflags0 + (dbs,unit_state,home_unit,mconstants) <- initUnits (hsc_logger hsc_env) dflags0 Nothing + dflags1 <- updatePlatformConstants dflags0 mconstants + unit_env0 <- initUnitEnv (ghcNameVersion dflags1) (targetPlatform dflags1) + let unit_env = unit_env0 + { ue_home_unit = Just home_unit + , ue_units = unit_state + , ue_unit_dbs = Just dbs + } + let hsc_env'' = hscSetFlags dflags1 $ hsc_env' + { hsc_unit_env = unit_env + } + return hsc_env'' + +-- | Everything after preprocess +hscPipeline :: P m => PipeEnv -> ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, Maybe Linkable) +hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do + case hsc_recomp_status of + HscUpToDate iface mb_linkable -> return (iface, mb_linkable) + HscRecompNeeded mb_old_hash -> do + (tc_result, warnings) <- use (T_Hsc hsc_env_with_plugins mod_sum) + hscBackendAction <- use (T_HscPostTc hsc_env_with_plugins mod_sum tc_result warnings mb_old_hash ) + hscBackendPipeline pipe_env hsc_env_with_plugins mod_sum hscBackendAction + +hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, Maybe Linkable) +hscBackendPipeline pipe_env hsc_env mod_sum result = + case backend (hsc_dflags hsc_env) of + NoBackend -> + case result of + HscUpdate iface -> return (iface, Nothing) + HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing) <*> pure Nothing + -- TODO: Why is there not a linkable? + -- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing + _ -> do + res <- hscGenBackendPipeline pipe_env hsc_env mod_sum result + liftIO (dynamicTooState (hsc_dflags hsc_env)) >>= \case + DT_OK -> do + let dflags' = setDynamicNow (hsc_dflags hsc_env) -- set "dynamicNow" + () <$ hscGenBackendPipeline pipe_env (hscSetFlags dflags' hsc_env) mod_sum result + _ -> return () + return res + +hscGenBackendPipeline :: P m + => PipeEnv + -> HscEnv + -> ModSummary + -> HscBackendAction + -> m (ModIface, Maybe Linkable) +hscGenBackendPipeline pipe_env hsc_env mod_sum result = do + let mod_name = moduleName (ms_mod mod_sum) + src_flavour = (ms_hsc_src mod_sum) + dflags = hsc_dflags hsc_env + -- MP: The ModLocation is recalculated here to get the right paths when + -- -dynamic-too is enabled. `ModLocation` should be extended with a field for + -- the location of the `dyn_o` file to avoid this recalculation. + location <- liftIO (getLocation pipe_env dflags src_flavour mod_name) + (fos, miface, mlinkable, o_file) <- use (T_HscBackend pipe_env hsc_env mod_name src_flavour location result) + final_fp <- hscPostBackendPipeline pipe_env hsc_env (ms_hsc_src mod_sum) (backend (hsc_dflags hsc_env)) (Just location) o_file + final_linkable <- + case final_fp of + -- No object file produced, bytecode or NoBackend + Nothing -> return mlinkable + Just o_fp -> do + unlinked_time <- liftIO (liftIO getCurrentTime) + final_o <- use (T_MergeForeign pipe_env hsc_env (Just location) o_fp fos) + let !linkable = LM unlinked_time + (ms_mod mod_sum) + [DotO final_o] + return (Just linkable) + return (miface, final_linkable) + +asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath +asPipeline use_cpp pipe_env hsc_env location input_fn = do + use (T_As use_cpp pipe_env hsc_env location input_fn) + +viaCPipeline :: P m => Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) +viaCPipeline c_phase pipe_env hsc_env location input_fn = do + out_fn <- use (T_Cc c_phase pipe_env hsc_env input_fn) + case stop_phase pipe_env of + StopC -> return Nothing + _ -> Just <$> asPipeline False pipe_env hsc_env location out_fn + +llvmPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath +llvmPipeline pipe_env hsc_env location fp = do + opt_fn <- use (T_LlvmOpt pipe_env hsc_env fp) + llvmLlcPipeline pipe_env hsc_env location opt_fn + +llvmLlcPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath +llvmLlcPipeline pipe_env hsc_env location opt_fn = do + llc_fn <- use (T_LlvmLlc pipe_env hsc_env opt_fn) + llvmManglePipeline pipe_env hsc_env location llc_fn + +llvmManglePipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath +llvmManglePipeline pipe_env hsc_env location llc_fn = do + mangled_fn <- + if gopt Opt_NoLlvmMangler (hsc_dflags hsc_env) + then use (T_LlvmMangle pipe_env hsc_env llc_fn) + else return llc_fn + asPipeline False pipe_env hsc_env location mangled_fn + +cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath +cmmCppPipeline pipe_env hsc_env input_fn = do + output_fn <- use (T_CmmCpp pipe_env hsc_env input_fn) + cmmPipeline pipe_env hsc_env output_fn + +cmmPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath +cmmPipeline pipe_env hsc_env input_fn = do + (fos, output_fn) <- use (T_Cmm pipe_env hsc_env input_fn) + mo_fn <- hscPostBackendPipeline pipe_env hsc_env HsSrcFile (backend (hsc_dflags hsc_env)) Nothing output_fn + case mo_fn of + Nothing -> panic "CMM pipeline - produced no .o file" + Just mo_fn -> use (T_MergeForeign pipe_env hsc_env Nothing mo_fn fos) + +hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) +hscPostBackendPipeline _ _ HsBootFile _ _ _ = return Nothing +hscPostBackendPipeline _ _ HsigFile _ _ _ = return Nothing +hscPostBackendPipeline pipe_env hsc_env _ bcknd ml input_fn = + case bcknd of + ViaC -> viaCPipeline HCc pipe_env hsc_env ml input_fn + NCG -> Just <$> asPipeline False pipe_env hsc_env ml input_fn + LLVM -> Just <$> llvmPipeline pipe_env hsc_env ml input_fn + NoBackend -> return Nothing + Interpreter -> return Nothing + +-- Pipeline from a given suffix +pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath) +pipelineStart pipe_env hsc_env input_fn = + fromSuffix (src_suffix pipe_env) + where + stop_after = stop_phase pipe_env + frontend :: P m => HscSource -> m (Maybe FilePath) + frontend sf = case stop_after of + StopPreprocess -> do + -- The actual output from preprocessing + (_, out_fn) <- preprocessPipeline pipe_env hsc_env input_fn + let logger = hsc_logger hsc_env + -- Sometimes, a compilation phase doesn't actually generate any output + -- (eg. the CPP phase when -fcpp is not turned on). If we end on this + -- stage, but we wanted to keep the output, then we have to explicitly + -- copy the file, remembering to prepend a {-# LINE #-} pragma so that + -- further compilation stages can tell what the original filename was. + -- File name we expected the output to have + final_fn <- liftIO $ phaseOutputFilenameNew (Hsc HsSrcFile) pipe_env hsc_env Nothing + when (final_fn /= out_fn) $ do + let msg = "Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'" + line_prag = "{-# LINE 1 \"" ++ src_filename pipe_env ++ "\" #-}\n" + liftIO (showPass logger msg) + liftIO (copyWithHeader line_prag input_fn final_fn) + return Nothing + _ -> objFromLinkable <$> fullPipeline pipe_env hsc_env input_fn sf + c :: P m => Phase -> m (Maybe FilePath) + c phase = viaCPipeline phase pipe_env hsc_env Nothing input_fn + as :: P m => Bool -> m (Maybe FilePath) + as use_cpp = Just <$> asPipeline use_cpp pipe_env hsc_env Nothing input_fn + + objFromLinkable (_, Just (LM _ _ [DotO lnk])) = Just lnk + objFromLinkable _ = Nothing + + + fromSuffix :: P m => String -> m (Maybe FilePath) + fromSuffix "lhs" = frontend HsSrcFile + fromSuffix "lhs-boot" = frontend HsBootFile + fromSuffix "lhsig" = frontend HsigFile + fromSuffix "hs" = frontend HsSrcFile + fromSuffix "hs-boot" = frontend HsBootFile + fromSuffix "hsig" = frontend HsigFile + fromSuffix "hscpp" = frontend HsSrcFile + fromSuffix "hspp" = frontend HsSrcFile + fromSuffix "hc" = c HCc + fromSuffix "c" = c Cc + fromSuffix "cpp" = c Ccxx + fromSuffix "C" = c Cc + fromSuffix "m" = c Cobjc + fromSuffix "M" = c Cobjcxx + fromSuffix "mm" = c Cobjcxx + fromSuffix "cc" = c Ccxx + fromSuffix "cxx" = c Ccxx + fromSuffix "s" = as False + fromSuffix "S" = as True + fromSuffix "ll" = Just <$> llvmPipeline pipe_env hsc_env Nothing input_fn + fromSuffix "bc" = Just <$> llvmLlcPipeline pipe_env hsc_env Nothing input_fn + fromSuffix "lm_s" = Just <$> llvmManglePipeline pipe_env hsc_env Nothing input_fn + fromSuffix "o" = return (Just input_fn) + fromSuffix "cmm" = Just <$> cmmCppPipeline pipe_env hsc_env input_fn + fromSuffix "cmmcpp" = Just <$> cmmPipeline pipe_env hsc_env input_fn + fromSuffix _ = return (Just input_fn) + +{- + +Note [The Pipeline Monad] +~~~~~~~~~~~~~~~~~~~~~~~~~ + +The pipeline is represented as a free monad by the `TPipelineClass` type synonym, +which stipulates the general monadic interface for the pipeline and `MonadUse`, instantiated +to `TPhase`, which indicates the actions available in the pipeline. + +The `TPhase` actions correspond to different compiled phases, they are executed by +the 'runPhase' function which interprets each action into IO. + +The idea in the future is that we can now implement different instiations of +`TPipelineClass` to give different behaviours that the default `HookedPhase` implementation: + +* Additional logging of different phases +* Automatic parrelism (in the style of shake) +* Easy consumption by external tools such as ghcide +* Easier to create your own pipeline and extend existing pipelines. + +The structure of the code as a free monad also means that the return type of each +phase is a lot more flexible. + -} diff --git a/compiler/GHC/Driver/Pipeline.hs-boot b/compiler/GHC/Driver/Pipeline.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Driver/Pipeline.hs-boot @@ -0,0 +1,13 @@ +module GHC.Driver.Pipeline where + + +import GHC.Driver.Env.Types ( HscEnv ) +import GHC.ForeignSrcLang ( ForeignSrcLang ) +import GHC.Prelude (FilePath, IO) +import GHC.Unit.Module.Location (ModLocation) +import GHC.Unit.Module.Name (ModuleName) +import GHC.Driver.Session (DynFlags) + +-- These are used in GHC.Driver.Pipeline.Execute, but defined in terms of runPipeline +compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath +compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO () diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -0,0 +1,1267 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +#include "ghcplatform.h" + +{- Functions for providing the default interpretation of the 'TPhase' actions +-} +module GHC.Driver.Pipeline.Execute where + +import GHC.Prelude +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Catch +import GHC.Driver.Hooks +import Control.Monad.Trans.Reader +import GHC.Driver.Pipeline.Monad +import GHC.Driver.Pipeline.Phases +import GHC.Driver.Env hiding (Hsc) +import GHC.Unit.Module.Location +import GHC.Driver.Phases +import GHC.Unit.Module.Name ( ModuleName ) +import GHC.Unit.Types +import GHC.Types.SourceFile +import GHC.Unit.Module.Status +import GHC.Unit.Module.ModIface +import GHC.Linker.Types +import GHC.Driver.Backend +import GHC.Driver.Session +import GHC.Driver.CmdLine +import GHC.Unit.Module.ModSummary +import qualified GHC.LanguageExtensions as LangExt +import GHC.Types.SrcLoc +import GHC.Driver.Main +import GHC.Tc.Types +import GHC.Types.Error +import GHC.Driver.Errors.Types +import GHC.Fingerprint +import GHC.Utils.Logger +import GHC.Utils.TmpFs +import GHC.Platform +import Data.List (intercalate, isInfixOf) +import GHC.Unit.Env +import GHC.SysTools.Info +import GHC.Utils.Error +import Data.Maybe +import GHC.CmmToLlvm.Mangler +import GHC.SysTools +import GHC.Utils.Panic.Plain +import System.Directory +import System.FilePath +import GHC.Utils.Misc +import GHC.Utils.Outputable +import qualified Control.Exception as Exception +import GHC.Unit.Info +import GHC.Unit.State +import GHC.Unit.Home +import GHC.Data.Maybe +import GHC.Iface.Make +import Data.Time +import GHC.Driver.Config.Parser +import GHC.Parser.Header +import GHC.Data.StringBuffer +import GHC.Types.SourceError +import GHC.Unit.Finder +import GHC.Runtime.Loader +import Data.IORef +import GHC.Types.Name.Env +import GHC.Platform.Ways +import GHC.Platform.ArchOS +import GHC.CmmToLlvm.Base ( llvmVersionList ) +import {-# SOURCE #-} GHC.Driver.Pipeline (compileForeign, compileEmptyStub) +import GHC.Settings +import System.IO +import GHC.Linker.ExtraObj +import GHC.Linker.Dynamic +import Data.Version +import GHC.Utils.Panic + +newtype HookedUse a = HookedUse { runHookedUse :: (Hooks, PhaseHook) -> IO a } + deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch) via (ReaderT (Hooks, PhaseHook) IO) + +instance MonadUse TPhase HookedUse where + use fa = HookedUse $ \(hooks, (PhaseHook k)) -> + case runPhaseHook hooks of + Nothing -> k fa + Just (PhaseHook h) -> h fa + +-- | The default mechanism to run a pipeline, see Note [The Pipeline Monad] +runPipeline :: Hooks -> HookedUse a -> IO a +runPipeline hooks pipeline = runHookedUse pipeline (hooks, PhaseHook runPhase) + +-- | Default interpretation of each phase, in terms of IO. +runPhase :: TPhase out -> IO out +runPhase (T_Unlit pipe_env hsc_env inp_path) = do + out_path <- phaseOutputFilenameNew (Cpp HsSrcFile) pipe_env hsc_env Nothing + runUnlitPhase hsc_env inp_path out_path +runPhase (T_FileArgs hsc_env inp_path) = getFileArgs hsc_env inp_path +runPhase (T_Cpp pipe_env hsc_env inp_path) = do + out_path <- phaseOutputFilenameNew (HsPp HsSrcFile) pipe_env hsc_env Nothing + runCppPhase hsc_env inp_path out_path +runPhase (T_HsPp pipe_env hsc_env origin_path inp_path) = do + out_path <- phaseOutputFilenameNew (Hsc HsSrcFile) pipe_env hsc_env Nothing + runHsPpPhase hsc_env origin_path inp_path out_path +runPhase (T_HscRecomp pipe_env hsc_env fp hsc_src) = do + runHscPhase pipe_env hsc_env fp hsc_src +runPhase (T_Hsc hsc_env mod_sum) = runHscTcPhase hsc_env mod_sum +runPhase (T_HscPostTc hsc_env ms fer m mfi) = + runHscPostTcPhase hsc_env ms fer m mfi +runPhase (T_HscBackend pipe_env hsc_env mod_name hsc_src location x) = do + runHscBackendPhase pipe_env hsc_env mod_name hsc_src location x +runPhase (T_CmmCpp pipe_env hsc_env input_fn) = do + output_fn <- phaseOutputFilenameNew Cmm pipe_env hsc_env Nothing + doCpp (hsc_logger hsc_env) + (hsc_tmpfs hsc_env) + (hsc_dflags hsc_env) + (hsc_unit_env hsc_env) + False{-not raw-} + input_fn output_fn + return output_fn +runPhase (T_Cmm pipe_env hsc_env input_fn) = do + let dflags = hsc_dflags hsc_env + let next_phase = hscPostBackendPhase HsSrcFile (backend dflags) + output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing + mstub <- hscCompileCmmFile hsc_env input_fn output_fn + stub_o <- mapM (compileStub hsc_env) mstub + let foreign_os = (maybeToList stub_o) + return (foreign_os, output_fn) + +runPhase (T_Cc phase pipe_env hsc_env input_fn) = runCcPhase phase pipe_env hsc_env input_fn +runPhase (T_As cpp pipe_env hsc_env location input_fn) = do + runAsPhase cpp pipe_env hsc_env location input_fn +runPhase (T_LlvmOpt pipe_env hsc_env input_fn) = + runLlvmOptPhase pipe_env hsc_env input_fn +runPhase (T_LlvmLlc pipe_env hsc_env input_fn) = + runLlvmLlcPhase pipe_env hsc_env input_fn +runPhase (T_LlvmMangle pipe_env hsc_env input_fn) = + runLlvmManglePhase pipe_env hsc_env input_fn +runPhase (T_MergeForeign pipe_env hsc_env location input_fn fos) = + runMergeForeign pipe_env hsc_env location input_fn fos + +runLlvmManglePhase :: PipeEnv -> HscEnv -> FilePath -> IO [Char] +runLlvmManglePhase pipe_env hsc_env input_fn = do + let next_phase = As False + output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing + let dflags = hsc_dflags hsc_env + llvmFixupAsm (targetPlatform dflags) input_fn output_fn + return output_fn + +runMergeForeign :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> [FilePath] -> IO FilePath +runMergeForeign _pipe_env hsc_env _location input_fn foreign_os = do + if null foreign_os + then return input_fn + else do + -- Work around a binutil < 2.31 bug where you can't merge objects if the output file + -- is one of the inputs + new_o <- newTempName (hsc_logger hsc_env) + (hsc_tmpfs hsc_env) + (tmpDir (hsc_dflags hsc_env)) + TFL_CurrentModule "o" + copyFile input_fn new_o + let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + let tmpfs = hsc_tmpfs hsc_env + joinObjectFiles logger tmpfs dflags (new_o : foreign_os) input_fn + return input_fn + +runLlvmLlcPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath +runLlvmLlcPhase pipe_env hsc_env input_fn = do + -- Note [Clamping of llc optimizations] + -- + -- See #13724 + -- + -- we clamp the llc optimization between [1,2]. This is because passing -O0 + -- to llc 3.9 or llc 4.0, the naive register allocator can fail with + -- + -- Error while trying to spill R1 from class GPR: Cannot scavenge register + -- without an emergency spill slot! + -- + -- Observed at least with target 'arm-unknown-linux-gnueabihf'. + -- + -- + -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile + -- rts/HeapStackCheck.cmm + -- + -- llc -O3 '-mtriple=arm-unknown-linux-gnueabihf' -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s + -- 0 llc 0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40 + -- 1 llc 0x0000000102ae69a6 SignalHandler(int) + 358 + -- 2 libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26 + -- 3 libsystem_c.dylib 0x00007fffc226498b __vfprintf + 17876 + -- 4 llc 0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699 + -- 5 llc 0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381 + -- 6 llc 0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457 + -- 7 llc 0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20 + -- 8 llc 0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134 + -- 9 llc 0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498 + -- 10 llc 0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67 + -- 11 llc 0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920 + -- 12 llc 0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133 + -- 13 llc 0x000000010195bf0b main + 491 + -- 14 libdyld.dylib 0x00007fffc21e5235 start + 1 + -- Stack dump: + -- 0. Program arguments: llc -O3 -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s + -- 1. Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'. + -- 2. Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"' + -- + -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa + -- + let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + llvmOpts = case optLevel dflags of + 0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient. + 1 -> "-O1" + _ -> "-O2" + + defaultOptions = map GHC.SysTools.Option . concatMap words . snd + $ unzip (llvmOptions dflags) + optFlag = if null (getOpts dflags opt_lc) + then map GHC.SysTools.Option $ words llvmOpts + else [] + + next_phase <- if -- hidden debugging flag '-dno-llvm-mangler' to skip mangling + | gopt Opt_NoLlvmMangler dflags -> return (As False) + | otherwise -> return LlvmMangle + + output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing + + GHC.SysTools.runLlvmLlc logger dflags + ( optFlag + ++ defaultOptions + ++ [ GHC.SysTools.FileOption "" input_fn + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn + ] + ) + + return output_fn + +runLlvmOptPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath +runLlvmOptPhase pipe_env hsc_env input_fn = do + let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + let -- we always (unless -optlo specified) run Opt since we rely on it to + -- fix up some pretty big deficiencies in the code we generate + optIdx = max 0 $ min 2 $ optLevel dflags -- ensure we're in [0,2] + llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig dflags of + Just passes -> passes + Nothing -> panic ("runPhase LlvmOpt: llvm-passes file " + ++ "is missing passes for level " + ++ show optIdx) + defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst + $ unzip (llvmOptions dflags) + + -- don't specify anything if user has specified commands. We do this + -- for opt but not llc since opt is very specifically for optimisation + -- passes only, so if the user is passing us extra options we assume + -- they know what they are doing and don't get in the way. + optFlag = if null (getOpts dflags opt_lo) + then map GHC.SysTools.Option $ words llvmOpts + else [] + + output_fn <- phaseOutputFilenameNew LlvmLlc pipe_env hsc_env Nothing + + GHC.SysTools.runLlvmOpt logger dflags + ( optFlag + ++ defaultOptions ++ + [ GHC.SysTools.FileOption "" input_fn + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn] + ) + + return output_fn + + +runAsPhase :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath +runAsPhase with_cpp pipe_env hsc_env location input_fn = do + 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) + let (as_prog, get_asm_info) | backend dflags == LLVM + , platformOS platform == OSDarwin + = (GHC.SysTools.runClang, pure Clang) + | otherwise + = (GHC.SysTools.runAs, getAssemblerInfo logger dflags) + + asmInfo <- get_asm_info + + let cmdline_include_paths = includePaths dflags + let pic_c_flags = picCCOpts dflags + + output_fn <- phaseOutputFilenameNew StopLn pipe_env hsc_env location + + -- we create directories for the object file, because it + -- might be a hierarchical module. + createDirectoryIfMissing True (takeDirectory output_fn) + + let global_includes = [ GHC.SysTools.Option ("-I" ++ p) + | p <- includePathsGlobal cmdline_include_paths ] + let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p) + | p <- includePathsQuote cmdline_include_paths ++ + includePathsQuoteImplicit cmdline_include_paths] + let runAssembler inputFilename outputFilename + = withAtomicRename outputFilename $ \temp_outputFilename -> + as_prog + logger dflags + (local_includes ++ global_includes + -- See Note [-fPIC for assembler] + ++ map GHC.SysTools.Option pic_c_flags + -- See Note [Produce big objects on Windows] + ++ [ GHC.SysTools.Option "-Wa,-mbig-obj" + | platformOS (targetPlatform dflags) == OSMinGW32 + , not $ target32Bit (targetPlatform dflags) + ] + + -- We only support SparcV9 and better because V8 lacks an atomic CAS + -- instruction so we have to make sure that the assembler accepts the + -- instruction set. Note that the user can still override this + -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag + -- regardless of the ordering. + -- + -- This is a temporary hack. + ++ (if platformArch (targetPlatform dflags) == ArchSPARC + then [GHC.SysTools.Option "-mcpu=v9"] + else []) + ++ (if any (asmInfo ==) [Clang, AppleClang, AppleClang51] + then [GHC.SysTools.Option "-Qunused-arguments"] + else []) + ++ [ GHC.SysTools.Option "-x" + , if with_cpp + then GHC.SysTools.Option "assembler-with-cpp" + else GHC.SysTools.Option "assembler" + , GHC.SysTools.Option "-c" + , GHC.SysTools.FileOption "" inputFilename + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" temp_outputFilename + ]) + + debugTraceMsg logger 4 (text "Running the assembler") + runAssembler input_fn output_fn + + return output_fn + + +runCcPhase :: Phase -> PipeEnv -> HscEnv -> FilePath -> IO FilePath +runCcPhase cc_phase pipe_env hsc_env input_fn = do + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + let unit_env = hsc_unit_env hsc_env + let home_unit = hsc_home_unit hsc_env + let tmpfs = hsc_tmpfs hsc_env + let platform = ue_platform unit_env + let hcc = cc_phase `eqPhase` HCc + + let cmdline_include_paths = includePaths dflags + + -- HC files have the dependent packages stamped into them + pkgs <- if hcc then getHCFilePackages input_fn else return [] + + -- add package include paths even if we're just compiling .c + -- files; this is the Value Add(TM) that using ghc instead of + -- gcc gives you :) + ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env pkgs) + let pkg_include_dirs = collectIncludeDirs ps + let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] + (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) + let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] + (includePathsQuote cmdline_include_paths ++ + includePathsQuoteImplicit cmdline_include_paths) + let include_paths = include_paths_quote ++ include_paths_global + + -- pass -D or -optP to preprocessor when compiling foreign C files + -- (#16737). Doing it in this way is simpler and also enable the C + -- compiler to perform preprocessing and parsing in a single pass, + -- but it may introduce inconsistency if a different pgm_P is specified. + let more_preprocessor_opts = concat + [ ["-Xpreprocessor", i] + | not hcc + , i <- getOpts dflags opt_P + ] + + let gcc_extra_viac_flags = extraGccViaCFlags dflags + let pic_c_flags = picCCOpts dflags + + let verbFlags = getVerbFlags dflags + + -- cc-options are not passed when compiling .hc files. Our + -- hc code doesn't not #include any header files anyway, so these + -- options aren't necessary. + let pkg_extra_cc_opts + | hcc = [] + | otherwise = collectExtraCcOpts ps + + let framework_paths + | platformUsesFrameworks platform + = let pkgFrameworkPaths = collectFrameworksDirs ps + cmdlineFrameworkPaths = frameworkPaths dflags + in map ("-F"++) (cmdlineFrameworkPaths ++ pkgFrameworkPaths) + | otherwise + = [] + + let cc_opt | optLevel dflags >= 2 = [ "-O2" ] + | optLevel dflags >= 1 = [ "-O" ] + | otherwise = [] + + -- Decide next phase + let next_phase = As False + output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing + + let + more_hcc_opts = + -- on x86 the floating point regs have greater precision + -- than a double, which leads to unpredictable results. + -- By default, we turn this off with -ffloat-store unless + -- the user specified -fexcess-precision. + (if platformArch platform == ArchX86 && + not (gopt Opt_ExcessPrecision dflags) + then [ "-ffloat-store" ] + else []) ++ + + -- gcc's -fstrict-aliasing allows two accesses to memory + -- to be considered non-aliasing if they have different types. + -- This interacts badly with the C code we generate, which is + -- very weakly typed, being derived from C--. + ["-fno-strict-aliasing"] + + ghcVersionH <- getGhcVersionPathName dflags unit_env + + GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags ( + [ GHC.SysTools.FileOption "" input_fn + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn + ] + ++ map GHC.SysTools.Option ( + pic_c_flags + + -- Stub files generated for foreign exports references the runIO_closure + -- and runNonIO_closure symbols, which are defined in the base package. + -- These symbols are imported into the stub.c file via RtsAPI.h, and the + -- way we do the import depends on whether we're currently compiling + -- the base package or not. + ++ (if platformOS platform == OSMinGW32 && + isHomeUnitId home_unit baseUnitId + then [ "-DCOMPILING_BASE_PACKAGE" ] + else []) + + -- We only support SparcV9 and better because V8 lacks an atomic CAS + -- instruction. Note that the user can still override this + -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag + -- regardless of the ordering. + -- + -- This is a temporary hack. See #2872, commit + -- 5bd3072ac30216a505151601884ac88bf404c9f2 + ++ (if platformArch platform == ArchSPARC + then ["-mcpu=v9"] + else []) + + -- GCC 4.6+ doesn't like -Wimplicit when compiling C++. + ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx) + then ["-Wimplicit"] + else []) + + ++ (if hcc + then gcc_extra_viac_flags ++ more_hcc_opts + else []) + ++ verbFlags + ++ [ "-S" ] + ++ cc_opt + ++ [ "-include", ghcVersionH ] + ++ framework_paths + ++ include_paths + ++ more_preprocessor_opts + ++ pkg_extra_cc_opts + )) + + return output_fn + +-- This is where all object files get written from, for hs-boot and hsig files as well. +runHscBackendPhase :: PipeEnv + -> HscEnv + -> ModuleName + -> HscSource + -> ModLocation + -> HscBackendAction + -> IO ([FilePath], ModIface, Maybe Linkable, FilePath) +runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do + let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + o_file = ml_obj_file location -- The real object file + next_phase = hscPostBackendPhase src_flavour (backend dflags) + case result of + HscUpdate iface -> + do + case src_flavour of + HsigFile -> do + -- We need to create a REAL but empty .o file + -- because we are going to attempt to put it in a library + let input_fn = expectJust "runPhase" (ml_hs_file location) + basename = dropExtension input_fn + compileEmptyStub dflags hsc_env basename location mod_name + + -- In the case of hs-boot files, generate a dummy .o-boot + -- stamp file for the benefit of Make + HsBootFile -> touchObjectFile logger dflags o_file + HsSrcFile -> panic "HscUpdate not relevant for HscSrcFile" + + return ([], iface, Nothing, o_file) + HscRecomp { hscs_guts = cgguts, + hscs_mod_location = mod_location, + hscs_partial_iface = partial_iface, + hscs_old_iface_hash = mb_old_iface_hash + } + -> case backend dflags of + NoBackend -> panic "HscRecomp not relevant for NoBackend" + Interpreter -> do + -- In interpreted mode the regular codeGen backend is not run so we + -- generate a interface without codeGen info. + final_iface <- mkFullIface hsc_env partial_iface Nothing + hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location + + (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location + + stub_o <- case hasStub of + Nothing -> return [] + Just stub_c -> do + stub_o <- compileStub hsc_env stub_c + return [DotO stub_o] + + let hs_unlinked = [BCOs comp_bc spt_entries] + unlinked_time <- getCurrentTime + let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name) + (hs_unlinked ++ stub_o) + return ([], final_iface, Just linkable, panic "interpreter") + _ -> do + output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location) + (outputFilename, mStub, foreign_files, cg_infos) <- + hscGenHardCode hsc_env cgguts mod_location output_fn + final_iface <- mkFullIface hsc_env partial_iface (Just cg_infos) + + -- See Note [Writing interface files] + hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location + + stub_o <- mapM (compileStub hsc_env) mStub + foreign_os <- + mapM (uncurry (compileForeign hsc_env)) foreign_files + let fos = (maybe [] return stub_o ++ foreign_os) + + -- This is awkward, no linkable is produced here because we still + -- have some way to do before the object file is produced + -- In future we can split up the driver logic more so that this function + -- is in TPipeline and in this branch we can invoke the rest of the backend phase. + return (fos, final_iface, Nothing, outputFilename) + + +runUnlitPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath +runUnlitPhase hsc_env input_fn output_fn = do + let + -- escape the characters \, ", and ', but don't try to escape + -- Unicode or anything else (so we don't use Util.charToC + -- here). If we get this wrong, then in + -- GHC.HsToCore.Coverage.isGoodTickSrcSpan where we check that the filename in + -- a SrcLoc is the same as the source filenaame, the two will + -- look bogusly different. See test: + -- libraries/hpc/tests/function/subdir/tough2.hs + escape ('\\':cs) = '\\':'\\': escape cs + escape ('\"':cs) = '\\':'\"': escape cs + escape ('\'':cs) = '\\':'\'': escape cs + escape (c:cs) = c : escape cs + escape [] = [] + + let flags = [ -- The -h option passes the file name for unlit to + -- put in a #line directive + GHC.SysTools.Option "-h" + -- See Note [Don't normalise input filenames]. + , GHC.SysTools.Option $ escape input_fn + , GHC.SysTools.FileOption "" input_fn + , GHC.SysTools.FileOption "" output_fn + ] + + let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + GHC.SysTools.runUnlit logger dflags flags + + return output_fn + +getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, [Warn])) +getFileArgs hsc_env input_fn = do + let dflags0 = hsc_dflags hsc_env + parser_opts = initParserOpts dflags0 + src_opts <- getOptionsFromFile parser_opts input_fn + (dflags1, unhandled_flags, warns) + <- parseDynamicFilePragma dflags0 src_opts + checkProcessArgsResult unhandled_flags + return (dflags1, warns) + +runCppPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath +runCppPhase hsc_env input_fn output_fn = do + doCpp (hsc_logger hsc_env) + (hsc_tmpfs hsc_env) + (hsc_dflags hsc_env) + (hsc_unit_env hsc_env) + True{-raw-} + input_fn output_fn + return output_fn + + +runHscPhase :: PipeEnv + -> HscEnv + -> FilePath + -> HscSource + -> IO (HscEnv, ModSummary, HscRecompStatus) +runHscPhase pipe_env hsc_env0 input_fn src_flavour = do + let dflags0 = hsc_dflags hsc_env0 + PipeEnv{ src_basename=basename, + src_suffix=suff } = pipe_env + + -- we add the current directory (i.e. the directory in which + -- the .hs files resides) to the include path, since this is + -- what gcc does, and it's probably what you want. + let current_dir = takeDirectory basename + new_includes = addImplicitQuoteInclude paths [current_dir] + paths = includePaths dflags0 + dflags = dflags0 { includePaths = new_includes } + hsc_env = hscSetFlags dflags hsc_env0 + + + + -- gather the imports and module name + (hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do + buf <- hGetStringBuffer input_fn + let imp_prelude = xopt LangExt.ImplicitPrelude dflags + popts = initParserOpts dflags + eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff) + case eimps of + Left errs -> throwErrors (GhcPsMessage <$> errs) + Right (src_imps,imps, ghc_prim_imp, L _ mod_name) -> return + (Just buf, mod_name, imps, src_imps, ghc_prim_imp) + + -- Take -o into account if present + -- Very like -ohi, but we must *only* do this if we aren't linking + -- (If we're linking then the -o applies to the linked thing, not to + -- the object file for one module.) + -- Note the nasty duplication with the same computation in compileFile above + location <- getLocation pipe_env dflags src_flavour mod_name + let o_file = ml_obj_file location -- The real object file + hi_file = ml_hi_file location + hie_file = ml_hie_file location + dyn_o_file = dynamicOutputFile dflags o_file + + src_hash <- getFileHash (basename <.> suff) + hi_date <- modificationTimeIfExists hi_file + hie_date <- modificationTimeIfExists hie_file + o_mod <- modificationTimeIfExists o_file + dyn_o_mod <- modificationTimeIfExists dyn_o_file + + -- Tell the finder cache about this module + mod <- do + let home_unit = hsc_home_unit hsc_env + let fc = hsc_FC hsc_env + addHomeModuleToFinder fc home_unit mod_name location + + -- Make the ModSummary to hand to hscMain + let + mod_summary = ModSummary { ms_mod = mod, + ms_hsc_src = src_flavour, + ms_hspp_file = input_fn, + ms_hspp_opts = dflags, + ms_hspp_buf = hspp_buf, + ms_location = location, + ms_hs_hash = src_hash, + ms_obj_date = o_mod, + ms_dyn_obj_date = dyn_o_mod, + ms_parsed_mod = Nothing, + ms_iface_date = hi_date, + ms_hie_date = hie_date, + ms_ghc_prim_import = ghc_prim_imp, + ms_textual_imps = imps, + ms_srcimps = src_imps } + + + -- run the compiler! + let msg :: Messager + msg hsc_env _ what _ = oneShotMsg (hsc_logger hsc_env) what + plugin_hsc_env' <- 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. + -- See also Note [hsc_type_env_var hack] + type_env_var <- newIORef emptyNameEnv + let plugin_hsc_env = plugin_hsc_env' { hsc_type_env_var = Just (mod, type_env_var) } + + status <- hscRecompStatus (Just msg) plugin_hsc_env mod_summary + Nothing Nothing (1, 1) + + return (plugin_hsc_env, mod_summary, status) + +runHscTcPhase :: HscEnv -> ModSummary -> IO (FrontendResult, Messages GhcMessage) +runHscTcPhase = hscTypecheckAndGetWarnings + +runHscPostTcPhase :: + HscEnv + -> ModSummary + -> FrontendResult + -> Messages GhcMessage + -> Maybe Fingerprint + -> IO HscBackendAction +runHscPostTcPhase hsc_env mod_summary tc_result tc_warnings mb_old_hash = do + runHsc hsc_env $ do + hscDesugarAndSimplify mod_summary tc_result tc_warnings mb_old_hash + + +runHsPpPhase :: HscEnv -> FilePath -> FilePath -> FilePath -> IO FilePath +runHsPpPhase hsc_env orig_fn input_fn output_fn = do + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + GHC.SysTools.runPp logger dflags + ( [ GHC.SysTools.Option orig_fn + , GHC.SysTools.Option input_fn + , GHC.SysTools.FileOption "" output_fn + ] ) + return output_fn + +phaseOutputFilenameNew :: Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> IO FilePath +phaseOutputFilenameNew next_phase pipe_env hsc_env maybe_loc = do + let PipeEnv{stop_phase, src_basename, output_spec} = pipe_env + let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + tmpfs = hsc_tmpfs hsc_env + getOutputFilename logger tmpfs (stopPhaseToPhase stop_phase) output_spec + src_basename dflags next_phase maybe_loc + + +-- | Computes the next output filename for something in the compilation +-- pipeline. This is controlled by several variables: +-- +-- 1. 'Phase': the last phase to be run (e.g. 'stopPhase'). This +-- is used to tell if we're in the last phase or not, because +-- in that case flags like @-o@ may be important. +-- 2. 'PipelineOutput': is this intended to be a 'Temporary' or +-- 'Persistent' build output? Temporary files just go in +-- a fresh temporary name. +-- 3. 'String': what was the basename of the original input file? +-- 4. 'DynFlags': the obvious thing +-- 5. 'Phase': the phase we want to determine the output filename of. +-- 6. @Maybe ModLocation@: the 'ModLocation' of the module we're +-- compiling; this can be used to override the default output +-- of an object file. (TODO: do we actually need this?) +getOutputFilename + :: Logger + -> TmpFs + -> Phase + -> PipelineOutput + -> String + -> DynFlags + -> Phase -- next phase + -> Maybe ModLocation + -> IO FilePath +getOutputFilename logger tmpfs stop_phase output basename dflags next_phase maybe_location + | is_last_phase, Persistent <- output = persistent_fn + | is_last_phase, SpecificFile <- output = case outputFile dflags of + Just f -> return f + Nothing -> + panic "SpecificFile: No filename" + | keep_this_output = persistent_fn + | Temporary lifetime <- output = newTempName logger tmpfs (tmpDir dflags) lifetime suffix + | otherwise = newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule + suffix + where + hcsuf = hcSuf dflags + odir = objectDir dflags + osuf = objectSuf dflags + keep_hc = gopt Opt_KeepHcFiles dflags + keep_hscpp = gopt Opt_KeepHscppFiles dflags + keep_s = gopt Opt_KeepSFiles dflags + keep_bc = gopt Opt_KeepLlvmFiles dflags + + myPhaseInputExt HCc = hcsuf + myPhaseInputExt MergeForeign = osuf + myPhaseInputExt StopLn = osuf + myPhaseInputExt other = phaseInputExt other + + is_last_phase = next_phase `eqPhase` stop_phase + + -- sometimes, we keep output from intermediate stages + keep_this_output = + case next_phase of + As _ | keep_s -> True + LlvmOpt | keep_bc -> True + HCc | keep_hc -> True + HsPp _ | keep_hscpp -> True -- See #10869 + _other -> False + + suffix = myPhaseInputExt next_phase + + -- persistent object files get put in odir + persistent_fn + | StopLn <- next_phase = return odir_persistent + | otherwise = return persistent + + persistent = basename <.> suffix + + odir_persistent + | Just loc <- maybe_location = ml_obj_file loc + | Just d <- odir = (d persistent) + | otherwise = persistent + + +-- | LLVM Options. These are flags to be passed to opt and llc, to ensure +-- consistency we list them in pairs, so that they form groups. +llvmOptions :: DynFlags + -> [(String, String)] -- ^ pairs of (opt, llc) arguments +llvmOptions dflags = + [("-enable-tbaa -tbaa", "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ] + ++ [("-relocation-model=" ++ rmodel + ,"-relocation-model=" ++ rmodel) | not (null rmodel)] + ++ [("-stack-alignment=" ++ (show align) + ,"-stack-alignment=" ++ (show align)) | align > 0 ] + + -- Additional llc flags + ++ [("", "-mcpu=" ++ mcpu) | not (null mcpu) + , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ] + ++ [("", "-mattr=" ++ attrs) | not (null attrs) ] + ++ [("", "-target-abi=" ++ abi) | not (null abi) ] + + where target = platformMisc_llvmTarget $ platformMisc dflags + Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets $ llvmConfig dflags) + + -- Relocation models + rmodel | gopt Opt_PIC dflags = "pic" + | positionIndependent dflags = "pic" + | ways dflags `hasWay` WayDyn = "dynamic-no-pic" + | otherwise = "static" + + platform = targetPlatform dflags + + align :: Int + align = case platformArch platform of + ArchX86_64 | isAvxEnabled dflags -> 32 + _ -> 0 + + attrs :: String + attrs = intercalate "," $ mattr + ++ ["+sse42" | isSse4_2Enabled dflags ] + ++ ["+sse2" | isSse2Enabled platform ] + ++ ["+sse" | isSseEnabled platform ] + ++ ["+avx512f" | isAvx512fEnabled dflags ] + ++ ["+avx2" | isAvx2Enabled dflags ] + ++ ["+avx" | isAvxEnabled dflags ] + ++ ["+avx512cd"| isAvx512cdEnabled dflags ] + ++ ["+avx512er"| isAvx512erEnabled dflags ] + ++ ["+avx512pf"| isAvx512pfEnabled dflags ] + ++ ["+bmi" | isBmiEnabled dflags ] + ++ ["+bmi2" | isBmi2Enabled dflags ] + + abi :: String + abi = case platformArch (targetPlatform dflags) of + ArchRISCV64 -> "lp64d" + _ -> "" + +-- ----------------------------------------------------------------------------- +-- Running CPP + +-- | Run CPP +-- +-- 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 + let cmdline_include_paths = includePaths dflags + let unit_state = ue_units unit_env + pkg_include_dirs <- mayThrowUnitErr + (collectIncludeDirs <$> preloadUnitsInfo unit_env) + let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] + (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) + let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] + (includePathsQuote cmdline_include_paths ++ + includePathsQuoteImplicit cmdline_include_paths) + let include_paths = include_paths_quote ++ include_paths_global + + let verbFlags = getVerbFlags dflags + + let cpp_prog args | raw = GHC.SysTools.runCpp logger dflags args + | otherwise = GHC.SysTools.runCc Nothing logger tmpfs dflags + (GHC.SysTools.Option "-E" : args) + + let platform = targetPlatform dflags + targetArch = stringEncodeArch $ platformArch platform + targetOS = stringEncodeOS $ platformOS platform + isWindows = platformOS platform == OSMinGW32 + let target_defs = + [ "-D" ++ HOST_OS ++ "_BUILD_OS", + "-D" ++ HOST_ARCH ++ "_BUILD_ARCH", + "-D" ++ targetOS ++ "_HOST_OS", + "-D" ++ targetArch ++ "_HOST_ARCH" ] + -- remember, in code we *compile*, the HOST is the same our TARGET, + -- and BUILD is the same as our HOST. + + let io_manager_defs = + [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] ++ + [ "-D__IO_MANAGER_MIO__=1" ] + + let sse_defs = + [ "-D__SSE__" | isSseEnabled platform ] ++ + [ "-D__SSE2__" | isSse2Enabled platform ] ++ + [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] + + let avx_defs = + [ "-D__AVX__" | isAvxEnabled dflags ] ++ + [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ + [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++ + [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++ + [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ + [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] + + backend_defs <- getBackendDefs logger dflags + + let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] + -- Default CPP defines in Haskell source + ghcVersionH <- getGhcVersionPathName dflags unit_env + let hsSourceCppOpts = [ "-include", ghcVersionH ] + + -- MIN_VERSION macros + let uids = explicitUnits unit_state + pkgs = catMaybes (map (lookupUnit unit_state) uids) + mb_macro_include <- + if not (null pkgs) && gopt Opt_VersionMacros dflags + then do macro_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "h" + writeFile macro_stub (generatePackageVersionMacros pkgs) + -- Include version macros for every *exposed* package. + -- Without -hide-all-packages and with a package database + -- size of 1000 packages, it takes cpp an estimated 2 + -- milliseconds to process this file. See #10970 + -- comment 8. + return [GHC.SysTools.FileOption "-include" macro_stub] + else return [] + + cpp_prog ( map GHC.SysTools.Option verbFlags + ++ map GHC.SysTools.Option include_paths + ++ map GHC.SysTools.Option hsSourceCppOpts + ++ map GHC.SysTools.Option target_defs + ++ map GHC.SysTools.Option backend_defs + ++ map GHC.SysTools.Option th_defs + ++ map GHC.SysTools.Option hscpp_opts + ++ map GHC.SysTools.Option sse_defs + ++ map GHC.SysTools.Option avx_defs + ++ map GHC.SysTools.Option io_manager_defs + ++ mb_macro_include + -- Set the language mode to assembler-with-cpp when preprocessing. This + -- alleviates some of the C99 macro rules relating to whitespace and the hash + -- operator, which we tend to abuse. Clang in particular is not very happy + -- about this. + ++ [ GHC.SysTools.Option "-x" + , GHC.SysTools.Option "assembler-with-cpp" + , GHC.SysTools.Option input_fn + -- We hackily use Option instead of FileOption here, so that the file + -- name is not back-slashed on Windows. cpp is capable of + -- dealing with / in filenames, so it works fine. Furthermore + -- if we put in backslashes, cpp outputs #line directives + -- with *double* backslashes. And that in turn means that + -- our error messages get double backslashes in them. + -- In due course we should arrange that the lexer deals + -- with these \\ escapes properly. + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn + ]) + +getBackendDefs :: Logger -> DynFlags -> IO [String] +getBackendDefs logger dflags | backend dflags == LLVM = do + llvmVer <- figureLlvmVersion logger dflags + return $ case fmap llvmVersionList llvmVer of + Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ] + Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] + _ -> [] + where + format (major, minor) + | minor >= 100 = error "getBackendDefs: Unsupported minor version" + | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int + +getBackendDefs _ _ = + return [] + +-- | What phase to run after one of the backend code generators has run +hscPostBackendPhase :: HscSource -> Backend -> Phase +hscPostBackendPhase HsBootFile _ = StopLn +hscPostBackendPhase HsigFile _ = StopLn +hscPostBackendPhase _ bcknd = + case bcknd of + ViaC -> HCc + NCG -> As False + LLVM -> LlvmOpt + NoBackend -> StopLn + Interpreter -> StopLn + + +compileStub :: HscEnv -> FilePath -> IO FilePath +compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c + + +-- --------------------------------------------------------------------------- +-- join object files into a single relocatable object file, using ld -r + +{- +Note [Produce big objects on Windows] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The Windows Portable Executable object format has a limit of 32k sections, which +we tend to blow through pretty easily. Thankfully, there is a "big object" +extension, which raises this limit to 2^32. However, it must be explicitly +enabled in the toolchain: + + * the assembler accepts the -mbig-obj flag, which causes it to produce a + bigobj-enabled COFF object. + + * the linker accepts the --oformat pe-bigobj-x86-64 flag. Despite what the name + suggests, this tells the linker to produce a bigobj-enabled COFF object, no a + PE executable. + +We must enable bigobj output in a few places: + + * When merging object files (GHC.Driver.Pipeline.joinObjectFiles) + + * When assembling (GHC.Driver.Pipeline.runPhase (RealPhase As ...)) + +Unfortunately the big object format is not supported on 32-bit targets so +none of this can be used in that case. + + +Note [Merging object files for GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHCi can usually loads standard linkable object files using GHC's linker +implementation. However, most users build their projects with -split-sections, +meaning that such object files can have an extremely high number of sections. +As the linker must map each of these sections individually, loading such object +files is very inefficient. + +To avoid this inefficiency, we use the linker's `-r` flag and a linker script +to produce a merged relocatable object file. This file will contain a singe +text section section and can consequently be mapped far more efficiently. As +gcc tends to do unpredictable things to our linker command line, we opt to +invoke ld directly in this case, in contrast to our usual strategy of linking +via gcc. + +-} + +joinObjectFiles :: Logger -> TmpFs -> DynFlags -> [FilePath] -> FilePath -> IO () +joinObjectFiles logger tmpfs dflags o_files output_fn = do + let toolSettings' = toolSettings dflags + ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings' + osInfo = platformOS (targetPlatform dflags) + ld_r args = GHC.SysTools.runMergeObjects logger tmpfs dflags ( + -- See Note [Produce big objects on Windows] + concat + [ [GHC.SysTools.Option "--oformat", GHC.SysTools.Option "pe-bigobj-x86-64"] + | OSMinGW32 == osInfo + , not $ target32Bit (targetPlatform dflags) + ] + ++ map GHC.SysTools.Option ld_build_id + ++ [ GHC.SysTools.Option "-o", + GHC.SysTools.FileOption "" output_fn ] + ++ args) + + -- suppress the generation of the .note.gnu.build-id section, + -- which we don't need and sometimes causes ld to emit a + -- warning: + ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"] + | otherwise = [] + + if ldIsGnuLd + then do + script <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "ldscript" + cwd <- getCurrentDirectory + let o_files_abs = map (\x -> "\"" ++ (cwd x) ++ "\"") o_files + writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")" + ld_r [GHC.SysTools.FileOption "" script] + else if toolSettings_ldSupportsFilelist toolSettings' + then do + filelist <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "filelist" + writeFile filelist $ unlines o_files + ld_r [GHC.SysTools.Option "-filelist", + GHC.SysTools.FileOption "" filelist] + else + ld_r (map (GHC.SysTools.FileOption "") o_files) + +----------------------------------------------------------------------------- +-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file + +getHCFilePackages :: FilePath -> IO [UnitId] +getHCFilePackages filename = + Exception.bracket (openFile filename ReadMode) hClose $ \h -> do + l <- hGetLine h + case l of + '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest -> + return (map stringToUnitId (words rest)) + _other -> + return [] + + +linkDynLibCheck :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () +linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do + when (haveRtsOptsFlags dflags) $ + 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.") + linkDynLib logger tmpfs dflags unit_env o_files dep_units + + + +-- --------------------------------------------------------------------------- +-- Macros (cribbed from Cabal) + +generatePackageVersionMacros :: [UnitInfo] -> String +generatePackageVersionMacros pkgs = concat + -- Do not add any C-style comments. See #3389. + [ generateMacros "" pkgname version + | pkg <- pkgs + , let version = unitPackageVersion pkg + pkgname = map fixchar (unitPackageNameString pkg) + ] + +fixchar :: Char -> Char +fixchar '-' = '_' +fixchar c = c + +generateMacros :: String -> String -> Version -> String +generateMacros prefix name version = + concat + ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" + ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" + ," (major1) < ",major1," || \\\n" + ," (major1) == ",major1," && (major2) < ",major2," || \\\n" + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" + ,"\n\n" + ] + where + (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) + + +-- ----------------------------------------------------------------------------- +-- Misc. + + + +touchObjectFile :: Logger -> DynFlags -> FilePath -> IO () +touchObjectFile logger dflags path = do + createDirectoryIfMissing True $ takeDirectory path + GHC.SysTools.touch logger dflags "Touching object file" path + +-- | Find out path to @ghcversion.h@ file +getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath +getGhcVersionPathName dflags unit_env = do + candidates <- case ghcVersionFile dflags of + Just path -> return [path] + Nothing -> do + ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId]) + return (( "ghcversion.h") <$> collectIncludeDirs ps) + + found <- filterM doesFileExist candidates + case found of + [] -> throwGhcExceptionIO (InstallationError + ("ghcversion.h missing; tried: " + ++ intercalate ", " candidates)) + (x:_) -> return x + +-- Note [-fPIC for assembler] +-- When compiling .c source file GHC's driver pipeline basically +-- does the following two things: +-- 1. ${CC} -S 'PIC_CFLAGS' source.c +-- 2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S +-- +-- Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler? +-- Because on some architectures (at least sparc32) assembler also chooses +-- the relocation type! +-- Consider the following C module: +-- +-- /* pic-sample.c */ +-- int v; +-- void set_v (int n) { v = n; } +-- int get_v (void) { return v; } +-- +-- $ gcc -S -fPIC pic-sample.c +-- $ gcc -c pic-sample.s -o pic-sample.no-pic.o # incorrect binary +-- $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o # correct binary +-- +-- $ objdump -r -d pic-sample.pic.o > pic-sample.pic.o.od +-- $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od +-- $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od +-- +-- Most of architectures won't show any difference in this test, but on sparc32 +-- the following assembly snippet: +-- +-- sethi %hi(_GLOBAL_OFFSET_TABLE_-8), %l7 +-- +-- generates two kinds or relocations, only 'R_SPARC_PC22' is correct: +-- +-- 3c: 2f 00 00 00 sethi %hi(0), %l7 +-- - 3c: R_SPARC_PC22 _GLOBAL_OFFSET_TABLE_-0x8 +-- + 3c: R_SPARC_HI22 _GLOBAL_OFFSET_TABLE_-0x8 + +{- Note [Don't normalise input filenames] + +Summary + We used to normalise input filenames when starting the unlit phase. This + broke hpc in `--make` mode with imported literate modules (#2991). + +Introduction + 1) --main + When compiling a module with --main, GHC scans its imports to find out which + other modules it needs to compile too. It turns out that there is a small + difference between saying `ghc --make A.hs`, when `A` imports `B`, and + specifying both modules on the command line with `ghc --make A.hs B.hs`. In + the former case, the filename for B is inferred to be './B.hs' instead of + 'B.hs'. + + 2) unlit + When GHC compiles a literate haskell file, the source code first needs to go + through unlit, which turns it into normal Haskell source code. At the start + of the unlit phase, in `Driver.Pipeline.runPhase`, we call unlit with the + option `-h` and the name of the original file. We used to normalise this + filename using System.FilePath.normalise, which among other things removes + an initial './'. unlit then uses that filename in #line directives that it + inserts in the transformed source code. + + 3) SrcSpan + A SrcSpan represents a portion of a source code file. It has fields + linenumber, start column, end column, and also a reference to the file it + originated from. The SrcSpans for a literate haskell file refer to the + filename that was passed to unlit -h. + + 4) -fhpc + At some point during compilation with -fhpc, in the function + `GHC.HsToCore.Coverage.isGoodTickSrcSpan`, we compare the filename that a + `SrcSpan` refers to with the name of the file we are currently compiling. + For some reason I don't yet understand, they can sometimes legitimally be + different, and then hpc ignores that SrcSpan. + +Problem + When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate + module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the + start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2). + Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are + still compiling `./B.lhs`. Hpc thinks these two filenames are different (4), + doesn't include ticks for B, and we have unhappy customers (#2991). + +Solution + Do not normalise `input_fn` when starting the unlit phase. + +Alternative solution + Another option would be to not compare the two filenames on equality, but to + use System.FilePath.equalFilePath. That function first normalises its + arguments. The problem is that by the time we need to do the comparison, the + filenames have been turned into FastStrings, probably for performance + reasons, so System.FilePath.equalFilePath can not be used directly. + +Archeology + The call to `normalise` was added in a commit called "Fix slash + direction on Windows with the new filePath code" (c9b6b5e8). The problem + that commit was addressing has since been solved in a different manner, in a + commit called "Fix the filename passed to unlit" (1eedbc6b). So the + `normalise` is no longer necessary. +-} diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs --- a/compiler/GHC/Hs/Syn/Type.hs +++ b/compiler/GHC/Hs/Syn/Type.hs @@ -5,7 +5,7 @@ -- this task, see #12706, #15320, #16804, and #17331. module GHC.Hs.Syn.Type ( -- * Extracting types from HsExpr - lhsExprType, hsExprType, + lhsExprType, hsExprType, hsWrapperType, -- * Extracting types from HsSyn hsLitType, hsPatType, hsLPatType 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 @@ -30,6 +30,7 @@ import GHC.HsToCore.Monad import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs ) import GHC.HsToCore.Errors.Types +import GHC.Hs.Syn.Type ( hsExprType, hsWrapperType ) import GHC.Types.SourceText import GHC.Types.Name import GHC.Types.Name.Env @@ -302,7 +303,9 @@ dsExpr e@(HsApp _ fun arg) = do { fun' <- dsLExpr fun - ; dsWhenNoErrs (dsLExprNoLP arg) + -- See Note [Desugaring representation-polymorphic applications] + -- in GHC.HsToCore.Utils + ; dsWhenNoErrs (hsExprType e) (dsLExprNoLP arg) (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') } dsExpr e@(HsAppType {}) = dsHsWrapped e @@ -325,7 +328,7 @@ converting to core it must become a CO. -} -dsExpr (ExplicitTuple _ tup_args boxity) +dsExpr e@(ExplicitTuple _ tup_args boxity) = do { let go (lam_vars, args) (Missing (Scaled mult ty)) -- For every missing expression, we need -- another lambda in the desugaring. @@ -337,15 +340,20 @@ = do { core_expr <- dsLExprNoLP expr ; return (lam_vars, core_expr : args) } - ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args)) + -- See Note [Desugaring representation-polymorphic applications] + -- in GHC.HsToCore.Utils + ; dsWhenNoErrs (hsExprType e) (foldM go ([], []) (reverse tup_args)) -- The reverse is because foldM goes left-to-right (\(lam_vars, args) -> mkCoreLams lam_vars $ mkCoreTupBoxity boxity args) } -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make -dsExpr (ExplicitSum types alt arity expr) - = dsWhenNoErrs (dsLExprNoLP expr) (mkCoreUbxSum arity alt types) +dsExpr e@(ExplicitSum types alt arity expr) + -- See Note [Desugaring representation-polymorphic applications] + -- in GHC.HsToCore.Utils + = dsWhenNoErrs (hsExprType e) (dsLExprNoLP expr) + (mkCoreUbxSum arity alt types) dsExpr (HsPragE _ prag expr) = ds_prag_expr prag expr @@ -796,10 +804,21 @@ ; 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_msg n | n <- [1..] ]) - (\_ -> core_res_wrap (mkCoreApps fun wrapped_args)) } - -- Use mkCoreApps instead of mkApps: - -- unboxed types are possible with RebindableSyntax (#19883) + -- We need to compute the type of the desugared expression without + -- actually performing the desugaring, which could be problematic + -- in the presence of representation polymorphism. + -- See Note [Desugaring representation-polymorphic applications] + -- in GHC.HsToCore.Utils + expr_type = hsWrapperType res_wrap + (applyTypeToArgs (ppr fun) (exprType fun) wrapped_args) + ; dsWhenNoErrs expr_type + (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) + -- This won't be evaluated if there are any + -- representation-polymorphic arguments. + where mk_msg n = LevityCheckInSyntaxExpr (DsArgNum n) expr dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr" 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 @@ -224,17 +224,10 @@ -- another case, and a coercion.) -- The result is IO t, so wrap the result in an IO constructor = do { res <- resultWrapper io_res_ty - ; let extra_result_tys - = case res of - (Just ty,_) - | isUnboxedTupleType ty - -> let Just ls = tyConAppArgs_maybe ty in tail ls - _ -> [] - - return_result state anss + ; let return_result state anss = mkCoreUbxTup - (realWorldStatePrimTy : io_res_ty : extra_result_tys) - (state : anss) + [realWorldStatePrimTy, io_res_ty] + [state, anss] ; (ccall_res_ty, the_alt) <- mk_alt return_result res @@ -266,11 +259,10 @@ [the_alt] return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) where - return_result _ [ans] = ans - return_result _ _ = panic "return_result: expected single result" + return_result _ ans = ans -mk_alt :: (Expr Var -> [Expr Var] -> Expr Var) +mk_alt :: (Expr Var -> Expr Var -> Expr Var) -> (Maybe Type, Expr Var -> Expr Var) -> DsM (Type, CoreAlt) mk_alt return_result (Nothing, wrap_result) @@ -278,7 +270,7 @@ state_id <- newSysLocalDs Many realWorldStatePrimTy let the_rhs = return_result (Var state_id) - [wrap_result (panic "boxResult")] + (wrap_result (panic "boxResult")) ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy] the_alt = Alt (DataAlt (tupleDataCon Unboxed 1)) [state_id] the_rhs @@ -292,7 +284,7 @@ do { result_id <- newSysLocalDs Many prim_res_ty ; state_id <- newSysLocalDs Many realWorldStatePrimTy ; let the_rhs = return_result (Var state_id) - [wrap_result (Var result_id)] + (wrap_result (Var result_id)) ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty] the_alt = Alt (DataAlt (tupleDataCon Unboxed 2)) [state_id, result_id] the_rhs ; return (ccall_res_ty, the_alt) } 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 @@ -49,7 +49,7 @@ EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper, -- Representation polymorphism - dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs, + dsNoLevPoly, dsNoLevPolyExpr, -- Trace injection pprRuntimeTrace @@ -600,7 +600,7 @@ dsNoLevPoly :: Type -> LevityCheckProvenance -> DsM () -- See Note [Representation polymorphism checking] dsNoLevPoly ty provenance = - checkForLevPolyX (\ty -> failWithDs . DsLevityPolyInType ty) provenance ty + checkForLevPolyX (\ty -> diagnosticDs . DsLevityPolyInType ty) provenance ty -- | Check an expression for representation polymorphism, failing if it is -- representation-polymorphic. @@ -609,20 +609,6 @@ 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 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 - = do { (result, no_errs) <- askNoErrsDs thing_inside - ; return $ if no_errs - then mk_expr result - else unitExpr } -- | Inject a trace message into the compiled program. Whereas -- pprTrace prints out information *while compiling*, pprRuntimeTrace 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 @@ -305,7 +305,7 @@ ; inst_ds <- mapM repInstD instds ; deriv_ds <- mapM repStandaloneDerivD derivds ; fix_ds <- mapM repLFixD fixds - ; _ <- mapM no_default_decl defds + ; def_ds <- mapM repDefD defds ; for_ds <- mapM repForD fords ; _ <- mapM no_warn (concatMap (wd_warnings . unLoc) warnds) @@ -319,6 +319,7 @@ val_ds ++ catMaybes tycl_ds ++ role_ds ++ kisig_ds ++ (concat fix_ds) + ++ def_ds ++ inst_ds ++ rule_ds ++ for_ds ++ ann_ds ++ deriv_ds) }) ; @@ -332,8 +333,6 @@ where no_splice (L loc _) = notHandledL (locA loc) ThSplicesWithinDeclBrackets - no_default_decl (L loc decl) - = notHandledL (locA loc) (ThDefaultDeclarations decl) no_warn :: LWarnDecl GhcRn -> MetaM a no_warn (L loc (Warning _ thing _)) = notHandledL (locA loc) (ThWarningAndDeprecationPragmas thing) @@ -797,6 +796,12 @@ ; dec <- rep2 rep_fn [prec', name'] ; return (loc,dec) } ; mapM do_one names } + +repDefD :: LDefaultDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repDefD (L loc (DefaultDecl _ tys)) = do { tys1 <- repLTys tys + ; MkC tys2 <- coreListM typeTyConName tys1 + ; dec <- rep2 defaultDName [tys2] + ; return (locA loc, dec)} repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repRuleD (L loc (HsRule { rd_name = n 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 @@ -30,7 +30,7 @@ wrapBind, wrapBinds, mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs, - mkFailExpr, + mkFailExpr, dsWhenNoErrs, seqVar, @@ -981,6 +981,69 @@ mk_fail_msg dflags ctx pat = showPpr dflags $ text "Pattern match failure in" <+> pprStmtContext ctx <+> text "at" <+> ppr (getLocA pat) + +{- Note [Desugaring representation-polymorphic applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To desugar a function application + +> HsApp _ f e :: HsExpr GhcTc + +into Core, we need to know whether the argument e is lifted or unlifted, +in order to respect the let/app invariant. + (See Note [Core let/app invariant] in GHC.Core) + +This causes a problem when e is representation-polymorphic, as we aren't able +to determine whether to build a Core application + +> f_desugared e_desugared + +or a strict binding: + +> case e_desugared of { x -> f_desugared x } + +See GHC.Core.Make.mkValApp, which will call isUnliftedType, which panics +on a representation-polymorphic type. + +These representation-polymorphic applications are disallowed in source Haskell, +but we might want to continue desugaring as much as possible instead of +aborting as soon as we see such a problematic function application. + +When desugaring an expression which might have problems (such as disallowed +representation polymorphism as above), we check for errors first, and then: + + - if no problems were detected, desugar normally, + - if errors were found, we want to avoid desugaring, so we instead return + a runtime error Core expression which has the right type. + +This is what the function dsWhenNoErrs achieves: + +> dsWhenNoErrs result_ty thing_inside mk_expr + +We run thing_inside to check for errors. If there are no errors, we apply +mk_expr to desugar; otherwise, we construct a runtime error at type result_ty. + +Note that result_ty is only used when there is an error, and isn't inspected +otherwise; this means it's OK to pass something that can be a bit expensive +to compute. + +See #12709 for an example of why this machinery is necessary. +See also #14765 and #18149 for why it is important to return an expression +that has the proper type in case of an error. +-} + +-- | Runs the thing_inside. If there are no errors, use the provided +-- function to construct a Core expression, and return it. +-- Otherwise, return a runtime error, of the given type. +-- This is useful for doing a bunch of representation polymorphism checks +-- and then avoiding making a Core App. +-- See Note [Desugaring representation-polymorphic applications] +dsWhenNoErrs :: Type -> DsM a -> (a -> CoreExpr) -> DsM CoreExpr +dsWhenNoErrs result_ty thing_inside mk_expr + = do { (result, no_errs) <- askNoErrsDs thing_inside + ; if no_errs + then return $ mk_expr result + else mkErrorAppDs rUNTIME_ERROR_ID result_ty + (text "dsWhenNoErrs found errors") } {- ********************************************************************* * * 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 @@ -43,6 +43,7 @@ ( tcIfaceDecls, tcIfaceRules, tcIfaceInst, tcIfaceFamInst , tcIfaceAnnotations, tcIfaceCompleteMatches ) +import GHC.Driver.Config.Finder import GHC.Driver.Env import GHC.Driver.Errors.Types import GHC.Driver.Session @@ -318,9 +319,10 @@ = do hsc_env <- getTopEnv let fc = hsc_FC hsc_env let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags let units = hsc_units hsc_env let home_unit = hsc_home_unit hsc_env - res <- liftIO $ findImportedModule fc units home_unit dflags mod maybe_pkg + res <- liftIO $ findImportedModule fc fopts units home_unit mod maybe_pkg case res of Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) -- TODO: Make sure this error message is good @@ -879,8 +881,9 @@ Just h -> h return (Succeeded (iface, "")) else do + let fopts = initFinderOpts dflags -- Look for the file - mb_found <- liftIO (findExactModule fc dflags unit_state home_unit mod) + mb_found <- liftIO (findExactModule fc fopts unit_state home_unit mod) case mb_found of InstalledFound loc mod -> do -- Found file, so read it 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 @@ -13,6 +13,7 @@ import GHC.Prelude import GHC.Driver.Backend +import GHC.Driver.Config.Finder import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr @@ -452,11 +453,11 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface = do - res <- liftIO $ fmap sequence $ traverse (\(mb_pkg, L _ mod) -> + res <- liftIO $ traverse (\(mb_pkg, L _ mod) -> let reason = moduleNameString mod ++ " changed" - in classify reason <$> findImportedModule fc units home_unit dflags mod (mb_pkg)) + in classify reason <$> findImportedModule fc fopts units home_unit mod (mb_pkg)) (ms_imps summary ++ ms_srcimps summary) - case res of + case sequence (res ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of Left recomp -> return recomp Right es -> do let (hs, ps) = partitionEithers es @@ -467,6 +468,7 @@ return (res1 `mappend` res2) where dflags = hsc_dflags hsc_env + fopts = initFinderOpts dflags logger = hsc_logger hsc_env fc = hsc_FC hsc_env home_unit = hsc_home_unit hsc_env @@ -475,8 +477,14 @@ prev_dep_pkgs = sort (dep_direct_pkgs (mi_deps iface)) bkpk_units = map (("Signature",) . indefUnit . instUnitInstanceOf . moduleUnit) (requirementMerges units (moduleName (mi_module iface))) - implicit_deps = map ("Implicit",) (implicitPackageDeps dflags) + + -- GHC.Prim is very special and doesn't appear in ms_textual_imps but + -- ghc-prim will appear in the package dependencies still. In order to not confuse + -- the recompilation logic we need to not forget we imported GHC.Prim. + fake_ghc_prim_import = if homeUnitId home_unit == primUnitId + then Left (mkModuleName "GHC.Prim") + else Right ("GHC.Prim", primUnitId) classify _ (Found _ mod) 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 @@ -437,7 +437,7 @@ ; local_ccs - | WayProf `S.member` ways dflags + | ways dflags `hasWay` WayProf = collectCostCentres mod all_tidy_binds tidy_rules | otherwise = S.empty 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 @@ -23,7 +23,6 @@ import GHC.Utils.Logger import GHC.Utils.TmpFs -import qualified Data.Set as Set import System.FilePath linkDynLib :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () @@ -55,7 +54,7 @@ | osElfTarget os || osMachOTarget os , dynLibLoader dflags == SystemDependent , -- Only if we want dynamic libraries - WayDyn `Set.member` ways dflags + ways dflags `hasWay` WayDyn -- Only use RPath if we explicitly asked for it , useXLinkerRPath dflags os = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", 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 @@ -49,8 +49,8 @@ mkExtraObj :: Logger -> TmpFs -> DynFlags -> UnitState -> Suffix -> String -> IO FilePath mkExtraObj logger tmpfs dflags unit_state extn xs - = do cFile <- newTempName logger tmpfs dflags TFL_CurrentModule extn - oFile <- newTempName logger tmpfs dflags TFL_GhcSession "o" + = do cFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule extn + oFile <- newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession "o" writeFile cFile xs ccInfo <- liftIO $ getCompilerInfo logger dflags runCc Nothing logger tmpfs dflags 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 @@ -46,6 +46,7 @@ import GHC.Driver.Ppr import GHC.Driver.Config import GHC.Driver.Config.Diagnostic +import GHC.Driver.Config.Finder import GHC.Tc.Utils.Monad @@ -638,8 +639,8 @@ text " with" <+> compWay <+> text "using -osuf to set a different object file suffix." where compWay - | WayDyn `elem` ways dflags = text "-dynamic" - | WayProf `elem` ways dflags = text "-prof" + | ways dflags `hasWay` WayDyn = text "-dynamic" + | ways dflags `hasWay` WayProf = text "-prof" | otherwise = text "normal" ghciWay | hostIsDynamic = text "with -dynamic" @@ -754,7 +755,8 @@ let fc = hsc_FC hsc_env let home_unit = hsc_home_unit hsc_env let dflags = hsc_dflags hsc_env - mb_stuff <- findHomeModule fc home_unit dflags mod_name + let fopts = initFinderOpts dflags + mb_stuff <- findHomeModule fc fopts home_unit mod_name case mb_stuff of Found loc mod -> found loc mod _ -> no_obj mod_name @@ -797,13 +799,13 @@ ********************************************************************* -} -loadDecls :: Interp -> HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> CompiledByteCode -> IO () +loadDecls :: Interp -> HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> CompiledByteCode -> IO [(Name, ForeignHValue)] loadDecls interp hsc_env span cbc@CompiledByteCode{..} = do -- Initialise the linker (if it's not been done already) initLoaderState interp hsc_env -- Take lock for the actual work. - modifyLoaderState_ interp $ \pls0 -> do + modifyLoaderState interp $ \pls0 -> do -- Link the packages and modules required (pls, ok) <- loadDependencies interp hsc_env pls0 span needed_mods if failed ok @@ -819,7 +821,7 @@ nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs , itbl_env = ie } - return pls2 + return (pls2, nms_fhvs) where free_names = uniqDSetToList $ foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos @@ -952,7 +954,7 @@ let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ] let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ] (soFile, libPath , libName) <- - newTempLibName logger tmpfs dflags TFL_CurrentModule (platformSOExt platform) + newTempLibName logger tmpfs (tmpDir dflags) TFL_CurrentModule (platformSOExt platform) let dflags2 = dflags { -- We don't want the original ldInputs in 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 @@ -89,7 +89,7 @@ get_pkg_lib_path_opts l | osElfTarget (platformOS platform) && dynLibLoader dflags == SystemDependent && - WayDyn `elem` ways dflags + ways dflags `hasWay` WayDyn = let libpath = if gopt Opt_RelativeDynlibPaths dflags then "$ORIGIN" (l `makeRelativeTo` full_output_fn) @@ -110,7 +110,7 @@ in ["-L" ++ l] ++ rpathlink ++ rpath | osMachOTarget (platformOS platform) && dynLibLoader dflags == SystemDependent && - WayDyn `elem` ways dflags && + ways dflags `hasWay` WayDyn && useXLinkerRPath dflags (platformOS platform) = let libpath = if gopt Opt_RelativeDynlibPaths dflags then "@loader_path" @@ -123,7 +123,7 @@ if gopt Opt_SingleLibFolder dflags then do libs <- getLibs dflags unit_env dep_units - tmpDir <- newTempDir logger tmpfs dflags + tmpDir <- newTempDir logger tmpfs (tmpDir dflags) sequence_ [ copyFile lib (tmpDir basename) | (lib, basename) <- libs] return [ "-L" ++ tmpDir ] diff --git a/compiler/GHC/Linker/Unit.hs b/compiler/GHC/Linker/Unit.hs --- a/compiler/GHC/Linker/Unit.hs +++ b/compiler/GHC/Linker/Unit.hs @@ -50,7 +50,7 @@ -- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way. libraryDirsForWay :: Ways -> UnitInfo -> [String] libraryDirsForWay ws - | WayDyn `elem` ws = map ST.unpack . unitLibraryDynDirs + | hasWay ws WayDyn = map ST.unpack . unitLibraryDynDirs | otherwise = map ST.unpack . unitLibraryDirs getLibs :: DynFlags -> UnitEnv -> [UnitId] -> IO [(String,String)] diff --git a/compiler/GHC/Linker/Windows.hs b/compiler/GHC/Linker/Windows.hs --- a/compiler/GHC/Linker/Windows.hs +++ b/compiler/GHC/Linker/Windows.hs @@ -45,9 +45,9 @@ if not (gopt Opt_EmbedManifest dflags) then return [] else do - rc_filename <- newTempName logger tmpfs dflags TFL_CurrentModule "rc" + rc_filename <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "rc" rc_obj_filename <- - newTempName logger tmpfs dflags TFL_GhcSession (objectSuf dflags) + newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession (objectSuf dflags) writeFile rc_filename $ "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" 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 @@ -455,10 +455,7 @@ ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) } where localPatternSynonymErr :: TcRnMessage - localPatternSynonymErr - = TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname)) - 2 (text "Pattern synonym declarations are only valid at top level") + localPatternSynonymErr = TcRnIllegalPatSynDecl rdrname rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b) 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 @@ -448,7 +448,7 @@ addErr $ TcRnUnknownMessage $ mkPlainError noHints $ text "RebindableSyntax is required if OverloadedRecordUpdate is enabled." ; let punnedFields = [fld | (L _ fld) <- flds, hfbPun fld] - ; punsEnabled <-xoptM LangExt.RecordPuns + ; punsEnabled <-xoptM LangExt.NamedFieldPuns ; unless (null punnedFields || punsEnabled) $ addErr $ TcRnUnknownMessage $ mkPlainError noHints $ text "For this to work enable NamedFieldPuns." 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 @@ -270,7 +270,7 @@ rnSrcWarnDecls bndr_set decls' = do { -- check for duplicates ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups - in addErrAt (locA loc) (dupWarnDecl lrdr' rdr)) + in addErrAt (locA loc) (TcRnDuplicateWarningDecls lrdr' rdr)) warn_rdr_dups ; pairs_s <- mapM (addLocMA rn_deprec) decls ; return (WarnSome ((concat pairs_s))) } @@ -296,13 +296,6 @@ -- look for duplicates among the OccNames; -- we check that the names are defined above -- invt: the lists returned by findDupsEq always have at least two elements - -dupWarnDecl :: LocatedN RdrName -> RdrName -> TcRnMessage --- Located RdrName -> DeprecDecl RdrName -> SDoc -dupWarnDecl d rdr_name - = TcRnUnknownMessage $ mkPlainError noHints $ - vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name), - text "also at " <+> ppr (getLocA d)] {- ********************************************************* 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 @@ -571,9 +571,9 @@ Just (False, _) -> True _ -> False bad_import = - mod `elemModuleSet` qualifiedMods - && not is_qual + not is_qual && not has_import_list + && mod `elemModuleSet` qualifiedMods warning = vcat [ text "To ensure compatibility with future core libraries changes" @@ -860,9 +860,12 @@ ; traceRn "getLocalNonValBinders 2" (ppr avails) ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env + -- Force the field access so that tcg_env is not retained. The + -- selector thunk optimisation doesn't kick-in, see #20139 + ; let !old_field_env = tcg_field_env tcg_env -- Extend tcg_field_env with new fields (this used to be the -- work of extendRecordFieldEnv) - ; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds + field_env = extendNameEnvList old_field_env flds envs = (tcg_env { tcg_field_env = field_env }, tcl_env) ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env]) 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 @@ -36,9 +36,6 @@ -- Literals rnLit, rnOverLit, - - -- Pattern Error message that is also used elsewhere - patSigErr ) where -- ENH: thin imports to only what is necessary for patterns @@ -558,7 +555,7 @@ rnPatAndThen mk p@(ViewPat _ expr pat) = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns - ; checkErr vp_flag (badViewPat p) } + ; checkErr vp_flag (TcRnIllegalViewPattern p) } -- Because of the way we're arranging the recursive calls, -- this will be in the right context ; expr' <- liftCpsFV $ rnLExpr expr @@ -757,7 +754,7 @@ -- This is used for record construction and pattern-matching, but not updates. rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) - = do { pun_ok <- xoptM LangExt.RecordPuns + = do { pun_ok <- xoptM LangExt.NamedFieldPuns ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields ; let parent = guard disambig_ok >> mb_con ; flds1 <- mapM (rn_fld pun_ok parent) flds @@ -782,7 +779,7 @@ , hfbPun = pun })) = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl ; arg' <- if pun - then do { checkErr pun_ok (badPun (L loc lbl)) + then do { checkErr pun_ok (TcRnIllegalFieldPunning (L loc lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) ; return (L (noAnnSrcSpan loc) (mk_arg loc arg_rdr)) } @@ -809,7 +806,7 @@ ; checkErr dd_flag (needFlagDotDot ctxt) ; (rdr_env, lcl_env) <- getRdrEnvs ; con_fields <- lookupConstructorFields con - ; when (null con_fields) (addErr (badDotDotCon con)) + ; when (null con_fields) (addErr (TcRnIllegalWildcardsInConstructor con)) ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds) -- For constructor uses (but not patterns) @@ -866,14 +863,14 @@ :: [LHsRecUpdField GhcPs] -> RnM ([LHsRecUpdField GhcRn], FreeVars) rnHsRecUpdFields flds - = do { pun_ok <- xoptM LangExt.RecordPuns + = do { pun_ok <- xoptM LangExt.NamedFieldPuns ; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok dup_fields_ok) flds ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds -- Check for an empty record update e {} -- NB: don't complain about e { .. }, because rn_dotdot has done that already - ; when (null flds) $ addErr emptyUpdateErr + ; when (null flds) $ addErr TcRnEmptyRecordUpdate ; return (flds1, plusFVs fvss) } where @@ -888,7 +885,7 @@ -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head lookupRecFieldOcc_update dup_fields_ok lbl ; arg' <- if pun - then do { checkErr pun_ok (badPun (L loc lbl)) + then do { checkErr pun_ok (TcRnIllegalFieldPunning (L loc lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) ; return (L (noAnnSrcSpan loc) (HsVar noExtField @@ -925,35 +922,15 @@ getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) flds needFlagDotDot :: HsRecFieldContext -> TcRnMessage -needFlagDotDot ctxt = TcRnUnknownMessage $ mkPlainError noHints $ - vcat [text "Illegal `..' in record" <+> pprRFC ctxt, - text "Use RecordWildCards to permit this"] - -badDotDotCon :: Name -> TcRnMessage -badDotDotCon con - = TcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con) - , nest 2 (text "The constructor has no labelled fields") ] - -emptyUpdateErr :: TcRnMessage -emptyUpdateErr = TcRnUnknownMessage $ mkPlainError noHints $ text "Empty record update" - -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"] +needFlagDotDot = TcRnIllegalWildcardsInRecord . toRecordFieldPart dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> TcRnMessage -dupFieldErr ctxt dups - = TcRnUnknownMessage $ mkPlainError noHints $ - hsep [text "duplicate field name", - quotes (ppr (NE.head dups)), - text "in record", pprRFC ctxt] +dupFieldErr ctxt = TcRnDuplicateFieldName (toRecordFieldPart ctxt) -pprRFC :: HsRecFieldContext -> SDoc -pprRFC (HsRecFieldCon {}) = text "construction" -pprRFC (HsRecFieldPat {}) = text "pattern" -pprRFC (HsRecFieldUpd {}) = text "update" +toRecordFieldPart :: HsRecFieldContext -> RecordFieldPart +toRecordFieldPart (HsRecFieldCon n) = RecordFieldConstructor n +toRecordFieldPart (HsRecFieldPat n) = RecordFieldPattern n +toRecordFieldPart (HsRecFieldUpd {}) = RecordFieldUpdate {- ************************************************************************ @@ -968,7 +945,7 @@ -} rnLit :: HsLit p -> RnM () -rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c) +rnLit (HsChar _ c) = checkErr (inCharRange c) (TcRnCharLiteralOutOfRange c) rnLit _ = return () -- | Turn a Fractional-looking literal which happens to be an integer into an @@ -1022,26 +999,3 @@ ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name) , fvs1 `plusFV` fvs2) } else return ((lit', Nothing), fvs1) } - -{- -************************************************************************ -* * -\subsubsection{Errors} -* * -************************************************************************ --} - -patSigErr :: Outputable a => a -> SDoc -patSigErr ty - = (text "Illegal signature in pattern:" <+> ppr ty) - $$ nest 4 (text "Use ScopedTypeVariables to permit it") - -bogusCharError :: Char -> TcRnMessage -bogusCharError c - = TcRnUnknownMessage $ mkPlainError noHints $ - text "character literal out of range: '\\" <> char c <> char '\'' - -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/Utils.hs b/compiler/GHC/Rename/Utils.hs --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -163,9 +163,9 @@ check_shadow n | startsWithUnderscore occ = return () -- Do not report shadowing for "_x" -- See #3262 - | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)] + | Just n <- mb_local = complain (ShadowedNameProvenanceLocal (nameSrcLoc n)) | otherwise = do { gres' <- filterM is_shadowed_gre gres - ; complain (map pprNameProvenance gres') } + ; when (not . null $ gres') $ complain (ShadowedNameProvenanceGlobal gres') } where (loc,occ) = get_loc_occ n mb_local = lookupLocalRdrOcc local_env occ @@ -173,19 +173,14 @@ -- Make an Unqualified RdrName and look that up, so that -- we don't find any GREs that are in scope qualified-only - complain [] = return () - complain pp_locs = do - let msg = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnNameShadowing) - noHints - (shadowedNameWarn occ pp_locs) - addDiagnosticAt loc msg + complain provenance = addDiagnosticAt loc (TcRnShadowedName occ provenance) is_shadowed_gre :: GlobalRdrElt -> RnM Bool -- Returns False for record selectors that are shadowed, when -- punning or wild-cards are on (cf #2723) is_shadowed_gre gre | isRecFldGRE gre = do { dflags <- getDynFlags - ; return $ not (xopt LangExt.RecordPuns dflags + ; return $ not (xopt LangExt.NamedFieldPuns dflags || xopt LangExt.RecordWildCards dflags) } is_shadowed_gre _other = return True @@ -589,13 +584,6 @@ (flds, non_flds) = NE.partition isRecFldGRE gres num_flds = length flds num_non_flds = length non_flds - - -shadowedNameWarn :: OccName -> [SDoc] -> SDoc -shadowedNameWarn occ shadowed_locs - = sep [text "This binding for" <+> quotes (ppr occ) - <+> text "shadows the existing binding" <> plural shadowed_locs, - nest 2 (vcat shadowed_locs)] unknownSubordinateErr :: SDoc -> RdrName -> SDoc 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 @@ -51,6 +51,7 @@ , greMangledName, mkRdrQual ) import GHC.Unit.Finder ( findPluginModule, FindResult(..) ) +import GHC.Driver.Config.Finder ( initFinderOpts ) import GHC.Unit.Module ( Module, ModuleName ) import GHC.Unit.Module.ModIface @@ -258,11 +259,12 @@ -> IO (Maybe (Name, ModIface)) lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags let fc = hsc_FC hsc_env let units = hsc_units hsc_env let home_unit = hsc_home_unit hsc_env -- First find the unit the module resides in by searching exposed units and home modules - found_module <- findPluginModule fc units home_unit dflags mod_name + found_module <- findPluginModule fc fopts units home_unit mod_name case found_module of Found _ mod -> do -- Find the exports of the module diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs --- a/compiler/GHC/StgToByteCode.hs +++ b/compiler/GHC/StgToByteCode.hs @@ -11,7 +11,7 @@ -- -- | GHC.StgToByteCode: Generate bytecode from STG -module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen, stgExprToBCOs ) where +module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where import GHC.Prelude @@ -176,48 +176,6 @@ BcM and used when generating code for variable references. -} --- ----------------------------------------------------------------------------- --- Generating byte code for an expression - --- Returns: the root BCO for this expression -stgExprToBCOs :: HscEnv - -> Module - -> Type - -> StgRhs - -> IO UnlinkedBCO -stgExprToBCOs hsc_env this_mod expr_ty expr - = withTiming logger - (text "GHC.StgToByteCode"<+>brackets (ppr this_mod)) - (const ()) $ do - - -- the uniques are needed to generate fresh variables when we introduce new - -- let bindings for ticked expressions - us <- mkSplitUniqSupply 'y' - (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco) - <- runBc hsc_env us this_mod Nothing emptyVarEnv $ do - prepd_expr <- annBindingFreeVars <$> - bcPrepBind (StgNonRec dummy_id expr) - case prepd_expr of - (StgNonRec _ cg_expr) -> schemeR [] (idName dummy_id, cg_expr) - _ -> - panic "GHC.StgByteCode.stgExprToBCOs" - - when (notNull mallocd) - (panic "GHC.StgToByteCode.stgExprToBCOs: missing final emitBc?") - - 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 - profile = targetProfile dflags - interp = hscInterp hsc_env - -- we need an otherwise unused Id for bytecode generation - dummy_id = mkSysLocal (fsLit "BCO_toplevel") - (mkPseudoUniqueE 0) - Many - expr_ty {- Prepare the STG for bytecode generation: @@ -439,7 +397,10 @@ -- by just re-using the single top-level definition. So -- for the worker itself, we must allocate it directly. -- ioToBc (putStrLn $ "top level BCO") - emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, ENTER]) + let enter = if isUnliftedTypeKind (tyConResKind (dataConTyCon data_con)) + then RETURN_UNLIFTED P + else ENTER + emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, enter]) (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) | otherwise @@ -575,36 +536,36 @@ -- Returning an unlifted value. -- Heave it on the stack, SLIDE, and RETURN. -returnUnboxedAtom +returnUnliftedAtom :: StackDepth -> Sequel -> BCEnv -> StgArg -> BcM BCInstrList -returnUnboxedAtom d s p e = do +returnUnliftedAtom d s p e = do let reps = case e of StgLitArg lit -> typePrimRepArgs (literalType lit) StgVarArg i -> bcIdPrimReps i (push, szb) <- pushAtom d p e - ret <- returnUnboxedReps d s szb reps + ret <- returnUnliftedReps d s szb reps return (push `appOL` ret) --- return an unboxed value from the top of the stack -returnUnboxedReps +-- return an unlifted value from the top of the stack +returnUnliftedReps :: StackDepth -> Sequel -> ByteOff -- size of the thing we're returning -> [PrimRep] -- representations -> BcM BCInstrList -returnUnboxedReps d s szb reps = do +returnUnliftedReps d s szb reps = do profile <- getProfile let platform = profilePlatform profile non_void VoidRep = False non_void _ = True ret <- case filter non_void reps of -- use RETURN_UBX for unary representations - [] -> return (unitOL $ RETURN_UBX V) - [rep] -> return (unitOL $ RETURN_UBX (toArgRep platform rep)) + [] -> return (unitOL $ RETURN_UNLIFTED V) + [rep] -> return (unitOL $ RETURN_UNLIFTED (toArgRep platform rep)) -- otherwise use RETURN_TUPLE with a tuple descriptor nv_reps -> do let (tuple_info, args_offsets) = layoutTuple profile 0 (primRepCmmType platform) nv_reps @@ -633,19 +594,19 @@ massert (off == dd + szb) go (dd + szb) (push:pushes) cs pushes <- go d [] tuple_components - ret <- returnUnboxedReps d - s - (wordsToBytes platform $ tupleSize tuple_info) - (map atomPrimRep es) + ret <- returnUnliftedReps d + s + (wordsToBytes platform $ tupleSize tuple_info) + (map atomPrimRep es) return (mconcat pushes `appOL` ret) -- Compile code to apply the given expression to the remaining args -- on the stack, returning a HNF. schemeE :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList -schemeE d s p (StgLit lit) = returnUnboxedAtom d s p (StgLitArg lit) +schemeE d s p (StgLit lit) = returnUnliftedAtom d s p (StgLitArg lit) schemeE d s p (StgApp x []) - | isUnliftedType (idType x) = returnUnboxedAtom d s p (StgVarArg x) + | isUnliftedType (idType x) = returnUnliftedAtom d s p (StgVarArg x) -- Delegate tail-calls to schemeT. schemeE d s p e@(StgApp {}) = schemeT d s p e schemeE d s p e@(StgConApp {}) = schemeT d s p e @@ -884,7 +845,9 @@ platform <- profilePlatform <$> getProfile return (alloc_con `appOL` mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` - ENTER) + if isUnliftedTypeKind (tyConResKind (dataConTyCon con)) + then RETURN_UNLIFTED P + else ENTER) -- Case 4: Tail call of function schemeT d s p (StgApp fn args) @@ -952,7 +915,10 @@ platform <- profilePlatform <$> getProfile assert (sz == wordSize platform ) return () let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s) - return (push_fn `appOL` (slide `appOL` unitOL ENTER)) + enter = if isUnliftedType (idType fn) + then RETURN_UNLIFTED P + else ENTER + return (push_fn `appOL` (slide `appOL` unitOL enter)) do_pushes !d args reps = do let (push_apply, n, rest_of_reps) = findPushSeq reps (these_args, rest_of_args) = splitAt n args @@ -1049,9 +1015,9 @@ -- An unlifted value gets an extra info table pushed on top -- when it is returned. unlifted_itbl_size_b :: StackDepth - unlifted_itbl_size_b | isAlgCase = 0 - | ubx_tuple_frame = 3 * wordSize platform - | otherwise = wordSize platform + unlifted_itbl_size_b | ubx_tuple_frame = 3 * wordSize platform + | not (isUnliftedType bndr_ty) = 0 + | otherwise = wordSize platform (bndr_size, tuple_info, args_offsets) | ubx_tuple_frame = @@ -1072,7 +1038,7 @@ d_bndr = d + ret_frame_size_b + bndr_size - -- depth of stack after the extra info table for an unboxed return + -- depth of stack after the extra info table for an unlifted return -- has been pushed, if any. This is the stack depth at the -- continuation. d_alts = d + ret_frame_size_b + bndr_size + unlifted_itbl_size_b @@ -1082,7 +1048,7 @@ p_alts = Map.insert bndr d_bndr p bndr_ty = idType bndr - isAlgCase = not (isUnliftedType bndr_ty) + isAlgCase = isAlgType bndr_ty -- given an alt, return a discr and code for it. codeAlt (DEFAULT, _, rhs) @@ -1131,11 +1097,17 @@ [ (arg, stack_bot - ByteOff offset) | (NonVoid arg, offset) <- args_offsets ] p_alts + + -- unlifted datatypes have an infotable word on top + unpack = if isUnliftedType bndr_ty + then PUSH_L 1 `consOL` + UNPACK (trunc16W size) `consOL` + unitOL (SLIDE (trunc16W size) 1) + else unitOL (UNPACK (trunc16W size)) in do massert isAlgCase rhs_code <- schemeE stack_bot s p' rhs - return (my_discr alt, - unitOL (UNPACK (trunc16W size)) `appOL` rhs_code) + return (my_discr alt, unpack `appOL` rhs_code) where real_bndrs = filterOut isTyVar bndrs @@ -1224,7 +1196,7 @@ return (PUSH_ALTS_TUPLE alt_bco' tuple_info tuple_bco `consOL` scrut_code) else let push_alts - | isAlgCase + | not (isUnliftedType bndr_ty) = PUSH_ALTS alt_bco' | otherwise = let unlifted_rep = @@ -1619,7 +1591,7 @@ -- slide and return d_after_r_min_s = bytesToWords platform (d_after_r - s) wrapup = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW) - `snocOL` RETURN_UBX (toArgRep platform r_rep) + `snocOL` RETURN_UNLIFTED (toArgRep platform r_rep) --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $ return ( push_args `appOL` diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -206,7 +206,7 @@ (lit,decl) = if not isNCG || asString then mkByteStringCLit label str else mkFileEmbedLit label $ unsafePerformIO $ do - bFile <- newTempName logger tmpfs dflags TFL_CurrentModule ".dat" + bFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule ".dat" BS.writeFile bFile str return bFile emitDecl decl diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -318,6 +318,10 @@ -- x86-32 and 3 bits on x86-64. -- -- Also see Note [Tagging big families] in GHC.StgToCmm.Expr +-- +-- The interpreter also needs to be updated if we change the +-- tagging strategy. See Note [Data constructor dynamic tags] in +-- rts/Interpreter.c isSmallFamily :: Platform -> Int -> Bool isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform 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 @@ -1,4 +1,4 @@ - +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -16,6 +16,8 @@ shouldInlinePrimOp ) where +#include "MachDeps.h" + import GHC.Prelude hiding ((<*>)) import GHC.Platform @@ -340,6 +342,8 @@ StableNameToIntOp -> \[arg] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) + EqStablePtrOp -> \args -> opTranslate args (mo_wordEq platform) + ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2]) @@ -1080,6 +1084,10 @@ Word16ToInt16Op -> \args -> opNop args Int32ToWord32Op -> \args -> opNop args Word32ToInt32Op -> \args -> opNop args +#if WORD_SIZE_IN_BITS < 64 + Int64ToWord64Op -> \args -> opNop args + Word64ToInt64Op -> \args -> opNop args +#endif IntToWordOp -> \args -> opNop args WordToIntOp -> \args -> opNop args IntToAddrOp -> \args -> opNop args @@ -1332,6 +1340,54 @@ Word32LtOp -> \args -> opTranslate args (MO_U_Lt W32) Word32NeOp -> \args -> opTranslate args (MO_Ne W32) +#if WORD_SIZE_IN_BITS < 64 +-- Int64# signed ops + + Int64ToIntOp -> \args -> opTranslate64 args (\w -> MO_SS_Conv w (wordWidth platform)) MO_I64_ToI + IntToInt64Op -> \args -> opTranslate64 args (\w -> MO_SS_Conv (wordWidth platform) w) MO_I64_FromI + Int64NegOp -> \args -> opTranslate64 args MO_S_Neg MO_x64_Neg + Int64AddOp -> \args -> opTranslate64 args MO_Add MO_x64_Add + Int64SubOp -> \args -> opTranslate64 args MO_Sub MO_x64_Sub + Int64MulOp -> \args -> opTranslate64 args MO_Mul MO_x64_Mul + Int64QuotOp -> \args -> opTranslate64 args MO_S_Quot MO_I64_Quot + Int64RemOp -> \args -> opTranslate64 args MO_S_Rem MO_I64_Rem + + Int64SllOp -> \args -> opTranslate64 args MO_Shl MO_x64_Shl + Int64SraOp -> \args -> opTranslate64 args MO_S_Shr MO_I64_Shr + Int64SrlOp -> \args -> opTranslate64 args MO_U_Shr MO_W64_Shr + + Int64EqOp -> \args -> opTranslate64 args MO_Eq MO_x64_Eq + Int64GeOp -> \args -> opTranslate64 args MO_S_Ge MO_I64_Ge + Int64GtOp -> \args -> opTranslate64 args MO_S_Gt MO_I64_Gt + Int64LeOp -> \args -> opTranslate64 args MO_S_Le MO_I64_Le + Int64LtOp -> \args -> opTranslate64 args MO_S_Lt MO_I64_Lt + Int64NeOp -> \args -> opTranslate64 args MO_Ne MO_x64_Ne + +-- Word64# unsigned ops + + Word64ToWordOp -> \args -> opTranslate64 args (\w -> MO_UU_Conv w (wordWidth platform)) MO_W64_ToW + WordToWord64Op -> \args -> opTranslate64 args (\w -> MO_UU_Conv (wordWidth platform) w) MO_W64_FromW + Word64AddOp -> \args -> opTranslate64 args MO_Add MO_x64_Add + Word64SubOp -> \args -> opTranslate64 args MO_Sub MO_x64_Sub + Word64MulOp -> \args -> opTranslate64 args MO_Mul MO_x64_Mul + Word64QuotOp -> \args -> opTranslate64 args MO_U_Quot MO_W64_Quot + Word64RemOp -> \args -> opTranslate64 args MO_U_Rem MO_W64_Rem + + Word64AndOp -> \args -> opTranslate64 args MO_And MO_x64_And + Word64OrOp -> \args -> opTranslate64 args MO_Or MO_x64_Or + Word64XorOp -> \args -> opTranslate64 args MO_Xor MO_x64_Xor + Word64NotOp -> \args -> opTranslate64 args MO_Not MO_x64_Not + Word64SllOp -> \args -> opTranslate64 args MO_Shl MO_x64_Shl + Word64SrlOp -> \args -> opTranslate64 args MO_U_Shr MO_W64_Shr + + Word64EqOp -> \args -> opTranslate64 args MO_Eq MO_x64_Eq + Word64GeOp -> \args -> opTranslate64 args MO_U_Ge MO_W64_Ge + Word64GtOp -> \args -> opTranslate64 args MO_U_Gt MO_W64_Gt + Word64LeOp -> \args -> opTranslate64 args MO_U_Le MO_W64_Le + Word64LtOp -> \args -> opTranslate64 args MO_U_Lt MO_W64_Lt + Word64NeOp -> \args -> opTranslate64 args MO_Ne MO_x64_Ne +#endif + -- Char# ops CharEqOp -> \args -> opTranslate args (MO_Eq (wordWidth platform)) @@ -1408,20 +1464,6 @@ FloatToDoubleOp -> \args -> opTranslate args (MO_FF_Conv W32 W64) DoubleToFloatOp -> \args -> opTranslate args (MO_FF_Conv W64 W32) --- Word comparisons masquerading as more exotic things. - - SameMutVarOp -> \args -> opTranslate args (mo_wordEq platform) - SameMVarOp -> \args -> opTranslate args (mo_wordEq platform) - SameIOPortOp -> \args -> opTranslate args (mo_wordEq platform) - SameMutableArrayOp -> \args -> opTranslate args (mo_wordEq platform) - SameMutableByteArrayOp -> \args -> opTranslate args (mo_wordEq platform) - SameMutableArrayArrayOp -> \args -> opTranslate args (mo_wordEq platform) - SameSmallMutableArrayOp -> \args -> opTranslate args (mo_wordEq platform) - SameTVarOp -> \args -> opTranslate args (mo_wordEq platform) - EqStablePtrOp -> \args -> opTranslate args (mo_wordEq platform) --- See Note [Comparing stable names] - EqStableNameOp -> \args -> opTranslate args (mo_wordEq platform) - IntQuotRemOp -> \args -> opCallishHandledLater args $ if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) then Left (MO_S_QuotRem (wordWidth platform)) @@ -1649,6 +1691,18 @@ let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) emit stmt +#if WORD_SIZE_IN_BITS < 64 + opTranslate64 + :: [CmmExpr] + -> (Width -> MachOp) + -> CallishMachOp + -> PrimopCmmEmit + opTranslate64 args mkMop callish = + case platformWordSize platform of + PW4 -> opCallish args callish + PW8 -> opTranslate args $ mkMop W64 +#endif + -- | Basically a "manual" case, rather than one of the common repetitive forms -- above. The results are a parameter to the returned function so we know the -- choice of variant never depends on them. @@ -2025,17 +2079,6 @@ emit =<< mkCmmIfThenElse (eq aa zero) g1 g4 genericFabsOp _ _ _ = panic "genericFabsOp" - --- Note [Comparing stable names] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- A StableName# is actually a pointer to a stable name object (SNO) --- containing an index into the stable name table (SNT). We --- used to compare StableName#s by following the pointers to the --- SNOs and checking whether they held the same SNT indices. However, --- this is not necessary: there is a one-to-one correspondence --- between SNOs and entries in the SNT, so simple pointer equality --- does the trick. ------------------------------------------------------------------------------ -- Helpers for translating various minor variants of array indexing. 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 @@ -168,7 +168,7 @@ return (r,()) where getResponseFile args = do - fp <- newTempName logger tmpfs dflags TFL_CurrentModule "rsp" + fp <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "rsp" withFile fp WriteMode $ \h -> do #if defined(mingw32_HOST_OS) hSetEncoding h latin1 diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -9,6 +9,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -39,6 +40,8 @@ getPossibleDataCons, tyConInstArgTys ) where +#include "MachDeps.h" + import GHC.Prelude import GHC.Tc.Utils.Monad @@ -1490,10 +1493,12 @@ eqInt8_RDR , ltInt8_RDR , geInt8_RDR , gtInt8_RDR , leInt8_RDR , eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR , eqInt32_RDR , ltInt32_RDR , geInt32_RDR , gtInt32_RDR , leInt32_RDR , + eqInt64_RDR , ltInt64_RDR , geInt64_RDR , gtInt64_RDR , leInt64_RDR , eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR , eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR , eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR, eqWord32_RDR, ltWord32_RDR, geWord32_RDR, gtWord32_RDR, leWord32_RDR, + eqWord64_RDR, ltWord64_RDR, geWord64_RDR, gtWord64_RDR, leWord64_RDR, eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR , eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR , eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR, @@ -1547,6 +1552,12 @@ gtInt32_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt32#" ) geInt32_RDR = varQual_RDR gHC_PRIM (fsLit "geInt32#") +eqInt64_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt64#") +ltInt64_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt64#" ) +leInt64_RDR = varQual_RDR gHC_PRIM (fsLit "leInt64#") +gtInt64_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt64#" ) +geInt64_RDR = varQual_RDR gHC_PRIM (fsLit "geInt64#") + eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#") ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#") leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#") @@ -1571,6 +1582,12 @@ gtWord32_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord32#" ) geWord32_RDR = varQual_RDR gHC_PRIM (fsLit "geWord32#") +eqWord64_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord64#") +ltWord64_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord64#" ) +leWord64_RDR = varQual_RDR gHC_PRIM (fsLit "leWord64#") +gtWord64_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord64#" ) +geWord64_RDR = varQual_RDR gHC_PRIM (fsLit "geWord64#") + eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#") ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#") leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#") @@ -1598,7 +1615,6 @@ word32ToWord_RDR = varQual_RDR gHC_PRIM (fsLit "word32ToWord#") int32ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int32ToInt#") - {- ************************************************************************ * * @@ -2345,6 +2361,8 @@ , eqInt16_RDR , geInt16_RDR , gtInt16_RDR )) ,(int32PrimTy , (ltInt32_RDR , leInt32_RDR , eqInt32_RDR , geInt32_RDR , gtInt32_RDR )) + ,(int64PrimTy , (ltInt64_RDR , leInt64_RDR + , eqInt64_RDR , geInt64_RDR , gtInt64_RDR )) ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR )) ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR @@ -2353,6 +2371,8 @@ , eqWord16_RDR, geWord16_RDR, gtWord16_RDR )) ,(word32PrimTy, (ltWord32_RDR, leWord32_RDR , eqWord32_RDR, geWord32_RDR, gtWord32_RDR )) + ,(word64PrimTy, (ltWord64_RDR, leWord64_RDR + , eqWord64_RDR, geWord64_RDR, gtWord64_RDR )) ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR )) ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR 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 @@ -74,6 +74,7 @@ import GHC.Data.Bag import GHC.Data.FastString +import GHC.Utils.Trace (pprTraceUserWarning) import GHC.Data.List.SetOps ( equivClasses ) import GHC.Data.Maybe import qualified GHC.Data.Strict as Strict @@ -2521,8 +2522,8 @@ = vcat [ ppWhen lead_with_ambig $ text "Probable fix: use a type annotation to specify what" <+> pprQuotedList ambig_tvs <+> text "should be." - , text "These potential instance" <> plural unifiers - <+> text "exist:"] + , thisOrThese unifiers <+> text "potential instance" <> plural unifiers + <+> text "exist" <> singular unifiers <> text ":"] mb_patsyn_prov :: Maybe SDoc mb_patsyn_prov @@ -2944,8 +2945,11 @@ = vcat (map pp_one (getSkolemInfo (cec_encl ctxt) tvs)) where pp_one (UnkSkol, tvs) - = hang (pprQuotedList tvs) - 2 (is_or_are tvs "an" "unknown") + = vcat [ hang (pprQuotedList tvs) + 2 (is_or_are tvs "a" "(rigid, skolem)") + , nest 2 (text "of unknown origin") + , nest 2 (text "bound at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) + ] pp_one (RuntimeUnkSkol, tvs) = hang (pprQuotedList tvs) 2 (is_or_are tvs "an" "unknown runtime") @@ -2979,7 +2983,13 @@ getSkolemInfo [] tvs | all isRuntimeUnkSkol tvs = [(RuntimeUnkSkol, tvs)] -- #14628 - | otherwise = pprPanic "No skolem info:" (ppr tvs) + | otherwise = -- See https://gitlab.haskell.org/ghc/ghc/-/issues?label_name[]=No%20skolem%20info + pprTraceUserWarning msg [(UnkSkol,tvs)] + where + msg = text "No skolem info - we could not find the origin of the following variables" <+> ppr tvs + $$ text "This should not happen, please report it as a bug following the instructions at:" + $$ text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug" + getSkolemInfo (implic:implics) tvs | null tvs_here = getSkolemInfo implics tvs 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 @@ -185,10 +185,10 @@ ; let r_ty = mkTyVarTy r_tv ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty)) (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) $ \ _ _ -> - tcCheckMonoExpr pred pred_ty + ; (pred', fun') <- tcSyntaxOp IfThenElseOrigin fun + (map synKnownType [pred_ty, r_ty, r_ty]) + (mkCheckExpType r_ty) $ \ _ _ -> + tcCheckMonoExpr pred pred_ty ; b1' <- tcCmd env b1 res_ty ; b2' <- tcCmd env b2 res_ty 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 @@ -39,6 +39,7 @@ import GHC.Driver.Env import GHC.Driver.Hooks import GHC.Driver.Config.Diagnostic +import GHC.Driver.Config.Finder import GHC.Hs @@ -1211,7 +1212,7 @@ dflags <- getDynFlags logger <- getLogger tmpfs <- hsc_tmpfs <$> getTopEnv - liftIO $ newTempName logger tmpfs dflags TFL_GhcSession suffix + liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix qAddTopDecls thds = do l <- getSrcSpanM @@ -1264,7 +1265,8 @@ let fc = hsc_FC hsc_env let home_unit = hsc_home_unit hsc_env let dflags = hsc_dflags hsc_env - r <- liftIO $ findHomeModule fc home_unit dflags (mkModuleName plugin) + let fopts = initFinderOpts dflags + r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin) let err = hang (text "addCorePlugin: invalid plugin module " <+> text (show plugin) diff --git a/compiler/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs --- a/compiler/GHC/Tc/Plugin.hs +++ b/compiler/GHC/Tc/Plugin.hs @@ -77,6 +77,7 @@ import GHC.Core.TyCon import GHC.Core.DataCon import GHC.Core.Class +import GHC.Driver.Config.Finder import GHC.Driver.Env import GHC.Utils.Outputable import GHC.Core.Type @@ -102,7 +103,8 @@ let home_unit = hsc_home_unit hsc_env let units = hsc_units hsc_env let dflags = hsc_dflags hsc_env - tcPluginIO $ Finder.findImportedModule fc units home_unit dflags mod_name mb_pkg + let fopts = initFinderOpts dflags + tcPluginIO $ Finder.findImportedModule fc fopts units home_unit mod_name mb_pkg lookupOrig :: Module -> OccName -> TcPluginM Name lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod 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 @@ -1795,12 +1795,7 @@ -- 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 $ 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" - ])) + addErrTcS $ TcRnSimplifierTooManyIterations limit wc ; return wc } | unif_happened 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 @@ -153,7 +153,7 @@ | isWanted ev , Just ip_name <- isCallStackPred cls tys - , OccurrenceOf func <- ctLocOrigin loc + , isPushCallStackOrigin orig -- If we're given a CallStack constraint that arose from a function -- call, we need to push the current call-site onto the stack instead -- of solving it directly from a given. @@ -170,7 +170,8 @@ -- Then we solve the wanted by pushing the call-site -- onto the newly emitted CallStack - ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvExpr new_ev) + ; let ev_cs = EvCsPushCall (callStackOriginFS orig) + (ctLocSpan loc) (ctEvExpr new_ev) ; solveCallStack ev ev_cs ; canClass new_ev cls tys @@ -184,6 +185,7 @@ where has_scs cls = not (null (classSCTheta cls)) loc = ctEvLoc ev + orig = ctLocOrigin loc pred = ctEvPred ev fds = classHasFds cls 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 @@ -1981,7 +1981,8 @@ ; return (poly_meth_id, local_meth_id) } where sel_name = idName sel_id - sel_occ = nameOccName sel_name + -- Force so that a thunk doesn't end up in a Name (#19619) + !sel_occ = nameOccName sel_name local_meth_ty = instantiateMethod clas sel_id inst_tys poly_meth_ty = mkSpecSigmaTy tyvars theta local_meth_ty theta = map idType dfun_ev_vars 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 @@ -23,7 +23,7 @@ import GHC.Hs import GHC.Tc.Gen.Pat import GHC.Core.Multiplicity -import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType ) +import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType, isManyDataConTy ) import GHC.Core.TyCo.Subst( extendTvSubstWithClone ) import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad @@ -389,6 +389,10 @@ univ_tvs = binderVars univ_bndrs ex_tvs = binderVars ex_bndrs + -- Pattern synonyms currently cannot be linear (#18806) + ; checkTc (all (isManyDataConTy . scaledMult) arg_tys) $ + TcRnLinearPatSyn sig_body_ty + -- Skolemise the quantified type variables. This is necessary -- in order to check the actual pattern type against the -- expected type. Even though the tyvars in the type are @@ -513,8 +517,8 @@ GHC.Tc.Utils.Instantiate.tcInstSkolTyVarsX except that the latter does cloning. -[Pattern synonyms and higher rank types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Pattern synonyms and higher rank types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data T = MkT (forall a. a->a) 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 @@ -21,7 +21,6 @@ import GHC.Core.Utils import GHC.Types.SrcLoc -import GHC.Types.Name import GHC.Types.TyThing -- Used with Opt_DeferTypeErrors @@ -71,5 +70,5 @@ return (pushCS nameExpr locExpr (Cast tm ip_co)) case cs of - EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm - EvCsEmpty -> return emptyCS + EvCsPushCall fs loc tm -> mkPush fs loc tm + EvCsEmpty -> return emptyCS 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 @@ -19,6 +19,8 @@ import GHC.Prelude + +import GHC.Driver.Config.Finder import GHC.Driver.Env import GHC.Driver.Ppr import GHC.Driver.Session @@ -322,7 +324,7 @@ implicitRequirements' hsc_env normal_imports = fmap concat $ forM normal_imports $ \(mb_pkg, L _ imp) -> do - found <- findImportedModule fc units home_unit dflags imp mb_pkg + found <- findImportedModule fc fopts units home_unit imp mb_pkg case found of Found _ mod | not (isHomeModule home_unit mod) -> return (uniqDSetToList (moduleFreeHoles mod)) @@ -332,6 +334,7 @@ home_unit = hsc_home_unit hsc_env units = hsc_units hsc_env dflags = hsc_dflags hsc_env + fopts = initFinderOpts dflags -- | Like @implicitRequirements'@, but returns either the module name, if it is -- a free hole, or the instantiated unit the imported module is from, so that @@ -347,10 +350,11 @@ home_unit = hsc_home_unit hsc_env units = hsc_units hsc_env dflags = hsc_dflags hsc_env + fopts = initFinderOpts dflags go acc [] = pure acc go (accL, accR) ((mb_pkg, L _ imp):imports) = do - found <- findImportedModule fc units home_unit dflags imp mb_pkg + found <- findImportedModule fc fopts units home_unit imp mb_pkg let acc' = case found of Found _ mod | not (isHomeModule home_unit mod) -> case moduleUnit mod of 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 @@ -588,7 +588,10 @@ = do { loc <- getSrcSpanM ; uniq <- newUnique ; let old_name = tyVarName tycovar - new_name = mkInternalName uniq (getOccName old_name) loc + -- Force so we don't retain reference to the old name and id + -- See (#19619) for more discussion + !old_occ_name = getOccName old_name + new_name = mkInternalName uniq old_occ_name loc new_kind = substTyUnchecked subst (tyVarKind tycovar) new_tcv = mk_tcv new_name new_kind subst1 = extendTCvSubstWithClone subst tycovar new_tcv @@ -844,8 +847,15 @@ tcExtendLocalInstEnv dfuns thing_inside = do { traceDFuns dfuns ; env <- getGblEnv + -- Force the access to the TcgEnv so it isn't retained. + -- During auditing it is much easier to observe in -hi profiles if + -- there are a very small number of TcGblEnv. Keeping a TcGblEnv + -- alive is quite dangerous because it contains reference to many + -- large data structures. + ; let !init_inst_env = tcg_inst_env env + !init_insts = tcg_insts env ; (inst_env', cls_insts') <- foldlM addLocalInst - (tcg_inst_env env, tcg_insts env) + (init_inst_env, init_insts) dfuns ; let env' = env { tcg_insts = cls_insts' , tcg_inst_env = inst_env' } 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 @@ -711,29 +711,41 @@ ************************************************************************ -} --- Note [INLINE conditional tracing utilities] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~ --- In general we want to optimise for the case where tracing is not enabled. --- To ensure this happens, we ensure that traceTc and friends are inlined; this --- ensures that the allocation of the document can be pushed into the tracing --- path, keeping the non-traced path free of this extraneous work. For --- instance, instead of --- --- let thunk = ... --- in if doTracing --- then emitTraceMsg thunk --- else return () --- --- where the conditional is buried in a non-inlined utility function (e.g. --- traceTc), we would rather have: --- --- if doTracing --- then let thunk = ... --- in emitTraceMsg thunk --- else return () --- --- See #18168. --- +{- Note [INLINE conditional tracing utilities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we want to optimise for the case where tracing is not enabled. +To ensure this happens, we ensure that traceTc and friends are inlined; this +ensures that the allocation of the document can be pushed into the tracing +path, keeping the non-traced path free of this extraneous work. For +instance, if we don't inline traceTc, we'll get + + let stuff_to_print = ... + in traceTc "wombat" stuff_to_print + +and the stuff_to_print thunk will be allocated in the "hot path", regardless +of tracing. But if we INLINE traceTc we get + + let stuff_to_print = ... + in if doTracing + then emitTraceMsg "wombat" stuff_to_print + else return () + +and then we float in: + + if doTracing + then let stuff_to_print = ... + in emitTraceMsg "wombat" stuff_to_print + else return () + +Now stuff_to_print is allocated only in the "cold path". + +Moreover, on the "cold" path, after the conditional, we want to inline +as /little/ as possible. Performance doesn't matter here, and we'd like +to bloat the caller's code as little as possible. So we put a NOINLINE +on 'emitTraceMsg' + +See #18168. +-} -- Typechecker trace traceTc :: String -> SDoc -> TcRn () diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -226,6 +226,10 @@ ; returnJustLA (Hs.SigD noExtField (FixSig noAnn (FixitySig noExtField [nm'] (cvtFixity fx)))) } +cvtDec (TH.DefaultD tys) + = do { tys' <- traverse cvtType tys + ; returnJustLA (Hs.DefD noExtField $ DefaultDecl noAnn tys') } + cvtDec (PragmaD prag) = cvtPragmaD prag diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs deleted file mode 100644 --- a/compiler/GHC/Unit/Finder.hs +++ /dev/null @@ -1,625 +0,0 @@ -{- -(c) The University of Glasgow, 2000-2006 - --} - - -{-# LANGUAGE FlexibleContexts #-} - --- | Module finder -module GHC.Unit.Finder ( - FindResult(..), - InstalledFindResult(..), - FinderCache, - initFinderCache, - flushFinderCaches, - findImportedModule, - findPluginModule, - findExactModule, - findHomeModule, - findExposedPackageModule, - mkHomeModLocation, - mkHomeModLocation2, - mkHiOnlyModLocation, - mkHiPath, - mkObjPath, - addHomeModuleToFinder, - uncacheModule, - mkStubPaths, - - findObjectLinkableMaybe, - findObjectLinkable, - - -- Hash cache - lookupFileCache - - ) where - -import GHC.Prelude - -import GHC.Driver.Session - -import GHC.Platform.Ways - -import GHC.Builtin.Names ( gHC_PRIM ) - -import GHC.Unit.Types -import GHC.Unit.Module -import GHC.Unit.Home -import GHC.Unit.State -import GHC.Unit.Finder.Types - -import GHC.Data.FastString -import GHC.Data.Maybe ( expectJust ) -import qualified GHC.Data.ShortText as ST - -import GHC.Utils.Misc -import GHC.Utils.Outputable as Outputable -import GHC.Utils.Panic - -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 -type BaseName = String -- Basename of file - --- ----------------------------------------------------------------------------- --- The Finder - --- The Finder provides a thin filesystem abstraction to the rest of --- the compiler. For a given module, it can tell you where the --- source, interface, and object files for that module live. - --- It does *not* know which particular package a module lives in. Use --- Packages.lookupModuleInAllUnits for that. - --- ----------------------------------------------------------------------------- --- The finder's cache - - -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; also flush the file hash --- cache -flushFinderCaches :: FinderCache -> HomeUnit -> IO () -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 = - atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ()) - -removeFromFinderCache :: FinderCache -> InstalledModule -> IO () -removeFromFinderCache (FinderCache ref _) key = - atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ()) - -lookupFinderCache :: FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult) -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 - --- | Locate a module that was imported by the user. We have the --- module's name, and possibly a package name. Without a package --- name, this function will use the search path and the known exposed --- packages to find the module, if a package is specified then only --- that package is searched for the module. - -findImportedModule - :: FinderCache - -> UnitState - -> HomeUnit - -> DynFlags - -> ModuleName - -> Maybe FastString - -> IO FindResult -findImportedModule fc units home_unit dflags mod_name mb_pkg = - case mb_pkg of - Nothing -> unqual_import - Just pkg | pkg == fsLit "this" -> home_import -- "this" is special - | otherwise -> pkg_import - where - home_import = findHomeModule fc home_unit dflags mod_name - - pkg_import = findExposedPackageModule fc units dflags mod_name mb_pkg - - unqual_import = home_import - `orIfNotFound` - findExposedPackageModule fc units dflags mod_name Nothing - --- | Locate a plugin module requested by the user, for a compiler --- plugin. This consults the same set of exposed packages as --- 'findImportedModule', unless @-hide-all-plugin-packages@ or --- @-plugin-package@ are specified. -findPluginModule :: FinderCache -> UnitState -> HomeUnit -> DynFlags -> ModuleName -> IO FindResult -findPluginModule fc units home_unit dflags mod_name = - findHomeModule fc home_unit dflags mod_name - `orIfNotFound` - findExposedPluginPackageModule fc units dflags mod_name - --- | Locate a specific 'Module'. The purpose of this function is to --- create a 'ModLocation' for a given 'Module', that is to find out --- where the files associated with this module live. It is used when --- reading the interface for a module mentioned by another interface, --- for example (a "system import"). - -findExactModule :: FinderCache -> DynFlags -> UnitState -> HomeUnit -> InstalledModule -> IO InstalledFindResult -findExactModule fc dflags unit_state home_unit mod = do - if isHomeInstalledModule home_unit mod - then findInstalledHomeModule fc dflags home_unit (moduleName mod) - else findPackageModule fc unit_state dflags mod - --- ----------------------------------------------------------------------------- --- Helpers - --- | Given a monadic actions @this@ and @or_this@, first execute --- @this@. If the returned 'FindResult' is successful, return --- it; otherwise, execute @or_this@. If both failed, this function --- also combines their failure messages in a reasonable way. -orIfNotFound :: Monad m => m FindResult -> m FindResult -> m FindResult -orIfNotFound this or_this = do - res <- this - case res of - NotFound { fr_paths = paths1, fr_mods_hidden = mh1 - , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 } - -> do res2 <- or_this - case res2 of - NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2 - , fr_pkgs_hidden = ph2, fr_unusables = u2 - , fr_suggestions = s2 } - -> return (NotFound { fr_paths = paths1 ++ paths2 - , fr_pkg = mb_pkg2 -- snd arg is the package search - , fr_mods_hidden = mh1 ++ mh2 - , fr_pkgs_hidden = ph1 ++ ph2 - , fr_unusables = u1 ++ u2 - , fr_suggestions = s1 ++ s2 }) - _other -> return res2 - _other -> return res - --- | Helper function for 'findHomeModule': this function wraps an IO action --- which would look up @mod_name@ in the file system (the home package), --- and first consults the 'hsc_FC' cache to see if the lookup has already --- been done. Otherwise, do the lookup (with the IO action) and save --- the result in the finder cache and the module location cache (if it --- was successful.) -homeSearchCache :: FinderCache -> HomeUnit -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult -homeSearchCache fc home_unit mod_name do_this = do - let mod = mkHomeInstalledModule home_unit mod_name - modLocationCache fc mod do_this - -findExposedPackageModule :: FinderCache -> UnitState -> DynFlags -> ModuleName -> Maybe FastString -> IO FindResult -findExposedPackageModule fc units dflags mod_name mb_pkg = - findLookupResult fc dflags - $ lookupModuleWithSuggestions units mod_name mb_pkg - -findExposedPluginPackageModule :: FinderCache -> UnitState -> DynFlags -> ModuleName -> IO FindResult -findExposedPluginPackageModule fc units dflags mod_name = - findLookupResult fc dflags - $ lookupPluginModuleWithSuggestions units mod_name Nothing - -findLookupResult :: FinderCache -> DynFlags -> LookupResult -> IO FindResult -findLookupResult fc dflags r = case r of - LookupFound m pkg_conf -> do - let im = fst (getModuleInstantiation m) - r' <- findPackageModule_ fc dflags im pkg_conf - case r' of - -- TODO: ghc -M is unlikely to do the right thing - -- with just the location of the thing that was - -- instantiated; you probably also need all of the - -- implicit locations from the instances - InstalledFound loc _ -> return (Found loc m) - InstalledNoPackage _ -> return (NoPackage (moduleUnit m)) - InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnit m) - , fr_pkgs_hidden = [] - , fr_mods_hidden = [] - , fr_unusables = [] - , fr_suggestions = []}) - LookupMultiple rs -> - return (FoundMultiple rs) - LookupHidden pkg_hiddens mod_hiddens -> - return (NotFound{ fr_paths = [], fr_pkg = Nothing - , fr_pkgs_hidden = map (moduleUnit.fst) pkg_hiddens - , fr_mods_hidden = map (moduleUnit.fst) mod_hiddens - , fr_unusables = [] - , fr_suggestions = [] }) - LookupUnusable unusable -> - let unusables' = map get_unusable unusable - get_unusable (m, ModUnusable r) = (moduleUnit m, r) - get_unusable (_, r) = - pprPanic "findLookupResult: unexpected origin" (ppr r) - in return (NotFound{ fr_paths = [], fr_pkg = Nothing - , fr_pkgs_hidden = [] - , fr_mods_hidden = [] - , fr_unusables = unusables' - , fr_suggestions = [] }) - LookupNotFound suggest -> do - let suggest' - | gopt Opt_HelpfulErrors dflags = suggest - | otherwise = [] - return (NotFound{ fr_paths = [], fr_pkg = Nothing - , fr_pkgs_hidden = [] - , fr_mods_hidden = [] - , fr_unusables = [] - , fr_suggestions = suggest' }) - -modLocationCache :: FinderCache -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult -modLocationCache fc mod do_this = do - m <- lookupFinderCache fc mod - case m of - Just result -> return result - Nothing -> do - result <- do_this - addToFinderCache fc mod result - return result - --- This returns a module because it's more convenient for users -addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> IO Module -addHomeModuleToFinder fc home_unit mod_name loc = do - let mod = mkHomeInstalledModule home_unit mod_name - addToFinderCache fc mod (InstalledFound loc mod) - return (mkHomeModule home_unit mod_name) - -uncacheModule :: FinderCache -> HomeUnit -> ModuleName -> IO () -uncacheModule fc home_unit mod_name = do - let mod = mkHomeInstalledModule home_unit mod_name - removeFromFinderCache fc mod - --- ----------------------------------------------------------------------------- --- The internal workers - -findHomeModule :: FinderCache -> HomeUnit -> DynFlags -> ModuleName -> IO FindResult -findHomeModule fc home_unit dflags mod_name = do - let uid = homeUnitAsUnit home_unit - r <- findInstalledHomeModule fc dflags home_unit mod_name - return $ case r of - InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name) - InstalledNoPackage _ -> NoPackage uid -- impossible - InstalledNotFound fps _ -> NotFound { - fr_paths = fps, - fr_pkg = Just uid, - fr_mods_hidden = [], - fr_pkgs_hidden = [], - fr_unusables = [], - fr_suggestions = [] - } - --- | Implements the search for a module name in the home package only. Calling --- this function directly is usually *not* what you want; currently, it's used --- as a building block for the following operations: --- --- 1. When you do a normal package lookup, we first check if the module --- is available in the home module, before looking it up in the package --- database. --- --- 2. When you have a package qualified import with package name "this", --- we shortcut to the home module. --- --- 3. When we look up an exact 'Module', if the unit id associated with --- the module is the current home module do a look up in the home module. --- --- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to --- call this.) -findInstalledHomeModule :: FinderCache -> DynFlags -> HomeUnit -> ModuleName -> IO InstalledFindResult -findInstalledHomeModule fc dflags home_unit mod_name = do - homeSearchCache fc home_unit mod_name $ - let - home_path = importPaths dflags - hisuf = hiSuf dflags - mod = mkHomeInstalledModule home_unit mod_name - - source_exts = - [ ("hs", mkHomeModLocationSearched dflags mod_name "hs") - , ("lhs", mkHomeModLocationSearched dflags mod_name "lhs") - , ("hsig", mkHomeModLocationSearched dflags mod_name "hsig") - , ("lhsig", mkHomeModLocationSearched dflags mod_name "lhsig") - ] - - -- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that - -- when hiDir field is set in dflags, we know to look there (see #16500) - hi_exts = [ (hisuf, mkHomeModHiOnlyLocation dflags mod_name) - , (addBootSuffix hisuf, mkHomeModHiOnlyLocation dflags mod_name) - ] - - -- In compilation manager modes, we look for source files in the home - -- package because we can compile these automatically. In one-shot - -- compilation mode we look for .hi and .hi-boot files only. - exts | isOneShot (ghcMode dflags) = hi_exts - | otherwise = source_exts - in - - -- special case for GHC.Prim; we won't find it in the filesystem. - -- This is important only when compiling the base package (where GHC.Prim - -- is a home module). - if mod `installedModuleEq` gHC_PRIM - then return (InstalledFound (error "GHC.Prim ModLocation") mod) - else searchPathExts home_path mod exts - - --- | Search for a module in external packages only. -findPackageModule :: FinderCache -> UnitState -> DynFlags -> InstalledModule -> IO InstalledFindResult -findPackageModule fc unit_state dflags mod = do - let pkg_id = moduleUnit mod - case lookupUnitId unit_state pkg_id of - Nothing -> return (InstalledNoPackage pkg_id) - Just u -> findPackageModule_ fc dflags mod u - --- | Look up the interface file associated with module @mod@. This function --- requires a few invariants to be upheld: (1) the 'Module' in question must --- be the module identifier of the *original* implementation of a module, --- not a reexport (this invariant is upheld by "GHC.Unit.State") and (2) --- the 'UnitInfo' must be consistent with the unit id in the 'Module'. --- The redundancy is to avoid an extra lookup in the package state --- for the appropriate config. -findPackageModule_ :: FinderCache -> DynFlags -> InstalledModule -> UnitInfo -> IO InstalledFindResult -findPackageModule_ fc dflags mod pkg_conf = do - massertPpr (moduleUnit mod == unitId pkg_conf) - (ppr (moduleUnit mod) <+> ppr (unitId pkg_conf)) - modLocationCache fc mod $ - - -- special case for GHC.Prim; we won't find it in the filesystem. - if mod `installedModuleEq` gHC_PRIM - then return (InstalledFound (error "GHC.Prim ModLocation") mod) - else - - let - tag = waysBuildTag (ways dflags) - - -- hi-suffix for packages depends on the build tag. - package_hisuf | null tag = "hi" - | otherwise = tag ++ "_hi" - - mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf - - import_dirs = map ST.unpack $ unitImportDirs pkg_conf - -- we never look for a .hi-boot file in an external package; - -- .hi-boot files only make sense for the home package. - in - case import_dirs of - [one] | MkDepend <- ghcMode dflags -> do - -- there's only one place that this .hi file can be, so - -- don't bother looking for it. - let basename = moduleNameSlashes (moduleName mod) - loc <- mk_hi_loc one basename - return (InstalledFound loc mod) - _otherwise -> - searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)] - --- ----------------------------------------------------------------------------- --- General path searching - -searchPathExts :: [FilePath] -- paths to search - -> InstalledModule -- module name - -> [ ( - FileExt, -- suffix - FilePath -> BaseName -> IO ModLocation -- action - ) - ] - -> IO InstalledFindResult - -searchPathExts paths mod exts = search to_search - where - basename = moduleNameSlashes (moduleName mod) - - to_search :: [(FilePath, IO ModLocation)] - to_search = [ (file, fn path basename) - | path <- paths, - (ext,fn) <- exts, - let base | path == "." = basename - | otherwise = path basename - file = base <.> ext - ] - - search [] = return (InstalledNotFound (map fst to_search) (Just (moduleUnit mod))) - - search ((file, mk_result) : rest) = do - b <- doesFileExist file - if b - then do { loc <- mk_result; return (InstalledFound loc mod) } - else search rest - -mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt - -> FilePath -> BaseName -> IO ModLocation -mkHomeModLocationSearched dflags mod suff path basename = - mkHomeModLocation2 dflags mod (path basename) suff - --- ----------------------------------------------------------------------------- --- Constructing a home module location - --- This is where we construct the ModLocation for a module in the home --- package, for which we have a source file. It is called from three --- places: --- --- (a) Here in the finder, when we are searching for a module to import, --- using the search path (-i option). --- --- (b) The compilation manager, when constructing the ModLocation for --- a "root" module (a source file named explicitly on the command line --- or in a :load command in GHCi). --- --- (c) The driver in one-shot mode, when we need to construct a --- ModLocation for a source file named on the command-line. --- --- Parameters are: --- --- mod --- The name of the module --- --- path --- (a): The search path component where the source file was found. --- (b) and (c): "." --- --- src_basename --- (a): (moduleNameSlashes mod) --- (b) and (c): The filename of the source file, minus its extension --- --- ext --- The filename extension of the source file (usually "hs" or "lhs"). - -mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation -mkHomeModLocation dflags mod src_filename = do - let (basename,extension) = splitExtension src_filename - mkHomeModLocation2 dflags mod basename extension - -mkHomeModLocation2 :: DynFlags - -> ModuleName - -> FilePath -- Of source module, without suffix - -> String -- Suffix - -> IO ModLocation -mkHomeModLocation2 dflags mod src_basename ext = do - let mod_basename = moduleNameSlashes mod - - obj_fn = mkObjPath dflags src_basename mod_basename - hi_fn = mkHiPath dflags src_basename mod_basename - hie_fn = mkHiePath dflags src_basename mod_basename - - return (ModLocation{ ml_hs_file = Just (src_basename <.> ext), - ml_hi_file = hi_fn, - ml_obj_file = obj_fn, - ml_hie_file = hie_fn }) - -mkHomeModHiOnlyLocation :: DynFlags - -> ModuleName - -> FilePath - -> BaseName - -> IO ModLocation -mkHomeModHiOnlyLocation dflags mod path basename = do - loc <- mkHomeModLocation2 dflags mod (path basename) "" - return loc { ml_hs_file = Nothing } - -mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String - -> IO ModLocation -mkHiOnlyModLocation dflags hisuf path basename - = do let full_basename = path basename - obj_fn = mkObjPath dflags full_basename basename - hie_fn = mkHiePath dflags full_basename basename - return ModLocation{ ml_hs_file = Nothing, - ml_hi_file = full_basename <.> hisuf, - -- Remove the .hi-boot suffix from - -- hi_file, if it had one. We always - -- want the name of the real .hi file - -- in the ml_hi_file field. - ml_obj_file = obj_fn, - ml_hie_file = hie_fn - } - --- | Constructs the filename of a .o file for a given source file. --- Does /not/ check whether the .o file exists -mkObjPath - :: DynFlags - -> FilePath -- the filename of the source file, minus the extension - -> String -- the module name with dots replaced by slashes - -> FilePath -mkObjPath dflags basename mod_basename = obj_basename <.> osuf - where - odir = objectDir dflags - osuf = objectSuf dflags - - obj_basename | Just dir <- odir = dir mod_basename - | otherwise = basename - - --- | Constructs the filename of a .hi file for a given source file. --- Does /not/ check whether the .hi file exists -mkHiPath - :: DynFlags - -> FilePath -- the filename of the source file, minus the extension - -> String -- the module name with dots replaced by slashes - -> FilePath -mkHiPath dflags basename mod_basename = hi_basename <.> hisuf - where - hidir = hiDir dflags - hisuf = hiSuf dflags - - hi_basename | Just dir <- hidir = dir mod_basename - | otherwise = basename - --- | Constructs the filename of a .hie file for a given source file. --- Does /not/ check whether the .hie file exists -mkHiePath - :: DynFlags - -> FilePath -- the filename of the source file, minus the extension - -> String -- the module name with dots replaced by slashes - -> FilePath -mkHiePath dflags basename mod_basename = hie_basename <.> hiesuf - where - hiedir = hieDir dflags - hiesuf = hieSuf dflags - - hie_basename | Just dir <- hiedir = dir mod_basename - | otherwise = basename - - - --- ----------------------------------------------------------------------------- --- Filenames of the stub files - --- We don't have to store these in ModLocations, because they can be derived --- from other available information, and they're only rarely needed. - -mkStubPaths - :: DynFlags - -> ModuleName - -> ModLocation - -> FilePath - -mkStubPaths dflags mod location - = let - stubdir = stubDir dflags - - mod_basename = moduleNameSlashes mod - src_basename = dropExtension $ expectJust "mkStubPaths" - (ml_hs_file location) - - stub_basename0 - | Just dir <- stubdir = dir mod_basename - | otherwise = src_basename - - stub_basename = stub_basename0 ++ "_stub" - in - stub_basename <.> "h" - --- ----------------------------------------------------------------------------- --- findLinkable isn't related to the other stuff in here, --- but there's no other obvious place for it - -findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable) -findObjectLinkableMaybe mod locn - = do let obj_fn = ml_obj_file locn - maybe_obj_time <- modificationTimeIfExists obj_fn - case maybe_obj_time of - Nothing -> return Nothing - Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) - --- Make an object linkable when we know the object file exists, and we know --- its modification time. -findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable -findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn]) - -- We used to look for _stub.o files here, but that was a bug (#706) - -- Now GHC merges the stub.o into the main .o (#3687) - 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.20210701 +version: 0.20210801 license: BSD3 license-file: LICENSE category: Development @@ -61,7 +61,6 @@ else build-depends: Win32 build-depends: - rts, ghc-prim > 0.2 && < 0.8, base >= 4.14 && < 4.17, containers >= 0.5 && < 0.7, @@ -75,10 +74,11 @@ time >= 1.4 && < 1.10, transformers == 0.5.*, process >= 1 && < 1.7, - hpc == 0.6.*, exceptions == 0.10.*, parsec, - ghc-lib-parser == 0.20210701 + rts, + hpc == 0.6.*, + ghc-lib-parser == 0.20210801 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns @@ -218,6 +218,7 @@ GHC.Driver.CmdLine, GHC.Driver.Config, GHC.Driver.Config.Diagnostic, + GHC.Driver.Config.Finder, GHC.Driver.Config.Logger, GHC.Driver.Config.Parser, GHC.Driver.Env, @@ -230,6 +231,7 @@ GHC.Driver.Monad, GHC.Driver.Phases, GHC.Driver.Pipeline.Monad, + GHC.Driver.Pipeline.Phases, GHC.Driver.Plugins, GHC.Driver.Ppr, GHC.Driver.Session, @@ -279,6 +281,7 @@ GHC.Parser, GHC.Parser.Annotation, GHC.Parser.CharClass, + GHC.Parser.Errors.Basic, GHC.Parser.Errors.Ppr, GHC.Parser.Errors.Types, GHC.Parser.Header, @@ -383,6 +386,7 @@ GHC.Unit.Database, GHC.Unit.Env, GHC.Unit.External, + GHC.Unit.Finder, GHC.Unit.Finder.Types, GHC.Unit.Home, GHC.Unit.Home.ModInfo, @@ -608,6 +612,7 @@ GHC.Driver.Make GHC.Driver.MakeFile GHC.Driver.Pipeline + GHC.Driver.Pipeline.Execute GHC.HandleEncoding GHC.Hs.Stats GHC.Hs.Syn.Type @@ -773,7 +778,6 @@ GHC.ThToHs GHC.Types.Name.Shape GHC.Types.TyThing.Ppr - GHC.Unit.Finder GHC.Utils.Asm GHC.Utils.Monad.State.Lazy GHCi.CreateBCO diff --git a/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl b/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl @@ -288,7 +288,6 @@ | FloatToDoubleOp | FloatDecode_IntOp | NewArrayOp - | SameMutableArrayOp | ReadArrayOp | WriteArrayOp | SizeofArrayOp @@ -304,7 +303,6 @@ | ThawArrayOp | CasArrayOp | NewSmallArrayOp - | SameSmallMutableArrayOp | ShrinkSmallMutableArrayOp_Char | ReadSmallArrayOp | WriteSmallArrayOp @@ -328,7 +326,6 @@ | ByteArrayIsPinnedOp | ByteArrayContents_Char | MutableByteArrayContents_Char - | SameMutableByteArrayOp | ShrinkMutableByteArrayOp_Char | ResizeMutableByteArrayOp_Char | UnsafeFreezeByteArrayOp @@ -442,7 +439,6 @@ | FetchOrByteArrayOp_Int | FetchXorByteArrayOp_Int | NewArrayArrayOp - | SameMutableArrayArrayOp | UnsafeFreezeArrayArrayOp | SizeofArrayArrayOp | SizeofMutableArrayArrayOp @@ -532,7 +528,6 @@ | NewMutVarOp | ReadMutVarOp | WriteMutVarOp - | SameMutVarOp | AtomicModifyMutVar2Op | AtomicModifyMutVar_Op | CasMutVarOp @@ -551,7 +546,6 @@ | ReadTVarOp | ReadTVarIOOp | WriteTVarOp - | SameTVarOp | NewMVarOp | TakeMVarOp | TryTakeMVarOp @@ -559,12 +553,10 @@ | TryPutMVarOp | ReadMVarOp | TryReadMVarOp - | SameMVarOp | IsEmptyMVarOp | NewIOPortrOp | ReadIOPortOp | WriteIOPortOp - | SameIOPortOp | DelayOp | WaitReadOp | WaitWriteOp @@ -587,7 +579,6 @@ | DeRefStablePtrOp | EqStablePtrOp | MakeStableNameOp - | EqStableNameOp | StableNameToIntOp | CompactNewOp | CompactResizeOp diff --git a/ghc-lib/stage0/compiler/build/primop-list.hs-incl b/ghc-lib/stage0/compiler/build/primop-list.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-list.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-list.hs-incl @@ -287,7 +287,6 @@ , FloatToDoubleOp , FloatDecode_IntOp , NewArrayOp - , SameMutableArrayOp , ReadArrayOp , WriteArrayOp , SizeofArrayOp @@ -303,7 +302,6 @@ , ThawArrayOp , CasArrayOp , NewSmallArrayOp - , SameSmallMutableArrayOp , ShrinkSmallMutableArrayOp_Char , ReadSmallArrayOp , WriteSmallArrayOp @@ -327,7 +325,6 @@ , ByteArrayIsPinnedOp , ByteArrayContents_Char , MutableByteArrayContents_Char - , SameMutableByteArrayOp , ShrinkMutableByteArrayOp_Char , ResizeMutableByteArrayOp_Char , UnsafeFreezeByteArrayOp @@ -441,7 +438,6 @@ , FetchOrByteArrayOp_Int , FetchXorByteArrayOp_Int , NewArrayArrayOp - , SameMutableArrayArrayOp , UnsafeFreezeArrayArrayOp , SizeofArrayArrayOp , SizeofMutableArrayArrayOp @@ -531,7 +527,6 @@ , NewMutVarOp , ReadMutVarOp , WriteMutVarOp - , SameMutVarOp , AtomicModifyMutVar2Op , AtomicModifyMutVar_Op , CasMutVarOp @@ -550,7 +545,6 @@ , ReadTVarOp , ReadTVarIOOp , WriteTVarOp - , SameTVarOp , NewMVarOp , TakeMVarOp , TryTakeMVarOp @@ -558,12 +552,10 @@ , TryPutMVarOp , ReadMVarOp , TryReadMVarOp - , SameMVarOp , IsEmptyMVarOp , NewIOPortrOp , ReadIOPortOp , WriteIOPortOp - , SameIOPortOp , DelayOp , WaitReadOp , WaitWriteOp @@ -586,7 +578,6 @@ , DeRefStablePtrOp , EqStablePtrOp , MakeStableNameOp - , EqStableNameOp , StableNameToIntOp , CompactNewOp , CompactResizeOp 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 @@ -287,7 +287,6 @@ primOpInfo FloatToDoubleOp = mkGenPrimOp (fsLit "float2Double#") [] [floatPrimTy] (doublePrimTy) primOpInfo FloatDecode_IntOp = mkGenPrimOp (fsLit "decodeFloat_Int#") [] [floatPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) 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) @@ -303,7 +302,6 @@ 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) @@ -327,7 +325,6 @@ 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])) @@ -441,7 +438,6 @@ 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) @@ -531,7 +527,6 @@ 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])) @@ -550,7 +545,6 @@ 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])) @@ -558,12 +552,10 @@ 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) @@ -576,17 +568,16 @@ 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 MkWeakOp = mkGenPrimOp (fsLit "mkWeak#") [levity1TyVarInf, levPolyAlphaTyVarSpec, betaTyVarSpec, gammaTyVarSpec] [levPolyAlphaTy, betaTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy])) +primOpInfo MkWeakNoFinalizerOp = mkGenPrimOp (fsLit "mkWeakNoFinalizer#") [levity1TyVarInf, levPolyAlphaTyVarSpec, betaTyVarSpec] [levPolyAlphaTy, 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 TouchOp = mkGenPrimOp (fsLit "touch#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [levPolyAlphaTy, 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) @@ -599,13 +590,13 @@ 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 ReallyUnsafePtrEqualityOp = mkGenPrimOp (fsLit "reallyUnsafePtrEquality#") [levity1TyVarInf, levPolyAlphaTyVarSpec, levity2TyVarInf, levPolyBetaTyVarSpec] [levPolyAlphaTy, levPolyBetaTy] (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 KeepAliveOp = mkGenPrimOp (fsLit "keepAlive#") [levity1TyVarInf, levPolyAlphaTyVarSpec, runtimeRep2TyVarInf, openBetaTyVarSpec] [levPolyAlphaTy, 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])) diff --git a/ghc-lib/stage0/compiler/build/primop-tag.hs-incl b/ghc-lib/stage0/compiler/build/primop-tag.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-tag.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-tag.hs-incl @@ -1,1286 +1,1277 @@ maxPrimOpTag :: Int -maxPrimOpTag = 1283 -primOpTag :: PrimOp -> Int -primOpTag CharGtOp = 1 -primOpTag CharGeOp = 2 -primOpTag CharEqOp = 3 -primOpTag CharNeOp = 4 -primOpTag CharLtOp = 5 -primOpTag CharLeOp = 6 -primOpTag OrdOp = 7 -primOpTag Int8ToIntOp = 8 -primOpTag IntToInt8Op = 9 -primOpTag Int8NegOp = 10 -primOpTag Int8AddOp = 11 -primOpTag Int8SubOp = 12 -primOpTag Int8MulOp = 13 -primOpTag Int8QuotOp = 14 -primOpTag Int8RemOp = 15 -primOpTag Int8QuotRemOp = 16 -primOpTag Int8SllOp = 17 -primOpTag Int8SraOp = 18 -primOpTag Int8SrlOp = 19 -primOpTag Int8ToWord8Op = 20 -primOpTag Int8EqOp = 21 -primOpTag Int8GeOp = 22 -primOpTag Int8GtOp = 23 -primOpTag Int8LeOp = 24 -primOpTag Int8LtOp = 25 -primOpTag Int8NeOp = 26 -primOpTag Word8ToWordOp = 27 -primOpTag WordToWord8Op = 28 -primOpTag Word8AddOp = 29 -primOpTag Word8SubOp = 30 -primOpTag Word8MulOp = 31 -primOpTag Word8QuotOp = 32 -primOpTag Word8RemOp = 33 -primOpTag Word8QuotRemOp = 34 -primOpTag Word8AndOp = 35 -primOpTag Word8OrOp = 36 -primOpTag Word8XorOp = 37 -primOpTag Word8NotOp = 38 -primOpTag Word8SllOp = 39 -primOpTag Word8SrlOp = 40 -primOpTag Word8ToInt8Op = 41 -primOpTag Word8EqOp = 42 -primOpTag Word8GeOp = 43 -primOpTag Word8GtOp = 44 -primOpTag Word8LeOp = 45 -primOpTag Word8LtOp = 46 -primOpTag Word8NeOp = 47 -primOpTag Int16ToIntOp = 48 -primOpTag IntToInt16Op = 49 -primOpTag Int16NegOp = 50 -primOpTag Int16AddOp = 51 -primOpTag Int16SubOp = 52 -primOpTag Int16MulOp = 53 -primOpTag Int16QuotOp = 54 -primOpTag Int16RemOp = 55 -primOpTag Int16QuotRemOp = 56 -primOpTag Int16SllOp = 57 -primOpTag Int16SraOp = 58 -primOpTag Int16SrlOp = 59 -primOpTag Int16ToWord16Op = 60 -primOpTag Int16EqOp = 61 -primOpTag Int16GeOp = 62 -primOpTag Int16GtOp = 63 -primOpTag Int16LeOp = 64 -primOpTag Int16LtOp = 65 -primOpTag Int16NeOp = 66 -primOpTag Word16ToWordOp = 67 -primOpTag WordToWord16Op = 68 -primOpTag Word16AddOp = 69 -primOpTag Word16SubOp = 70 -primOpTag Word16MulOp = 71 -primOpTag Word16QuotOp = 72 -primOpTag Word16RemOp = 73 -primOpTag Word16QuotRemOp = 74 -primOpTag Word16AndOp = 75 -primOpTag Word16OrOp = 76 -primOpTag Word16XorOp = 77 -primOpTag Word16NotOp = 78 -primOpTag Word16SllOp = 79 -primOpTag Word16SrlOp = 80 -primOpTag Word16ToInt16Op = 81 -primOpTag Word16EqOp = 82 -primOpTag Word16GeOp = 83 -primOpTag Word16GtOp = 84 -primOpTag Word16LeOp = 85 -primOpTag Word16LtOp = 86 -primOpTag Word16NeOp = 87 -primOpTag Int32ToIntOp = 88 -primOpTag IntToInt32Op = 89 -primOpTag Int32NegOp = 90 -primOpTag Int32AddOp = 91 -primOpTag Int32SubOp = 92 -primOpTag Int32MulOp = 93 -primOpTag Int32QuotOp = 94 -primOpTag Int32RemOp = 95 -primOpTag Int32QuotRemOp = 96 -primOpTag Int32SllOp = 97 -primOpTag Int32SraOp = 98 -primOpTag Int32SrlOp = 99 -primOpTag Int32ToWord32Op = 100 -primOpTag Int32EqOp = 101 -primOpTag Int32GeOp = 102 -primOpTag Int32GtOp = 103 -primOpTag Int32LeOp = 104 -primOpTag Int32LtOp = 105 -primOpTag Int32NeOp = 106 -primOpTag Word32ToWordOp = 107 -primOpTag WordToWord32Op = 108 -primOpTag Word32AddOp = 109 -primOpTag Word32SubOp = 110 -primOpTag Word32MulOp = 111 -primOpTag Word32QuotOp = 112 -primOpTag Word32RemOp = 113 -primOpTag Word32QuotRemOp = 114 -primOpTag Word32AndOp = 115 -primOpTag Word32OrOp = 116 -primOpTag Word32XorOp = 117 -primOpTag Word32NotOp = 118 -primOpTag Word32SllOp = 119 -primOpTag Word32SrlOp = 120 -primOpTag Word32ToInt32Op = 121 -primOpTag Word32EqOp = 122 -primOpTag Word32GeOp = 123 -primOpTag Word32GtOp = 124 -primOpTag Word32LeOp = 125 -primOpTag Word32LtOp = 126 -primOpTag Word32NeOp = 127 -primOpTag IntAddOp = 128 -primOpTag IntSubOp = 129 -primOpTag IntMulOp = 130 -primOpTag IntMul2Op = 131 -primOpTag IntMulMayOfloOp = 132 -primOpTag IntQuotOp = 133 -primOpTag IntRemOp = 134 -primOpTag IntQuotRemOp = 135 -primOpTag IntAndOp = 136 -primOpTag IntOrOp = 137 -primOpTag IntXorOp = 138 -primOpTag IntNotOp = 139 -primOpTag IntNegOp = 140 -primOpTag IntAddCOp = 141 -primOpTag IntSubCOp = 142 -primOpTag IntGtOp = 143 -primOpTag IntGeOp = 144 -primOpTag IntEqOp = 145 -primOpTag IntNeOp = 146 -primOpTag IntLtOp = 147 -primOpTag IntLeOp = 148 -primOpTag ChrOp = 149 -primOpTag IntToWordOp = 150 -primOpTag IntToFloatOp = 151 -primOpTag IntToDoubleOp = 152 -primOpTag WordToFloatOp = 153 -primOpTag WordToDoubleOp = 154 -primOpTag IntSllOp = 155 -primOpTag IntSraOp = 156 -primOpTag IntSrlOp = 157 -primOpTag WordAddOp = 158 -primOpTag WordAddCOp = 159 -primOpTag WordSubCOp = 160 -primOpTag WordAdd2Op = 161 -primOpTag WordSubOp = 162 -primOpTag WordMulOp = 163 -primOpTag WordMul2Op = 164 -primOpTag WordQuotOp = 165 -primOpTag WordRemOp = 166 -primOpTag WordQuotRemOp = 167 -primOpTag WordQuotRem2Op = 168 -primOpTag WordAndOp = 169 -primOpTag WordOrOp = 170 -primOpTag WordXorOp = 171 -primOpTag WordNotOp = 172 -primOpTag WordSllOp = 173 -primOpTag WordSrlOp = 174 -primOpTag WordToIntOp = 175 -primOpTag WordGtOp = 176 -primOpTag WordGeOp = 177 -primOpTag WordEqOp = 178 -primOpTag WordNeOp = 179 -primOpTag WordLtOp = 180 -primOpTag WordLeOp = 181 -primOpTag PopCnt8Op = 182 -primOpTag PopCnt16Op = 183 -primOpTag PopCnt32Op = 184 -primOpTag PopCnt64Op = 185 -primOpTag PopCntOp = 186 -primOpTag Pdep8Op = 187 -primOpTag Pdep16Op = 188 -primOpTag Pdep32Op = 189 -primOpTag Pdep64Op = 190 -primOpTag PdepOp = 191 -primOpTag Pext8Op = 192 -primOpTag Pext16Op = 193 -primOpTag Pext32Op = 194 -primOpTag Pext64Op = 195 -primOpTag PextOp = 196 -primOpTag Clz8Op = 197 -primOpTag Clz16Op = 198 -primOpTag Clz32Op = 199 -primOpTag Clz64Op = 200 -primOpTag ClzOp = 201 -primOpTag Ctz8Op = 202 -primOpTag Ctz16Op = 203 -primOpTag Ctz32Op = 204 -primOpTag Ctz64Op = 205 -primOpTag CtzOp = 206 -primOpTag BSwap16Op = 207 -primOpTag BSwap32Op = 208 -primOpTag BSwap64Op = 209 -primOpTag BSwapOp = 210 -primOpTag BRev8Op = 211 -primOpTag BRev16Op = 212 -primOpTag BRev32Op = 213 -primOpTag BRev64Op = 214 -primOpTag BRevOp = 215 -primOpTag Narrow8IntOp = 216 -primOpTag Narrow16IntOp = 217 -primOpTag Narrow32IntOp = 218 -primOpTag Narrow8WordOp = 219 -primOpTag Narrow16WordOp = 220 -primOpTag Narrow32WordOp = 221 -primOpTag DoubleGtOp = 222 -primOpTag DoubleGeOp = 223 -primOpTag DoubleEqOp = 224 -primOpTag DoubleNeOp = 225 -primOpTag DoubleLtOp = 226 -primOpTag DoubleLeOp = 227 -primOpTag DoubleAddOp = 228 -primOpTag DoubleSubOp = 229 -primOpTag DoubleMulOp = 230 -primOpTag DoubleDivOp = 231 -primOpTag DoubleNegOp = 232 -primOpTag DoubleFabsOp = 233 -primOpTag DoubleToIntOp = 234 -primOpTag DoubleToFloatOp = 235 -primOpTag DoubleExpOp = 236 -primOpTag DoubleExpM1Op = 237 -primOpTag DoubleLogOp = 238 -primOpTag DoubleLog1POp = 239 -primOpTag DoubleSqrtOp = 240 -primOpTag DoubleSinOp = 241 -primOpTag DoubleCosOp = 242 -primOpTag DoubleTanOp = 243 -primOpTag DoubleAsinOp = 244 -primOpTag DoubleAcosOp = 245 -primOpTag DoubleAtanOp = 246 -primOpTag DoubleSinhOp = 247 -primOpTag DoubleCoshOp = 248 -primOpTag DoubleTanhOp = 249 -primOpTag DoubleAsinhOp = 250 -primOpTag DoubleAcoshOp = 251 -primOpTag DoubleAtanhOp = 252 -primOpTag DoublePowerOp = 253 -primOpTag DoubleDecode_2IntOp = 254 -primOpTag DoubleDecode_Int64Op = 255 -primOpTag FloatGtOp = 256 -primOpTag FloatGeOp = 257 -primOpTag FloatEqOp = 258 -primOpTag FloatNeOp = 259 -primOpTag FloatLtOp = 260 -primOpTag FloatLeOp = 261 -primOpTag FloatAddOp = 262 -primOpTag FloatSubOp = 263 -primOpTag FloatMulOp = 264 -primOpTag FloatDivOp = 265 -primOpTag FloatNegOp = 266 -primOpTag FloatFabsOp = 267 -primOpTag FloatToIntOp = 268 -primOpTag FloatExpOp = 269 -primOpTag FloatExpM1Op = 270 -primOpTag FloatLogOp = 271 -primOpTag FloatLog1POp = 272 -primOpTag FloatSqrtOp = 273 -primOpTag FloatSinOp = 274 -primOpTag FloatCosOp = 275 -primOpTag FloatTanOp = 276 -primOpTag FloatAsinOp = 277 -primOpTag FloatAcosOp = 278 -primOpTag FloatAtanOp = 279 -primOpTag FloatSinhOp = 280 -primOpTag FloatCoshOp = 281 -primOpTag FloatTanhOp = 282 -primOpTag FloatAsinhOp = 283 -primOpTag FloatAcoshOp = 284 -primOpTag FloatAtanhOp = 285 -primOpTag FloatPowerOp = 286 -primOpTag FloatToDoubleOp = 287 -primOpTag FloatDecode_IntOp = 288 -primOpTag NewArrayOp = 289 -primOpTag SameMutableArrayOp = 290 -primOpTag ReadArrayOp = 291 -primOpTag WriteArrayOp = 292 -primOpTag SizeofArrayOp = 293 -primOpTag SizeofMutableArrayOp = 294 -primOpTag IndexArrayOp = 295 -primOpTag UnsafeFreezeArrayOp = 296 -primOpTag UnsafeThawArrayOp = 297 -primOpTag CopyArrayOp = 298 -primOpTag CopyMutableArrayOp = 299 -primOpTag CloneArrayOp = 300 -primOpTag CloneMutableArrayOp = 301 -primOpTag FreezeArrayOp = 302 -primOpTag ThawArrayOp = 303 -primOpTag CasArrayOp = 304 -primOpTag NewSmallArrayOp = 305 -primOpTag SameSmallMutableArrayOp = 306 -primOpTag ShrinkSmallMutableArrayOp_Char = 307 -primOpTag ReadSmallArrayOp = 308 -primOpTag WriteSmallArrayOp = 309 -primOpTag SizeofSmallArrayOp = 310 -primOpTag SizeofSmallMutableArrayOp = 311 -primOpTag GetSizeofSmallMutableArrayOp = 312 -primOpTag IndexSmallArrayOp = 313 -primOpTag UnsafeFreezeSmallArrayOp = 314 -primOpTag UnsafeThawSmallArrayOp = 315 -primOpTag CopySmallArrayOp = 316 -primOpTag CopySmallMutableArrayOp = 317 -primOpTag CloneSmallArrayOp = 318 -primOpTag CloneSmallMutableArrayOp = 319 -primOpTag FreezeSmallArrayOp = 320 -primOpTag ThawSmallArrayOp = 321 -primOpTag CasSmallArrayOp = 322 -primOpTag NewByteArrayOp_Char = 323 -primOpTag NewPinnedByteArrayOp_Char = 324 -primOpTag NewAlignedPinnedByteArrayOp_Char = 325 -primOpTag MutableByteArrayIsPinnedOp = 326 -primOpTag ByteArrayIsPinnedOp = 327 -primOpTag ByteArrayContents_Char = 328 -primOpTag MutableByteArrayContents_Char = 329 -primOpTag SameMutableByteArrayOp = 330 -primOpTag ShrinkMutableByteArrayOp_Char = 331 -primOpTag ResizeMutableByteArrayOp_Char = 332 -primOpTag UnsafeFreezeByteArrayOp = 333 -primOpTag SizeofByteArrayOp = 334 -primOpTag SizeofMutableByteArrayOp = 335 -primOpTag GetSizeofMutableByteArrayOp = 336 -primOpTag IndexByteArrayOp_Char = 337 -primOpTag IndexByteArrayOp_WideChar = 338 -primOpTag IndexByteArrayOp_Int = 339 -primOpTag IndexByteArrayOp_Word = 340 -primOpTag IndexByteArrayOp_Addr = 341 -primOpTag IndexByteArrayOp_Float = 342 -primOpTag IndexByteArrayOp_Double = 343 -primOpTag IndexByteArrayOp_StablePtr = 344 -primOpTag IndexByteArrayOp_Int8 = 345 -primOpTag IndexByteArrayOp_Int16 = 346 -primOpTag IndexByteArrayOp_Int32 = 347 -primOpTag IndexByteArrayOp_Int64 = 348 -primOpTag IndexByteArrayOp_Word8 = 349 -primOpTag IndexByteArrayOp_Word16 = 350 -primOpTag IndexByteArrayOp_Word32 = 351 -primOpTag IndexByteArrayOp_Word64 = 352 -primOpTag IndexByteArrayOp_Word8AsChar = 353 -primOpTag IndexByteArrayOp_Word8AsWideChar = 354 -primOpTag IndexByteArrayOp_Word8AsInt = 355 -primOpTag IndexByteArrayOp_Word8AsWord = 356 -primOpTag IndexByteArrayOp_Word8AsAddr = 357 -primOpTag IndexByteArrayOp_Word8AsFloat = 358 -primOpTag IndexByteArrayOp_Word8AsDouble = 359 -primOpTag IndexByteArrayOp_Word8AsStablePtr = 360 -primOpTag IndexByteArrayOp_Word8AsInt16 = 361 -primOpTag IndexByteArrayOp_Word8AsInt32 = 362 -primOpTag IndexByteArrayOp_Word8AsInt64 = 363 -primOpTag IndexByteArrayOp_Word8AsWord16 = 364 -primOpTag IndexByteArrayOp_Word8AsWord32 = 365 -primOpTag IndexByteArrayOp_Word8AsWord64 = 366 -primOpTag ReadByteArrayOp_Char = 367 -primOpTag ReadByteArrayOp_WideChar = 368 -primOpTag ReadByteArrayOp_Int = 369 -primOpTag ReadByteArrayOp_Word = 370 -primOpTag ReadByteArrayOp_Addr = 371 -primOpTag ReadByteArrayOp_Float = 372 -primOpTag ReadByteArrayOp_Double = 373 -primOpTag ReadByteArrayOp_StablePtr = 374 -primOpTag ReadByteArrayOp_Int8 = 375 -primOpTag ReadByteArrayOp_Int16 = 376 -primOpTag ReadByteArrayOp_Int32 = 377 -primOpTag ReadByteArrayOp_Int64 = 378 -primOpTag ReadByteArrayOp_Word8 = 379 -primOpTag ReadByteArrayOp_Word16 = 380 -primOpTag ReadByteArrayOp_Word32 = 381 -primOpTag ReadByteArrayOp_Word64 = 382 -primOpTag ReadByteArrayOp_Word8AsChar = 383 -primOpTag ReadByteArrayOp_Word8AsWideChar = 384 -primOpTag ReadByteArrayOp_Word8AsInt = 385 -primOpTag ReadByteArrayOp_Word8AsWord = 386 -primOpTag ReadByteArrayOp_Word8AsAddr = 387 -primOpTag ReadByteArrayOp_Word8AsFloat = 388 -primOpTag ReadByteArrayOp_Word8AsDouble = 389 -primOpTag ReadByteArrayOp_Word8AsStablePtr = 390 -primOpTag ReadByteArrayOp_Word8AsInt16 = 391 -primOpTag ReadByteArrayOp_Word8AsInt32 = 392 -primOpTag ReadByteArrayOp_Word8AsInt64 = 393 -primOpTag ReadByteArrayOp_Word8AsWord16 = 394 -primOpTag ReadByteArrayOp_Word8AsWord32 = 395 -primOpTag ReadByteArrayOp_Word8AsWord64 = 396 -primOpTag WriteByteArrayOp_Char = 397 -primOpTag WriteByteArrayOp_WideChar = 398 -primOpTag WriteByteArrayOp_Int = 399 -primOpTag WriteByteArrayOp_Word = 400 -primOpTag WriteByteArrayOp_Addr = 401 -primOpTag WriteByteArrayOp_Float = 402 -primOpTag WriteByteArrayOp_Double = 403 -primOpTag WriteByteArrayOp_StablePtr = 404 -primOpTag WriteByteArrayOp_Int8 = 405 -primOpTag WriteByteArrayOp_Int16 = 406 -primOpTag WriteByteArrayOp_Int32 = 407 -primOpTag WriteByteArrayOp_Int64 = 408 -primOpTag WriteByteArrayOp_Word8 = 409 -primOpTag WriteByteArrayOp_Word16 = 410 -primOpTag WriteByteArrayOp_Word32 = 411 -primOpTag WriteByteArrayOp_Word64 = 412 -primOpTag WriteByteArrayOp_Word8AsChar = 413 -primOpTag WriteByteArrayOp_Word8AsWideChar = 414 -primOpTag WriteByteArrayOp_Word8AsInt = 415 -primOpTag WriteByteArrayOp_Word8AsWord = 416 -primOpTag WriteByteArrayOp_Word8AsAddr = 417 -primOpTag WriteByteArrayOp_Word8AsFloat = 418 -primOpTag WriteByteArrayOp_Word8AsDouble = 419 -primOpTag WriteByteArrayOp_Word8AsStablePtr = 420 -primOpTag WriteByteArrayOp_Word8AsInt16 = 421 -primOpTag WriteByteArrayOp_Word8AsInt32 = 422 -primOpTag WriteByteArrayOp_Word8AsInt64 = 423 -primOpTag WriteByteArrayOp_Word8AsWord16 = 424 -primOpTag WriteByteArrayOp_Word8AsWord32 = 425 -primOpTag WriteByteArrayOp_Word8AsWord64 = 426 -primOpTag CompareByteArraysOp = 427 -primOpTag CopyByteArrayOp = 428 -primOpTag CopyMutableByteArrayOp = 429 -primOpTag CopyByteArrayToAddrOp = 430 -primOpTag CopyMutableByteArrayToAddrOp = 431 -primOpTag CopyAddrToByteArrayOp = 432 -primOpTag SetByteArrayOp = 433 -primOpTag AtomicReadByteArrayOp_Int = 434 -primOpTag AtomicWriteByteArrayOp_Int = 435 -primOpTag CasByteArrayOp_Int = 436 -primOpTag FetchAddByteArrayOp_Int = 437 -primOpTag FetchSubByteArrayOp_Int = 438 -primOpTag FetchAndByteArrayOp_Int = 439 -primOpTag FetchNandByteArrayOp_Int = 440 -primOpTag FetchOrByteArrayOp_Int = 441 -primOpTag FetchXorByteArrayOp_Int = 442 -primOpTag NewArrayArrayOp = 443 -primOpTag SameMutableArrayArrayOp = 444 -primOpTag UnsafeFreezeArrayArrayOp = 445 -primOpTag SizeofArrayArrayOp = 446 -primOpTag SizeofMutableArrayArrayOp = 447 -primOpTag IndexArrayArrayOp_ByteArray = 448 -primOpTag IndexArrayArrayOp_ArrayArray = 449 -primOpTag ReadArrayArrayOp_ByteArray = 450 -primOpTag ReadArrayArrayOp_MutableByteArray = 451 -primOpTag ReadArrayArrayOp_ArrayArray = 452 -primOpTag ReadArrayArrayOp_MutableArrayArray = 453 -primOpTag WriteArrayArrayOp_ByteArray = 454 -primOpTag WriteArrayArrayOp_MutableByteArray = 455 -primOpTag WriteArrayArrayOp_ArrayArray = 456 -primOpTag WriteArrayArrayOp_MutableArrayArray = 457 -primOpTag CopyArrayArrayOp = 458 -primOpTag CopyMutableArrayArrayOp = 459 -primOpTag AddrAddOp = 460 -primOpTag AddrSubOp = 461 -primOpTag AddrRemOp = 462 -primOpTag AddrToIntOp = 463 -primOpTag IntToAddrOp = 464 -primOpTag AddrGtOp = 465 -primOpTag AddrGeOp = 466 -primOpTag AddrEqOp = 467 -primOpTag AddrNeOp = 468 -primOpTag AddrLtOp = 469 -primOpTag AddrLeOp = 470 -primOpTag IndexOffAddrOp_Char = 471 -primOpTag IndexOffAddrOp_WideChar = 472 -primOpTag IndexOffAddrOp_Int = 473 -primOpTag IndexOffAddrOp_Word = 474 -primOpTag IndexOffAddrOp_Addr = 475 -primOpTag IndexOffAddrOp_Float = 476 -primOpTag IndexOffAddrOp_Double = 477 -primOpTag IndexOffAddrOp_StablePtr = 478 -primOpTag IndexOffAddrOp_Int8 = 479 -primOpTag IndexOffAddrOp_Int16 = 480 -primOpTag IndexOffAddrOp_Int32 = 481 -primOpTag IndexOffAddrOp_Int64 = 482 -primOpTag IndexOffAddrOp_Word8 = 483 -primOpTag IndexOffAddrOp_Word16 = 484 -primOpTag IndexOffAddrOp_Word32 = 485 -primOpTag IndexOffAddrOp_Word64 = 486 -primOpTag ReadOffAddrOp_Char = 487 -primOpTag ReadOffAddrOp_WideChar = 488 -primOpTag ReadOffAddrOp_Int = 489 -primOpTag ReadOffAddrOp_Word = 490 -primOpTag ReadOffAddrOp_Addr = 491 -primOpTag ReadOffAddrOp_Float = 492 -primOpTag ReadOffAddrOp_Double = 493 -primOpTag ReadOffAddrOp_StablePtr = 494 -primOpTag ReadOffAddrOp_Int8 = 495 -primOpTag ReadOffAddrOp_Int16 = 496 -primOpTag ReadOffAddrOp_Int32 = 497 -primOpTag ReadOffAddrOp_Int64 = 498 -primOpTag ReadOffAddrOp_Word8 = 499 -primOpTag ReadOffAddrOp_Word16 = 500 -primOpTag ReadOffAddrOp_Word32 = 501 -primOpTag ReadOffAddrOp_Word64 = 502 -primOpTag WriteOffAddrOp_Char = 503 -primOpTag WriteOffAddrOp_WideChar = 504 -primOpTag WriteOffAddrOp_Int = 505 -primOpTag WriteOffAddrOp_Word = 506 -primOpTag WriteOffAddrOp_Addr = 507 -primOpTag WriteOffAddrOp_Float = 508 -primOpTag WriteOffAddrOp_Double = 509 -primOpTag WriteOffAddrOp_StablePtr = 510 -primOpTag WriteOffAddrOp_Int8 = 511 -primOpTag WriteOffAddrOp_Int16 = 512 -primOpTag WriteOffAddrOp_Int32 = 513 -primOpTag WriteOffAddrOp_Int64 = 514 -primOpTag WriteOffAddrOp_Word8 = 515 -primOpTag WriteOffAddrOp_Word16 = 516 -primOpTag WriteOffAddrOp_Word32 = 517 -primOpTag WriteOffAddrOp_Word64 = 518 -primOpTag InterlockedExchange_Addr = 519 -primOpTag InterlockedExchange_Word = 520 -primOpTag CasAddrOp_Addr = 521 -primOpTag CasAddrOp_Word = 522 -primOpTag FetchAddAddrOp_Word = 523 -primOpTag FetchSubAddrOp_Word = 524 -primOpTag FetchAndAddrOp_Word = 525 -primOpTag FetchNandAddrOp_Word = 526 -primOpTag FetchOrAddrOp_Word = 527 -primOpTag FetchXorAddrOp_Word = 528 -primOpTag AtomicReadAddrOp_Word = 529 -primOpTag AtomicWriteAddrOp_Word = 530 -primOpTag NewMutVarOp = 531 -primOpTag ReadMutVarOp = 532 -primOpTag WriteMutVarOp = 533 -primOpTag SameMutVarOp = 534 -primOpTag AtomicModifyMutVar2Op = 535 -primOpTag AtomicModifyMutVar_Op = 536 -primOpTag CasMutVarOp = 537 -primOpTag CatchOp = 538 -primOpTag RaiseOp = 539 -primOpTag RaiseIOOp = 540 -primOpTag MaskAsyncExceptionsOp = 541 -primOpTag MaskUninterruptibleOp = 542 -primOpTag UnmaskAsyncExceptionsOp = 543 -primOpTag MaskStatus = 544 -primOpTag AtomicallyOp = 545 -primOpTag RetryOp = 546 -primOpTag CatchRetryOp = 547 -primOpTag CatchSTMOp = 548 -primOpTag NewTVarOp = 549 -primOpTag ReadTVarOp = 550 -primOpTag ReadTVarIOOp = 551 -primOpTag WriteTVarOp = 552 -primOpTag SameTVarOp = 553 -primOpTag NewMVarOp = 554 -primOpTag TakeMVarOp = 555 -primOpTag TryTakeMVarOp = 556 -primOpTag PutMVarOp = 557 -primOpTag TryPutMVarOp = 558 -primOpTag ReadMVarOp = 559 -primOpTag TryReadMVarOp = 560 -primOpTag SameMVarOp = 561 -primOpTag IsEmptyMVarOp = 562 -primOpTag NewIOPortrOp = 563 -primOpTag ReadIOPortOp = 564 -primOpTag WriteIOPortOp = 565 -primOpTag SameIOPortOp = 566 -primOpTag DelayOp = 567 -primOpTag WaitReadOp = 568 -primOpTag WaitWriteOp = 569 -primOpTag ForkOp = 570 -primOpTag ForkOnOp = 571 -primOpTag KillThreadOp = 572 -primOpTag YieldOp = 573 -primOpTag MyThreadIdOp = 574 -primOpTag LabelThreadOp = 575 -primOpTag IsCurrentThreadBoundOp = 576 -primOpTag NoDuplicateOp = 577 -primOpTag ThreadStatusOp = 578 -primOpTag MkWeakOp = 579 -primOpTag MkWeakNoFinalizerOp = 580 -primOpTag AddCFinalizerToWeakOp = 581 -primOpTag DeRefWeakOp = 582 -primOpTag FinalizeWeakOp = 583 -primOpTag TouchOp = 584 -primOpTag MakeStablePtrOp = 585 -primOpTag DeRefStablePtrOp = 586 -primOpTag EqStablePtrOp = 587 -primOpTag MakeStableNameOp = 588 -primOpTag EqStableNameOp = 589 -primOpTag StableNameToIntOp = 590 -primOpTag CompactNewOp = 591 -primOpTag CompactResizeOp = 592 -primOpTag CompactContainsOp = 593 -primOpTag CompactContainsAnyOp = 594 -primOpTag CompactGetFirstBlockOp = 595 -primOpTag CompactGetNextBlockOp = 596 -primOpTag CompactAllocateBlockOp = 597 -primOpTag CompactFixupPointersOp = 598 -primOpTag CompactAdd = 599 -primOpTag CompactAddWithSharing = 600 -primOpTag CompactSize = 601 -primOpTag ReallyUnsafePtrEqualityOp = 602 -primOpTag ParOp = 603 -primOpTag SparkOp = 604 -primOpTag SeqOp = 605 -primOpTag GetSparkOp = 606 -primOpTag NumSparks = 607 -primOpTag KeepAliveOp = 608 -primOpTag DataToTagOp = 609 -primOpTag TagToEnumOp = 610 -primOpTag AddrToAnyOp = 611 -primOpTag AnyToAddrOp = 612 -primOpTag MkApUpd0_Op = 613 -primOpTag NewBCOOp = 614 -primOpTag UnpackClosureOp = 615 -primOpTag ClosureSizeOp = 616 -primOpTag GetApStackValOp = 617 -primOpTag GetCCSOfOp = 618 -primOpTag GetCurrentCCSOp = 619 -primOpTag ClearCCSOp = 620 -primOpTag WhereFromOp = 621 -primOpTag TraceEventOp = 622 -primOpTag TraceEventBinaryOp = 623 -primOpTag TraceMarkerOp = 624 -primOpTag SetThreadAllocationCounter = 625 -primOpTag (VecBroadcastOp IntVec 16 W8) = 626 -primOpTag (VecBroadcastOp IntVec 8 W16) = 627 -primOpTag (VecBroadcastOp IntVec 4 W32) = 628 -primOpTag (VecBroadcastOp IntVec 2 W64) = 629 -primOpTag (VecBroadcastOp IntVec 32 W8) = 630 -primOpTag (VecBroadcastOp IntVec 16 W16) = 631 -primOpTag (VecBroadcastOp IntVec 8 W32) = 632 -primOpTag (VecBroadcastOp IntVec 4 W64) = 633 -primOpTag (VecBroadcastOp IntVec 64 W8) = 634 -primOpTag (VecBroadcastOp IntVec 32 W16) = 635 -primOpTag (VecBroadcastOp IntVec 16 W32) = 636 -primOpTag (VecBroadcastOp IntVec 8 W64) = 637 -primOpTag (VecBroadcastOp WordVec 16 W8) = 638 -primOpTag (VecBroadcastOp WordVec 8 W16) = 639 -primOpTag (VecBroadcastOp WordVec 4 W32) = 640 -primOpTag (VecBroadcastOp WordVec 2 W64) = 641 -primOpTag (VecBroadcastOp WordVec 32 W8) = 642 -primOpTag (VecBroadcastOp WordVec 16 W16) = 643 -primOpTag (VecBroadcastOp WordVec 8 W32) = 644 -primOpTag (VecBroadcastOp WordVec 4 W64) = 645 -primOpTag (VecBroadcastOp WordVec 64 W8) = 646 -primOpTag (VecBroadcastOp WordVec 32 W16) = 647 -primOpTag (VecBroadcastOp WordVec 16 W32) = 648 -primOpTag (VecBroadcastOp WordVec 8 W64) = 649 -primOpTag (VecBroadcastOp FloatVec 4 W32) = 650 -primOpTag (VecBroadcastOp FloatVec 2 W64) = 651 -primOpTag (VecBroadcastOp FloatVec 8 W32) = 652 -primOpTag (VecBroadcastOp FloatVec 4 W64) = 653 -primOpTag (VecBroadcastOp FloatVec 16 W32) = 654 -primOpTag (VecBroadcastOp FloatVec 8 W64) = 655 -primOpTag (VecPackOp IntVec 16 W8) = 656 -primOpTag (VecPackOp IntVec 8 W16) = 657 -primOpTag (VecPackOp IntVec 4 W32) = 658 -primOpTag (VecPackOp IntVec 2 W64) = 659 -primOpTag (VecPackOp IntVec 32 W8) = 660 -primOpTag (VecPackOp IntVec 16 W16) = 661 -primOpTag (VecPackOp IntVec 8 W32) = 662 -primOpTag (VecPackOp IntVec 4 W64) = 663 -primOpTag (VecPackOp IntVec 64 W8) = 664 -primOpTag (VecPackOp IntVec 32 W16) = 665 -primOpTag (VecPackOp IntVec 16 W32) = 666 -primOpTag (VecPackOp IntVec 8 W64) = 667 -primOpTag (VecPackOp WordVec 16 W8) = 668 -primOpTag (VecPackOp WordVec 8 W16) = 669 -primOpTag (VecPackOp WordVec 4 W32) = 670 -primOpTag (VecPackOp WordVec 2 W64) = 671 -primOpTag (VecPackOp WordVec 32 W8) = 672 -primOpTag (VecPackOp WordVec 16 W16) = 673 -primOpTag (VecPackOp WordVec 8 W32) = 674 -primOpTag (VecPackOp WordVec 4 W64) = 675 -primOpTag (VecPackOp WordVec 64 W8) = 676 -primOpTag (VecPackOp WordVec 32 W16) = 677 -primOpTag (VecPackOp WordVec 16 W32) = 678 -primOpTag (VecPackOp WordVec 8 W64) = 679 -primOpTag (VecPackOp FloatVec 4 W32) = 680 -primOpTag (VecPackOp FloatVec 2 W64) = 681 -primOpTag (VecPackOp FloatVec 8 W32) = 682 -primOpTag (VecPackOp FloatVec 4 W64) = 683 -primOpTag (VecPackOp FloatVec 16 W32) = 684 -primOpTag (VecPackOp FloatVec 8 W64) = 685 -primOpTag (VecUnpackOp IntVec 16 W8) = 686 -primOpTag (VecUnpackOp IntVec 8 W16) = 687 -primOpTag (VecUnpackOp IntVec 4 W32) = 688 -primOpTag (VecUnpackOp IntVec 2 W64) = 689 -primOpTag (VecUnpackOp IntVec 32 W8) = 690 -primOpTag (VecUnpackOp IntVec 16 W16) = 691 -primOpTag (VecUnpackOp IntVec 8 W32) = 692 -primOpTag (VecUnpackOp IntVec 4 W64) = 693 -primOpTag (VecUnpackOp IntVec 64 W8) = 694 -primOpTag (VecUnpackOp IntVec 32 W16) = 695 -primOpTag (VecUnpackOp IntVec 16 W32) = 696 -primOpTag (VecUnpackOp IntVec 8 W64) = 697 -primOpTag (VecUnpackOp WordVec 16 W8) = 698 -primOpTag (VecUnpackOp WordVec 8 W16) = 699 -primOpTag (VecUnpackOp WordVec 4 W32) = 700 -primOpTag (VecUnpackOp WordVec 2 W64) = 701 -primOpTag (VecUnpackOp WordVec 32 W8) = 702 -primOpTag (VecUnpackOp WordVec 16 W16) = 703 -primOpTag (VecUnpackOp WordVec 8 W32) = 704 -primOpTag (VecUnpackOp WordVec 4 W64) = 705 -primOpTag (VecUnpackOp WordVec 64 W8) = 706 -primOpTag (VecUnpackOp WordVec 32 W16) = 707 -primOpTag (VecUnpackOp WordVec 16 W32) = 708 -primOpTag (VecUnpackOp WordVec 8 W64) = 709 -primOpTag (VecUnpackOp FloatVec 4 W32) = 710 -primOpTag (VecUnpackOp FloatVec 2 W64) = 711 -primOpTag (VecUnpackOp FloatVec 8 W32) = 712 -primOpTag (VecUnpackOp FloatVec 4 W64) = 713 -primOpTag (VecUnpackOp FloatVec 16 W32) = 714 -primOpTag (VecUnpackOp FloatVec 8 W64) = 715 -primOpTag (VecInsertOp IntVec 16 W8) = 716 -primOpTag (VecInsertOp IntVec 8 W16) = 717 -primOpTag (VecInsertOp IntVec 4 W32) = 718 -primOpTag (VecInsertOp IntVec 2 W64) = 719 -primOpTag (VecInsertOp IntVec 32 W8) = 720 -primOpTag (VecInsertOp IntVec 16 W16) = 721 -primOpTag (VecInsertOp IntVec 8 W32) = 722 -primOpTag (VecInsertOp IntVec 4 W64) = 723 -primOpTag (VecInsertOp IntVec 64 W8) = 724 -primOpTag (VecInsertOp IntVec 32 W16) = 725 -primOpTag (VecInsertOp IntVec 16 W32) = 726 -primOpTag (VecInsertOp IntVec 8 W64) = 727 -primOpTag (VecInsertOp WordVec 16 W8) = 728 -primOpTag (VecInsertOp WordVec 8 W16) = 729 -primOpTag (VecInsertOp WordVec 4 W32) = 730 -primOpTag (VecInsertOp WordVec 2 W64) = 731 -primOpTag (VecInsertOp WordVec 32 W8) = 732 -primOpTag (VecInsertOp WordVec 16 W16) = 733 -primOpTag (VecInsertOp WordVec 8 W32) = 734 -primOpTag (VecInsertOp WordVec 4 W64) = 735 -primOpTag (VecInsertOp WordVec 64 W8) = 736 -primOpTag (VecInsertOp WordVec 32 W16) = 737 -primOpTag (VecInsertOp WordVec 16 W32) = 738 -primOpTag (VecInsertOp WordVec 8 W64) = 739 -primOpTag (VecInsertOp FloatVec 4 W32) = 740 -primOpTag (VecInsertOp FloatVec 2 W64) = 741 -primOpTag (VecInsertOp FloatVec 8 W32) = 742 -primOpTag (VecInsertOp FloatVec 4 W64) = 743 -primOpTag (VecInsertOp FloatVec 16 W32) = 744 -primOpTag (VecInsertOp FloatVec 8 W64) = 745 -primOpTag (VecAddOp IntVec 16 W8) = 746 -primOpTag (VecAddOp IntVec 8 W16) = 747 -primOpTag (VecAddOp IntVec 4 W32) = 748 -primOpTag (VecAddOp IntVec 2 W64) = 749 -primOpTag (VecAddOp IntVec 32 W8) = 750 -primOpTag (VecAddOp IntVec 16 W16) = 751 -primOpTag (VecAddOp IntVec 8 W32) = 752 -primOpTag (VecAddOp IntVec 4 W64) = 753 -primOpTag (VecAddOp IntVec 64 W8) = 754 -primOpTag (VecAddOp IntVec 32 W16) = 755 -primOpTag (VecAddOp IntVec 16 W32) = 756 -primOpTag (VecAddOp IntVec 8 W64) = 757 -primOpTag (VecAddOp WordVec 16 W8) = 758 -primOpTag (VecAddOp WordVec 8 W16) = 759 -primOpTag (VecAddOp WordVec 4 W32) = 760 -primOpTag (VecAddOp WordVec 2 W64) = 761 -primOpTag (VecAddOp WordVec 32 W8) = 762 -primOpTag (VecAddOp WordVec 16 W16) = 763 -primOpTag (VecAddOp WordVec 8 W32) = 764 -primOpTag (VecAddOp WordVec 4 W64) = 765 -primOpTag (VecAddOp WordVec 64 W8) = 766 -primOpTag (VecAddOp WordVec 32 W16) = 767 -primOpTag (VecAddOp WordVec 16 W32) = 768 -primOpTag (VecAddOp WordVec 8 W64) = 769 -primOpTag (VecAddOp FloatVec 4 W32) = 770 -primOpTag (VecAddOp FloatVec 2 W64) = 771 -primOpTag (VecAddOp FloatVec 8 W32) = 772 -primOpTag (VecAddOp FloatVec 4 W64) = 773 -primOpTag (VecAddOp FloatVec 16 W32) = 774 -primOpTag (VecAddOp FloatVec 8 W64) = 775 -primOpTag (VecSubOp IntVec 16 W8) = 776 -primOpTag (VecSubOp IntVec 8 W16) = 777 -primOpTag (VecSubOp IntVec 4 W32) = 778 -primOpTag (VecSubOp IntVec 2 W64) = 779 -primOpTag (VecSubOp IntVec 32 W8) = 780 -primOpTag (VecSubOp IntVec 16 W16) = 781 -primOpTag (VecSubOp IntVec 8 W32) = 782 -primOpTag (VecSubOp IntVec 4 W64) = 783 -primOpTag (VecSubOp IntVec 64 W8) = 784 -primOpTag (VecSubOp IntVec 32 W16) = 785 -primOpTag (VecSubOp IntVec 16 W32) = 786 -primOpTag (VecSubOp IntVec 8 W64) = 787 -primOpTag (VecSubOp WordVec 16 W8) = 788 -primOpTag (VecSubOp WordVec 8 W16) = 789 -primOpTag (VecSubOp WordVec 4 W32) = 790 -primOpTag (VecSubOp WordVec 2 W64) = 791 -primOpTag (VecSubOp WordVec 32 W8) = 792 -primOpTag (VecSubOp WordVec 16 W16) = 793 -primOpTag (VecSubOp WordVec 8 W32) = 794 -primOpTag (VecSubOp WordVec 4 W64) = 795 -primOpTag (VecSubOp WordVec 64 W8) = 796 -primOpTag (VecSubOp WordVec 32 W16) = 797 -primOpTag (VecSubOp WordVec 16 W32) = 798 -primOpTag (VecSubOp WordVec 8 W64) = 799 -primOpTag (VecSubOp FloatVec 4 W32) = 800 -primOpTag (VecSubOp FloatVec 2 W64) = 801 -primOpTag (VecSubOp FloatVec 8 W32) = 802 -primOpTag (VecSubOp FloatVec 4 W64) = 803 -primOpTag (VecSubOp FloatVec 16 W32) = 804 -primOpTag (VecSubOp FloatVec 8 W64) = 805 -primOpTag (VecMulOp IntVec 16 W8) = 806 -primOpTag (VecMulOp IntVec 8 W16) = 807 -primOpTag (VecMulOp IntVec 4 W32) = 808 -primOpTag (VecMulOp IntVec 2 W64) = 809 -primOpTag (VecMulOp IntVec 32 W8) = 810 -primOpTag (VecMulOp IntVec 16 W16) = 811 -primOpTag (VecMulOp IntVec 8 W32) = 812 -primOpTag (VecMulOp IntVec 4 W64) = 813 -primOpTag (VecMulOp IntVec 64 W8) = 814 -primOpTag (VecMulOp IntVec 32 W16) = 815 -primOpTag (VecMulOp IntVec 16 W32) = 816 -primOpTag (VecMulOp IntVec 8 W64) = 817 -primOpTag (VecMulOp WordVec 16 W8) = 818 -primOpTag (VecMulOp WordVec 8 W16) = 819 -primOpTag (VecMulOp WordVec 4 W32) = 820 -primOpTag (VecMulOp WordVec 2 W64) = 821 -primOpTag (VecMulOp WordVec 32 W8) = 822 -primOpTag (VecMulOp WordVec 16 W16) = 823 -primOpTag (VecMulOp WordVec 8 W32) = 824 -primOpTag (VecMulOp WordVec 4 W64) = 825 -primOpTag (VecMulOp WordVec 64 W8) = 826 -primOpTag (VecMulOp WordVec 32 W16) = 827 -primOpTag (VecMulOp WordVec 16 W32) = 828 -primOpTag (VecMulOp WordVec 8 W64) = 829 -primOpTag (VecMulOp FloatVec 4 W32) = 830 -primOpTag (VecMulOp FloatVec 2 W64) = 831 -primOpTag (VecMulOp FloatVec 8 W32) = 832 -primOpTag (VecMulOp FloatVec 4 W64) = 833 -primOpTag (VecMulOp FloatVec 16 W32) = 834 -primOpTag (VecMulOp FloatVec 8 W64) = 835 -primOpTag (VecDivOp FloatVec 4 W32) = 836 -primOpTag (VecDivOp FloatVec 2 W64) = 837 -primOpTag (VecDivOp FloatVec 8 W32) = 838 -primOpTag (VecDivOp FloatVec 4 W64) = 839 -primOpTag (VecDivOp FloatVec 16 W32) = 840 -primOpTag (VecDivOp FloatVec 8 W64) = 841 -primOpTag (VecQuotOp IntVec 16 W8) = 842 -primOpTag (VecQuotOp IntVec 8 W16) = 843 -primOpTag (VecQuotOp IntVec 4 W32) = 844 -primOpTag (VecQuotOp IntVec 2 W64) = 845 -primOpTag (VecQuotOp IntVec 32 W8) = 846 -primOpTag (VecQuotOp IntVec 16 W16) = 847 -primOpTag (VecQuotOp IntVec 8 W32) = 848 -primOpTag (VecQuotOp IntVec 4 W64) = 849 -primOpTag (VecQuotOp IntVec 64 W8) = 850 -primOpTag (VecQuotOp IntVec 32 W16) = 851 -primOpTag (VecQuotOp IntVec 16 W32) = 852 -primOpTag (VecQuotOp IntVec 8 W64) = 853 -primOpTag (VecQuotOp WordVec 16 W8) = 854 -primOpTag (VecQuotOp WordVec 8 W16) = 855 -primOpTag (VecQuotOp WordVec 4 W32) = 856 -primOpTag (VecQuotOp WordVec 2 W64) = 857 -primOpTag (VecQuotOp WordVec 32 W8) = 858 -primOpTag (VecQuotOp WordVec 16 W16) = 859 -primOpTag (VecQuotOp WordVec 8 W32) = 860 -primOpTag (VecQuotOp WordVec 4 W64) = 861 -primOpTag (VecQuotOp WordVec 64 W8) = 862 -primOpTag (VecQuotOp WordVec 32 W16) = 863 -primOpTag (VecQuotOp WordVec 16 W32) = 864 -primOpTag (VecQuotOp WordVec 8 W64) = 865 -primOpTag (VecRemOp IntVec 16 W8) = 866 -primOpTag (VecRemOp IntVec 8 W16) = 867 -primOpTag (VecRemOp IntVec 4 W32) = 868 -primOpTag (VecRemOp IntVec 2 W64) = 869 -primOpTag (VecRemOp IntVec 32 W8) = 870 -primOpTag (VecRemOp IntVec 16 W16) = 871 -primOpTag (VecRemOp IntVec 8 W32) = 872 -primOpTag (VecRemOp IntVec 4 W64) = 873 -primOpTag (VecRemOp IntVec 64 W8) = 874 -primOpTag (VecRemOp IntVec 32 W16) = 875 -primOpTag (VecRemOp IntVec 16 W32) = 876 -primOpTag (VecRemOp IntVec 8 W64) = 877 -primOpTag (VecRemOp WordVec 16 W8) = 878 -primOpTag (VecRemOp WordVec 8 W16) = 879 -primOpTag (VecRemOp WordVec 4 W32) = 880 -primOpTag (VecRemOp WordVec 2 W64) = 881 -primOpTag (VecRemOp WordVec 32 W8) = 882 -primOpTag (VecRemOp WordVec 16 W16) = 883 -primOpTag (VecRemOp WordVec 8 W32) = 884 -primOpTag (VecRemOp WordVec 4 W64) = 885 -primOpTag (VecRemOp WordVec 64 W8) = 886 -primOpTag (VecRemOp WordVec 32 W16) = 887 -primOpTag (VecRemOp WordVec 16 W32) = 888 -primOpTag (VecRemOp WordVec 8 W64) = 889 -primOpTag (VecNegOp IntVec 16 W8) = 890 -primOpTag (VecNegOp IntVec 8 W16) = 891 -primOpTag (VecNegOp IntVec 4 W32) = 892 -primOpTag (VecNegOp IntVec 2 W64) = 893 -primOpTag (VecNegOp IntVec 32 W8) = 894 -primOpTag (VecNegOp IntVec 16 W16) = 895 -primOpTag (VecNegOp IntVec 8 W32) = 896 -primOpTag (VecNegOp IntVec 4 W64) = 897 -primOpTag (VecNegOp IntVec 64 W8) = 898 -primOpTag (VecNegOp IntVec 32 W16) = 899 -primOpTag (VecNegOp IntVec 16 W32) = 900 -primOpTag (VecNegOp IntVec 8 W64) = 901 -primOpTag (VecNegOp FloatVec 4 W32) = 902 -primOpTag (VecNegOp FloatVec 2 W64) = 903 -primOpTag (VecNegOp FloatVec 8 W32) = 904 -primOpTag (VecNegOp FloatVec 4 W64) = 905 -primOpTag (VecNegOp FloatVec 16 W32) = 906 -primOpTag (VecNegOp FloatVec 8 W64) = 907 -primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 908 -primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 909 -primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 910 -primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 911 -primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 912 -primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 913 -primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 914 -primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 915 -primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 916 -primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 917 -primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 918 -primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 919 -primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 920 -primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 921 -primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 922 -primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 923 -primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 924 -primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 925 -primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 926 -primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 927 -primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 928 -primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 929 -primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 930 -primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 931 -primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 932 -primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 933 -primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 934 -primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 935 -primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 936 -primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 937 -primOpTag (VecReadByteArrayOp IntVec 16 W8) = 938 -primOpTag (VecReadByteArrayOp IntVec 8 W16) = 939 -primOpTag (VecReadByteArrayOp IntVec 4 W32) = 940 -primOpTag (VecReadByteArrayOp IntVec 2 W64) = 941 -primOpTag (VecReadByteArrayOp IntVec 32 W8) = 942 -primOpTag (VecReadByteArrayOp IntVec 16 W16) = 943 -primOpTag (VecReadByteArrayOp IntVec 8 W32) = 944 -primOpTag (VecReadByteArrayOp IntVec 4 W64) = 945 -primOpTag (VecReadByteArrayOp IntVec 64 W8) = 946 -primOpTag (VecReadByteArrayOp IntVec 32 W16) = 947 -primOpTag (VecReadByteArrayOp IntVec 16 W32) = 948 -primOpTag (VecReadByteArrayOp IntVec 8 W64) = 949 -primOpTag (VecReadByteArrayOp WordVec 16 W8) = 950 -primOpTag (VecReadByteArrayOp WordVec 8 W16) = 951 -primOpTag (VecReadByteArrayOp WordVec 4 W32) = 952 -primOpTag (VecReadByteArrayOp WordVec 2 W64) = 953 -primOpTag (VecReadByteArrayOp WordVec 32 W8) = 954 -primOpTag (VecReadByteArrayOp WordVec 16 W16) = 955 -primOpTag (VecReadByteArrayOp WordVec 8 W32) = 956 -primOpTag (VecReadByteArrayOp WordVec 4 W64) = 957 -primOpTag (VecReadByteArrayOp WordVec 64 W8) = 958 -primOpTag (VecReadByteArrayOp WordVec 32 W16) = 959 -primOpTag (VecReadByteArrayOp WordVec 16 W32) = 960 -primOpTag (VecReadByteArrayOp WordVec 8 W64) = 961 -primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 962 -primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 963 -primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 964 -primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 965 -primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 966 -primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 967 -primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 968 -primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 969 -primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 970 -primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 971 -primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 972 -primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 973 -primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 974 -primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 975 -primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 976 -primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 977 -primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 978 -primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 979 -primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 980 -primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 981 -primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 982 -primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 983 -primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 984 -primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 985 -primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 986 -primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 987 -primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 988 -primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 989 -primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 990 -primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 991 -primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 992 -primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 993 -primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 994 -primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 995 -primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 996 -primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 997 -primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 998 -primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 999 -primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 1000 -primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 1001 -primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 1002 -primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1003 -primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1004 -primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1005 -primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1006 -primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1007 -primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1008 -primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1009 -primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1010 -primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1011 -primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1012 -primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1013 -primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1014 -primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1015 -primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1016 -primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1017 -primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1018 -primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1019 -primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1020 -primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1021 -primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1022 -primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1023 -primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1024 -primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1025 -primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1026 -primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1027 -primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1028 -primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1029 -primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1030 -primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1031 -primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1032 -primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1033 -primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1034 -primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1035 -primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1036 -primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1037 -primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1038 -primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1039 -primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1040 -primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1041 -primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1042 -primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1043 -primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1044 -primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1045 -primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1046 -primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1047 -primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1048 -primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1049 -primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1050 -primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1051 -primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1052 -primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1053 -primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1054 -primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1055 -primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1056 -primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1057 -primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1058 -primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1059 -primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1060 -primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1061 -primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1062 -primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1063 -primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1064 -primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1065 -primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1066 -primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1067 -primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1068 -primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1069 -primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1070 -primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1071 -primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1072 -primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1073 -primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1074 -primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1075 -primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1076 -primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1077 -primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1078 -primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1079 -primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1080 -primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1081 -primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1082 -primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1083 -primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1084 -primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1085 -primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1086 -primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1087 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1088 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1089 -primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1090 -primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1091 -primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1092 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1093 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1094 -primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1095 -primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1096 -primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1097 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1098 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1099 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1100 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1101 -primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1102 -primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1103 -primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1104 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1105 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1106 -primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1107 -primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1108 -primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1109 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1110 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1111 -primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1112 -primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1113 -primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1114 -primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1115 -primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1116 -primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1117 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1118 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1119 -primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1120 -primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1121 -primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1122 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1123 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1124 -primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1125 -primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1126 -primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1127 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1128 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1129 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1130 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1131 -primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1132 -primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1133 -primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1134 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1135 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1136 -primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1137 -primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1138 -primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1139 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1140 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1141 -primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1142 -primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1143 -primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1144 -primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1145 -primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1146 -primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1147 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1148 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1149 -primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1150 -primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1151 -primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1152 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1153 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1154 -primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1155 -primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1156 -primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1157 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1158 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1159 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1160 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1161 -primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1162 -primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1163 -primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1164 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1165 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1166 -primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1167 -primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1168 -primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1169 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1170 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1171 -primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1172 -primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1173 -primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1174 -primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1175 -primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1176 -primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1177 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1178 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1179 -primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1180 -primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1181 -primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1182 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1183 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1184 -primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1185 -primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1186 -primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1187 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1188 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1189 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1190 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1191 -primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1192 -primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1193 -primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1194 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1195 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1196 -primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1197 -primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1198 -primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1199 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1200 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1201 -primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1202 -primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1203 -primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1204 -primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1205 -primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1206 -primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1207 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1208 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1209 -primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1210 -primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1211 -primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1212 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1213 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1214 -primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1215 -primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1216 -primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1217 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1218 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1219 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1220 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1221 -primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1222 -primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1223 -primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1224 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1225 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1226 -primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1227 -primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1228 -primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1229 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1230 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1231 -primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1232 -primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1233 -primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1234 -primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1235 -primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1236 -primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1237 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1238 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1239 -primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1240 -primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1241 -primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1242 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1243 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1244 -primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1245 -primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1246 -primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1247 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1248 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1249 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1250 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1251 -primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1252 -primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1253 -primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1254 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1255 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1256 -primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1257 -primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1258 -primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1259 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1260 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1261 -primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1262 -primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1263 -primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1264 -primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1265 -primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1266 -primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1267 -primOpTag PrefetchByteArrayOp3 = 1268 -primOpTag PrefetchMutableByteArrayOp3 = 1269 -primOpTag PrefetchAddrOp3 = 1270 -primOpTag PrefetchValueOp3 = 1271 -primOpTag PrefetchByteArrayOp2 = 1272 -primOpTag PrefetchMutableByteArrayOp2 = 1273 -primOpTag PrefetchAddrOp2 = 1274 -primOpTag PrefetchValueOp2 = 1275 -primOpTag PrefetchByteArrayOp1 = 1276 -primOpTag PrefetchMutableByteArrayOp1 = 1277 -primOpTag PrefetchAddrOp1 = 1278 -primOpTag PrefetchValueOp1 = 1279 -primOpTag PrefetchByteArrayOp0 = 1280 -primOpTag PrefetchMutableByteArrayOp0 = 1281 -primOpTag PrefetchAddrOp0 = 1282 -primOpTag PrefetchValueOp0 = 1283 +maxPrimOpTag = 1274 +primOpTag :: PrimOp -> Int +primOpTag CharGtOp = 1 +primOpTag CharGeOp = 2 +primOpTag CharEqOp = 3 +primOpTag CharNeOp = 4 +primOpTag CharLtOp = 5 +primOpTag CharLeOp = 6 +primOpTag OrdOp = 7 +primOpTag Int8ToIntOp = 8 +primOpTag IntToInt8Op = 9 +primOpTag Int8NegOp = 10 +primOpTag Int8AddOp = 11 +primOpTag Int8SubOp = 12 +primOpTag Int8MulOp = 13 +primOpTag Int8QuotOp = 14 +primOpTag Int8RemOp = 15 +primOpTag Int8QuotRemOp = 16 +primOpTag Int8SllOp = 17 +primOpTag Int8SraOp = 18 +primOpTag Int8SrlOp = 19 +primOpTag Int8ToWord8Op = 20 +primOpTag Int8EqOp = 21 +primOpTag Int8GeOp = 22 +primOpTag Int8GtOp = 23 +primOpTag Int8LeOp = 24 +primOpTag Int8LtOp = 25 +primOpTag Int8NeOp = 26 +primOpTag Word8ToWordOp = 27 +primOpTag WordToWord8Op = 28 +primOpTag Word8AddOp = 29 +primOpTag Word8SubOp = 30 +primOpTag Word8MulOp = 31 +primOpTag Word8QuotOp = 32 +primOpTag Word8RemOp = 33 +primOpTag Word8QuotRemOp = 34 +primOpTag Word8AndOp = 35 +primOpTag Word8OrOp = 36 +primOpTag Word8XorOp = 37 +primOpTag Word8NotOp = 38 +primOpTag Word8SllOp = 39 +primOpTag Word8SrlOp = 40 +primOpTag Word8ToInt8Op = 41 +primOpTag Word8EqOp = 42 +primOpTag Word8GeOp = 43 +primOpTag Word8GtOp = 44 +primOpTag Word8LeOp = 45 +primOpTag Word8LtOp = 46 +primOpTag Word8NeOp = 47 +primOpTag Int16ToIntOp = 48 +primOpTag IntToInt16Op = 49 +primOpTag Int16NegOp = 50 +primOpTag Int16AddOp = 51 +primOpTag Int16SubOp = 52 +primOpTag Int16MulOp = 53 +primOpTag Int16QuotOp = 54 +primOpTag Int16RemOp = 55 +primOpTag Int16QuotRemOp = 56 +primOpTag Int16SllOp = 57 +primOpTag Int16SraOp = 58 +primOpTag Int16SrlOp = 59 +primOpTag Int16ToWord16Op = 60 +primOpTag Int16EqOp = 61 +primOpTag Int16GeOp = 62 +primOpTag Int16GtOp = 63 +primOpTag Int16LeOp = 64 +primOpTag Int16LtOp = 65 +primOpTag Int16NeOp = 66 +primOpTag Word16ToWordOp = 67 +primOpTag WordToWord16Op = 68 +primOpTag Word16AddOp = 69 +primOpTag Word16SubOp = 70 +primOpTag Word16MulOp = 71 +primOpTag Word16QuotOp = 72 +primOpTag Word16RemOp = 73 +primOpTag Word16QuotRemOp = 74 +primOpTag Word16AndOp = 75 +primOpTag Word16OrOp = 76 +primOpTag Word16XorOp = 77 +primOpTag Word16NotOp = 78 +primOpTag Word16SllOp = 79 +primOpTag Word16SrlOp = 80 +primOpTag Word16ToInt16Op = 81 +primOpTag Word16EqOp = 82 +primOpTag Word16GeOp = 83 +primOpTag Word16GtOp = 84 +primOpTag Word16LeOp = 85 +primOpTag Word16LtOp = 86 +primOpTag Word16NeOp = 87 +primOpTag Int32ToIntOp = 88 +primOpTag IntToInt32Op = 89 +primOpTag Int32NegOp = 90 +primOpTag Int32AddOp = 91 +primOpTag Int32SubOp = 92 +primOpTag Int32MulOp = 93 +primOpTag Int32QuotOp = 94 +primOpTag Int32RemOp = 95 +primOpTag Int32QuotRemOp = 96 +primOpTag Int32SllOp = 97 +primOpTag Int32SraOp = 98 +primOpTag Int32SrlOp = 99 +primOpTag Int32ToWord32Op = 100 +primOpTag Int32EqOp = 101 +primOpTag Int32GeOp = 102 +primOpTag Int32GtOp = 103 +primOpTag Int32LeOp = 104 +primOpTag Int32LtOp = 105 +primOpTag Int32NeOp = 106 +primOpTag Word32ToWordOp = 107 +primOpTag WordToWord32Op = 108 +primOpTag Word32AddOp = 109 +primOpTag Word32SubOp = 110 +primOpTag Word32MulOp = 111 +primOpTag Word32QuotOp = 112 +primOpTag Word32RemOp = 113 +primOpTag Word32QuotRemOp = 114 +primOpTag Word32AndOp = 115 +primOpTag Word32OrOp = 116 +primOpTag Word32XorOp = 117 +primOpTag Word32NotOp = 118 +primOpTag Word32SllOp = 119 +primOpTag Word32SrlOp = 120 +primOpTag Word32ToInt32Op = 121 +primOpTag Word32EqOp = 122 +primOpTag Word32GeOp = 123 +primOpTag Word32GtOp = 124 +primOpTag Word32LeOp = 125 +primOpTag Word32LtOp = 126 +primOpTag Word32NeOp = 127 +primOpTag IntAddOp = 128 +primOpTag IntSubOp = 129 +primOpTag IntMulOp = 130 +primOpTag IntMul2Op = 131 +primOpTag IntMulMayOfloOp = 132 +primOpTag IntQuotOp = 133 +primOpTag IntRemOp = 134 +primOpTag IntQuotRemOp = 135 +primOpTag IntAndOp = 136 +primOpTag IntOrOp = 137 +primOpTag IntXorOp = 138 +primOpTag IntNotOp = 139 +primOpTag IntNegOp = 140 +primOpTag IntAddCOp = 141 +primOpTag IntSubCOp = 142 +primOpTag IntGtOp = 143 +primOpTag IntGeOp = 144 +primOpTag IntEqOp = 145 +primOpTag IntNeOp = 146 +primOpTag IntLtOp = 147 +primOpTag IntLeOp = 148 +primOpTag ChrOp = 149 +primOpTag IntToWordOp = 150 +primOpTag IntToFloatOp = 151 +primOpTag IntToDoubleOp = 152 +primOpTag WordToFloatOp = 153 +primOpTag WordToDoubleOp = 154 +primOpTag IntSllOp = 155 +primOpTag IntSraOp = 156 +primOpTag IntSrlOp = 157 +primOpTag WordAddOp = 158 +primOpTag WordAddCOp = 159 +primOpTag WordSubCOp = 160 +primOpTag WordAdd2Op = 161 +primOpTag WordSubOp = 162 +primOpTag WordMulOp = 163 +primOpTag WordMul2Op = 164 +primOpTag WordQuotOp = 165 +primOpTag WordRemOp = 166 +primOpTag WordQuotRemOp = 167 +primOpTag WordQuotRem2Op = 168 +primOpTag WordAndOp = 169 +primOpTag WordOrOp = 170 +primOpTag WordXorOp = 171 +primOpTag WordNotOp = 172 +primOpTag WordSllOp = 173 +primOpTag WordSrlOp = 174 +primOpTag WordToIntOp = 175 +primOpTag WordGtOp = 176 +primOpTag WordGeOp = 177 +primOpTag WordEqOp = 178 +primOpTag WordNeOp = 179 +primOpTag WordLtOp = 180 +primOpTag WordLeOp = 181 +primOpTag PopCnt8Op = 182 +primOpTag PopCnt16Op = 183 +primOpTag PopCnt32Op = 184 +primOpTag PopCnt64Op = 185 +primOpTag PopCntOp = 186 +primOpTag Pdep8Op = 187 +primOpTag Pdep16Op = 188 +primOpTag Pdep32Op = 189 +primOpTag Pdep64Op = 190 +primOpTag PdepOp = 191 +primOpTag Pext8Op = 192 +primOpTag Pext16Op = 193 +primOpTag Pext32Op = 194 +primOpTag Pext64Op = 195 +primOpTag PextOp = 196 +primOpTag Clz8Op = 197 +primOpTag Clz16Op = 198 +primOpTag Clz32Op = 199 +primOpTag Clz64Op = 200 +primOpTag ClzOp = 201 +primOpTag Ctz8Op = 202 +primOpTag Ctz16Op = 203 +primOpTag Ctz32Op = 204 +primOpTag Ctz64Op = 205 +primOpTag CtzOp = 206 +primOpTag BSwap16Op = 207 +primOpTag BSwap32Op = 208 +primOpTag BSwap64Op = 209 +primOpTag BSwapOp = 210 +primOpTag BRev8Op = 211 +primOpTag BRev16Op = 212 +primOpTag BRev32Op = 213 +primOpTag BRev64Op = 214 +primOpTag BRevOp = 215 +primOpTag Narrow8IntOp = 216 +primOpTag Narrow16IntOp = 217 +primOpTag Narrow32IntOp = 218 +primOpTag Narrow8WordOp = 219 +primOpTag Narrow16WordOp = 220 +primOpTag Narrow32WordOp = 221 +primOpTag DoubleGtOp = 222 +primOpTag DoubleGeOp = 223 +primOpTag DoubleEqOp = 224 +primOpTag DoubleNeOp = 225 +primOpTag DoubleLtOp = 226 +primOpTag DoubleLeOp = 227 +primOpTag DoubleAddOp = 228 +primOpTag DoubleSubOp = 229 +primOpTag DoubleMulOp = 230 +primOpTag DoubleDivOp = 231 +primOpTag DoubleNegOp = 232 +primOpTag DoubleFabsOp = 233 +primOpTag DoubleToIntOp = 234 +primOpTag DoubleToFloatOp = 235 +primOpTag DoubleExpOp = 236 +primOpTag DoubleExpM1Op = 237 +primOpTag DoubleLogOp = 238 +primOpTag DoubleLog1POp = 239 +primOpTag DoubleSqrtOp = 240 +primOpTag DoubleSinOp = 241 +primOpTag DoubleCosOp = 242 +primOpTag DoubleTanOp = 243 +primOpTag DoubleAsinOp = 244 +primOpTag DoubleAcosOp = 245 +primOpTag DoubleAtanOp = 246 +primOpTag DoubleSinhOp = 247 +primOpTag DoubleCoshOp = 248 +primOpTag DoubleTanhOp = 249 +primOpTag DoubleAsinhOp = 250 +primOpTag DoubleAcoshOp = 251 +primOpTag DoubleAtanhOp = 252 +primOpTag DoublePowerOp = 253 +primOpTag DoubleDecode_2IntOp = 254 +primOpTag DoubleDecode_Int64Op = 255 +primOpTag FloatGtOp = 256 +primOpTag FloatGeOp = 257 +primOpTag FloatEqOp = 258 +primOpTag FloatNeOp = 259 +primOpTag FloatLtOp = 260 +primOpTag FloatLeOp = 261 +primOpTag FloatAddOp = 262 +primOpTag FloatSubOp = 263 +primOpTag FloatMulOp = 264 +primOpTag FloatDivOp = 265 +primOpTag FloatNegOp = 266 +primOpTag FloatFabsOp = 267 +primOpTag FloatToIntOp = 268 +primOpTag FloatExpOp = 269 +primOpTag FloatExpM1Op = 270 +primOpTag FloatLogOp = 271 +primOpTag FloatLog1POp = 272 +primOpTag FloatSqrtOp = 273 +primOpTag FloatSinOp = 274 +primOpTag FloatCosOp = 275 +primOpTag FloatTanOp = 276 +primOpTag FloatAsinOp = 277 +primOpTag FloatAcosOp = 278 +primOpTag FloatAtanOp = 279 +primOpTag FloatSinhOp = 280 +primOpTag FloatCoshOp = 281 +primOpTag FloatTanhOp = 282 +primOpTag FloatAsinhOp = 283 +primOpTag FloatAcoshOp = 284 +primOpTag FloatAtanhOp = 285 +primOpTag FloatPowerOp = 286 +primOpTag FloatToDoubleOp = 287 +primOpTag FloatDecode_IntOp = 288 +primOpTag NewArrayOp = 289 +primOpTag ReadArrayOp = 290 +primOpTag WriteArrayOp = 291 +primOpTag SizeofArrayOp = 292 +primOpTag SizeofMutableArrayOp = 293 +primOpTag IndexArrayOp = 294 +primOpTag UnsafeFreezeArrayOp = 295 +primOpTag UnsafeThawArrayOp = 296 +primOpTag CopyArrayOp = 297 +primOpTag CopyMutableArrayOp = 298 +primOpTag CloneArrayOp = 299 +primOpTag CloneMutableArrayOp = 300 +primOpTag FreezeArrayOp = 301 +primOpTag ThawArrayOp = 302 +primOpTag CasArrayOp = 303 +primOpTag NewSmallArrayOp = 304 +primOpTag ShrinkSmallMutableArrayOp_Char = 305 +primOpTag ReadSmallArrayOp = 306 +primOpTag WriteSmallArrayOp = 307 +primOpTag SizeofSmallArrayOp = 308 +primOpTag SizeofSmallMutableArrayOp = 309 +primOpTag GetSizeofSmallMutableArrayOp = 310 +primOpTag IndexSmallArrayOp = 311 +primOpTag UnsafeFreezeSmallArrayOp = 312 +primOpTag UnsafeThawSmallArrayOp = 313 +primOpTag CopySmallArrayOp = 314 +primOpTag CopySmallMutableArrayOp = 315 +primOpTag CloneSmallArrayOp = 316 +primOpTag CloneSmallMutableArrayOp = 317 +primOpTag FreezeSmallArrayOp = 318 +primOpTag ThawSmallArrayOp = 319 +primOpTag CasSmallArrayOp = 320 +primOpTag NewByteArrayOp_Char = 321 +primOpTag NewPinnedByteArrayOp_Char = 322 +primOpTag NewAlignedPinnedByteArrayOp_Char = 323 +primOpTag MutableByteArrayIsPinnedOp = 324 +primOpTag ByteArrayIsPinnedOp = 325 +primOpTag ByteArrayContents_Char = 326 +primOpTag MutableByteArrayContents_Char = 327 +primOpTag ShrinkMutableByteArrayOp_Char = 328 +primOpTag ResizeMutableByteArrayOp_Char = 329 +primOpTag UnsafeFreezeByteArrayOp = 330 +primOpTag SizeofByteArrayOp = 331 +primOpTag SizeofMutableByteArrayOp = 332 +primOpTag GetSizeofMutableByteArrayOp = 333 +primOpTag IndexByteArrayOp_Char = 334 +primOpTag IndexByteArrayOp_WideChar = 335 +primOpTag IndexByteArrayOp_Int = 336 +primOpTag IndexByteArrayOp_Word = 337 +primOpTag IndexByteArrayOp_Addr = 338 +primOpTag IndexByteArrayOp_Float = 339 +primOpTag IndexByteArrayOp_Double = 340 +primOpTag IndexByteArrayOp_StablePtr = 341 +primOpTag IndexByteArrayOp_Int8 = 342 +primOpTag IndexByteArrayOp_Int16 = 343 +primOpTag IndexByteArrayOp_Int32 = 344 +primOpTag IndexByteArrayOp_Int64 = 345 +primOpTag IndexByteArrayOp_Word8 = 346 +primOpTag IndexByteArrayOp_Word16 = 347 +primOpTag IndexByteArrayOp_Word32 = 348 +primOpTag IndexByteArrayOp_Word64 = 349 +primOpTag IndexByteArrayOp_Word8AsChar = 350 +primOpTag IndexByteArrayOp_Word8AsWideChar = 351 +primOpTag IndexByteArrayOp_Word8AsInt = 352 +primOpTag IndexByteArrayOp_Word8AsWord = 353 +primOpTag IndexByteArrayOp_Word8AsAddr = 354 +primOpTag IndexByteArrayOp_Word8AsFloat = 355 +primOpTag IndexByteArrayOp_Word8AsDouble = 356 +primOpTag IndexByteArrayOp_Word8AsStablePtr = 357 +primOpTag IndexByteArrayOp_Word8AsInt16 = 358 +primOpTag IndexByteArrayOp_Word8AsInt32 = 359 +primOpTag IndexByteArrayOp_Word8AsInt64 = 360 +primOpTag IndexByteArrayOp_Word8AsWord16 = 361 +primOpTag IndexByteArrayOp_Word8AsWord32 = 362 +primOpTag IndexByteArrayOp_Word8AsWord64 = 363 +primOpTag ReadByteArrayOp_Char = 364 +primOpTag ReadByteArrayOp_WideChar = 365 +primOpTag ReadByteArrayOp_Int = 366 +primOpTag ReadByteArrayOp_Word = 367 +primOpTag ReadByteArrayOp_Addr = 368 +primOpTag ReadByteArrayOp_Float = 369 +primOpTag ReadByteArrayOp_Double = 370 +primOpTag ReadByteArrayOp_StablePtr = 371 +primOpTag ReadByteArrayOp_Int8 = 372 +primOpTag ReadByteArrayOp_Int16 = 373 +primOpTag ReadByteArrayOp_Int32 = 374 +primOpTag ReadByteArrayOp_Int64 = 375 +primOpTag ReadByteArrayOp_Word8 = 376 +primOpTag ReadByteArrayOp_Word16 = 377 +primOpTag ReadByteArrayOp_Word32 = 378 +primOpTag ReadByteArrayOp_Word64 = 379 +primOpTag ReadByteArrayOp_Word8AsChar = 380 +primOpTag ReadByteArrayOp_Word8AsWideChar = 381 +primOpTag ReadByteArrayOp_Word8AsInt = 382 +primOpTag ReadByteArrayOp_Word8AsWord = 383 +primOpTag ReadByteArrayOp_Word8AsAddr = 384 +primOpTag ReadByteArrayOp_Word8AsFloat = 385 +primOpTag ReadByteArrayOp_Word8AsDouble = 386 +primOpTag ReadByteArrayOp_Word8AsStablePtr = 387 +primOpTag ReadByteArrayOp_Word8AsInt16 = 388 +primOpTag ReadByteArrayOp_Word8AsInt32 = 389 +primOpTag ReadByteArrayOp_Word8AsInt64 = 390 +primOpTag ReadByteArrayOp_Word8AsWord16 = 391 +primOpTag ReadByteArrayOp_Word8AsWord32 = 392 +primOpTag ReadByteArrayOp_Word8AsWord64 = 393 +primOpTag WriteByteArrayOp_Char = 394 +primOpTag WriteByteArrayOp_WideChar = 395 +primOpTag WriteByteArrayOp_Int = 396 +primOpTag WriteByteArrayOp_Word = 397 +primOpTag WriteByteArrayOp_Addr = 398 +primOpTag WriteByteArrayOp_Float = 399 +primOpTag WriteByteArrayOp_Double = 400 +primOpTag WriteByteArrayOp_StablePtr = 401 +primOpTag WriteByteArrayOp_Int8 = 402 +primOpTag WriteByteArrayOp_Int16 = 403 +primOpTag WriteByteArrayOp_Int32 = 404 +primOpTag WriteByteArrayOp_Int64 = 405 +primOpTag WriteByteArrayOp_Word8 = 406 +primOpTag WriteByteArrayOp_Word16 = 407 +primOpTag WriteByteArrayOp_Word32 = 408 +primOpTag WriteByteArrayOp_Word64 = 409 +primOpTag WriteByteArrayOp_Word8AsChar = 410 +primOpTag WriteByteArrayOp_Word8AsWideChar = 411 +primOpTag WriteByteArrayOp_Word8AsInt = 412 +primOpTag WriteByteArrayOp_Word8AsWord = 413 +primOpTag WriteByteArrayOp_Word8AsAddr = 414 +primOpTag WriteByteArrayOp_Word8AsFloat = 415 +primOpTag WriteByteArrayOp_Word8AsDouble = 416 +primOpTag WriteByteArrayOp_Word8AsStablePtr = 417 +primOpTag WriteByteArrayOp_Word8AsInt16 = 418 +primOpTag WriteByteArrayOp_Word8AsInt32 = 419 +primOpTag WriteByteArrayOp_Word8AsInt64 = 420 +primOpTag WriteByteArrayOp_Word8AsWord16 = 421 +primOpTag WriteByteArrayOp_Word8AsWord32 = 422 +primOpTag WriteByteArrayOp_Word8AsWord64 = 423 +primOpTag CompareByteArraysOp = 424 +primOpTag CopyByteArrayOp = 425 +primOpTag CopyMutableByteArrayOp = 426 +primOpTag CopyByteArrayToAddrOp = 427 +primOpTag CopyMutableByteArrayToAddrOp = 428 +primOpTag CopyAddrToByteArrayOp = 429 +primOpTag SetByteArrayOp = 430 +primOpTag AtomicReadByteArrayOp_Int = 431 +primOpTag AtomicWriteByteArrayOp_Int = 432 +primOpTag CasByteArrayOp_Int = 433 +primOpTag FetchAddByteArrayOp_Int = 434 +primOpTag FetchSubByteArrayOp_Int = 435 +primOpTag FetchAndByteArrayOp_Int = 436 +primOpTag FetchNandByteArrayOp_Int = 437 +primOpTag FetchOrByteArrayOp_Int = 438 +primOpTag FetchXorByteArrayOp_Int = 439 +primOpTag NewArrayArrayOp = 440 +primOpTag UnsafeFreezeArrayArrayOp = 441 +primOpTag SizeofArrayArrayOp = 442 +primOpTag SizeofMutableArrayArrayOp = 443 +primOpTag IndexArrayArrayOp_ByteArray = 444 +primOpTag IndexArrayArrayOp_ArrayArray = 445 +primOpTag ReadArrayArrayOp_ByteArray = 446 +primOpTag ReadArrayArrayOp_MutableByteArray = 447 +primOpTag ReadArrayArrayOp_ArrayArray = 448 +primOpTag ReadArrayArrayOp_MutableArrayArray = 449 +primOpTag WriteArrayArrayOp_ByteArray = 450 +primOpTag WriteArrayArrayOp_MutableByteArray = 451 +primOpTag WriteArrayArrayOp_ArrayArray = 452 +primOpTag WriteArrayArrayOp_MutableArrayArray = 453 +primOpTag CopyArrayArrayOp = 454 +primOpTag CopyMutableArrayArrayOp = 455 +primOpTag AddrAddOp = 456 +primOpTag AddrSubOp = 457 +primOpTag AddrRemOp = 458 +primOpTag AddrToIntOp = 459 +primOpTag IntToAddrOp = 460 +primOpTag AddrGtOp = 461 +primOpTag AddrGeOp = 462 +primOpTag AddrEqOp = 463 +primOpTag AddrNeOp = 464 +primOpTag AddrLtOp = 465 +primOpTag AddrLeOp = 466 +primOpTag IndexOffAddrOp_Char = 467 +primOpTag IndexOffAddrOp_WideChar = 468 +primOpTag IndexOffAddrOp_Int = 469 +primOpTag IndexOffAddrOp_Word = 470 +primOpTag IndexOffAddrOp_Addr = 471 +primOpTag IndexOffAddrOp_Float = 472 +primOpTag IndexOffAddrOp_Double = 473 +primOpTag IndexOffAddrOp_StablePtr = 474 +primOpTag IndexOffAddrOp_Int8 = 475 +primOpTag IndexOffAddrOp_Int16 = 476 +primOpTag IndexOffAddrOp_Int32 = 477 +primOpTag IndexOffAddrOp_Int64 = 478 +primOpTag IndexOffAddrOp_Word8 = 479 +primOpTag IndexOffAddrOp_Word16 = 480 +primOpTag IndexOffAddrOp_Word32 = 481 +primOpTag IndexOffAddrOp_Word64 = 482 +primOpTag ReadOffAddrOp_Char = 483 +primOpTag ReadOffAddrOp_WideChar = 484 +primOpTag ReadOffAddrOp_Int = 485 +primOpTag ReadOffAddrOp_Word = 486 +primOpTag ReadOffAddrOp_Addr = 487 +primOpTag ReadOffAddrOp_Float = 488 +primOpTag ReadOffAddrOp_Double = 489 +primOpTag ReadOffAddrOp_StablePtr = 490 +primOpTag ReadOffAddrOp_Int8 = 491 +primOpTag ReadOffAddrOp_Int16 = 492 +primOpTag ReadOffAddrOp_Int32 = 493 +primOpTag ReadOffAddrOp_Int64 = 494 +primOpTag ReadOffAddrOp_Word8 = 495 +primOpTag ReadOffAddrOp_Word16 = 496 +primOpTag ReadOffAddrOp_Word32 = 497 +primOpTag ReadOffAddrOp_Word64 = 498 +primOpTag WriteOffAddrOp_Char = 499 +primOpTag WriteOffAddrOp_WideChar = 500 +primOpTag WriteOffAddrOp_Int = 501 +primOpTag WriteOffAddrOp_Word = 502 +primOpTag WriteOffAddrOp_Addr = 503 +primOpTag WriteOffAddrOp_Float = 504 +primOpTag WriteOffAddrOp_Double = 505 +primOpTag WriteOffAddrOp_StablePtr = 506 +primOpTag WriteOffAddrOp_Int8 = 507 +primOpTag WriteOffAddrOp_Int16 = 508 +primOpTag WriteOffAddrOp_Int32 = 509 +primOpTag WriteOffAddrOp_Int64 = 510 +primOpTag WriteOffAddrOp_Word8 = 511 +primOpTag WriteOffAddrOp_Word16 = 512 +primOpTag WriteOffAddrOp_Word32 = 513 +primOpTag WriteOffAddrOp_Word64 = 514 +primOpTag InterlockedExchange_Addr = 515 +primOpTag InterlockedExchange_Word = 516 +primOpTag CasAddrOp_Addr = 517 +primOpTag CasAddrOp_Word = 518 +primOpTag FetchAddAddrOp_Word = 519 +primOpTag FetchSubAddrOp_Word = 520 +primOpTag FetchAndAddrOp_Word = 521 +primOpTag FetchNandAddrOp_Word = 522 +primOpTag FetchOrAddrOp_Word = 523 +primOpTag FetchXorAddrOp_Word = 524 +primOpTag AtomicReadAddrOp_Word = 525 +primOpTag AtomicWriteAddrOp_Word = 526 +primOpTag NewMutVarOp = 527 +primOpTag ReadMutVarOp = 528 +primOpTag WriteMutVarOp = 529 +primOpTag AtomicModifyMutVar2Op = 530 +primOpTag AtomicModifyMutVar_Op = 531 +primOpTag CasMutVarOp = 532 +primOpTag CatchOp = 533 +primOpTag RaiseOp = 534 +primOpTag RaiseIOOp = 535 +primOpTag MaskAsyncExceptionsOp = 536 +primOpTag MaskUninterruptibleOp = 537 +primOpTag UnmaskAsyncExceptionsOp = 538 +primOpTag MaskStatus = 539 +primOpTag AtomicallyOp = 540 +primOpTag RetryOp = 541 +primOpTag CatchRetryOp = 542 +primOpTag CatchSTMOp = 543 +primOpTag NewTVarOp = 544 +primOpTag ReadTVarOp = 545 +primOpTag ReadTVarIOOp = 546 +primOpTag WriteTVarOp = 547 +primOpTag NewMVarOp = 548 +primOpTag TakeMVarOp = 549 +primOpTag TryTakeMVarOp = 550 +primOpTag PutMVarOp = 551 +primOpTag TryPutMVarOp = 552 +primOpTag ReadMVarOp = 553 +primOpTag TryReadMVarOp = 554 +primOpTag IsEmptyMVarOp = 555 +primOpTag NewIOPortrOp = 556 +primOpTag ReadIOPortOp = 557 +primOpTag WriteIOPortOp = 558 +primOpTag DelayOp = 559 +primOpTag WaitReadOp = 560 +primOpTag WaitWriteOp = 561 +primOpTag ForkOp = 562 +primOpTag ForkOnOp = 563 +primOpTag KillThreadOp = 564 +primOpTag YieldOp = 565 +primOpTag MyThreadIdOp = 566 +primOpTag LabelThreadOp = 567 +primOpTag IsCurrentThreadBoundOp = 568 +primOpTag NoDuplicateOp = 569 +primOpTag ThreadStatusOp = 570 +primOpTag MkWeakOp = 571 +primOpTag MkWeakNoFinalizerOp = 572 +primOpTag AddCFinalizerToWeakOp = 573 +primOpTag DeRefWeakOp = 574 +primOpTag FinalizeWeakOp = 575 +primOpTag TouchOp = 576 +primOpTag MakeStablePtrOp = 577 +primOpTag DeRefStablePtrOp = 578 +primOpTag EqStablePtrOp = 579 +primOpTag MakeStableNameOp = 580 +primOpTag StableNameToIntOp = 581 +primOpTag CompactNewOp = 582 +primOpTag CompactResizeOp = 583 +primOpTag CompactContainsOp = 584 +primOpTag CompactContainsAnyOp = 585 +primOpTag CompactGetFirstBlockOp = 586 +primOpTag CompactGetNextBlockOp = 587 +primOpTag CompactAllocateBlockOp = 588 +primOpTag CompactFixupPointersOp = 589 +primOpTag CompactAdd = 590 +primOpTag CompactAddWithSharing = 591 +primOpTag CompactSize = 592 +primOpTag ReallyUnsafePtrEqualityOp = 593 +primOpTag ParOp = 594 +primOpTag SparkOp = 595 +primOpTag SeqOp = 596 +primOpTag GetSparkOp = 597 +primOpTag NumSparks = 598 +primOpTag KeepAliveOp = 599 +primOpTag DataToTagOp = 600 +primOpTag TagToEnumOp = 601 +primOpTag AddrToAnyOp = 602 +primOpTag AnyToAddrOp = 603 +primOpTag MkApUpd0_Op = 604 +primOpTag NewBCOOp = 605 +primOpTag UnpackClosureOp = 606 +primOpTag ClosureSizeOp = 607 +primOpTag GetApStackValOp = 608 +primOpTag GetCCSOfOp = 609 +primOpTag GetCurrentCCSOp = 610 +primOpTag ClearCCSOp = 611 +primOpTag WhereFromOp = 612 +primOpTag TraceEventOp = 613 +primOpTag TraceEventBinaryOp = 614 +primOpTag TraceMarkerOp = 615 +primOpTag SetThreadAllocationCounter = 616 +primOpTag (VecBroadcastOp IntVec 16 W8) = 617 +primOpTag (VecBroadcastOp IntVec 8 W16) = 618 +primOpTag (VecBroadcastOp IntVec 4 W32) = 619 +primOpTag (VecBroadcastOp IntVec 2 W64) = 620 +primOpTag (VecBroadcastOp IntVec 32 W8) = 621 +primOpTag (VecBroadcastOp IntVec 16 W16) = 622 +primOpTag (VecBroadcastOp IntVec 8 W32) = 623 +primOpTag (VecBroadcastOp IntVec 4 W64) = 624 +primOpTag (VecBroadcastOp IntVec 64 W8) = 625 +primOpTag (VecBroadcastOp IntVec 32 W16) = 626 +primOpTag (VecBroadcastOp IntVec 16 W32) = 627 +primOpTag (VecBroadcastOp IntVec 8 W64) = 628 +primOpTag (VecBroadcastOp WordVec 16 W8) = 629 +primOpTag (VecBroadcastOp WordVec 8 W16) = 630 +primOpTag (VecBroadcastOp WordVec 4 W32) = 631 +primOpTag (VecBroadcastOp WordVec 2 W64) = 632 +primOpTag (VecBroadcastOp WordVec 32 W8) = 633 +primOpTag (VecBroadcastOp WordVec 16 W16) = 634 +primOpTag (VecBroadcastOp WordVec 8 W32) = 635 +primOpTag (VecBroadcastOp WordVec 4 W64) = 636 +primOpTag (VecBroadcastOp WordVec 64 W8) = 637 +primOpTag (VecBroadcastOp WordVec 32 W16) = 638 +primOpTag (VecBroadcastOp WordVec 16 W32) = 639 +primOpTag (VecBroadcastOp WordVec 8 W64) = 640 +primOpTag (VecBroadcastOp FloatVec 4 W32) = 641 +primOpTag (VecBroadcastOp FloatVec 2 W64) = 642 +primOpTag (VecBroadcastOp FloatVec 8 W32) = 643 +primOpTag (VecBroadcastOp FloatVec 4 W64) = 644 +primOpTag (VecBroadcastOp FloatVec 16 W32) = 645 +primOpTag (VecBroadcastOp FloatVec 8 W64) = 646 +primOpTag (VecPackOp IntVec 16 W8) = 647 +primOpTag (VecPackOp IntVec 8 W16) = 648 +primOpTag (VecPackOp IntVec 4 W32) = 649 +primOpTag (VecPackOp IntVec 2 W64) = 650 +primOpTag (VecPackOp IntVec 32 W8) = 651 +primOpTag (VecPackOp IntVec 16 W16) = 652 +primOpTag (VecPackOp IntVec 8 W32) = 653 +primOpTag (VecPackOp IntVec 4 W64) = 654 +primOpTag (VecPackOp IntVec 64 W8) = 655 +primOpTag (VecPackOp IntVec 32 W16) = 656 +primOpTag (VecPackOp IntVec 16 W32) = 657 +primOpTag (VecPackOp IntVec 8 W64) = 658 +primOpTag (VecPackOp WordVec 16 W8) = 659 +primOpTag (VecPackOp WordVec 8 W16) = 660 +primOpTag (VecPackOp WordVec 4 W32) = 661 +primOpTag (VecPackOp WordVec 2 W64) = 662 +primOpTag (VecPackOp WordVec 32 W8) = 663 +primOpTag (VecPackOp WordVec 16 W16) = 664 +primOpTag (VecPackOp WordVec 8 W32) = 665 +primOpTag (VecPackOp WordVec 4 W64) = 666 +primOpTag (VecPackOp WordVec 64 W8) = 667 +primOpTag (VecPackOp WordVec 32 W16) = 668 +primOpTag (VecPackOp WordVec 16 W32) = 669 +primOpTag (VecPackOp WordVec 8 W64) = 670 +primOpTag (VecPackOp FloatVec 4 W32) = 671 +primOpTag (VecPackOp FloatVec 2 W64) = 672 +primOpTag (VecPackOp FloatVec 8 W32) = 673 +primOpTag (VecPackOp FloatVec 4 W64) = 674 +primOpTag (VecPackOp FloatVec 16 W32) = 675 +primOpTag (VecPackOp FloatVec 8 W64) = 676 +primOpTag (VecUnpackOp IntVec 16 W8) = 677 +primOpTag (VecUnpackOp IntVec 8 W16) = 678 +primOpTag (VecUnpackOp IntVec 4 W32) = 679 +primOpTag (VecUnpackOp IntVec 2 W64) = 680 +primOpTag (VecUnpackOp IntVec 32 W8) = 681 +primOpTag (VecUnpackOp IntVec 16 W16) = 682 +primOpTag (VecUnpackOp IntVec 8 W32) = 683 +primOpTag (VecUnpackOp IntVec 4 W64) = 684 +primOpTag (VecUnpackOp IntVec 64 W8) = 685 +primOpTag (VecUnpackOp IntVec 32 W16) = 686 +primOpTag (VecUnpackOp IntVec 16 W32) = 687 +primOpTag (VecUnpackOp IntVec 8 W64) = 688 +primOpTag (VecUnpackOp WordVec 16 W8) = 689 +primOpTag (VecUnpackOp WordVec 8 W16) = 690 +primOpTag (VecUnpackOp WordVec 4 W32) = 691 +primOpTag (VecUnpackOp WordVec 2 W64) = 692 +primOpTag (VecUnpackOp WordVec 32 W8) = 693 +primOpTag (VecUnpackOp WordVec 16 W16) = 694 +primOpTag (VecUnpackOp WordVec 8 W32) = 695 +primOpTag (VecUnpackOp WordVec 4 W64) = 696 +primOpTag (VecUnpackOp WordVec 64 W8) = 697 +primOpTag (VecUnpackOp WordVec 32 W16) = 698 +primOpTag (VecUnpackOp WordVec 16 W32) = 699 +primOpTag (VecUnpackOp WordVec 8 W64) = 700 +primOpTag (VecUnpackOp FloatVec 4 W32) = 701 +primOpTag (VecUnpackOp FloatVec 2 W64) = 702 +primOpTag (VecUnpackOp FloatVec 8 W32) = 703 +primOpTag (VecUnpackOp FloatVec 4 W64) = 704 +primOpTag (VecUnpackOp FloatVec 16 W32) = 705 +primOpTag (VecUnpackOp FloatVec 8 W64) = 706 +primOpTag (VecInsertOp IntVec 16 W8) = 707 +primOpTag (VecInsertOp IntVec 8 W16) = 708 +primOpTag (VecInsertOp IntVec 4 W32) = 709 +primOpTag (VecInsertOp IntVec 2 W64) = 710 +primOpTag (VecInsertOp IntVec 32 W8) = 711 +primOpTag (VecInsertOp IntVec 16 W16) = 712 +primOpTag (VecInsertOp IntVec 8 W32) = 713 +primOpTag (VecInsertOp IntVec 4 W64) = 714 +primOpTag (VecInsertOp IntVec 64 W8) = 715 +primOpTag (VecInsertOp IntVec 32 W16) = 716 +primOpTag (VecInsertOp IntVec 16 W32) = 717 +primOpTag (VecInsertOp IntVec 8 W64) = 718 +primOpTag (VecInsertOp WordVec 16 W8) = 719 +primOpTag (VecInsertOp WordVec 8 W16) = 720 +primOpTag (VecInsertOp WordVec 4 W32) = 721 +primOpTag (VecInsertOp WordVec 2 W64) = 722 +primOpTag (VecInsertOp WordVec 32 W8) = 723 +primOpTag (VecInsertOp WordVec 16 W16) = 724 +primOpTag (VecInsertOp WordVec 8 W32) = 725 +primOpTag (VecInsertOp WordVec 4 W64) = 726 +primOpTag (VecInsertOp WordVec 64 W8) = 727 +primOpTag (VecInsertOp WordVec 32 W16) = 728 +primOpTag (VecInsertOp WordVec 16 W32) = 729 +primOpTag (VecInsertOp WordVec 8 W64) = 730 +primOpTag (VecInsertOp FloatVec 4 W32) = 731 +primOpTag (VecInsertOp FloatVec 2 W64) = 732 +primOpTag (VecInsertOp FloatVec 8 W32) = 733 +primOpTag (VecInsertOp FloatVec 4 W64) = 734 +primOpTag (VecInsertOp FloatVec 16 W32) = 735 +primOpTag (VecInsertOp FloatVec 8 W64) = 736 +primOpTag (VecAddOp IntVec 16 W8) = 737 +primOpTag (VecAddOp IntVec 8 W16) = 738 +primOpTag (VecAddOp IntVec 4 W32) = 739 +primOpTag (VecAddOp IntVec 2 W64) = 740 +primOpTag (VecAddOp IntVec 32 W8) = 741 +primOpTag (VecAddOp IntVec 16 W16) = 742 +primOpTag (VecAddOp IntVec 8 W32) = 743 +primOpTag (VecAddOp IntVec 4 W64) = 744 +primOpTag (VecAddOp IntVec 64 W8) = 745 +primOpTag (VecAddOp IntVec 32 W16) = 746 +primOpTag (VecAddOp IntVec 16 W32) = 747 +primOpTag (VecAddOp IntVec 8 W64) = 748 +primOpTag (VecAddOp WordVec 16 W8) = 749 +primOpTag (VecAddOp WordVec 8 W16) = 750 +primOpTag (VecAddOp WordVec 4 W32) = 751 +primOpTag (VecAddOp WordVec 2 W64) = 752 +primOpTag (VecAddOp WordVec 32 W8) = 753 +primOpTag (VecAddOp WordVec 16 W16) = 754 +primOpTag (VecAddOp WordVec 8 W32) = 755 +primOpTag (VecAddOp WordVec 4 W64) = 756 +primOpTag (VecAddOp WordVec 64 W8) = 757 +primOpTag (VecAddOp WordVec 32 W16) = 758 +primOpTag (VecAddOp WordVec 16 W32) = 759 +primOpTag (VecAddOp WordVec 8 W64) = 760 +primOpTag (VecAddOp FloatVec 4 W32) = 761 +primOpTag (VecAddOp FloatVec 2 W64) = 762 +primOpTag (VecAddOp FloatVec 8 W32) = 763 +primOpTag (VecAddOp FloatVec 4 W64) = 764 +primOpTag (VecAddOp FloatVec 16 W32) = 765 +primOpTag (VecAddOp FloatVec 8 W64) = 766 +primOpTag (VecSubOp IntVec 16 W8) = 767 +primOpTag (VecSubOp IntVec 8 W16) = 768 +primOpTag (VecSubOp IntVec 4 W32) = 769 +primOpTag (VecSubOp IntVec 2 W64) = 770 +primOpTag (VecSubOp IntVec 32 W8) = 771 +primOpTag (VecSubOp IntVec 16 W16) = 772 +primOpTag (VecSubOp IntVec 8 W32) = 773 +primOpTag (VecSubOp IntVec 4 W64) = 774 +primOpTag (VecSubOp IntVec 64 W8) = 775 +primOpTag (VecSubOp IntVec 32 W16) = 776 +primOpTag (VecSubOp IntVec 16 W32) = 777 +primOpTag (VecSubOp IntVec 8 W64) = 778 +primOpTag (VecSubOp WordVec 16 W8) = 779 +primOpTag (VecSubOp WordVec 8 W16) = 780 +primOpTag (VecSubOp WordVec 4 W32) = 781 +primOpTag (VecSubOp WordVec 2 W64) = 782 +primOpTag (VecSubOp WordVec 32 W8) = 783 +primOpTag (VecSubOp WordVec 16 W16) = 784 +primOpTag (VecSubOp WordVec 8 W32) = 785 +primOpTag (VecSubOp WordVec 4 W64) = 786 +primOpTag (VecSubOp WordVec 64 W8) = 787 +primOpTag (VecSubOp WordVec 32 W16) = 788 +primOpTag (VecSubOp WordVec 16 W32) = 789 +primOpTag (VecSubOp WordVec 8 W64) = 790 +primOpTag (VecSubOp FloatVec 4 W32) = 791 +primOpTag (VecSubOp FloatVec 2 W64) = 792 +primOpTag (VecSubOp FloatVec 8 W32) = 793 +primOpTag (VecSubOp FloatVec 4 W64) = 794 +primOpTag (VecSubOp FloatVec 16 W32) = 795 +primOpTag (VecSubOp FloatVec 8 W64) = 796 +primOpTag (VecMulOp IntVec 16 W8) = 797 +primOpTag (VecMulOp IntVec 8 W16) = 798 +primOpTag (VecMulOp IntVec 4 W32) = 799 +primOpTag (VecMulOp IntVec 2 W64) = 800 +primOpTag (VecMulOp IntVec 32 W8) = 801 +primOpTag (VecMulOp IntVec 16 W16) = 802 +primOpTag (VecMulOp IntVec 8 W32) = 803 +primOpTag (VecMulOp IntVec 4 W64) = 804 +primOpTag (VecMulOp IntVec 64 W8) = 805 +primOpTag (VecMulOp IntVec 32 W16) = 806 +primOpTag (VecMulOp IntVec 16 W32) = 807 +primOpTag (VecMulOp IntVec 8 W64) = 808 +primOpTag (VecMulOp WordVec 16 W8) = 809 +primOpTag (VecMulOp WordVec 8 W16) = 810 +primOpTag (VecMulOp WordVec 4 W32) = 811 +primOpTag (VecMulOp WordVec 2 W64) = 812 +primOpTag (VecMulOp WordVec 32 W8) = 813 +primOpTag (VecMulOp WordVec 16 W16) = 814 +primOpTag (VecMulOp WordVec 8 W32) = 815 +primOpTag (VecMulOp WordVec 4 W64) = 816 +primOpTag (VecMulOp WordVec 64 W8) = 817 +primOpTag (VecMulOp WordVec 32 W16) = 818 +primOpTag (VecMulOp WordVec 16 W32) = 819 +primOpTag (VecMulOp WordVec 8 W64) = 820 +primOpTag (VecMulOp FloatVec 4 W32) = 821 +primOpTag (VecMulOp FloatVec 2 W64) = 822 +primOpTag (VecMulOp FloatVec 8 W32) = 823 +primOpTag (VecMulOp FloatVec 4 W64) = 824 +primOpTag (VecMulOp FloatVec 16 W32) = 825 +primOpTag (VecMulOp FloatVec 8 W64) = 826 +primOpTag (VecDivOp FloatVec 4 W32) = 827 +primOpTag (VecDivOp FloatVec 2 W64) = 828 +primOpTag (VecDivOp FloatVec 8 W32) = 829 +primOpTag (VecDivOp FloatVec 4 W64) = 830 +primOpTag (VecDivOp FloatVec 16 W32) = 831 +primOpTag (VecDivOp FloatVec 8 W64) = 832 +primOpTag (VecQuotOp IntVec 16 W8) = 833 +primOpTag (VecQuotOp IntVec 8 W16) = 834 +primOpTag (VecQuotOp IntVec 4 W32) = 835 +primOpTag (VecQuotOp IntVec 2 W64) = 836 +primOpTag (VecQuotOp IntVec 32 W8) = 837 +primOpTag (VecQuotOp IntVec 16 W16) = 838 +primOpTag (VecQuotOp IntVec 8 W32) = 839 +primOpTag (VecQuotOp IntVec 4 W64) = 840 +primOpTag (VecQuotOp IntVec 64 W8) = 841 +primOpTag (VecQuotOp IntVec 32 W16) = 842 +primOpTag (VecQuotOp IntVec 16 W32) = 843 +primOpTag (VecQuotOp IntVec 8 W64) = 844 +primOpTag (VecQuotOp WordVec 16 W8) = 845 +primOpTag (VecQuotOp WordVec 8 W16) = 846 +primOpTag (VecQuotOp WordVec 4 W32) = 847 +primOpTag (VecQuotOp WordVec 2 W64) = 848 +primOpTag (VecQuotOp WordVec 32 W8) = 849 +primOpTag (VecQuotOp WordVec 16 W16) = 850 +primOpTag (VecQuotOp WordVec 8 W32) = 851 +primOpTag (VecQuotOp WordVec 4 W64) = 852 +primOpTag (VecQuotOp WordVec 64 W8) = 853 +primOpTag (VecQuotOp WordVec 32 W16) = 854 +primOpTag (VecQuotOp WordVec 16 W32) = 855 +primOpTag (VecQuotOp WordVec 8 W64) = 856 +primOpTag (VecRemOp IntVec 16 W8) = 857 +primOpTag (VecRemOp IntVec 8 W16) = 858 +primOpTag (VecRemOp IntVec 4 W32) = 859 +primOpTag (VecRemOp IntVec 2 W64) = 860 +primOpTag (VecRemOp IntVec 32 W8) = 861 +primOpTag (VecRemOp IntVec 16 W16) = 862 +primOpTag (VecRemOp IntVec 8 W32) = 863 +primOpTag (VecRemOp IntVec 4 W64) = 864 +primOpTag (VecRemOp IntVec 64 W8) = 865 +primOpTag (VecRemOp IntVec 32 W16) = 866 +primOpTag (VecRemOp IntVec 16 W32) = 867 +primOpTag (VecRemOp IntVec 8 W64) = 868 +primOpTag (VecRemOp WordVec 16 W8) = 869 +primOpTag (VecRemOp WordVec 8 W16) = 870 +primOpTag (VecRemOp WordVec 4 W32) = 871 +primOpTag (VecRemOp WordVec 2 W64) = 872 +primOpTag (VecRemOp WordVec 32 W8) = 873 +primOpTag (VecRemOp WordVec 16 W16) = 874 +primOpTag (VecRemOp WordVec 8 W32) = 875 +primOpTag (VecRemOp WordVec 4 W64) = 876 +primOpTag (VecRemOp WordVec 64 W8) = 877 +primOpTag (VecRemOp WordVec 32 W16) = 878 +primOpTag (VecRemOp WordVec 16 W32) = 879 +primOpTag (VecRemOp WordVec 8 W64) = 880 +primOpTag (VecNegOp IntVec 16 W8) = 881 +primOpTag (VecNegOp IntVec 8 W16) = 882 +primOpTag (VecNegOp IntVec 4 W32) = 883 +primOpTag (VecNegOp IntVec 2 W64) = 884 +primOpTag (VecNegOp IntVec 32 W8) = 885 +primOpTag (VecNegOp IntVec 16 W16) = 886 +primOpTag (VecNegOp IntVec 8 W32) = 887 +primOpTag (VecNegOp IntVec 4 W64) = 888 +primOpTag (VecNegOp IntVec 64 W8) = 889 +primOpTag (VecNegOp IntVec 32 W16) = 890 +primOpTag (VecNegOp IntVec 16 W32) = 891 +primOpTag (VecNegOp IntVec 8 W64) = 892 +primOpTag (VecNegOp FloatVec 4 W32) = 893 +primOpTag (VecNegOp FloatVec 2 W64) = 894 +primOpTag (VecNegOp FloatVec 8 W32) = 895 +primOpTag (VecNegOp FloatVec 4 W64) = 896 +primOpTag (VecNegOp FloatVec 16 W32) = 897 +primOpTag (VecNegOp FloatVec 8 W64) = 898 +primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 899 +primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 900 +primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 901 +primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 902 +primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 903 +primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 904 +primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 905 +primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 906 +primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 907 +primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 908 +primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 909 +primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 910 +primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 911 +primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 912 +primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 913 +primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 914 +primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 915 +primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 916 +primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 917 +primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 918 +primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 919 +primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 920 +primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 921 +primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 922 +primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 923 +primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 924 +primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 925 +primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 926 +primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 927 +primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 928 +primOpTag (VecReadByteArrayOp IntVec 16 W8) = 929 +primOpTag (VecReadByteArrayOp IntVec 8 W16) = 930 +primOpTag (VecReadByteArrayOp IntVec 4 W32) = 931 +primOpTag (VecReadByteArrayOp IntVec 2 W64) = 932 +primOpTag (VecReadByteArrayOp IntVec 32 W8) = 933 +primOpTag (VecReadByteArrayOp IntVec 16 W16) = 934 +primOpTag (VecReadByteArrayOp IntVec 8 W32) = 935 +primOpTag (VecReadByteArrayOp IntVec 4 W64) = 936 +primOpTag (VecReadByteArrayOp IntVec 64 W8) = 937 +primOpTag (VecReadByteArrayOp IntVec 32 W16) = 938 +primOpTag (VecReadByteArrayOp IntVec 16 W32) = 939 +primOpTag (VecReadByteArrayOp IntVec 8 W64) = 940 +primOpTag (VecReadByteArrayOp WordVec 16 W8) = 941 +primOpTag (VecReadByteArrayOp WordVec 8 W16) = 942 +primOpTag (VecReadByteArrayOp WordVec 4 W32) = 943 +primOpTag (VecReadByteArrayOp WordVec 2 W64) = 944 +primOpTag (VecReadByteArrayOp WordVec 32 W8) = 945 +primOpTag (VecReadByteArrayOp WordVec 16 W16) = 946 +primOpTag (VecReadByteArrayOp WordVec 8 W32) = 947 +primOpTag (VecReadByteArrayOp WordVec 4 W64) = 948 +primOpTag (VecReadByteArrayOp WordVec 64 W8) = 949 +primOpTag (VecReadByteArrayOp WordVec 32 W16) = 950 +primOpTag (VecReadByteArrayOp WordVec 16 W32) = 951 +primOpTag (VecReadByteArrayOp WordVec 8 W64) = 952 +primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 953 +primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 954 +primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 955 +primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 956 +primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 957 +primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 958 +primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 959 +primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 960 +primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 961 +primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 962 +primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 963 +primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 964 +primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 965 +primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 966 +primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 967 +primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 968 +primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 969 +primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 970 +primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 971 +primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 972 +primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 973 +primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 974 +primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 975 +primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 976 +primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 977 +primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 978 +primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 979 +primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 980 +primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 981 +primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 982 +primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 983 +primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 984 +primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 985 +primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 986 +primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 987 +primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 988 +primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 989 +primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 990 +primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 991 +primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 992 +primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 993 +primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 994 +primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 995 +primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 996 +primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 997 +primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 998 +primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 999 +primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1000 +primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1001 +primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1002 +primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1003 +primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1004 +primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1005 +primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1006 +primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1007 +primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1008 +primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1009 +primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1010 +primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1011 +primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1012 +primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1013 +primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1014 +primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1015 +primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1016 +primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1017 +primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1018 +primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1019 +primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1020 +primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1021 +primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1022 +primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1023 +primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1024 +primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1025 +primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1026 +primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1027 +primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1028 +primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1029 +primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1030 +primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1031 +primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1032 +primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1033 +primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1034 +primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1035 +primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1036 +primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1037 +primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1038 +primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1039 +primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1040 +primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1041 +primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1042 +primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1043 +primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1044 +primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1045 +primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1046 +primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1047 +primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1048 +primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1049 +primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1050 +primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1051 +primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1052 +primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1053 +primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1054 +primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1055 +primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1056 +primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1057 +primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1058 +primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1059 +primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1060 +primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1061 +primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1062 +primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1063 +primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1064 +primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1065 +primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1066 +primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1067 +primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1068 +primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1069 +primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1070 +primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1071 +primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1072 +primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1073 +primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1074 +primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1075 +primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1076 +primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1077 +primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1078 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1079 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1080 +primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1081 +primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1082 +primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1083 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1084 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1085 +primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1086 +primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1087 +primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1088 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1089 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1090 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1091 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1092 +primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1093 +primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1094 +primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1095 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1096 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1097 +primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1098 +primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1099 +primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1100 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1101 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1102 +primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1103 +primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1104 +primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1105 +primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1106 +primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1107 +primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1108 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1109 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1110 +primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1111 +primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1112 +primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1113 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1114 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1115 +primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1116 +primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1117 +primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1118 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1119 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1120 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1121 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1122 +primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1123 +primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1124 +primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1125 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1126 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1127 +primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1128 +primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1129 +primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1130 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1131 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1132 +primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1133 +primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1134 +primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1135 +primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1136 +primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1137 +primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1138 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1139 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1140 +primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1141 +primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1142 +primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1143 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1144 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1145 +primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1146 +primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1147 +primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1148 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1149 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1150 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1151 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1152 +primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1153 +primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1154 +primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1155 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1156 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1157 +primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1158 +primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1159 +primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1160 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1161 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1162 +primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1163 +primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1164 +primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1165 +primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1166 +primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1167 +primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1168 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1169 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1170 +primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1171 +primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1172 +primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1173 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1174 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1175 +primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1176 +primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1177 +primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1178 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1179 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1180 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1181 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1182 +primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1183 +primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1184 +primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1185 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1186 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1187 +primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1188 +primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1189 +primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1190 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1191 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1192 +primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1193 +primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1194 +primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1195 +primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1196 +primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1197 +primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1198 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1199 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1200 +primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1201 +primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1202 +primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1203 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1204 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1205 +primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1206 +primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1207 +primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1208 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1209 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1210 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1211 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1212 +primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1213 +primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1214 +primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1215 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1216 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1217 +primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1218 +primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1219 +primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1220 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1221 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1222 +primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1223 +primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1224 +primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1225 +primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1226 +primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1227 +primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1228 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1229 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1230 +primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1231 +primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1232 +primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1233 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1234 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1235 +primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1236 +primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1237 +primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1238 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1239 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1240 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1241 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1242 +primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1243 +primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1244 +primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1245 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1246 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1247 +primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1248 +primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1249 +primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1250 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1251 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1252 +primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1253 +primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1254 +primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1255 +primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1256 +primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1257 +primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1258 +primOpTag PrefetchByteArrayOp3 = 1259 +primOpTag PrefetchMutableByteArrayOp3 = 1260 +primOpTag PrefetchAddrOp3 = 1261 +primOpTag PrefetchValueOp3 = 1262 +primOpTag PrefetchByteArrayOp2 = 1263 +primOpTag PrefetchMutableByteArrayOp2 = 1264 +primOpTag PrefetchAddrOp2 = 1265 +primOpTag PrefetchValueOp2 = 1266 +primOpTag PrefetchByteArrayOp1 = 1267 +primOpTag PrefetchMutableByteArrayOp1 = 1268 +primOpTag PrefetchAddrOp1 = 1269 +primOpTag PrefetchValueOp1 = 1270 +primOpTag PrefetchByteArrayOp0 = 1271 +primOpTag PrefetchMutableByteArrayOp0 = 1272 +primOpTag PrefetchAddrOp0 = 1273 +primOpTag PrefetchValueOp0 = 1274 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 @@ -482,6 +482,9 @@ macro is obsolete. */ #define TIME_WITH_SYS_TIME 1 +/* Compile-in ASSERTs in all ways. */ +/* #undef USE_ASSERTS_ALL_WAYS */ + /* Enable single heap address space support */ #define USE_LARGE_ADDRESS_SPACE 1 diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc --- a/libraries/ghci/GHCi/InfoTable.hsc +++ b/libraries/ghci/GHCi/InfoTable.hsc @@ -37,8 +37,8 @@ -> Int -- pointer tag -> ByteString -- con desc -> IO (Ptr StgInfoTable) - -- resulting info table is allocated with allocateExec(), and - -- should be freed with freeExec(). + -- resulting info table is allocated with allocateExecPage(), and + -- should be freed with freeExecPage(). mkConInfoTable tables_next_to_code ptr_words nonptr_words tag ptrtag con_desc = do let entry_addr = interpConstrEntry !! ptrtag @@ -325,13 +325,35 @@ Right xs -> sizeOf (head xs) * length xs -- Note: Must return proper pointer for use in a closure +#if MIN_VERSION_rts(1,0,1) newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ()) -newExecConItbl tables_next_to_code obj con_desc -#if RTS_LINKER_USE_MMAP && MIN_VERSION_rts(1,0,1) - = do +newExecConItbl tables_next_to_code obj con_desc = do + sz0 <- sizeOfEntryCode tables_next_to_code + let lcon_desc = BS.length con_desc + 1{- null terminator -} + -- SCARY + -- This size represents the number of bytes in an StgConInfoTable. + sz = fromIntegral $ conInfoTableSizeB + sz0 + -- Note: we need to allocate the conDesc string next to the info + -- table, because on a 64-bit platform we reference this string + -- with a 32-bit offset relative to the info table, so if we + -- allocated the string separately it might be out of range. + + ex_ptr <- fillExecBuffer (sz + fromIntegral lcon_desc) $ \wr_ptr ex_ptr -> do + let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz + , infoTable = obj } + pokeConItbl tables_next_to_code wr_ptr ex_ptr cinfo + BS.useAsCStringLen con_desc $ \(src, len) -> + copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len + let null_off = fromIntegral sz + fromIntegral (BS.length con_desc) + poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8) + + pure $ if tables_next_to_code + then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB + else castPtrToFunPtr ex_ptr #else +newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ()) +newExecConItbl tables_next_to_code obj con_desc = alloca $ \pcode -> do -#endif sz0 <- sizeOfEntryCode tables_next_to_code let lcon_desc = BS.length con_desc + 1{- null terminator -} -- SCARY @@ -341,13 +363,8 @@ -- table, because on a 64-bit platform we reference this string -- with a 32-bit offset relative to the info table, so if we -- allocated the string separately it might be out of range. -#if RTS_LINKER_USE_MMAP && MIN_VERSION_rts(1,0,1) - wr_ptr <- _allocateWrite (sz + fromIntegral lcon_desc) - let ex_ptr = wr_ptr -#else wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode ex_ptr <- peek pcode -#endif let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz , infoTable = obj } pokeConItbl tables_next_to_code wr_ptr ex_ptr cinfo @@ -356,25 +373,64 @@ let null_off = fromIntegral sz + fromIntegral (BS.length con_desc) poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8) _flushExec sz ex_ptr -- Cache flush (if needed) -#if RTS_LINKER_USE_MMAP && MIN_VERSION_rts(1,0,1) - _markExec (sz + fromIntegral lcon_desc) ex_ptr -#endif pure $ if tables_next_to_code then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB else castPtrToFunPtr ex_ptr +#endif +-- | Allocate a buffer of a given size, use the given action to fill it with +-- data, and mark it as executable. The action is given a writable pointer and +-- the executable pointer. Returns a pointer to the executable code. +#if MIN_VERSION_rts(1,0,1) +fillExecBuffer :: CSize -> (Ptr a -> Ptr a -> IO ()) -> IO (Ptr a) +#endif + +#if MIN_VERSION_rts(1,0,2) + +data ExecPage + +foreign import ccall unsafe "allocateExecPage" + _allocateExecPage :: IO (Ptr ExecPage) + +foreign import ccall unsafe "freezeExecPage" + _freezeExecPage :: Ptr ExecPage -> IO () + +fillExecBuffer sz cont + -- we can only allocate single pages. This assumes a 4k page size which + -- isn't strictly correct but is a reasonable conservative lower bound. + | sz > 4096 = fail "withExecBuffer: Too large" + | otherwise = do + pg <- _allocateExecPage + cont (castPtr pg) (castPtr pg) + _freezeExecPage pg + return (castPtr pg) + +#elif MIN_VERSION_rts(1,0,1) + foreign import ccall unsafe "allocateExec" _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a) foreign import ccall unsafe "flushExec" _flushExec :: CUInt -> Ptr a -> IO () -#if RTS_LINKER_USE_MMAP && MIN_VERSION_rts(1,0,1) -foreign import ccall unsafe "allocateWrite" - _allocateWrite :: CUInt -> IO (Ptr a) -foreign import ccall unsafe "markExec" - _markExec :: CUInt -> Ptr a -> IO () +fillExecBuffer sz cont = alloca $ \pcode -> do + wr_ptr <- _allocateExec (fromIntegral sz) pcode + ex_ptr <- peek pcode + cont wr_ptr ex_ptr + _flushExec (fromIntegral sz) ex_ptr -- Cache flush (if needed) + return (ex_ptr) + +#else + +foreign import ccall unsafe "allocateExec" + _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a) + +foreign import ccall unsafe "flushExec" + _flushExec :: CUInt -> Ptr a -> IO () + + #endif + -- ----------------------------------------------------------------------------- -- Constants and config