{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}

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

    -- * Predicates on types
    isVoidTy,

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

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

#include "HsVersions.h"

import GhcPrelude

import BasicTypes (Arity, RepArity)
import DataCon
import Outputable
import PrelNames
import Coercion
import TyCon
import TyCoRep
import Type
import Util
import TysPrim
import {-# SOURCE #-} TysWiredIn ( anyTypeOfKind )

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 :: Type -> Bool
isNvUnaryType ty :: Type
ty
  | [_] <- HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty
  = Bool
True
  | Bool
otherwise
  = Bool
False

-- INVARIANT: the result list is never empty.
typePrimRepArgs :: HasDebugCallStack => Type -> [PrimRep]
typePrimRepArgs :: Type -> [PrimRep]
typePrimRepArgs ty :: Type
ty
  | [] <- [PrimRep]
reps
  = [PrimRep
VoidRep]
  | Bool
otherwise
  = [PrimRep]
reps
  where
    reps :: [PrimRep]
reps = HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
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 :: Type -> Type
unwrapType ty :: Type
ty
  | Just (_, unwrapped :: Type
unwrapped)
      <- NormaliseStepper () -> (() -> () -> ()) -> Type -> Maybe ((), Type)
forall ev.
NormaliseStepper ev -> (ev -> ev -> ev) -> Type -> Maybe (ev, Type)
topNormaliseTypeX NormaliseStepper ()
stepper () -> () -> ()
forall a. Monoid a => a -> a -> a
mappend Type
inner_ty
  = Type
unwrapped
  | Bool
otherwise
  = Type
inner_ty
  where
    inner_ty :: Type
inner_ty = Type -> Type
go Type
ty

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

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

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

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

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


{- **********************************************************************
*                                                                       *
                Unboxed sums
 See Note [Translating unboxed sums to unboxed tuples] in UnariseStg.hs
*                                                                       *
********************************************************************** -}

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]] -> [SlotTy]
ubxSumRepType :: [[PrimRep]] -> [SlotTy]
ubxSumRepType constrs0 :: [[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]] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthLessThan` 2
  = [SlotTy
WordSlot]

  | Bool
otherwise
  = let
      combine_alts :: [SortedSlotTys]  -- slots of constructors
                   -> SortedSlotTys    -- final slots
      combine_alts :: [[SlotTy]] -> [SlotTy]
combine_alts constrs :: [[SlotTy]]
constrs = ([SlotTy] -> [SlotTy] -> [SlotTy])
-> [SlotTy] -> [[SlotTy]] -> [SlotTy]
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 existing_slots :: [SlotTy]
existing_slots []
        = [SlotTy]
existing_slots
      merge [] needed_slots :: [SlotTy]
needed_slots
        = [SlotTy]
needed_slots
      merge (es :: SlotTy
es : ess :: [SlotTy]
ess) (s :: SlotTy
s : ss :: [SlotTy]
ss)
        | Just s' :: 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 ty :: [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 :: [SlotTy]
sumRep = SlotTy
WordSlot SlotTy -> [SlotTy] -> [SlotTy]
forall a. a -> [a] -> [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
      [SlotTy]
sumRep

layoutUbxSum :: 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 :: [SlotTy] -> [SlotTy] -> [Arity]
layoutUbxSum sum_slots0 :: [SlotTy]
sum_slots0 arg_slots0 :: [SlotTy]
arg_slots0 =
    [SlotTy] -> IntSet -> [Arity]
go [SlotTy]
arg_slots0 IntSet
IS.empty
  where
    go :: [SlotTy] -> IS.IntSet -> [Int]
    go :: [SlotTy] -> IntSet -> [Arity]
go [] _
      = []
    go (arg :: SlotTy
arg : args :: [SlotTy]
args) used :: IntSet
used
      = let slot_idx :: Arity
slot_idx = SlotTy -> Arity -> [SlotTy] -> IntSet -> Arity
findSlot SlotTy
arg 0 [SlotTy]
sum_slots0 IntSet
used
         in Arity
slot_idx Arity -> [Arity] -> [Arity]
forall a. a -> [a] -> [a]
: [SlotTy] -> IntSet -> [Arity]
go [SlotTy]
args (Arity -> IntSet -> IntSet
IS.insert Arity
slot_idx IntSet
used)

    findSlot :: SlotTy -> Int -> SortedSlotTys -> IS.IntSet -> Int
    findSlot :: SlotTy -> Arity -> [SlotTy] -> IntSet -> Arity
findSlot arg :: SlotTy
arg slot_idx :: Arity
slot_idx (slot :: SlotTy
slot : slots :: [SlotTy]
slots) useds :: IntSet
useds
      | Bool -> Bool
not (Arity -> IntSet -> Bool
IS.member Arity
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
      = Arity
slot_idx
      | Bool
otherwise
      = SlotTy -> Arity -> [SlotTy] -> IntSet -> Arity
findSlot SlotTy
arg (Arity
slot_idx Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ 1) [SlotTy]
slots IntSet
useds
    findSlot _ _ [] _
      = String -> SDoc -> Arity
forall a. HasCallStack => String -> SDoc -> a
pprPanic "findSlot" (String -> SDoc
text "Can't find slot" SDoc -> SDoc -> SDoc
$$ [SlotTy] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SlotTy]
sum_slots0 SDoc -> SDoc -> SDoc
$$ [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)
--
--   - 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 = PtrSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot
  deriving (SlotTy -> SlotTy -> Bool
(SlotTy -> SlotTy -> Bool)
-> (SlotTy -> SlotTy -> Bool) -> Eq SlotTy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SlotTy -> SlotTy -> Bool
$c/= :: SlotTy -> SlotTy -> Bool
== :: SlotTy -> SlotTy -> Bool
$c== :: 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
min :: SlotTy -> SlotTy -> SlotTy
$cmin :: SlotTy -> SlotTy -> SlotTy
max :: SlotTy -> SlotTy -> SlotTy
$cmax :: SlotTy -> SlotTy -> SlotTy
>= :: SlotTy -> SlotTy -> Bool
$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
compare :: SlotTy -> SlotTy -> Ordering
$ccompare :: SlotTy -> SlotTy -> Ordering
$cp1Ord :: Eq 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 PtrSlot    = String -> SDoc
text "PtrSlot"
  ppr Word64Slot = String -> SDoc
text "Word64Slot"
  ppr WordSlot   = String -> SDoc
text "WordSlot"
  ppr DoubleSlot = String -> SDoc
text "DoubleSlot"
  ppr FloatSlot  = String -> SDoc
text "FloatSlot"

typeSlotTy :: UnaryType -> Maybe SlotTy
typeSlotTy :: Type -> Maybe SlotTy
typeSlotTy ty :: Type
ty
  | Type -> Bool
isVoidTy Type
ty
  = Maybe SlotTy
forall a. Maybe a
Nothing
  | Bool
otherwise
  = SlotTy -> Maybe SlotTy
forall a. a -> Maybe a
Just (PrimRep -> SlotTy
primRepSlot (HasDebugCallStack => Type -> PrimRep
Type -> PrimRep
typePrimRep1 Type
ty))

primRepSlot :: PrimRep -> SlotTy
primRepSlot :: PrimRep -> SlotTy
primRepSlot VoidRep     = String -> SDoc -> SlotTy
forall a. HasCallStack => String -> SDoc -> a
pprPanic "primRepSlot" (String -> SDoc
text "No slot for VoidRep")
primRepSlot LiftedRep   = SlotTy
PtrSlot
primRepSlot UnliftedRep = SlotTy
PtrSlot
primRepSlot IntRep      = SlotTy
WordSlot
primRepSlot Int8Rep     = SlotTy
WordSlot
primRepSlot Int16Rep    = SlotTy
WordSlot
primRepSlot Int64Rep    = SlotTy
Word64Slot
primRepSlot WordRep     = SlotTy
WordSlot
primRepSlot Word8Rep    = SlotTy
WordSlot
primRepSlot Word16Rep   = SlotTy
WordSlot
primRepSlot Word64Rep   = SlotTy
Word64Slot
primRepSlot AddrRep     = SlotTy
WordSlot
primRepSlot FloatRep    = SlotTy
FloatSlot
primRepSlot DoubleRep   = SlotTy
DoubleSlot
primRepSlot VecRep{}    = String -> SDoc -> SlotTy
forall a. HasCallStack => String -> SDoc -> a
pprPanic "primRepSlot" (String -> SDoc
text "No slot for VecRep")

slotPrimRep :: SlotTy -> PrimRep
slotPrimRep :: SlotTy -> PrimRep
slotPrimRep PtrSlot     = PrimRep
LiftedRep   -- choice between lifted & unlifted seems arbitrary
slotPrimRep Word64Slot  = PrimRep
Word64Rep
slotPrimRep WordSlot    = PrimRep
WordRep
slotPrimRep DoubleSlot  = PrimRep
DoubleRep
slotPrimRep FloatSlot   = PrimRep
FloatRep

-- | Returns the bigger type if one fits into the other. (commutative)
fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy
fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy
fitsIn ty1 :: SlotTy
ty1 ty2 :: SlotTy
ty2
  | 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)
  | SlotTy -> Bool
isFloatSlot SlotTy
ty1 Bool -> Bool -> Bool
&& SlotTy -> Bool
isFloatSlot 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)
  | SlotTy -> Bool
isPtrSlot SlotTy
ty1 Bool -> Bool -> Bool
&& SlotTy -> Bool
isPtrSlot SlotTy
ty2
  = SlotTy -> Maybe SlotTy
forall a. a -> Maybe a
Just SlotTy
PtrSlot
  | Bool
otherwise
  = Maybe SlotTy
forall a. Maybe a
Nothing
  where
    isPtrSlot :: SlotTy -> Bool
isPtrSlot PtrSlot = Bool
True
    isPtrSlot _       = Bool
False

    isWordSlot :: SlotTy -> Bool
isWordSlot Word64Slot = Bool
True
    isWordSlot WordSlot   = Bool
True
    isWordSlot _          = Bool
False

    isFloatSlot :: SlotTy -> Bool
isFloatSlot DoubleSlot = Bool
True
    isFloatSlot FloatSlot  = Bool
True
    isFloatSlot _          = Bool
False


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

-- | 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)
typePrimRep :: HasDebugCallStack => Type -> [PrimRep]
typePrimRep :: Type -> [PrimRep]
typePrimRep ty :: Type
ty = HasDebugCallStack => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [PrimRep]
kindPrimRep (String -> SDoc
text "typePrimRep" SDoc -> SDoc -> SDoc
<+>
                              SDoc -> SDoc
parens (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty)))
                             (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty)

-- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output;
-- an empty list of PrimReps becomes a VoidRep
typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep
typePrimRep1 :: Type -> PrimRep
typePrimRep1 ty :: Type
ty = case HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty of
  []    -> PrimRep
VoidRep
  [rep :: PrimRep
rep] -> PrimRep
rep
  _     -> String -> SDoc -> PrimRep
forall a. HasCallStack => String -> SDoc -> a
pprPanic "typePrimRep1" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
$$ [PrimRep] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty))

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

-- | Like 'tyConPrimRep', but assumed that there is precisely zero or
-- one 'PrimRep' output
tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep
tyConPrimRep1 :: TyCon -> PrimRep
tyConPrimRep1 tc :: TyCon
tc = case HasDebugCallStack => TyCon -> [PrimRep]
TyCon -> [PrimRep]
tyConPrimRep TyCon
tc of
  []    -> PrimRep
VoidRep
  [rep :: PrimRep
rep] -> PrimRep
rep
  _     -> String -> SDoc -> PrimRep
forall a. HasCallStack => String -> SDoc -> a
pprPanic "tyConPrimRep1" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
$$ [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.
kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep]
kindPrimRep :: SDoc -> Type -> [PrimRep]
kindPrimRep doc :: SDoc
doc ki :: Type
ki
  | Just ki' :: Type
ki' <- Type -> Maybe Type
coreView Type
ki
  = HasDebugCallStack => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [PrimRep]
kindPrimRep SDoc
doc Type
ki'
kindPrimRep doc :: SDoc
doc (TyConApp typ :: TyCon
typ [runtime_rep :: Type
runtime_rep])
  = ASSERT( typ `hasKey` tYPETyConKey )
    HasDebugCallStack => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [PrimRep]
runtimeRepPrimRep SDoc
doc Type
runtime_rep
kindPrimRep doc :: SDoc
doc ki :: Type
ki
  = String -> SDoc -> [PrimRep]
forall a. HasCallStack => String -> SDoc -> a
pprPanic "kindPrimRep" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ki SDoc -> SDoc -> SDoc
$$ SDoc
doc)

-- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that
-- it encodes.
runtimeRepPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep]
runtimeRepPrimRep :: SDoc -> Type -> [PrimRep]
runtimeRepPrimRep doc :: SDoc
doc rr_ty :: Type
rr_ty
  | Just rr_ty' :: Type
rr_ty' <- Type -> Maybe Type
coreView Type
rr_ty
  = HasDebugCallStack => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [PrimRep]
runtimeRepPrimRep SDoc
doc Type
rr_ty'
  | TyConApp rr_dc :: TyCon
rr_dc args :: [Type]
args <- Type
rr_ty
  , RuntimeRep fun :: [Type] -> [PrimRep]
fun <- TyCon -> RuntimeRepInfo
tyConRuntimeRepInfo TyCon
rr_dc
  = [Type] -> [PrimRep]
fun [Type]
args
  | Bool
otherwise
  = String -> SDoc -> [PrimRep]
forall a. HasCallStack => String -> SDoc -> a
pprPanic "runtimeRepPrimRep" (SDoc
doc SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rr_ty)

-- | 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.
primRepToType :: PrimRep -> Type
primRepToType :: PrimRep -> Type
primRepToType = Type -> Type
anyTypeOfKind (Type -> Type) -> (PrimRep -> Type) -> PrimRep -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
tYPE (Type -> Type) -> (PrimRep -> Type) -> PrimRep -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimRep -> Type
primRepToRuntimeRep