Implement unboxed sum primitive type
[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
203 | otherwise
204 = -- keep searching for a slot
205 es : merge ess (s : ss)
206
207 -- Nesting unboxed tuples and sums is OK, so we need to flatten first.
208 rep :: Type -> SortedSlotTys
209 rep ty = sort (repTypeSlots (repType ty))
210
211 sumRep = WordSlot : combine_alts (map rep constrs0)
212 -- WordSlot: for the tag of the sum
213 in
214 sumRep
215
216 layout :: SortedSlotTys -- Layout of sum. Does not include tag.
217 -- We assume that they are in increasing order
218 -> [SlotTy] -- Slot types of things we want to map to locations in the
219 -- sum layout
220 -> [Int] -- Where to map 'things' in the sum layout
221 layout sum_slots0 arg_slots0 =
222 go arg_slots0 IS.empty
223 where
224 go :: [SlotTy] -> IS.IntSet -> [Int]
225 go [] _
226 = []
227 go (arg : args) used
228 = let slot_idx = findSlot arg 0 sum_slots0 used
229 in slot_idx : go args (IS.insert slot_idx used)
230
231 findSlot :: SlotTy -> Int -> SortedSlotTys -> IS.IntSet -> Int
232 findSlot arg slot_idx (slot : slots) useds
233 | not (IS.member slot_idx useds)
234 , Just slot == arg `fitsIn` slot
235 = slot_idx
236 | otherwise
237 = findSlot arg (slot_idx + 1) slots useds
238 findSlot _ _ [] _
239 = pprPanic "findSlot" (text "Can't find slot" $$ ppr sum_slots0 $$ ppr arg_slots0)
240
241 --------------------------------------------------------------------------------
242
243 -- We have 3 kinds of slots:
244 --
245 -- - Pointer slot: Only shared between actual pointers to Haskell heap (i.e.
246 -- boxed objects)
247 --
248 -- - Word slots: Shared between IntRep, WordRep, Int64Rep, Word64Rep, AddrRep.
249 --
250 -- - Float slots: Shared between floating point types.
251 --
252 -- - Void slots: Shared between void types. Not used in sums.
253 data SlotTy = PtrSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot
254 deriving (Eq, Ord)
255 -- Constructor order is important! If slot A could fit into slot B
256 -- then slot A must occur first. E.g. FloatSlot before DoubleSlot
257 --
258 -- We are assuming that WordSlot is smaller than or equal to Word64Slot
259 -- (would not be true on a 128-bit machine)
260
261 instance Outputable SlotTy where
262 ppr PtrSlot = text "PtrSlot"
263 ppr Word64Slot = text "Word64Slot"
264 ppr WordSlot = text "WordSlot"
265 ppr DoubleSlot = text "DoubleSlot"
266 ppr FloatSlot = text "FloatSlot"
267
268 typeSlotTy :: UnaryType -> Maybe SlotTy
269 typeSlotTy ty
270 | isVoidTy ty
271 = Nothing
272 | otherwise
273 = Just (primRepSlot (typePrimRep ty))
274
275 primRepSlot :: PrimRep -> SlotTy
276 primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep")
277 primRepSlot PtrRep = PtrSlot
278 primRepSlot IntRep = WordSlot
279 primRepSlot WordRep = WordSlot
280 primRepSlot Int64Rep = Word64Slot
281 primRepSlot Word64Rep = Word64Slot
282 primRepSlot AddrRep = WordSlot
283 primRepSlot FloatRep = FloatSlot
284 primRepSlot DoubleRep = DoubleSlot
285 primRepSlot VecRep{} = pprPanic "primRepSlot" (text "No slot for VecRep")
286
287 -- Used when unarising sum binders (need to give unarised Ids types)
288 slotTyToType :: SlotTy -> Type
289 slotTyToType PtrSlot = anyTypeOfKind liftedTypeKind
290 slotTyToType Word64Slot = int64PrimTy
291 slotTyToType WordSlot = intPrimTy
292 slotTyToType DoubleSlot = doublePrimTy
293 slotTyToType FloatSlot = floatPrimTy
294
295 slotPrimRep :: SlotTy -> PrimRep
296 slotPrimRep PtrSlot = PtrRep
297 slotPrimRep Word64Slot = Word64Rep
298 slotPrimRep WordSlot = WordRep
299 slotPrimRep DoubleSlot = DoubleRep
300 slotPrimRep FloatSlot = FloatRep
301
302 -- | Returns the bigger type if one fits into the other. (commutative)
303 fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy
304 fitsIn ty1 ty2
305 | isWordSlot ty1 && isWordSlot ty2
306 = Just (max ty1 ty2)
307 | isFloatSlot ty1 && isFloatSlot ty2
308 = Just (max ty1 ty2)
309 | isPtrSlot ty1 && isPtrSlot ty2
310 = Just PtrSlot
311 | otherwise
312 = Nothing
313 where
314 isPtrSlot PtrSlot = True
315 isPtrSlot _ = False
316
317 isWordSlot Word64Slot = True
318 isWordSlot WordSlot = True
319 isWordSlot _ = False
320
321 isFloatSlot DoubleSlot = True
322 isFloatSlot FloatSlot = True
323 isFloatSlot _ = False
324
325
326 {- **********************************************************************
327 * *
328 PrimRep
329 * *
330 ********************************************************************** -}
331
332 -- | Discovers the primitive representation of a more abstract 'UnaryType'
333 typePrimRep :: UnaryType -> PrimRep
334 typePrimRep ty = kindPrimRep (text "kindRep ty" <+> ppr ty $$ ppr (typeKind ty))
335 (typeKind ty)
336
337 -- | Find the runtime representation of a 'TyCon'. Defined here to
338 -- avoid module loops. Do not call this on unboxed tuples or sums,
339 -- because they don't /have/ a runtime representation
340 tyConPrimRep :: TyCon -> PrimRep
341 tyConPrimRep tc
342 = ASSERT2( not (isUnboxedTupleTyCon tc), ppr tc )
343 ASSERT2( not (isUnboxedSumTyCon tc), ppr tc )
344 kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind)
345 res_kind
346 where
347 res_kind = tyConResKind tc
348
349 -- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep'
350 -- of values of types of this kind.
351 kindPrimRep :: SDoc -> Kind -> PrimRep
352 kindPrimRep doc ki
353 | Just ki' <- coreViewOneStarKind ki
354 = kindPrimRep doc ki'
355 kindPrimRep _ (TyConApp typ [runtime_rep])
356 = ASSERT( typ `hasKey` tYPETyConKey )
357 go runtime_rep
358 where
359 go rr
360 | Just rr' <- coreView rr
361 = go rr'
362 go (TyConApp rr_dc args)
363 | RuntimeRep fun <- tyConRuntimeRepInfo rr_dc
364 = fun args
365 go rr
366 = pprPanic "kindPrimRep.go" (ppr rr)
367 kindPrimRep doc ki
368 = WARN( True, text "kindPrimRep defaulting to PtrRep on" <+> ppr ki $$ doc )
369 PtrRep -- this can happen legitimately for, e.g., Any