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}
\begin{code}
module CoreUtils (
-- Construction
- mkInlineMe, mkSCC, mkCoerce,
+ mkInlineMe, mkSCC, mkCoerce, mkCoerceI,
bindNonRec, needsCaseBinding,
mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
\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;
-- 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
-> 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)
)
+ ----- Cases for .NET; almost certainly bit-rotted ---------
| Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
tc == listTyCon,
Just (cc,[]) <- splitTyConApp_maybe arg_ty,
\ 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
\ 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 ->
\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)
-- 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
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
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
-- 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
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
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
_ -> 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.
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)))
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 ()
import Unify
import VarSet
import Type
+import Coercion
import TyCon
-- others:
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}
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
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
mkForAllCoercion, mkFunCoercion, mkInstsCoercion, mkUnsafeCoercion,
mkNewTypeCoercion, mkFamInstCoercion, mkAppsCoercion,
- splitNewTypeRepCo_maybe, decomposeCo,
+ splitNewTypeRepCo_maybe, instNewTyCon_maybe, decomposeCo,
unsafeCoercionTyCon, symCoercionTyCon,
transCoercionTyCon, leftCoercionTyCon,
+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}
\begin{code}
-
-- CoercionI is either
-- (a) proper coercion
-- (b) the identity coercion
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,
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
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
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
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
-- 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}
projects / ghc-hetmet.git / commitdiff