Commit 546dd4f2 authored by Ian Lynagh's avatar Ian Lynagh

Implement the CTYPE pragma; part of the CApiFFI extension

For now, the syntax is
    type    {-# CTYPE "some C type" #-} Foo = ...
    newtype {-# CTYPE "some C type" #-} Foo = ...
    data    {-# CTYPE "some C type" #-} Foo = ...
parent c56c0c90
......@@ -11,6 +11,8 @@ module DsForeign ( dsForeigns ) where
#include "HsVersions.h"
import TcRnMonad -- temp
import TypeRep
import CoreSyn
import DsCCall
......@@ -227,12 +229,12 @@ dsFCall fn_id co fcall headerFilename = do
Nothing -> io_res_ty
isVoidRes = raw_res_ty `eqType` unitTy
cResType | isVoidRes = text "void"
| otherwise = showStgType raw_res_ty
| otherwise = toCType raw_res_ty
pprCconv = ccallConvAttribute CApiConv
argTypes
| null arg_tys = text "void"
| otherwise = hsep $ punctuate comma
[ showStgType t <+> char 'a' <> int n
[ toCType t <+> char 'a' <> int n
| (t, n) <- zip arg_tys [1..] ]
argVals = hsep $ punctuate comma
[ char 'a' <> int n
......@@ -496,7 +498,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
SDoc, -- C type
Type, -- Haskell type
CmmType)] -- the CmmType
arg_info = [ let stg_type = showStgType ty in
arg_info = [ let stg_type = toCType ty in
(arg_cname n stg_type,
stg_type,
ty,
......@@ -533,7 +535,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes
cResType | res_hty_is_unit = text "void"
| otherwise = showStgType res_hty
| otherwise = toCType res_hty
-- when the return type is integral and word-sized or smaller, it
-- must be assigned as type ffi_arg (#3516). To see what type
......@@ -661,12 +663,34 @@ mkHObj t = text "rts_mk" <> text (showFFIType t)
unpackHObj :: Type -> SDoc
unpackHObj t = text "rts_get" <> text (showFFIType t)
showStgType :: Type -> SDoc
showStgType t = text "Hs" <> text (showFFIType t)
showFFIType :: Type -> String
showFFIType t = getOccString (getName (typeTyCon t))
toCType :: Type -> SDoc
toCType = f False
where f voidOK t
-- First, if we have (Ptr t), then we need to convert t to a
-- C type and put a * after it.
| Just (ptr, [t']) <- splitTyConApp_maybe t
, tyConName ptr == ptrTyConName
= f True t' <> char '*'
-- Otherwise, if we have a type constructor application, then
-- see if there is a C type associated with that constructor.
-- Note that we aren't looking through type synonyms or
-- anything, as it may be the synonym that is annotated.
| TyConApp tycon _ <- t
, Just (CType cType) <- tyConCType_maybe tycon
= ftext cType
-- If we don't know a C type for this type, then try looking
-- through one layer of type synonym etc.
| Just t' <- coreView t
= f voidOK t'
-- Otherwise we don't know the C type. If we are allowing
-- void then return that; otherwise something has gone wrong.
| voidOK = ptext (sLit "void")
| otherwise
= pprPanic "toCType" (ppr t)
typeTyCon :: Type -> TyCon
typeTyCon ty = case tcSplitTyConApp_maybe (repType ty) of
Just (tc,_) -> tc
......
......@@ -161,13 +161,14 @@ cvtDec (PragmaD prag)
cvtDec (TySynD tc tvs rhs)
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
; rhs' <- cvtType rhs
; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') }
; returnL $ TyClD (TySynonym tc' Nothing tvs' Nothing rhs') }
cvtDec (DataD ctxt tc tvs constrs derivs)
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
; returnL $ TyClD (TyData { tcdND = DataType, tcdCType = Nothing
, tcdLName = tc', tcdCtxt = ctxt'
, tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing
, tcdCons = cons', tcdDerivs = derivs' }) }
......@@ -175,7 +176,8 @@ cvtDec (NewtypeD ctxt tc tvs constr derivs)
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
; returnL $ TyClD (TyData { tcdND = NewType, tcdCType = Nothing
, tcdLName = tc', tcdCtxt = ctxt'
, tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing
, tcdCons = [con'], tcdDerivs = derivs'}) }
......@@ -214,7 +216,8 @@ cvtDec (DataInstD ctxt tc tys constrs derivs)
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
; returnL $ InstD $ FamInstDecl $
TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
TyData { tcdND = DataType, tcdCType = Nothing
, tcdLName = tc', tcdCtxt = ctxt'
, tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
, tcdCons = cons', tcdDerivs = derivs' } }
......@@ -223,7 +226,8 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs)
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
; returnL $ InstD $ FamInstDecl $
TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
TyData { tcdND = NewType, tcdCType = Nothing
, tcdLName = tc', tcdCtxt = ctxt'
, tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
, tcdCons = [con'], tcdDerivs = derivs' } }
......@@ -231,7 +235,7 @@ cvtDec (TySynInstD tc tys rhs)
= do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys
; rhs' <- cvtType rhs
; returnL $ InstD $ FamInstDecl $
TySynonym tc' tvs' tys' rhs' }
TySynonym tc' Nothing tvs' tys' rhs' }
----------------
cvt_ci_decs :: MsgDoc -> [TH.Dec]
......
......@@ -465,6 +465,7 @@ data TyClDecl name
tcdCtxt :: LHsContext name, -- ^ Context
tcdLName :: Located name, -- ^ Type constructor
tcdCType :: Maybe CType,
tcdTyVars :: [LHsTyVarBndr name], -- ^ Type variables
tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns.
-- See Note [tcdTyVars and tcdTyPats]
......@@ -496,6 +497,7 @@ data TyClDecl name
}
| TySynonym { tcdLName :: Located name, -- ^ type constructor
tcdCType :: Maybe CType,
tcdTyVars :: [LHsTyVarBndr name], -- ^ type variables
tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns
-- See Note [tcdTyVars and tcdTyPats]
......
......@@ -1370,7 +1370,7 @@ instance Binary IfaceDecl where
put_ _ (IfaceForeign _ _) =
error "Binary.put_(IfaceDecl): IfaceForeign"
put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
putByte bh 2
put_ bh (occNameFS a1)
put_ bh a2
......@@ -1379,13 +1379,15 @@ instance Binary IfaceDecl where
put_ bh a5
put_ bh a6
put_ bh a7
put_ bh a8
put_ bh (IfaceSyn a1 a2 a3 a4) = do
put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
putByte bh 3
put_ bh (occNameFS a1)
put_ bh a2
put_ bh a3
put_ bh a4
put_ bh a5
put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
putByte bh 4
......@@ -1421,14 +1423,16 @@ instance Binary IfaceDecl where
a5 <- get bh
a6 <- get bh
a7 <- get bh
a8 <- get bh
occ <- return $! mkOccNameFS tcName a1
return (IfaceData occ a2 a3 a4 a5 a6 a7)
return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
3 -> do a1 <- get bh
a2 <- get bh
a3 <- get bh
a4 <- get bh
a5 <- get bh
occ <- return $! mkOccNameFS tcName a1
return (IfaceSyn occ a2 a3 a4)
return (IfaceSyn occ a2 a3 a4 a5)
4 -> do a1 <- get bh
a2 <- get bh
a3 <- get bh
......
......@@ -29,6 +29,7 @@ import DataCon
import Var
import VarSet
import BasicTypes
import ForeignCall
import Name
import MkId
import Class
......@@ -45,17 +46,19 @@ import Outputable
\begin{code}
------------------------------------------------------
buildSynTyCon :: Name -> [TyVar]
-> Maybe CType
-> SynTyConRhs
-> Kind -- ^ Kind of the RHS
-> TyConParent
-> TcRnIf m n TyCon
buildSynTyCon tc_name tvs rhs rhs_kind parent
= return (mkSynTyCon tc_name kind tvs rhs parent)
buildSynTyCon tc_name tvs cType rhs rhs_kind parent
= return (mkSynTyCon tc_name kind tvs cType rhs parent)
where kind = mkPiKinds tvs rhs_kind
------------------------------------------------------
buildAlgTyCon :: Name
-> [TyVar] -- ^ Kind variables and type variables
-> Maybe CType
-> ThetaType -- ^ Stupid theta
-> AlgTyConRhs
-> RecFlag
......@@ -63,8 +66,8 @@ buildAlgTyCon :: Name
-> TyConParent
-> TyCon
buildAlgTyCon tc_name ktvs stupid_theta rhs is_rec gadt_syn parent
= mkAlgTyCon tc_name kind ktvs stupid_theta rhs parent is_rec gadt_syn
buildAlgTyCon tc_name ktvs cType stupid_theta rhs is_rec gadt_syn parent
= mkAlgTyCon tc_name kind ktvs cType stupid_theta rhs parent is_rec gadt_syn
where
kind = mkPiKinds ktvs liftedTypeKind
......
......@@ -68,6 +68,7 @@ data IfaceDecl
ifIdInfo :: IfaceIdInfo }
| IfaceData { ifName :: OccName, -- Type constructor
ifCType :: Maybe CType, -- C type for CAPI FFI
ifTyVars :: [IfaceTvBndr], -- Type variables
ifCtxt :: IfaceContext, -- The "stupid theta"
ifCons :: IfaceConDecls, -- Includes new/data/data family info
......@@ -79,6 +80,7 @@ data IfaceDecl
}
| IfaceSyn { ifName :: OccName, -- Type constructor
ifCType :: Maybe CType, -- C type for CAPI FFI
ifTyVars :: [IfaceTvBndr], -- Type variables
ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon)
ifSynRhs :: Maybe IfaceType -- Just rhs for an ordinary synonyn
......
......@@ -1432,12 +1432,14 @@ tyThingToIfaceDecl (ATyCon tycon)
| isSynTyCon tycon
= IfaceSyn { ifName = getOccName tycon,
ifCType = tyConCType tycon,
ifTyVars = toIfaceTvBndrs tyvars,
ifSynRhs = syn_rhs,
ifSynKind = syn_ki }
| isAlgTyCon tycon
= IfaceData { ifName = getOccName tycon,
ifCType = tyConCType tycon,
ifTyVars = toIfaceTvBndrs tyvars,
ifCtxt = toIfaceContext (tyConStupidTheta tycon),
ifCons = ifaceConDecls (algTyConRhs tycon),
......
......@@ -432,6 +432,7 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type,
; return (AnId (mkGlobalId details name ty info)) }
tc_iface_decl parent _ (IfaceData {ifName = occ_name,
ifCType = cType,
ifTyVars = tv_bndrs,
ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
......@@ -443,7 +444,7 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
{ stupid_theta <- tcIfaceCtxt ctxt
; parent' <- tc_parent tyvars mb_axiom_name
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; return (buildAlgTyCon tc_name tyvars stupid_theta
; return (buildAlgTyCon tc_name tyvars cType stupid_theta
cons is_rec gadt_syn parent') }
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon) }
......@@ -462,6 +463,7 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
; return (FamInstTyCon ax fam_tc (substTys subst fam_tys)) }
tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
ifCType = cType,
ifSynRhs = mb_rhs_ty,
ifSynKind = kind })
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
......@@ -469,7 +471,7 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
; rhs_kind <- tcIfaceType kind -- Note [Synonym kind loop]
; rhs <- forkM (mk_doc tc_name) $
tc_syn_rhs mb_rhs_ty
; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind parent
; tycon <- buildSynTyCon tc_name tyvars cType rhs rhs_kind parent
; return (ATyCon tycon) }
where
mk_doc n = ptext (sLit "Type syonym") <+> ppr n
......
......@@ -487,6 +487,7 @@ data Token
| ITvect_prag
| ITvect_scalar_prag
| ITnovect_prag
| ITctype
| ITdotdot -- reserved symbols
| ITcolon
......@@ -2287,7 +2288,8 @@ oneWordPrags = Map.fromList([("rules", rulePrag),
("nounpack", token ITnounpack_prag),
("ann", token ITann_prag),
("vectorize", token ITvect_prag),
("novectorize", token ITnovect_prag)])
("novectorize", token ITnovect_prag),
("ctype", token ITctype)])
twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)),
("notinline conlike", token (ITinline_prag NoInline ConLike)),
......
......@@ -38,9 +38,7 @@ import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataC
unboxedUnitTyCon, unboxedUnitDataCon,
listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR )
import Type ( funTyCon )
import ForeignCall ( Safety(..), CExportSpec(..), CLabelString,
CCallConv(..), CCallTarget(..), defaultCCallConv
)
import ForeignCall
import OccName ( varName, dataName, tcClsName, tvName )
import DataCon ( DataCon, dataConName )
import SrcLoc
......@@ -269,6 +267,7 @@ incorrect.
'{-# VECTORISE' { L _ ITvect_prag }
'{-# VECTORISE_SCALAR' { L _ ITvect_scalar_prag }
'{-# NOVECTORISE' { L _ ITnovect_prag }
'{-# CTYPE' { L _ ITctype }
'#-}' { L _ ITclose_prag }
'..' { L _ ITdotdot } -- reserved symbols
......@@ -610,7 +609,7 @@ cl_decl :: { LTyClDecl RdrName }
--
ty_decl :: { LTyClDecl RdrName }
-- ordinary type synonyms
: 'type' type '=' ctypedoc
: 'type' capi_ctype type '=' ctypedoc
-- Note ctype, not sigtype, on the right of '='
-- We allow an explicit for-all but we don't insert one
-- in type Foo a = (b,b)
......@@ -618,7 +617,7 @@ ty_decl :: { LTyClDecl RdrName }
--
-- Note the use of type for the head; this allows
-- infix type constructors to be declared
{% mkTySynonym (comb2 $1 $4) False $2 $4 }
{% mkTySynonym (comb2 $1 $5) False $2 $3 $5 }
-- type family declarations
| 'type' 'family' type opt_kind_sig
......@@ -627,18 +626,18 @@ ty_decl :: { LTyClDecl RdrName }
{% mkTyFamily (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4) }
-- ordinary data type or newtype declaration
| data_or_newtype tycl_hdr constrs deriving
{% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) False $2
Nothing (reverse (unLoc $3)) (unLoc $4) }
| data_or_newtype capi_ctype tycl_hdr constrs deriving
{% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) False $2 $3
Nothing (reverse (unLoc $4)) (unLoc $5) }
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
-- ordinary GADT declaration
| data_or_newtype tycl_hdr opt_kind_sig
| data_or_newtype capi_ctype tycl_hdr opt_kind_sig
gadt_constrlist
deriving
{% mkTyData (comb4 $1 $2 $4 $5) (unLoc $1) False $2
(unLoc $3) (unLoc $4) (unLoc $5) }
{% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) False $2 $3
(unLoc $4) (unLoc $5) (unLoc $6) }
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
......@@ -652,15 +651,15 @@ inst_decl :: { LInstDecl RdrName }
in L (comb3 $1 $2 $3) (ClsInstDecl $2 binds sigs ats) }
-- type instance declarations
| 'type' 'instance' type '=' ctype
| 'type' 'instance' capi_ctype type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
{% do { L loc d <- mkTySynonym (comb2 $1 $5) True $3 $5
{% do { L loc d <- mkTySynonym (comb2 $1 $6) True $3 $4 $6
; return (L loc (FamInstDecl d)) } }
-- data/newtype instance declaration
| data_or_newtype 'instance' tycl_hdr constrs deriving
{% do { L loc d <- mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $3
{% do { L loc d <- mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True Nothing $3
Nothing (reverse (unLoc $4)) (unLoc $5)
; return (L loc (FamInstDecl d)) } }
......@@ -668,7 +667,7 @@ inst_decl :: { LInstDecl RdrName }
| data_or_newtype 'instance' tycl_hdr opt_kind_sig
gadt_constrlist
deriving
{% do { L loc d <- mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $3
{% do { L loc d <- mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True Nothing $3
(unLoc $4) (unLoc $5) (unLoc $6)
; return (L loc (FamInstDecl d)) } }
......@@ -689,10 +688,10 @@ at_decl_cls :: { LTyClDecl RdrName }
{% mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3) }
-- default type instance
| 'type' type '=' ctype
| 'type' capi_ctype type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
{% mkTySynonym (comb2 $1 $4) True $2 $4 }
{% mkTySynonym (comb2 $1 $5) True $2 $3 $5 }
-- data/newtype family declaration
| 'data' type opt_kind_sig
......@@ -702,22 +701,22 @@ at_decl_cls :: { LTyClDecl RdrName }
--
at_decl_inst :: { LTyClDecl RdrName }
-- type instance declarations
: 'type' type '=' ctype
: 'type' capi_ctype type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
{% mkTySynonym (comb2 $1 $4) True $2 $4 }
{% mkTySynonym (comb2 $1 $5) True $2 $3 $5 }
-- data/newtype instance declaration
| data_or_newtype tycl_hdr constrs deriving
{% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) True $2
Nothing (reverse (unLoc $3)) (unLoc $4) }
| data_or_newtype capi_ctype tycl_hdr constrs deriving
{% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $2 $3
Nothing (reverse (unLoc $4)) (unLoc $5) }
-- GADT instance declaration
| data_or_newtype tycl_hdr opt_kind_sig
| data_or_newtype capi_ctype tycl_hdr opt_kind_sig
gadt_constrlist
deriving
{% mkTyData (comb4 $1 $2 $4 $5) (unLoc $1) True $2
(unLoc $3) (unLoc $4) (unLoc $5) }
{% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $2 $3
(unLoc $4) (unLoc $5) (unLoc $6) }
data_or_newtype :: { Located NewOrData }
: 'data' { L1 DataType }
......@@ -738,6 +737,10 @@ tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }
: context '=>' type { LL (Just $1, $3) }
| type { L1 (Nothing, $1) }
capi_ctype :: { Maybe CType }
capi_ctype : '{-# CTYPE' STRING '#-}' { Just (CType (getSTRING $2)) }
| { Nothing }
-----------------------------------------------------------------------------
-- Stand-alone deriving
......
......@@ -192,31 +192,34 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
mkTyData :: SrcSpan
-> NewOrData
-> Bool -- True <=> data family instance
-> Maybe CType
-> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-> Maybe (LHsKind RdrName)
-> [LConDecl RdrName]
-> Maybe [LHsType RdrName]
-> P (LTyClDecl RdrName)
mkTyData loc new_or_data is_family (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
mkTyData loc new_or_data is_family cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
= do { (tc, tparams) <- checkTyClHdr tycl_hdr
; checkDatatypeContext mcxt
; let cxt = fromMaybe (noLoc []) mcxt
; (tyvars, typats) <- checkTParams is_family tycl_hdr tparams
; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
; return (L loc (TyData { tcdND = new_or_data, tcdCType = cType,
tcdCtxt = cxt, tcdLName = tc,
tcdTyVars = tyvars, tcdTyPats = typats,
tcdCons = data_cons,
tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
mkTySynonym :: SrcSpan
-> Bool -- True <=> type family instances
-> Maybe CType
-> LHsType RdrName -- LHS
-> LHsType RdrName -- RHS
-> P (LTyClDecl RdrName)
mkTySynonym loc is_family lhs rhs
mkTySynonym loc is_family cType lhs rhs
= do { (tc, tparams) <- checkTyClHdr lhs
; (tyvars, typats) <- checkTParams is_family lhs tparams
; return (L loc (TySynonym tc tyvars typats rhs)) }
; return (L loc (TySynonym tc cType tyvars typats rhs)) }
mkTyFamily :: SrcSpan
-> FamilyFlavour
......
......@@ -14,6 +14,8 @@ module ForeignCall (
CCallSpec(..),
CCallTarget(..), isDynamicTarget,
CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
CType(..),
) where
import FastString
......@@ -227,6 +229,12 @@ instance Outputable CCallSpec where
= text "__dyn_ccall" <> gc_suf <+> text "\"\""
\end{code}
\begin{code}
-- | A C type, used in CAPI FFI calls
newtype CType = CType FastString
deriving (Data, Typeable)
\end{code}
%************************************************************************
%* *
......@@ -308,4 +316,9 @@ instance Binary CCallConv where
2 -> do return PrimCallConv
3 -> do return CmmCallConv
_ -> do return CApiConv
instance Binary CType where
put_ bh (CType fs) = put_ bh fs
get bh = do fs <- get bh
return (CType fs)
\end{code}
......@@ -241,6 +241,7 @@ pcTyCon is_enum is_rec name tyvars cons
tycon = mkAlgTyCon name
(mkArrowKinds (map tyVarKind tyvars) liftedTypeKind)
tyvars
Nothing
[] -- No stupid theta
(DataTyCon cons is_enum)
NoParentTyCon
......@@ -406,6 +407,7 @@ mkIPName ip tycon_u datacon_u dc_wrk_u co_ax_u = name_ip
tycon = mkAlgTyCon tycon_name
(liftedTypeKind `mkArrowKind` constraintKind)
[alphaTyVar]
Nothing
[] -- No stupid theta
(NewTyCon { data_con = datacon,
nt_rhs = mkTyVarTy alphaTyVar,
......@@ -432,6 +434,7 @@ eqTyCon :: TyCon
eqTyCon = mkAlgTyCon eqTyConName
(ForAllTy kv $ mkArrowKinds [k, k] constraintKind)
[kv, a, b]
Nothing
[] -- No stupid theta
(DataTyCon [eqBoxDataCon] False)
NoParentTyCon
......
......@@ -799,7 +799,8 @@ rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars
-- "data", "newtype", "data instance, and "newtype instance" declarations
-- both top level and (for an associated type) in an instance decl
rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCType = cType,
tcdCtxt = context,
tcdLName = tycon, tcdTyVars = tyvars,
tcdTyPats = typats, tcdCons = condecls,
tcdKindSig = sig, tcdDerivs = derivs}
......@@ -831,7 +832,8 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
-- No need to check for duplicate constructor decls
-- since that is done by RnNames.extendGlobalRdrEnvRn
; return (TyData {tcdND = new_or_data, tcdCtxt = context',
; return (TyData {tcdND = new_or_data, tcdCType = cType,
tcdCtxt = context',
tcdLName = tycon', tcdTyVars = tyvars',
tcdTyPats = typats', tcdKindSig = sig',
tcdCons = condecls', tcdDerivs = derivs'},
......@@ -849,14 +851,16 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
; return (Just ds', extractHsTyNames_s ds') }
-- "type" and "type instance" declarations
rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdLName = name,
rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdCType = cType,
tcdLName = name,
tcdTyPats = typats, tcdSynRhs = ty})
= bindQTvs syn_doc mb_cls tyvars $ \ tyvars' -> do
{ -- Checks for distinct tyvars
name' <- lookupTcdName mb_cls tydecl
; (typats',fvs1) <- rnTyPats syn_doc name' typats
; (ty', fvs2) <- rnHsTypeFVs syn_doc ty
; return (TySynonym { tcdLName = name', tcdTyVars = tyvars'
; return (TySynonym { tcdLName = name', tcdCType = cType
, tcdTyVars = tyvars'
, tcdTyPats = typats', tcdSynRhs = ty'}
, extractHsTyVarBndrNames_s tyvars' (fvs1 `plusFV` fvs2)) }
where
......
......@@ -99,7 +99,7 @@ genGenericRepExtras tc mod =
| (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ]
mkTyCon name = ASSERT( isExternalName name )
buildAlgTyCon name [] [] distinctAbstractTyConRhs
buildAlgTyCon name [] Nothing [] distinctAbstractTyConRhs
NonRecursive False NoParentTyCon
let metaDTyCon = mkTyCon d_name
......
......@@ -558,7 +558,8 @@ tcFamInstDecl1 fam_tc (decl@TySynonym {})
; return (mkSynFamInst rep_tc_name t_tvs fam_tc t_typats t_rhs) }
-- "newtype instance" and "data instance"
tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCtxt = ctxt
tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCType = cType
, tcdCtxt = ctxt
, tcdTyVars = tvs, tcdTyPats = Just pats
, tcdCons = cons})
= do { -- Check that the family declaration is for the right kind
......@@ -595,7 +596,7 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCtxt = ctxt
mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons)
; let fam_inst = mkDataFamInst axiom_name tvs' fam_tc pats' rep_tc
parent = FamInstTyCon (famInstAxiom fam_inst) fam_tc pats'
rep_tc = buildAlgTyCon rep_tc_name tvs' stupid_theta tc_rhs
rep_tc = buildAlgTyCon rep_tc_name tvs' cType stupid_theta tc_rhs
Recursive h98_syntax parent
-- We always assume that indexed types are recursive. Why?
-- (1) Due to their open nature, we can never be sure that a
......
......@@ -555,7 +555,7 @@ tcTyClDecl1 parent _calc_isrec
= tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
{ traceTc "type family:" (ppr tc_name)
; checkFamFlag tc_name
; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent
; tycon <- buildSynTyCon tc_name tvs' Nothing SynFamilyTyCon kind parent
; return [ATyCon tycon] }
-- "data family" declaration
......@@ -566,24 +566,25 @@ tcTyClDecl1 parent _calc_isrec
; checkFamFlag tc_name
; extra_tvs <- tcDataKindSig kind
; let final_tvs = tvs' ++ extra_tvs -- we may not need these
tycon = buildAlgTyCon tc_name final_tvs []
tycon = buildAlgTyCon tc_name final_tvs Nothing []
DataFamilyTyCon Recursive True parent
; return [ATyCon tycon] }
-- "type" synonym declaration
tcTyClDecl1 _parent _calc_isrec
(TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
(TySynonym {tcdLName = L _ tc_name, tcdCType = cType, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
= ASSERT( isNoParent _parent )
tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
{ rhs_ty' <- tcCheckHsType rhs_ty kind
; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty')
; tycon <- buildSynTyCon tc_name tvs' cType (SynonymTyCon rhs_ty')
kind NoParentTyCon
; return [ATyCon tycon] }
-- "newtype" and "data"
-- NB: not used for newtype/data instances (whether associated or not)
tcTyClDecl1 _parent calc_isrec
(TyData { tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs
(TyData { tcdND = new_or_data, tcdCType = cType
, tcdCtxt = ctxt, tcdTyVars = tvs
, tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons })
= ASSERT( isNoParent _parent )
let is_rec = calc_isrec tc_name
......@@ -613,7 +614,7 @@ tcTyClDecl1 _parent calc_isrec
DataType -> return (mkDataTyConRhs data_cons)
NewType -> ASSERT( not (null data_cons) )
mkNewTyConRhs tc_name tycon (head data_cons)
; return (buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs
; return (buildAlgTyCon tc_name final_tvs cType stupid_theta tc_rhs
is_rec (not h98_syntax) NoParentTyCon) }
; return [ATyCon tycon] }
......
......@@ -60,6 +60,7 @@ module TyCon(
tyConKind,
tyConUnique,
tyConTyVars,
tyConCType, tyConCType_maybe,
tyConDataCons, tyConDataCons_maybe, tyConSingleDataCon_maybe,
tyConFamilySize,
tyConStupidTheta,
......@@ -93,6 +94,7 @@ import {-# SOURCE #-} IParam ( ipTyConName )
import Var
import Class
import BasicTypes
import ForeignCall
import Name
import PrelNames
import Maybes
......@@ -310,6 +312,9 @@ data TyCon
-- 3. The family instance types if present
--
-- Note that it does /not/ scope over the data constructors.
tyConCType :: Maybe CType, -- The C type that should be used
-- for this type when using the FFI
-- and CAPI
algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT syntax?
-- If so, that doesn't mean it's a true GADT;
......@@ -355,6 +360,9 @@ data TyCon
tyConArity :: Arity,
tyConTyVars :: [TyVar], -- Bound tyvars
tyConCType :: Maybe CType, -- The C type that should be used
-- for this type when using the FFI
-- and CAPI
synTcRhs :: SynTyConRhs, -- ^ Contains information about the
-- expansion of the synonym
......@@ -838,19 +846,22 @@ mkAlgTyCon :: Name
-> Kind -- ^ Kind of the resulting 'TyCon'
-> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'.
-- Arity is inferred from the length of this list
-> Maybe CType -- ^ The C type this type corresponds to
-- when using the CAPI FFI
-> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta'
-> AlgTyConRhs -- ^ Information about dat aconstructors
-> TyConParent
-> RecFlag -- ^ Is the 'TyCon' recursive?
-> Bool -- ^ Was the 'TyCon' declared with GADT syntax?
-> TyCon
mkAlgTyCon name kind tyvars stupid rhs parent is_rec gadt_syn
mkAlgTyCon name kind tyvars cType stupid rhs parent is_rec gadt_syn
= AlgTyCon {
tyConName = name,
tyConUnique = nameUnique name,
tc_kind = kind,
tyConArity = length tyvars,
tyConTyVars = tyvars,
tyConCType = cType,
algTcStupidTheta = stupid,
algTcRhs = rhs,
algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent,
......@@ -861,12 +872,12 @@ mkAlgTyCon name kind tyvars stupid rhs parent is_rec gadt_syn
-- | Simpler specialization of 'mkAlgTyCon' for classes
mkClassTyCon :: Name -> Kind -> [TyVar] -> AlgTyConRhs -> Class -> RecFlag -> TyCon
mkClassTyCon name kind tyvars rhs clas is_rec =
mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False
mkAlgTyCon name kind tyvars Nothing [] rhs (ClassTyCon clas) is_rec False
-- | Simpler specialization of 'mkAlgTyCon' for implicit paramaters
mkIParamTyCon :: Name -> Kind -> TyVar -> AlgTyConRhs -> RecFlag -> TyCon
mkIParamTyCon name kind tyvar rhs is_rec =
mkAlgTyCon name kind [tyvar] [] rhs NoParentTyCon is_rec False
mkAlgTyCon name kind [tyvar] Nothing [] rhs NoParentTyCon is_rec False
mkTupleTyCon :: Name
-> Kind -- ^ Kind of the resulting 'TyCon'
......@@ -935,14 +946,15 @@ mkPrimTyCon' name kind arity rep is_unlifted
}
-- | Create a type synonym 'TyCon'
mkSynTyCon :: Name -> Kind -> [TyVar] -> SynTyConRhs -> TyConParent -> TyCon
mkSynTyCon name kind tyvars rhs parent
mkSynTyCon :: Name -> Kind -> [TyVar] -> Maybe CType -> SynTyConRhs -> TyConParent -> TyCon
mkSynTyCon name kind tyvars cType rhs parent
= SynTyCon {