diff options
Diffstat (limited to 'compiler/coreSyn/MkCore.hs')
| -rw-r--r-- | compiler/coreSyn/MkCore.hs | 229 |
1 files changed, 178 insertions, 51 deletions
diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs index 5a29994d0e..a425ad249e 100644 --- a/compiler/coreSyn/MkCore.hs +++ b/compiler/coreSyn/MkCore.hs @@ -42,15 +42,17 @@ module MkCore ( mkNothingExpr, mkJustExpr, -- * Error Ids - mkRuntimeErrorApp, mkImpossibleExpr, errorIds, - rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID, + mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds, + rEC_CON_ERROR_ID, rUNTIME_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, pAT_ERROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID, - tYPE_ERROR_ID, + tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID ) where #include "HsVersions.h" +import GhcPrelude + import Id import Var ( EvVar, setTyVarUnique ) @@ -63,13 +65,11 @@ import TysWiredIn import PrelNames import HsUtils ( mkChunkified, chunkify ) -import TcType ( mkSpecSigmaTy ) import Type import Coercion ( isCoVar ) import TysPrim import DataCon ( DataCon, dataConWorkId ) -import IdInfo ( vanillaIdInfo, setStrictnessInfo, - setArityInfo ) +import IdInfo import Demand import Name hiding ( varName ) import Outputable @@ -81,6 +81,7 @@ import DynFlags import Data.List import Data.Char ( ord ) +import Control.Monad.Fail ( MonadFail ) infixl 4 `mkCoreApp`, `mkCoreApps` @@ -106,9 +107,7 @@ sortQuantVars vs = sorted_tcvs ++ ids -- appropriate (see "CoreSyn#let_app_invariant") mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr mkCoreLet (NonRec bndr rhs) body -- See Note [CoreSyn let/app invariant] - | needsCaseBinding (idType bndr) rhs - , not (isJoinId bndr) - = Case rhs bndr (exprType body) [(DEFAULT,[],body)] + = bindNonRec bndr rhs body mkCoreLet bind body = Let bind body @@ -118,34 +117,43 @@ mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr mkCoreLets binds body = foldr mkCoreLet body binds -- | Construct an expression which represents the application of one expression +-- paired with its type to an argument. The result is paired with its type. This +-- function is not exported and used in the definition of 'mkCoreApp' and +-- 'mkCoreApps'. +-- Respects the let/app invariant by building a case expression where necessary +-- See CoreSyn Note [CoreSyn let/app invariant] +mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type) +mkCoreAppTyped _ (fun, fun_ty) (Type ty) + = (App fun (Type ty), piResultTy fun_ty ty) +mkCoreAppTyped _ (fun, fun_ty) (Coercion co) + = (App fun (Coercion co), res_ty) + where + (_, res_ty) = splitFunTy fun_ty +mkCoreAppTyped d (fun, fun_ty) arg + = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d ) + (mk_val_app fun arg arg_ty res_ty, res_ty) + where + (arg_ty, res_ty) = splitFunTy fun_ty + +-- | Construct an expression which represents the application of one expression -- to the other -mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr -- Respects the let/app invariant by building a case expression where necessary -- See CoreSyn Note [CoreSyn let/app invariant] -mkCoreApp _ fun (Type ty) = App fun (Type ty) -mkCoreApp _ fun (Coercion co) = App fun (Coercion co) -mkCoreApp d fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d ) - mk_val_app fun arg arg_ty res_ty - where - fun_ty = exprType fun - (arg_ty, res_ty) = splitFunTy fun_ty +mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr +mkCoreApp s fun arg + = fst $ mkCoreAppTyped s (fun, exprType fun) arg -- | Construct an expression which represents the application of a number of -- expressions to another. The leftmost expression in the list is applied first -- Respects the let/app invariant by building a case expression where necessary -- See CoreSyn Note [CoreSyn let/app invariant] mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr --- Slightly more efficient version of (foldl mkCoreApp) -mkCoreApps orig_fun orig_args - = go orig_fun (exprType orig_fun) orig_args +mkCoreApps fun args + = fst $ + foldl' (mkCoreAppTyped doc_string) (fun, fun_ty) args where - go fun _ [] = fun - go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (piResultTy fun_ty ty) args - go fun fun_ty (arg : args) = ASSERT2( isFunTy fun_ty, ppr fun_ty $$ ppr orig_fun - $$ ppr orig_args ) - go (mk_val_app fun arg arg_ty res_ty) res_ty args - where - (arg_ty, res_ty) = splitFunTy fun_ty + doc_string = ppr fun_ty $$ ppr fun $$ ppr args + fun_ty = exprType fun -- | Construct an expression which represents the application of a number of -- expressions to that of a data constructor expression. The leftmost expression @@ -171,7 +179,7 @@ mk_val_app fun arg arg_ty res_ty -- -- This is Dangerous. But this is the only place we play this -- game, mk_val_app returns an expression that does not have - -- have a free wild-id. So the only thing that can go wrong + -- a free wild-id. So the only thing that can go wrong -- is if you take apart this case expression, and pass a -- fragment of it as the fun part of a 'mk_val_app'. @@ -251,13 +259,9 @@ mkIntegerExpr i = do t <- lookupTyCon integerTyConName return (Lit (mkLitInteger i (mkTyConTy t))) -- | Create a 'CoreExpr' which will evaluate to the given @Natural@ --- --- TODO: should we add LitNatural to Core? -mkNaturalExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Natural -mkNaturalExpr i = do iExpr <- mkIntegerExpr i - fiExpr <- lookupId naturalFromIntegerName - return (mkCoreApps (Var fiExpr) [iExpr]) - +mkNaturalExpr :: MonadThings m => Integer -> m CoreExpr +mkNaturalExpr i = do t <- lookupTyCon naturalTyConName + return (Lit (mkLitNatural i (mkTyConTy t))) -- | Create a 'CoreExpr' which will evaluate to the given @Float@ mkFloatExpr :: Float -> CoreExpr @@ -328,7 +332,7 @@ We could do one of two things: * Flatten it out, so that mkCoreTup [e1] = e1 -* Built a one-tuple (see Note [One-tuples] in TysWiredIn) +* Build a one-tuple (see Note [One-tuples] in TysWiredIn) mkCoreTup1 [e1] = Unit e1 We use a suffix "1" to indicate this. @@ -362,7 +366,7 @@ mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr mkCoreUbxTup tys exps = ASSERT( tys `equalLength` exps) mkCoreConApps (tupleDataCon Unboxed (length tys)) - (map (Type . getRuntimeRep "mkCoreUbxTup") tys ++ map Type tys ++ exps) + (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps) -- | Make a core tuple of the given boxity mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr @@ -596,7 +600,7 @@ mkFoldrExpr elt_ty result_ty c n list = do `App` list) -- | Make a 'build' expression applied to a locally-bound worker function -mkBuildExpr :: (MonadThings m, MonadUnique m) +mkBuildExpr :: (MonadFail m, MonadThings m, MonadUnique m) => Type -- ^ Type of list elements to be built -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's -- of the binders for the build worker function, returns @@ -651,7 +655,7 @@ mkRuntimeErrorApp -> CoreExpr mkRuntimeErrorApp err_id res_ty err_msg - = mkApps (Var err_id) [ Type (getRuntimeRep "mkRuntimeErrorApp" res_ty) + = mkApps (Var err_id) [ Type (getRuntimeRep res_ty) , Type res_ty, err_string ] where err_string = Lit (mkMachString err_msg) @@ -686,7 +690,6 @@ templates, but we don't ever expect to generate code for it. errorIds :: [Id] errorIds = [ rUNTIME_ERROR_ID, - iRREFUT_PAT_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, pAT_ERROR_ID, @@ -697,14 +700,16 @@ errorIds ] recSelErrorName, runtimeErrorName, absentErrorName :: Name -irrefutPatErrorName, recConErrorName, patErrorName :: Name +recConErrorName, patErrorName :: Name nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name typeErrorName :: Name +absentSumFieldErrorName :: Name recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID absentErrorName = err_nm "absentError" absentErrorIdKey aBSENT_ERROR_ID +absentSumFieldErrorName = err_nm "absentSumFieldError" absentSumFieldErrorIdKey + aBSENT_SUM_FIELD_ERROR_ID runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID -irrefutPatErrorName = err_nm "irrefutPatError" irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID typeErrorName = err_nm "typeError" typeErrorIdKey tYPE_ERROR_ID @@ -717,19 +722,46 @@ nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError" err_nm :: String -> Unique -> Id -> Name err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id -rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id +rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, rEC_CON_ERROR_ID :: Id pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id -tYPE_ERROR_ID, aBSENT_ERROR_ID :: Id +tYPE_ERROR_ID, aBSENT_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName -iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName pAT_ERROR_ID = mkRuntimeErrorId patErrorName nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName -aBSENT_ERROR_ID = mkRuntimeErrorId absentErrorName tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName +-- Note [aBSENT_SUM_FIELD_ERROR_ID] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Absent argument error for unused unboxed sum fields are different than absent +-- error used in dummy worker functions (see `mkAbsentErrorApp`): +-- +-- - `absentSumFieldError` can't take arguments because it's used in unarise for +-- unused pointer fields in unboxed sums, and applying an argument would +-- require allocating a thunk. +-- +-- - `absentSumFieldError` can't be CAFFY because that would mean making some +-- non-CAFFY definitions that use unboxed sums CAFFY in unarise. +-- +-- To make `absentSumFieldError` non-CAFFY we get a stable pointer to it in +-- RtsStartup.c and mark it as non-CAFFY here. +-- +-- Getting this wrong causes hard-to-debug runtime issues, see #15038. +-- +-- TODO: Remove stable pointer hack after fixing #9718. +-- However, we should still be careful about not making things CAFFY just +-- because they use unboxed sums. Unboxed objects are supposed to be +-- efficient, and none of the other unboxed literals make things CAFFY. + +aBSENT_SUM_FIELD_ERROR_ID + = mkVanillaGlobalWithInfo absentSumFieldErrorName + (mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a + (vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] exnRes + `setArityInfo` 0 + `setCafInfo` NoCafRefs) -- #15038 + mkRuntimeErrorId :: Name -> Id -- Error function -- with type: forall (r:RuntimeRep) (a:TYPE r). Addr# -> a @@ -738,7 +770,7 @@ mkRuntimeErrorId :: Name -> Id -- The Addr# is expected to be the address of -- a UTF8-encoded error string mkRuntimeErrorId name - = mkVanillaGlobalWithInfo name runtime_err_ty bottoming_info + = mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info where bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig `setArityInfo` 1 @@ -756,10 +788,11 @@ mkRuntimeErrorId name strict_sig = mkClosedStrictSig [evalDmd] exnRes -- exnRes: these throw an exception, not just diverge - -- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a - -- See Note [Error and friends have an "open-tyvar" forall] - runtime_err_ty = mkSpecSigmaTy [runtimeRep1TyVar, openAlphaTyVar] [] - (mkFunTy addrPrimTy openAlphaTy) +runtimeErrorTy :: Type +-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a +-- See Note [Error and friends have an "open-tyvar" forall] +runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] + (mkFunTy addrPrimTy openAlphaTy) {- Note [Error and friends have an "open-tyvar" forall] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -769,4 +802,98 @@ mkRuntimeErrorId name Notice the runtime-representation polymorphism. This ensures that "error" can be instantiated at unboxed as well as boxed types. This is OK because it never returns, so the return type is irrelevant. + + +************************************************************************ +* * + aBSENT_ERROR_ID +* * +************************************************************************ + +Note [aBSENT_ERROR_ID] +~~~~~~~~~~~~~~~~~~~~~~ +We use aBSENT_ERROR_ID to build dummy values in workers. E.g. + + f x = (case x of (a,b) -> b) + 1::Int + +The demand analyser figures ot that only the second component of x is +used, and does a w/w split thus + + f x = case x of (a,b) -> $wf b + + $wf b = let a = absentError "blah" + x = (a,b) + in <the original RHS of f> + +After some simplification, the (absentError "blah") thunk goes away. + +------ Tricky wrinkle ------- +Trac #14285 had, roughly + + data T a = MkT a !a + {-# INLINABLE f #-} + f x = case x of MkT a b -> g (MkT b a) + +It turned out that g didn't use the second component, and hence f doesn't use +the first. But the stable-unfolding for f looks like + \x. case x of MkT a b -> g ($WMkT b a) +where $WMkT is the wrapper for MkT that evaluates its arguments. We +apply the same w/w split to this unfolding (see Note [Worker-wrapper +for INLINEABLE functions] in WorkWrap) so the template ends up like + \b. let a = absentError "blah" + x = MkT a b + in case x of MkT a b -> g ($WMkT b a) + +After doing case-of-known-constructor, and expanding $WMkT we get + \b -> g (case absentError "blah" of a -> MkT b a) + +Yikes! That bogusly appears to evaluate the absentError! + +This is extremely tiresome. Another way to think of this is that, in +Core, it is an invariant that a strict data contructor, like MkT, must +be applied only to an argument in HNF. So (absentError "blah") had +better be non-bottom. + +So the "solution" is to add a special case for absentError to exprIsHNFlike. +This allows Simplify.rebuildCase, in the Note [Case to let transformation] +branch, to convert the case on absentError into a let. We also make +absentError *not* be diverging, unlike the other error-ids, so that we +can be sure not to remove the case branches before converting the case to +a let. + +If, by some bug or bizarre happenstance, we ever call absentError, we should +throw an exception. This should never happen, of course, but we definitely +can't return anything. e.g. if somehow we had + case absentError "foo" of + Nothing -> ... + Just x -> ... +then if we return, the case expression will select a field and continue. +Seg fault city. Better to throw an exception. (Even though we've said +it is in HNF :-) + +It might seem a bit surprising that seq on absentError is simply erased + + absentError "foo" `seq` x ==> x + +but that should be okay; since there's no pattern match we can't really +be relying on anything from it. -} + +aBSENT_ERROR_ID + = mkVanillaGlobalWithInfo absentErrorName absent_ty arity_info + where + absent_ty = mkSpecForAllTys [alphaTyVar] (mkFunTy addrPrimTy alphaTy) + -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for + -- lifted-type things; see Note [Absent errors] in WwLib + arity_info = vanillaIdInfo `setArityInfo` 1 + -- NB: no bottoming strictness info, unlike other error-ids. + -- See Note [aBSENT_ERROR_ID] + +mkAbsentErrorApp :: Type -- The type to instantiate 'a' + -> String -- The string to print + -> CoreExpr + +mkAbsentErrorApp res_ty err_msg + = mkApps (Var aBSENT_ERROR_ID) [ Type res_ty, err_string ] + where + err_string = Lit (mkMachString err_msg) |