import Name ( NamedThing(..) )
import DataCon ( DataCon{-instance NamedThing-}, dataConWrapId )
import Maybes ( maybeToBool, catMaybes )
-import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..), CCall(..), CCallTarget(..) )
+import PrimOp ( primOpNeedsWrapper, pprPrimOp, pprCCallOp,
+ PrimOp(..), CCall(..), CCallTarget(..) )
import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
import SMRep ( pprSMRep )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
that the runtime check that PerformGC is being used sensibly will work.
\begin{code}
-pprCCall (CCall op_str is_asm may_gc cconv) args results vol_regs
+pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
= vcat [
char '{',
declare_local_vars, -- local var for *result*
| otherwise = ( pp_basic_saves $$ pp_saves,
pp_basic_restores $$ pp_restores)
- non_void_args =
- let nvas = tail args
- in ASSERT (all non_void nvas) nvas
- -- the first argument will be the "I/O world" token (a VoidRep)
+ non_void_args = let nvas = take (length args - 1) args
+ in ASSERT2 ( all non_void nvas, pprCCallOp call <+> hsep (map pprAmode args) )
+ nvas
+ -- the last argument will be the "I/O world" token (a VoidRep)
-- all others should be non-void
non_void_results =
import Type ( Type, ClassContext, mkDictTy, mkTyConApp, mkTyVarTys,
mkFunTys, mkFunTy, mkSigmaTy, classesToPreds,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, tyVarsOfTypes,
- splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
+ splitSigmaTy, splitFunTy_maybe,
splitFunTys, splitForAllTys, unUsgTy,
mkUsgTy, UsageAnn(..)
)
tidyTopName,
nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule,
- isUserExportedName, isUserImportedName, isUserImportedExplicitlyName, nameSrcLoc,
- isLocallyDefinedName, isDynName,
+ isUserExportedName, isUserImportedName, isUserImportedExplicitlyName,
+ maybeUserImportedFrom,
+ nameSrcLoc, isLocallyDefinedName, isDynName,
isSystemName, isLocalName, isGlobalName, isExternallyVisibleName,
isUserImportedName (Name { n_prov = NonLocalDef (UserImport _ _ _) _ }) = True
isUserImportedName other = False
+maybeUserImportedFrom (Name { n_prov = NonLocalDef (UserImport m _ _) _ }) = Just m
+maybeUserImportedFrom other = Nothing
+
isDynName :: Name -> Bool
-- Does this name come from a DLL?
isDynName nm = not (isLocallyDefinedName nm) &&
%
% (c) The GRASP Project, Glasgow University, 1992-1998
%
-% $Id: CgRetConv.lhs,v 1.20 2000/03/23 17:45:19 simonpj Exp $
+% $Id: CgRetConv.lhs,v 1.21 2000/04/05 16:25:51 simonpj Exp $
%
\section[CgRetConv]{Return conventions for the code generator}
import PrimOp ( PrimOp{-instance Outputable-} )
import PrimRep ( isFloatingRep, PrimRep(..), is64BitRep )
import TyCon ( TyCon, tyConDataCons, tyConFamilySize )
-import Type ( Type, typePrimRep, isUnLiftedType,
- splitAlgTyConApp_maybe )
+import Type ( Type, typePrimRep, isUnLiftedType )
import Util ( isn'tIn )
import Outputable
splitFunTy_maybe, mkPiType, mkTyVarTy, unUsgTy,
splitForAllTy_maybe, splitTyConApp_maybe,
isUnLiftedType, typeKind,
- splitAlgTyConApp_maybe,
isUnboxedTupleType,
hasMoreBoxityInfo
)
import PrimOp ( PrimOp(..), primOpIsDupable, primOpOutOfLine, ccallIsCasm )
import IdInfo ( ArityInfo(..), InlinePragInfo(..), OccInfo(..), IdFlavour(..), CprInfo(..), insideLam, workerExists )
import TyCon ( tyConFamilySize )
-import Type ( splitAlgTyConApp_maybe, splitFunTy_maybe, isUnLiftedType )
+import Type ( splitFunTy_maybe, isUnLiftedType )
import Unique ( Unique, buildIdKey, augmentIdKey )
import Maybes ( maybeToBool )
import Bag
\begin{code}
-mkCoerce :: Type -> Type -> Expr b -> Expr b
--- In (mkCoerce to_ty from_ty e), we require that from_ty = exprType e
--- But exprType is defined in CoreUtils, so we don't check the assertion
+mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
= ASSERT( from_ty == to_ty2 )
mkCoerce to_ty from_ty expr
| to_ty == from_ty = expr
- | otherwise = Note (Coerce to_ty from_ty) expr
+ | otherwise = ASSERT( from_ty == exprType expr )
+ Note (Coerce to_ty from_ty) expr
\end{code}
\begin{code}
, mkCCall
, unboxArg
, boxResult
- , wrapUnboxedValue
- , can'tSeeDataConsPanic
-
+ , resultWrapper
) where
#include "HsVersions.h"
import DsMonad
import DsUtils
-import TcHsSyn ( maybeBoxedPrimType )
-import CoreUtils ( exprType )
+import CoreUtils ( exprType, mkCoerce )
import Id ( Id, mkWildId )
-import MkId ( mkCCallOpId )
+import MkId ( mkCCallOpId, realWorldPrimId )
import Maybes ( maybeToBool )
import PrelInfo ( packStringForCId )
import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) )
-import DataCon ( DataCon, splitProductType_maybe )
+import DataCon ( DataCon, splitProductType_maybe, dataConSourceArity, dataConWrapId )
import CallConv
import Type ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,
- splitTyConApp_maybe, tyVarsOfType, mkForAllTys, Type
+ splitTyConApp_maybe, tyVarsOfType, mkForAllTys,
+ isNewType, repType, isUnLiftedType, mkFunTy,
+ Type
)
import TysPrim ( byteArrayPrimTy, realWorldStatePrimTy,
- byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
- intPrimTy
+ byteArrayPrimTyCon, mutableByteArrayPrimTyCon, intPrimTy
)
-import TysWiredIn ( unitDataConId, stringTy, boolTy,
- falseDataCon, falseDataConId,
- trueDataCon, trueDataConId,
+import TysWiredIn ( unitDataConId, stringTy,
unboxedPairDataCon,
- mkUnboxedTupleTy, unboxedTupleCon
+ mkUnboxedTupleTy, unboxedTupleCon,
+ boolTy, trueDataCon, falseDataCon, trueDataConId, falseDataConId,
+ unitTy
)
import Literal ( mkMachInt )
import CStrings ( CLabelString )
-import Unique ( Unique )
+import Unique ( Unique, Uniquable(..), ioTyConKey )
import VarSet ( varSetElems )
import Outputable
\end{code}
-> [CoreExpr] -- Arguments (desugared)
-> Bool -- True <=> might cause Haskell GC
-> Bool -- True <=> really a "_casm_"
- -> Type -- Type of the result (a boxed-prim IO type)
+ -> Type -- Type of the result: IO t
-> DsM CoreExpr
dsCCall lbl args may_gc is_asm result_ty
- = newSysLocalDs realWorldStatePrimTy `thenDs` \ old_s ->
-
- mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
- boxResult result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
+ = mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
+ boxResult result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
getUniqueDs `thenDs` \ uniq ->
let
- val_args = Var old_s : unboxed_args
the_ccall = CCall (StaticTarget lbl) is_asm may_gc cCallConv
- the_prim_app = mkCCall uniq the_ccall val_args final_result_ty
- the_body = foldr ($) (res_wrapper the_prim_app) arg_wrappers
+ the_prim_app = mkCCall uniq the_ccall unboxed_args ccall_result_ty
in
- returnDs (Lam old_s the_body)
+ returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
mkCCall :: Unique -> CCall
-> [CoreExpr] -- Args
-> DsM (CoreExpr, -- To pass as the actual argument
CoreExpr -> CoreExpr -- Wrapper to unbox the arg
)
-unboxArg arg
+-- Example: if the arg is e::Int, unboxArg will return
+-- (x#::Int#, \W. case x of I# x# -> W)
+-- where W is a CoreExpr that probably mentions x#
- -- Primitive types
- -- ADR Question: can this ever be used? None of the PrimTypes are
- -- instances of the CCallable class.
- --
- -- SOF response:
- -- Oh yes they are, I've just added them :-) Having _ccall_ and _casm_
- -- that accept unboxed arguments is a Good Thing if you have a stub generator
- -- which generates the boiler-plate box-unbox code for you, i.e., it may help
- -- us nuke this very module :-)
- --
+unboxArg arg
+ -- Unlifted types: nothing to unbox
| isUnLiftedType arg_ty
= returnDs (arg, \body -> body)
- -- Strings
- | arg_ty == stringTy
- -- ToDo (ADR): - allow synonyms of Strings too?
- = newSysLocalDs byteArrayPrimTy `thenDs` \ prim_arg ->
+ -- Newtypes
+ | isNewType arg_ty
+ = unboxArg (mkCoerce (repType arg_ty) arg_ty arg)
+
+ -- Booleans
+ | arg_ty == boolTy
+ = newSysLocalDs intPrimTy `thenDs` \ prim_arg ->
returnDs (Var prim_arg,
- \body -> Case (App (Var packStringForCId) arg)
- prim_arg [(DEFAULT,[],body)])
+ \ body -> Case (Case arg (mkWildId arg_ty)
+ [(DataAlt falseDataCon,[],mkIntLit 0),
+ (DataAlt trueDataCon, [],mkIntLit 1)])
+ prim_arg
+ [(DEFAULT,[],body)])
+
+ -- Data types with a single constructor, which has a single, primitive-typed arg
+ -- This deals with Int, Float etc
+ | is_product_type && data_con_arity == 1
+ = ASSERT(isUnLiftedType data_con_arg_ty1 ) -- Typechecker ensures this
+ newSysLocalDs arg_ty `thenDs` \ case_bndr ->
+ newSysLocalDs data_con_arg_ty1 `thenDs` \ prim_arg ->
+ returnDs (Var prim_arg,
+ \ body -> Case arg case_bndr [(DataAlt data_con,[prim_arg],body)]
+ )
-- Byte-arrays, both mutable and otherwise; hack warning
| is_product_type &&
- length data_con_arg_tys == 3 &&
+ data_con_arity == 3 &&
maybeToBool maybe_arg3_tycon &&
(arg3_tycon == byteArrayPrimTyCon ||
arg3_tycon == mutableByteArrayPrimTyCon)
\ body -> Case arg case_bndr [(DataAlt data_con,vars,body)]
)
- -- Data types with a single constructor, which has a single, primitive-typed arg
- | maybeToBool maybe_boxed_prim_arg_ty
- = newSysLocalDs arg_ty `thenDs` \ case_bndr ->
- newSysLocalDs the_prim_arg_ty `thenDs` \ prim_arg ->
- returnDs (Var prim_arg,
- \ body -> Case arg case_bndr [(DataAlt box_data_con,[prim_arg],body)]
- )
-
- -- Booleans
- | arg_ty == boolTy
- = newSysLocalDs intPrimTy `thenDs` \ prim_arg ->
- returnDs (Var prim_arg,
- \ body -> Case (Case arg (mkWildId arg_ty) [
- (DataAlt falseDataCon,[],mkIntLit 0),
- (DataAlt trueDataCon, [],mkIntLit 1)])
- prim_arg [(DEFAULT,[],body)]
- )
-
| otherwise
= getSrcLocDs `thenDs` \ l ->
pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
where
- arg_ty = exprType arg
-
- maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty
- (Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty
+ arg_ty = exprType arg
+ arg_rep_ty = repType arg_ty
maybe_product_type = splitProductType_maybe arg_ty
is_product_type = maybeToBool maybe_product_type
Just (tycon, _, data_con, data_con_arg_tys) = maybe_product_type
- (data_con_arg_ty1 : data_con_arg_ty2 : data_con_arg_ty3 :_)
- = data_con_arg_tys
-
- maybe_arg3_tycon = splitTyConApp_maybe data_con_arg_ty3
- Just (arg3_tycon,_) = maybe_arg3_tycon
+ data_con_arity = dataConSourceArity data_con
+ (data_con_arg_ty1 : _) = data_con_arg_tys
-can'tSeeDataConsPanic thing ty
- = pprPanic
- "ERROR: Can't see the data constructor(s) for _ccall_/_casm_/foreign declaration"
- (hcat [ text thing, text "; type: ", ppr ty
- , text "(try compiling with -fno-prune-tydecls ..)\n"])
+ (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
+ maybe_arg3_tycon = splitTyConApp_maybe data_con_arg_ty3
+ Just (arg3_tycon,_) = maybe_arg3_tycon
\end{code}
\begin{code}
-boxResult :: Type -- Type of desired result
- -> DsM (Type, -- Type of the result of the ccall itself
- CoreExpr -> CoreExpr) -- Wrapper for the ccall
- -- to box the result
-boxResult result_ty
- -- Data types with a single nullary constructor
- | (maybeToBool maybe_product_type) && -- Data type
- (null data_con_arg_tys)
- =
- newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
-{-
- wrapUnboxedValue result_ty `thenDs` \ (state_and_prim_datacon,
- state_and_prim_ty, prim_result_id, the_result) ->
- mkConDs ioOkDataCon
- [TyArg result_ty, VarArg (Var prim_state_id), VarArg the_result]
- `thenDs` \ the_pair ->
--}
- let
- the_pair = mkConApp unboxedPairDataCon
- [Type realWorldStatePrimTy, Type result_ty,
- Var prim_state_id,
- Var unitDataConId]
- the_alt = (DataAlt (unboxedTupleCon 1), [prim_state_id], the_pair)
- scrut_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy]
- in
- returnDs (scrut_ty, \prim_app -> Case prim_app (mkWildId scrut_ty) [the_alt]
- )
+boxResult :: Type -> DsM (Type, CoreExpr -> CoreExpr)
+
+-- Takes the result of the user-level ccall:
+-- either (IO t),
+-- or maybe just t for an side-effect-free call
+-- Returns a wrapper for the primitive ccall itself, along with the
+-- type of the result of the primitive ccall. This result type
+-- will be of the form
+-- State# RealWorld -> (# State# RealWorld, t' #)
+-- where t' is the unwrapped form of t. If t is simply (), then
+-- the result type will be
+-- State# RealWorld -> (# State# RealWorld #)
- -- Data types with a single constructor, which has a single, primitive-typed arg
- | (maybeToBool maybe_product_type) && -- Data type
- not (null data_con_arg_tys) && null other_args_tys && -- Just one arg
- isUnLiftedType the_prim_result_ty -- of primitive type
- =
- newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
- newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
- newSysLocalDs ccall_res_type `thenDs` \ case_bndr ->
-
- let
- the_result = mkConApp data_con (map Type tycon_arg_tys ++ [Var prim_result_id])
- the_pair = mkConApp unboxedPairDataCon
- [Type realWorldStatePrimTy, Type result_ty,
- Var prim_state_id, the_result]
- the_alt = (DataAlt unboxedPairDataCon, [prim_state_id, prim_result_id], the_pair)
- in
- returnDs (ccall_res_type, \prim_app -> Case prim_app case_bndr [the_alt]
- )
+boxResult result_ty
+ = case splitAlgTyConApp_maybe result_ty of
+
+ -- The result is IO t, so wrap the result in an IO constructor
+ Just (io_tycon, [io_res_ty], [io_data_con]) | getUnique io_tycon == ioTyConKey
+ -> mk_alt return_result
+ (resultWrapper io_res_ty) `thenDs` \ (ccall_res_ty, the_alt) ->
+ newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
+ let
+ wrap = \ the_call -> mkApps (Var (dataConWrapId io_data_con))
+ [Type io_res_ty, Lam state_id $
+ Case (App the_call (Var state_id))
+ (mkWildId ccall_res_ty)
+ [the_alt]]
+ in
+ returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
+ where
+ return_result state ans = mkConApp unboxedPairDataCon
+ [Type realWorldStatePrimTy, Type io_res_ty,
+ state, ans]
+
+ -- It isn't, so do unsafePerformIO
+ -- It's not conveniently available, so we inline it
+ other -> mk_alt return_result
+ (resultWrapper result_ty) `thenDs` \ (ccall_res_ty, the_alt) ->
+ let
+ wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
+ (mkWildId ccall_res_ty)
+ [the_alt]
+ in
+ returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
+ where
+ return_result state ans = ans
+ where
+ mk_alt return_result (Nothing, wrap_result)
+ = -- The ccall returns ()
+ newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
+ let
+ the_rhs = return_result (Var state_id) (wrap_result (panic "boxResult"))
+ ccall_res_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy]
+ the_alt = (DataAlt (unboxedTupleCon 1), [state_id], the_rhs)
+ in
+ returnDs (ccall_res_ty, the_alt)
+
+ mk_alt return_result (Just prim_res_ty, wrap_result)
+ = -- The ccall returns a non-() value
+ newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
+ newSysLocalDs prim_res_ty `thenDs` \ result_id ->
+ let
+ the_rhs = return_result (Var state_id) (wrap_result (Var result_id))
+ ccall_res_ty = mkUnboxedTupleTy 2 [realWorldStatePrimTy, prim_res_ty]
+ the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
+ in
+ returnDs (ccall_res_ty, the_alt)
+
+
+resultWrapper :: Type
+ -> (Maybe Type, -- Type of the expected result, if any
+ CoreExpr -> CoreExpr) -- Wrapper for the result
+resultWrapper result_ty
+ -- Base case 1: primitive types
+ | isUnLiftedType result_ty
+ = (Just result_ty, \e -> e)
+
+ -- Base case 1: the unit type ()
+ | result_ty == unitTy
+ = (Nothing, \e -> Var unitDataConId)
- -- Booleans
| result_ty == boolTy
- = returnDs (mkUnboxedTupleTy 2 [realWorldStatePrimTy, intPrimTy],
- \ prim_app -> Case prim_app (mkWildId intPrimTy) [
- (LitAlt (mkMachInt 0),[],Var falseDataConId),
- (DEFAULT ,[],Var trueDataConId )])
+ = (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
+ [(LitAlt (mkMachInt 0),[],Var falseDataConId),
+ (DEFAULT ,[],Var trueDataConId )])
+
+ -- Data types with a single constructor, which has a single arg
+ | is_product_type && data_con_arity == 1
+ = let
+ (maybe_ty, wrapper) = resultWrapper unwrapped_res_ty
+ (unwrapped_res_ty : _) = data_con_arg_tys
+ in
+ (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
+ (map Type tycon_arg_tys ++ [wrapper e]))
+
+ -- newtypes
+ | isNewType result_ty
+ = let
+ rep_ty = repType result_ty
+ (maybe_ty, wrapper) = resultWrapper rep_ty
+ in
+ (maybe_ty, \e -> mkCoerce result_ty rep_ty (wrapper e))
| otherwise
- = pprPanic "boxResult: " (ppr result_ty)
+ = pprPanic "resultWrapper" (ppr result_ty)
where
maybe_product_type = splitProductType_maybe result_ty
+ is_product_type = maybeToBool maybe_product_type
Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type
- (the_prim_result_ty : other_args_tys) = data_con_arg_tys
-
- ccall_res_type = mkUnboxedTupleTy 2 [realWorldStatePrimTy, the_prim_result_ty]
-
--- wrap up an unboxed value.
-wrapUnboxedValue :: Type -> DsM (Type, Id, CoreExpr)
-wrapUnboxedValue ty
- | (maybeToBool maybe_product_type) && -- Data type
- not (null data_con_arg_tys) && null other_args_tys && -- Just one arg
- isUnLiftedType the_prim_result_ty -- of primitive type
- =
- newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
- let
- the_result = mkConApp data_con (map Type tycon_arg_tys ++ [Var prim_result_id])
- in
- returnDs (ccall_res_type, prim_result_id, the_result)
-
- -- Data types with a single nullary constructor
- | (maybeToBool maybe_product_type) && -- Data type
- (null data_con_arg_tys)
- =
- let
- scrut_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy]
- in
- returnDs (scrut_ty, unitDataConId, Var unitDataConId)
-
- | otherwise
- = pprPanic "boxResult: " (ppr ty)
- where
- maybe_product_type = splitProductType_maybe ty
- Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type
- (the_prim_result_ty : other_args_tys) = data_con_arg_tys
- ccall_res_type = mkUnboxedTupleTy 2 [realWorldStatePrimTy, the_prim_result_ty]
+ data_con_arity = dataConSourceArity data_con
\end{code}
mkSimpleMatch
)
import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds,
- TypecheckedStmt,
- maybeBoxedPrimType
-
+ TypecheckedStmt
)
import CoreSyn
import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
import DsMonad
import DsBinds ( dsMonoBinds, AutoScc(..) )
import DsGRHSs ( dsGuarded )
-import DsCCall ( dsCCall )
+import DsCCall ( dsCCall, resultWrapper )
import DsListComp ( dsListComp )
import DsUtils ( mkErrorAppDs, mkDsLets, mkConsExpr, mkNilExpr )
import Match ( matchWrapper, matchSimply )
= returnDs (mkStringLitFS str)
dsExpr (HsLitOut (HsLitLit str) ty)
- | isUnLiftedType ty
- = returnDs (mkLit (MachLitLit str ty))
- | otherwise
- = case (maybeBoxedPrimType ty) of
- Just (boxing_data_con, prim_ty) ->
- returnDs ( mkConApp boxing_data_con [mkLit (MachLitLit str prim_ty)] )
- _ ->
- pprError "ERROR:"
- (vcat
- [ hcat [ text "Cannot see data constructor of ``literal-literal''s type: "
- , text "value:", quotes (quotes (ptext str))
- , text "; type: ", ppr ty
- ]
- , text "Try compiling with -fno-prune-tydecls."
- ])
-
+ = ASSERT( maybeToBool maybe_ty )
+ returnDs (wrap_fn (mkLit (MachLitLit str rep_ty)))
where
- (data_con, prim_ty)
- = case (maybeBoxedPrimType ty) of
- Just (boxing_data_con, prim_ty) -> (boxing_data_con, prim_ty)
- Nothing
- -> pprPanic "ERROR: ``literal-literal'' not a single-constructor type: "
- (hcat [ptext str, text "; type: ", ppr ty])
+ (maybe_ty, wrap_fn) = resultWrapper ty
+ Just rep_ty = maybe_ty
dsExpr (HsLitOut (HsInt i) ty)
= returnDs (mkIntegerLit i)
import CoreSyn
-import DsCCall ( dsCCall, mkCCall, boxResult, unboxArg, wrapUnboxedValue )
+import DsCCall ( dsCCall, mkCCall, boxResult, unboxArg )
import DsMonad
import DsUtils
import CoreUtils ( exprType, mkInlineMe, bindNonRec )
import DataCon ( DataCon, dataConWrapId )
import Id ( Id, idType, idName, mkWildId, mkVanillaId )
-import MkId ( mkCCallOpId, mkWorkerId )
+import MkId ( mkWorkerId )
import Literal ( Literal(..) )
import Module ( Module, moduleUserString )
import Name ( mkGlobalName, nameModule, nameOccName, getOccString,
mkForeignExportOcc, isLocalName,
NamedThing(..), Provenance(..), ExportFlag(..)
)
-import PrelInfo ( deRefStablePtr_NAME, bindIO_NAME, makeStablePtr_NAME, realWorldPrimId )
-import Type ( splitAlgTyConApp_maybe, unUsgTy,
+import PrelInfo ( deRefStablePtr_NAME, bindIO_NAME, makeStablePtr_NAME )
+import Type ( unUsgTy,
splitTyConApp_maybe, splitFunTys, splitForAllTys,
Type, mkFunTys, mkForAllTys, mkTyConApp,
mkTyVarTy, mkFunTy, splitAppTy
import Unique
import Maybes ( maybeToBool )
import Outputable
-
-#if __GLASGOW_HASKELL__ >= 404
-import GlaExts ( fromInt )
-#endif
\end{code}
Desugaring of @foreign@ declarations is naturally split up into
-> DsM [CoreBind]
dsFImport fn_id ty may_not_gc ext_name cconv
= let
- (tvs, arg_tys, mbIoDataCon, io_res_ty) = splitForeignTyDs ty
- is_io_action = maybeToBool mbIoDataCon
+ (tvs, fun_ty) = splitForAllTys ty
+ (arg_tys, io_res_ty) = splitFunTys fun_ty
in
newSysLocalsDs arg_tys `thenDs` \ args ->
- newSysLocalDs realWorldStatePrimTy `thenDs` \ old_s ->
- mapAndUnzipDs unboxArg (map Var args) `thenDs` \ (unboxed_args, arg_wrappers) ->
-
- (if not is_io_action then
- newSysLocalDs realWorldStatePrimTy `thenDs` \ state_tok ->
- wrapUnboxedValue io_res_ty `thenDs` \ (ccall_result_ty, v, res_v) ->
- returnDs ( ccall_result_ty
- , \ prim_app -> Case prim_app (mkWildId ccall_result_ty)
- [(DataAlt (unboxedTupleCon 2), [state_tok, v], res_v)])
- else
- boxResult io_res_ty) `thenDs` \ (ccall_result_ty, res_wrapper) ->
+ mapAndUnzipDs unboxArg (map Var args) `thenDs` \ (val_args, arg_wrappers) ->
+ boxResult io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
(case ext_name of
Dynamic -> getUniqueDs `thenDs` \ u ->
getUniqueDs `thenDs` \ ccall_uniq ->
getUniqueDs `thenDs` \ work_uniq ->
let
- the_state_arg | is_io_action = old_s
- | otherwise = realWorldPrimId
-
-- Build the worker
- val_args = Var the_state_arg : unboxed_args
work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars
worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
the_ccall = CCall lbl False (not may_not_gc) cconv
-- Build the wrapper
work_app = mkApps (mkVarApps (Var work_id) tvs) val_args
wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
- io_app = case mbIoDataCon of
- Nothing -> wrapper_body
- Just ioDataCon -> mkApps (Var (dataConWrapId ioDataCon))
- [Type io_res_ty, Lam old_s wrapper_body]
- wrap_rhs = mkInlineMe (mkLams (tvs ++ args) io_app)
+ wrap_rhs = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
in
returnDs [NonRec fn_id wrap_rhs, NonRec work_id work_rhs]
\end{code}
-Given the type of a foreign import declaration, split it up into
-its constituent parts.
-
-\begin{code}
-splitForeignTyDs :: Type -> ([TyVar], [Type], Maybe DataCon, Type)
-splitForeignTyDs ty
- = case splitAlgTyConApp_maybe res_ty of
- Just (_,(io_res_ty:_),(ioCon:_)) -> -- .... -> IO t
- (tvs, arg_tys, Just ioCon, io_res_ty)
- _ -> -- .... -> t
- (tvs, arg_tys, Nothing, res_ty)
- where
- (arg_tys, res_ty) = splitFunTys sans_foralls
- (tvs, sans_foralls) = splitForAllTys ty
-\end{code}
-
-foreign labels
+Foreign labels
\begin{code}
dsFLabel :: Id -> ExtName -> DsM CoreBind
opt_D_dump_rn_trace,
opt_D_dump_rn_stats,
opt_D_dump_stix,
+ opt_D_dump_minimal_imports,
opt_D_source_stats,
opt_D_verbose_core2core,
opt_D_verbose_stg2stg,
opt_D_source_stats = opt_D_dump_most || lookUp SLIT("-dsource-stats")
opt_D_verbose_core2core = opt_D_dump_all || lookUp SLIT("-dverbose-simpl")
opt_D_verbose_stg2stg = opt_D_dump_all || lookUp SLIT("-dverbose-stg")
+opt_D_dump_minimal_imports = lookUp SLIT("-ddump-minimal-imports")
opt_DoCoreLinting = lookUp SLIT("-dcore-lint")
opt_DoStgLinting = lookUp SLIT("-dstg-lint")
import Name ( mkWiredInTyConName, mkWiredInIdName, mkSrcOccFS, mkWorkerOcc, dataName )
import DataCon ( DataCon, StrictnessMark(..), mkDataCon, dataConId )
import Var ( TyVar, tyVarKind )
-import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkAlgTyCon, mkSynTyCon, mkTupleTyCon )
+import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, tyConDataCons,
+ mkAlgTyCon, mkSynTyCon, mkTupleTyCon, isUnLiftedTyCon
+ )
import BasicTypes ( Arity, NewOrData(..), RecFlag(..) )
import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys,
mkArrowKinds, boxedTypeKind, unboxedTypeKind,
- mkFunTy, mkFunTys, isUnLiftedType,
- splitTyConApp_maybe, splitAlgTyConApp_maybe,
+ mkFunTy, mkFunTys,
+ splitTyConApp_maybe, repType,
TauType, ClassContext )
import PrimRep ( PrimRep(..) )
import Unique
dc_uniq = mkTupleDataConUnique arity
mod = mkPrelModule mod_name
-unitTyCon = tupleTyCon 0
-pairTyCon = tupleTyCon 2
+unitTyCon = tupleTyCon 0
+unitDataConId = dataConId (head (tyConDataCons unitTyCon))
-unitDataConId = dataConId (tupleCon 0)
+pairTyCon = tupleTyCon 2
\end{code}
%************************************************************************
intDataCon = pcDataCon intDataConKey pREL_BASE SLIT("I#") [] [] [intPrimTy] intTyCon
isIntTy :: Type -> Bool
-isIntTy ty
- = case (splitAlgTyConApp_maybe ty) of
- Just (tycon, [], _) -> getUnique tycon == intTyConKey
- _ -> False
+isIntTy = isTyCon intTyConKey
\end{code}
\begin{code}
addrDataCon = pcDataCon addrDataConKey pREL_ADDR SLIT("A#") [] [] [addrPrimTy] addrTyCon
isAddrTy :: Type -> Bool
-isAddrTy ty
- = case (splitAlgTyConApp_maybe ty) of
- Just (tycon, [], _) -> getUnique tycon == addrTyConKey
- _ -> False
-
+isAddrTy = isTyCon addrTyConKey
\end{code}
\begin{code}
floatDataCon = pcDataCon floatDataConKey pREL_FLOAT SLIT("F#") [] [] [floatPrimTy] floatTyCon
isFloatTy :: Type -> Bool
-isFloatTy ty
- = case (splitAlgTyConApp_maybe ty) of
- Just (tycon, [], _) -> getUnique tycon == floatTyConKey
- _ -> False
-
+isFloatTy = isTyCon floatTyConKey
\end{code}
\begin{code}
doubleTy = mkTyConTy doubleTyCon
isDoubleTy :: Type -> Bool
-isDoubleTy ty
- = case (splitAlgTyConApp_maybe ty) of
- Just (tycon, [], _) -> getUnique tycon == doubleTyConKey
- _ -> False
+isDoubleTy = isTyCon doubleTyConKey
doubleTyCon = pcNonRecDataTyCon doubleTyConKey pREL_FLOAT SLIT("Double") [] [] [doubleDataCon]
doubleDataCon = pcDataCon doubleDataConKey pREL_FLOAT SLIT("D#") [] [] [doublePrimTy] doubleTyCon
foreignObjDataCon
= pcDataCon foreignObjDataConKey pREL_IO_BASE SLIT("ForeignObj")
[] [] [foreignObjPrimTy] foreignObjTyCon
+
+isForeignObjTy :: Type -> Bool
+isForeignObjTy = isTyCon foreignObjTyConKey
\end{code}
%************************************************************************
isIntegerTy :: Type -> Bool
-isIntegerTy ty
- = case (splitAlgTyConApp_maybe ty) of
- Just (tycon, [], _) -> getUnique tycon == integerTyConKey
- _ -> False
+isIntegerTy = isTyCon integerTyConKey
\end{code}
\begin{code}
isFFIArgumentTy :: Bool -> Type -> Bool
-isFFIArgumentTy forASafeCall ty =
- (opt_GlasgowExts && isUnLiftedType ty) ||
- case (splitAlgTyConApp_maybe ty) of
- Just (tycon, _, _) ->
- let
- u = getUnique tycon
- in
- u `elem` primArgTyConKeys && -- it has a suitable prim type, and
- (not forASafeCall || not ( u `elem` notSafeExternalTyCons)) -- it is safe to pass out.
- _ -> False
-
--- types that can be passed as arguments to "foreign" functions
-primArgTyConKeys
- = [ intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey
- , wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey
- , floatTyConKey, doubleTyConKey
- , addrTyConKey, charTyConKey, foreignObjTyConKey
- , stablePtrTyConKey
- , byteArrayTyConKey, mutableByteArrayTyConKey
- ]
-
--- types that can be passed from the outside world into Haskell.
--- excludes (mutable) byteArrays.
-isFFIExternalTy :: Type -> Bool
-isFFIExternalTy ty =
- (opt_GlasgowExts && isUnLiftedType ty) || --leave out for now: maybeToBool (maybeBoxedPrimType ty))) ||
- case (splitAlgTyConApp_maybe ty) of
- Just (tycon, _, _) ->
- let
- u_tycon = getUnique tycon
- in
- (u_tycon `elem` primArgTyConKeys) &&
- not (u_tycon `elem` notLegalExternalTyCons)
- _ -> False
+-- Checks for valid argument type for a 'foreign import'
+isFFIArgumentTy is_safe ty = checkTyCon (legalOutgoingTyCon is_safe) ty
+isFFIExternalTy :: Type -> Bool
+-- Types that are allowed as arguments of a 'foreign export'
+isFFIExternalTy ty = checkTyCon legalIncomingTyCon ty
isFFIResultTy :: Type -> Bool
-isFFIResultTy ty =
- not (isUnLiftedType ty) &&
- case (splitAlgTyConApp_maybe ty) of
- Just (tycon, _, _) ->
- let
- u_tycon = getUnique tycon
- in
- (u_tycon == getUnique unitTyCon) ||
- ((u_tycon `elem` primArgTyConKeys) &&
- not (u_tycon `elem` notLegalExternalTyCons))
- _ -> False
-
--- it's illegal to return foreign objects and (mutable)
--- bytearrays from a _ccall_ / foreign declaration
--- (or be passed them as arguments in foreign exported functions).
-notLegalExternalTyCons =
- [ foreignObjTyConKey, byteArrayTyConKey, mutableByteArrayTyConKey ]
-
--- it's really unsafe to pass out references to objects in the heap,
--- so for safe call-outs we simply disallow it.
-notSafeExternalTyCons =
- [ byteArrayTyConKey, mutableByteArrayTyConKey ]
+-- Types that are allowed as a result of a 'foreign import' or of a 'foreign export'
+-- Maybe we should distinguish between import and export, but
+-- here we just choose the more restrictive 'incoming' predicate
+-- But we allow () as well
+isFFIResultTy ty = checkTyCon (\tc -> tc == unitTyCon || legalIncomingTyCon tc) ty
+
+checkTyCon :: (TyCon -> Bool) -> Type -> Bool
+checkTyCon check_tc ty = case splitTyConApp_maybe (repType ty) of
+ Just (tycon, _) -> check_tc tycon
+ Nothing -> False
+
+isTyCon :: Unique -> Type -> Bool
+isTyCon uniq ty = checkTyCon (\tc -> uniq == getUnique tc) ty
+\end{code}
+----------------------------------------------
+These chaps do the work; they are not exported
+----------------------------------------------
-isForeignObjTy :: Type -> Bool
-isForeignObjTy ty =
- case (splitAlgTyConApp_maybe ty) of
- Just (tycon, _, _) -> (getUnique tycon) == foreignObjTyConKey
- _ -> False
-
+\begin{code}
+legalIncomingTyCon :: TyCon -> Bool
+-- It's illegal to return foreign objects and (mutable)
+-- bytearrays from a _ccall_ / foreign declaration
+-- (or be passed them as arguments in foreign exported functions).
+legalIncomingTyCon tc
+ | getUnique tc `elem` [ foreignObjTyConKey, byteArrayTyConKey, mutableByteArrayTyConKey ]
+ = False
+ | otherwise
+ = marshalableTyCon tc
+
+legalOutgoingTyCon :: Bool -> TyCon -> Bool
+-- Checks validity of types going from Haskell -> external world
+-- The boolean is true for a 'safe' call (when we don't want to
+-- pass Haskell pointers to the world)
+legalOutgoingTyCon be_safe tc
+ | be_safe && getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
+ = False
+ | otherwise
+ = marshalableTyCon tc
+
+marshalableTyCon tc
+ = (opt_GlasgowExts && isUnLiftedTyCon tc)
+ || getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey
+ , wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey
+ , floatTyConKey, doubleTyConKey
+ , addrTyConKey, charTyConKey, foreignObjTyConKey
+ , stablePtrTyConKey
+ , byteArrayTyConKey, mutableByteArrayTyConKey
+ , boolTyConKey
+ ]
\end{code}
+
%************************************************************************
%* *
\subsection[TysWiredIn-Bool]{The @Bool@ type}
extractHsTyNames, extractHsCtxtTyNames
)
-import CmdLineOpts ( opt_HiMap, opt_D_dump_rn_trace,
+import CmdLineOpts ( opt_HiMap, opt_D_dump_rn_trace, opt_D_dump_minimal_imports,
opt_D_dump_rn, opt_D_dump_rn_stats, opt_WarnDeprecations
)
import RnMonad
import RnNames ( getGlobalNames )
import RnSource ( rnSourceDecls, rnDecl )
-import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions,
+import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, getInterfaceExports,
getImportedRules, loadHomeInterface, getSlurped, removeContext
)
-import RnEnv ( availName, availsToNameSet,
- warnUnusedImports, warnUnusedLocalBinds, lookupImplicitOccRn,
+import RnEnv ( availName, availsToNameSet, unitAvailEnv, availEnvElts, plusAvailEnv,
+ warnUnusedImports, warnUnusedLocalBinds, lookupImplicitOccRn, pprAvail,
FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs
)
-import Module ( Module, ModuleName, mkSearchPath, mkThisModule )
+import Module ( Module, ModuleName, WhereFrom(..),
+ moduleNameUserString, mkSearchPath, moduleName, mkThisModule
+ )
import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc,
- nameOccName, nameUnique,
+ nameOccName, nameUnique, nameModule, maybeUserImportedFrom,
isUserImportedExplicitlyName, isUserImportedName,
maybeWiredInTyConName, maybeWiredInIdName, isWiredInName
)
import Id ( idType )
import TyCon ( isSynTyCon, getSynTyConDefn )
import NameSet
-import PrelMods ( mAIN_Name, pREL_MAIN_Name )
+import PrelMods ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name )
import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon )
import PrelInfo ( ioTyCon_NAME, thinAirIdNames, fractionalClassKeys, derivingOccurrences )
import Type ( namesOfType, funTyCon )
import ErrUtils ( printErrorsAndWarnings, dumpIfSet, ghcExit )
import BasicTypes ( NewOrData(..) )
import Bag ( isEmptyBag, bagToList )
-import FiniteMap ( eltsFM )
+import FiniteMap ( FiniteMap, eltsFM, fmToList, emptyFM, addToFM_C )
import UniqSupply ( UniqSupply )
import UniqFM ( lookupUFM )
import Maybes ( maybeToBool )
import Outputable
+import IO ( openFile, IOMode(..) )
\end{code}
getNameSupplyRn `thenRn` \ name_supply ->
-- REPORT UNUSED NAMES
- reportUnusedNames gbl_env global_avail_env
+ reportUnusedNames mod_name gbl_env global_avail_env
export_env
source_fvs `thenRn_`
%*********************************************************
\begin{code}
-reportUnusedNames :: GlobalRdrEnv -> NameEnv AvailInfo -> ExportEnv -> NameSet -> RnM d ()
-reportUnusedNames gbl_env avail_env (ExportEnv export_avails _ _) mentioned_names
+reportUnusedNames :: ModuleName -> GlobalRdrEnv -> AvailEnv -> ExportEnv -> NameSet -> RnMG ()
+reportUnusedNames mod_name gbl_env avail_env (ExportEnv export_avails _ _) mentioned_names
= let
used_names = mentioned_names `unionNameSets` availsToNameSet export_avails
| n <- nameSetToList mentioned_names,
not (isLocallyDefined n),
Just txt <- [lookupNameEnv deprec_env n] ]
+
+ minimal_imports :: FiniteMap Module AvailEnv
+ minimal_imports = foldNameSet add emptyFM really_used_names
+ add n acc = case maybeUserImportedFrom n of
+ Nothing -> acc
+ Just m -> addToFM_C plusAvailEnv acc m
+ (unitAvailEnv (mk_avail n))
+ mk_avail n = case lookupNameEnv avail_env n of
+ Just (AvailTC m _) | n==m -> AvailTC n [n]
+ | otherwise -> AvailTC m [n,m]
+ Just avail -> Avail n
+ Nothing -> pprPanic "mk_avail" (ppr n)
in
warnUnusedLocalBinds bad_locals `thenRn_`
warnUnusedImports bad_imps `thenRn_`
+ printMinimalImports mod_name minimal_imports `thenRn_`
getIfacesRn `thenRn` \ ifaces ->
(if opt_WarnDeprecations
then mapRn_ warnDeprec (deprec_used (iDeprecs ifaces))
else returnRn ())
+-- ToDo: deal with original imports with 'qualified' and 'as M' clauses
+printMinimalImports mod_name imps
+ | not opt_D_dump_minimal_imports
+ = returnRn ()
+ | otherwise
+ = mapRn to_ies (fmToList imps) `thenRn` \ mod_ies ->
+ ioToRnM (do { h <- openFile filename WriteMode ;
+ printForUser h (vcat (map ppr_mod_ie mod_ies))
+ }) `thenRn_`
+ returnRn ()
+ where
+ filename = moduleNameUserString mod_name ++ ".imports"
+ ppr_mod_ie (mod_name, ies)
+ | mod_name == pRELUDE_Name
+ = empty
+ | otherwise
+ = ptext SLIT("import") <+> ppr mod_name <>
+ parens (fsep (punctuate comma (map ppr ies)))
+
+ to_ies (mod, avail_env) = mapRn to_ie (availEnvElts avail_env) `thenRn` \ ies ->
+ returnRn (moduleName mod, ies)
+
+ to_ie :: AvailInfo -> RnMG (IE Name)
+ to_ie (Avail n) = returnRn (IEVar n)
+ to_ie (AvailTC n [m]) = ASSERT( n==m )
+ returnRn (IEThingAbs n)
+ to_ie (AvailTC n ns) = getInterfaceExports (moduleName (nameModule n))
+ ImportBySystem `thenRn` \ (_, avails) ->
+ case [ms | AvailTC m ms <- avails, m == n] of
+ [ms] | all (`elem` ns) ms -> returnRn (IEThingAll n)
+ | otherwise -> returnRn (IEThingWith n (filter (/= n) ns))
+ other -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $
+ returnRn (IEVar n)
+
warnDeprec :: (Name, DeprecTxt) -> RnM d ()
warnDeprec (name, txt)
= pushSrcLocRn (getSrcLoc name) $
plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails
plusExportAvails (m1, e1) (m2, e2)
- = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2)
+ = (plusFM_C (++) m1 m2, plusAvailEnv e1 e2)
-- ToDo: wasteful: we do this once for each constructor!
\end{code}
\begin{code}
plusAvail (Avail n1) (Avail n2) = Avail n1
-plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2))
+plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2))
-- Added SOF 4/97
#ifdef DEBUG
plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
#endif
+addAvail :: AvailEnv -> AvailInfo -> AvailEnv
+addAvail avails avail = addToNameEnv_C plusAvail avails (availName avail) avail
+
+emptyAvailEnv = emptyNameEnv
+unitAvailEnv :: AvailInfo -> AvailEnv
+unitAvailEnv a = unitNameEnv (availName a) a
+
+plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv
+plusAvailEnv = plusNameEnv_C plusAvail
+
+availEnvElts = nameEnvElts
+
addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
addAvailToNameSet names avail = addListToNameSet names (availNames avail)
filterAvail ie avail = Nothing
+pprAvail :: AvailInfo -> SDoc
+pprAvail (AvailTC n ns) = ppr n <> case filter (/= n) ns of
+ [] -> empty
+ ns' -> parens (hsep (punctuate comma (map ppr ns')))
--- In interfaces, pprAvail gets given the OccName of the "host" thing
-pprAvail avail = getPprStyle $ \ sty ->
- if ifaceStyle sty then
- ppr_avail (pprOccName . nameOccName) avail
- else
- ppr_avail ppr avail
-
-ppr_avail pp_name (AvailTC n ns) = hsep [
- pp_name n,
- parens $ hsep $ punctuate comma $
- map pp_name ns
- ]
-ppr_avail pp_name (Avail n) = pp_name n
+pprAvail (Avail n) = ppr n
\end{code}
addToNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a
addToNameEnv :: NameEnv a -> Name -> a -> NameEnv a
plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a
+plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a
extendNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a
lookupNameEnv :: NameEnv a -> Name -> Maybe a
delFromNameEnv :: NameEnv a -> Name -> NameEnv a
elemNameEnv :: Name -> NameEnv a -> Bool
+unitNameEnv :: Name -> a -> NameEnv a
emptyNameEnv = emptyUFM
nameEnvElts = eltsUFM
addToNameEnv_C = addToUFM_C
addToNameEnv = addToUFM
plusNameEnv = plusUFM
+plusNameEnv_C = plusUFM_C
extendNameEnv = addListToUFM
lookupNameEnv = lookupUFM
delFromNameEnv = delFromUFM
elemNameEnv = elemUFM
+unitNameEnv = unitUFM
--------------------------------
type FixityEnv = NameEnv RenamedFixitySig
-- Includes avails only from *unqualified* imports
-- (see 1.4 Report Section 5.1.1)
- NameEnv AvailInfo) -- Used to figure out all other export specifiers.
- -- Maps a Name to the AvailInfo that contains it
-
+ AvailEnv) -- Used to figure out all other export specifiers.
+
data GenAvailInfo name = Avail name -- An ordinary identifier
| AvailTC name -- The name of the type or class
-- to be in scope, it must be in this list.
-- Thus, typically: AvailTC Eq [Eq, ==, /=]
+type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contains it
type AvailInfo = GenAvailInfo Name
type RdrAvailInfo = GenAvailInfo OccName
\end{code}
-> RnMG (Maybe (ExportEnv,
GlobalRdrEnv,
FixityEnv, -- Fixities for local decls only
- NameEnv AvailInfo -- Maps a name to its parent AvailInfo
+ AvailEnv -- Maps a name to its parent AvailInfo
-- Just for in-scope things only
))
-- Nothing => no need to recompile
-- the main worker function in exportsFromAvail
= ([ModuleName], -- 'module M's seen so far
ExportOccMap, -- Tracks exported occurrence names
- NameEnv AvailInfo) -- The accumulated exported stuff, kept in an env
+ AvailEnv) -- The accumulated exported stuff, kept in an env
-- so we can common-up related AvailInfos
type ExportOccMap = FiniteMap OccName (Name, RdrNameIE)
(mod_avail_env, entity_avail_env)
global_name_env
= foldlRn exports_from_item
- ([], emptyFM, emptyNameEnv) export_items `thenRn` \ (_, _, export_avail_map) ->
+ ([], emptyFM, emptyAvailEnv) export_items `thenRn` \ (_, _, export_avail_map) ->
let
export_avails :: [AvailInfo]
export_avails = nameEnvElts export_avail_map
Just mod_avails -> foldlRn (check_occs ie) occs mod_avails
`thenRn` \ occs' ->
let
- avails' = foldl add_avail avails mod_avails
+ avails' = foldl addAvail avails mod_avails
in
returnRn (mod:mods, occs', avails')
= warnCheckRn (ok_item ie avail) (dodgyExportWarn ie) `thenRn_`
check_occs ie occs export_avail `thenRn` \ occs' ->
- returnRn (mods, occs', add_avail avails export_avail)
+ returnRn (mods, occs', addAvail avails export_avail)
where
rdr_name = ieName ie
-- in the AvailTC is the type or class itself
ok_item _ _ = True
-add_avail avails avail = addToNameEnv_C plusAvail avails (availName avail) avail
-
check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap
check_occs ie occs avail
= foldlRn check occs (availNames avail)
import TyCon ( TyCon, isDataTyCon )
import PrelInfo ( unpackCStringId, unpackCString2Id, addr2IntegerId )
import PrelRules ( builtinRules )
-import Type ( Type, splitAlgTyConApp_maybe,
+import Type ( Type,
isUnLiftedType,
tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
Type
import TysWiredIn ( unboxedTupleCon, unboxedTupleTyCon )
import Type ( isUnLiftedType,
splitForAllTys, splitFunTys, isAlgType,
- splitAlgTyConApp_maybe, splitNewType_maybe,
+ splitNewType_maybe,
mkTyConApp, mkFunTys,
Type
)
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
import TcHsSyn ( TcExpr, TcRecordBinds, mkHsConApp,
- mkHsTyApp, mkHsLet, maybeBoxedPrimType
+ mkHsTyApp, mkHsLet
)
import TcMonad
-- constraints on the argument and result types.
mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
newClassDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) ->
- returnTc (mkHsConApp ioDataCon [result_ty] [HsCCall lbl args' may_gc is_asm result_ty],
- -- do the wrapping in the newtype constructor here
+ returnTc (HsCCall lbl args' may_gc is_asm io_result_ty,
foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
\end{code}
-- re-exported from TcEnv
TcId, tcInstId,
- maybeBoxedPrimType,
-
zonkTopBinds, zonkId, zonkIdOcc,
zonkForeignExports, zonkRules
) where
import TcType ( TcType, TcTyVar,
zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType
)
-import Type ( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type )
+import Type ( mkTyVarTy, isUnLiftedType, Type )
import Name ( isLocallyDefined )
import Var ( TyVar )
import VarEnv ( TyVarEnv, emptyVarEnv, extendVarEnvList )
%* *
%************************************************************************
-Some gruesome hackery for desugaring ccalls. It's here because if we put it
-in Type.lhs we get irritating loops, and it's only used by TcInstDcls.lhs and
-DsCCall.lhs.
-
-\begin{code}
-maybeBoxedPrimType :: Type -> Maybe (DataCon, Type)
-maybeBoxedPrimType ty
- = case splitProductType_maybe ty of -- Product data type
- Just (tycon, tys_applied, data_con, [data_con_arg_ty]) -- constr has one arg
- | isUnLiftedType data_con_arg_ty -- which is primitive
- -> Just (data_con, data_con_arg_ty)
-
- other_cases -> Nothing
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
-%* *
-%************************************************************************
-
This zonking pass runs over the bindings
a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
andMonoBindList
)
import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl )
-import TcHsSyn ( TcMonoBinds, mkHsConApp,
- maybeBoxedPrimType
- )
+import TcHsSyn ( TcMonoBinds, mkHsConApp )
import TcBinds ( tcSpecSigs )
import TcClassDcl ( tcMethodBind, checkFromThisClass )
import Subst ( mkTopTyVarSubst, substClasses )
import VarSet ( mkVarSet, varSetElems )
import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
-import TysWiredIn ( stringTy )
+import TysWiredIn ( stringTy, isFFIArgumentTy, isFFIResultTy )
import Unique ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
import Outputable
\end{code}
| otherwise = addErrTc (instConstraintErr clas tys)
scrutiniseInstanceHead clas inst_taus
- | -- CCALL CHECK (a).... urgh!
- -- To verify that a user declaration of a CCallable/CReturnable
- -- instance is OK, we must be able to see the constructor(s)
- -- of the instance type (see next guard.)
- --
- -- We flag this separately to give a more precise error msg.
- --
- (getUnique clas == cCallableClassKey || getUnique clas == cReturnableClassKey)
- && is_alg_tycon_app && not constructors_visible
- = addErrTc (invisibleDataConPrimCCallErr clas first_inst_tau)
-
- | -- CCALL CHECK (b)
+ | -- CCALL CHECK
-- A user declaration of a CCallable/CReturnable instance
-- must be for a "boxed primitive" type.
(getUnique clas == cCallableClassKey && not (ccallable_type first_inst_tau)) ||
constructors_visible = not (null data_cons)
-
--- These conditions come directly from what the DsCCall is capable of.
--- Totally grotesque. Green card should solve this.
-
-ccallable_type ty = isUnLiftedType ty || -- Allow CCallable Int# etc
- maybeToBool (maybeBoxedPrimType ty) || -- Ditto Int etc
- ty == stringTy ||
- byte_arr_thing
- where
- byte_arr_thing = case splitProductType_maybe ty of
- Just (tycon, ty_args, data_con, [data_con_arg_ty1, data_con_arg_ty2, data_con_arg_ty3]) ->
- maybeToBool maybe_arg3_tycon &&
- (arg3_tycon == byteArrayPrimTyCon ||
- arg3_tycon == mutableByteArrayPrimTyCon)
- where
- maybe_arg3_tycon = splitTyConApp_maybe data_con_arg_ty3
- Just (arg3_tycon,_) = maybe_arg3_tycon
-
- other -> False
-
-creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
- -- Or, a data type with a single nullary constructor
- case (splitAlgTyConApp_maybe ty) of
- Just (tycon, tys_applied, [data_con])
- -> isNullaryDataCon data_con
- other -> False
+ccallable_type ty = isFFIArgumentTy False {- Not safe call -} ty
+creturnable_type ty = isFFIResultTy ty
\end{code}
\begin{code}
4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"),
ppr inst_ty])
-{-
- Declaring CCallable & CReturnable instances in a module different
- from where the type was defined. Caused by importing data type
- abstractly (either programmatically or by the renamer being over-eager
- in its pruning.)
--}
-invisibleDataConPrimCCallErr clas inst_ty
- = hang (hsep [ptext SLIT("Constructors for"), quotes (ppr inst_ty),
- ptext SLIT("not visible when checking"),
- quotes (ppr clas), ptext SLIT("instance")])
- 4 (hsep [text "(Try either importing", ppr inst_ty,
- text "non-abstractly or compile using -fno-prune-tydecls ..)"])
-
methodCtxt = ptext SLIT("When checking the methods of an instance declaration")
superClassCtxt = ptext SLIT("When checking the superclasses of an instance declaration")
\end{code}
splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon])
splitAlgTyConApp_maybe (TyConApp tc tys)
- | isAlgTyCon tc &&
+ | isAlgTyCon tc &&
tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc)
splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
splitAlgTyConApp_maybe other = Nothing
projects / ghc-hetmet.git / commitdiff