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