diff --git a/compiler/GHC.hs b/compiler/GHC.hs --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -301,6 +301,7 @@ import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename , isSourceFilename, startPhase ) import GHC.Driver.Env +import GHC.Driver.Errors import GHC.Driver.CmdLine import GHC.Driver.Session hiding (WarnReason(..)) import GHC.Driver.Backend @@ -889,7 +890,7 @@ -- the REPL. See #12356. if xopt LangExt.StaticPointers dflags0 then do liftIO $ printOrThrowWarnings dflags0 $ listToBag - [mkPlainWarnMsg dflags0 interactiveSrcSpan + [mkPlainWarnMsg interactiveSrcSpan $ text "StaticPointers is not supported in GHCi interactive expressions."] return $ xopt_unset dflags0 LangExt.StaticPointers else return dflags0 @@ -1279,7 +1280,7 @@ gutsToCoreModule safe_mode (Right mg) = CoreModule { cm_module = mg_module mg, cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg)) - (mg_tcs mg) + (mg_tcs mg) (mg_patsyns mg) (mg_fam_insts mg), cm_binds = mg_binds mg, cm_safe = safe_mode @@ -1473,7 +1474,7 @@ -- if it is visible from at least one module in the list. -> Maybe [Module] -- ^ modules to load. If this is not specified, we load -- modules for everything that is in scope unqualified. - -> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst]))) + -> m (Messages ErrDoc, Maybe (NameEnv ([ClsInst], [FamInst]))) getNameToInstancesIndex visible_mods mods_to_load = do hsc_env <- getSession liftIO $ runTcInteractive hsc_env $ 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 @@ -473,10 +473,11 @@ LitNumWord64 -> int64 (fromIntegral i) LitNumInteger -> panic "GHC.ByteCode.Asm.literal: LitNumInteger" LitNumNatural -> panic "GHC.ByteCode.Asm.literal: LitNumNatural" + -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most -- likely to elicit a crash (rather than corrupt memory) in case absence -- analysis messed up. - literal LitRubbish = int 0 + literal (LitRubbish {}) = int 0 litlabel fs = lit [BCONPtrLbl fs] addr (RemotePtr a) = words [fromIntegral a] 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 @@ -222,7 +222,7 @@ pprCoreExprShort e = pprCoreExpr e pprCoreAltShort :: CoreAlt -> SDoc -pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> text "->" <+> pprCoreExprShort expr +pprCoreAltShort (Alt con args expr) = ppr con <+> sep (map ppr args) <+> text "->" <+> pprCoreExprShort expr instance Outputable BCInstr where ppr (STKCHECK n) = text "STKCHECK" <+> ppr n 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 @@ -346,10 +346,10 @@ = case mop of MO_Mul rep | Just p <- exactLog2 n -> - Just $! (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p rep)]) + Just $! (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p $ wordWidth platform)]) MO_U_Quot rep | Just p <- exactLog2 n -> - Just $! (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)]) + Just $! (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p $ wordWidth platform)]) MO_U_Rem rep | Just _ <- exactLog2 n -> Just $! (cmmMachOpFold platform (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)]) diff --git a/compiler/GHC/Cmm/Ppr/Decl.hs b/compiler/GHC/Cmm/Ppr/Decl.hs --- a/compiler/GHC/Cmm/Ppr/Decl.hs +++ b/compiler/GHC/Cmm/Ppr/Decl.hs @@ -53,7 +53,7 @@ import GHC.Utils.Outputable import GHC.Data.FastString -import Data.List +import Data.List (intersperse) import qualified Data.ByteString as BS diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -140,7 +140,7 @@ import GHC.Data.Stream (Stream) import qualified GHC.Data.Stream as Stream -import Data.List +import Data.List (sortBy, groupBy) import Data.Maybe import Data.Ord ( comparing ) import Control.Exception diff --git a/compiler/GHC/CmmToAsm/BlockLayout.hs b/compiler/GHC/CmmToAsm/BlockLayout.hs --- a/compiler/GHC/CmmToAsm/BlockLayout.hs +++ b/compiler/GHC/CmmToAsm/BlockLayout.hs @@ -44,7 +44,7 @@ import GHC.Data.List.SetOps (removeDups) import GHC.Data.OrdList -import Data.List +import Data.List (sortOn, sortBy) import Data.Foldable (toList) import qualified Data.Set as Set diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs @@ -27,7 +27,7 @@ import GHC.Utils.Panic import GHC.Platform -import Data.List +import Data.List (nub, (\\), intersect) import Data.Maybe import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs b/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs @@ -51,7 +51,7 @@ import GHC.Platform import GHC.Cmm.Dataflow.Collections -import Data.List +import Data.List (nub, foldl1', find) import Data.Maybe import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet diff --git a/compiler/GHC/CmmToAsm/Reg/Linear.hs b/compiler/GHC/CmmToAsm/Reg/Linear.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear.hs @@ -139,7 +139,7 @@ import GHC.Platform import Data.Maybe -import Data.List +import Data.List (partition, nub) import Control.Monad import Control.Applicative diff --git a/compiler/GHC/CmmToAsm/Reg/Liveness.hs b/compiler/GHC/CmmToAsm/Reg/Liveness.hs --- a/compiler/GHC/CmmToAsm/Reg/Liveness.hs +++ b/compiler/GHC/CmmToAsm/Reg/Liveness.hs @@ -67,7 +67,7 @@ import GHC.Data.Bag import GHC.Utils.Monad.State -import Data.List +import Data.List (mapAccumL, groupBy, partition) import Data.Maybe import Data.IntSet (IntSet) diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -525,13 +525,15 @@ goSubWord rem_bytes accum (lit : rest) | Just (bytes, w) <- isSubWordLit lit , rem_bytes >= widthInBytes w - = let accum' = - case platformByteOrder platform of - BigEndian -> (accum `shiftL` widthInBits w) .|. bytes - LittleEndian -> (accum `shiftL` widthInBits w) .|. byteSwap w bytes + = let accum' = (accum `shiftL` widthInBits w) .|. fixEndian w bytes in goSubWord (rem_bytes - widthInBytes w) accum' rest goSubWord rem_bytes accum rest - = pprWord (byteSwap (wordWidth platform) $ accum `shiftL` (8*rem_bytes)) : go rest + = pprWord (fixEndian (wordWidth platform) $ accum `shiftL` (8*rem_bytes)) : go rest + + fixEndian :: Width -> Integer -> Integer + fixEndian w = case platformByteOrder platform of + BigEndian -> id + LittleEndian -> byteSwap w -- Decompose multi-word or floating-point literals into multiple -- single-word (or smaller) literals. 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 @@ -449,20 +449,7 @@ platform <- getPlatform runStmtsDecls $ do - -- parameter types - let arg_type (_, AddrHint) = i8Ptr - -- cast pointers to i8*. Llvm equivalent of void* - arg_type (expr, _) = cmmToLlvmType $ cmmExprType platform expr - - -- ret type - let ret_type [] = LMVoid - ret_type [(_, AddrHint)] = i8Ptr - ret_type [(reg, _)] = cmmToLlvmType $ localRegType reg - ret_type t = panic $ "genCall: Too many return values! Can only handle" - ++ " 0 or 1, given " ++ show (length t) ++ "." - -- extract Cmm call convention, and translate to LLVM call convention - platform <- lift $ getPlatform let lmconv = case target of ForeignTarget _ (ForeignConvention conv _ _ _) -> case conv of @@ -485,6 +472,22 @@ The native code generator only handles StdCall and CCallConv. -} + -- parameter types + let arg_type (_, AddrHint) = (i8Ptr, []) + -- cast pointers to i8*. Llvm equivalent of void* + arg_type (expr, hint) = + case cmmToLlvmType $ cmmExprType platform expr of + ty@(LMInt n) | n < 64 && lmconv == CC_Ccc && platformCConvNeedsExtension platform + -> (ty, if hint == SignedHint then [SignExt] else [ZeroExt]) + ty -> (ty, []) + + -- ret type + let ret_type [] = LMVoid + ret_type [(_, AddrHint)] = i8Ptr + ret_type [(reg, _)] = cmmToLlvmType $ localRegType reg + ret_type t = panic $ "genCall: Too many return values! Can only handle" + ++ " 0 or 1, given " ++ show (length t) ++ "." + -- call attributes let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs | otherwise = llvmStdFunAttrs @@ -499,7 +502,7 @@ let ress_hints = zip res res_hints let ccTy = StdCall -- tail calls should be done through CmmJump let retTy = ret_type ress_hints - let argTy = tysToParams $ map arg_type args_hints + let argTy = map arg_type args_hints let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible lmconv retTy FixedArgs argTy (llvmFunAlign platform) @@ -1506,9 +1509,9 @@ MO_And _ -> genBinMach LM_MO_And MO_Or _ -> genBinMach LM_MO_Or MO_Xor _ -> genBinMach LM_MO_Xor - MO_Shl _ -> genBinMach LM_MO_Shl - MO_U_Shr _ -> genBinMach LM_MO_LShr - MO_S_Shr _ -> genBinMach LM_MO_AShr + MO_Shl _ -> genBinCastYMach LM_MO_Shl + MO_U_Shr _ -> genBinCastYMach LM_MO_LShr + MO_S_Shr _ -> genBinCastYMach LM_MO_AShr MO_V_Add l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Add MO_V_Sub l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub @@ -1552,15 +1555,23 @@ #endif where - binLlvmOp ty binOp = do + binLlvmOp ty binOp allow_y_cast = do platform <- getPlatform runExprData $ do vx <- exprToVarW x vy <- exprToVarW y - if getVarType vx == getVarType vy - then - doExprW (ty vx) $ binOp vx vy - else do + + if | getVarType vx == getVarType vy + -> doExprW (ty vx) $ binOp vx vy + + | allow_y_cast + -> do + vy' <- singletonPanic "binLlvmOp cast"<$> + castVarsW Signed [(vy, (ty vx))] + doExprW (ty vx) $ binOp vx vy' + + | otherwise + -> do -- Error. Continue anyway so we can debug the generated ll file. dflags <- getDynFlags let style = PprCode CStyle @@ -1582,7 +1593,7 @@ -- comparisons while LLVM return i1. Need to extend to llvmWord type -- if expected. See Note [Literals and branch conditions]. genBinComp opt cmp = do - ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp) + ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp) False dflags <- getDynFlags platform <- getPlatform if getVarType v1 == i1 @@ -1596,7 +1607,9 @@ panic $ "genBinComp: Compare returned type other then i1! " ++ (showSDoc dflags $ ppr $ getVarType v1) - genBinMach op = binLlvmOp getVarType (LlvmOp op) + genBinMach op = binLlvmOp getVarType (LlvmOp op) False + + genBinCastYMach op = binLlvmOp getVarType (LlvmOp op) True genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op) diff --git a/compiler/GHC/Core/Map/Expr.hs b/compiler/GHC/Core/Map/Expr.hs --- a/compiler/GHC/Core/Map/Expr.hs +++ b/compiler/GHC/Core/Map/Expr.hs @@ -350,11 +350,11 @@ instance Eq (DeBruijn CoreAlt) where D env1 a1 == D env2 a2 = go a1 a2 where - go (DEFAULT, _, rhs1) (DEFAULT, _, rhs2) + go (Alt DEFAULT _ rhs1) (Alt DEFAULT _ rhs2) = D env1 rhs1 == D env2 rhs2 - go (LitAlt lit1, _, rhs1) (LitAlt lit2, _, rhs2) + go (Alt (LitAlt lit1) _ rhs1) (Alt (LitAlt lit2) _ rhs2) = lit1 == lit2 && D env1 rhs1 == D env2 rhs2 - go (DataAlt dc1, bs1, rhs1) (DataAlt dc2, bs2, rhs2) + go (Alt (DataAlt dc1) bs1 rhs1) (Alt (DataAlt dc2) bs2 rhs2) = dc1 == dc2 && D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2 go _ _ = False @@ -372,17 +372,17 @@ , am_lit = mapTM (filterTM f) alit } lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a -lkA env (DEFAULT, _, rhs) = am_deflt >.> lkG (D env rhs) -lkA env (LitAlt lit, _, rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs) -lkA env (DataAlt dc, bs, rhs) = am_data >.> lkDNamed dc +lkA env (Alt DEFAULT _ rhs) = am_deflt >.> lkG (D env rhs) +lkA env (Alt (LitAlt lit) _ rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs) +lkA env (Alt (DataAlt dc) bs rhs) = am_data >.> lkDNamed dc >=> lkG (D (extendCMEs env bs) rhs) xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a -xtA env (DEFAULT, _, rhs) f m = +xtA env (Alt DEFAULT _ rhs) f m = m { am_deflt = am_deflt m |> xtG (D env rhs) f } -xtA env (LitAlt l, _, rhs) f m = +xtA env (Alt (LitAlt l) _ rhs) f m = m { am_lit = am_lit m |> alterTM l |>> xtG (D env rhs) f } -xtA env (DataAlt d, bs, rhs) f m = +xtA env (Alt (DataAlt d) bs rhs) f m = m { am_data = am_data m |> xtDNamed d |>> xtG (D (extendCMEs env bs) rhs) f } diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs --- a/compiler/GHC/Core/Opt/CSE.hs +++ b/compiler/GHC/Core/Opt/CSE.hs @@ -620,15 +620,15 @@ arg_tys = tyConAppArgs (idType bndr3) -- See Note [CSE for case alternatives] - cse_alt (DataAlt con, args, rhs) - = (DataAlt con, args', tryForCSE new_env rhs) + cse_alt (Alt (DataAlt con) args rhs) + = Alt (DataAlt con) args' (tryForCSE new_env rhs) where (env', args') = addBinders alt_env args new_env = extendCSEnv env' con_expr con_target con_expr = mkAltExpr (DataAlt con) args' arg_tys - cse_alt (con, args, rhs) - = (con, args', tryForCSE env' rhs) + cse_alt (Alt con args rhs) + = Alt con args' (tryForCSE env' rhs) where (env', args') = addBinders alt_env args @@ -636,11 +636,11 @@ -- See Note [Combine case alternatives] combineAlts env alts | (Just alt1, rest_alts) <- find_bndr_free_alt alts - , (_,bndrs1,rhs1) <- alt1 + , Alt _ bndrs1 rhs1 <- alt1 , let filtered_alts = filterOut (identical_alt rhs1) rest_alts , not (equalLength rest_alts filtered_alts) = ASSERT2( null bndrs1, ppr alts ) - (DEFAULT, [], rhs1) : filtered_alts + Alt DEFAULT [] rhs1 : filtered_alts | otherwise = alts @@ -652,12 +652,12 @@ -- See Note [Combine case alts: awkward corner] find_bndr_free_alt [] = (Nothing, []) - find_bndr_free_alt (alt@(_,bndrs,_) : alts) + find_bndr_free_alt (alt@(Alt _ bndrs _) : alts) | null bndrs = (Just alt, alts) | otherwise = case find_bndr_free_alt alts of (mb_bf, alts) -> (mb_bf, alt:alts) - identical_alt rhs1 (_,_,rhs) = eqExpr in_scope rhs1 rhs + identical_alt rhs1 (Alt _ _ rhs) = eqExpr in_scope rhs1 rhs -- Even if this alt has binders, they will have been cloned -- If any of these binders are mentioned in 'rhs', then -- 'rhs' won't compare equal to 'rhs1' (which is from an diff --git a/compiler/GHC/Core/Opt/CallArity.hs b/compiler/GHC/Core/Opt/CallArity.hs --- a/compiler/GHC/Core/Opt/CallArity.hs +++ b/compiler/GHC/Core/Opt/CallArity.hs @@ -524,8 +524,8 @@ (final_ae, Case scrut' bndr ty alts') where (alt_aes, alts') = unzip $ map go alts - go (dc, bndrs, e) = let (ae, e') = callArityAnal arity int e - in (ae, (dc, bndrs, e')) + go (Alt dc bndrs e) = let (ae, e') = callArityAnal arity int e + in (ae, Alt dc bndrs e') alt_ae = lubRess alt_aes (scrut_ae, scrut') = callArityAnal 0 int scrut final_ae = scrut_ae `both` alt_ae diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -34,7 +34,7 @@ import GHC.Data.Maybe ( isJust, isNothing ) import Control.Monad ( guard ) -import Data.List +import Data.List ( mapAccumL ) {- Note [Constructed Product Result] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -209,14 +209,14 @@ -> Id -- ^ case binder -> Alt Var -- ^ current alternative -> (CprType, Alt Var) -cprAnalAlt env scrut case_bndr (con@(DataAlt dc),bndrs,rhs) +cprAnalAlt env scrut case_bndr (Alt con@(DataAlt dc) bndrs rhs) -- See 'extendEnvForDataAlt' and Note [CPR in a DataAlt case alternative] - = (rhs_ty, (con, bndrs, rhs')) + = (rhs_ty, Alt con bndrs rhs') where env_alt = extendEnvForDataAlt env scrut case_bndr dc bndrs (rhs_ty, rhs') = cprAnal env_alt rhs -cprAnalAlt env _ _ (con,bndrs,rhs) - = (rhs_ty, (con, bndrs, rhs')) +cprAnalAlt env _ _ (Alt con bndrs rhs) + = (rhs_ty, Alt con bndrs rhs') where (rhs_ty, rhs') = cprAnal env rhs diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -56,8 +56,8 @@ -} -- | Options for the demand analysis -data DmdAnalOpts = DmdAnalOpts - { dmd_strict_dicts :: !Bool -- ^ Use strict dictionaries +newtype DmdAnalOpts = DmdAnalOpts + { dmd_strict_dicts :: Bool -- ^ Use strict dictionaries } -- | Outputs a new copy of the Core program in which binders have been annotated @@ -424,7 +424,7 @@ in (multDmdType n lam_ty, Lam var' body') -dmdAnal' env dmd (Case scrut case_bndr ty [(alt, bndrs, rhs)]) +dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs]) -- Only one alternative. -- If it's a DataAlt, it should be the only constructor of the type. | is_single_data_alt alt @@ -464,7 +464,7 @@ -- , text "scrut_ty" <+> ppr scrut_ty -- , text "alt_ty" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $ - (res_ty, Case scrut' case_bndr' ty [(alt, bndrs', rhs')]) + (res_ty, Case scrut' case_bndr' ty [Alt alt bndrs' rhs']) where is_single_data_alt (DataAlt dc) = isJust $ tyConSingleAlgDataCon_maybe $ dataConTyCon dc is_single_data_alt _ = True @@ -536,13 +536,13 @@ = False dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> (DmdType, Alt Var) -dmdAnalSumAlt env dmd case_bndr (con,bndrs,rhs) +dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) | (rhs_ty, rhs') <- dmdAnal env dmd rhs , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr -- See Note [Demand on scrutinee of a product case] id_dmds = addCaseBndrDmd case_bndr_sd dmds - = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs')) + = (alt_ty, Alt con (setBndrsDemandInfo bndrs id_dmds) rhs') {- Note [Analysing with absent demand] diff --git a/compiler/GHC/Core/Opt/Exitify.hs b/compiler/GHC/Core/Opt/Exitify.hs --- a/compiler/GHC/Core/Opt/Exitify.hs +++ b/compiler/GHC/Core/Opt/Exitify.hs @@ -81,7 +81,7 @@ = Case (go in_scope scrut) bndr ty (map go_alt alts) where in_scope1 = in_scope `extendInScopeSet` bndr - go_alt (dc, pats, rhs) = (dc, pats, go in_scope' rhs) + go_alt (Alt dc pats rhs) = Alt dc pats (go in_scope' rhs) where in_scope' = in_scope1 `extendInScopeSetList` pats go in_scope (Let (NonRec bndr rhs) body) @@ -152,9 +152,9 @@ -- Case right hand sides are in tail-call position go captured (_, AnnCase scrut bndr ty alts) = do - alts' <- forM alts $ \(dc, pats, rhs) -> do + alts' <- forM alts $ \(AnnAlt dc pats rhs) -> do rhs' <- go (captured ++ [bndr] ++ pats) rhs - return (dc, pats, rhs') + return (Alt dc pats rhs') return $ Case (deAnnotate scrut) bndr ty alts' go captured (_, AnnLet ann_bind body) diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs --- a/compiler/GHC/Core/Opt/FloatIn.hs +++ b/compiler/GHC/Core/Opt/FloatIn.hs @@ -454,7 +454,7 @@ -} -fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)]) +fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs]) | isUnliftedType (idType case_bndr) , exprOkForSideEffects (deAnnotate scrut) -- See Note [Floating primops] @@ -493,12 +493,12 @@ scrut_fvs = freeVarsOf scrut alts_fvs = map alt_fvs alts all_alts_fvs = unionDVarSets alts_fvs - alt_fvs (_con, args, rhs) + alt_fvs (AnnAlt _con args rhs) = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args) -- Delete case_bndr and args from free vars of rhs -- to get free vars of alt - fi_alt to_drop (con, args, rhs) = (con, args, fiExpr platform to_drop rhs) + fi_alt to_drop (AnnAlt con args rhs) = Alt con args (fiExpr platform to_drop rhs) ------------------ fiBind :: Platform diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs --- a/compiler/GHC/Core/Opt/FloatOut.hs +++ b/compiler/GHC/Core/Opt/FloatOut.hs @@ -468,7 +468,7 @@ floatExpr (Case scrut (TB case_bndr case_spec) ty alts) = case case_spec of FloatMe dest_lvl -- Case expression moves - | [(con@(DataAlt {}), bndrs, rhs)] <- alts + | [Alt con@(DataAlt {}) bndrs rhs] <- alts -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') -> case floatExpr rhs of { (fsb, fdb, rhs') -> let @@ -485,9 +485,9 @@ (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts') }} where - float_alt bind_lvl (con, bs, rhs) + float_alt bind_lvl (Alt con bs rhs) = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') -> - (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) } + (fs, rhs_floats, Alt con [b | TB b _ <- bs] rhs') } floatRhs :: CoreBndr -> LevelledExpr diff --git a/compiler/GHC/Core/Opt/LiberateCase.hs b/compiler/GHC/Core/Opt/LiberateCase.hs --- a/compiler/GHC/Core/Opt/LiberateCase.hs +++ b/compiler/GHC/Core/Opt/LiberateCase.hs @@ -255,9 +255,8 @@ mk_alt_env (Cast scrut _) = mk_alt_env scrut -- Note [Scrutinee with cast] mk_alt_env _ = env -libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr) - -> (AltCon, [CoreBndr], CoreExpr) -libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs) +libCaseAlt :: LibCaseEnv -> Alt CoreBndr -> Alt CoreBndr +libCaseAlt env (Alt con args rhs) = Alt con args (libCase (addBinders env args) rhs) {- Ids 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 @@ -69,7 +69,7 @@ import GHC.Types.Demand ( zapDmdEnvSig ) import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Types.Unique.Supply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) +import GHC.Types.Unique.Supply ( UniqSupply ) import GHC.Types.Unique.FM import GHC.Types.Name.Ppr @@ -634,10 +634,9 @@ snd $ ic_instances $ hsc_IC hsc_env ) simpl_env = simplEnvForGHCi dflags - ; us <- mkSplitUniqSupply 's' ; let sz = exprSize expr - ; (expr', counts) <- initSmpl dflags rule_env fi_env us sz $ + ; (expr', counts) <- initSmpl dflags rule_env fi_env sz $ simplExprGently simpl_env expr ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags) @@ -685,27 +684,25 @@ simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts simplifyPgm pass guts = do { hsc_env <- getHscEnv - ; us <- getUniqueSupplyM ; rb <- getRuleBase ; liftIOWithCount $ - simplifyPgmIO pass hsc_env us rb guts } + simplifyPgmIO pass hsc_env rb guts } simplifyPgmIO :: CoreToDo -> HscEnv - -> UniqSupply -> RuleBase -> ModGuts -> IO (SimplCount, ModGuts) -- New bindings simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) - hsc_env us hpt_rule_base + hsc_env hpt_rule_base guts@(ModGuts { mg_module = this_mod , mg_rdr_env = rdr_env , mg_deps = deps , mg_binds = binds, mg_rules = rules , mg_fam_inst_env = fam_inst_env }) = do { (termination_msg, it_count, counts_out, guts') - <- do_iteration us 1 [] binds rules + <- do_iteration 1 [] binds rules ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags && dopt Opt_D_dump_simpl_stats dflags) @@ -724,14 +721,14 @@ active_rule = activeRule mode active_unf = activeUnfolding mode - do_iteration :: UniqSupply - -> Int -- Counts iterations + do_iteration :: Int --UniqSupply + -- -> Int -- Counts iterations -> [SimplCount] -- Counts from earlier iterations, reversed -> CoreProgram -- Bindings in -> [CoreRule] -- and orphan rules -> IO (String, Int, SimplCount, ModGuts) - do_iteration us iteration_no counts_so_far binds rules + do_iteration iteration_no counts_so_far binds rules -- iteration_no is the number of the iteration we are -- about to begin, with '1' for the first | iteration_no > max_iterations -- Stop if we've run out of iterations @@ -776,7 +773,7 @@ -- Simplify the program ((binds1, rules1), counts1) <- - initSmpl dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs us1 sz $ + initSmpl dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs sz $ do { (floats, env1) <- {-# SCC "SimplTopBinds" #-} simplTopBinds simpl_env tagged_binds @@ -810,20 +807,18 @@ lintPassResult hsc_env pass binds2 ; -- Loop - do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 + do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 } } #if __GLASGOW_HASKELL__ <= 810 | otherwise = panic "do_iteration" #endif where - (us1, us2) = splitUniqSupply us - -- Remember the counts_so_far are reversed totalise :: [SimplCount] -> SimplCount totalise = foldr (\c acc -> acc `plusSimplCount` c) (zeroSimplCount dflags) -simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO" +simplifyPgmIO _ _ _ _ = panic "simplifyPgmIO" ------------------- dump_end_iteration :: DynFlags -> PrintUnqualified -> Int @@ -1102,7 +1097,7 @@ dmdAnal :: DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram dmdAnal dflags fam_envs rules binds = do - let opts = DmdAnalOpts + let !opts = DmdAnalOpts { dmd_strict_dicts = gopt Opt_DictsStrict dflags } binds_plus_dmds = dmdAnalProgram opts fam_envs rules binds diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -491,7 +491,7 @@ -> LvlM LevelledExpr -- Result expression lvlCase env scrut_fvs scrut' case_bndr ty alts -- See Note [Floating single-alternative cases] - | [(con@(DataAlt {}), bs, body)] <- alts + | [AnnAlt con@(DataAlt {}) bs body] <- alts , exprIsHNF (deTagExpr scrut') -- See Note [Check the output scrutinee for exprIsHNF] , not (isTopLvl dest_lvl) -- Can't have top-level cases , not (floatTopLvlOnly env) -- Can float anywhere @@ -501,7 +501,7 @@ do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs) ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut' ; body' <- lvlMFE rhs_env True body - ; let alt' = (con, map (stayPut dest_lvl) bs', body') + ; let alt' = Alt con (map (stayPut dest_lvl) bs') body' ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) } | otherwise -- Stays put @@ -516,9 +516,9 @@ dest_lvl = maxFvLevel (const True) env scrut_fvs -- Don't abstract over type variables, hence const True - lvl_alt alts_env (con, bs, rhs) + lvl_alt alts_env (AnnAlt con bs rhs) = do { rhs' <- lvlMFE new_env True rhs - ; return (con, bs', rhs') } + ; return (Alt con bs' rhs') } where (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs @@ -701,13 +701,13 @@ ; let l1r = incMinorLvlFrom rhs_env float_rhs = mkLams abs_vars_w_lvls $ Case expr1 (stayPut l1r ubx_bndr) dc_res_ty - [(DEFAULT, [], mkConApp dc [Var ubx_bndr])] + [Alt DEFAULT [] (mkConApp dc [Var ubx_bndr])] ; var <- newLvlVar float_rhs Nothing is_mk_static ; let l1u = incMinorLvlFrom env use_expr = Case (mkVarApps (Var var) abs_vars) (stayPut l1u bx_bndr) expr_ty - [(DataAlt dc, [stayPut l1u ubx_bndr], Var ubx_bndr)] + [Alt (DataAlt dc) [stayPut l1u ubx_bndr] (Var ubx_bndr)] ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs) use_expr) } 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 @@ -1222,7 +1222,7 @@ tickScrut e = foldr mkTick e ticks -- Alternatives get annotated with all ticks that scope in some way, -- but we don't want to count entries. - tickAlt (c,bs,e) = (c,bs, foldr mkTick e ts_scope) + tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope) ts_scope = map mkNoCount $ filter (not . (`tickishScopesLike` NoScope)) ticks @@ -2586,8 +2586,8 @@ , not (litIsLifted lit) = do { tick (KnownBranch case_bndr) ; case findAlt (LitAlt lit) alts of - Nothing -> missingAlt env case_bndr alts cont - Just (_, bs, rhs) -> simple_rhs env [] scrut bs rhs } + Nothing -> missingAlt env case_bndr alts cont + Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs } | Just (in_scope', wfloats, con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut @@ -2598,12 +2598,12 @@ ; let scaled_wfloats = map scale_float wfloats ; case findAlt (DataAlt con) alts of Nothing -> missingAlt env0 case_bndr alts cont - Just (DEFAULT, bs, rhs) -> let con_app = Var (dataConWorkId con) + 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 (_, bs, rhs) -> knownCon env0 scrut scaled_wfloats con ty_args other_args - case_bndr bs rhs cont + 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 } where simple_rhs env wfloats scrut' bs rhs = @@ -2650,7 +2650,7 @@ -- 2. Eliminate the case if scrutinee is evaluated -------------------------------------------------- -rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont +rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont -- See if we can get rid of the case altogether -- See Note [Case elimination] -- mkCase made sure that if all the alternatives are equal, @@ -2882,7 +2882,7 @@ -> OutExpr -> InId -> OutId -> [InAlt] -> SimplM (SimplEnv, OutExpr, OutId) -- Note [Improving seq] -improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] +improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _] | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) = do { case_bndr2 <- newId (fsLit "nt") Many ty2 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing @@ -2903,21 +2903,21 @@ -> InAlt -> SimplM OutAlt -simplAlt env _ imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs) +simplAlt env _ imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs) = ASSERT( null bndrs ) do { let env' = addBinderUnfolding env case_bndr' (mkOtherCon imposs_deflt_cons) -- Record the constructors that the case-binder *can't* be. ; rhs' <- simplExprC env' rhs cont' - ; return (DEFAULT, [], rhs') } + ; return (Alt DEFAULT [] rhs') } -simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs) +simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) bndrs rhs) = ASSERT( null bndrs ) do { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit) ; rhs' <- simplExprC env' rhs cont' - ; return (LitAlt lit, [], rhs') } + ; return (Alt (LitAlt lit) [] rhs') } -simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs) +simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) vs rhs) = do { -- See Note [Adding evaluatedness info to pattern-bound variables] let vs_with_evals = addEvals scrut' con vs ; (env', vs') <- simplLamBndrs env vs_with_evals @@ -2929,7 +2929,7 @@ ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app ; rhs' <- simplExprC env'' rhs cont' - ; return (DataAlt con, vs', rhs') } + ; return (Alt (DataAlt con) vs' rhs') } {- Note [Adding evaluatedness info to pattern-bound variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3247,7 +3247,7 @@ | otherwise = not (all is_bot_alt alts) -- otherwise case: first alt is non-bot, so all the rest must be bot where - is_bot_alt (_,_,rhs) = exprIsDeadEnd rhs + is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs ------------------------- mkDupableCont :: SimplEnv @@ -3435,9 +3435,9 @@ mkDupableAlt :: Platform -> OutId -> JoinFloats -> OutAlt -> SimplM (JoinFloats, OutAlt) -mkDupableAlt platform case_bndr jfloats (con, bndrs', rhs') +mkDupableAlt platform case_bndr jfloats (Alt con bndrs' rhs') | exprIsDupable platform rhs' -- Note [Small alternative rhs] - = return (jfloats, (con, bndrs', rhs')) + = return (jfloats, Alt con bndrs' rhs') | otherwise = do { simpl_opts <- initSimpleOpts <$> getDynFlags @@ -3481,7 +3481,7 @@ ; join_bndr <- newJoinId final_bndrs' rhs_ty' ; let join_call = mkApps (Var join_bndr) final_args - alt' = (con, bndrs', join_call) + alt' = Alt con bndrs' join_call ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs) , alt') } 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 @@ -60,7 +60,6 @@ import GHC.Types.Id as Id import GHC.Core.Make ( mkWildValBinder ) import GHC.Driver.Session ( DynFlags ) -import GHC.Driver.Ppr import GHC.Builtin.Types import GHC.Core.TyCo.Rep ( TyCoBinder(..) ) import qualified GHC.Core.Type as Type @@ -683,7 +682,8 @@ refineFromInScope in_scope v | isLocalId v = case lookupInScope in_scope v of Just v' -> v' - Nothing -> WARN( True, ppr v ) v -- This is an error! + Nothing -> pprPanic "refineFromInScope" (ppr in_scope $$ ppr v) + -- c.f #19074 for a subtle place where this went wrong | otherwise = v lookupRecBndr :: SimplEnv -> InId -> OutId diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs --- a/compiler/GHC/Core/Opt/Simplify/Monad.hs +++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs @@ -60,15 +60,14 @@ newtype SimplM result = SM' { unSM :: SimplTopEnv -- Envt that does not change much - -> UniqSupply -- We thread the unique supply because - -- constantly splitting it is rather expensive -> SimplCount - -> IO (result, UniqSupply, SimplCount)} - -- We only need IO here for dump output + -> IO (result, SimplCount)} + -- We only need IO here for dump output, but since we already have it + -- we might as well use it for uniques. deriving (Functor) -pattern SM :: (SimplTopEnv -> UniqSupply -> SimplCount - -> IO (result, UniqSupply, SimplCount)) +pattern SM :: (SimplTopEnv -> SimplCount + -> IO (result, SimplCount)) -> SimplM result -- This pattern synonym makes the simplifier monad eta-expand, -- which as a very beneficial effect on compiler performance @@ -89,14 +88,15 @@ } initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv) - -> UniqSupply -- No init count; set to 0 -> Int -- Size of the bindings, used to limit -- the number of ticks we allow -> SimplM a -> IO (a, SimplCount) -initSmpl dflags rules fam_envs us size m - = do (result, _, count) <- unSM m env us (zeroSimplCount dflags) +initSmpl dflags rules fam_envs size m + = do -- No init count; set to 0 + let simplCount = zeroSimplCount dflags + (result, count) <- unSM m env simplCount return (result, count) where env = STE { st_flags = dflags @@ -141,20 +141,20 @@ (>>=) = thenSmpl returnSmpl :: a -> SimplM a -returnSmpl e = SM (\_st_env us sc -> return (e, us, sc)) +returnSmpl e = SM (\_st_env sc -> return (e, sc)) thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b thenSmpl_ :: SimplM a -> SimplM b -> SimplM b thenSmpl m k - = SM $ \st_env us0 sc0 -> do - (m_result, us1, sc1) <- unSM m st_env us0 sc0 - unSM (k m_result) st_env us1 sc1 + = SM $ \st_env sc0 -> do + (m_result, sc1) <- unSM m st_env sc0 + unSM (k m_result) st_env sc1 thenSmpl_ m k - = SM $ \st_env us0 sc0 -> do - (_, us1, sc1) <- unSM m st_env us0 sc0 - unSM k st_env us1 sc1 + = SM $ \st_env sc0 -> do + (_, sc1) <- unSM m st_env sc0 + unSM k st_env sc1 -- TODO: this specializing is not allowed -- {-# SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-} @@ -177,35 +177,30 @@ ************************************************************************ -} -instance MonadUnique SimplM where - getUniqueSupplyM - = SM (\_st_env us sc -> case splitUniqSupply us of - (us1, us2) -> return (us1, us2, sc)) - - getUniqueM - = SM (\_st_env us sc -> case takeUniqFromSupply us of - (u, us') -> return (u, us', sc)) +-- See Note [Uniques for wired-in prelude things and known masks] in GHC.Builtin.Uniques +simplMask :: Char +simplMask = 's' - getUniquesM - = SM (\_st_env us sc -> case splitUniqSupply us of - (us1, us2) -> return (uniqsFromSupply us1, us2, sc)) +instance MonadUnique SimplM where + getUniqueSupplyM = liftIO $ mkSplitUniqSupply simplMask + getUniqueM = liftIO $ uniqFromMask simplMask instance HasDynFlags SimplM where - getDynFlags = SM (\st_env us sc -> return (st_flags st_env, us, sc)) + getDynFlags = SM (\st_env sc -> return (st_flags st_env, sc)) instance MonadIO SimplM where - liftIO m = SM $ \_ us sc -> do + liftIO m = SM $ \_ sc -> do x <- m - return (x, us, sc) + return (x, sc) getSimplRules :: SimplM RuleEnv -getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc)) +getSimplRules = SM (\st_env sc -> return (st_rules st_env, sc)) getFamEnvs :: SimplM (FamInstEnv, FamInstEnv) -getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc)) +getFamEnvs = SM (\st_env sc -> return (st_fams st_env, sc)) getOptCoercionOpts :: SimplM OptCoercionOpts -getOptCoercionOpts = SM (\st_env us sc -> return (st_co_opt_opts st_env, us, sc)) +getOptCoercionOpts = SM (\st_env sc -> return (st_co_opt_opts st_env, sc)) newId :: FastString -> Mult -> Type -> SimplM Id newId fs w ty = do uniq <- getUniqueM @@ -234,21 +229,21 @@ -} getSimplCount :: SimplM SimplCount -getSimplCount = SM (\_st_env us sc -> return (sc, us, sc)) +getSimplCount = SM (\_st_env sc -> return (sc, sc)) tick :: Tick -> SimplM () -tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc - in sc' `seq` return ((), us, sc')) +tick t = SM (\st_env sc -> let sc' = doSimplTick (st_flags st_env) t sc + in sc' `seq` return ((), sc')) checkedTick :: Tick -> SimplM () -- Try to take a tick, but fail if too many checkedTick t - = SM (\st_env us sc -> + = SM (\st_env sc -> if st_max_ticks st_env <= mkIntWithInf (simplCountN sc) then throwGhcExceptionIO $ PprProgramError "Simplifier ticks exhausted" (msg sc) else let sc' = doSimplTick (st_flags st_env) t sc - in sc' `seq` return ((), us, sc')) + in sc' `seq` return ((), sc')) where msg sc = vcat [ text "When trying" <+> ppr t @@ -276,5 +271,5 @@ -- Record a tick, but don't add to the total tick count, which is -- used to decide when nothing further has happened freeTick t - = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc - in sc' `seq` return ((), us, sc')) + = SM (\_st_env sc -> let sc' = doFreeSimplTick t sc + in sc' `seq` return ((), sc')) 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 @@ -2242,15 +2242,15 @@ -- 1. Merge Nested Cases -------------------------------------------------- -mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts) +mkCase dflags scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts) | gopt Opt_CaseMerge dflags , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts) <- stripTicksTop tickishFloatable deflt_rhs , inner_scrut_var == outer_bndr = do { tick (CaseMerge outer_bndr) - ; let wrap_alt (con, args, rhs) = ASSERT( outer_bndr `notElem` args ) - (con, args, wrap_rhs rhs) + ; let wrap_alt (Alt con args rhs) = ASSERT( outer_bndr `notElem` args ) + (Alt con args (wrap_rhs rhs)) -- Simplifier's no-shadowing invariant should ensure -- that outer_bndr is not shadowed by the inner patterns wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs @@ -2284,13 +2284,13 @@ -- 2. Eliminate Identity Case -------------------------------------------------- -mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _) -- Identity case +mkCase1 _dflags scrut case_bndr _ alts@(Alt _ _ rhs1 : _) -- Identity case | all identity_alt alts = do { tick (CaseIdentity case_bndr) ; return (mkTicks ticks $ re_cast scrut rhs1) } where - ticks = concatMap (stripTicksT tickishFloatable . thdOf3) (tail alts) - identity_alt (con, args, rhs) = check_eq rhs con args + ticks = concatMap (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) (tail alts) + identity_alt (Alt con args rhs) = check_eq rhs con args check_eq (Cast rhs co) con args -- See Note [RHS casts] = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args @@ -2332,8 +2332,8 @@ mkCase2 dflags scrut bndr alts_ty alts | -- See Note [Scrutinee Constant Folding] case alts of -- Not if there is just a DEFAULT alternative - [(DEFAULT,_,_)] -> False - _ -> True + [Alt DEFAULT _ _] -> False + _ -> True , gopt Opt_CaseFolding dflags , Just (scrut', tx_con, mk_orig) <- caseRules (targetPlatform dflags) scrut = do { bndr' <- newId (fsLit "lwild") Many (exprType scrut') @@ -2368,11 +2368,11 @@ tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id -> CoreAlt -> SimplM (Maybe CoreAlt) - tx_alt tx_con mk_orig new_bndr (con, bs, rhs) + tx_alt tx_con mk_orig new_bndr (Alt con bs rhs) = case tx_con con of Nothing -> return Nothing Just con' -> do { bs' <- mk_new_bndrs new_bndr con' - ; return (Just (con', bs', rhs')) } + ; return (Just (Alt con' bs' rhs')) } where rhs' | isDeadBinder bndr = rhs | otherwise = bindNonRec bndr orig_val rhs @@ -2399,8 +2399,8 @@ add_default :: [CoreAlt] -> [CoreAlt] -- See Note [Literal cases] - add_default ((LitAlt {}, bs, rhs) : alts) = (DEFAULT, bs, rhs) : alts - add_default alts = alts + add_default (Alt (LitAlt {}) bs rhs : alts) = Alt DEFAULT bs rhs : alts + add_default alts = alts {- Note [Literal cases] ~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -1,18 +1,23 @@ {- +ToDo [Oct 2013] +~~~~~~~~~~~~~~~ +1. Nuke ForceSpecConstr for good (it is subsumed by GHC.Types.SPEC in ghc-prim) +2. Nuke NoSpecConstr + (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +\section[SpecConstr]{Specialise over constructors} -} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} --- | Specialise over constructors -module GHC.Core.Opt.SpecConstr - ( specConstrProgram - ) -where +module GHC.Core.Opt.SpecConstr( + specConstrProgram, + SpecConstrAnnotation(..) + ) where #include "GhclibHsVersions.h" @@ -31,7 +36,7 @@ import GHC.Core.Coercion hiding( substCo ) import GHC.Core.Rules import GHC.Core.Type hiding ( substTy ) -import GHC.Core.TyCon ( tyConUnique ) +import GHC.Core.TyCon ( tyConUnique, tyConName ) import GHC.Core.Multiplicity import GHC.Types.Id import GHC.Core.Ppr ( pprParendExpr ) @@ -46,6 +51,7 @@ import GHC.Data.Maybe ( orElse, catMaybes, isJust, isNothing ) import GHC.Types.Demand import GHC.Types.Cpr +import GHC.Serialized ( deserializeWithData ) import GHC.Utils.Misc import GHC.Data.Pair import GHC.Types.Unique.Supply @@ -55,9 +61,11 @@ import GHC.Types.Unique.FM import GHC.Utils.Monad import Control.Monad ( zipWithM ) -import Data.List +import Data.List (nubBy, sortBy, partition) import GHC.Builtin.Names ( specTyConKey ) import GHC.Unit.Module +import GHC.Core.TyCon ( TyCon ) +import GHC.Exts( SpecConstrAnnotation(..) ) import Data.Ord( comparing ) {- @@ -449,19 +457,32 @@ specialise some (but not necessarily all!) loops regardless of their size and the number of specialisations. -We allow a library to force the specialisation by adding a parameter of type -GHC.Types.SPEC (from ghc-prim) to the loop body. +We allow a library to do this, in one of two ways (one which is +deprecated): - Historical note: in the past any datatype could be used in place of - GHC.Types.SPEC as long as it was annotated with GHC.Exts.ForceSpecConstr. It - has been deprecated because it required GHCi, which isn't available for - things like a cross compiler using stage1. + 1) Add a parameter of type GHC.Types.SPEC (from ghc-prim) to the loop body. + 2) (Deprecated) Annotate a type with ForceSpecConstr from GHC.Exts, + and then add *that* type as a parameter to the loop body + +The reason #2 is deprecated is because it requires GHCi, which isn't +available for things like a cross compiler using stage1. + Here's a (simplified) example from the `vector` package. You may bring the special 'force specialization' type into scope by saying: import GHC.Types (SPEC(..)) +or by defining your own type (again, deprecated): + + data SPEC = SPEC | SPEC2 + {-# ANN type SPEC ForceSpecConstr #-} + +(Note this is the exact same definition of GHC.Types.SPEC, just +without the annotation.) + +After that, you say: + foldl :: (a -> b -> a) -> a -> Stream b -> a {-# INLINE foldl #-} foldl f z (Stream step s _) = foldl_loop SPEC z s @@ -483,7 +504,7 @@ This is all quite ugly; we ought to come up with a better design. -SPEC arguments are spotted in scExpr' and scTopBinds which then set +ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set sc_force to True when calling specLoop. This flag does four things: * Ignore specConstrThreshold, to specialise functions of arbitrary size @@ -526,8 +547,8 @@ user (e.g., the accumulator here) but we still want to specialise as much as possible. -Alternatives to SPEC -~~~~~~~~~~~~~~~~~~~~ +Alternatives to ForceSpecConstr +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Instead of giving the loop an extra argument of type SPEC, we also considered *wrapping* arguments in SPEC, thus data SPEC a = SPEC a | SPEC2 @@ -551,13 +572,13 @@ Note [Limit recursive specialisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is possible for SPEC to cause an infinite loop of specialisation. +It is possible for ForceSpecConstr to cause an infinite loop of specialisation. Because there is no limit on the number of specialisations, a recursive call with a recursive constructor as an argument (for example, list cons) will generate a specialisation for that constructor. If the resulting specialisation also contains a recursive call with the constructor, this could proceed indefinitely. -For example, if SPEC is on: +For example, if ForceSpecConstr is on: loop :: [Int] -> [Int] -> [Int] loop z [] = z loop z (x:xs) = loop (x:z) xs @@ -587,6 +608,16 @@ See #5550. Also #13623, where this test had become over-aggressive, and we lost a wonderful specialisation that we really wanted! +Note [NoSpecConstr] +~~~~~~~~~~~~~~~~~~~ +The ignoreDataCon stuff allows you to say + {-# ANN type T NoSpecConstr #-} +to mean "don't specialise on arguments of this type". It was added +before we had ForceSpecConstr. Lacking ForceSpecConstr we specialised +regardless of size; and then we needed a way to turn that *off*. Now +that we have ForceSpecConstr, this NoSpecConstr is probably redundant. +(Used only for PArray, TODO: remove?) + ----------------------------------------------------- Stuff not yet handled ----------------------------------------------------- @@ -674,10 +705,11 @@ = do dflags <- getDynFlags us <- getUniqueSupplyM + (_, annos) <- getFirstAnnotations deserializeWithData guts this_mod <- getModule let binds' = reverse $ fst $ initUs us $ do -- Note [Top-level recursive groups] - (env, binds) <- goEnv (initScEnv dflags this_mod) + (env, binds) <- goEnv (initScEnv dflags this_mod annos) (mg_binds guts) -- binds is identical to (mg_binds guts), except that the -- binders on the LHS have been replaced by extendBndr @@ -793,7 +825,7 @@ -- See Note [Avoiding exponential blowup] sc_recursive :: Int, -- Max # of specialisations over recursive type. - -- Stops SPEC from diverging. + -- Stops ForceSpecConstr from diverging. sc_keen :: Bool, -- Specialise on arguments that are known -- constructors, even if they are not @@ -810,13 +842,15 @@ -- Binds interesting non-top-level variables -- Domain is OutVars (*after* applying the substitution) - sc_vals :: ValueEnv + sc_vals :: ValueEnv, -- Domain is OutIds (*after* applying the substitution) -- Used even for top-level bindings (but not imported ones) -- The range of the ValueEnv is *work-free* values -- such as (\x. blah), or (Just v) -- but NOT (Just (expensive v)) -- See Note [Work-free values only in environment] + + sc_annotations :: UniqFM Name SpecConstrAnnotation } --------------------- @@ -833,8 +867,8 @@ ppr LambdaVal = text "" --------------------- -initScEnv :: DynFlags -> Module -> ScEnv -initScEnv dflags this_mod +initScEnv :: DynFlags -> Module -> UniqFM Name SpecConstrAnnotation -> ScEnv +initScEnv dflags this_mod anns = SCE { sc_dflags = dflags, sc_uf_opts = unfoldingOpts dflags, sc_module = this_mod, @@ -845,7 +879,8 @@ sc_force = False, sc_subst = emptySubst, sc_how_bound = emptyVarEnv, - sc_vals = emptyVarEnv } + sc_vals = emptyVarEnv, + sc_annotations = anns } data HowBound = RecFun -- These are the recursive functions for which -- we seek interesting call patterns @@ -970,7 +1005,21 @@ --------------------------------------------------- -- See Note [Forcing specialisation] +ignoreType :: ScEnv -> Type -> Bool +ignoreDataCon :: ScEnv -> DataCon -> Bool forceSpecBndr :: ScEnv -> Var -> Bool + +ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc) + +ignoreType env ty + = case tyConAppTyCon_maybe ty of + Just tycon -> ignoreTyCon env tycon + _ -> False + +ignoreTyCon :: ScEnv -> TyCon -> Bool +ignoreTyCon env tycon + = lookupUFM (sc_annotations env) (tyConName tycon) == Just NoSpecConstr + forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTyCoVars . varType $ var forceSpecFunTy :: ScEnv -> Type -> Bool @@ -984,6 +1033,7 @@ | Just (tycon, tys) <- splitTyConApp_maybe ty , tycon /= funTyCon = tyConUnique tycon == specTyConKey + || lookupUFM (sc_annotations env) (tyConName tycon) == Just ForceSpecConstr || any (forceSpecArgTy env) tys forceSpecArgTy _ _ = False @@ -1183,8 +1233,8 @@ } where sc_con_app con args scrut' -- Known constructor; simplify - = do { let (_, bs, rhs) = findAlt con alts - `orElse` (DEFAULT, [], mkImpossibleExpr ty) + = do { let Alt _ bs rhs = findAlt con alts + `orElse` Alt DEFAULT [] (mkImpossibleExpr ty) alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args) ; scExpr alt_env' rhs } @@ -1204,7 +1254,7 @@ ; return (foldr combineUsage scrut_usg' alt_usgs, Case scrut' b' (scSubstTy env ty) alts') } - sc_alt env scrut' b' (con,bs,rhs) + sc_alt env scrut' b' (Alt con bs rhs) = do { let (env1, bs1) = extendBndrsWith RecArg env bs (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1 ; (usg, rhs') <- scExpr env2 rhs @@ -1212,7 +1262,7 @@ scrut_occ = case con of DataAlt dc -> ScrutOcc (unitUFM dc arg_occs) _ -> ScrutOcc emptyUFM - ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) } + ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') } scExpr' env (Let (NonRec bndr rhs) body) | isTyVar bndr -- Type-lets may be created by doBeta @@ -1846,9 +1896,9 @@ of specialisations for a given function to N. * -fno-spec-constr-count sets the sc_count field to Nothing, - which switches off the limit. + which switches of the limit. -* The ghastly SPEC trick also switches off the limit +* The ghastly ForceSpecConstr trick also switches of the limit for a particular function * Otherwise we sort the patterns to choose the most general @@ -2121,6 +2171,7 @@ -} argToPat env in_scope val_env (Cast arg co) arg_occ + | not (ignoreType env ty2) = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ ; if not interesting then wildCardPat ty2 @@ -2151,6 +2202,7 @@ -- NB: this *precedes* the Var case, so that we catch nullary constrs argToPat env in_scope val_env arg arg_occ | Just (ConVal (DataAlt dc) args) <- isValue val_env arg + , not (ignoreDataCon env dc) -- See Note [NoSpecConstr] , Just arg_occs <- mb_scrut dc = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs @@ -2171,10 +2223,11 @@ -- In that case it counts as "interesting" argToPat env in_scope val_env (Var v) arg_occ | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a) - is_value -- (b) + is_value, -- (b) -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing] -- So sc_keen focused just on f (I# x), where we have freshly-allocated -- box that we can eliminate in the caller + not (ignoreType env (varType v)) = return (True, Var v) where is_value diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -1140,14 +1140,14 @@ , Id , [CoreAlt] , UsageDetails) -specCase env scrut' case_bndr [(con, args, rhs)] +specCase env scrut' case_bndr [Alt con args rhs] | isDictId case_bndr -- See Note [Floating dictionaries out of cases] , interestingDict env scrut' , not (isDeadBinder case_bndr && null sc_args') = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args') ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg') - [(con, args', Var sc_arg')] + [Alt con args' (Var sc_arg')] | sc_arg' <- sc_args' ] -- Extend the substitution for RHS to map the *original* binders @@ -1171,7 +1171,7 @@ flt_binds = scrut_bind : sc_binds (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds all_uds = flt_binds `addDictBinds` free_uds - alt' = (con, args', wrapDictBindsE dumped_dbs rhs') + alt' = Alt con args' (wrapDictBindsE dumped_dbs rhs') ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) } where (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args) @@ -1200,10 +1200,10 @@ ; return (scrut, case_bndr', alts', uds_alts) } where (env_alt, case_bndr') = substBndr env case_bndr - spec_alt (con, args, rhs) = do + spec_alt (Alt con args rhs) = do (rhs', uds) <- specExpr env_rhs rhs let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds - return ((con, args', wrapDictBindsE dumped_dbs rhs'), free_uds) + return (Alt con args' (wrapDictBindsE dumped_dbs rhs'), free_uds) where (env_rhs, args') = substBndrs env_alt args diff --git a/compiler/GHC/Core/Opt/StaticArgs.hs b/compiler/GHC/Core/Opt/StaticArgs.hs --- a/compiler/GHC/Core/Opt/StaticArgs.hs +++ b/compiler/GHC/Core/Opt/StaticArgs.hs @@ -225,9 +225,9 @@ let (alts', sat_infos_alts) = unzip zipped_alts' return (Case expr' bndr ty alts', mergeIdSATInfo sat_info_expr' (mergeIdSATInfos sat_infos_alts), Nothing) where - satAlt (con, bndrs, expr) = do + satAlt (Alt con bndrs expr) = do (expr', sat_info_expr) <- satTopLevelExpr expr interesting_ids - return ((con, bndrs, expr'), sat_info_expr) + return (Alt con bndrs expr', sat_info_expr) satExpr (Let bind body) interesting_ids = do (body', sat_info_body, body_app) <- satExpr body interesting_ids diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -142,12 +142,12 @@ -- See Note [Zapping Used Once info in WorkWrap] return (Case new_expr new_binder ty new_alts) where - ww_alt (con, binders, rhs) = do + ww_alt (Alt con binders rhs) = do new_rhs <- wwExpr dflags fam_envs rhs let new_binders = [ if isId b then zapIdUsedOnceInfo b else b | b <- binders ] -- See Note [Zapping Used Once info in WorkWrap] - return (con, new_binders, new_rhs) + return (Alt con new_binders new_rhs) {- ************************************************************************ @@ -781,27 +781,59 @@ NB: For recursive thunks, the Simplifier is unable to float `x-rhs` out of `x*`'s RHS, because `x*` occurs freely in `x-rhs`, and will just change it back to the original definition, so we just split non-recursive thunks. + +Note [Thunk splitting for top-level binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Top-level bindings are never strict. Yet they can be absent, as T14270 shows: + + module T14270 (mkTrApp) where + mkTrApp x y + | Just ... <- ... typeRepKind x ... + = undefined + | otherwise + = undefined + typeRepKind = Tick scc undefined + +(T19180 is a profiling-free test case for this) +Note that `typeRepKind` is not exported and its only use site in +`mkTrApp` guards a bottoming expression. Thus, demand analysis +figures out that `typeRepKind` is absent and splits the thunk to + + typeRepKind = + let typeRepKind = Tick scc undefined in + let typeRepKind = absentError in + typeRepKind + +But now we have a local binding with an External Name +(See Note [About the NameSorts]). That will trigger a CoreLint error, which we +get around by localising the Id for the auxiliary bindings in 'splitThunk'. -} --- See Note [Thunk splitting] +-- | See Note [Thunk splitting]. +-- -- splitThunk converts the *non-recursive* binding -- x = e -- into --- x = let x = e --- in case x of --- I# y -> let x = I# y in x } +-- x = let x' = e in +-- case x' of I# y -> let x' = I# y in x' -- See comments above. Is it not beautifully short? -- Moreover, it works just as well when there are -- several binders, and if the binders are lifted -- E.g. x = e --- --> x = let x = e in --- case x of (a,b) -> let x = (a,b) in x - +-- --> x = let x' = e in +-- case x' of (a,b) -> let x' = (a,b) in x' +-- Here, x' is a localised version of x, in case x is a +-- top-level Id with an External Name, because Lint rejects local binders with +-- External Names; see Note [About the NameSorts] in GHC.Types.Name. +-- +-- How can we do thunk-splitting on a top-level binder? See +-- Note [Thunk splitting for top-level binders]. splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)] -splitThunk dflags fam_envs is_rec fn_id rhs - = ASSERT(not (isJoinId fn_id)) - do { (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False [fn_id] - ; let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ] - ; if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive +splitThunk dflags fam_envs is_rec x rhs + = ASSERT(not (isJoinId x)) + do { let x' = localiseId x -- See comment above + ; (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False [x'] + ; let res = [ (x, Let (NonRec x' rhs) (wrap_fn (work_fn (Var x')))) ] + ; if useful then ASSERT2( isNonRec is_rec, ppr x ) -- The thunk must be non-recursive return res - else return [(fn_id, rhs)] } + else return [(x, rhs)] } diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -593,7 +593,7 @@ = return (False, [arg], nop_fn, nop_fn) | isAbsDmd dmd - , Just work_fn <- mk_absent_let dflags fam_envs arg + , Just work_fn <- mk_absent_let dflags fam_envs arg dmd -- Absent case. We can't always handle absence for arbitrary -- unlifted types, so we need to choose just the cases we can -- (that's what mk_absent_let does) @@ -1255,22 +1255,73 @@ Note [Absent errors] ~~~~~~~~~~~~~~~~~~~~ -We make a new binding for Ids that are marked absent, thus - let x = absentError "x :: Int" -The idea is that this binding will never be used; but if it -buggily is used we'll get a runtime error message. +Consider + data T = MkT [Int] [Int] ![Int] + f :: T -> Int# -> blah + f ps w = case ps of MkT xs _ _ -> +Then f gets a strictness sig of . We make worker $wf thus: -Coping with absence for *unlifted* types is important; see, for -example, #4306 and #15627. In the UnliftedRep case, we can -use LitRubbish, which we need to apply to the required type. -For the unlifted types of singleton kind like Float#, Addr#, etc. we -also find a suitable literal, using Literal.absentLiteralOf. We don't -have literals for every primitive type, so the function is partial. +$wf :: [Int] -> blah +$wf xs = case ps of MkT xs _ _ -> + where + ys = absentError "ys :: [Int]" + zs = LitRubbish True + ps = MkT xs ys zs + w = 0# -Note: I did try the experiment of using an error thunk for unlifted -things too, relying on the simplifier to drop it as dead code. -But this is fragile +We make a let-binding for Absent arguments, such as ys and w, that are not even +passed to the worker. They should, of course, never be used. We distinguish four +cases: +1. Ordinary boxed, lifted arguments, like 'ys' We make a new binding for Ids + that are marked absent, thus + let ys = absentError "ys :: [Int]" + The idea is that this binding will never be used; but if it + buggily is used we'll get a runtime error message. + +2. Boxed, lifted types, with a strict demand, like 'zs'. You may ask: how the + demand be both absent and strict? That's exactly what happens for 'zs': it + is not used, so its demand is Absent, but then during w/w, in + addDataConStrictness, we strictify the demand. So it gets cardinality C_10, + the empty interval. + + We don't want to use an error-thunk for 'zs' because MkT's third argument has + a bang, and hence should be always evaluated. This turned out to be + important when fixing #16970, which establishes the invariant that strict + constructor arguments are always evaluated. So we use LitRubbish instead + of an error thunk -- see #19133. + + These first two cases are distinguished by isStrictDmd in lifted_rhs. + +3. Unboxed types, like 'w', with a type like Float#, Int#. Coping with absence + for unboxed types is important; see, for example, #4306 and #15627. We + simply find a suitable literal, using Literal.absentLiteralOf. We don't have + literals for every primitive type, so the function is partial. + +4. Boxed, unlifted types, like (Array# t). We can't use absentError because + unlifted bindings ares strict. So we use LitRubbish, which we need to apply + to the required type. + +Case (2) and (4) crucially use LitRubbish as the placeholder: see Note [Rubbish +literals] in GHC.Types.Literal. We could do that in case (1) as well, but we +get slightly better self-checking with an error thunk. + +Suppose we use LitRubbish and absence analysis is Wrong, so that the "absent" +value is used after all. Then in case (2) we could get a seg-fault, because we +may have replaced, say, a [Either Int Bool] by (), and that will fail if we do +case analysis on it. Similarly with boxed unlifted types, case (4). + +In case (3), if absence analysis is wrong we could conceivably get an exception, +from a divide-by-zero with the absent value. But it's very unlikely. + +Only in case (1) can we guarantee a civilised runtime error. Not much we can do +about this; we really rely on absence analysis to be correct. + + +Historical note: I did try the experiment of using an error thunk for unlifted +things too, relying on the simplifier to drop it as dead code. But this is +fragile + - It fails when profiling is on, which disables various optimisations - It fails when reboxing happens. E.g. @@ -1281,10 +1332,8 @@ pass that component to the worker for 'f', which reconstructs 'p' to pass it to 'g'. Alas we can't say ...f (MkT a (absentError Int# "blah"))... - bacause `MkT` is strict in its Int# argument, so we get an absentError + because `MkT` is strict in its Int# argument, so we get an absentError exception when we shouldn't. Very annoying! - -So absentError is only used for lifted types. -} -- | Tries to find a suitable dummy RHS to bind the given absent identifier to. @@ -1292,23 +1341,28 @@ -- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding -- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be -- found (currently only happens for bindings of 'VecRep' representation). -mk_absent_let :: DynFlags -> FamInstEnvs -> Id -> Maybe (CoreExpr -> CoreExpr) -mk_absent_let dflags fam_envs arg +mk_absent_let :: DynFlags -> FamInstEnvs -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr) +mk_absent_let dflags fam_envs arg dmd + -- The lifted case: Bind 'absentError' -- See Note [Absent errors] | not (isUnliftedType arg_ty) - = Just (Let (NonRec lifted_arg abs_rhs)) + = Just (Let (NonRec lifted_arg lifted_rhs)) -- The 'UnliftedRep' (because polymorphic) case: Bind @__RUBBISH \@arg_ty@ -- See Note [Absent errors] + | [UnliftedRep] <- typePrimRep arg_ty = Just (Let (NonRec arg unlifted_rhs)) + -- The monomorphic unlifted cases: Bind to some literal, if possible -- See Note [Absent errors] | Just tc <- tyConAppTyCon_maybe nty , Just lit <- absentLiteralOf tc = Just (Let (NonRec arg (Lit lit `mkCast` mkSymCo co))) + | nty `eqType` unboxedUnitTy = Just (Let (NonRec arg (Var voidPrimId `mkCast` mkSymCo co))) + | otherwise = WARN( True, text "No absent value for" <+> ppr arg_ty ) Nothing -- Can happen for 'State#' and things of 'VecRep' @@ -1317,6 +1371,11 @@ -- Note in strictness signature that this is bottoming -- (for the sake of the "empty case scrutinee not known to -- diverge for sure lint" warning) + + lifted_rhs | isStrictDmd dmd = mkTyApps (Lit (rubbishLit True)) [arg_ty] + | otherwise = mkAbsentErrorApp arg_ty msg + unlifted_rhs = mkTyApps (Lit (rubbishLit False)) [arg_ty] + arg_ty = idType arg -- Normalise the type to have best chance of finding an absent literal @@ -1326,7 +1385,6 @@ (co, nty) = topNormaliseType_maybe fam_envs arg_ty `orElse` (mkRepReflCo arg_ty, arg_ty) - abs_rhs = mkAbsentErrorApp arg_ty msg msg = showSDoc (gopt_set dflags Opt_SuppressUniques) (vcat [ text "Arg:" <+> ppr arg @@ -1342,7 +1400,6 @@ -- will have different lengths and hence different costs for -- the inliner leading to different inlining. -- See also Note [Unique Determinism] in GHC.Types.Unique - unlifted_rhs = mkTyApps (Lit rubbishLit) [arg_ty] ww_prefix :: FastString ww_prefix = fsLit "ww" diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -68,7 +68,7 @@ import GHC.Data.Maybe import GHC.Data.Bag import GHC.Utils.Misc as Utils -import Data.List +import Data.List (sortBy, mapAccumL, isPrefixOf) import Data.Function ( on ) import Control.Monad ( guard ) @@ -890,7 +890,7 @@ -> Maybe RuleSubst match_alts _ subst [] [] = return subst -match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) +match_alts renv subst (Alt c1 vs1 r1:alts1) (Alt c2 vs2 r2:alts2) | c1 == c2 = do { subst1 <- match renv' subst r1 r2 ; match_alts renv subst1 alts1 alts2 } @@ -1211,7 +1211,7 @@ ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e ruleCheck env (Lam _ e) = ruleCheck env e ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` - unionManyBags [ruleCheck env r | (_,_,r) <- as] + unionManyBags [ruleCheck env r | Alt _ _ r <- as] ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs --- a/compiler/GHC/Core/Tidy.hs +++ b/compiler/GHC/Core/Tidy.hs @@ -31,7 +31,7 @@ import GHC.Types.Name hiding (tidyNameOcc) import GHC.Types.SrcLoc import GHC.Data.Maybe -import Data.List +import Data.List (mapAccumL) {- ************************************************************************ @@ -83,9 +83,9 @@ ------------ Case alternatives -------------- tidyAlt :: TidyEnv -> CoreAlt -> CoreAlt -tidyAlt env (con, vs, rhs) +tidyAlt env (Alt con vs rhs) = tidyBndrs env vs =: \ (env', vs) -> - (con, vs, tidyExpr env' rhs) + (Alt con vs (tidyExpr env' rhs)) ------------ Tickish -------------- tidyTickish :: TidyEnv -> Tickish Id -> Tickish Id diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -65,7 +65,8 @@ import GHC.Types.Var.Env import GHC.Builtin.Names ( unsafeEqualityProofName ) -import Data.List +import Data.List ( genericReplicate, genericLength, intersperse + , partition, scanl', sort, sortBy, zip4, zip6, nub ) import Foreign import Control.Monad import Data.Char @@ -655,7 +656,7 @@ schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut -- handle pairs with one void argument (e.g. state token) -schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) +schemeE d s p (AnnCase scrut bndr _ [AnnAlt (DataAlt dc) [bind1, bind2] rhs]) | isUnboxedTupleDataCon dc -- Convert -- case .... of x { (# V'd-thing, a #) -> ... } @@ -667,20 +668,20 @@ -- envt (it won't be bound now) because we never look such things up. , Just res <- case (typePrimRep (idType bind1), typePrimRep (idType bind2)) of ([], [_]) - -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr) + -> Just $ doCase d s p scrut bind2 [AnnAlt DEFAULT [] rhs] (Just bndr) ([_], []) - -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) + -> Just $ doCase d s p scrut bind1 [AnnAlt DEFAULT [] rhs] (Just bndr) _ -> Nothing = res -- handle unit tuples -schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)]) +schemeE d s p (AnnCase scrut bndr _ [AnnAlt (DataAlt dc) [bind1] rhs]) | isUnboxedTupleDataCon dc , typePrimRep (idType bndr) `lengthAtMost` 1 - = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) + = doCase d s p scrut bind1 [AnnAlt DEFAULT [] rhs] (Just bndr) -- handle nullary tuples -schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)]) +schemeE d s p (AnnCase scrut bndr _ alt@[AnnAlt DEFAULT [] _]) | isUnboxedTupleType (idType bndr) , Just ty <- case typePrimRep (idType bndr) of [_] -> Just (unwrapType (idType bndr)) @@ -1061,11 +1062,11 @@ isAlgCase = not (isUnliftedType bndr_ty) && isNothing is_unboxed_tuple -- given an alt, return a discr and code for it. - codeAlt (DEFAULT, _, (_,rhs)) + codeAlt (AnnAlt DEFAULT _ (_,rhs)) = do rhs_code <- schemeE d_alts s p_alts rhs return (NoDiscr, rhs_code) - codeAlt alt@(_, bndrs, (_,rhs)) + codeAlt alt@(AnnAlt _ bndrs (_,rhs)) -- primitive or nullary constructor alt: no need to UNPACK | null real_bndrs = do rhs_code <- schemeE d_alts s p_alts rhs @@ -1099,13 +1100,13 @@ where real_bndrs = filterOut isTyVar bndrs - my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-} - my_discr (DataAlt dc, _, _) + my_discr (AnnAlt DEFAULT _ _) = NoDiscr {-shouldn't really happen-} + my_discr (AnnAlt (DataAlt dc) _ _) | isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc = multiValException | otherwise = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG)) - my_discr (LitAlt l, _, _) + my_discr (AnnAlt (LitAlt l) _ _) = case l of LitNumber LitNumInt i -> DiscrI (fromInteger i) LitNumber LitNumWord w -> DiscrW (fromInteger w) LitFloat r -> DiscrF (fromRational r) @@ -1116,7 +1117,7 @@ maybe_ncons | not isAlgCase = Nothing | otherwise - = case [dc | (DataAlt dc, _, _) <- alts] of + = case [dc | AnnAlt (DataAlt dc) _ _ <- alts] of [] -> Nothing (dc:_) -> Just (tyConFamilySize (dataConTyCon dc)) @@ -1655,13 +1656,13 @@ _ -> PUSH_UBX lit (trunc16W $ bytesToWords platform size_bytes) case lit of - LitLabel _ _ _ -> code AddrRep - LitFloat _ -> code FloatRep - LitDouble _ -> code DoubleRep - LitChar _ -> code WordRep + LitLabel {} -> code AddrRep + LitFloat {} -> code FloatRep + LitDouble {} -> code DoubleRep + LitChar {} -> code WordRep LitNullAddr -> code AddrRep - LitString _ -> code AddrRep - LitRubbish -> code WordRep + LitString {} -> code AddrRep + LitRubbish {} -> code WordRep LitNumber nt _ -> case nt of LitNumInt -> code IntRep LitNumWord -> code WordRep @@ -1954,7 +1955,7 @@ bcView (AnnCase (_,e) _ _ alts) -- Handle unsafe equality proof | AnnVar id <- bcViewLoop e , idName id == unsafeEqualityProofName - , [(_, _, (_, rhs))] <- alts + , [AnnAlt _ _ (_, rhs)] <- alts = Just rhs bcView _ = Nothing diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -52,7 +52,6 @@ import GHC.Builtin.Names ( unsafeEqualityProofName ) import Control.Monad (ap) -import Data.List.NonEmpty (nonEmpty, toList) import Data.Maybe (fromMaybe) import Data.Tuple (swap) import qualified Data.Set as Set @@ -326,7 +325,7 @@ -> CtsM (StgRhs, CollectedCCs) coreToTopStgRhs dflags ccs this_mod (bndr, rhs) - = do { new_rhs <- coreToStgExpr rhs + = do { new_rhs <- coreToPreStgRhs rhs ; let (stg_rhs, ccs') = mkTopStgRhs dflags this_mod ccs bndr new_rhs @@ -359,6 +358,10 @@ -- Expressions -- --------------------------------------------------------------------------- +-- coreToStgExpr panics if the input expression is a value lambda. CorePrep +-- ensures that value lambdas only exist as the RHS of bindings, which we +-- handle with the function coreToPreStgRhs. + coreToStgExpr :: CoreExpr -> CtsM StgExpr @@ -374,9 +377,10 @@ coreToStgExpr (Lit (LitNumber LitNumInteger _)) = panic "coreToStgExpr: LitInteger" coreToStgExpr (Lit (LitNumber LitNumNatural _)) = panic "coreToStgExpr: LitNatural" coreToStgExpr (Lit l) = return (StgLit l) -coreToStgExpr (App (Lit LitRubbish) _some_unlifted_type) +coreToStgExpr (App (Lit lit) _some_boxed_type) + | isRubbishLit lit -- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in - -- a STG to Cmm pass. + -- a STG to Cmm pass. Doesn't matter whether it is lifted or unlifted = coreToStgExpr (Var unitDataConId) coreToStgExpr (Var v) = coreToStgApp v [] [] coreToStgExpr (Coercion _) @@ -391,17 +395,14 @@ coreToStgExpr expr@(Lam _ _) = let (args, body) = myCollectBinders expr - args' = filterStgBinders args in - extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do - body' <- coreToStgExpr body - let - result_expr = case nonEmpty args' of - Nothing -> body' - Just args'' -> StgLam args'' body' + case filterStgBinders args of - return result_expr + [] -> coreToStgExpr body + _ -> pprPanic "coretoStgExpr" $ + text "Unexpected value lambda:" $$ ppr expr + coreToStgExpr (Tick tick expr) = do case tick of HpcTick{} -> return () @@ -447,8 +448,8 @@ text "STG:" $$ pprStgExpr panicStgPprOpts stg _ -> return stg where - vars_alt :: (AltCon, [Var], CoreExpr) -> CtsM (AltCon, [Var], StgExpr) - vars_alt (con, binders, rhs) + vars_alt :: CoreAlt -> CtsM (AltCon, [Var], StgExpr) + vars_alt (Alt con binders rhs) | DataAlt c <- con, c == unboxedUnitDataCon = -- This case is a bit smelly. -- See Note [Nullary unboxed tuple] in GHC.Core.Type @@ -499,7 +500,7 @@ -- grabbing the one from a constructor alternative -- if one exists. look_for_better_tycon - | ((DataAlt con, _, _) : _) <- data_alts = + | ((Alt (DataAlt con) _ _) : _) <- data_alts = AlgAlt (dataConTyCon con) | otherwise = ASSERT(null data_alts) @@ -673,23 +674,42 @@ -> CtsM StgRhs coreToStgRhs (bndr, rhs) = do - new_rhs <- coreToStgExpr rhs + new_rhs <- coreToPreStgRhs rhs return (mkStgRhs bndr new_rhs) +-- Represents the RHS of a binding for use with mk(Top)StgRhs. +data PreStgRhs = PreStgRhs [Id] StgExpr -- The [Id] is empty for thunks + +-- Convert the RHS of a binding from Core to STG. This is a wrapper around +-- coreToStgExpr that can handle value lambdas. +coreToPreStgRhs :: CoreExpr -> CtsM PreStgRhs +coreToPreStgRhs (Cast expr _) = coreToPreStgRhs expr +coreToPreStgRhs expr@(Lam _ _) = + let + (args, body) = myCollectBinders expr + args' = filterStgBinders args + in + extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do + body' <- coreToStgExpr body + return (PreStgRhs args' body') +coreToPreStgRhs expr = PreStgRhs [] <$> coreToStgExpr expr + -- Generate a top-level RHS. Any new cost centres generated for CAFs will be -- appended to `CollectedCCs` argument. mkTopStgRhs :: DynFlags -> Module -> CollectedCCs - -> Id -> StgExpr -> (StgRhs, CollectedCCs) + -> Id -> PreStgRhs -> (StgRhs, CollectedCCs) -mkTopStgRhs dflags this_mod ccs bndr rhs - | StgLam bndrs body <- rhs - = -- StgLam can't have empty arguments, so not CAF +mkTopStgRhs dflags this_mod ccs bndr (PreStgRhs bndrs rhs) + | not (null bndrs) + = -- The list of arguments is non-empty, so not CAF ( StgRhsClosure noExtFieldSilent dontCareCCS ReEntrant - (toList bndrs) body + bndrs rhs , ccs ) + -- After this point we know that `bndrs` is empty, + -- so this is not a function binding | StgConApp con args _ <- unticked_rhs , -- Dynamic StgConApps are updatable not (isDllConApp dflags this_mod con args) @@ -731,14 +751,16 @@ -- Generate a non-top-level RHS. Cost-centre is always currentCCS, -- see Note [Cost-centre initialization plan]. -mkStgRhs :: Id -> StgExpr -> StgRhs -mkStgRhs bndr rhs - | StgLam bndrs body <- rhs +mkStgRhs :: Id -> PreStgRhs -> StgRhs +mkStgRhs bndr (PreStgRhs bndrs rhs) + | not (null bndrs) = StgRhsClosure noExtFieldSilent currentCCS ReEntrant - (toList bndrs) body + bndrs rhs + -- After this point we know that `bndrs` is empty, + -- so this is not a function binding | isJoinId bndr -- must be a nullary join point = ASSERT(idJoinArity bndr == 0) StgRhsClosure noExtFieldSilent diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -622,7 +622,7 @@ cpeRhsE env (Case scrut bndr ty alts) | isUnsafeEqualityProof scrut - , [(con, bs, rhs)] <- alts + , [Alt con bs rhs] <- alts = do { (floats1, scrut') <- cpeBody env scrut ; (env1, bndr') <- cpCloneBndr env bndr ; (env2, bs') <- cpCloneBndrs env1 bs @@ -652,10 +652,10 @@ ; return (floats, Case scrut' bndr2 ty alts'') } where - sat_alt env (con, bs, rhs) + sat_alt env (Alt con bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs ; rhs' <- cpeBodyNF env2 rhs - ; return (con, bs', rhs') } + ; return (Alt con bs' rhs') } -- --------------------------------------------------------------------------- -- CpeBody: produces a result satisfying CpeBody @@ -1120,7 +1120,7 @@ = cpExprIsTrivial e | Case scrut _ _ alts <- e , isUnsafeEqualityProof scrut - , [(_,_,rhs)] <- alts + , [Alt _ _ rhs] <- alts = cpExprIsTrivial rhs | otherwise = exprIsTrivial e @@ -1302,6 +1302,22 @@ Note [Pin demand info on floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We pin demand info on floated lets, so that we can see the one-shot thunks. + +Note [Speculative evaluation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since call-by-value is much cheaper than call-by-need, we case-bind arguments +that are either + + 1. Strictly evaluated anyway, according to the StrictSig of the callee, or + 2. ok-for-spec, according to 'exprOkForSpeculation' + +While (1) is a no-brainer and always beneficial, (2) is a bit +more subtle, as the careful haddock for 'exprOkForSpeculation' +points out. Still, by case-binding the argument we don't need +to allocate a thunk for it, whose closure must be retained as +long as the callee might evaluate it. And if it is evaluated on +most code paths anyway, we get to turn the unknown eval in the +callee into a known call at the call site. -} data FloatingBind @@ -1350,19 +1366,20 @@ mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind mkFloat dmd is_unlifted bndr rhs - | is_strict - , not is_hnf = FloatCase rhs bndr DEFAULT [] (exprOkForSpeculation rhs) + | is_strict || ok_for_spec -- See Note [Speculative evaluation] + , not is_hnf = FloatCase rhs bndr DEFAULT [] ok_for_spec -- Don't make a case for a HNF binding, even if it's strict -- Otherwise we get case (\x -> e) of ...! - | is_unlifted = ASSERT2( exprOkForSpeculation rhs, ppr rhs ) + | is_unlifted = ASSERT2( ok_for_spec, ppr rhs ) FloatCase rhs bndr DEFAULT [] True - | is_hnf = FloatLet (NonRec bndr rhs) - | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs) + | is_hnf = FloatLet (NonRec bndr rhs) + | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs) -- See Note [Pin demand info on floats] where - is_hnf = exprIsHNF rhs - is_strict = isStrUsedDmd dmd + is_hnf = exprIsHNF rhs + is_strict = isStrUsedDmd dmd + ok_for_spec = exprOkForSpeculation rhs emptyFloats :: Floats emptyFloats = Floats OkToSpec nilOL @@ -1374,7 +1391,7 @@ wrapBinds (Floats _ binds) body = foldrOL mk_bind body binds where - mk_bind (FloatCase rhs bndr con bs _) body = Case rhs bndr (exprType body) [(con,bs,body)] + mk_bind (FloatCase rhs bndr con bs _) body = Case rhs bndr (exprType body) [Alt con bs body] mk_bind (FloatLet bind) body = Let bind body mk_bind (FloatTick tickish) body = mkTick tickish body @@ -1828,7 +1845,7 @@ Type{} -> cs Coercion{} -> cs - go_alts = foldl' (\cs (_con, _bndrs, e) -> go cs e) + go_alts = foldl' (\cs (Alt _con _bndrs e) -> go cs e) go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre go_bind cs (NonRec b e) = diff --git a/compiler/GHC/Data/Graph/Color.hs b/compiler/GHC/Data/Graph/Color.hs --- a/compiler/GHC/Data/Graph/Color.hs +++ b/compiler/GHC/Data/Graph/Color.hs @@ -28,7 +28,7 @@ import GHC.Utils.Panic import Data.Maybe -import Data.List +import Data.List (mapAccumL) -- | Try to color a graph with this set of colors. diff --git a/compiler/GHC/Data/Graph/Ops.hs b/compiler/GHC/Data/Graph/Ops.hs --- a/compiler/GHC/Data/Graph/Ops.hs +++ b/compiler/GHC/Data/Graph/Ops.hs @@ -46,7 +46,7 @@ import GHC.Types.Unique.Set import GHC.Types.Unique.FM -import Data.List hiding (union) +import Data.List (mapAccumL, sortBy) import Data.Maybe -- | Lookup a node from the graph. 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 @@ -30,6 +30,7 @@ import GHC.Driver.Main import GHC.Driver.Make import GHC.Driver.Env +import GHC.Driver.Errors import GHC.Parser import GHC.Parser.Header @@ -96,7 +97,7 @@ (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags}) -- Cribbed from: preprocessFile / GHC.Driver.Pipeline - liftIO $ checkProcessArgsResult dflags unhandled_flags + liftIO $ checkProcessArgsResult unhandled_flags liftIO $ handleFlagWarnings dflags warns -- TODO: Preprocessing not implemented @@ -776,7 +777,6 @@ summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing = do hsc_env <- getSession - let dflags = hsc_dflags hsc_env -- TODO: this looks for modules in the wrong place r <- liftIO $ summariseModule hsc_env emptyModNodeMap -- GHC API recomp not supported @@ -786,7 +786,7 @@ Nothing -- GHC API buffer support not supported [] -- No exclusions case r of - Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found")) + Nothing -> throwOneError (mkPlainErrMsg loc (text "module" <+> ppr modname <+> text "was not found")) Just (Left err) -> throwErrors err Just (Right summary) -> return summary diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fprof-auto-top #-} ------------------------------------------------------------------------------- @@ -93,6 +92,7 @@ import GHC.Driver.Session import GHC.Driver.Backend import GHC.Driver.Env +import GHC.Driver.Errors import GHC.Driver.CodeOutput import GHC.Driver.Config import GHC.Driver.Hooks @@ -183,6 +183,7 @@ import GHC.Types.SafeHaskell import GHC.Types.ForeignStubs import GHC.Types.Var.Env ( emptyTidyEnv ) +import GHC.Types.Error import GHC.Types.Fixity.Env import GHC.Types.CostCentre import GHC.Types.Unique.Supply @@ -320,9 +321,10 @@ -- 2. If there are no error messages, but the second result indicates failure -- there should be warnings in the first result. That is, if the action -- failed, it must have been due to the warnings (i.e., @-Werror@). -ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a +ioMsgMaybe :: IO (Messages ErrDoc, Maybe a) -> Hsc a ioMsgMaybe ioA = do - ((warns,errs), mb_r) <- liftIO ioA + (msgs, mb_r) <- liftIO ioA + let (warns, errs) = partitionMessages msgs logWarnings warns case mb_r of Nothing -> throwErrors errs @@ -330,10 +332,10 @@ -- | like ioMsgMaybe, except that we ignore error messages and return -- 'Nothing' instead. -ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a) +ioMsgMaybe' :: IO (Messages ErrDoc, Maybe a) -> Hsc (Maybe a) ioMsgMaybe' ioA = do - ((warns,_errs), mb_r) <- liftIO $ ioA - logWarnings warns + (msgs, mb_r) <- liftIO $ ioA + logWarnings (getWarningMessages msgs) return mb_r -- ----------------------------------------------------------------------------- @@ -562,7 +564,7 @@ && wopt Opt_WarnMissingSafeHaskellMode dflags) $ logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnMissingSafeHaskellMode) $ - mkPlainWarnMsg dflags (getLoc (hpm_module mod)) $ + mkPlainWarnMsg (getLoc (hpm_module mod)) $ warnMissingSafeHaskellMode tcg_res <- {-# SCC "Typecheck-Rename" #-} @@ -591,13 +593,13 @@ | safeHaskell dflags == Sf_Safe -> return () | otherwise -> (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnSafe) $ - mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $ + mkPlainWarnMsg (warnSafeOnLoc dflags) $ errSafe tcg_res') False | safeHaskell dflags == Sf_Trustworthy && wopt Opt_WarnTrustworthySafe dflags -> (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnTrustworthySafe) $ - mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $ + mkPlainWarnMsg (trustworthyOnLoc dflags) $ errTwthySafe tcg_res') False -> return () return tcg_res' @@ -1119,22 +1121,22 @@ case safeLanguageOn dflags of True -> do -- XSafe: we nuke user written RULES - logWarnings $ warns dflags (tcg_rules tcg_env') + logWarnings $ warns (tcg_rules tcg_env') return tcg_env' { tcg_rules = [] } False -- SafeInferred: user defined RULES, so not safe | safeInferOn dflags && not (null $ tcg_rules tcg_env') - -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env') + -> markUnsafeInfer tcg_env' $ warns (tcg_rules tcg_env') -- Trustworthy OR SafeInferred: with no RULES | otherwise -> return tcg_env' - warns dflags rules = listToBag $ map (warnRules dflags) rules + warns rules = listToBag $ map warnRules rules - warnRules :: DynFlags -> GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg - warnRules dflags (L loc (HsRule { rd_name = n })) = - mkPlainWarnMsg dflags loc $ + warnRules :: GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg ErrDoc + warnRules (L loc (HsRule { rd_name = n })) = + mkPlainWarnMsg loc $ text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ text "User defined rules are disabled under Safe Haskell" @@ -1210,9 +1212,7 @@ cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal cond' v1 v2 | imv_is_safe v1 /= imv_is_safe v2 - = do - dflags <- getDynFlags - throwOneError $ mkPlainErrMsg dflags (imv_span v1) + = throwOneError $ mkPlainErrMsg (imv_span v1) (text "Module" <+> ppr (imv_name v1) <+> (text $ "is imported both as a safe and unsafe import!")) | otherwise @@ -1280,7 +1280,7 @@ iface <- lookup' m case iface of -- can't load iface to check trust! - Nothing -> throwOneError $ mkPlainErrMsg dflags l + Nothing -> throwOneError $ mkPlainErrMsg l $ text "Can't load the interface file for" <+> ppr m <> text ", to check that it can be safely imported" @@ -1314,20 +1314,20 @@ state = hsc_units hsc_env inferredImportWarn = unitBag $ makeIntoWarning (Reason Opt_WarnInferredSafeImports) - $ mkWarnMsg dflags l (pkgQual state) + $ mkWarnMsg l (pkgQual state) $ sep [ text "Importing Safe-Inferred module " <> ppr (moduleName m) <> text " from explicitly Safe module" ] - pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual state) $ + pkgTrustErr = unitBag $ mkErrMsg l (pkgQual state) $ 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." ] - modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual state) $ + modTrustErr = unitBag $ mkErrMsg l (pkgQual state) $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The module itself isn't safe." ] @@ -1366,7 +1366,6 @@ -- | Check the list of packages are trusted. checkPkgTrust :: Set UnitId -> Hsc () checkPkgTrust pkgs = do - dflags <- getDynFlags hsc_env <- getHscEnv let errors = S.foldr go [] pkgs state = hsc_units hsc_env @@ -1374,7 +1373,7 @@ | unitIsTrusted $ unsafeLookupUnitId state pkg = acc | otherwise - = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual state) + = (:acc) $ mkErrMsg noSrcSpan (pkgQual state) $ pprWithUnitState state $ text "The package (" <> ppr pkg @@ -1399,7 +1398,7 @@ when (wopt Opt_WarnUnsafe dflags) (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $ - mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) + mkPlainWarnMsg (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe) -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other @@ -1608,7 +1607,7 @@ $ do (warns,errs,cmm) <- withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ parseCmmFile dflags home_unit filename - return ((fmap pprWarning warns, fmap pprError errs), cmm) + return (mkMessages (fmap pprWarning warns `unionBags` fmap pprError errs), cmm) liftIO $ do dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) let -- Make up a module name to give the NCG. We can't pass bottom here @@ -1925,7 +1924,7 @@ case is of [L _ i] -> return i _ -> liftIO $ throwOneError $ - mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $ + mkPlainErrMsg noSrcSpan $ text "parse error in import declaration" -- | Typecheck an expression (but don't run it) @@ -1951,11 +1950,10 @@ hscParseExpr :: String -> Hsc (LHsExpr GhcPs) hscParseExpr expr = do - hsc_env <- getHscEnv maybe_stmt <- hscParseStmt expr case maybe_stmt of Just (L _ (BodyStmt _ expr _ _)) -> return expr - _ -> throwOneError $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan + _ -> throwOneError $ mkPlainErrMsg noSrcSpan (text "not an expression:" <+> quotes (text expr)) hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs)) 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 @@ -59,6 +59,7 @@ import GHC.Driver.Backend import GHC.Driver.Monad import GHC.Driver.Env +import GHC.Driver.Errors import GHC.Driver.Main import GHC.Parser.Header @@ -119,7 +120,7 @@ import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) import qualified Control.Monad.Catch as MC import Data.IORef -import Data.List +import Data.List (nub, sort, sortBy, partition) import qualified Data.List as List import Data.Foldable (toList) import Data.Maybe @@ -315,7 +316,7 @@ (sep (map ppr missing)) warn = makeIntoWarning (Reason Opt_WarnMissingHomeModules) - (mkPlainErrMsg dflags noSrcSpan msg) + (mkPlainErrMsg noSrcSpan msg) -- | Describes which modules of the module graph need to be loaded. data LoadHowMuch @@ -382,7 +383,7 @@ let warn = makeIntoWarning (Reason Opt_WarnUnusedPackages) - (mkPlainErrMsg dflags noSrcSpan msg) + (mkPlainErrMsg noSrcSpan msg) msg = vcat [ text "The following packages were specified" <+> text "via -package or -package-id flags," , text "but were not needed for compilation:" @@ -2200,15 +2201,15 @@ warnUnnecessarySourceImports sccs = do dflags <- getDynFlags when (wopt Opt_WarnUnusedImports dflags) - (logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs))) - where check dflags ms = + (logWarnings (listToBag (concatMap (check . flattenSCC) sccs))) + where check ms = let mods_in_this_cycle = map ms_mod_name ms in - [ warn dflags i | m <- ms, i <- ms_home_srcimps m, - unLoc i `notElem` mods_in_this_cycle ] + [ warn i | m <- ms, i <- ms_home_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] - warn :: DynFlags -> Located ModuleName -> WarnMsg - warn dflags (L loc mod) = - mkPlainErrMsg dflags loc + warn :: Located ModuleName -> WarnMsg + warn (L loc mod) = + mkPlainErrMsg loc (text "Warning: {-# SOURCE #-} unnecessary in import of " <+> quotes (ppr mod)) @@ -2277,14 +2278,14 @@ if exists || isJust maybe_buf then summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf - else return $ Left $ unitBag $ mkPlainErrMsg dflags noSrcSpan $ + else return $ Left $ unitBag $ mkPlainErrMsg noSrcSpan $ text "can't find file:" <+> text file getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot (L rootLoc modl) obj_allowed maybe_buf excl_mods case maybe_summary of - Nothing -> return $ Left $ moduleNotFoundErr dflags modl + Nothing -> return $ Left $ moduleNotFoundErr modl Just s -> return s rootLoc = mkGeneralSrcSpan (fsLit "") @@ -2301,7 +2302,7 @@ checkDuplicates root_map | allow_dup_roots = return () | null dup_roots = return () - | otherwise = liftIO $ multiRootsErr dflags (emsModSummary <$> head dup_roots) + | otherwise = liftIO $ multiRootsErr (emsModSummary <$> head dup_roots) where dup_roots :: [[ExtendedModSummary]] -- Each at least of length 2 dup_roots = filterOut isSingleton $ map rights $ modNodeMapElems root_map @@ -2320,7 +2321,7 @@ = if isSingleton summs then loop ss done else - do { multiRootsErr dflags (emsModSummary <$> rights summs) + do { multiRootsErr (emsModSummary <$> rights summs) ; return (ModNodeMap Map.empty) } | otherwise @@ -2696,7 +2697,7 @@ -- It might have been deleted since the Finder last found it maybe_t <- modificationTimeIfExists src_fn case maybe_t of - Nothing -> return $ Left $ noHsFileErr dflags loc src_fn + Nothing -> return $ Left $ noHsFileErr loc src_fn Just t -> new_summary location' mod src_fn t new_summary location mod src_fn src_timestamp @@ -2717,7 +2718,7 @@ | otherwise = HsSrcFile when (pi_mod_name /= wanted_mod) $ - throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ + throwE $ unitBag $ mkPlainErrMsg pi_mod_name_loc $ text "File name does not match module name:" $$ text "Saw:" <+> quotes (ppr pi_mod_name) $$ text "Expected:" <+> quotes (ppr wanted_mod) @@ -2729,7 +2730,7 @@ | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) : homeUnitInstantiations home_unit) ]) - in throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ + in throwE $ unitBag $ mkPlainErrMsg pi_mod_name_loc $ text "Unexpected signature:" <+> quotes (ppr pi_mod_name) $$ if gopt Opt_BuildingCabalPackage dflags then parens (text "Try adding" <+> quotes (ppr pi_mod_name) @@ -2885,24 +2886,24 @@ (\_ -> setLogAction (log_action dflags) >> printDeferredDiagnostics) (\_ -> f) -noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> ErrMsg +noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> ErrMsg ErrDoc -- ToDo: we don't have a proper line number for this error noModError hsc_env loc wanted_mod err - = mkPlainErrMsg (hsc_dflags hsc_env) loc $ cannotFindModule hsc_env wanted_mod err + = mkPlainErrMsg loc $ cannotFindModule hsc_env wanted_mod err -noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrorMessages -noHsFileErr dflags loc path - = unitBag $ mkPlainErrMsg dflags loc $ text "Can't find" <+> text path +noHsFileErr :: SrcSpan -> String -> ErrorMessages +noHsFileErr loc path + = unitBag $ mkPlainErrMsg loc $ text "Can't find" <+> text path -moduleNotFoundErr :: DynFlags -> ModuleName -> ErrorMessages -moduleNotFoundErr dflags mod - = unitBag $ mkPlainErrMsg dflags noSrcSpan $ +moduleNotFoundErr :: ModuleName -> ErrorMessages +moduleNotFoundErr mod + = unitBag $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "cannot be found locally" -multiRootsErr :: DynFlags -> [ModSummary] -> IO () -multiRootsErr _ [] = panic "multiRootsErr" -multiRootsErr dflags summs@(summ1:_) - = throwOneError $ mkPlainErrMsg dflags noSrcSpan $ +multiRootsErr :: [ModSummary] -> IO () +multiRootsErr [] = panic "multiRootsErr" +multiRootsErr summs@(summ1:_) + = throwOneError $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "is defined in multiple files:" <+> sep (map text files) 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 @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- @@ -30,7 +29,7 @@ import GHC.Utils.Panic import GHC.Types.SourceError import GHC.Types.SrcLoc -import Data.List +import Data.List (partition) import GHC.Data.FastString import GHC.SysTools.FileCleanup @@ -48,7 +47,7 @@ import System.FilePath import System.IO import System.IO.Error ( isEOFError ) -import Control.Monad ( when ) +import Control.Monad ( when, forM_ ) import Data.Maybe ( isJust ) import Data.IORef import qualified Data.Set as Set @@ -242,6 +241,16 @@ -- Something like A.o : A.hs ; writeDependency root hdl obj_files src_file + -- add dependency between objects and their corresponding .hi-boot + -- files if the module has a corresponding .hs-boot file (#14482) + ; when (isBootSummary node == IsBoot) $ do + let hi_boot = msHiFilePath node + let obj = removeBootSuffix (msObjFilePath node) + forM_ extra_suffixes $ \suff -> do + let way_obj = insertSuffixes obj [suff] + let way_hi_boot = insertSuffixes hi_boot [suff] + mapM_ (writeDependency root hdl way_obj) way_hi_boot + -- Emit a dependency for each CPP import ; when (depIncludeCppDeps dflags) $ do -- CPP deps are descovered in the module parsing phase by parsing @@ -288,9 +297,8 @@ -> return Nothing fail -> - let dflags = hsc_dflags hsc_env - in throwOneError $ mkPlainErrMsg dflags srcloc $ - cannotFindModule hsc_env imp fail + throwOneError $ mkPlainErrMsg srcloc $ + cannotFindModule hsc_env imp fail } ----------------------------- 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 @@ -46,6 +46,7 @@ import GHC.Driver.Main import GHC.Driver.Env hiding ( Hsc ) +import GHC.Driver.Errors import GHC.Driver.Pipeline.Monad import GHC.Driver.Config import GHC.Driver.Phases @@ -149,7 +150,7 @@ where srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1 handler (ProgramError msg) = return $ Left $ unitBag $ - mkPlainErrMsg (hsc_dflags hsc_env) srcspan $ text msg + mkPlainErrMsg srcspan $ text msg handler ex = throwGhcExceptionIO ex -- --------------------------------------------------------------------------- @@ -895,22 +896,33 @@ case phase of HscOut {} -> 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 - -- if Opt_BuildDynamicToo is set and if the platform - -- supports it, we first run the backend to generate - -- the dynamic objects and then re-run it to generate - -- the non-dynamic ones. - 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 - noDynToo + -- 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 @@ -1127,7 +1139,7 @@ (dflags1, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags0 src_opts setDynFlags dflags1 - liftIO $ checkProcessArgsResult dflags1 unhandled_flags + liftIO $ checkProcessArgsResult unhandled_flags if not (xopt LangExt.Cpp dflags1) then do -- we have to be careful to emit warnings only once. @@ -1148,7 +1160,7 @@ src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn (dflags2, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags0 src_opts - liftIO $ checkProcessArgsResult dflags2 unhandled_flags + liftIO $ checkProcessArgsResult unhandled_flags unless (gopt Opt_Pp dflags2) $ liftIO $ handleFlagWarnings dflags2 warns -- the HsPp pass below will emit warnings @@ -1182,7 +1194,7 @@ (dflags1, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags src_opts setDynFlags dflags1 - liftIO $ checkProcessArgsResult dflags1 unhandled_flags + liftIO $ checkProcessArgsResult unhandled_flags liftIO $ handleFlagWarnings dflags1 warns return (RealPhase (Hsc sf), output_fn) diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -86,7 +86,7 @@ import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModIface -import Data.List +import Data.List (partition) import Data.IORef import Control.Monad( when ) import GHC.Driver.Plugins ( LoadedPlugin(..) ) @@ -100,7 +100,7 @@ -} -- | Main entry point to the desugarer. -deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts) +deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages ErrDoc, Maybe ModGuts) -- Can modify PCS by faulting in more declarations deSugar hsc_env @@ -283,7 +283,7 @@ and Rec the rest. -} -deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages, Maybe CoreExpr) +deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages ErrDoc, Maybe CoreExpr) deSugarExpr hsc_env tc_expr = do { let dflags = hsc_dflags hsc_env diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -21,11 +21,8 @@ import GHC.HsToCore.Utils import GHC.HsToCore.Monad -import GHC.Hs hiding (collectPatBinders, collectPatsBinders, - collectLStmtsBinders, collectLStmtBinders, - collectStmtBinders ) +import GHC.Hs import GHC.Tc.Utils.Zonk -import qualified GHC.Hs.Utils as HsUtils -- NB: The desugarer, which straddles the source and Core worlds, sometimes -- needs to see source types (newtypes etc), and sometimes not @@ -55,7 +52,7 @@ import GHC.Types.Var.Set import GHC.Types.SrcLoc import GHC.Data.List.SetOps( assocMaybe ) -import Data.List +import Data.List (mapAccumL) import GHC.Utils.Misc import GHC.Types.Unique.DSet @@ -207,7 +204,7 @@ coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr coreCasePair scrut_var var1 var2 body = Case (Var scrut_var) scrut_var (exprType body) - [(DataAlt (tupleDataCon Boxed 2), [var1, var2], body)] + [Alt (DataAlt (tupleDataCon Boxed 2)) [var1, var2] body] mkCorePairTy :: Type -> Type -> Type mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2] @@ -320,7 +317,7 @@ -> DsM CoreExpr dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do (meth_binds, meth_ids) <- mkCmdEnv ids - let locals = mkVarSet (collectPatBinders pat) + let locals = mkVarSet (collectPatBinders CollWithDictBinders pat) (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals unitTy cmd_ty cmd let env_ty = mkBigCoreVarTupTy env_ids @@ -609,7 +606,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body) env_ids = do let - defined_vars = mkVarSet (collectLocalBinders binds) + defined_vars = mkVarSet (collectLocalBinders CollWithDictBinders binds) local_vars' = defined_vars `unionVarSet` local_vars (core_body, _free_vars, env_ids') @@ -746,7 +743,7 @@ -> DsM (CoreExpr, -- desugared expression DIdSet) -- subset of local vars that occur free dsCmdLam ids local_vars stack_ty res_ty pats body env_ids = do - let pat_vars = mkVarSet (collectPatsBinders pats) + let pat_vars = mkVarSet (collectPatsBinders CollWithDictBinders pats) let local_vars' = pat_vars `unionVarSet` local_vars (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty (core_body, free_vars, env_ids') @@ -813,7 +810,7 @@ env_ids') dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do - let bound_vars = mkVarSet (collectLStmtBinders stmt) + let bound_vars = mkVarSet (collectLStmtBinders CollWithDictBinders stmt) let local_vars' = bound_vars `unionVarSet` local_vars (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts) (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids @@ -889,7 +886,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do let pat_ty = hsLPatType pat (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd - let pat_vars = mkVarSet (collectPatBinders pat) + let pat_vars = mkVarSet (collectPatBinders CollWithDictBinders pat) let env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids env_ty2 = mkBigCoreVarTupTy env_ids2 @@ -1126,7 +1123,7 @@ = dsCmdLStmt ids local_vars out_ids stmt env_ids dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do - let bound_vars = mkVarSet (collectLStmtBinders stmt) + let bound_vars = mkVarSet (collectLStmtBinders CollWithDictBinders stmt) let local_vars' = bound_vars `unionVarSet` local_vars (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids @@ -1161,12 +1158,12 @@ leavesMatch (L _ (Match { m_pats = pats , m_grhss = GRHSs _ grhss (L _ binds) })) = let - defined_vars = mkVarSet (collectPatsBinders pats) + defined_vars = mkVarSet (collectPatsBinders CollWithDictBinders pats) `unionVarSet` - mkVarSet (collectLocalBinders binds) + mkVarSet (collectLocalBinders CollWithDictBinders binds) in [(body, - mkVarSet (collectLStmtsBinders stmts) + mkVarSet (collectLStmtsBinders CollWithDictBinders stmts) `unionVarSet` defined_vars) | L _ (GRHS _ stmts body) <- grhss] @@ -1205,80 +1202,3 @@ fold_pairs [] = [] fold_pairs [x] = [x] fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs - -{- -Note [Dictionary binders in ConPatOut] See also same Note in GHC.Hs.Utils -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The following functions to collect value variables from patterns are -copied from GHC.Hs.Utils, with one change: we also collect the dictionary -bindings (cpt_binds) from ConPatOut. We need them for cases like - -h :: Arrow a => Int -> a (Int,Int) Int -h x = proc (y,z) -> case compare x y of - GT -> returnA -< z+x - -The type checker turns the case into - - case compare x y of - GT { p77 = plusInt } -> returnA -< p77 z x - -Here p77 is a local binding for the (+) operation. - -See comments in GHC.Hs.Utils for why the other version does not include -these bindings. --} - -collectPatBinders :: LPat GhcTc -> [Id] -collectPatBinders pat = collectl pat [] - -collectPatsBinders :: [LPat GhcTc] -> [Id] -collectPatsBinders pats = foldr collectl [] pats - ---------------------- -collectl :: LPat GhcTc -> [Id] -> [Id] --- See Note [Dictionary binders in ConPatOut] -collectl (L _ pat) bndrs - = go pat - where - go (VarPat _ (L _ var)) = var : bndrs - go (WildPat _) = bndrs - go (LazyPat _ pat) = collectl pat bndrs - go (BangPat _ pat) = collectl pat bndrs - go (AsPat _ (L _ a) pat) = a : collectl pat bndrs - go (ParPat _ pat) = collectl pat bndrs - - go (ListPat _ pats) = foldr collectl bndrs pats - go (TuplePat _ pats _) = foldr collectl bndrs pats - go (SumPat _ pat _ _) = collectl pat bndrs - - go (ConPat { pat_args = ps - , pat_con_ext = ConPatTc { cpt_binds = ds }}) = - collectEvBinders ds - ++ foldr collectl bndrs (hsConPatArgs ps) - go (LitPat _ _) = bndrs - go (NPat {}) = bndrs - go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs - - go (SigPat _ pat _) = collectl pat bndrs - go (XPat (CoPat _ pat _)) = collectl (noLoc pat) bndrs - go (ViewPat _ _ pat) = collectl pat bndrs - go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p) - -collectEvBinders :: TcEvBinds -> [Id] -collectEvBinders (EvBinds bs) = foldr add_ev_bndr [] bs -collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders" - -add_ev_bndr :: EvBind -> [Id] -> [Id] -add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs - | otherwise = bs - -- A worry: what about coercion variable binders?? - -collectLStmtsBinders :: [LStmt GhcTc body] -> [Id] -collectLStmtsBinders = concatMap collectLStmtBinders - -collectLStmtBinders :: LStmt GhcTc body -> [Id] -collectLStmtBinders = collectStmtBinders . unLoc - -collectStmtBinders :: Stmt GhcTc body -> [Id] -collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids -collectStmtBinders stmt = HsUtils.collectStmtBinders stmt diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -929,7 +929,7 @@ where (bs, body') = split_lets body -- handle "unlifted lets" too, needed for "map/coerce" - split_lets (Case r d _ [(DEFAULT, _, body)]) + split_lets (Case r d _ [Alt DEFAULT _ body]) | isCoVar d = ((d,r):bs, body') where (bs, body') = split_lets body diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -27,7 +27,6 @@ import GHC.Cmm.CLabel import GHC.Core.Type -import GHC.Core.ConLike import GHC.Core import GHC.Core.TyCon @@ -52,7 +51,7 @@ import GHC.Types.CostCentre.State import Control.Monad -import Data.List +import Data.List (isSuffixOf, intersperse) import Data.Array import Data.Time import System.Directory @@ -370,7 +369,7 @@ patvar_tickss <- case simplePatId of Just{} -> return initial_patvar_tickss Nothing -> do - let patvars = map getOccString (collectPatBinders lhs) + let patvars = map getOccString (collectPatBinders CollNoDictBinders lhs) patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars return (zipWith mbCons patvar_ticks @@ -514,8 +513,11 @@ addTickHsExpr e@(HsUnboundVar {}) = return e addTickHsExpr e@(HsRecFld _ (Ambiguous id _)) = do freeVar id; return e addTickHsExpr e@(HsRecFld _ (Unambiguous id _)) = do freeVar id; return e -addTickHsExpr e@(HsConLikeOut _ con) - | Just id <- conLikeWrapId_maybe con = do freeVar id; return e + +addTickHsExpr e@(HsConLikeOut {}) = return e + -- We used to do a freeVar on a pat-syn builder, but actually + -- such builders are never in the inScope env, which + -- doesn't include top level bindings addTickHsExpr e@(HsIPVar {}) = return e addTickHsExpr e@(HsOverLit {}) = return e addTickHsExpr e@(HsOverLabel{}) = return e @@ -572,7 +574,7 @@ ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts ; return $ HsMultiIf ty alts' } addTickHsExpr (HsLet x (L l binds) e) = - bindLocals (collectLocalBinders binds) $ + bindLocals (collectLocalBinders CollNoDictBinders binds) $ liftM2 (HsLet x . L l) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsExprLetBody e) @@ -642,9 +644,6 @@ liftM (XExpr . ExpansionExpr . HsExpanded a) $ (addTickHsExpr b) --- Others should never happen in expression content. -addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) - addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc) addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e ; return (L l (Present x e')) } @@ -662,7 +661,7 @@ -> TM (Match GhcTc (LHsExpr GhcTc)) addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats , m_grhss = gRHSs }) = - bindLocals (collectPatsBinders pats) $ do + bindLocals (collectPatsBinders CollNoDictBinders pats) $ do gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs return $ match { m_grhss = gRHSs' } @@ -674,7 +673,7 @@ guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded return $ GRHSs x guarded' (L l local_binds') where - binders = collectLocalBinders local_binds + binders = collectLocalBinders CollNoDictBinders local_binds addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc) -> TM (GRHS GhcTc (LHsExpr GhcTc)) @@ -704,7 +703,7 @@ addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a -> TM ([ExprLStmt GhcTc], a) addTickLStmts' isGuard lstmts res - = bindLocals (collectLStmtsBinders lstmts) $ + = bindLocals (collectLStmtsBinders CollNoDictBinders lstmts) $ do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts ; a <- res ; return (lstmts', a) } @@ -878,7 +877,7 @@ (addTickLHsCmd c2) (addTickLHsCmd c3) addTickHsCmd (HsCmdLet x (L l binds) c) = - bindLocals (collectLocalBinders binds) $ + bindLocals (collectLocalBinders CollNoDictBinders binds) $ liftM2 (HsCmdLet x . L l) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsCmd c) @@ -915,7 +914,7 @@ addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) = - bindLocals (collectPatsBinders pats) $ do + bindLocals (collectPatsBinders CollNoDictBinders pats) $ do gRHSs' <- addTickCmdGRHSs gRHSs return $ match { m_grhss = gRHSs' } @@ -926,7 +925,7 @@ guarded' <- mapM (liftL addTickCmdGRHS) guarded return $ GRHSs x guarded' (L l local_binds') where - binders = collectLocalBinders local_binds + binders = collectLocalBinders CollNoDictBinders local_binds addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)) -- The *guards* are *not* Cmds, although the body is @@ -950,7 +949,7 @@ a <- res return (lstmts', a) where - binders = collectLStmtsBinders lstmts + binders = collectLStmtsBinders CollNoDictBinders lstmts addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc)) addTickCmdStmt (BindStmt x pat c) = diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs --- a/compiler/GHC/HsToCore/Docs.hs +++ b/compiler/GHC/HsToCore/Docs.hs @@ -17,6 +17,7 @@ import GHC.Hs.Binds import GHC.Hs.Doc import GHC.Hs.Decls +import Language.Haskell.Syntax.Extension import GHC.Hs.Extension import GHC.Hs.Type import GHC.Hs.Utils @@ -118,7 +119,7 @@ getMainDeclBinder :: CollectPass (GhcPass p) => HsDecl (GhcPass p) -> [IdP (GhcPass p)] getMainDeclBinder (TyClD _ d) = [tcdName d] getMainDeclBinder (ValD _ d) = - case collectHsBindBinders d of + case collectHsBindBinders CollNoDictBinders d of [] -> [] (name:_) -> [name] getMainDeclBinder (SigD _ d) = sigNameNoLoc d 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 @@ -465,11 +465,7 @@ -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make dsExpr (ExplicitSum types alt arity expr) - = dsWhenNoErrs (dsLExprNoLP expr) - (\core_expr -> mkCoreConApps (sumDataCon alt arity) - (map (Type . getRuntimeRep) types ++ - map Type types ++ - [core_expr]) ) + = dsWhenNoErrs (dsLExprNoLP expr) (mkCoreUbxSum arity alt types) dsExpr (HsPragE _ prag expr) = ds_prag_expr prag expr @@ -584,9 +580,9 @@ constructor @C@, setting all of @C@'s fields to bottom. -} -dsExpr (RecordCon { rcon_flds = rbinds - , rcon_ext = RecordConTc { rcon_con_expr = con_expr - , rcon_con_like = con_like }}) +dsExpr (RecordCon { rcon_con = L _ con_like + , rcon_flds = rbinds + , rcon_ext = con_expr }) = do { con_expr' <- dsExpr con_expr ; let (arg_tys, _) = tcSplitFunTys (exprType con_expr') @@ -1159,11 +1155,15 @@ dsConLike :: ConLike -> DsM CoreExpr dsConLike (RealDataCon dc) = dsHsVar (dataConWrapId dc) -dsConLike (PatSynCon ps) = return $ case patSynBuilder ps of - Just (id, add_void) - | add_void -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId) - | otherwise -> Var id - _ -> pprPanic "dsConLike" (ppr ps) +dsConLike (PatSynCon ps) + | Just (builder_name, _, add_void) <- patSynBuilder ps + = do { builder_id <- dsLookupGlobalId builder_name + ; return (if add_void + then mkCoreApp (text "dsConLike" <+> ppr ps) + (Var builder_id) (Var voidPrimId) + else Var builder_id) } + | otherwise + = pprPanic "dsConLike" (ppr ps) {- ************************************************************************ diff --git a/compiler/GHC/HsToCore/Expr.hs-boot b/compiler/GHC/HsToCore/Expr.hs-boot --- a/compiler/GHC/HsToCore/Expr.hs-boot +++ b/compiler/GHC/HsToCore/Expr.hs-boot @@ -2,7 +2,7 @@ import GHC.Hs ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr ) import GHC.HsToCore.Monad ( DsM ) import GHC.Core ( CoreExpr ) -import GHC.Hs.Extension ( GhcTc) +import GHC.Hs.Extension ( GhcTc) dsExpr :: HsExpr GhcTc -> DsM CoreExpr dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr 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 @@ -37,7 +37,6 @@ import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.Multiplicity -import GHC.Types.Id ( Id ) import GHC.Core.Coercion import GHC.Builtin.Types.Prim import GHC.Core.TyCon @@ -159,7 +158,7 @@ \ body -> Case (mkIfThenElse arg (mkIntLit platform 1) (mkIntLit platform 0)) prim_arg (exprType body) - [(DEFAULT,[],body)]) + [Alt DEFAULT [] body]) -- Data types with a single constructor, which has a single, primitive-typed arg -- This deals with Int, Float etc; also Ptr, ForeignPtr @@ -169,7 +168,7 @@ do case_bndr <- newSysLocalDs Many arg_ty prim_arg <- newSysLocalDs Many data_con_arg_ty1 return (Var prim_arg, - \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)] + \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) [prim_arg] body] ) -- Byte-arrays, both mutable and otherwise; hack warning @@ -184,7 +183,7 @@ = do case_bndr <- newSysLocalDs Many arg_ty vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs (map unrestricted data_con_arg_tys) return (Var arr_cts_var, - \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)] + \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) vars body] ) | otherwise @@ -275,7 +274,7 @@ mk_alt :: (Expr Var -> [Expr Var] -> Expr Var) -> (Maybe Type, Expr Var -> Expr Var) - -> DsM (Type, (AltCon, [Id], Expr Var)) + -> DsM (Type, CoreAlt) mk_alt return_result (Nothing, wrap_result) = do -- The ccall returns () state_id <- newSysLocalDs Many realWorldStatePrimTy @@ -284,7 +283,7 @@ [wrap_result (panic "boxResult")] ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy] - the_alt = (DataAlt (tupleDataCon Unboxed 1), [state_id], the_rhs) + the_alt = Alt (DataAlt (tupleDataCon Unboxed 1)) [state_id] the_rhs return (ccall_res_ty, the_alt) @@ -297,7 +296,7 @@ ; let the_rhs = return_result (Var state_id) [wrap_result (Var result_id)] ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty] - the_alt = (DataAlt (tupleDataCon Unboxed 2), [state_id, result_id], the_rhs) + the_alt = Alt (DataAlt (tupleDataCon Unboxed 2)) [state_id, result_id] the_rhs ; return (ccall_res_ty, the_alt) } @@ -332,8 +331,8 @@ ; let platform = targetPlatform dflags ; let marshal_bool e = mkWildCase e (unrestricted intPrimTy) boolTy - [ (DEFAULT ,[],Var trueDataConId ) - , (LitAlt (mkLitInt platform 0),[],Var falseDataConId)] + [ Alt DEFAULT [] (Var trueDataConId ) + , Alt (LitAlt (mkLitInt platform 0)) [] (Var falseDataConId)] ; return (Just intPrimTy, marshal_bool) } -- Newtypes diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -62,7 +62,7 @@ import GHC.Utils.Encoding import Data.Maybe -import Data.List +import Data.List (unzip4, nub) {- Desugaring of @foreign@ declarations is naturally split up into @@ -715,7 +715,10 @@ -- See Note [Tracking foreign exports] in rts/ForeignExports.c vcat [ text "static struct ForeignExportsList" <+> list_symbol <+> equals - <+> braces (text ".exports = " <+> export_list) <> semi + <+> braces ( + text ".exports = " <+> export_list <> comma <+> + text ".n_entries = " <+> ppr (length hs_fns)) + <> semi , text "static void " <> ctor_symbol <> text "(void)" <+> text " __attribute__((constructor));" , text "static void " <> ctor_symbol <> text "()" diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs --- a/compiler/GHC/HsToCore/ListComp.hs +++ b/compiler/GHC/HsToCore/ListComp.hs @@ -295,8 +295,8 @@ let rhs = Lam u1 $ Case (Var u1) u1 res_ty - [(DataAlt nilDataCon, [], core_list2), - (DataAlt consDataCon, [u2, u3], core_match)] + [Alt (DataAlt nilDataCon) [] core_list2 + ,Alt (DataAlt consDataCon) [u2, u3] core_match] -- Increasing order of tag return (Let (Rec [(h, rhs)]) letrec_body) @@ -423,8 +423,8 @@ mk_case (as, a', as') rest = Case (Var as) as elt_tuple_list_ty - [(DataAlt nilDataCon, [], mkNilExpr elt_tuple_ty), - (DataAlt consDataCon, [a', as'], rest)] + [ Alt (DataAlt nilDataCon) [] (mkNilExpr elt_tuple_ty) + , Alt (DataAlt consDataCon) [a', as'] rest] -- Increasing order of tag diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -259,7 +259,7 @@ = return [MR_Fallible mk_seq] where mk_seq fail = return $ mkWildCase (Var var) (idScaledType var) res_ty - [(DEFAULT, [], fail)] + [Alt DEFAULT [] fail] matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) -- Real true variables, just like in matchVar, SLPJ p 94 @@ -453,7 +453,7 @@ -- This is a convenient place to check for unlifted types under a lazy pattern. -- Doing this check during type-checking is unsatisfactory because we may -- not fully know the zonked types yet. We sure do here. - = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat) + = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat) ; unless (null unlifted_bndrs) $ putSrcSpanDs (getLoc pat) $ errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$ diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -97,8 +97,8 @@ HsCharPrim _ c -> return (Lit (LitChar c)) HsIntPrim _ i -> return (Lit (mkLitIntWrap platform i)) HsWordPrim _ w -> return (Lit (mkLitWordWrap platform w)) - HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap platform i)) - HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap platform w)) + HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap i)) + HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap w)) HsFloatPrim _ f -> return (Lit (LitFloat (fl_value f))) HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d))) HsChar _ c -> return (mkCharExpr c) @@ -514,8 +514,8 @@ -- HsLit does not. hsLitKey platform (HsIntPrim _ i) = mkLitIntWrap platform i hsLitKey platform (HsWordPrim _ w) = mkLitWordWrap platform w -hsLitKey platform (HsInt64Prim _ i) = mkLitInt64Wrap platform i -hsLitKey platform (HsWord64Prim _ w) = mkLitWord64Wrap platform w +hsLitKey _ (HsInt64Prim _ i) = mkLitInt64Wrap i +hsLitKey _ (HsWord64Prim _ w) = mkLitWord64Wrap w hsLitKey _ (HsCharPrim _ c) = mkLitChar c hsLitKey _ (HsFloatPrim _ f) = mkLitFloat (fl_value f) hsLitKey _ (HsDoublePrim _ d) = mkLitDouble (fl_value d) 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 @@ -83,7 +83,6 @@ import GHC.Builtin.Names -import GHC.Data.Bag import GHC.Data.FastString import GHC.Unit.Env @@ -104,9 +103,9 @@ import GHC.Types.Literal ( mkLitString ) import GHC.Types.CostCentre.State import GHC.Types.TyThing +import GHC.Types.Error import GHC.Utils.Outputable -import GHC.Utils.Error import GHC.Utils.Panic import Data.IORef @@ -214,7 +213,7 @@ } -- | Run a 'DsM' action inside the 'IO' monad. -initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a) +initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages ErrDoc, Maybe a) initDs hsc_env tcg_env thing_inside = do { msg_var <- newIORef emptyMessages ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env @@ -223,7 +222,7 @@ -- | Build a set of desugarer environments derived from a 'TcGblEnv'. mkDsEnvsFromTcGbl :: MonadIO m - => HscEnv -> IORef Messages -> TcGblEnv + => HscEnv -> IORef (Messages ErrDoc) -> TcGblEnv -> m (DsGblEnv, DsLclEnv) mkDsEnvsFromTcGbl hsc_env msg_var tcg_env = do { cc_st_var <- liftIO $ newIORef newCostCentreState @@ -240,37 +239,38 @@ msg_var cc_st_var complete_matches } -runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a) +runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages ErrDoc, Maybe a) runDs hsc_env (ds_gbl, ds_lcl) thing_inside = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl (tryM thing_inside) ; msgs <- readIORef (ds_msgs ds_gbl) ; let final_res - | errorsFound dflags msgs = Nothing - | Right r <- res = Just r - | otherwise = panic "initDs" + | errorsFound msgs = Nothing + | Right r <- res = Just r + | otherwise = panic "initDs" ; return (msgs, final_res) } - where dflags = hsc_dflags hsc_env -- | Run a 'DsM' action in the context of an existing 'ModGuts' -initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a) -initDsWithModGuts hsc_env guts thing_inside +initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages ErrDoc, Maybe a) +initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds + , mg_tcs = tycons, mg_fam_insts = fam_insts + , mg_patsyns = patsyns, mg_rdr_env = rdr_env + , mg_fam_inst_env = fam_inst_env + , mg_complete_matches = local_complete_matches + }) thing_inside = do { cc_st_var <- newIORef newCostCentreState ; msg_var <- newIORef emptyMessages ; eps <- liftIO $ hscEPS hsc_env ; let unit_env = hsc_unit_env hsc_env - type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts) - rdr_env = mg_rdr_env guts - fam_inst_env = mg_fam_inst_env guts - this_mod = mg_module guts + type_env = typeEnvFromEntities ids tycons patsyns fam_insts complete_matches = hptCompleteSigs hsc_env -- from the home package - ++ mg_complete_matches guts -- from the current module + ++ local_complete_matches -- from the current module ++ eps_complete_matches eps -- from imports bindsToIds (NonRec v _) = [v] bindsToIds (Rec binds) = map fst binds - ids = concatMap bindsToIds (mg_binds guts) + ids = concatMap bindsToIds binds envs = mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env msg_var cc_st_var @@ -278,7 +278,7 @@ ; runDs hsc_env envs thing_inside } -initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a) +initTcDsForSolver :: TcM a -> DsM (Messages ErrDoc, Maybe a) -- Spin up a TcM context so that we can run the constraint solver -- Returns any error messages generated by the constraint solver -- and (Just res) if no error happened; Nothing if an error happened @@ -309,7 +309,7 @@ thing_inside } mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv - -> IORef Messages -> IORef CostCentreState -> CompleteMatches + -> IORef (Messages ErrDoc) -> IORef CostCentreState -> CompleteMatches -> (DsGblEnv, DsLclEnv) mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var complete_matches @@ -453,10 +453,9 @@ warnDs reason warn = do { env <- getGblEnv ; loc <- getSrcSpanDs - ; dflags <- getDynFlags ; let msg = makeIntoWarning reason $ - mkWarnMsg dflags loc (ds_unqual env) warn - ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) } + mkWarnMsg loc (ds_unqual env) warn + ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } -- | Emit a warning only if the correct WarnReason is set in the DynFlags warnIfSetDs :: WarningFlag -> SDoc -> DsM () @@ -468,9 +467,8 @@ errDs err = do { env <- getGblEnv ; loc <- getSrcSpanDs - ; dflags <- getDynFlags - ; let msg = mkErrMsg dflags loc (ds_unqual env) err - ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) } + ; let msg = mkErrMsg loc (ds_unqual env) err + ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } -- | Issue an error, but return the expression for (), so that we can continue -- reporting errors. @@ -508,14 +506,13 @@ thing_inside -- Propagate errors - ; msgs@(warns, errs) <- readMutVar errs_var - ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs)) + ; msgs <- readMutVar errs_var + ; updMutVar (ds_msgs env) (unionMessages msgs) -- And return ; case mb_res of Left _ -> failM - Right res -> do { dflags <- getDynFlags - ; let errs_found = errorsFound dflags msgs + Right res -> do { let errs_found = errorsFound msgs ; return (res, not errs_found) } } mkPrintUnqualifiedDs :: DsM PrintUnqualified diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs --- a/compiler/GHC/HsToCore/Pmc/Solver.hs +++ b/compiler/GHC/HsToCore/Pmc/Solver.hs @@ -48,6 +48,7 @@ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Data.Bag +import GHC.Types.Error import GHC.Types.Unique.Set import GHC.Types.Unique.DSet import GHC.Types.Unique.SDFM @@ -86,8 +87,10 @@ import Control.Monad (foldM, forM, guard, mzero, when) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State.Strict +import Data.Coerce import Data.Either (partitionEithers) import Data.Foldable (foldlM, minimumBy, toList) +import Data.Monoid (Any(..)) import Data.List (sortBy, find) import qualified Data.List.NonEmpty as NE import Data.Ord (comparing) @@ -120,9 +123,19 @@ -- See Note [Implementation of COMPLETE pragmas] --- | Update the COMPLETE sets of 'ResidualCompleteMatches'. -updRcm :: (CompleteMatch -> CompleteMatch) -> ResidualCompleteMatches -> ResidualCompleteMatches -updRcm f (RCM vanilla pragmas) = RCM (f <$> vanilla) (fmap f <$> pragmas) +-- | Update the COMPLETE sets of 'ResidualCompleteMatches', or 'Nothing' +-- if there was no change as per the update function. +updRcm :: (CompleteMatch -> (Bool, CompleteMatch)) + -> ResidualCompleteMatches -> (Maybe ResidualCompleteMatches) +updRcm f (RCM vanilla pragmas) + | not any_change = Nothing + | otherwise = Just (RCM vanilla' pragmas') + where + f' :: CompleteMatch -> (Any, CompleteMatch) + f' = coerce f + (chgd, vanilla') = traverse f' vanilla + (chgds, pragmas') = traverse (traverse f') pragmas + any_change = getAny $ chgd `mappend` chgds -- | A pseudo-'CompleteMatch' for the vanilla complete set of the given data -- 'TyCon'. @@ -160,10 +173,17 @@ add_tc_match rcm = rcm{rcm_vanilla = rcm_vanilla rcm <|> vanillaCompleteMatchTC tc} -markMatched :: ConLike -> ResidualCompleteMatches -> DsM ResidualCompleteMatches -markMatched cl rcm = do +markMatched :: PmAltCon -> ResidualCompleteMatches -> DsM (Maybe ResidualCompleteMatches) +-- Nothing means the PmAltCon didn't occur in any COMPLETE set. +-- See Note [Shortcutting the inhabitation test] for how this is useful for +-- performance on T17836. +markMatched (PmAltLit _) _ = pure Nothing -- lits are never part of a COMPLETE set +markMatched (PmAltConLike cl) rcm = do rcm' <- addConLikeMatches cl rcm - pure $ updRcm (flip delOneFromUniqDSet cl) rcm' + let go cm = case lookupUniqDSet cm cl of + Nothing -> (False, cm) + Just _ -> (True, delOneFromUniqDSet cm cl) + pure $ updRcm go rcm' {- Note [Implementation of COMPLETE pragmas] @@ -660,11 +680,11 @@ | otherwise = do { evs <- traverse nameTyCt cts ; tracePm "tyOracle" (ppr cts $$ ppr inert) - ; ((_warns, errs), res) <- initTcDsForSolver $ tcCheckSatisfiability inert evs + ; (msgs, res) <- initTcDsForSolver $ tcCheckSatisfiability inert evs ; case res of -- return the new inert set and increment the sequence number n Just mb_new_inert -> return (TySt (n+1) <$> mb_new_inert) - Nothing -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc errs) } + Nothing -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc (getErrorMessages msgs)) } -- | Allocates a fresh 'EvVar' name for 'PredTy's. nameTyCt :: PredType -> DsM EvVar @@ -747,6 +767,10 @@ Just x -> markDirty x nabla' Nothing -> nabla' where + -- | Update `x`'s 'VarInfo' entry. Fail ('MaybeT') if contradiction, + -- otherwise return updated entry and `Just x'` if `x` should be marked dirty, + -- where `x'` is the representative of `x`. + go :: VarInfo -> MaybeT DsM (Maybe Id, VarInfo) go vi@(VI x' pos neg _ rcm) = do -- 1. Bail out quickly when nalt contradicts a solution let contradicts nalt sol = eqPmAltCon (paca_con sol) nalt == Equal @@ -762,13 +786,16 @@ MASSERT( isPmAltConMatchStrict nalt ) let vi' = vi{ vi_neg = neg', vi_bot = IsNotBot } -- 3. Make sure there's at least one other possible constructor - case nalt of - PmAltConLike cl -> do - -- Mark dirty to force a delayed inhabitation test - rcm' <- lift (markMatched cl rcm) - pure (Just x', vi'{ vi_rcm = rcm' }) - _ -> - pure (Nothing, vi') + mb_rcm' <- lift (markMatched nalt rcm) + pure $ case mb_rcm' of + -- If nalt could be removed from a COMPLETE set, we'll get back Just and + -- have to mark x dirty, by returning Just x'. + Just rcm' -> (Just x', vi'{ vi_rcm = rcm' }) + -- Otherwise, nalt didn't occur in any residual COMPLETE set and we + -- don't have to mark it dirty. So we return Nothing, which in the case + -- above would have compromised precision. + -- See Note [Shortcutting the inhabitation test], grep for T17836. + Nothing -> (Nothing, vi') hasRequiredTheta :: PmAltCon -> Bool hasRequiredTheta (PmAltConLike cl) = notNull req_theta @@ -1226,25 +1253,20 @@ test_one vi = lift (varNeedsTesting old_ty_st nabla vi) >>= \case True -> do - -- tracPm "test_one" (ppr vi) + -- lift $ tracePm "test_one" (ppr vi) -- No solution yet and needs testing -- We have to test with a Nabla where all dirty bits are cleared instantiate (fuel-1) nabla_not_dirty vi _ -> pure vi -- | Checks whether the given 'VarInfo' needs to be tested for inhabitants. --- --- 1. If it already has a solution, we don't have to test. --- 2. If it's marked dirty because of new negative term constraints, we have --- to test. --- 3. Otherwise, if the type state didn't change, we don't need to test. --- 4. If the type state changed, we compare normalised source types. No need --- to test if unchanged. +-- Returns `False` when we can skip the inhabitation test, presuming it would +-- say "yes" anyway. See Note [Shortcutting the inhabitation test]. varNeedsTesting :: TyState -> Nabla -> VarInfo -> DsM Bool -varNeedsTesting _ _ vi - | notNull (vi_pos vi) = pure False varNeedsTesting _ MkNabla{nabla_tm_st=tm_st} vi | elemDVarSet (vi_id vi) (ts_dirty tm_st) = pure True +varNeedsTesting _ _ vi + | notNull (vi_pos vi) = pure False varNeedsTesting old_ty_st MkNabla{nabla_ty_st=new_ty_st} _ -- Same type state => still inhabited | not (tyStateRefined old_ty_st new_ty_st) = pure False @@ -1517,11 +1539,114 @@ subst <- tcMatchTy con_res_ty norm_res_ty traverse (lookupTyVar subst) univ_tvs -{- Note [Fuel for the inhabitation test] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Whether or not a type is inhabited is undecidable in general. As a result, we -can run into infinite loops in `inhabitationTest`. Therefore, we adopt a -fuel-based approach to prevent that. +{- Note [Soundness and completeness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Soundness and completeness of the pattern-match checker depends entirely on the +soundness and completeness of the inhabitation test. + +Achieving both soundness and completeness at the same time is undecidable. +See also T17977 and Note [Fuel for the inhabitation test]. +Losing soundness would make the algorithm pointless; hence we give up on +completeness, but try to get as close as possible (how close is called +the 'precision' of the algorithm). + +Soundness means that you + 1. Can remove clauses flagged as redundant without changing program semantics + (no false positives). + 2. Can be sure that your program is free of incomplete pattern matches + when the checker doesn't flag any inexhaustive definitions + (no false negatives). + +A complete algorithm would mean that + 1. When a clause can be deleted without changing program semantics, it will + be flagged as redundant (no false negatives). + 2. A program that is free of incomplete pattern matches will never have a + definition be flagged as inexhaustive (no false positives). + +Via the LYG algorithm, we reduce both these properties to a property on +the inhabitation test of refinementment types: + *Soundness*: If the inhabitation test says "no" for a given refinement type + Nabla, then it provably has no inhabitant. + *Completeness*: If the inhabitation test says "yes" for a given refinement type + Nabla, then it provably has an inhabitant. +Our test is sound, but incomplete, so there are instances where we say +"yes" but in fact the Nabla is empty. Which entails false positive exhaustivity +and false negative redundancy warnings, as above. + +In summary, we have the following correspondence: + +Property | Exhaustiveness warnings | Redundancy warnings | Inhabitation test | +-------------|-------------------------|---------------------|-------------------| +Soundness | No false negatives | No false positives | Only says "no" | + | | | if there is no | + | | | inhabitant | +Completeness | No false positives | No false negatives | Only says "yes" | + | | | if there is an | + | | | inhabitant | + +Note [Shortcutting the inhabitation test] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally, we have to re-test a refinement type for inhabitants whenever we +add a new constraint. Often, we can say "no" early, upon trying to add a +contradicting constraint, see Note [The Pos/Neg invariant]. Still, COMPLETE +sets and type evidence are best handled in a delayed fashion, because of +the recursive nature of the test and our fuel-based approach. +But even then there are some cases in which we can skip the full test, +because we are sure that the refinement type is still inhabited. These +conditions are monitored by 'varNeedsTesting'. It returns + +- `True` whenever a full inhabitation test is needed +- `False` whenever the test can be skipped, amounting to an inhabitation test + that says "yes". + +According to Note [Soundness and Completeness], this test will never compromise +soundness: The `True` case just forwards to the actual inhabitation test and the +`False` case amounts to an inhabitation test that is trivially sound, because it +never says "no". + +Of course, if the returns says `False`, Completeness (and thus Precision) of the +algorithm is affected, but we get to skip costly inhabitation tests. We try to +trade as little Precision as possible against as much Performance as possible. +Here are the tests, in order: + + 1. If a variable is dirty (because of a newly added negative term constraint), + we have to test. + 2. If a variable has positive information, we don't have to test: The + positive information acts as constructive proof for inhabitation. + 3. If the type state didn't change, there is no need to test. + 4. If the variable's normalised type didn't change, there is no need to test. + 5. Otherwise, we have to test. + +Why (1) before (2)? +------------------- +Consider the reverse for (T18960): + pattern P x = x + {-# COMPLETE P :: () #-} + foo = case () of x@(P _) -> () +This should be exhaustive. But if we say "We know `x` has solution `()`, so it's +inhabited", then we'll get a warning saying that `()` wasn't matched. +But the match on `P` added the new negative information to the uncovered set, +in the process of which we marked `x` as dirty. By giving the dirty flag a +higher priority than positive info, we get to test again and see that `x` is +uninhabited and the match is exhaustive. + +But suppose that `P` wasn't mentioned in any COMPLETE set. Then we simply +don't mark `x` as dirty and will emit a warning again (which we would anyway), +without running a superfluous inhabitation test. That speeds up T17836 +considerably. + +Why (2) before (3) and (4)? +--------------------------- +Simply because (2) is more efficient to test than (3) (not by a lot), which +is more efficient to test than (4), which is still more efficient than running +the full inhabitation test (5). + +Note [Fuel for the inhabitation test] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Whether or not a type is inhabited is undecidable in general, see also +Note [Soundness and Completeness]. As a result, we can run into infinite +loops in `inhabitationTest`. Therefore, we adopt a fuel-based approach to +prevent that. Consider the following example: 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 @@ -89,7 +89,7 @@ import Data.ByteString ( unpack ) import Control.Monad -import Data.List +import Data.List (sort, sortBy) import Data.Function import Control.Monad.Trans.Reader import Control.Monad.Trans.Class @@ -265,7 +265,7 @@ data M a repTopP :: LPat GhcRn -> MetaM (Core (M TH.Pat)) -repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat) +repTopP pat = do { ss <- mkGenSyms (collectPatBinders CollNoDictBinders pat) ; pat' <- addBinds ss (repLP pat) ; wrapGenSyms ss pat' } @@ -1568,7 +1568,7 @@ = do { e1 <- repLE e ; repUnboxedSum e1 alt arity } -repE (RecordCon { rcon_con_name = c, rcon_flds = flds }) +repE (RecordCon { rcon_con = c, rcon_flds = flds }) = do { x <- lookupLOcc c; fs <- repFields flds; repRecCon x fs } @@ -1618,7 +1618,7 @@ repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Match)) repMatchTup (L _ (Match { m_pats = [p] , m_grhss = GRHSs _ guards (L _ wheres) })) = - do { ss1 <- mkGenSyms (collectPatBinders p) + do { ss1 <- mkGenSyms (collectPatBinders CollNoDictBinders p) ; addBinds ss1 $ do { ; p1 <- repLP p ; (ss2,ds) <- repBinds wheres @@ -1631,7 +1631,7 @@ repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Clause)) repClauseTup (L _ (Match { m_pats = ps , m_grhss = GRHSs _ guards (L _ wheres) })) = - do { ss1 <- mkGenSyms (collectPatsBinders ps) + do { ss1 <- mkGenSyms (collectPatsBinders CollNoDictBinders ps) ; addBinds ss1 $ do { ps1 <- repLPs ps ; (ss2,ds) <- repBinds wheres @@ -1714,7 +1714,7 @@ repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)]) repSts (BindStmt _ p e : ss) = do { e2 <- repLE e - ; ss1 <- mkGenSyms (collectPatBinders p) + ; ss1 <- mkGenSyms (collectPatBinders CollNoDictBinders p) ; addBinds ss1 $ do { ; p1 <- repLP p; ; (ss2,zs) <- repSts ss @@ -1749,7 +1749,7 @@ ; z <- repNoBindSt e2 ; return ([], [z]) } repSts (stmt@RecStmt{} : ss) - = do { let binders = collectLStmtsBinders (recS_stmts stmt) + = do { let binders = collectLStmtsBinders CollNoDictBinders (recS_stmts stmt) ; ss1 <- mkGenSyms binders -- Bring all of binders in the recursive group into scope for the -- whole group. @@ -1779,7 +1779,7 @@ } repBinds (HsValBinds _ decs) - = do { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs } + = do { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders CollNoDictBinders decs } -- No need to worry about detailed scopes within -- the binding group, because we are talking Names -- here, so we can safely treat it as a mutually @@ -1971,7 +1971,7 @@ repLambda (L _ (Match { m_pats = ps , m_grhss = GRHSs _ [L _ (GRHS _ [] e)] (L _ (EmptyLocalBinds _)) } )) - = do { let bndrs = collectPatsBinders ps ; + = do { let bndrs = collectPatsBinders CollNoDictBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( do { xs <- repLPs ps; body <- repLE e; repLam xs body }) diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs --- a/compiler/GHC/HsToCore/Types.hs +++ b/compiler/GHC/HsToCore/Types.hs @@ -47,7 +47,7 @@ -- constructors are in scope during -- pattern-match satisfiability checking , ds_unqual :: PrintUnqualified - , ds_msgs :: IORef Messages -- Warning messages + , ds_msgs :: IORef (Messages ErrDoc) -- Warning messages , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, -- possibly-imported things , ds_complete_matches :: CompleteMatches diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -40,7 +40,7 @@ import GHC.Data.Maybe import Control.Monad (filterM) -import Data.List +import Data.List (sort, sortBy, nub) import Data.IORef import Data.Map (Map) import qualified Data.Map as Map 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 @@ -261,7 +261,7 @@ mkEvalMatchResult :: Id -> Type -> MatchResult CoreExpr -> MatchResult CoreExpr mkEvalMatchResult var ty = fmap $ \e -> - Case (Var var) var ty [(DEFAULT, [], e)] + Case (Var var) var ty [Alt DEFAULT [] e] mkGuardedMatchResult :: CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr mkGuardedMatchResult pred_expr mr = MR_Fallible $ \fail -> do @@ -277,13 +277,13 @@ where mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts - return (Case (Var var) var ty ((DEFAULT, [], fail) : alts)) + return (Case (Var var) var ty (Alt DEFAULT [] fail : alts)) sorted_alts = sortWith fst match_alts -- Right order for a Case mk_alt fail (lit, mr) = ASSERT( not (litIsLifted lit) ) do body <- runMatchResult fail mr - return (LitAlt lit, [], body) + return (Alt (LitAlt lit) [] body) data CaseAlt a = MkCaseAlt{ alt_pat :: a, alt_bndrs :: [Var], @@ -322,8 +322,9 @@ mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr mkPatSynCase var ty alt fail = do + matcher_id <- dsLookupGlobalId matcher_name matcher <- dsLExpr $ mkLHsWrap wrapper $ - nlHsTyApp matcher [getRuntimeRep ty, ty] + nlHsTyApp matcher_id [getRuntimeRep ty, ty] cont <- mkCoreLams bndrs <$> runMatchResult fail match_result return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail] where @@ -331,7 +332,7 @@ alt_bndrs = bndrs, alt_wrapper = wrapper, alt_result = match_result} = alt - (matcher, needs_void_lam) = patSynMatcher psyn + (matcher_name, _, needs_void_lam) = patSynMatcher psyn -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn -- on these extra Void# arguments @@ -367,7 +368,7 @@ , alt_result = match_result } = flip adjustMatchResultDs match_result $ \body -> do case dataConBoxer con of - Nothing -> return (DataAlt con, args, body) + Nothing -> return (Alt (DataAlt con) args body) Just (DCB boxer) -> do us <- newUniqueSupply let (rep_ids, binds) = initUs_ us (boxer ty_args args) @@ -375,12 +376,12 @@ -- Upholds the invariant that the binders of a case expression -- must be scaled by the case multiplicity. See Note [Case -- expression invariants] in CoreSyn. - return (DataAlt con, rep_ids', mkLets binds body) + return (Alt (DataAlt con) rep_ids' (mkLets binds body)) mk_default :: MatchResult (Maybe CoreAlt) mk_default | exhaustive_case = MR_Infallible $ return Nothing - | otherwise = MR_Fallible $ \fail -> return $ Just (DEFAULT, [], fail) + | otherwise = MR_Fallible $ \fail -> return $ Just (Alt DEFAULT [] fail) mentioned_constructors = mkUniqSet $ map alt_pat sorted_alts un_mentioned_constructors @@ -487,7 +488,7 @@ mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2 | f `hasKey` seqIdKey -- Note [Desugaring seq], points (1) and (2) - = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)] + = Case arg1 case_bndr ty2 [Alt DEFAULT [] arg2] where case_bndr = case arg1 of Var v1 | isInternalName (idName v1) @@ -722,7 +723,7 @@ -- Strip the bangs before looking for case (A) or (B) -- The incoming pattern may well have a bang on it - binders = collectPatBinders pat' + binders = collectPatBinders CollNoDictBinders pat' ticks' = ticks ++ repeat [] local_binders = map localiseId binders -- See Note [Localise pattern binders] @@ -952,8 +953,8 @@ trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId) -- return $ Case e bndr1 boolTy - [ (DataAlt falseDataCon, [], falseBox) - , (DataAlt trueDataCon, [], trueBox) + [ Alt (DataAlt falseDataCon) [] falseBox + , Alt (DataAlt trueDataCon) [] trueBox ] diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -52,7 +52,7 @@ import GHC.Builtin.Types ( mkListTy, mkSumTy ) import GHC.Tc.Types import GHC.Tc.Types.Evidence -import GHC.Types.Var ( Id, Var, EvId, varName, setVarName, varType, varUnique ) +import GHC.Types.Var ( Id, Var, EvId, varName, varType, varUnique ) import GHC.Types.Var.Env import GHC.Builtin.Uniques import GHC.Iface.Make ( mkIfaceExports ) @@ -557,21 +557,6 @@ -- Only used for data family instances, so we only need rhs -- Most probably the rest will be unhelpful anyway -{- Note [Real DataCon Name] -The typechecker substitutes the conLikeWrapId for the name, but we don't want -this showing up in the hieFile, so we replace the name in the Id with the -original datacon name -See also Note [Data Constructor Naming] --} -class HasRealDataConName p where - getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p) - -instance HasRealDataConName GhcRn where - getRealDataCon _ n = n -instance HasRealDataConName GhcTc where - getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) = - L sp (setVarName var (conLikeName con)) - -- | The main worker class -- See Note [Updating HieAst for changes in the GHC AST] for more information -- on how to add/modify instances for this. @@ -795,7 +780,6 @@ , ToHie (RFContext (Located (FieldOcc (GhcPass p)))) , ToHie (TScoped (LHsWcType (GhcPass (NoGhcTcPass p)))) , ToHie (TScoped (LHsSigWcType (GhcPass (NoGhcTcPass p)))) - , HasRealDataConName (GhcPass p) ) => HiePass p where hiePass :: HiePassEv p @@ -1125,11 +1109,15 @@ ExplicitList _ _ exprs -> [ toHie exprs ] - RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} -> - [ toHie $ C Use (getRealDataCon @(GhcPass p) mrealcon name) - -- See Note [Real DataCon Name] + RecordCon { rcon_con = con, rcon_flds = binds} -> + [ toHie $ C Use $ con_name , toHie $ RC RecFieldAssign $ binds ] + where + con_name :: Located Name + con_name = case hiePass @p of -- Like ConPat + HieRn -> con + HieTc -> fmap conLikeName con RecordUpd {rupd_expr = expr, rupd_flds = upds}-> [ toHie expr , toHie $ map (RC RecFieldAssign) upds diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -18,7 +18,6 @@ import GHC.Prelude -import GHC.Driver.Session import GHC.Driver.Env import GHC.Tc.Utils.Monad @@ -35,13 +34,13 @@ import GHC.Types.SrcLoc import GHC.Types.Unique.FM import GHC.Types.Avail +import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.Var import GHC.Types.Basic import GHC.Types.Name import GHC.Types.Name.Shape -import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Fingerprint @@ -58,7 +57,7 @@ r <- liftIO $ do_this case r of Left errs -> do - addMessages (emptyBag, errs) + addMessages (mkMessages errs) failM Right x -> return x @@ -75,10 +74,9 @@ failWithRn :: SDoc -> ShIfM a failWithRn doc = do errs_var <- fmap sh_if_errs getGblEnv - dflags <- getDynFlags errs <- readTcRef errs_var -- TODO: maybe associate this with a source location? - writeTcRef errs_var (errs `snocBag` mkPlainErrMsg dflags noSrcSpan doc) + writeTcRef errs_var (errs `snocBag` mkPlainErrMsg noSrcSpan doc) failM -- | What we have is a generalized ModIface, which corresponds to @@ -664,8 +662,8 @@ rnIfaceTyConBinder (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis rnIfaceAlt :: Rename IfaceAlt -rnIfaceAlt (conalt, names, rhs) - = (,,) <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs +rnIfaceAlt (IfaceAlt conalt names rhs) + = IfaceAlt <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs rnIfaceConAlt :: Rename IfaceConAlt rnIfaceConAlt (IfaceDataAlt data_occ) = IfaceDataAlt <$> rnIfaceGlobal data_occ 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 @@ -34,8 +34,6 @@ import GHC.Core.Seq (seqBinds) import GHC.Core.Lint import GHC.Core.Rules -import GHC.Core.PatSyn -import GHC.Core.ConLike import GHC.Core.Opt.Arity ( exprArity, exprBotStrictness_maybe ) import GHC.Core.InstEnv import GHC.Core.Type ( tidyTopType ) @@ -194,10 +192,8 @@ final_tcs = filterOut isWiredIn tcs -- See Note [Drop wired-in things] - type_env1 = typeEnvFromEntities final_ids final_tcs fam_insts - insts' = mkFinalClsInsts type_env1 insts - pat_syns' = mkFinalPatSyns type_env1 pat_syns - type_env' = extendTypeEnvWithPatSyns pat_syns' type_env1 + type_env' = typeEnvFromEntities final_ids final_tcs pat_syns fam_insts + insts' = mkFinalClsInsts type_env' insts -- Default methods have their export flag set (isExportedId), -- but everything else doesn't (yet), because this is @@ -221,13 +217,6 @@ mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst] mkFinalClsInsts env = map (updateClsInstDFun (lookupFinalId env)) -mkFinalPatSyns :: TypeEnv -> [PatSyn] -> [PatSyn] -mkFinalPatSyns env = map (updatePatSynIds (lookupFinalId env)) - -extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv -extendTypeEnvWithPatSyns tidy_patsyns type_env - = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ] - globaliseAndTidyBootId :: Id -> Id -- For a LocalId with an External Name, -- makes it into a GlobalId @@ -430,10 +419,8 @@ ; final_tcs = filterOut isWiredIn tcs -- See Note [Drop wired-in things] - ; type_env = typeEnvFromEntities final_ids final_tcs fam_insts - ; tidy_cls_insts = mkFinalClsInsts type_env cls_insts - ; tidy_patsyns = mkFinalPatSyns type_env patsyns - ; tidy_type_env = extendTypeEnvWithPatSyns tidy_patsyns type_env + ; tidy_type_env = typeEnvFromEntities final_ids final_tcs patsyns fam_insts + ; tidy_cls_insts = mkFinalClsInsts tidy_type_env cls_insts ; tidy_rules = tidyRules tidy_env trimmed_rules ; -- See Note [Injecting implicit bindings] @@ -836,8 +823,8 @@ dffvExpr (Case e b _ as) = dffvExpr e >> extendScope b (mapM_ dffvAlt as) dffvExpr _other = return () -dffvAlt :: (t, [Var], CoreExpr) -> DFFV () -dffvAlt (_,xs,r) = extendScopeList xs (dffvExpr r) +dffvAlt :: CoreAlt -> DFFV () +dffvAlt (Alt _ xs r) = extendScopeList xs (dffvExpr r) dffvBind :: (Id, CoreExpr) -> DFFV () dffvBind(x,r) diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs --- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs +++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs @@ -151,7 +151,7 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State -import Data.List +import Data.List (intercalate) import Data.Maybe import GHC.Fingerprint import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/GHC/Iface/UpdateIdInfos.hs b/compiler/GHC/Iface/UpdateIdInfos.hs --- a/compiler/GHC/Iface/UpdateIdInfos.hs +++ b/compiler/GHC/Iface/UpdateIdInfos.hs @@ -45,8 +45,10 @@ } = mod_details -- type TypeEnv = NameEnv TyThing - ~type_env' = mapNameEnv (updateTyThingIdInfos type_env' cg_infos) type_env - -- Not strict! + type_env' = mapNameEnv (updateTyThingIdInfos type_env' cg_infos) type_env + -- NB: Knot-tied! The result, type_env', is passed right back into into + -- updateTyThingIdInfos, so that that occurrences of any Ids (e.g. in + -- IdInfos, etc) can be looked up in the tidied env !insts' = strictMap (updateInstIdInfos type_env' cg_infos) insts !rules' = strictMap (updateRuleIdInfos type_env') rules @@ -140,7 +142,7 @@ go env (Case e b ty alts) = assertNotInNameEnv env [b] (Case (go env e) b ty (map go_alt alts)) where - go_alt (k,bs,e) = assertNotInNameEnv env bs (k, bs, go env e) + go_alt (Alt k bs e) = assertNotInNameEnv env bs (Alt k bs (go env e)) go env (Cast e c) = Cast (go env e) c go env (Tick t e) = Tick t (go env e) go _ e@Type{} = e diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -870,9 +870,9 @@ ; return $ AConLike . PatSynCon $ patsyn }}} where mk_doc n = text "Pattern synonym" <+> ppr n - tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool) + tc_pr :: (IfExtName, Bool) -> IfL (Name, Type, Bool) tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm) - ; return (id, b) } + ; return (nm, idType id, b) } tcIfaceDecls :: Bool -> [(Fingerprint, IfaceDecl)] @@ -1532,30 +1532,30 @@ ------------------------- tcIfaceAlt :: CoreExpr -> Mult -> (TyCon, [Type]) - -> (IfaceConAlt, [FastString], IfaceExpr) - -> IfL (AltCon, [TyVar], CoreExpr) -tcIfaceAlt _ _ _ (IfaceDefault, names, rhs) + -> IfaceAlt + -> IfL CoreAlt +tcIfaceAlt _ _ _ (IfaceAlt IfaceDefault names rhs) = ASSERT( null names ) do rhs' <- tcIfaceExpr rhs - return (DEFAULT, [], rhs') + return (Alt DEFAULT [] rhs') -tcIfaceAlt _ _ _ (IfaceLitAlt lit, names, rhs) +tcIfaceAlt _ _ _ (IfaceAlt (IfaceLitAlt lit) names rhs) = ASSERT( null names ) do lit' <- tcIfaceLit lit rhs' <- tcIfaceExpr rhs - return (LitAlt lit', [], rhs') + return (Alt (LitAlt lit') [] rhs') -- A case alternative is made quite a bit more complicated -- by the fact that we omit type annotations because we can -- work them out. True enough, but its not that easy! -tcIfaceAlt scrut mult (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) +tcIfaceAlt scrut mult (tycon, inst_tys) (IfaceAlt (IfaceDataAlt data_occ) arg_strs rhs) = do { con <- tcIfaceDataCon data_occ ; when (debugIsOn && not (con `elem` tyConDataCons tycon)) (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon))) ; tcIfaceDataAlt mult con inst_tys arg_strs rhs } tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [FastString] -> IfaceExpr - -> IfL (AltCon, [TyVar], CoreExpr) + -> IfL CoreAlt tcIfaceDataAlt mult con inst_tys arg_strs rhs = do { us <- newUniqueSupply ; let uniqs = uniqsFromSupply us @@ -1565,7 +1565,7 @@ ; rhs' <- extendIfaceEnvs ex_tvs $ extendIfaceIdEnv arg_ids $ tcIfaceExpr rhs - ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') } + ; return (Alt (DataAlt con) (ex_tvs ++ arg_ids) rhs') } {- ************************************************************************ diff --git a/compiler/GHC/Linker/MacOS.hs b/compiler/GHC/Linker/MacOS.hs --- a/compiler/GHC/Linker/MacOS.hs +++ b/compiler/GHC/Linker/MacOS.hs @@ -22,7 +22,7 @@ import GHC.Utils.Exception -import Data.List +import Data.List (isPrefixOf, nub, sort, intersperse, intercalate) import Control.Monad (join, forM, filterM) import System.Directory (doesFileExist, getHomeDirectory) import System.FilePath ((), (<.>)) diff --git a/compiler/GHC/Llvm/Ppr.hs b/compiler/GHC/Llvm/Ppr.hs --- a/compiler/GHC/Llvm/Ppr.hs +++ b/compiler/GHC/Llvm/Ppr.hs @@ -284,7 +284,7 @@ where ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) = let tc = if ct == TailCall then text "tail " else empty - ppValues = hsep $ punctuate comma $ map ppCallMetaExpr args + ppValues = ppCallParams opts (map snd params) args ppArgTy = (ppCommaJoin $ map (ppr . fst) params) <> (case argTy of VarArgs -> text ", ..." @@ -295,11 +295,15 @@ <> fnty <+> ppName opts fptr <> lparen <+> ppValues <+> rparen <+> attrDoc - -- Metadata needs to be marked as having the `metadata` type when used - -- in a call argument - ppCallMetaExpr (MetaVar v) = ppVar opts v - ppCallMetaExpr v = text "metadata" <+> ppMetaExpr opts v + ppCallParams :: LlvmOpts -> [[LlvmParamAttr]] -> [MetaExpr] -> SDoc + ppCallParams opts attrs args = hsep $ punctuate comma $ zipWith ppCallMetaExpr attrs args + where + -- Metadata needs to be marked as having the `metadata` type when used + -- in a call argument + ppCallMetaExpr attrs (MetaVar v) = ppVar' attrs opts v + ppCallMetaExpr _ v = text "metadata" <+> ppMetaExpr opts v + ppMachOp :: LlvmOpts -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc ppMachOp opts op left right = (ppr op) <+> (ppr (getVarType left)) <+> ppName opts left @@ -546,14 +550,20 @@ | otherwise -> text "undef" ppVar :: LlvmOpts -> LlvmVar -> SDoc -ppVar opts v = case v of - LMLitVar x -> ppTypeLit opts x - x -> ppr (getVarType x) <+> ppName opts x +ppVar = ppVar' [] +ppVar' :: [LlvmParamAttr] -> LlvmOpts -> LlvmVar -> SDoc +ppVar' attrs opts v = case v of + LMLitVar x -> ppTypeLit' attrs opts x + x -> ppr (getVarType x) <+> ppSpaceJoin attrs <+> ppName opts x + ppTypeLit :: LlvmOpts -> LlvmLit -> SDoc -ppTypeLit opts l = case l of +ppTypeLit = ppTypeLit' [] + +ppTypeLit' :: [LlvmParamAttr] -> LlvmOpts -> LlvmLit -> SDoc +ppTypeLit' attrs opts l = case l of LMVectorLit {} -> ppLit opts l - _ -> ppr (getLitType l) <+> ppLit opts l + _ -> ppr (getLitType l) <+> ppSpaceJoin attrs <+> ppLit opts l ppStatic :: LlvmOpts -> LlvmStatic -> SDoc ppStatic opts st = case st of 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 @@ -266,7 +266,7 @@ -- import A(f) -- g = let f = ... in f -- should. - ; let bound_names = collectHsValBinders binds' + ; let bound_names = collectHsValBinders CollNoDictBinders binds' -- There should be only Ids, but if there are any bogus -- pattern synonyms, we'll collect them anyway, so that -- we don't generate subsequent out-of-scope messages @@ -285,7 +285,7 @@ = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds ; return $ ValBinds x mbinds' sigs } where - bndrs = collectHsBindsBinders mbinds + bndrs = collectHsBindsBinders CollNoDictBinders mbinds doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) @@ -472,7 +472,7 @@ -- Keep locally-defined Names -- As well as dependency analysis, we need these for the -- MonoLocalBinds test in GHC.Tc.Gen.Bind.decideGeneralisationPlan - bndrs = collectPatBinders pat + bndrs = collectPatBinders CollNoDictBinders pat bind' = bind { pat_rhs = grhss' , pat_ext = fvs' } @@ -864,7 +864,7 @@ -- (==) :: a -> a -> a -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-} ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs - bound_nms = mkNameSet (collectHsBindsBinders binds') + bound_nms = mkNameSet (collectHsBindsBinders CollNoDictBinders binds') sig_ctxt | is_cls_decl = ClsDeclCtxt cls | otherwise = InstDeclCtxt bound_nms ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags 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 @@ -53,7 +53,7 @@ import GHC.Types.Name.Reader import GHC.Types.Unique.Set import GHC.Types.SourceText -import Data.List +import Data.List (unzip4, minimumBy) import Data.Maybe (isJust, isNothing) import GHC.Utils.Misc import GHC.Data.List.SetOps ( removeDups ) @@ -294,14 +294,14 @@ = do { (expr', fvs) <- rnLExpr expr ; return (ExplicitSum x alt arity expr', fvs) } -rnExpr (RecordCon { rcon_con_name = con_id +rnExpr (RecordCon { rcon_con = con_id , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) }) = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id ; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds ; (flds', fvss) <- mapAndUnzipM rn_field flds ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd } ; return (RecordCon { rcon_ext = noExtField - , rcon_con_name = con_lname, rcon_flds = rec_binds' } + , rcon_con = con_lname, rcon_flds = rec_binds' } , fvs `plusFV` plusFVs fvss `addOneFV` con_name) } where mk_hs_var l n = HsVar noExtField (L l n) @@ -780,10 +780,9 @@ entirely. So, for list comprehensions, the fail function is set to 'Nothing' for clarity. - * In the case of monadic contexts (e.g. monad comprehensions, do, and mdo - expressions) we want pattern match failure to be desugared to the appropriate - 'fail' function (either that of Monad or MonadFail, depending on whether - -XMonadFailDesugaring is enabled.) +* In the case of monadic contexts (e.g. monad comprehensions, do, and mdo + expressions) we want pattern match failure to be desugared to the + 'fail' function (from MonadFail type class). At one point we failed to make this distinction, leading to #11216. -} @@ -838,7 +837,7 @@ ; (fail_op, fvs2) <- monadFailOp pat ctxt ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do - { (thing, fvs3) <- thing_inside (collectPatBinders pat') + { (thing, fvs3) <- thing_inside (collectPatBinders CollNoDictBinders pat') ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op } ; return (( [( L loc (BindStmt xbsrn pat' body'), fv_expr )] , thing), @@ -848,7 +847,7 @@ rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside = rnLocalBindsAndThen binds $ \binds' bind_fvs -> do - { (thing, fvs) <- thing_inside (collectLocalBinders binds') + { (thing, fvs) <- thing_inside (collectLocalBinders CollNoDictBinders binds') ; return ( ([(L loc (LetStmt noExtField (L l binds')), bind_fvs)], thing) , fvs) } @@ -1064,7 +1063,7 @@ ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s -- ...bring them and their fixities into scope - ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv) + ; let bound_names = collectLStmtsBinders CollNoDictBinders (map fst new_lhs_and_fv) -- Fake uses of variables introduced implicitly (warning suppression, see #4404) rec_uses = lStmtsImplicits (map fst new_lhs_and_fv) implicit_uses = mkNameSet $ concatMap snd $ rec_uses @@ -1141,7 +1140,7 @@ -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] rn_rec_stmts_lhs fix_env stmts = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts - ; let boundNames = collectLStmtsBinders (map fst ls) + ; let boundNames = collectLStmtsBinders CollNoDictBinders (map fst ls) -- First do error checking: we need to check for dups here because we -- don't bind all of the variables from the Stmt at once -- with bindLocatedLocals. @@ -1178,7 +1177,7 @@ ; (fail_op, fvs2) <- getMonadFailOp ctxt - ; let bndrs = mkNameSet (collectPatBinders pat') + ; let bndrs = mkNameSet (collectPatBinders CollNoDictBinders pat') fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op } ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, @@ -1708,10 +1707,11 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees + dflags <- getDynFlags let (stmts', fvss) = unzip pairs let (need_join, tail') = -- See Note [ApplicativeDo and refutable patterns] - if any hasRefutablePattern stmts' + if any (hasRefutablePattern dflags) stmts' then (True, tail) else needJoin monad_names tail @@ -1734,7 +1734,7 @@ }, emptyFVs) stmtTreeArg ctxt tail_fvs tree = do let stmts = flattenStmtTree tree - pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) + pvarset = mkNameSet (concatMap (collectStmtBinders CollNoDictBinders . unLoc . fst) stmts) `intersectNameSet` tail_fvs pvars = nameSetElemsStable pvarset -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] @@ -1765,7 +1765,7 @@ -> [[(ExprLStmt GhcRn, FreeVars)]] segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts) where - allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) + allvars = mkNameSet (concatMap (collectStmtBinders CollNoDictBinders . unLoc . fst) stmts) -- We would rather not have a segment that just has LetStmts in -- it, so combine those with an adjacent segment where possible. @@ -1805,7 +1805,7 @@ | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars) | otherwise = (pvars, fvs') where fvs' = fvs `intersectNameSet` allvars - pvars = mkNameSet (collectStmtBinders (unLoc stmt)) + pvars = mkNameSet (collectStmtBinders CollNoDictBinders (unLoc stmt)) isStrictPatternBind :: ExprLStmt GhcRn -> Bool isStrictPatternBind (L _ (BindStmt _ pat _)) = isStrictPattern pat @@ -1866,10 +1866,11 @@ -} -hasRefutablePattern :: ApplicativeArg GhcRn -> Bool -hasRefutablePattern (ApplicativeArgOne { app_arg_pattern = pat - , is_body_stmt = False}) = not (isIrrefutableHsPat pat) -hasRefutablePattern _ = False +hasRefutablePattern :: DynFlags -> ApplicativeArg GhcRn -> Bool +hasRefutablePattern dflags (ApplicativeArgOne { app_arg_pattern = pat + , is_body_stmt = False}) = + not (isIrrefutableHsPat dflags pat) +hasRefutablePattern _ _ = False isLetStmt :: LStmt (GhcPass a) b -> Bool isLetStmt (L _ LetStmt{}) = True @@ -1912,7 +1913,7 @@ | disjointNameSet bndrs fvs && not (isStrictPattern pat) = go lets ((L loc (BindStmt xbs pat body), fvs) : indep) bndrs' rest - where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat) + where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders CollNoDictBinders pat) -- If we encounter a LetStmt that doesn't depend on a BindStmt in this -- group, then move it to the beginning, so that it doesn't interfere with -- grouping more BindStmts. @@ -2156,17 +2157,18 @@ monadFailOp :: LPat GhcPs -> HsStmtContext GhcRn -> RnM (FailOperator GhcRn, FreeVars) -monadFailOp pat ctxt - -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.) - -- we should not need to fail. - | isIrrefutableHsPat pat = return (Nothing, emptyFVs) +monadFailOp pat ctxt = do + dflags <- getDynFlags + -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.) + -- we should not need to fail. + if | isIrrefutableHsPat dflags pat -> return (Nothing, emptyFVs) - -- For non-monadic contexts (e.g. guard patterns, list - -- comprehensions, etc.) we should not need to fail, or failure is handled in - -- a different way. See Note [Failing pattern matches in Stmts]. - | not (isMonadStmtContext ctxt) = return (Nothing, emptyFVs) + -- For non-monadic contexts (e.g. guard patterns, list + -- comprehensions, etc.) we should not need to fail, or failure is handled in + -- a different way. See Note [Failing pattern matches in Stmts]. + | not (isMonadStmtContext ctxt) -> return (Nothing, emptyFVs) - | otherwise = getMonadFailOp ctxt + | otherwise -> getMonadFailOp ctxt {- Note [Monad fail : Rebindable syntax, overloaded strings] diff --git a/compiler/GHC/Rename/Fixity.hs b/compiler/GHC/Rename/Fixity.hs --- a/compiler/GHC/Rename/Fixity.hs +++ b/compiler/GHC/Rename/Fixity.hs @@ -36,7 +36,7 @@ import GHC.Rename.Unbound -import Data.List +import Data.List (groupBy) import Data.Function ( on ) {- diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -2,7 +2,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -71,7 +70,7 @@ import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt -import Data.List +import Data.List (sortBy, nubBy, partition) import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty(..)) import Control.Monad 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 @@ -141,8 +141,9 @@ new_lhs <- rnTopBindsLHS local_fix_env val_decls ; -- Bind the LHSes (and their fixities) in the global rdr environment - let { id_bndrs = collectHsIdBinders new_lhs } ; -- Excludes pattern-synonym binders - -- They are already in scope + let { id_bndrs = collectHsIdBinders CollNoDictBinders new_lhs } ; + -- Excludes pattern-synonym binders + -- They are already in scope traceRn "rnSrcDecls" (ppr id_bndrs) ; tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ; setEnvs tc_envs $ do { 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 @@ -1432,7 +1432,7 @@ = do { let exports = availsToNameSet (tcg_exports gbl_env) sig_ns = tcg_sigs gbl_env -- We use sig_ns to exclude top-level bindings that are generated by GHC - binds = collectHsBindsBinders $ tcg_binds gbl_env + binds = collectHsBindsBinders CollNoDictBinders $ tcg_binds gbl_env pat_syns = tcg_patsyns gbl_env -- Warn about missing signatures 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 @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -342,7 +341,7 @@ -- complain *twice* about duplicates e.g. f (x,x) = ... -- -- See note [Don't report shadowing for pattern synonyms] - ; let bndrs = collectPatsBinders pats' + ; let bndrs = collectPatsBinders CollNoDictBinders pats' ; addErrCtxt doc_pat $ if isPatSynCtxt ctxt then checkDupNames bndrs @@ -597,7 +596,7 @@ loc = maybe noSrcSpan getLoc dd -- Get the arguments of the implicit binders - implicit_binders fs (unLoc -> n) = collectPatsBinders implicit_pats + implicit_binders fs (unLoc -> n) = collectPatsBinders CollNoDictBinders implicit_pats where implicit_pats = map (hsRecFieldArg . unLoc) (drop n fs) diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs --- a/compiler/GHC/Rename/Unbound.hs +++ b/compiler/GHC/Rename/Unbound.hs @@ -40,7 +40,7 @@ import GHC.Unit.Module.Imported import GHC.Unit.Home.ModInfo -import Data.List +import Data.List (sortBy, partition, nub) import Data.Function ( on ) {- 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 @@ -56,7 +56,7 @@ import GHC.Driver.Session import GHC.Data.FastString import Control.Monad -import Data.List +import Data.List (find, sortBy) import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) import qualified Data.List.NonEmpty as NE import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -67,7 +67,7 @@ import Control.Monad import Data.Maybe -import Data.List +import Data.List ((\\)) import GHC.Exts import qualified Data.Sequence as Seq import Data.Sequence (viewl, ViewL(..)) diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs --- a/compiler/GHC/Stg/CSE.hs +++ b/compiler/GHC/Stg/CSE.hs @@ -95,8 +95,6 @@ import GHC.Core.DataCon import GHC.Types.Id import GHC.Stg.Syntax -import GHC.Utils.Outputable -import GHC.Utils.Panic import GHC.Types.Basic (isWeakLoopBreaker) import GHC.Types.Var.Env import GHC.Core (AltCon(..)) @@ -312,8 +310,6 @@ stgCseExpr env (StgOpApp op args tys) = StgOpApp op args' tys where args' = substArgs env args -stgCseExpr _ (StgLam _ _) - = pprPanic "stgCseExp" (text "StgLam") stgCseExpr env (StgTick tick body) = let body' = stgCseExpr env body in StgTick tick body' diff --git a/compiler/GHC/Stg/DepAnal.hs b/compiler/GHC/Stg/DepAnal.hs --- a/compiler/GHC/Stg/DepAnal.hs +++ b/compiler/GHC/Stg/DepAnal.hs @@ -91,8 +91,6 @@ args bounds as expr bounds (StgOpApp _ as _) = args bounds as - expr _ lam@StgLam{} = - pprPanic "annTopBindingsDeps" (text "Found lambda:" $$ pprStgExpr panicStgPprOpts lam) expr bounds (StgCase scrut scrut_bndr _ as) = expr bounds scrut `unionVarSet` alts (extendVarSet bounds scrut_bndr) as diff --git a/compiler/GHC/Stg/FVs.hs b/compiler/GHC/Stg/FVs.hs --- a/compiler/GHC/Stg/FVs.hs +++ b/compiler/GHC/Stg/FVs.hs @@ -48,9 +48,7 @@ import GHC.Types.Id import GHC.Types.Var.Set import GHC.Core ( Tickish(Breakpoint) ) -import GHC.Utils.Outputable import GHC.Utils.Misc -import GHC.Utils.Panic import Data.Maybe ( mapMaybe ) @@ -128,7 +126,6 @@ go (StgLit lit) = (StgLit lit, emptyDVarSet) go (StgConApp dc as tys) = (StgConApp dc as tys, args env as) go (StgOpApp op as ty) = (StgOpApp op as ty, args env as) - go StgLam{} = pprPanic "StgFVs: StgLam" empty go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs) where (scrut', scrut_fvs) = go scrut diff --git a/compiler/GHC/Stg/Lift.hs b/compiler/GHC/Stg/Lift.hs --- a/compiler/GHC/Stg/Lift.hs +++ b/compiler/GHC/Stg/Lift.hs @@ -229,7 +229,6 @@ pure (StgApp f' top_lvl_args) liftExpr (StgConApp con args tys) = StgConApp con <$> traverse liftArgs args <*> pure tys liftExpr (StgOpApp op args ty) = StgOpApp op <$> traverse liftArgs args <*> pure ty -liftExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam") liftExpr (StgCase scrut info ty alts) = do scrut' <- liftExpr scrut withSubstBndr (binderInfoBndr info) $ \bndr' -> do diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs --- a/compiler/GHC/Stg/Lift/Analysis.hs +++ b/compiler/GHC/Stg/Lift/Analysis.hs @@ -34,7 +34,6 @@ import qualified GHC.StgToCmm.Closure as StgToCmm.Closure import qualified GHC.StgToCmm.Layout as StgToCmm.Layout import GHC.Utils.Outputable -import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Types.Var.Set @@ -223,7 +222,6 @@ -- argument occurrences, see "GHC.Stg.Lift.Analysis#arg_occs". | null args = unitVarSet f | otherwise = mkArgOccs args -tagSkeletonExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam") tagSkeletonExpr (StgCase scrut bndr ty alts) = (skel, arg_occs, StgCase scrut' bndr' ty alts') where diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -192,10 +192,6 @@ lintStgExpr (StgOpApp _ args _) = mapM_ lintStgArg args -lintStgExpr lam@(StgLam _ _) = do - opts <- getStgPprOpts - addErrL (text "Unexpected StgLam" <+> pprStgExpr opts lam) - lintStgExpr (StgLet _ binds body) = do binders <- lintStgBinds NotTopLevel binds addLoc (BodyOfLetRec binders) $ diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs --- a/compiler/GHC/Stg/Pipeline.hs +++ b/compiler/GHC/Stg/Pipeline.hs @@ -27,7 +27,6 @@ import GHC.Driver.Session import GHC.Utils.Error -import GHC.Types.Unique (uniqFromMask) import GHC.Types.Unique.Supply import GHC.Utils.Outputable import GHC.Utils.Panic diff --git a/compiler/GHC/Stg/Stats.hs b/compiler/GHC/Stg/Stats.hs --- a/compiler/GHC/Stg/Stats.hs +++ b/compiler/GHC/Stg/Stats.hs @@ -32,7 +32,6 @@ import GHC.Stg.Syntax import GHC.Types.Id (Id) -import GHC.Utils.Panic import Data.Map (Map) import qualified Data.Map as Map @@ -169,5 +168,3 @@ where stat_alts alts = combineSEs (map statExpr [ e | (_,_,e) <- alts ]) - -statExpr (StgLam {}) = panic "statExpr StgLam" diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -336,9 +336,6 @@ unariseExpr rho (StgOpApp op args ty) = return (StgOpApp op (unariseFunArgs rho args) ty) -unariseExpr _ e@StgLam{} - = pprPanic "unariseExpr: found lambda" (pprStgExpr panicStgPprOpts e) - unariseExpr rho (StgCase scrut bndr alt_ty alts) -- tuple/sum binders in the scrutinee can always be eliminated | StgApp v [] <- scrut diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -36,7 +36,7 @@ import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info -import GHC.Cmm.Utils ( mAX_PTR_TAG ) +import GHC.Cmm.Utils ( zeroExpr, cmmTagMask, mkWordCLit, mAX_PTR_TAG ) import GHC.Core import GHC.Core.DataCon import GHC.Types.ForeignCall @@ -70,16 +70,47 @@ cgIdApp a [] -- dataToTag# :: a -> Int# --- See Note [dataToTag#] in primops.txt.pp +-- See Note [dataToTag# magic] in primops.txt.pp cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do platform <- getPlatform emitComment (mkFastString "dataToTag#") - tmp <- newTemp (bWord platform) - _ <- withSequel (AssignTo [tmp] False) (cgIdApp a []) - -- TODO: For small types look at the tag bits instead of reading info table - ptr_opts <- getPtrOpts - emitReturn [getConstrTag ptr_opts (cmmUntag platform (CmmReg (CmmLocal tmp)))] + info <- getCgIdInfo a + let amode = idInfoToAmode info + tag_reg <- assignTemp $ cmmConstrTag1 platform amode + result_reg <- newTemp (bWord platform) + let tag = CmmReg $ CmmLocal tag_reg + is_tagged = cmmNeWord platform tag (zeroExpr platform) + is_too_big_tag = cmmEqWord platform tag (cmmTagMask platform) + -- Here we will first check the tag bits of the pointer we were given; + -- if this doesn't work then enter the closure and use the info table + -- to determine the constructor. Note that all tag bits set means that + -- the constructor index is too large to fit in the pointer and therefore + -- we must look in the info table. See Note [Tagging big families]. + slow_path <- getCode $ do + tmp <- newTemp (bWord platform) + _ <- withSequel (AssignTo [tmp] False) (cgIdApp a []) + ptr_opts <- getPtrOpts + emitAssign (CmmLocal result_reg) + $ getConstrTag ptr_opts (cmmUntag platform (CmmReg (CmmLocal tmp))) + + fast_path <- getCode $ do + -- Return the constructor index from the pointer tag + return_ptr_tag <- getCode $ do + emitAssign (CmmLocal result_reg) + $ cmmSubWord platform tag (CmmLit $ mkWordCLit platform 1) + -- Return the constructor index recorded in the info table + return_info_tag <- getCode $ do + ptr_opts <- getPtrOpts + emitAssign (CmmLocal result_reg) + $ getConstrTag ptr_opts (cmmUntag platform amode) + + emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) + + emit =<< mkCmmIfThenElse' is_tagged fast_path slow_path (Just True) + emitReturn [CmmReg $ CmmLocal result_reg] + + cgExpr (StgOpApp op args ty) = cgOpApp op args ty cgExpr (StgConApp con args _)= cgConApp con args cgExpr (StgTick t e) = cgTick t >> cgExpr e @@ -97,8 +128,6 @@ cgExpr (StgCase expr bndr alt_type alts) = cgCase expr bndr alt_type alts - -cgExpr (StgLam {}) = panic "cgExpr: StgLam" ------------------------------------------------------------------------ -- Let no escape diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs --- a/compiler/GHC/StgToCmm/Layout.hs +++ b/compiler/GHC/StgToCmm/Layout.hs @@ -60,7 +60,7 @@ import GHC.Unit import GHC.Utils.Misc -import Data.List +import Data.List (mapAccumL, partition) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.FastString diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -89,7 +89,7 @@ import GHC.Utils.Misc import Control.Monad -import Data.List +import Data.List (mapAccumL) 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 @@ -1079,6 +1079,12 @@ -- The rest just translate straightforwardly + Int8ToWord8Op -> \args -> opNop args + Word8ToInt8Op -> \args -> opNop args + Int16ToWord16Op -> \args -> opNop args + Word16ToInt16Op -> \args -> opNop args + Int32ToWord32Op -> \args -> opNop args + Word32ToInt32Op -> \args -> opNop args IntToWordOp -> \args -> opNop args WordToIntOp -> \args -> opNop args IntToAddrOp -> \args -> opNop args @@ -1195,8 +1201,8 @@ -- Int8# signed ops - Int8ExtendOp -> \args -> opTranslate args (MO_SS_Conv W8 (wordWidth platform)) - Int8NarrowOp -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W8) + Int8ToIntOp -> \args -> opTranslate args (MO_SS_Conv W8 (wordWidth platform)) + IntToInt8Op -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W8) Int8NegOp -> \args -> opTranslate args (MO_S_Neg W8) Int8AddOp -> \args -> opTranslate args (MO_Add W8) Int8SubOp -> \args -> opTranslate args (MO_Sub W8) @@ -1204,6 +1210,10 @@ Int8QuotOp -> \args -> opTranslate args (MO_S_Quot W8) Int8RemOp -> \args -> opTranslate args (MO_S_Rem W8) + Int8SllOp -> \args -> opTranslate args (MO_Shl W8) + Int8SraOp -> \args -> opTranslate args (MO_S_Shr W8) + Int8SrlOp -> \args -> opTranslate args (MO_U_Shr W8) + Int8EqOp -> \args -> opTranslate args (MO_Eq W8) Int8GeOp -> \args -> opTranslate args (MO_S_Ge W8) Int8GtOp -> \args -> opTranslate args (MO_S_Gt W8) @@ -1213,15 +1223,21 @@ -- Word8# unsigned ops - Word8ExtendOp -> \args -> opTranslate args (MO_UU_Conv W8 (wordWidth platform)) - Word8NarrowOp -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W8) - Word8NotOp -> \args -> opTranslate args (MO_Not W8) + Word8ToWordOp -> \args -> opTranslate args (MO_UU_Conv W8 (wordWidth platform)) + WordToWord8Op -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W8) Word8AddOp -> \args -> opTranslate args (MO_Add W8) Word8SubOp -> \args -> opTranslate args (MO_Sub W8) Word8MulOp -> \args -> opTranslate args (MO_Mul W8) Word8QuotOp -> \args -> opTranslate args (MO_U_Quot W8) Word8RemOp -> \args -> opTranslate args (MO_U_Rem W8) + Word8AndOp -> \args -> opTranslate args (MO_And W8) + Word8OrOp -> \args -> opTranslate args (MO_Or W8) + Word8XorOp -> \args -> opTranslate args (MO_Xor W8) + Word8NotOp -> \args -> opTranslate args (MO_Not W8) + Word8SllOp -> \args -> opTranslate args (MO_Shl W8) + Word8SrlOp -> \args -> opTranslate args (MO_U_Shr W8) + Word8EqOp -> \args -> opTranslate args (MO_Eq W8) Word8GeOp -> \args -> opTranslate args (MO_U_Ge W8) Word8GtOp -> \args -> opTranslate args (MO_U_Gt W8) @@ -1231,8 +1247,8 @@ -- Int16# signed ops - Int16ExtendOp -> \args -> opTranslate args (MO_SS_Conv W16 (wordWidth platform)) - Int16NarrowOp -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W16) + Int16ToIntOp -> \args -> opTranslate args (MO_SS_Conv W16 (wordWidth platform)) + IntToInt16Op -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W16) Int16NegOp -> \args -> opTranslate args (MO_S_Neg W16) Int16AddOp -> \args -> opTranslate args (MO_Add W16) Int16SubOp -> \args -> opTranslate args (MO_Sub W16) @@ -1240,6 +1256,10 @@ Int16QuotOp -> \args -> opTranslate args (MO_S_Quot W16) Int16RemOp -> \args -> opTranslate args (MO_S_Rem W16) + Int16SllOp -> \args -> opTranslate args (MO_Shl W16) + Int16SraOp -> \args -> opTranslate args (MO_S_Shr W16) + Int16SrlOp -> \args -> opTranslate args (MO_U_Shr W16) + Int16EqOp -> \args -> opTranslate args (MO_Eq W16) Int16GeOp -> \args -> opTranslate args (MO_S_Ge W16) Int16GtOp -> \args -> opTranslate args (MO_S_Gt W16) @@ -1249,15 +1269,21 @@ -- Word16# unsigned ops - Word16ExtendOp -> \args -> opTranslate args (MO_UU_Conv W16 (wordWidth platform)) - Word16NarrowOp -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W16) - Word16NotOp -> \args -> opTranslate args (MO_Not W16) + Word16ToWordOp -> \args -> opTranslate args (MO_UU_Conv W16 (wordWidth platform)) + WordToWord16Op -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W16) Word16AddOp -> \args -> opTranslate args (MO_Add W16) Word16SubOp -> \args -> opTranslate args (MO_Sub W16) Word16MulOp -> \args -> opTranslate args (MO_Mul W16) Word16QuotOp -> \args -> opTranslate args (MO_U_Quot W16) Word16RemOp -> \args -> opTranslate args (MO_U_Rem W16) + Word16AndOp -> \args -> opTranslate args (MO_And W16) + Word16OrOp -> \args -> opTranslate args (MO_Or W16) + Word16XorOp -> \args -> opTranslate args (MO_Xor W16) + Word16NotOp -> \args -> opTranslate args (MO_Not W16) + Word16SllOp -> \args -> opTranslate args (MO_Shl W16) + Word16SrlOp -> \args -> opTranslate args (MO_U_Shr W16) + Word16EqOp -> \args -> opTranslate args (MO_Eq W16) Word16GeOp -> \args -> opTranslate args (MO_U_Ge W16) Word16GtOp -> \args -> opTranslate args (MO_U_Gt W16) @@ -1267,14 +1293,50 @@ -- Int32# signed ops - Int32ExtendOp -> \args -> opTranslate args (MO_SS_Conv W32 (wordWidth platform)) - Int32NarrowOp -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W32) + Int32ToIntOp -> \args -> opTranslate args (MO_SS_Conv W32 (wordWidth platform)) + IntToInt32Op -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W32) + Int32NegOp -> \args -> opTranslate args (MO_S_Neg W32) + Int32AddOp -> \args -> opTranslate args (MO_Add W32) + Int32SubOp -> \args -> opTranslate args (MO_Sub W32) + Int32MulOp -> \args -> opTranslate args (MO_Mul W32) + Int32QuotOp -> \args -> opTranslate args (MO_S_Quot W32) + Int32RemOp -> \args -> opTranslate args (MO_S_Rem W32) + Int32SllOp -> \args -> opTranslate args (MO_Shl W32) + Int32SraOp -> \args -> opTranslate args (MO_S_Shr W32) + Int32SrlOp -> \args -> opTranslate args (MO_U_Shr W32) + + Int32EqOp -> \args -> opTranslate args (MO_Eq W32) + Int32GeOp -> \args -> opTranslate args (MO_S_Ge W32) + Int32GtOp -> \args -> opTranslate args (MO_S_Gt W32) + Int32LeOp -> \args -> opTranslate args (MO_S_Le W32) + Int32LtOp -> \args -> opTranslate args (MO_S_Lt W32) + Int32NeOp -> \args -> opTranslate args (MO_Ne W32) + -- Word32# unsigned ops - Word32ExtendOp -> \args -> opTranslate args (MO_UU_Conv W32 (wordWidth platform)) - Word32NarrowOp -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W32) + Word32ToWordOp -> \args -> opTranslate args (MO_UU_Conv W32 (wordWidth platform)) + WordToWord32Op -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W32) + Word32AddOp -> \args -> opTranslate args (MO_Add W32) + Word32SubOp -> \args -> opTranslate args (MO_Sub W32) + Word32MulOp -> \args -> opTranslate args (MO_Mul W32) + Word32QuotOp -> \args -> opTranslate args (MO_U_Quot W32) + Word32RemOp -> \args -> opTranslate args (MO_U_Rem W32) + Word32AndOp -> \args -> opTranslate args (MO_And W32) + Word32OrOp -> \args -> opTranslate args (MO_Or W32) + Word32XorOp -> \args -> opTranslate args (MO_Xor W32) + Word32NotOp -> \args -> opTranslate args (MO_Not W32) + Word32SllOp -> \args -> opTranslate args (MO_Shl W32) + Word32SrlOp -> \args -> opTranslate args (MO_U_Shr W32) + + Word32EqOp -> \args -> opTranslate args (MO_Eq W32) + Word32GeOp -> \args -> opTranslate args (MO_U_Ge W32) + Word32GtOp -> \args -> opTranslate args (MO_U_Gt W32) + Word32LeOp -> \args -> opTranslate args (MO_U_Le W32) + Word32LtOp -> \args -> opTranslate args (MO_U_Lt W32) + Word32NeOp -> \args -> opTranslate args (MO_Ne W32) + -- Char# ops CharEqOp -> \args -> opTranslate args (MO_Eq (wordWidth platform)) @@ -1380,6 +1442,11 @@ then Left (MO_S_QuotRem W16) else Right (genericIntQuotRemOp W16) + Int32QuotRemOp -> \args -> opCallishHandledLater args $ + if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + then Left (MO_S_QuotRem W32) + else Right (genericIntQuotRemOp W32) + WordQuotRemOp -> \args -> opCallishHandledLater args $ if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) then Left (MO_U_QuotRem (wordWidth platform)) @@ -1400,6 +1467,11 @@ then Left (MO_U_QuotRem W16) else Right (genericWordQuotRemOp W16) + Word32QuotRemOp -> \args -> opCallishHandledLater args $ + if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + then Left (MO_U_QuotRem W32) + else Right (genericWordQuotRemOp W32) + WordAdd2Op -> \args -> opCallishHandledLater args $ if (ncg && (x86ish || ppc)) || llvm then Left (MO_Add2 (wordWidth platform)) @@ -2907,7 +2979,7 @@ -> CmmType -- ^ Pointed value type -> CmmExpr -- ^ Op argument (e.g. amount to add) -> FCode () -doAtomicAddrRMW res amop addr ty n = do +doAtomicAddrRMW res amop addr ty n = emitPrimCall [ res ] (MO_AtomicRMW (typeWidth ty) amop) @@ -2934,7 +3006,7 @@ -> CmmExpr -- ^ Addr# -> CmmType -- ^ Type of element by which we are indexing -> FCode () -doAtomicReadAddr res addr ty = do +doAtomicReadAddr res addr ty = emitPrimCall [ res ] (MO_AtomicRead (typeWidth ty)) @@ -2961,7 +3033,7 @@ -> CmmType -- ^ Type of element by which we are indexing -> CmmExpr -- ^ Value to write -> FCode () -doAtomicWriteAddr addr ty val = do +doAtomicWriteAddr addr ty val = emitPrimCall [ {- no results -} ] (MO_AtomicWrite (typeWidth ty)) diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -84,7 +84,7 @@ import qualified Data.ByteString.Char8 as BS8 import qualified Data.Map as M import Data.Char -import Data.List +import Data.List (sortBy) import Data.Ord diff --git a/compiler/GHC/SysTools/Info.hs b/compiler/GHC/SysTools/Info.hs --- a/compiler/GHC/SysTools/Info.hs +++ b/compiler/GHC/SysTools/Info.hs @@ -14,7 +14,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc -import Data.List +import Data.List ( isInfixOf, isPrefixOf ) import Data.IORef import System.IO diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs --- a/compiler/GHC/SysTools/Tasks.hs +++ b/compiler/GHC/SysTools/Tasks.hs @@ -25,7 +25,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc -import Data.List +import Data.List (tails, isPrefixOf) import System.IO import System.Process 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 @@ -8,6 +8,7 @@ {-# LANGUAGE CPP, ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -89,19 +90,13 @@ -- generated. See @Note [Auxiliary binders]@ for a more detailed description -- of how these are used. data AuxBindSpec - -- DerivCon2Tag, DerivTag2Con, and DerivMaxTag are used in derived Eq, Ord, + -- DerivTag2Con, and DerivMaxTag are used in derived Eq, Ord, -- Enum, and Ix instances. -- All these generate ZERO-BASED tag operations -- I.e first constructor has tag 0 - -- | @$con2tag@: Computes the tag for a given constructor - = DerivCon2Tag - TyCon -- The type constructor of the data type to which the - -- constructors belong - RdrName -- The to-be-generated $con2tag binding's RdrName - -- | @$tag2con@: Given a tag, computes the corresponding data constructor - | DerivTag2Con + = DerivTag2Con TyCon -- The type constructor of the data type to which the -- constructors belong RdrName -- The to-be-generated $tag2con binding's RdrName @@ -135,7 +130,6 @@ -- | Retrieve the 'RdrName' of the binding that the supplied 'AuxBindSpec' -- describes. auxBindSpecRdrName :: AuxBindSpec -> RdrName -auxBindSpecRdrName (DerivCon2Tag _ con2tag_RDR) = con2tag_RDR auxBindSpecRdrName (DerivTag2Con _ tag2con_RDR) = tag2con_RDR auxBindSpecRdrName (DerivMaxTag _ maxtag_RDR) = maxtag_RDR auxBindSpecRdrName (DerivDataDataType _ dataT_RDR _) = dataT_RDR @@ -185,17 +179,17 @@ case (a1 `eqFloat#` a2) of r -> r for that particular test. -* If there are a lot of (more than ten) nullary constructors, we emit a +* For nullary constructors, we emit a catch-all clause of the form: - (==) a b = case (con2tag_Foo a) of { a# -> - case (con2tag_Foo b) of { b# -> + (==) a b = case (dataToTag# a) of { a# -> + case (dataToTag# b) of { b# -> case (a# ==# b#) of { r -> r }}} - If con2tag gets inlined this leads to join point stuff, so - it's better to use regular pattern matching if there aren't too - many nullary constructors. "Ten" is arbitrary, of course + An older approach preferred regular pattern matches in some cases + but with dataToTag# forcing it's argument, and work on improving + join points, this seems no longer necessary. * If there aren't any nullary constructors, we emit a simpler catch-all: @@ -204,7 +198,7 @@ * For the @(/=)@ method, we normally just use the default method. If the type is an enumeration type, we could/may/should? generate - special code that calls @con2tag_Foo@, much like for @(==)@ shown + special code that calls @dataToTag#@, much like for @(==)@ shown above. We thought about doing this: If we're also deriving 'Ord' for this @@ -219,24 +213,18 @@ gen_Eq_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff) gen_Eq_binds loc tycon tycon_args = do - -- See Note [Auxiliary binders] - con2tag_RDR <- new_con2tag_rdr_name loc tycon - - return (method_binds con2tag_RDR, aux_binds con2tag_RDR) + return (method_binds, emptyBag) where all_cons = getPossibleDataCons tycon tycon_args (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons - -- If there are ten or more (arbitrary number) nullary constructors, - -- use the con2tag stuff. For small types it's better to use - -- ordinary pattern matching. - (tag_match_cons, pat_match_cons) - | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons) - | otherwise = ([], all_cons) - + -- For nullary constructors, use the getTag stuff. + (tag_match_cons, pat_match_cons) = (nullary_cons, non_nullary_cons) no_tag_match_cons = null tag_match_cons - fall_through_eqn con2tag_RDR + -- (LHS patterns, result) + fall_through_eqn :: [([Located (Pat (GhcPass 'Parsed))] , LHsExpr GhcPs)] + fall_through_eqn | no_tag_match_cons -- All constructors have arguments = case pat_match_cons of [] -> [] -- No constructors; no fall-though case @@ -246,20 +234,18 @@ [([nlWildPat, nlWildPat], false_Expr)] | otherwise -- One or more tag_match cons; add fall-through of - -- extract tags compare for equality + -- extract tags compare for equality, + -- The case `(C1 x) == (C1 y)` can no longer happen + -- at this point as it's matched earlier. = [([a_Pat, b_Pat], - untag_Expr con2tag_RDR [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] + untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))] - aux_binds con2tag_RDR - | no_tag_match_cons = emptyBag - | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon con2tag_RDR - - method_binds con2tag_RDR = unitBag (eq_bind con2tag_RDR) - eq_bind con2tag_RDR + method_binds = unitBag eq_bind + eq_bind = mkFunBindEC 2 loc eq_RDR (const true_Expr) (map pats_etc pat_match_cons - ++ fall_through_eqn con2tag_RDR) + ++ fall_through_eqn) ------------------------------------------------------------------ pats_etc data_con @@ -325,8 +311,8 @@ Take care on the last field to tail-call into comparing av,bv * To make nullary_rhs generate this - case con2tag a of a# -> - case con2tag b of -> + case dataToTag# a of a# -> + case dataToTag# b of -> a# `compare` b# Several special cases: @@ -403,25 +389,20 @@ ------------ gen_Ord_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff) gen_Ord_binds loc tycon tycon_args = do - -- See Note [Auxiliary binders] - con2tag_RDR <- new_con2tag_rdr_name loc tycon - return $ if null tycon_data_cons -- No data-cons => invoke bale-out case then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) [] , emptyBag) - else ( unitBag (mkOrdOp con2tag_RDR OrdCompare) - `unionBags` other_ops con2tag_RDR - , aux_binds con2tag_RDR) + else ( unitBag (mkOrdOp OrdCompare) + `unionBags` other_ops + , aux_binds) where - aux_binds con2tag_RDR - | single_con_type = emptyBag - | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon con2tag_RDR + aux_binds = emptyBag -- Note [Game plan for deriving Ord] - other_ops con2tag_RDR + other_ops | (last_tag - first_tag) <= 2 -- 1-3 constructors || null non_nullary_cons -- Or it's an enumeration - = listToBag [mkOrdOp con2tag_RDR OrdLT, lE, gT, gE] + = listToBag [mkOrdOp OrdLT, lE, gT, gE] | otherwise = emptyBag @@ -447,40 +428,40 @@ (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons - mkOrdOp :: RdrName -> OrdOp -> LHsBind GhcPs + mkOrdOp :: OrdOp -> LHsBind GhcPs -- Returns a binding op a b = ... compares a and b according to op .... - mkOrdOp con2tag_RDR op + mkOrdOp op = mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat] - (mkOrdOpRhs con2tag_RDR op) + (mkOrdOpRhs op) - mkOrdOpRhs :: RdrName -> OrdOp -> LHsExpr GhcPs - mkOrdOpRhs con2tag_RDR op -- RHS for comparing 'a' and 'b' according to op + mkOrdOpRhs :: OrdOp -> LHsExpr GhcPs + mkOrdOpRhs op -- RHS for comparing 'a' and 'b' according to op | nullary_cons `lengthAtMost` 2 -- Two nullary or fewer, so use cases = nlHsCase (nlHsVar a_RDR) $ - map (mkOrdOpAlt con2tag_RDR op) tycon_data_cons + map (mkOrdOpAlt op) tycon_data_cons -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y... -- C2 x -> case b of C2 x -> ....comopare x.... } | null non_nullary_cons -- All nullary, so go straight to comparing tags - = mkTagCmp con2tag_RDR op + = mkTagCmp op | otherwise -- Mixed nullary and non-nullary = nlHsCase (nlHsVar a_RDR) $ - (map (mkOrdOpAlt con2tag_RDR op) non_nullary_cons - ++ [mkHsCaseAlt nlWildPat (mkTagCmp con2tag_RDR op)]) + (map (mkOrdOpAlt op) non_nullary_cons + ++ [mkHsCaseAlt nlWildPat (mkTagCmp op)]) - mkOrdOpAlt :: RdrName -> OrdOp -> DataCon + mkOrdOpAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs) -- Make the alternative (Ki a1 a2 .. av -> - mkOrdOpAlt con2tag_RDR op data_con + mkOrdOpAlt op data_con = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed) - (mkInnerRhs con2tag_RDR op data_con) + (mkInnerRhs op data_con) where as_needed = take (dataConSourceArity data_con) as_RDRs data_con_RDR = getRdrName data_con - mkInnerRhs con2tag_RDR op data_con + mkInnerRhs op data_con | single_con_type = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ] @@ -503,14 +484,14 @@ , mkHsCaseAlt nlWildPat (gtResult op) ] | tag > last_tag `div` 2 -- lower range is larger - = untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] $ + = untag_Expr [(b_RDR, bh_RDR)] $ nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit) (gtResult op) $ -- Definitely GT nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con , mkHsCaseAlt nlWildPat (ltResult op) ] | otherwise -- upper range is larger - = untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] $ + = untag_Expr [(b_RDR, bh_RDR)] $ nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit) (ltResult op) $ -- Definitely LT nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con @@ -529,11 +510,11 @@ data_con_RDR = getRdrName data_con bs_needed = take (dataConSourceArity data_con) bs_RDRs - mkTagCmp :: RdrName -> OrdOp -> LHsExpr GhcPs + mkTagCmp :: OrdOp -> LHsExpr GhcPs -- Both constructors known to be nullary -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b# - mkTagCmp con2tag_RDR op = - untag_Expr con2tag_RDR [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $ + mkTagCmp op = + untag_Expr [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $ unliftedOrdOp intPrimTy op ah_RDR bh_RDR mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs @@ -622,8 +603,8 @@ data Foo ... = N1 | N2 | ... | Nn \end{verbatim} -we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a -@maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@). +we use both dataToTag# and @tag2con_Foo@ functions, as well as a +@maxtag_Foo@ variable, the later generated by @gen_tag_n_con_binds. \begin{verbatim} instance ... Enum (Foo ...) where @@ -632,20 +613,20 @@ toEnum i = tag2con_Foo i - enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo] + enumFrom a = map tag2con_Foo [dataToTag# a .. maxtag_Foo] -- or, really... enumFrom a - = case con2tag_Foo a of + = case dataToTag# a of a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo) enumFromThen a b - = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo] + = map tag2con_Foo [dataToTag# a, dataToTag# b .. maxtag_Foo] -- or, really... enumFromThen a b - = case con2tag_Foo a of { a# -> - case con2tag_Foo b of { b# -> + = case dataToTag# a of { a# -> + case dataToTag# b of { b# -> map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo) }} \end{verbatim} @@ -656,32 +637,30 @@ gen_Enum_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff) gen_Enum_binds loc tycon _ = do -- See Note [Auxiliary binders] - con2tag_RDR <- new_con2tag_rdr_name loc tycon tag2con_RDR <- new_tag2con_rdr_name loc tycon maxtag_RDR <- new_maxtag_rdr_name loc tycon - return ( method_binds con2tag_RDR tag2con_RDR maxtag_RDR - , aux_binds con2tag_RDR tag2con_RDR maxtag_RDR ) + return ( method_binds tag2con_RDR maxtag_RDR + , aux_binds tag2con_RDR maxtag_RDR ) where - method_binds con2tag_RDR tag2con_RDR maxtag_RDR = listToBag - [ succ_enum con2tag_RDR tag2con_RDR maxtag_RDR - , pred_enum con2tag_RDR tag2con_RDR - , to_enum tag2con_RDR maxtag_RDR - , enum_from con2tag_RDR tag2con_RDR maxtag_RDR -- [0 ..] - , enum_from_then con2tag_RDR tag2con_RDR maxtag_RDR -- [0, 1 ..] - , from_enum con2tag_RDR + method_binds tag2con_RDR maxtag_RDR = listToBag + [ succ_enum tag2con_RDR maxtag_RDR + , pred_enum tag2con_RDR + , to_enum tag2con_RDR maxtag_RDR + , enum_from tag2con_RDR maxtag_RDR -- [0 ..] + , enum_from_then tag2con_RDR maxtag_RDR -- [0, 1 ..] + , from_enum ] - aux_binds con2tag_RDR tag2con_RDR maxtag_RDR = listToBag $ map DerivAuxBind - [ DerivCon2Tag tycon con2tag_RDR - , DerivTag2Con tycon tag2con_RDR + aux_binds tag2con_RDR maxtag_RDR = listToBag $ map DerivAuxBind + [ DerivTag2Con tycon tag2con_RDR , DerivMaxTag tycon maxtag_RDR ] occ_nm = getOccString tycon - succ_enum con2tag_RDR tag2con_RDR maxtag_RDR + succ_enum tag2con_RDR maxtag_RDR = mkSimpleGeneratedFunBind loc succ_RDR [a_Pat] $ - untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $ + untag_Expr [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsVar maxtag_RDR, nlHsVarApps intDataCon_RDR [ah_RDR]]) (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration") @@ -689,9 +668,9 @@ (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], nlHsIntLit 1])) - pred_enum con2tag_RDR tag2con_RDR + pred_enum tag2con_RDR = mkSimpleGeneratedFunBind loc pred_RDR [a_Pat] $ - untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $ + untag_Expr [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, nlHsVarApps intDataCon_RDR [ah_RDR]]) (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration") @@ -710,18 +689,18 @@ (nlHsVarApps tag2con_RDR [a_RDR]) (illegal_toEnum_tag occ_nm maxtag_RDR) - enum_from con2tag_RDR tag2con_RDR maxtag_RDR + enum_from tag2con_RDR maxtag_RDR = mkSimpleGeneratedFunBind loc enumFrom_RDR [a_Pat] $ - untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $ + untag_Expr [(a_RDR, ah_RDR)] $ nlHsApps map_RDR [nlHsVar tag2con_RDR, nlHsPar (enum_from_to_Expr (nlHsVarApps intDataCon_RDR [ah_RDR]) (nlHsVar maxtag_RDR))] - enum_from_then con2tag_RDR tag2con_RDR maxtag_RDR + enum_from_then tag2con_RDR maxtag_RDR = mkSimpleGeneratedFunBind loc enumFromThen_RDR [a_Pat, b_Pat] $ - untag_Expr con2tag_RDR [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ + untag_Expr [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $ nlHsPar (enum_from_then_to_Expr (nlHsVarApps intDataCon_RDR [ah_RDR]) @@ -732,9 +711,9 @@ (nlHsVar maxtag_RDR) )) - from_enum con2tag_RDR + from_enum = mkSimpleGeneratedFunBind loc fromEnum_RDR [a_Pat] $ - untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $ + untag_Expr [(a_RDR, ah_RDR)] $ (nlHsVarApps intDataCon_RDR [ah_RDR]) {- @@ -790,32 +769,32 @@ \begin{verbatim} instance ... Ix (Foo ...) where range (a, b) - = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b] + = map tag2con_Foo [dataToTag# a .. dataToTag# b] -- or, really... range (a, b) - = case (con2tag_Foo a) of { a# -> - case (con2tag_Foo b) of { b# -> + = case (dataToTag# a) of { a# -> + case (dataToTag# b) of { b# -> map tag2con_Foo (enumFromTo (I# a#) (I# b#)) }} -- Generate code for unsafeIndex, because using index leads -- to lots of redundant range tests unsafeIndex c@(a, b) d - = case (con2tag_Foo d -# con2tag_Foo a) of + = case (dataToTag# d -# dataToTag# a) of r# -> I# r# inRange (a, b) c = let - p_tag = con2tag_Foo c + p_tag = dataToTag# c in - p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b + p_tag >= dataToTag# a && p_tag <= dataToTag# b -- or, really... inRange (a, b) c - = case (con2tag_Foo a) of { a_tag -> - case (con2tag_Foo b) of { b_tag -> - case (con2tag_Foo c) of { c_tag -> + = case (dataToTag# a) of { a_tag -> + case (dataToTag# b) of { b_tag -> + case (dataToTag# c) of { c_tag -> if (c_tag >=# a_tag) then c_tag <=# b_tag else @@ -836,39 +815,37 @@ gen_Ix_binds loc tycon _ = do -- See Note [Auxiliary binders] - con2tag_RDR <- new_con2tag_rdr_name loc tycon tag2con_RDR <- new_tag2con_rdr_name loc tycon return $ if isEnumerationTyCon tycon - then (enum_ixes con2tag_RDR tag2con_RDR, listToBag $ map DerivAuxBind - [ DerivCon2Tag tycon con2tag_RDR - , DerivTag2Con tycon tag2con_RDR + then (enum_ixes tag2con_RDR, listToBag $ map DerivAuxBind + [ DerivTag2Con tycon tag2con_RDR ]) - else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon con2tag_RDR))) + else (single_con_ixes, emptyBag) where -------------------------------------------------------------- - enum_ixes con2tag_RDR tag2con_RDR = listToBag - [ enum_range con2tag_RDR tag2con_RDR - , enum_index con2tag_RDR - , enum_inRange con2tag_RDR + enum_ixes tag2con_RDR = listToBag + [ enum_range tag2con_RDR + , enum_index + , enum_inRange ] - enum_range con2tag_RDR tag2con_RDR + enum_range tag2con_RDR = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ - untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $ - untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] $ + untag_Expr [(a_RDR, ah_RDR)] $ + untag_Expr [(b_RDR, bh_RDR)] $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $ nlHsPar (enum_from_to_Expr (nlHsVarApps intDataCon_RDR [ah_RDR]) (nlHsVarApps intDataCon_RDR [bh_RDR])) - enum_index con2tag_RDR + enum_index = mkSimpleGeneratedFunBind loc unsafeIndex_RDR [noLoc (AsPat noExtField (noLoc c_RDR) (nlTuplePat [a_Pat, nlWildPat] Boxed)), d_Pat] ( - untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] ( - untag_Expr con2tag_RDR [(d_RDR, dh_RDR)] ( + untag_Expr [(a_RDR, ah_RDR)] ( + untag_Expr [(d_RDR, dh_RDR)] ( let rhs = nlHsVarApps intDataCon_RDR [c_RDR] in @@ -879,11 +856,11 @@ ) -- This produces something like `(ch >= ah) && (ch <= bh)` - enum_inRange con2tag_RDR + enum_inRange = mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ - untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] ( - untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] ( - untag_Expr con2tag_RDR [(c_RDR, ch_RDR)] ( + untag_Expr [(a_RDR, ah_RDR)] ( + untag_Expr [(b_RDR, bh_RDR)] ( + untag_Expr [(c_RDR, ch_RDR)] ( -- This used to use `if`, which interacts badly with RebindableSyntax. -- See #11396. nlHsApps and_RDR @@ -1503,7 +1480,7 @@ kind1 = typeToTypeKind kind2 = liftedTypeKind `mkVisFunTyMany` kind1 -gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, +gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstrTag_RDR, mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR, dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR, constr_RDR, dataType_RDR, @@ -1511,14 +1488,18 @@ eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR , 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 , 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, 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, extendWord8_RDR, extendInt8_RDR, - extendWord16_RDR, extendInt16_RDR :: RdrName + extendWord16_RDR, extendInt16_RDR, + extendWord32_RDR, extendInt32_RDR + :: RdrName gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr") @@ -1527,7 +1508,7 @@ dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2") gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1") gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2") -mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr") +mkConstrTag_RDR = varQual_RDR gENERICS (fsLit "mkConstrTag") constr_RDR = tcQual_RDR gENERICS (fsLit "Constr") mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType") dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType") @@ -1559,6 +1540,12 @@ gtInt16_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt16#" ) geInt16_RDR = varQual_RDR gHC_PRIM (fsLit "geInt16#") +eqInt32_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt32#") +ltInt32_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt32#" ) +leInt32_RDR = varQual_RDR gHC_PRIM (fsLit "leInt32#") +gtInt32_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt32#" ) +geInt32_RDR = varQual_RDR gHC_PRIM (fsLit "geInt32#") + eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#") ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#") leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#") @@ -1577,6 +1564,12 @@ gtWord16_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord16#" ) geWord16_RDR = varQual_RDR gHC_PRIM (fsLit "geWord16#") +eqWord32_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord32#") +ltWord32_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord32#" ) +leWord32_RDR = varQual_RDR gHC_PRIM (fsLit "leWord32#") +gtWord32_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord32#" ) +geWord32_RDR = varQual_RDR gHC_PRIM (fsLit "geWord32#") + eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#") ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#") leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#") @@ -1601,6 +1594,8 @@ extendWord16_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord16#") extendInt16_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt16#") +extendWord32_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord32#") +extendInt32_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt32#") {- ************************************************************************ @@ -2084,14 +2079,13 @@ {- ************************************************************************ * * -\subsection{Generating extra binds (@con2tag@, @tag2con@, etc.)} +\subsection{Generating extra binds (@tag2con@, etc.)} * * ************************************************************************ \begin{verbatim} data Foo ... = ... -con2tag_Foo :: Foo ... -> Int# tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int# maxtag_Foo :: Int -- ditto (NB: not unlifted) \end{verbatim} @@ -2110,23 +2104,6 @@ (genAuxBindSpecSig loc spec))) where gen_bind :: AuxBindSpec -> LHsBind GhcPs - gen_bind (DerivCon2Tag tycon con2tag_RDR) - = mkFunBindSE 0 loc con2tag_RDR eqns - where - lots_of_constructors = tyConFamilySize tycon > 8 - -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS - -- but we don't do vectored returns any more. - - eqns | lots_of_constructors = [get_tag_eqn] - | otherwise = map mk_eqn (tyConDataCons tycon) - - get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr) - - mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs) - mk_eqn con = ([nlWildConPat con], - nlHsLit (HsIntPrim NoSourceText - (toInteger ((dataConTag con) - fIRST_TAG)))) - gen_bind (DerivTag2Con _ tag2con_RDR) = mkFunBindSE 0 loc tag2con_RDR [([nlConVarPat intDataCon_RDR [a_RDR]], @@ -2151,12 +2128,12 @@ gen_bind (DerivDataConstr dc dataC_RDR dataT_RDR) = mkHsVarBind loc dataC_RDR rhs where - rhs = nlHsApps mkConstr_RDR constr_args + rhs = nlHsApps mkConstrTag_RDR constr_args constr_args - = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag - nlHsVar dataT_RDR -- DataType - , nlHsLit (mkHsString (occNameString dc_occ)) -- String name + = [ nlHsVar dataT_RDR -- DataType + , nlHsLit (mkHsString (occNameString dc_occ)) -- Constructor name + , nlHsIntLit (toInteger (dataConTag dc)) -- Constructor tag , nlList labels -- Field labels , nlHsVar fixity ] -- Fixity @@ -2183,10 +2160,6 @@ -- See @Note [Auxiliary binders]@. genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs genAuxBindSpecSig loc spec = case spec of - DerivCon2Tag tycon _ - -> mk_sig $ L loc $ XHsType $ - mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $ - mkParentType tycon `mkVisFunTyMany` intPrimTy DerivTag2Con tycon _ -> mk_sig $ L loc $ XHsType $ mkSpecForAllTys (tyConTyVars tycon) $ @@ -2362,12 +2335,16 @@ , eqInt8_RDR , geInt8_RDR , gtInt8_RDR )) ,(int16PrimTy , (ltInt16_RDR , leInt16_RDR , eqInt16_RDR , geInt16_RDR , gtInt16_RDR )) + ,(int32PrimTy , (ltInt32_RDR , leInt32_RDR + , eqInt32_RDR , geInt32_RDR , gtInt32_RDR )) ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR )) ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR , eqWord8_RDR , geWord8_RDR , gtWord8_RDR )) ,(word16PrimTy, (ltWord16_RDR, leWord16_RDR , eqWord16_RDR, geWord16_RDR, gtWord16_RDR )) + ,(word32PrimTy, (ltWord32_RDR, leWord32_RDR + , eqWord32_RDR, geWord32_RDR, gtWord32_RDR )) ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR )) ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR @@ -2390,13 +2367,19 @@ . nlHsApp (nlHsVar extendInt8_RDR)) , (word8PrimTy, nlHsApp (nlHsVar $ getRdrName wordDataCon) - . nlHsApp (nlHsVar extendWord8_RDR)) + . nlHsApp (nlHsVar extendWord8_RDR)) , (int16PrimTy, nlHsApp (nlHsVar $ getRdrName intDataCon) . nlHsApp (nlHsVar extendInt16_RDR)) , (word16PrimTy, nlHsApp (nlHsVar $ getRdrName wordDataCon) - . nlHsApp (nlHsVar extendWord16_RDR)) + . nlHsApp (nlHsVar extendWord16_RDR)) + , (int32PrimTy, + nlHsApp (nlHsVar $ getRdrName intDataCon) + . nlHsApp (nlHsVar extendInt32_RDR)) + , (word32PrimTy, + nlHsApp (nlHsVar $ getRdrName wordDataCon) + . nlHsApp (nlHsVar extendWord32_RDR)) ] @@ -2412,6 +2395,8 @@ ,(word8PrimTy, "##") ,(int16PrimTy, "#") ,(word16PrimTy, "##") + ,(int32PrimTy, "#") + ,(word32PrimTy, "##") ] primConvTbl :: [(Type, String)] @@ -2420,6 +2405,8 @@ , (word8PrimTy, "narrowWord8#") , (int16PrimTy, "narrowInt16#") , (word16PrimTy, "narrowWord16#") + , (int32PrimTy, "narrowInt32#") + , (word32PrimTy, "narrowWord32#") ] litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)] @@ -2472,12 +2459,12 @@ where (_, _, prim_eq, _, _) = primOrdOps "Eq" ty -untag_Expr :: RdrName -> [(RdrName, RdrName)] +untag_Expr :: [(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs -untag_Expr _ [] expr = expr -untag_Expr con2tag_RDR ((untag_this, put_tag_here) : more) expr - = nlHsCase (nlHsPar (nlHsVarApps con2tag_RDR [untag_this])) {-of-} - [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr con2tag_RDR more expr)] +untag_Expr [] expr = expr +untag_Expr ((untag_this, put_tag_here) : more) expr + = nlHsCase (nlHsPar (nlHsVarApps dataToTag_RDR [untag_this])) {-of-} + [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr more expr)] enum_from_to_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs @@ -2590,10 +2577,9 @@ minusInt_RDR = getRdrName (primOpId IntSubOp ) tagToEnum_RDR = getRdrName (primOpId TagToEnumOp) -new_con2tag_rdr_name, new_tag2con_rdr_name, new_maxtag_rdr_name +new_tag2con_rdr_name, new_maxtag_rdr_name :: SrcSpan -> TyCon -> TcM RdrName -- Generates Exact RdrNames, for the binding positions -new_con2tag_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkCon2TagOcc new_tag2con_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkTag2ConOcc new_maxtag_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkMaxTagOcc @@ -2657,52 +2643,52 @@ Note [Auxiliary binders] ~~~~~~~~~~~~~~~~~~~~~~~~ We often want to make top-level auxiliary bindings in derived instances. -For example, derived Eq instances sometimes generate code like this: +For example, derived Ix instances sometimes generate code like this: data T = ... - deriving instance Eq T + deriving instance Ix T ==> - instance Eq T where - a == b = $con2tag_T a == $con2tag_T b + instance Ix T where + range (a, b) = map tag2con_T [dataToTag# a .. dataToTag# b] - $con2tag_T :: T -> Int - $con2tag_T = ...code.... + $tag2con_T :: Int -> T + $tag2con_T = ...code.... Note that multiple instances of the same type might need to use the same sort -of auxiliary binding. For example, $con2tag is used not only in derived Eq -instances, but also in derived Ord instances: +of auxiliary binding. For example, $tag2con is used not only in derived Ix +instances, but also in derived Enum instances: - deriving instance Ord T + deriving instance Enum T ==> - instance Ord T where - compare a b = $con2tag_T a `compare` $con2tag_T b + instance Enum T where + toEnum i = tag2con_T i - $con2tag_T :: T -> Int - $con2tag_T = ...code.... + $tag2con_T :: Int -> T + $tag2con_T = ...code.... -How do we ensure that the two usages of $con2tag_T do not conflict with each -other? We do so by generating a separate $con2tag_T definition for each +How do we ensure that the two usages of $tag2con_T do not conflict with each +other? We do so by generating a separate $tag2con_T definition for each instance, giving each definition an Exact RdrName with a separate Unique to avoid name clashes: - instance Eq T where - a == b = $con2tag_T{Uniq1} a == $con2tag_T{Uniq1} b + instance Ix T where + range (a, b) = map tag2con_T{Uniq2} [dataToTag# a .. dataToTag# b] - instance Ord T where - compare a b = $con2tag_T{Uniq2} a `compare` $con2tag_T{Uniq2} b + instance Enum T where + toEnum a = $tag2con_T{Uniq2} a - -- $con2tag_T{Uniq1} and $con2tag_T{Uniq2} are Exact RdrNames with + -- $tag2con_T{Uniq1} and $tag2con_T{Uniq2} are Exact RdrNames with -- underyling System Names - $con2tag_T{Uniq1} :: T -> Int - $con2tag_T{Uniq1} = ...code.... + $tag2con_T{Uniq1} :: Int -> T + $tag2con_T{Uniq1} = ...code.... - $con2tag_T{Uniq2} :: T -> Int - $con2tag_T{Uniq2} = ...code.... + $tag2con_T{Uniq2} :: Int -> T + $tag2con_T{Uniq2} = ...code.... Note that: @@ -2718,8 +2704,8 @@ de-duplication mechanism isn't perfect, so we fall back to CSE (which is very effective within a single module). -* Note that the "_T" part of "$con2tag_T" is just for debug-printing - purposes. We could call them all "$con2tag", or even just "aux". +* Note that the "_T" part of "$tag2con_T" is just for debug-printing + purposes. We could call them all "$tag2con", or even just "aux". The Unique is enough to keep them separate. This is important: we might be generating an Eq instance for two @@ -2732,17 +2718,17 @@ are used. Using some hypothetical Haskell syntax, it might look like this: let { - $con2tag_T{Uniq1} :: T -> Int - $con2tag_T{Uniq1} = ...code.... + $tag2con_T{Uniq1} :: Int -> T + $tag2con_T{Uniq1} = ...code.... - $con2tag_T{Uniq2} :: T -> Int - $con2tag_T{Uniq2} = ...code.... + $tag2con_T{Uniq2} :: Int -> T + $tag2con_T{Uniq2} = ...code.... } in { - instance Eq T where - a == b = $con2tag_T{Uniq1} a == $con2tag_T{Uniq1} b + instance Ix T where + range (a, b) = map tag2con_T{Uniq2} [dataToTag# a .. dataToTag# b] - instance Ord T where - compare a b = $con2tag_T{Uniq2} a `compare` $con2tag_T{Uniq2} b + instance Enum T where + toEnum a = $tag2con_T{Uniq2} a } Making auxiliary bindings local is key to making this work, since GHC will @@ -2773,29 +2759,29 @@ ==> - instance Eq T where - a == b = $con2tag_T{Uniq1} a == $con2tag_T{Uniq1} b + instance Ix T where + range (a, b) = map tag2con_T{Uniq2} [dataToTag# a .. dataToTag# b] - instance Ord T where - compare a b = $con2tag_T{Uniq2} a `compare` $con2tag_T{Uniq2} b + instance Enum T where + toEnum a = $tag2con_T{Uniq2} a - $con2tag_T{Uniq1} :: T -> Int - $con2tag_T{Uniq1} = ...code.... + $tag2con_T{Uniq1} :: Int -> T + $tag2con_T{Uniq1} = ...code.... - $con2tag_T{Uniq2} :: T -> Int - $con2tag_T{Uniq2} = ...code.... + $tag2con_T{Uniq2} :: Int -> T + $tag2con_T{Uniq2} = ...code.... -$con2tag_T{Uniq1} and $con2tag_T{Uniq2} are blatant duplicates of each other, +$tag2con_T{Uniq1} and $tag2con_T{Uniq2} are blatant duplicates of each other, which is not ideal. Surely GHC can do better than that at the very least! And indeed it does. Within the genAuxBinds function, GHC performs a small CSE-like pass to define duplicate auxiliary binders in terms of the original one. On the example above, that would look like this: - $con2tag_T{Uniq1} :: T -> Int - $con2tag_T{Uniq1} = ...code.... + $tag2con_T{Uniq1} :: Int -> T + $tag2con_T{Uniq1} = ...code.... - $con2tag_T{Uniq2} :: T -> Int - $con2tag_T{Uniq2} = $con2tag_T{Uniq1} + $tag2con_T{Uniq2} :: Int -> T + $tag2con_T{Uniq2} = $tag2con_T{Uniq1} (Note that this pass does not cover all possible forms of code duplication. See "Wrinkle: Why we sometimes do generate duplicate code" for situations @@ -2805,19 +2791,19 @@ of auxiliary bindings that must be generates along with their RdrNames. As genAuxBinds processes this list, it marks the first occurrence of each sort of auxiliary binding as the "original". For example, if genAuxBinds sees a -DerivCon2Tag for the first time (with the RdrName $con2tag_T{Uniq1}), then it -will generate the full code for a $con2tag binding: +DerivCon2Tag for the first time (with the RdrName $tag2con_T{Uniq1}), then it +will generate the full code for a $tag2con binding: - $con2tag_T{Uniq1} :: T -> Int - $con2tag_T{Uniq1} = ...code.... + $tag2con_T{Uniq1} :: Int -> T + $tag2con_T{Uniq1} = ...code.... Later, if genAuxBinds sees any additional DerivCon2Tag values, it will treat them as duplicates. For example, if genAuxBinds later sees a DerivCon2Tag with -the RdrName $con2tag_T{Uniq2}, it will generate this code, which is much more +the RdrName $tag2con_T{Uniq2}, it will generate this code, which is much more compact: - $con2tag_T{Uniq2} :: T -> Int - $con2tag_T{Uniq2} = $con2tag_T{Uniq1} + $tag2con_T{Uniq2} :: Int -> T + $tag2con_T{Uniq2} = $tag2con_T{Uniq1} An alternative approach would be /not/ performing any kind of deduplication in genAuxBinds at all and simply relying on GHC's simplifier to perform this kind @@ -2839,14 +2825,14 @@ data T = ... module B where import A - deriving instance Eq T + deriving instance Ix T module C where import B deriving instance Enum T - The derived Eq and Enum instances for T make use of $con2tag_T, and since + The derived Eq and Enum instances for T make use of $tag2con_T, and since they are defined in separate modules, each module must produce its own copy - of $con2tag_T. + of $tag2con_T. 2. When derived instances are separated by TH splices (#18321), as in the following example: @@ -2854,14 +2840,14 @@ module M where data T = ... - deriving instance Eq T + deriving instance Ix T $(pure []) deriving instance Enum T Due to the way that GHC typechecks TyClGroups, genAuxBinds will run twice in this program: once for all the declarations before the TH splice, and once again for all the declarations after the TH splice. As a result, - $con2tag_T will be generated twice, since genAuxBinds will be unable to + $tag2con_T will be generated twice, since genAuxBinds will be unable to recognize the presence of duplicates. These situations are much rarer, so we do not spend any effort to deduplicate 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 @@ -50,8 +50,9 @@ import GHC.Types.Var.Env import GHC.Types.Name.Set import GHC.Data.Bag -import GHC.Utils.Error ( ErrMsg, errDoc, pprLocErrMsg ) +import GHC.Utils.Error ( pprLocErrMsg ) import GHC.Types.Basic +import GHC.Types.Error import GHC.Core.ConLike ( ConLike(..)) import GHC.Utils.Misc import GHC.Data.FastString @@ -167,7 +168,6 @@ -- See Note [Deferring coercion errors to runtime] -- Used by solveEqualities for kind equalities -- (see Note [Fail fast on kind errors] in "GHC.Tc.Solver") --- and for simplifyDefault. reportAllUnsolved :: WantedConstraints -> TcM () reportAllUnsolved wanted = do { ev_binds <- newNoTcEvBinds @@ -378,15 +378,30 @@ , cec_out_of_scope_holes = HoleError }) = False deferringAnyBindings _ = True --- | Transforms a 'ReportErrCtxt' into one that does not defer any bindings --- at all. -noDeferredBindings :: ReportErrCtxt -> ReportErrCtxt -noDeferredBindings ctxt = ctxt { cec_defer_type_errors = TypeError - , cec_expr_holes = HoleError - , cec_out_of_scope_holes = HoleError } +maybeSwitchOffDefer :: EvBindsVar -> ReportErrCtxt -> ReportErrCtxt +-- Switch off defer-type-errors inside CoEvBindsVar +-- See Note [Failing equalities with no evidence bindings] +maybeSwitchOffDefer evb ctxt + | CoEvBindsVar{} <- evb + = ctxt { cec_defer_type_errors = TypeError + , cec_expr_holes = HoleError + , cec_out_of_scope_holes = HoleError } + | otherwise + = ctxt -{- Note [Suppressing error messages] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Failing equalities with no evidence bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we go inside an implication that has no term evidence +(e.g. unifying under a forall), we can't defer type errors. You could +imagine using the /enclosing/ bindings (in cec_binds), but that may +not have enough stuff in scope for the bindings to be well typed. So +we just switch off deferred type errors altogether. See #14605. + +This is done by maybeSwitchOffDefer. It's also useful in one other +place: see Note [Wrapping failing kind equalities] in GHC.Tc.Solver. + +Note [Suppressing error messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The cec_suppress flag says "don't report any errors". Instead, just create evidence bindings (as usual). It's used when more important errors have occurred. @@ -445,15 +460,8 @@ implic' = implic { ic_skols = tvs' , ic_given = map (tidyEvVar env1) given , ic_info = info' } - ctxt1 | CoEvBindsVar{} <- evb = noDeferredBindings ctxt - | otherwise = ctxt - -- If we go inside an implication that has no term - -- evidence (e.g. unifying under a forall), we can't defer - -- type errors. You could imagine using the /enclosing/ - -- bindings (in cec_binds), but that may not have enough stuff - -- in scope for the bindings to be well typed. So we just - -- switch off deferred type errors altogether. See #14605. + ctxt1 = maybeSwitchOffDefer evb ctxt ctxt' = ctxt1 { cec_tidy = env1 , cec_encl = implic' : cec_encl ctxt @@ -742,7 +750,7 @@ ; maybeReportError ctxt err ; addDeferredBinding ctxt err ct } -mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg +mkUserTypeError :: ReportErrCtxt -> Ct -> TcM (ErrMsg ErrDoc) mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct $ important $ pprUserTypeErrorTy @@ -818,7 +826,7 @@ find one, we report the insoluble Given. -} -mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) +mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc)) -- Make error message for a group -> Reporter -- Deal with lots of constraints -- Group together errors from same location, @@ -827,7 +835,7 @@ = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) -- Like mkGroupReporter, but doesn't actually print error messages -mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter +mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc)) -> Reporter mkSuppressReporter mk_err ctxt cts = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) @@ -845,7 +853,7 @@ -- Reduce duplication by reporting only one error from each -- /starting/ location even if the end location differs -reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter +reportGroup :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc)) -> Reporter reportGroup mk_err ctxt cts = ASSERT( not (null cts)) do { err <- mk_err ctxt cts @@ -864,13 +872,13 @@ -- like reportGroup, but does not actually report messages. It still adds -- -fdefer-type-errors bindings, though. -suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter +suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc)) -> Reporter suppressGroup mk_err ctxt cts = do { err <- mk_err ctxt cts ; traceTc "Suppressing errors for" (ppr cts) ; mapM_ (addDeferredBinding ctxt err) cts } -maybeReportHoleError :: ReportErrCtxt -> Hole -> ErrMsg -> TcM () +maybeReportHoleError :: ReportErrCtxt -> Hole -> ErrMsg ErrDoc -> TcM () maybeReportHoleError ctxt hole err | isOutOfScopeHole hole -- Always report an error for out-of-scope variables @@ -912,7 +920,7 @@ HoleWarn -> reportWarning (Reason Opt_WarnTypedHoles) err HoleDefer -> return () -maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM () +maybeReportError :: ReportErrCtxt -> ErrMsg ErrDoc -> TcM () -- Report the error and/or make a deferred binding for it maybeReportError ctxt err | cec_suppress ctxt -- Some worse error has occurred; @@ -924,7 +932,7 @@ TypeWarn reason -> reportWarning reason err TypeError -> reportError err -addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () +addDeferredBinding :: ReportErrCtxt -> ErrMsg ErrDoc -> Ct -> TcM () -- See Note [Deferring coercion errors to runtime] addDeferredBinding ctxt err ct | deferringAnyBindings ctxt @@ -947,14 +955,14 @@ = return () mkErrorTerm :: DynFlags -> Type -- of the error term - -> ErrMsg -> EvTerm + -> ErrMsg ErrDoc -> EvTerm mkErrorTerm dflags ty err = evDelayedError ty err_fs where err_msg = pprLocErrMsg err err_fs = mkFastString $ showSDoc dflags $ err_msg $$ text "(deferred type error)" -maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Hole -> TcM () +maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg ErrDoc -> Hole -> TcM () maybeAddDeferredHoleBinding ctxt err (Hole { hole_sort = ExprHole (HER ref ref_ty _) }) -- Only add bindings for holes in expressions -- not for holes in partial type signatures @@ -1040,11 +1048,11 @@ ppr_one ct' = hang (parens (pprType (ctPred ct'))) 2 (pprCtLoc (ctLoc ct')) -mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM ErrMsg +mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM (ErrMsg ErrDoc) mkErrorMsgFromCt ctxt ct report = mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report -mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg +mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM (ErrMsg ErrDoc) mkErrorReport ctxt tcl_env (Report important relevant_bindings valid_subs) = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) ; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env) Nothing) @@ -1145,7 +1153,7 @@ ************************************************************************ -} -mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc) mkIrredErr ctxt cts = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 ; let orig = ctOrigin ct1 @@ -1156,7 +1164,7 @@ (ct1:_) = cts ---------------- -mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM ErrMsg +mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (ErrMsg ErrDoc) mkHoleError _tidy_simples _ctxt hole@(Hole { hole_occ = occ , hole_ty = hole_ty , hole_loc = ct_loc }) @@ -1297,7 +1305,7 @@ 2 (vcat $ map pprConstraint constraints) ---------------- -mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkIPErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc) mkIPErr ctxt cts = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 ; let orig = ctOrigin ct1 @@ -1374,11 +1382,11 @@ -- Don't have multiple equality errors from the same location -- E.g. (Int,Bool) ~ (Bool,Int) one error will do! -mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkEqErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc) mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct mkEqErr _ [] = panic "mkEqErr" -mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg +mkEqErr1 :: ReportErrCtxt -> Ct -> TcM (ErrMsg ErrDoc) mkEqErr1 ctxt ct -- Wanted or derived; -- givens handled in mkGivenErrorReporter = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct @@ -1444,7 +1452,7 @@ mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report -> Ct - -> TcType -> TcType -> TcM ErrMsg + -> TcType -> TcType -> TcM (ErrMsg ErrDoc) mkEqErr_help dflags ctxt report ct ty1 ty2 | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1 = mkTyVarEqErr dflags ctxt report ct tv1 ty2 @@ -1455,7 +1463,7 @@ reportEqErr :: ReportErrCtxt -> Report -> Ct - -> TcType -> TcType -> TcM ErrMsg + -> TcType -> TcType -> TcM (ErrMsg ErrDoc) reportEqErr ctxt report ct ty1 ty2 = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo]) where @@ -1464,7 +1472,7 @@ mkTyVarEqErr, mkTyVarEqErr' :: DynFlags -> ReportErrCtxt -> Report -> Ct - -> TcTyVar -> TcType -> TcM ErrMsg + -> TcTyVar -> TcType -> TcM (ErrMsg ErrDoc) -- tv1 and ty2 are already tidied mkTyVarEqErr dflags ctxt report ct tv1 ty2 = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2) @@ -1664,7 +1672,7 @@ -- always be another unsolved wanted around, which will ordinarily suppress -- this message. But this can still be printed out with -fdefer-type-errors -- (sigh), so we must produce a message. -mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc) mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ctxt ct report where report = important msg @@ -2271,7 +2279,7 @@ ************************************************************************ -} -mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkDictErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc) mkDictErr ctxt cts = ASSERT( not (null cts) ) do { inst_envs <- tcGetInstEnvs diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -47,8 +47,8 @@ import GHC.Tc.Instance.Family( tcGetFamInstEnvs ) import GHC.Tc.Utils.TcType import GHC.Core.Type (mkStrLitTy, tidyOpenType, mkCastTy) +import GHC.Builtin.Types ( mkBoxedTupleTy ) import GHC.Builtin.Types.Prim -import GHC.Builtin.Types( mkBoxedTupleTy ) import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.Var as Var @@ -320,7 +320,7 @@ do { thing <- thing_inside -- See Note [Pattern synonym builders don't yield dependencies] -- in GHC.Rename.Bind - ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns + ; patsyn_builders <- mapM (tcPatSynBuilderBind prag_fn) patsyns ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ] ; return (extra_binds, thing) } @@ -438,17 +438,17 @@ 2 (vcat $ map pprLBind . bagToList $ binds) where pprLoc loc = parens (text "defined at" <+> ppr loc) - pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) + pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind) <+> pprLoc loc tc_single :: forall thing. TopLevelFlag -> TcSigFun -> TcPragEnv -> LHsBind GhcRn -> IsGroupClosed -> TcM thing -> TcM (LHsBinds GhcTc, thing) -tc_single _top_lvl sig_fn _prag_fn +tc_single _top_lvl sig_fn prag_fn (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name })) _ thing_inside - = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name) + = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name) prag_fn ; thing <- setGblEnv tcg_env thing_inside ; return (aux_binds, thing) } @@ -488,7 +488,7 @@ key_map :: NameEnv BKey -- Which binding it comes from key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds - , bndr <- collectHsBindBinders bind ] + , bndr <- collectHsBindBinders CollNoDictBinders bind ] ------------------------ tcPolyBinds :: TcSigFun -> TcPragEnv @@ -531,7 +531,7 @@ ; return result } where - binder_names = collectHsBindListBinders bind_list + binder_names = collectHsBindListBinders CollNoDictBinders bind_list loc = foldr1 combineSrcSpans (map getLoc bind_list) -- The mbinds have been dependency analysed and -- may no longer be adjacent; so find the narrowest @@ -729,9 +729,8 @@ ; mapM_ (checkOverloadedSig mono) sigs ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted) - ; (qtvs, givens, ev_binds, residual, insoluble) + ; (qtvs, givens, ev_binds, insoluble) <- simplifyInfer tclvl infer_mode sigs name_taus wanted - ; emitConstraints residual ; let inferred_theta = map evVarPred givens ; exports <- checkNoErrs $ @@ -946,29 +945,30 @@ -- so that the Hole constraint we have already emitted -- (in tcHsPartialSigType) can report what filled it in. -- NB: my_theta already includes all the annotated constraints - ; let inferred_diff = [ pred - | pred <- my_theta - , all (not . (`eqType` pred)) annotated_theta ] - ; ctuple <- mk_ctuple inferred_diff + ; diff_theta <- findInferredDiff annotated_theta my_theta ; case tcGetCastedTyVar_maybe wc_var_ty of -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it - -- comes from the checkExpectedKind in GHC.Tc.Gen.HsType.tcAnonWildCardOcc. So, to - -- make the kinds work out, we reverse the cast here. - Just (wc_var, wc_co) -> writeMetaTyVar wc_var (ctuple `mkCastTy` mkTcSymCo wc_co) + -- comes from the checkExpectedKind in GHC.Tc.Gen.HsType.tcAnonWildCardOcc. + -- So, to make the kinds work out, we reverse the cast here. + Just (wc_var, wc_co) -> writeMetaTyVar wc_var (mk_ctuple diff_theta + `mkCastTy` mkTcSymCo wc_co) Nothing -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty) ; traceTc "completeTheta" $ vcat [ ppr sig - , ppr annotated_theta, ppr inferred_theta - , ppr inferred_diff ] - ; return (free_tvs, my_theta) } + , text "annotated_theta:" <+> ppr annotated_theta + , text "inferred_theta:" <+> ppr inferred_theta + , text "my_theta:" <+> ppr my_theta + , text "diff_theta:" <+> ppr diff_theta ] + ; return (free_tvs, annotated_theta ++ diff_theta) } + -- Return (annotated_theta ++ diff_theta) + -- See Note [Extra-constraints wildcards] - mk_ctuple preds = return (mkBoxedTupleTy preds) + mk_ctuple preds = mkBoxedTupleTy preds -- Hack alert! See GHC.Tc.Gen.HsType: -- Note [Extra-constraint holes in partial type signatures] - mk_impedance_match_msg :: MonoBindInfo -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) @@ -1086,7 +1086,22 @@ explicitly-quantified type variables have not been unified together. #14449 showed this up. +Note [Extra-constraints wildcards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this from #18646 + class Foo x where + foo :: x + bar :: (Foo (), _) => f () + bar = pure foo + +We get [W] Foo (), [W] Applicative f. When we do pickCapturedPreds in +choose_psig_context, we'll discard Foo ()! Usually would not quantify over +such (closed) predicates. So my_theta will be (Applicative f). But we really +do want to quantify over (Foo ()) -- it was speicfied by the programmer. +Solution: always return annotated_theta (user-specified) plus the extra piece +diff_theta. + Note [Validity of inferred types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We need to check inferred type for validity, in case it uses language @@ -1230,7 +1245,7 @@ , mbis ) } where - bndrs = collectPatBinders pat + bndrs = collectPatBinders CollNoDictBinders pat -- GENERAL CASE tcMonoBinds _ sig_fn no_gen binds @@ -1392,7 +1407,7 @@ ; return (TcPatBind mbis pat' grhss pat_ty) } where - bndr_names = collectPatBinders pat + bndr_names = collectPatBinders CollNoDictBinders pat (nosig_names, sig_names) = partitionWith find_sig bndr_names find_sig :: Name -> Either Name (Name, TcIdSigInfo) @@ -1657,7 +1672,7 @@ partial_sig_mrs = [ null theta | TcIdSig (PartialSig { psig_hs_ty = hs_ty }) - <- mapMaybe sig_fn (collectHsBindListBinders lbinds) + <- mapMaybe sig_fn (collectHsBindListBinders CollNoDictBinders lbinds) , let (L _ theta, _) = splitLHsQualTy (hsSigWcType hs_ty) ] has_partial_sigs = not (null partial_sig_mrs) @@ -1709,7 +1724,7 @@ in [(f, open_fvs)] bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs }) = let open_fvs = get_open_fvs fvs - in [(b, open_fvs) | b <- collectPatBinders pat] + in [(b, open_fvs) | b <- collectPatBinders CollNoDictBinders pat] bindFvs _ = [] diff --git a/compiler/GHC/Tc/Gen/Default.hs b/compiler/GHC/Tc/Gen/Default.hs --- a/compiler/GHC/Tc/Gen/Default.hs +++ b/compiler/GHC/Tc/Gen/Default.hs @@ -12,6 +12,8 @@ import GHC.Hs import GHC.Core.Class +import GHC.Core.Type ( typeKind ) +import GHC.Types.Var( tyVarKind ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.HsType @@ -82,13 +84,20 @@ ; return ty } check_instance :: Type -> Class -> TcM Bool - -- Check that ty is an instance of cls - -- We only care about whether it worked or not; return a boolean +-- Check that ty is an instance of cls +-- We only care about whether it worked or not; return a boolean +-- This checks that cls :: k -> Constraint +-- with just one argument and no polymorphism; if we need to add +-- polymorphism we can make it more complicated. For now we are +-- concerned with classes like +-- Num :: Type -> Constraint +-- Foldable :: (Type->Type) -> Constraint check_instance ty cls - = do { (_, success) <- discardErrs $ - askNoErrs $ - simplifyDefault [mkClassPred cls [ty]] - ; return success } + | [cls_tv] <- classTyVars cls + , tyVarKind cls_tv `tcEqType` typeKind ty + = simplifyDefault [mkClassPred cls [ty]] + | otherwise + = return False defaultDeclCtxt :: SDoc defaultDeclCtxt = text "When checking the types in a default declaration" diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -5,7 +5,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] - -- in module GHC.Hs.Extension + -- in module Language.Haskell.Syntax.Extension {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {- @@ -569,37 +569,45 @@ ************************************************************************ -} -tcExpr expr@(RecordCon { rcon_con_name = L loc con_name +tcExpr expr@(RecordCon { rcon_con = L loc con_name , rcon_flds = rbinds }) res_ty = do { con_like <- tcLookupConLike con_name - -- Check for missing fields - ; checkMissingFields con_like rbinds - ; (con_expr, con_sigma) <- tcInferId con_name ; (con_wrap, con_tau) <- topInstantiate orig con_sigma -- a shallow instantiation should really be enough for -- a data constructor. ; let arity = conLikeArity con_like Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau - ; case conLikeWrapId_maybe con_like of { - Nothing -> nonBidirectionalErr (conLikeName con_like) ; - Just con_id -> - do { rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds + ; checkTc (conLikeHasBuilder con_like) $ + nonBidirectionalErr (conLikeName con_like) + + ; rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds -- It is currently not possible for a record to have -- multiplicities. When they do, `tcRecordBinds` will take -- scaled types instead. Meanwhile, it's safe to take -- `scaledThing` above, as we know all the multiplicities are -- Many. - ; let rcon_tc = RecordConTc - { rcon_con_like = con_like - , rcon_con_expr = mkHsWrap con_wrap con_expr } + + ; let rcon_tc = mkHsWrap con_wrap con_expr expr' = RecordCon { rcon_ext = rcon_tc - , rcon_con_name = L loc con_id + , rcon_con = L loc con_like , rcon_flds = rbinds' } - ; tcWrapResultMono expr expr' actual_res_ty res_ty } } } + ; ret <- tcWrapResultMono expr expr' actual_res_ty res_ty + + -- Check for missing fields. We do this after type-checking to get + -- better types in error messages (cf #18869). For example: + -- data T a = MkT { x :: a, y :: a } + -- r = MkT { y = True } + -- Then we'd like to warn about a missing field `x :: True`, rather than `x :: a0`. + -- + -- NB: to do this really properly we should delay reporting until typechecking is complete, + -- via a new `HoleSort`. But that seems too much work. + ; checkMissingFields con_like rbinds arg_tys + + ; return ret } where orig = OccurrenceOf con_name @@ -826,8 +834,8 @@ -- Check that we're not dealing with a unidirectional pattern -- synonym - ; unless (isJust $ conLikeWrapId_maybe con1) - (nonBidirectionalErr (conLikeName con1)) + ; checkTc (conLikeHasBuilder con1) $ + nonBidirectionalErr (conLikeName con1) -- STEP 3 Note [Criteria for update] -- Check that each updated field is polymorphic; that is, its type @@ -1465,8 +1473,8 @@ field_lbl = occNameFS $ rdrNameOcc (unLoc lbl) -checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcM () -checkMissingFields con_like rbinds +checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM () +checkMissingFields con_like rbinds arg_tys | null field_labels -- Not declared as a record; -- But C{} is still valid if no strict fields = if any isBanged field_strs then @@ -1479,22 +1487,33 @@ (missingFields con_like [])) | otherwise = do -- A record - unless (null missing_s_fields) - (addErrTc (missingStrictFields con_like missing_s_fields)) + unless (null missing_s_fields) $ do + fs <- zonk_fields missing_s_fields + -- It is an error to omit a strict field, because + -- we can't substitute it with (error "Missing field f") + addErrTc (missingStrictFields con_like fs) warn <- woptM Opt_WarnMissingFields - when (warn && notNull missing_ns_fields) - (warnTc (Reason Opt_WarnMissingFields) True - (missingFields con_like missing_ns_fields)) + when (warn && notNull missing_ns_fields) $ do + fs <- zonk_fields missing_ns_fields + -- It is not an error (though we may want) to omit a + -- lazy field, because we can always use + -- (error "Missing field f") instead. + warnTc (Reason Opt_WarnMissingFields) True + (missingFields con_like fs) where + -- we zonk the fields to get better types in error messages (#18869) + zonk_fields fs = forM fs $ \(str,ty) -> do + ty' <- zonkTcType ty + return (str,ty') missing_s_fields - = [ flLabel fl | (fl, str) <- field_info, + = [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info, isBanged str, not (fl `elemField` field_names_used) ] missing_ns_fields - = [ flLabel fl | (fl, str) <- field_info, + = [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info, not (isBanged str), not (fl `elemField` field_names_used) ] @@ -1502,9 +1521,7 @@ field_names_used = hsRecFields rbinds field_labels = conLikeFieldLabels con_like - field_info = zipEqual "missingFields" - field_labels - field_strs + field_info = zip3 field_labels field_strs arg_tys field_strs = conLikeImplBangs con_like @@ -1627,25 +1644,29 @@ mixedSelectors _ _ = panic "GHC.Tc.Gen.Expr: mixedSelectors emptylists" -missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc +missingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc missingStrictFields con fields - = header <> rest + = vcat [header, nest 2 rest] where + pprField (f,ty) = ppr f <+> dcolon <+> ppr ty rest | null fields = Outputable.empty -- Happens for non-record constructors -- with strict fields - | otherwise = colon <+> pprWithCommas ppr fields + | otherwise = vcat (fmap pprField fields) header = text "Constructor" <+> quotes (ppr con) <+> - text "does not have the required strict field(s)" + text "does not have the required strict field(s)" <> + if null fields then Outputable.empty else colon -missingFields :: ConLike -> [FieldLabelString] -> SDoc +missingFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc missingFields con fields - = header <> rest + = vcat [header, nest 2 rest] where + pprField (f,ty) = ppr f <+> text "::" <+> ppr ty rest | null fields = Outputable.empty - | otherwise = colon <+> pprWithCommas ppr fields + | otherwise = vcat (fmap pprField fields) header = text "Fields of" <+> quotes (ppr con) <+> - text "not initialised" + text "not initialised" <> + if null fields then Outputable.empty else colon -- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args)) diff --git a/compiler/GHC/Tc/Gen/Expr.hs-boot b/compiler/GHC/Tc/Gen/Expr.hs-boot --- a/compiler/GHC/Tc/Gen/Expr.hs-boot +++ b/compiler/GHC/Tc/Gen/Expr.hs-boot @@ -5,7 +5,7 @@ import GHC.Tc.Types ( TcM ) import GHC.Tc.Types.Origin ( CtOrigin ) import GHC.Core.Type ( Mult ) -import GHC.Hs.Extension ( GhcRn, GhcTc ) +import GHC.Hs.Extension ( GhcRn, GhcTc ) tcCheckPolyExpr, tcCheckPolyExprNC :: LHsExpr GhcRn diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -659,9 +659,8 @@ = ApplyMR | otherwise = NoRestrictions - ; (qtvs, givens, ev_binds, residual, _) + ; (qtvs, givens, ev_binds, _) <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted - ; emitConstraints residual ; tau <- zonkTcType tau ; let inferred_theta = map evVarPred givens @@ -774,7 +773,7 @@ | Just (expr, ty) <- patSynBuilderOcc ps -> return (expr, ty) | otherwise - -> nonBidirectionalErr id_name + -> failWithTc (nonBidirectionalErr id_name) AGlobal (ATyCon ty_con) -> fail_tycon global_env ty_con @@ -856,10 +855,9 @@ | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl) | otherwise = return () -nonBidirectionalErr :: Outputable name => name -> TcM a -nonBidirectionalErr name = failWithTc $ - text "non-bidirectional pattern synonym" - <+> quotes (ppr name) <+> text "used in an expression" +nonBidirectionalErr :: Outputable name => name -> SDoc +nonBidirectionalErr name = text "non-bidirectional pattern synonym" + <+> quotes (ppr name) <+> text "used in an expression" {- Note [Linear fields generalization] diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -537,7 +537,8 @@ ; kvs <- kindGeneralizeAll ty1 -- "All" because it's a top-level type ; reportUnsolvedEqualities skol_info kvs tclvl wanted - ; final_ty <- zonkTcTypeToType (mkInfForAllTys kvs ty1) + ; ze <- mkEmptyZonkEnv NoFlexi + ; final_ty <- zonkTcTypeToTypeX ze (mkInfForAllTys kvs ty1) ; traceTc "tc_top_lhs_type }" (vcat [ppr sig_ty, ppr final_ty]) ; return final_ty } where @@ -679,6 +680,9 @@ ; let fun_ty = mkTyConApp fam_tc [] ; (fam_app, res_kind) <- tcInferTyApps mode lhs_fun fun_ty hs_pats + -- Hack alert: see Note [tcFamTyPats: zonking the result kind] + ; res_kind <- zonkTcType res_kind + ; traceTc "End tcFamTyPats }" $ vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ] @@ -687,6 +691,34 @@ fam_name = tyConName fam_tc fam_arity = tyConArity fam_tc lhs_fun = noLoc (HsTyVar noExtField NotPromoted (noLoc fam_name)) + +{- Note [tcFamTyPats: zonking the result kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#19250) + F :: forall k. k -> k + type instance F (x :: Constraint) = () + +The tricky point is this: + is that () an empty type tuple (() :: Type), or + an empty constraint tuple (() :: Constraint)? +We work this out in a hacky way, by looking at the expected kind: +see Note [Inferring tuple kinds]. + +In this case, we kind-check the RHS using the kind gotten from the LHS: +see the call to tcCheckLHsType in tcTyFamInstEqnGuts in GHC.Tc.Tycl. + +But we want the kind from the LHS to be /zonked/, so that when +kind-checking the RHS (tcCheckLHsType) we can "see" what we learned +from kind-checking the LHS (tcFamTyPats). In our example above, the +type of the LHS is just `kappa` (by instantiating the forall k), but +then we learn (from x::Constraint) that kappa ~ Constraint. We want +that info when kind-checking the RHS. + +Easy solution: just zonk that return kind. Of course this won't help +if there is lots of type-family reduction to do, but it works fine in +common cases. +-} + {- ************************************************************************ diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -65,6 +65,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Driver.Session ( getDynFlags ) import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Name @@ -395,7 +396,8 @@ tcGuardStmt :: TcExprStmtChecker tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside - = do { guard' <- tcCheckMonoExpr guard boolTy + = do { guard' <- tcScalingUsage Many $ tcCheckMonoExpr guard boolTy + -- Scale the guard to Many (see #19120 and #19193) ; thing <- thing_inside res_ty ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) } @@ -946,12 +948,12 @@ -- match can't fail (so the fail op is Nothing), however, it seems that the -- isIrrefutableHsPat test is still required here for some reason I haven't -- yet determined. -tcMonadFailOp orig pat fail_op res_ty - | isIrrefutableHsPat pat - = return Nothing - | otherwise - = Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy] - (mkCheckExpType res_ty) $ \_ _ -> return ()) +tcMonadFailOp orig pat fail_op res_ty = do + dflags <- getDynFlags + if isIrrefutableHsPat dflags pat + then return Nothing + else Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy] + (mkCheckExpType res_ty) $ \_ _ -> return ()) {- Note [Treat rebindable syntax first] @@ -1061,8 +1063,8 @@ ; return (ApplicativeArgMany x stmts' ret' pat' ctxt) } get_arg_bndrs :: ApplicativeArg GhcTc -> [Id] - get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat - get_arg_bndrs (ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat + get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders CollNoDictBinders pat + get_arg_bndrs (ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders CollNoDictBinders pat {- Note [ApplicativeDo and constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -410,13 +410,14 @@ -- These are /signatures/ so we zonk to squeeze out any kind -- unification variables. Do this after kindGeneralizeAll which may -- default kind variables to *. - ; (ze, kv_bndrs) <- zonkTyVarBinders (mkTyVarBinders InferredSpec kvs) - ; (ze, implicit_bndrs) <- zonkTyVarBindersX ze implicit_bndrs - ; (ze, univ_bndrs) <- zonkTyVarBindersX ze univ_bndrs - ; (ze, ex_bndrs) <- zonkTyVarBindersX ze ex_bndrs - ; req <- zonkTcTypesToTypesX ze req - ; prov <- zonkTcTypesToTypesX ze prov - ; body_ty <- zonkTcTypeToTypeX ze body_ty + ; ze <- mkEmptyZonkEnv NoFlexi + ; (ze, kv_bndrs) <- zonkTyVarBindersX ze (mkTyVarBinders InferredSpec kvs) + ; (ze, implicit_bndrs) <- zonkTyVarBindersX ze implicit_bndrs + ; (ze, univ_bndrs) <- zonkTyVarBindersX ze univ_bndrs + ; (ze, ex_bndrs) <- zonkTyVarBindersX ze ex_bndrs + ; req <- zonkTcTypesToTypesX ze req + ; prov <- zonkTcTypesToTypesX ze prov + ; body_ty <- zonkTcTypeToTypeX ze body_ty -- Now do validity checking ; checkValidType ctxt $ @@ -511,7 +512,7 @@ unification takes place, we'll find out when we do the final impedance-matching check in GHC.Tc.Gen.Bind.mkExport -See Note [Signature skolems] in GHC.Tc.Utils.TcType +See Note [TyVarTv] in GHC.Tc.Utils.TcMType None of this applies to a function binding with a complete signature, which doesn't use tcInstSig. See GHC.Tc.Gen.Bind.tcPolyCheck. 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 @@ -104,6 +104,7 @@ import GHC.Types.Var.Set import GHC.Types.Meta import GHC.Types.Basic hiding( SuccessFlag(..) ) +import GHC.Types.Error import GHC.Types.Fixity as Hs import GHC.Types.Annotations import GHC.Types.Name @@ -114,7 +115,6 @@ import GHC.Unit.Module.ModIface import GHC.Unit.Module.Deps -import GHC.Utils.Error import GHC.Utils.Misc import GHC.Utils.Panic as Panic import GHC.Utils.Lexeme @@ -122,7 +122,6 @@ import GHC.SysTools.FileCleanup ( newTempName, TempFileLifetime(..) ) -import GHC.Data.Bag import GHC.Data.FastString import GHC.Data.Maybe( MaybeErr(..) ) import qualified GHC.Data.EnumSet as EnumSet @@ -1153,7 +1152,7 @@ where checkTopDecl :: HsDecl GhcPs -> TcM () checkTopDecl (ValD _ binds) - = mapM_ bindName (collectHsBindBinders binds) + = mapM_ bindName (collectHsBindBinders CollNoDictBinders binds) checkTopDecl (SigD _ _) = return () checkTopDecl (AnnD _ _) @@ -1286,7 +1285,7 @@ -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. runRemoteTH :: IServInstance - -> [Messages] -- saved from nested calls to qRecover + -> [Messages ErrDoc] -- saved from nested calls to qRecover -> TcM () runRemoteTH iserv recovers = do THMsg msg <- liftIO $ readIServ iserv getTHMessage @@ -1298,15 +1297,15 @@ writeTcRef v emptyMessages runRemoteTH iserv (msgs : recovers) EndRecover caught_error -> do - let (prev_msgs@(prev_warns,prev_errs), rest) = case recovers of + let (prev_msgs, rest) = case recovers of [] -> panic "EndRecover" a : b -> (a,b) v <- getErrsVar - (warn_msgs,_) <- readTcRef v + warn_msgs <- getWarningMessages <$> readTcRef v -- keep the warnings only if there were no errors writeTcRef v $ if caught_error then prev_msgs - else (prev_warns `unionBags` warn_msgs, prev_errs) + else mkMessages warn_msgs `unionMessages` prev_msgs runRemoteTH iserv rest _other -> do r <- handleTHMessage msg diff --git a/compiler/GHC/Tc/Gen/Splice.hs-boot b/compiler/GHC/Tc/Gen/Splice.hs-boot --- a/compiler/GHC/Tc/Gen/Splice.hs-boot +++ b/compiler/GHC/Tc/Gen/Splice.hs-boot @@ -9,7 +9,7 @@ import GHC.Tc.Types( TcM , SpliceType ) import GHC.Tc.Utils.TcType ( ExpRhoType ) import GHC.Types.Annotations ( Annotation, CoreAnnTarget ) -import GHC.Hs.Extension ( GhcRn, GhcPs, GhcTc ) +import GHC.Hs.Extension ( GhcRn, GhcPs, GhcTc ) import GHC.Hs ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers ) diff --git a/compiler/GHC/Tc/Instance/FunDeps.hs b/compiler/GHC/Tc/Instance/FunDeps.hs --- a/compiler/GHC/Tc/Instance/FunDeps.hs +++ b/compiler/GHC/Tc/Instance/FunDeps.hs @@ -656,9 +656,7 @@ (ltys1, rtys1) = instFD fd cls_tvs tys1 (ltys2, rtys2) = instFD fd cls_tvs tys2 qtv_set2 = mkVarSet qtvs2 - bind_fn tv | tv `elemVarSet` qtv_set1 = BindMe - | tv `elemVarSet` qtv_set2 = BindMe - | otherwise = Skolem + bind_fn = matchBindFun (qtv_set1 `unionVarSet` qtv_set2) eq_inst i1 i2 = instanceDFunId i1 == instanceDFunId i2 -- A single instance may appear twice in the un-nubbed conflict list diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -60,7 +60,6 @@ import GHC.Tc.Utils.Unify( checkConstraints ) import GHC.Tc.Utils.Zonk import GHC.Tc.Gen.Expr -import GHC.Tc.Errors( reportAllUnsolved ) import GHC.Tc.Gen.App( tcInferSigma ) import GHC.Tc.Utils.Monad import GHC.Tc.Gen.Export @@ -130,6 +129,7 @@ import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Types.Error import GHC.Types.Name.Reader import GHC.Types.Fixity.Env import GHC.Types.Id as Id @@ -188,7 +188,7 @@ -> ModSummary -> Bool -- True <=> save renamed syntax -> HsParsedModule - -> IO (Messages, Maybe TcGblEnv) + -> IO (Messages ErrDoc, Maybe TcGblEnv) tcRnModule hsc_env mod_sum save_rn_syntax parsedModule@HsParsedModule {hpm_module= L loc this_module} @@ -202,13 +202,13 @@ tcRnModuleTcRnM hsc_env mod_sum parsedModule pair | otherwise - = return ((emptyBag, unitBag err_msg), Nothing) + = return (err_msg `addMessage` emptyMessages, Nothing) where hsc_src = ms_hsc_src mod_sum dflags = hsc_dflags hsc_env home_unit = hsc_home_unit hsc_env - err_msg = mkPlainErrMsg dflags loc $ + err_msg = mkPlainErrMsg loc $ text "Module does not have a RealSrcSpan:" <+> ppr this_mod pair :: (Module, SrcSpan) @@ -1494,7 +1494,7 @@ ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` greMangledName gre) emptyFVs fo_gres - ; sig_names = mkNameSet (collectHsValBinders hs_val_binds) + ; sig_names = mkNameSet (collectHsValBinders CollNoDictBinders hs_val_binds) `minusNameSet` getTypeSigNames val_sigs -- Extend the GblEnv with the (as yet un-zonked) @@ -1986,7 +1986,7 @@ ********************************************************* -} -runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a) +runTcInteractive :: HscEnv -> TcRn a -> IO (Messages ErrDoc, Maybe a) -- Initialise the tcg_inst_env with instances from all home modules. -- This mimics the more selective call to hptInstances in tcRnImports runTcInteractive hsc_env thing_inside @@ -2102,7 +2102,7 @@ -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound -- values, coerced to (). tcRnStmt :: HscEnv -> GhciLStmt GhcPs - -> IO (Messages, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) + -> IO (Messages ErrDoc, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) tcRnStmt hsc_env rdr_stmt = runTcInteractive hsc_env $ do { @@ -2364,8 +2364,8 @@ ; opt_pr_flag <- goptM Opt_PrintBindResult ; let print_result_plan | opt_pr_flag -- The flag says "print result" - , [v] <- collectLStmtBinders gi_stmt -- One binder - = [mk_print_result_plan gi_stmt v] + , [v] <- collectLStmtBinders CollNoDictBinders gi_stmt -- One binder + = [mk_print_result_plan gi_stmt v] | otherwise = [] -- The plans are: @@ -2415,7 +2415,7 @@ io_ret_ty = mkTyConApp ioTyCon [ret_ty] tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts (mkCheckExpType io_ret_ty) - names = collectLStmtsBinders stmts + names = collectLStmtsBinders CollNoDictBinders stmts -- OK, we're ready to typecheck the stmts ; traceTc "GHC.Tc.Module.tcGhciStmts: tc stmts" empty @@ -2482,7 +2482,7 @@ return (noLoc $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) -isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name) +isGHCiMonad :: HscEnv -> String -> IO (Messages ErrDoc, Maybe Name) isGHCiMonad hsc_env ty = runTcInteractive hsc_env $ do rdrEnv <- getGlobalRdrEnv @@ -2509,7 +2509,7 @@ tcRnExpr :: HscEnv -> TcRnExprMode -> LHsExpr GhcPs - -> IO (Messages, Maybe Type) + -> IO (Messages ErrDoc, Maybe Type) tcRnExpr hsc_env mode rdr_expr = runTcInteractive hsc_env $ do { @@ -2526,8 +2526,9 @@ -- Generalise uniq <- newUnique ; let { fresh_it = itName uniq (getLoc rdr_expr) } ; - (qtvs, dicts, _, residual, _) - <- simplifyInfer tclvl infer_mode + ((qtvs, dicts, _, _), residual) + <- captureConstraints $ + simplifyInfer tclvl infer_mode [] {- No sig vars -} [(fresh_it, res_ty)] lie ; @@ -2577,7 +2578,7 @@ -------------------------- tcRnImportDecls :: HscEnv -> [LImportDecl GhcPs] - -> IO (Messages, Maybe GlobalRdrEnv) + -> IO (Messages ErrDoc, Maybe GlobalRdrEnv) -- Find the new chunk of GlobalRdrEnv created by this list of import -- decls. In contract tcRnImports *extends* the TcGblEnv. tcRnImportDecls hsc_env import_decls @@ -2593,7 +2594,7 @@ -> ZonkFlexi -> Bool -- Normalise the returned type -> LHsType GhcPs - -> IO (Messages, Maybe (Type, Kind)) + -> IO (Messages ErrDoc, Maybe (Type, Kind)) tcRnType hsc_env flexi normalise rdr_type = runTcInteractive hsc_env $ setXOptM LangExt.PolyKinds $ -- See Note [Kind-generalise in tcRnType] @@ -2609,13 +2610,16 @@ -- It can have any rank or kind -- First bring into scope any wildcards ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_type]) - ; (_tclvl, wanted, (ty, kind)) - <- pushLevelAndSolveEqualitiesX "tcRnType" $ + ; ((ty, kind), wanted) + <- captureTopConstraints $ + pushTcLevelM_ $ bindNamedWildCardBinders wcs $ \ wcs' -> do { mapM_ emitNamedTypeHole wcs' ; tcInferLHsTypeUnsaturated rn_type } - ; checkNoErrs (reportAllUnsolved wanted) + -- Since all the wanteds are equalities, the returned bindings will be empty + ; empty_binds <- simplifyTop wanted + ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds ) -- Do kind generalisation; see Note [Kind-generalise in tcRnType] ; kvs <- kindGeneralizeAll kind @@ -2724,7 +2728,7 @@ tcRnDeclsi :: HscEnv -> [LHsDecl GhcPs] - -> IO (Messages, Maybe TcGblEnv) + -> IO (Messages ErrDoc, Maybe TcGblEnv) tcRnDeclsi hsc_env local_decls = runTcInteractive hsc_env $ tcRnSrcDecls False local_decls Nothing @@ -2749,13 +2753,13 @@ -- a package module with an interface on disk. If neither of these is -- true, then the result will be an error indicating the interface -- could not be found. -getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface) +getModuleInterface :: HscEnv -> Module -> IO (Messages ErrDoc, Maybe ModIface) getModuleInterface hsc_env mod = runTcInteractive hsc_env $ loadModuleInterface (text "getModuleInterface") mod tcRnLookupRdrName :: HscEnv -> Located RdrName - -> IO (Messages, Maybe [Name]) + -> IO (Messages ErrDoc, Maybe [Name]) -- ^ Find all the Names that this RdrName could mean, in GHCi tcRnLookupRdrName hsc_env (L loc rdr_name) = runTcInteractive hsc_env $ @@ -2769,7 +2773,7 @@ ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name))) ; return names } -tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing) +tcRnLookupName :: HscEnv -> Name -> IO (Messages ErrDoc, Maybe TyThing) tcRnLookupName hsc_env name = runTcInteractive hsc_env $ tcRnLookupName' name @@ -2788,7 +2792,7 @@ tcRnGetInfo :: HscEnv -> Name - -> IO ( Messages + -> IO ( Messages ErrDoc , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) -- Used to implement :info in GHCi @@ -3118,5 +3122,5 @@ recordUnsafeInfer pluginUnsafe where unsafeText = "Use of plugins makes the module unsafe" - pluginUnsafe = unitBag ( mkPlainWarnMsg dflags noSrcSpan + pluginUnsafe = unitBag ( mkPlainWarnMsg noSrcSpan (Outputable.text unsafeText) ) 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 @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} module GHC.Tc.Solver( - simplifyInfer, InferMode(..), + InferMode(..), simplifyInfer, findInferredDiff, growThetaTyVars, simplifyAmbiguityCheck, simplifyDefault, @@ -32,10 +32,10 @@ import GHC.Data.Bag import GHC.Core.Class ( Class, classKey, classTyCon ) import GHC.Driver.Session -import GHC.Types.Id ( idType ) import GHC.Tc.Utils.Instantiate import GHC.Data.List.SetOps import GHC.Types.Name +import GHC.Types.Id( idType ) import GHC.Utils.Outputable import GHC.Builtin.Utils import GHC.Builtin.Names @@ -60,7 +60,7 @@ import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Basic ( IntWithInf, intGtLimit ) -import GHC.Utils.Error ( emptyMessages ) +import GHC.Types.Error import qualified GHC.LanguageExtensions as LangExt import Control.Monad @@ -149,7 +149,7 @@ ; warnAllUnsolved $ emptyWC { wc_simple = unsafe_ol } - ; whyUnsafe <- fst <$> TcM.readTcRef errs_var + ; whyUnsafe <- getWarningMessages <$> TcM.readTcRef errs_var ; TcM.writeTcRef errs_var saved_msg ; recordUnsafeInfer whyUnsafe } @@ -218,7 +218,13 @@ ; traceTc "emitFlatConstraints {" (ppr wanted) ; case floatKindEqualities wanted of Nothing -> do { traceTc "emitFlatConstraints } failing" (ppr wanted) - ; emitConstraints wanted -- So they get reported! + -- Emit the bad constraints, wrapped in an implication + -- See Note [Wrapping failing kind equalities] + ; tclvl <- TcM.getTcLevel + ; implic <- buildTvImplication UnkSkol [] tclvl wanted + -- UnkSkol: doesn't matter, because + -- we bind no skolem varaibles here + ; emitImplication implic ; failM } Just (simples, holes) -> do { _ <- promoteTyVarSet (tyCoVarsOfCts simples) @@ -376,6 +382,40 @@ See also #18062, #11506 +Note [Wrapping failing kind equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In simplifyAndEmitFlatConstraints, if we fail to get down to simple +flat constraints we will +* re-emit the constraints so that they are reported +* fail in the monad +But there is a Terrible Danger that, if -fdefer-type-errors is on, and +we just re-emit an insoluble constraint like (* ~ (*->*)), that we'll +report only a warning and proceed with compilation. But if we ever fail +in the monad it should be fatal; we should report an error and stop after +the type checker. If not, chaos results: #19142. + +Our solution is this: +* Even with -fdefer-type-errors, inside an implication with no place for + value bindings (ic_binds = CoEvBindsVar), report failing equalities as + errors. We have to do this anyway; see GHC.Tc.Errors + Note [Failing equalities with no evidence bindings]. + +* Right here in simplifyAndEmitFlatConstraints, use buildTvImplication + to wrap the failing constraint in a degenerate implication (no + skolems, no theta, no bumped TcLevel), with ic_binds = CoEvBindsVar. + That way any failing equalities will lead to an error not a warning, + irrespective of -fdefer-type-errors. + + This is a slight hack, because the implication doesn't have a bumped + TcLevel, but that doesn't matter. + +We re-emit the implication rather than reporting the errors right now, +so that the error mesages are improved by other solving and defaulting. +e.g. we prefer + Cannot match 'Type->Type' with 'Type' +to Cannot match 'Type->Type' with 'TYPE r0' + + Note [floatKindEqualities vs approximateWC] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ floatKindEqualities and approximateWC are strikingly similar to each @@ -757,13 +797,12 @@ ------------------ simplifyDefault :: ThetaType -- Wanted; has no type variables in it - -> TcM () -- Succeeds if the constraint is soluble + -> TcM Bool -- Return if the constraint is soluble simplifyDefault theta = do { traceTc "simplifyDefault" empty ; wanteds <- newWanteds DefaultOrigin theta ; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds)) - ; reportAllUnsolved unsolved - ; return () } + ; return (isEmptyWC unsolved) } ------------------ tcCheckSatisfiability :: InertSet -> Bag EvVar -> TcM (Maybe InertSet) @@ -897,7 +936,6 @@ -> TcM ([TcTyVar], -- Quantify over these type variables [EvVar], -- ... and these constraints (fully zonked) TcEvBinds, -- ... binding these evidence variables - WantedConstraints, -- Redidual as-yet-unsolved constraints Bool) -- True <=> the residual constraints are insoluble simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds @@ -912,7 +950,7 @@ ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus) ; qtkvs <- quantifyTyVars dep_vars ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) - ; return (qtkvs, [], emptyTcEvBinds, emptyWC, False) } + ; return (qtkvs, [], emptyTcEvBinds, False) } | otherwise = do { traceTc "simplifyInfer {" $ vcat @@ -933,18 +971,13 @@ -- bindings, so we can't just revert to the input -- constraint. - ; tc_env <- TcM.getEnv - ; ev_binds_var <- TcM.newTcEvBinds - ; psig_theta_vars <- mapM TcM.newEvVar psig_theta + ; ev_binds_var <- TcM.newTcEvBinds + ; psig_evs <- newWanteds AnnOrigin psig_theta ; wanted_transformed_incl_derivs <- setTcLevel rhs_tclvl $ runTcSWithEvBinds ev_binds_var $ - do { let loc = mkGivenLoc rhs_tclvl UnkSkol $ - env_lcl tc_env - psig_givens = mkGivens loc psig_theta_vars - ; _ <- solveSimpleGivens psig_givens - -- See Note [Add signature contexts as givens] - ; solveWanteds wanteds } + solveWanteds (mkSimpleWC psig_evs `andWC` wanteds) + -- psig_evs : see Note [Add signature contexts as givens] -- Find quant_pred_candidates, the predicates that -- we'll consider quantifying over @@ -972,20 +1005,10 @@ quant_pred_candidates ; bound_theta_vars <- mapM TcM.newEvVar bound_theta - -- We must produce bindings for the psig_theta_vars, because we may have - -- used them in evidence bindings constructed by solveWanteds earlier - -- Easiest way to do this is to emit them as new Wanteds (#14643) - ; ct_loc <- getCtLocM AnnOrigin Nothing - ; let psig_wanted = [ CtWanted { ctev_pred = idType psig_theta_var - , ctev_dest = EvVarDest psig_theta_var - , ctev_nosh = WDeriv - , ctev_loc = ct_loc } - | psig_theta_var <- psig_theta_vars ] - - -- Now construct the residual constraint - ; residual_wanted <- mkResidualConstraints rhs_tclvl ev_binds_var + -- Now emit the residual constraint + ; emitResidualConstraints rhs_tclvl ev_binds_var name_taus co_vars qtvs bound_theta_vars - (wanted_transformed `andWC` mkSimpleWC psig_wanted) + wanted_transformed -- All done! ; traceTc "} simplifyInfer/produced residual implication for quantification" $ @@ -995,30 +1018,31 @@ , text "qtvs =" <+> ppr qtvs , text "definite_error =" <+> ppr definite_error ] - ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var - , residual_wanted, definite_error ) } + ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var, definite_error ) } -- NB: bound_theta_vars must be fully zonked where partial_sigs = filter isPartialSig sigs -------------------- -mkResidualConstraints :: TcLevel -> EvBindsVar - -> [(Name, TcTauType)] - -> VarSet -> [TcTyVar] -> [EvVar] - -> WantedConstraints -> TcM WantedConstraints +emitResidualConstraints :: TcLevel -> EvBindsVar + -> [(Name, TcTauType)] + -> VarSet -> [TcTyVar] -> [EvVar] + -> WantedConstraints -> TcM () -- Emit the remaining constraints from the RHS. --- See Note [Emitting the residual implication in simplifyInfer] -mkResidualConstraints rhs_tclvl ev_binds_var +emitResidualConstraints rhs_tclvl ev_binds_var name_taus co_vars qtvs full_theta_vars wanteds | isEmptyWC wanteds - = return wanteds + = return () | otherwise = do { wanted_simple <- TcM.zonkSimples (wc_simple wanteds) ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple is_mono ct = isWantedCt ct && ctEvId ct `elemVarSet` co_vars + -- Reason for the partition: + -- see Note [Emitting the residual implication in simplifyInfer] - ; _ <- TcM.promoteTyVarSet (tyCoVarsOfCts outer_simple) +-- Already done by defaultTyVarsAndSimplify +-- ; _ <- TcM.promoteTyVarSet (tyCoVarsOfCts outer_simple) ; let inner_wanted = wanteds { wc_simple = inner_simple } ; implics <- if isEmptyWC inner_wanted @@ -1033,21 +1057,50 @@ , ic_given_eqs = MaybeGivenEqs , ic_info = skol_info } - ; return (emptyWC { wc_simple = outer_simple - , wc_impl = implics })} + ; emitConstraints (emptyWC { wc_simple = outer_simple + , wc_impl = implics }) } where full_theta = map idType full_theta_vars - skol_info = InferSkol [ (name, mkSigmaTy [] full_theta ty) - | (name, ty) <- name_taus ] - -- Don't add the quantified variables here, because - -- they are also bound in ic_skols and we want them - -- to be tidied uniformly + skol_info = InferSkol [ (name, mkSigmaTy [] full_theta ty) + | (name, ty) <- name_taus ] + -- We don't add the quantified variables here, because they are + -- also bound in ic_skols and we want them to be tidied + -- uniformly. -------------------- ctsPreds :: Cts -> [PredType] ctsPreds cts = [ ctEvPred ev | ct <- bagToList cts , let ev = ctEvidence ct ] +findInferredDiff :: TcThetaType -> TcThetaType -> TcM TcThetaType +findInferredDiff annotated_theta inferred_theta + = pushTcLevelM_ $ + do { lcl_env <- TcM.getLclEnv + ; given_ids <- mapM TcM.newEvVar annotated_theta + ; wanteds <- newWanteds AnnOrigin inferred_theta + ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env + given_cts = mkGivens given_loc given_ids + + ; residual <- runTcSDeriveds $ + do { _ <- solveSimpleGivens given_cts + ; solveSimpleWanteds (listToBag (map mkNonCanonical wanteds)) } + -- NB: There are no meta tyvars fromn this level annotated_theta + -- because we have either promoted them or unified them + -- See `Note [Quantification and partial signatures]` Wrinkle 2 + + ; return (map (box_pred . ctPred) $ + bagToList $ + wc_simple residual) } + where + box_pred :: PredType -> PredType + box_pred pred = case classifyPredType pred of + EqPred rel ty1 ty2 + | Just (cls,tys) <- boxEqPred rel ty1 ty2 + -> mkClassPred cls tys + | otherwise + -> pprPanic "findInferredDiff" (ppr pred) + _other -> pred + {- Note [Emitting the residual implication in simplifyInfer] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -1074,32 +1127,31 @@ All rather subtle; see #14584. -Note [Add signature contexts as givens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Add signature contexts as wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this (#11016): f2 :: (?x :: Int) => _ f2 = ?x + or this - f3 :: a ~ Bool => (a, _) - f3 = (True, False) -or theis - f4 :: (Ord a, _) => a -> Bool - f4 x = x==x + class C a b | a -> b + g :: C p q => p -> q + f3 :: C Int b => _ + f3 = g (3::Int) We'll use plan InferGen because there are holes in the type. But: * For f2 we want to have the (?x :: Int) constraint floating around so that the functional dependencies kick in. Otherwise the occurrence of ?x on the RHS produces constraint (?x :: alpha), and we won't unify alpha:=Int. - * For f3 we want the (a ~ Bool) available to solve the wanted (a ~ Bool) - in the RHS - * For f4 we want to use the (Ord a) in the signature to solve the Eq a - constraint. -Solution: in simplifyInfer, just before simplifying the constraints -gathered from the RHS, add Given constraints for the context of any -type signatures. + * For f3 want the (C Int b) constraint from the partial signature + to meet the (C Int beta) constraint we get from the call to g; again, + fundeps +Solution: in simplifyInfer, we add the constraints from the signature +as extra Wanteds + ************************************************************************ * * Quantification @@ -1181,12 +1233,15 @@ ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs) ; let quantifiable_candidates = pickQuantifiablePreds (mkVarSet qtvs) candidates - -- NB: do /not/ run pickQuantifiablePreds over psig_theta, - -- because we always want to quantify over psig_theta, and not - -- drop any of them; e.g. CallStack constraints. c.f #14658 theta = mkMinimalBySCs id $ -- See Note [Minimize by Superclasses] - (psig_theta ++ quantifiable_candidates) + psig_theta ++ quantifiable_candidates + -- NB: add psig_theta back in here, even though it's already + -- part of candidates, because we always want to quantify over + -- psig_theta, and pickQuantifiableCandidates might have + -- dropped some e.g. CallStack constraints. c.f #14658 + -- equalities (a ~ Bool) + -- Remember, this is the theta for the residual constraint ; traceTc "decideQuantification" (vcat [ text "infer_mode:" <+> ppr infer_mode @@ -2123,13 +2178,13 @@ type family Head (xs :: [k]) where Head (x ': xs) = x GHC correctly infers that the extra-constraints wildcard on `bar` -should be (Head rngs ~ '(r, r'), Foo rngs). It then adds this constraint -as a Given on the implication constraint for `bar`. (This implication is -created by mkResidualConstraints in simplifyInfer.) The Hole for -the _ is stored within the implication's WantedConstraints. -When simplifyHoles is called, that constraint is already assumed as -a Given. Simplifying with respect to it turns it into -('(r, r') ~ '(r, r'), Foo rngs), which is disastrous. +should be (Head rngs ~ '(r, r'), Foo rngs). It then adds this +constraint as a Given on the implication constraint for `bar`. (This +implication is emitted by emitResidualConstraints.) The Hole for the _ +is stored within the implication's WantedConstraints. When +simplifyHoles is called, that constraint is already assumed as a +Given. Simplifying with respect to it turns it into ('(r, r') ~ '(r, +r'), Foo rngs), which is disastrous. Furthermore, there is no need to simplify here: extra-constraints wildcards are filled in with the output of the solver, in chooseInferredQuantifiers 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 @@ -2378,8 +2378,9 @@ process [G] alpha[1] ~ Int, we don't have any given-equalities in the inert set, and hence there are no given equalities to make alpha untouchable. -(NB: if it were alpha[2] ~ Int, this argument wouldn't hold. But that -almost never happens, and will never happen at all if we cure #18929.) +NB: if it were alpha[2] ~ Int, this argument wouldn't hold. But that +never happens: invariant (GivenInv) in Note [TcLevel invariants] +in GHC.Tc.Utils.TcType. Simple solution: never unify in Givens! -} diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs --- a/compiler/GHC/Tc/Solver/Interact.hs +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, MultiWayIf #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -2151,7 +2151,7 @@ - natural numbers - Typeable -* See also Note [What might match later?] in GHC.Tc.Solver.Monad. +* See also Note [What might equal later?] in GHC.Tc.Solver.Monad. * The given-overlap problem is arguably not easy to appear in practice due to our aggressive prioritization of equality solving over other @@ -2263,8 +2263,8 @@ -- Look up the predicate in Given quantified constraints, -- which are effectively just local instance declarations. matchLocalInst pred loc - = do { ics <- getInertCans - ; case match_local_inst (inert_insts ics) of + = do { inerts@(IS { inert_cans = ics }) <- getTcSInerts + ; case match_local_inst inerts (inert_insts ics) of ([], False) -> do { traceTcS "No local instance for" (ppr pred) ; return NoInstance } ([(dfun_ev, inst_tys)], unifs) @@ -2281,14 +2281,15 @@ where pred_tv_set = tyCoVarsOfType pred - match_local_inst :: [QCInst] + match_local_inst :: InertSet + -> [QCInst] -> ( [(CtEvidence, [DFunInstType])] , Bool ) -- True <=> Some unify but do not match - match_local_inst [] + match_local_inst _inerts [] = ([], False) - match_local_inst (qci@(QCI { qci_tvs = qtvs, qci_pred = qpred + match_local_inst inerts (qci@(QCI { qci_tvs = qtvs, qci_pred = qpred , qci_ev = ev }) - : qcis) + : qcis) | let in_scope = mkInScopeSet (qtv_set `unionVarSet` pred_tv_set) , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope) emptyTvSubstEnv qpred pred @@ -2303,5 +2304,5 @@ (matches, unif || this_unif) where qtv_set = mkVarSet qtvs - this_unif = mightMatchLater qpred (ctEvLoc ev) pred loc - (matches, unif) = match_local_inst qcis + this_unif = mightEqualLater inerts qpred (ctEvLoc ev) pred loc + (matches, unif) = match_local_inst inerts qcis diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -63,7 +63,7 @@ getInertEqs, getInertCans, getInertGivens, getInertInsols, getInnermostGivenEqLevel, getTcSInerts, setTcSInerts, - matchableGivens, prohibitedSuperClassSolve, mightMatchLater, + matchableGivens, prohibitedSuperClassSolve, mightEqualLater, getUnsolvedInerts, removeInertCts, getPendingGivenScs, addInertCan, insertFunEq, addInertForAll, @@ -2032,7 +2032,19 @@ inert_solved_funeqs optimistically. But when we lookup we have to take the substitution into account +NB: we could in principle avoid kick-out: + a) When unifying a meta-tyvar from an outer level, because + then the entire implication will be iterated; see + Note [The Unification Level Flag] + b) For Givens, after a unification. By (GivenInv) in GHC.Tc.Utils.TcType + Note [TcLevel invariants], a Given can't include a meta-tyvar from + its own level, so it falls under (a). Of course, we must still + kick out Givens when adding a new non-unificaiton Given. + +But kicking out more vigorously may lead to earlier unification and fewer +iterations, so we don't take advantage of these possibilities. + Note [Rewrite insolubles] ~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have an insoluble alpha ~ [alpha], which is insoluble @@ -2296,11 +2308,13 @@ -- True of a type variable that comes from a -- shallower level than the ambient level (tclvl) isOuterTyVar tclvl tv - | isTyVar tv = tclvl `strictlyDeeperThan` tcTyVarLevel tv - || isPromotableMetaTyVar tv - -- isPromotable: a meta-tv alpha[3] may end up unifying with skolem b[2], - -- so treat it as an "outer" var, even at level 3. - -- This will become redundant after fixing #18929. + | isTyVar tv = ASSERT2( not (isTouchableMetaTyVar tclvl tv), ppr tv <+> ppr tclvl ) + tclvl `strictlyDeeperThan` tcTyVarLevel tv + -- ASSERT: we are dealing with Givens here, and invariant (GivenInv) from + -- Note Note [TcLevel invariants] in GHC.Tc.Utils.TcType ensures that there can't + -- be a touchable meta tyvar. If this wasn't true, you might worry that, + -- at level 3, a meta-tv alpha[3] gets unified with skolem b[2], and thereby + -- becomes "outer" even though its level numbers says it isn't. | otherwise = False -- Coercion variables; doesn't much matter -- | Returns Given constraints that might, @@ -2308,7 +2322,7 @@ -- Given might overlap with an instance. See Note [Instance and Given overlap] -- in "GHC.Tc.Solver.Interact" matchableGivens :: CtLoc -> PredType -> InertSet -> Cts -matchableGivens loc_w pred_w (IS { inert_cans = inert_cans }) +matchableGivens loc_w pred_w inerts@(IS { inert_cans = inert_cans }) = filterBag matchable_given all_relevant_givens where -- just look in class constraints and irreds. matchableGivens does get called @@ -2326,51 +2340,82 @@ matchable_given :: Ct -> Bool matchable_given ct | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct - = mightMatchLater pred_g loc_g pred_w loc_w + = mightEqualLater inerts pred_g loc_g pred_w loc_w | otherwise = False -mightMatchLater :: TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool --- See Note [What might match later?] -mightMatchLater given_pred given_loc wanted_pred wanted_loc +mightEqualLater :: InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool +-- See Note [What might equal later?] +-- Used to implement logic in Note [Instance and Given overlap] in GHC.Tc.Solver.Interact +mightEqualLater (IS { inert_cycle_breakers = cbvs }) + given_pred given_loc wanted_pred wanted_loc | prohibitedSuperClassSolve given_loc wanted_loc = False - | SurelyApart <- tcUnifyTysFG bind_meta_tv [flattened_given] [flattened_wanted] - = False - | otherwise - = True -- safe answer + = case tcUnifyTysFG bind_fun [flattened_given] [flattened_wanted] of + SurelyApart -> False -- types that are surely apart do not equal later + MaybeApart MARInfinite _ -> False -- see Example 7 in the Note. + _ -> True + where in_scope = mkInScopeSet $ tyCoVarsOfTypes [given_pred, wanted_pred] -- NB: flatten both at the same time, so that we can share mappings -- from type family applications to variables, and also to guarantee -- that the fresh variables are really fresh between the given and - -- the wanted. + -- the wanted. Flattening both at the same time is needed to get + -- Example 10 from the Note. ([flattened_given, flattened_wanted], var_mapping) = flattenTysX in_scope [given_pred, wanted_pred] - bind_meta_tv :: TcTyVar -> BindFlag - -- Any meta tyvar may be unified later, so we treat it as - -- bindable when unifying with givens. That ensures that we - -- conservatively assume that a meta tyvar might get unified with - -- something that matches the 'given', until demonstrated - -- otherwise. More info in Note [Instance and Given overlap] - -- in GHC.Tc.Solver.Interact - bind_meta_tv tv | is_meta_tv tv = BindMe + bind_fun :: BindFun + bind_fun tv rhs_ty + | isMetaTyVar tv + , can_unify tv (metaTyVarInfo tv) rhs_ty + -- this checks for CycleBreakerTvs and TyVarTvs; forgetting + -- the latter was #19106. + = BindMe - | Just (_fam_tc, fam_args) <- lookupVarEnv var_mapping tv - , anyFreeVarsOfTypes is_meta_tv fam_args - = BindMe + -- See Examples 4, 5, and 6 from the Note + | Just (_fam_tc, fam_args) <- lookupVarEnv var_mapping tv + , anyFreeVarsOfTypes mentions_meta_ty_var fam_args + = BindMe - | otherwise = Skolem + | otherwise + = Apart - -- CycleBreakerTvs really stands for a type family application in - -- a given; these won't contain touchable meta-variables - is_meta_tv = isMetaTyVar <&&> not . isCycleBreakerTyVar + -- True for TauTv and TyVarTv (and RuntimeUnkTv) meta-tyvars + -- (as they can be unified) + -- and also for CycleBreakerTvs that mentions meta-tyvars + mentions_meta_ty_var :: TyVar -> Bool + mentions_meta_ty_var tv + | isMetaTyVar tv + = case metaTyVarInfo tv of + -- See Examples 8 and 9 in the Note + CycleBreakerTv + | Just tyfam_app <- lookup tv cbvs + -> anyFreeVarsOfType mentions_meta_ty_var tyfam_app + | otherwise + -> pprPanic "mightEqualLater finds an unbound cbv" (ppr tv $$ ppr cbvs) + _ -> True + | otherwise + = False + -- like canSolveByUnification, but allows cbv variables to unify + can_unify :: TcTyVar -> MetaInfo -> Type -> Bool + can_unify _lhs_tv TyVarTv rhs_ty -- see Example 3 from the Note + | Just rhs_tv <- tcGetTyVar_maybe rhs_ty + = case tcTyVarDetails rhs_tv of + MetaTv { mtv_info = TyVarTv } -> True + MetaTv {} -> False -- could unify with anything + SkolemTv {} -> True + RuntimeUnk -> True + | otherwise -- not a var on the RHS + = False + can_unify lhs_tv _other _rhs_ty = mentions_meta_ty_var lhs_tv + prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance prohibitedSuperClassSolve from_loc solve_loc @@ -2387,54 +2432,90 @@ only float equalities with a meta-tyvar on the left, so we only pull those out here. -Note [What might match later?] +Note [What might equal later?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must determine whether a Given might later match a Wanted. We +We must determine whether a Given might later equal a Wanted. We definitely need to account for the possibility that any metavariable -in the Wanted might be arbitrarily instantiated. We do *not* want -to allow skolems in the Given to be instantiated. But what about -type family applications? (Examples are below the explanation.) +might be arbitrarily instantiated. Yet we do *not* want +to allow skolems in to be instantiated, as we've already rewritten +with respect to any Givens. (We're solving a Wanted here, and so +all Givens have already been processed.) -To allow flexibility in how type family applications unify we use -the Core flattener. See -Note [Flattening type-family applications when matching instances] in GHC.Core.Unify. -The Core flattener replaces all type family applications with -fresh variables. The next question: should we allow these fresh -variables in the domain of a unifying substitution? +This is best understood by example. -A type family application that mentions only skolems is settled: any -skolems would have been rewritten w.r.t. Givens by now. These type -family applications match only themselves. A type family application -that mentions metavariables, on the other hand, can match anything. -So, if the original type family application contains a metavariable, -we use BindMe to tell the unifier to allow it in the substitution. -On the other hand, a type family application with only skolems is -considered rigid. +1. C alpha ~? C Int -Examples: - [G] C a - [W] C alpha - This easily might match later. + That given certainly might match later. - [G] C a - [W] C (F alpha) - This might match later, too, but we need to flatten the (F alpha) - to a fresh variable so that the unifier can connect the two. +2. C a ~? C Int - [G] C (F alpha) - [W] C a - This also might match later. Again, we will need to flatten to - find this out. (Surprised about a metavariable in a Given? See - #18929.) + No. No new givens are going to arise that will get the `a` to rewrite + to Int. - [G] C (F a) - [W] C a - This won't match later. We're not going to get new Givens that - can inform the F a, and so this is a no-go. +3. C alpha[tv] ~? C Int + That alpha[tv] is a TyVarTv, unifiable only with other type variables. + It cannot equal later. + +4. C (F alpha) ~? C Int + + Sure -- that can equal later, if we learn something useful about alpha. + +5. C (F alpha[tv]) ~? C Int + + This, too, might equal later. Perhaps we have [G] F b ~ Int elsewhere. + Or maybe we have C (F alpha[tv] beta[tv]), these unify with each other, + and F x x = Int. Remember: returning True doesn't commit ourselves to + anything. + +6. C (F a) ~? C a + + No, this won't match later. If we could rewrite (F a) or a, we would + have by now. + +7. C (Maybe alpha) ~? C alpha + + We say this cannot equal later, because it would require + alpha := Maybe (Maybe (Maybe ...)). While such a type can be contrived, + we choose not to worry about it. See Note [Infinitary substitution in lookup] + in GHC.Core.InstEnv. Getting this wrong let to #19107, tested in + typecheck/should_compile/T19107. + +8. C cbv ~? C Int + where cbv = F a + + The cbv is a cycle-breaker var which stands for F a. See + Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical. + This is just like case 6, and we say "no". Saying "no" here is + essential in getting the parser to type-check, with its use of DisambECP. + +9. C cbv ~? C Int + where cbv = F alpha + + Here, we might indeed equal later. Distinguishing between + this case and Example 8 is why we need the InertSet in mightEqualLater. + +10. C (F alpha, Int) ~? C (Bool, F alpha) + + This cannot equal later, because F a would have to equal both Bool and + Int. + +To deal with type family applications, we use the Core flattener. See +Note [Flattening type-family applications when matching instances] in GHC.Core.Unify. +The Core flattener replaces all type family applications with +fresh variables. The next question: should we allow these fresh +variables in the domain of a unifying substitution? + +A type family application that mentions only skolems (example 6) is settled: +any skolems would have been rewritten w.r.t. Givens by now. These type family +applications match only themselves. A type family application that mentions +metavariables, on the other hand, can match anything. So, if the original type +family application contains a metavariable, we use BindMe to tell the unifier +to allow it in the substitution. On the other hand, a type family application +with only skolems is considered rigid. + This treatment fixes #18910 and is tested in typecheck/should_compile/InstanceGivenOverlap{,2} - -} removeInertCts :: [Ct] -> InertCans -> InertCans diff --git a/compiler/GHC/Tc/Solver/Rewrite.hs b/compiler/GHC/Tc/Solver/Rewrite.hs --- a/compiler/GHC/Tc/Solver/Rewrite.hs +++ b/compiler/GHC/Tc/Solver/Rewrite.hs @@ -662,7 +662,7 @@ tys } where - (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki -- "RAE" fix + (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki fvs = tyCoVarsOfType ki {-# INLINE rewrite_vector #-} diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -96,7 +96,7 @@ import Control.Monad import Data.Function ( on ) import Data.Functor.Identity -import Data.List +import Data.List (nubBy, partition) import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.Set as Set import Data.Tuple( swap ) @@ -887,10 +887,10 @@ -- Step 3: Final zonk (following kind generalisation) -- See Note [Swizzling the tyvars before generaliseTcTyCon] - ; ze <- emptyZonkEnv - ; (ze, inferred) <- zonkTyBndrsX ze inferred - ; (ze, sorted_spec_tvs) <- zonkTyBndrsX ze sorted_spec_tvs - ; (ze, req_tvs) <- zonkTyBndrsX ze req_tvs + ; ze <- mkEmptyZonkEnv NoFlexi + ; (ze, inferred) <- zonkTyBndrsX ze inferred + ; (ze, sorted_spec_tvs) <- zonkTyBndrsX ze sorted_spec_tvs + ; (ze, req_tvs) <- zonkTyBndrsX ze req_tvs ; tc_res_kind <- zonkTcTypeToTypeX ze tc_res_kind ; traceTc "generaliseTcTyCon: post zonk" $ @@ -1083,7 +1083,7 @@ These unification variables - Are TyVarTvs: that is, unification variables that can unify only with other type variables. - See Note [Signature skolems] in GHC.Tc.Utils.TcType + See Note [TyVarTv] in GHC.Tc.Utils.TcMType - Have complete fresh Names; see GHC.Tc.Utils.TcMType Note [Unification variables need fresh Names] @@ -2346,13 +2346,24 @@ ; at_stuff <- tcClassATs class_name clas ats at_defs ; return (ctxt, fds, sig_stuff, at_stuff) } + -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType + -- Example: (typecheck/should_fail/T17562) + -- type C :: Type -> Type -> Constraint + -- class (forall a. a b ~ a c) => C b c + -- The kind of `a` is unconstrained. + ; dvs <- candidateQTyVarsOfTypes ctxt + ; let mk_doc tidy_env = do { (tidy_env2, ctxt) <- zonkTidyTcTypes tidy_env ctxt + ; return ( tidy_env2 + , sep [ text "the class context:" + , pprTheta ctxt ] ) } + ; doNotQuantifyTyVars dvs mk_doc -- The pushLevelAndSolveEqualities will report errors for any -- unsolved equalities, so these zonks should not encounter -- any unfilled coercion variables unless there is such an error -- The zonk also squeeze out the TcTyCons, and converts -- Skolems to tyvars. - ; ze <- emptyZonkEnv + ; ze <- mkEmptyZonkEnv NoFlexi ; ctxt <- zonkTcTypesToTypesX ze ctxt ; sig_stuff <- mapM (zonkTcMethInfoToMethInfoX ze) sig_stuff -- ToDo: do we need to zonk at_stuff? @@ -2739,7 +2750,20 @@ ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) ; rhs_ty <- pushLevelAndSolveEqualities skol_info (binderVars binders) $ tcCheckLHsType hs_ty (TheKind res_kind) - ; rhs_ty <- zonkTcTypeToType rhs_ty + + -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType + -- Example: (typecheck/should_fail/T17567) + -- type T = forall a. Proxy a + -- The kind of `a` is unconstrained. + ; dvs <- candidateQTyVarsOfType rhs_ty + ; let mk_doc tidy_env = do { (tidy_env2, rhs_ty) <- zonkTidyTcType tidy_env rhs_ty + ; return ( tidy_env2 + , sep [ text "the type synonym right-hand side:" + , ppr rhs_ty ] ) } + ; doNotQuantifyTyVars dvs mk_doc + + ; ze <- mkEmptyZonkEnv NoFlexi + ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty ; let roles = roles_info tc_name ; return (buildSynTyCon tc_name binders res_kind roles rhs_ty) } where @@ -2776,10 +2800,24 @@ ; let skol_tvs = binderVars tycon_binders ; stupid_tc_theta <- pushLevelAndSolveEqualities skol_info skol_tvs $ tcHsContext ctxt - ; stupid_theta <- zonkTcTypesToTypes stupid_tc_theta - ; kind_signatures <- xoptM LangExt.KindSignatures - -- Check that we don't use kind signatures without Glasgow extensions + -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType + -- Example: (typecheck/should_fail/T17567StupidTheta) + -- data (forall a. a b ~ a c) => T b c + -- The kind of 'a' is unconstrained. + ; dvs <- candidateQTyVarsOfTypes stupid_tc_theta + ; let mk_doc tidy_env + = do { (tidy_env2, theta) <- zonkTidyTcTypes tidy_env stupid_tc_theta + ; return ( tidy_env2 + , sep [ text "the datatype context:" + , pprTheta theta ] ) } + ; doNotQuantifyTyVars dvs mk_doc + + ; ze <- mkEmptyZonkEnv NoFlexi + ; stupid_theta <- zonkTcTypesToTypesX ze stupid_tc_theta + + -- Check that we don't use kind signatures without the extension + ; kind_signatures <- xoptM LangExt.KindSignatures ; when (isJust mb_ksig) $ checkTc (kind_signatures) (badSigTyDecl tc_name) @@ -3016,7 +3054,18 @@ , text "lhs_ty" <+> ppr lhs_ty , text "qtvs" <+> pprTyVars qtvs ] - ; (ze, qtvs) <- zonkTyBndrs qtvs + -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType + -- Example: typecheck/should_fail/T17301 + ; dvs_rhs <- candidateQTyVarsOfType rhs_ty + ; let mk_doc tidy_env + = do { (tidy_env2, rhs_ty) <- zonkTidyTcType tidy_env rhs_ty + ; return ( tidy_env2 + , sep [ text "type family equation right-hand side:" + , ppr rhs_ty ] ) } + ; doNotQuantifyTyVars dvs_rhs mk_doc + + ; ze <- mkEmptyZonkEnv NoFlexi + ; (ze, qtvs) <- zonkTyBndrsX ze qtvs ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty @@ -3283,10 +3332,11 @@ -- See test dependent/should_fail/T13780a -- Zonk to Types - ; (ze, qkvs) <- zonkTyBndrs kvs - ; (ze, user_qtvbndrs) <- zonkTyVarBindersX ze exp_tvbndrs + ; ze <- mkEmptyZonkEnv NoFlexi + ; (ze, qkvs) <- zonkTyBndrsX ze kvs + ; (ze, user_qtvbndrs) <- zonkTyVarBindersX ze exp_tvbndrs ; arg_tys <- zonkScaledTcTypesToTypesX ze arg_tys - ; ctxt <- zonkTcTypesToTypesX ze ctxt + ; ctxt <- zonkTcTypesToTypesX ze ctxt -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls) @@ -3368,10 +3418,11 @@ ; let tvbndrs = mkTyVarBinders InferredSpec tkvs ++ outer_tv_bndrs -- Zonk to Types - ; (ze, tvbndrs) <- zonkTyVarBinders tvbndrs + ; ze <- mkEmptyZonkEnv NoFlexi + ; (ze, tvbndrs) <- zonkTyVarBindersX ze tvbndrs ; arg_tys <- zonkScaledTcTypesToTypesX ze arg_tys - ; ctxt <- zonkTcTypesToTypesX ze ctxt - ; res_ty <- zonkTcTypeToTypeX ze res_ty + ; ctxt <- zonkTcTypesToTypesX ze ctxt + ; res_ty <- zonkTcTypeToTypeX ze res_ty ; let res_tmpl = mkDDHeaderTy dd_info rep_tycon tc_bndrs (univ_tvs, ex_tvs, tvbndrs', eq_preds, arg_subst) diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs --- a/compiler/GHC/Tc/TyCl/Build.hs +++ b/compiler/GHC/Tc/TyCl/Build.hs @@ -33,7 +33,6 @@ import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.Type -import GHC.Types.Id import GHC.Types.SourceText import GHC.Tc.Utils.TcType import GHC.Core.Multiplicity @@ -171,7 +170,7 @@ ------------------------------------------------------ buildPatSyn :: Name -> Bool - -> (Id,Bool) -> Maybe (Id, Bool) + -> PatSynMatcher -> PatSynBuilder -> ([InvisTVBinder], ThetaType) -- ^ Univ and req -> ([InvisTVBinder], ThetaType) -- ^ Ex and prov -> [Type] -- ^ Argument types @@ -179,7 +178,7 @@ -> [FieldLabel] -- ^ Field labels for -- a record pattern synonym -> PatSyn -buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder +buildPatSyn src_name declared_infix matcher@(_, matcher_ty,_) builder (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys pat_ty field_labels = -- The assertion checks that the matcher is @@ -202,7 +201,7 @@ arg_tys pat_ty matcher builder field_labels where - ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id + ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ matcher_ty ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy (scaledThing cont_sigma) (arg_tys1, _) = (tcSplitFunTys cont_tau) 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 @@ -912,9 +912,10 @@ ; reportUnsolvedEqualities FamInstSkol qtvs tclvl wanted -- Zonk the patterns etc into the Type world - ; (ze, qtvs) <- zonkTyBndrs qtvs - ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty - ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta + ; ze <- mkEmptyZonkEnv NoFlexi + ; (ze, qtvs) <- zonkTyBndrsX ze qtvs + ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty + ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta ; master_res_kind <- zonkTcTypeToTypeX ze master_res_kind ; instance_res_kind <- zonkTcTypeToTypeX ze instance_res_kind @@ -1152,9 +1153,9 @@ ; let dm_binds = unionManyBags dm_binds_s -- (b) instance declarations - ; let dm_ids = collectHsBindsBinders dm_binds + ; let dm_ids = collectHsBindsBinders CollNoDictBinders dm_binds -- Add the default method Ids (again) - -- (they were arready added in GHC.Tc.TyCl.Utils.tcAddImplicits) + -- (they were already added in GHC.Tc.TyCl.Utils.tcAddImplicits) -- See Note [Default methods in the type environment] ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $ mapM tcInstDecl2 inst_decls 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 @@ -26,7 +26,7 @@ import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType ) import GHC.Core.TyCo.Subst( extendTvSubstWithClone ) import GHC.Tc.Utils.Monad -import GHC.Tc.Gen.Sig( emptyPragEnv, completeSigFromId ) +import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv, addInlinePrags ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.Zonk @@ -61,6 +61,7 @@ import GHC.Data.Bag import GHC.Utils.Misc import GHC.Utils.Error +import GHC.Driver.Session ( getDynFlags ) import Data.Maybe( mapMaybe ) import Control.Monad ( zipWithM ) import Data.List( partition, mapAccumL ) @@ -77,12 +78,13 @@ tcPatSynDecl :: PatSynBind GhcRn GhcRn -> Maybe TcSigInfo + -> TcPragEnv -- See Note [Pragmas for pattern synonyms] -> TcM (LHsBinds GhcTc, TcGblEnv) -tcPatSynDecl psb mb_sig +tcPatSynDecl psb mb_sig prag_fn = recoverM (recoverPSB psb) $ case mb_sig of - Nothing -> tcInferPatSynDecl psb - Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi + Nothing -> tcInferPatSynDecl psb prag_fn + Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi prag_fn _ -> panic "tcPatSynDecl" recoverPSB :: PatSynBind GhcRn GhcRn @@ -102,13 +104,12 @@ ([mkTyVarBinder SpecifiedSpec alphaTyVar], []) ([], []) [] -- Arg tys alphaTy - (matcher_id, True) Nothing + (matcher_name, matcher_ty, True) Nothing [] -- Field labels where -- The matcher_id is used only by the desugarer, so actually -- and error-thunk would probably do just as well here. - matcher_id = mkLocalId matcher_name Many $ - mkSpecForAllTys [alphaTyVar] alphaTy + matcher_ty = mkSpecForAllTys [alphaTyVar] alphaTy {- Note [Pattern synonym error recovery] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -139,9 +140,11 @@ -} tcInferPatSynDecl :: PatSynBind GhcRn GhcRn + -> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv) tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details , psb_def = lpat, psb_dir = dir }) + prag_fn = addPatSynCtxt lname $ do { traceTc "tcInferPatSynDecl {" $ ppr name @@ -163,8 +166,9 @@ -- ex_tvs in its kind k. -- See Note [Type variables whose kind is captured] - ; (univ_tvs, req_dicts, ev_binds, residual, _) - <- simplifyInfer tclvl NoRestrictions [] named_taus wanted + ; ((univ_tvs, req_dicts, ev_binds, _), residual) + <- captureConstraints $ + simplifyInfer tclvl NoRestrictions [] named_taus wanted ; top_ev_binds <- checkNoErrs (simplifyTop residual) ; addTopEvBinds top_ev_binds $ @@ -186,7 +190,7 @@ ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs) ; rec_fields <- lookupConstructorFields name - ; tc_patsyn_finish lname dir is_infix lpat' + ; tc_patsyn_finish lname dir is_infix lpat' prag_fn (mkTyVarBinders InferredSpec univ_tvs , req_theta, ev_binds, req_dicts) (mkTyVarBinders InferredSpec ex_tvs @@ -224,7 +228,7 @@ dependentArgErr :: (Id, DTyCoVarSet) -> TcM () -- See Note [Coercions that escape] dependentArgErr (arg, bad_cos) - = addErrTc $ + = failWithTc $ -- fail here: otherwise we get downstream errors vcat [ text "Iceland Jack! Iceland Jack! Stop torturing me!" , hang (text "Pattern-bound variable") 2 (ppr arg <+> dcolon <+> ppr (idType arg)) @@ -344,6 +348,7 @@ tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn -> TcPatSynInfo + -> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv) tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details , psb_def = lpat, psb_dir = dir } @@ -351,6 +356,7 @@ , patsig_univ_bndrs = explicit_univ_bndrs, patsig_req = req_theta , patsig_ex_bndrs = explicit_ex_bndrs, patsig_prov = prov_theta , patsig_body_ty = sig_body_ty } + prag_fn = addPatSynCtxt lname $ do { traceTc "tcCheckPatSynDecl" $ vcat [ ppr implicit_bndrs, ppr explicit_univ_bndrs, ppr req_theta @@ -443,7 +449,7 @@ ; traceTc "tcCheckPatSynDecl }" $ ppr name ; rec_fields <- lookupConstructorFields name - ; tc_patsyn_finish lname dir is_infix lpat' + ; tc_patsyn_finish lname dir is_infix lpat' prag_fn (skol_univ_bndrs, skol_req_theta, ev_binds, req_dicts) (skol_ex_bndrs, mkTyVarTys ex_tvs', skol_prov_theta, prov_dicts) (args', skol_arg_tys) @@ -653,6 +659,7 @@ -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir) -> Bool -- ^ Whether infix -> LPat GhcTc -- ^ Pattern of the PatSyn + -> TcPragEnv -> ([TcInvisTVBinder], [PredType], TcEvBinds, [EvVar]) -> ([TcInvisTVBinder], [TcType], [PredType], [EvTerm]) -> ([LHsExpr GhcTc], [TcType]) -- ^ Pattern arguments and types @@ -660,7 +667,7 @@ -> [FieldLabel] -- ^ Selector names -- ^ Whether fields, empty if not record PatSyn -> TcM (LHsBinds GhcTc, TcGblEnv) -tc_patsyn_finish lname dir is_infix lpat' +tc_patsyn_finish lname dir is_infix lpat' prag_fn (univ_tvs, req_theta, req_ev_binds, req_dicts) (ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) @@ -668,11 +675,12 @@ = do { -- Zonk everything. We are about to build a final PatSyn -- so there had better be no unification variables in there - (ze, univ_tvs') <- zonkTyVarBinders univ_tvs + ; ze <- mkEmptyZonkEnv NoFlexi + ; (ze, univ_tvs') <- zonkTyVarBindersX ze univ_tvs ; req_theta' <- zonkTcTypesToTypesX ze req_theta - ; (ze, ex_tvs') <- zonkTyVarBindersX ze ex_tvs + ; (ze, ex_tvs') <- zonkTyVarBindersX ze ex_tvs ; prov_theta' <- zonkTcTypesToTypesX ze prov_theta - ; pat_ty' <- zonkTcTypeToTypeX ze pat_ty + ; pat_ty' <- zonkTcTypeToTypeX ze pat_ty ; arg_tys' <- zonkTcTypesToTypesX ze arg_tys ; let (env1, univ_tvs) = tidyTyCoVarBinders emptyTidyEnv univ_tvs' @@ -691,17 +699,17 @@ ppr pat_ty -- Make the 'matcher' - ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' + ; (matcher, matcher_bind) <- tcPatSynMatcher lname lpat' prag_fn (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts) (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty -- Make the 'builder' - ; builder_id <- mkPatSynBuilderId dir lname - univ_tvs req_theta - ex_tvs prov_theta - arg_tys pat_ty + ; builder <- mkPatSynBuilder dir lname + univ_tvs req_theta + ex_tvs prov_theta + arg_tys pat_ty -- Make the PatSyn itself ; let patSyn = mkPatSyn (unLoc lname) is_infix @@ -709,7 +717,7 @@ (ex_tvs, prov_theta) arg_tys pat_ty - matcher_id builder_id + matcher builder field_labels -- Selectors @@ -731,13 +739,14 @@ tcPatSynMatcher :: Located Name -> LPat GhcTc + -> TcPragEnv -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar]) -> ([TcTyVar], [TcType], ThetaType, [EvTerm]) -> ([LHsExpr GhcTc], [TcType]) -> TcType - -> TcM ((Id, Bool), LHsBinds GhcTc) + -> TcM (PatSynMatcher, LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn -tcPatSynMatcher (L loc name) lpat +tcPatSynMatcher (L loc name) lpat prag_fn (univ_tvs, req_theta, req_ev_binds, req_dicts) (ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty @@ -761,6 +770,7 @@ ; cont <- newSysLocalId (fsLit "cont") Many cont_ty ; fail <- newSysLocalId (fsLit "fail") Many fail_ty + ; dflags <- getDynFlags ; let matcher_tau = mkVisFunTysMany [pat_ty, cont_ty, fail_ty] res_ty matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau matcher_id = mkExportedVanillaId matcher_name matcher_sigma @@ -773,7 +783,7 @@ args = map nlVarPat [scrutinee, cont, fail] lwpat = noLoc $ WildPat pat_ty - cases = if isIrrefutableHsPat lpat + cases = if isIrrefutableHsPat dflags lpat then [mkHsCaseAlt lpat cont'] else [mkHsCaseAlt lpat cont', mkHsCaseAlt lwpat fail'] @@ -800,17 +810,19 @@ , mg_ext = MatchGroupTc [] res_ty , mg_origin = Generated } + prags = lookupPragEnv prag_fn name + -- See Note [Pragmas for pattern synonyms] - ; let bind = FunBind{ fun_id = L loc matcher_id + ; matcher_prag_id <- addInlinePrags matcher_id prags + ; let bind = FunBind{ fun_id = L loc matcher_prag_id , fun_matches = mg , fun_ext = idHsWrapper , fun_tick = [] } matcher_bind = unitBag (noLoc bind) - ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id)) ; traceTc "tcPatSynMatcher" (ppr matcher_bind) - ; return ((matcher_id, is_unlifted), matcher_bind) } + ; return ((matcher_name, matcher_sigma, is_unlifted), matcher_bind) } mkPatSynRecSelBinds :: PatSyn -> [FieldLabel] -- ^ Visible field labels @@ -832,12 +844,12 @@ ************************************************************************ -} -mkPatSynBuilderId :: HsPatSynDir a -> Located Name - -> [InvisTVBinder] -> ThetaType - -> [InvisTVBinder] -> ThetaType - -> [Type] -> Type - -> TcM (Maybe (Id, Bool)) -mkPatSynBuilderId dir (L _ name) +mkPatSynBuilder :: HsPatSynDir a -> Located Name + -> [InvisTVBinder] -> ThetaType + -> [InvisTVBinder] -> ThetaType + -> [Type] -> Type + -> TcM PatSynBuilder +mkPatSynBuilder dir (L _ name) univ_bndrs req_theta ex_bndrs prov_theta arg_tys pat_ty | isUnidirectional dir @@ -852,41 +864,47 @@ mkPhiTy theta $ mkVisFunTysMany arg_tys $ pat_ty - builder_id = mkExportedVanillaId builder_name builder_sigma - -- See Note [Exported LocalIds] in GHC.Types.Id - - builder_id' = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id - - ; return (Just (builder_id', need_dummy_arg)) } + ; return (Just (builder_name, builder_sigma, need_dummy_arg)) } -tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn +tcPatSynBuilderBind :: TcPragEnv + -> PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn -tcPatSynBuilderBind (PSB { psb_id = L loc name - , psb_def = lpat - , psb_dir = dir - , psb_args = details }) +tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) + , psb_def = lpat + , psb_dir = dir + , psb_args = details }) | isUnidirectional dir = return emptyBag | Left why <- mb_match_group -- Can't invert the pattern = setSrcSpan (getLoc lpat) $ failWithTc $ vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym" - <+> quotes (ppr name) <> colon) + <+> quotes (ppr ps_name) <> colon) 2 why , text "RHS pattern:" <+> ppr lpat ] | Right match_group <- mb_match_group -- Bidirectional - = do { patsyn <- tcLookupPatSyn name + = do { patsyn <- tcLookupPatSyn ps_name ; case patSynBuilder patsyn of { Nothing -> return emptyBag ; -- This case happens if we found a type error in the -- pattern synonym, recovered, and put a placeholder -- with patSynBuilder=Nothing in the environment - Just (builder_id, need_dummy_arg) -> -- Normal case + Just (builder_name, builder_ty, need_dummy_arg) -> -- Normal case do { -- Bidirectional, so patSynBuilder returns Just - let match_group' | need_dummy_arg = add_dummy_arg match_group + let pat_ty = patSynResultType patsyn + builder_id = modifyIdInfo (`setLevityInfoWithType` pat_ty) $ + mkExportedVanillaId builder_name builder_ty + -- See Note [Exported LocalIds] in GHC.Types.Id + prags = lookupPragEnv prag_fn ps_name + -- See Note [Pragmas for pattern synonyms] + -- Keyed by the PatSyn Name, not the (internal) builder name + + ; builder_id <- addInlinePrags builder_id prags + + ; let match_group' | need_dummy_arg = add_dummy_arg match_group | otherwise = match_group bind = FunBind { fun_id = L loc (idName builder_id) @@ -894,10 +912,12 @@ , fun_ext = emptyNameSet , fun_tick = [] } - sig = completeSigFromId (PatSynCtxt name) builder_id + sig = completeSigFromId (PatSynCtxt ps_name) builder_id ; traceTc "tcPatSynBuilderBind {" $ - ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id) + vcat [ ppr patsyn + , ppr builder_id <+> dcolon <+> ppr (idType builder_id) + , ppr prags ] ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind) ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds ; return builder_binds } } } @@ -909,7 +929,7 @@ mb_match_group = case dir of ExplicitBidirectional explicit_mg -> Right explicit_mg - ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat) + ImplicitBidirectional -> fmap mk_mg (tcPatToExpr ps_name args lpat) Unidirectional -> panic "tcPatSynBuilderBind" mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) @@ -917,7 +937,7 @@ where builder_args = [L loc (VarPat noExtField (L loc n)) | L loc n <- args] - builder_match = mkMatch (mkPrefixFunRhs (L loc name)) + builder_match = mkMatch (mkPrefixFunRhs ps_lname) builder_args body (noLoc (EmptyLocalBinds noExtField)) @@ -936,13 +956,12 @@ patSynBuilderOcc :: PatSyn -> Maybe (HsExpr GhcTc, TcSigmaType) patSynBuilderOcc ps - | Just (builder_id, add_void_arg) <- patSynBuilder ps + | Just (_, builder_ty, add_void_arg) <- patSynBuilder ps , let builder_expr = HsConLikeOut noExtField (PatSynCon ps) - builder_ty = idType builder_id = Just $ if add_void_arg - then ( builder_expr -- still just return builder_expr; the void# arg is added - -- by dsConLike in the desugarer + then ( builder_expr -- still just return builder_expr; the void# arg + -- is added by dsConLike in the desugarer , tcFunResultTy builder_ty ) else (builder_expr, builder_ty) @@ -1129,12 +1148,34 @@ simply discard the signature. Note [Record PatSyn Desugaring] -------------------------------- +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It is important that prov_theta comes before req_theta as this ordering is used when desugaring record pattern synonym updates. Any change to this ordering should make sure to change GHC.HsToCore.Expr if you want to avoid difficult to decipher core lint errors! + +Note [Pragmas for pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +INLINE and NOINLINE pragmas are supported for pattern synonyms. They affect both +the matcher and the builder. +(See Note [Matchers and builders for pattern synonyms] in PatSyn) + +For example: + pattern InlinedPattern x = [x] + {-# INLINE InlinedPattern #-} + pattern NonInlinedPattern x = [x] + {-# NOINLINE NonInlinedPattern #-} + +For pattern synonyms with explicit builders, only pragma for the entire pattern +synonym is supported. For example: + pattern HeadC x <- x:xs where + HeadC x = [x] + -- This wouldn't compile: {-# INLINE HeadC #-} + {-# INLINE HeadC #-} -- But this works + +When no pragma is provided for a pattern, the inlining decision might change +between different versions of GHC. -} diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs-boot b/compiler/GHC/Tc/TyCl/PatSyn.hs-boot --- a/compiler/GHC/Tc/TyCl/PatSyn.hs-boot +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs-boot @@ -5,10 +5,13 @@ import GHC.Tc.Utils.Monad ( TcGblEnv) import GHC.Hs.Extension ( GhcRn, GhcTc ) import Data.Maybe ( Maybe ) +import GHC.Tc.Gen.Sig ( TcPragEnv ) tcPatSynDecl :: PatSynBind GhcRn GhcRn -> Maybe TcSigInfo + -> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv) -tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc) +tcPatSynBuilderBind :: TcPragEnv -> PatSynBind GhcRn GhcRn + -> TcM (LHsBinds GhcTc) 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 @@ -361,7 +361,7 @@ -- an @hsig@ file.) tcRnCheckUnit :: HscEnv -> Unit -> - IO (Messages, Maybe ()) + IO (Messages ErrDoc, Maybe ()) tcRnCheckUnit hsc_env uid = withTiming dflags (text "Check unit id" <+> ppr uid) @@ -381,7 +381,7 @@ -- | Top-level driver for signature merging (run after typechecking -- an @hsig@ file). tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface - -> IO (Messages, Maybe TcGblEnv) + -> IO (Messages ErrDoc, Maybe TcGblEnv) tcRnMergeSignatures hsc_env hpm orig_tcg_env iface = withTiming dflags (text "Signature merging" <+> brackets (ppr this_mod)) @@ -912,7 +912,7 @@ -- an @hsig@ file.) tcRnInstantiateSignature :: HscEnv -> Module -> RealSrcSpan -> - IO (Messages, Maybe TcGblEnv) + IO (Messages ErrDoc, Maybe TcGblEnv) tcRnInstantiateSignature hsc_env this_mod real_loc = withTiming dflags (text "Signature instantiation"<+>brackets (ppr this_mod)) diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -4,7 +4,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an -- orphan {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] - -- in module GHC.Hs.Extension + -- in module Language.Haskell.Syntax.Extension {-# LANGUAGE TypeFamilies #-} module GHC.Tc.Utils.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 @@ -188,6 +188,7 @@ import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Types.Error import GHC.Types.Fixity.Env import GHC.Types.Name.Reader import GHC.Types.Name @@ -200,7 +201,6 @@ import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Name.Ppr -import GHC.Types.Unique (uniqFromMask) import GHC.Types.Unique.Supply import GHC.Types.Annotations import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) ) @@ -231,7 +231,7 @@ -> Module -> RealSrcSpan -> TcM r - -> IO (Messages, Maybe r) + -> IO (Messages ErrDoc, Maybe r) -- Nothing => error thrown by the thing inside -- (error messages should have been printed already) @@ -353,10 +353,10 @@ -> TcGblEnv -> RealSrcSpan -> TcM r - -> IO (Messages, Maybe r) + -> IO (Messages ErrDoc, Maybe r) initTcWithGbl hsc_env gbl_env loc do_this = do { lie_var <- newIORef emptyWC - ; errs_var <- newIORef (emptyBag, emptyBag) + ; errs_var <- newIORef emptyMessages ; usage_var <- newIORef zeroUE ; let lcl_env = TcLclEnv { tcl_errs = errs_var, @@ -393,14 +393,13 @@ -- Collect any error messages ; msgs <- readIORef (tcl_errs lcl_env) - ; let { final_res | errorsFound dflags msgs = Nothing - | otherwise = maybe_res } + ; let { final_res | errorsFound msgs = Nothing + | otherwise = maybe_res } ; return (msgs, final_res) } - where dflags = hsc_dflags hsc_env -initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a) +initTcInteractive :: HscEnv -> TcM a -> IO (Messages ErrDoc, Maybe a) -- Initialise the type checker monad for use in GHCi initTcInteractive hsc_env thing_inside = initTc hsc_env HsSrcFile False @@ -931,10 +930,10 @@ -- Reporting errors -getErrsVar :: TcRn (TcRef Messages) +getErrsVar :: TcRn (TcRef (Messages ErrDoc)) getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } -setErrsVar :: TcRef Messages -> TcRn a -> TcRn a +setErrsVar :: TcRef (Messages ErrDoc) -> TcRn a -> TcRn a setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) addErr :: MsgDoc -> TcRn () @@ -964,7 +963,7 @@ -- Add the error if the bool is False checkErr ok msg = unless ok (addErr msg) -addMessages :: Messages -> TcRn () +addMessages :: Messages ErrDoc -> TcRn () addMessages msgs1 = do { errs_var <- getErrsVar ; msgs0 <- readTcRef errs_var ; @@ -975,13 +974,13 @@ -- used to ignore-unused-variable warnings inside derived code discardWarnings thing_inside = do { errs_var <- getErrsVar - ; (old_warns, _) <- readTcRef errs_var + ; old_warns <- getWarningMessages <$> readTcRef errs_var ; result <- thing_inside -- Revert warnings to old_warns - ; (_new_warns, new_errs) <- readTcRef errs_var - ; writeTcRef errs_var (old_warns, new_errs) + ; new_errs <- getErrorMessages <$> readTcRef errs_var + ; writeTcRef errs_var $ mkMessages (old_warns `unionBags` new_errs) ; return result } @@ -993,38 +992,36 @@ ************************************************************************ -} -mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg +mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn (ErrMsg ErrDoc) mkLongErrAt loc msg extra - = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified ; + = do { printer <- getPrintUnqualified ; unit_state <- hsc_units <$> getTopEnv ; let msg' = pprWithUnitState unit_state msg in - return $ mkLongErrMsg dflags loc printer msg' extra } + return $ mkLongErrMsg loc printer msg' extra } -mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg +mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn (ErrMsg ErrDoc) mkErrDocAt loc errDoc - = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified ; + = do { printer <- getPrintUnqualified ; unit_state <- hsc_units <$> getTopEnv ; let f = pprWithUnitState unit_state errDoc' = mapErrDoc f errDoc in - return $ mkErrDoc dflags loc printer errDoc' } + return $ mkErr loc printer errDoc' } addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError -reportErrors :: [ErrMsg] -> TcM () +reportErrors :: [ErrMsg ErrDoc] -> TcM () reportErrors = mapM_ reportError -reportError :: ErrMsg -> TcRn () +reportError :: ErrMsg ErrDoc -> TcRn () reportError err = do { traceTc "Adding error:" (pprLocErrMsg err) ; errs_var <- getErrsVar ; - (warns, errs) <- readTcRef errs_var ; - writeTcRef errs_var (warns, errs `snocBag` err) } + msgs <- readTcRef errs_var ; + writeTcRef errs_var (err `addMessage` msgs) } -reportWarning :: WarnReason -> ErrMsg -> TcRn () +reportWarning :: WarnReason -> ErrMsg ErrDoc -> TcRn () reportWarning reason err = do { let warn = makeIntoWarning reason err -- 'err' was built by mkLongErrMsg or something like that, @@ -1033,8 +1030,8 @@ ; traceTc "Adding warning:" (pprLocErrMsg warn) ; errs_var <- getErrsVar - ; (warns, errs) <- readTcRef errs_var - ; writeTcRef errs_var (warns `snocBag` warn, errs) } + ; (warns, errs) <- partitionMessages <$> readTcRef errs_var + ; writeTcRef errs_var (mkMessages $ (warns `snocBag` warn) `unionBags` errs) } ----------------------- @@ -1061,8 +1058,7 @@ ifErrsM bale_out normal = do { errs_var <- getErrsVar ; msgs <- readTcRef errs_var ; - dflags <- getDynFlags ; - if errorsFound dflags msgs then + if errorsFound msgs then bale_out else normal } @@ -1195,7 +1191,7 @@ ; lie <- readTcRef lie_var ; return (res, lie) } -capture_messages :: TcM r -> TcM (r, Messages) +capture_messages :: TcM r -> TcM (r, Messages ErrDoc) -- capture_messages simply captures and returns the -- errors arnd warnings generated by thing_inside -- Precondition: thing_inside must not throw an exception! @@ -1231,8 +1227,7 @@ ; failM } Just res -> do { emitConstraints lie - ; dflags <- getDynFlags - ; let errs_found = errorsFound dflags msgs + ; let errs_found = errorsFound msgs || insolubleWC lie ; return (res, not errs_found) } } @@ -1366,7 +1361,7 @@ Just acc' -> foldAndRecoverM f acc' xs } ----------------------- -tryTc :: TcRn a -> TcRn (Maybe a, Messages) +tryTc :: TcRn a -> TcRn (Maybe a, Messages ErrDoc) -- (tryTc m) executes m, and returns -- Just r, if m succeeds (returning r) -- Nothing, if m fails @@ -1394,9 +1389,8 @@ = do { ((mb_res, lie), msgs) <- capture_messages $ capture_constraints $ tcTryM thing_inside - ; dflags <- getDynFlags ; case mb_res of - Just res | not (errorsFound dflags msgs) + Just res | not (errorsFound msgs) , not (insolubleWC lie) -> -- 'main' succeeded with no errors do { addMessages msgs -- msgs might still have warnings @@ -1516,9 +1510,8 @@ -- | Display a warning, with an optional flag, for a given location. add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn () add_warn_at reason loc msg extra_info - = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified ; - let { warn = mkLongWarnMsg dflags loc printer + = do { printer <- getPrintUnqualified ; + let { warn = mkLongWarnMsg loc printer msg extra_info } ; reportWarning reason warn } diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -83,6 +83,7 @@ defaultTyVar, promoteMetaTyVarTo, promoteTyVarSet, quantifyTyVars, isQuantifiableTv, skolemiseUnboundMetaTyVar, zonkAndSkolemise, skolemiseQuantifiedTyVar, + doNotQuantifyTyVars, candidateQTyVarsOfType, candidateQTyVarsOfKind, candidateQTyVarsOfTypes, candidateQTyVarsOfKinds, @@ -765,21 +766,27 @@ {- Note [TyVarTv] ~~~~~~~~~~~~~~~~~ A TyVarTv can unify with type *variables* only, including other TyVarTvs and -skolems. Sometimes, they can unify with type variables that the user would -rather keep distinct; see #11203 for an example. So, any client of this -function needs to either allow the TyVarTvs to unify with each other or check -that they don't (say, with a call to findDubTyVarTvs). +skolems. They are used in two places: -Before #15050 this (under the name SigTv) was used for ScopedTypeVariables in -patterns, to make sure these type variables only refer to other type variables, -but this restriction was dropped, and ScopedTypeVariables can now refer to full -types (GHC Proposal 29). +1. In kind signatures, see GHC.Tc.TyCl + Note [Inferring kinds for type declarations] + and Note [Kind checking for GADTs] -The remaining uses of newTyVarTyVars are -* In kind signatures, see - GHC.Tc.TyCl Note [Inferring kinds for type declarations] - and Note [Kind checking for GADTs] -* In partial type signatures, see Note [Quantified variables in partial type signatures] +2. In partial type signatures. See GHC.Tc.Types + Note [Quantified variables in partial type signatures] + +Sometimes, they can unify with type variables that the user would +rather keep distinct; see #11203 for an example. So, any client of +this function needs to either allow the TyVarTvs to unify with each +other or check that they don't. In the case of (1) the check is done +in GHC.Tc.TyCl.swizzleTcTyConBndrs. In case of (2) it's done by +findDupTyVarTvs in GHC.Tc.Gen.Bind.chooseInferredQuantifiers. + +Historical note: Before #15050 this (under the name SigTv) was also +used for ScopedTypeVariables in patterns, to make sure these type +variables only refer to other type variables, but this restriction was +dropped, and ScopedTypeVariables can now refer to full types (GHC +Proposal 29). -} newMetaTyVarName :: FastString -> TcM Name @@ -1299,7 +1306,30 @@ , text "dv_tvs =" <+> ppr tvs , text "dv_cvs =" <+> ppr cvs ]) +isEmptyCandidates :: CandidatesQTvs -> Bool +isEmptyCandidates (DV { dv_kvs = kvs, dv_tvs = tvs }) + = isEmptyDVarSet kvs && isEmptyDVarSet tvs +-- | Extract out the kind vars (in order) and type vars (in order) from +-- a 'CandidatesQTvs'. The lists are guaranteed to be distinct. Keeping +-- the lists separate is important only in the -XNoPolyKinds case. +candidateVars :: CandidatesQTvs -> ([TcTyVar], [TcTyVar]) +candidateVars (DV { dv_kvs = dep_kv_set, dv_tvs = nondep_tkv_set }) + = (dep_kvs, nondep_tvs) + where + dep_kvs = scopedSort $ dVarSetElems dep_kv_set + -- scopedSort: put the kind variables into + -- well-scoped order. + -- E.g. [k, (a::k)] not the other way round + + nondep_tvs = dVarSetElems (nondep_tkv_set `minusDVarSet` dep_kv_set) + -- See Note [Dependent type variables] + -- The `minus` dep_tkvs removes any kind-level vars + -- e.g. T k (a::k) Since k appear in a kind it'll + -- be in dv_kvs, and is dependent. So remove it from + -- dv_tvs which will also contain k + -- NB kinds of tvs are already zonked + candidateKindVars :: CandidatesQTvs -> TyVarSet candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) @@ -1377,7 +1407,7 @@ go :: CandidatesQTvs -> TcType -> TcM CandidatesQTvs -- Uses accumulating-parameter style go dv (AppTy t1 t2) = foldlM go dv [t1, t2] - go dv (TyConApp _ tys) = foldlM go dv tys + go dv (TyConApp tc tys) = go_tc_args dv (tyConBinders tc) tys go dv (FunTy _ w arg res) = foldlM go dv [w, arg, res] go dv (LitTy {}) = return dv go dv (CastTy ty co) = do dv1 <- go dv ty @@ -1395,6 +1425,20 @@ = do { dv1 <- collect_cand_qtvs orig_ty True bound dv (tyVarKind tv) ; collect_cand_qtvs orig_ty is_dep (bound `extendVarSet` tv) dv1 ty } + -- This makes sure that we default e.g. the alpha in Proxy alpha (Any alpha). + -- Tested in polykinds/NestedProxies. + -- We just might get this wrong in AppTy, but I don't think that's possible + -- with -XNoPolyKinds. And fixing it would be non-performant, as we'd need + -- to look at kinds. + go_tc_args dv (tc_bndr:tc_bndrs) (ty:tys) + = do { dv1 <- collect_cand_qtvs orig_ty (is_dep || isNamedTyConBinder tc_bndr) + bound dv ty + ; go_tc_args dv1 tc_bndrs tys } + go_tc_args dv _bndrs tys -- _bndrs might be non-empty: undersaturation + -- tys might be non-empty: oversaturation + -- either way, the foldlM is correct + = foldlM go dv tys + ----------------- go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv | tv `elemDVarSet` kvs @@ -1415,7 +1459,7 @@ ; cur_lvl <- getTcLevel ; if | tcTyVarLevel tv <= cur_lvl -> return dv -- this variable is from an outer context; skip - -- See Note [Use level numbers ofor quantification] + -- See Note [Use level numbers for quantification] | intersectsVarSet bound tv_kind_vars -- the tyvar must not be from an outer context, but we have @@ -1566,7 +1610,7 @@ It takes these free type/kind variables (partitioned into dependent and non-dependent variables) skolemises metavariables with a TcLevel greater -than the ambient level (see Note [Use level numbers of quantification]). +than the ambient level (see Note [Use level numbers for quantification]). * This function distinguishes between dependent and non-dependent variables only to keep correct defaulting behavior with -XNoPolyKinds. @@ -1642,46 +1686,21 @@ -- invariants on CandidateQTvs, we do not have to filter out variables -- free in the environment here. Just quantify unconditionally, subject -- to the restrictions in Note [quantifyTyVars]. -quantifyTyVars dvs@(DV{ dv_kvs = dep_kv_set, dv_tvs = nondep_tkv_set }) +quantifyTyVars dvs -- short-circuit common case - | isEmptyDVarSet dep_kv_set - , isEmptyDVarSet nondep_tkv_set + | isEmptyCandidates dvs = do { traceTc "quantifyTyVars has nothing to quantify" empty ; return [] } | otherwise = do { traceTc "quantifyTyVars {" (ppr dvs) - ; let dep_kvs = scopedSort $ dVarSetElems dep_kv_set - -- scopedSort: put the kind variables into - -- well-scoped order. - -- E.g. [k, (a::k)] not the other way round - - nondep_tvs = dVarSetElems (nondep_tkv_set `minusDVarSet` dep_kv_set) - -- See Note [Dependent type variables] - -- The `minus` dep_tkvs removes any kind-level vars - -- e.g. T k (a::k) Since k appear in a kind it'll - -- be in dv_kvs, and is dependent. So remove it from - -- dv_tvs which will also contain k - -- NB kinds of tvs are already zonked - - -- In the non-PolyKinds case, default the kind variables - -- to *, and zonk the tyvars as usual. Notice that this - -- may make quantifyTyVars return a shorter list - -- than it was passed, but that's ok - ; poly_kinds <- xoptM LangExt.PolyKinds - ; dep_kvs' <- mapMaybeM (zonk_quant (not poly_kinds)) dep_kvs - ; nondep_tvs' <- mapMaybeM (zonk_quant False) nondep_tvs - ; let final_qtvs = dep_kvs' ++ nondep_tvs' - -- Because of the order, any kind variables - -- mentioned in the kinds of the nondep_tvs' - -- now refer to the dep_kvs' + ; undefaulted <- defaultTyVars dvs + ; final_qtvs <- mapMaybeM zonk_quant undefaulted ; traceTc "quantifyTyVars }" - (vcat [ text "nondep:" <+> pprTyVars nondep_tvs - , text "dep:" <+> pprTyVars dep_kvs - , text "dep_kvs'" <+> pprTyVars dep_kvs' - , text "nondep_tvs'" <+> pprTyVars nondep_tvs' ]) + (vcat [ text "undefaulted:" <+> pprTyVars undefaulted + , text "final_qtvs:" <+> pprTyVars final_qtvs ]) -- We should never quantify over coercion variables; check this ; let co_vars = filter isCoVar final_qtvs @@ -1691,9 +1710,8 @@ where -- zonk_quant returns a tyvar if it should be quantified over; -- otherwise, it returns Nothing. The latter case happens for - -- * Kind variables, with -XNoPolyKinds: don't quantify over these - -- * RuntimeRep variables: we never quantify over these - zonk_quant default_kind tkv + -- non-meta-tyvars + zonk_quant tkv | not (isTyVar tkv) = return Nothing -- this can happen for a covar that's associated with -- a coercion hole. Test case: typecheck/should_compile/T2494 @@ -1703,11 +1721,7 @@ -- kind signature, we have the class variables in -- scope, and they are TyVars not TcTyVars | otherwise - = do { deflt_done <- defaultTyVar default_kind tkv - ; case deflt_done of - True -> return Nothing - False -> do { tv <- skolemiseQuantifiedTyVar tkv - ; return (Just tv) } } + = Just <$> skolemiseQuantifiedTyVar tkv isQuantifiableTv :: TcLevel -- Level of the context, outside the quantification -> TcTyVar @@ -1769,7 +1783,7 @@ | isTyVarTyVar tv -- Do not default TyVarTvs. Doing so would violate the invariants - -- on TyVarTvs; see Note [Signature skolems] in GHC.Tc.Utils.TcType. + -- on TyVarTvs; see Note [TyVarTv] in GHC.Tc.Utils.TcMType. -- #13343 is an example; #14555 is another -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl = return False @@ -1817,6 +1831,24 @@ where (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv +-- | Default some unconstrained type variables: +-- RuntimeRep tyvars default to LiftedRep +-- Multiplicity tyvars default to Many +-- Type tyvars from dv_kvs default to Type, when -XNoPolyKinds +-- (under -XNoPolyKinds, non-defaulting vars in dv_kvs is an error) +defaultTyVars :: CandidatesQTvs -- ^ all candidates for quantification + -> TcM [TcTyVar] -- ^ those variables not defaulted +defaultTyVars dvs + = do { poly_kinds <- xoptM LangExt.PolyKinds + ; defaulted_kvs <- mapM (defaultTyVar (not poly_kinds)) dep_kvs + ; defaulted_tvs <- mapM (defaultTyVar False) nondep_tvs + ; let undefaulted_kvs = [ kv | (kv, False) <- dep_kvs `zip` defaulted_kvs ] + undefaulted_tvs = [ tv | (tv, False) <- nondep_tvs `zip` defaulted_tvs ] + ; return (undefaulted_kvs ++ undefaulted_tvs) } + -- NB: kvs before tvs because tvs may depend on kvs + where + (dep_kvs, nondep_tvs) = candidateVars dvs + skolemiseUnboundMetaTyVar :: TcTyVar -> TcM TyVar -- We have a Meta tyvar with a ref-cell inside it -- Skolemise it, so that we are totally out of Meta-tyvar-land @@ -1850,6 +1882,134 @@ Flexi -> return () Indirect ty -> WARN( True, ppr tv $$ ppr ty ) return () } + +{- Note [Error on unconstrained meta-variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + type C :: Type -> Type -> Constraint + class (forall a. a b ~ a c) => C b c + +or + + type T = forall a. Proxy a + +or + + data (forall a. a b ~ a c) => T b c + +We will infer a :: Type -> kappa... but then we get no further information +on kappa. What to do? + + A. We could choose kappa := Type. But this only works when the kind of kappa + is Type (true in this example, but not always). + B. We could default to Any. + C. We could quantify. + D. We could error. + +We choose (D), as described in #17567. Discussion of alternatives is below. + +(One last example: type instance F Int = Proxy Any, where the unconstrained +kind variable is the inferred kind of Any. The four examples here illustrate +all cases in which this Note applies.) + +To do this, we must take an extra step before doing the final zonk to create +e.g. a TyCon. (There is no problem in the final term-level zonk. See the +section on alternative (B) below.) This extra step is needed only for +constructs that do not quantify their free meta-variables, such as a class +constraint or right-hand side of a type synonym. + +Specifically: before the final zonk, every construct must either call +quantifyTyVars or doNotQuantifyTyVars. The latter issues an error +if it is passed any free variables. (Exception: we still default +RuntimeRep and Multiplicity variables.) + +Because no meta-variables remain after quantifying or erroring, we perform +the zonk with NoFlexi, which panics upon seeing a meta-variable. + +Alternatives not implemented: + +A. As stated above, this works only sometimes. We might have a free + meta-variable of kind Nat, for example. + +B. This is what we used to do, but it caused Any to appear in error + messages sometimes. See #17567 for several examples. Defaulting to + Any during the final, whole-program zonk is OK, though, because + we are completely done type-checking at that point. No chance to + leak into an error message. + +C. Examine the class declaration at the top of this Note again. + Where should we quantify? We might imagine quantifying and + putting the kind variable in the forall of the quantified constraint. + But what if there are nested foralls? Which one should get the + variable? Other constructs have other problems. (For example, + the right-hand side of a type family instance equation may not + be a poly-type.) + + More broadly, the GHC AST defines a set of places where it performs + implicit lexical generalization. For example, in a type + signature + + f :: Proxy a -> Bool + + the otherwise-unbound a is lexically quantified, giving us + + f :: forall a. Proxy a -> Bool + + The places that allow lexical quantification are marked in the AST with + HsImplicitBndrs. HsImplicitBndrs offers a binding site for otherwise-unbound + variables. + + Later, during type-checking, we discover that a's kind is unconstrained. + We thus quantify *again*, to + + f :: forall {k} (a :: k). Proxy @k a -> Bool + + It is this second quantification that this Note is really about -- + let's call it *inferred quantification*. + So there are two sorts of implicit quantification in types: + 1. Lexical quantification: signalled by HsImplicitBndrs, occurs over + variables mentioned by the user but with no explicit binding site, + suppressed by a user-written forall (by the forall-or-nothing rule, + in Note [forall-or-nothing rule] in GHC.Hs.Type). + 2. Inferred quantification: no signal in HsSyn, occurs over unconstrained + variables invented by the type-checker, possible only with -XPolyKinds, + unaffected by forall-or-nothing rule + These two quantifications are performed in different compiler phases, and are + essentially unrelated. However, it is convenient + for programmers to remember only one set of implicit quantification + sites. So, we choose to use the same places (those with HsImplicitBndrs) + for lexical quantification as for inferred quantification of unconstrained + meta-variables. Accordingly, there is no quantification in a class + constraint, or the other constructs that call doNotQuantifyTyVars. +-} + +doNotQuantifyTyVars :: CandidatesQTvs + -> (TidyEnv -> TcM (TidyEnv, SDoc)) + -- ^ like "the class context (D a b, E foogle)" + -> TcM () +doNotQuantifyTyVars dvs where_found + | isEmptyCandidates dvs + = traceTc "doNotQuantifyTyVars has nothing to error on" empty + + | otherwise + = do { traceTc "doNotQuantifyTyVars" (ppr dvs) + ; undefaulted <- defaultTyVars dvs + -- could have regular TyVars here, in an associated type RHS, or + -- bound by a type declaration head. So filter looking only for + -- metavars. e.g. b and c in `class (forall a. a b ~ a c) => C b c` + -- are OK + ; let leftover_metas = filter isMetaTyVar undefaulted + ; unless (null leftover_metas) $ + do { let (tidy_env1, tidied_tvs) = tidyOpenTyCoVars emptyTidyEnv leftover_metas + ; (tidy_env2, where_doc) <- where_found tidy_env1 + ; let doc = vcat [ text "Uninferrable type variable" + <> plural tidied_tvs + <+> pprWithCommas pprTyVar tidied_tvs + <+> text "in" + , where_doc ] + ; failWithTcM (tidy_env2, pprWithExplicitKindsWhen True doc) } + ; traceTc "doNotQuantifyTyVars success" empty } {- Note [Defaulting with -XNoPolyKinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -1583,7 +1582,7 @@ up a fresh gamma[n], and unify beta[k] := gamma[n]. * (TYVAR-TV) Unification variables. Suppose alpha[tyv,n] is a level-n - TyVarTv (see Note [Signature skolems] in GHC.Tc.Types.TcType)? Now + TyVarTv (see Note [TyVarTv] in GHC.Tc.Types.TcMType)? Now consider alpha[tyv,n] ~ Bool. We don't want to unify because that would break the TyVarTv invariant. diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -33,10 +32,10 @@ zonkTopDecls, zonkTopExpr, zonkTopLExpr, zonkTopBndrs, ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv, - zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX, + zonkTyVarBindersX, zonkTyVarBinderX, zonkTyBndrs, zonkTyBndrsX, zonkTcTypeToType, zonkTcTypeToTypeX, - zonkTcTypesToTypes, zonkTcTypesToTypesX, zonkScaledTcTypesToTypesX, + zonkTcTypesToTypesX, zonkScaledTcTypesToTypesX, zonkTyVarOcc, zonkCoToCo, zonkEvBinds, zonkTcEvBinds, @@ -284,6 +283,10 @@ It's a way to have a variable that is not a mutable unification variable, but doesn't have a binding site either. + +* NoFlexi: See Note [Error on unconstrained meta-variables] + in GHC.Tc.Utils.TcMType. This mode will panic on unfilled + meta-variables. -} data ZonkFlexi -- See Note [Un-unified unification variables] @@ -291,6 +294,9 @@ | SkolemiseFlexi -- Skolemise unbound unification variables -- See Note [Zonking the LHS of a RULE] | RuntimeUnkFlexi -- Used in the GHCi debugger + | NoFlexi -- Panic on unfilled meta-variables + -- See Note [Error on unconstrained meta-variables] + -- in GHC.Tc.Utils.TcMType instance Outputable ZonkEnv where ppr (ZonkEnv { ze_tv_env = tv_env @@ -452,10 +458,6 @@ ; let tv' = mkTyVar (tyVarName tv) ki ; return (extendTyZonkEnv env tv', tv') } -zonkTyVarBinders :: [VarBndr TcTyVar vis] - -> TcM (ZonkEnv, [VarBndr TyVar vis]) -zonkTyVarBinders tvbs = initZonkEnv $ \ ze -> zonkTyVarBindersX ze tvbs - zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis] -> TcM (ZonkEnv, [VarBndr TyVar vis]) zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX @@ -529,7 +531,7 @@ zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (ZonkEnv, LHsBinds GhcTc) zonkRecMonoBinds env binds = fixM (\ ~(_, new_binds) -> do - { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds) + { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders CollNoDictBinders new_binds) ; binds' <- zonkMonoBinds env1 binds ; return (env1, binds') }) @@ -578,7 +580,7 @@ ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) -> do { let env3 = extendIdZonkEnvRec env2 $ - collectHsBindsBinders new_val_binds + collectHsBindsBinders CollNoDictBinders new_val_binds ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds ; new_exports <- mapM (zonk_export env3) exports ; return (new_val_binds, new_exports) } @@ -887,10 +889,10 @@ where zonkWit env Nothing = return (env, Nothing) zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln -zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds }) - = do { new_con_expr <- zonkExpr env (rcon_con_expr ext) +zonkExpr env expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds }) + = do { new_con_expr <- zonkExpr env con_expr ; new_rbinds <- zonkRecFields env rbinds - ; return (expr { rcon_ext = ext { rcon_con_expr = new_con_expr } + ; return (expr { rcon_ext = new_con_expr , rcon_flds = new_rbinds }) } zonkExpr env (RecordUpd { rupd_flds = rbinds @@ -1613,10 +1615,10 @@ return $ Case scrut' b' ty' alts' zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt -zonkCoreAlt env (dc, bndrs, rhs) +zonkCoreAlt env (Alt dc bndrs rhs) = do (env1, bndrs') <- zonkCoreBndrsX env bndrs rhs' <- zonkCoreExpr env1 rhs - return $ (dc, bndrs', rhs') + return $ Alt dc bndrs' rhs' zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind) zonkCoreBind env (NonRec v e) @@ -1847,6 +1849,9 @@ -- otherwise-unconstrained unification variables are -- turned into RuntimeUnks as they leave the -- typechecker's monad + + NoFlexi -> pprPanic "NoFlexi" (ppr tv <+> dcolon <+> ppr zonked_kind) + where name = tyVarName tv @@ -1898,9 +1903,6 @@ -- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType. zonkTcTypeToType :: TcType -> TcM Type zonkTcTypeToType ty = initZonkEnv $ \ ze -> zonkTcTypeToTypeX ze ty - -zonkTcTypesToTypes :: [TcType] -> TcM [Type] -zonkTcTypesToTypes tys = initZonkEnv $ \ ze -> zonkTcTypesToTypesX ze tys zonkScaledTcTypeToTypeX :: ZonkEnv -> Scaled TcType -> TcM (Scaled TcType) zonkScaledTcTypeToTypeX env (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX env m diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -1182,7 +1182,7 @@ -- in Note [Lift equality constraints when quantifying] in GHC.Tc.Utils.TcType ForAllPred _ theta head -> check_quant_pred env dflags ctxt pred theta head - IrredPred {} -> check_irred_pred under_syn env dflags ctxt pred + IrredPred {} -> check_irred_pred under_syn env dflags pred check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TcM () check_eq_pred env dflags pred @@ -1224,30 +1224,17 @@ -- This case will not normally be executed because without -- -XConstraintKinds tuple types are only kind-checked as * -check_irred_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM () -check_irred_pred under_syn env dflags ctxt pred +check_irred_pred :: Bool -> TidyEnv -> DynFlags -> PredType -> TcM () +check_irred_pred under_syn env dflags pred -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint -- where X is a type function - = do { -- If it looks like (x t1 t2), require ConstraintKinds + = -- If it looks like (x t1 t2), require ConstraintKinds -- see Note [ConstraintKinds in predicates] -- But (X t1 t2) is always ok because we just require ConstraintKinds -- at the definition site (#9838) - failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags) - && hasTyVarHead pred) - (predIrredErr env pred) - - -- Make sure it is OK to have an irred pred in this context - -- See Note [Irreducible predicates in superclasses] - ; failIfTcM (is_superclass ctxt - && not (xopt LangExt.UndecidableInstances dflags) - && has_tyfun_head pred) - (predSuperClassErr env pred) } - where - is_superclass ctxt = case ctxt of { ClassSCCtxt _ -> True; _ -> False } - has_tyfun_head ty - = case tcSplitTyConApp_maybe ty of - Just (tc, _) -> isTypeFamilyTyCon tc - Nothing -> False + failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags) + && hasTyVarHead pred) + (predIrredErr env pred) {- Note [ConstraintKinds in predicates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1258,19 +1245,7 @@ module B where import A f :: C a => a -> a -- Does *not* need -XConstraintKinds - -Note [Irreducible predicates in superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Allowing type-family calls in class superclasses is somewhat dangerous -because we can write: - - type family Fooish x :: * -> Constraint - type instance Fooish () = Foo - class Fooish () a => Foo a where - -This will cause the constraint simplifier to loop because every time we canonicalise a -(Foo a) class constraint we add a (Fooish () a) constraint which will be immediately -solved to add+canonicalise another (Foo a) constraint. -} +-} ------------------------- check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt @@ -1294,10 +1269,9 @@ -- Check the arguments of a class constraint flexible_contexts = xopt LangExt.FlexibleContexts dflags - undecidable_ok = xopt LangExt.UndecidableInstances dflags arg_tys_ok = case ctxt of SpecInstCtxt -> True -- {-# SPECIALISE instance Eq (T Int) #-} is fine - InstDeclCtxt {} -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys + InstDeclCtxt {} -> checkValidClsArgs flexible_contexts cls tys -- Further checks on head and theta -- in checkInstTermination _ -> checkValidClsArgs flexible_contexts cls tys @@ -1431,7 +1405,7 @@ , text "While checking" <+> pprUserTypeCtxt ctxt ] ) eqPredTyErr, predTupleErr, predIrredErr, - predSuperClassErr, badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) + badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) badQuantHeadErr env pred = ( env , hang (text "Quantified predicate must have a class or type variable head:") @@ -1448,11 +1422,6 @@ = ( env , hang (text "Illegal constraint:" <+> ppr_tidy env pred) 2 (parens constraintKindsMsg) ) -predSuperClassErr env pred - = ( env - , hang (text "Illegal constraint" <+> quotes (ppr_tidy env pred) - <+> text "in a superclass context") - 2 (parens undecidableMsg) ) predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) predTyVarErr env pred @@ -2452,8 +2421,8 @@ -- The /scoped/ type variables from the class-instance header -- should not be alpha-renamed. Inferred ones can be. no_bind_set = mkVarSet inst_tvs - bind_me tv | tv `elemVarSet` no_bind_set = Skolem - | otherwise = BindMe + bind_me tv _ty | tv `elemVarSet` no_bind_set = Apart + | otherwise = BindMe {- Note [Check type-family instance binders] 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.20210101 +version: 0.20210201 license: BSD3 license-file: LICENSE category: Development @@ -80,7 +80,7 @@ hpc == 0.6.*, exceptions == 0.10.*, parsec, - ghc-lib-parser == 0.20210101 + ghc-lib-parser == 0.20210201 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns @@ -216,6 +216,7 @@ GHC.Driver.Config, GHC.Driver.Env, GHC.Driver.Env.Types, + GHC.Driver.Errors, GHC.Driver.Flags, GHC.Driver.Hooks, GHC.Driver.Monad, @@ -405,6 +406,14 @@ GHCi.Message, GHCi.RemoteTypes, GHCi.TH.Binary, + Language.Haskell.Syntax, + Language.Haskell.Syntax.Binds, + Language.Haskell.Syntax.Decls, + Language.Haskell.Syntax.Expr, + Language.Haskell.Syntax.Extension, + Language.Haskell.Syntax.Lit, + Language.Haskell.Syntax.Pat, + Language.Haskell.Syntax.Type, Language.Haskell.TH, Language.Haskell.TH.LanguageExtensions, Language.Haskell.TH.Lib, diff --git a/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl b/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl @@ -10,6 +10,12 @@ primOpCanFail Word16QuotOp = True primOpCanFail Word16RemOp = True primOpCanFail Word16QuotRemOp = True +primOpCanFail Int32QuotOp = True +primOpCanFail Int32RemOp = True +primOpCanFail Int32QuotRemOp = True +primOpCanFail Word32QuotOp = True +primOpCanFail Word32RemOp = True +primOpCanFail Word32QuotRemOp = True primOpCanFail IntQuotOp = True primOpCanFail IntRemOp = True primOpCanFail IntQuotRemOp = True diff --git a/ghc-lib/stage0/compiler/build/primop-code-size.hs-incl b/ghc-lib/stage0/compiler/build/primop-code-size.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-code-size.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-code-size.hs-incl @@ -1,4 +1,10 @@ primOpCodeSize OrdOp = 0 +primOpCodeSize Int8ToWord8Op = 0 +primOpCodeSize Word8ToInt8Op = 0 +primOpCodeSize Int16ToWord16Op = 0 +primOpCodeSize Word16ToInt16Op = 0 +primOpCodeSize Int32ToWord32Op = 0 +primOpCodeSize Word32ToInt32Op = 0 primOpCodeSize IntAddCOp = 2 primOpCodeSize IntSubCOp = 2 primOpCodeSize ChrOp = 0 diff --git a/ghc-lib/stage0/compiler/build/primop-commutable.hs-incl b/ghc-lib/stage0/compiler/build/primop-commutable.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-commutable.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-commutable.hs-incl @@ -4,10 +4,23 @@ commutableOp Int8MulOp = True commutableOp Word8AddOp = True commutableOp Word8MulOp = True +commutableOp Word8AndOp = True +commutableOp Word8OrOp = True +commutableOp Word8XorOp = True commutableOp Int16AddOp = True commutableOp Int16MulOp = True commutableOp Word16AddOp = True commutableOp Word16MulOp = True +commutableOp Word16AndOp = True +commutableOp Word16OrOp = True +commutableOp Word16XorOp = True +commutableOp Int32AddOp = True +commutableOp Int32MulOp = True +commutableOp Word32AddOp = True +commutableOp Word32MulOp = True +commutableOp Word32AndOp = True +commutableOp Word32OrOp = True +commutableOp Word32XorOp = True commutableOp IntAddOp = True commutableOp IntMulOp = True commutableOp IntMulMayOfloOp = True 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 @@ -6,8 +6,8 @@ | CharLtOp | CharLeOp | OrdOp - | Int8ExtendOp - | Int8NarrowOp + | Int8ToIntOp + | IntToInt8Op | Int8NegOp | Int8AddOp | Int8SubOp @@ -15,29 +15,39 @@ | Int8QuotOp | Int8RemOp | Int8QuotRemOp + | Int8SllOp + | Int8SraOp + | Int8SrlOp + | Int8ToWord8Op | Int8EqOp | Int8GeOp | Int8GtOp | Int8LeOp | Int8LtOp | Int8NeOp - | Word8ExtendOp - | Word8NarrowOp - | Word8NotOp + | Word8ToWordOp + | WordToWord8Op | Word8AddOp | Word8SubOp | Word8MulOp | Word8QuotOp | Word8RemOp | Word8QuotRemOp + | Word8AndOp + | Word8OrOp + | Word8XorOp + | Word8NotOp + | Word8SllOp + | Word8SrlOp + | Word8ToInt8Op | Word8EqOp | Word8GeOp | Word8GtOp | Word8LeOp | Word8LtOp | Word8NeOp - | Int16ExtendOp - | Int16NarrowOp + | Int16ToIntOp + | IntToInt16Op | Int16NegOp | Int16AddOp | Int16SubOp @@ -45,31 +55,77 @@ | Int16QuotOp | Int16RemOp | Int16QuotRemOp + | Int16SllOp + | Int16SraOp + | Int16SrlOp + | Int16ToWord16Op | Int16EqOp | Int16GeOp | Int16GtOp | Int16LeOp | Int16LtOp | Int16NeOp - | Word16ExtendOp - | Word16NarrowOp - | Word16NotOp + | Word16ToWordOp + | WordToWord16Op | Word16AddOp | Word16SubOp | Word16MulOp | Word16QuotOp | Word16RemOp | Word16QuotRemOp + | Word16AndOp + | Word16OrOp + | Word16XorOp + | Word16NotOp + | Word16SllOp + | Word16SrlOp + | Word16ToInt16Op | Word16EqOp | Word16GeOp | Word16GtOp | Word16LeOp | Word16LtOp | Word16NeOp - | Int32ExtendOp - | Int32NarrowOp - | Word32ExtendOp - | Word32NarrowOp + | Int32ToIntOp + | IntToInt32Op + | Int32NegOp + | Int32AddOp + | Int32SubOp + | Int32MulOp + | Int32QuotOp + | Int32RemOp + | Int32QuotRemOp + | Int32SllOp + | Int32SraOp + | Int32SrlOp + | Int32ToWord32Op + | Int32EqOp + | Int32GeOp + | Int32GtOp + | Int32LeOp + | Int32LtOp + | Int32NeOp + | Word32ToWordOp + | WordToWord32Op + | Word32AddOp + | Word32SubOp + | Word32MulOp + | Word32QuotOp + | Word32RemOp + | Word32QuotRemOp + | Word32AndOp + | Word32OrOp + | Word32XorOp + | Word32NotOp + | Word32SllOp + | Word32SrlOp + | Word32ToInt32Op + | Word32EqOp + | Word32GeOp + | Word32GtOp + | Word32LeOp + | Word32LtOp + | Word32NeOp | IntAddOp | IntSubOp | IntMulOp 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 @@ -5,8 +5,8 @@ , CharLtOp , CharLeOp , OrdOp - , Int8ExtendOp - , Int8NarrowOp + , Int8ToIntOp + , IntToInt8Op , Int8NegOp , Int8AddOp , Int8SubOp @@ -14,29 +14,39 @@ , Int8QuotOp , Int8RemOp , Int8QuotRemOp + , Int8SllOp + , Int8SraOp + , Int8SrlOp + , Int8ToWord8Op , Int8EqOp , Int8GeOp , Int8GtOp , Int8LeOp , Int8LtOp , Int8NeOp - , Word8ExtendOp - , Word8NarrowOp - , Word8NotOp + , Word8ToWordOp + , WordToWord8Op , Word8AddOp , Word8SubOp , Word8MulOp , Word8QuotOp , Word8RemOp , Word8QuotRemOp + , Word8AndOp + , Word8OrOp + , Word8XorOp + , Word8NotOp + , Word8SllOp + , Word8SrlOp + , Word8ToInt8Op , Word8EqOp , Word8GeOp , Word8GtOp , Word8LeOp , Word8LtOp , Word8NeOp - , Int16ExtendOp - , Int16NarrowOp + , Int16ToIntOp + , IntToInt16Op , Int16NegOp , Int16AddOp , Int16SubOp @@ -44,31 +54,77 @@ , Int16QuotOp , Int16RemOp , Int16QuotRemOp + , Int16SllOp + , Int16SraOp + , Int16SrlOp + , Int16ToWord16Op , Int16EqOp , Int16GeOp , Int16GtOp , Int16LeOp , Int16LtOp , Int16NeOp - , Word16ExtendOp - , Word16NarrowOp - , Word16NotOp + , Word16ToWordOp + , WordToWord16Op , Word16AddOp , Word16SubOp , Word16MulOp , Word16QuotOp , Word16RemOp , Word16QuotRemOp + , Word16AndOp + , Word16OrOp + , Word16XorOp + , Word16NotOp + , Word16SllOp + , Word16SrlOp + , Word16ToInt16Op , Word16EqOp , Word16GeOp , Word16GtOp , Word16LeOp , Word16LtOp , Word16NeOp - , Int32ExtendOp - , Int32NarrowOp - , Word32ExtendOp - , Word32NarrowOp + , Int32ToIntOp + , IntToInt32Op + , Int32NegOp + , Int32AddOp + , Int32SubOp + , Int32MulOp + , Int32QuotOp + , Int32RemOp + , Int32QuotRemOp + , Int32SllOp + , Int32SraOp + , Int32SrlOp + , Int32ToWord32Op + , Int32EqOp + , Int32GeOp + , Int32GtOp + , Int32LeOp + , Int32LtOp + , Int32NeOp + , Word32ToWordOp + , WordToWord32Op + , Word32AddOp + , Word32SubOp + , Word32MulOp + , Word32QuotOp + , Word32RemOp + , Word32QuotRemOp + , Word32AndOp + , Word32OrOp + , Word32XorOp + , Word32NotOp + , Word32SllOp + , Word32SrlOp + , Word32ToInt32Op + , Word32EqOp + , Word32GeOp + , Word32GtOp + , Word32LeOp + , Word32LtOp + , Word32NeOp , IntAddOp , IntSubOp , IntMulOp 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 @@ -5,8 +5,8 @@ primOpInfo CharLtOp = mkCompare (fsLit "ltChar#") charPrimTy primOpInfo CharLeOp = mkCompare (fsLit "leChar#") charPrimTy primOpInfo OrdOp = mkGenPrimOp (fsLit "ord#") [] [charPrimTy] (intPrimTy) -primOpInfo Int8ExtendOp = mkGenPrimOp (fsLit "extendInt8#") [] [int8PrimTy] (intPrimTy) -primOpInfo Int8NarrowOp = mkGenPrimOp (fsLit "narrowInt8#") [] [intPrimTy] (int8PrimTy) +primOpInfo Int8ToIntOp = mkGenPrimOp (fsLit "extendInt8#") [] [int8PrimTy] (intPrimTy) +primOpInfo IntToInt8Op = mkGenPrimOp (fsLit "narrowInt8#") [] [intPrimTy] (int8PrimTy) primOpInfo Int8NegOp = mkGenPrimOp (fsLit "negateInt8#") [] [int8PrimTy] (int8PrimTy) primOpInfo Int8AddOp = mkGenPrimOp (fsLit "plusInt8#") [] [int8PrimTy, int8PrimTy] (int8PrimTy) primOpInfo Int8SubOp = mkGenPrimOp (fsLit "subInt8#") [] [int8PrimTy, int8PrimTy] (int8PrimTy) @@ -14,29 +14,39 @@ primOpInfo Int8QuotOp = mkGenPrimOp (fsLit "quotInt8#") [] [int8PrimTy, int8PrimTy] (int8PrimTy) primOpInfo Int8RemOp = mkGenPrimOp (fsLit "remInt8#") [] [int8PrimTy, int8PrimTy] (int8PrimTy) primOpInfo Int8QuotRemOp = mkGenPrimOp (fsLit "quotRemInt8#") [] [int8PrimTy, int8PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy])) +primOpInfo Int8SllOp = mkGenPrimOp (fsLit "uncheckedShiftLInt8#") [] [int8PrimTy, intPrimTy] (int8PrimTy) +primOpInfo Int8SraOp = mkGenPrimOp (fsLit "uncheckedShiftRAInt8#") [] [int8PrimTy, intPrimTy] (int8PrimTy) +primOpInfo Int8SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRLInt8#") [] [int8PrimTy, intPrimTy] (int8PrimTy) +primOpInfo Int8ToWord8Op = mkGenPrimOp (fsLit "int8ToWord8#") [] [int8PrimTy] (word8PrimTy) primOpInfo Int8EqOp = mkCompare (fsLit "eqInt8#") int8PrimTy primOpInfo Int8GeOp = mkCompare (fsLit "geInt8#") int8PrimTy primOpInfo Int8GtOp = mkCompare (fsLit "gtInt8#") int8PrimTy primOpInfo Int8LeOp = mkCompare (fsLit "leInt8#") int8PrimTy primOpInfo Int8LtOp = mkCompare (fsLit "ltInt8#") int8PrimTy primOpInfo Int8NeOp = mkCompare (fsLit "neInt8#") int8PrimTy -primOpInfo Word8ExtendOp = mkGenPrimOp (fsLit "extendWord8#") [] [word8PrimTy] (wordPrimTy) -primOpInfo Word8NarrowOp = mkGenPrimOp (fsLit "narrowWord8#") [] [wordPrimTy] (word8PrimTy) -primOpInfo Word8NotOp = mkGenPrimOp (fsLit "notWord8#") [] [word8PrimTy] (word8PrimTy) +primOpInfo Word8ToWordOp = mkGenPrimOp (fsLit "extendWord8#") [] [word8PrimTy] (wordPrimTy) +primOpInfo WordToWord8Op = mkGenPrimOp (fsLit "narrowWord8#") [] [wordPrimTy] (word8PrimTy) primOpInfo Word8AddOp = mkGenPrimOp (fsLit "plusWord8#") [] [word8PrimTy, word8PrimTy] (word8PrimTy) primOpInfo Word8SubOp = mkGenPrimOp (fsLit "subWord8#") [] [word8PrimTy, word8PrimTy] (word8PrimTy) primOpInfo Word8MulOp = mkGenPrimOp (fsLit "timesWord8#") [] [word8PrimTy, word8PrimTy] (word8PrimTy) primOpInfo Word8QuotOp = mkGenPrimOp (fsLit "quotWord8#") [] [word8PrimTy, word8PrimTy] (word8PrimTy) primOpInfo Word8RemOp = mkGenPrimOp (fsLit "remWord8#") [] [word8PrimTy, word8PrimTy] (word8PrimTy) primOpInfo Word8QuotRemOp = mkGenPrimOp (fsLit "quotRemWord8#") [] [word8PrimTy, word8PrimTy] ((mkTupleTy Unboxed [word8PrimTy, word8PrimTy])) +primOpInfo Word8AndOp = mkGenPrimOp (fsLit "andWord8#") [] [word8PrimTy, word8PrimTy] (word8PrimTy) +primOpInfo Word8OrOp = mkGenPrimOp (fsLit "orWord8#") [] [word8PrimTy, word8PrimTy] (word8PrimTy) +primOpInfo Word8XorOp = mkGenPrimOp (fsLit "xorWord8#") [] [word8PrimTy, word8PrimTy] (word8PrimTy) +primOpInfo Word8NotOp = mkGenPrimOp (fsLit "notWord8#") [] [word8PrimTy] (word8PrimTy) +primOpInfo Word8SllOp = mkGenPrimOp (fsLit "uncheckedShiftLWord8#") [] [word8PrimTy, intPrimTy] (word8PrimTy) +primOpInfo Word8SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRLWord8#") [] [word8PrimTy, intPrimTy] (word8PrimTy) +primOpInfo Word8ToInt8Op = mkGenPrimOp (fsLit "word8ToInt8#") [] [word8PrimTy] (int8PrimTy) primOpInfo Word8EqOp = mkCompare (fsLit "eqWord8#") word8PrimTy primOpInfo Word8GeOp = mkCompare (fsLit "geWord8#") word8PrimTy primOpInfo Word8GtOp = mkCompare (fsLit "gtWord8#") word8PrimTy primOpInfo Word8LeOp = mkCompare (fsLit "leWord8#") word8PrimTy primOpInfo Word8LtOp = mkCompare (fsLit "ltWord8#") word8PrimTy primOpInfo Word8NeOp = mkCompare (fsLit "neWord8#") word8PrimTy -primOpInfo Int16ExtendOp = mkGenPrimOp (fsLit "extendInt16#") [] [int16PrimTy] (intPrimTy) -primOpInfo Int16NarrowOp = mkGenPrimOp (fsLit "narrowInt16#") [] [intPrimTy] (int16PrimTy) +primOpInfo Int16ToIntOp = mkGenPrimOp (fsLit "extendInt16#") [] [int16PrimTy] (intPrimTy) +primOpInfo IntToInt16Op = mkGenPrimOp (fsLit "narrowInt16#") [] [intPrimTy] (int16PrimTy) primOpInfo Int16NegOp = mkGenPrimOp (fsLit "negateInt16#") [] [int16PrimTy] (int16PrimTy) primOpInfo Int16AddOp = mkGenPrimOp (fsLit "plusInt16#") [] [int16PrimTy, int16PrimTy] (int16PrimTy) primOpInfo Int16SubOp = mkGenPrimOp (fsLit "subInt16#") [] [int16PrimTy, int16PrimTy] (int16PrimTy) @@ -44,31 +54,77 @@ primOpInfo Int16QuotOp = mkGenPrimOp (fsLit "quotInt16#") [] [int16PrimTy, int16PrimTy] (int16PrimTy) primOpInfo Int16RemOp = mkGenPrimOp (fsLit "remInt16#") [] [int16PrimTy, int16PrimTy] (int16PrimTy) primOpInfo Int16QuotRemOp = mkGenPrimOp (fsLit "quotRemInt16#") [] [int16PrimTy, int16PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy])) +primOpInfo Int16SllOp = mkGenPrimOp (fsLit "uncheckedShiftLInt16#") [] [int16PrimTy, intPrimTy] (int16PrimTy) +primOpInfo Int16SraOp = mkGenPrimOp (fsLit "uncheckedShiftRAInt16#") [] [int16PrimTy, intPrimTy] (int16PrimTy) +primOpInfo Int16SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRLInt16#") [] [int16PrimTy, intPrimTy] (int16PrimTy) +primOpInfo Int16ToWord16Op = mkGenPrimOp (fsLit "int16ToWord16#") [] [int16PrimTy] (word16PrimTy) primOpInfo Int16EqOp = mkCompare (fsLit "eqInt16#") int16PrimTy primOpInfo Int16GeOp = mkCompare (fsLit "geInt16#") int16PrimTy primOpInfo Int16GtOp = mkCompare (fsLit "gtInt16#") int16PrimTy primOpInfo Int16LeOp = mkCompare (fsLit "leInt16#") int16PrimTy primOpInfo Int16LtOp = mkCompare (fsLit "ltInt16#") int16PrimTy primOpInfo Int16NeOp = mkCompare (fsLit "neInt16#") int16PrimTy -primOpInfo Word16ExtendOp = mkGenPrimOp (fsLit "extendWord16#") [] [word16PrimTy] (wordPrimTy) -primOpInfo Word16NarrowOp = mkGenPrimOp (fsLit "narrowWord16#") [] [wordPrimTy] (word16PrimTy) -primOpInfo Word16NotOp = mkGenPrimOp (fsLit "notWord16#") [] [word16PrimTy] (word16PrimTy) +primOpInfo Word16ToWordOp = mkGenPrimOp (fsLit "extendWord16#") [] [word16PrimTy] (wordPrimTy) +primOpInfo WordToWord16Op = mkGenPrimOp (fsLit "narrowWord16#") [] [wordPrimTy] (word16PrimTy) primOpInfo Word16AddOp = mkGenPrimOp (fsLit "plusWord16#") [] [word16PrimTy, word16PrimTy] (word16PrimTy) primOpInfo Word16SubOp = mkGenPrimOp (fsLit "subWord16#") [] [word16PrimTy, word16PrimTy] (word16PrimTy) primOpInfo Word16MulOp = mkGenPrimOp (fsLit "timesWord16#") [] [word16PrimTy, word16PrimTy] (word16PrimTy) primOpInfo Word16QuotOp = mkGenPrimOp (fsLit "quotWord16#") [] [word16PrimTy, word16PrimTy] (word16PrimTy) primOpInfo Word16RemOp = mkGenPrimOp (fsLit "remWord16#") [] [word16PrimTy, word16PrimTy] (word16PrimTy) primOpInfo Word16QuotRemOp = mkGenPrimOp (fsLit "quotRemWord16#") [] [word16PrimTy, word16PrimTy] ((mkTupleTy Unboxed [word16PrimTy, word16PrimTy])) +primOpInfo Word16AndOp = mkGenPrimOp (fsLit "andWord16#") [] [word16PrimTy, word16PrimTy] (word16PrimTy) +primOpInfo Word16OrOp = mkGenPrimOp (fsLit "orWord16#") [] [word16PrimTy, word16PrimTy] (word16PrimTy) +primOpInfo Word16XorOp = mkGenPrimOp (fsLit "xorWord16#") [] [word16PrimTy, word16PrimTy] (word16PrimTy) +primOpInfo Word16NotOp = mkGenPrimOp (fsLit "notWord16#") [] [word16PrimTy] (word16PrimTy) +primOpInfo Word16SllOp = mkGenPrimOp (fsLit "uncheckedShiftLWord16#") [] [word16PrimTy, intPrimTy] (word16PrimTy) +primOpInfo Word16SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRLWord16#") [] [word16PrimTy, intPrimTy] (word16PrimTy) +primOpInfo Word16ToInt16Op = mkGenPrimOp (fsLit "word16ToInt16#") [] [word16PrimTy] (int16PrimTy) primOpInfo Word16EqOp = mkCompare (fsLit "eqWord16#") word16PrimTy primOpInfo Word16GeOp = mkCompare (fsLit "geWord16#") word16PrimTy primOpInfo Word16GtOp = mkCompare (fsLit "gtWord16#") word16PrimTy primOpInfo Word16LeOp = mkCompare (fsLit "leWord16#") word16PrimTy primOpInfo Word16LtOp = mkCompare (fsLit "ltWord16#") word16PrimTy primOpInfo Word16NeOp = mkCompare (fsLit "neWord16#") word16PrimTy -primOpInfo Int32ExtendOp = mkGenPrimOp (fsLit "extendInt32#") [] [int32PrimTy] (intPrimTy) -primOpInfo Int32NarrowOp = mkGenPrimOp (fsLit "narrowInt32#") [] [intPrimTy] (int32PrimTy) -primOpInfo Word32ExtendOp = mkGenPrimOp (fsLit "extendWord32#") [] [word32PrimTy] (wordPrimTy) -primOpInfo Word32NarrowOp = mkGenPrimOp (fsLit "narrowWord32#") [] [wordPrimTy] (word32PrimTy) +primOpInfo Int32ToIntOp = mkGenPrimOp (fsLit "extendInt32#") [] [int32PrimTy] (intPrimTy) +primOpInfo IntToInt32Op = mkGenPrimOp (fsLit "narrowInt32#") [] [intPrimTy] (int32PrimTy) +primOpInfo Int32NegOp = mkGenPrimOp (fsLit "negateInt32#") [] [int32PrimTy] (int32PrimTy) +primOpInfo Int32AddOp = mkGenPrimOp (fsLit "plusInt32#") [] [int32PrimTy, int32PrimTy] (int32PrimTy) +primOpInfo Int32SubOp = mkGenPrimOp (fsLit "subInt32#") [] [int32PrimTy, int32PrimTy] (int32PrimTy) +primOpInfo Int32MulOp = mkGenPrimOp (fsLit "timesInt32#") [] [int32PrimTy, int32PrimTy] (int32PrimTy) +primOpInfo Int32QuotOp = mkGenPrimOp (fsLit "quotInt32#") [] [int32PrimTy, int32PrimTy] (int32PrimTy) +primOpInfo Int32RemOp = mkGenPrimOp (fsLit "remInt32#") [] [int32PrimTy, int32PrimTy] (int32PrimTy) +primOpInfo Int32QuotRemOp = mkGenPrimOp (fsLit "quotRemInt32#") [] [int32PrimTy, int32PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy])) +primOpInfo Int32SllOp = mkGenPrimOp (fsLit "uncheckedShiftLInt32#") [] [int32PrimTy, intPrimTy] (int32PrimTy) +primOpInfo Int32SraOp = mkGenPrimOp (fsLit "uncheckedShiftRAInt32#") [] [int32PrimTy, intPrimTy] (int32PrimTy) +primOpInfo Int32SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRLInt32#") [] [int32PrimTy, intPrimTy] (int32PrimTy) +primOpInfo Int32ToWord32Op = mkGenPrimOp (fsLit "int32ToWord32#") [] [int32PrimTy] (word32PrimTy) +primOpInfo Int32EqOp = mkCompare (fsLit "eqInt32#") int32PrimTy +primOpInfo Int32GeOp = mkCompare (fsLit "geInt32#") int32PrimTy +primOpInfo Int32GtOp = mkCompare (fsLit "gtInt32#") int32PrimTy +primOpInfo Int32LeOp = mkCompare (fsLit "leInt32#") int32PrimTy +primOpInfo Int32LtOp = mkCompare (fsLit "ltInt32#") int32PrimTy +primOpInfo Int32NeOp = mkCompare (fsLit "neInt32#") int32PrimTy +primOpInfo Word32ToWordOp = mkGenPrimOp (fsLit "extendWord32#") [] [word32PrimTy] (wordPrimTy) +primOpInfo WordToWord32Op = mkGenPrimOp (fsLit "narrowWord32#") [] [wordPrimTy] (word32PrimTy) +primOpInfo Word32AddOp = mkGenPrimOp (fsLit "plusWord32#") [] [word32PrimTy, word32PrimTy] (word32PrimTy) +primOpInfo Word32SubOp = mkGenPrimOp (fsLit "subWord32#") [] [word32PrimTy, word32PrimTy] (word32PrimTy) +primOpInfo Word32MulOp = mkGenPrimOp (fsLit "timesWord32#") [] [word32PrimTy, word32PrimTy] (word32PrimTy) +primOpInfo Word32QuotOp = mkGenPrimOp (fsLit "quotWord32#") [] [word32PrimTy, word32PrimTy] (word32PrimTy) +primOpInfo Word32RemOp = mkGenPrimOp (fsLit "remWord32#") [] [word32PrimTy, word32PrimTy] (word32PrimTy) +primOpInfo Word32QuotRemOp = mkGenPrimOp (fsLit "quotRemWord32#") [] [word32PrimTy, word32PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy])) +primOpInfo Word32AndOp = mkGenPrimOp (fsLit "andWord32#") [] [word32PrimTy, word32PrimTy] (word32PrimTy) +primOpInfo Word32OrOp = mkGenPrimOp (fsLit "orWord32#") [] [word32PrimTy, word32PrimTy] (word32PrimTy) +primOpInfo Word32XorOp = mkGenPrimOp (fsLit "xorWord32#") [] [word32PrimTy, word32PrimTy] (word32PrimTy) +primOpInfo Word32NotOp = mkGenPrimOp (fsLit "notWord32#") [] [word32PrimTy] (word32PrimTy) +primOpInfo Word32SllOp = mkGenPrimOp (fsLit "uncheckedShiftLWord32#") [] [word32PrimTy, intPrimTy] (word32PrimTy) +primOpInfo Word32SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRLWord32#") [] [word32PrimTy, intPrimTy] (word32PrimTy) +primOpInfo Word32ToInt32Op = mkGenPrimOp (fsLit "word32ToInt32#") [] [word32PrimTy] (int32PrimTy) +primOpInfo Word32EqOp = mkCompare (fsLit "eqWord32#") word32PrimTy +primOpInfo Word32GeOp = mkCompare (fsLit "geWord32#") word32PrimTy +primOpInfo Word32GtOp = mkCompare (fsLit "gtWord32#") word32PrimTy +primOpInfo Word32LeOp = mkCompare (fsLit "leWord32#") word32PrimTy +primOpInfo Word32LtOp = mkCompare (fsLit "ltWord32#") word32PrimTy +primOpInfo Word32NeOp = mkCompare (fsLit "neWord32#") word32PrimTy primOpInfo IntAddOp = mkGenPrimOp (fsLit "+#") [] [intPrimTy, intPrimTy] (intPrimTy) primOpInfo IntSubOp = mkGenPrimOp (fsLit "-#") [] [intPrimTy, intPrimTy] (intPrimTy) primOpInfo IntMulOp = mkGenPrimOp (fsLit "*#") [] [intPrimTy, intPrimTy] (intPrimTy) 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,1227 +1,1283 @@ maxPrimOpTag :: Int -maxPrimOpTag = 1224 -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 Int8ExtendOp = 8 -primOpTag Int8NarrowOp = 9 -primOpTag Int8NegOp = 10 -primOpTag Int8AddOp = 11 -primOpTag Int8SubOp = 12 -primOpTag Int8MulOp = 13 -primOpTag Int8QuotOp = 14 -primOpTag Int8RemOp = 15 -primOpTag Int8QuotRemOp = 16 -primOpTag Int8EqOp = 17 -primOpTag Int8GeOp = 18 -primOpTag Int8GtOp = 19 -primOpTag Int8LeOp = 20 -primOpTag Int8LtOp = 21 -primOpTag Int8NeOp = 22 -primOpTag Word8ExtendOp = 23 -primOpTag Word8NarrowOp = 24 -primOpTag Word8NotOp = 25 -primOpTag Word8AddOp = 26 -primOpTag Word8SubOp = 27 -primOpTag Word8MulOp = 28 -primOpTag Word8QuotOp = 29 -primOpTag Word8RemOp = 30 -primOpTag Word8QuotRemOp = 31 -primOpTag Word8EqOp = 32 -primOpTag Word8GeOp = 33 -primOpTag Word8GtOp = 34 -primOpTag Word8LeOp = 35 -primOpTag Word8LtOp = 36 -primOpTag Word8NeOp = 37 -primOpTag Int16ExtendOp = 38 -primOpTag Int16NarrowOp = 39 -primOpTag Int16NegOp = 40 -primOpTag Int16AddOp = 41 -primOpTag Int16SubOp = 42 -primOpTag Int16MulOp = 43 -primOpTag Int16QuotOp = 44 -primOpTag Int16RemOp = 45 -primOpTag Int16QuotRemOp = 46 -primOpTag Int16EqOp = 47 -primOpTag Int16GeOp = 48 -primOpTag Int16GtOp = 49 -primOpTag Int16LeOp = 50 -primOpTag Int16LtOp = 51 -primOpTag Int16NeOp = 52 -primOpTag Word16ExtendOp = 53 -primOpTag Word16NarrowOp = 54 -primOpTag Word16NotOp = 55 -primOpTag Word16AddOp = 56 -primOpTag Word16SubOp = 57 -primOpTag Word16MulOp = 58 -primOpTag Word16QuotOp = 59 -primOpTag Word16RemOp = 60 -primOpTag Word16QuotRemOp = 61 -primOpTag Word16EqOp = 62 -primOpTag Word16GeOp = 63 -primOpTag Word16GtOp = 64 -primOpTag Word16LeOp = 65 -primOpTag Word16LtOp = 66 -primOpTag Word16NeOp = 67 -primOpTag Int32ExtendOp = 68 -primOpTag Int32NarrowOp = 69 -primOpTag Word32ExtendOp = 70 -primOpTag Word32NarrowOp = 71 -primOpTag IntAddOp = 72 -primOpTag IntSubOp = 73 -primOpTag IntMulOp = 74 -primOpTag IntMul2Op = 75 -primOpTag IntMulMayOfloOp = 76 -primOpTag IntQuotOp = 77 -primOpTag IntRemOp = 78 -primOpTag IntQuotRemOp = 79 -primOpTag IntAndOp = 80 -primOpTag IntOrOp = 81 -primOpTag IntXorOp = 82 -primOpTag IntNotOp = 83 -primOpTag IntNegOp = 84 -primOpTag IntAddCOp = 85 -primOpTag IntSubCOp = 86 -primOpTag IntGtOp = 87 -primOpTag IntGeOp = 88 -primOpTag IntEqOp = 89 -primOpTag IntNeOp = 90 -primOpTag IntLtOp = 91 -primOpTag IntLeOp = 92 -primOpTag ChrOp = 93 -primOpTag IntToWordOp = 94 -primOpTag IntToFloatOp = 95 -primOpTag IntToDoubleOp = 96 -primOpTag WordToFloatOp = 97 -primOpTag WordToDoubleOp = 98 -primOpTag IntSllOp = 99 -primOpTag IntSraOp = 100 -primOpTag IntSrlOp = 101 -primOpTag WordAddOp = 102 -primOpTag WordAddCOp = 103 -primOpTag WordSubCOp = 104 -primOpTag WordAdd2Op = 105 -primOpTag WordSubOp = 106 -primOpTag WordMulOp = 107 -primOpTag WordMul2Op = 108 -primOpTag WordQuotOp = 109 -primOpTag WordRemOp = 110 -primOpTag WordQuotRemOp = 111 -primOpTag WordQuotRem2Op = 112 -primOpTag WordAndOp = 113 -primOpTag WordOrOp = 114 -primOpTag WordXorOp = 115 -primOpTag WordNotOp = 116 -primOpTag WordSllOp = 117 -primOpTag WordSrlOp = 118 -primOpTag WordToIntOp = 119 -primOpTag WordGtOp = 120 -primOpTag WordGeOp = 121 -primOpTag WordEqOp = 122 -primOpTag WordNeOp = 123 -primOpTag WordLtOp = 124 -primOpTag WordLeOp = 125 -primOpTag PopCnt8Op = 126 -primOpTag PopCnt16Op = 127 -primOpTag PopCnt32Op = 128 -primOpTag PopCnt64Op = 129 -primOpTag PopCntOp = 130 -primOpTag Pdep8Op = 131 -primOpTag Pdep16Op = 132 -primOpTag Pdep32Op = 133 -primOpTag Pdep64Op = 134 -primOpTag PdepOp = 135 -primOpTag Pext8Op = 136 -primOpTag Pext16Op = 137 -primOpTag Pext32Op = 138 -primOpTag Pext64Op = 139 -primOpTag PextOp = 140 -primOpTag Clz8Op = 141 -primOpTag Clz16Op = 142 -primOpTag Clz32Op = 143 -primOpTag Clz64Op = 144 -primOpTag ClzOp = 145 -primOpTag Ctz8Op = 146 -primOpTag Ctz16Op = 147 -primOpTag Ctz32Op = 148 -primOpTag Ctz64Op = 149 -primOpTag CtzOp = 150 -primOpTag BSwap16Op = 151 -primOpTag BSwap32Op = 152 -primOpTag BSwap64Op = 153 -primOpTag BSwapOp = 154 -primOpTag BRev8Op = 155 -primOpTag BRev16Op = 156 -primOpTag BRev32Op = 157 -primOpTag BRev64Op = 158 -primOpTag BRevOp = 159 -primOpTag Narrow8IntOp = 160 -primOpTag Narrow16IntOp = 161 -primOpTag Narrow32IntOp = 162 -primOpTag Narrow8WordOp = 163 -primOpTag Narrow16WordOp = 164 -primOpTag Narrow32WordOp = 165 -primOpTag DoubleGtOp = 166 -primOpTag DoubleGeOp = 167 -primOpTag DoubleEqOp = 168 -primOpTag DoubleNeOp = 169 -primOpTag DoubleLtOp = 170 -primOpTag DoubleLeOp = 171 -primOpTag DoubleAddOp = 172 -primOpTag DoubleSubOp = 173 -primOpTag DoubleMulOp = 174 -primOpTag DoubleDivOp = 175 -primOpTag DoubleNegOp = 176 -primOpTag DoubleFabsOp = 177 -primOpTag DoubleToIntOp = 178 -primOpTag DoubleToFloatOp = 179 -primOpTag DoubleExpOp = 180 -primOpTag DoubleExpM1Op = 181 -primOpTag DoubleLogOp = 182 -primOpTag DoubleLog1POp = 183 -primOpTag DoubleSqrtOp = 184 -primOpTag DoubleSinOp = 185 -primOpTag DoubleCosOp = 186 -primOpTag DoubleTanOp = 187 -primOpTag DoubleAsinOp = 188 -primOpTag DoubleAcosOp = 189 -primOpTag DoubleAtanOp = 190 -primOpTag DoubleSinhOp = 191 -primOpTag DoubleCoshOp = 192 -primOpTag DoubleTanhOp = 193 -primOpTag DoubleAsinhOp = 194 -primOpTag DoubleAcoshOp = 195 -primOpTag DoubleAtanhOp = 196 -primOpTag DoublePowerOp = 197 -primOpTag DoubleDecode_2IntOp = 198 -primOpTag DoubleDecode_Int64Op = 199 -primOpTag FloatGtOp = 200 -primOpTag FloatGeOp = 201 -primOpTag FloatEqOp = 202 -primOpTag FloatNeOp = 203 -primOpTag FloatLtOp = 204 -primOpTag FloatLeOp = 205 -primOpTag FloatAddOp = 206 -primOpTag FloatSubOp = 207 -primOpTag FloatMulOp = 208 -primOpTag FloatDivOp = 209 -primOpTag FloatNegOp = 210 -primOpTag FloatFabsOp = 211 -primOpTag FloatToIntOp = 212 -primOpTag FloatExpOp = 213 -primOpTag FloatExpM1Op = 214 -primOpTag FloatLogOp = 215 -primOpTag FloatLog1POp = 216 -primOpTag FloatSqrtOp = 217 -primOpTag FloatSinOp = 218 -primOpTag FloatCosOp = 219 -primOpTag FloatTanOp = 220 -primOpTag FloatAsinOp = 221 -primOpTag FloatAcosOp = 222 -primOpTag FloatAtanOp = 223 -primOpTag FloatSinhOp = 224 -primOpTag FloatCoshOp = 225 -primOpTag FloatTanhOp = 226 -primOpTag FloatAsinhOp = 227 -primOpTag FloatAcoshOp = 228 -primOpTag FloatAtanhOp = 229 -primOpTag FloatPowerOp = 230 -primOpTag FloatToDoubleOp = 231 -primOpTag FloatDecode_IntOp = 232 -primOpTag NewArrayOp = 233 -primOpTag SameMutableArrayOp = 234 -primOpTag ReadArrayOp = 235 -primOpTag WriteArrayOp = 236 -primOpTag SizeofArrayOp = 237 -primOpTag SizeofMutableArrayOp = 238 -primOpTag IndexArrayOp = 239 -primOpTag UnsafeFreezeArrayOp = 240 -primOpTag UnsafeThawArrayOp = 241 -primOpTag CopyArrayOp = 242 -primOpTag CopyMutableArrayOp = 243 -primOpTag CloneArrayOp = 244 -primOpTag CloneMutableArrayOp = 245 -primOpTag FreezeArrayOp = 246 -primOpTag ThawArrayOp = 247 -primOpTag CasArrayOp = 248 -primOpTag NewSmallArrayOp = 249 -primOpTag SameSmallMutableArrayOp = 250 -primOpTag ShrinkSmallMutableArrayOp_Char = 251 -primOpTag ReadSmallArrayOp = 252 -primOpTag WriteSmallArrayOp = 253 -primOpTag SizeofSmallArrayOp = 254 -primOpTag SizeofSmallMutableArrayOp = 255 -primOpTag GetSizeofSmallMutableArrayOp = 256 -primOpTag IndexSmallArrayOp = 257 -primOpTag UnsafeFreezeSmallArrayOp = 258 -primOpTag UnsafeThawSmallArrayOp = 259 -primOpTag CopySmallArrayOp = 260 -primOpTag CopySmallMutableArrayOp = 261 -primOpTag CloneSmallArrayOp = 262 -primOpTag CloneSmallMutableArrayOp = 263 -primOpTag FreezeSmallArrayOp = 264 -primOpTag ThawSmallArrayOp = 265 -primOpTag CasSmallArrayOp = 266 -primOpTag NewByteArrayOp_Char = 267 -primOpTag NewPinnedByteArrayOp_Char = 268 -primOpTag NewAlignedPinnedByteArrayOp_Char = 269 -primOpTag MutableByteArrayIsPinnedOp = 270 -primOpTag ByteArrayIsPinnedOp = 271 -primOpTag ByteArrayContents_Char = 272 -primOpTag SameMutableByteArrayOp = 273 -primOpTag ShrinkMutableByteArrayOp_Char = 274 -primOpTag ResizeMutableByteArrayOp_Char = 275 -primOpTag UnsafeFreezeByteArrayOp = 276 -primOpTag SizeofByteArrayOp = 277 -primOpTag SizeofMutableByteArrayOp = 278 -primOpTag GetSizeofMutableByteArrayOp = 279 -primOpTag IndexByteArrayOp_Char = 280 -primOpTag IndexByteArrayOp_WideChar = 281 -primOpTag IndexByteArrayOp_Int = 282 -primOpTag IndexByteArrayOp_Word = 283 -primOpTag IndexByteArrayOp_Addr = 284 -primOpTag IndexByteArrayOp_Float = 285 -primOpTag IndexByteArrayOp_Double = 286 -primOpTag IndexByteArrayOp_StablePtr = 287 -primOpTag IndexByteArrayOp_Int8 = 288 -primOpTag IndexByteArrayOp_Int16 = 289 -primOpTag IndexByteArrayOp_Int32 = 290 -primOpTag IndexByteArrayOp_Int64 = 291 -primOpTag IndexByteArrayOp_Word8 = 292 -primOpTag IndexByteArrayOp_Word16 = 293 -primOpTag IndexByteArrayOp_Word32 = 294 -primOpTag IndexByteArrayOp_Word64 = 295 -primOpTag IndexByteArrayOp_Word8AsChar = 296 -primOpTag IndexByteArrayOp_Word8AsWideChar = 297 -primOpTag IndexByteArrayOp_Word8AsInt = 298 -primOpTag IndexByteArrayOp_Word8AsWord = 299 -primOpTag IndexByteArrayOp_Word8AsAddr = 300 -primOpTag IndexByteArrayOp_Word8AsFloat = 301 -primOpTag IndexByteArrayOp_Word8AsDouble = 302 -primOpTag IndexByteArrayOp_Word8AsStablePtr = 303 -primOpTag IndexByteArrayOp_Word8AsInt16 = 304 -primOpTag IndexByteArrayOp_Word8AsInt32 = 305 -primOpTag IndexByteArrayOp_Word8AsInt64 = 306 -primOpTag IndexByteArrayOp_Word8AsWord16 = 307 -primOpTag IndexByteArrayOp_Word8AsWord32 = 308 -primOpTag IndexByteArrayOp_Word8AsWord64 = 309 -primOpTag ReadByteArrayOp_Char = 310 -primOpTag ReadByteArrayOp_WideChar = 311 -primOpTag ReadByteArrayOp_Int = 312 -primOpTag ReadByteArrayOp_Word = 313 -primOpTag ReadByteArrayOp_Addr = 314 -primOpTag ReadByteArrayOp_Float = 315 -primOpTag ReadByteArrayOp_Double = 316 -primOpTag ReadByteArrayOp_StablePtr = 317 -primOpTag ReadByteArrayOp_Int8 = 318 -primOpTag ReadByteArrayOp_Int16 = 319 -primOpTag ReadByteArrayOp_Int32 = 320 -primOpTag ReadByteArrayOp_Int64 = 321 -primOpTag ReadByteArrayOp_Word8 = 322 -primOpTag ReadByteArrayOp_Word16 = 323 -primOpTag ReadByteArrayOp_Word32 = 324 -primOpTag ReadByteArrayOp_Word64 = 325 -primOpTag ReadByteArrayOp_Word8AsChar = 326 -primOpTag ReadByteArrayOp_Word8AsWideChar = 327 -primOpTag ReadByteArrayOp_Word8AsInt = 328 -primOpTag ReadByteArrayOp_Word8AsWord = 329 -primOpTag ReadByteArrayOp_Word8AsAddr = 330 -primOpTag ReadByteArrayOp_Word8AsFloat = 331 -primOpTag ReadByteArrayOp_Word8AsDouble = 332 -primOpTag ReadByteArrayOp_Word8AsStablePtr = 333 -primOpTag ReadByteArrayOp_Word8AsInt16 = 334 -primOpTag ReadByteArrayOp_Word8AsInt32 = 335 -primOpTag ReadByteArrayOp_Word8AsInt64 = 336 -primOpTag ReadByteArrayOp_Word8AsWord16 = 337 -primOpTag ReadByteArrayOp_Word8AsWord32 = 338 -primOpTag ReadByteArrayOp_Word8AsWord64 = 339 -primOpTag WriteByteArrayOp_Char = 340 -primOpTag WriteByteArrayOp_WideChar = 341 -primOpTag WriteByteArrayOp_Int = 342 -primOpTag WriteByteArrayOp_Word = 343 -primOpTag WriteByteArrayOp_Addr = 344 -primOpTag WriteByteArrayOp_Float = 345 -primOpTag WriteByteArrayOp_Double = 346 -primOpTag WriteByteArrayOp_StablePtr = 347 -primOpTag WriteByteArrayOp_Int8 = 348 -primOpTag WriteByteArrayOp_Int16 = 349 -primOpTag WriteByteArrayOp_Int32 = 350 -primOpTag WriteByteArrayOp_Int64 = 351 -primOpTag WriteByteArrayOp_Word8 = 352 -primOpTag WriteByteArrayOp_Word16 = 353 -primOpTag WriteByteArrayOp_Word32 = 354 -primOpTag WriteByteArrayOp_Word64 = 355 -primOpTag WriteByteArrayOp_Word8AsChar = 356 -primOpTag WriteByteArrayOp_Word8AsWideChar = 357 -primOpTag WriteByteArrayOp_Word8AsInt = 358 -primOpTag WriteByteArrayOp_Word8AsWord = 359 -primOpTag WriteByteArrayOp_Word8AsAddr = 360 -primOpTag WriteByteArrayOp_Word8AsFloat = 361 -primOpTag WriteByteArrayOp_Word8AsDouble = 362 -primOpTag WriteByteArrayOp_Word8AsStablePtr = 363 -primOpTag WriteByteArrayOp_Word8AsInt16 = 364 -primOpTag WriteByteArrayOp_Word8AsInt32 = 365 -primOpTag WriteByteArrayOp_Word8AsInt64 = 366 -primOpTag WriteByteArrayOp_Word8AsWord16 = 367 -primOpTag WriteByteArrayOp_Word8AsWord32 = 368 -primOpTag WriteByteArrayOp_Word8AsWord64 = 369 -primOpTag CompareByteArraysOp = 370 -primOpTag CopyByteArrayOp = 371 -primOpTag CopyMutableByteArrayOp = 372 -primOpTag CopyByteArrayToAddrOp = 373 -primOpTag CopyMutableByteArrayToAddrOp = 374 -primOpTag CopyAddrToByteArrayOp = 375 -primOpTag SetByteArrayOp = 376 -primOpTag AtomicReadByteArrayOp_Int = 377 -primOpTag AtomicWriteByteArrayOp_Int = 378 -primOpTag CasByteArrayOp_Int = 379 -primOpTag FetchAddByteArrayOp_Int = 380 -primOpTag FetchSubByteArrayOp_Int = 381 -primOpTag FetchAndByteArrayOp_Int = 382 -primOpTag FetchNandByteArrayOp_Int = 383 -primOpTag FetchOrByteArrayOp_Int = 384 -primOpTag FetchXorByteArrayOp_Int = 385 -primOpTag NewArrayArrayOp = 386 -primOpTag SameMutableArrayArrayOp = 387 -primOpTag UnsafeFreezeArrayArrayOp = 388 -primOpTag SizeofArrayArrayOp = 389 -primOpTag SizeofMutableArrayArrayOp = 390 -primOpTag IndexArrayArrayOp_ByteArray = 391 -primOpTag IndexArrayArrayOp_ArrayArray = 392 -primOpTag ReadArrayArrayOp_ByteArray = 393 -primOpTag ReadArrayArrayOp_MutableByteArray = 394 -primOpTag ReadArrayArrayOp_ArrayArray = 395 -primOpTag ReadArrayArrayOp_MutableArrayArray = 396 -primOpTag WriteArrayArrayOp_ByteArray = 397 -primOpTag WriteArrayArrayOp_MutableByteArray = 398 -primOpTag WriteArrayArrayOp_ArrayArray = 399 -primOpTag WriteArrayArrayOp_MutableArrayArray = 400 -primOpTag CopyArrayArrayOp = 401 -primOpTag CopyMutableArrayArrayOp = 402 -primOpTag AddrAddOp = 403 -primOpTag AddrSubOp = 404 -primOpTag AddrRemOp = 405 -primOpTag AddrToIntOp = 406 -primOpTag IntToAddrOp = 407 -primOpTag AddrGtOp = 408 -primOpTag AddrGeOp = 409 -primOpTag AddrEqOp = 410 -primOpTag AddrNeOp = 411 -primOpTag AddrLtOp = 412 -primOpTag AddrLeOp = 413 -primOpTag IndexOffAddrOp_Char = 414 -primOpTag IndexOffAddrOp_WideChar = 415 -primOpTag IndexOffAddrOp_Int = 416 -primOpTag IndexOffAddrOp_Word = 417 -primOpTag IndexOffAddrOp_Addr = 418 -primOpTag IndexOffAddrOp_Float = 419 -primOpTag IndexOffAddrOp_Double = 420 -primOpTag IndexOffAddrOp_StablePtr = 421 -primOpTag IndexOffAddrOp_Int8 = 422 -primOpTag IndexOffAddrOp_Int16 = 423 -primOpTag IndexOffAddrOp_Int32 = 424 -primOpTag IndexOffAddrOp_Int64 = 425 -primOpTag IndexOffAddrOp_Word8 = 426 -primOpTag IndexOffAddrOp_Word16 = 427 -primOpTag IndexOffAddrOp_Word32 = 428 -primOpTag IndexOffAddrOp_Word64 = 429 -primOpTag ReadOffAddrOp_Char = 430 -primOpTag ReadOffAddrOp_WideChar = 431 -primOpTag ReadOffAddrOp_Int = 432 -primOpTag ReadOffAddrOp_Word = 433 -primOpTag ReadOffAddrOp_Addr = 434 -primOpTag ReadOffAddrOp_Float = 435 -primOpTag ReadOffAddrOp_Double = 436 -primOpTag ReadOffAddrOp_StablePtr = 437 -primOpTag ReadOffAddrOp_Int8 = 438 -primOpTag ReadOffAddrOp_Int16 = 439 -primOpTag ReadOffAddrOp_Int32 = 440 -primOpTag ReadOffAddrOp_Int64 = 441 -primOpTag ReadOffAddrOp_Word8 = 442 -primOpTag ReadOffAddrOp_Word16 = 443 -primOpTag ReadOffAddrOp_Word32 = 444 -primOpTag ReadOffAddrOp_Word64 = 445 -primOpTag WriteOffAddrOp_Char = 446 -primOpTag WriteOffAddrOp_WideChar = 447 -primOpTag WriteOffAddrOp_Int = 448 -primOpTag WriteOffAddrOp_Word = 449 -primOpTag WriteOffAddrOp_Addr = 450 -primOpTag WriteOffAddrOp_Float = 451 -primOpTag WriteOffAddrOp_Double = 452 -primOpTag WriteOffAddrOp_StablePtr = 453 -primOpTag WriteOffAddrOp_Int8 = 454 -primOpTag WriteOffAddrOp_Int16 = 455 -primOpTag WriteOffAddrOp_Int32 = 456 -primOpTag WriteOffAddrOp_Int64 = 457 -primOpTag WriteOffAddrOp_Word8 = 458 -primOpTag WriteOffAddrOp_Word16 = 459 -primOpTag WriteOffAddrOp_Word32 = 460 -primOpTag WriteOffAddrOp_Word64 = 461 -primOpTag InterlockedExchange_Addr = 462 -primOpTag InterlockedExchange_Word = 463 -primOpTag CasAddrOp_Addr = 464 -primOpTag CasAddrOp_Word = 465 -primOpTag FetchAddAddrOp_Word = 466 -primOpTag FetchSubAddrOp_Word = 467 -primOpTag FetchAndAddrOp_Word = 468 -primOpTag FetchNandAddrOp_Word = 469 -primOpTag FetchOrAddrOp_Word = 470 -primOpTag FetchXorAddrOp_Word = 471 -primOpTag AtomicReadAddrOp_Word = 472 -primOpTag AtomicWriteAddrOp_Word = 473 -primOpTag NewMutVarOp = 474 -primOpTag ReadMutVarOp = 475 -primOpTag WriteMutVarOp = 476 -primOpTag SameMutVarOp = 477 -primOpTag AtomicModifyMutVar2Op = 478 -primOpTag AtomicModifyMutVar_Op = 479 -primOpTag CasMutVarOp = 480 -primOpTag CatchOp = 481 -primOpTag RaiseOp = 482 -primOpTag RaiseIOOp = 483 -primOpTag MaskAsyncExceptionsOp = 484 -primOpTag MaskUninterruptibleOp = 485 -primOpTag UnmaskAsyncExceptionsOp = 486 -primOpTag MaskStatus = 487 -primOpTag AtomicallyOp = 488 -primOpTag RetryOp = 489 -primOpTag CatchRetryOp = 490 -primOpTag CatchSTMOp = 491 -primOpTag NewTVarOp = 492 -primOpTag ReadTVarOp = 493 -primOpTag ReadTVarIOOp = 494 -primOpTag WriteTVarOp = 495 -primOpTag SameTVarOp = 496 -primOpTag NewMVarOp = 497 -primOpTag TakeMVarOp = 498 -primOpTag TryTakeMVarOp = 499 -primOpTag PutMVarOp = 500 -primOpTag TryPutMVarOp = 501 -primOpTag ReadMVarOp = 502 -primOpTag TryReadMVarOp = 503 -primOpTag SameMVarOp = 504 -primOpTag IsEmptyMVarOp = 505 -primOpTag NewIOPortrOp = 506 -primOpTag ReadIOPortOp = 507 -primOpTag WriteIOPortOp = 508 -primOpTag SameIOPortOp = 509 -primOpTag DelayOp = 510 -primOpTag WaitReadOp = 511 -primOpTag WaitWriteOp = 512 -primOpTag ForkOp = 513 -primOpTag ForkOnOp = 514 -primOpTag KillThreadOp = 515 -primOpTag YieldOp = 516 -primOpTag MyThreadIdOp = 517 -primOpTag LabelThreadOp = 518 -primOpTag IsCurrentThreadBoundOp = 519 -primOpTag NoDuplicateOp = 520 -primOpTag ThreadStatusOp = 521 -primOpTag MkWeakOp = 522 -primOpTag MkWeakNoFinalizerOp = 523 -primOpTag AddCFinalizerToWeakOp = 524 -primOpTag DeRefWeakOp = 525 -primOpTag FinalizeWeakOp = 526 -primOpTag TouchOp = 527 -primOpTag MakeStablePtrOp = 528 -primOpTag DeRefStablePtrOp = 529 -primOpTag EqStablePtrOp = 530 -primOpTag MakeStableNameOp = 531 -primOpTag EqStableNameOp = 532 -primOpTag StableNameToIntOp = 533 -primOpTag CompactNewOp = 534 -primOpTag CompactResizeOp = 535 -primOpTag CompactContainsOp = 536 -primOpTag CompactContainsAnyOp = 537 -primOpTag CompactGetFirstBlockOp = 538 -primOpTag CompactGetNextBlockOp = 539 -primOpTag CompactAllocateBlockOp = 540 -primOpTag CompactFixupPointersOp = 541 -primOpTag CompactAdd = 542 -primOpTag CompactAddWithSharing = 543 -primOpTag CompactSize = 544 -primOpTag ReallyUnsafePtrEqualityOp = 545 -primOpTag ParOp = 546 -primOpTag SparkOp = 547 -primOpTag SeqOp = 548 -primOpTag GetSparkOp = 549 -primOpTag NumSparks = 550 -primOpTag DataToTagOp = 551 -primOpTag TagToEnumOp = 552 -primOpTag AddrToAnyOp = 553 -primOpTag AnyToAddrOp = 554 -primOpTag MkApUpd0_Op = 555 -primOpTag NewBCOOp = 556 -primOpTag UnpackClosureOp = 557 -primOpTag ClosureSizeOp = 558 -primOpTag GetApStackValOp = 559 -primOpTag GetCCSOfOp = 560 -primOpTag GetCurrentCCSOp = 561 -primOpTag ClearCCSOp = 562 -primOpTag TraceEventOp = 563 -primOpTag TraceEventBinaryOp = 564 -primOpTag TraceMarkerOp = 565 -primOpTag SetThreadAllocationCounter = 566 -primOpTag (VecBroadcastOp IntVec 16 W8) = 567 -primOpTag (VecBroadcastOp IntVec 8 W16) = 568 -primOpTag (VecBroadcastOp IntVec 4 W32) = 569 -primOpTag (VecBroadcastOp IntVec 2 W64) = 570 -primOpTag (VecBroadcastOp IntVec 32 W8) = 571 -primOpTag (VecBroadcastOp IntVec 16 W16) = 572 -primOpTag (VecBroadcastOp IntVec 8 W32) = 573 -primOpTag (VecBroadcastOp IntVec 4 W64) = 574 -primOpTag (VecBroadcastOp IntVec 64 W8) = 575 -primOpTag (VecBroadcastOp IntVec 32 W16) = 576 -primOpTag (VecBroadcastOp IntVec 16 W32) = 577 -primOpTag (VecBroadcastOp IntVec 8 W64) = 578 -primOpTag (VecBroadcastOp WordVec 16 W8) = 579 -primOpTag (VecBroadcastOp WordVec 8 W16) = 580 -primOpTag (VecBroadcastOp WordVec 4 W32) = 581 -primOpTag (VecBroadcastOp WordVec 2 W64) = 582 -primOpTag (VecBroadcastOp WordVec 32 W8) = 583 -primOpTag (VecBroadcastOp WordVec 16 W16) = 584 -primOpTag (VecBroadcastOp WordVec 8 W32) = 585 -primOpTag (VecBroadcastOp WordVec 4 W64) = 586 -primOpTag (VecBroadcastOp WordVec 64 W8) = 587 -primOpTag (VecBroadcastOp WordVec 32 W16) = 588 -primOpTag (VecBroadcastOp WordVec 16 W32) = 589 -primOpTag (VecBroadcastOp WordVec 8 W64) = 590 -primOpTag (VecBroadcastOp FloatVec 4 W32) = 591 -primOpTag (VecBroadcastOp FloatVec 2 W64) = 592 -primOpTag (VecBroadcastOp FloatVec 8 W32) = 593 -primOpTag (VecBroadcastOp FloatVec 4 W64) = 594 -primOpTag (VecBroadcastOp FloatVec 16 W32) = 595 -primOpTag (VecBroadcastOp FloatVec 8 W64) = 596 -primOpTag (VecPackOp IntVec 16 W8) = 597 -primOpTag (VecPackOp IntVec 8 W16) = 598 -primOpTag (VecPackOp IntVec 4 W32) = 599 -primOpTag (VecPackOp IntVec 2 W64) = 600 -primOpTag (VecPackOp IntVec 32 W8) = 601 -primOpTag (VecPackOp IntVec 16 W16) = 602 -primOpTag (VecPackOp IntVec 8 W32) = 603 -primOpTag (VecPackOp IntVec 4 W64) = 604 -primOpTag (VecPackOp IntVec 64 W8) = 605 -primOpTag (VecPackOp IntVec 32 W16) = 606 -primOpTag (VecPackOp IntVec 16 W32) = 607 -primOpTag (VecPackOp IntVec 8 W64) = 608 -primOpTag (VecPackOp WordVec 16 W8) = 609 -primOpTag (VecPackOp WordVec 8 W16) = 610 -primOpTag (VecPackOp WordVec 4 W32) = 611 -primOpTag (VecPackOp WordVec 2 W64) = 612 -primOpTag (VecPackOp WordVec 32 W8) = 613 -primOpTag (VecPackOp WordVec 16 W16) = 614 -primOpTag (VecPackOp WordVec 8 W32) = 615 -primOpTag (VecPackOp WordVec 4 W64) = 616 -primOpTag (VecPackOp WordVec 64 W8) = 617 -primOpTag (VecPackOp WordVec 32 W16) = 618 -primOpTag (VecPackOp WordVec 16 W32) = 619 -primOpTag (VecPackOp WordVec 8 W64) = 620 -primOpTag (VecPackOp FloatVec 4 W32) = 621 -primOpTag (VecPackOp FloatVec 2 W64) = 622 -primOpTag (VecPackOp FloatVec 8 W32) = 623 -primOpTag (VecPackOp FloatVec 4 W64) = 624 -primOpTag (VecPackOp FloatVec 16 W32) = 625 -primOpTag (VecPackOp FloatVec 8 W64) = 626 -primOpTag (VecUnpackOp IntVec 16 W8) = 627 -primOpTag (VecUnpackOp IntVec 8 W16) = 628 -primOpTag (VecUnpackOp IntVec 4 W32) = 629 -primOpTag (VecUnpackOp IntVec 2 W64) = 630 -primOpTag (VecUnpackOp IntVec 32 W8) = 631 -primOpTag (VecUnpackOp IntVec 16 W16) = 632 -primOpTag (VecUnpackOp IntVec 8 W32) = 633 -primOpTag (VecUnpackOp IntVec 4 W64) = 634 -primOpTag (VecUnpackOp IntVec 64 W8) = 635 -primOpTag (VecUnpackOp IntVec 32 W16) = 636 -primOpTag (VecUnpackOp IntVec 16 W32) = 637 -primOpTag (VecUnpackOp IntVec 8 W64) = 638 -primOpTag (VecUnpackOp WordVec 16 W8) = 639 -primOpTag (VecUnpackOp WordVec 8 W16) = 640 -primOpTag (VecUnpackOp WordVec 4 W32) = 641 -primOpTag (VecUnpackOp WordVec 2 W64) = 642 -primOpTag (VecUnpackOp WordVec 32 W8) = 643 -primOpTag (VecUnpackOp WordVec 16 W16) = 644 -primOpTag (VecUnpackOp WordVec 8 W32) = 645 -primOpTag (VecUnpackOp WordVec 4 W64) = 646 -primOpTag (VecUnpackOp WordVec 64 W8) = 647 -primOpTag (VecUnpackOp WordVec 32 W16) = 648 -primOpTag (VecUnpackOp WordVec 16 W32) = 649 -primOpTag (VecUnpackOp WordVec 8 W64) = 650 -primOpTag (VecUnpackOp FloatVec 4 W32) = 651 -primOpTag (VecUnpackOp FloatVec 2 W64) = 652 -primOpTag (VecUnpackOp FloatVec 8 W32) = 653 -primOpTag (VecUnpackOp FloatVec 4 W64) = 654 -primOpTag (VecUnpackOp FloatVec 16 W32) = 655 -primOpTag (VecUnpackOp FloatVec 8 W64) = 656 -primOpTag (VecInsertOp IntVec 16 W8) = 657 -primOpTag (VecInsertOp IntVec 8 W16) = 658 -primOpTag (VecInsertOp IntVec 4 W32) = 659 -primOpTag (VecInsertOp IntVec 2 W64) = 660 -primOpTag (VecInsertOp IntVec 32 W8) = 661 -primOpTag (VecInsertOp IntVec 16 W16) = 662 -primOpTag (VecInsertOp IntVec 8 W32) = 663 -primOpTag (VecInsertOp IntVec 4 W64) = 664 -primOpTag (VecInsertOp IntVec 64 W8) = 665 -primOpTag (VecInsertOp IntVec 32 W16) = 666 -primOpTag (VecInsertOp IntVec 16 W32) = 667 -primOpTag (VecInsertOp IntVec 8 W64) = 668 -primOpTag (VecInsertOp WordVec 16 W8) = 669 -primOpTag (VecInsertOp WordVec 8 W16) = 670 -primOpTag (VecInsertOp WordVec 4 W32) = 671 -primOpTag (VecInsertOp WordVec 2 W64) = 672 -primOpTag (VecInsertOp WordVec 32 W8) = 673 -primOpTag (VecInsertOp WordVec 16 W16) = 674 -primOpTag (VecInsertOp WordVec 8 W32) = 675 -primOpTag (VecInsertOp WordVec 4 W64) = 676 -primOpTag (VecInsertOp WordVec 64 W8) = 677 -primOpTag (VecInsertOp WordVec 32 W16) = 678 -primOpTag (VecInsertOp WordVec 16 W32) = 679 -primOpTag (VecInsertOp WordVec 8 W64) = 680 -primOpTag (VecInsertOp FloatVec 4 W32) = 681 -primOpTag (VecInsertOp FloatVec 2 W64) = 682 -primOpTag (VecInsertOp FloatVec 8 W32) = 683 -primOpTag (VecInsertOp FloatVec 4 W64) = 684 -primOpTag (VecInsertOp FloatVec 16 W32) = 685 -primOpTag (VecInsertOp FloatVec 8 W64) = 686 -primOpTag (VecAddOp IntVec 16 W8) = 687 -primOpTag (VecAddOp IntVec 8 W16) = 688 -primOpTag (VecAddOp IntVec 4 W32) = 689 -primOpTag (VecAddOp IntVec 2 W64) = 690 -primOpTag (VecAddOp IntVec 32 W8) = 691 -primOpTag (VecAddOp IntVec 16 W16) = 692 -primOpTag (VecAddOp IntVec 8 W32) = 693 -primOpTag (VecAddOp IntVec 4 W64) = 694 -primOpTag (VecAddOp IntVec 64 W8) = 695 -primOpTag (VecAddOp IntVec 32 W16) = 696 -primOpTag (VecAddOp IntVec 16 W32) = 697 -primOpTag (VecAddOp IntVec 8 W64) = 698 -primOpTag (VecAddOp WordVec 16 W8) = 699 -primOpTag (VecAddOp WordVec 8 W16) = 700 -primOpTag (VecAddOp WordVec 4 W32) = 701 -primOpTag (VecAddOp WordVec 2 W64) = 702 -primOpTag (VecAddOp WordVec 32 W8) = 703 -primOpTag (VecAddOp WordVec 16 W16) = 704 -primOpTag (VecAddOp WordVec 8 W32) = 705 -primOpTag (VecAddOp WordVec 4 W64) = 706 -primOpTag (VecAddOp WordVec 64 W8) = 707 -primOpTag (VecAddOp WordVec 32 W16) = 708 -primOpTag (VecAddOp WordVec 16 W32) = 709 -primOpTag (VecAddOp WordVec 8 W64) = 710 -primOpTag (VecAddOp FloatVec 4 W32) = 711 -primOpTag (VecAddOp FloatVec 2 W64) = 712 -primOpTag (VecAddOp FloatVec 8 W32) = 713 -primOpTag (VecAddOp FloatVec 4 W64) = 714 -primOpTag (VecAddOp FloatVec 16 W32) = 715 -primOpTag (VecAddOp FloatVec 8 W64) = 716 -primOpTag (VecSubOp IntVec 16 W8) = 717 -primOpTag (VecSubOp IntVec 8 W16) = 718 -primOpTag (VecSubOp IntVec 4 W32) = 719 -primOpTag (VecSubOp IntVec 2 W64) = 720 -primOpTag (VecSubOp IntVec 32 W8) = 721 -primOpTag (VecSubOp IntVec 16 W16) = 722 -primOpTag (VecSubOp IntVec 8 W32) = 723 -primOpTag (VecSubOp IntVec 4 W64) = 724 -primOpTag (VecSubOp IntVec 64 W8) = 725 -primOpTag (VecSubOp IntVec 32 W16) = 726 -primOpTag (VecSubOp IntVec 16 W32) = 727 -primOpTag (VecSubOp IntVec 8 W64) = 728 -primOpTag (VecSubOp WordVec 16 W8) = 729 -primOpTag (VecSubOp WordVec 8 W16) = 730 -primOpTag (VecSubOp WordVec 4 W32) = 731 -primOpTag (VecSubOp WordVec 2 W64) = 732 -primOpTag (VecSubOp WordVec 32 W8) = 733 -primOpTag (VecSubOp WordVec 16 W16) = 734 -primOpTag (VecSubOp WordVec 8 W32) = 735 -primOpTag (VecSubOp WordVec 4 W64) = 736 -primOpTag (VecSubOp WordVec 64 W8) = 737 -primOpTag (VecSubOp WordVec 32 W16) = 738 -primOpTag (VecSubOp WordVec 16 W32) = 739 -primOpTag (VecSubOp WordVec 8 W64) = 740 -primOpTag (VecSubOp FloatVec 4 W32) = 741 -primOpTag (VecSubOp FloatVec 2 W64) = 742 -primOpTag (VecSubOp FloatVec 8 W32) = 743 -primOpTag (VecSubOp FloatVec 4 W64) = 744 -primOpTag (VecSubOp FloatVec 16 W32) = 745 -primOpTag (VecSubOp FloatVec 8 W64) = 746 -primOpTag (VecMulOp IntVec 16 W8) = 747 -primOpTag (VecMulOp IntVec 8 W16) = 748 -primOpTag (VecMulOp IntVec 4 W32) = 749 -primOpTag (VecMulOp IntVec 2 W64) = 750 -primOpTag (VecMulOp IntVec 32 W8) = 751 -primOpTag (VecMulOp IntVec 16 W16) = 752 -primOpTag (VecMulOp IntVec 8 W32) = 753 -primOpTag (VecMulOp IntVec 4 W64) = 754 -primOpTag (VecMulOp IntVec 64 W8) = 755 -primOpTag (VecMulOp IntVec 32 W16) = 756 -primOpTag (VecMulOp IntVec 16 W32) = 757 -primOpTag (VecMulOp IntVec 8 W64) = 758 -primOpTag (VecMulOp WordVec 16 W8) = 759 -primOpTag (VecMulOp WordVec 8 W16) = 760 -primOpTag (VecMulOp WordVec 4 W32) = 761 -primOpTag (VecMulOp WordVec 2 W64) = 762 -primOpTag (VecMulOp WordVec 32 W8) = 763 -primOpTag (VecMulOp WordVec 16 W16) = 764 -primOpTag (VecMulOp WordVec 8 W32) = 765 -primOpTag (VecMulOp WordVec 4 W64) = 766 -primOpTag (VecMulOp WordVec 64 W8) = 767 -primOpTag (VecMulOp WordVec 32 W16) = 768 -primOpTag (VecMulOp WordVec 16 W32) = 769 -primOpTag (VecMulOp WordVec 8 W64) = 770 -primOpTag (VecMulOp FloatVec 4 W32) = 771 -primOpTag (VecMulOp FloatVec 2 W64) = 772 -primOpTag (VecMulOp FloatVec 8 W32) = 773 -primOpTag (VecMulOp FloatVec 4 W64) = 774 -primOpTag (VecMulOp FloatVec 16 W32) = 775 -primOpTag (VecMulOp FloatVec 8 W64) = 776 -primOpTag (VecDivOp FloatVec 4 W32) = 777 -primOpTag (VecDivOp FloatVec 2 W64) = 778 -primOpTag (VecDivOp FloatVec 8 W32) = 779 -primOpTag (VecDivOp FloatVec 4 W64) = 780 -primOpTag (VecDivOp FloatVec 16 W32) = 781 -primOpTag (VecDivOp FloatVec 8 W64) = 782 -primOpTag (VecQuotOp IntVec 16 W8) = 783 -primOpTag (VecQuotOp IntVec 8 W16) = 784 -primOpTag (VecQuotOp IntVec 4 W32) = 785 -primOpTag (VecQuotOp IntVec 2 W64) = 786 -primOpTag (VecQuotOp IntVec 32 W8) = 787 -primOpTag (VecQuotOp IntVec 16 W16) = 788 -primOpTag (VecQuotOp IntVec 8 W32) = 789 -primOpTag (VecQuotOp IntVec 4 W64) = 790 -primOpTag (VecQuotOp IntVec 64 W8) = 791 -primOpTag (VecQuotOp IntVec 32 W16) = 792 -primOpTag (VecQuotOp IntVec 16 W32) = 793 -primOpTag (VecQuotOp IntVec 8 W64) = 794 -primOpTag (VecQuotOp WordVec 16 W8) = 795 -primOpTag (VecQuotOp WordVec 8 W16) = 796 -primOpTag (VecQuotOp WordVec 4 W32) = 797 -primOpTag (VecQuotOp WordVec 2 W64) = 798 -primOpTag (VecQuotOp WordVec 32 W8) = 799 -primOpTag (VecQuotOp WordVec 16 W16) = 800 -primOpTag (VecQuotOp WordVec 8 W32) = 801 -primOpTag (VecQuotOp WordVec 4 W64) = 802 -primOpTag (VecQuotOp WordVec 64 W8) = 803 -primOpTag (VecQuotOp WordVec 32 W16) = 804 -primOpTag (VecQuotOp WordVec 16 W32) = 805 -primOpTag (VecQuotOp WordVec 8 W64) = 806 -primOpTag (VecRemOp IntVec 16 W8) = 807 -primOpTag (VecRemOp IntVec 8 W16) = 808 -primOpTag (VecRemOp IntVec 4 W32) = 809 -primOpTag (VecRemOp IntVec 2 W64) = 810 -primOpTag (VecRemOp IntVec 32 W8) = 811 -primOpTag (VecRemOp IntVec 16 W16) = 812 -primOpTag (VecRemOp IntVec 8 W32) = 813 -primOpTag (VecRemOp IntVec 4 W64) = 814 -primOpTag (VecRemOp IntVec 64 W8) = 815 -primOpTag (VecRemOp IntVec 32 W16) = 816 -primOpTag (VecRemOp IntVec 16 W32) = 817 -primOpTag (VecRemOp IntVec 8 W64) = 818 -primOpTag (VecRemOp WordVec 16 W8) = 819 -primOpTag (VecRemOp WordVec 8 W16) = 820 -primOpTag (VecRemOp WordVec 4 W32) = 821 -primOpTag (VecRemOp WordVec 2 W64) = 822 -primOpTag (VecRemOp WordVec 32 W8) = 823 -primOpTag (VecRemOp WordVec 16 W16) = 824 -primOpTag (VecRemOp WordVec 8 W32) = 825 -primOpTag (VecRemOp WordVec 4 W64) = 826 -primOpTag (VecRemOp WordVec 64 W8) = 827 -primOpTag (VecRemOp WordVec 32 W16) = 828 -primOpTag (VecRemOp WordVec 16 W32) = 829 -primOpTag (VecRemOp WordVec 8 W64) = 830 -primOpTag (VecNegOp IntVec 16 W8) = 831 -primOpTag (VecNegOp IntVec 8 W16) = 832 -primOpTag (VecNegOp IntVec 4 W32) = 833 -primOpTag (VecNegOp IntVec 2 W64) = 834 -primOpTag (VecNegOp IntVec 32 W8) = 835 -primOpTag (VecNegOp IntVec 16 W16) = 836 -primOpTag (VecNegOp IntVec 8 W32) = 837 -primOpTag (VecNegOp IntVec 4 W64) = 838 -primOpTag (VecNegOp IntVec 64 W8) = 839 -primOpTag (VecNegOp IntVec 32 W16) = 840 -primOpTag (VecNegOp IntVec 16 W32) = 841 -primOpTag (VecNegOp IntVec 8 W64) = 842 -primOpTag (VecNegOp FloatVec 4 W32) = 843 -primOpTag (VecNegOp FloatVec 2 W64) = 844 -primOpTag (VecNegOp FloatVec 8 W32) = 845 -primOpTag (VecNegOp FloatVec 4 W64) = 846 -primOpTag (VecNegOp FloatVec 16 W32) = 847 -primOpTag (VecNegOp FloatVec 8 W64) = 848 -primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 849 -primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 850 -primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 851 -primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 852 -primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 853 -primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 854 -primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 855 -primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 856 -primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 857 -primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 858 -primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 859 -primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 860 -primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 861 -primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 862 -primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 863 -primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 864 -primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 865 -primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 866 -primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 867 -primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 868 -primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 869 -primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 870 -primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 871 -primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 872 -primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 873 -primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 874 -primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 875 -primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 876 -primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 877 -primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 878 -primOpTag (VecReadByteArrayOp IntVec 16 W8) = 879 -primOpTag (VecReadByteArrayOp IntVec 8 W16) = 880 -primOpTag (VecReadByteArrayOp IntVec 4 W32) = 881 -primOpTag (VecReadByteArrayOp IntVec 2 W64) = 882 -primOpTag (VecReadByteArrayOp IntVec 32 W8) = 883 -primOpTag (VecReadByteArrayOp IntVec 16 W16) = 884 -primOpTag (VecReadByteArrayOp IntVec 8 W32) = 885 -primOpTag (VecReadByteArrayOp IntVec 4 W64) = 886 -primOpTag (VecReadByteArrayOp IntVec 64 W8) = 887 -primOpTag (VecReadByteArrayOp IntVec 32 W16) = 888 -primOpTag (VecReadByteArrayOp IntVec 16 W32) = 889 -primOpTag (VecReadByteArrayOp IntVec 8 W64) = 890 -primOpTag (VecReadByteArrayOp WordVec 16 W8) = 891 -primOpTag (VecReadByteArrayOp WordVec 8 W16) = 892 -primOpTag (VecReadByteArrayOp WordVec 4 W32) = 893 -primOpTag (VecReadByteArrayOp WordVec 2 W64) = 894 -primOpTag (VecReadByteArrayOp WordVec 32 W8) = 895 -primOpTag (VecReadByteArrayOp WordVec 16 W16) = 896 -primOpTag (VecReadByteArrayOp WordVec 8 W32) = 897 -primOpTag (VecReadByteArrayOp WordVec 4 W64) = 898 -primOpTag (VecReadByteArrayOp WordVec 64 W8) = 899 -primOpTag (VecReadByteArrayOp WordVec 32 W16) = 900 -primOpTag (VecReadByteArrayOp WordVec 16 W32) = 901 -primOpTag (VecReadByteArrayOp WordVec 8 W64) = 902 -primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 903 -primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 904 -primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 905 -primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 906 -primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 907 -primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 908 -primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 909 -primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 910 -primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 911 -primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 912 -primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 913 -primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 914 -primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 915 -primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 916 -primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 917 -primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 918 -primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 919 -primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 920 -primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 921 -primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 922 -primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 923 -primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 924 -primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 925 -primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 926 -primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 927 -primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 928 -primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 929 -primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 930 -primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 931 -primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 932 -primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 933 -primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 934 -primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 935 -primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 936 -primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 937 -primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 938 -primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 939 -primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 940 -primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 941 -primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 942 -primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 943 -primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 944 -primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 945 -primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 946 -primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 947 -primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 948 -primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 949 -primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 950 -primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 951 -primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 952 -primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 953 -primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 954 -primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 955 -primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 956 -primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 957 -primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 958 -primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 959 -primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 960 -primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 961 -primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 962 -primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 963 -primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 964 -primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 965 -primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 966 -primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 967 -primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 968 -primOpTag (VecReadOffAddrOp IntVec 16 W8) = 969 -primOpTag (VecReadOffAddrOp IntVec 8 W16) = 970 -primOpTag (VecReadOffAddrOp IntVec 4 W32) = 971 -primOpTag (VecReadOffAddrOp IntVec 2 W64) = 972 -primOpTag (VecReadOffAddrOp IntVec 32 W8) = 973 -primOpTag (VecReadOffAddrOp IntVec 16 W16) = 974 -primOpTag (VecReadOffAddrOp IntVec 8 W32) = 975 -primOpTag (VecReadOffAddrOp IntVec 4 W64) = 976 -primOpTag (VecReadOffAddrOp IntVec 64 W8) = 977 -primOpTag (VecReadOffAddrOp IntVec 32 W16) = 978 -primOpTag (VecReadOffAddrOp IntVec 16 W32) = 979 -primOpTag (VecReadOffAddrOp IntVec 8 W64) = 980 -primOpTag (VecReadOffAddrOp WordVec 16 W8) = 981 -primOpTag (VecReadOffAddrOp WordVec 8 W16) = 982 -primOpTag (VecReadOffAddrOp WordVec 4 W32) = 983 -primOpTag (VecReadOffAddrOp WordVec 2 W64) = 984 -primOpTag (VecReadOffAddrOp WordVec 32 W8) = 985 -primOpTag (VecReadOffAddrOp WordVec 16 W16) = 986 -primOpTag (VecReadOffAddrOp WordVec 8 W32) = 987 -primOpTag (VecReadOffAddrOp WordVec 4 W64) = 988 -primOpTag (VecReadOffAddrOp WordVec 64 W8) = 989 -primOpTag (VecReadOffAddrOp WordVec 32 W16) = 990 -primOpTag (VecReadOffAddrOp WordVec 16 W32) = 991 -primOpTag (VecReadOffAddrOp WordVec 8 W64) = 992 -primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 993 -primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 994 -primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 995 -primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 996 -primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 997 -primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 998 -primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 999 -primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1000 -primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1001 -primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1002 -primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1003 -primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1004 -primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1005 -primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1006 -primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1007 -primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1008 -primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1009 -primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1010 -primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1011 -primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1012 -primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1013 -primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1014 -primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1015 -primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1016 -primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1017 -primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1018 -primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1019 -primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1020 -primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1021 -primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1022 -primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1023 -primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1024 -primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1025 -primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1026 -primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1027 -primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1028 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1029 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1030 -primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1031 -primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1032 -primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1033 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1034 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1035 -primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1036 -primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1037 -primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1038 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1039 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1040 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1041 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1042 -primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1043 -primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1044 -primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1045 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1046 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1047 -primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1048 -primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1049 -primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1050 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1051 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1052 -primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1053 -primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1054 -primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1055 -primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1056 -primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1057 -primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1058 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1059 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1060 -primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1061 -primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1062 -primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1063 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1064 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1065 -primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1066 -primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1067 -primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1068 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1069 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1070 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1071 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1072 -primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1073 -primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1074 -primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1075 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1076 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1077 -primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1078 -primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1079 -primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1080 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1081 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1082 -primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1083 -primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1084 -primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1085 -primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1086 -primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1087 -primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1088 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1089 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1090 -primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1091 -primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1092 -primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1093 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1094 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1095 -primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1096 -primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1097 -primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1098 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1099 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1100 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1101 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1102 -primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1103 -primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1104 -primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1105 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1106 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1107 -primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1108 -primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1109 -primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1110 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1111 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1112 -primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1113 -primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1114 -primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1115 -primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1116 -primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1117 -primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1118 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1119 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1120 -primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1121 -primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1122 -primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1123 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1124 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1125 -primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1126 -primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1127 -primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1128 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1129 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1130 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1131 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1132 -primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1133 -primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1134 -primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1135 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1136 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1137 -primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1138 -primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1139 -primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1140 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1141 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1142 -primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1143 -primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1144 -primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1145 -primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1146 -primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1147 -primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1148 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1149 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1150 -primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1151 -primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1152 -primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1153 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1154 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1155 -primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1156 -primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1157 -primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1158 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1159 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1160 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1161 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1162 -primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1163 -primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1164 -primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1165 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1166 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1167 -primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1168 -primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1169 -primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1170 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1171 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1172 -primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1173 -primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1174 -primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1175 -primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1176 -primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1177 -primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1178 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1179 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1180 -primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1181 -primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1182 -primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1183 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1184 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1185 -primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1186 -primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1187 -primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1188 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1189 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1190 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1191 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1192 -primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1193 -primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1194 -primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1195 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1196 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1197 -primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1198 -primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1199 -primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1200 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1201 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1202 -primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1203 -primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1204 -primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1205 -primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1206 -primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1207 -primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1208 -primOpTag PrefetchByteArrayOp3 = 1209 -primOpTag PrefetchMutableByteArrayOp3 = 1210 -primOpTag PrefetchAddrOp3 = 1211 -primOpTag PrefetchValueOp3 = 1212 -primOpTag PrefetchByteArrayOp2 = 1213 -primOpTag PrefetchMutableByteArrayOp2 = 1214 -primOpTag PrefetchAddrOp2 = 1215 -primOpTag PrefetchValueOp2 = 1216 -primOpTag PrefetchByteArrayOp1 = 1217 -primOpTag PrefetchMutableByteArrayOp1 = 1218 -primOpTag PrefetchAddrOp1 = 1219 -primOpTag PrefetchValueOp1 = 1220 -primOpTag PrefetchByteArrayOp0 = 1221 -primOpTag PrefetchMutableByteArrayOp0 = 1222 -primOpTag PrefetchAddrOp0 = 1223 -primOpTag PrefetchValueOp0 = 1224 +maxPrimOpTag = 1280 +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 SameMutableByteArrayOp = 329 +primOpTag ShrinkMutableByteArrayOp_Char = 330 +primOpTag ResizeMutableByteArrayOp_Char = 331 +primOpTag UnsafeFreezeByteArrayOp = 332 +primOpTag SizeofByteArrayOp = 333 +primOpTag SizeofMutableByteArrayOp = 334 +primOpTag GetSizeofMutableByteArrayOp = 335 +primOpTag IndexByteArrayOp_Char = 336 +primOpTag IndexByteArrayOp_WideChar = 337 +primOpTag IndexByteArrayOp_Int = 338 +primOpTag IndexByteArrayOp_Word = 339 +primOpTag IndexByteArrayOp_Addr = 340 +primOpTag IndexByteArrayOp_Float = 341 +primOpTag IndexByteArrayOp_Double = 342 +primOpTag IndexByteArrayOp_StablePtr = 343 +primOpTag IndexByteArrayOp_Int8 = 344 +primOpTag IndexByteArrayOp_Int16 = 345 +primOpTag IndexByteArrayOp_Int32 = 346 +primOpTag IndexByteArrayOp_Int64 = 347 +primOpTag IndexByteArrayOp_Word8 = 348 +primOpTag IndexByteArrayOp_Word16 = 349 +primOpTag IndexByteArrayOp_Word32 = 350 +primOpTag IndexByteArrayOp_Word64 = 351 +primOpTag IndexByteArrayOp_Word8AsChar = 352 +primOpTag IndexByteArrayOp_Word8AsWideChar = 353 +primOpTag IndexByteArrayOp_Word8AsInt = 354 +primOpTag IndexByteArrayOp_Word8AsWord = 355 +primOpTag IndexByteArrayOp_Word8AsAddr = 356 +primOpTag IndexByteArrayOp_Word8AsFloat = 357 +primOpTag IndexByteArrayOp_Word8AsDouble = 358 +primOpTag IndexByteArrayOp_Word8AsStablePtr = 359 +primOpTag IndexByteArrayOp_Word8AsInt16 = 360 +primOpTag IndexByteArrayOp_Word8AsInt32 = 361 +primOpTag IndexByteArrayOp_Word8AsInt64 = 362 +primOpTag IndexByteArrayOp_Word8AsWord16 = 363 +primOpTag IndexByteArrayOp_Word8AsWord32 = 364 +primOpTag IndexByteArrayOp_Word8AsWord64 = 365 +primOpTag ReadByteArrayOp_Char = 366 +primOpTag ReadByteArrayOp_WideChar = 367 +primOpTag ReadByteArrayOp_Int = 368 +primOpTag ReadByteArrayOp_Word = 369 +primOpTag ReadByteArrayOp_Addr = 370 +primOpTag ReadByteArrayOp_Float = 371 +primOpTag ReadByteArrayOp_Double = 372 +primOpTag ReadByteArrayOp_StablePtr = 373 +primOpTag ReadByteArrayOp_Int8 = 374 +primOpTag ReadByteArrayOp_Int16 = 375 +primOpTag ReadByteArrayOp_Int32 = 376 +primOpTag ReadByteArrayOp_Int64 = 377 +primOpTag ReadByteArrayOp_Word8 = 378 +primOpTag ReadByteArrayOp_Word16 = 379 +primOpTag ReadByteArrayOp_Word32 = 380 +primOpTag ReadByteArrayOp_Word64 = 381 +primOpTag ReadByteArrayOp_Word8AsChar = 382 +primOpTag ReadByteArrayOp_Word8AsWideChar = 383 +primOpTag ReadByteArrayOp_Word8AsInt = 384 +primOpTag ReadByteArrayOp_Word8AsWord = 385 +primOpTag ReadByteArrayOp_Word8AsAddr = 386 +primOpTag ReadByteArrayOp_Word8AsFloat = 387 +primOpTag ReadByteArrayOp_Word8AsDouble = 388 +primOpTag ReadByteArrayOp_Word8AsStablePtr = 389 +primOpTag ReadByteArrayOp_Word8AsInt16 = 390 +primOpTag ReadByteArrayOp_Word8AsInt32 = 391 +primOpTag ReadByteArrayOp_Word8AsInt64 = 392 +primOpTag ReadByteArrayOp_Word8AsWord16 = 393 +primOpTag ReadByteArrayOp_Word8AsWord32 = 394 +primOpTag ReadByteArrayOp_Word8AsWord64 = 395 +primOpTag WriteByteArrayOp_Char = 396 +primOpTag WriteByteArrayOp_WideChar = 397 +primOpTag WriteByteArrayOp_Int = 398 +primOpTag WriteByteArrayOp_Word = 399 +primOpTag WriteByteArrayOp_Addr = 400 +primOpTag WriteByteArrayOp_Float = 401 +primOpTag WriteByteArrayOp_Double = 402 +primOpTag WriteByteArrayOp_StablePtr = 403 +primOpTag WriteByteArrayOp_Int8 = 404 +primOpTag WriteByteArrayOp_Int16 = 405 +primOpTag WriteByteArrayOp_Int32 = 406 +primOpTag WriteByteArrayOp_Int64 = 407 +primOpTag WriteByteArrayOp_Word8 = 408 +primOpTag WriteByteArrayOp_Word16 = 409 +primOpTag WriteByteArrayOp_Word32 = 410 +primOpTag WriteByteArrayOp_Word64 = 411 +primOpTag WriteByteArrayOp_Word8AsChar = 412 +primOpTag WriteByteArrayOp_Word8AsWideChar = 413 +primOpTag WriteByteArrayOp_Word8AsInt = 414 +primOpTag WriteByteArrayOp_Word8AsWord = 415 +primOpTag WriteByteArrayOp_Word8AsAddr = 416 +primOpTag WriteByteArrayOp_Word8AsFloat = 417 +primOpTag WriteByteArrayOp_Word8AsDouble = 418 +primOpTag WriteByteArrayOp_Word8AsStablePtr = 419 +primOpTag WriteByteArrayOp_Word8AsInt16 = 420 +primOpTag WriteByteArrayOp_Word8AsInt32 = 421 +primOpTag WriteByteArrayOp_Word8AsInt64 = 422 +primOpTag WriteByteArrayOp_Word8AsWord16 = 423 +primOpTag WriteByteArrayOp_Word8AsWord32 = 424 +primOpTag WriteByteArrayOp_Word8AsWord64 = 425 +primOpTag CompareByteArraysOp = 426 +primOpTag CopyByteArrayOp = 427 +primOpTag CopyMutableByteArrayOp = 428 +primOpTag CopyByteArrayToAddrOp = 429 +primOpTag CopyMutableByteArrayToAddrOp = 430 +primOpTag CopyAddrToByteArrayOp = 431 +primOpTag SetByteArrayOp = 432 +primOpTag AtomicReadByteArrayOp_Int = 433 +primOpTag AtomicWriteByteArrayOp_Int = 434 +primOpTag CasByteArrayOp_Int = 435 +primOpTag FetchAddByteArrayOp_Int = 436 +primOpTag FetchSubByteArrayOp_Int = 437 +primOpTag FetchAndByteArrayOp_Int = 438 +primOpTag FetchNandByteArrayOp_Int = 439 +primOpTag FetchOrByteArrayOp_Int = 440 +primOpTag FetchXorByteArrayOp_Int = 441 +primOpTag NewArrayArrayOp = 442 +primOpTag SameMutableArrayArrayOp = 443 +primOpTag UnsafeFreezeArrayArrayOp = 444 +primOpTag SizeofArrayArrayOp = 445 +primOpTag SizeofMutableArrayArrayOp = 446 +primOpTag IndexArrayArrayOp_ByteArray = 447 +primOpTag IndexArrayArrayOp_ArrayArray = 448 +primOpTag ReadArrayArrayOp_ByteArray = 449 +primOpTag ReadArrayArrayOp_MutableByteArray = 450 +primOpTag ReadArrayArrayOp_ArrayArray = 451 +primOpTag ReadArrayArrayOp_MutableArrayArray = 452 +primOpTag WriteArrayArrayOp_ByteArray = 453 +primOpTag WriteArrayArrayOp_MutableByteArray = 454 +primOpTag WriteArrayArrayOp_ArrayArray = 455 +primOpTag WriteArrayArrayOp_MutableArrayArray = 456 +primOpTag CopyArrayArrayOp = 457 +primOpTag CopyMutableArrayArrayOp = 458 +primOpTag AddrAddOp = 459 +primOpTag AddrSubOp = 460 +primOpTag AddrRemOp = 461 +primOpTag AddrToIntOp = 462 +primOpTag IntToAddrOp = 463 +primOpTag AddrGtOp = 464 +primOpTag AddrGeOp = 465 +primOpTag AddrEqOp = 466 +primOpTag AddrNeOp = 467 +primOpTag AddrLtOp = 468 +primOpTag AddrLeOp = 469 +primOpTag IndexOffAddrOp_Char = 470 +primOpTag IndexOffAddrOp_WideChar = 471 +primOpTag IndexOffAddrOp_Int = 472 +primOpTag IndexOffAddrOp_Word = 473 +primOpTag IndexOffAddrOp_Addr = 474 +primOpTag IndexOffAddrOp_Float = 475 +primOpTag IndexOffAddrOp_Double = 476 +primOpTag IndexOffAddrOp_StablePtr = 477 +primOpTag IndexOffAddrOp_Int8 = 478 +primOpTag IndexOffAddrOp_Int16 = 479 +primOpTag IndexOffAddrOp_Int32 = 480 +primOpTag IndexOffAddrOp_Int64 = 481 +primOpTag IndexOffAddrOp_Word8 = 482 +primOpTag IndexOffAddrOp_Word16 = 483 +primOpTag IndexOffAddrOp_Word32 = 484 +primOpTag IndexOffAddrOp_Word64 = 485 +primOpTag ReadOffAddrOp_Char = 486 +primOpTag ReadOffAddrOp_WideChar = 487 +primOpTag ReadOffAddrOp_Int = 488 +primOpTag ReadOffAddrOp_Word = 489 +primOpTag ReadOffAddrOp_Addr = 490 +primOpTag ReadOffAddrOp_Float = 491 +primOpTag ReadOffAddrOp_Double = 492 +primOpTag ReadOffAddrOp_StablePtr = 493 +primOpTag ReadOffAddrOp_Int8 = 494 +primOpTag ReadOffAddrOp_Int16 = 495 +primOpTag ReadOffAddrOp_Int32 = 496 +primOpTag ReadOffAddrOp_Int64 = 497 +primOpTag ReadOffAddrOp_Word8 = 498 +primOpTag ReadOffAddrOp_Word16 = 499 +primOpTag ReadOffAddrOp_Word32 = 500 +primOpTag ReadOffAddrOp_Word64 = 501 +primOpTag WriteOffAddrOp_Char = 502 +primOpTag WriteOffAddrOp_WideChar = 503 +primOpTag WriteOffAddrOp_Int = 504 +primOpTag WriteOffAddrOp_Word = 505 +primOpTag WriteOffAddrOp_Addr = 506 +primOpTag WriteOffAddrOp_Float = 507 +primOpTag WriteOffAddrOp_Double = 508 +primOpTag WriteOffAddrOp_StablePtr = 509 +primOpTag WriteOffAddrOp_Int8 = 510 +primOpTag WriteOffAddrOp_Int16 = 511 +primOpTag WriteOffAddrOp_Int32 = 512 +primOpTag WriteOffAddrOp_Int64 = 513 +primOpTag WriteOffAddrOp_Word8 = 514 +primOpTag WriteOffAddrOp_Word16 = 515 +primOpTag WriteOffAddrOp_Word32 = 516 +primOpTag WriteOffAddrOp_Word64 = 517 +primOpTag InterlockedExchange_Addr = 518 +primOpTag InterlockedExchange_Word = 519 +primOpTag CasAddrOp_Addr = 520 +primOpTag CasAddrOp_Word = 521 +primOpTag FetchAddAddrOp_Word = 522 +primOpTag FetchSubAddrOp_Word = 523 +primOpTag FetchAndAddrOp_Word = 524 +primOpTag FetchNandAddrOp_Word = 525 +primOpTag FetchOrAddrOp_Word = 526 +primOpTag FetchXorAddrOp_Word = 527 +primOpTag AtomicReadAddrOp_Word = 528 +primOpTag AtomicWriteAddrOp_Word = 529 +primOpTag NewMutVarOp = 530 +primOpTag ReadMutVarOp = 531 +primOpTag WriteMutVarOp = 532 +primOpTag SameMutVarOp = 533 +primOpTag AtomicModifyMutVar2Op = 534 +primOpTag AtomicModifyMutVar_Op = 535 +primOpTag CasMutVarOp = 536 +primOpTag CatchOp = 537 +primOpTag RaiseOp = 538 +primOpTag RaiseIOOp = 539 +primOpTag MaskAsyncExceptionsOp = 540 +primOpTag MaskUninterruptibleOp = 541 +primOpTag UnmaskAsyncExceptionsOp = 542 +primOpTag MaskStatus = 543 +primOpTag AtomicallyOp = 544 +primOpTag RetryOp = 545 +primOpTag CatchRetryOp = 546 +primOpTag CatchSTMOp = 547 +primOpTag NewTVarOp = 548 +primOpTag ReadTVarOp = 549 +primOpTag ReadTVarIOOp = 550 +primOpTag WriteTVarOp = 551 +primOpTag SameTVarOp = 552 +primOpTag NewMVarOp = 553 +primOpTag TakeMVarOp = 554 +primOpTag TryTakeMVarOp = 555 +primOpTag PutMVarOp = 556 +primOpTag TryPutMVarOp = 557 +primOpTag ReadMVarOp = 558 +primOpTag TryReadMVarOp = 559 +primOpTag SameMVarOp = 560 +primOpTag IsEmptyMVarOp = 561 +primOpTag NewIOPortrOp = 562 +primOpTag ReadIOPortOp = 563 +primOpTag WriteIOPortOp = 564 +primOpTag SameIOPortOp = 565 +primOpTag DelayOp = 566 +primOpTag WaitReadOp = 567 +primOpTag WaitWriteOp = 568 +primOpTag ForkOp = 569 +primOpTag ForkOnOp = 570 +primOpTag KillThreadOp = 571 +primOpTag YieldOp = 572 +primOpTag MyThreadIdOp = 573 +primOpTag LabelThreadOp = 574 +primOpTag IsCurrentThreadBoundOp = 575 +primOpTag NoDuplicateOp = 576 +primOpTag ThreadStatusOp = 577 +primOpTag MkWeakOp = 578 +primOpTag MkWeakNoFinalizerOp = 579 +primOpTag AddCFinalizerToWeakOp = 580 +primOpTag DeRefWeakOp = 581 +primOpTag FinalizeWeakOp = 582 +primOpTag TouchOp = 583 +primOpTag MakeStablePtrOp = 584 +primOpTag DeRefStablePtrOp = 585 +primOpTag EqStablePtrOp = 586 +primOpTag MakeStableNameOp = 587 +primOpTag EqStableNameOp = 588 +primOpTag StableNameToIntOp = 589 +primOpTag CompactNewOp = 590 +primOpTag CompactResizeOp = 591 +primOpTag CompactContainsOp = 592 +primOpTag CompactContainsAnyOp = 593 +primOpTag CompactGetFirstBlockOp = 594 +primOpTag CompactGetNextBlockOp = 595 +primOpTag CompactAllocateBlockOp = 596 +primOpTag CompactFixupPointersOp = 597 +primOpTag CompactAdd = 598 +primOpTag CompactAddWithSharing = 599 +primOpTag CompactSize = 600 +primOpTag ReallyUnsafePtrEqualityOp = 601 +primOpTag ParOp = 602 +primOpTag SparkOp = 603 +primOpTag SeqOp = 604 +primOpTag GetSparkOp = 605 +primOpTag NumSparks = 606 +primOpTag DataToTagOp = 607 +primOpTag TagToEnumOp = 608 +primOpTag AddrToAnyOp = 609 +primOpTag AnyToAddrOp = 610 +primOpTag MkApUpd0_Op = 611 +primOpTag NewBCOOp = 612 +primOpTag UnpackClosureOp = 613 +primOpTag ClosureSizeOp = 614 +primOpTag GetApStackValOp = 615 +primOpTag GetCCSOfOp = 616 +primOpTag GetCurrentCCSOp = 617 +primOpTag ClearCCSOp = 618 +primOpTag TraceEventOp = 619 +primOpTag TraceEventBinaryOp = 620 +primOpTag TraceMarkerOp = 621 +primOpTag SetThreadAllocationCounter = 622 +primOpTag (VecBroadcastOp IntVec 16 W8) = 623 +primOpTag (VecBroadcastOp IntVec 8 W16) = 624 +primOpTag (VecBroadcastOp IntVec 4 W32) = 625 +primOpTag (VecBroadcastOp IntVec 2 W64) = 626 +primOpTag (VecBroadcastOp IntVec 32 W8) = 627 +primOpTag (VecBroadcastOp IntVec 16 W16) = 628 +primOpTag (VecBroadcastOp IntVec 8 W32) = 629 +primOpTag (VecBroadcastOp IntVec 4 W64) = 630 +primOpTag (VecBroadcastOp IntVec 64 W8) = 631 +primOpTag (VecBroadcastOp IntVec 32 W16) = 632 +primOpTag (VecBroadcastOp IntVec 16 W32) = 633 +primOpTag (VecBroadcastOp IntVec 8 W64) = 634 +primOpTag (VecBroadcastOp WordVec 16 W8) = 635 +primOpTag (VecBroadcastOp WordVec 8 W16) = 636 +primOpTag (VecBroadcastOp WordVec 4 W32) = 637 +primOpTag (VecBroadcastOp WordVec 2 W64) = 638 +primOpTag (VecBroadcastOp WordVec 32 W8) = 639 +primOpTag (VecBroadcastOp WordVec 16 W16) = 640 +primOpTag (VecBroadcastOp WordVec 8 W32) = 641 +primOpTag (VecBroadcastOp WordVec 4 W64) = 642 +primOpTag (VecBroadcastOp WordVec 64 W8) = 643 +primOpTag (VecBroadcastOp WordVec 32 W16) = 644 +primOpTag (VecBroadcastOp WordVec 16 W32) = 645 +primOpTag (VecBroadcastOp WordVec 8 W64) = 646 +primOpTag (VecBroadcastOp FloatVec 4 W32) = 647 +primOpTag (VecBroadcastOp FloatVec 2 W64) = 648 +primOpTag (VecBroadcastOp FloatVec 8 W32) = 649 +primOpTag (VecBroadcastOp FloatVec 4 W64) = 650 +primOpTag (VecBroadcastOp FloatVec 16 W32) = 651 +primOpTag (VecBroadcastOp FloatVec 8 W64) = 652 +primOpTag (VecPackOp IntVec 16 W8) = 653 +primOpTag (VecPackOp IntVec 8 W16) = 654 +primOpTag (VecPackOp IntVec 4 W32) = 655 +primOpTag (VecPackOp IntVec 2 W64) = 656 +primOpTag (VecPackOp IntVec 32 W8) = 657 +primOpTag (VecPackOp IntVec 16 W16) = 658 +primOpTag (VecPackOp IntVec 8 W32) = 659 +primOpTag (VecPackOp IntVec 4 W64) = 660 +primOpTag (VecPackOp IntVec 64 W8) = 661 +primOpTag (VecPackOp IntVec 32 W16) = 662 +primOpTag (VecPackOp IntVec 16 W32) = 663 +primOpTag (VecPackOp IntVec 8 W64) = 664 +primOpTag (VecPackOp WordVec 16 W8) = 665 +primOpTag (VecPackOp WordVec 8 W16) = 666 +primOpTag (VecPackOp WordVec 4 W32) = 667 +primOpTag (VecPackOp WordVec 2 W64) = 668 +primOpTag (VecPackOp WordVec 32 W8) = 669 +primOpTag (VecPackOp WordVec 16 W16) = 670 +primOpTag (VecPackOp WordVec 8 W32) = 671 +primOpTag (VecPackOp WordVec 4 W64) = 672 +primOpTag (VecPackOp WordVec 64 W8) = 673 +primOpTag (VecPackOp WordVec 32 W16) = 674 +primOpTag (VecPackOp WordVec 16 W32) = 675 +primOpTag (VecPackOp WordVec 8 W64) = 676 +primOpTag (VecPackOp FloatVec 4 W32) = 677 +primOpTag (VecPackOp FloatVec 2 W64) = 678 +primOpTag (VecPackOp FloatVec 8 W32) = 679 +primOpTag (VecPackOp FloatVec 4 W64) = 680 +primOpTag (VecPackOp FloatVec 16 W32) = 681 +primOpTag (VecPackOp FloatVec 8 W64) = 682 +primOpTag (VecUnpackOp IntVec 16 W8) = 683 +primOpTag (VecUnpackOp IntVec 8 W16) = 684 +primOpTag (VecUnpackOp IntVec 4 W32) = 685 +primOpTag (VecUnpackOp IntVec 2 W64) = 686 +primOpTag (VecUnpackOp IntVec 32 W8) = 687 +primOpTag (VecUnpackOp IntVec 16 W16) = 688 +primOpTag (VecUnpackOp IntVec 8 W32) = 689 +primOpTag (VecUnpackOp IntVec 4 W64) = 690 +primOpTag (VecUnpackOp IntVec 64 W8) = 691 +primOpTag (VecUnpackOp IntVec 32 W16) = 692 +primOpTag (VecUnpackOp IntVec 16 W32) = 693 +primOpTag (VecUnpackOp IntVec 8 W64) = 694 +primOpTag (VecUnpackOp WordVec 16 W8) = 695 +primOpTag (VecUnpackOp WordVec 8 W16) = 696 +primOpTag (VecUnpackOp WordVec 4 W32) = 697 +primOpTag (VecUnpackOp WordVec 2 W64) = 698 +primOpTag (VecUnpackOp WordVec 32 W8) = 699 +primOpTag (VecUnpackOp WordVec 16 W16) = 700 +primOpTag (VecUnpackOp WordVec 8 W32) = 701 +primOpTag (VecUnpackOp WordVec 4 W64) = 702 +primOpTag (VecUnpackOp WordVec 64 W8) = 703 +primOpTag (VecUnpackOp WordVec 32 W16) = 704 +primOpTag (VecUnpackOp WordVec 16 W32) = 705 +primOpTag (VecUnpackOp WordVec 8 W64) = 706 +primOpTag (VecUnpackOp FloatVec 4 W32) = 707 +primOpTag (VecUnpackOp FloatVec 2 W64) = 708 +primOpTag (VecUnpackOp FloatVec 8 W32) = 709 +primOpTag (VecUnpackOp FloatVec 4 W64) = 710 +primOpTag (VecUnpackOp FloatVec 16 W32) = 711 +primOpTag (VecUnpackOp FloatVec 8 W64) = 712 +primOpTag (VecInsertOp IntVec 16 W8) = 713 +primOpTag (VecInsertOp IntVec 8 W16) = 714 +primOpTag (VecInsertOp IntVec 4 W32) = 715 +primOpTag (VecInsertOp IntVec 2 W64) = 716 +primOpTag (VecInsertOp IntVec 32 W8) = 717 +primOpTag (VecInsertOp IntVec 16 W16) = 718 +primOpTag (VecInsertOp IntVec 8 W32) = 719 +primOpTag (VecInsertOp IntVec 4 W64) = 720 +primOpTag (VecInsertOp IntVec 64 W8) = 721 +primOpTag (VecInsertOp IntVec 32 W16) = 722 +primOpTag (VecInsertOp IntVec 16 W32) = 723 +primOpTag (VecInsertOp IntVec 8 W64) = 724 +primOpTag (VecInsertOp WordVec 16 W8) = 725 +primOpTag (VecInsertOp WordVec 8 W16) = 726 +primOpTag (VecInsertOp WordVec 4 W32) = 727 +primOpTag (VecInsertOp WordVec 2 W64) = 728 +primOpTag (VecInsertOp WordVec 32 W8) = 729 +primOpTag (VecInsertOp WordVec 16 W16) = 730 +primOpTag (VecInsertOp WordVec 8 W32) = 731 +primOpTag (VecInsertOp WordVec 4 W64) = 732 +primOpTag (VecInsertOp WordVec 64 W8) = 733 +primOpTag (VecInsertOp WordVec 32 W16) = 734 +primOpTag (VecInsertOp WordVec 16 W32) = 735 +primOpTag (VecInsertOp WordVec 8 W64) = 736 +primOpTag (VecInsertOp FloatVec 4 W32) = 737 +primOpTag (VecInsertOp FloatVec 2 W64) = 738 +primOpTag (VecInsertOp FloatVec 8 W32) = 739 +primOpTag (VecInsertOp FloatVec 4 W64) = 740 +primOpTag (VecInsertOp FloatVec 16 W32) = 741 +primOpTag (VecInsertOp FloatVec 8 W64) = 742 +primOpTag (VecAddOp IntVec 16 W8) = 743 +primOpTag (VecAddOp IntVec 8 W16) = 744 +primOpTag (VecAddOp IntVec 4 W32) = 745 +primOpTag (VecAddOp IntVec 2 W64) = 746 +primOpTag (VecAddOp IntVec 32 W8) = 747 +primOpTag (VecAddOp IntVec 16 W16) = 748 +primOpTag (VecAddOp IntVec 8 W32) = 749 +primOpTag (VecAddOp IntVec 4 W64) = 750 +primOpTag (VecAddOp IntVec 64 W8) = 751 +primOpTag (VecAddOp IntVec 32 W16) = 752 +primOpTag (VecAddOp IntVec 16 W32) = 753 +primOpTag (VecAddOp IntVec 8 W64) = 754 +primOpTag (VecAddOp WordVec 16 W8) = 755 +primOpTag (VecAddOp WordVec 8 W16) = 756 +primOpTag (VecAddOp WordVec 4 W32) = 757 +primOpTag (VecAddOp WordVec 2 W64) = 758 +primOpTag (VecAddOp WordVec 32 W8) = 759 +primOpTag (VecAddOp WordVec 16 W16) = 760 +primOpTag (VecAddOp WordVec 8 W32) = 761 +primOpTag (VecAddOp WordVec 4 W64) = 762 +primOpTag (VecAddOp WordVec 64 W8) = 763 +primOpTag (VecAddOp WordVec 32 W16) = 764 +primOpTag (VecAddOp WordVec 16 W32) = 765 +primOpTag (VecAddOp WordVec 8 W64) = 766 +primOpTag (VecAddOp FloatVec 4 W32) = 767 +primOpTag (VecAddOp FloatVec 2 W64) = 768 +primOpTag (VecAddOp FloatVec 8 W32) = 769 +primOpTag (VecAddOp FloatVec 4 W64) = 770 +primOpTag (VecAddOp FloatVec 16 W32) = 771 +primOpTag (VecAddOp FloatVec 8 W64) = 772 +primOpTag (VecSubOp IntVec 16 W8) = 773 +primOpTag (VecSubOp IntVec 8 W16) = 774 +primOpTag (VecSubOp IntVec 4 W32) = 775 +primOpTag (VecSubOp IntVec 2 W64) = 776 +primOpTag (VecSubOp IntVec 32 W8) = 777 +primOpTag (VecSubOp IntVec 16 W16) = 778 +primOpTag (VecSubOp IntVec 8 W32) = 779 +primOpTag (VecSubOp IntVec 4 W64) = 780 +primOpTag (VecSubOp IntVec 64 W8) = 781 +primOpTag (VecSubOp IntVec 32 W16) = 782 +primOpTag (VecSubOp IntVec 16 W32) = 783 +primOpTag (VecSubOp IntVec 8 W64) = 784 +primOpTag (VecSubOp WordVec 16 W8) = 785 +primOpTag (VecSubOp WordVec 8 W16) = 786 +primOpTag (VecSubOp WordVec 4 W32) = 787 +primOpTag (VecSubOp WordVec 2 W64) = 788 +primOpTag (VecSubOp WordVec 32 W8) = 789 +primOpTag (VecSubOp WordVec 16 W16) = 790 +primOpTag (VecSubOp WordVec 8 W32) = 791 +primOpTag (VecSubOp WordVec 4 W64) = 792 +primOpTag (VecSubOp WordVec 64 W8) = 793 +primOpTag (VecSubOp WordVec 32 W16) = 794 +primOpTag (VecSubOp WordVec 16 W32) = 795 +primOpTag (VecSubOp WordVec 8 W64) = 796 +primOpTag (VecSubOp FloatVec 4 W32) = 797 +primOpTag (VecSubOp FloatVec 2 W64) = 798 +primOpTag (VecSubOp FloatVec 8 W32) = 799 +primOpTag (VecSubOp FloatVec 4 W64) = 800 +primOpTag (VecSubOp FloatVec 16 W32) = 801 +primOpTag (VecSubOp FloatVec 8 W64) = 802 +primOpTag (VecMulOp IntVec 16 W8) = 803 +primOpTag (VecMulOp IntVec 8 W16) = 804 +primOpTag (VecMulOp IntVec 4 W32) = 805 +primOpTag (VecMulOp IntVec 2 W64) = 806 +primOpTag (VecMulOp IntVec 32 W8) = 807 +primOpTag (VecMulOp IntVec 16 W16) = 808 +primOpTag (VecMulOp IntVec 8 W32) = 809 +primOpTag (VecMulOp IntVec 4 W64) = 810 +primOpTag (VecMulOp IntVec 64 W8) = 811 +primOpTag (VecMulOp IntVec 32 W16) = 812 +primOpTag (VecMulOp IntVec 16 W32) = 813 +primOpTag (VecMulOp IntVec 8 W64) = 814 +primOpTag (VecMulOp WordVec 16 W8) = 815 +primOpTag (VecMulOp WordVec 8 W16) = 816 +primOpTag (VecMulOp WordVec 4 W32) = 817 +primOpTag (VecMulOp WordVec 2 W64) = 818 +primOpTag (VecMulOp WordVec 32 W8) = 819 +primOpTag (VecMulOp WordVec 16 W16) = 820 +primOpTag (VecMulOp WordVec 8 W32) = 821 +primOpTag (VecMulOp WordVec 4 W64) = 822 +primOpTag (VecMulOp WordVec 64 W8) = 823 +primOpTag (VecMulOp WordVec 32 W16) = 824 +primOpTag (VecMulOp WordVec 16 W32) = 825 +primOpTag (VecMulOp WordVec 8 W64) = 826 +primOpTag (VecMulOp FloatVec 4 W32) = 827 +primOpTag (VecMulOp FloatVec 2 W64) = 828 +primOpTag (VecMulOp FloatVec 8 W32) = 829 +primOpTag (VecMulOp FloatVec 4 W64) = 830 +primOpTag (VecMulOp FloatVec 16 W32) = 831 +primOpTag (VecMulOp FloatVec 8 W64) = 832 +primOpTag (VecDivOp FloatVec 4 W32) = 833 +primOpTag (VecDivOp FloatVec 2 W64) = 834 +primOpTag (VecDivOp FloatVec 8 W32) = 835 +primOpTag (VecDivOp FloatVec 4 W64) = 836 +primOpTag (VecDivOp FloatVec 16 W32) = 837 +primOpTag (VecDivOp FloatVec 8 W64) = 838 +primOpTag (VecQuotOp IntVec 16 W8) = 839 +primOpTag (VecQuotOp IntVec 8 W16) = 840 +primOpTag (VecQuotOp IntVec 4 W32) = 841 +primOpTag (VecQuotOp IntVec 2 W64) = 842 +primOpTag (VecQuotOp IntVec 32 W8) = 843 +primOpTag (VecQuotOp IntVec 16 W16) = 844 +primOpTag (VecQuotOp IntVec 8 W32) = 845 +primOpTag (VecQuotOp IntVec 4 W64) = 846 +primOpTag (VecQuotOp IntVec 64 W8) = 847 +primOpTag (VecQuotOp IntVec 32 W16) = 848 +primOpTag (VecQuotOp IntVec 16 W32) = 849 +primOpTag (VecQuotOp IntVec 8 W64) = 850 +primOpTag (VecQuotOp WordVec 16 W8) = 851 +primOpTag (VecQuotOp WordVec 8 W16) = 852 +primOpTag (VecQuotOp WordVec 4 W32) = 853 +primOpTag (VecQuotOp WordVec 2 W64) = 854 +primOpTag (VecQuotOp WordVec 32 W8) = 855 +primOpTag (VecQuotOp WordVec 16 W16) = 856 +primOpTag (VecQuotOp WordVec 8 W32) = 857 +primOpTag (VecQuotOp WordVec 4 W64) = 858 +primOpTag (VecQuotOp WordVec 64 W8) = 859 +primOpTag (VecQuotOp WordVec 32 W16) = 860 +primOpTag (VecQuotOp WordVec 16 W32) = 861 +primOpTag (VecQuotOp WordVec 8 W64) = 862 +primOpTag (VecRemOp IntVec 16 W8) = 863 +primOpTag (VecRemOp IntVec 8 W16) = 864 +primOpTag (VecRemOp IntVec 4 W32) = 865 +primOpTag (VecRemOp IntVec 2 W64) = 866 +primOpTag (VecRemOp IntVec 32 W8) = 867 +primOpTag (VecRemOp IntVec 16 W16) = 868 +primOpTag (VecRemOp IntVec 8 W32) = 869 +primOpTag (VecRemOp IntVec 4 W64) = 870 +primOpTag (VecRemOp IntVec 64 W8) = 871 +primOpTag (VecRemOp IntVec 32 W16) = 872 +primOpTag (VecRemOp IntVec 16 W32) = 873 +primOpTag (VecRemOp IntVec 8 W64) = 874 +primOpTag (VecRemOp WordVec 16 W8) = 875 +primOpTag (VecRemOp WordVec 8 W16) = 876 +primOpTag (VecRemOp WordVec 4 W32) = 877 +primOpTag (VecRemOp WordVec 2 W64) = 878 +primOpTag (VecRemOp WordVec 32 W8) = 879 +primOpTag (VecRemOp WordVec 16 W16) = 880 +primOpTag (VecRemOp WordVec 8 W32) = 881 +primOpTag (VecRemOp WordVec 4 W64) = 882 +primOpTag (VecRemOp WordVec 64 W8) = 883 +primOpTag (VecRemOp WordVec 32 W16) = 884 +primOpTag (VecRemOp WordVec 16 W32) = 885 +primOpTag (VecRemOp WordVec 8 W64) = 886 +primOpTag (VecNegOp IntVec 16 W8) = 887 +primOpTag (VecNegOp IntVec 8 W16) = 888 +primOpTag (VecNegOp IntVec 4 W32) = 889 +primOpTag (VecNegOp IntVec 2 W64) = 890 +primOpTag (VecNegOp IntVec 32 W8) = 891 +primOpTag (VecNegOp IntVec 16 W16) = 892 +primOpTag (VecNegOp IntVec 8 W32) = 893 +primOpTag (VecNegOp IntVec 4 W64) = 894 +primOpTag (VecNegOp IntVec 64 W8) = 895 +primOpTag (VecNegOp IntVec 32 W16) = 896 +primOpTag (VecNegOp IntVec 16 W32) = 897 +primOpTag (VecNegOp IntVec 8 W64) = 898 +primOpTag (VecNegOp FloatVec 4 W32) = 899 +primOpTag (VecNegOp FloatVec 2 W64) = 900 +primOpTag (VecNegOp FloatVec 8 W32) = 901 +primOpTag (VecNegOp FloatVec 4 W64) = 902 +primOpTag (VecNegOp FloatVec 16 W32) = 903 +primOpTag (VecNegOp FloatVec 8 W64) = 904 +primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 905 +primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 906 +primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 907 +primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 908 +primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 909 +primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 910 +primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 911 +primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 912 +primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 913 +primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 914 +primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 915 +primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 916 +primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 917 +primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 918 +primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 919 +primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 920 +primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 921 +primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 922 +primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 923 +primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 924 +primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 925 +primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 926 +primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 927 +primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 928 +primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 929 +primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 930 +primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 931 +primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 932 +primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 933 +primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 934 +primOpTag (VecReadByteArrayOp IntVec 16 W8) = 935 +primOpTag (VecReadByteArrayOp IntVec 8 W16) = 936 +primOpTag (VecReadByteArrayOp IntVec 4 W32) = 937 +primOpTag (VecReadByteArrayOp IntVec 2 W64) = 938 +primOpTag (VecReadByteArrayOp IntVec 32 W8) = 939 +primOpTag (VecReadByteArrayOp IntVec 16 W16) = 940 +primOpTag (VecReadByteArrayOp IntVec 8 W32) = 941 +primOpTag (VecReadByteArrayOp IntVec 4 W64) = 942 +primOpTag (VecReadByteArrayOp IntVec 64 W8) = 943 +primOpTag (VecReadByteArrayOp IntVec 32 W16) = 944 +primOpTag (VecReadByteArrayOp IntVec 16 W32) = 945 +primOpTag (VecReadByteArrayOp IntVec 8 W64) = 946 +primOpTag (VecReadByteArrayOp WordVec 16 W8) = 947 +primOpTag (VecReadByteArrayOp WordVec 8 W16) = 948 +primOpTag (VecReadByteArrayOp WordVec 4 W32) = 949 +primOpTag (VecReadByteArrayOp WordVec 2 W64) = 950 +primOpTag (VecReadByteArrayOp WordVec 32 W8) = 951 +primOpTag (VecReadByteArrayOp WordVec 16 W16) = 952 +primOpTag (VecReadByteArrayOp WordVec 8 W32) = 953 +primOpTag (VecReadByteArrayOp WordVec 4 W64) = 954 +primOpTag (VecReadByteArrayOp WordVec 64 W8) = 955 +primOpTag (VecReadByteArrayOp WordVec 32 W16) = 956 +primOpTag (VecReadByteArrayOp WordVec 16 W32) = 957 +primOpTag (VecReadByteArrayOp WordVec 8 W64) = 958 +primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 959 +primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 960 +primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 961 +primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 962 +primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 963 +primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 964 +primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 965 +primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 966 +primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 967 +primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 968 +primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 969 +primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 970 +primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 971 +primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 972 +primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 973 +primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 974 +primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 975 +primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 976 +primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 977 +primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 978 +primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 979 +primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 980 +primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 981 +primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 982 +primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 983 +primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 984 +primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 985 +primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 986 +primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 987 +primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 988 +primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 989 +primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 990 +primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 991 +primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 992 +primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 993 +primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 994 +primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 995 +primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 996 +primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 997 +primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 998 +primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 999 +primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1000 +primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1001 +primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1002 +primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1003 +primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1004 +primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1005 +primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1006 +primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1007 +primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1008 +primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1009 +primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1010 +primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1011 +primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1012 +primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1013 +primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1014 +primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1015 +primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1016 +primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1017 +primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1018 +primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1019 +primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1020 +primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1021 +primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1022 +primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1023 +primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1024 +primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1025 +primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1026 +primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1027 +primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1028 +primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1029 +primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1030 +primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1031 +primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1032 +primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1033 +primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1034 +primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1035 +primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1036 +primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1037 +primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1038 +primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1039 +primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1040 +primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1041 +primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1042 +primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1043 +primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1044 +primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1045 +primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1046 +primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1047 +primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1048 +primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1049 +primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1050 +primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1051 +primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1052 +primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1053 +primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1054 +primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1055 +primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1056 +primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1057 +primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1058 +primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1059 +primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1060 +primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1061 +primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1062 +primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1063 +primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1064 +primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1065 +primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1066 +primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1067 +primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1068 +primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1069 +primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1070 +primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1071 +primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1072 +primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1073 +primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1074 +primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1075 +primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1076 +primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1077 +primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1078 +primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1079 +primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1080 +primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1081 +primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1082 +primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1083 +primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1084 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1085 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1086 +primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1087 +primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1088 +primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1089 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1090 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1091 +primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1092 +primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1093 +primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1094 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1095 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1096 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1097 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1098 +primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1099 +primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1100 +primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1101 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1102 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1103 +primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1104 +primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1105 +primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1106 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1107 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1108 +primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1109 +primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1110 +primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1111 +primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1112 +primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1113 +primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1114 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1115 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1116 +primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1117 +primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1118 +primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1119 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1120 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1121 +primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1122 +primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1123 +primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1124 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1125 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1126 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1127 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1128 +primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1129 +primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1130 +primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1131 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1132 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1133 +primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1134 +primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1135 +primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1136 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1137 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1138 +primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1139 +primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1140 +primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1141 +primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1142 +primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1143 +primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1144 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1145 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1146 +primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1147 +primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1148 +primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1149 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1150 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1151 +primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1152 +primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1153 +primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1154 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1155 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1156 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1157 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1158 +primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1159 +primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1160 +primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1161 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1162 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1163 +primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1164 +primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1165 +primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1166 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1167 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1168 +primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1169 +primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1170 +primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1171 +primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1172 +primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1173 +primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1174 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1175 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1176 +primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1177 +primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1178 +primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1179 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1180 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1181 +primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1182 +primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1183 +primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1184 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1185 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1186 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1187 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1188 +primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1189 +primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1190 +primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1191 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1192 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1193 +primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1194 +primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1195 +primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1196 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1197 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1198 +primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1199 +primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1200 +primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1201 +primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1202 +primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1203 +primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1204 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1205 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1206 +primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1207 +primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1208 +primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1209 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1210 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1211 +primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1212 +primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1213 +primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1214 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1215 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1216 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1217 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1218 +primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1219 +primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1220 +primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1221 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1222 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1223 +primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1224 +primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1225 +primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1226 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1227 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1228 +primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1229 +primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1230 +primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1231 +primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1232 +primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1233 +primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1234 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1235 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1236 +primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1237 +primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1238 +primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1239 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1240 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1241 +primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1242 +primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1243 +primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1244 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1245 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1246 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1247 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1248 +primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1249 +primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1250 +primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1251 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1252 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1253 +primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1254 +primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1255 +primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1256 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1257 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1258 +primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1259 +primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1260 +primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1261 +primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1262 +primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1263 +primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1264 +primOpTag PrefetchByteArrayOp3 = 1265 +primOpTag PrefetchMutableByteArrayOp3 = 1266 +primOpTag PrefetchAddrOp3 = 1267 +primOpTag PrefetchValueOp3 = 1268 +primOpTag PrefetchByteArrayOp2 = 1269 +primOpTag PrefetchMutableByteArrayOp2 = 1270 +primOpTag PrefetchAddrOp2 = 1271 +primOpTag PrefetchValueOp2 = 1272 +primOpTag PrefetchByteArrayOp1 = 1273 +primOpTag PrefetchMutableByteArrayOp1 = 1274 +primOpTag PrefetchAddrOp1 = 1275 +primOpTag PrefetchValueOp1 = 1276 +primOpTag PrefetchByteArrayOp0 = 1277 +primOpTag PrefetchMutableByteArrayOp0 = 1278 +primOpTag PrefetchAddrOp0 = 1279 +primOpTag PrefetchValueOp0 = 1280 diff --git a/ghc-lib/stage0/lib/DerivedConstants.h b/ghc-lib/stage0/lib/DerivedConstants.h --- a/ghc-lib/stage0/lib/DerivedConstants.h +++ b/ghc-lib/stage0/lib/DerivedConstants.h @@ -491,6 +491,9 @@ #define OFFSET_StgCompactNFDataBlock_next 16 #define REP_StgCompactNFDataBlock_next b64 #define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next] +#define OFFSET_RtsFlags_ProfFlags_doHeapProfile 272 +#define REP_RtsFlags_ProfFlags_doHeapProfile b32 +#define RtsFlags_ProfFlags_doHeapProfile(__ptr__) REP_RtsFlags_ProfFlags_doHeapProfile[__ptr__+OFFSET_RtsFlags_ProfFlags_doHeapProfile] #define OFFSET_RtsFlags_ProfFlags_showCCSOnException 293 #define REP_RtsFlags_ProfFlags_showCCSOnException b8 #define RtsFlags_ProfFlags_showCCSOnException(__ptr__) REP_RtsFlags_ProfFlags_showCCSOnException[__ptr__+OFFSET_RtsFlags_ProfFlags_showCCSOnException] 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 @@ -137,6 +137,9 @@ /* Define to 1 if you have the header file. */ #define HAVE_DLFCN_H 1 +/* Define to 1 if you have the `dlinfo' function. */ +/* #undef HAVE_DLINFO */ + /* Define to 1 if you have the header file. */ /* #undef HAVE_ELFUTILS_LIBDW_H */ diff --git a/ghc-lib/stage0/lib/ghcversion.h b/ghc-lib/stage0/lib/ghcversion.h --- a/ghc-lib/stage0/lib/ghcversion.h +++ b/ghc-lib/stage0/lib/ghcversion.h @@ -5,10 +5,10 @@ #define __GLASGOW_HASKELL__ 901 #endif #if !defined(__GLASGOW_HASKELL_FULL_VERSION__) -#define __GLASGOW_HASKELL_FULL_VERSION__ "9.1.20201228" +#define __GLASGOW_HASKELL_FULL_VERSION__ "9.1.20210201" #endif -#define __GLASGOW_HASKELL_PATCHLEVEL1__ 20201228 +#define __GLASGOW_HASKELL_PATCHLEVEL1__ 20210201 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \