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

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