Commit a6c448b4 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Small refactor of getRuntimeRep

Instead of using a string argument, use HasDebugCallStack.
(Oddly, some functions were using both!)

Plus, use getRuntimeRep rather than getRuntimeRep_maybe when
if the caller panics on Nothing. Less code, and a better debug
stack.
parent 8eead4de
......@@ -362,7 +362,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
......@@ -651,7 +651,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)
......
......@@ -1185,7 +1185,7 @@ dsEvTerm (EvDelayedError ty msg) = return $ dsEvDelayedError ty msg
dsEvDelayedError :: Type -> FastString -> CoreExpr
dsEvDelayedError ty msg
= Var errorId `mkTyApps` [getRuntimeRep "dsEvTerm" ty, ty] `mkApps` [litMsg]
= Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]
where
errorId = tYPE_ERROR_ID
litMsg = Lit (MachStr (fastStringToByteString msg))
......@@ -1261,8 +1261,8 @@ ds_ev_typeable ty (EvTypeableTrFun ev1 ev2)
; mkTrFun <- dsLookupGlobalId mkTrFunName
-- mkTrFun :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2).
-- TypeRep a -> TypeRep b -> TypeRep (a -> b)
; let r1 = getRuntimeRep "ds_ev_typeable" t1
r2 = getRuntimeRep "ds_ev_typeable" t2
; let r1 = getRuntimeRep t1
r2 = getRuntimeRep t2
; return $ mkApps (mkTyApps (Var mkTrFun) [r1, r2, t1, t2])
[ e1, e2 ]
}
......
......@@ -380,7 +380,7 @@ ds_expr _ (ExplicitTuple tup_args boxity)
ds_expr _ (ExplicitSum alt arity expr types)
= do { core_expr <- dsLExpr expr
; return $ mkCoreConApps (sumDataCon alt arity)
(map (Type . getRuntimeRep "dsExpr ExplicitSum") types ++
(map (Type . getRuntimeRep) types ++
map Type types ++
[core_expr]) }
......
......@@ -344,7 +344,7 @@ sort_alts = sortWith (dataConTag . alt_pat)
mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
mkPatSynCase var ty alt fail = do
matcher <- dsLExpr $ mkLHsWrap wrapper $
nlHsTyApp matcher [getRuntimeRep "mkPatSynCase" ty, ty]
nlHsTyApp matcher [getRuntimeRep ty, ty]
let MatchResult _ mkCont = match_result
cont <- mkCoreLams bndrs <$> mkCont fail
return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
......@@ -471,7 +471,7 @@ mkErrorAppDs err_id ty msg = do
full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
core_msg = Lit (mkMachString full_msg)
-- mkMachString returns a result of type String#
return (mkApps (Var err_id) [Type (getRuntimeRep "mkErrorAppDs" ty), Type ty, core_msg])
return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg])
{-
'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.
......
......@@ -1404,7 +1404,7 @@ tcIfaceExpr (IfaceTuple sort args)
; let con_tys = map exprType args'
some_con_args = map Type con_tys ++ args'
con_args = case sort of
UnboxedTuple -> map (Type . getRuntimeRep "tcIfaceExpr") con_tys ++ some_con_args
UnboxedTuple -> map (Type . getRuntimeRep) con_tys ++ some_con_args
_ -> some_con_args
-- Put the missing type arguments back in
con_id = dataConWorkId (tyConSingleDataCon tc)
......
......@@ -1487,7 +1487,7 @@ mkTupleTy :: Boxity -> [Type] -> Type
mkTupleTy Boxed [ty] = ty
mkTupleTy Boxed tys = mkTyConApp (tupleTyCon Boxed (length tys)) tys
mkTupleTy Unboxed tys = mkTyConApp (tupleTyCon Unboxed (length tys))
(map (getRuntimeRep "mkTupleTy") tys ++ tys)
(map getRuntimeRep tys ++ tys)
-- | Build the type of a small tuple that holds the specified type of thing
mkBoxedTupleTy :: [Type] -> Type
......@@ -1505,7 +1505,7 @@ unitTy = mkTupleTy Boxed []
mkSumTy :: [Type] -> Type
mkSumTy tys = mkTyConApp (sumTyCon (length tys))
(map (getRuntimeRep "mkSumTy") tys ++ tys)
(map getRuntimeRep tys ++ tys)
{- *********************************************************************
* *
......
......@@ -396,7 +396,7 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
; op_id <- tcLookupId op_name
; res_ty <- readExpType res_ty
; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep "tcExpr ($)" res_ty
; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep res_ty
, arg2_sigma
, res_ty])
(HsVar (L lv op_id)))
......
......@@ -642,7 +642,7 @@ tc_hs_type mode rn_ty@(HsSumTy hs_tys) exp_kind
= do { let arity = length hs_tys
; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys
; tau_tys <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds
; let arg_reps = map (getRuntimeRepFromKind "tc_hs_type HsSumTy") arg_kinds
; let arg_reps = map getRuntimeRepFromKind arg_kinds
arg_tys = arg_reps ++ tau_tys
; checkExpectedKind rn_ty
(mkTyConApp (sumTyCon arity) arg_tys)
......@@ -774,7 +774,7 @@ finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind
; checkExpectedKind rn_ty (mkTyConApp tycon arg_tys) res_kind exp_kind }
where
arity = length tau_tys
tau_reps = map (getRuntimeRepFromKind "finish_tuple") tau_kinds
tau_reps = map getRuntimeRepFromKind tau_kinds
res_kind = case tup_sort of
UnboxedTuple -> unboxedTupleKind tau_reps
BoxedTuple -> liftedTypeKind
......
......@@ -1327,8 +1327,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags)
error_fun = L inst_loc $
wrapId (mkWpTyApps
[ getRuntimeRep "tcInstanceMethods.tc_default" meth_tau
, meth_tau])
[ getRuntimeRep meth_tau, meth_tau])
nO_METHOD_BINDING_ERROR_ID
error_msg dflags = L inst_loc (HsLit (HsStringPrim noSourceText
(unsafeMkByteString (error_string dflags))))
......
......@@ -2120,7 +2120,7 @@ tcGhciStmts stmts
(noLoc $ ExplicitList unitTy Nothing (map mk_item ids)) ;
mk_item id = let ty_args = [idType id, unitTy] in
nlHsApp (nlHsTyApp unsafeCoerceId
(map (getRuntimeRep "tcGhciStmts") ty_args ++ ty_args))
(map getRuntimeRep ty_args ++ ty_args))
(nlHsVar id) ;
stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
} ;
......
......@@ -691,18 +691,19 @@ repSplitAppTy_maybe :: Type -> Maybe (Type,Type)
-- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that
-- any Core view stuff is already done
repSplitAppTy_maybe (FunTy ty1 ty2)
| Just rep1 <- getRuntimeRep_maybe ty1
, Just rep2 <- getRuntimeRep_maybe ty2
= Just (TyConApp funTyCon [rep1, rep2, ty1], ty2)
where
rep1 = getRuntimeRep ty1
rep2 = getRuntimeRep ty2
| otherwise
= pprPanic "repSplitAppTy_maybe" (ppr ty1 $$ ppr ty2)
repSplitAppTy_maybe (AppTy ty1 ty2)
= Just (ty1, ty2)
repSplitAppTy_maybe (TyConApp tc tys)
| mightBeUnsaturatedTyCon tc || tys `lengthExceeds` tyConArity tc
, Just (tys', ty') <- snocView tys
= Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps!
repSplitAppTy_maybe _other = Nothing
-- this one doesn't braek apart (c => t).
......@@ -715,12 +716,12 @@ tcRepSplitAppTy_maybe (FunTy ty1 ty2)
| isConstraintKind (typeKind ty1)
= Nothing -- See Note [Decomposing fat arrow c=>t]
| Just rep1 <- getRuntimeRep_maybe ty1
, Just rep2 <- getRuntimeRep_maybe ty2
| otherwise
= Just (TyConApp funTyCon [rep1, rep2, ty1], ty2)
where
rep1 = getRuntimeRep ty1
rep2 = getRuntimeRep ty2
| otherwise
= pprPanic "repSplitAppTy_maybe" (ppr ty1 $$ ppr ty2)
tcRepSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
tcRepSplitAppTy_maybe (TyConApp tc tys)
| mightBeUnsaturatedTyCon tc || tys `lengthExceeds` tyConArity tc
......@@ -743,16 +744,17 @@ tcSplitTyConApp_maybe ty = tcRepSplitTyConApp_maybe ty
-- | Like 'tcSplitTyConApp_maybe' but doesn't look through type synonyms.
tcRepSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])
-- Defined here to avoid module loops between Unify and TcType.
tcRepSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
tcRepSplitTyConApp_maybe (TyConApp tc tys)
= Just (tc, tys)
tcRepSplitTyConApp_maybe (FunTy arg res)
| Just arg_rep <- getRuntimeRep_maybe arg
, Just res_rep <- getRuntimeRep_maybe res
= Just (funTyCon, [arg_rep, res_rep, arg, res])
where
arg_rep = getRuntimeRep arg
res_rep = getRuntimeRep res
| otherwise
= pprPanic "tcRepSplitTyConApp_maybe" (ppr arg $$ ppr res)
tcRepSplitTyConApp_maybe _ = Nothing
tcRepSplitTyConApp_maybe _
= Nothing
-------------
splitAppTy :: Type -> (Type, Type)
......@@ -779,13 +781,12 @@ splitAppTys ty = split ty ty []
in
(TyConApp tc tc_args1, tc_args2 ++ args)
split _ (FunTy ty1 ty2) args
| Just rep1 <- getRuntimeRep_maybe ty1
, Just rep2 <- getRuntimeRep_maybe ty2
= ASSERT( null args )
(TyConApp funTyCon [], [rep1, rep2, ty1, ty2])
where
rep1 = getRuntimeRep ty1
rep2 = getRuntimeRep ty2
| otherwise
= pprPanic "splitAppTys" (ppr ty1 $$ ppr ty2 $$ ppr args)
split orig_ty _ args = (orig_ty, args)
-- | Like 'splitAppTys', but doesn't look through type synonyms
......@@ -800,13 +801,12 @@ repSplitAppTys ty = split ty []
in
(TyConApp tc tc_args1, tc_args2 ++ args)
split (FunTy ty1 ty2) args
| Just rep1 <- getRuntimeRep_maybe ty1
, Just rep2 <- getRuntimeRep_maybe ty2
= ASSERT( null args )
(TyConApp funTyCon [], [rep1, rep2, ty1, ty2])
where
rep1 = getRuntimeRep ty1
rep2 = getRuntimeRep ty2
| otherwise
= pprPanic "repSplitAppTys" (ppr ty1 $$ ppr ty2 $$ ppr args)
split ty args = (ty, args)
{-
......@@ -1085,7 +1085,7 @@ tyConAppArgs_maybe (FunTy arg res)
| Just rep1 <- getRuntimeRep_maybe arg
, Just rep2 <- getRuntimeRep_maybe res
= Just [rep1, rep2, arg, res]
tyConAppArgs_maybe _ = Nothing
tyConAppArgs_maybe _ = Nothing
tyConAppArgs :: Type -> [Type]
tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty)
......@@ -1116,12 +1116,9 @@ splitTyConApp_maybe ty = repSplitTyConApp_maybe ty
repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
repSplitTyConApp_maybe (FunTy arg res)
| Just rep1 <- getRuntimeRep_maybe arg
, Just rep2 <- getRuntimeRep_maybe res
= Just (funTyCon, [rep1, rep2, arg, res])
| otherwise
= pprPanic "repSplitTyConApp_maybe"
(ppr arg $$ ppr res $$ ppr (typeKind res))
| Just arg_rep <- getRuntimeRep_maybe arg
, Just res_rep <- getRuntimeRep_maybe res
= Just (funTyCon, [arg_rep, res_rep, arg, res])
repSplitTyConApp_maybe _ = Nothing
-- | Attempts to tease a list type apart and gives the type of the elements if
......@@ -1936,7 +1933,7 @@ isFamFreeTy (CoercionTy _) = False -- Not sure about this
-- levity polymorphic), and panics if the kind does not have the shape
-- TYPE r.
isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool
isLiftedType_maybe ty = go (getRuntimeRep "isLiftedType_maybe" ty)
isLiftedType_maybe ty = go (getRuntimeRep ty)
where
go rr | Just rr' <- coreView rr = go rr'
go (TyConApp lifted_rep [])
......@@ -1978,24 +1975,21 @@ getRuntimeRep_maybe = getRuntimeRepFromKind_maybe . typeKind
-- | Extract the RuntimeRep classifier of a type. For instance,
-- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible.
getRuntimeRep :: HasDebugCallStack
=> String -- ^ Printed in case of an error
-> Type -> Type
getRuntimeRep err ty =
case getRuntimeRep_maybe ty of
getRuntimeRep :: HasDebugCallStack => Type -> Type
getRuntimeRep ty
= case getRuntimeRep_maybe ty of
Just r -> r
Nothing -> pprPanic "getRuntimeRep"
(text err $$ ppr ty <+> dcolon <+> ppr (typeKind ty))
Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty))
-- | Extract the RuntimeRep classifier of a type from its kind. For example,
-- @getRuntimeRepFromKind * = LiftedRep@; Panics if this is not possible.
getRuntimeRepFromKind :: HasDebugCallStack
=> String -> Type -> Type
getRuntimeRepFromKind err k =
=> Type -> Type
getRuntimeRepFromKind k =
case getRuntimeRepFromKind_maybe k of
Just r -> r
Nothing -> pprPanic "getRuntimeRepFromKind"
(text err $$ ppr k <+> dcolon <+> ppr (typeKind k))
(ppr k <+> dcolon <+> ppr (typeKind k))
-- | Extract the RuntimeRep classifier of a type from its kind. For example,
-- @getRuntimeRepFromKind * = LiftedRep@; Returns 'Nothing' if this is not
......@@ -2013,14 +2007,14 @@ getRuntimeRepFromKind_maybe = go
isUnboxedTupleType :: Type -> Bool
isUnboxedTupleType ty
= tyConAppTyCon (getRuntimeRep "isUnboxedTupleType" ty) `hasKey` tupleRepDataConKey
= tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey
-- NB: Do not use typePrimRep, as that can't tell the difference between
-- unboxed tuples and unboxed sums
isUnboxedSumType :: Type -> Bool
isUnboxedSumType ty
= tyConAppTyCon (getRuntimeRep "isUnboxedSumType" ty) `hasKey` sumRepDataConKey
= tyConAppTyCon (getRuntimeRep ty) `hasKey` sumRepDataConKey
-- | See "Type#type_classification" for what an algebraic type is.
-- Should only be applied to /types/, as opposed to e.g. partially
......
......@@ -360,7 +360,8 @@ vectExpr (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType ty)) err)
| v == pAT_ERROR_ID
= do
{ (vty, lty) <- vectAndLiftType ty
; return (mkCoreApps (Var v) [Type (getRuntimeRep "vectExpr" vty), Type vty, err'], mkCoreApps (Var v) [Type lty, err'])
; return (mkCoreApps (Var v) [Type (getRuntimeRep vty), Type vty, err'],
mkCoreApps (Var v) [Type lty, err'])
}
where
err' = deAnnotate err
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment