{-# 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 :: Type -> Type
getPrimTyOf Type
ty
  | Type -> Bool
isBoolTy Type
rep_ty = Type
intPrimTy
  -- Except for Bool, the types we are interested in have a single constructor
  -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
  | Bool
otherwise =
  case Type -> Maybe (TyCon, [Type], DataCon, [Scaled Type])
splitDataProductType_maybe Type
rep_ty of
     Just (TyCon
_, [Type]
_, DataCon
data_con, [Scaled Type
_ Type
prim_ty]) ->
        forall a. HasCallStack => Bool -> a -> a
assert (DataCon -> Arity
dataConSourceArity DataCon
data_con forall a. Eq a => a -> a -> Bool
== Arity
1) forall a b. (a -> b) -> a -> b
$
        forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (HasDebugCallStack => Type -> Bool
isUnliftedType Type
prim_ty) (forall a. Outputable a => a -> SDoc
ppr Type
prim_ty)
          -- NB: it's OK to call isUnliftedType here, as we don't allow
          -- representation-polymorphic types in foreign import/export declarations
        Type
prim_ty
     Maybe (TyCon, [Type], DataCon, [Scaled Type])
_other -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getPrimTyOf" (forall a. Outputable a => a -> SDoc
ppr Type
ty)
  where
        rep_ty :: Type
rep_ty = Type -> Type
unwrapType Type
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 -> Type -> Char
primTyDescChar !Platform
platform Type
ty
 | Type
ty Type -> Type -> Bool
`eqType` Type
unitTy = Char
'v'
 | Bool
otherwise
 = case HasDebugCallStack => Type -> PrimRep
typePrimRep1 (Type -> Type
getPrimTyOf Type
ty) of
     PrimRep
IntRep      -> Char
signed_word
     PrimRep
WordRep     -> Char
unsigned_word
     PrimRep
Int8Rep     -> Char
'B'
     PrimRep
Word8Rep    -> Char
'b'
     PrimRep
Int16Rep    -> Char
'S'
     PrimRep
Word16Rep   -> Char
's'
     PrimRep
Int32Rep    -> Char
'W'
     PrimRep
Word32Rep   -> Char
'w'
     PrimRep
Int64Rep    -> Char
'L'
     PrimRep
Word64Rep   -> Char
'l'
     PrimRep
AddrRep     -> Char
'p'
     PrimRep
FloatRep    -> Char
'f'
     PrimRep
DoubleRep   -> Char
'd'
     PrimRep
_           -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"primTyDescChar" (forall a. Outputable a => a -> SDoc
ppr Type
ty)
  where
    (Char
signed_word, Char
unsigned_word) = case Platform -> PlatformWordSize
platformWordSize Platform
platform of
      PlatformWordSize
PW4 -> (Char
'W',Char
'w')
      PlatformWordSize
PW8 -> (Char
'L',Char
'l')

-- | Printed C Type to be used with CAPI calling convention
ppPrimTyConStgType :: TyCon -> Maybe String
ppPrimTyConStgType :: TyCon -> Maybe String
ppPrimTyConStgType TyCon
tc =
  if | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
charPrimTyCon -> forall a. a -> Maybe a
Just String
"StgChar"
     | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
intPrimTyCon -> forall a. a -> Maybe a
Just String
"StgInt"
     | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
int8PrimTyCon -> forall a. a -> Maybe a
Just String
"StgInt8"
     | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
int16PrimTyCon -> forall a. a -> Maybe a
Just String
"StgInt16"
     | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
int32PrimTyCon -> forall a. a -> Maybe a
Just String
"StgInt32"
     | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
int64PrimTyCon -> forall a. a -> Maybe a
Just String
"StgInt64"
     | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
wordPrimTyCon -> forall a. a -> Maybe a
Just String
"StgWord"
     | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
word8PrimTyCon -> forall a. a -> Maybe a
Just String
"StgWord8"
     | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
word16PrimTyCon -> forall a. a -> Maybe a
Just String
"StgWord16"
     | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
word32PrimTyCon -> forall a. a -> Maybe a
Just String
"StgWord32"
     | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
word64PrimTyCon -> forall a. a -> Maybe a
Just String
"StgWord64"
     | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
floatPrimTyCon -> forall a. a -> Maybe a
Just String
"StgFloat"
     | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
doublePrimTyCon -> forall a. a -> Maybe a
Just String
"StgDouble"
     | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
addrPrimTyCon -> forall a. a -> Maybe a
Just String
"StgAddr"
     | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
stablePtrPrimTyCon -> forall a. a -> Maybe a
Just String
"StgStablePtr"
     | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
arrayPrimTyCon -> forall a. a -> Maybe a
Just String
"const StgAddr"
     | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
mutableArrayPrimTyCon -> forall a. a -> Maybe a
Just String
"StgAddr"
     | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
byteArrayPrimTyCon -> forall a. a -> Maybe a
Just String
"const StgAddr"
     | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
mutableByteArrayPrimTyCon -> forall a. a -> Maybe a
Just String
"StgAddr"
     | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
smallArrayPrimTyCon -> forall a. a -> Maybe a
Just String
"const StgAddr"
     | TyCon
tc forall a. Eq a => a -> a -> Bool
== TyCon
smallMutableArrayPrimTyCon -> forall a. a -> Maybe a
Just String
"StgAddr"
     | Bool
otherwise -> forall a. Maybe a
Nothing