{-# 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

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]) ->
        Bool -> Type -> Type
forall a. HasCallStack => Bool -> a -> a
assert (DataCon -> Arity
dataConSourceArity DataCon
data_con Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
1) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
        Bool -> SDoc -> Type -> Type
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
prim_ty) (Type -> SDoc
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 -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getPrimTyOf" (Type -> SDoc
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 HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
unitTy = Char
'v'
 | Bool
otherwise
 = case HasDebugCallStack => Type -> PrimRep
Type -> PrimRep
typePrimRepU (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
_           -> String -> SDoc -> Char
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"primTyDescChar" (Type -> SDoc
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 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
charPrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"StgChar"
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
intPrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"StgInt"
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
int8PrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"StgInt8"
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
int16PrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"StgInt16"
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
int32PrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"StgInt32"
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
int64PrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"StgInt64"
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
wordPrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"StgWord"
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
word8PrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"StgWord8"
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
word16PrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"StgWord16"
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
word32PrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"StgWord32"
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
word64PrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"StgWord64"
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
floatPrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"StgFloat"
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
doublePrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"StgDouble"
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
addrPrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"StgAddr"
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
stablePtrPrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"StgStablePtr"
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
arrayPrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"const StgAddr"
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableArrayPrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"StgAddr"
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
byteArrayPrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"const StgAddr"
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableByteArrayPrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"StgAddr"
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
smallArrayPrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"const StgAddr"
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
smallMutableArrayPrimTyCon -> String -> Maybe String
forall a. a -> Maybe a
Just String
"StgAddr"
     | Bool
otherwise -> Maybe String
forall a. Maybe a
Nothing