{-# LANGUAGE FlexibleContexts #-}
module GHC.Types.RepType
  (
    
    UnaryType, NvUnaryType, isNvUnaryType,
    unwrapType,
    
    isZeroBitTy,
    
    typePrimRep, typePrimRep1,
    runtimeRepPrimRep, typePrimRepArgs,
    PrimRep(..), primRepToType, primRepToRuntimeRep,
    countFunRepArgs, countConRepArgs, dataConRuntimeRepStrictness,
    tyConPrimRep, tyConPrimRep1,
    runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe,
    
    ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..),
    slotPrimRep, primRepSlot,
    
    mightBeFunTy
    ) 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
_] <- (() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty
  = Bool
True
  | Bool
otherwise
  = Bool
False
typePrimRepArgs :: HasDebugCallStack => Type -> [PrimRep]
typePrimRepArgs :: (() :: Constraint) => Type -> [PrimRep]
typePrimRepArgs Type
ty
  | [] <- [PrimRep]
reps
  = [PrimRep
VoidRep]
  | Bool
otherwise
  = [PrimRep]
reps
  where
    reps :: [PrimRep]
reps = (() :: Constraint) => 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 :: Int -> Type -> Int
countFunRepArgs Int
0 Type
_
  = Int
0
countFunRepArgs Int
n Type
ty
  | FunTy AnonArgFlag
_ 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 ((() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRepArgs Type
arg) 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, (() :: Constraint) => 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 AnonArgFlag
_ 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 ((() :: Constraint) => 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, (() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty))
dataConRuntimeRepStrictness :: HasDebugCallStack => DataCon -> [StrictnessMark]
dataConRuntimeRepStrictness :: (() :: Constraint) => 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
      
      |  
        ((() :: Constraint) => 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 ((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 = (() :: Constraint) => 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 :: (() :: Constraint) => 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
. (() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep
type SortedSlotTys = [SlotTy]
ubxSumRepType :: [[PrimRep]] -> [SlotTy]
ubxSumRepType :: [[PrimRep]] -> [SlotTy]
ubxSumRepType [[PrimRep]]
constrs0
  
  
  
  
  | [[PrimRep]]
constrs0 [[PrimRep]] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthLessThan` Int
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 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 :: [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 :: HasDebugCallStack
             => SortedSlotTys 
                              
             -> [SlotTy]      
                              
             -> [Int]         
layoutUbxSum :: (() :: Constraint) => [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
text String
"Can't find slot" SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"sum_slots:" SDoc -> SDoc -> SDoc
<> [SlotTy] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SlotTy]
sum_slots0
                                                    SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"arg_slots:" SDoc -> SDoc -> SDoc
<> [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
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"
  ppr (VecSlot Int
n PrimElemRep
e)   = String -> SDoc
text String
"VecSlot" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n SDoc -> SDoc -> SDoc
<+> PrimElemRep -> SDoc
forall a. Outputable a => a -> SDoc
ppr PrimElemRep
e
typeSlotTy :: UnaryType -> Maybe SlotTy
typeSlotTy :: Type -> Maybe SlotTy
typeSlotTy Type
ty
  | (() :: Constraint) => 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 ((() :: Constraint) => 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 Int
n PrimElemRep
e) = Int -> PrimElemRep -> SlotTy
VecSlot Int
n PrimElemRep
e
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
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 :: (() :: Constraint) => Type -> [PrimRep]
typePrimRep Type
ty = (() :: Constraint) => 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 ((() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
ty)))
                             ((() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
ty)
typePrimRep_maybe :: Type -> Maybe [PrimRep]
typePrimRep_maybe :: Type -> Maybe [PrimRep]
typePrimRep_maybe Type
ty = (() :: Constraint) => Type -> Maybe [PrimRep]
Type -> Maybe [PrimRep]
kindPrimRep_maybe ((() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
ty)
typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep
typePrimRep1 :: (() :: Constraint) => Type -> PrimRep
typePrimRep1 Type
ty = case (() :: Constraint) => 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 ((() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty))
tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep]
tyConPrimRep :: (() :: Constraint) => TyCon -> [PrimRep]
tyConPrimRep TyCon
tc
  = (() :: Constraint) => 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 :: (() :: Constraint) => TyCon -> PrimRep
tyConPrimRep1 TyCon
tc = case (() :: Constraint) => 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 ((() :: Constraint) => TyCon -> [PrimRep]
TyCon -> [PrimRep]
tyConPrimRep TyCon
tc))
kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep]
kindPrimRep :: (() :: Constraint) => SDoc -> Type -> [PrimRep]
kindPrimRep SDoc
doc Type
ki
  | Just Type
ki' <- Type -> Maybe Type
coreView Type
ki
  = (() :: Constraint) => 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
$
    (() :: Constraint) => 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)
kindPrimRep_maybe :: HasDebugCallStack => Kind -> Maybe [PrimRep]
kindPrimRep_maybe :: (() :: Constraint) => Type -> Maybe [PrimRep]
kindPrimRep_maybe Type
ki
  | Just Type
ki' <- Type -> Maybe Type
coreView Type
ki
  = (() :: Constraint) => Type -> Maybe [PrimRep]
Type -> Maybe [PrimRep]
kindPrimRep_maybe Type
ki'
kindPrimRep_maybe (TyConApp TyCon
typ [Type
runtime_rep])
  = Bool -> Maybe [PrimRep] -> Maybe [PrimRep]
forall a. HasCallStack => Bool -> a -> a
assert (TyCon
typ TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
tYPETyConKey) (Maybe [PrimRep] -> Maybe [PrimRep])
-> Maybe [PrimRep] -> Maybe [PrimRep]
forall a b. (a -> b) -> a -> b
$
    Type -> Maybe [PrimRep]
runtimeRepPrimRep_maybe Type
runtime_rep
kindPrimRep_maybe Type
_ki
  = Maybe [PrimRep]
forall a. Maybe a
Nothing
runtimeRepPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep]
runtimeRepPrimRep :: (() :: Constraint) => SDoc -> Type -> [PrimRep]
runtimeRepPrimRep SDoc
doc Type
rr_ty
  | Just Type
rr_ty' <- Type -> Maybe Type
coreView Type
rr_ty
  = (() :: Constraint) => 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)
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 -> RuntimeRepInfo
tyConRuntimeRepInfo 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 -> 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 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
  | [PrimRep
LiftedRep] <- (() :: Constraint) => 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