Merge commit '7b0b9f603bb1215e2b7af23c2404d637b95a4988' as 'hadrian'
[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 data SlotTy = PtrSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot
232 deriving (Eq, Ord)
233 -- Constructor order is important! If slot A could fit into slot B
234 -- then slot A must occur first. E.g. FloatSlot before DoubleSlot
235 --
236 -- We are assuming that WordSlot is smaller than or equal to Word64Slot
237 -- (would not be true on a 128-bit machine)
238
239 instance Outputable SlotTy where
240 ppr PtrSlot = text "PtrSlot"
241 ppr Word64Slot = text "Word64Slot"
242 ppr WordSlot = text "WordSlot"
243 ppr DoubleSlot = text "DoubleSlot"
244 ppr FloatSlot = text "FloatSlot"
245
246 typeSlotTy :: UnaryType -> Maybe SlotTy
247 typeSlotTy ty
248 | isVoidTy ty
249 = Nothing
250 | otherwise
251 = Just (primRepSlot (typePrimRep1 ty))
252
253 primRepSlot :: PrimRep -> SlotTy
254 primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep")
255 primRepSlot LiftedRep = PtrSlot
256 primRepSlot UnliftedRep = PtrSlot
257 primRepSlot IntRep = WordSlot
258 primRepSlot WordRep = WordSlot
259 primRepSlot Int64Rep = Word64Slot
260 primRepSlot Word64Rep = Word64Slot
261 primRepSlot AddrRep = WordSlot
262 primRepSlot FloatRep = FloatSlot
263 primRepSlot DoubleRep = DoubleSlot
264 primRepSlot VecRep{} = pprPanic "primRepSlot" (text "No slot for VecRep")
265
266 slotPrimRep :: SlotTy -> PrimRep
267 slotPrimRep PtrSlot = LiftedRep -- choice between lifted & unlifted seems arbitrary
268 slotPrimRep Word64Slot = Word64Rep
269 slotPrimRep WordSlot = WordRep
270 slotPrimRep DoubleSlot = DoubleRep
271 slotPrimRep FloatSlot = FloatRep
272
273 -- | Returns the bigger type if one fits into the other. (commutative)
274 fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy
275 fitsIn ty1 ty2
276 | isWordSlot ty1 && isWordSlot ty2
277 = Just (max ty1 ty2)
278 | isFloatSlot ty1 && isFloatSlot ty2
279 = Just (max ty1 ty2)
280 | isPtrSlot ty1 && isPtrSlot ty2
281 = Just PtrSlot
282 | otherwise
283 = Nothing
284 where
285 isPtrSlot PtrSlot = True
286 isPtrSlot _ = False
287
288 isWordSlot Word64Slot = True
289 isWordSlot WordSlot = True
290 isWordSlot _ = False
291
292 isFloatSlot DoubleSlot = True
293 isFloatSlot FloatSlot = True
294 isFloatSlot _ = False
295
296
297 {- **********************************************************************
298 * *
299 PrimRep
300 * *
301 ********************************************************************** -}
302
303 -- | Discovers the primitive representation of a 'Type'. Returns
304 -- a list of 'PrimRep': it's a list because of the possibility of
305 -- no runtime representation (void) or multiple (unboxed tuple/sum)
306 typePrimRep :: HasDebugCallStack => Type -> [PrimRep]
307 typePrimRep ty = kindPrimRep (text "typePrimRep" <+>
308 parens (ppr ty <+> dcolon <+> ppr (typeKind ty)))
309 (typeKind ty)
310
311 -- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output;
312 -- an empty list of PrimReps becomes a VoidRep
313 typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep
314 typePrimRep1 ty = case typePrimRep ty of
315 [] -> VoidRep
316 [rep] -> rep
317 _ -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty))
318
319 -- | Find the runtime representation of a 'TyCon'. Defined here to
320 -- avoid module loops. Returns a list of the register shapes necessary.
321 tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep]
322 tyConPrimRep tc
323 = kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind)
324 res_kind
325 where
326 res_kind = tyConResKind tc
327
328 -- | Like 'tyConPrimRep', but assumed that there is precisely zero or
329 -- one 'PrimRep' output
330 tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep
331 tyConPrimRep1 tc = case tyConPrimRep tc of
332 [] -> VoidRep
333 [rep] -> rep
334 _ -> pprPanic "tyConPrimRep1" (ppr tc $$ ppr (tyConPrimRep tc))
335
336 -- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's
337 -- of values of types of this kind.
338 kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep]
339 kindPrimRep doc ki
340 | Just ki' <- coreView ki
341 = kindPrimRep doc ki'
342 kindPrimRep doc (TyConApp typ [runtime_rep])
343 = ASSERT( typ `hasKey` tYPETyConKey )
344 runtimeRepPrimRep doc runtime_rep
345 kindPrimRep doc ki
346 = pprPanic "kindPrimRep" (ppr ki $$ doc)
347
348 -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that
349 -- it encodes.
350 runtimeRepPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep]
351 runtimeRepPrimRep doc rr_ty
352 | Just rr_ty' <- coreView rr_ty
353 = runtimeRepPrimRep doc rr_ty'
354 | TyConApp rr_dc args <- rr_ty
355 , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc
356 = fun args
357 | otherwise
358 = pprPanic "runtimeRepPrimRep" (doc $$ ppr rr_ty)
359
360 -- | Convert a PrimRep back to a Type. Used only in the unariser to give types
361 -- to fresh Ids. Really, only the type's representation matters.
362 primRepToType :: PrimRep -> Type
363 primRepToType = anyTypeOfKind . tYPE . primRepToRuntimeRep