{-# LANGUAGE FlexibleContexts #-}
module GHC.Types.RepType
(
UnaryType, NvUnaryType, isNvUnaryType,
unwrapType,
isZeroBitTy,
typePrimRep, typePrimRep1,
runtimeRepPrimRep, typePrimRepArgs,
PrimRep(..), primRepToRuntimeRep, primRepToType,
countFunRepArgs, countConRepArgs, dataConRuntimeRepStrictness,
tyConPrimRep, tyConPrimRep1,
ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..),
slotPrimRep, primRepSlot
) where
import GHC.Prelude
import GHC.Types.Basic (Arity, RepArity)
import GHC.Core.DataCon
import GHC.Builtin.Names
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 GHC.Utils.Panic.Plain
import Data.List (sort)
import qualified Data.IntSet as IS
type NvUnaryType = Type
type UnaryType = Type
isNvUnaryType :: Type -> Bool
isNvUnaryType :: Type -> Bool
isNvUnaryType Type
ty
| [PrimRep
_] <- HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty
= Bool
True
| Bool
otherwise
= Bool
False
typePrimRepArgs :: HasDebugCallStack => Type -> [PrimRep]
typePrimRepArgs :: Type -> [PrimRep]
typePrimRepArgs Type
ty
| [] <- [PrimRep]
reps
= [PrimRep
VoidRep]
| Bool
otherwise
= [PrimRep]
reps
where
reps :: [PrimRep]
reps = HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty
unwrapType :: Type -> Type
unwrapType :: Type -> Type
unwrapType Type
ty
| Just (()
_, 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 Type
t | Just Type
t' <- Type -> Maybe Type
coreView Type
t = Type -> Type
go Type
t'
go (ForAllTy TyCoVarBinder
_ Type
t) = Type -> Type
go Type
t
go (CastTy Type
t KindCoercion
_) = Type -> Type
go Type
t
go Type
t = Type
t
stepper :: NormaliseStepper ()
stepper RecTcChecker
rec_nts TyCon
tc [Type]
tys
| Just (Type
ty', KindCoercion
_) <- TyCon -> [Type] -> Maybe (Type, KindCoercion)
instNewTyCon_maybe TyCon
tc [Type]
tys
= case RecTcChecker -> TyCon -> Maybe RecTcChecker
checkRecTc RecTcChecker
rec_nts TyCon
tc of
Just RecTcChecker
rec_nts' -> RecTcChecker -> Type -> () -> NormaliseStepResult ()
forall ev. RecTcChecker -> Type -> ev -> NormaliseStepResult ev
NS_Step RecTcChecker
rec_nts' (Type -> Type
go Type
ty') ()
Maybe RecTcChecker
Nothing -> NormaliseStepResult ()
forall ev. NormaliseStepResult ev
NS_Abort
| Bool
otherwise
= NormaliseStepResult ()
forall ev. NormaliseStepResult ev
NS_Done
countFunRepArgs :: Arity -> Type -> RepArity
countFunRepArgs :: Arity -> Type -> Arity
countFunRepArgs Arity
0 Type
_
= Arity
0
countFunRepArgs Arity
n Type
ty
| FunTy AnonArgFlag
_ Type
_ Type
arg 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
- Arity
1) Type
res
| Bool
otherwise
= String -> SDoc -> Arity
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"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 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 Arity
0 Type
_
= Arity
0
go Arity
n Type
ty
| FunTy AnonArgFlag
_ Type
_ Type
arg 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
- Arity
1) Type
res
| Bool
otherwise
= String -> SDoc -> Arity
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"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))
dataConRuntimeRepStrictness :: HasDebugCallStack => DataCon -> [StrictnessMark]
dataConRuntimeRepStrictness :: DataCon -> [StrictnessMark]
dataConRuntimeRepStrictness DataCon
dc =
let repMarks :: [StrictnessMark]
repMarks = DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
dc
repTys :: [Type]
repTys = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
irrelevantMult ([Scaled Type] -> [Type]) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ DataCon -> [Scaled Type]
dataConRepArgTys DataCon
dc
in
[StrictnessMark] -> [Type] -> [StrictnessMark] -> [StrictnessMark]
go [StrictnessMark]
repMarks [Type]
repTys []
where
go :: [StrictnessMark] -> [Type] -> [StrictnessMark] -> [StrictnessMark]
go (StrictnessMark
mark:[StrictnessMark]
marks) (Type
ty:[Type]
types) [StrictnessMark]
out_marks
|
(HasDebugCallStack => Type -> Bool
Type -> Bool
isZeroBitTy Type
ty)
= [StrictnessMark] -> [Type] -> [StrictnessMark] -> [StrictnessMark]
go [StrictnessMark]
marks [Type]
types [StrictnessMark]
out_marks
| [PrimRep
_] <- [PrimRep]
reps
= [StrictnessMark] -> [Type] -> [StrictnessMark] -> [StrictnessMark]
go [StrictnessMark]
marks [Type]
types (StrictnessMark
markStrictnessMark -> [StrictnessMark] -> [StrictnessMark]
forall a. a -> [a] -> [a]
:[StrictnessMark]
out_marks)
| Bool
otherwise
= [StrictnessMark] -> [Type] -> [StrictnessMark] -> [StrictnessMark]
go [StrictnessMark]
marks [Type]
types ((Arity -> StrictnessMark -> [StrictnessMark]
forall a. Arity -> a -> [a]
replicate ([PrimRep] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [PrimRep]
real_reps) StrictnessMark
NotMarkedStrict)[StrictnessMark] -> [StrictnessMark] -> [StrictnessMark]
forall a. [a] -> [a] -> [a]
++[StrictnessMark]
out_marks)
where
reps :: [PrimRep]
reps = HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
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 [Type]
_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
$$ [StrictnessMark] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StrictnessMark]
_m SDoc -> SDoc -> SDoc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
_t SDoc -> SDoc -> SDoc
$$ [StrictnessMark] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StrictnessMark]
_o)
isZeroBitTy :: HasDebugCallStack => Type -> Bool
isZeroBitTy :: Type -> Bool
isZeroBitTy = [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
type SortedSlotTys = [SlotTy]
ubxSumRepType :: [[PrimRep]] -> [SlotTy]
ubxSumRepType :: [[PrimRep]] -> [SlotTy]
ubxSumRepType [[PrimRep]]
constrs0
| [[PrimRep]]
constrs0 [[PrimRep]] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthLessThan` Arity
2
= [SlotTy
WordSlot]
| Bool
otherwise
= let
combine_alts :: [SortedSlotTys]
-> SortedSlotTys
combine_alts :: [[SlotTy]] -> [SlotTy]
combine_alts [[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 [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
=
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
=
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
=
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)
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 :: [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)
in
[SlotTy]
sumRep
layoutUbxSum :: SortedSlotTys
-> [SlotTy]
-> [Int]
layoutUbxSum :: [SlotTy] -> [SlotTy] -> [Arity]
layoutUbxSum [SlotTy]
sum_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 [] IntSet
_
= []
go (SlotTy
arg : [SlotTy]
args) IntSet
used
= let slot_idx :: Arity
slot_idx = SlotTy -> Arity -> [SlotTy] -> IntSet -> Arity
findSlot SlotTy
arg Arity
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 SlotTy
arg Arity
slot_idx (SlotTy
slot : [SlotTy]
slots) 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
+ Arity
1) [SlotTy]
slots IntSet
useds
findSlot SlotTy
_ Arity
_ [] IntSet
_
= String -> SDoc -> Arity
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"findSlot" (String -> SDoc
text String
"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)
data SlotTy = PtrLiftedSlot | PtrUnliftedSlot | 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)
instance Outputable SlotTy where
ppr :: SlotTy -> SDoc
ppr SlotTy
PtrLiftedSlot = String -> SDoc
text String
"PtrLiftedSlot"
ppr SlotTy
PtrUnliftedSlot = String -> SDoc
text String
"PtrUnliftedSlot"
ppr SlotTy
Word64Slot = String -> SDoc
text String
"Word64Slot"
ppr SlotTy
WordSlot = String -> SDoc
text String
"WordSlot"
ppr SlotTy
DoubleSlot = String -> SDoc
text String
"DoubleSlot"
ppr SlotTy
FloatSlot = String -> SDoc
text String
"FloatSlot"
typeSlotTy :: UnaryType -> Maybe SlotTy
typeSlotTy :: Type -> Maybe SlotTy
typeSlotTy Type
ty
| HasDebugCallStack => Type -> Bool
Type -> Bool
isZeroBitTy 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 PrimRep
VoidRep = String -> SDoc -> SlotTy
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"primRepSlot" (String -> SDoc
text String
"No slot for VoidRep")
primRepSlot PrimRep
LiftedRep = SlotTy
PtrLiftedSlot
primRepSlot PrimRep
UnliftedRep = 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{} = String -> SDoc -> SlotTy
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"primRepSlot" (String -> SDoc
text String
"No slot for VecRep")
slotPrimRep :: SlotTy -> PrimRep
slotPrimRep :: SlotTy -> PrimRep
slotPrimRep SlotTy
PtrLiftedSlot = PrimRep
LiftedRep
slotPrimRep SlotTy
PtrUnliftedSlot = PrimRep
UnliftedRep
slotPrimRep SlotTy
Word64Slot = PrimRep
Word64Rep
slotPrimRep SlotTy
WordSlot = PrimRep
WordRep
slotPrimRep SlotTy
DoubleSlot = PrimRep
DoubleRep
slotPrimRep SlotTy
FloatSlot = PrimRep
FloatRep
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)
| 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)
| Bool
otherwise
= Maybe SlotTy
forall a. Maybe a
Nothing
where
isWordSlot :: SlotTy -> Bool
isWordSlot SlotTy
Word64Slot = Bool
True
isWordSlot SlotTy
WordSlot = Bool
True
isWordSlot SlotTy
_ = Bool
False
isFloatSlot :: SlotTy -> Bool
isFloatSlot SlotTy
DoubleSlot = Bool
True
isFloatSlot SlotTy
FloatSlot = Bool
True
isFloatSlot SlotTy
_ = Bool
False
typePrimRep :: HasDebugCallStack => Type -> [PrimRep]
typePrimRep :: Type -> [PrimRep]
typePrimRep Type
ty = HasDebugCallStack => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [PrimRep]
kindPrimRep (String -> SDoc
text String
"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)
typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep
typePrimRep1 :: Type -> PrimRep
typePrimRep1 Type
ty = case HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty of
[] -> PrimRep
VoidRep
[PrimRep
rep] -> PrimRep
rep
[PrimRep]
_ -> String -> SDoc -> PrimRep
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"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))
tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep]
tyConPrimRep :: TyCon -> [PrimRep]
tyConPrimRep TyCon
tc
= HasDebugCallStack => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [PrimRep]
kindPrimRep (String -> SDoc
text String
"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
tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep
tyConPrimRep1 :: 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
$$ [PrimRep] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => TyCon -> [PrimRep]
TyCon -> [PrimRep]
tyConPrimRep TyCon
tc))
kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep]
kindPrimRep :: SDoc -> Type -> [PrimRep]
kindPrimRep SDoc
doc Type
ki
| Just Type
ki' <- Type -> Maybe Type
coreView Type
ki
= HasDebugCallStack => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [PrimRep]
kindPrimRep SDoc
doc Type
ki'
kindPrimRep SDoc
doc (TyConApp TyCon
typ [Type
runtime_rep])
= Bool -> [PrimRep] -> [PrimRep]
forall a. HasCallStack => Bool -> a -> a
assert (TyCon
typ TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
tYPETyConKey) ([PrimRep] -> [PrimRep]) -> [PrimRep] -> [PrimRep]
forall a b. (a -> b) -> a -> b
$
HasDebugCallStack => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [PrimRep]
runtimeRepPrimRep SDoc
doc Type
runtime_rep
kindPrimRep SDoc
doc Type
ki
= String -> SDoc -> [PrimRep]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"kindPrimRep" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ki SDoc -> SDoc -> SDoc
$$ SDoc
doc)
runtimeRepPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep]
runtimeRepPrimRep :: SDoc -> Type -> [PrimRep]
runtimeRepPrimRep SDoc
doc Type
rr_ty
| Just Type
rr_ty' <- Type -> Maybe Type
coreView Type
rr_ty
= HasDebugCallStack => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [PrimRep]
runtimeRepPrimRep SDoc
doc Type
rr_ty'
| TyConApp TyCon
rr_dc [Type]
args <- Type
rr_ty
, RuntimeRep [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 String
"runtimeRepPrimRep" (SDoc
doc SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rr_ty)
primRepToRuntimeRep :: PrimRep -> Type
primRepToRuntimeRep :: PrimRep -> Type
primRepToRuntimeRep PrimRep
rep = case PrimRep
rep of
PrimRep
VoidRep -> Type
zeroBitRepTy
PrimRep
LiftedRep -> Type
liftedRepTy
PrimRep
UnliftedRep -> Type
unliftedRepTy
PrimRep
IntRep -> Type
intRepDataConTy
PrimRep
Int8Rep -> Type
int8RepDataConTy
PrimRep
Int16Rep -> Type
int16RepDataConTy
PrimRep
Int32Rep -> Type
int32RepDataConTy
PrimRep
Int64Rep -> Type
int64RepDataConTy
PrimRep
WordRep -> Type
wordRepDataConTy
PrimRep
Word8Rep -> Type
word8RepDataConTy
PrimRep
Word16Rep -> Type
word16RepDataConTy
PrimRep
Word32Rep -> Type
word32RepDataConTy
PrimRep
Word64Rep -> Type
word64RepDataConTy
PrimRep
AddrRep -> Type
addrRepDataConTy
PrimRep
FloatRep -> Type
floatRepDataConTy
PrimRep
DoubleRep -> Type
doubleRepDataConTy
VecRep Arity
n PrimElemRep
elem -> TyCon -> [Type] -> Type
TyConApp TyCon
vecRepDataConTyCon [Type
n', Type
elem']
where
n' :: Type
n' = case Arity
n of
Arity
2 -> Type
vec2DataConTy
Arity
4 -> Type
vec4DataConTy
Arity
8 -> Type
vec8DataConTy
Arity
16 -> Type
vec16DataConTy
Arity
32 -> Type
vec32DataConTy
Arity
64 -> Type
vec64DataConTy
Arity
_ -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Disallowed VecCount" (Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Arity
n)
elem' :: Type
elem' = case PrimElemRep
elem of
PrimElemRep
Int8ElemRep -> Type
int8ElemRepDataConTy
PrimElemRep
Int16ElemRep -> Type
int16ElemRepDataConTy
PrimElemRep
Int32ElemRep -> Type
int32ElemRepDataConTy
PrimElemRep
Int64ElemRep -> Type
int64ElemRepDataConTy
PrimElemRep
Word8ElemRep -> Type
word8ElemRepDataConTy
PrimElemRep
Word16ElemRep -> Type
word16ElemRepDataConTy
PrimElemRep
Word32ElemRep -> Type
word32ElemRepDataConTy
PrimElemRep
Word64ElemRep -> Type
word64ElemRepDataConTy
PrimElemRep
FloatElemRep -> Type
floatElemRepDataConTy
PrimElemRep
DoubleElemRep -> Type
doubleElemRepDataConTy
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
mkTYPEapp (Type -> Type) -> (PrimRep -> Type) -> PrimRep -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimRep -> Type
primRepToRuntimeRep