module RepType
(
UnaryType, NvUnaryType, isNvUnaryType,
unwrapType,
isVoidTy,
typePrimRep, typePrimRep1,
runtimeRepPrimRep, typePrimRepArgs,
PrimRep(..), primRepToType,
countFunRepArgs, countConRepArgs, tyConPrimRep, tyConPrimRep1,
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 TysWiredIn ( anyTypeOfKind )
import Data.List (foldl', sort)
import qualified Data.IntSet as IS
type NvUnaryType = Type
type UnaryType = Type
isNvUnaryType :: Type -> Bool
isNvUnaryType ty
| [_] <- typePrimRep ty
= True
| otherwise
= False
typePrimRepArgs :: Type -> [PrimRep]
typePrimRepArgs ty
| [] <- reps
= [VoidRep]
| otherwise
= reps
where
reps = typePrimRep ty
unwrapType :: Type -> Type
unwrapType ty
| Just (_, unwrapped)
<- topNormaliseTypeX stepper mappend inner_ty
= unwrapped
| otherwise
= inner_ty
where
inner_ty = go ty
go t | Just t' <- coreView t = go t'
go (ForAllTy _ t) = go t
go (CastTy t _) = go t
go t = t
stepper rec_nts tc tys
| Just (ty', _) <- instNewTyCon_maybe tc tys
= case checkRecTc rec_nts tc of
Just rec_nts' -> NS_Step rec_nts' (go ty') ()
Nothing -> NS_Abort
| otherwise
= NS_Done
countFunRepArgs :: Arity -> Type -> RepArity
countFunRepArgs 0 _
= 0
countFunRepArgs n ty
| FunTy arg res <- unwrapType ty
= length (typePrimRepArgs arg) + countFunRepArgs (n 1) res
| otherwise
= pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty))
countConRepArgs :: DataCon -> RepArity
countConRepArgs dc = go (dataConRepArity dc) (dataConRepType dc)
where
go :: Arity -> Type -> RepArity
go 0 _
= 0
go n ty
| FunTy arg res <- unwrapType ty
= length (typePrimRep arg) + go (n 1) res
| otherwise
= pprPanic "countConRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty))
isVoidTy :: Type -> Bool
isVoidTy = null . typePrimRep
type SortedSlotTys = [SlotTy]
ubxSumRepType :: [[PrimRep]] -> [SlotTy]
ubxSumRepType constrs0
| constrs0 `lengthLessThan` 2
= [WordSlot]
| otherwise
= let
combine_alts :: [SortedSlotTys]
-> SortedSlotTys
combine_alts constrs = foldl' merge [] constrs
merge :: SortedSlotTys -> SortedSlotTys -> SortedSlotTys
merge existing_slots []
= existing_slots
merge [] needed_slots
= needed_slots
merge (es : ess) (s : ss)
| Just s' <- s `fitsIn` es
=
s' : merge ess ss
| s < es
=
s : merge (es : ess) ss
| otherwise
=
es : merge ess (s : ss)
rep :: [PrimRep] -> SortedSlotTys
rep ty = sort (map primRepSlot ty)
sumRep = WordSlot : combine_alts (map rep constrs0)
in
sumRep
layoutUbxSum :: SortedSlotTys
-> [SlotTy]
-> [Int]
layoutUbxSum sum_slots0 arg_slots0 =
go arg_slots0 IS.empty
where
go :: [SlotTy] -> IS.IntSet -> [Int]
go [] _
= []
go (arg : args) used
= let slot_idx = findSlot arg 0 sum_slots0 used
in slot_idx : go args (IS.insert slot_idx used)
findSlot :: SlotTy -> Int -> SortedSlotTys -> IS.IntSet -> Int
findSlot arg slot_idx (slot : slots) useds
| not (IS.member slot_idx useds)
, Just slot == arg `fitsIn` slot
= slot_idx
| otherwise
= findSlot arg (slot_idx + 1) slots useds
findSlot _ _ [] _
= pprPanic "findSlot" (text "Can't find slot" $$ ppr sum_slots0 $$ ppr arg_slots0)
data SlotTy = PtrSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot
deriving (Eq, Ord)
instance Outputable SlotTy where
ppr PtrSlot = text "PtrSlot"
ppr Word64Slot = text "Word64Slot"
ppr WordSlot = text "WordSlot"
ppr DoubleSlot = text "DoubleSlot"
ppr FloatSlot = text "FloatSlot"
typeSlotTy :: UnaryType -> Maybe SlotTy
typeSlotTy ty
| isVoidTy ty
= Nothing
| otherwise
= Just (primRepSlot (typePrimRep1 ty))
primRepSlot :: PrimRep -> SlotTy
primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep")
primRepSlot LiftedRep = PtrSlot
primRepSlot UnliftedRep = PtrSlot
primRepSlot IntRep = WordSlot
primRepSlot WordRep = WordSlot
primRepSlot Int64Rep = Word64Slot
primRepSlot Word64Rep = Word64Slot
primRepSlot AddrRep = WordSlot
primRepSlot FloatRep = FloatSlot
primRepSlot DoubleRep = DoubleSlot
primRepSlot VecRep{} = pprPanic "primRepSlot" (text "No slot for VecRep")
slotPrimRep :: SlotTy -> PrimRep
slotPrimRep PtrSlot = LiftedRep
slotPrimRep Word64Slot = Word64Rep
slotPrimRep WordSlot = WordRep
slotPrimRep DoubleSlot = DoubleRep
slotPrimRep FloatSlot = FloatRep
fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy
fitsIn ty1 ty2
| isWordSlot ty1 && isWordSlot ty2
= Just (max ty1 ty2)
| isFloatSlot ty1 && isFloatSlot ty2
= Just (max ty1 ty2)
| isPtrSlot ty1 && isPtrSlot ty2
= Just PtrSlot
| otherwise
= Nothing
where
isPtrSlot PtrSlot = True
isPtrSlot _ = False
isWordSlot Word64Slot = True
isWordSlot WordSlot = True
isWordSlot _ = False
isFloatSlot DoubleSlot = True
isFloatSlot FloatSlot = True
isFloatSlot _ = False
typePrimRep :: HasDebugCallStack => Type -> [PrimRep]
typePrimRep ty = kindPrimRep (text "typePrimRep" <+>
parens (ppr ty <+> dcolon <+> ppr (typeKind ty)))
(typeKind ty)
typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep
typePrimRep1 ty = case typePrimRep ty of
[] -> VoidRep
[rep] -> rep
_ -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty))
tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep]
tyConPrimRep tc
= kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind)
res_kind
where
res_kind = tyConResKind tc
tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep
tyConPrimRep1 tc = case tyConPrimRep tc of
[] -> VoidRep
[rep] -> rep
_ -> pprPanic "tyConPrimRep1" (ppr tc $$ ppr (tyConPrimRep tc))
kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep]
kindPrimRep doc ki
| Just ki' <- coreView ki
= kindPrimRep doc ki'
kindPrimRep doc (TyConApp typ [runtime_rep])
= ASSERT( typ `hasKey` tYPETyConKey )
runtimeRepPrimRep doc runtime_rep
kindPrimRep doc ki
= pprPanic "kindPrimRep" (ppr ki $$ doc)
runtimeRepPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep]
runtimeRepPrimRep doc rr_ty
| Just rr_ty' <- coreView rr_ty
= runtimeRepPrimRep doc rr_ty'
| TyConApp rr_dc args <- rr_ty
, RuntimeRep fun <- tyConRuntimeRepInfo rr_dc
= fun args
| otherwise
= pprPanic "runtimeRepPrimRep" (doc $$ ppr rr_ty)
primRepToType :: PrimRep -> Type
primRepToType = anyTypeOfKind . tYPE . primRepToRuntimeRep