RepType.hs 12.1 KB
Newer Older
1
{-# LANGUAGE CPP #-}
Ben Gamari's avatar
Ben Gamari committed
2
{-# LANGUAGE FlexibleContexts #-}
3 4

module RepType
Richard Eisenberg's avatar
Richard Eisenberg committed
5 6
  (
    -- * Code generator views onto Types
7
    UnaryType, NvUnaryType, isNvUnaryType,
Richard Eisenberg's avatar
Richard Eisenberg committed
8
    unwrapType,
9 10

    -- * Predicates on types
Richard Eisenberg's avatar
Richard Eisenberg committed
11
    isVoidTy,
12 13

    -- * Type representation for the code generator
Richard Eisenberg's avatar
Richard Eisenberg committed
14 15 16 17
    typePrimRep, typePrimRep1,
    runtimeRepPrimRep, typePrimRepArgs,
    PrimRep(..), primRepToType,
    countFunRepArgs, countConRepArgs, tyConPrimRep, tyConPrimRep1,
18 19

    -- * Unboxed sum representation type
Richard Eisenberg's avatar
Richard Eisenberg committed
20 21
    ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..),
    slotPrimRep, primRepSlot
22 23 24 25
  ) where

#include "HsVersions.h"

26 27
import GhcPrelude

28 29 30 31
import BasicTypes (Arity, RepArity)
import DataCon
import Outputable
import PrelNames
Richard Eisenberg's avatar
Richard Eisenberg committed
32
import Coercion
33 34 35 36
import TyCon
import TyCoRep
import Type
import Util
Richard Eisenberg's avatar
Richard Eisenberg committed
37 38
import TysPrim
import {-# SOURCE #-} TysWiredIn ( anyTypeOfKind )
39

David Eichmann's avatar
David Eichmann committed
40
import Data.List (sort)
41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56
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;
Richard Eisenberg's avatar
Richard Eisenberg committed
57
     --                 can be Void# or (# #)
58 59 60

isNvUnaryType :: Type -> Bool
isNvUnaryType ty
Richard Eisenberg's avatar
Richard Eisenberg committed
61 62 63 64
  | [_] <- typePrimRep ty
  = True
  | otherwise
  = False
65 66

-- INVARIANT: the result list is never empty.
67
typePrimRepArgs :: HasDebugCallStack => Type -> [PrimRep]
Richard Eisenberg's avatar
Richard Eisenberg committed
68 69 70 71 72
typePrimRepArgs ty
  | [] <- reps
  = [VoidRep]
  | otherwise
  = reps
73
  where
Richard Eisenberg's avatar
Richard Eisenberg committed
74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
    reps = typePrimRep 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 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

     -- cf. Coercion.unwrapNewTypeStepper
    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   -- infinite newtypes
      | otherwise
      = NS_Done
106 107 108 109 110

countFunRepArgs :: Arity -> Type -> RepArity
countFunRepArgs 0 _
  = 0
countFunRepArgs n ty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
111
  | FunTy _ arg res <- unwrapType ty
Richard Eisenberg's avatar
Richard Eisenberg committed
112
  = length (typePrimRepArgs arg) + countFunRepArgs (n - 1) res
113
  | otherwise
Richard Eisenberg's avatar
Richard Eisenberg committed
114
  = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty))
115 116 117 118 119 120 121 122

countConRepArgs :: DataCon -> RepArity
countConRepArgs dc = go (dataConRepArity dc) (dataConRepType dc)
  where
    go :: Arity -> Type -> RepArity
    go 0 _
      = 0
    go n ty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
123
      | FunTy _ arg res <- unwrapType ty
Richard Eisenberg's avatar
Richard Eisenberg committed
124
      = length (typePrimRep arg) + go (n - 1) res
125
      | otherwise
Richard Eisenberg's avatar
Richard Eisenberg committed
126
      = pprPanic "countConRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty))
127 128 129

-- | True if the type has zero width.
isVoidTy :: Type -> Bool
Richard Eisenberg's avatar
Richard Eisenberg committed
130
isVoidTy = null . typePrimRep
131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146


{- **********************************************************************
*                                                                       *
                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.
--
Richard Eisenberg's avatar
Richard Eisenberg committed
147
--   (# Int# | Maybe Int | (# Int#, Float# #) #)
148
--
Richard Eisenberg's avatar
Richard Eisenberg committed
149 150
-- We call `ubxSumRepType [ [IntRep], [LiftedRep], [IntRep, FloatRep] ]`,
-- which returns [WordSlot, PtrSlot, WordSlot, FloatSlot]
151 152 153
--
-- INVARIANT: Result slots are sorted (via Ord SlotTy), except that at the head
-- of the list we have the slot for the tag.
Richard Eisenberg's avatar
Richard Eisenberg committed
154 155 156 157 158 159
ubxSumRepType :: [[PrimRep]] -> [SlotTy]
ubxSumRepType 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.
160
  | constrs0 `lengthLessThan` 2
Richard Eisenberg's avatar
Richard Eisenberg committed
161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199
  = [WordSlot]

  | otherwise
  = let
      combine_alts :: [SortedSlotTys]  -- slots of constructors
                   -> SortedSlotTys    -- final slots
      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
        = -- found a slot, use it
          s' : merge ess ss
        | s < es
        = -- we need a new slot and this is the right place for it
          s : merge (es : ess) ss
        | otherwise
        = -- keep searching for a slot
          es : merge ess (s : ss)

      -- Nesting unboxed tuples and sums is OK, so we need to flatten first.
      rep :: [PrimRep] -> SortedSlotTys
      rep ty = sort (map primRepSlot ty)

      sumRep = WordSlot : combine_alts (map rep constrs0)
               -- WordSlot: for the tag of the sum
    in
      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 sum_slots0 arg_slots0 =
200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230
    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)

--------------------------------------------------------------------------------

-- 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.
Michal Terepeta's avatar
Michal Terepeta committed
231 232 233
--
-- TODO(michalt): We should probably introduce `SlotTy`s for 8-/16-/32-bit
-- values, so that we can pack things more tightly.
234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253
data SlotTy = PtrSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot
  deriving (Eq, 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 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
Richard Eisenberg's avatar
Richard Eisenberg committed
254
  = Just (primRepSlot (typePrimRep1 ty))
255 256 257

primRepSlot :: PrimRep -> SlotTy
primRepSlot VoidRep     = pprPanic "primRepSlot" (text "No slot for VoidRep")
Richard Eisenberg's avatar
Richard Eisenberg committed
258 259
primRepSlot LiftedRep   = PtrSlot
primRepSlot UnliftedRep = PtrSlot
260
primRepSlot IntRep      = WordSlot
Michal Terepeta's avatar
Michal Terepeta committed
261
primRepSlot Int8Rep     = WordSlot
Abhiroop Sarkar's avatar
Abhiroop Sarkar committed
262
primRepSlot Int16Rep    = WordSlot
Ben Gamari's avatar
Ben Gamari committed
263
primRepSlot Int64Rep    = Word64Slot
Michal Terepeta's avatar
Michal Terepeta committed
264 265
primRepSlot WordRep     = WordSlot
primRepSlot Word8Rep    = WordSlot
Abhiroop Sarkar's avatar
Abhiroop Sarkar committed
266
primRepSlot Word16Rep   = WordSlot
267 268 269 270 271 272 273
primRepSlot Word64Rep   = Word64Slot
primRepSlot AddrRep     = WordSlot
primRepSlot FloatRep    = FloatSlot
primRepSlot DoubleRep   = DoubleSlot
primRepSlot VecRep{}    = pprPanic "primRepSlot" (text "No slot for VecRep")

slotPrimRep :: SlotTy -> PrimRep
Richard Eisenberg's avatar
Richard Eisenberg committed
274
slotPrimRep PtrSlot     = LiftedRep   -- choice between lifted & unlifted seems arbitrary
275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309
slotPrimRep Word64Slot  = Word64Rep
slotPrimRep WordSlot    = WordRep
slotPrimRep DoubleSlot  = DoubleRep
slotPrimRep FloatSlot   = FloatRep

-- | Returns the bigger type if one fits into the other. (commutative)
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


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

Richard Eisenberg's avatar
Richard Eisenberg committed
310 311 312 313 314 315
-- | 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 ty = kindPrimRep (text "typePrimRep" <+>
                              parens (ppr ty <+> dcolon <+> ppr (typeKind ty)))
316 317
                             (typeKind ty)

Richard Eisenberg's avatar
Richard Eisenberg committed
318 319 320 321 322 323 324 325
-- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output;
-- an empty list of PrimReps becomes a VoidRep
typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep
typePrimRep1 ty = case typePrimRep ty of
  []    -> VoidRep
  [rep] -> rep
  _     -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty))

326
-- | Find the runtime representation of a 'TyCon'. Defined here to
Richard Eisenberg's avatar
Richard Eisenberg committed
327 328
-- avoid module loops. Returns a list of the register shapes necessary.
tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep]
329
tyConPrimRep tc
Richard Eisenberg's avatar
Richard Eisenberg committed
330
  = kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind)
331 332 333 334
                res_kind
  where
    res_kind = tyConResKind tc

Richard Eisenberg's avatar
Richard Eisenberg committed
335 336 337 338 339 340 341 342 343
-- | Like 'tyConPrimRep', but assumed that there is precisely zero or
-- one 'PrimRep' output
tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep
tyConPrimRep1 tc = case tyConPrimRep tc of
  []    -> VoidRep
  [rep] -> rep
  _     -> pprPanic "tyConPrimRep1" (ppr tc $$ ppr (tyConPrimRep tc))

-- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's
344
-- of values of types of this kind.
Richard Eisenberg's avatar
Richard Eisenberg committed
345
kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep]
346
kindPrimRep doc ki
Ben Gamari's avatar
Ben Gamari committed
347
  | Just ki' <- coreView ki
348
  = kindPrimRep doc ki'
Richard Eisenberg's avatar
Richard Eisenberg committed
349
kindPrimRep doc (TyConApp typ [runtime_rep])
350
  = ASSERT( typ `hasKey` tYPETyConKey )
Richard Eisenberg's avatar
Richard Eisenberg committed
351
    runtimeRepPrimRep doc runtime_rep
352
kindPrimRep doc ki
Richard Eisenberg's avatar
Richard Eisenberg committed
353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370
  = pprPanic "kindPrimRep" (ppr ki $$ doc)

-- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that
-- it encodes.
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)

-- | 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 = anyTypeOfKind . tYPE . primRepToRuntimeRep