{-# LANGUAGE FlexibleContexts #-}
module GHC.Types.RepType
(
UnaryType, NvUnaryType, isNvUnaryRep,
unwrapType,
isZeroBitTy,
typePrimRep, typePrimRep1, typePrimRepU,
runtimeRepPrimRep,
PrimRep(..), primRepToRuntimeRep, primRepToType,
countFunRepArgs, countConRepArgs, dataConRuntimeRepStrictness,
tyConPrimRep,
runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe,
ubxSumRepType, layoutUbxSum, repSlotTy, SlotTy (..),
slotPrimRep, primRepSlot,
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
, 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
type NvUnaryType = Type
type UnaryType = Type
isNvUnaryRep :: [PrimRep] -> Bool
isNvUnaryRep :: [PrimRep] -> Bool
isNvUnaryRep [PrimRep
_] = Bool
True
isNvUnaryRep [PrimRep]
_ = Bool
False
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 ForAllTyBinder
_ 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 :: Int -> Type -> Int
countFunRepArgs Int
0 Type
_
= Int
0
countFunRepArgs Int
n Type
ty
| FunTy FunTyFlag
_ Type
_ Type
arg Type
res <- Type -> Type
unwrapType Type
ty
= ([PrimRep] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
arg) Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` Int
1)
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Type -> Int
countFunRepArgs (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Type
res
| Bool
otherwise
= String -> SDoc -> Int
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"countFunRepArgs: arity greater than type can handle" ((Int, Type, [PrimRep]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int
n, Type
ty, HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty))
countConRepArgs :: DataCon -> RepArity
countConRepArgs :: DataCon -> Int
countConRepArgs DataCon
dc = Int -> Type -> Int
go (DataCon -> Int
dataConRepArity DataCon
dc) (DataCon -> Type
dataConRepType DataCon
dc)
where
go :: Arity -> Type -> RepArity
go :: Int -> Type -> Int
go Int
0 Type
_
= Int
0
go Int
n Type
ty
| FunTy FunTyFlag
_ Type
_ Type
arg Type
res <- Type -> Type
unwrapType Type
ty
= [PrimRep] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
arg) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Type -> Int
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Type
res
| Bool
otherwise
= String -> SDoc -> Int
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"countConRepArgs: arity greater than type can handle" ((Int, Type, [PrimRep]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int
n, Type
ty, HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty))
dataConRuntimeRepStrictness :: HasDebugCallStack => DataCon -> [StrictnessMark]
dataConRuntimeRepStrictness :: HasDebugCallStack => 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
= case [PrimRep]
reps of
[] ->
[StrictnessMark] -> [Type] -> [StrictnessMark] -> [StrictnessMark]
go [StrictnessMark]
marks [Type]
types [StrictnessMark]
out_marks
[PrimRep
_] -> [StrictnessMark] -> [Type] -> [StrictnessMark] -> [StrictnessMark]
go [StrictnessMark]
marks [Type]
types (StrictnessMark
markStrictnessMark -> [StrictnessMark] -> [StrictnessMark]
forall a. a -> [a] -> [a]
:[StrictnessMark]
out_marks)
[PrimRep]
_ -> [StrictnessMark] -> [Type] -> [StrictnessMark] -> [StrictnessMark]
go [StrictnessMark]
marks [Type]
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]
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
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
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
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
_t SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [StrictnessMark] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StrictnessMark]
_o)
isZeroBitTy :: HasDebugCallStack => Type -> Bool
isZeroBitTy :: HasDebugCallStack => Type -> Bool
isZeroBitTy = [PrimRep] -> Bool
forall a. [a] -> 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]] -> NonEmpty SlotTy
ubxSumRepType :: [[PrimRep]] -> NonEmpty SlotTy
ubxSumRepType [[PrimRep]]
constrs0
| [[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]
-> SortedSlotTys
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
=
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 :: 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)
in
NonEmpty SlotTy
sumRep
layoutUbxSum :: HasDebugCallStack
=> SortedSlotTys
-> [SlotTy]
-> [Int]
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 )
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)
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
repSlotTy :: [PrimRep] -> Maybe SlotTy
repSlotTy :: [PrimRep] -> Maybe SlotTy
repSlotTy [PrimRep]
reps = case [PrimRep]
reps 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]
_ -> String -> SDoc -> Maybe SlotTy
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"repSlotTy" ([PrimRep] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [PrimRep]
reps)
primRepSlot :: PrimRep -> SlotTy
primRepSlot :: PrimRep -> SlotTy
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
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
where
isWordSlot :: SlotTy -> Bool
isWordSlot SlotTy
Word64Slot = Bool
True
isWordSlot SlotTy
WordSlot = Bool
True
isWordSlot SlotTy
_ = Bool
False
typePrimRep :: HasDebugCallStack => Type -> [PrimRep]
typePrimRep :: HasDebugCallStack => Type -> [PrimRep]
typePrimRep Type
ty = HasDebugCallStack => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [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 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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)
typePrimRep_maybe :: Type -> Maybe [PrimRep]
typePrimRep_maybe :: Type -> Maybe [PrimRep]
typePrimRep_maybe Type
ty = HasDebugCallStack => Type -> Maybe [PrimRep]
Type -> Maybe [PrimRep]
kindPrimRep_maybe (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty)
typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimOrVoidRep
typePrimRep1 :: HasDebugCallStack => Type -> PrimOrVoidRep
typePrimRep1 Type
ty = case HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty of
[] -> PrimOrVoidRep
VoidRep
[PrimRep
rep] -> PrimRep -> PrimOrVoidRep
NVRep PrimRep
rep
[PrimRep]
_ -> String -> SDoc -> PrimOrVoidRep
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"typePrimRep1" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [PrimRep] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty))
typePrimRepU :: HasDebugCallStack => NvUnaryType -> PrimRep
typePrimRepU :: HasDebugCallStack => Type -> PrimRep
typePrimRepU Type
ty = case HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty of
[PrimRep
rep] -> PrimRep
rep
[PrimRep]
_ -> String -> SDoc -> PrimRep
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"typePrimRepU" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [PrimRep] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty))
tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep]
tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep]
tyConPrimRep TyCon
tc
= HasDebugCallStack => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [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
$$ 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
kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep]
kindPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep]
kindPrimRep SDoc
doc Type
ki
| Just Type
runtime_rep <- HasDebugCallStack => Type -> Maybe Type
Type -> Maybe Type
kindRep_maybe Type
ki
= 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
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
doc)
kindPrimRep_maybe :: HasDebugCallStack => Kind -> Maybe [PrimRep]
kindPrimRep_maybe :: HasDebugCallStack => Type -> Maybe [PrimRep]
kindPrimRep_maybe Type
ki
| Just (TypeOrConstraint
_torc, Type
rep) <- Type -> Maybe (TypeOrConstraint, Type)
sORTKind_maybe Type
ki
= Type -> Maybe [PrimRep]
runtimeRepPrimRep_maybe Type
rep
| Bool
otherwise
= String -> SDoc -> Maybe [PrimRep]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"kindPrimRep" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ki)
runtimeRepPrimRep :: HasDebugCallStack => SDoc -> RuntimeRepType -> [PrimRep]
runtimeRepPrimRep :: HasDebugCallStack => 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 -> PromDataConInfo
tyConPromDataConInfo 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
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rr_ty)
runtimeRepPrimRep_maybe :: Type -> Maybe [PrimRep]
runtimeRepPrimRep_maybe :: Type -> Maybe [PrimRep]
runtimeRepPrimRep_maybe Type
rr_ty
| Just Type
rr_ty' <- Type -> Maybe Type
coreView Type
rr_ty
= Type -> Maybe [PrimRep]
runtimeRepPrimRep_maybe Type
rr_ty'
| TyConApp TyCon
rr_dc [Type]
args <- Type
rr_ty
, RuntimeRep [Type] -> [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
$! [Type] -> [PrimRep]
fun [Type]
args
| Bool
otherwise
= Maybe [PrimRep]
forall a. Maybe a
Nothing
primRepToRuntimeRep :: PrimRep -> RuntimeRepType
primRepToRuntimeRep :: PrimRep -> Type
primRepToRuntimeRep PrimRep
rep = case PrimRep
rep of
BoxedRep Maybe Levity
mlev -> case Maybe Levity
mlev of
Maybe Levity
Nothing -> String -> Type
forall a. HasCallStack => String -> a
panic String
"primRepToRuntimeRep: levity polymorphic BoxedRep"
Just Levity
Lifted -> Type
liftedRepTy
Just Levity
Unlifted -> 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 Int
n PrimElemRep
elem -> TyCon -> [Type] -> Type
TyConApp TyCon
vecRepDataConTyCon [Type
n', Type
elem']
where
n' :: Type
n' = case Int
n of
Int
2 -> Type
vec2DataConTy
Int
4 -> Type
vec4DataConTy
Int
8 -> Type
vec8DataConTy
Int
16 -> Type
vec16DataConTy
Int
32 -> Type
vec32DataConTy
Int
64 -> Type
vec64DataConTy
Int
_ -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Disallowed VecCount" (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
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
mightBeFunTy :: Type -> Bool
mightBeFunTy :: Type -> Bool
mightBeFunTy Type
ty
| Type -> Bool
definitelyUnliftedType Type
ty
= Bool
False
| [BoxedRep Maybe Levity
_] <- HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty
, Just TyCon
tc <- Type -> Maybe TyCon
tyConAppTyCon_maybe (Type -> Type
unwrapType Type
ty)
, TyCon -> Bool
isDataTyCon TyCon
tc
= Bool
False
| Bool
otherwise
= Bool
True