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