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