Commit 474b582b authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Tidy up the treatment of newtypes, refactor, and fix Trac #736

I've forgotten the precise details already, but this patch
significantly refactors the way newtypes are handled, fixes
the foreign-export problem Trac #736 (which concerned newtypes),
and gets rid of a bogus unsafeCoerce in the foreign export
desugaring.
parent 0f556c99
...@@ -766,8 +766,9 @@ splitProductType str ty ...@@ -766,8 +766,9 @@ splitProductType str ty
deepSplitProductType_maybe ty deepSplitProductType_maybe ty
= do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty = do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty
; let {result ; let {result
| isClosedNewTyCon tycon && not (isRecursiveTyCon tycon) | Just (ty', _co) <- instNewTyCon_maybe tycon tycon_args
= deepSplitProductType_maybe (newTyConInstRhs tycon tycon_args) , not (isRecursiveTyCon tycon)
= deepSplitProductType_maybe ty' -- Ignore the coercion?
| isNewTyCon tycon = Nothing -- cannot unbox through recursive | isNewTyCon tycon = Nothing -- cannot unbox through recursive
-- newtypes nor through families -- newtypes nor through families
| otherwise = Just res} | otherwise = Just res}
......
...@@ -8,7 +8,7 @@ Utility functions on @Core@ syntax ...@@ -8,7 +8,7 @@ Utility functions on @Core@ syntax
\begin{code} \begin{code}
module CoreUtils ( module CoreUtils (
-- Construction -- Construction
mkInlineMe, mkSCC, mkCoerce, mkInlineMe, mkSCC, mkCoerce, mkCoerceI,
bindNonRec, needsCaseBinding, bindNonRec, needsCaseBinding,
mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes, mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
...@@ -194,6 +194,10 @@ mkInlineMe e = Note InlineMe e ...@@ -194,6 +194,10 @@ mkInlineMe e = Note InlineMe e
\begin{code} \begin{code}
mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr
mkCoerceI IdCo e = e
mkCoerceI (ACo co) e = mkCoerce co e
mkCoerce :: Coercion -> CoreExpr -> CoreExpr mkCoerce :: Coercion -> CoreExpr -> CoreExpr
mkCoerce co (Cast expr co2) mkCoerce co (Cast expr co2)
= ASSERT(let { (from_ty, _to_ty) = coercionKind co; = ASSERT(let { (from_ty, _to_ty) = coercionKind co;
...@@ -1159,8 +1163,8 @@ eta_expand n us expr ty ...@@ -1159,8 +1163,8 @@ eta_expand n us expr ty
-- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
case splitNewTypeRepCo_maybe ty of { case splitNewTypeRepCo_maybe ty of {
Just(ty1,co) -> Just(ty1,co) -> mkCoerce (mkSymCoercion co)
mkCoerce (mkSymCoercion co) (eta_expand n us (mkCoerce co expr) ty1) ; (eta_expand n us (mkCoerce co expr) ty1) ;
Nothing -> Nothing ->
-- We have an expression of arity > 0, but its type isn't a function -- We have an expression of arity > 0, but its type isn't a function
......
...@@ -91,9 +91,9 @@ dsCCall :: CLabelString -- C routine to invoke ...@@ -91,9 +91,9 @@ dsCCall :: CLabelString -- C routine to invoke
-> DsM CoreExpr -- Result, of type ??? -> DsM CoreExpr -- Result, of type ???
dsCCall lbl args may_gc result_ty dsCCall lbl args may_gc result_ty
= mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) -> = mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
boxResult id Nothing result_ty `thenDs` \ (ccall_result_ty, res_wrapper) -> boxResult id Nothing result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
newUnique `thenDs` \ uniq -> newUnique `thenDs` \ uniq ->
let let
target = StaticTarget lbl target = StaticTarget lbl
the_fcall = CCall (CCallSpec target CCallConv may_gc) the_fcall = CCall (CCallSpec target CCallConv may_gc)
...@@ -182,6 +182,7 @@ unboxArg arg ...@@ -182,6 +182,7 @@ unboxArg arg
) )
----- Cases for .NET; almost certainly bit-rotted ---------
| Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty, | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
tc == listTyCon, tc == listTyCon,
Just (cc,[]) <- splitTyConApp_maybe arg_ty, Just (cc,[]) <- splitTyConApp_maybe arg_ty,
...@@ -193,7 +194,7 @@ unboxArg arg ...@@ -193,7 +194,7 @@ unboxArg arg
\ body -> \ body ->
let let
io_ty = exprType body io_ty = exprType body
Just (_,io_arg) = tcSplitIOType_maybe io_ty Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
in in
mkApps (Var unpack_id) mkApps (Var unpack_id)
[ Type io_arg [ Type io_arg
...@@ -209,13 +210,14 @@ unboxArg arg ...@@ -209,13 +210,14 @@ unboxArg arg
\ body -> \ body ->
let let
io_ty = exprType body io_ty = exprType body
Just (_,io_arg) = tcSplitIOType_maybe io_ty Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
in in
mkApps (Var unpack_id) mkApps (Var unpack_id)
[ Type io_arg [ Type io_arg
, arg , arg
, Lam prim_obj body , Lam prim_obj body
]) ])
--------------- End of cases for .NET --------------------
| otherwise | otherwise
= getSrcSpanDs `thenDs` \ l -> = getSrcSpanDs `thenDs` \ l ->
...@@ -235,7 +237,8 @@ unboxArg arg ...@@ -235,7 +237,8 @@ unboxArg arg
\begin{code} \begin{code}
boxResult :: ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> CoreExpr)) boxResult :: ((Maybe Type, CoreExpr -> CoreExpr)
-> (Maybe Type, CoreExpr -> CoreExpr))
-> Maybe Id -> Maybe Id
-> Type -> Type
-> DsM (Type, CoreExpr -> CoreExpr) -> DsM (Type, CoreExpr -> CoreExpr)
...@@ -255,45 +258,45 @@ boxResult :: ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> Cor ...@@ -255,45 +258,45 @@ boxResult :: ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> Cor
-- It looks a mess: I wonder if it could be refactored. -- It looks a mess: I wonder if it could be refactored.
boxResult augment mbTopCon result_ty boxResult augment mbTopCon result_ty
| Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty | Just (io_tycon, io_res_ty, co) <- tcSplitIOType_maybe result_ty
-- isIOType_maybe handles the case where the type is a -- isIOType_maybe handles the case where the type is a
-- simple wrapping of IO. E.g. -- simple wrapping of IO. E.g.
-- newtype Wrap a = W (IO a) -- newtype Wrap a = W (IO a)
-- No coercion necessay because its a non-recursive newtype -- No coercion necessary because its a non-recursive newtype
-- (If we wanted to handle a *recursive* newtype too, we'd need -- (If we wanted to handle a *recursive* newtype too, we'd need
-- another case, and a coercion.) -- another case, and a coercion.)
= -- The result is IO t, so wrap the result in an IO constructor -- The result is IO t, so wrap the result in an IO constructor
= do { res <- resultWrapper io_res_ty
resultWrapper io_res_ty `thenDs` \ res -> ; let aug_res = augment res
let aug_res = augment res extra_result_tys
extra_result_tys = case aug_res of = case aug_res of
(Just ty,_) (Just ty,_)
| isUnboxedTupleType ty | isUnboxedTupleType ty
-> let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls -> let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
_ -> [] _ -> []
return_result state anss return_result state anss
= mkConApp (tupleCon Unboxed (2 + length extra_result_tys)) = mkConApp (tupleCon Unboxed (2 + length extra_result_tys))
(map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys) (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)
++ (state : anss)) ++ (state : anss))
in
mk_alt return_result aug_res `thenDs` \ (ccall_res_ty, the_alt) -> ; (ccall_res_ty, the_alt) <- mk_alt return_result aug_res
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
let ; state_id <- newSysLocalDs realWorldStatePrimTy
io_data_con = head (tyConDataCons io_tycon) ; let io_data_con = head (tyConDataCons io_tycon)
toIOCon = case mbTopCon of toIOCon = mbTopCon `orElse` dataConWrapId io_data_con
Nothing -> dataConWrapId io_data_con
Just x -> x wrap the_call = mkCoerceI (mkSymCoI co) $
wrap = \ the_call -> mkApps (Var toIOCon) mkApps (Var toIOCon)
[ Type io_res_ty, [ Type io_res_ty,
Lam state_id $ Lam state_id $
Case (App the_call (Var state_id)) Case (App the_call (Var state_id))
(mkWildId ccall_res_ty) (mkWildId ccall_res_ty)
(coreAltType the_alt) (coreAltType the_alt)
[the_alt] [the_alt]
] ]
in
returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) ; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }
boxResult augment mbTopCon result_ty boxResult augment mbTopCon result_ty
= -- It isn't IO, so do unsafePerformIO = -- It isn't IO, so do unsafePerformIO
...@@ -302,9 +305,9 @@ boxResult augment mbTopCon result_ty ...@@ -302,9 +305,9 @@ boxResult augment mbTopCon result_ty
mk_alt return_result (augment res) `thenDs` \ (ccall_res_ty, the_alt) -> mk_alt return_result (augment res) `thenDs` \ (ccall_res_ty, the_alt) ->
let let
wrap = \ the_call -> Case (App the_call (Var realWorldPrimId)) wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
(mkWildId ccall_res_ty) (mkWildId ccall_res_ty)
(coreAltType the_alt) (coreAltType the_alt)
[the_alt] [the_alt]
in in
returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
where where
...@@ -360,6 +363,9 @@ mk_alt return_result (Just prim_res_ty, wrap_result) ...@@ -360,6 +363,9 @@ mk_alt return_result (Just prim_res_ty, wrap_result)
resultWrapper :: Type resultWrapper :: Type
-> DsM (Maybe Type, -- Type of the expected result, if any -> DsM (Maybe Type, -- Type of the expected result, if any
CoreExpr -> CoreExpr) -- Wrapper for the result CoreExpr -> CoreExpr) -- Wrapper for the result
-- resultWrapper deals with the result *value*
-- E.g. foreign import foo :: Int -> IO T
-- Then resultWrapper deals with marshalling the 'T' part
resultWrapper result_ty resultWrapper result_ty
-- Base case 1: primitive types -- Base case 1: primitive types
| isPrimitiveType result_ty | isPrimitiveType result_ty
......
...@@ -282,8 +282,9 @@ dsFExport fn_id ty ext_name cconv isDyn ...@@ -282,8 +282,9 @@ dsFExport fn_id ty ext_name cconv isDyn
-- If it's IO t, return (t, True) -- If it's IO t, return (t, True)
-- If it's plain t, return (t, False) -- If it's plain t, return (t, False)
(case tcSplitIOType_maybe orig_res_ty of (case tcSplitIOType_maybe orig_res_ty of
Just (ioTyCon, res_ty) -> returnDs (res_ty, True) Just (ioTyCon, res_ty, co) -> returnDs (res_ty, True)
-- The function already returns IO t -- The function already returns IO t
-- ToDo: what about the coercion?
Nothing -> returnDs (orig_res_ty, False) Nothing -> returnDs (orig_res_ty, False)
-- The function returns t -- The function returns t
) `thenDs` \ (res_ty, -- t ) `thenDs` \ (res_ty, -- t
...@@ -339,7 +340,6 @@ dsFExportDynamic id cconv ...@@ -339,7 +340,6 @@ dsFExportDynamic id cconv
dsLookupGlobalId newStablePtrName `thenDs` \ newStablePtrId -> dsLookupGlobalId newStablePtrName `thenDs` \ newStablePtrId ->
dsLookupTyCon stablePtrTyConName `thenDs` \ stable_ptr_tycon -> dsLookupTyCon stablePtrTyConName `thenDs` \ stable_ptr_tycon ->
let let
mk_stbl_ptr_app = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty] stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
export_ty = mkFunTy stable_ptr_ty arg_ty export_ty = mkFunTy stable_ptr_ty arg_ty
in in
...@@ -348,12 +348,6 @@ dsFExportDynamic id cconv ...@@ -348,12 +348,6 @@ dsFExportDynamic id cconv
dsFExport id export_ty fe_nm cconv True dsFExport id export_ty fe_nm cconv True
`thenDs` \ (h_code, c_code, arg_reps, args_size) -> `thenDs` \ (h_code, c_code, arg_reps, args_size) ->
let let
stbl_app cont ret_ty = mkApps (Var bindIOId)
[ Type stable_ptr_ty
, Type ret_ty
, mk_stbl_ptr_app
, cont
]
{- {-
The arguments to the external function which will The arguments to the external function which will
create a little bit of (template) code on the fly create a little bit of (template) code on the fly
...@@ -384,18 +378,19 @@ dsFExportDynamic id cconv ...@@ -384,18 +378,19 @@ dsFExportDynamic id cconv
_ -> Nothing _ -> Nothing
in in
dsCCall adjustor adj_args PlayRisky io_res_ty `thenDs` \ ccall_adj -> dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty]) `thenDs` \ ccall_adj ->
-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
let ccall_adj_ty = exprType ccall_adj
ccall_io_adj = mkLams [stbl_value] $
#ifdef DEBUG
pprTrace "DsForeign: why is there an unsafeCoerce here?" (text "") $
#endif
(Cast ccall_adj (mkUnsafeCoercion ccall_adj_ty io_res_ty ))
io_app = mkLams tvs $ let io_app = mkLams tvs $
mkLams [cback] $ Lam cback $
stbl_app ccall_io_adj res_ty mkCoerceI (mkSymCoI co) $
mkApps (Var bindIOId)
[ Type stable_ptr_ty
, Type res_ty
, mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
, Lam stbl_value ccall_adj
]
fed = (id `setInlinePragma` NeverActive, io_app) fed = (id `setInlinePragma` NeverActive, io_app)
-- Never inline the f.e.d. function, because the litlit -- Never inline the f.e.d. function, because the litlit
-- might not be in scope in other modules. -- might not be in scope in other modules.
...@@ -403,11 +398,12 @@ dsFExportDynamic id cconv ...@@ -403,11 +398,12 @@ dsFExportDynamic id cconv
returnDs ([fed], h_code, c_code) returnDs ([fed], h_code, c_code)
where where
ty = idType id ty = idType id
(tvs,sans_foralls) = tcSplitForAllTys ty (tvs,sans_foralls) = tcSplitForAllTys ty
([arg_ty], io_res_ty) = tcSplitFunTys sans_foralls ([arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls
[res_ty] = tcTyConAppArgs io_res_ty Just (io_tc, res_ty, co) = tcSplitIOType_maybe fn_res_ty
-- Must use tcSplit* to see the (IO t), which is a newtype -- Must have an IO type; hence Just
-- co : fn_res_ty ~ IO res_ty
toCName :: Id -> String toCName :: Id -> String
toCName i = showSDoc (pprCode CStyle (ppr (idName i))) toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
......
...@@ -263,7 +263,7 @@ mustBeIO = False ...@@ -263,7 +263,7 @@ mustBeIO = False
checkForeignRes non_io_result_ok pred_res_ty ty checkForeignRes non_io_result_ok pred_res_ty ty
-- (IO t) is ok, and so is any newtype wrapping thereof -- (IO t) is ok, and so is any newtype wrapping thereof
| Just (io, res_ty) <- tcSplitIOType_maybe ty, | Just (io, res_ty, _) <- tcSplitIOType_maybe ty,
pred_res_ty res_ty pred_res_ty res_ty
= returnM () = returnM ()
......
...@@ -140,6 +140,7 @@ import ForeignCall ...@@ -140,6 +140,7 @@ import ForeignCall
import Unify import Unify
import VarSet import VarSet
import Type import Type
import Coercion
import TyCon import TyCon
-- others: -- others:
...@@ -840,6 +841,7 @@ tcSplitPredTy_maybe other = Nothing ...@@ -840,6 +841,7 @@ tcSplitPredTy_maybe other = Nothing
predTyUnique :: PredType -> Unique predTyUnique :: PredType -> Unique
predTyUnique (IParam n _) = getUnique (ipNameName n) predTyUnique (IParam n _) = getUnique (ipNameName n)
predTyUnique (ClassP clas tys) = getUnique clas predTyUnique (ClassP clas tys) = getUnique clas
predTyUnique (EqPred a b) = pprPanic "predTyUnique" (ppr (EqPred a b))
\end{code} \end{code}
...@@ -1050,6 +1052,7 @@ exactTyVarsOfType ty ...@@ -1050,6 +1052,7 @@ exactTyVarsOfType ty
go (AppTy fun arg) = go fun `unionVarSet` go arg go (AppTy fun arg) = go fun `unionVarSet` go arg
go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar
`unionVarSet` go_tv tyvar `unionVarSet` go_tv tyvar
go (NoteTy _ _) = panic "exactTyVarsOfType" -- Handled by tcView
go_pred (IParam _ ty) = go ty go_pred (IParam _ ty) = go ty
go_pred (ClassP _ tys) = exactTyVarsOfTypes tys go_pred (ClassP _ tys) = exactTyVarsOfTypes tys
...@@ -1103,22 +1106,28 @@ restricted set of types as arguments and results (the restricting factor ...@@ -1103,22 +1106,28 @@ restricted set of types as arguments and results (the restricting factor
being the ) being the )
\begin{code} \begin{code}
tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type) tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, CoercionI)
-- (isIOType t) returns (Just (IO,t')) if t is of the form (IO t'), or -- (isIOType t) returns Just (IO,t',co)
-- some newtype wrapping thereof -- if co : t ~ IO t'
-- returns Nothing otherwise -- returns Nothing otherwise
tcSplitIOType_maybe ty tcSplitIOType_maybe ty
| Just (io_tycon, [io_res_ty]) <- tcSplitTyConApp_maybe ty, = case tcSplitTyConApp_maybe ty of
-- This split absolutely has to be a tcSplit, because we must -- This split absolutely has to be a tcSplit, because we must
-- see the IO type; and it's a newtype which is transparent to splitTyConApp. -- see the IO type; and it's a newtype which is transparent to splitTyConApp.
io_tycon `hasKey` ioTyConKey
= Just (io_tycon, io_res_ty)
| Just ty' <- coreView ty -- Look through non-recursive newtypes Just (io_tycon, [io_res_ty])
= tcSplitIOType_maybe ty' | io_tycon `hasKey` ioTyConKey
-> Just (io_tycon, io_res_ty, IdCo)
| otherwise Just (tc, tys)
= Nothing | not (isRecursiveTyCon tc)
, Just (ty, co1) <- instNewTyCon_maybe tc tys
-- Newtypes that require a coercion are ok
-> case tcSplitIOType_maybe ty of
Nothing -> Nothing
Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCoI` co2)
other -> Nothing
isFFITy :: Type -> Bool isFFITy :: Type -> Bool
-- True for any TyCon that can possibly be an arg or result of an FFI call -- True for any TyCon that can possibly be an arg or result of an FFI call
......
...@@ -27,7 +27,7 @@ module Coercion ( ...@@ -27,7 +27,7 @@ module Coercion (
mkForAllCoercion, mkFunCoercion, mkInstsCoercion, mkUnsafeCoercion, mkForAllCoercion, mkFunCoercion, mkInstsCoercion, mkUnsafeCoercion,
mkNewTypeCoercion, mkFamInstCoercion, mkAppsCoercion, mkNewTypeCoercion, mkFamInstCoercion, mkAppsCoercion,
splitNewTypeRepCo_maybe, decomposeCo, splitNewTypeRepCo_maybe, instNewTyCon_maybe, decomposeCo,
unsafeCoercionTyCon, symCoercionTyCon, unsafeCoercionTyCon, symCoercionTyCon,
transCoercionTyCon, leftCoercionTyCon, transCoercionTyCon, leftCoercionTyCon,
...@@ -413,24 +413,37 @@ unsafeCoercionTyConName = mkCoConName FSLIT("CoUnsafe") unsafeCoercionTyConKey u ...@@ -413,24 +413,37 @@ unsafeCoercionTyConName = mkCoConName FSLIT("CoUnsafe") unsafeCoercionTyConKey u
instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, CoercionI)
-- instNewTyCon_maybe T ts
-- = Just (rep_ty, co) if co : T ts ~ rep_ty
instNewTyCon_maybe tc tys
| Just (tvs, ty, mb_co_tc) <- unwrapNewTyCon_maybe tc
= ASSERT( tys `lengthIs` tyConArity tc )
Just (substTyWith tvs tys ty,
case mb_co_tc of
Nothing -> IdCo
Just co_tc -> ACo (mkTyConApp co_tc tys))
| otherwise
= Nothing
-- this is here to avoid module loops -- this is here to avoid module loops
splitNewTypeRepCo_maybe :: Type -> Maybe (Type, Coercion) splitNewTypeRepCo_maybe :: Type -> Maybe (Type, Coercion)
-- Sometimes we want to look through a newtype and get its associated coercion -- Sometimes we want to look through a newtype and get its associated coercion
-- It only strips *one layer* off, so the caller will usually call itself recursively -- It only strips *one layer* off, so the caller will usually call itself recursively
-- Only applied to types of kind *, hence the newtype is always saturated -- Only applied to types of kind *, hence the newtype is always saturated
-- splitNewTypeRepCo_maybe ty
-- = Just (ty', co) if co : ty ~ ty'
-- Returns Nothing for non-newtypes or fully-transparent newtypes
splitNewTypeRepCo_maybe ty splitNewTypeRepCo_maybe ty
| Just ty' <- coreView ty = splitNewTypeRepCo_maybe ty' | Just ty' <- coreView ty = splitNewTypeRepCo_maybe ty'
splitNewTypeRepCo_maybe (TyConApp tc tys) splitNewTypeRepCo_maybe (TyConApp tc tys)
| isClosedNewTyCon tc | Just (ty', coi) <- instNewTyCon_maybe tc tys
= ASSERT( tys `lengthIs` tyConArity tc ) -- splitNewTypeRepCo_maybe only be applied = case coi of
-- to *types* (of kind *) ACo co -> Just (ty', co)
case newTyConRhs tc of IdCo -> panic "splitNewTypeRepCo_maybe"
(tvs, rep_ty) -> -- This case handled by coreView
ASSERT( length tvs == length tys ) splitNewTypeRepCo_maybe other
Just (substTyWith tvs tys rep_ty, mkTyConApp co_con tys) = Nothing
where
co_con = maybe (pprPanic "splitNewTypeRepCo_maybe" (ppr tc)) id (newTyConCo_maybe tc)
splitNewTypeRepCo_maybe other = Nothing
\end{code} \end{code}
...@@ -440,7 +453,6 @@ splitNewTypeRepCo_maybe other = Nothing ...@@ -440,7 +453,6 @@ splitNewTypeRepCo_maybe other = Nothing
\begin{code} \begin{code}
-- CoercionI is either -- CoercionI is either
-- (a) proper coercion -- (a) proper coercion
-- (b) the identity coercion -- (b) the identity coercion
......
...@@ -18,8 +18,10 @@ module TyCon( ...@@ -18,8 +18,10 @@ module TyCon(
SynTyConRhs(..), SynTyConRhs(..),
isFunTyCon, isUnLiftedTyCon, isProductTyCon, isFunTyCon, isUnLiftedTyCon, isProductTyCon,
isAlgTyCon, isDataTyCon, isNewTyCon, isClosedNewTyCon, isSynTyCon, isAlgTyCon, isDataTyCon,
isClosedSynTyCon, isPrimTyCon, isNewTyCon, unwrapNewTyCon_maybe,
isSynTyCon, isClosedSynTyCon,
isPrimTyCon,
isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon, isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon,
assocTyConArgPoss_maybe, isTyConAssoc, setTyConArgPoss, assocTyConArgPoss_maybe, isTyConAssoc, setTyConArgPoss,
isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
...@@ -642,19 +644,15 @@ isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity ...@@ -642,19 +644,15 @@ isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
isDataTyCon other = False isDataTyCon other = False
isNewTyCon :: TyCon -> Bool isNewTyCon :: TyCon -> Bool
isNewTyCon (AlgTyCon {algTcRhs = rhs}) = isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True
case rhs of isNewTyCon other = False
NewTyCon {} -> True
_ -> False unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, Maybe TyCon)
isNewTyCon other = False unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs,
algTcRhs = NewTyCon { nt_co = mb_co,
-- This is an important refinement as typical newtype optimisations do *not* nt_rhs = rhs }})
-- hold for newtype families. Why? Given a type `T a', if T is a newtype = Just (tvs, rhs, mb_co)
-- family, there is no unique right hand side by which `T a' can be replaced unwrapNewTyCon_maybe other = Nothing
-- by a cast.
--
isClosedNewTyCon :: TyCon -> Bool
isClosedNewTyCon tycon = isNewTyCon tycon && not (isOpenTyCon tycon)
isProductTyCon :: TyCon -> Bool isProductTyCon :: TyCon -> Bool
-- A "product" tycon -- A "product" tycon
......
...@@ -407,8 +407,6 @@ splitNewTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) ...@@ -407,8 +407,6 @@ splitNewTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
splitNewTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) splitNewTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
splitNewTyConApp_maybe other = Nothing splitNewTyConApp_maybe other = Nothing
-- get instantiated newtype rhs, the arguments had better saturate
-- the constructor
newTyConInstRhs :: TyCon -> [Type] -> Type newTyConInstRhs :: TyCon -> [Type] -> Type
newTyConInstRhs tycon tys = newTyConInstRhs tycon tys =
let (tvs, ty) = newTyConRhs tycon in substTyWith tvs tys ty let (tvs, ty) = newTyConRhs tycon in substTyWith tvs tys ty
...@@ -450,12 +448,15 @@ repType :: Type -> Type ...@@ -450,12 +448,15 @@ repType :: Type -> Type
repType ty | Just ty' <- coreView ty = repType ty' repType ty | Just ty' <- coreView ty = repType ty'
repType (ForAllTy _ ty) = repType ty repType (ForAllTy _ ty) = repType ty
repType (TyConApp tc tys) repType (TyConApp tc tys)
| isClosedNewTyCon tc = -- Recursive newtypes are opaque to coreView | isNewTyCon tc
-- but we must expand them here. Sure to , (tvs, rep_ty) <- newTyConRep tc
-- be saturated because repType is only applied = -- Recursive newtypes are opaque to coreView
-- to types of kind * -- but we must expand them here. Sure to
ASSERT( {- isRecursiveTyCon tc && -} tys `lengthIs` tyConArity tc ) -- be saturated because repType is only applied
repType (new_type_rep tc tys) -- to types of kind *
ASSERT( tys `lengthIs` tyConArity tc )
repType (substTyWith tvs tys rep_ty)
repType ty = ty repType ty = ty
-- repType' aims to be a more thorough version of repType -- repType' aims to be a more thorough version of repType
...@@ -468,12 +469,6 @@ repType' ty -- | pprTrace "repType'" (ppr ty $$ ppr (go1 ty)) False = undefined ...@@ -468,12 +469,6 @@ repType' ty -- | pprTrace "repType'" (ppr ty $$ ppr (go1 ty)) False = undefined
go ty = ty go ty = ty
-- new_type_rep doesn't ask any questions:
-- it just expands newtype, whether recursive or not
new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon )
case newTyConRep new_tycon of
(tvs, rep_ty) -> substTyWith tvs tys rep_ty
-- ToDo: this could be moved to the code generator, using splitTyConApp instead -- ToDo: this could be moved to the code generator, using splitTyConApp instead