{-# LANGUAGE FlexibleContexts #-}

module GHC.Types.RepType
  (
    -- * Code generator views onto Types
    UnaryType, NvUnaryType, isNvUnaryType,
    unwrapType,

    -- * Predicates on types
    isZeroBitTy,

    -- * Type representation for the code generator
    typePrimRep, typePrimRep1,
    runtimeRepPrimRep, typePrimRepArgs,
    PrimRep(..), primRepToRuntimeRep, primRepToType,
    countFunRepArgs, countConRepArgs, dataConRuntimeRepStrictness,
    tyConPrimRep, tyConPrimRep1,
    runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe,

    -- * Unboxed sum representation type
    ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..),
    slotPrimRep, primRepSlot,

    -- * Is this type known to be data?
    mightBeFunTy

    ) where

import GHC.Prelude

import GHC.Types.Basic (Arity, RepArity)
import GHC.Core.DataCon
import GHC.Core.Coercion
import GHC.Core.TyCon
import GHC.Core.TyCon.RecWalk
import GHC.Core.TyCo.Rep
import GHC.Core.Type
import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind
  , vecRepDataConTyCon
  , liftedRepTy, unliftedRepTy, zeroBitRepTy
  , intRepDataConTy
  , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy
  , wordRepDataConTy
  , word16RepDataConTy, word8RepDataConTy, word32RepDataConTy, word64RepDataConTy
  , addrRepDataConTy
  , floatRepDataConTy, doubleRepDataConTy
  , vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy
  , vec64DataConTy
  , int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy
  , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy
  , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy
  , doubleElemRepDataConTy )

import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic

import Data.List.NonEmpty (NonEmpty (..))
import Data.List (sort)
import qualified Data.IntSet as IS

{- **********************************************************************
*                                                                       *
                Representation types
*                                                                       *
********************************************************************** -}

type NvUnaryType = Type
type UnaryType   = Type
     -- Both are always a value type; i.e. its kind is TYPE rr
     -- for some rr; moreover the rr is never a variable.
     --
     --   NvUnaryType : never an unboxed tuple or sum, or void
     --
     --   UnaryType   : never an unboxed tuple or sum;
     --                 can be Void# or (# #)

isNvUnaryType :: Type -> Bool
isNvUnaryType :: UnaryType -> Bool
isNvUnaryType UnaryType
ty
  | [PrimRep
_] <- HasDebugCallStack => UnaryType -> [PrimRep]
UnaryType -> [PrimRep]
typePrimRep UnaryType
ty
  = Bool
True
  | Bool
otherwise
  = Bool
False

-- INVARIANT: the result list is never empty.
typePrimRepArgs :: HasDebugCallStack => Type -> NonEmpty PrimRep
typePrimRepArgs :: HasDebugCallStack => UnaryType -> NonEmpty PrimRep
typePrimRepArgs UnaryType
ty
  = case [PrimRep]
reps of
      [] -> PrimRep
VoidRep PrimRep -> [PrimRep] -> NonEmpty PrimRep
forall a. a -> [a] -> NonEmpty a
:| []
      (PrimRep
x:[PrimRep]
xs) ->   PrimRep
x PrimRep -> [PrimRep] -> NonEmpty PrimRep
forall a. a -> [a] -> NonEmpty a
:| [PrimRep]
xs
  where
    reps :: [PrimRep]
reps = HasDebugCallStack => UnaryType -> [PrimRep]
UnaryType -> [PrimRep]
typePrimRep UnaryType
ty

-- | Gets rid of the stuff that prevents us from understanding the
-- runtime representation of a type. Including:
--   1. Casts
--   2. Newtypes
--   3. Foralls
--   4. Synonyms
-- But not type/data families, because we don't have the envs to hand.
unwrapType :: Type -> Type
unwrapType :: UnaryType -> UnaryType
unwrapType UnaryType
ty
  | Just (()
_, UnaryType
unwrapped)
      <- NormaliseStepper ()
-> (() -> () -> ()) -> UnaryType -> Maybe ((), UnaryType)
forall ev.
NormaliseStepper ev
-> (ev -> ev -> ev) -> UnaryType -> Maybe (ev, UnaryType)
topNormaliseTypeX NormaliseStepper ()
stepper () -> () -> ()
forall a. Monoid a => a -> a -> a
mappend UnaryType
inner_ty
  = UnaryType
unwrapped
  | Bool
otherwise
  = UnaryType
inner_ty
  where
    inner_ty :: UnaryType
inner_ty = UnaryType -> UnaryType
go UnaryType
ty

    go :: UnaryType -> UnaryType
go UnaryType
t | Just UnaryType
t' <- UnaryType -> Maybe UnaryType
coreView UnaryType
t = UnaryType -> UnaryType
go UnaryType
t'
    go (ForAllTy ForAllTyBinder
_ UnaryType
t)            = UnaryType -> UnaryType
go UnaryType
t
    go (CastTy UnaryType
t KindCoercion
_)              = UnaryType -> UnaryType
go UnaryType
t
    go UnaryType
t                         = UnaryType
t

     -- cf. Coercion.unwrapNewTypeStepper
    stepper :: NormaliseStepper ()
stepper RecTcChecker
rec_nts TyCon
tc [UnaryType]
tys
      | Just (UnaryType
ty', KindCoercion
_) <- TyCon -> [UnaryType] -> Maybe (UnaryType, KindCoercion)
instNewTyCon_maybe TyCon
tc [UnaryType]
tys
      = case RecTcChecker -> TyCon -> Maybe RecTcChecker
checkRecTc RecTcChecker
rec_nts TyCon
tc of
          Just RecTcChecker
rec_nts' -> RecTcChecker -> UnaryType -> () -> NormaliseStepResult ()
forall ev.
RecTcChecker -> UnaryType -> ev -> NormaliseStepResult ev
NS_Step RecTcChecker
rec_nts' (UnaryType -> UnaryType
go UnaryType
ty') ()
          Maybe RecTcChecker
Nothing       -> NormaliseStepResult ()
forall ev. NormaliseStepResult ev
NS_Abort   -- infinite newtypes
      | Bool
otherwise
      = NormaliseStepResult ()
forall ev. NormaliseStepResult ev
NS_Done

-- | Count the arity of a function post-unarisation, including zero-width arguments.
--
-- The post-unarisation arity may be larger than the arity of the original
-- function type. See Note [Unarisation].
countFunRepArgs :: Arity -> Type -> RepArity
countFunRepArgs :: Int -> UnaryType -> Int
countFunRepArgs Int
0 UnaryType
_
  = Int
0
countFunRepArgs Int
n UnaryType
ty
  | FunTy FunTyFlag
_ UnaryType
_ UnaryType
arg UnaryType
res <- UnaryType -> UnaryType
unwrapType UnaryType
ty
  = NonEmpty PrimRep -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (HasDebugCallStack => UnaryType -> NonEmpty PrimRep
UnaryType -> NonEmpty PrimRep
typePrimRepArgs UnaryType
arg) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> UnaryType -> Int
countFunRepArgs (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) UnaryType
res
  | Bool
otherwise
  = String -> SDoc -> Int
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"countFunRepArgs: arity greater than type can handle" ((Int, UnaryType, [PrimRep]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int
n, UnaryType
ty, HasDebugCallStack => UnaryType -> [PrimRep]
UnaryType -> [PrimRep]
typePrimRep UnaryType
ty))

countConRepArgs :: DataCon -> RepArity
countConRepArgs :: DataCon -> Int
countConRepArgs DataCon
dc = Int -> UnaryType -> Int
go (DataCon -> Int
dataConRepArity DataCon
dc) (DataCon -> UnaryType
dataConRepType DataCon
dc)
  where
    go :: Arity -> Type -> RepArity
    go :: Int -> UnaryType -> Int
go Int
0 UnaryType
_
      = Int
0
    go Int
n UnaryType
ty
      | FunTy FunTyFlag
_ UnaryType
_ UnaryType
arg UnaryType
res <- UnaryType -> UnaryType
unwrapType UnaryType
ty
      = [PrimRep] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (HasDebugCallStack => UnaryType -> [PrimRep]
UnaryType -> [PrimRep]
typePrimRep UnaryType
arg) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> UnaryType -> Int
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) UnaryType
res
      | Bool
otherwise
      = String -> SDoc -> Int
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"countConRepArgs: arity greater than type can handle" ((Int, UnaryType, [PrimRep]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int
n, UnaryType
ty, HasDebugCallStack => UnaryType -> [PrimRep]
UnaryType -> [PrimRep]
typePrimRep UnaryType
ty))

dataConRuntimeRepStrictness :: HasDebugCallStack => DataCon -> [StrictnessMark]
-- ^ Give the demands on the arguments of a
-- Core constructor application (Con dc args) at runtime.
-- Assumes the constructor is not levity polymorphic. For example
-- unboxed tuples won't work.
dataConRuntimeRepStrictness :: HasDebugCallStack => DataCon -> [StrictnessMark]
dataConRuntimeRepStrictness DataCon
dc =

  -- pprTrace "dataConRuntimeRepStrictness" (ppr dc $$ ppr (dataConRepArgTys dc)) $

  let repMarks :: [StrictnessMark]
repMarks = DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
dc
      repTys :: [UnaryType]
repTys = (Scaled UnaryType -> UnaryType)
-> [Scaled UnaryType] -> [UnaryType]
forall a b. (a -> b) -> [a] -> [b]
map Scaled UnaryType -> UnaryType
forall a. Scaled a -> a
irrelevantMult ([Scaled UnaryType] -> [UnaryType])
-> [Scaled UnaryType] -> [UnaryType]
forall a b. (a -> b) -> a -> b
$ DataCon -> [Scaled UnaryType]
dataConRepArgTys DataCon
dc
  in -- todo: assert dc != unboxedTuple/unboxedSum
     [StrictnessMark]
-> [UnaryType] -> [StrictnessMark] -> [StrictnessMark]
go [StrictnessMark]
repMarks [UnaryType]
repTys []
  where
    go :: [StrictnessMark]
-> [UnaryType] -> [StrictnessMark] -> [StrictnessMark]
go (StrictnessMark
mark:[StrictnessMark]
marks) (UnaryType
ty:[UnaryType]
types) [StrictnessMark]
out_marks
      -- Zero-width argument, mark is irrelevant at runtime.
      |  -- pprTrace "VoidTy" (ppr ty) $
        (HasDebugCallStack => UnaryType -> Bool
UnaryType -> Bool
isZeroBitTy UnaryType
ty)
      = [StrictnessMark]
-> [UnaryType] -> [StrictnessMark] -> [StrictnessMark]
go [StrictnessMark]
marks [UnaryType]
types [StrictnessMark]
out_marks
      -- Single rep argument, e.g. Int
      -- Keep mark as-is
      | [PrimRep
_] <- [PrimRep]
reps
      = [StrictnessMark]
-> [UnaryType] -> [StrictnessMark] -> [StrictnessMark]
go [StrictnessMark]
marks [UnaryType]
types (StrictnessMark
markStrictnessMark -> [StrictnessMark] -> [StrictnessMark]
forall a. a -> [a] -> [a]
:[StrictnessMark]
out_marks)
      -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #)
      -- Make up one non-strict mark per runtime argument.
      | Bool
otherwise -- TODO: Assert real_reps /= null
      = [StrictnessMark]
-> [UnaryType] -> [StrictnessMark] -> [StrictnessMark]
go [StrictnessMark]
marks [UnaryType]
types ((Int -> StrictnessMark -> [StrictnessMark]
forall a. Int -> a -> [a]
replicate ([PrimRep] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PrimRep]
real_reps) StrictnessMark
NotMarkedStrict)[StrictnessMark] -> [StrictnessMark] -> [StrictnessMark]
forall a. [a] -> [a] -> [a]
++[StrictnessMark]
out_marks)
      where
        reps :: [PrimRep]
reps = HasDebugCallStack => UnaryType -> [PrimRep]
UnaryType -> [PrimRep]
typePrimRep UnaryType
ty
        real_reps :: [PrimRep]
real_reps = (PrimRep -> Bool) -> [PrimRep] -> [PrimRep]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (PrimRep -> Bool) -> PrimRep -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimRep -> Bool
isVoidRep) ([PrimRep] -> [PrimRep]) -> [PrimRep] -> [PrimRep]
forall a b. (a -> b) -> a -> b
$ [PrimRep]
reps
    go [] [] [StrictnessMark]
out_marks = [StrictnessMark] -> [StrictnessMark]
forall a. [a] -> [a]
reverse [StrictnessMark]
out_marks
    go [StrictnessMark]
_m [UnaryType]
_t [StrictnessMark]
_o = String -> SDoc -> [StrictnessMark]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dataConRuntimeRepStrictness2" (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [StrictnessMark] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StrictnessMark]
_m SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [UnaryType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnaryType]
_t SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [StrictnessMark] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StrictnessMark]
_o)

-- | True if the type has zero width.
isZeroBitTy :: HasDebugCallStack => Type -> Bool
isZeroBitTy :: HasDebugCallStack => UnaryType -> Bool
isZeroBitTy = [PrimRep] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([PrimRep] -> Bool)
-> (UnaryType -> [PrimRep]) -> UnaryType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => UnaryType -> [PrimRep]
UnaryType -> [PrimRep]
typePrimRep


{- **********************************************************************
*                                                                       *
                Unboxed sums
 See Note [Translating unboxed sums to unboxed tuples] in GHC.Stg.Unarise
*                                                                       *
********************************************************************** -}

type SortedSlotTys = [SlotTy]

-- | Given the arguments of a sum type constructor application,
--   return the unboxed sum rep type.
--
-- E.g.
--
--   (# Int# | Maybe Int | (# Int#, Float# #) #)
--
-- We call `ubxSumRepType [ [IntRep], [LiftedRep], [IntRep, FloatRep] ]`,
-- which returns [WordSlot, PtrSlot, WordSlot, FloatSlot]
--
-- INVARIANT: Result slots are sorted (via Ord SlotTy), except that at the head
-- of the list we have the slot for the tag.
ubxSumRepType :: [[PrimRep]] -> NonEmpty SlotTy
ubxSumRepType :: [[PrimRep]] -> NonEmpty SlotTy
ubxSumRepType [[PrimRep]]
constrs0
  -- These first two cases never classify an actual unboxed sum, which always
  -- has at least two disjuncts. But it could happen if a user writes, e.g.,
  -- forall (a :: TYPE (SumRep [IntRep])). ...
  -- which could never be instantiated. We still don't want to panic.
  | [[PrimRep]]
constrs0 [[PrimRep]] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthLessThan` Int
2
  = SlotTy
WordSlot SlotTy -> [SlotTy] -> NonEmpty SlotTy
forall a. a -> [a] -> NonEmpty a
:| []

  | Bool
otherwise
  = let
      combine_alts :: [SortedSlotTys]  -- slots of constructors
                   -> SortedSlotTys    -- final slots
      combine_alts :: [[SlotTy]] -> [SlotTy]
combine_alts [[SlotTy]]
constrs = ([SlotTy] -> [SlotTy] -> [SlotTy])
-> [SlotTy] -> [[SlotTy]] -> [SlotTy]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [SlotTy] -> [SlotTy] -> [SlotTy]
merge [] [[SlotTy]]
constrs

      merge :: SortedSlotTys -> SortedSlotTys -> SortedSlotTys
      merge :: [SlotTy] -> [SlotTy] -> [SlotTy]
merge [SlotTy]
existing_slots []
        = [SlotTy]
existing_slots
      merge [] [SlotTy]
needed_slots
        = [SlotTy]
needed_slots
      merge (SlotTy
es : [SlotTy]
ess) (SlotTy
s : [SlotTy]
ss)
        | Just SlotTy
s' <- SlotTy
s SlotTy -> SlotTy -> Maybe SlotTy
`fitsIn` SlotTy
es
        = -- found a slot, use it
          SlotTy
s' SlotTy -> [SlotTy] -> [SlotTy]
forall a. a -> [a] -> [a]
: [SlotTy] -> [SlotTy] -> [SlotTy]
merge [SlotTy]
ess [SlotTy]
ss
        | SlotTy
s SlotTy -> SlotTy -> Bool
forall a. Ord a => a -> a -> Bool
< SlotTy
es
        = -- we need a new slot and this is the right place for it
          SlotTy
s SlotTy -> [SlotTy] -> [SlotTy]
forall a. a -> [a] -> [a]
: [SlotTy] -> [SlotTy] -> [SlotTy]
merge (SlotTy
es SlotTy -> [SlotTy] -> [SlotTy]
forall a. a -> [a] -> [a]
: [SlotTy]
ess) [SlotTy]
ss
        | Bool
otherwise
        = -- keep searching for a slot
          SlotTy
es SlotTy -> [SlotTy] -> [SlotTy]
forall a. a -> [a] -> [a]
: [SlotTy] -> [SlotTy] -> [SlotTy]
merge [SlotTy]
ess (SlotTy
s SlotTy -> [SlotTy] -> [SlotTy]
forall a. a -> [a] -> [a]
: [SlotTy]
ss)

      -- Nesting unboxed tuples and sums is OK, so we need to flatten first.
      rep :: [PrimRep] -> SortedSlotTys
      rep :: [PrimRep] -> [SlotTy]
rep [PrimRep]
ty = [SlotTy] -> [SlotTy]
forall a. Ord a => [a] -> [a]
sort ((PrimRep -> SlotTy) -> [PrimRep] -> [SlotTy]
forall a b. (a -> b) -> [a] -> [b]
map PrimRep -> SlotTy
primRepSlot [PrimRep]
ty)

      sumRep :: NonEmpty SlotTy
sumRep = SlotTy
WordSlot SlotTy -> [SlotTy] -> NonEmpty SlotTy
forall a. a -> [a] -> NonEmpty a
:| [[SlotTy]] -> [SlotTy]
combine_alts (([PrimRep] -> [SlotTy]) -> [[PrimRep]] -> [[SlotTy]]
forall a b. (a -> b) -> [a] -> [b]
map [PrimRep] -> [SlotTy]
rep [[PrimRep]]
constrs0)
               -- WordSlot: for the tag of the sum
    in
      NonEmpty SlotTy
sumRep

layoutUbxSum :: HasDebugCallStack
             => SortedSlotTys -- Layout of sum. Does not include tag.
                              -- We assume that they are in increasing order
             -> [SlotTy]      -- Slot types of things we want to map to locations in the
                              -- sum layout
             -> [Int]         -- Where to map 'things' in the sum layout
layoutUbxSum :: HasDebugCallStack => [SlotTy] -> [SlotTy] -> [Int]
layoutUbxSum [SlotTy]
sum_slots0 [SlotTy]
arg_slots0 =
    [SlotTy] -> IntSet -> [Int]
go [SlotTy]
arg_slots0 IntSet
IS.empty
  where
    go :: [SlotTy] -> IS.IntSet -> [Int]
    go :: [SlotTy] -> IntSet -> [Int]
go [] IntSet
_
      = []
    go (SlotTy
arg : [SlotTy]
args) IntSet
used
      = let slot_idx :: Int
slot_idx = SlotTy -> Int -> [SlotTy] -> IntSet -> Int
findSlot SlotTy
arg Int
0 [SlotTy]
sum_slots0 IntSet
used
         in Int
slot_idx Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [SlotTy] -> IntSet -> [Int]
go [SlotTy]
args (Int -> IntSet -> IntSet
IS.insert Int
slot_idx IntSet
used)

    findSlot :: SlotTy -> Int -> SortedSlotTys -> IS.IntSet -> Int
    findSlot :: SlotTy -> Int -> [SlotTy] -> IntSet -> Int
findSlot SlotTy
arg Int
slot_idx (SlotTy
slot : [SlotTy]
slots) IntSet
useds
      | Bool -> Bool
not (Int -> IntSet -> Bool
IS.member Int
slot_idx IntSet
useds)
      , SlotTy -> Maybe SlotTy
forall a. a -> Maybe a
Just SlotTy
slot Maybe SlotTy -> Maybe SlotTy -> Bool
forall a. Eq a => a -> a -> Bool
== SlotTy
arg SlotTy -> SlotTy -> Maybe SlotTy
`fitsIn` SlotTy
slot
      = Int
slot_idx
      | Bool
otherwise
      = SlotTy -> Int -> [SlotTy] -> IntSet -> Int
findSlot SlotTy
arg (Int
slot_idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [SlotTy]
slots IntSet
useds
    findSlot SlotTy
_ Int
_ [] IntSet
_
      = String -> SDoc -> Int
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"findSlot" (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Can't find slot" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"sum_slots:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [SlotTy] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SlotTy]
sum_slots0
                                                    SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arg_slots:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [SlotTy] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SlotTy]
arg_slots0 )

--------------------------------------------------------------------------------

-- We have 3 kinds of slots:
--
--   - Pointer slot: Only shared between actual pointers to Haskell heap (i.e.
--     boxed objects). These come in two variants: Lifted and unlifted (see
--     #19645).
--
--   - Word slots: Shared between IntRep, WordRep, Int64Rep, Word64Rep, AddrRep.
--
--   - Float slots: Shared between floating point types.
--
--   - Void slots: Shared between void types. Not used in sums.
--
-- TODO(michalt): We should probably introduce `SlotTy`s for 8-/16-/32-bit
-- values, so that we can pack things more tightly.
data SlotTy = PtrLiftedSlot | PtrUnliftedSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot | VecSlot Int PrimElemRep
  deriving (SlotTy -> SlotTy -> Bool
(SlotTy -> SlotTy -> Bool)
-> (SlotTy -> SlotTy -> Bool) -> Eq SlotTy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SlotTy -> SlotTy -> Bool
== :: SlotTy -> SlotTy -> Bool
$c/= :: SlotTy -> SlotTy -> Bool
/= :: SlotTy -> SlotTy -> Bool
Eq, Eq SlotTy
Eq SlotTy =>
(SlotTy -> SlotTy -> Ordering)
-> (SlotTy -> SlotTy -> Bool)
-> (SlotTy -> SlotTy -> Bool)
-> (SlotTy -> SlotTy -> Bool)
-> (SlotTy -> SlotTy -> Bool)
-> (SlotTy -> SlotTy -> SlotTy)
-> (SlotTy -> SlotTy -> SlotTy)
-> Ord SlotTy
SlotTy -> SlotTy -> Bool
SlotTy -> SlotTy -> Ordering
SlotTy -> SlotTy -> SlotTy
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SlotTy -> SlotTy -> Ordering
compare :: SlotTy -> SlotTy -> Ordering
$c< :: SlotTy -> SlotTy -> Bool
< :: SlotTy -> SlotTy -> Bool
$c<= :: SlotTy -> SlotTy -> Bool
<= :: SlotTy -> SlotTy -> Bool
$c> :: SlotTy -> SlotTy -> Bool
> :: SlotTy -> SlotTy -> Bool
$c>= :: SlotTy -> SlotTy -> Bool
>= :: SlotTy -> SlotTy -> Bool
$cmax :: SlotTy -> SlotTy -> SlotTy
max :: SlotTy -> SlotTy -> SlotTy
$cmin :: SlotTy -> SlotTy -> SlotTy
min :: SlotTy -> SlotTy -> SlotTy
Ord)
    -- Constructor order is important! If slot A could fit into slot B
    -- then slot A must occur first.  E.g.  FloatSlot before DoubleSlot
    --
    -- We are assuming that WordSlot is smaller than or equal to Word64Slot
    -- (would not be true on a 128-bit machine)

instance Outputable SlotTy where
  ppr :: SlotTy -> SDoc
ppr SlotTy
PtrLiftedSlot   = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"PtrLiftedSlot"
  ppr SlotTy
PtrUnliftedSlot = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"PtrUnliftedSlot"
  ppr SlotTy
Word64Slot      = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Word64Slot"
  ppr SlotTy
WordSlot        = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"WordSlot"
  ppr SlotTy
DoubleSlot      = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DoubleSlot"
  ppr SlotTy
FloatSlot       = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"FloatSlot"
  ppr (VecSlot Int
n PrimElemRep
e)   = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"VecSlot" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> PrimElemRep -> SDoc
forall a. Outputable a => a -> SDoc
ppr PrimElemRep
e

typeSlotTy :: UnaryType -> Maybe SlotTy
typeSlotTy :: UnaryType -> Maybe SlotTy
typeSlotTy UnaryType
ty = case HasDebugCallStack => UnaryType -> [PrimRep]
UnaryType -> [PrimRep]
typePrimRep UnaryType
ty of
                  [] -> Maybe SlotTy
forall a. Maybe a
Nothing
                  [PrimRep
rep] -> SlotTy -> Maybe SlotTy
forall a. a -> Maybe a
Just (PrimRep -> SlotTy
primRepSlot PrimRep
rep)
                  [PrimRep]
reps -> String -> SDoc -> Maybe SlotTy
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"typeSlotTy" (UnaryType -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnaryType
ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [PrimRep] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [PrimRep]
reps)

primRepSlot :: PrimRep -> SlotTy
primRepSlot :: PrimRep -> SlotTy
primRepSlot PrimRep
VoidRep     = String -> SDoc -> SlotTy
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"primRepSlot" (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"No slot for VoidRep")
primRepSlot (BoxedRep Maybe Levity
mlev) = case Maybe Levity
mlev of
  Maybe Levity
Nothing       -> String -> SlotTy
forall a. HasCallStack => String -> a
panic String
"primRepSlot: levity polymorphic BoxedRep"
  Just Levity
Lifted   -> SlotTy
PtrLiftedSlot
  Just Levity
Unlifted -> SlotTy
PtrUnliftedSlot
primRepSlot PrimRep
IntRep      = SlotTy
WordSlot
primRepSlot PrimRep
Int8Rep     = SlotTy
WordSlot
primRepSlot PrimRep
Int16Rep    = SlotTy
WordSlot
primRepSlot PrimRep
Int32Rep    = SlotTy
WordSlot
primRepSlot PrimRep
Int64Rep    = SlotTy
Word64Slot
primRepSlot PrimRep
WordRep     = SlotTy
WordSlot
primRepSlot PrimRep
Word8Rep    = SlotTy
WordSlot
primRepSlot PrimRep
Word16Rep   = SlotTy
WordSlot
primRepSlot PrimRep
Word32Rep   = SlotTy
WordSlot
primRepSlot PrimRep
Word64Rep   = SlotTy
Word64Slot
primRepSlot PrimRep
AddrRep     = SlotTy
WordSlot
primRepSlot PrimRep
FloatRep    = SlotTy
FloatSlot
primRepSlot PrimRep
DoubleRep   = SlotTy
DoubleSlot
primRepSlot (VecRep Int
n PrimElemRep
e) = Int -> PrimElemRep -> SlotTy
VecSlot Int
n PrimElemRep
e

slotPrimRep :: SlotTy -> PrimRep
slotPrimRep :: SlotTy -> PrimRep
slotPrimRep SlotTy
PtrLiftedSlot   = Maybe Levity -> PrimRep
BoxedRep (Levity -> Maybe Levity
forall a. a -> Maybe a
Just Levity
Lifted)
slotPrimRep SlotTy
PtrUnliftedSlot = Maybe Levity -> PrimRep
BoxedRep (Levity -> Maybe Levity
forall a. a -> Maybe a
Just Levity
Unlifted)
slotPrimRep SlotTy
Word64Slot      = PrimRep
Word64Rep
slotPrimRep SlotTy
WordSlot        = PrimRep
WordRep
slotPrimRep SlotTy
DoubleSlot      = PrimRep
DoubleRep
slotPrimRep SlotTy
FloatSlot       = PrimRep
FloatRep
slotPrimRep (VecSlot Int
n PrimElemRep
e)   = Int -> PrimElemRep -> PrimRep
VecRep Int
n PrimElemRep
e

-- | Returns the bigger type if one fits into the other. (commutative)
--
-- Note that lifted and unlifted pointers are *not* in a fits-in relation for
-- the reasons described in Note [Don't merge lifted and unlifted slots] in
-- GHC.Stg.Unarise.
fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy
fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy
fitsIn SlotTy
ty1 SlotTy
ty2
  | SlotTy
ty1 SlotTy -> SlotTy -> Bool
forall a. Eq a => a -> a -> Bool
== SlotTy
ty2
  = SlotTy -> Maybe SlotTy
forall a. a -> Maybe a
Just SlotTy
ty1
  | SlotTy -> Bool
isWordSlot SlotTy
ty1 Bool -> Bool -> Bool
&& SlotTy -> Bool
isWordSlot SlotTy
ty2
  = SlotTy -> Maybe SlotTy
forall a. a -> Maybe a
Just (SlotTy -> SlotTy -> SlotTy
forall a. Ord a => a -> a -> a
max SlotTy
ty1 SlotTy
ty2)
  | Bool
otherwise
  = Maybe SlotTy
forall a. Maybe a
Nothing
  -- We used to share slots between Float/Double but currently we can't easily
  -- covert between float/double in a way that is both work free and safe.
  -- So we put them in different slots.
  -- See Note [Casting slot arguments]
  where
    isWordSlot :: SlotTy -> Bool
isWordSlot SlotTy
Word64Slot = Bool
True
    isWordSlot SlotTy
WordSlot   = Bool
True
    isWordSlot SlotTy
_          = Bool
False



{- **********************************************************************
*                                                                       *
                   PrimRep
*                                                                       *
*************************************************************************

Note [RuntimeRep and PrimRep]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This Note describes the relationship between GHC.Types.RuntimeRep
(of levity/representation polymorphism fame) and GHC.Core.TyCon.PrimRep,
as these types are closely related.

A "primitive entity" is one that can be
 * stored in one register
 * manipulated with one machine instruction


Examples include:
 * a 32-bit integer
 * a 32-bit float
 * a 64-bit float
 * a machine address (heap pointer), etc.
 * a quad-float (on a machine with SIMD register and instructions)
 * ...etc...

The "representation or a primitive entity" specifies what kind of register is
needed and how many bits are required. The data type GHC.Core.TyCon.PrimRep
enumerates all the possibilities.

data PrimRep
  = VoidRep       -- See Note [VoidRep]
  | LiftedRep     -- ^ Lifted pointer
  | UnliftedRep   -- ^ Unlifted pointer
  | Int8Rep       -- ^ Signed, 8-bit value
  | Int16Rep      -- ^ Signed, 16-bit value
  ...etc...
  | VecRep Int PrimElemRep  -- ^ SIMD fixed-width vector

The Haskell source language is a bit more flexible: a single value may need multiple PrimReps.
For example

  utup :: (# Int, Int #) -> Bool
  utup x = ...

Here x :: (# Int, Int #), and that takes two registers, and two instructions to move around.
Unboxed sums are similar.

Every Haskell expression e has a type ty, whose kind is of form TYPE rep
   e :: ty :: TYPE rep
where rep :: RuntimeRep. Here rep describes the runtime representation for e's value,
but RuntimeRep has some extra cases:

data RuntimeRep = VecRep VecCount VecElem   -- ^ a SIMD vector type
                | TupleRep [RuntimeRep]     -- ^ An unboxed tuple of the given reps
                | SumRep [RuntimeRep]       -- ^ An unboxed sum of the given reps
                | BoxedRep Levity -- ^ boxed; represented by a pointer
                | IntRep          -- ^ signed, word-sized value
                ...etc...
data Levity     = Lifted
                | Unlifted

It's all in 1-1 correspondence with PrimRep except for TupleRep and SumRep,
which describe unboxed products and sums respectively. RuntimeRep is defined
in the library ghc-prim:GHC.Types. It is also "wired-in" to GHC: see
GHC.Builtin.Types.runtimeRepTyCon. The unarisation pass, in GHC.Stg.Unarise, transforms the
program, so that every variable has a type that has a PrimRep. For
example, unarisation transforms our utup function above, to take two Int
arguments instead of one (# Int, Int #) argument.

Also, note that boxed types are represented slightly differently in RuntimeRep
and PrimRep. PrimRep just has the nullary LiftedRep and UnliftedRep data
constructors. RuntimeRep has a BoxedRep data constructor, which accepts a
Levity. The subtle distinction is that since BoxedRep can accept a variable
argument, RuntimeRep can talk about levity polymorphic types. PrimRep, by
contrast, cannot.

See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep].

Note [VoidRep]
~~~~~~~~~~~~~~
PrimRep contains a constructor VoidRep, while RuntimeRep does
not. Yet representations are often characterised by a list of PrimReps,
where a void would be denoted as []. (See also Note [RuntimeRep and PrimRep].)

However, after the unariser, all identifiers have exactly one PrimRep, but
void arguments still exist. Thus, PrimRep includes VoidRep to describe these
binders. Perhaps post-unariser representations (which need VoidRep) should be
a different type than pre-unariser representations (which use a list and do
not need VoidRep), but we have what we have.

RuntimeRep instead uses TupleRep '[] to denote a void argument. When
converting a TupleRep '[] into a list of PrimReps, we get an empty list.

Note [Getting from RuntimeRep to PrimRep]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
General info on RuntimeRep and PrimRep is in Note [RuntimeRep and PrimRep].

How do we get from an Id to the list or PrimReps used to store it? We get
the Id's type ty (using idType), then ty's kind ki (using typeKind), then
pattern-match on ki to extract rep (in kindPrimRep), then extract the PrimRep
from the RuntimeRep (in runtimeRepPrimRep).

We now must convert the RuntimeRep to a list of PrimReps. Let's look at two
examples:

  1. x :: Int#
  2. y :: (# Int, Word# #)

With these types, we can extract these kinds:

  1. Int# :: TYPE IntRep
  2. (# Int, Word# #) :: TYPE (TupleRep [LiftedRep, WordRep])

In the end, we will get these PrimReps:

  1. [IntRep]
  2. [LiftedRep, WordRep]

It would thus seem that we should have a function somewhere of
type `RuntimeRep -> [PrimRep]`. This doesn't work though: when we
look at the argument of TYPE, we get something of type Type (of course).
RuntimeRep exists in the user's program, but not in GHC as such.
Instead, we must decompose the Type of kind RuntimeRep into tycons and
extract the PrimReps from the TyCons. This is what runtimeRepPrimRep does:
it takes a Type and returns a [PrimRep]

runtimeRepPrimRep works by using tyConRuntimeRepInfo. That function
should be passed the TyCon produced by promoting one of the constructors
of RuntimeRep into type-level data. The RuntimeRep promoted datacons are
associated with a RuntimeRepInfo (stored directly in the PromotedDataCon
constructor of TyCon, field promDcRepInfo).
This pairing happens in GHC.Builtin.Types. A RuntimeRepInfo
usually(*) contains a function from [Type] to [PrimRep]: the [Type] are
the arguments to the promoted datacon. These arguments are necessary
for the TupleRep and SumRep constructors, so that this process can recur,
producing a flattened list of PrimReps. Calling this extracted function
happens in runtimeRepPrimRep; the functions themselves are defined in
tupleRepDataCon and sumRepDataCon, both in GHC.Builtin.Types.

The (*) above is to support vector representations. RuntimeRep refers
to VecCount and VecElem, whose promoted datacons have nuggets of information
related to vectors; these form the other alternatives for RuntimeRepInfo.

Returning to our examples, the Types we get (after stripping off TYPE) are

  1. TyConApp (PromotedDataCon "IntRep") []
  2. TyConApp (PromotedDataCon "TupleRep")
              [TyConApp (PromotedDataCon ":")
                        [ TyConApp (AlgTyCon "RuntimeRep") []
                        , TyConApp (PromotedDataCon "LiftedRep") []
                        , TyConApp (PromotedDataCon ":")
                                   [ TyConApp (AlgTyCon "RuntimeRep") []
                                   , TyConApp (PromotedDataCon "WordRep") []
                                   , TyConApp (PromotedDataCon "'[]")
                                              [TyConApp (AlgTyCon "RuntimeRep") []]]]]

runtimeRepPrimRep calls tyConRuntimeRepInfo on (PromotedDataCon "IntRep"), resp.
(PromotedDataCon "TupleRep"), extracting a function that will produce the PrimReps.
In example 1, this function is passed an empty list (the empty list of args to IntRep)
and returns the PrimRep IntRep. (See the definition of runtimeRepSimpleDataCons in
GHC.Builtin.Types and its helper function mk_runtime_rep_dc.) Example 2 passes the promoted
list as the one argument to the extracted function. The extracted function is defined
as prim_rep_fun within tupleRepDataCon in GHC.Builtin.Types. It takes one argument, decomposes
the promoted list (with extractPromotedList), and then recurs back to runtimeRepPrimRep
to process the LiftedRep and WordRep, concatenating the results.

-}

-- | Discovers the primitive representation of a 'Type'. Returns
-- a list of 'PrimRep': it's a list because of the possibility of
-- no runtime representation (void) or multiple (unboxed tuple/sum)
-- See also Note [Getting from RuntimeRep to PrimRep]
typePrimRep :: HasDebugCallStack => Type -> [PrimRep]
typePrimRep :: HasDebugCallStack => UnaryType -> [PrimRep]
typePrimRep UnaryType
ty = HasDebugCallStack => SDoc -> UnaryType -> [PrimRep]
SDoc -> UnaryType -> [PrimRep]
kindPrimRep (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"typePrimRep" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                              SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (UnaryType -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnaryType
ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UnaryType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => UnaryType -> UnaryType
UnaryType -> UnaryType
typeKind UnaryType
ty)))
                             (HasDebugCallStack => UnaryType -> UnaryType
UnaryType -> UnaryType
typeKind UnaryType
ty)

-- | Discovers the primitive representation of a 'Type'. Returns
-- a list of 'PrimRep': it's a list because of the possibility of
-- no runtime representation (void) or multiple (unboxed tuple/sum)
-- See also Note [Getting from RuntimeRep to PrimRep]
-- Returns Nothing if rep can't be determined. Eg. levity polymorphic types.
typePrimRep_maybe :: Type -> Maybe [PrimRep]
typePrimRep_maybe :: UnaryType -> Maybe [PrimRep]
typePrimRep_maybe UnaryType
ty = HasDebugCallStack => UnaryType -> Maybe [PrimRep]
UnaryType -> Maybe [PrimRep]
kindPrimRep_maybe (HasDebugCallStack => UnaryType -> UnaryType
UnaryType -> UnaryType
typeKind UnaryType
ty)

-- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output;
-- an empty list of PrimReps becomes a VoidRep.
-- This assumption holds after unarise, see Note [Post-unarisation invariants].
-- Before unarise it may or may not hold.
-- See also Note [RuntimeRep and PrimRep] and Note [VoidRep]
typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep
typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep
typePrimRep1 UnaryType
ty = case HasDebugCallStack => UnaryType -> [PrimRep]
UnaryType -> [PrimRep]
typePrimRep UnaryType
ty of
  []    -> PrimRep
VoidRep
  [PrimRep
rep] -> PrimRep
rep
  [PrimRep]
_     -> String -> SDoc -> PrimRep
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"typePrimRep1" (UnaryType -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnaryType
ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [PrimRep] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => UnaryType -> [PrimRep]
UnaryType -> [PrimRep]
typePrimRep UnaryType
ty))

-- | Find the runtime representation of a 'TyCon'. Defined here to
-- avoid module loops. Returns a list of the register shapes necessary.
-- See also Note [Getting from RuntimeRep to PrimRep]
tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep]
tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep]
tyConPrimRep TyCon
tc
  = HasDebugCallStack => SDoc -> UnaryType -> [PrimRep]
SDoc -> UnaryType -> [PrimRep]
kindPrimRep (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"kindRep tc" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ UnaryType -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnaryType
res_kind)
                UnaryType
res_kind
  where
    res_kind :: UnaryType
res_kind = TyCon -> UnaryType
tyConResKind TyCon
tc

-- | Like 'tyConPrimRep', but assumed that there is precisely zero or
-- one 'PrimRep' output
-- See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep]
tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep
tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep
tyConPrimRep1 TyCon
tc = case HasDebugCallStack => TyCon -> [PrimRep]
TyCon -> [PrimRep]
tyConPrimRep TyCon
tc of
  []    -> PrimRep
VoidRep
  [PrimRep
rep] -> PrimRep
rep
  [PrimRep]
_     -> String -> SDoc -> PrimRep
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tyConPrimRep1" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [PrimRep] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => TyCon -> [PrimRep]
TyCon -> [PrimRep]
tyConPrimRep TyCon
tc))

-- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's
-- of values of types of this kind.
-- See also Note [Getting from RuntimeRep to PrimRep]
kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep]
kindPrimRep :: HasDebugCallStack => SDoc -> UnaryType -> [PrimRep]
kindPrimRep SDoc
doc UnaryType
ki
  | Just UnaryType
runtime_rep <- HasDebugCallStack => UnaryType -> Maybe UnaryType
UnaryType -> Maybe UnaryType
kindRep_maybe UnaryType
ki
  = HasDebugCallStack => SDoc -> UnaryType -> [PrimRep]
SDoc -> UnaryType -> [PrimRep]
runtimeRepPrimRep SDoc
doc UnaryType
runtime_rep
kindPrimRep SDoc
doc UnaryType
ki
  = String -> SDoc -> [PrimRep]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"kindPrimRep" (UnaryType -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnaryType
ki SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
doc)

-- NB: We could implement the partial methods by calling into the maybe
-- variants here. But then both would need to pass around the doc argument.

-- | Take a kind (of shape `TYPE rr` or `CONSTRAINT rr`) and produce the 'PrimRep's
-- of values of types of this kind.
-- See also Note [Getting from RuntimeRep to PrimRep]
-- Returns Nothing if rep can't be determined. Eg. levity polymorphic types.
kindPrimRep_maybe :: HasDebugCallStack => Kind -> Maybe [PrimRep]
kindPrimRep_maybe :: HasDebugCallStack => UnaryType -> Maybe [PrimRep]
kindPrimRep_maybe UnaryType
ki
  | Just (TypeOrConstraint
_torc, UnaryType
rep) <- UnaryType -> Maybe (TypeOrConstraint, UnaryType)
sORTKind_maybe UnaryType
ki
  = UnaryType -> Maybe [PrimRep]
runtimeRepPrimRep_maybe UnaryType
rep
  | Bool
otherwise
  = String -> SDoc -> Maybe [PrimRep]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"kindPrimRep" (UnaryType -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnaryType
ki)

-- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that
-- it encodes. See also Note [Getting from RuntimeRep to PrimRep].
-- The @[PrimRep]@ is the final runtime representation /after/ unarisation.
--
-- The result does not contain any VoidRep.
runtimeRepPrimRep :: HasDebugCallStack => SDoc -> RuntimeRepType -> [PrimRep]
runtimeRepPrimRep :: HasDebugCallStack => SDoc -> UnaryType -> [PrimRep]
runtimeRepPrimRep SDoc
doc UnaryType
rr_ty
  | Just UnaryType
rr_ty' <- UnaryType -> Maybe UnaryType
coreView UnaryType
rr_ty
  = HasDebugCallStack => SDoc -> UnaryType -> [PrimRep]
SDoc -> UnaryType -> [PrimRep]
runtimeRepPrimRep SDoc
doc UnaryType
rr_ty'
  | TyConApp TyCon
rr_dc [UnaryType]
args <- UnaryType
rr_ty
  , RuntimeRep [UnaryType] -> [PrimRep]
fun <- TyCon -> PromDataConInfo
tyConPromDataConInfo TyCon
rr_dc
  = [UnaryType] -> [PrimRep]
fun [UnaryType]
args
  | Bool
otherwise
  = String -> SDoc -> [PrimRep]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"runtimeRepPrimRep" (SDoc
doc SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ UnaryType -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnaryType
rr_ty)

-- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that
-- it encodes. See also Note [Getting from RuntimeRep to PrimRep].
-- The @[PrimRep]@ is the final runtime representation /after/ unarisation
-- and does not contain VoidRep.
--
-- Returns @Nothing@ if rep can't be determined. Eg. levity polymorphic types.
runtimeRepPrimRep_maybe :: Type -> Maybe [PrimRep]
runtimeRepPrimRep_maybe :: UnaryType -> Maybe [PrimRep]
runtimeRepPrimRep_maybe UnaryType
rr_ty
  | Just UnaryType
rr_ty' <- UnaryType -> Maybe UnaryType
coreView UnaryType
rr_ty
  = UnaryType -> Maybe [PrimRep]
runtimeRepPrimRep_maybe UnaryType
rr_ty'
  | TyConApp TyCon
rr_dc [UnaryType]
args <- UnaryType
rr_ty
  , RuntimeRep [UnaryType] -> [PrimRep]
fun <- TyCon -> PromDataConInfo
tyConPromDataConInfo TyCon
rr_dc
  = [PrimRep] -> Maybe [PrimRep]
forall a. a -> Maybe a
Just ([PrimRep] -> Maybe [PrimRep]) -> [PrimRep] -> Maybe [PrimRep]
forall a b. (a -> b) -> a -> b
$! [UnaryType] -> [PrimRep]
fun [UnaryType]
args
  | Bool
otherwise
  = Maybe [PrimRep]
forall a. Maybe a
Nothing

-- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep
primRepToRuntimeRep :: PrimRep -> RuntimeRepType
primRepToRuntimeRep :: PrimRep -> UnaryType
primRepToRuntimeRep PrimRep
rep = case PrimRep
rep of
  PrimRep
VoidRep       -> UnaryType
zeroBitRepTy
  BoxedRep Maybe Levity
mlev -> case Maybe Levity
mlev of
    Maybe Levity
Nothing       -> String -> UnaryType
forall a. HasCallStack => String -> a
panic String
"primRepToRuntimeRep: levity polymorphic BoxedRep"
    Just Levity
Lifted   -> UnaryType
liftedRepTy
    Just Levity
Unlifted -> UnaryType
unliftedRepTy
  PrimRep
IntRep        -> UnaryType
intRepDataConTy
  PrimRep
Int8Rep       -> UnaryType
int8RepDataConTy
  PrimRep
Int16Rep      -> UnaryType
int16RepDataConTy
  PrimRep
Int32Rep      -> UnaryType
int32RepDataConTy
  PrimRep
Int64Rep      -> UnaryType
int64RepDataConTy
  PrimRep
WordRep       -> UnaryType
wordRepDataConTy
  PrimRep
Word8Rep      -> UnaryType
word8RepDataConTy
  PrimRep
Word16Rep     -> UnaryType
word16RepDataConTy
  PrimRep
Word32Rep     -> UnaryType
word32RepDataConTy
  PrimRep
Word64Rep     -> UnaryType
word64RepDataConTy
  PrimRep
AddrRep       -> UnaryType
addrRepDataConTy
  PrimRep
FloatRep      -> UnaryType
floatRepDataConTy
  PrimRep
DoubleRep     -> UnaryType
doubleRepDataConTy
  VecRep Int
n PrimElemRep
elem -> TyCon -> [UnaryType] -> UnaryType
TyConApp TyCon
vecRepDataConTyCon [UnaryType
n', UnaryType
elem']
    where
      n' :: UnaryType
n' = case Int
n of
        Int
2  -> UnaryType
vec2DataConTy
        Int
4  -> UnaryType
vec4DataConTy
        Int
8  -> UnaryType
vec8DataConTy
        Int
16 -> UnaryType
vec16DataConTy
        Int
32 -> UnaryType
vec32DataConTy
        Int
64 -> UnaryType
vec64DataConTy
        Int
_  -> String -> SDoc -> UnaryType
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Disallowed VecCount" (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n)

      elem' :: UnaryType
elem' = case PrimElemRep
elem of
        PrimElemRep
Int8ElemRep   -> UnaryType
int8ElemRepDataConTy
        PrimElemRep
Int16ElemRep  -> UnaryType
int16ElemRepDataConTy
        PrimElemRep
Int32ElemRep  -> UnaryType
int32ElemRepDataConTy
        PrimElemRep
Int64ElemRep  -> UnaryType
int64ElemRepDataConTy
        PrimElemRep
Word8ElemRep  -> UnaryType
word8ElemRepDataConTy
        PrimElemRep
Word16ElemRep -> UnaryType
word16ElemRepDataConTy
        PrimElemRep
Word32ElemRep -> UnaryType
word32ElemRepDataConTy
        PrimElemRep
Word64ElemRep -> UnaryType
word64ElemRepDataConTy
        PrimElemRep
FloatElemRep  -> UnaryType
floatElemRepDataConTy
        PrimElemRep
DoubleElemRep -> UnaryType
doubleElemRepDataConTy

-- | Convert a PrimRep back to a Type. Used only in the unariser to give types
-- to fresh Ids. Really, only the type's representation matters.
-- See also Note [RuntimeRep and PrimRep]
primRepToType :: PrimRep -> Type
primRepToType :: PrimRep -> UnaryType
primRepToType = UnaryType -> UnaryType
anyTypeOfKind (UnaryType -> UnaryType)
-> (PrimRep -> UnaryType) -> PrimRep -> UnaryType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnaryType -> UnaryType
mkTYPEapp (UnaryType -> UnaryType)
-> (PrimRep -> UnaryType) -> PrimRep -> UnaryType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimRep -> UnaryType
primRepToRuntimeRep

--------------
mightBeFunTy :: Type -> Bool
-- Return False only if we are *sure* it's a data type
-- Look through newtypes etc as much as possible. Used to
-- decide if we need to enter a closure via a slow call.
--
-- AK: It would be nice to figure out and document the difference
-- between this and isFunTy at some point.
mightBeFunTy :: UnaryType -> Bool
mightBeFunTy UnaryType
ty
  | [BoxedRep Maybe Levity
_] <- HasDebugCallStack => UnaryType -> [PrimRep]
UnaryType -> [PrimRep]
typePrimRep UnaryType
ty
  , Just TyCon
tc <- UnaryType -> Maybe TyCon
tyConAppTyCon_maybe (UnaryType -> UnaryType
unwrapType UnaryType
ty)
  , TyCon -> Bool
isDataTyCon TyCon
tc
  = Bool
False
  | Bool
otherwise
  = Bool
True