{-# 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]) ->
        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 ((() :: Constraint) => 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 Type -> Type -> Bool
`eqType` Type
unitTy = Char
'v'
 | Bool
otherwise
 = case (() :: Constraint) => Type -> PrimRep
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
_           -> 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