1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
|
{-# LANGUAGE MultiWayIf #-}
module GHC.HsToCore.Foreign.Utils
( Binding
, getPrimTyOf
, primTyDescChar
, ppPrimTyConStgType
)
where
import GHC.Prelude
import GHC.Platform
import GHC.Tc.Utils.TcType
import GHC.Core (CoreExpr)
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Types.Id
import GHC.Types.RepType
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
-- the occurrence analyser will sort it all out
-- This function returns the primitive type associated with the boxed
-- type argument to a foreign export (eg. Int ==> Int#).
getPrimTyOf :: Type -> UnaryType
getPrimTyOf ty
| isBoolTy rep_ty = intPrimTy
-- Except for Bool, the types we are interested in have a single constructor
-- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
| otherwise =
case splitDataProductType_maybe rep_ty of
Just (_, _, data_con, [Scaled _ prim_ty]) ->
assert (dataConSourceArity data_con == 1) $
assertPpr (isUnliftedType prim_ty) (ppr prim_ty)
-- NB: it's OK to call isUnliftedType here, as we don't allow
-- representation-polymorphic types in foreign import/export declarations
prim_ty
_other -> pprPanic "getPrimTyOf" (ppr ty)
where
rep_ty = unwrapType ty
-- represent a primitive type as a Char, for building a string that
-- described the foreign function type. The types are size-dependent,
-- e.g. 'W' is a signed 32-bit integer.
primTyDescChar :: Platform -> Type -> Char
primTyDescChar !platform ty
| ty `eqType` unitTy = 'v'
| otherwise
= case typePrimRep1 (getPrimTyOf ty) of
IntRep -> signed_word
WordRep -> unsigned_word
Int8Rep -> 'B'
Word8Rep -> 'b'
Int16Rep -> 'S'
Word16Rep -> 's'
Int32Rep -> 'W'
Word32Rep -> 'w'
Int64Rep -> 'L'
Word64Rep -> 'l'
AddrRep -> 'p'
FloatRep -> 'f'
DoubleRep -> 'd'
_ -> pprPanic "primTyDescChar" (ppr ty)
where
(signed_word, unsigned_word) = case platformWordSize platform of
PW4 -> ('W','w')
PW8 -> ('L','l')
-- | Printed C Type to be used with CAPI calling convention
ppPrimTyConStgType :: TyCon -> Maybe String
ppPrimTyConStgType tc =
if | tc == charPrimTyCon -> Just "StgChar"
| tc == intPrimTyCon -> Just "StgInt"
| tc == int8PrimTyCon -> Just "StgInt8"
| tc == int16PrimTyCon -> Just "StgInt16"
| tc == int32PrimTyCon -> Just "StgInt32"
| tc == int64PrimTyCon -> Just "StgInt64"
| tc == wordPrimTyCon -> Just "StgWord"
| tc == word8PrimTyCon -> Just "StgWord8"
| tc == word16PrimTyCon -> Just "StgWord16"
| tc == word32PrimTyCon -> Just "StgWord32"
| tc == word64PrimTyCon -> Just "StgWord64"
| tc == floatPrimTyCon -> Just "StgFloat"
| tc == doublePrimTyCon -> Just "StgDouble"
| tc == addrPrimTyCon -> Just "StgAddr"
| tc == stablePtrPrimTyCon -> Just "StgStablePtr"
| tc == arrayPrimTyCon -> Just "const StgAddr"
| tc == mutableArrayPrimTyCon -> Just "StgAddr"
| tc == byteArrayPrimTyCon -> Just "const StgAddr"
| tc == mutableByteArrayPrimTyCon -> Just "StgAddr"
| tc == smallArrayPrimTyCon -> Just "const StgAddr"
| tc == smallMutableArrayPrimTyCon -> Just "StgAddr"
| otherwise -> Nothing
|
