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
deepSplitProductType_maybe ty
= do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty
; let {result
| isClosedNewTyCon tycon && not (isRecursiveTyCon tycon)
= deepSplitProductType_maybe (newTyConInstRhs tycon tycon_args)
| Just (ty', _co) <- instNewTyCon_maybe tycon tycon_args
, not (isRecursiveTyCon tycon)
= deepSplitProductType_maybe ty' -- Ignore the coercion?
| isNewTyCon tycon = Nothing -- cannot unbox through recursive
-- newtypes nor through families
| otherwise = Just res}
......
......@@ -8,7 +8,7 @@ Utility functions on @Core@ syntax
\begin{code}
module CoreUtils (
-- Construction
mkInlineMe, mkSCC, mkCoerce,
mkInlineMe, mkSCC, mkCoerce, mkCoerceI,
bindNonRec, needsCaseBinding,
mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
......@@ -194,6 +194,10 @@ mkInlineMe e = Note InlineMe e
\begin{code}
mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr
mkCoerceI IdCo e = e
mkCoerceI (ACo co) e = mkCoerce co e
mkCoerce :: Coercion -> CoreExpr -> CoreExpr
mkCoerce co (Cast expr co2)
= ASSERT(let { (from_ty, _to_ty) = coercionKind co;
......@@ -1159,8 +1163,8 @@ eta_expand n us expr ty
-- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
case splitNewTypeRepCo_maybe ty of {
Just(ty1,co) ->
mkCoerce (mkSymCoercion co) (eta_expand n us (mkCoerce co expr) ty1) ;
Just(ty1,co) -> mkCoerce (mkSymCoercion co)
(eta_expand n us (mkCoerce co expr) ty1) ;
Nothing ->
-- We have an expression of arity > 0, but its type isn't a function
......
......@@ -91,9 +91,9 @@ dsCCall :: CLabelString -- C routine to invoke
-> DsM CoreExpr -- Result, of type ???
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) ->
newUnique `thenDs` \ uniq ->
newUnique `thenDs` \ uniq ->
let
target = StaticTarget lbl
the_fcall = CCall (CCallSpec target CCallConv may_gc)
......@@ -182,6 +182,7 @@ unboxArg arg
)
----- Cases for .NET; almost certainly bit-rotted ---------
| Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
tc == listTyCon,
Just (cc,[]) <- splitTyConApp_maybe arg_ty,
......@@ -193,7 +194,7 @@ unboxArg arg
\ body ->
let
io_ty = exprType body
Just (_,io_arg) = tcSplitIOType_maybe io_ty
Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
in
mkApps (Var unpack_id)
[ Type io_arg
......@@ -209,13 +210,14 @@ unboxArg arg
\ body ->
let
io_ty = exprType body
Just (_,io_arg) = tcSplitIOType_maybe io_ty
Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
in
mkApps (Var unpack_id)
[ Type io_arg
, arg
, Lam prim_obj body
])
--------------- End of cases for .NET --------------------
| otherwise
= getSrcSpanDs `thenDs` \ l ->
......@@ -235,7 +237,8 @@ unboxArg arg
\begin{code}
boxResult :: ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> CoreExpr))
boxResult :: ((Maybe Type, CoreExpr -> CoreExpr)
-> (Maybe Type, CoreExpr -> CoreExpr))
-> Maybe Id
-> Type
-> DsM (Type, CoreExpr -> CoreExpr)
......@@ -255,45 +258,45 @@ boxResult :: ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> Cor
-- It looks a mess: I wonder if it could be refactored.
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
-- simple wrapping of IO. E.g.
-- 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
-- another case, and a coercion.)
= -- The result is IO t, so wrap the result in an IO constructor
resultWrapper io_res_ty `thenDs` \ res ->
let aug_res = augment res
extra_result_tys = case aug_res of
(Just ty,_)
| isUnboxedTupleType ty
-> let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
_ -> []
return_result state anss
= mkConApp (tupleCon Unboxed (2 + length extra_result_tys))
(map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)
++ (state : anss))
in
mk_alt return_result aug_res `thenDs` \ (ccall_res_ty, the_alt) ->
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
let
io_data_con = head (tyConDataCons io_tycon)
toIOCon = case mbTopCon of
Nothing -> dataConWrapId io_data_con
Just x -> x
wrap = \ the_call -> mkApps (Var toIOCon)
[ Type io_res_ty,
Lam state_id $
Case (App the_call (Var state_id))
(mkWildId ccall_res_ty)
(coreAltType the_alt)
[the_alt]
]
in
returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
-- The result is IO t, so wrap the result in an IO constructor
= do { res <- resultWrapper io_res_ty
; let aug_res = augment res
extra_result_tys
= case aug_res of
(Just ty,_)
| isUnboxedTupleType ty
-> let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
_ -> []
return_result state anss
= mkConApp (tupleCon Unboxed (2 + length extra_result_tys))
(map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)
++ (state : anss))
; (ccall_res_ty, the_alt) <- mk_alt return_result aug_res
; state_id <- newSysLocalDs realWorldStatePrimTy
; let io_data_con = head (tyConDataCons io_tycon)
toIOCon = mbTopCon `orElse` dataConWrapId io_data_con
wrap the_call = mkCoerceI (mkSymCoI co) $
mkApps (Var toIOCon)
[ Type io_res_ty,
Lam state_id $
Case (App the_call (Var state_id))
(mkWildId ccall_res_ty)
(coreAltType the_alt)
[the_alt]
]
; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }
boxResult augment mbTopCon result_ty
= -- It isn't IO, so do unsafePerformIO
......@@ -302,9 +305,9 @@ boxResult augment mbTopCon result_ty
mk_alt return_result (augment res) `thenDs` \ (ccall_res_ty, the_alt) ->
let
wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
(mkWildId ccall_res_ty)
(coreAltType the_alt)
[the_alt]
(mkWildId ccall_res_ty)
(coreAltType the_alt)
[the_alt]
in
returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
where
......@@ -360,6 +363,9 @@ mk_alt return_result (Just prim_res_ty, wrap_result)
resultWrapper :: Type
-> DsM (Maybe Type, -- Type of the expected result, if any
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
-- Base case 1: primitive types
| isPrimitiveType result_ty
......
......@@ -282,8 +282,9 @@ dsFExport fn_id ty ext_name cconv isDyn
-- If it's IO t, return (t, True)
-- If it's plain t, return (t, False)
(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
-- ToDo: what about the coercion?
Nothing -> returnDs (orig_res_ty, False)
-- The function returns t
) `thenDs` \ (res_ty, -- t
......@@ -339,7 +340,6 @@ dsFExportDynamic id cconv
dsLookupGlobalId newStablePtrName `thenDs` \ newStablePtrId ->
dsLookupTyCon stablePtrTyConName `thenDs` \ stable_ptr_tycon ->
let
mk_stbl_ptr_app = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
export_ty = mkFunTy stable_ptr_ty arg_ty
in
......@@ -348,12 +348,6 @@ dsFExportDynamic id cconv
dsFExport id export_ty fe_nm cconv True
`thenDs` \ (h_code, c_code, arg_reps, args_size) ->
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
create a little bit of (template) code on the fly
......@@ -384,18 +378,19 @@ dsFExportDynamic id cconv
_ -> Nothing
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
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 $
mkLams [cback] $
stbl_app ccall_io_adj res_ty
let io_app = mkLams tvs $
Lam cback $
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)
-- Never inline the f.e.d. function, because the litlit
-- might not be in scope in other modules.
......@@ -403,11 +398,12 @@ dsFExportDynamic id cconv
returnDs ([fed], h_code, c_code)
where
ty = idType id
(tvs,sans_foralls) = tcSplitForAllTys ty
([arg_ty], io_res_ty) = tcSplitFunTys sans_foralls
[res_ty] = tcTyConAppArgs io_res_ty
-- Must use tcSplit* to see the (IO t), which is a newtype
ty = idType id
(tvs,sans_foralls) = tcSplitForAllTys ty
([arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls
Just (io_tc, res_ty, co) = tcSplitIOType_maybe fn_res_ty
-- Must have an IO type; hence Just
-- co : fn_res_ty ~ IO res_ty
toCName :: Id -> String
toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
......
......@@ -263,7 +263,7 @@ mustBeIO = False
checkForeignRes non_io_result_ok pred_res_ty ty
-- (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
= returnM ()
......
......@@ -140,6 +140,7 @@ import ForeignCall
import Unify
import VarSet
import Type
import Coercion
import TyCon
-- others:
......@@ -840,6 +841,7 @@ tcSplitPredTy_maybe other = Nothing
predTyUnique :: PredType -> Unique
predTyUnique (IParam n _) = getUnique (ipNameName n)
predTyUnique (ClassP clas tys) = getUnique clas
predTyUnique (EqPred a b) = pprPanic "predTyUnique" (ppr (EqPred a b))
\end{code}
......@@ -1050,6 +1052,7 @@ exactTyVarsOfType ty
go (AppTy fun arg) = go fun `unionVarSet` go arg
go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar
`unionVarSet` go_tv tyvar
go (NoteTy _ _) = panic "exactTyVarsOfType" -- Handled by tcView
go_pred (IParam _ ty) = go ty
go_pred (ClassP _ tys) = exactTyVarsOfTypes tys
......@@ -1103,22 +1106,28 @@ restricted set of types as arguments and results (the restricting factor
being the )
\begin{code}
tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type)
-- (isIOType t) returns (Just (IO,t')) if t is of the form (IO t'), or
-- some newtype wrapping thereof
tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, CoercionI)
-- (isIOType t) returns Just (IO,t',co)
-- if co : t ~ IO t'
-- returns Nothing otherwise
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
-- 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
= tcSplitIOType_maybe ty'
Just (io_tycon, [io_res_ty])
| io_tycon `hasKey` ioTyConKey
-> Just (io_tycon, io_res_ty, IdCo)
| otherwise
= Nothing
Just (tc, tys)
| 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
-- True for any TyCon that can possibly be an arg or result of an FFI call
......
......@@ -27,7 +27,7 @@ module Coercion (
mkForAllCoercion, mkFunCoercion, mkInstsCoercion, mkUnsafeCoercion,
mkNewTypeCoercion, mkFamInstCoercion, mkAppsCoercion,
splitNewTypeRepCo_maybe, decomposeCo,
splitNewTypeRepCo_maybe, instNewTyCon_maybe, decomposeCo,
unsafeCoercionTyCon, symCoercionTyCon,
transCoercionTyCon, leftCoercionTyCon,
......@@ -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
splitNewTypeRepCo_maybe :: Type -> Maybe (Type, 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
-- 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
| Just ty' <- coreView ty = splitNewTypeRepCo_maybe ty'
splitNewTypeRepCo_maybe (TyConApp tc tys)
| isClosedNewTyCon tc
= ASSERT( tys `lengthIs` tyConArity tc ) -- splitNewTypeRepCo_maybe only be applied
-- to *types* (of kind *)
case newTyConRhs tc of
(tvs, rep_ty) ->
ASSERT( length tvs == length tys )
Just (substTyWith tvs tys rep_ty, mkTyConApp co_con tys)
where
co_con = maybe (pprPanic "splitNewTypeRepCo_maybe" (ppr tc)) id (newTyConCo_maybe tc)
splitNewTypeRepCo_maybe other = Nothing
| Just (ty', coi) <- instNewTyCon_maybe tc tys
= case coi of
ACo co -> Just (ty', co)
IdCo -> panic "splitNewTypeRepCo_maybe"
-- This case handled by coreView
splitNewTypeRepCo_maybe other
= Nothing
\end{code}
......@@ -440,7 +453,6 @@ splitNewTypeRepCo_maybe other = Nothing
\begin{code}
-- CoercionI is either
-- (a) proper coercion
-- (b) the identity coercion
......
......@@ -18,8 +18,10 @@ module TyCon(
SynTyConRhs(..),
isFunTyCon, isUnLiftedTyCon, isProductTyCon,
isAlgTyCon, isDataTyCon, isNewTyCon, isClosedNewTyCon, isSynTyCon,
isClosedSynTyCon, isPrimTyCon,
isAlgTyCon, isDataTyCon,
isNewTyCon, unwrapNewTyCon_maybe,
isSynTyCon, isClosedSynTyCon,
isPrimTyCon,
isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon,
assocTyConArgPoss_maybe, isTyConAssoc, setTyConArgPoss,
isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
......@@ -642,19 +644,15 @@ isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
isDataTyCon other = False
isNewTyCon :: TyCon -> Bool
isNewTyCon (AlgTyCon {algTcRhs = rhs}) =
case rhs of
NewTyCon {} -> True
_ -> False
isNewTyCon other = False
-- This is an important refinement as typical newtype optimisations do *not*
-- hold for newtype families. Why? Given a type `T a', if T is a newtype
-- family, there is no unique right hand side by which `T a' can be replaced
-- by a cast.
--
isClosedNewTyCon :: TyCon -> Bool
isClosedNewTyCon tycon = isNewTyCon tycon && not (isOpenTyCon tycon)
isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True
isNewTyCon other = False
unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, Maybe TyCon)
unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs,
algTcRhs = NewTyCon { nt_co = mb_co,
nt_rhs = rhs }})
= Just (tvs, rhs, mb_co)
unwrapNewTyCon_maybe other = Nothing
isProductTyCon :: TyCon -> Bool
-- A "product" tycon
......
......@@ -407,8 +407,6 @@ splitNewTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
splitNewTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
splitNewTyConApp_maybe other = Nothing
-- get instantiated newtype rhs, the arguments had better saturate
-- the constructor
newTyConInstRhs :: TyCon -> [Type] -> Type
newTyConInstRhs tycon tys =
let (tvs, ty) = newTyConRhs tycon in substTyWith tvs tys ty
......@@ -450,12 +448,15 @@ repType :: Type -> Type
repType ty | Just ty' <- coreView ty = repType ty'
repType (ForAllTy _ ty) = repType ty
repType (TyConApp tc tys)
| isClosedNewTyCon tc = -- Recursive newtypes are opaque to coreView
-- but we must expand them here. Sure to
-- be saturated because repType is only applied
-- to types of kind *
ASSERT( {- isRecursiveTyCon tc && -} tys `lengthIs` tyConArity tc )
repType (new_type_rep tc tys)
| isNewTyCon tc
, (tvs, rep_ty) <- newTyConRep tc
= -- Recursive newtypes are opaque to coreView
-- but we must expand them here. Sure to
-- be saturated because repType is only applied
-- to types of kind *
ASSERT( tys `lengthIs` tyConArity tc )
repType (substTyWith tvs tys rep_ty)
repType ty = ty
-- 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
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
-- of inspecting the type directly.
typePrimRep :: Type -> PrimRep
......@@ -488,7 +483,6 @@ typePrimRep ty = case repType ty of
-- The reason is that f must have kind *->*, not *->*#, because
-- (we claim) there is no way to constrain f's kind any other
-- way.
\end{code}
......
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