Introduce Int16# and Word16#
[ghc.git] / compiler / simplStg / RepType.hs
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE FlexibleContexts #-}
3
4 module RepType
5 (
6 -- * Code generator views onto Types
7 UnaryType, NvUnaryType, isNvUnaryType,
8 unwrapType,
9
10 -- * Predicates on types
11 isVoidTy,
12
13 -- * Type representation for the code generator
14 typePrimRep, typePrimRep1,
15 runtimeRepPrimRep, typePrimRepArgs,
16 PrimRep(..), primRepToType,
17 countFunRepArgs, countConRepArgs, tyConPrimRep, tyConPrimRep1,
18
19 -- * Unboxed sum representation type
20 ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..),
21 slotPrimRep, primRepSlot
22 ) where
23
24 #include "HsVersions.h"
25
26 import GhcPrelude
27
28 import BasicTypes (Arity, RepArity)
29 import DataCon
30 import Outputable
31 import PrelNames
32 import Coercion
33 import TyCon
34 import TyCoRep
35 import Type
36 import Util
37 import TysPrim
38 import {-# SOURCE #-} TysWiredIn ( anyTypeOfKind )
39
40 import Data.List (foldl', sort)
41 import qualified Data.IntSet as IS
42
43 {- **********************************************************************
44 * *
45 Representation types
46 * *
47 ********************************************************************** -}
48
49 type NvUnaryType = Type
50 type UnaryType = Type
51 -- Both are always a value type; i.e. its kind is TYPE rr
52 -- for some rr; moreover the rr is never a variable.
53 --
54 -- NvUnaryType : never an unboxed tuple or sum, or void
55 --
56 -- UnaryType : never an unboxed tuple or sum;
57 -- can be Void# or (# #)
58
59 isNvUnaryType :: Type -> Bool
60 isNvUnaryType ty
61 | [_] <- typePrimRep ty
62 = True
63 | otherwise
64 = False
65
66 -- INVARIANT: the result list is never empty.
67 typePrimRepArgs :: Type -> [PrimRep]
68 typePrimRepArgs ty
69 | [] <- reps
70 = [VoidRep]
71 | otherwise
72 = reps
73 where
74 reps = typePrimRep ty
75
76 -- | Gets rid of the stuff that prevents us from understanding the
77 -- runtime representation of a type. Including:
78 -- 1. Casts
79 -- 2. Newtypes
80 -- 3. Foralls
81 -- 4. Synonyms
82 -- But not type/data families, because we don't have the envs to hand.
83 unwrapType :: Type -> Type
84 unwrapType ty
85 | Just (_, unwrapped)
86 <- topNormaliseTypeX stepper mappend inner_ty
87 = unwrapped
88 | otherwise
89 = inner_ty
90 where
91 inner_ty = go ty
92
93 go t | Just t' <- coreView t = go t'
94 go (ForAllTy _ t) = go t
95 go (CastTy t _) = go t
96 go t = t
97
98 -- cf. Coercion.unwrapNewTypeStepper
99 stepper rec_nts tc tys
100 | Just (ty', _) <- instNewTyCon_maybe tc tys
101 = case checkRecTc rec_nts tc of
102 Just rec_nts' -> NS_Step rec_nts' (go ty') ()
103 Nothing -> NS_Abort -- infinite newtypes
104 | otherwise
105 = NS_Done
106
107 countFunRepArgs :: Arity -> Type -> RepArity
108 countFunRepArgs 0 _
109 = 0
110 countFunRepArgs n ty
111 | FunTy arg res <- unwrapType ty
112 = length (typePrimRepArgs arg) + countFunRepArgs (n - 1) res
113 | otherwise
114 = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty))
115
116 countConRepArgs :: DataCon -> RepArity
117 countConRepArgs dc = go (dataConRepArity dc) (dataConRepType dc)
118 where
119 go :: Arity -> Type -> RepArity
120 go 0 _
121 = 0
122 go n ty
123 | FunTy arg res <- unwrapType ty
124 = length (typePrimRep arg) + go (n - 1) res
125 | otherwise
126 = pprPanic "countConRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty))
127
128 -- | True if the type has zero width.
129 isVoidTy :: Type -> Bool
130 isVoidTy = null . typePrimRep
131
132
133 {- **********************************************************************
134 * *
135 Unboxed sums
136 See Note [Translating unboxed sums to unboxed tuples] in UnariseStg.hs
137 * *
138 ********************************************************************** -}
139
140 type SortedSlotTys = [SlotTy]
141
142 -- | Given the arguments of a sum type constructor application,
143 -- return the unboxed sum rep type.
144 --
145 -- E.g.
146 --
147 -- (# Int# | Maybe Int | (# Int#, Float# #) #)
148 --
149 -- We call `ubxSumRepType [ [IntRep], [LiftedRep], [IntRep, FloatRep] ]`,
150 -- which returns [WordSlot, PtrSlot, WordSlot, FloatSlot]
151 --
152 -- INVARIANT: Result slots are sorted (via Ord SlotTy), except that at the head
153 -- of the list we have the slot for the tag.
154 ubxSumRepType :: [[PrimRep]] -> [SlotTy]
155 ubxSumRepType constrs0
156 -- These first two cases never classify an actual unboxed sum, which always
157 -- has at least two disjuncts. But it could happen if a user writes, e.g.,
158 -- forall (a :: TYPE (SumRep [IntRep])). ...
159 -- which could never be instantiated. We still don't want to panic.
160 | constrs0 `lengthLessThan` 2
161 = [WordSlot]
162
163 | otherwise
164 = let
165 combine_alts :: [SortedSlotTys] -- slots of constructors
166 -> SortedSlotTys -- final slots
167 combine_alts constrs = foldl' merge [] constrs
168
169 merge :: SortedSlotTys -> SortedSlotTys -> SortedSlotTys
170 merge existing_slots []
171 = existing_slots
172 merge [] needed_slots
173 = needed_slots
174 merge (es : ess) (s : ss)
175 | Just s' <- s `fitsIn` es
176 = -- found a slot, use it
177 s' : merge ess ss
178 | s < es
179 = -- we need a new slot and this is the right place for it
180 s : merge (es : ess) ss
181 | otherwise
182 = -- keep searching for a slot
183 es : merge ess (s : ss)
184
185 -- Nesting unboxed tuples and sums is OK, so we need to flatten first.
186 rep :: [PrimRep] -> SortedSlotTys
187 rep ty = sort (map primRepSlot ty)
188
189 sumRep = WordSlot : combine_alts (map rep constrs0)
190 -- WordSlot: for the tag of the sum
191 in
192 sumRep
193
194 layoutUbxSum :: SortedSlotTys -- Layout of sum. Does not include tag.
195 -- We assume that they are in increasing order
196 -> [SlotTy] -- Slot types of things we want to map to locations in the
197 -- sum layout
198 -> [Int] -- Where to map 'things' in the sum layout
199 layoutUbxSum sum_slots0 arg_slots0 =
200 go arg_slots0 IS.empty
201 where
202 go :: [SlotTy] -> IS.IntSet -> [Int]
203 go [] _
204 = []
205 go (arg : args) used
206 = let slot_idx = findSlot arg 0 sum_slots0 used
207 in slot_idx : go args (IS.insert slot_idx used)
208
209 findSlot :: SlotTy -> Int -> SortedSlotTys -> IS.IntSet -> Int
210 findSlot arg slot_idx (slot : slots) useds
211 | not (IS.member slot_idx useds)
212 , Just slot == arg `fitsIn` slot
213 = slot_idx
214 | otherwise
215 = findSlot arg (slot_idx + 1) slots useds
216 findSlot _ _ [] _
217 = pprPanic "findSlot" (text "Can't find slot" $$ ppr sum_slots0 $$ ppr arg_slots0)
218
219 --------------------------------------------------------------------------------
220
221 -- We have 3 kinds of slots:
222 --
223 -- - Pointer slot: Only shared between actual pointers to Haskell heap (i.e.
224 -- boxed objects)
225 --
226 -- - Word slots: Shared between IntRep, WordRep, Int64Rep, Word64Rep, AddrRep.
227 --
228 -- - Float slots: Shared between floating point types.
229 --
230 -- - Void slots: Shared between void types. Not used in sums.
231 --
232 -- TODO(michalt): We should probably introduce `SlotTy`s for 8-/16-/32-bit
233 -- values, so that we can pack things more tightly.
234 data SlotTy = PtrSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot
235 deriving (Eq, Ord)
236 -- Constructor order is important! If slot A could fit into slot B
237 -- then slot A must occur first. E.g. FloatSlot before DoubleSlot
238 --
239 -- We are assuming that WordSlot is smaller than or equal to Word64Slot
240 -- (would not be true on a 128-bit machine)
241
242 instance Outputable SlotTy where
243 ppr PtrSlot = text "PtrSlot"
244 ppr Word64Slot = text "Word64Slot"
245 ppr WordSlot = text "WordSlot"
246 ppr DoubleSlot = text "DoubleSlot"
247 ppr FloatSlot = text "FloatSlot"
248
249 typeSlotTy :: UnaryType -> Maybe SlotTy
250 typeSlotTy ty
251 | isVoidTy ty
252 = Nothing
253 | otherwise
254 = Just (primRepSlot (typePrimRep1 ty))
255
256 primRepSlot :: PrimRep -> SlotTy
257 primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep")
258 primRepSlot LiftedRep = PtrSlot
259 primRepSlot UnliftedRep = PtrSlot
260 primRepSlot IntRep = WordSlot
261 primRepSlot Int8Rep = WordSlot
262 primRepSlot Int16Rep = WordSlot
263 primRepSlot Int64Rep = Word64Slot
264 primRepSlot WordRep = WordSlot
265 primRepSlot Word8Rep = WordSlot
266 primRepSlot Word16Rep = WordSlot
267 primRepSlot Word64Rep = Word64Slot
268 primRepSlot AddrRep = WordSlot
269 primRepSlot FloatRep = FloatSlot
270 primRepSlot DoubleRep = DoubleSlot
271 primRepSlot VecRep{} = pprPanic "primRepSlot" (text "No slot for VecRep")
272
273 slotPrimRep :: SlotTy -> PrimRep
274 slotPrimRep PtrSlot = LiftedRep -- choice between lifted & unlifted seems arbitrary
275 slotPrimRep Word64Slot = Word64Rep
276 slotPrimRep WordSlot = WordRep
277 slotPrimRep DoubleSlot = DoubleRep
278 slotPrimRep FloatSlot = FloatRep
279
280 -- | Returns the bigger type if one fits into the other. (commutative)
281 fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy
282 fitsIn ty1 ty2
283 | isWordSlot ty1 && isWordSlot ty2
284 = Just (max ty1 ty2)
285 | isFloatSlot ty1 && isFloatSlot ty2
286 = Just (max ty1 ty2)
287 | isPtrSlot ty1 && isPtrSlot ty2
288 = Just PtrSlot
289 | otherwise
290 = Nothing
291 where
292 isPtrSlot PtrSlot = True
293 isPtrSlot _ = False
294
295 isWordSlot Word64Slot = True
296 isWordSlot WordSlot = True
297 isWordSlot _ = False
298
299 isFloatSlot DoubleSlot = True
300 isFloatSlot FloatSlot = True
301 isFloatSlot _ = False
302
303
304 {- **********************************************************************
305 * *
306 PrimRep
307 * *
308 ********************************************************************** -}
309
310 -- | Discovers the primitive representation of a 'Type'. Returns
311 -- a list of 'PrimRep': it's a list because of the possibility of
312 -- no runtime representation (void) or multiple (unboxed tuple/sum)
313 typePrimRep :: HasDebugCallStack => Type -> [PrimRep]
314 typePrimRep ty = kindPrimRep (text "typePrimRep" <+>
315 parens (ppr ty <+> dcolon <+> ppr (typeKind ty)))
316 (typeKind ty)
317
318 -- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output;
319 -- an empty list of PrimReps becomes a VoidRep
320 typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep
321 typePrimRep1 ty = case typePrimRep ty of
322 [] -> VoidRep
323 [rep] -> rep
324 _ -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty))
325
326 -- | Find the runtime representation of a 'TyCon'. Defined here to
327 -- avoid module loops. Returns a list of the register shapes necessary.
328 tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep]
329 tyConPrimRep tc
330 = kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind)
331 res_kind
332 where
333 res_kind = tyConResKind tc
334
335 -- | Like 'tyConPrimRep', but assumed that there is precisely zero or
336 -- one 'PrimRep' output
337 tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep
338 tyConPrimRep1 tc = case tyConPrimRep tc of
339 [] -> VoidRep
340 [rep] -> rep
341 _ -> pprPanic "tyConPrimRep1" (ppr tc $$ ppr (tyConPrimRep tc))
342
343 -- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's
344 -- of values of types of this kind.
345 kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep]
346 kindPrimRep doc ki
347 | Just ki' <- coreView ki
348 = kindPrimRep doc ki'
349 kindPrimRep doc (TyConApp typ [runtime_rep])
350 = ASSERT( typ `hasKey` tYPETyConKey )
351 runtimeRepPrimRep doc runtime_rep
352 kindPrimRep doc ki
353 = pprPanic "kindPrimRep" (ppr ki $$ doc)
354
355 -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that
356 -- it encodes.
357 runtimeRepPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep]
358 runtimeRepPrimRep doc rr_ty
359 | Just rr_ty' <- coreView rr_ty
360 = runtimeRepPrimRep doc rr_ty'
361 | TyConApp rr_dc args <- rr_ty
362 , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc
363 = fun args
364 | otherwise
365 = pprPanic "runtimeRepPrimRep" (doc $$ ppr rr_ty)
366
367 -- | Convert a PrimRep back to a Type. Used only in the unariser to give types
368 -- to fresh Ids. Really, only the type's representation matters.
369 primRepToType :: PrimRep -> Type
370 primRepToType = anyTypeOfKind . tYPE . primRepToRuntimeRep