content: {-# 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 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 typePrimRepU (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
  