@@ -1,5 +1,4077 @@
1+diff --git a/compiler/GHC/Core/Map/Expr.hs b/compiler/GHC/Core/Map/Expr.hs
2+new file mode 100644
3+index 0000000000..04c786deec
4+--- /dev/null
5++++ b/compiler/GHC/Core/Map/Expr.hs
6+@@ -0,0 +1,392 @@
7++{-# LANGUAGE CPP #-}
8++{-# LANGUAGE FlexibleContexts #-}
9++{-# LANGUAGE FlexibleInstances #-}
10++{-# LANGUAGE RankNTypes #-}
11++{-# LANGUAGE ScopedTypeVariables #-}
12++{-# LANGUAGE TypeFamilies #-}
13++{-# LANGUAGE UndecidableInstances #-}
14++
15++{-
16++(c) The University of Glasgow 2006
17++(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
18++-}
19++
20++{-# OPTIONS_GHC -Wno-orphans #-}
21++ -- Eq (DeBruijn CoreExpr) and Eq (DeBruijn CoreAlt)
22++
23++module GHC.Core.Map.Expr (
24++ -- * Maps over Core expressions
25++ CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,
26++ -- * 'TrieMap' class reexports
27++ TrieMap(..), insertTM, deleteTM,
28++ lkDFreeVar, xtDFreeVar,
29++ lkDNamed, xtDNamed,
30++ (>.>), (|>), (|>>),
31++ ) where
32++
33++#include "HsVersions.h"
34++
35++import GHC.Prelude
36++
37++import GHC.Data.TrieMap
38++import GHC.Core.Map.Type
39++import GHC.Core
40++import GHC.Core.Type
41++import GHC.Types.Var
42++
43++import GHC.Utils.Misc
44++import GHC.Utils.Outputable
45++
46++import qualified Data.Map as Map
47++import GHC.Types.Name.Env
48++import Control.Monad( (>=>) )
49++
50++{-
51++This module implements TrieMaps over Core related data structures
52++like CoreExpr or Type. It is built on the Tries from the TrieMap
53++module.
54++
55++The code is very regular and boilerplate-like, but there is
56++some neat handling of *binders*. In effect they are deBruijn
57++numbered on the fly.
58++
59++
60++-}
61++
62++----------------------
63++-- Recall that
64++-- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c
65++
66++-- The CoreMap makes heavy use of GenMap. However the CoreMap Types are not
67++-- known when defining GenMap so we can only specialize them here.
68++
69++{-# SPECIALIZE lkG :: Key CoreMapX -> CoreMapG a -> Maybe a #-}
70++{-# SPECIALIZE xtG :: Key CoreMapX -> XT a -> CoreMapG a -> CoreMapG a #-}
71++{-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a -> CoreMapG b #-}
72++{-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a -> b -> b #-}
73++
74++
75++{-
76++************************************************************************
77++* *
78++ CoreMap
79++* *
80++************************************************************************
81++-}
82++
83++{-
84++Note [Binders]
85++~~~~~~~~~~~~~~
86++ * In general we check binders as late as possible because types are
87++ less likely to differ than expression structure. That's why
88++ cm_lam :: CoreMapG (TypeMapG a)
89++ rather than
90++ cm_lam :: TypeMapG (CoreMapG a)
91++
92++ * We don't need to look at the type of some binders, notably
93++ - the case binder in (Case _ b _ _)
94++ - the binders in an alternative
95++ because they are totally fixed by the context
96++
97++Note [Empty case alternatives]
98++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
99++* For a key (Case e b ty (alt:alts)) we don't need to look the return type
100++ 'ty', because every alternative has that type.
101++
102++* For a key (Case e b ty []) we MUST look at the return type 'ty', because
103++ otherwise (Case (error () "urk") _ Int []) would compare equal to
104++ (Case (error () "urk") _ Bool [])
105++ which is utterly wrong (#6097)
106++
107++We could compare the return type regardless, but the wildly common case
108++is that it's unnecessary, so we have two fields (cm_case and cm_ecase)
109++for the two possibilities. Only cm_ecase looks at the type.
110++
111++See also Note [Empty case alternatives] in GHC.Core.
112++-}
113++
114++-- | @CoreMap a@ is a map from 'CoreExpr' to @a@. If you are a client, this
115++-- is the type you want.
116++newtype CoreMap a = CoreMap (CoreMapG a)
117++
118++instance TrieMap CoreMap where
119++ type Key CoreMap = CoreExpr
120++ emptyTM = CoreMap emptyTM
121++ lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m
122++ alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m)
123++ foldTM k (CoreMap m) = foldTM k m
124++ mapTM f (CoreMap m) = CoreMap (mapTM f m)
125++ filterTM f (CoreMap m) = CoreMap (filterTM f m)
126++
127++-- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@. The extended
128++-- key makes it suitable for recursive traversal, since it can track binders,
129++-- but it is strictly internal to this module. If you are including a 'CoreMap'
130++-- inside another 'TrieMap', this is the type you want.
131++type CoreMapG = GenMap CoreMapX
132++
133++-- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without
134++-- the 'GenMap' optimization.
135++data CoreMapX a
136++ = CM { cm_var :: VarMap a
137++ , cm_lit :: LiteralMap a
138++ , cm_co :: CoercionMapG a
139++ , cm_type :: TypeMapG a
140++ , cm_cast :: CoreMapG (CoercionMapG a)
141++ , cm_tick :: CoreMapG (TickishMap a)
142++ , cm_app :: CoreMapG (CoreMapG a)
143++ , cm_lam :: CoreMapG (BndrMap a) -- Note [Binders]
144++ , cm_letn :: CoreMapG (CoreMapG (BndrMap a))
145++ , cm_letr :: ListMap CoreMapG (CoreMapG (ListMap BndrMap a))
146++ , cm_case :: CoreMapG (ListMap AltMap a)
147++ , cm_ecase :: CoreMapG (TypeMapG a) -- Note [Empty case alternatives]
148++ }
149++
150++instance Eq (DeBruijn CoreExpr) where
151++ D env1 e1 == D env2 e2 = go e1 e2 where
152++ go (Var v1) (Var v2)
153++ = case (lookupCME env1 v1, lookupCME env2 v2) of
154++ (Just b1, Just b2) -> b1 == b2
155++ (Nothing, Nothing) -> v1 == v2
156++ _ -> False
157++ go (Lit lit1) (Lit lit2) = lit1 == lit2
158++ go (Type t1) (Type t2) = D env1 t1 == D env2 t2
159++ go (Coercion co1) (Coercion co2) = D env1 co1 == D env2 co2
160++ go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2
161++ go (App f1 a1) (App f2 a2) = go f1 f2 && go a1 a2
162++ -- This seems a bit dodgy, see 'eqTickish'
163++ go (Tick n1 e1) (Tick n2 e2) = n1 == n2 && go e1 e2
164++
165++ go (Lam b1 e1) (Lam b2 e2)
166++ = D env1 (varType b1) == D env2 (varType b2)
167++ && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2)
168++ && D (extendCME env1 b1) e1 == D (extendCME env2 b2) e2
169++
170++ go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)
171++ = go r1 r2
172++ && D (extendCME env1 v1) e1 == D (extendCME env2 v2) e2
173++
174++ go (Let (Rec ps1) e1) (Let (Rec ps2) e2)
175++ = equalLength ps1 ps2
176++ && D env1' rs1 == D env2' rs2
177++ && D env1' e1 == D env2' e2
178++ where
179++ (bs1,rs1) = unzip ps1
180++ (bs2,rs2) = unzip ps2
181++ env1' = extendCMEs env1 bs1
182++ env2' = extendCMEs env2 bs2
183++
184++ go (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)
185++ | null a1 -- See Note [Empty case alternatives]
186++ = null a2 && go e1 e2 && D env1 t1 == D env2 t2
187++ | otherwise
188++ = go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2
189++
190++ go _ _ = False
191++
192++emptyE :: CoreMapX a
193++emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM
194++ , cm_co = emptyTM, cm_type = emptyTM
195++ , cm_cast = emptyTM, cm_app = emptyTM
196++ , cm_lam = emptyTM, cm_letn = emptyTM
197++ , cm_letr = emptyTM, cm_case = emptyTM
198++ , cm_ecase = emptyTM, cm_tick = emptyTM }
199++
200++instance TrieMap CoreMapX where
201++ type Key CoreMapX = DeBruijn CoreExpr
202++ emptyTM = emptyE
203++ lookupTM = lkE
204++ alterTM = xtE
205++ foldTM = fdE
206++ mapTM = mapE
207++ filterTM = ftE
208++
209++--------------------------
210++mapE :: (a->b) -> CoreMapX a -> CoreMapX b
211++mapE f (CM { cm_var = cvar, cm_lit = clit
212++ , cm_co = cco, cm_type = ctype
213++ , cm_cast = ccast , cm_app = capp
214++ , cm_lam = clam, cm_letn = cletn
215++ , cm_letr = cletr, cm_case = ccase
216++ , cm_ecase = cecase, cm_tick = ctick })
217++ = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit
218++ , cm_co = mapTM f cco, cm_type = mapTM f ctype
219++ , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp
220++ , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn
221++ , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase
222++ , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick }
223++
224++ftE :: (a->Bool) -> CoreMapX a -> CoreMapX a
225++ftE f (CM { cm_var = cvar, cm_lit = clit
226++ , cm_co = cco, cm_type = ctype
227++ , cm_cast = ccast , cm_app = capp
228++ , cm_lam = clam, cm_letn = cletn
229++ , cm_letr = cletr, cm_case = ccase
230++ , cm_ecase = cecase, cm_tick = ctick })
231++ = CM { cm_var = filterTM f cvar, cm_lit = filterTM f clit
232++ , cm_co = filterTM f cco, cm_type = filterTM f ctype
233++ , cm_cast = mapTM (filterTM f) ccast, cm_app = mapTM (filterTM f) capp
234++ , cm_lam = mapTM (filterTM f) clam, cm_letn = mapTM (mapTM (filterTM f)) cletn
235++ , cm_letr = mapTM (mapTM (filterTM f)) cletr, cm_case = mapTM (filterTM f) ccase
236++ , cm_ecase = mapTM (filterTM f) cecase, cm_tick = mapTM (filterTM f) ctick }
237++
238++--------------------------
239++lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a
240++lookupCoreMap cm e = lookupTM e cm
241++
242++extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a
243++extendCoreMap m e v = alterTM e (\_ -> Just v) m
244++
245++foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b
246++foldCoreMap k z m = foldTM k m z
247++
248++emptyCoreMap :: CoreMap a
249++emptyCoreMap = emptyTM
250++
251++instance Outputable a => Outputable (CoreMap a) where
252++ ppr m = text "CoreMap elts" <+> ppr (foldTM (:) m [])
253++
254++-------------------------
255++fdE :: (a -> b -> b) -> CoreMapX a -> b -> b
256++fdE k m
257++ = foldTM k (cm_var m)
258++ . foldTM k (cm_lit m)
259++ . foldTM k (cm_co m)
260++ . foldTM k (cm_type m)
261++ . foldTM (foldTM k) (cm_cast m)
262++ . foldTM (foldTM k) (cm_tick m)
263++ . foldTM (foldTM k) (cm_app m)
264++ . foldTM (foldTM k) (cm_lam m)
265++ . foldTM (foldTM (foldTM k)) (cm_letn m)
266++ . foldTM (foldTM (foldTM k)) (cm_letr m)
267++ . foldTM (foldTM k) (cm_case m)
268++ . foldTM (foldTM k) (cm_ecase m)
269++
270++-- lkE: lookup in trie for expressions
271++lkE :: DeBruijn CoreExpr -> CoreMapX a -> Maybe a
272++lkE (D env expr) cm = go expr cm
273++ where
274++ go (Var v) = cm_var >.> lkVar env v
275++ go (Lit l) = cm_lit >.> lookupTM l
276++ go (Type t) = cm_type >.> lkG (D env t)
277++ go (Coercion c) = cm_co >.> lkG (D env c)
278++ go (Cast e c) = cm_cast >.> lkG (D env e) >=> lkG (D env c)
279++ go (Tick tickish e) = cm_tick >.> lkG (D env e) >=> lkTickish tickish
280++ go (App e1 e2) = cm_app >.> lkG (D env e2) >=> lkG (D env e1)
281++ go (Lam v e) = cm_lam >.> lkG (D (extendCME env v) e)
282++ >=> lkBndr env v
283++ go (Let (NonRec b r) e) = cm_letn >.> lkG (D env r)
284++ >=> lkG (D (extendCME env b) e) >=> lkBndr env b
285++ go (Let (Rec prs) e) = let (bndrs,rhss) = unzip prs
286++ env1 = extendCMEs env bndrs
287++ in cm_letr
288++ >.> lkList (lkG . D env1) rhss
289++ >=> lkG (D env1 e)
290++ >=> lkList (lkBndr env1) bndrs
291++ go (Case e b ty as) -- See Note [Empty case alternatives]
292++ | null as = cm_ecase >.> lkG (D env e) >=> lkG (D env ty)
293++ | otherwise = cm_case >.> lkG (D env e)
294++ >=> lkList (lkA (extendCME env b)) as
295++
296++xtE :: DeBruijn CoreExpr -> XT a -> CoreMapX a -> CoreMapX a
297++xtE (D env (Var v)) f m = m { cm_var = cm_var m
298++ |> xtVar env v f }
299++xtE (D env (Type t)) f m = m { cm_type = cm_type m
300++ |> xtG (D env t) f }
301++xtE (D env (Coercion c)) f m = m { cm_co = cm_co m
302++ |> xtG (D env c) f }
303++xtE (D _ (Lit l)) f m = m { cm_lit = cm_lit m |> alterTM l f }
304++xtE (D env (Cast e c)) f m = m { cm_cast = cm_cast m |> xtG (D env e)
305++ |>> xtG (D env c) f }
306++xtE (D env (Tick t e)) f m = m { cm_tick = cm_tick m |> xtG (D env e)
307++ |>> xtTickish t f }
308++xtE (D env (App e1 e2)) f m = m { cm_app = cm_app m |> xtG (D env e2)
309++ |>> xtG (D env e1) f }
310++xtE (D env (Lam v e)) f m = m { cm_lam = cm_lam m
311++ |> xtG (D (extendCME env v) e)
312++ |>> xtBndr env v f }
313++xtE (D env (Let (NonRec b r) e)) f m = m { cm_letn = cm_letn m
314++ |> xtG (D (extendCME env b) e)
315++ |>> xtG (D env r)
316++ |>> xtBndr env b f }
317++xtE (D env (Let (Rec prs) e)) f m = m { cm_letr =
318++ let (bndrs,rhss) = unzip prs
319++ env1 = extendCMEs env bndrs
320++ in cm_letr m
321++ |> xtList (xtG . D env1) rhss
322++ |>> xtG (D env1 e)
323++ |>> xtList (xtBndr env1)
324++ bndrs f }
325++xtE (D env (Case e b ty as)) f m
326++ | null as = m { cm_ecase = cm_ecase m |> xtG (D env e)
327++ |>> xtG (D env ty) f }
328++ | otherwise = m { cm_case = cm_case m |> xtG (D env e)
329++ |>> let env1 = extendCME env b
330++ in xtList (xtA env1) as f }
331++
332++-- TODO: this seems a bit dodgy, see 'eqTickish'
333++type TickishMap a = Map.Map CoreTickish a
334++lkTickish :: CoreTickish -> TickishMap a -> Maybe a
335++lkTickish = lookupTM
336++
337++xtTickish :: CoreTickish -> XT a -> TickishMap a -> TickishMap a
338++xtTickish = alterTM
339++
340++------------------------
341++data AltMap a -- A single alternative
342++ = AM { am_deflt :: CoreMapG a
343++ , am_data :: DNameEnv (CoreMapG a)
344++ , am_lit :: LiteralMap (CoreMapG a) }
345++
346++instance TrieMap AltMap where
347++ type Key AltMap = CoreAlt
348++ emptyTM = AM { am_deflt = emptyTM
349++ , am_data = emptyDNameEnv
350++ , am_lit = emptyTM }
351++ lookupTM = lkA emptyCME
352++ alterTM = xtA emptyCME
353++ foldTM = fdA
354++ mapTM = mapA
355++ filterTM = ftA
356++
357++instance Eq (DeBruijn CoreAlt) where
358++ D env1 a1 == D env2 a2 = go a1 a2 where
359++ go (Alt DEFAULT _ rhs1) (Alt DEFAULT _ rhs2)
360++ = D env1 rhs1 == D env2 rhs2
361++ go (Alt (LitAlt lit1) _ rhs1) (Alt (LitAlt lit2) _ rhs2)
362++ = lit1 == lit2 && D env1 rhs1 == D env2 rhs2
363++ go (Alt (DataAlt dc1) bs1 rhs1) (Alt (DataAlt dc2) bs2 rhs2)
364++ = dc1 == dc2 &&
365++ D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2
366++ go _ _ = False
367++
368++mapA :: (a->b) -> AltMap a -> AltMap b
369++mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })
370++ = AM { am_deflt = mapTM f adeflt
371++ , am_data = mapTM (mapTM f) adata
372++ , am_lit = mapTM (mapTM f) alit }
373++
374++ftA :: (a->Bool) -> AltMap a -> AltMap a
375++ftA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })
376++ = AM { am_deflt = filterTM f adeflt
377++ , am_data = mapTM (filterTM f) adata
378++ , am_lit = mapTM (filterTM f) alit }
379++
380++lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a
381++lkA env (Alt DEFAULT _ rhs) = am_deflt >.> lkG (D env rhs)
382++lkA env (Alt (LitAlt lit) _ rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs)
383++lkA env (Alt (DataAlt dc) bs rhs) = am_data >.> lkDNamed dc
384++ >=> lkG (D (extendCMEs env bs) rhs)
385++
386++xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a
387++xtA env (Alt DEFAULT _ rhs) f m =
388++ m { am_deflt = am_deflt m |> xtG (D env rhs) f }
389++xtA env (Alt (LitAlt l) _ rhs) f m =
390++ m { am_lit = am_lit m |> alterTM l |>> xtG (D env rhs) f }
391++xtA env (Alt (DataAlt d) bs rhs) f m =
392++ m { am_data = am_data m |> xtDNamed d
393++ |>> xtG (D (extendCMEs env bs) rhs) f }
394++
395++fdA :: (a -> b -> b) -> AltMap a -> b -> b
396++fdA k m = foldTM k (am_deflt m)
397++ . foldTM (foldTM k) (am_data m)
398++ . foldTM (foldTM k) (am_lit m)
399+diff --git a/compiler/GHC/Core/Opt/CallerCC.hs b/compiler/GHC/Core/Opt/CallerCC.hs
400+new file mode 100644
401+index 0000000000..68875dc18f
402+--- /dev/null
403++++ b/compiler/GHC/Core/Opt/CallerCC.hs
404+@@ -0,0 +1,223 @@
405++{-# LANGUAGE NamedFieldPuns #-}
406++{-# LANGUAGE TypeApplications #-}
407++{-# LANGUAGE DeriveGeneric #-}
408++{-# LANGUAGE DeriveDataTypeable #-}
409++{-# LANGUAGE DeriveAnyClass #-}
410++{-# LANGUAGE DerivingStrategies #-}
411++{-# LANGUAGE TupleSections #-}
412++
413++-- | Adds cost-centers to call sites selected with the @-fprof-caller=...@
414++-- flag.
415++module GHC.Core.Opt.CallerCC
416++ ( addCallerCostCentres
417++ , CallerCcFilter
418++ , parseCallerCcFilter
419++ ) where
420++
421++import Data.Bifunctor
422++import Data.Word (Word8)
423++import Data.Maybe
424++import qualified Text.Parsec as P
425++
426++import Control.Applicative
427++import Control.Monad.Trans.State.Strict
428++import Data.Either
429++import Control.Monad
430++
431++import GHC.Prelude
432++import GHC.Utils.Outputable as Outputable
433++import GHC.Driver.Session
434++import GHC.Driver.Ppr
435++import GHC.Types.CostCentre
436++import GHC.Types.CostCentre.State
437++import GHC.Types.Name hiding (varName)
438++import GHC.Unit.Module.Name
439++import GHC.Unit.Module.ModGuts
440++import GHC.Types.SrcLoc
441++import GHC.Types.Var
442++import GHC.Unit.Types
443++import GHC.Data.FastString
444++import GHC.Core
445++import GHC.Core.Opt.Monad
446++import GHC.Utils.Panic
447++import qualified GHC.Utils.Binary as B
448++
449++addCallerCostCentres :: ModGuts -> CoreM ModGuts
450++addCallerCostCentres guts = do
451++ dflags <- getDynFlags
452++ let filters = callerCcFilters dflags
453++ let env :: Env
454++ env = Env
455++ { thisModule = mg_module guts
456++ , ccState = newCostCentreState
457++ , dflags = dflags
458++ , revParents = []
459++ , filters = filters
460++ }
461++ let guts' = guts { mg_binds = doCoreProgram env (mg_binds guts)
462++ }
463++ return guts'
464++
465++doCoreProgram :: Env -> CoreProgram -> CoreProgram
466++doCoreProgram env binds = flip evalState newCostCentreState $ do
467++ mapM (doBind env) binds
468++
469++doBind :: Env -> CoreBind -> M CoreBind
470++doBind env (NonRec b rhs) = NonRec b <$> doExpr (addParent b env) rhs
471++doBind env (Rec bs) = Rec <$> mapM doPair bs
472++ where
473++ doPair (b,rhs) = (b,) <$> doExpr (addParent b env) rhs
474++
475++doExpr :: Env -> CoreExpr -> M CoreExpr
476++doExpr env e@(Var v)
477++ | needsCallSiteCostCentre env v = do
478++ let nameDoc :: SDoc
479++ nameDoc = withUserStyle alwaysQualify DefaultDepth $
480++ hcat (punctuate dot (map ppr (parents env))) <> parens (text "calling:" <> ppr v)
481++
482++ ccName :: CcName
483++ ccName = mkFastString $ showSDoc (dflags env) nameDoc
484++ ccIdx <- getCCIndex' ccName
485++ let span = case revParents env of
486++ top:_ -> nameSrcSpan $ varName top
487++ _ -> noSrcSpan
488++ cc = NormalCC (ExprCC ccIdx) ccName (thisModule env) span
489++ tick :: CoreTickish
490++ tick = ProfNote cc True True
491++ pure $ Tick tick e
492++ | otherwise = pure e
493++doExpr _env e@(Lit _) = pure e
494++doExpr env (f `App` x) = App <$> doExpr env f <*> doExpr env x
495++doExpr env (Lam b x) = Lam b <$> doExpr env x
496++doExpr env (Let b rhs) = Let <$> doBind env b <*> doExpr env rhs
497++doExpr env (Case scrut b ty alts) =
498++ Case <$> doExpr env scrut <*> pure b <*> pure ty <*> mapM doAlt alts
499++ where
500++ doAlt (Alt con bs rhs) = Alt con bs <$> doExpr env rhs
501++doExpr env (Cast expr co) = Cast <$> doExpr env expr <*> pure co
502++doExpr env (Tick t e) = Tick t <$> doExpr env e
503++doExpr _env e@(Type _) = pure e
504++doExpr _env e@(Coercion _) = pure e
505++
506++type M = State CostCentreState
507++
508++getCCIndex' :: FastString -> M CostCentreIndex
509++getCCIndex' name = state (getCCIndex name)
510++
511++data Env = Env
512++ { thisModule :: Module
513++ , dflags :: DynFlags
514++ , ccState :: CostCentreState
515++ , revParents :: [Id]
516++ , filters :: [CallerCcFilter]
517++ }
518++
519++addParent :: Id -> Env -> Env
520++addParent i env = env { revParents = i : revParents env }
521++
522++parents :: Env -> [Id]
523++parents env = reverse (revParents env)
524++
525++needsCallSiteCostCentre :: Env -> Id -> Bool
526++needsCallSiteCostCentre env i =
527++ any matches (filters env)
528++ where
529++ matches :: CallerCcFilter -> Bool
530++ matches ccf =
531++ checkModule && checkFunc
532++ where
533++ checkModule =
534++ case ccfModuleName ccf of
535++ Just modFilt
536++ | Just iMod <- nameModule_maybe (varName i)
537++ -> moduleName iMod == modFilt
538++ | otherwise -> False
539++ Nothing -> True
540++ checkFunc =
541++ occNameMatches (ccfFuncName ccf) (getOccName i)
542++
543++data NamePattern
544++ = PChar Char NamePattern
545++ | PWildcard NamePattern
546++ | PEnd
547++
548++instance Outputable NamePattern where
549++ ppr (PChar c rest) = char c <> ppr rest
550++ ppr (PWildcard rest) = char '*' <> ppr rest
551++ ppr PEnd = Outputable.empty
552++
553++instance B.Binary NamePattern where
554++ get bh = do
555++ tag <- B.get bh
556++ case tag :: Word8 of
557++ 0 -> PChar <$> B.get bh <*> B.get bh
558++ 1 -> PWildcard <$> B.get bh
559++ 2 -> pure PEnd
560++ _ -> panic "Binary(NamePattern): Invalid tag"
561++ put_ bh (PChar x y) = B.put_ bh (0 :: Word8) >> B.put_ bh x >> B.put_ bh y
562++ put_ bh (PWildcard x) = B.put_ bh (1 :: Word8) >> B.put_ bh x
563++ put_ bh PEnd = B.put_ bh (2 :: Word8)
564++
565++occNameMatches :: NamePattern -> OccName -> Bool
566++occNameMatches pat = go pat . occNameString
567++ where
568++ go :: NamePattern -> String -> Bool
569++ go PEnd "" = True
570++ go (PChar c rest) (d:s)
571++ = d == c && go rest s
572++ go (PWildcard rest) s
573++ = go rest s || go (PWildcard rest) (tail s)
574++ go _ _ = False
575++
576++type Parser = P.Parsec String ()
577++
578++parseNamePattern :: Parser NamePattern
579++parseNamePattern = pattern
580++ where
581++ pattern = star <|> wildcard <|> char <|> end
582++ star = PChar '*' <$ P.string "\\*" <*> pattern
583++ wildcard = do
584++ void $ P.char '*'
585++ PWildcard <$> pattern
586++ char = PChar <$> P.anyChar <*> pattern
587++ end = PEnd <$ P.eof
588++
589++data CallerCcFilter
590++ = CallerCcFilter { ccfModuleName :: Maybe ModuleName
591++ , ccfFuncName :: NamePattern
592++ }
593++
594++instance Outputable CallerCcFilter where
595++ ppr ccf =
596++ maybe (char '*') ppr (ccfModuleName ccf)
597++ <> char '.'
598++ <> ppr (ccfFuncName ccf)
599++
600++instance B.Binary CallerCcFilter where
601++ get bh = CallerCcFilter <$> B.get bh <*> B.get bh
602++ put_ bh (CallerCcFilter x y) = B.put_ bh x >> B.put_ bh y
603++
604++parseCallerCcFilter :: String -> Either String CallerCcFilter
605++parseCallerCcFilter =
606++ first show . P.parse parseCallerCcFilter' "caller-CC filter"
607++
608++parseCallerCcFilter' :: Parser CallerCcFilter
609++parseCallerCcFilter' =
610++ CallerCcFilter
611++ <$> moduleFilter
612++ <* P.char '.'
613++ <*> parseNamePattern
614++ where
615++ moduleFilter :: Parser (Maybe ModuleName)
616++ moduleFilter =
617++ (Just . mkModuleName <$> moduleName)
618++ <|>
619++ (Nothing <$ P.char '*')
620++
621++ moduleName :: Parser String
622++ moduleName = do
623++ c <- P.upper
624++ cs <- some $ P.upper <|> P.lower <|> P.digit <|> P.oneOf "_"
625++ rest <- optional $ P.try $ P.char '.' >> fmap ('.':) moduleName
626++ return $ c : (cs ++ fromMaybe "" rest)
627++
628+diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
629+index 68b9f00798..b93935816f 100644
630+--- a/compiler/GHC/Hs/Binds.hs
631++++ b/compiler/GHC/Hs/Binds.hs
632+@@ -242,7 +242,7 @@ data HsBindLR idL idR
633+ -- type Int -> forall a'. a' -> a'
634+ -- Notice that the coercion captures the free a'.
635+
636+- fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any
637++ fun_tick :: [CoreTickish] -- ^ Ticks to put on the rhs, if any
638+ }
639+
640+ -- | Pattern Binding
641+@@ -262,7 +262,7 @@ data HsBindLR idL idR
642+ pat_ext :: XPatBind idL idR, -- ^ See Note [Bind free vars]
643+ pat_lhs :: LPat idL,
644+ pat_rhs :: GRHSs idR (LHsExpr idR),
645+- pat_ticks :: ([Tickish Id], [[Tickish Id]])
646++ pat_ticks :: ([CoreTickish], [[CoreTickish]])
647+ -- ^ Ticks to put on the rhs, if any, and ticks to put on
648+ -- the bound variables.
649+ }
650+diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
651+index 09b9f6ef8a..f95fd4ff1b 100644
652+--- a/compiler/GHC/Hs/Expr.hs
653++++ b/compiler/GHC/Hs/Expr.hs
654+@@ -601,7 +601,7 @@ data HsExpr p
655+
656+ | HsTick
657+ (XTick p)
658+- (Tickish (IdP p))
659++ CoreTickish
660+ (LHsExpr p) -- sub-expression
661+
662+ | HsBinTick
663+diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
664+index 07113a4e82..aaba4e3499 100644
665+--- a/compiler/GHC/StgToCmm/Expr.hs
666++++ b/compiler/GHC/StgToCmm/Expr.hs
667+@@ -1147,7 +1147,7 @@ emitEnter fun = do
668+ -- | Generate Cmm code for a tick. Depending on the type of Tickish,
669+ -- this will either generate actual Cmm instrumentation code, or
670+ -- simply pass on the annotation as a @CmmTickish@.
671+-cgTick :: Tickish Id -> FCode ()
672++cgTick :: StgTickish -> FCode ()
673+ cgTick tick
674+ = do { dflags <- getDynFlags
675+ ; case tick of
676+diff --git a/compiler/Language/Haskell/Syntax/Binds.hs b/compiler/Language/Haskell/Syntax/Binds.hs
677+new file mode 100644
678+index 0000000000..ebd93d3ecd
679+--- /dev/null
680++++ b/compiler/Language/Haskell/Syntax/Binds.hs
681+@@ -0,0 +1,944 @@
682++{-# LANGUAGE ConstraintKinds #-}
683++{-# LANGUAGE DeriveDataTypeable #-}
684++{-# LANGUAGE DeriveFunctor #-}
685++{-# LANGUAGE FlexibleContexts #-}
686++{-# LANGUAGE FlexibleInstances #-}
687++{-# LANGUAGE LambdaCase #-}
688++{-# LANGUAGE ScopedTypeVariables #-}
689++{-# LANGUAGE TypeApplications #-}
690++{-# LANGUAGE TypeFamilies #-}
691++{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
692++ -- in module Language.Haskell.Syntax.Extension
693++{-# LANGUAGE ViewPatterns #-}
694++
695++
696++{-
697++(c) The University of Glasgow 2006
698++(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
699++
700++\section[HsBinds]{Abstract syntax: top-level bindings and signatures}
701++
702++Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
703++-}
704++
705++-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.*
706++module Language.Haskell.Syntax.Binds where
707++
708++import GHC.Prelude
709++
710++import {-# SOURCE #-} Language.Haskell.Syntax.Expr
711++ ( LHsExpr
712++ , MatchGroup
713++ , GRHSs )
714++import {-# SOURCE #-} Language.Haskell.Syntax.Pat
715++ ( LPat )
716++
717++import Language.Haskell.Syntax.Extension
718++import Language.Haskell.Syntax.Type
719++import GHC.Core
720++import GHC.Tc.Types.Evidence
721++import GHC.Core.Type
722++import GHC.Types.Basic
723++import GHC.Types.SourceText
724++import GHC.Types.SrcLoc as SrcLoc
725++import GHC.Types.Var
726++import GHC.Types.Fixity
727++import GHC.Data.Bag
728++import GHC.Data.BooleanFormula (LBooleanFormula)
729++
730++import GHC.Utils.Outputable
731++
732++import Data.Data hiding ( Fixity )
733++import Data.Void
734++
735++{-
736++************************************************************************
737++* *
738++\subsection{Bindings: @BindGroup@}
739++* *
740++************************************************************************
741++
742++Global bindings (where clauses)
743++-}
744++
745++-- During renaming, we need bindings where the left-hand sides
746++-- have been renamed but the right-hand sides have not.
747++-- Other than during renaming, these will be the same.
748++
749++-- | Haskell Local Bindings
750++type HsLocalBinds id = HsLocalBindsLR id id
751++
752++-- | Located Haskell local bindings
753++type LHsLocalBinds id = XRec id (HsLocalBinds id)
754++
755++-- | Haskell Local Bindings with separate Left and Right identifier types
756++--
757++-- Bindings in a 'let' expression
758++-- or a 'where' clause
759++data HsLocalBindsLR idL idR
760++ = HsValBinds
761++ (XHsValBinds idL idR)
762++ (HsValBindsLR idL idR)
763++ -- ^ Haskell Value Bindings
764++
765++ -- There should be no pattern synonyms in the HsValBindsLR
766++ -- These are *local* (not top level) bindings
767++ -- The parser accepts them, however, leaving the
768++ -- renamer to report them
769++
770++ | HsIPBinds
771++ (XHsIPBinds idL idR)
772++ (HsIPBinds idR)
773++ -- ^ Haskell Implicit Parameter Bindings
774++
775++ | EmptyLocalBinds (XEmptyLocalBinds idL idR)
776++ -- ^ Empty Local Bindings
777++
778++ | XHsLocalBindsLR
779++ !(XXHsLocalBindsLR idL idR)
780++
781++type LHsLocalBindsLR idL idR = XRec idL (HsLocalBindsLR idL idR)
782++
783++
784++-- | Haskell Value Bindings
785++type HsValBinds id = HsValBindsLR id id
786++
787++-- | Haskell Value bindings with separate Left and Right identifier types
788++-- (not implicit parameters)
789++-- Used for both top level and nested bindings
790++-- May contain pattern synonym bindings
791++data HsValBindsLR idL idR
792++ = -- | Value Bindings In
793++ --
794++ -- Before renaming RHS; idR is always RdrName
795++ -- Not dependency analysed
796++ -- Recursive by default
797++ ValBinds
798++ (XValBinds idL idR)
799++ (LHsBindsLR idL idR) [LSig idR]
800++
801++ -- | Value Bindings Out
802++ --
803++ -- After renaming RHS; idR can be Name or Id Dependency analysed,
804++ -- later bindings in the list may depend on earlier ones.
805++ | XValBindsLR
806++ !(XXValBindsLR idL idR)
807++
808++-- ---------------------------------------------------------------------
809++
810++-- | Located Haskell Binding
811++type LHsBind id = LHsBindLR id id
812++
813++-- | Located Haskell Bindings
814++type LHsBinds id = LHsBindsLR id id
815++
816++-- | Haskell Binding
817++type HsBind id = HsBindLR id id
818++
819++-- | Located Haskell Bindings with separate Left and Right identifier types
820++type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
821++
822++-- | Located Haskell Binding with separate Left and Right identifier types
823++type LHsBindLR idL idR = XRec idL (HsBindLR idL idR)
824++
825++{- Note [FunBind vs PatBind]
826++ ~~~~~~~~~~~~~~~~~~~~~~~~~
827++The distinction between FunBind and PatBind is a bit subtle. FunBind covers
828++patterns which resemble function bindings and simple variable bindings.
829++
830++ f x = e
831++ f !x = e
832++ f = e
833++ !x = e -- FunRhs has SrcStrict
834++ x `f` y = e -- FunRhs has Infix
835++
836++The actual patterns and RHSs of a FunBind are encoding in fun_matches.
837++The m_ctxt field of each Match in fun_matches will be FunRhs and carries
838++two bits of information about the match,
839++
840++ * The mc_fixity field on each Match describes the fixity of the
841++ function binder in that match. E.g. this is legal:
842++ f True False = e1
843++ True `f` True = e2
844++
845++ * The mc_strictness field is used /only/ for nullary FunBinds: ones
846++ with one Match, which has no pats. For these, it describes whether
847++ the match is decorated with a bang (e.g. `!x = e`).
848++
849++By contrast, PatBind represents data constructor patterns, as well as a few
850++other interesting cases. Namely,
851++
852++ Just x = e
853++ (x) = e
854++ x :: Ty = e
855++-}
856++
857++-- | Haskell Binding with separate Left and Right id's
858++data HsBindLR idL idR
859++ = -- | Function-like Binding
860++ --
861++ -- FunBind is used for both functions @f x = e@
862++ -- and variables @f = \x -> e@
863++ -- and strict variables @!x = x + 1@
864++ --
865++ -- Reason 1: Special case for type inference: see 'GHC.Tc.Gen.Bind.tcMonoBinds'.
866++ --
867++ -- Reason 2: Instance decls can only have FunBinds, which is convenient.
868++ -- If you change this, you'll need to change e.g. rnMethodBinds
869++ --
870++ -- But note that the form @f :: a->a = ...@
871++ -- parses as a pattern binding, just like
872++ -- @(f :: a -> a) = ... @
873++ --
874++ -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their
875++ -- 'MatchContext'. See Note [FunBind vs PatBind] for
876++ -- details about the relationship between FunBind and PatBind.
877++ --
878++ -- 'GHC.Parser.Annotation.AnnKeywordId's
879++ --
880++ -- - 'GHC.Parser.Annotation.AnnFunId', attached to each element of fun_matches
881++ --
882++ -- - 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere',
883++ -- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose',
884++
885++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
886++ FunBind {
887++
888++ fun_ext :: XFunBind idL idR,
889++
890++ -- ^ After the renamer (but before the type-checker), this contains the
891++ -- locally-bound free variables of this defn. See Note [Bind free vars]
892++ --
893++ -- After the type-checker, this contains a coercion from the type of
894++ -- the MatchGroup to the type of the Id. Example:
895++ --
896++ -- @
897++ -- f :: Int -> forall a. a -> a
898++ -- f x y = y
899++ -- @
900++ --
901++ -- Then the MatchGroup will have type (Int -> a' -> a')
902++ -- (with a free type variable a'). The coercion will take
903++ -- a CoreExpr of this type and convert it to a CoreExpr of
904++ -- type Int -> forall a'. a' -> a'
905++ -- Notice that the coercion captures the free a'.
906++
907++ fun_id :: LIdP idL, -- Note [fun_id in Match] in GHC.Hs.Expr
908++
909++ fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload
910++
911++ fun_tick :: [CoreTickish] -- ^ Ticks to put on the rhs, if any
912++ }
913++
914++ -- | Pattern Binding
915++ --
916++ -- The pattern is never a simple variable;
917++ -- That case is done by FunBind.
918++ -- See Note [FunBind vs PatBind] for details about the
919++ -- relationship between FunBind and PatBind.
920++
921++ --
922++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang',
923++ -- 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere',
924++ -- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose',
925++
926++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
927++ | PatBind {
928++ pat_ext :: XPatBind idL idR, -- ^ See Note [Bind free vars]
929++ pat_lhs :: LPat idL,
930++ pat_rhs :: GRHSs idR (LHsExpr idR),
931++ pat_ticks :: ([CoreTickish], [[CoreTickish]])
932++ -- ^ Ticks to put on the rhs, if any, and ticks to put on
933++ -- the bound variables.
934++ }
935++
936++ -- | Variable Binding
937++ --
938++ -- Dictionary binding and suchlike.
939++ -- All VarBinds are introduced by the type checker
940++ | VarBind {
941++ var_ext :: XVarBind idL idR,
942++ var_id :: IdP idL,
943++ var_rhs :: LHsExpr idR -- ^ Located only for consistency
944++ }
945++
946++ -- | Abstraction Bindings
947++ | AbsBinds { -- Binds abstraction; TRANSLATION
948++ abs_ext :: XAbsBinds idL idR,
949++ abs_tvs :: [TyVar],
950++ abs_ev_vars :: [EvVar], -- ^ Includes equality constraints
951++
952++ -- | AbsBinds only gets used when idL = idR after renaming,
953++ -- but these need to be idL's for the collect... code in HsUtil
954++ -- to have the right type
955++ abs_exports :: [ABExport idL],
956++
957++ -- | Evidence bindings
958++ -- Why a list? See "GHC.Tc.TyCl.Instance"
959++ -- Note [Typechecking plan for instance declarations]
960++ abs_ev_binds :: [TcEvBinds],
961++
962++ -- | Typechecked user bindings
963++ abs_binds :: LHsBinds idL,
964++
965++ abs_sig :: Bool -- See Note [The abs_sig field of AbsBinds]
966++ }
967++
968++ -- | Patterns Synonym Binding
969++ | PatSynBind
970++ (XPatSynBind idL idR)
971++ (PatSynBind idL idR)
972++ -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern',
973++ -- 'GHC.Parser.Annotation.AnnLarrow','GHC.Parser.Annotation.AnnEqual',
974++ -- 'GHC.Parser.Annotation.AnnWhere'
975++ -- 'GHC.Parser.Annotation.AnnOpen' @'{'@,'GHC.Parser.Annotation.AnnClose' @'}'@
976++
977++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
978++
979++ | XHsBindsLR !(XXHsBindsLR idL idR)
980++
981++
982++ -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
983++ --
984++ -- Creates bindings for (polymorphic, overloaded) poly_f
985++ -- in terms of monomorphic, non-overloaded mono_f
986++ --
987++ -- Invariants:
988++ -- 1. 'binds' binds mono_f
989++ -- 2. ftvs is a subset of tvs
990++ -- 3. ftvs includes all tyvars free in ds
991++ --
992++ -- See Note [AbsBinds]
993++
994++-- | Abstraction Bindings Export
995++data ABExport p
996++ = ABE { abe_ext :: XABE p
997++ , abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id
998++ , abe_mono :: IdP p
999++ , abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper]
1000++ -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
1001++ , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas
1002++ }
1003++ | XABExport !(XXABExport p)
1004++
1005++
1006++-- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern',
1007++-- 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnLarrow',
1008++-- 'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen' @'{'@,
1009++-- 'GHC.Parser.Annotation.AnnClose' @'}'@,
1010++
1011++-- For details on above see note [Api annotations] in GHC.Parser.Annotation
1012++
1013++-- | Pattern Synonym binding
1014++data PatSynBind idL idR
1015++ = PSB { psb_ext :: XPSB idL idR, -- ^ Post renaming, FVs.
1016++ -- See Note [Bind free vars]
1017++ psb_id :: LIdP idL, -- ^ Name of the pattern synonym
1018++ psb_args :: HsPatSynDetails idR, -- ^ Formal parameter names
1019++ psb_def :: LPat idR, -- ^ Right-hand side
1020++ psb_dir :: HsPatSynDir idR -- ^ Directionality
1021++ }
1022++ | XPatSynBind !(XXPatSynBind idL idR)
1023++
1024++{-
1025++Note [AbsBinds]
1026++~~~~~~~~~~~~~~~
1027++The AbsBinds constructor is used in the output of the type checker, to
1028++record *typechecked* and *generalised* bindings. Specifically
1029++
1030++ AbsBinds { abs_tvs = tvs
1031++ , abs_ev_vars = [d1,d2]
1032++ , abs_exports = [ABE { abe_poly = fp, abe_mono = fm
1033++ , abe_wrap = fwrap }
1034++ ABE { slly for g } ]
1035++ , abs_ev_binds = DBINDS
1036++ , abs_binds = BIND[fm,gm] }
1037++
1038++where 'BIND' binds the monomorphic Ids 'fm' and 'gm', means
1039++
1040++ fp = fwrap [/\ tvs. \d1 d2. letrec { DBINDS ]
1041++ [ ; BIND[fm,gm] } ]
1042++ [ in fm ]
1043++
1044++ gp = ...same again, with gm instead of fm
1045++
1046++The 'fwrap' is an impedance-matcher that typically does nothing; see
1047++Note [ABExport wrapper].
1048++
1049++This is a pretty bad translation, because it duplicates all the bindings.
1050++So the desugarer tries to do a better job:
1051++
1052++ fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
1053++ (fm,gm) -> fm
1054++ ..ditto for gp..
1055++
1056++ tp = /\ [a,b] -> \ [d1,d2] -> letrec { DBINDS; BIND }
1057++ in (fm,gm)
1058++
1059++In general:
1060++
1061++ * abs_tvs are the type variables over which the binding group is
1062++ generalised
1063++ * abs_ev_var are the evidence variables (usually dictionaries)
1064++ over which the binding group is generalised
1065++ * abs_binds are the monomorphic bindings
1066++ * abs_ex_binds are the evidence bindings that wrap the abs_binds
1067++ * abs_exports connects the monomorphic Ids bound by abs_binds
1068++ with the polymorphic Ids bound by the AbsBinds itself.
1069++
1070++For example, consider a module M, with this top-level binding, where
1071++there is no type signature for M.reverse,
1072++ M.reverse [] = []
1073++ M.reverse (x:xs) = M.reverse xs ++ [x]
1074++
1075++In Hindley-Milner, a recursive binding is typechecked with the
1076++*recursive* uses being *monomorphic*. So after typechecking *and*
1077++desugaring we will get something like this
1078++
1079++ M.reverse :: forall a. [a] -> [a]
1080++ = /\a. letrec
1081++ reverse :: [a] -> [a] = \xs -> case xs of
1082++ [] -> []
1083++ (x:xs) -> reverse xs ++ [x]
1084++ in reverse
1085++
1086++Notice that 'M.reverse' is polymorphic as expected, but there is a local
1087++definition for plain 'reverse' which is *monomorphic*. The type variable
1088++'a' scopes over the entire letrec.
1089++
1090++That's after desugaring. What about after type checking but before
1091++desugaring? That's where AbsBinds comes in. It looks like this:
1092++
1093++ AbsBinds { abs_tvs = [a]
1094++ , abs_ev_vars = []
1095++ , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a],
1096++ , abe_mono = reverse :: [a] -> [a]}]
1097++ , abs_ev_binds = {}
1098++ , abs_binds = { reverse :: [a] -> [a]
1099++ = \xs -> case xs of
1100++ [] -> []
1101++ (x:xs) -> reverse xs ++ [x] } }
1102++
1103++Here,
1104++
1105++ * abs_tvs says what type variables are abstracted over the binding
1106++ group, just 'a' in this case.
1107++ * abs_binds is the *monomorphic* bindings of the group
1108++ * abs_exports describes how to get the polymorphic Id 'M.reverse'
1109++ from the monomorphic one 'reverse'
1110++
1111++Notice that the *original* function (the polymorphic one you thought
1112++you were defining) appears in the abe_poly field of the
1113++abs_exports. The bindings in abs_binds are for fresh, local, Ids with
1114++a *monomorphic* Id.
1115++
1116++If there is a group of mutually recursive (see Note [Polymorphic
1117++recursion]) functions without type signatures, we get one AbsBinds
1118++with the monomorphic versions of the bindings in abs_binds, and one
1119++element of abe_exports for each variable bound in the mutually
1120++recursive group. This is true even for pattern bindings. Example:
1121++ (f,g) = (\x -> x, f)
1122++After type checking we get
1123++ AbsBinds { abs_tvs = [a]
1124++ , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a
1125++ , abe_mono = f :: a -> a }
1126++ , ABE { abe_poly = M.g :: forall a. a -> a
1127++ , abe_mono = g :: a -> a }]
1128++ , abs_binds = { (f,g) = (\x -> x, f) }
1129++
1130++Note [Polymorphic recursion]
1131++~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1132++Consider
1133++ Rec { f x = ...(g ef)...
1134++
1135++ ; g :: forall a. [a] -> [a]
1136++ ; g y = ...(f eg)... }
1137++
1138++These bindings /are/ mutually recursive (f calls g, and g calls f).
1139++But we can use the type signature for g to break the recursion,
1140++like this:
1141++
1142++ 1. Add g :: forall a. [a] -> [a] to the type environment
1143++
1144++ 2. Typecheck the definition of f, all by itself,
1145++ including generalising it to find its most general
1146++ type, say f :: forall b. b -> b -> [b]
1147++
1148++ 3. Extend the type environment with that type for f
1149++
1150++ 4. Typecheck the definition of g, all by itself,
1151++ checking that it has the type claimed by its signature
1152++
1153++Steps 2 and 4 each generate a separate AbsBinds, so we end
1154++up with
1155++ Rec { AbsBinds { ...for f ... }
1156++ ; AbsBinds { ...for g ... } }
1157++
1158++This approach allows both f and to call each other
1159++polymorphically, even though only g has a signature.
1160++
1161++We get an AbsBinds that encompasses multiple source-program
1162++bindings only when
1163++ * Each binding in the group has at least one binder that
1164++ lacks a user type signature
1165++ * The group forms a strongly connected component
1166++
1167++
1168++Note [The abs_sig field of AbsBinds]
1169++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1170++The abs_sig field supports a couple of special cases for bindings.
1171++Consider
1172++
1173++ x :: Num a => (# a, a #)
1174++ x = (# 3, 4 #)
1175++
1176++The general desugaring for AbsBinds would give
1177++
1178++ x = /\a. \ ($dNum :: Num a) ->
1179++ letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in
1180++ xm
1181++
1182++But that has an illegal let-binding for an unboxed tuple. In this
1183++case we'd prefer to generate the (more direct)
1184++
1185++ x = /\ a. \ ($dNum :: Num a) ->
1186++ (# fromInteger $dNum 3, fromInteger $dNum 4 #)
1187++
1188++A similar thing happens with representation-polymorphic defns
1189++(#11405):
1190++
1191++ undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a
1192++ undef = error "undef"
1193++
1194++Again, the vanilla desugaring gives a local let-binding for a
1195++representation-polymorphic (undefm :: a), which is illegal. But
1196++again we can desugar without a let:
1197++
1198++ undef = /\ a. \ (d:HasCallStack) -> error a d "undef"
1199++
1200++The abs_sig field supports this direct desugaring, with no local
1201++let-binding. When abs_sig = True
1202++
1203++ * the abs_binds is single FunBind
1204++
1205++ * the abs_exports is a singleton
1206++
1207++ * we have a complete type sig for binder
1208++ and hence the abs_binds is non-recursive
1209++ (it binds the mono_id but refers to the poly_id
1210++
1211++These properties are exploited in GHC.HsToCore.Binds.dsAbsBinds to
1212++generate code without a let-binding.
1213++
1214++Note [ABExport wrapper]
1215++~~~~~~~~~~~~~~~~~~~~~~~
1216++Consider
1217++ (f,g) = (\x.x, \y.y)
1218++This ultimately desugars to something like this:
1219++ tup :: forall a b. (a->a, b->b)
1220++ tup = /\a b. (\x:a.x, \y:b.y)
1221++ f :: forall a. a -> a
1222++ f = /\a. case tup a Any of
1223++ (fm::a->a,gm:Any->Any) -> fm
1224++ ...similarly for g...
1225++
1226++The abe_wrap field deals with impedance-matching between
1227++ (/\a b. case tup a b of { (f,g) -> f })
1228++and the thing we really want, which may have fewer type
1229++variables. The action happens in GHC.Tc.Gen.Bind.mkExport.
1230++
1231++Note [Bind free vars]
1232++~~~~~~~~~~~~~~~~~~~~~
1233++The bind_fvs field of FunBind and PatBind records the free variables
1234++of the definition. It is used for the following purposes
1235++
1236++a) Dependency analysis prior to type checking
1237++ (see GHC.Tc.Gen.Bind.tc_group)
1238++
1239++b) Deciding whether we can do generalisation of the binding
1240++ (see GHC.Tc.Gen.Bind.decideGeneralisationPlan)
1241++
1242++c) Deciding whether the binding can be used in static forms
1243++ (see GHC.Tc.Gen.Expr.checkClosedInStaticForm for the HsStatic case and
1244++ GHC.Tc.Gen.Bind.isClosedBndrGroup).
1245++
1246++Specifically,
1247++
1248++ * bind_fvs includes all free vars that are defined in this module
1249++ (including top-level things and lexically scoped type variables)
1250++
1251++ * bind_fvs excludes imported vars; this is just to keep the set smaller
1252++
1253++ * Before renaming, and after typechecking, the field is unused;
1254++ it's just an error thunk
1255++-}
1256++
1257++
1258++{-
1259++************************************************************************
1260++* *
1261++ Implicit parameter bindings
1262++* *
1263++************************************************************************
1264++-}
1265++
1266++-- | Haskell Implicit Parameter Bindings
1267++data HsIPBinds id
1268++ = IPBinds
1269++ (XIPBinds id)
1270++ [LIPBind id]
1271++ -- TcEvBinds -- Only in typechecker output; binds
1272++ -- -- uses of the implicit parameters
1273++ | XHsIPBinds !(XXHsIPBinds id)
1274++
1275++
1276++-- | Located Implicit Parameter Binding
1277++type LIPBind id = XRec id (IPBind id)
1278++-- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a
1279++-- list
1280++
1281++-- For details on above see note [Api annotations] in GHC.Parser.Annotation
1282++
1283++-- | Implicit parameter bindings.
1284++--
1285++-- These bindings start off as (Left "x") in the parser and stay
1286++-- that way until after type-checking when they are replaced with
1287++-- (Right d), where "d" is the name of the dictionary holding the
1288++-- evidence for the implicit parameter.
1289++--
1290++-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual'
1291++
1292++-- For details on above see note [Api annotations] in GHC.Parser.Annotation
1293++data IPBind id
1294++ = IPBind
1295++ (XCIPBind id)
1296++ (Either (XRec id HsIPName) (IdP id))
1297++ (LHsExpr id)
1298++ | XIPBind !(XXIPBind id)
1299++
1300++{-
1301++************************************************************************
1302++* *
1303++\subsection{@Sig@: type signatures and value-modifying user pragmas}
1304++* *
1305++************************************************************************
1306++
1307++It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
1308++``specialise this function to these four types...'') in with type
1309++signatures. Then all the machinery to move them into place, etc.,
1310++serves for both.
1311++-}
1312++
1313++-- | Located Signature
1314++type LSig pass = XRec pass (Sig pass)
1315++
1316++-- | Signatures and pragmas
1317++data Sig pass
1318++ = -- | An ordinary type signature
1319++ --
1320++ -- > f :: Num a => a -> a
1321++ --
1322++ -- After renaming, this list of Names contains the named
1323++ -- wildcards brought into scope by this signature. For a signature
1324++ -- @_ -> _a -> Bool@, the renamer will leave the unnamed wildcard @_@
1325++ -- untouched, and the named wildcard @_a@ is then replaced with
1326++ -- fresh meta vars in the type. Their names are stored in the type
1327++ -- signature that brought them into scope, in this third field to be
1328++ -- more specific.
1329++ --
1330++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon',
1331++ -- 'GHC.Parser.Annotation.AnnComma'
1332++
1333++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1334++ TypeSig
1335++ (XTypeSig pass)
1336++ [LIdP pass] -- LHS of the signature; e.g. f,g,h :: blah
1337++ (LHsSigWcType pass) -- RHS of the signature; can have wildcards
1338++
1339++ -- | A pattern synonym type signature
1340++ --
1341++ -- > pattern Single :: () => (Show a) => a -> [a]
1342++ --
1343++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern',
1344++ -- 'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnForall'
1345++ -- 'GHC.Parser.Annotation.AnnDot','GHC.Parser.Annotation.AnnDarrow'
1346++
1347++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1348++ | PatSynSig (XPatSynSig pass) [LIdP pass] (LHsSigType pass)
1349++ -- P :: forall a b. Req => Prov => ty
1350++
1351++ -- | A signature for a class method
1352++ -- False: ordinary class-method signature
1353++ -- True: generic-default class method signature
1354++ -- e.g. class C a where
1355++ -- op :: a -> a -- Ordinary
1356++ -- default op :: Eq a => a -> a -- Generic default
1357++ -- No wildcards allowed here
1358++ --
1359++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDefault',
1360++ -- 'GHC.Parser.Annotation.AnnDcolon'
1361++ | ClassOpSig (XClassOpSig pass) Bool [LIdP pass] (LHsSigType pass)
1362++
1363++ -- | A type signature in generated code, notably the code
1364++ -- generated for record selectors. We simply record
1365++ -- the desired Id itself, replete with its name, type
1366++ -- and IdDetails. Otherwise it's just like a type
1367++ -- signature: there should be an accompanying binding
1368++ | IdSig (XIdSig pass) Id
1369++
1370++ -- | An ordinary fixity declaration
1371++ --
1372++ -- > infixl 8 ***
1373++ --
1374++ --
1375++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnInfix',
1376++ -- 'GHC.Parser.Annotation.AnnVal'
1377++
1378++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1379++ | FixSig (XFixSig pass) (FixitySig pass)
1380++
1381++ -- | An inline pragma
1382++ --
1383++ -- > {#- INLINE f #-}
1384++ --
1385++ -- - 'GHC.Parser.Annotation.AnnKeywordId' :
1386++ -- 'GHC.Parser.Annotation.AnnOpen' @'{-\# INLINE'@ and @'['@,
1387++ -- 'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnOpen',
1388++ -- 'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnTilde',
1389++ -- 'GHC.Parser.Annotation.AnnClose'
1390++
1391++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1392++ | InlineSig (XInlineSig pass)
1393++ (LIdP pass) -- Function name
1394++ InlinePragma -- Never defaultInlinePragma
1395++
1396++ -- | A specialisation pragma
1397++ --
1398++ -- > {-# SPECIALISE f :: Int -> Int #-}
1399++ --
1400++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
1401++ -- 'GHC.Parser.Annotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@,
1402++ -- 'GHC.Parser.Annotation.AnnTilde',
1403++ -- 'GHC.Parser.Annotation.AnnVal',
1404++ -- 'GHC.Parser.Annotation.AnnClose' @']'@ and @'\#-}'@,
1405++ -- 'GHC.Parser.Annotation.AnnDcolon'
1406++
1407++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1408++ | SpecSig (XSpecSig pass)
1409++ (LIdP pass) -- Specialise a function or datatype ...
1410++ [LHsSigType pass] -- ... to these types
1411++ InlinePragma -- The pragma on SPECIALISE_INLINE form.
1412++ -- If it's just defaultInlinePragma, then we said
1413++ -- SPECIALISE, not SPECIALISE_INLINE
1414++
1415++ -- | A specialisation pragma for instance declarations only
1416++ --
1417++ -- > {-# SPECIALISE instance Eq [Int] #-}
1418++ --
1419++ -- (Class tys); should be a specialisation of the
1420++ -- current instance declaration
1421++ --
1422++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
1423++ -- 'GHC.Parser.Annotation.AnnInstance','GHC.Parser.Annotation.AnnClose'
1424++
1425++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1426++ | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass)
1427++ -- Note [Pragma source text] in GHC.Types.SourceText
1428++
1429++ -- | A minimal complete definition pragma
1430++ --
1431++ -- > {-# MINIMAL a | (b, c | (d | e)) #-}
1432++ --
1433++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
1434++ -- 'GHC.Parser.Annotation.AnnVbar','GHC.Parser.Annotation.AnnComma',
1435++ -- 'GHC.Parser.Annotation.AnnClose'
1436++
1437++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1438++ | MinimalSig (XMinimalSig pass)
1439++ SourceText (LBooleanFormula (LIdP pass))
1440++ -- Note [Pragma source text] in GHC.Types.SourceText
1441++
1442++ -- | A "set cost centre" pragma for declarations
1443++ --
1444++ -- > {-# SCC funName #-}
1445++ --
1446++ -- or
1447++ --
1448++ -- > {-# SCC funName "cost_centre_name" #-}
1449++
1450++ | SCCFunSig (XSCCFunSig pass)
1451++ SourceText -- Note [Pragma source text] in GHC.Types.SourceText
1452++ (LIdP pass) -- Function name
1453++ (Maybe (XRec pass StringLiteral))
1454++ -- | A complete match pragma
1455++ --
1456++ -- > {-# COMPLETE C, D [:: T] #-}
1457++ --
1458++ -- Used to inform the pattern match checker about additional
1459++ -- complete matchings which, for example, arise from pattern
1460++ -- synonym definitions.
1461++ | CompleteMatchSig (XCompleteMatchSig pass)
1462++ SourceText
1463++ (XRec pass [LIdP pass])
1464++ (Maybe (LIdP pass))
1465++ | XSig !(XXSig pass)
1466++
1467++-- | Located Fixity Signature
1468++type LFixitySig pass = XRec pass (FixitySig pass)
1469++
1470++-- | Fixity Signature
1471++data FixitySig pass = FixitySig (XFixitySig pass) [LIdP pass] Fixity
1472++ | XFixitySig !(XXFixitySig pass)
1473++
1474++-- | Type checker Specialisation Pragmas
1475++--
1476++-- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer
1477++data TcSpecPrags
1478++ = IsDefaultMethod -- ^ Super-specialised: a default method should
1479++ -- be macro-expanded at every call site
1480++ | SpecPrags [LTcSpecPrag]
1481++ deriving Data
1482++
1483++-- | Located Type checker Specification Pragmas
1484++type LTcSpecPrag = Located TcSpecPrag
1485++
1486++-- | Type checker Specification Pragma
1487++data TcSpecPrag
1488++ = SpecPrag
1489++ Id
1490++ HsWrapper
1491++ InlinePragma
1492++ -- ^ The Id to be specialised, a wrapper that specialises the
1493++ -- polymorphic function, and inlining spec for the specialised function
1494++ deriving Data
1495++
1496++noSpecPrags :: TcSpecPrags
1497++noSpecPrags = SpecPrags []
1498++
1499++hasSpecPrags :: TcSpecPrags -> Bool
1500++hasSpecPrags (SpecPrags ps) = not (null ps)
1501++hasSpecPrags IsDefaultMethod = False
1502++
1503++isDefaultMethod :: TcSpecPrags -> Bool
1504++isDefaultMethod IsDefaultMethod = True
1505++isDefaultMethod (SpecPrags {}) = False
1506++
1507++isFixityLSig :: forall p. UnXRec p => LSig p -> Bool
1508++isFixityLSig (unXRec @p -> FixSig {}) = True
1509++isFixityLSig _ = False
1510++
1511++isTypeLSig :: forall p. UnXRec p => LSig p -> Bool -- Type signatures
1512++isTypeLSig (unXRec @p -> TypeSig {}) = True
1513++isTypeLSig (unXRec @p -> ClassOpSig {}) = True
1514++isTypeLSig (unXRec @p -> IdSig {}) = True
1515++isTypeLSig _ = False
1516++
1517++isSpecLSig :: forall p. UnXRec p => LSig p -> Bool
1518++isSpecLSig (unXRec @p -> SpecSig {}) = True
1519++isSpecLSig _ = False
1520++
1521++isSpecInstLSig :: forall p. UnXRec p => LSig p -> Bool
1522++isSpecInstLSig (unXRec @p -> SpecInstSig {}) = True
1523++isSpecInstLSig _ = False
1524++
1525++isPragLSig :: forall p. UnXRec p => LSig p -> Bool
1526++-- Identifies pragmas
1527++isPragLSig (unXRec @p -> SpecSig {}) = True
1528++isPragLSig (unXRec @p -> InlineSig {}) = True
1529++isPragLSig (unXRec @p -> SCCFunSig {}) = True
1530++isPragLSig (unXRec @p -> CompleteMatchSig {}) = True
1531++isPragLSig _ = False
1532++
1533++isInlineLSig :: forall p. UnXRec p => LSig p -> Bool
1534++-- Identifies inline pragmas
1535++isInlineLSig (unXRec @p -> InlineSig {}) = True
1536++isInlineLSig _ = False
1537++
1538++isMinimalLSig :: forall p. UnXRec p => LSig p -> Bool
1539++isMinimalLSig (unXRec @p -> MinimalSig {}) = True
1540++isMinimalLSig _ = False
1541++
1542++isSCCFunSig :: forall p. UnXRec p => LSig p -> Bool
1543++isSCCFunSig (unXRec @p -> SCCFunSig {}) = True
1544++isSCCFunSig _ = False
1545++
1546++isCompleteMatchSig :: forall p. UnXRec p => LSig p -> Bool
1547++isCompleteMatchSig (unXRec @p -> CompleteMatchSig {} ) = True
1548++isCompleteMatchSig _ = False
1549++
1550++hsSigDoc :: Sig name -> SDoc
1551++hsSigDoc (TypeSig {}) = text "type signature"
1552++hsSigDoc (PatSynSig {}) = text "pattern synonym signature"
1553++hsSigDoc (ClassOpSig _ is_deflt _ _)
1554++ | is_deflt = text "default type signature"
1555++ | otherwise = text "class method signature"
1556++hsSigDoc (IdSig {}) = text "id signature"
1557++hsSigDoc (SpecSig _ _ _ inl)
1558++ = ppr inl <+> text "pragma"
1559++hsSigDoc (InlineSig _ _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma"
1560++hsSigDoc (SpecInstSig _ src _)
1561++ = pprWithSourceText src empty <+> text "instance pragma"
1562++hsSigDoc (FixSig {}) = text "fixity declaration"
1563++hsSigDoc (MinimalSig {}) = text "MINIMAL pragma"
1564++hsSigDoc (SCCFunSig {}) = text "SCC pragma"
1565++hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma"
1566++hsSigDoc (XSig {}) = text "XSIG TTG extension"
1567++
1568++{-
1569++************************************************************************
1570++* *
1571++\subsection[PatSynBind]{A pattern synonym definition}
1572++* *
1573++************************************************************************
1574++-}
1575++
1576++-- | Haskell Pattern Synonym Details
1577++type HsPatSynDetails pass = HsConDetails Void (LIdP pass) [RecordPatSynField pass]
1578++
1579++-- See Note [Record PatSyn Fields]
1580++-- | Record Pattern Synonym Field
1581++data RecordPatSynField pass
1582++ = RecordPatSynField
1583++ { recordPatSynField :: FieldOcc pass
1584++ -- ^ Field label visible in rest of the file
1585++ , recordPatSynPatVar :: LIdP pass
1586++ -- ^ Filled in by renamer, the name used internally by the pattern
1587++ }
1588++
1589++
1590++{-
1591++Note [Record PatSyn Fields]
1592++~~~~~~~~~~~~~~~~~~~~~~~~~~~
1593++
1594++Consider the following two pattern synonyms.
1595++
1596++ pattern P x y = ([x,True], [y,'v'])
1597++ pattern Q{ x, y } =([x,True], [y,'v'])
1598++
1599++In P, we just have two local binders, x and y.
1600++
1601++In Q, we have local binders but also top-level record selectors
1602++ x :: ([Bool], [Char]) -> Bool
1603++ y :: ([Bool], [Char]) -> Char
1604++
1605++Both are recorded in the `RecordPatSynField`s for `x` and `y`:
1606++* recordPatSynField: the top-level record selector
1607++* recordPatSynPatVar: the local `x`, bound only in the RHS of the pattern synonym.
1608++
1609++It would make sense to support record-like syntax
1610++
1611++ pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v'])
1612++
1613++when we have a different name for the local and top-level binder,
1614++making the distinction between the two names clear.
1615++
1616++-}
1617++instance Outputable (RecordPatSynField a) where
1618++ ppr (RecordPatSynField { recordPatSynField = v }) = ppr v
1619++
1620++
1621++-- | Haskell Pattern Synonym Direction
1622++data HsPatSynDir id
1623++ = Unidirectional
1624++ | ImplicitBidirectional
1625++ | ExplicitBidirectional (MatchGroup id (LHsExpr id))
1626+diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
1627+new file mode 100644
1628+index 0000000000..478ac1e2ac
1629+--- /dev/null
1630++++ b/compiler/Language/Haskell/Syntax/Expr.hs
1631+@@ -0,0 +1,1775 @@
1632++{-# LANGUAGE CPP #-}
1633++{-# LANGUAGE ConstraintKinds #-}
1634++{-# LANGUAGE DataKinds #-}
1635++{-# LANGUAGE DeriveDataTypeable #-}
1636++{-# LANGUAGE ExistentialQuantification #-}
1637++{-# LANGUAGE FlexibleContexts #-}
1638++{-# LANGUAGE FlexibleInstances #-}
1639++{-# LANGUAGE LambdaCase #-}
1640++{-# LANGUAGE ScopedTypeVariables #-}
1641++{-# LANGUAGE StandaloneDeriving #-}
1642++{-# LANGUAGE TypeApplications #-}
1643++{-# LANGUAGE TypeFamilyDependencies #-}
1644++{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
1645++ -- in module Language.Haskell.Syntax.Extension
1646++
1647++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
1648++
1649++{-
1650++(c) The University of Glasgow 2006
1651++(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
1652++-}
1653++
1654++-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.*
1655++
1656++-- | Abstract Haskell syntax for expressions.
1657++module Language.Haskell.Syntax.Expr where
1658++
1659++#include "HsVersions.h"
1660++
1661++-- friends:
1662++import GHC.Prelude
1663++
1664++import Language.Haskell.Syntax.Decls
1665++import Language.Haskell.Syntax.Pat
1666++import Language.Haskell.Syntax.Lit
1667++import Language.Haskell.Syntax.Extension
1668++import Language.Haskell.Syntax.Type
1669++import Language.Haskell.Syntax.Binds
1670++
1671++-- others:
1672++import GHC.Tc.Types.Evidence
1673++import GHC.Core
1674++import GHC.Types.Name
1675++import GHC.Types.Basic
1676++import GHC.Types.Fixity
1677++import GHC.Types.SourceText
1678++import GHC.Types.SrcLoc
1679++import GHC.Core.ConLike
1680++import GHC.Unit.Module (ModuleName)
1681++import GHC.Utils.Outputable
1682++import GHC.Utils.Panic
1683++import GHC.Data.FastString
1684++import GHC.Core.Type
1685++
1686++-- libraries:
1687++import Data.Data hiding (Fixity(..))
1688++import qualified Data.Data as Data (Fixity(..))
1689++
1690++import GHCi.RemoteTypes ( ForeignRef )
1691++import qualified Language.Haskell.TH as TH (Q)
1692++
1693++{-
1694++************************************************************************
1695++* *
1696++\subsection{Expressions proper}
1697++* *
1698++************************************************************************
1699++-}
1700++
1701++-- * Expressions proper
1702++
1703++-- | Located Haskell Expression
1704++type LHsExpr p = XRec p (HsExpr p)
1705++ -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when
1706++ -- in a list
1707++
1708++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1709++
1710++-------------------------
1711++{- Note [NoSyntaxExpr]
1712++~~~~~~~~~~~~~~~~~~~~~~
1713++Syntax expressions can be missing (NoSyntaxExprRn or NoSyntaxExprTc)
1714++for several reasons:
1715++
1716++ 1. As described in Note [Rebindable if]
1717++
1718++ 2. In order to suppress "not in scope: xyz" messages when a bit of
1719++ rebindable syntax does not apply. For example, when using an irrefutable
1720++ pattern in a BindStmt, we don't need a `fail` operator.
1721++
1722++ 3. Rebindable syntax might just not make sense. For example, a BodyStmt
1723++ contains the syntax for `guard`, but that's used only in monad comprehensions.
1724++ If we had more of a whiz-bang type system, we might be able to rule this
1725++ case out statically.
1726++-}
1727++
1728++-- | Syntax Expression
1729++--
1730++-- SyntaxExpr is represents the function used in interpreting rebindable
1731++-- syntax. In the parser, we have no information to supply; in the renamer,
1732++-- we have the name of the function (but see
1733++-- Note [Monad fail : Rebindable syntax, overloaded strings] for a wrinkle)
1734++-- and in the type-checker we have a more elaborate structure 'SyntaxExprTc'.
1735++--
1736++-- In some contexts, rebindable syntax is not implemented, and so we have
1737++-- constructors to represent that possibility in both the renamer and
1738++-- typechecker instantiations.
1739++--
1740++-- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for
1741++-- @(>>=)@, and then instantiated by the type checker with its type args
1742++-- etc
1743++type family SyntaxExpr p
1744++
1745++-- | Command Syntax Table (for Arrow syntax)
1746++type CmdSyntaxTable p = [(Name, HsExpr p)]
1747++-- See Note [CmdSyntaxTable]
1748++
1749++{-
1750++Note [CmdSyntaxTable]
1751++~~~~~~~~~~~~~~~~~~~~~
1752++Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps
1753++track of the methods needed for a Cmd.
1754++
1755++* Before the renamer, this list is an empty list
1756++
1757++* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@
1758++ For example, for the 'arr' method
1759++ * normal case: (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr)
1760++ * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22)
1761++ where @arr_22@ is whatever 'arr' is in scope
1762++
1763++* After the type checker, it takes the form [(std_name, <expression>)]
1764++ where <expression> is the evidence for the method. This evidence is
1765++ instantiated with the class, but is still polymorphic in everything
1766++ else. For example, in the case of 'arr', the evidence has type
1767++ forall b c. (b->c) -> a b c
1768++ where 'a' is the ambient type of the arrow. This polymorphism is
1769++ important because the desugarer uses the same evidence at multiple
1770++ different types.
1771++
1772++This is Less Cool than what we normally do for rebindable syntax, which is to
1773++make fully-instantiated piece of evidence at every use site. The Cmd way
1774++is Less Cool because
1775++ * The renamer has to predict which methods are needed.
1776++ See the tedious GHC.Rename.Expr.methodNamesCmd.
1777++
1778++ * The desugarer has to know the polymorphic type of the instantiated
1779++ method. This is checked by Inst.tcSyntaxName, but is less flexible
1780++ than the rest of rebindable syntax, where the type is less
1781++ pre-ordained. (And this flexibility is useful; for example we can
1782++ typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.)
1783++-}
1784++
1785++-- | A Haskell expression.
1786++data HsExpr p
1787++ = HsVar (XVar p)
1788++ (LIdP p) -- ^ Variable
1789++ -- See Note [Located RdrNames]
1790++
1791++ | HsUnboundVar (XUnboundVar p)
1792++ OccName -- ^ Unbound variable; also used for "holes"
1793++ -- (_ or _x).
1794++ -- Turned from HsVar to HsUnboundVar by the
1795++ -- renamer, when it finds an out-of-scope
1796++ -- variable or hole.
1797++ -- The (XUnboundVar p) field becomes an HoleExprRef
1798++ -- after typechecking; this is where the
1799++ -- erroring expression will be written after
1800++ -- solving. See Note [Holes] in GHC.Tc.Types.Constraint.
1801++
1802++ | HsConLikeOut (XConLikeOut p)
1803++ ConLike -- ^ After typechecker only; must be different
1804++ -- HsVar for pretty printing
1805++
1806++ | HsRecFld (XRecFld p)
1807++ (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector
1808++ -- The parser produces HsVars
1809++ -- The renamer renames record-field selectors to HsRecFld
1810++ -- The typechecker preserves HsRecFld
1811++
1812++ | HsOverLabel (XOverLabel p)
1813++ (Maybe (IdP p)) FastString
1814++ -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels)
1815++ -- @Just id@ means @RebindableSyntax@ is in use, and gives the id of the
1816++ -- in-scope 'fromLabel'.
1817++ -- NB: Not in use after typechecking
1818++
1819++ | HsIPVar (XIPVar p)
1820++ HsIPName -- ^ Implicit parameter (not in use after typechecking)
1821++ | HsOverLit (XOverLitE p)
1822++ (HsOverLit p) -- ^ Overloaded literals
1823++
1824++ | HsLit (XLitE p)
1825++ (HsLit p) -- ^ Simple (non-overloaded) literals
1826++
1827++ | HsLam (XLam p)
1828++ (MatchGroup p (LHsExpr p))
1829++ -- ^ Lambda abstraction. Currently always a single match
1830++ --
1831++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',
1832++ -- 'GHC.Parser.Annotation.AnnRarrow',
1833++
1834++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1835++
1836++ | HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p)) -- ^ Lambda-case
1837++ --
1838++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',
1839++ -- 'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen',
1840++ -- 'GHC.Parser.Annotation.AnnClose'
1841++
1842++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1843++
1844++ | HsApp (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application
1845++
1846++ | HsAppType (XAppTypeE p) -- After typechecking: the type argument
1847++ (LHsExpr p)
1848++ (LHsWcType (NoGhcTc p)) -- ^ Visible type application
1849++ --
1850++ -- Explicit type argument; e.g f @Int x y
1851++ -- NB: Has wildcards, but no implicit quantification
1852++ --
1853++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnAt',
1854++
1855++ -- | Operator applications:
1856++ -- NB Bracketed ops such as (+) come out as Vars.
1857++
1858++ -- NB We need an expr for the operator in an OpApp/Section since
1859++ -- the typechecker may need to apply the operator to a few types.
1860++
1861++ | OpApp (XOpApp p)
1862++ (LHsExpr p) -- left operand
1863++ (LHsExpr p) -- operator
1864++ (LHsExpr p) -- right operand
1865++
1866++ -- | Negation operator. Contains the negated expression and the name
1867++ -- of 'negate'
1868++ --
1869++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnMinus'
1870++
1871++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1872++ | NegApp (XNegApp p)
1873++ (LHsExpr p)
1874++ (SyntaxExpr p)
1875++
1876++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,
1877++ -- 'GHC.Parser.Annotation.AnnClose' @')'@
1878++
1879++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1880++ | HsPar (XPar p)
1881++ (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn]
1882++
1883++ | SectionL (XSectionL p)
1884++ (LHsExpr p) -- operand; see Note [Sections in HsSyn]
1885++ (LHsExpr p) -- operator
1886++ | SectionR (XSectionR p)
1887++ (LHsExpr p) -- operator; see Note [Sections in HsSyn]
1888++ (LHsExpr p) -- operand
1889++
1890++ -- | Used for explicit tuples and sections thereof
1891++ --
1892++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
1893++ -- 'GHC.Parser.Annotation.AnnClose'
1894++
1895++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1896++ -- Note [ExplicitTuple]
1897++ | ExplicitTuple
1898++ (XExplicitTuple p)
1899++ [LHsTupArg p]
1900++ Boxity
1901++
1902++ -- | Used for unboxed sum types
1903++ --
1904++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'(#'@,
1905++ -- 'GHC.Parser.Annotation.AnnVbar', 'GHC.Parser.Annotation.AnnClose' @'#)'@,
1906++ --
1907++ -- There will be multiple 'GHC.Parser.Annotation.AnnVbar', (1 - alternative) before
1908++ -- the expression, (arity - alternative) after it
1909++ | ExplicitSum
1910++ (XExplicitSum p)
1911++ ConTag -- Alternative (one-based)
1912++ Arity -- Sum arity
1913++ (LHsExpr p)
1914++
1915++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnCase',
1916++ -- 'GHC.Parser.Annotation.AnnOf','GHC.Parser.Annotation.AnnOpen' @'{'@,
1917++ -- 'GHC.Parser.Annotation.AnnClose' @'}'@
1918++
1919++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1920++ | HsCase (XCase p)
1921++ (LHsExpr p)
1922++ (MatchGroup p (LHsExpr p))
1923++
1924++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf',
1925++ -- 'GHC.Parser.Annotation.AnnSemi',
1926++ -- 'GHC.Parser.Annotation.AnnThen','GHC.Parser.Annotation.AnnSemi',
1927++ -- 'GHC.Parser.Annotation.AnnElse',
1928++
1929++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1930++ | HsIf (XIf p) -- GhcPs: this is a Bool; False <=> do not use
1931++ -- rebindable syntax
1932++ (LHsExpr p) -- predicate
1933++ (LHsExpr p) -- then part
1934++ (LHsExpr p) -- else part
1935++
1936++ -- | Multi-way if
1937++ --
1938++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf'
1939++ -- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose',
1940++
1941++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1942++ | HsMultiIf (XMultiIf p) [LGRHS p (LHsExpr p)]
1943++
1944++ -- | let(rec)
1945++ --
1946++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet',
1947++ -- 'GHC.Parser.Annotation.AnnOpen' @'{'@,
1948++ -- 'GHC.Parser.Annotation.AnnClose' @'}'@,'GHC.Parser.Annotation.AnnIn'
1949++
1950++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1951++ | HsLet (XLet p)
1952++ (LHsLocalBinds p)
1953++ (LHsExpr p)
1954++
1955++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo',
1956++ -- 'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnSemi',
1957++ -- 'GHC.Parser.Annotation.AnnVbar',
1958++ -- 'GHC.Parser.Annotation.AnnClose'
1959++
1960++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1961++ | HsDo (XDo p) -- Type of the whole expression
1962++ (HsStmtContext (HsDoRn p))
1963++ -- The parameterisation of the above is unimportant
1964++ -- because in this context we never use
1965++ -- the PatGuard or ParStmt variant
1966++ (XRec p [ExprLStmt p]) -- "do":one or more stmts
1967++
1968++ -- | Syntactic list: [a,b,c,...]
1969++ --
1970++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@,
1971++ -- 'GHC.Parser.Annotation.AnnClose' @']'@
1972++
1973++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1974++ -- See Note [Empty lists]
1975++ | ExplicitList
1976++ (XExplicitList p) -- Gives type of components of list
1977++ (Maybe (SyntaxExpr p))
1978++ -- For OverloadedLists, the fromListN witness
1979++ [LHsExpr p]
1980++
1981++ -- | Record construction
1982++ --
1983++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@,
1984++ -- 'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose' @'}'@
1985++
1986++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1987++ | RecordCon
1988++ { rcon_ext :: XRecordCon p
1989++ , rcon_con :: XRec p (ConLikeP p) -- The constructor
1990++ , rcon_flds :: HsRecordBinds p } -- The fields
1991++
1992++ -- | Record update
1993++ --
1994++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@,
1995++ -- 'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose' @'}'@
1996++
1997++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
1998++ | RecordUpd
1999++ { rupd_ext :: XRecordUpd p
2000++ , rupd_expr :: LHsExpr p
2001++ , rupd_flds :: [LHsRecUpdField p]
2002++ }
2003++ -- For a type family, the arg types are of the *instance* tycon,
2004++ -- not the family tycon
2005++
2006++ -- | Expression with an explicit type signature. @e :: type@
2007++ --
2008++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'
2009++
2010++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
2011++ | ExprWithTySig
2012++ (XExprWithTySig p)
2013++
2014++ (LHsExpr p)
2015++ (LHsSigWcType (NoGhcTc p))
2016++
2017++ -- | Arithmetic sequence
2018++ --
2019++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@,
2020++ -- 'GHC.Parser.Annotation.AnnComma','GHC.Parser.Annotation.AnnDotdot',
2021++ -- 'GHC.Parser.Annotation.AnnClose' @']'@
2022++
2023++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
2024++ | ArithSeq
2025++ (XArithSeq p)
2026++ (Maybe (SyntaxExpr p))
2027++ -- For OverloadedLists, the fromList witness
2028++ (ArithSeqInfo p)
2029++
2030++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
2031++
2032++ -----------------------------------------------------------
2033++ -- MetaHaskell Extensions
2034++
2035++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
2036++ -- 'GHC.Parser.Annotation.AnnOpenE','GHC.Parser.Annotation.AnnOpenEQ',
2037++ -- 'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnCloseQ'
2038++
2039++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
2040++ | HsBracket (XBracket p) (HsBracket p)
2041++
2042++ -- See Note [Pending Splices]
2043++ | HsRnBracketOut
2044++ (XRnBracketOut p)
2045++ (HsBracket (HsBracketRn p)) -- Output of the renamer is the *original* renamed
2046++ -- expression, plus
2047++ [PendingRnSplice' p] -- _renamed_ splices to be type checked
2048++
2049++ | HsTcBracketOut
2050++ (XTcBracketOut p)
2051++ (Maybe QuoteWrapper) -- The wrapper to apply type and dictionary argument
2052++ -- to the quote.
2053++ (HsBracket (HsBracketRn p)) -- Output of the type checker is the *original*
2054++ -- renamed expression, plus
2055++ [PendingTcSplice' p] -- _typechecked_ splices to be
2056++ -- pasted back in by the desugarer
2057++
2058++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
2059++ -- 'GHC.Parser.Annotation.AnnClose'
2060++
2061++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
2062++ | HsSpliceE (XSpliceE p) (HsSplice p)
2063++
2064++ -----------------------------------------------------------
2065++ -- Arrow notation extension
2066++
2067++ -- | @proc@ notation for Arrows
2068++ --
2069++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnProc',
2070++ -- 'GHC.Parser.Annotation.AnnRarrow'
2071++
2072++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
2073++ | HsProc (XProc p)
2074++ (LPat p) -- arrow abstraction, proc
2075++ (LHsCmdTop p) -- body of the abstraction
2076++ -- always has an empty stack
2077++
2078++ ---------------------------------------
2079++ -- static pointers extension
2080++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnStatic',
2081++
2082++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
2083++ | HsStatic (XStatic p) -- Free variables of the body
2084++ (LHsExpr p) -- Body
2085++
2086++ ---------------------------------------
2087++ -- Haskell program coverage (Hpc) Support
2088++
2089++ | HsTick
2090++ (XTick p)
2091++ CoreTickish
2092++ (LHsExpr p) -- sub-expression
2093++
2094++ | HsBinTick
2095++ (XBinTick p)
2096++ Int -- module-local tick number for True
2097++ Int -- module-local tick number for False
2098++ (LHsExpr p) -- sub-expression
2099++
2100++ ---------------------------------------
2101++ -- Expressions annotated with pragmas, written as {-# ... #-}
2102++ | HsPragE (XPragE p) (HsPragE p) (LHsExpr p)
2103++
2104++ | XExpr !(XXExpr p)
2105++ -- Note [Trees that Grow] extension constructor for the
2106++ -- general idea, and Note [Rebindable syntax and HsExpansion]
2107++ -- for an example of how we use it.
2108++
2109++-- | The AST used to hard-refer to GhcPass, which was a layer violation. For now,
2110++-- we paper it over with this new extension point.
2111++type family HsDoRn p
2112++type family HsBracketRn p
2113++type family PendingRnSplice' p
2114++type family PendingTcSplice' p
2115++
2116++-- ---------------------------------------------------------------------
2117++
2118++{-
2119++Note [Rebindable syntax and HsExpansion]
2120++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2121++
2122++We implement rebindable syntax (RS) support by performing a desugaring
2123++in the renamer. We transform GhcPs expressions affected by RS into the
2124++appropriate desugared form, but **annotated with the original expression**.
2125++
2126++Let us consider a piece of code like:
2127++
2128++ {-# LANGUAGE RebindableSyntax #-}
2129++ ifThenElse :: Char -> () -> () -> ()
2130++ ifThenElse _ _ _ = ()
2131++ x = if 'a' then () else True
2132++
2133++The parsed AST for the RHS of x would look something like (slightly simplified):
2134++
2135++ L locif (HsIf (L loca 'a') (L loctrue ()) (L locfalse True))
2136++
2137++Upon seeing such an AST with RS on, we could transform it into a
2138++mere function call, as per the RS rules, equivalent to the
2139++following function application:
2140++
2141++ ifThenElse 'a' () True
2142++
2143++which doesn't typecheck. But GHC would report an error about
2144++not being able to match the third argument's type (Bool) with the
2145++expected type: (), in the expression _as desugared_, i.e in
2146++the aforementioned function application. But the user never
2147++wrote a function application! This would be pretty bad.
2148++
2149++To remedy this, instead of transforming the original HsIf
2150++node into mere applications of 'ifThenElse', we keep the
2151++original 'if' expression around too, using the TTG
2152++XExpr extension point to allow GHC to construct an
2153++'HsExpansion' value that will keep track of the original
2154++expression in its first field, and the desugared one in the
2155++second field. The resulting renamed AST would look like:
2156++
2157++ L locif (XExpr
2158++ (HsExpanded
2159++ (HsIf (L loca 'a')
2160++ (L loctrue ())
2161++ (L locfalse True)
2162++ )
2163++ (App (L generatedSrcSpan
2164++ (App (L generatedSrcSpan
2165++ (App (L generatedSrcSpan (Var ifThenElse))
2166++ (L loca 'a')
2167++ )
2168++ )
2169++ (L loctrue ())
2170++ )
2171++ )
2172++ (L locfalse True)
2173++ )
2174++ )
2175++ )
2176++
2177++When comes the time to typecheck the program, we end up calling
2178++tcMonoExpr on the AST above. If this expression gives rise to
2179++a type error, then it will appear in a context line and GHC
2180++will pretty-print it using the 'Outputable (HsExpansion a b)'
2181++instance defined below, which *only prints the original
2182++expression*. This is the gist of the idea, but is not quite
2183++enough to recover the error messages that we had with the
2184++SyntaxExpr-based, typechecking/desugaring-to-core time
2185++implementation of rebindable syntax. The key idea is to decorate
2186++some elements of the desugared expression so as to be able to
2187++give them a special treatment when typechecking the desugared
2188++expression, to print a different context line or skip one
2189++altogether.
2190++
2191++Whenever we 'setSrcSpan' a 'generatedSrcSpan', we update a field in
2192++TcLclEnv called 'tcl_in_gen_code', setting it to True, which indicates that we
2193++entered generated code, i.e code fabricated by the compiler when rebinding some
2194++syntax. If someone tries to push some error context line while that field is set
2195++to True, the pushing won't actually happen and the context line is just dropped.
2196++Once we 'setSrcSpan' a real span (for an expression that was in the original
2197++source code), we set 'tcl_in_gen_code' back to False, indicating that we
2198++"emerged from the generated code tunnel", and that the expressions we will be
2199++processing are relevant to report in context lines again.
2200++
2201++You might wonder why we store a RealSrcSpan in addition to a Bool in
2202++the TcLclEnv: could we not store a Maybe RealSrcSpan? The problem is
2203++that we still generate constraints when processing generated code,
2204++and a CtLoc must contain a RealSrcSpan -- otherwise, error messages
2205++might appear without source locations. So we keep the RealSrcSpan of
2206++the last location spotted that wasn't generated; it's as good as
2207++we're going to get in generated code. Once we get to sub-trees that
2208++are not generated, then we update the RealSrcSpan appropriately, and
2209++set the tcl_in_gen_code Bool to False.
2210++
2211++---
2212++
2213++A general recipe to follow this approach for new constructs could go as follows:
2214++
2215++- Remove any GhcRn-time SyntaxExpr extensions to the relevant constructor for your
2216++ construct, in HsExpr or related syntax data types.
2217++- At renaming-time:
2218++ - take your original node of interest (HsIf above)
2219++ - rename its subexpressions (condition, true branch, false branch above)
2220++ - construct the suitable "rebound"-and-renamed result (ifThenElse call
2221++ above), where the 'SrcSpan' attached to any _fabricated node_ (the
2222++ HsVar/HsApp nodes, above) is set to 'generatedSrcSpan'
2223++ - take both the original node and that rebound-and-renamed result and wrap
2224++ them in an XExpr: XExpr (HsExpanded <original node> <desugared>)
2225++ - At typechecking-time:
2226++ - remove any logic that was previously dealing with your rebindable
2227++ construct, typically involving [tc]SyntaxOp, SyntaxExpr and friends.
2228++ - the XExpr (HsExpanded ... ...) case in tcExpr already makes sure that we
2229++ typecheck the desugared expression while reporting the original one in
2230++ errors
2231++
2232++-}
2233++
2234++-- See Note [Rebindable syntax and HsExpansion] just above.
2235++data HsExpansion a b
2236++ = HsExpanded a b
2237++ deriving Data
2238++
2239++-- | Build a "wrapped" 'HsExpansion' out of an extension constructor,
2240++-- and the two components of the expansion: original and desugared
2241++-- expressions.
2242++--
2243++-- See Note [Rebindable Syntax and HsExpansion] above for more details.
2244++mkExpanded
2245++ :: (HsExpansion a b -> b) -- ^ XExpr, XCmd, ...
2246++ -> a -- ^ source expression ('GhcPs')
2247++ -> b -- ^ "desugared" expression
2248++ -- ('GhcRn')
2249++ -> b -- ^ suitably wrapped
2250++ -- 'HsExpansion'
2251++mkExpanded xwrap a b = xwrap (HsExpanded a b)
2252++
2253++-- | Just print the original expression (the @a@).
2254++instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where
2255++ ppr (HsExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a)
2256++
2257++-- ---------------------------------------------------------------------
2258++
2259++-- | A pragma, written as {-# ... #-}, that may appear within an expression.
2260++data HsPragE p
2261++ = HsPragSCC (XSCC p)
2262++ SourceText -- Note [Pragma source text] in GHC.Types.SourceText
2263++ StringLiteral -- "set cost centre" SCC pragma
2264++
2265++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
2266++ -- 'GHC.Parser.Annotation.AnnOpen' @'{-\# GENERATED'@,
2267++ -- 'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnVal',
2268++ -- 'GHC.Parser.Annotation.AnnColon','GHC.Parser.Annotation.AnnVal',
2269++ -- 'GHC.Parser.Annotation.AnnMinus',
2270++ -- 'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnColon',
2271++ -- 'GHC.Parser.Annotation.AnnVal',
2272++ -- 'GHC.Parser.Annotation.AnnClose' @'\#-}'@
2273++
2274++ | XHsPragE !(XXPragE p)
2275++
2276++-- | Located Haskell Tuple Argument
2277++--
2278++-- 'HsTupArg' is used for tuple sections
2279++-- @(,a,)@ is represented by
2280++-- @ExplicitTuple [Missing ty1, Present a, Missing ty3]@
2281++-- Which in turn stands for @(\x:ty1 \y:ty2. (x,a,y))@
2282++type LHsTupArg id = XRec id (HsTupArg id)
2283++-- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma'
2284++
2285++-- For details on above see note [Api annotations] in GHC.Parser.Annotation
2286++
2287++-- | Haskell Tuple Argument
2288++data HsTupArg id
2289++ = Present (XPresent id) (LHsExpr id) -- ^ The argument
2290++ | Missing (XMissing id) -- ^ The argument is missing, but this is its type
2291++ | XTupArg !(XXTupArg id) -- ^ Note [Trees that Grow] extension point
2292++
2293++{-
2294++Note [Parens in HsSyn]
2295++~~~~~~~~~~~~~~~~~~~~~~
2296++HsPar (and ParPat in patterns, HsParTy in types) is used as follows
2297++
2298++ * HsPar is required; the pretty printer does not add parens.
2299++
2300++ * HsPars are respected when rearranging operator fixities.
2301++ So a * (b + c) means what it says (where the parens are an HsPar)
2302++
2303++ * For ParPat and HsParTy the pretty printer does add parens but this should be
2304++ a no-op for ParsedSource, based on the pretty printer round trip feature
2305++ introduced in
2306++ https://phabricator.haskell.org/rGHC499e43824bda967546ebf95ee33ec1f84a114a7c
2307++
2308++ * ParPat and HsParTy are pretty printed as '( .. )' regardless of whether or
2309++ not they are strictly necessary. This should be addressed when #13238 is
2310++ completed, to be treated the same as HsPar.
2311++
2312++
2313++Note [Sections in HsSyn]
2314++~~~~~~~~~~~~~~~~~~~~~~~~
2315++Sections should always appear wrapped in an HsPar, thus
2316++ HsPar (SectionR ...)
2317++The parser parses sections in a wider variety of situations
2318++(See Note [Parsing sections]), but the renamer checks for those
2319++parens. This invariant makes pretty-printing easier; we don't need
2320++a special case for adding the parens round sections.
2321++
2322++Note [Rebindable if]
2323++~~~~~~~~~~~~~~~~~~~~
2324++The rebindable syntax for 'if' is a bit special, because when
2325++rebindable syntax is *off* we do not want to treat
2326++ (if c then t else e)
2327++as if it was an application (ifThenElse c t e). Why not?
2328++Because we allow an 'if' to return *unboxed* results, thus
2329++ if blah then 3# else 4#
2330++whereas that would not be possible using a all to a polymorphic function
2331++(because you can't call a polymorphic function at an unboxed type).
2332++
2333++So we use NoSyntaxExpr to mean "use the old built-in typing rule".
2334++
2335++A further complication is that, in the `deriving` code, we never want
2336++to use rebindable syntax. So, even in GhcPs, we want to denote whether
2337++to use rebindable syntax or not. This is done via the type instance
2338++for XIf GhcPs.
2339++
2340++Note [Record Update HsWrapper]
2341++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2342++There is a wrapper in RecordUpd which is used for the *required*
2343++constraints for pattern synonyms. This wrapper is created in the
2344++typechecking and is then directly used in the desugaring without
2345++modification.
2346++
2347++For example, if we have the record pattern synonym P,
2348++ pattern P :: (Show a) => a -> Maybe a
2349++ pattern P{x} = Just x
2350++
2351++ foo = (Just True) { x = False }
2352++then `foo` desugars to something like
2353++ foo = case Just True of
2354++ P x -> P False
2355++hence we need to provide the correct dictionaries to P's matcher on
2356++the RHS so that we can build the expression.
2357++
2358++Note [Located RdrNames]
2359++~~~~~~~~~~~~~~~~~~~~~~~
2360++A number of syntax elements have seemingly redundant locations attached to them.
2361++This is deliberate, to allow transformations making use of the API Annotations
2362++to easily correlate a Located Name in the RenamedSource with a Located RdrName
2363++in the ParsedSource.
2364++
2365++There are unfortunately enough differences between the ParsedSource and the
2366++RenamedSource that the API Annotations cannot be used directly with
2367++RenamedSource, so this allows a simple mapping to be used based on the location.
2368++
2369++Note [ExplicitTuple]
2370++~~~~~~~~~~~~~~~~~~~~
2371++An ExplicitTuple is never just a data constructor like (,,,).
2372++That is, the `[LHsTupArg p]` argument of `ExplicitTuple` has at least
2373++one `Present` member (and is thus never empty).
2374++
2375++A tuple data constructor like () or (,,,) is parsed as an `HsVar`, not an
2376++`ExplicitTuple`, and stays that way. This is important for two reasons:
2377++
2378++ 1. We don't need -XTupleSections for (,,,)
2379++ 2. The type variables in (,,,) can be instantiated with visible type application.
2380++ That is,
2381++
2382++ (,,) :: forall a b c. a -> b -> c -> (a,b,c)
2383++ (True,,) :: forall {b} {c}. b -> c -> (Bool,b,c)
2384++
2385++ Note that the tuple section has *inferred* arguments, while the data
2386++ constructor has *specified* ones.
2387++ (See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl
2388++ for background.)
2389++
2390++Sadly, the grammar for this is actually ambiguous, and it's only thanks to the
2391++preference of a shift in a shift/reduce conflict that the parser works as this
2392++Note details. Search for a reference to this Note in GHC.Parser for further
2393++explanation.
2394++
2395++Note [Empty lists]
2396++~~~~~~~~~~~~~~~~~~
2397++An empty list could be considered either a data constructor (stored with
2398++HsVar) or an ExplicitList. This Note describes how empty lists flow through the
2399++various phases and why.
2400++
2401++Parsing
2402++-------
2403++An empty list is parsed by the sysdcon nonterminal. It thus comes to life via
2404++HsVar nilDataCon (defined in GHC.Builtin.Types). A freshly-parsed (HsExpr GhcPs) empty list
2405++is never a ExplicitList.
2406++
2407++Renaming
2408++--------
2409++If -XOverloadedLists is enabled, we must type-check the empty list as if it
2410++were a call to fromListN. (This is true regardless of the setting of
2411++-XRebindableSyntax.) This is very easy if the empty list is an ExplicitList,
2412++but an annoying special case if it's an HsVar. So the renamer changes a
2413++HsVar nilDataCon to an ExplicitList [], but only if -XOverloadedLists is on.
2414++(Why not always? Read on, dear friend.) This happens in the HsVar case of rnExpr.
2415++
2416++Type-checking
2417++-------------
2418++We want to accept an expression like [] @Int. To do this, we must infer that
2419++[] :: forall a. [a]. This is easy if [] is a HsVar with the right DataCon inside.
2420++However, the type-checking for explicit lists works differently: [x,y,z] is never
2421++polymorphic. Instead, we unify the types of x, y, and z together, and use the
2422++unified type as the argument to the cons and nil constructors. Thus, treating
2423++[] as an empty ExplicitList in the type-checker would prevent [] @Int from working.
2424++
2425++However, if -XOverloadedLists is on, then [] @Int really shouldn't be allowed:
2426++it's just like fromListN 0 [] @Int. Since
2427++ fromListN :: forall list. IsList list => Int -> [Item list] -> list
2428++that expression really should be rejected. Thus, the renamer's behaviour is
2429++exactly what we want: treat [] as a datacon when -XNoOverloadedLists, and as
2430++an empty ExplicitList when -XOverloadedLists.
2431++
2432++See also #13680, which requested [] @Int to work.
2433++-}
2434++
2435++
2436++-----------------------
2437++pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc
2438++pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))
2439++ = ppr (src,(n1,n2),(n3,n4))
2440++
2441++{-
2442++HsSyn records exactly where the user put parens, with HsPar.
2443++So generally speaking we print without adding any parens.
2444++However, some code is internally generated, and in some places
2445++parens are absolutely required; so for these places we use
2446++pprParendLExpr (but don't print double parens of course).
2447++
2448++For operator applications we don't add parens, because the operator
2449++fixities should do the job, except in debug mode (-dppr-debug) so we
2450++can see the structure of the parse tree.
2451++-}
2452++
2453++{-
2454++************************************************************************
2455++* *
2456++\subsection{Commands (in arrow abstractions)}
2457++* *
2458++************************************************************************
2459++
2460++We re-use HsExpr to represent these.
2461++-}
2462++
2463++-- | Located Haskell Command (for arrow syntax)
2464++type LHsCmd id = XRec id (HsCmd id)
2465++
2466++-- | Haskell Command (e.g. a "statement" in an Arrow proc block)
2467++data HsCmd id
2468++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.Annlarrowtail',
2469++ -- 'GHC.Parser.Annotation.Annrarrowtail','GHC.Parser.Annotation.AnnLarrowtail',
2470++ -- 'GHC.Parser.Annotation.AnnRarrowtail'
2471++
2472++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
2473++ = HsCmdArrApp -- Arrow tail, or arrow application (f -< arg)
2474++ (XCmdArrApp id) -- type of the arrow expressions f,
2475++ -- of the form a t t', where arg :: t
2476++ (LHsExpr id) -- arrow expression, f
2477++ (LHsExpr id) -- input expression, arg
2478++ HsArrAppType -- higher-order (-<<) or first-order (-<)
2479++ Bool -- True => right-to-left (f -< arg)
2480++ -- False => left-to-right (arg >- f)
2481++
2482++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpenB' @'(|'@,
2483++ -- 'GHC.Parser.Annotation.AnnCloseB' @'|)'@
2484++
2485++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
2486++ | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |)
2487++ (XCmdArrForm id)
2488++ (LHsExpr id) -- The operator.
2489++ -- After type-checking, a type abstraction to be
2490++ -- applied to the type of the local environment tuple
2491++ LexicalFixity -- Whether the operator appeared prefix or infix when
2492++ -- parsed.
2493++ (Maybe Fixity) -- fixity (filled in by the renamer), for forms that
2494++ -- were converted from OpApp's by the renamer
2495++ [LHsCmdTop id] -- argument commands
2496++
2497++ | HsCmdApp (XCmdApp id)
2498++ (LHsCmd id)
2499++ (LHsExpr id)
2500++
2501++ | HsCmdLam (XCmdLam id)
2502++ (MatchGroup id (LHsCmd id)) -- kappa
2503++ -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',
2504++ -- 'GHC.Parser.Annotation.AnnRarrow',
2505++
2506++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
2507++
2508++ | HsCmdPar (XCmdPar id)
2509++ (LHsCmd id) -- parenthesised command
2510++ -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,
2511++ -- 'GHC.Parser.Annotation.AnnClose' @')'@
2512++
2513++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
2514++
2515++ | HsCmdCase (XCmdCase id)
2516++ (LHsExpr id)
2517++ (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's
2518++ -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnCase',
2519++ -- 'GHC.Parser.Annotation.AnnOf','GHC.Parser.Annotation.AnnOpen' @'{'@,
2520++ -- 'GHC.Parser.Annotation.AnnClose' @'}'@
2521++
2522++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
2523++
2524++ | HsCmdLamCase (XCmdLamCase id)
2525++ (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's
2526++ -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',
2527++ -- 'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen' @'{'@,
2528++ -- 'GHC.Parser.Annotation.AnnClose' @'}'@
2529++
2530++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
2531++
2532++ | HsCmdIf (XCmdIf id)
2533++ (SyntaxExpr id) -- cond function
2534++ (LHsExpr id) -- predicate
2535++ (LHsCmd id) -- then part
2536++ (LHsCmd id) -- else part
2537++ -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf',
2538++ -- 'GHC.Parser.Annotation.AnnSemi',
2539++ -- 'GHC.Parser.Annotation.AnnThen','GHC.Parser.Annotation.AnnSemi',
2540++ -- 'GHC.Parser.Annotation.AnnElse',
2541++
2542++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
2543++
2544++ | HsCmdLet (XCmdLet id)
2545++ (LHsLocalBinds id) -- let(rec)
2546++ (LHsCmd id)
2547++ -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet',
2548++ -- 'GHC.Parser.Annotation.AnnOpen' @'{'@,
2549++ -- 'GHC.Parser.Annotation.AnnClose' @'}'@,'GHC.Parser.Annotation.AnnIn'
2550++
2551++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
2552++
2553++ | HsCmdDo (XCmdDo id) -- Type of the whole expression
2554++ (XRec id [CmdLStmt id])
2555++ -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo',
2556++ -- 'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnSemi',
2557++ -- 'GHC.Parser.Annotation.AnnVbar',
2558++ -- 'GHC.Parser.Annotation.AnnClose'
2559++
2560++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
2561++
2562++ | XCmd !(XXCmd id) -- Note [Trees that Grow] extension point
2563++
2564++
2565++-- | Haskell Array Application Type
2566++data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
2567++ deriving Data
2568++
2569++
2570++{- | Top-level command, introducing a new arrow.
2571++This may occur inside a proc (where the stack is empty) or as an
2572++argument of a command-forming operator.
2573++-}
2574++
2575++-- | Located Haskell Top-level Command
2576++type LHsCmdTop p = XRec p (HsCmdTop p)
2577++
2578++-- | Haskell Top-level Command
2579++data HsCmdTop p
2580++ = HsCmdTop (XCmdTop p)
2581++ (LHsCmd p)
2582++ | XCmdTop !(XXCmdTop p) -- Note [Trees that Grow] extension point
2583++
2584++-----------------------
2585++
2586++{-
2587++************************************************************************
2588++* *
2589++\subsection{Record binds}
2590++* *
2591++************************************************************************
2592++-}
2593++
2594++-- | Haskell Record Bindings
2595++type HsRecordBinds p = HsRecFields p (LHsExpr p)
2596++
2597++{-
2598++************************************************************************
2599++* *
2600++\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}
2601++* *
2602++************************************************************************
2603++
2604++@Match@es are sets of pattern bindings and right hand sides for
2605++functions, patterns or case branches. For example, if a function @g@
2606++is defined as:
2607++\begin{verbatim}
2608++g (x,y) = y
2609++g ((x:ys),y) = y+1,
2610++\end{verbatim}
2611++then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@.
2612++
2613++It is always the case that each element of an @[Match]@ list has the
2614++same number of @pats@s inside it. This corresponds to saying that
2615++a function defined by pattern matching must have the same number of
2616++patterns in each equation.
2617++-}
2618++
2619++data MatchGroup p body
2620++ = MG { mg_ext :: XMG p body -- Post-typechecker, types of args and result
2621++ , mg_alts :: XRec p [LMatch p body] -- The alternatives
2622++ , mg_origin :: Origin }
2623++ -- The type is the type of the entire group
2624++ -- t1 -> ... -> tn -> tr
2625++ -- where there are n patterns
2626++ | XMatchGroup !(XXMatchGroup p body)
2627++
2628++data MatchGroupTc
2629++ = MatchGroupTc
2630++ { mg_arg_tys :: [Scaled Type] -- Types of the arguments, t1..tn
2631++ , mg_res_ty :: Type -- Type of the result, tr
2632++ } deriving Data
2633++
2634++-- | Located Match
2635++type LMatch id body = XRec id (Match id body)
2636++-- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a
2637++-- list
2638++
2639++-- For details on above see note [Api annotations] in GHC.Parser.Annotation
2640++data Match p body
2641++ = Match {
2642++ m_ext :: XCMatch p body,
2643++ m_ctxt :: HsMatchContext (NoGhcTc p),
2644++ -- See note [m_ctxt in Match]
2645++ m_pats :: [LPat p], -- The patterns
2646++ m_grhss :: (GRHSs p body)
2647++ }
2648++ | XMatch !(XXMatch p body)
2649++
2650++{-
2651++Note [m_ctxt in Match]
2652++~~~~~~~~~~~~~~~~~~~~~~
2653++
2654++A Match can occur in a number of contexts, such as a FunBind, HsCase, HsLam and
2655++so on.
2656++
2657++In order to simplify tooling processing and pretty print output, the provenance
2658++is captured in an HsMatchContext.
2659++
2660++This is particularly important for the API Annotations for a multi-equation
2661++FunBind.
2662++
2663++The parser initially creates a FunBind with a single Match in it for
2664++every function definition it sees.
2665++
2666++These are then grouped together by getMonoBind into a single FunBind,
2667++where all the Matches are combined.
2668++
2669++In the process, all the original FunBind fun_id's bar one are
2670++discarded, including the locations.
2671++
2672++This causes a problem for source to source conversions via API
2673++Annotations, so the original fun_ids and infix flags are preserved in
2674++the Match, when it originates from a FunBind.
2675++
2676++Example infix function definition requiring individual API Annotations
2677++
2678++ (&&& ) [] [] = []
2679++ xs &&& [] = xs
2680++ ( &&& ) [] ys = ys
2681++
2682++
2683++
2684++-}
2685++
2686++
2687++isInfixMatch :: Match id body -> Bool
2688++isInfixMatch match = case m_ctxt match of
2689++ FunRhs {mc_fixity = Infix} -> True
2690++ _ -> False
2691++
2692++-- | Guarded Right-Hand Sides
2693++--
2694++-- GRHSs are used both for pattern bindings and for Matches
2695++--
2696++-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVbar',
2697++-- 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere',
2698++-- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose'
2699++-- 'GHC.Parser.Annotation.AnnRarrow','GHC.Parser.Annotation.AnnSemi'
2700++
2701++-- For details on above see note [Api annotations] in GHC.Parser.Annotation
2702++data GRHSs p body
2703++ = GRHSs {
2704++ grhssExt :: XCGRHSs p body,
2705++ grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs
2706++ grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause
2707++ }
2708++ | XGRHSs !(XXGRHSs p body)
2709++
2710++-- | Located Guarded Right-Hand Side
2711++type LGRHS id body = XRec id (GRHS id body)
2712++
2713++-- | Guarded Right Hand Side.
2714++data GRHS p body = GRHS (XCGRHS p body)
2715++ [GuardLStmt p] -- Guards
2716++ body -- Right hand side
2717++ | XGRHS !(XXGRHS p body)
2718++
2719++-- We know the list must have at least one @Match@ in it.
2720++
2721++{-
2722++************************************************************************
2723++* *
2724++\subsection{Do stmts and list comprehensions}
2725++* *
2726++************************************************************************
2727++-}
2728++
2729++-- | Located @do@ block Statement
2730++type LStmt id body = XRec id (StmtLR id id body)
2731++
2732++-- | Located Statement with separate Left and Right id's
2733++type LStmtLR idL idR body = XRec idL (StmtLR idL idR body)
2734++
2735++-- | @do@ block Statement
2736++type Stmt id body = StmtLR id id body
2737++
2738++-- | Command Located Statement
2739++type CmdLStmt id = LStmt id (LHsCmd id)
2740++
2741++-- | Command Statement
2742++type CmdStmt id = Stmt id (LHsCmd id)
2743++
2744++-- | Expression Located Statement
2745++type ExprLStmt id = LStmt id (LHsExpr id)
2746++
2747++-- | Expression Statement
2748++type ExprStmt id = Stmt id (LHsExpr id)
2749++
2750++-- | Guard Located Statement
2751++type GuardLStmt id = LStmt id (LHsExpr id)
2752++
2753++-- | Guard Statement
2754++type GuardStmt id = Stmt id (LHsExpr id)
2755++
2756++-- | Ghci Located Statement
2757++type GhciLStmt id = LStmt id (LHsExpr id)
2758++
2759++-- | Ghci Statement
2760++type GhciStmt id = Stmt id (LHsExpr id)
2761++
2762++-- The SyntaxExprs in here are used *only* for do-notation and monad
2763++-- comprehensions, which have rebindable syntax. Otherwise they are unused.
2764++-- | API Annotations when in qualifier lists or guards
2765++-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVbar',
2766++-- 'GHC.Parser.Annotation.AnnComma','GHC.Parser.Annotation.AnnThen',
2767++-- 'GHC.Parser.Annotation.AnnBy','GHC.Parser.Annotation.AnnBy',
2768++-- 'GHC.Parser.Annotation.AnnGroup','GHC.Parser.Annotation.AnnUsing'
2769++
2770++-- For details on above see note [Api annotations] in GHC.Parser.Annotation
2771++data StmtLR idL idR body -- body should always be (LHs**** idR)
2772++ = LastStmt -- Always the last Stmt in ListComp, MonadComp,
2773++ -- and (after the renamer, see GHC.Rename.Expr.checkLastStmt) DoExpr, MDoExpr
2774++ -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff
2775++ (XLastStmt idL idR body)
2776++ body
2777++ (Maybe Bool) -- Whether return was stripped
2778++ -- Just True <=> return with a dollar was stripped by ApplicativeDo
2779++ -- Just False <=> return without a dollar was stripped by ApplicativeDo
2780++ -- Nothing <=> Nothing was stripped
2781++ (SyntaxExpr idR) -- The return operator
2782++ -- The return operator is used only for MonadComp
2783++ -- For ListComp we use the baked-in 'return'
2784++ -- For DoExpr, MDoExpr, we don't apply a 'return' at all
2785++ -- See Note [Monad Comprehensions]
2786++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLarrow'
2787++
2788++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
2789++ | BindStmt (XBindStmt idL idR body)
2790++ -- ^ Post renaming has optional fail and bind / (>>=) operator.
2791++ -- Post typechecking, also has multiplicity of the argument
2792++ -- and the result type of the function passed to bind;
2793++ -- that is, (P, S) in (>>=) :: Q -> (R # P -> S) -> T
2794++ -- See Note [The type of bind in Stmts]
2795++ (LPat idL)
2796++ body
2797++
2798++ -- | 'ApplicativeStmt' represents an applicative expression built with
2799++ -- '<$>' and '<*>'. It is generated by the renamer, and is desugared into the
2800++ -- appropriate applicative expression by the desugarer, but it is intended
2801++ -- to be invisible in error messages.
2802++ --
2803++ -- For full details, see Note [ApplicativeDo] in "GHC.Rename.Expr"
2804++ --
2805++ | ApplicativeStmt
2806++ (XApplicativeStmt idL idR body) -- Post typecheck, Type of the body
2807++ [ ( SyntaxExpr idR
2808++ , ApplicativeArg idL) ]
2809++ -- [(<$>, e1), (<*>, e2), ..., (<*>, en)]
2810++ (Maybe (SyntaxExpr idR)) -- 'join', if necessary
2811++
2812++ | BodyStmt (XBodyStmt idL idR body) -- Post typecheck, element type
2813++ -- of the RHS (used for arrows)
2814++ body -- See Note [BodyStmt]
2815++ (SyntaxExpr idR) -- The (>>) operator
2816++ (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp
2817++ -- See notes [Monad Comprehensions]
2818++
2819++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet'
2820++ -- 'GHC.Parser.Annotation.AnnOpen' @'{'@,'GHC.Parser.Annotation.AnnClose' @'}'@,
2821++
2822++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
2823++ | LetStmt (XLetStmt idL idR body) (LHsLocalBindsLR idL idR)
2824++
2825++ -- ParStmts only occur in a list/monad comprehension
2826++ | ParStmt (XParStmt idL idR body) -- Post typecheck,
2827++ -- S in (>>=) :: Q -> (R -> S) -> T
2828++ [ParStmtBlock idL idR]
2829++ (HsExpr idR) -- Polymorphic `mzip` for monad comprehensions
2830++ (SyntaxExpr idR) -- The `>>=` operator
2831++ -- See notes [Monad Comprehensions]
2832++ -- After renaming, the ids are the binders
2833++ -- bound by the stmts and used after themp
2834++
2835++ | TransStmt {
2836++ trS_ext :: XTransStmt idL idR body, -- Post typecheck,
2837++ -- R in (>>=) :: Q -> (R -> S) -> T
2838++ trS_form :: TransForm,
2839++ trS_stmts :: [ExprLStmt idL], -- Stmts to the *left* of the 'group'
2840++ -- which generates the tuples to be grouped
2841++
2842++ trS_bndrs :: [(IdP idR, IdP idR)], -- See Note [TransStmt binder map]
2843++
2844++ trS_using :: LHsExpr idR,
2845++ trS_by :: Maybe (LHsExpr idR), -- "by e" (optional)
2846++ -- Invariant: if trS_form = GroupBy, then grp_by = Just e
2847++
2848++ trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for
2849++ -- the inner monad comprehensions
2850++ trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator
2851++ trS_fmap :: HsExpr idR -- The polymorphic 'fmap' function for desugaring
2852++ -- Only for 'group' forms
2853++ -- Just a simple HsExpr, because it's
2854++ -- too polymorphic for tcSyntaxOp
2855++ } -- See Note [Monad Comprehensions]
2856++
2857++ -- Recursive statement (see Note [How RecStmt works] below)
2858++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRec'
2859++
2860++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation
2861++ | RecStmt
2862++ { recS_ext :: XRecStmt idL idR body
2863++ , recS_stmts :: [LStmtLR idL idR body]
2864++
2865++ -- The next two fields are only valid after renaming
2866++ , recS_later_ids :: [IdP idR]
2867++ -- The ids are a subset of the variables bound by the
2868++ -- stmts that are used in stmts that follow the RecStmt
2869++
2870++ , recS_rec_ids :: [IdP idR]
2871++ -- Ditto, but these variables are the "recursive" ones,
2872++ -- that are used before they are bound in the stmts of
2873++ -- the RecStmt.
2874++ -- An Id can be in both groups
2875++ -- Both sets of Ids are (now) treated monomorphically
2876++ -- See Note [How RecStmt works] for why they are separate
2877++
2878++ -- Rebindable syntax
2879++ , recS_bind_fn :: SyntaxExpr idR -- The bind function
2880++ , recS_ret_fn :: SyntaxExpr idR -- The return function
2881++ , recS_mfix_fn :: SyntaxExpr idR -- The mfix function
2882++ }
2883++ | XStmtLR !(XXStmtLR idL idR body)
2884++
2885++data TransForm -- The 'f' below is the 'using' function, 'e' is the by function
2886++ = ThenForm -- then f or then f by e (depending on trS_by)
2887++ | GroupForm -- then group using f or then group by e using f (depending on trS_by)
2888++ deriving Data
2889++
2890++-- | Parenthesised Statement Block
2891++data ParStmtBlock idL idR
2892++ = ParStmtBlock
2893++ (XParStmtBlock idL idR)
2894++ [ExprLStmt idL]
2895++ [IdP idR] -- The variables to be returned
2896++ (SyntaxExpr idR) -- The return operator
2897++ | XParStmtBlock !(XXParStmtBlock idL idR)
2898++
2899++-- | The fail operator
2900++--
2901++-- This is used for `.. <-` "bind statments" in do notation, including
2902++-- non-monadic "binds" in applicative.
2903++--
2904++-- The fail operator is 'Just expr' if it potentially fail monadically. if the
2905++-- pattern match cannot fail, or shouldn't fail monadically (regular incomplete
2906++-- pattern exception), it is 'Nothing'.
2907++--
2908++-- See Note [Monad fail : Rebindable syntax, overloaded strings] for the type of
2909++-- expression in the 'Just' case, and why it is so.
2910++--
2911++-- See Note [Failing pattern matches in Stmts] for which contexts for
2912++-- '@BindStmt@'s should use the monadic fail and which shouldn't.
2913++type FailOperator id = Maybe (SyntaxExpr id)
2914++
2915++-- | Applicative Argument
2916++data ApplicativeArg idL
2917++ = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt)
2918++ { xarg_app_arg_one :: XApplicativeArgOne idL
2919++ -- ^ The fail operator, after renaming
2920++ --
2921++ -- The fail operator is needed if this is a BindStmt
2922++ -- where the pattern can fail. E.g.:
2923++ -- (Just a) <- stmt
2924++ -- The fail operator will be invoked if the pattern
2925++ -- match fails.
2926++ -- It is also used for guards in MonadComprehensions.
2927++ -- The fail operator is Nothing
2928++ -- if the pattern match can't fail
2929++ , app_arg_pattern :: LPat idL -- WildPat if it was a BodyStmt (see below)
2930++ , arg_expr :: LHsExpr idL
2931++ , is_body_stmt :: Bool
2932++ -- ^ True <=> was a BodyStmt,
2933++ -- False <=> was a BindStmt.
2934++ -- See Note [Applicative BodyStmt]
2935++ }
2936++ | ApplicativeArgMany -- do { stmts; return vars }
2937++ { xarg_app_arg_many :: XApplicativeArgMany idL
2938++ , app_stmts :: [ExprLStmt idL] -- stmts
2939++ , final_expr :: HsExpr idL -- return (v1,..,vn), or just (v1,..,vn)
2940++ , bv_pattern :: LPat idL -- (v1,...,vn)
2941++ , stmt_context :: HsStmtContext (ApplicativeArgStmCtxPass idL)
2942++ -- ^ context of the do expression, used in pprArg
2943++ }
2944++ | XApplicativeArg !(XXApplicativeArg idL)
2945++
2946++type family ApplicativeArgStmCtxPass idL
2947++
2948++{-
2949++Note [The type of bind in Stmts]
2950++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2951++Some Stmts, notably BindStmt, keep the (>>=) bind operator.
2952++We do NOT assume that it has type
2953++ (>>=) :: m a -> (a -> m b) -> m b
2954++In some cases (see #303, #1537) it might have a more
2955++exotic type, such as
2956++ (>>=) :: m i j a -> (a -> m j k b) -> m i k b
2957++So we must be careful not to make assumptions about the type.
2958++In particular, the monad may not be uniform throughout.
2959++
2960++Note [TransStmt binder map]
2961++~~~~~~~~~~~~~~~~~~~~~~~~~~~
2962++The [(idR,idR)] in a TransStmt behaves as follows:
2963++
2964++ * Before renaming: []
2965++
2966++ * After renaming:
2967++ [ (x27,x27), ..., (z35,z35) ]
2968++ These are the variables
2969++ bound by the stmts to the left of the 'group'
2970++ and used either in the 'by' clause,
2971++ or in the stmts following the 'group'
2972++ Each item is a pair of identical variables.
2973++
2974++ * After typechecking:
2975++ [ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ]
2976++ Each pair has the same unique, but different *types*.
2977++
2978++Note [BodyStmt]
2979++~~~~~~~~~~~~~~~
2980++BodyStmts are a bit tricky, because what they mean
2981++depends on the context. Consider the following contexts:
2982++
2983++ A do expression of type (m res_ty)
2984++ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2985++ * BodyStmt E any_ty: do { ....; E; ... }
2986++ E :: m any_ty
2987++ Translation: E >> ...
2988++
2989++ A list comprehensions of type [elt_ty]
2990++ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2991++ * BodyStmt E Bool: [ .. | .... E ]
2992++ [ .. | ..., E, ... ]
2993++ [ .. | .... | ..., E | ... ]
2994++ E :: Bool
2995++ Translation: if E then fail else ...
2996++
2997++ A guard list, guarding a RHS of type rhs_ty
2998++ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2999++ * BodyStmt E BooParStmtBlockl: f x | ..., E, ... = ...rhs...
3000++ E :: Bool
3001++ Translation: if E then fail else ...
3002++
3003++ A monad comprehension of type (m res_ty)
3004++ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3005++ * BodyStmt E Bool: [ .. | .... E ]
3006++ E :: Bool
3007++ Translation: guard E >> ...
3008++
3009++Array comprehensions are handled like list comprehensions.
3010++
3011++Note [How RecStmt works]
3012++~~~~~~~~~~~~~~~~~~~~~~~~
3013++Example:
3014++ HsDo [ BindStmt x ex
3015++
3016++ , RecStmt { recS_rec_ids = [a, c]
3017++ , recS_stmts = [ BindStmt b (return (a,c))
3018++ , LetStmt a = ...b...
3019++ , BindStmt c ec ]
3020++ , recS_later_ids = [a, b]
3021++
3022++ , return (a b) ]
3023++
3024++Here, the RecStmt binds a,b,c; but
3025++ - Only a,b are used in the stmts *following* the RecStmt,
3026++ - Only a,c are used in the stmts *inside* the RecStmt
3027++ *before* their bindings
3028++
3029++Why do we need *both* rec_ids and later_ids? For monads they could be
3030++combined into a single set of variables, but not for arrows. That
3031++follows from the types of the respective feedback operators:
3032++
3033++ mfix :: MonadFix m => (a -> m a) -> m a
3034++ loop :: ArrowLoop a => a (b,d) (c,d) -> a b c
3035++
3036++* For mfix, the 'a' covers the union of the later_ids and the rec_ids
3037++* For 'loop', 'c' is the later_ids and 'd' is the rec_ids
3038++
3039++Note [Typing a RecStmt]
3040++~~~~~~~~~~~~~~~~~~~~~~~
3041++A (RecStmt stmts) types as if you had written
3042++
3043++ (v1,..,vn, _, ..., _) <- mfix (\~(_, ..., _, r1, ..., rm) ->
3044++ do { stmts
3045++ ; return (v1,..vn, r1, ..., rm) })
3046++
3047++where v1..vn are the later_ids
3048++ r1..rm are the rec_ids
3049++
3050++Note [Monad Comprehensions]
3051++~~~~~~~~~~~~~~~~~~~~~~~~~~~
3052++Monad comprehensions require separate functions like 'return' and
3053++'>>=' for desugaring. These functions are stored in the statements
3054++used in monad comprehensions. For example, the 'return' of the 'LastStmt'
3055++expression is used to lift the body of the monad comprehension:
3056++
3057++ [ body | stmts ]
3058++ =>
3059++ stmts >>= \bndrs -> return body
3060++
3061++In transform and grouping statements ('then ..' and 'then group ..') the
3062++'return' function is required for nested monad comprehensions, for example:
3063++
3064++ [ body | stmts, then f, rest ]
3065++ =>
3066++ f [ env | stmts ] >>= \bndrs -> [ body | rest ]
3067++
3068++BodyStmts require the 'Control.Monad.guard' function for boolean
3069++expressions:
3070++
3071++ [ body | exp, stmts ]
3072++ =>
3073++ guard exp >> [ body | stmts ]
3074++
3075++Parallel statements require the 'Control.Monad.Zip.mzip' function:
3076++
3077++ [ body | stmts1 | stmts2 | .. ]
3078++ =>
3079++ mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body
3080++
3081++In any other context than 'MonadComp', the fields for most of these
3082++'SyntaxExpr's stay bottom.
3083++
3084++
3085++Note [Applicative BodyStmt]
3086++
3087++(#12143) For the purposes of ApplicativeDo, we treat any BodyStmt
3088++as if it was a BindStmt with a wildcard pattern. For example,
3089++
3090++ do
3091++ x <- A
3092++ B
3093++ return x
3094++
3095++is transformed as if it were
3096++
3097++ do
3098++ x <- A
3099++ _ <- B
3100++ return x
3101++
3102++so it transforms to
3103++
3104++ (\(x,_) -> x) <$> A <*> B
3105++
3106++But we have to remember when we treat a BodyStmt like a BindStmt,
3107++because in error messages we want to emit the original syntax the user
3108++wrote, not our internal representation. So ApplicativeArgOne has a
3109++Bool flag that is True when the original statement was a BodyStmt, so
3110++that we can pretty-print it correctly.
3111++-}
3112++
3113++
3114++{-
3115++************************************************************************
3116++* *
3117++ Template Haskell quotation brackets
3118++* *
3119++************************************************************************
3120++-}
3121++
3122++-- | Haskell Splice
3123++data HsSplice id
3124++ = HsTypedSplice -- $$z or $$(f 4)
3125++ (XTypedSplice id)
3126++ SpliceDecoration -- Whether $$( ) variant found, for pretty printing
3127++ (IdP id) -- A unique name to identify this splice point
3128++ (LHsExpr id) -- See Note [Pending Splices]
3129++
3130++ | HsUntypedSplice -- $z or $(f 4)
3131++ (XUntypedSplice id)
3132++ SpliceDecoration -- Whether $( ) variant found, for pretty printing
3133++ (IdP id) -- A unique name to identify this splice point
3134++ (LHsExpr id) -- See Note [Pending Splices]
3135++
3136++ | HsQuasiQuote -- See Note [Quasi-quote overview] in GHC.Tc.Gen.Splice
3137++ (XQuasiQuote id)
3138++ (IdP id) -- Splice point
3139++ (IdP id) -- Quoter
3140++ SrcSpan -- The span of the enclosed string
3141++ FastString -- The enclosed string
3142++
3143++ -- AZ:TODO: use XSplice instead of HsSpliced
3144++ | HsSpliced -- See Note [Delaying modFinalizers in untyped splices] in
3145++ -- GHC.Rename.Splice.
3146++ -- This is the result of splicing a splice. It is produced by
3147++ -- the renamer and consumed by the typechecker. It lives only
3148++ -- between the two.
3149++ (XSpliced id)
3150++ ThModFinalizers -- TH finalizers produced by the splice.
3151++ (HsSplicedThing id) -- The result of splicing
3152++ | XSplice !(XXSplice id) -- Note [Trees that Grow] extension point
3153++
3154++-- | A splice can appear with various decorations wrapped around it. This data
3155++-- type captures explicitly how it was originally written, for use in the pretty
3156++-- printer.
3157++data SpliceDecoration
3158++ = DollarSplice -- ^ $splice or $$splice
3159++ | BareSplice -- ^ bare splice
3160++ deriving (Data, Eq, Show)
3161++
3162++instance Outputable SpliceDecoration where
3163++ ppr x = text $ show x
3164++
3165++
3166++isTypedSplice :: HsSplice id -> Bool
3167++isTypedSplice (HsTypedSplice {}) = True
3168++isTypedSplice _ = False -- Quasi-quotes are untyped splices
3169++
3170++-- | Finalizers produced by a splice with
3171++-- 'Language.Haskell.TH.Syntax.addModFinalizer'
3172++--
3173++-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. For how
3174++-- this is used.
3175++--
3176++newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())]
3177++
3178++-- A Data instance which ignores the argument of 'ThModFinalizers'.
3179++instance Data ThModFinalizers where
3180++ gunfold _ z _ = z $ ThModFinalizers []
3181++ toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix
3182++ dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a]
3183++
3184++-- | Haskell Spliced Thing
3185++--
3186++-- Values that can result from running a splice.
3187++data HsSplicedThing id
3188++ = HsSplicedExpr (HsExpr id) -- ^ Haskell Spliced Expression
3189++ | HsSplicedTy (HsType id) -- ^ Haskell Spliced Type
3190++ | HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern
3191++
3192++
3193++-- See Note [Pending Splices]
3194++type SplicePointName = Name
3195++
3196++data UntypedSpliceFlavour
3197++ = UntypedExpSplice
3198++ | UntypedPatSplice
3199++ | UntypedTypeSplice
3200++ | UntypedDeclSplice
3201++ deriving Data
3202++
3203++-- | Haskell Bracket
3204++data HsBracket p
3205++ = ExpBr (XExpBr p) (LHsExpr p) -- [| expr |]
3206++ | PatBr (XPatBr p) (LPat p) -- [p| pat |]
3207++ | DecBrL (XDecBrL p) [LHsDecl p] -- [d| decls |]; result of parser
3208++ | DecBrG (XDecBrG p) (HsGroup p) -- [d| decls |]; result of renamer
3209++ | TypBr (XTypBr p) (LHsType p) -- [t| type |]
3210++ | VarBr (XVarBr p) Bool (IdP p) -- True: 'x, False: ''T
3211++ -- (The Bool flag is used only in pprHsBracket)
3212++ | TExpBr (XTExpBr p) (LHsExpr p) -- [|| expr ||]
3213++ | XBracket !(XXBracket p) -- Note [Trees that Grow] extension point
3214++
3215++isTypedBracket :: HsBracket id -> Bool
3216++isTypedBracket (TExpBr {}) = True
3217++isTypedBracket _ = False
3218++
3219++{-
3220++************************************************************************
3221++* *
3222++\subsection{Enumerations and list comprehensions}
3223++* *
3224++************************************************************************
3225++-}
3226++
3227++-- | Arithmetic Sequence Information
3228++data ArithSeqInfo id
3229++ = From (LHsExpr id)
3230++ | FromThen (LHsExpr id)
3231++ (LHsExpr id)
3232++ | FromTo (LHsExpr id)
3233++ (LHsExpr id)
3234++ | FromThenTo (LHsExpr id)
3235++ (LHsExpr id)
3236++ (LHsExpr id)
3237++-- AZ: Should ArithSeqInfo have a TTG extension?
3238++
3239++{-
3240++************************************************************************
3241++* *
3242++\subsection{HsMatchCtxt}
3243++* *
3244++************************************************************************
3245++-}
3246++
3247++-- | Haskell Match Context
3248++--
3249++-- Context of a pattern match. This is more subtle than it would seem. See Note
3250++-- [Varieties of pattern matches].
3251++data HsMatchContext p
3252++ = FunRhs { mc_fun :: LIdP p -- ^ function binder of @f@
3253++ , mc_fixity :: LexicalFixity -- ^ fixing of @f@
3254++ , mc_strictness :: SrcStrictness -- ^ was @f@ banged?
3255++ -- See Note [FunBind vs PatBind]
3256++ }
3257++ -- ^A pattern matching on an argument of a
3258++ -- function binding
3259++ | LambdaExpr -- ^Patterns of a lambda
3260++ | CaseAlt -- ^Patterns and guards on a case alternative
3261++ | IfAlt -- ^Guards of a multi-way if alternative
3262++ | ProcExpr -- ^Patterns of a proc
3263++ | PatBindRhs -- ^A pattern binding eg [y] <- e = e
3264++ | PatBindGuards -- ^Guards of pattern bindings, e.g.,
3265++ -- (Just b) | Just _ <- x = e
3266++ -- | otherwise = e'
3267++
3268++ | RecUpd -- ^Record update [used only in GHC.HsToCore.Expr to
3269++ -- tell matchWrapper what sort of
3270++ -- runtime error message to generate]
3271++
3272++ | StmtCtxt (HsStmtContext p) -- ^Pattern of a do-stmt, list comprehension,
3273++ -- pattern guard, etc
3274++
3275++ | ThPatSplice -- ^A Template Haskell pattern splice
3276++ | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |]
3277++ | PatSyn -- ^A pattern synonym declaration
3278++
3279++isPatSynCtxt :: HsMatchContext p -> Bool
3280++isPatSynCtxt ctxt =
3281++ case ctxt of
3282++ PatSyn -> True
3283++ _ -> False
3284++
3285++-- | Haskell Statement Context.
3286++data HsStmtContext p
3287++ = ListComp
3288++ | MonadComp
3289++
3290++ | DoExpr (Maybe ModuleName) -- ^[ModuleName.]do { ... }
3291++ | MDoExpr (Maybe ModuleName) -- ^[ModuleName.]mdo { ... } ie recursive do-expression
3292++ | ArrowExpr -- ^do-notation in an arrow-command context
3293++
3294++ | GhciStmtCtxt -- ^A command-line Stmt in GHCi pat <- rhs
3295++ | PatGuard (HsMatchContext p) -- ^Pattern guard for specified thing
3296++ | ParStmtCtxt (HsStmtContext p) -- ^A branch of a parallel stmt
3297++ | TransStmtCtxt (HsStmtContext p) -- ^A branch of a transform stmt
3298++
3299++qualifiedDoModuleName_maybe :: HsStmtContext p -> Maybe ModuleName
3300++qualifiedDoModuleName_maybe ctxt = case ctxt of
3301++ DoExpr m -> m
3302++ MDoExpr m -> m
3303++ _ -> Nothing
3304++
3305++isComprehensionContext :: HsStmtContext id -> Bool
3306++-- Uses comprehension syntax [ e | quals ]
3307++isComprehensionContext ListComp = True
3308++isComprehensionContext MonadComp = True
3309++isComprehensionContext (ParStmtCtxt c) = isComprehensionContext c
3310++isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c
3311++isComprehensionContext _ = False
3312++
3313++-- | Is this a monadic context?
3314++isMonadStmtContext :: HsStmtContext id -> Bool
3315++isMonadStmtContext MonadComp = True
3316++isMonadStmtContext DoExpr{} = True
3317++isMonadStmtContext MDoExpr{} = True
3318++isMonadStmtContext GhciStmtCtxt = True
3319++isMonadStmtContext (ParStmtCtxt ctxt) = isMonadStmtContext ctxt
3320++isMonadStmtContext (TransStmtCtxt ctxt) = isMonadStmtContext ctxt
3321++isMonadStmtContext _ = False -- ListComp, PatGuard, ArrowExpr
3322++
3323++isMonadCompContext :: HsStmtContext id -> Bool
3324++isMonadCompContext MonadComp = True
3325++isMonadCompContext _ = False
3326++
3327++matchSeparator :: HsMatchContext p -> SDoc
3328++matchSeparator (FunRhs {}) = text "="
3329++matchSeparator CaseAlt = text "->"
3330++matchSeparator IfAlt = text "->"
3331++matchSeparator LambdaExpr = text "->"
3332++matchSeparator ProcExpr = text "->"
3333++matchSeparator PatBindRhs = text "="
3334++matchSeparator PatBindGuards = text "="
3335++matchSeparator (StmtCtxt _) = text "<-"
3336++matchSeparator RecUpd = text "=" -- This can be printed by the pattern
3337++ -- match checker trace
3338++matchSeparator ThPatSplice = panic "unused"
3339++matchSeparator ThPatQuote = panic "unused"
3340++matchSeparator PatSyn = panic "unused"
3341++
3342++pprMatchContext :: (Outputable (IdP p), UnXRec p)
3343++ => HsMatchContext p -> SDoc
3344++pprMatchContext ctxt
3345++ | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt
3346++ | otherwise = text "a" <+> pprMatchContextNoun ctxt
3347++ where
3348++ want_an (FunRhs {}) = True -- Use "an" in front
3349++ want_an ProcExpr = True
3350++ want_an _ = False
3351++
3352++pprMatchContextNoun :: forall p. (Outputable (IdP p), UnXRec p)
3353++ => HsMatchContext p -> SDoc
3354++pprMatchContextNoun (FunRhs {mc_fun=fun})
3355++ = text "equation for"
3356++ <+> quotes (ppr (unXRec @p fun))
3357++pprMatchContextNoun CaseAlt = text "case alternative"
3358++pprMatchContextNoun IfAlt = text "multi-way if alternative"
3359++pprMatchContextNoun RecUpd = text "record-update construct"
3360++pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice"
3361++pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation"
3362++pprMatchContextNoun PatBindRhs = text "pattern binding"
3363++pprMatchContextNoun PatBindGuards = text "pattern binding guards"
3364++pprMatchContextNoun LambdaExpr = text "lambda abstraction"
3365++pprMatchContextNoun ProcExpr = text "arrow abstraction"
3366++pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"
3367++ $$ pprAStmtContext ctxt
3368++pprMatchContextNoun PatSyn = text "pattern synonym declaration"
3369++
3370++-----------------
3371++pprAStmtContext, pprStmtContext :: (Outputable (IdP p), UnXRec p)
3372++ => HsStmtContext p -> SDoc
3373++pprAStmtContext ctxt = article <+> pprStmtContext ctxt
3374++ where
3375++ pp_an = text "an"
3376++ pp_a = text "a"
3377++ article = case ctxt of
3378++ MDoExpr Nothing -> pp_an
3379++ GhciStmtCtxt -> pp_an
3380++ _ -> pp_a
3381++
3382++
3383++-----------------
3384++pprStmtContext GhciStmtCtxt = text "interactive GHCi command"
3385++pprStmtContext (DoExpr m) = prependQualified m (text "'do' block")
3386++pprStmtContext (MDoExpr m) = prependQualified m (text "'mdo' block")
3387++pprStmtContext ArrowExpr = text "'do' block in an arrow command"
3388++pprStmtContext ListComp = text "list comprehension"
3389++pprStmtContext MonadComp = text "monad comprehension"
3390++pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt
3391++
3392++-- Drop the inner contexts when reporting errors, else we get
3393++-- Unexpected transform statement
3394++-- in a transformed branch of
3395++-- transformed branch of
3396++-- transformed branch of monad comprehension
3397++pprStmtContext (ParStmtCtxt c) =
3398++ ifPprDebug (sep [text "parallel branch of", pprAStmtContext c])
3399++ (pprStmtContext c)
3400++pprStmtContext (TransStmtCtxt c) =
3401++ ifPprDebug (sep [text "transformed branch of", pprAStmtContext c])
3402++ (pprStmtContext c)
3403++
3404++prependQualified :: Maybe ModuleName -> SDoc -> SDoc
3405++prependQualified Nothing t = t
3406++prependQualified (Just _) t = text "qualified" <+> t
3407+diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
3408+index 9d6fa7f29b..a11cf728ae 100644
3409+--- a/compiler/cmm/CmmNode.hs
3410++++ b/compiler/cmm/CmmNode.hs
3411+@@ -34,7 +34,7 @@ import FastString
3412+ import ForeignCall
3413+ import Outputable
3414+ import SMRep
3415+-import CoreSyn (Tickish)
3416++import CoreSyn (CmmTickish)
3417+ import qualified Unique as U
3418+
3419+ import Hoopl.Block
3420+@@ -592,9 +592,6 @@ mapCollectSuccessors _ n = (n, [])
3421+
3422+ -- -----------------------------------------------------------------------------
3423+
3424+--- | Tickish in Cmm context (annotations only)
3425+-type CmmTickish = Tickish ()
3426+-
3427+ -- | Tick scope identifier, allowing us to reason about what
3428+ -- annotations in a Cmm block should scope over. We especially take
3429+ -- care to allow optimisations to reorganise blocks without losing
3430+diff --git a/compiler/cmm/CmmParse.hs b/compiler/cmm/CmmParse.hs
3431+index e7527f8e50..454c0efd21 100644
3432+--- a/compiler/cmm/CmmParse.hs
3433++++ b/compiler/cmm/CmmParse.hs
3434+@@ -220,7 +220,7 @@ import GHC.StgToCmm.Closure
3435+ import GHC.StgToCmm.Layout hiding (ArgRep(..))
3436+ import GHC.StgToCmm.Ticky
3437+ import GHC.StgToCmm.Bind ( emitBlackHoleCode, emitUpdateFrame )
3438+-import CoreSyn ( Tickish(SourceNote) )
3439++import CoreSyn ( GenTickish(SourceNote) )
3440+
3441+ import CmmOpt
3442+ import MkGraph
3443+diff --git a/compiler/cmm/CmmParse.y.source b/compiler/cmm/CmmParse.y.source
3444+index e7527f8e50..454c0efd21 100644
3445+--- a/compiler/cmm/CmmParse.y.source
3446++++ b/compiler/cmm/CmmParse.y.source
3447+@@ -220,7 +220,7 @@ import GHC.StgToCmm.Closure
3448+ import GHC.StgToCmm.Layout hiding (ArgRep(..))
3449+ import GHC.StgToCmm.Ticky
3450+ import GHC.StgToCmm.Bind ( emitBlackHoleCode, emitUpdateFrame )
3451+-import CoreSyn ( Tickish(SourceNote) )
3452++import CoreSyn ( GenTickish(SourceNote) )
3453+
3454+ import CmmOpt
3455+ import MkGraph
3456+diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs
3457+index 7f52054496..2d7421634b 100644
3458+--- a/compiler/coreSyn/CoreFVs.hs
3459++++ b/compiler/coreSyn/CoreFVs.hs
3460+@@ -6,6 +6,7 @@ Taken quite directly from the Peyton Jones/Lester paper.
3461+ -}
3462+
3463+ {-# LANGUAGE CPP #-}
3464++{-# LANGUAGE TypeFamilies #-}
3465+
3466+ -- | A module concerned with finding the free variables of an expression.
3467+ module CoreFVs (
3468+@@ -289,8 +290,8 @@ rhs_fvs (bndr, rhs) = expr_fvs rhs `unionFV`
3469+ exprs_fvs :: [CoreExpr] -> FV
3470+ exprs_fvs exprs = mapUnionFV expr_fvs exprs
3471+
3472+-tickish_fvs :: Tickish Id -> FV
3473+-tickish_fvs (Breakpoint _ ids) = FV.mkFVs ids
3474++tickish_fvs :: CoreTickish -> FV
3475++tickish_fvs (Breakpoint _ _ ids) = FV.mkFVs ids
3476+ tickish_fvs _ = emptyFV
3477+
3478+ {-
3479+@@ -771,8 +772,8 @@ freeVars = go
3480+ , AnnTick tickish expr2 )
3481+ where
3482+ expr2 = go expr
3483+- tickishFVs (Breakpoint _ ids) = mkDVarSet ids
3484+- tickishFVs _ = emptyDVarSet
3485++ tickishFVs (Breakpoint _ _ ids) = mkDVarSet ids
3486++ tickishFVs _ = emptyDVarSet
3487+
3488+ go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty)
3489+ go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co)
3490+diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
3491+index def51f5010..f5a3d0f713 100644
3492+--- a/compiler/coreSyn/CoreLint.hs
3493++++ b/compiler/coreSyn/CoreLint.hs
3494+@@ -15,6 +15,8 @@ module CoreLint (
3495+ lintPassResult, lintInteractiveExpr, lintExpr,
3496+ lintAnnots, lintTypes,
3497+
3498++ interactiveInScope,
3499++
3500+ -- ** Debug output
3501+ endPass, endPassIO,
3502+ dumpPassResult,
3503+@@ -735,10 +737,10 @@ lintCoreExpr (Cast expr co)
3504+
3505+ lintCoreExpr (Tick tickish expr)
3506+ = do case tickish of
3507+- Breakpoint _ ids -> forM_ ids $ \id -> do
3508+- checkDeadIdOcc id
3509+- lookupIdInScope id
3510+- _ -> return ()
3511++ Breakpoint _ _ ids -> forM_ ids $ \id -> do
3512++ checkDeadIdOcc id
3513++ lookupIdInScope id
3514++ _ -> return ()
3515+ markAllJoinsBadIf block_joins $ lintCoreExpr expr
3516+ where
3517+ block_joins = not (tickish `tickishScopesLike` SoftScope)
3518+diff --git a/compiler/coreSyn/CoreMap.hs b/compiler/coreSyn/CoreMap.hs
3519+index d50dcbf1bc..73f8a75d54 100644
3520+--- a/compiler/coreSyn/CoreMap.hs
3521++++ b/compiler/coreSyn/CoreMap.hs
3522+@@ -343,11 +343,11 @@ xtE (D env (Case e b ty as)) f m
3523+ in xtList (xtA env1) as f }
3524+
3525+ -- TODO: this seems a bit dodgy, see 'eqTickish'
3526+-type TickishMap a = Map.Map (Tickish Id) a
3527+-lkTickish :: Tickish Id -> TickishMap a -> Maybe a
3528++type TickishMap a = Map.Map CoreTickish a
3529++lkTickish :: CoreTickish -> TickishMap a -> Maybe a
3530+ lkTickish = lookupTM
3531+
3532+-xtTickish :: Tickish Id -> XT a -> TickishMap a -> TickishMap a
3533++xtTickish :: CoreTickish -> XT a -> TickishMap a -> TickishMap a
3534+ xtTickish = alterTM
3535+
3536+ ------------------------
3537+diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs
3538+index a2eeb9beb8..1c598f4aec 100644
3539+--- a/compiler/coreSyn/CoreOpt.hs
3540++++ b/compiler/coreSyn/CoreOpt.hs
3541+@@ -1168,7 +1168,7 @@ Currently, it is used in Rules.match, and is required to make
3542+ -}
3543+
3544+ exprIsLambda_maybe :: InScopeEnv -> CoreExpr
3545+- -> Maybe (Var, CoreExpr,[Tickish Id])
3546++ -> Maybe (Var, CoreExpr,[CoreTickish])
3547+ -- See Note [exprIsLambda_maybe]
3548+
3549+ -- The simple case: It is a lambda already
3550+diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
3551+index 09f53276bd..fa5a32cb4d 100644
3552+--- a/compiler/coreSyn/CorePrep.hs
3553++++ b/compiler/coreSyn/CorePrep.hs
3554+@@ -636,9 +636,9 @@ cpeRhsE env (Tick tickish expr)
3555+ = do { body <- cpeBodyNF env expr
3556+ ; return (emptyFloats, mkTick tickish' body) }
3557+ where
3558+- tickish' | Breakpoint n fvs <- tickish
3559++ tickish' | Breakpoint ext n fvs <- tickish
3560+ -- See also 'substTickish'
3561+- = Breakpoint n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs)
3562++ = Breakpoint ext n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs)
3563+ | otherwise
3564+ = tickish
3565+
3566+@@ -784,7 +784,7 @@ rhsToBody expr = return (emptyFloats, expr)
3567+
3568+ data ArgInfo = CpeApp CoreArg
3569+ | CpeCast Coercion
3570+- | CpeTick (Tickish Id)
3571++ | CpeTick CoreTickish
3572+
3573+ {- Note [runRW arg]
3574+ ~~~~~~~~~~~~~~~~~~~
3575+@@ -1218,7 +1218,7 @@ data FloatingBind
3576+ Bool -- The bool indicates "ok-for-speculation"
3577+
3578+ -- | See Note [Floating Ticks in CorePrep]
3579+- | FloatTick (Tickish Id)
3580++ | FloatTick CoreTickish
3581+
3582+ data Floats = Floats OkToSpec (OrdList FloatingBind)
3583+
3584+diff --git a/compiler/coreSyn/CoreSeq.hs b/compiler/coreSyn/CoreSeq.hs
3585+index 7de8923a71..a0b5f2ee17 100644
3586+--- a/compiler/coreSyn/CoreSeq.hs
3587++++ b/compiler/coreSyn/CoreSeq.hs
3588+@@ -20,7 +20,7 @@ import VarSet( seqDVarSet )
3589+ import Var( varType, tyVarKind )
3590+ import Type( seqType, isTyVar )
3591+ import Coercion( seqCo )
3592+-import Id( Id, idInfo )
3593++import Id( idInfo )
3594+
3595+ -- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the
3596+ -- compiler
3597+@@ -69,7 +69,7 @@ seqExprs :: [CoreExpr] -> ()
3598+ seqExprs [] = ()
3599+ seqExprs (e:es) = seqExpr e `seq` seqExprs es
3600+
3601+-seqTickish :: Tickish Id -> ()
3602++seqTickish :: CoreTickish -> ()
3603+ seqTickish ProfNote{ profNoteCC = cc } = cc `seq` ()
3604+ seqTickish HpcTick{} = ()
3605+ seqTickish Breakpoint{ breakpointFVs = ids } = seqBndrs ids
3606+diff --git a/compiler/coreSyn/CoreStats.hs b/compiler/coreSyn/CoreStats.hs
3607+index fde107b372..a03d62472f 100644
3608+--- a/compiler/coreSyn/CoreStats.hs
3609++++ b/compiler/coreSyn/CoreStats.hs
3610+@@ -116,7 +116,7 @@ exprSize (Tick n e) = tickSize n + exprSize e
3611+ exprSize (Type _) = 1
3612+ exprSize (Coercion _) = 1
3613+
3614+-tickSize :: Tickish Id -> Int
3615++tickSize :: CoreTickish -> Int
3616+ tickSize (ProfNote _ _ _) = 1
3617+ tickSize _ = 1
3618+
3619+diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs
3620+index 0eedca4201..1675b16318 100644
3621+--- a/compiler/coreSyn/CoreSubst.hs
3622++++ b/compiler/coreSyn/CoreSubst.hs
3623+@@ -705,9 +705,9 @@ substDVarSet subst fvs
3624+ | otherwise = tyCoFVsOfType (lookupTCvSubst subst fv) (const True) emptyVarSet $! acc
3625+
3626+ ------------------
3627+-substTickish :: Subst -> Tickish Id -> Tickish Id
3628+-substTickish subst (Breakpoint n ids)
3629+- = Breakpoint n (map do_one ids)
3630++substTickish :: Subst -> CoreTickish -> CoreTickish
3631++substTickish subst (Breakpoint ext n ids)
3632++ = Breakpoint ext n (map do_one ids)
3633+ where
3634+ do_one = getIdFromTrivialExpr . lookupIdSubst (text "subst_tickish") subst
3635+ substTickish _subst other = other
3636+diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
3637+index e3ad4715f1..9655d3ad09 100644
3638+--- a/compiler/coreSyn/CoreSyn.hs
3639++++ b/compiler/coreSyn/CoreSyn.hs
3640+@@ -6,12 +6,18 @@
3641+ {-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts #-}
3642+ {-# LANGUAGE NamedFieldPuns #-}
3643+ {-# LANGUAGE BangPatterns #-}
3644++{-# LANGUAGE KindSignatures #-}
3645++{-# LANGUAGE DataKinds #-}
3646++{-# LANGUAGE StandaloneDeriving #-}
3647++{-# LANGUAGE TypeFamilies #-}
3648++{-# LANGUAGE FlexibleInstances #-}
3649+
3650+ -- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection
3651+ module CoreSyn (
3652+ -- * Main data types
3653+ Expr(..), Alt, Bind(..), AltCon(..), Arg,
3654+- Tickish(..), TickishScoping(..), TickishPlacement(..),
3655++ CoreTickish, StgTickish, CmmTickish, XTickishId,
3656++ GenTickish(..), TickishScoping(..), TickishPlacement(..),
3657+ CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
3658+ TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr,
3659+
3660+@@ -118,6 +124,8 @@ import UniqSet
3661+ import SrcLoc ( RealSrcSpan, containsSpan )
3662+ import Binary
3663+
3664++import GHC.Hs.Extension ( NoExtField )
3665++
3666+ import Data.Data hiding (TyCon)
3667+ import Data.Int
3668+ import Data.Word
3669+@@ -260,7 +268,7 @@ data Expr b
3670+ | Case (Expr b) b Type [Alt b] -- See Note [Case expression invariants]
3671+ -- and Note [Why does Case have a 'Type' field?]
3672+ | Cast (Expr b) Coercion
3673+- | Tick (Tickish Id) (Expr b)
3674++ | Tick CoreTickish (Expr b)
3675+ | Type Type
3676+ | Coercion Coercion
3677+ deriving Data
3678+@@ -932,9 +940,31 @@ type MOutCoercion = MCoercion
3679+
3680+ -- | Allows attaching extra information to points in expressions
3681+
3682++-- | Used as a data type index for the GenTickish annotations
3683++data TickishPass
3684++ = TickishCore
3685++ | TickishStg
3686++ | TickishCmm
3687++
3688++type family XBreakpoint (pass :: TickishPass)
3689++type instance XBreakpoint 'TickishCore = NoExtField
3690++-- | Keep track of the type of breakpoints in STG, for GHCi
3691++type instance XBreakpoint 'TickishStg = Type
3692++type instance XBreakpoint 'TickishCmm = NoExtField
3693++
3694++type family XTickishId (pass :: TickishPass)
3695++type instance XTickishId 'TickishCore = Id
3696++type instance XTickishId 'TickishStg = Id
3697++type instance XTickishId 'TickishCmm = NoExtField
3698++
3699++type CoreTickish = GenTickish 'TickishCore
3700++type StgTickish = GenTickish 'TickishStg
3701++-- | Tickish in Cmm context (annotations only)
3702++type CmmTickish = GenTickish 'TickishCmm
3703++
3704+ -- If you edit this type, you may need to update the GHC formalism
3705+ -- See Note [GHC Formalism] in coreSyn/CoreLint.hs
3706+-data Tickish id =
3707++data GenTickish pass =
3708+ -- | An @{-# SCC #-}@ profiling annotation, either automatically
3709+ -- added by the desugarer as a result of -auto-all, or added by
3710+ -- the user.
3711+@@ -959,8 +989,10 @@ data Tickish id =
3712+ -- NB. we must take account of these Ids when (a) counting free variables,
3713+ -- and (b) substituting (don't substitute for them)
3714+ | Breakpoint
3715+- { breakpointId :: !Int
3716+- , breakpointFVs :: [id] -- ^ the order of this list is important:
3717++ { breakpointExt :: XBreakpoint pass
3718++ , breakpointId :: !Int
3719++ , breakpointFVs :: [XTickishId pass]
3720++ -- ^ the order of this list is important:
3721+ -- it matches the order of the lists in the
3722+ -- appropriate entry in HscTypes.ModBreaks.
3723+ --
3724+@@ -990,7 +1022,16 @@ data Tickish id =
3725+ -- (uses same names as CCs)
3726+ }
3727+
3728+- deriving (Eq, Ord, Data)
3729++deriving instance Eq (GenTickish 'TickishCore)
3730++deriving instance Ord (GenTickish 'TickishCore)
3731++deriving instance Data (GenTickish 'TickishCore)
3732++
3733++deriving instance Data (GenTickish 'TickishStg)
3734++
3735++deriving instance Eq (GenTickish 'TickishCmm)
3736++deriving instance Ord (GenTickish 'TickishCmm)
3737++deriving instance Data (GenTickish 'TickishCmm)
3738++
3739+
3740+ -- | A "counting tick" (where tickishCounts is True) is one that
3741+ -- counts evaluations in some way. We cannot discard a counting tick,
3742+@@ -1000,7 +1041,7 @@ data Tickish id =
3743+ -- However, we still allow the simplifier to increase or decrease
3744+ -- sharing, so in practice the actual number of ticks may vary, except
3745+ -- that we never change the value from zero to non-zero or vice versa.
3746+-tickishCounts :: Tickish id -> Bool
3747++tickishCounts :: GenTickish pass -> Bool
3748+ tickishCounts n@ProfNote{} = profNoteCount n
3749+ tickishCounts HpcTick{} = True
3750+ tickishCounts Breakpoint{} = True
3751+@@ -1069,7 +1110,7 @@ data TickishScoping =
3752+ deriving (Eq)
3753+
3754+ -- | Returns the intended scoping rule for a Tickish
3755+-tickishScoped :: Tickish id -> TickishScoping
3756++tickishScoped :: GenTickish pass -> TickishScoping
3757+ tickishScoped n@ProfNote{}
3758+ | profNoteScope n = CostCentreScope
3759+ | otherwise = NoScope
3760+@@ -1082,7 +1123,7 @@ tickishScoped SourceNote{} = SoftScope
3761+
3762+ -- | Returns whether the tick scoping rule is at least as permissive
3763+ -- as the given scoping rule.
3764+-tickishScopesLike :: Tickish id -> TickishScoping -> Bool
3765++tickishScopesLike :: GenTickish pass -> TickishScoping -> Bool
3766+ tickishScopesLike t scope = tickishScoped t `like` scope
3767+ where NoScope `like` _ = True
3768+ _ `like` NoScope = False
3769+@@ -1101,24 +1142,24 @@ tickishScopesLike t scope = tickishScoped t `like` scope
3770+ -- @tickishCounts@. Note that in principle splittable ticks can become
3771+ -- floatable using @mkNoTick@ -- even though there's currently no
3772+ -- tickish for which that is the case.
3773+-tickishFloatable :: Tickish id -> Bool
3774++tickishFloatable :: GenTickish pass -> Bool
3775+ tickishFloatable t = t `tickishScopesLike` SoftScope && not (tickishCounts t)
3776+
3777+ -- | Returns @True@ for a tick that is both counting /and/ scoping and
3778+ -- can be split into its (tick, scope) parts using 'mkNoScope' and
3779+ -- 'mkNoTick' respectively.
3780+-tickishCanSplit :: Tickish id -> Bool
3781++tickishCanSplit :: GenTickish pass -> Bool
3782+ tickishCanSplit ProfNote{profNoteScope = True, profNoteCount = True}
3783+ = True
3784+ tickishCanSplit _ = False
3785+
3786+-mkNoCount :: Tickish id -> Tickish id
3787++mkNoCount :: GenTickish pass -> GenTickish pass
3788+ mkNoCount n | not (tickishCounts n) = n
3789+ | not (tickishCanSplit n) = panic "mkNoCount: Cannot split!"
3790+ mkNoCount n@ProfNote{} = n {profNoteCount = False}
3791+ mkNoCount _ = panic "mkNoCount: Undefined split!"
3792+
3793+-mkNoScope :: Tickish id -> Tickish id
3794++mkNoScope :: GenTickish pass -> GenTickish pass
3795+ mkNoScope n | tickishScoped n == NoScope = n
3796+ | not (tickishCanSplit n) = panic "mkNoScope: Cannot split!"
3797+ mkNoScope n@ProfNote{} = n {profNoteScope = False}
3798+@@ -1139,7 +1180,7 @@ mkNoScope _ = panic "mkNoScope: Undefined split!"
3799+ -- Here there is just no operational difference between the first and
3800+ -- the second version. Therefore code generation should simply
3801+ -- translate the code as if it found the latter.
3802+-tickishIsCode :: Tickish id -> Bool
3803++tickishIsCode :: GenTickish pass -> Bool
3804+ tickishIsCode SourceNote{} = False
3805+ tickishIsCode _tickish = True -- all the rest for now
3806+
3807+@@ -1179,7 +1220,7 @@ data TickishPlacement =
3808+ deriving (Eq)
3809+
3810+ -- | Placement behaviour we want for the ticks
3811+-tickishPlace :: Tickish id -> TickishPlacement
3812++tickishPlace :: GenTickish pass -> TickishPlacement
3813+ tickishPlace n@ProfNote{}
3814+ | profNoteCount n = PlaceRuntime
3815+ | otherwise = PlaceCostCentre
3816+@@ -1189,7 +1230,8 @@ tickishPlace SourceNote{} = PlaceNonLam
3817+
3818+ -- | Returns whether one tick "contains" the other one, therefore
3819+ -- making the second tick redundant.
3820+-tickishContains :: Eq b => Tickish b -> Tickish b -> Bool
3821++tickishContains :: Eq (GenTickish pass)
3822++ => GenTickish pass -> GenTickish pass -> Bool
3823+ tickishContains (SourceNote sp1 n1) (SourceNote sp2 n2)
3824+ = containsSpan sp1 sp2 && n1 == n2
3825+ -- compare the String last
3826+@@ -2187,8 +2229,8 @@ stripNArgs _ _ = Nothing
3827+
3828+ -- | Like @collectArgs@, but also collects looks through floatable
3829+ -- ticks if it means that we can find more arguments.
3830+-collectArgsTicks :: (Tickish Id -> Bool) -> Expr b
3831+- -> (Expr b, [Arg b], [Tickish Id])
3832++collectArgsTicks :: (CoreTickish -> Bool) -> Expr b
3833++ -> (Expr b, [Arg b], [CoreTickish])
3834+ collectArgsTicks skipTick expr
3835+ = go expr [] []
3836+ where
3837+@@ -2273,7 +2315,7 @@ data AnnExpr' bndr annot
3838+ | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
3839+ | AnnCast (AnnExpr bndr annot) (annot, Coercion)
3840+ -- Put an annotation on the (root of) the coercion
3841+- | AnnTick (Tickish Id) (AnnExpr bndr annot)
3842++ | AnnTick CoreTickish (AnnExpr bndr annot)
3843+ | AnnType Type
3844+ | AnnCoercion Coercion
3845+
3846+@@ -2294,8 +2336,8 @@ collectAnnArgs expr
3847+ go (_, AnnApp f a) as = go f (a:as)
3848+ go e as = (e, as)
3849+
3850+-collectAnnArgsTicks :: (Tickish Var -> Bool) -> AnnExpr b a
3851+- -> (AnnExpr b a, [AnnExpr b a], [Tickish Var])
3852++collectAnnArgsTicks :: (CoreTickish -> Bool) -> AnnExpr b a
3853++ -> (AnnExpr b a, [AnnExpr b a], [CoreTickish])
3854+ collectAnnArgsTicks tickishOk expr
3855+ = go expr [] []
3856+ where
3857+diff --git a/compiler/coreSyn/CoreTidy.hs b/compiler/coreSyn/CoreTidy.hs
3858+index 3c924663f5..e6009445cb 100644
3859+--- a/compiler/coreSyn/CoreTidy.hs
3860++++ b/compiler/coreSyn/CoreTidy.hs
3861+@@ -86,8 +86,9 @@ tidyAlt env (con, vs, rhs)
3862+ (con, vs, tidyExpr env' rhs)
3863+
3864+ ------------ Tickish --------------
3865+-tidyTickish :: TidyEnv -> Tickish Id -> Tickish Id
3866+-tidyTickish env (Breakpoint ix ids) = Breakpoint ix (map (tidyVarOcc env) ids)
3867++tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish
3868++tidyTickish env (Breakpoint ext ix ids)
3869++ = Breakpoint ext ix (map (tidyVarOcc env) ids)
3870+ tidyTickish _ other_tickish = other_tickish
3871+
3872+ ------------ Rules --------------
3873+diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
3874+index 16f4a00341..283a9c7fdd 100644
3875+--- a/compiler/coreSyn/CoreUtils.hs
3876++++ b/compiler/coreSyn/CoreUtils.hs
3877+@@ -295,7 +295,7 @@ mkCast expr co
3878+
3879+ -- | Wraps the given expression in the source annotation, dropping the
3880+ -- annotation if possible.
3881+-mkTick :: Tickish Id -> CoreExpr -> CoreExpr
3882++mkTick :: CoreTickish -> CoreExpr -> CoreExpr
3883+ mkTick t orig_expr = mkTick' id id orig_expr
3884+ where
3885+ -- Some ticks (cost-centres) can be split in two, with the
3886+@@ -380,7 +380,7 @@ mkTick t orig_expr = mkTick' id id orig_expr
3887+ -- Catch-all: Annotate where we stand
3888+ _any -> top $ Tick t $ rest expr
3889+
3890+-mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr
3891++mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr
3892+ mkTicks ticks expr = foldr mkTick expr ticks
3893+
3894+ isSaturatedConApp :: CoreExpr -> Bool
3895+@@ -391,13 +391,13 @@ isSaturatedConApp e = go e []
3896+ go (Cast f _) as = go f as
3897+ go _ _ = False
3898+
3899+-mkTickNoHNF :: Tickish Id -> CoreExpr -> CoreExpr
3900++mkTickNoHNF :: CoreTickish -> CoreExpr -> CoreExpr
3901+ mkTickNoHNF t e
3902+ | exprIsHNF e = tickHNFArgs t e
3903+ | otherwise = mkTick t e
3904+
3905+ -- push a tick into the arguments of a HNF (call or constructor app)
3906+-tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr
3907++tickHNFArgs :: CoreTickish -> CoreExpr -> CoreExpr
3908+ tickHNFArgs t e = push t e
3909+ where
3910+ push t (App f (Type u)) = App (push t f) (Type u)
3911+@@ -405,28 +405,28 @@ tickHNFArgs t e = push t e
3912+ push _t e = e
3913+
3914+ -- | Strip ticks satisfying a predicate from top of an expression
3915+-stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)
3916++stripTicksTop :: (CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b)
3917+ stripTicksTop p = go []
3918+ where go ts (Tick t e) | p t = go (t:ts) e
3919+ go ts other = (reverse ts, other)
3920+
3921+ -- | Strip ticks satisfying a predicate from top of an expression,
3922+ -- returning the remaining expression
3923+-stripTicksTopE :: (Tickish Id -> Bool) -> Expr b -> Expr b
3924++stripTicksTopE :: (CoreTickish -> Bool) -> Expr b -> Expr b
3925+ stripTicksTopE p = go
3926+ where go (Tick t e) | p t = go e
3927+ go other = other
3928+
3929+ -- | Strip ticks satisfying a predicate from top of an expression,
3930+ -- returning the ticks
3931+-stripTicksTopT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]
3932++stripTicksTopT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish]
3933+ stripTicksTopT p = go []
3934+ where go ts (Tick t e) | p t = go (t:ts) e
3935+ go ts _ = ts
3936+
3937+ -- | Completely strip ticks satisfying a predicate from an
3938+ -- expression. Note this is O(n) in the size of the expression!
3939+-stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b
3940++stripTicksE :: (CoreTickish -> Bool) -> Expr b -> Expr b
3941+ stripTicksE p expr = go expr
3942+ where go (App e a) = App (go e) (go a)
3943+ go (Lam b e) = Lam b (go e)
3944+@@ -442,7 +442,7 @@ stripTicksE p expr = go expr
3945+ go_b (b, e) = (b, go e)
3946+ go_a (c,bs,e) = (c,bs, go e)
3947+
3948+-stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]
3949++stripTicksT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish]
3950+ stripTicksT p expr = fromOL $ go expr
3951+ where go (App e a) = go e `appOL` go a
3952+ go (Lam _ e) = go e
3953+@@ -2059,7 +2059,7 @@ cheapEqExpr :: Expr b -> Expr b -> Bool
3954+ cheapEqExpr = cheapEqExpr' (const False)
3955+
3956+ -- | Cheap expression equality test, can ignore ticks by type.
3957+-cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool
3958++cheapEqExpr' :: (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool
3959+ cheapEqExpr' ignoreTick = go_s
3960+ where go_s = go `on` stripTicksTopE ignoreTick
3961+ go (Var v1) (Var v2) = v1 == v2
3962+@@ -2136,8 +2136,8 @@ eqExpr in_scope e1 e2
3963+ go_alt env (c1, bs1, e1) (c2, bs2, e2)
3964+ = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2
3965+
3966+-eqTickish :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool
3967+-eqTickish env (Breakpoint lid lids) (Breakpoint rid rids)
3968++eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool
3969++eqTickish env (Breakpoint _ lid lids) (Breakpoint _ rid rids)
3970+ = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids
3971+ eqTickish _ l r = l == r
3972+
3973+@@ -2443,7 +2443,7 @@ tryEtaReduce bndrs body
3974+ -> Coercion -- Of kind (t1~t2)
3975+ -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2)
3976+ -- (and similarly for tyvars, coercion args)
3977+- , [Tickish Var])
3978++ , [CoreTickish])
3979+ -- See Note [Eta reduction with casted arguments]
3980+ ok_arg bndr (Type ty) co
3981+ | Just tv <- getTyVar_maybe ty
3982+diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs
3983+index c959fc1c4e..e78e5f6b0f 100644
3984+--- a/compiler/coreSyn/PprCore.hs
3985++++ b/compiler/coreSyn/PprCore.hs
3986+@@ -7,6 +7,8 @@ Printing of Core syntax
3987+ -}
3988+
3989+ {-# LANGUAGE MultiWayIf #-}
3990++{-# LANGUAGE FlexibleContexts #-}
3991++{-# LANGUAGE UndecidableInstances #-}
3992+ {-# OPTIONS_GHC -fno-warn-orphans #-}
3993+ module PprCore (
3994+ pprCoreExpr, pprParendExpr,
3995+@@ -597,13 +599,13 @@ pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
3996+ -----------------------------------------------------
3997+ -}
3998+
3999+-instance Outputable id => Outputable (Tickish id) where
4000++instance Outputable (XTickishId pass) => Outputable (GenTickish pass) where
4001+ ppr (HpcTick modl ix) =
4002+ hcat [text "hpc<",
4003+ ppr modl, comma,
4004+ ppr ix,
4005+ text ">"]
4006+- ppr (Breakpoint ix vars) =
4007++ ppr (Breakpoint _ext ix vars) =
4008+ hcat [text "break<",
4009+ ppr ix,
4010+ text ">",
4011+diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
4012+index 91b632f27e..ac5c0cd8e6 100644
4013+--- a/compiler/deSugar/Coverage.hs
4014++++ b/compiler/deSugar/Coverage.hs
4015+@@ -366,7 +366,7 @@ addTickLHsBind _ = panic "addTickLHsBind: Impossible Match" -- due to #15884
4016+
4017+
4018+ bindTick
4019+- :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
4020++ :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe CoreTickish)
4021+ bindTick density name pos fvs = do
4022+ decl_path <- getPathEntry
4023+ let
4024+@@ -1189,7 +1189,7 @@ allocTickBox boxLabel countEntries topOnly pos m =
4025+ -- the tick application inherits the source position of its
4026+ -- expression argument to support nested box allocations
4027+ allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars
4028+- -> TM (Maybe (Tickish Id))
4029++ -> TM (Maybe CoreTickish)
4030+ allocATickBox boxLabel countEntries topOnly pos fvs =
4031+ ifGoodTickSrcSpan pos (do
4032+ let
4033+@@ -1203,7 +1203,7 @@ allocATickBox boxLabel countEntries topOnly pos fvs =
4034+
4035+
4036+ mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]
4037+- -> TM (Tickish Id)
4038++ -> TM CoreTickish
4039+ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
4040+
4041+ let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs
4042+@@ -1238,7 +1238,7 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
4043+ c <- liftM tickBoxCount getState
4044+ setState $ \st -> st { tickBoxCount = c + 1
4045+ , mixEntries = me:mixEntries st }
4046+- return $ Breakpoint c ids
4047++ return $ Breakpoint noExtField c ids
4048+
4049+ SourceNotes | RealSrcSpan pos' <- pos ->
4050+ return $ SourceNote pos' cc_name
4051+diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
4052+index b76c4f0592..c94595b29d 100644
4053+--- a/compiler/deSugar/DsUtils.hs
4054++++ b/compiler/deSugar/DsUtils.hs
4055+@@ -665,7 +665,7 @@ work out well:
4056+ which is better.
4057+ -}
4058+
4059+-mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
4060++mkSelectorBinds :: [[CoreTickish]] -- ^ ticks to add, possibly
4061+ -> LPat GhcTc -- ^ The pattern
4062+ -> CoreExpr -- ^ Expression to which the pattern is bound
4063+ -> DsM (Id,[(Id,CoreExpr)])
4064+@@ -890,7 +890,7 @@ the tail call property. For example, see #3403.
4065+ * *
4066+ ********************************************************************* -}
4067+
4068+-mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr
4069++mkOptTickBox :: [CoreTickish] -> CoreExpr -> CoreExpr
4070+ mkOptTickBox = flip (foldr Tick)
4071+
4072+ mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
14073diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs
2−index 44876efc91..8b0fb9a17e 100644
4074+index 44876efc91..9d2aea3d4a 100644
34075--- a/compiler/ghci/ByteCodeAsm.hs
44076+++ b/compiler/ghci/ByteCodeAsm.hs
54077@@ -7,10 +7,10 @@
@@ -11,7 +4083,7 @@ index 44876efc91..8b0fb9a17e 100644
114083 SizedSeq, sizeSS, ssElts,
124084- iNTERP_STACK_CHECK_THRESH
134085+ iNTERP_STACK_CHECK_THRESH,
14−+ mkTupleInfoSig
4086++ mkTupleInfoLit
154087 ) where
164088
174089 #include "HsVersions.h"
@@ -40,7 +4112,7 @@ index 44876efc91..8b0fb9a17e 100644
404112 CCALL off m_addr i -> do np <- addr m_addr
414113 emit bci_CCALL [SmallOp off, Op np, SmallOp i]
424114 BRK_FUN index uniq cc -> do p1 <- ptr BCOPtrBreakArray
43−@@ -501,6 +512,41 @@ return_ubx V16 = error "return_ubx: vector"
4115+@@ -501,6 +512,64 @@ return_ubx V16 = error "return_ubx: vector"
444116 return_ubx V32 = error "return_ubx: vector"
454117 return_ubx V64 = error "return_ubx: vector"
464118
@@ -58,10 +4130,29 @@ index 44876efc91..8b0fb9a17e 100644
584130+ because we need a stg_ctoi_tN stack frame for each size N
594131+
604132+ If needed, you can support larger tuples by adding more in
61−+ StgMiscClosures.cmm and MiscClosures.h
62−+ -}
4133++ StgMiscClosures.cmm and MiscClosures.h and raising this limit.
4134++ -}
634135+ | tupleNativeStackSize > 32 =
644136+ pprPanic "mkTupleInfoSig: tuple too big" (ppr tupleNativeStackSize)
4137++ {-
4138++ Check that we aren't using too many registers for argument passing.
4139++ If this panic is triggered, the calling convention uses more.
4140++
4141++ You can raise the limits after modifying stg_ctoi_t and stg_ret_t
4142++ (StgMiscClosures.cmm) to save and restore the additional registers.
4143++ -}
4144++ | tupleVanillaRegs >= 64 = -- at most 6 vanilla registers
4145++ pprPanic "mkTupleInfoSig: too many vanilla registers" (ppr tupleVanillaRegs)
4146++ | tupleLongRegs >= 2 = -- at most 1 long register
4147++ pprPanic "mkTupleInfoSig: too many long registers" (ppr tupleLongRegs)
4148++ | tupleFloatRegs >= 64 = -- at most 6 float registers
4149++ pprPanic "mkTupleInfoSig: too many float registers" (ppr tupleFloatRegs)
4150++ | tupleDoubleRegs >= 64 = -- at most 6 double registers
4151++ pprPanic "mkTupleInfoSig: too many double registers" (ppr tupleDoubleRegs)
4152++ {-
4153++ Check that we can pack the register counts/bitmaps and stack size
4154++ in the information word.
4155++ -}
654156+ | tupleNativeStackSize < 16384 &&
664157+ tupleDoubleRegs < 64 && -- 6 bit bitmap (these can be shared with float)
674158+ tupleFloatRegs < 64 && -- 6 bit bitmap (these can be shared with double)
@@ -78,27 +4169,235 @@ index 44876efc91..8b0fb9a17e 100644
784169+ where
794170+ w :: Int -> Word32
804171+ w = fromIntegral
4172++
4173++mkTupleInfoLit :: DynFlags -> TupleInfo -> Literal
4174++mkTupleInfoLit dflags tuple_info =
4175++ mkLitWord dflags . fromIntegral $ mkTupleInfoSig tuple_info
814176+
824177 -- Make lists of host-sized words for literals, so that when the
834178 -- words are placed in memory at increasing addresses, the
844179 -- bit pattern is correct for the host's word size and endianness.
854180diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
86−index fb60c21f9d..62e8457c5a 100644
4181+index fb60c21f9d..d28e35d808 100644
874182--- a/compiler/ghci/ByteCodeGen.hs
884183+++ b/compiler/ghci/ByteCodeGen.hs
89−@@ -17,6 +17,11 @@ import ByteCodeInstr
90− import ByteCodeAsm
91− import ByteCodeTypes
92−
4184+@@ -30,12 +30,9 @@ import Id
4185+ import Var ( updateVarType )
4186+ import ForeignCall
4187+ import HscTypes
4188+-import CoreUtils
4189+ import CoreSyn
4190+-import PprCore
4191+ import Literal
4192+ import PrimOp
4193+-import CoreFVs
4194+ import Type
4195+ import RepType
4196+ import DataCon
4197+@@ -55,6 +52,12 @@ import Bitmap
4198+ import OrdList
4199+ import Maybes
4200+ import VarEnv
934201+import CmmCallConv
4202++import CmmType
944203+import CmmExpr
954204+import CmmNode
964205+import CmmUtils
4206++import PrelInfo
4207+
4208+ import Data.List
4209+ import Foreign
4210+@@ -76,12 +79,16 @@ import Data.Ord
4211+ import GHC.Stack.CCS
4212+ import Data.Either ( partitionEithers )
4213+
4214++import qualified CostCentre as CC
4215++import StgSyn
4216++import StgFVs
974217+
98− import GHCi
99− import GHCi.FFI
100− import GHCi.RemoteTypes
101−@@ -195,12 +200,6 @@ simpleFreeVars = freeVars
4218+ -- -----------------------------------------------------------------------------
4219+ -- Generating byte code for a complete module
4220+
4221+ byteCodeGen :: HscEnv
4222+ -> Module
4223+- -> CoreProgram
4224++ -> [StgTopBinding]
4225+ -> [TyCon]
4226+ -> Maybe ModBreaks
4227+ -> IO CompiledByteCode
4228+@@ -91,17 +98,22 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
4229+ (const ()) $ do
4230+ -- Split top-level binds into strings and others.
4231+ -- See Note [generating code for top-level string literal bindings].
4232+- let (strings, flatBinds) = partitionEithers $ do -- list monad
4233+- (bndr, rhs) <- flattenBinds binds
4234+- return $ case exprIsTickedString_maybe rhs of
4235+- Just str -> Left (bndr, str)
4236+- _ -> Right (bndr, simpleFreeVars rhs)
4237++ let (strings, lifted_binds) = partitionEithers $ do -- list monad
4238++ bnd <- binds
4239++ case bnd of
4240++ StgTopLifted bnd -> [Right bnd]
4241++ StgTopStringLit b str -> [Left (b, str)]
4242++ flattenBind (StgNonRec b e) = [(b,e)]
4243++ flattenBind (StgRec bs) = bs
4244+ stringPtrs <- allocateTopStrings hsc_env strings
4245+
4246+ us <- mkSplitUniqSupply 'y'
4247+ (BcM_State{..}, proto_bcos) <-
4248+- runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $
4249+- mapM schemeTopBind flatBinds
4250++ runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $ do
4251++ prepd_binds <- mapM bcPrepBind lifted_binds
4252++ let flattened_binds =
4253++ concatMap (flattenBind . annBindingFreeVars) (reverse prepd_binds)
4254++ mapM schemeTopBind flattened_binds
4255+
4256+ when (notNull ffis)
4257+ (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
4258+@@ -155,23 +167,25 @@ literals:
4259+ -- Returns: the root BCO for this expression
4260+ coreExprToBCOs :: HscEnv
4261+ -> Module
4262+- -> CoreExpr
4263++ -> Id
4264++ -> StgRhs
4265+ -> IO UnlinkedBCO
4266+-coreExprToBCOs hsc_env this_mod expr
4267++coreExprToBCOs hsc_env this_mod bndr expr
4268+ = withTiming dflags
4269+ (text "ByteCodeGen"<+>brackets (ppr this_mod))
4270+ (const ()) $ do
4271+- -- create a totally bogus name for the top-level BCO; this
4272+- -- should be harmless, since it's never used for anything
4273+- let invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")
4274+- invented_id = Id.mkLocalId invented_name (panic "invented_id's type")
4275+
4276+ -- the uniques are needed to generate fresh variables when we introduce new
4277+ -- let bindings for ticked expressions
4278+ us <- mkSplitUniqSupply 'y'
4279+ (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco)
4280+- <- runBc hsc_env us this_mod Nothing emptyVarEnv $
4281+- schemeTopBind (invented_id, simpleFreeVars expr)
4282++ <- runBc hsc_env us this_mod Nothing emptyVarEnv $ do
4283++ prepd_expr <- annBindingFreeVars <$>
4284++ bcPrepBind (StgNonRec bndr expr)
4285++ case prepd_expr of
4286++ (StgNonRec _ cg_expr) -> schemeR [] (idName bndr, cg_expr)
4287++ _ ->
4288++ panic "GHC.CoreToByteCode.coreExprToBCOs"
4289+
4290+ when (notNull mallocd)
4291+ (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
4292+@@ -181,26 +195,106 @@ coreExprToBCOs hsc_env this_mod expr
4293+ assembleOneBCO hsc_env proto_bco
4294+ where dflags = hsc_dflags hsc_env
4295+
4296+--- The regular freeVars function gives more information than is useful to
4297+--- us here. We need only the free variables, not everything in an FVAnn.
4298+--- Historical note: At one point FVAnn was more sophisticated than just
4299+--- a set. Now it isn't. So this function is much simpler. Keeping it around
4300+--- so that if someone changes FVAnn, they will get a nice type error right
4301+--- here.
4302+-simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet
4303+-simpleFreeVars = freeVars
4304++{-
4305++ Prepare the STG for bytecode generation:
4306++
4307++ - Ensure that all breakpoints are directly under
4308++ a let-binding, introducing a new binding for
4309++ those that aren't already.
4310++
4311++ - Protect Not-necessarily lifted join points, see
4312++ Note [Not-necessarily-lifted join points]
4313++
4314++ -}
4315++
4316++bcPrepRHS :: StgRhs -> BcM StgRhs
4317++-- explicitly match all constructors so we get a warning if we miss any
4318++bcPrepRHS (StgRhsClosure fvs cc upd args (StgTick bp@Breakpoint{} expr)) = do
4319++ {- If we have a breakpoint directly under an StgRhsClosure we don't
4320++ need to introduce a new binding for it.
4321++ -}
4322++ expr' <- bcPrepExpr expr
4323++ pure (StgRhsClosure fvs cc upd args (StgTick bp expr'))
4324++bcPrepRHS (StgRhsClosure fvs cc upd args expr) =
4325++ StgRhsClosure fvs cc upd args <$> bcPrepExpr expr
4326++bcPrepRHS con@StgRhsCon{} = pure con
4327++
4328++bcPrepExpr :: StgExpr -> BcM StgExpr
4329++-- explicitly match all constructors so we get a warning if we miss any
4330++bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs)
4331++ | isLiftedTypeKind (typeKind tick_ty) = do
4332++ id <- newId tick_ty
4333++ rhs' <- bcPrepExpr rhs
4334++ let expr' = StgTick bp rhs'
4335++ bnd = StgNonRec id (StgRhsClosure noExtFieldSilent
4336++ CC.dontCareCCS
4337++ ReEntrant
4338++ []
4339++ expr'
4340++ )
4341++ letExp = StgLet noExtFieldSilent bnd (StgApp id [])
4342++ pure letExp
4343++ | otherwise = do
4344++ id <- newId (mkVisFunTy realWorldStatePrimTy tick_ty)
4345++ st <- newId realWorldStatePrimTy
4346++ rhs' <- bcPrepExpr rhs
4347++ let expr' = StgTick bp rhs'
4348++ bnd = StgNonRec id (StgRhsClosure noExtFieldSilent
4349++ CC.dontCareCCS
4350++ ReEntrant
4351++ [voidArgId]
4352++ expr'
4353++ )
4354++ pure $ StgLet noExtFieldSilent bnd (StgApp id [StgVarArg st])
4355++bcPrepExpr (StgTick tick rhs) =
4356++ StgTick tick <$> bcPrepExpr rhs
4357++bcPrepExpr (StgLet xlet bnds expr) =
4358++ StgLet xlet <$> bcPrepBind bnds
4359++ <*> bcPrepExpr expr
4360++bcPrepExpr (StgLetNoEscape xlne bnds expr) =
4361++ StgLet xlne <$> bcPrepBind bnds
4362++ <*> bcPrepExpr expr
4363++bcPrepExpr (StgCase expr bndr alt_type alts) =
4364++ StgCase <$> bcPrepExpr expr
4365++ <*> pure bndr
4366++ <*> pure alt_type
4367++ <*> mapM bcPrepAlt alts
4368++bcPrepExpr lit@StgLit{} = pure lit
4369++-- See Note [Not-necessarily-lifted join points], step 3.
4370++bcPrepExpr (StgApp x [])
4371++ | isNNLJoinPoint x = pure $
4372++ StgApp (protectNNLJoinPointId x) [StgVarArg voidPrimId]
4373++bcPrepExpr app@StgApp{} = pure app
4374++bcPrepExpr app@StgConApp{} = pure app
4375++bcPrepExpr app@StgOpApp{} = pure app
4376++bcPrepExpr StgLam{} = panic "bcPrepExpr: StgLam"
4377++
4378++bcPrepAlt :: StgAlt -> BcM StgAlt
4379++bcPrepAlt (ac, bndrs, expr) = (,,) ac bndrs <$> bcPrepExpr expr
4380++
4381++bcPrepBind :: StgBinding -> BcM StgBinding
4382++-- explicitly match all constructors so we get a warning if we miss any
4383++bcPrepBind (StgNonRec bndr rhs) =
4384++ let (bndr', rhs') = bcPrepSingleBind (bndr, rhs)
4385++ in StgNonRec bndr' <$> bcPrepRHS rhs'
4386++bcPrepBind (StgRec bnds) =
4387++ StgRec <$> mapM ((\(b,r) -> (,) b <$> bcPrepRHS r) . bcPrepSingleBind)
4388++ bnds
4389++
4390++bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs)
4391++-- If necessary, modify this Id and body to protect not-necessarily-lifted join points.
4392++-- See Note [Not-necessarily-lifted join points], step 2.
4393++bcPrepSingleBind (x, StgRhsClosure ext cc upd_flag args body)
4394++ | isNNLJoinPoint x
4395++ = ( protectNNLJoinPointId x
4396++ , StgRhsClosure ext cc upd_flag (args ++ [voidArgId]) body)
4397++bcPrepSingleBind bnd = bnd
4398+
4399+ -- -----------------------------------------------------------------------------
4400+ -- Compilation schema for the bytecode generator
1024401
1034402 type BCInstrList = OrdList BCInstr
1044403
@@ -111,7 +4410,7 @@ index fb60c21f9d..62e8457c5a 100644
1114410 wordsToBytes :: DynFlags -> WordOff -> ByteOff
1124411 wordsToBytes dflags = fromIntegral . (* wORD_SIZE dflags) . fromIntegral
1134412
114−@@ -230,7 +229,7 @@ ppBCEnv p
4413+@@ -230,7 +324,7 @@ ppBCEnv p
1154414 $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))
1164415 $$ text "end-env"
1174416 where
@@ -120,7 +4419,16 @@ index fb60c21f9d..62e8457c5a 100644
1204419 cmp_snd x y = compare (snd x) (snd y)
1214420 -}
1224421
123−@@ -299,6 +298,11 @@ argBits dflags (rep : args)
4422+@@ -240,7 +334,7 @@ mkProtoBCO
4423+ :: DynFlags
4424+ -> name
4425+ -> BCInstrList
4426+- -> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
4427++ -> Either [CgStgAlt] (CgStgRhs)
4428+ -- ^ original expression; for debugging only
4429+ -> Int
4430+ -> Word16
4431+@@ -299,12 +393,17 @@ argBits dflags (rep : args)
1244432 | isFollowableArg rep = False : argBits dflags args
1254433 | otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args
1264434
@@ -132,125 +4440,667 @@ index fb60c21f9d..62e8457c5a 100644
1324440 -- -----------------------------------------------------------------------------
1334441 -- schemeTopBind
1344442
135−@@ -482,6 +486,57 @@ returnUnboxedAtom d s p e e_rep = do
136− `appOL` mkSlideB dflags szb (d - s) -- clear to sequel
137− `snocOL` RETURN_UBX e_rep) -- go
4443+ -- Compile code for the right-hand side of a top-level binding
4444+
4445+-schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)
4446++schemeTopBind :: (Id, CgStgRhs) -> BcM (ProtoBCO Name)
4447+ schemeTopBind (id, rhs)
4448+ | Just data_con <- isDataConWorkId_maybe id,
4449+ isNullaryRepDataCon data_con = do
4450+@@ -321,7 +420,7 @@ schemeTopBind (id, rhs)
4451+ (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
4452+
4453+ | otherwise
4454+- = schemeR [{- No free variables -}] (id, rhs)
4455++ = schemeR [{- No free variables -}] (getName id, rhs)
4456+
4457+
4458+ -- -----------------------------------------------------------------------------
4459+@@ -333,46 +432,29 @@ schemeTopBind (id, rhs)
4460+ -- removing the free variables and arguments.
4461+ --
4462+ -- Park the resulting BCO in the monad. Also requires the
4463+--- variable to which this value was bound, so as to give the
4464+--- resulting BCO a name.
4465+-
4466++-- name of the variable to which this value was bound,
4467++-- so as to give the resulting BCO a name.
4468+ schemeR :: [Id] -- Free vars of the RHS, ordered as they
4469+ -- will appear in the thunk. Empty for
4470+ -- top-level things, which have no free vars.
4471+- -> (Id, AnnExpr Id DVarSet)
4472++ -> (Name, CgStgRhs)
4473+ -> BcM (ProtoBCO Name)
4474+ schemeR fvs (nm, rhs)
4475+-{-
4476+- | trace (showSDoc (
4477+- (char ' '
4478+- $$ (ppr.filter (not.isTyVar).dVarSetElems.fst) rhs
4479+- $$ pprCoreExpr (deAnnotate rhs)
4480+- $$ char ' '
4481+- ))) False
4482+- = undefined
4483+- | otherwise
4484+--}
4485+ = schemeR_wrk fvs nm rhs (collect rhs)
4486+
4487+ -- If an expression is a lambda (after apply bcView), return the
4488+ -- list of arguments to the lambda (in R-to-L order) and the
4489+ -- underlying expression
4490+-collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet)
4491+-collect (_, e) = go [] e
4492+- where
4493+- go xs e | Just e' <- bcView e = go xs e'
4494+- go xs (AnnLam x (_,e))
4495+- | typePrimRep (idType x) `lengthExceeds` 1
4496+- = multiValException
4497+- | otherwise
4498+- = go (x:xs) e
4499+- go xs not_lambda = (reverse xs, not_lambda)
4500++
4501++collect :: CgStgRhs -> ([Var], CgStgExpr)
4502++collect (StgRhsClosure _ _ _ args body) = (args, body)
4503++collect (StgRhsCon _cc dc args) = ([], StgConApp dc args [])
4504+
4505+ schemeR_wrk
4506+ :: [Id]
4507+- -> Id
4508+- -> AnnExpr Id DVarSet -- expression e, for debugging only
4509+- -> ([Var], AnnExpr' Var DVarSet) -- result of collect on e
4510++ -> Name
4511++ -> CgStgRhs -- expression e, for debugging only
4512++ -> ([Var], CgStgExpr) -- result of collect on e
4513+ -> BcM (ProtoBCO Name)
4514+ schemeR_wrk fvs nm original_body (args, body)
4515+ = do
4516+@@ -400,17 +482,16 @@ schemeR_wrk fvs nm original_body (args, body)
4517+ arity bitmap_size bitmap False{-not alts-})
4518+
4519+ -- introduce break instructions for ticked expressions
4520+-schemeER_wrk :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
4521+-schemeER_wrk d p rhs
4522+- | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs
4523+- = do code <- schemeE d 0 p newRhs
4524++schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList
4525++schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs) rhs)
4526++ = do code <- schemeE d 0 p rhs
4527+ cc_arr <- getCCArray
4528+ this_mod <- moduleName <$> getCurrentModule
4529+ dflags <- getDynFlags
4530+ let idOffSets = getVarOffSets dflags d p fvs
4531+ let breakInfo = CgBreakInfo
4532+ { cgb_vars = idOffSets
4533+- , cgb_resty = exprType (deAnnotate' newRhs)
4534++ , cgb_resty = tick_ty
4535+ }
4536+ newBreakInfo tick_no breakInfo
4537+ dflags <- getDynFlags
4538+@@ -418,7 +499,7 @@ schemeER_wrk d p rhs
4539+ | otherwise = toRemotePtr nullPtr
4540+ let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc
4541+ return $ breakInstr `consOL` code
4542+- | otherwise = schemeE d 0 p rhs
4543++schemeER_wrk d p rhs = schemeE d 0 p rhs
4544+
4545+ getVarOffSets :: DynFlags -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)]
4546+ getVarOffSets dflags depth env = map getOffSet
4547+@@ -450,7 +531,7 @@ trunc16B = truncIntegral16
4548+ trunc16W :: WordOff -> Word16
4549+ trunc16W = truncIntegral16
1384550
139−+-- XXX merge the two functions below
140−+-- XXX use the old special cases if possible (more efficient)
4551+-fvsToEnv :: BCEnv -> DVarSet -> [Id]
4552++fvsToEnv :: BCEnv -> CgStgRhs -> [Id]
4553+ -- Takes the free variables of a right-hand side, and
4554+ -- delivers an ordered list of the local variables that will
4555+ -- be captured in the thunk for the RHS
4556+@@ -459,88 +540,126 @@ fvsToEnv :: BCEnv -> DVarSet -> [Id]
4557+ --
4558+ -- The code that constructs the thunk, and the code that executes
4559+ -- it, have to agree about this layout
4560+-fvsToEnv p fvs = [v | v <- dVarSetElems fvs,
4561+- isId v, -- Could be a type variable
4562+- v `Map.member` p]
4563++
4564++fvsToEnv p (StgRhsClosure fvs _ _ _ _) =
4565++ [v | v <- dVarSetElems fvs,
4566++ v `Map.member` p]
4567++fvsToEnv _ _ = []
4568+
4569+ -- -----------------------------------------------------------------------------
4570+ -- schemeE
4571+
4572++-- Returning an unlifted value.
4573++-- Heave it on the stack, SLIDE, and RETURN.
4574+ returnUnboxedAtom
4575+ :: StackDepth
4576+ -> Sequel
4577+ -> BCEnv
4578+- -> AnnExpr' Id DVarSet
4579+- -> ArgRep
4580++ -> StgArg
4581+ -> BcM BCInstrList
4582+--- Returning an unlifted value.
4583+--- Heave it on the stack, SLIDE, and RETURN.
4584+-returnUnboxedAtom d s p e e_rep = do
4585+- dflags <- getDynFlags
4586++returnUnboxedAtom d s p e = do
4587++ let reps = case e of
4588++ StgLitArg lit -> typePrimRepArgs (literalType lit)
4589++ StgVarArg i -> bcIdPrimReps i
4590+ (push, szb) <- pushAtom d p e
4591+- return (push -- value onto stack
4592+- `appOL` mkSlideB dflags szb (d - s) -- clear to sequel
4593+- `snocOL` RETURN_UBX e_rep) -- go
4594++ ret <- returnUnboxedReps d s szb reps
4595++ return (push `appOL` ret)
4596++
4597++-- return an unboxed value from the top of the stack
4598++returnUnboxedReps
4599++ :: StackDepth
4600++ -> Sequel
4601++ -> ByteOff -- size of the thing we're returning
4602++ -> [PrimRep] -- representations
4603++ -> BcM BCInstrList
4604++returnUnboxedReps d s szb reps = do
4605++ dflags <- getDynFlags
4606++ let non_void VoidRep = False
4607++ non_void _ = True
4608++ ret <- case filter non_void reps of
4609++ -- use RETURN_UBX for unary representations
4610++ [] -> return (unitOL $ RETURN_UBX V)
4611++ [rep] -> return (unitOL $ RETURN_UBX (toArgRep rep))
4612++ -- otherwise use RETURN_T with a tuple descriptor
4613++ nv_reps -> do
4614++ let (tuple_info, args_offsets) = layoutTuple dflags 0 (primRepCmmType dflags) nv_reps
4615++ args_ptrs = map (\(rep, off) -> (isFollowableArg (toArgRep rep), off)) args_offsets
4616++ tuple_bco <- emitBc (tupleBCO dflags tuple_info args_ptrs)
4617++ return $ PUSH_UBX (mkTupleInfoLit dflags tuple_info) 1 `consOL`
4618++ PUSH_BCO tuple_bco `consOL`
4619++ unitOL RETURN_T
4620++ return ( mkSlideB dflags szb (d - s) -- clear to sequel
4621++ `appOL` ret) -- go
4622++
4623++-- construct and return an unboxed tuple
1414624+returnUnboxedTuple
1424625+ :: StackDepth
1434626+ -> Sequel
1444627+ -> BCEnv
145−+ -> [AnnExpr' Id DVarSet]
4628++ -> [StgArg]
1464629+ -> BcM BCInstrList
1474630+returnUnboxedTuple d s p es = do
1484631+ dflags <- getDynFlags
1494632+ let arg_ty e = primRepCmmType dflags (atomPrimRep e)
1504633+ (tuple_info, tuple_components) = layoutTuple dflags d arg_ty es
151−+ args_ptrs = map (\(e, off) -> (isFollowableArg (atomRep e), off)) tuple_components
1524634+ go _ pushes [] = return (reverse pushes)
1534635+ go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a
1544636+ MASSERT(off == dd + szb)
1554637+ go (dd + szb) (push:pushes) cs
1564638+ pushes <- go d [] tuple_components
157−+ tuple_bco <- emitBc (tupleBCO dflags tuple_info args_ptrs)
158−+ return (mconcat pushes
159−+ `appOL` mkSlideB dflags (wordsToBytes dflags $ tupleSize tuple_info) (d - s) -- clear to sequel
160−+ `snocOL` PUSH_UBX (mkLitWord dflags . fromIntegral $ mkTupleInfoSig tuple_info) 1 -- add info word
161−+ `snocOL` PUSH_BCO tuple_bco -- add info BCO
162−+ `snocOL` RETURN_T) -- go
163−+
164−+
165−+
166−+-- return a tuple that's already on the stack in the right order
167−+returnUnboxedTuple'
168−+ :: StackDepth -- ^ current stack depth
169−+ -> Sequel -- ^ depth of sequel
170−+ -> BCEnv
171−+ -> StackDepth -- ^ depth of start of tuple
172−+ -> [PrimRep]
173−+ -> BcM BCInstrList
174−+returnUnboxedTuple' d s _p d_tuple t_reps = do
175−+ dflags <- getDynFlags
176−+ let arg_ty :: PrimRep -> CmmType
177−+ arg_ty e = primRepCmmType dflags e
178−+ (tuple_info, tuple_components) = layoutTuple dflags d arg_ty t_reps
179−+ args_ptrs = map (\(rep, off) -> (isFollowableArg (toArgRep rep), off)) tuple_components
180−+ tuple_offset = trunc16W $ bytesToWords dflags (d - d_tuple) + tupleSize tuple_info - 1
181−+ copyTuple = replicate (fromIntegral $ tupleSize tuple_info)
182−+ (PUSH_L tuple_offset)
183−+ tuple_bco <- emitBc (tupleBCO dflags tuple_info args_ptrs)
184−+ return (toOL copyTuple
185−+ `appOL` mkSlideB dflags (wordsToBytes dflags $ tupleSize tuple_info) (d - s) -- clear to sequel
186−+ `snocOL` PUSH_UBX (mkLitWord dflags . fromIntegral $ mkTupleInfoSig tuple_info) 1 -- add info word
187−+ `snocOL` PUSH_BCO tuple_bco
188−+ `snocOL` RETURN_T) -- go
189−+
4639++ ret <- returnUnboxedReps d
4640++ s
4641++ (wordsToBytes dflags $ tupleSize tuple_info)
4642++ (map atomPrimRep es)
4643++ return (mconcat pushes `appOL` ret)
4644+
1904645 -- Compile code to apply the given expression to the remaining args
1914646 -- on the stack, returning a HNF.
1924647 schemeE
193−@@ -499,6 +554,10 @@ schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V
194− schemeE d s p e@(AnnVar v)
195− -- See Note [Not-necessarily-lifted join points], step 3.
196− | isNNLJoinPoint v = doTailCall d s p (protectNNLJoinPointId v) [AnnVar voidPrimId]
197−+ | isUnboxedTupleType (idType v) =
198−+ let d_tuple = fromMaybe (panic "CoreToByteCode.schemeE: global unboxed tuples are not supported")
199−+ (lookupBCEnv_maybe v p)
200−+ in returnUnboxedTuple' d s p d_tuple (bcIdPrimReps v) --- XXX should this be arg reps instead?
201− | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)
202− | otherwise = schemeT d s p e
203−
204−@@ -817,7 +876,8 @@ schemeT d s p app
205− unboxedTupleReturn d s p arg2
206− [arg1,arg2] | isVAtom arg2 ->
207− unboxedTupleReturn d s p arg1
4648+- :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
4649+-schemeE d s p e
4650+- | Just e' <- bcView e
4651+- = schemeE d s p e'
4652++ :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList
4653++schemeE d s p (StgLit lit) = returnUnboxedAtom d s p (StgLitArg lit)
4654++schemeE d s p (StgApp x [])
4655++ | isUnliftedType (idType x) = returnUnboxedAtom d s p (StgVarArg x)
4656++schemeE _ _ _ (StgLam {}) = panic "schemeE: StgLam"
4657+
4658+ -- Delegate tail-calls to schemeT.
4659+-schemeE d s p e@(AnnApp _ _) = schemeT d s p e
4660+-
4661+-schemeE d s p e@(AnnLit lit) = returnUnboxedAtom d s p e (typeArgRep (literalType lit))
4662+-schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V
4663+-
4664+-schemeE d s p e@(AnnVar v)
4665+- -- See Note [Not-necessarily-lifted join points], step 3.
4666+- | isNNLJoinPoint v = doTailCall d s p (protectNNLJoinPointId v) [AnnVar voidPrimId]
4667+- | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)
4668+- | otherwise = schemeT d s p e
4669+-
4670+-schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
4671+- | (AnnVar v, args_r_to_l) <- splitApp rhs,
4672+- Just data_con <- isDataConWorkId_maybe v,
4673+- dataConRepArity data_con == length args_r_to_l
4674++schemeE d s p e@(StgApp {}) = schemeT d s p e
4675++schemeE d s p e@(StgConApp {}) = schemeT d s p e
4676++schemeE d s p e@(StgOpApp {}) = schemeT d s p e
4677++schemeE d s p (StgLetNoEscape xlet bnd body)
4678++ = schemeE d s p (StgLet xlet bnd body)
4679++schemeE d s p (StgLet _xlet (StgNonRec x (StgRhsCon _cc data_con args)) body)
4680+ = do -- Special case for a non-recursive let whose RHS is a
4681+ -- saturated constructor application.
4682+ -- Just allocate the constructor and carry on
4683+- alloc_code <- mkConAppCode d s p data_con args_r_to_l
4684++ alloc_code <- mkConAppCode d s p data_con args
4685+ dflags <- getDynFlags
4686+ let !d2 = d + wordSize dflags
4687+ body_code <- schemeE d2 s (Map.insert x d2 p) body
4688+ return (alloc_code `appOL` body_code)
4689+-
4690+ -- General case for let. Generates correct, if inefficient, code in
4691+ -- all situations.
4692+-schemeE d s p (AnnLet binds (_,body)) = do
4693++schemeE d s p (StgLet _ext binds body) = do
4694+ dflags <- getDynFlags
4695+- let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
4696+- AnnRec xs_n_rhss -> unzip xs_n_rhss
4697++ let (xs,rhss) = case binds of StgNonRec x rhs -> ([x],[rhs])
4698++ StgRec xs_n_rhss -> unzip xs_n_rhss
4699+ n_binds = genericLength xs
4700+
4701+- fvss = map (fvsToEnv p' . fst) rhss
4702+-
4703+- -- See Note [Not-necessarily-lifted join points], step 2.
4704+- (xs',rhss') = zipWithAndUnzip protectNNLJoinPointBind xs rhss
4705++ fvss = map (fvsToEnv p') rhss
4706+
4707+ -- Sizes of free vars
4708+ size_w = trunc16W . idSizeW dflags
4709+ sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss
4710+
4711+ -- the arity of each rhs
4712+- arities = map (genericLength . fst . collect) rhss'
4713++ arities = map (genericLength . fst . collect) rhss
4714+
4715+ -- This p', d' defn is safe because all the items being pushed
4716+ -- are ptrs, so all have size 1 word. d' and p' reflect the stack
4717+ -- after the closures have been allocated in the heap (but not
4718+ -- filled in), and pointers to them parked on the stack.
4719+ offsets = mkStackOffsets d (genericReplicate n_binds (wordSize dflags))
4720+- p' = Map.insertList (zipE xs' offsets) p
4721++ p' = Map.insertList (zipE xs offsets) p
4722+ d' = d + wordsToBytes dflags n_binds
4723+ zipE = zipEqual "schemeE"
4724+
4725+@@ -559,7 +678,7 @@ schemeE d s p (AnnLet binds (_,body)) = do
4726+ mkap | arity == 0 = MKAP
4727+ | otherwise = MKPAP
4728+ build_thunk dd (fv:fvs) size bco off arity = do
4729+- (push_code, pushed_szb) <- pushAtom dd p' (AnnVar fv)
4730++ (push_code, pushed_szb) <- pushAtom dd p' (StgVarArg fv)
4731+ more_push_code <-
4732+ build_thunk (dd + pushed_szb) fvs size bco off arity
4733+ return (push_code `appOL` more_push_code)
4734+@@ -571,109 +690,35 @@ schemeE d s p (AnnLet binds (_,body)) = do
4735+ mkAlloc sz arity = ALLOC_PAP arity sz
4736+
4737+ is_tick = case binds of
4738+- AnnNonRec id _ -> occNameFS (getOccName id) == tickFS
4739++ StgNonRec id _ -> occNameFS (getOccName id) == tickFS
4740+ _other -> False
4741+
4742+ compile_bind d' fvs x rhs size arity off = do
4743+- bco <- schemeR fvs (x,rhs)
4744++ bco <- schemeR fvs (getName x,rhs)
4745+ build_thunk d' fvs size bco off arity
4746+
4747+ compile_binds =
4748+ [ compile_bind d' fvs x rhs size arity (trunc16W n)
4749+ | (fvs, x, rhs, size, arity, n) <-
4750+- zip6 fvss xs' rhss' sizes arities [n_binds, n_binds-1 .. 1]
4751++ zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
4752+ ]
4753+ body_code <- schemeE d' s p' body
4754+ thunk_codes <- sequence compile_binds
4755+ return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
4756+
4757+--- Introduce a let binding for a ticked case expression. This rule
4758+--- *should* only fire when the expression was not already let-bound
4759+--- (the code gen for let bindings should take care of that). Todo: we
4760+--- call exprFreeVars on a deAnnotated expression, this may not be the
4761+--- best way to calculate the free vars but it seemed like the least
4762+--- intrusive thing to do
4763+-schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)
4764+- | isLiftedTypeKind (typeKind ty)
4765+- = do id <- newId ty
4766+- -- Todo: is emptyVarSet correct on the next line?
4767+- let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id)
4768+- schemeE d s p letExp
4769+-
4770+- | otherwise
4771+- = do -- If the result type is not definitely lifted, then we must generate
4772+- -- let f = \s . tick<n> e
4773+- -- in f realWorld#
4774+- -- When we stop at the breakpoint, _result will have an unlifted
4775+- -- type and hence won't be bound in the environment, but the
4776+- -- breakpoint will otherwise work fine.
4777+- --
4778+- -- NB (#12007) this /also/ applies for if (ty :: TYPE r), where
4779+- -- r :: RuntimeRep is a variable. This can happen in the
4780+- -- continuations for a pattern-synonym matcher
4781+- -- match = /\(r::RuntimeRep) /\(a::TYPE r).
4782+- -- \(k :: Int -> a) \(v::T).
4783+- -- case v of MkV n -> k n
4784+- -- Here (k n) :: a :: Type r, so we don't know if it's lifted
4785+- -- or not; but that should be fine provided we add that void arg.
4786+-
4787+- id <- newId (mkVisFunTy realWorldStatePrimTy ty)
4788+- st <- newId realWorldStatePrimTy
4789+- let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp)))
4790+- (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id)
4791+- (emptyDVarSet, AnnVar realWorldPrimId)))
4792+- schemeE d s p letExp
4793+-
4794+- where
4795+- exp' = deAnnotate' exp
4796+- fvs = exprFreeVarsDSet exp'
4797+- ty = exprType exp'
4798++schemeE _d _s _p (StgTick (Breakpoint _ bp_id _) _rhs)
4799++ = panic ("schemeE: Breakpoint without let binding: " ++
4800++ show bp_id ++
4801++ " forgot to run bcPrep?")
4802+
4803+ -- ignore other kinds of tick
4804+-schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs
4805+-
4806+-schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
4807+- -- no alts: scrut is guaranteed to diverge
4808+-
4809+-schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
4810+- | isUnboxedTupleCon dc -- handles pairs with one void argument (e.g. state token)
4811+- -- Convert
4812+- -- case .... of x { (# V'd-thing, a #) -> ... }
4813+- -- to
4814+- -- case .... of a { DEFAULT -> ... }
4815+- -- because the return convention for both are identical.
4816+- --
4817+- -- Note that it does not matter losing the void-rep thing from the
4818+- -- envt (it won't be bound now) because we never look such things up.
4819+- , Just res <- case (typePrimRep (idType bind1), typePrimRep (idType bind2)) of
4820+- ([], [_])
4821+- -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr)
4822+- ([_], [])
4823+- -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
4824+- _ -> Nothing
4825+- = res
4826+-
4827+-schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
4828+- | isUnboxedTupleCon dc
4829+- , typePrimRep (idType bndr) `lengthAtMost` 1 -- handles unit tuples
4830+- = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
4831+-
4832+-schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)])
4833+- | isUnboxedTupleType (idType bndr)
4834+- , Just ty <- case typePrimRep (idType bndr) of
4835+- [_] -> Just (unwrapType (idType bndr))
4836+- [] -> Just voidPrimTy
4837+- _ -> Nothing
4838+- -- handles any pattern with a single non-void binder; in particular I/O
4839+- -- monad returns (# RealWorld#, a #)
4840+- = doCase d s p scrut (bndr `setIdType` ty) alt (Just bndr)
4841+-
4842+-schemeE d s p (AnnCase scrut bndr _ alts)
4843+- = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-}
4844+-
4845+-schemeE _ _ _ expr
4846+- = pprPanic "ByteCodeGen.schemeE: unhandled case"
4847+- (pprCoreExpr (deAnnotate' expr))
4848++schemeE d s p (StgTick _ rhs) = schemeE d s p rhs
4849++
4850++-- no alts: scrut is guaranteed to diverge
4851++schemeE d s p (StgCase scrut _ _ []) = schemeE d s p scrut
4852++
4853++schemeE d s p (StgCase scrut bndr _ alts)
4854++ = doCase d s p scrut bndr alts
4855+
4856+ -- Is this Id a not-necessarily-lifted join point?
4857+ -- See Note [Not-necessarily-lifted join points], step 1
4858+@@ -681,16 +726,6 @@ isNNLJoinPoint :: Id -> Bool
4859+ isNNLJoinPoint x = isJoinId x &&
4860+ Just True /= isLiftedType_maybe (idType x)
4861+
4862+--- If necessary, modify this Id and body to protect not-necessarily-lifted join points.
4863+--- See Note [Not-necessarily-lifted join points], step 2.
4864+-protectNNLJoinPointBind :: Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet)
4865+-protectNNLJoinPointBind x rhs@(fvs, _)
4866+- | isNNLJoinPoint x
4867+- = (protectNNLJoinPointId x, (fvs, AnnLam voidArgId rhs))
4868+-
4869+- | otherwise
4870+- = (x, rhs)
4871+-
4872+ -- Update an Id's type to take a Void# argument.
4873+ -- Precondition: the Id is a not-necessarily-lifted join point.
4874+ -- See Note [Not-necessarily-lifted join points]
4875+@@ -778,10 +813,8 @@ Right Fix is to take advantage of join points as goto-labels.
4876+ --
4877+ -- 1. The fn denotes a ccall. Defer to generateCCall.
4878+ --
4879+--- 2. (Another nasty hack). Spot (# a::V, b #) and treat
4880+--- it simply as b -- since the representations are identical
4881+--- (the V takes up zero stack space). Also, spot
4882+--- (# b #) and treat it as b.
4883++-- 2. An unboxed tuple: push the components on the top of
4884++-- the stack and return.
4885+ --
4886+ -- 3. Application of a constructor, by defn saturated.
4887+ -- Split the args into ptrs and non-ptrs, and push the nonptrs,
4888+@@ -793,57 +826,45 @@ Right Fix is to take advantage of join points as goto-labels.
4889+ schemeT :: StackDepth -- Stack depth
4890+ -> Sequel -- Sequel depth
4891+ -> BCEnv -- stack env
4892+- -> AnnExpr' Id DVarSet
4893++ -> CgStgExpr
4894+ -> BcM BCInstrList
4895+
4896+-schemeT d s p app
4897+-
4898+ -- Case 0
4899++schemeT d s p app
4900+ | Just (arg, constr_names) <- maybe_is_tagToEnum_call app
4901+ = implement_tagToId d s p arg constr_names
4902+
4903+ -- Case 1
4904+- | Just (CCall ccall_spec) <- isFCallId_maybe fn
4905++schemeT d s p (StgOpApp (StgFCallOp (CCall ccall_spec) _ty) args result_ty)
4906+ = if isSupportedCConv ccall_spec
4907+- then generateCCall d s p ccall_spec fn args_r_to_l
4908++ then generateCCall d s p ccall_spec result_ty (reverse args)
4909+ else unsupportedCConvException
4910+
4911++schemeT d s p (StgOpApp (StgPrimOp op) args _ty)
4912++ = doTailCall d s p (primOpId op) (reverse args)
4913++
4914++schemeT _d _s _p (StgOpApp (StgPrimCallOp {}) _args _ty)
4915++ = unsupportedCConvException
4916+
4917+- -- Case 2: Constructor application
4918+- | Just con <- maybe_saturated_dcon
4919+- , isUnboxedTupleCon con
4920+- = case args_r_to_l of
4921+- [arg1,arg2] | isVAtom arg1 ->
4922+- unboxedTupleReturn d s p arg2
4923+- [arg1,arg2] | isVAtom arg2 ->
4924+- unboxedTupleReturn d s p arg1
2084925- _other -> multiValException
209−+ -- XXX find if we can work the above cases into the general version
210−+ other -> returnUnboxedTuple d s p (reverse other)
4926++ -- Case 2: Unboxed tuple
4927++schemeT d s p (StgConApp con args _tys)
4928++ | isUnboxedTupleCon con || isUnboxedSumCon con
4929++ = returnUnboxedTuple d s p args
2114930
2124931 -- Case 3: Ordinary data constructor
213− | Just con <- maybe_saturated_dcon
214−@@ -979,12 +1039,12 @@ doCase
215− -- don't enter the result
4932+- | Just con <- maybe_saturated_dcon
4933+- = do alloc_con <- mkConAppCode d s p con args_r_to_l
4934++ | otherwise
4935++ = do alloc_con <- mkConAppCode d s p con args
4936+ dflags <- getDynFlags
4937+ return (alloc_con `appOL`
4938+ mkSlideW 1 (bytesToWords dflags $ d - s) `snocOL`
4939+ ENTER)
4940+
4941+ -- Case 4: Tail call of function
4942+- | otherwise
4943+- = doTailCall d s p fn args_r_to_l
4944+-
4945+- where
4946+- -- Extract the args (R->L) and fn
4947+- -- The function will necessarily be a variable,
4948+- -- because we are compiling a tail call
4949+- (AnnVar fn, args_r_to_l) = splitApp app
4950+-
4951+- -- Only consider this to be a constructor application iff it is
4952+- -- saturated. Otherwise, we'll call the constructor wrapper.
4953+- n_args = length args_r_to_l
4954+- maybe_saturated_dcon
4955+- = case isDataConWorkId_maybe fn of
4956+- Just con | dataConRepArity con == n_args -> Just con
4957+- _ -> Nothing
4958++schemeT d s p (StgApp fn args)
4959++ = doTailCall d s p fn (reverse args)
4960++
4961++schemeT _ _ _ e = pprPanic "GHC.CoreToByteCode.schemeT"
4962++ (pprStgExpr e)
4963+
4964+ -- -----------------------------------------------------------------------------
4965+ -- Generate code to build a constructor application,
4966+@@ -854,25 +875,16 @@ mkConAppCode
4967+ -> Sequel
4968+ -> BCEnv
4969+ -> DataCon -- The data constructor
4970+- -> [AnnExpr' Id DVarSet] -- Args, in *reverse* order
4971++ -> [StgArg] -- Args, in *reverse* order
4972+ -> BcM BCInstrList
4973+-mkConAppCode _ _ _ con [] -- Nullary constructor
4974+- = ASSERT( isNullaryRepDataCon con )
4975+- return (unitOL (PUSH_G (getName (dataConWorkId con))))
4976+- -- Instead of doing a PACK, which would allocate a fresh
4977+- -- copy of this constructor, use the single shared version.
4978+-
4979+-mkConAppCode orig_d _ p con args_r_to_l =
4980+- ASSERT( args_r_to_l `lengthIs` dataConRepArity con ) app_code
4981++mkConAppCode orig_d _ p con args = app_code
4982+ where
4983+ app_code = do
4984+ dflags <- getDynFlags
4985+
4986+- -- The args are initially in reverse order, but mkVirtHeapOffsets
4987+- -- expects them to be left-to-right.
4988+ let non_voids =
4989+ [ NonVoid (prim_rep, arg)
4990+- | arg <- reverse args_r_to_l
4991++ | arg <- args
4992+ , let prim_rep = atomPrimRep arg
4993+ , not (isVoidRep prim_rep)
4994+ ]
4995+@@ -892,18 +904,6 @@ mkConAppCode orig_d _ p con args_r_to_l =
4996+ -- Push on the stack in the reverse order.
4997+ do_pushery orig_d (reverse args_offsets)
4998+
4999+-
5000+--- -----------------------------------------------------------------------------
5001+--- Returning an unboxed tuple with one non-void component (the only
5002+--- case we can handle).
5003+---
5004+--- Remember, we don't want to *evaluate* the component that is being
5005+--- returned, even if it is a pointed type. We always just return.
5006+-
5007+-unboxedTupleReturn
5008+- :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
5009+-unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)
5010+-
5011+ -- -----------------------------------------------------------------------------
5012+ -- Generate code for a tail-call
5013+
5014+@@ -912,13 +912,13 @@ doTailCall
5015+ -> Sequel
5016+ -> BCEnv
5017+ -> Id
5018+- -> [AnnExpr' Id DVarSet]
5019++ -> [StgArg]
5020+ -> BcM BCInstrList
5021+ doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args)
5022+ where
5023+ do_pushes !d [] reps = do
5024+ ASSERT( null reps ) return ()
5025+- (push_fn, sz) <- pushAtom d p (AnnVar fn)
5026++ (push_fn, sz) <- pushAtom d p (StgVarArg fn)
5027+ dflags <- getDynFlags
5028+ ASSERT( sz == wordSize dflags ) return ()
5029+ let slide = mkSlideB dflags (d - init_d + wordSize dflags) (init_d - s)
5030+@@ -972,19 +972,26 @@ doCase
5031+ :: StackDepth
5032+ -> Sequel
5033+ -> BCEnv
5034+- -> AnnExpr Id DVarSet
5035++ -> CgStgExpr
5036+ -> Id
5037+- -> [AnnAlt Id DVarSet]
5038+- -> Maybe Id -- Just x <=> is an unboxed tuple case with scrut binder,
5039+- -- don't enter the result
5040++ -> [CgStgAlt]
2165041 -> BcM BCInstrList
217− doCase d s p (_,scrut) bndr alts is_unboxed_tuple
5042+-doCase d s p (_,scrut) bndr alts is_unboxed_tuple
2185043- | typePrimRep (idType bndr) `lengthExceeds` 1
2195044- = multiValException
2205045- | otherwise
5046++doCase d s p scrut bndr alts
2215047 = do
2225048 dflags <- getDynFlags
2235049 let
224−+ -- XXX handle general unboxed tuples and the old special cased ones properly here
225−+ utup = isUnboxedTupleType bndr_ty && length (non_void (typeArgReps bndr_ty)) > 1
5050++
5051++ -- Are we dealing with an unboxed tuple with a tuple return frame?
5052++ --
5053++ -- 'Simple' tuples with at most one non-void component,
5054++ -- like (# Word# #) or (# Int#, State# RealWorld# #) do not have a
5055++ -- tuple return frame
5056++ ubx_tuple_frame =
5057++ (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) &&
5058++ length non_void_arg_reps > 1
5059++
5060++ non_void_arg_reps = non_void (typeArgReps bndr_ty)
2265061+
2275062 profiling
2285063 | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags
2295064 | otherwise = rtsIsProfiled
230−@@ -994,8 +1054,9 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
5065+@@ -994,53 +1001,84 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
2315066 -- When an alt is entered, it assumes the returned value is
2325067 -- on top of the itbl.
2335068 ret_frame_size_b :: StackDepth
2345069- ret_frame_size_b = 2 * wordSize dflags
235−-
236−+ ret_frame_size_b | utup = 4 * wordSize dflags
5070++ ret_frame_size_b | ubx_tuple_frame =
5071++ (if profiling then 5 else 4) * wordSize dflags
2375072+ | otherwise = 2 * wordSize dflags
238−+
239− -- The extra frame we push to save/restor the CCCS when profiling
240− save_ccs_size_b | profiling = 2 * wordSize dflags
5073+
5074+- -- The extra frame we push to save/restor the CCCS when profiling
5075+- save_ccs_size_b | profiling = 2 * wordSize dflags
5076++ -- The stack space used to save/restore the CCCS when profiling
5077++ save_ccs_size_b | profiling &&
5078++ not ubx_tuple_frame = 2 * wordSize dflags
2415079 | otherwise = 0
242−@@ -1004,16 +1065,22 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
5080+
5081+ -- An unlifted value gets an extra info table pushed on top
2435082 -- when it is returned.
2445083 unlifted_itbl_size_b :: StackDepth
245− unlifted_itbl_size_b | isAlgCase = 0
5084+- unlifted_itbl_size_b | isAlgCase = 0
2465085- | otherwise = wordSize dflags
247−+ | utup = 3 * wordSize dflags
248−+ | otherwise = wordSize dflags
5086++ unlifted_itbl_size_b | isAlgCase = 0
5087++ | ubx_tuple_frame = 3 * wordSize dflags
5088++ | otherwise = wordSize dflags
2495089+
250−+ bndr_size | utup = let bndr_ty = primRepCmmType dflags
251−+ (tuple_info, _) = layoutTuple dflags 0 bndr_ty (bcIdPrimReps bndr)
252−+ in wordsToBytes dflags (tupleSize tuple_info)
253−+ | otherwise = wordsToBytes dflags (idSizeW dflags bndr)
5090++ (bndr_size, tuple_info, args_offsets)
5091++ | ubx_tuple_frame =
5092++ let bndr_ty = primRepCmmType dflags
5093++ bndr_reps = filter (not.isVoidRep) (bcIdPrimReps bndr)
5094++ (tuple_info, args_offsets) =
5095++ layoutTuple dflags 0 bndr_ty bndr_reps
5096++ in ( wordsToBytes dflags (tupleSize tuple_info)
5097++ , tuple_info
5098++ , args_offsets
5099++ )
5100++ | otherwise = ( wordsToBytes dflags (idSizeW dflags bndr)
5101++ , voidTupleInfo
5102++ , []
5103++ )
2545104
2555105 -- depth of stack after the return value has been pushed
2565106 d_bndr =
@@ -265,7 +5115,26 @@ index fb60c21f9d..62e8457c5a 100644
2655115
2665116 -- Env in which to compile the alts, not including
2675117 -- any vars bound by the alts themselves
268−@@ -1036,11 +1103,26 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
5118+- p_alts0 = Map.insert bndr d_bndr p
5119+-
5120+- p_alts = case is_unboxed_tuple of
5121+- Just ubx_bndr -> Map.insert ubx_bndr d_bndr p_alts0
5122+- Nothing -> p_alts0
5123++ p_alts = Map.insert bndr d_bndr p
5124+
5125+ bndr_ty = idType bndr
5126+- isAlgCase = not (isUnliftedType bndr_ty) && isNothing is_unboxed_tuple
5127++ isAlgCase = not (isUnliftedType bndr_ty)
5128+
5129+ -- given an alt, return a discr and code for it.
5130+- codeAlt (DEFAULT, _, (_,rhs))
5131++ codeAlt (DEFAULT, _, rhs)
5132+ = do rhs_code <- schemeE d_alts s p_alts rhs
5133+ return (NoDiscr, rhs_code)
5134+
5135+- codeAlt alt@(_, bndrs, (_,rhs))
5136++ codeAlt alt@(_, bndrs, rhs)
5137+ -- primitive or nullary constructor alt: no need to UNPACK
2695138 | null real_bndrs = do
2705139 rhs_code <- schemeE d_alts s p_alts rhs
2715140 return (my_discr alt, rhs_code)
@@ -274,7 +5143,7 @@ index fb60c21f9d..62e8457c5a 100644
2745143- -- (See #14608.)
2755144- | any (\bndr -> typePrimRep (idType bndr) `lengthExceeds` 1) bndrs
2765145- = multiValException
277−+ | utup =
5146++ | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty =
2785147+ let bndr_ty = primRepCmmType dflags . bcIdPrimRep
2795148+ tuple_start = d_bndr
2805149+ (tuple_info, args_offsets) =
@@ -286,18 +5155,19 @@ index fb60c21f9d..62e8457c5a 100644
2865155+ stack_bot = d_alts
2875156+
2885157+ p' = Map.insertList
289−+ [ (arg, tuple_start - wordsToBytes dflags (tupleSize tuple_info) + offset)
5158++ [ (arg, tuple_start -
5159++ wordsToBytes dflags (tupleSize tuple_info) +
5160++ offset)
2905161+ | (arg, offset) <- args_offsets
2915162+ , not (isVoidRep $ bcIdPrimRep arg)]
2925163+ p_alts
2935164+ in do
294−+ -- traceCBC ("ubx tup cont: " ++ show (stack_bot,tuple_start,tot_wds) ++ "\n" ++ show args_offsets)
2955165+ rhs_code <- schemeE stack_bot s p' rhs
2965166+ return (NoDiscr, rhs_code)
2975167 -- algebraic alt with some binders
2985168 | otherwise =
2995169 let (tot_wds, _ptrs_wds, args_offsets) =
300−@@ -1068,7 +1150,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
5170+@@ -1068,16 +1106,16 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
3015171 my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
3025172 my_discr (DataAlt dc, _, _)
3035173 | isUnboxedTupleCon dc || isUnboxedSumCon dc
@@ -306,34 +5176,61 @@ index fb60c21f9d..62e8457c5a 100644
3065176 | otherwise
3075177 = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
3085178 my_discr (LitAlt l, _, _)
309−@@ -1100,17 +1182,22 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
5179+- = case l of LitNumber LitNumInt i _ -> DiscrI (fromInteger i)
5180+- LitNumber LitNumWord w _ -> DiscrW (fromInteger w)
5181++ = case l of LitNumber LitNumInt i _ -> DiscrI (fromInteger i)
5182++ LitNumber LitNumWord w _ -> DiscrW (fromInteger w)
5183+ LitFloat r -> DiscrF (fromRational r)
5184+ LitDouble r -> DiscrD (fromRational r)
5185+ LitChar i -> DiscrI (ord i)
5186+- _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
5187++ _ -> pprPanic "schemeE(StgCase).my_discr" (ppr l)
5188+
5189+ maybe_ncons
5190+ | not isAlgCase = Nothing
5191+@@ -1100,20 +1138,36 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
3105192 -- really want a bitmap up to depth (d-s). This affects compilation of
3115193 -- case-of-case expressions, which is the only time we can be compiling a
3125194 -- case expression with s /= 0.
3135195- bitmap_size = trunc16W $ bytesToWords dflags (d - s)
314−+ bitmap_size | utup = trunc16W $ 2 + bytesToWords dflags (d - s)
315−+ | otherwise = trunc16W $ bytesToWords dflags (d - s)
5196++
5197++ -- unboxed tuples get two more words, the second is a pointer (tuple_bco)
5198++ (extra_pointers, extra_slots)
5199++ | ubx_tuple_frame && profiling = ([1], 3) -- tuple_info, tuple_BCO, CCCS
5200++ | ubx_tuple_frame = ([1], 2) -- tuple_info, tuple_BCO
5201++ | otherwise = ([], 0)
5202++
5203++ bitmap_size = trunc16W $ fromIntegral extra_slots +
5204++ bytesToWords dflags (d - s)
5205++
3165206 bitmap_size' :: Int
3175207 bitmap_size' = fromIntegral bitmap_size
3185208- bitmap = intsToReverseBitmap dflags bitmap_size'{-size-}
3195209- (sort (filter (< bitmap_size') rel_slots))
320−+ -- unboxed tuples get two more words, the second is a pointer (tuple_bco)
321−+ bitmap | utup = intsToReverseBitmap dflags bitmap_size'{-size-}
322−+ (1 : sort (filter (< bitmap_size') (map (+2) rel_slots)))
323−+ | otherwise = intsToReverseBitmap dflags bitmap_size'{-size-}
324−+ (sort (filter (< bitmap_size') rel_slots))
5210++
5211++
5212++ pointers =
5213++ extra_pointers ++
5214++ sort (filter (< bitmap_size') (map (+extra_slots) rel_slots))
3255215 where
3265216 binds = Map.toList p
3275217 -- NB: unboxed tuple cases bind the scrut binder to the same offset
3285218 -- as one of the alt binders, so we have to remove any duplicates here:
329− rel_slots = nub $ map fromIntegral $ concat (map spread binds)
5219+- rel_slots = nub $ map fromIntegral $ concat (map spread binds)
3305220- spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
331−+ spread (id, offset) | isUnboxedTupleType (idType id) = []
5221++ rel_slots = nub $ map fromIntegral $ concatMap spread binds
5222++ spread (id, offset) | isUnboxedTupleType (idType id) ||
5223++ isUnboxedSumType (idType id) = []
3325224+ | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
3335225 | otherwise = []
3345226 where rel_offset = trunc16W $ bytesToWords dflags (d - offset)
3355227
336−@@ -1121,19 +1208,117 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
5228++ bitmap = intsToReverseBitmap dflags bitmap_size'{-size-} pointers
5229++
5230+ alt_stuff <- mapM codeAlt alts
5231+ alt_final <- mkMultiBranch maybe_ncons alt_stuff
5232+
5233+@@ -1121,18 +1175,118 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
3375234 alt_bco_name = getName bndr
3385235 alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts)
3395236 0{-no arity-} bitmap_size bitmap True{-is alts-}
@@ -348,25 +5245,27 @@ index fb60c21f9d..62e8457c5a 100644
3485245- | isAlgCase = PUSH_ALTS alt_bco'
3495246- | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty)
3505247- return (push_alts `consOL` scrut_code)
351−+ if utup
5248++ if ubx_tuple_frame
3525249+ then do
353−+ -- XXX we shouldn't call layoutTuple twice
354−+ let (tuple_info, args_offsets) =
355−+ layoutTuple dflags
356−+ 0
357−+ (primRepCmmType dflags)
358−+ (bcIdPrimReps bndr)
359−+ args_ptrs = map (\(rep, off) -> (isFollowableArg (toArgRep rep), off)) args_offsets
5250++ let args_ptrs =
5251++ map (\(rep, off) -> (isFollowableArg (toArgRep rep), off))
5252++ args_offsets
3605253+ tuple_bco <- emitBc (tupleBCO dflags tuple_info args_ptrs)
3615254+ return (PUSH_ALTS_T alt_bco' tuple_info tuple_bco
3625255+ `consOL` scrut_code)
3635256+ else let push_alts
364−+ | isAlgCase = PUSH_ALTS alt_bco'
365−+ | otherwise = PUSH_ALTS_UNLIFTED alt_bco'
366−+ (typeArgRep bndr_ty)
5257++ | isAlgCase
5258++ = PUSH_ALTS alt_bco'
5259++ | otherwise
5260++ = let unlifted_rep =
5261++ case non_void_arg_reps of
5262++ [] -> V
5263++ [rep] -> rep
5264++ _ -> panic "schemeE(StgCase).push_alts"
5265++ in PUSH_ALTS_UNLIFTED alt_bco' unlifted_rep
3675266+ in return (push_alts `consOL` scrut_code)
368−
369−
5267++
5268++
3705269+-- -----------------------------------------------------------------------------
3715270+-- Deal with tuples
3725271+
@@ -407,7 +5306,7 @@ index fb60c21f9d..62e8457c5a 100644
4075306+ DoubleReg n -> (v, f, a d n, l )
4085307+ LongReg n -> (v, f, d, a l n)
4095308+ _ ->
410−+ pprPanic "CoreToByteCode.layoutTuple count_reg"
5309++ pprPanic "CoreToByteCode.layoutTuple unsupported register type"
4115310+ (ppr r)
4125311+ where a bmp n = bmp .|. (1 `shiftL` (n-1))
4135312+
@@ -436,7 +5335,7 @@ index fb60c21f9d..62e8457c5a 100644
4365335+tupleBCO dflags info pointers =
4375336+ mkProtoBCO dflags invented_name body_code (Left [])
4385337+ 0{-no arity-} bitmap_size bitmap False{-is alts-}
439−+
5338+
4405339+ where
4415340+ {-
4425341+ The tuple BCO is never referred to by name, so we can get away
@@ -454,11 +5353,291 @@ index fb60c21f9d..62e8457c5a 100644
4545353+ (filter fst pointers)
4555354+ body_code = mkSlideW 0 1 -- pop frame header
4565355+ `snocOL` RETURN_T -- and add it again
457−+
5356+
4585357 -- -----------------------------------------------------------------------------
4595358 -- Deal with a CCall.
5359+@@ -1148,10 +1302,10 @@ generateCCall
5360+ -> Sequel
5361+ -> BCEnv
5362+ -> CCallSpec -- where to call
5363+- -> Id -- of target, for type info
5364+- -> [AnnExpr' Id DVarSet] -- args (atoms)
5365++ -> Type
5366++ -> [StgArg] -- args (atoms)
5367+ -> BcM BCInstrList
5368+-generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
5369++generateCCall d0 s p (CCallSpec target cconv safety) result_ty args_r_to_l
5370+ = do
5371+ dflags <- getDynFlags
5372+
5373+@@ -1160,56 +1314,40 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
5374+ addr_size_b :: ByteOff
5375+ addr_size_b = wordSize dflags
5376+
5377++ arrayish_rep_hdr_size :: TyCon -> Maybe Int
5378++ arrayish_rep_hdr_size t
5379++ | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
5380++ = Just (arrPtrsHdrSize dflags)
5381++ | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon
5382++ = Just (smallArrPtrsHdrSize dflags)
5383++ | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
5384++ = Just (arrWordsHdrSize dflags)
5385++ | otherwise
5386++ = Nothing
5387++
5388+ -- Get the args on the stack, with tags and suitably
5389+ -- dereferenced for the CCall. For each arg, return the
5390+ -- depth to the first word of the bits for that arg, and the
5391+ -- ArgRep of what was actually pushed.
5392+
5393+ pargs
5394+- :: ByteOff -> [AnnExpr' Id DVarSet] -> BcM [(BCInstrList, PrimRep)]
5395++ :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimRep)]
5396+ pargs _ [] = return []
5397+- pargs d (a:az)
5398+- = let arg_ty = unwrapType (exprType (deAnnotate' a))
5399+-
5400+- in case tyConAppTyCon_maybe arg_ty of
5401+- -- Don't push the FO; instead push the Addr# it
5402+- -- contains.
5403+- Just t
5404+- | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
5405+- -> do rest <- pargs (d + addr_size_b) az
5406+- code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a
5407+- return ((code,AddrRep):rest)
5408+-
5409+- | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon
5410+- -> do rest <- pargs (d + addr_size_b) az
5411+- code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize dflags)) d p a
5412+- return ((code,AddrRep):rest)
5413+-
5414+- | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
5415+- -> do rest <- pargs (d + addr_size_b) az
5416+- code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a
5417+- return ((code,AddrRep):rest)
5418+-
5419+- -- Default case: push taggedly, but otherwise intact.
5420+- _
5421+- -> do (code_a, sz_a) <- pushAtom d p a
5422+- rest <- pargs (d + sz_a) az
5423+- return ((code_a, atomPrimRep a) : rest)
5424+-
5425+- -- Do magic for Ptr/Byte arrays. Push a ptr to the array on
5426+- -- the stack but then advance it over the headers, so as to
5427+- -- point to the payload.
5428+- parg_ArrayishRep
5429+- :: Word16
5430+- -> StackDepth
5431+- -> BCEnv
5432+- -> AnnExpr' Id DVarSet
5433+- -> BcM BCInstrList
5434+- parg_ArrayishRep hdrSize d p a
5435+- = do (push_fo, _) <- pushAtom d p a
5436++ pargs d (aa@(StgVarArg a):az)
5437++ | Just t <- tyConAppTyCon_maybe (idType a)
5438++ , Just hdr_sz <- arrayish_rep_hdr_size t
5439++ -- Do magic for Ptr/Byte arrays. Push a ptr to the array on
5440++ -- the stack but then advance it over the headers, so as to
5441++ -- point to the payload.
5442++ = do rest <- pargs (d + addr_size_b) az
5443++ (push_fo, _) <- pushAtom d p aa
5444+ -- The ptr points at the header. Advance it over the
5445+ -- header and then pretend this is an Addr#.
5446+- return (push_fo `snocOL` SWIZZLE 0 hdrSize)
5447++ let code = push_fo `snocOL` SWIZZLE 0 (fromIntegral hdr_sz)
5448++ return ((code, AddrRep) : rest)
5449++ pargs d (aa:az) = do (code_a, sz_a) <- pushAtom d p aa
5450++ rest <- pargs (d + sz_a) az
5451++ return ((code_a, atomPrimRep aa) : rest)
5452+
5453+ code_n_reps <- pargs d0 args_r_to_l
5454+ let
5455+@@ -1230,7 +1368,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
4605456
461−@@ -1814,6 +1999,9 @@ bcIdPrimRep id
5457+ -- Get the result rep.
5458+ (returns_void, r_rep)
5459+- = case maybe_getCCallReturnRep (idType fn) of
5460++ = case maybe_getCCallReturnRep result_ty of
5461+ Nothing -> (True, VoidRep)
5462+ Just rr -> (False, rr)
5463+ {-
5464+@@ -1421,14 +1559,10 @@ maybe_getCCallReturnRep fn_ty
5465+ -- valid return value placeholder on the stack
5466+ _ -> blargh
5467+
5468+-maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name])
5469++maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name])
5470+ -- Detect and extract relevant info for the tagToEnum kludge.
5471+-maybe_is_tagToEnum_call app
5472+- | AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg <- app
5473+- , Just TagToEnumOp <- isPrimOpId_maybe v
5474+- = Just (snd arg, extract_constr_Names t)
5475+- | otherwise
5476+- = Nothing
5477++maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) [StgVarArg v] t)
5478++ = Just (v, extract_constr_Names t)
5479+ where
5480+ extract_constr_Names ty
5481+ | rep_ty <- unwrapType ty
5482+@@ -1439,6 +1573,7 @@ maybe_is_tagToEnum_call app
5483+ -- the DataCon. See DataCon.hs for details.
5484+ | otherwise
5485+ = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
5486++maybe_is_tagToEnum_call _ = Nothing
5487+
5488+ {- -----------------------------------------------------------------------------
5489+ Note [Implementing tagToEnum#]
5490+@@ -1482,13 +1617,13 @@ implement_tagToId
5491+ :: StackDepth
5492+ -> Sequel
5493+ -> BCEnv
5494+- -> AnnExpr' Id DVarSet
5495++ -> Id
5496+ -> [Name]
5497+ -> BcM BCInstrList
5498+ -- See Note [Implementing tagToEnum#]
5499+ implement_tagToId d s p arg names
5500+ = ASSERT( notNull names )
5501+- do (push_arg, arg_bytes) <- pushAtom d p arg
5502++ do (push_arg, arg_bytes) <- pushAtom d p (StgVarArg arg)
5503+ labels <- getLabelsBc (genericLength names)
5504+ label_fail <- getLabelBc
5505+ label_exit <- getLabelBc
5506+@@ -1530,21 +1665,12 @@ implement_tagToId d s p arg names
5507+ -- depth 6 stack has valid words 0 .. 5.
5508+
5509+ pushAtom
5510+- :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)
5511+-pushAtom d p e
5512+- | Just e' <- bcView e
5513+- = pushAtom d p e'
5514+-
5515+-pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things,
5516+- = return (nilOL, 0) -- treated just like a variable V
5517++ :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff)
5518+
5519+ -- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs
5520+ -- and Note [Bottoming expressions] in coreSyn/CoreUtils.hs:
5521+ -- The scrutinee of an empty case evaluates to bottom
5522+-pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128
5523+- = pushAtom d p a
5524+-
5525+-pushAtom d p (AnnVar var)
5526++pushAtom d p (StgVarArg var)
5527+ | [] <- typePrimRep (idType var)
5528+ = return (nilOL, 0)
5529+
5530+@@ -1583,55 +1709,57 @@ pushAtom d p (AnnVar var)
5531+ = do topStrings <- getTopStrings
5532+ dflags <- getDynFlags
5533+ case lookupVarEnv topStrings var of
5534+- Just ptr -> pushAtom d p $ AnnLit $ mkLitWord dflags $
5535++ Just ptr -> pushAtom d p $ StgLitArg $ mkLitWord dflags $
5536+ fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr
5537+ Nothing -> do
5538+ let sz = idSizeCon dflags var
5539+ MASSERT( sz == wordSize dflags )
5540+ return (unitOL (PUSH_G (getName var)), sz)
5541+
5542+-
5543+-pushAtom _ _ (AnnLit lit) = do
5544++pushAtom _ _ (StgLitArg lit) = do
5545+ dflags <- getDynFlags
5546+- let code rep
5547+- = let size_words = WordOff (argRepSizeW dflags rep)
5548+- in return (unitOL (PUSH_UBX lit (trunc16W size_words)),
5549+- wordsToBytes dflags size_words)
5550++ let code :: PrimRep -> BcM (BCInstrList, ByteOff)
5551++ code rep =
5552++ return (unitOL instr, size_bytes)
5553++ where
5554++ size_bytes = ByteOff $ primRepSizeB dflags rep
5555++ -- Here we handle the non-word-width cases specifically since we
5556++ -- must emit different bytecode for them.
5557++ instr =
5558++ case size_bytes of
5559++ 1 -> PUSH_UBX8 lit
5560++ 2 -> PUSH_UBX16 lit
5561++ 4 -> PUSH_UBX32 lit
5562++ _ -> PUSH_UBX lit (trunc16W $ bytesToWords dflags size_bytes)
5563+
5564+ case lit of
5565+- LitLabel _ _ _ -> code N
5566+- LitFloat _ -> code F
5567+- LitDouble _ -> code D
5568+- LitChar _ -> code N
5569+- LitNullAddr -> code N
5570+- LitString _ -> code N
5571+- LitRubbish -> code N
5572++ LitLabel _ _ _ -> code AddrRep
5573++ LitFloat _ -> code FloatRep
5574++ LitDouble _ -> code DoubleRep
5575++ LitChar _ -> code AddrRep
5576++ LitNullAddr -> code AddrRep
5577++ LitString _ -> code AddrRep
5578++ LitRubbish -> code AddrRep
5579+ LitNumber nt _ _ -> case nt of
5580+- LitNumInt -> code N
5581+- LitNumWord -> code N
5582+- LitNumInt64 -> code L
5583+- LitNumWord64 -> code L
5584++ LitNumInt -> code IntRep
5585++ LitNumWord -> code WordRep
5586++ LitNumInt64 -> code Int64Rep
5587++ LitNumWord64 -> code Word64Rep
5588+ -- No LitInteger's or LitNatural's should be left by the time this is
5589+ -- called. CorePrep should have converted them all to a real core
5590+ -- representation.
5591+ LitNumInteger -> panic "pushAtom: LitInteger"
5592+ LitNumNatural -> panic "pushAtom: LitNatural"
5593+
5594+-pushAtom _ _ expr
5595+- = pprPanic "ByteCodeGen.pushAtom"
5596+- (pprCoreExpr (deAnnotate' expr))
5597+-
5598+-
5599+ -- | Push an atom for constructor (i.e., PACK instruction) onto the stack.
5600+ -- This is slightly different to @pushAtom@ due to the fact that we allow
5601+ -- packing constructor fields. See also @mkConAppCode@ and @pushPadding@.
5602+ pushConstrAtom
5603+- :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)
5604+-
5605+-pushConstrAtom _ _ (AnnLit lit@(LitFloat _)) =
5606++ :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff)
5607++pushConstrAtom _ _ (StgLitArg lit@(LitFloat _)) =
5608+ return (unitOL (PUSH_UBX32 lit), 4)
5609+
5610+-pushConstrAtom d p (AnnVar v)
5611++pushConstrAtom d p va@(StgVarArg v)
5612+ | Just d_v <- lookupBCEnv_maybe v p = do -- v is a local variable
5613+ dflags <- getDynFlags
5614+ let !szb = idSizeCon dflags v
5615+@@ -1642,7 +1770,7 @@ pushConstrAtom d p (AnnVar v)
5616+ 1 -> done PUSH8
5617+ 2 -> done PUSH16
5618+ 4 -> done PUSH32
5619+- _ -> pushAtom d p (AnnVar v)
5620++ _ -> pushAtom d p va
5621+
5622+ pushConstrAtom d p expr = pushAtom d p expr
5623+
5624+@@ -1802,7 +1930,14 @@ idSizeW :: DynFlags -> Id -> WordOff
5625+ idSizeW dflags = WordOff . argRepSizeW dflags . bcIdArgRep
5626+
5627+ idSizeCon :: DynFlags -> Id -> ByteOff
5628+-idSizeCon dflags = ByteOff . primRepSizeB dflags . bcIdPrimRep
5629++idSizeCon dflags var
5630++ -- unboxed tuple components are padded to word size
5631++ | isUnboxedTupleType (idType var) ||
5632++ isUnboxedSumType (idType var) =
5633++ wordsToBytes dflags .
5634++ WordOff . sum . map (argRepSizeW dflags . toArgRep) .
5635++ bcIdPrimReps $ var
5636++ | otherwise = ByteOff (primRepSizeB dflags (bcIdPrimRep var))
5637+
5638+ bcIdArgRep :: Id -> ArgRep
5639+ bcIdArgRep = toArgRep . bcIdPrimRep
5640+@@ -1814,6 +1949,9 @@ bcIdPrimRep id
4625641 | otherwise
4635642 = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
4645643
@@ -468,22 +5647,134 @@ index fb60c21f9d..62e8457c5a 100644
4685647 repSizeWords :: DynFlags -> PrimRep -> WordOff
4695648 repSizeWords dflags rep = WordOff $ argRepSizeW dflags (toArgRep rep)
4705649
471−@@ -1921,6 +2109,10 @@ mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb)
472− typeArgRep :: Type -> ArgRep
473− typeArgRep = toArgRep . typePrimRep1
5650+@@ -1821,17 +1959,6 @@ isFollowableArg :: ArgRep -> Bool
5651+ isFollowableArg P = True
5652+ isFollowableArg _ = False
5653+
5654+-isVoidArg :: ArgRep -> Bool
5655+-isVoidArg V = True
5656+-isVoidArg _ = False
5657+-
5658+--- See bug #1257
5659+-multiValException :: a
5660+-multiValException = throwGhcException (ProgramError
5661+- ("Error: bytecode compiler can't handle unboxed tuples and sums.\n"++
5662+- " Possibly due to foreign import/export decls in source.\n"++
5663+- " Workaround: use -fobject-code, or compile this module to .o separately."))
5664+-
5665+ -- | Indicate if the calling convention is supported
5666+ isSupportedCConv :: CCallSpec -> Bool
5667+ isSupportedCConv (CCallSpec _ cconv _) = case cconv of
5668+@@ -1867,49 +1994,11 @@ mkSlideW !n !ws
5669+ limit :: Word16
5670+ limit = maxBound
5671+
5672+-splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])
5673+- -- The arguments are returned in *right-to-left* order
5674+-splitApp e | Just e' <- bcView e = splitApp e'
5675+-splitApp (AnnApp (_,f) (_,a)) = case splitApp f of
5676+- (f', as) -> (f', a:as)
5677+-splitApp e = (e, [])
5678+-
5679+-
5680+-bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
5681+--- The "bytecode view" of a term discards
5682+--- a) type abstractions
5683+--- b) type applications
5684+--- c) casts
5685+--- d) ticks (but not breakpoints)
5686+--- Type lambdas *can* occur in random expressions,
5687+--- whereas value lambdas cannot; that is why they are nuked here
5688+-bcView (AnnCast (_,e) _) = Just e
5689+-bcView (AnnLam v (_,e)) | isTyVar v = Just e
5690+-bcView (AnnApp (_,e) (_, AnnType _)) = Just e
5691+-bcView (AnnTick Breakpoint{} _) = Nothing
5692+-bcView (AnnTick _other_tick (_,e)) = Just e
5693+-bcView _ = Nothing
5694+-
5695+-isVAtom :: AnnExpr' Var ann -> Bool
5696+-isVAtom e | Just e' <- bcView e = isVAtom e'
5697+-isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v)
5698+-isVAtom (AnnCoercion {}) = True
5699+-isVAtom _ = False
5700+-
5701+-atomPrimRep :: AnnExpr' Id ann -> PrimRep
5702+-atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
5703+-atomPrimRep (AnnVar v) = bcIdPrimRep v
5704+-atomPrimRep (AnnLit l) = typePrimRep1 (literalType l)
5705+-
5706+--- #12128:
5707+--- A case expression can be an atom because empty cases evaluate to bottom.
5708+--- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs
5709+-atomPrimRep (AnnCase _ _ ty _) =
5710+- ASSERT(case typePrimRep ty of [LiftedRep] -> True; _ -> False) LiftedRep
5711+-atomPrimRep (AnnCoercion {}) = VoidRep
5712+-atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other))
5713++atomPrimRep :: StgArg -> PrimRep
5714++atomPrimRep (StgVarArg v) = bcIdPrimRep v
5715++atomPrimRep (StgLitArg l) = typePrimRep1 (literalType l)
5716+
5717+-atomRep :: AnnExpr' Id ann -> ArgRep
5718++atomRep :: StgArg -> ArgRep
5719+ atomRep e = toArgRep (atomPrimRep e)
4745720
475−+-- XXX this can be removed?
5721+ -- | Let szsw be the sizes in bytes of some items pushed onto the stack, which
5722+@@ -1918,8 +2007,8 @@ atomRep e = toArgRep (atomPrimRep e)
5723+ mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
5724+ mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb)
5725+
5726+-typeArgRep :: Type -> ArgRep
5727+-typeArgRep = toArgRep . typePrimRep1
4765728+typeArgReps :: Type -> [ArgRep]
477−+typeArgReps = map toArgRep . typePrimRepArgs -- typePrimRepArgs (idType id)
478−+
5729++typeArgReps = map toArgRep . typePrimRepArgs
5730+
4795731 -- -----------------------------------------------------------------------------
4805732 -- The bytecode generator's monad
481−
4825733diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs
483−index c386ece52a..d8f902546f 100644
5734+index c386ece52a..af7cfee394 100644
4845735--- a/compiler/ghci/ByteCodeInstr.hs
4855736+++ b/compiler/ghci/ByteCodeInstr.hs
486−@@ -86,6 +86,9 @@ data BCInstr
5737+@@ -1,4 +1,5 @@
5738+-{-# LANGUAGE CPP, MagicHash #-}
5739++{-# LANGUAGE CPP #-}
5740++{-# LANGUAGE FlexibleContexts #-}
5741+ {-# OPTIONS_GHC -funbox-strict-fields #-}
5742+ --
5743+ -- (c) The University of Glasgow 2002-2006
5744+@@ -17,22 +18,18 @@ import ByteCodeTypes
5745+ import GHCi.RemoteTypes
5746+ import GHCi.FFI (C_ffi_cif)
5747+ import GHC.StgToCmm.Layout ( ArgRep(..) )
5748+-import PprCore
5749+ import Outputable
5750+-import FastString
5751+ import Name
5752+ import Unique
5753+-import Id
5754+-import CoreSyn
5755+ import Literal
5756+ import DataCon
5757+-import VarSet
5758+ import PrimOp
5759+ import SMRep
5760+
5761+ import Data.Word
5762+ import GHC.Stack.CCS (CostCentre)
5763+
5764++import StgSyn
5765+ -- ----------------------------------------------------------------------------
5766+ -- Bytecode instructions
5767+
5768+@@ -45,7 +42,7 @@ data ProtoBCO a
5769+ protoBCOBitmapSize :: Word16,
5770+ protoBCOArity :: Int,
5771+ -- what the BCO came from, for debugging only
5772+- protoBCOExpr :: Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet),
5773++ protoBCOExpr :: Either [CgStgAlt] CgStgRhs,
5774+ -- malloc'd pointers
5775+ protoBCOFFIs :: [FFIInfo]
5776+ }
5777+@@ -86,6 +83,9 @@ data BCInstr
4875778 -- Push an alt continuation
4885779 | PUSH_ALTS (ProtoBCO Name)
4895780 | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep
@@ -493,7 +5784,7 @@ index c386ece52a..d8f902546f 100644
4935784
4945785 -- Pushing 8, 16 and 32 bits of padding (for constructors).
4955786 | PUSH_PAD8
496−@@ -168,8 +171,9 @@ data BCInstr
5787+@@ -168,8 +168,9 @@ data BCInstr
4975788
4985789 -- To Infinity And Beyond
4995790 | ENTER
@@ -504,7 +5795,77 @@ index c386ece52a..d8f902546f 100644
5045795
5055796 -- Breakpoints
5065797 | BRK_FUN Word16 Unique (RemotePtr CostCentre)
507−@@ -234,8 +238,13 @@ instance Outputable BCInstr where
5798+@@ -188,36 +189,45 @@ instance Outputable a => Outputable (ProtoBCO a) where
5799+ = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity
5800+ <+> text (show ffis) <> colon)
5801+ $$ nest 3 (case origin of
5802+- Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';'))
5803+- (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}'
5804+- Right rhs -> pprCoreExprShort (deAnnotate rhs))
5805++ Left alts ->
5806++ vcat (zipWith (<+>) (char '{' : repeat (char ';'))
5807++ (map pprStgAltShort alts))
5808++ Right rhs ->
5809++ pprStgRhsShort rhs
5810++ )
5811+ $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap)
5812+ $$ nest 3 (vcat (map ppr instrs))
5813+
5814+--- Print enough of the Core expression to enable the reader to find
5815+--- the expression in the -ddump-prep output. That is, we need to
5816++-- Print enough of the STG expression to enable the reader to find
5817++-- the expression in the -ddump-stg output. That is, we need to
5818+ -- include at least a binder.
5819+
5820+-pprCoreExprShort :: CoreExpr -> SDoc
5821+-pprCoreExprShort expr@(Lam _ _)
5822+- = let
5823+- (bndrs, _) = collectBinders expr
5824+- in
5825+- char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> text "..."
5826++pprStgExprShort :: OutputablePass pass => GenStgExpr pass -> SDoc
5827++pprStgExprShort (StgCase _expr var _ty _alts) =
5828++ text "case of" <+> ppr var
5829++pprStgExprShort (StgLet _ bnd _) =
5830++ text "let" <+> pprStgBindShort bnd <+> text "in ..."
5831++pprStgExprShort (StgLetNoEscape _ bnd _) =
5832++ text "let-no-escape" <+> pprStgBindShort bnd <+> text "in ..."
5833++pprStgExprShort (StgTick t e) = ppr t <+> pprStgExprShort e
5834++pprStgExprShort e = pprStgExpr e
5835++
5836++pprStgBindShort :: OutputablePass pass => GenStgBinding pass -> SDoc
5837++pprStgBindShort (StgNonRec x _) =
5838++ ppr x <+> text "= ..."
5839++pprStgBindShort (StgRec bs) =
5840++ char '{' <+> ppr (fst (head bs)) <+> text "= ...; ... }"
5841++
5842++pprStgAltShort :: OutputablePass pass => GenStgAlt pass -> SDoc
5843++pprStgAltShort (con, args, expr) =
5844++ ppr con <+> sep (map ppr args) <+> text "->" <+> pprStgExprShort expr
5845++
5846++pprStgRhsShort :: OutputablePass pass => GenStgRhs pass -> SDoc
5847++pprStgRhsShort (StgRhsClosure _ext _cc upd_flag args body) =
5848++ hang (hsep [ char '\\' <> ppr upd_flag, brackets (interppSP args) ])
5849++ 4 (pprStgExprShort body)
5850++pprStgRhsShort rhs = pprStgRhs rhs
5851+
5852+-pprCoreExprShort (Case _expr var _ty _alts)
5853+- = text "case of" <+> ppr var
5854+-
5855+-pprCoreExprShort (Let (NonRec x _) _) = text "let" <+> ppr x <+> ptext (sLit ("= ... in ..."))
5856+-pprCoreExprShort (Let (Rec bs) _) = text "let {" <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ..."))
5857+-
5858+-pprCoreExprShort (Tick t e) = ppr t <+> pprCoreExprShort e
5859+-pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> text "`cast` T"
5860+-
5861+-pprCoreExprShort e = pprCoreExpr e
5862+-
5863+-pprCoreAltShort :: CoreAlt -> SDoc
5864+-pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> text "->" <+> pprCoreExprShort expr
5865+
5866+ instance Outputable BCInstr where
5867+ ppr (STKCHECK n) = text "STKCHECK" <+> ppr n
5868+@@ -234,8 +244,13 @@ instance Outputable BCInstr where
5085869 ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers."
5095870 <> ppr op
5105871 ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco)
@@ -518,7 +5879,7 @@ index c386ece52a..d8f902546f 100644
5185879
5195880 ppr PUSH_PAD8 = text "PUSH_PAD8"
5205881 ppr PUSH_PAD16 = text "PUSH_PAD16"
521−@@ -292,8 +301,11 @@ instance Outputable BCInstr where
5882+@@ -292,8 +307,11 @@ instance Outputable BCInstr where
5225883 ppr ENTER = text "ENTER"
5235884 ppr RETURN = text "RETURN"
5245885 ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk
@@ -530,7 +5891,7 @@ index c386ece52a..d8f902546f 100644
5305891 -- -----------------------------------------------------------------------------
5315892 -- The stack use, in words, of each bytecode insn. These _must_ be
5325893 -- correct, or overestimates of reality, to be safe.
533−@@ -321,8 +333,14 @@ bciStackUse PUSH32_W{} = 1 -- takes exactly 1 word
5894+@@ -321,8 +339,14 @@ bciStackUse PUSH32_W{} = 1 -- takes exactly 1 word
5345895 bciStackUse PUSH_G{} = 1
5355896 bciStackUse PUSH_PRIMOP{} = 1
5365897 bciStackUse PUSH_BCO{} = 1
@@ -547,7 +5908,7 @@ index c386ece52a..d8f902546f 100644
5475908 bciStackUse (PUSH_PAD8) = 1 -- overapproximation
5485909 bciStackUse (PUSH_PAD16) = 1 -- overapproximation
5495910 bciStackUse (PUSH_PAD32) = 1 -- overapproximation on 64bit arch
550−@@ -361,6 +379,7 @@ bciStackUse JMP{} = 0
5911+@@ -361,6 +385,7 @@ bciStackUse JMP{} = 0
5515912 bciStackUse ENTER{} = 0
5525913 bciStackUse RETURN{} = 0
5535914 bciStackUse RETURN_UBX{} = 1
@@ -556,19 +5917,21 @@ index c386ece52a..d8f902546f 100644
5565917 bciStackUse SWIZZLE{} = 0
5575918 bciStackUse BRK_FUN{} = 0
5585919diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs
559−index 0c0c34ad64..71378b27f3 100644
5920+index 0c0c34ad64..617126196e 100644
5605921--- a/compiler/ghci/ByteCodeTypes.hs
5615922+++ b/compiler/ghci/ByteCodeTypes.hs
562−@@ -8,6 +8,8 @@ module ByteCodeTypes
563− ( CompiledByteCode(..), seqCompiledByteCode, FFIInfo(..)
5923+@@ -5,7 +5,9 @@
5924+
5925+ -- | Bytecode assembler types
5926+ module ByteCodeTypes
5927+- ( CompiledByteCode(..), seqCompiledByteCode, FFIInfo(..)
5928++ ( CompiledByteCode(..), seqCompiledByteCode
5929++ , FFIInfo(..), TupleInfo(..), voidTupleInfo
5930++ , ByteOff(..), WordOff(..)
5645931 , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)
5655932 , ItblEnv, ItblPtr(..)
566−+ , TupleInfo(..)
567−+ , ByteOff(..), WordOff(..)
5685933 , CgBreakInfo(..)
569− , ModBreaks (..), BreakIndex, emptyModBreaks
570− , CCostCentre
571−@@ -67,6 +69,34 @@ seqCompiledByteCode CompiledByteCode{..} =
5934+@@ -67,6 +69,37 @@ seqCompiledByteCode CompiledByteCode{..} =
5725935 rnf bc_strs `seq`
5735936 rnf (fmap seqModBreaks bc_breaks)
5745937
@@ -599,51 +5962,635 @@ index 0c0c34ad64..71378b27f3 100644
5995962+ char 'F' <> ppr tupleFloatRegs <+>
6005963+ char 'D' <> ppr tupleDoubleRegs <>
6015964+ char '>'
5965++
5966++voidTupleInfo :: TupleInfo
5967++voidTupleInfo = TupleInfo 0 0 0 0 0 0
6025968+
6035969 type ItblEnv = NameEnv (Name, ItblPtr)
6045970 -- We need the Name in the range so we know which
6055971 -- elements to filter out when unloading a module
5972+diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
5973+index 077c66371e..d5a0b22ff1 100644
5974+--- a/compiler/iface/TcIface.hs
5975++++ b/compiler/iface/TcIface.hs
5976+@@ -1372,7 +1372,7 @@ tcIfaceExpr (IfaceTick tickish expr) = do
5977+ return (Tick tickish' expr')
5978+
5979+ -------------------------
5980+-tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id)
5981++tcIfaceTickish :: IfaceTickish -> IfM lcl CoreTickish
5982+ tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix)
5983+ tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push)
5984+ tcIfaceTickish (IfaceSource src name) = return (SourceNote src name)
5985+diff --git a/compiler/iface/ToIface.hs b/compiler/iface/ToIface.hs
5986+index d32a0529af..92ae16d7ea 100644
5987+--- a/compiler/iface/ToIface.hs
5988++++ b/compiler/iface/ToIface.hs
5989+@@ -550,7 +550,7 @@ toIfaceOneShot id | isId id
5990+ = IfaceNoOneShot
5991+
5992+ ---------------------
5993+-toIfaceTickish :: Tickish Id -> Maybe IfaceTickish
5994++toIfaceTickish :: CoreTickish -> Maybe IfaceTickish
5995+ toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push)
5996+ toIfaceTickish (HpcTick modl ix) = Just (IfaceHpcTick modl ix)
5997+ toIfaceTickish (SourceNote src names) = Just (IfaceSource src names)
6065998diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
607−index 6599da07f4..d587f9c88e 100644
5999+index dc8344d14d..b32b383510 100644
6086000--- a/compiler/main/GhcMake.hs
6096001+++ b/compiler/main/GhcMake.hs
610−@@ -2078,7 +2078,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
611− (defaultObjectTarget dflags)
612− map0
613− else if hscTarget dflags == HscInterpreted
6002+@@ -66,7 +66,6 @@ import TcBackpack
6003+ import Packages
6004+ import UniqSet
6005+ import Util
6006+-import qualified GHC.LanguageExtensions as LangExt
6007+ import NameEnv
6008+ import FileCleanup
6009+
6010+@@ -2074,15 +2073,12 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
6011+ -- otherwise those modules will fail to compile.
6012+ -- See Note [-fno-code mode] #8025
6013+ map1 <- if hscTarget dflags == HscNothing
6014+- then enableCodeGenForTH
6015+- (defaultObjectTarget dflags)
6016+- map0
6017+- else if hscTarget dflags == HscInterpreted
6146018- then enableCodeGenForUnboxedTuplesOrSums
615−+ then enableCodeGenForUnboxedSums
616− (defaultObjectTarget dflags)
617− map0
618− else return map0
619−@@ -2177,23 +2177,21 @@ enableCodeGenForTH =
620− --
621− -- This is used used in order to load code that uses unboxed tuples
622− -- or sums into GHCi while still allowing some code to be interpreted.
6019+- (defaultObjectTarget dflags)
6020+- map0
6021+- else return map0
6022++ then enableCodeGenForTH
6023++ (defaultObjectTarget dflags)
6024++ map0
6025++ else return map0
6026+ return $ concat $ nodeMapElts map1
6027++
6028+ where
6029+ calcDeps = msDeps
6030+
6031+@@ -2170,30 +2166,8 @@ enableCodeGenForTH =
6032+ -- can't compile anything anyway! See #16219.
6033+ not (isIndefinite dflags)
6034+
6035+--- | Update the every ModSummary that is depended on
6036+--- by a module that needs unboxed tuples. We enable codegen to
6037+--- the specified target, disable optimization and change the .hi
6038+--- and .o file locations to be temporary files.
6039+---
6040+--- This is used used in order to load code that uses unboxed tuples
6041+--- or sums into GHCi while still allowing some code to be interpreted.
6236042-enableCodeGenForUnboxedTuplesOrSums :: HscTarget
624−+enableCodeGenForUnboxedSums :: HscTarget
625− -> NodeMap [Either ErrorMessages ModSummary]
626− -> IO (NodeMap [Either ErrorMessages ModSummary])
6043+- -> NodeMap [Either ErrorMessages ModSummary]
6044+- -> IO (NodeMap [Either ErrorMessages ModSummary])
6276045-enableCodeGenForUnboxedTuplesOrSums =
628−+enableCodeGenForUnboxedSums =
629− enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule
630− where
631− condition ms =
6046+- enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule
6047+- where
6048+- condition ms =
6326049- unboxed_tuples_or_sums (ms_hspp_opts ms) &&
633−+ xopt LangExt.UnboxedSums (ms_hspp_opts ms) &&
634− not (gopt Opt_ByteCodeIfUnboxed (ms_hspp_opts ms)) &&
635− not (isBootSummary ms)
6050+- not (gopt Opt_ByteCodeIfUnboxed (ms_hspp_opts ms)) &&
6051+- not (isBootSummary ms)
6366052- unboxed_tuples_or_sums d =
6376053- xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d
638− should_modify (ModSummary { ms_hspp_opts = dflags }) =
639− hscTarget dflags == HscInterpreted
640−
641− -- | Helper used to implement 'enableCodeGenForTH' and
6054+- should_modify (ModSummary { ms_hspp_opts = dflags }) =
6055+- hscTarget dflags == HscInterpreted
6056+-
6057+--- | Helper used to implement 'enableCodeGenForTH' and
6426058--- 'enableCodeGenForUnboxedTuples'. In particular, this enables
643−+-- 'enableCodeGenForUnboxedSums'. In particular, this enables
6059++-- | Helper used to implement 'enableCodeGenForTH'.
6060++-- In particular, this enables
6446061 -- unoptimized code generation for all modules that meet some
6456062 -- condition (first parameter), or are dependencies of those
6466063 -- modules. The second parameter is a condition to check before
6064+diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
6065+index 9bb6b4e391..e4dd13b9d7 100644
6066+--- a/compiler/main/HscMain.hs
6067++++ b/compiler/main/HscMain.hs
6068+@@ -123,8 +123,10 @@ import MkIface
6069+ import Desugar
6070+ import SimplCore
6071+ import TidyPgm
6072++import Unique
6073+ import CorePrep
6074+ import CoreToStg ( coreToStg )
6075++import CoreUtils ( exprType )
6076+ import qualified GHC.StgToCmm as StgToCmm ( codeGen )
6077+ import StgSyn
6078+ import StgFVs ( annTopBindingsFreeVars )
6079+@@ -1432,7 +1434,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
6080+ ----------------- Convert to STG ------------------
6081+ (stg_binds, (caf_ccs, caf_cc_stacks))
6082+ <- {-# SCC "CoreToStg" #-}
6083+- myCoreToStg dflags this_mod prepd_binds
6084++ myCoreToStg hsc_env this_mod prepd_binds
6085+
6086+ let cost_centre_info =
6087+ (S.toList local_ccs ++ caf_ccs, caf_cc_stacks)
6088+@@ -1494,8 +1496,12 @@ hscInteractive hsc_env cgguts location = do
6089+ -- Do saturation and convert to A-normal form
6090+ (prepd_binds, _) <- {-# SCC "CorePrep" #-}
6091+ corePrepPgm hsc_env this_mod location core_binds data_tycons
6092++
6093++ (stg_binds, _caf_ccs__caf_cc_stacks)
6094++ <- {-# SCC "CoreToStg" #-}
6095++ myCoreToStg hsc_env this_mod prepd_binds
6096+ ----------------- Generate byte code ------------------
6097+- comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks
6098++ comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks
6099+ ------------------ Create f-x-dynamic C-side stuff -----
6100+ (_istub_h_exists, istub_c_exists)
6101+ <- outputForeignStubs dflags this_mod location foreign_stubs
6102+@@ -1572,21 +1578,20 @@ doCodeGen hsc_env this_mod data_tycons
6103+
6104+
6105+
6106+-myCoreToStg :: DynFlags -> Module -> CoreProgram
6107++myCoreToStg :: HscEnv -> Module -> CoreProgram
6108+ -> IO ( [StgTopBinding] -- output program
6109+ , CollectedCCs ) -- CAF cost centre info (declared and used)
6110+-myCoreToStg dflags this_mod prepd_binds = do
6111++myCoreToStg hsc_env this_mod prepd_binds = do
6112+ let (stg_binds, cost_centre_info)
6113+ = {-# SCC "Core2Stg" #-}
6114+- coreToStg dflags this_mod prepd_binds
6115++ coreToStg (hsc_dflags hsc_env) this_mod prepd_binds
6116+
6117+ stg_binds2
6118+ <- {-# SCC "Stg2Stg" #-}
6119+- stg2stg dflags this_mod stg_binds
6120++ stg2stg hsc_env this_mod stg_binds
6121+
6122+ return (stg_binds2, cost_centre_info)
6123+
6124+-
6125+ {- **********************************************************************
6126+ %* *
6127+ \subsection{Compiling a do-statement}
6128+@@ -1722,9 +1727,13 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
6129+ (prepd_binds, _) <- {-# SCC "CorePrep" #-}
6130+ liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons
6131+
6132++ (stg_binds, _caf_ccs__caf_cc_stacks)
6133++ <- {-# SCC "CoreToStg" #-}
6134++ liftIO $ myCoreToStg hsc_env this_mod prepd_binds
6135++
6136+ {- Generate byte code -}
6137+ cbc <- liftIO $ byteCodeGen hsc_env this_mod
6138+- prepd_binds data_tycons mod_breaks
6139++ stg_binds data_tycons mod_breaks
6140+
6141+ let src_span = srcLocSpan interactiveSrcLoc
6142+ liftIO $ linkDecls hsc_env src_span cbc
6143+@@ -1887,9 +1896,20 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr
6144+ {- Lint if necessary -}
6145+ ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr
6146+
6147++ {- Create a temporary binding and convert to STG -}
6148++ ; let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel")
6149++ (mkPseudoUniqueE 0)
6150++ (exprType prepd_expr)
6151++ ; ([StgTopLifted (StgNonRec _ stg_expr)], _) <-
6152++ myCoreToStg hsc_env
6153++ (icInteractiveModule (hsc_IC hsc_env))
6154++ [NonRec bco_tmp_id prepd_expr]
6155++
6156+ {- Convert to BCOs -}
6157+ ; bcos <- coreExprToBCOs hsc_env
6158+- (icInteractiveModule (hsc_IC hsc_env)) prepd_expr
6159++ (icInteractiveModule (hsc_IC hsc_env))
6160++ bco_tmp_id
6161++ stg_expr
6162+
6163+ {- link it -}
6164+ ; hval <- linkExpr hsc_env srcspan bcos
6165+diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
6166+index ae491ac02d..2131b0f30c 100644
6167+--- a/compiler/main/TidyPgm.hs
6168++++ b/compiler/main/TidyPgm.hs
6169+@@ -769,7 +769,7 @@ dffvExpr :: CoreExpr -> DFFV ()
6170+ dffvExpr (Var v) = insert v
6171+ dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2
6172+ dffvExpr (Lam v e) = extendScope v (dffvExpr e)
6173+-dffvExpr (Tick (Breakpoint _ ids) e) = mapM_ insert ids >> dffvExpr e
6174++dffvExpr (Tick (Breakpoint _ _ ids) e) = mapM_ insert ids >> dffvExpr e
6175+ dffvExpr (Tick _other e) = dffvExpr e
6176+ dffvExpr (Cast e _) = dffvExpr e
6177+ dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e)
6178+diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs
6179+index 33f1c5b2f7..9b252bc01c 100644
6180+--- a/compiler/nativeGen/Dwarf.hs
6181++++ b/compiler/nativeGen/Dwarf.hs
6182+@@ -7,7 +7,7 @@ import GhcPrelude
6183+ import CLabel
6184+ import CmmExpr ( GlobalReg(..) )
6185+ import Config ( cProjectName, cProjectVersion )
6186+-import CoreSyn ( Tickish(..) )
6187++import CoreSyn ( CmmTickish, GenTickish(..) )
6188+ import Debug
6189+ import DynFlags
6190+ import Module
6191+@@ -207,7 +207,7 @@ blockToDwarf df blk
6192+ | Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk
6193+ | otherwise = Nothing -- block was optimized out
6194+
6195+-tickToDwarf :: DynFlags -> Tickish () -> [DwarfInfo]
6196++tickToDwarf :: DynFlags -> CmmTickish -> [DwarfInfo]
6197+ tickToDwarf _ (SourceNote ss _) = [DwarfSrcNote ss]
6198+ tickToDwarf _ _ = []
6199+
6200+diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
6201+index 702cd98e77..6ed38ede7c 100644
6202+--- a/compiler/nativeGen/X86/CodeGen.hs
6203++++ b/compiler/nativeGen/X86/CodeGen.hs
6204+@@ -69,7 +69,7 @@ import Hoopl.Collections
6205+ import Hoopl.Graph
6206+ import Hoopl.Label
6207+ import CLabel
6208+-import CoreSyn ( Tickish(..) )
6209++import CoreSyn ( GenTickish(..) )
6210+ import SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )
6211+
6212+ -- The rest:
6213+diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs
6214+index 015d096a0a..e594aa2e73 100644
6215+--- a/compiler/simplCore/FloatOut.hs
6216++++ b/compiler/simplCore/FloatOut.hs
6217+@@ -733,7 +733,7 @@ atJoinCeiling (fs, floats, expr')
6218+ where
6219+ (floats', ceils) = partitionAtJoinCeiling floats
6220+
6221+-wrapTick :: Tickish Id -> FloatBinds -> FloatBinds
6222++wrapTick :: CoreTickish -> FloatBinds -> FloatBinds
6223+ wrapTick t (FB tops ceils defns)
6224+ = FB (mapBag wrap_bind tops) (wrap_defns ceils)
6225+ (M.map (M.map wrap_defns) defns)
6226+diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs
6227+index 7c3ed3f16a..7524c8e577 100644
6228+--- a/compiler/simplCore/OccurAnal.hs
6229++++ b/compiler/simplCore/OccurAnal.hs
6230+@@ -1708,7 +1708,7 @@ occAnal env (Tick tickish body)
6231+ | tickish `tickishScopesLike` SoftScope
6232+ = (markAllNonTailCalled usage, Tick tickish body')
6233+
6234+- | Breakpoint _ ids <- tickish
6235++ | Breakpoint _ _ ids <- tickish
6236+ = (usage_lam `andUDs` foldr addManyOccs emptyDetails ids, Tick tickish body')
6237+ -- never substitute for any of the Ids in a Breakpoint
6238+
6239+@@ -1841,7 +1841,7 @@ Constructors are rather like lambdas in this way.
6240+ -}
6241+
6242+ occAnalApp :: OccEnv
6243+- -> (Expr CoreBndr, [Arg CoreBndr], [Tickish Id])
6244++ -> (Expr CoreBndr, [Arg CoreBndr], [CoreTickish])
6245+ -> (UsageDetails, Expr CoreBndr)
6246+ occAnalApp env (Var fun, args, ticks)
6247+ | null ticks = (uds, mkApps (Var fun) args')
6248+diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
6249+index 149a079a0a..45e9036162 100644
6250+--- a/compiler/simplCore/SimplCore.hs
6251++++ b/compiler/simplCore/SimplCore.hs
6252+@@ -900,7 +900,7 @@ ticks. More often than not, other references will be unfoldings of
6253+ x_exported, and therefore carry the tick anyway.
6254+ -}
6255+
6256+-type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks
6257++type IndEnv = IdEnv (Id, [CoreTickish]) -- Maps local_id -> exported_id, ticks
6258+
6259+ shortOutIndirections :: CoreProgram -> CoreProgram
6260+ shortOutIndirections binds
6261+diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs
6262+index bad66e3d8b..1b854a1459 100644
6263+--- a/compiler/simplCore/SimplUtils.hs
6264++++ b/compiler/simplCore/SimplUtils.hs
6265+@@ -155,7 +155,7 @@ data SimplCont
6266+ , sc_cont :: SimplCont }
6267+
6268+ | TickIt -- (TickIt t K)[e] = K[ tick t e ]
6269+- (Tickish Id) -- Tick tickish <hole>
6270++ CoreTickish -- Tick tickish <hole>
6271+ SimplCont
6272+
6273+ type StaticEnv = SimplEnv -- Just the static part is relevant
6274+diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
6275+index 569bcfd3dc..b361364f92 100644
6276+--- a/compiler/simplCore/Simplify.hs
6277++++ b/compiler/simplCore/Simplify.hs
6278+@@ -5,6 +5,7 @@
6279+ -}
6280+
6281+ {-# LANGUAGE CPP #-}
6282++{-# LANGUAGE TypeFamilies #-}
6283+
6284+ module Simplify ( simplTopBinds, simplExpr, simplRules ) where
6285+
6286+@@ -1061,7 +1062,7 @@ simplCoercion env co
6287+ -- long as this is a non-scoping tick, to let case and application
6288+ -- optimisations apply.
6289+
6290+-simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont
6291++simplTick :: SimplEnv -> CoreTickish -> InExpr -> SimplCont
6292+ -> SimplM (SimplFloats, OutExpr)
6293+ simplTick env tickish expr cont
6294+ -- A scoped tick turns into a continuation, so that we can spot
6295+@@ -1155,8 +1156,8 @@ simplTick env tickish expr cont
6296+
6297+
6298+ simplTickish env tickish
6299+- | Breakpoint n ids <- tickish
6300+- = Breakpoint n (map (getDoneId . substId env) ids)
6301++ | Breakpoint ext n ids <- tickish
6302++ = Breakpoint ext n (map (getDoneId . substId env) ids)
6303+ | otherwise = tickish
6304+
6305+ -- Push type application and coercion inside a tick
6306+diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs
6307+index 89b7d4205e..a05d66788d 100644
6308+--- a/compiler/simplStg/SimplStg.hs
6309++++ b/compiler/simplStg/SimplStg.hs
6310+@@ -17,6 +17,7 @@ import GhcPrelude
6311+
6312+ import StgSyn
6313+
6314++import HscTypes ( HscEnv, hsc_dflags )
6315+ import StgLint ( lintStgTopBindings )
6316+ import StgStats ( showStgStats )
6317+ import UnariseStg ( unarise )
6318+@@ -44,12 +45,12 @@ instance MonadUnique StgM where
6319+ runStgM :: Char -> StgM a -> IO a
6320+ runStgM mask (StgM m) = evalStateT m mask
6321+
6322+-stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do
6323++stg2stg :: HscEnv -- includes spec of what stg-to-stg passes to do
6324+ -> Module -- module being compiled
6325+ -> [StgTopBinding] -- input program
6326+ -> IO [StgTopBinding] -- output program
6327+
6328+-stg2stg dflags this_mod binds
6329++stg2stg hsc_env this_mod binds
6330+ = do { dump_when Opt_D_dump_stg "STG:" binds
6331+ ; showPass dflags "Stg2Stg"
6332+ -- Do the main business!
6333+@@ -62,9 +63,10 @@ stg2stg dflags this_mod binds
6334+ }
6335+
6336+ where
6337++ dflags = hsc_dflags hsc_env
6338+ stg_linter unarised
6339+ | gopt Opt_DoStgLinting dflags
6340+- = lintStgTopBindings dflags this_mod unarised
6341++ = lintStgTopBindings hsc_env this_mod unarised
6342+ | otherwise
6343+ = \ _whodunnit _binds -> return ()
6344+
6345+diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs
6346+index dc48d75eb8..adee4e7532 100644
6347+--- a/compiler/specialise/Specialise.hs
6348++++ b/compiler/specialise/Specialise.hs
6349+@@ -952,9 +952,9 @@ specLam env bndrs body
6350+ ; return (mkLams bndrs (wrapDictBindsE dumped_dbs body'), free_uds) }
6351+
6352+ --------------
6353+-specTickish :: SpecEnv -> Tickish Id -> Tickish Id
6354+-specTickish env (Breakpoint ix ids)
6355+- = Breakpoint ix [ id' | id <- ids, Var id' <- [specVar env id]]
6356++specTickish :: SpecEnv -> CoreTickish -> CoreTickish
6357++specTickish env (Breakpoint ext ix ids)
6358++ = Breakpoint ext ix [ id' | id <- ids, Var id' <- [specVar env id]]
6359+ -- drop vars from the list if they have a non-variable substitution.
6360+ -- should never happen, but it's harmless to drop them anyway.
6361+ specTickish _ other_tickish = other_tickish
6362+diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
6363+index 634b74be5b..f24e824525 100644
6364+--- a/compiler/stgSyn/CoreToStg.hs
6365++++ b/compiler/stgSyn/CoreToStg.hs
6366+@@ -1,4 +1,6 @@
6367+ {-# LANGUAGE CPP, DeriveFunctor #-}
6368++{-# LANGUAGE BangPatterns #-}
6369++{-# LANGUAGE TypeFamilies #-}
6370+
6371+ --
6372+ -- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
6373+@@ -429,13 +431,10 @@ coreToStgExpr expr@(Lam _ _)
6374+ return result_expr
6375+
6376+ coreToStgExpr (Tick tick expr)
6377+- = do case tick of
6378+- HpcTick{} -> return ()
6379+- ProfNote{} -> return ()
6380+- SourceNote{} -> return ()
6381+- Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"
6382++ = do
6383++ let !stg_tick = coreToStgTick (exprType expr) tick
6384+ expr2 <- coreToStgExpr expr
6385+- return (StgTick tick expr2)
6386++ return (StgTick stg_tick expr2)
6387+
6388+ coreToStgExpr (Cast expr _)
6389+ = coreToStgExpr expr
6390+@@ -526,7 +525,7 @@ mkStgAltType bndr alts
6391+
6392+ coreToStgApp :: Id -- Function
6393+ -> [CoreArg] -- Arguments
6394+- -> [Tickish Id] -- Debug ticks
6395++ -> [CoreTickish] -- Debug ticks
6396+ -> CtsM StgExpr
6397+ coreToStgApp f args ticks = do
6398+ (args', ticks') <- coreToStgArgs args
6399+@@ -572,7 +571,8 @@ coreToStgApp f args ticks = do
6400+ TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args')
6401+ _other -> StgApp f args'
6402+
6403+- tapp = foldr StgTick app (ticks ++ ticks')
6404++ add_tick !t !e = StgTick t e
6405++ tapp = foldr add_tick app (map (coreToStgTick res_ty) ticks ++ ticks')
6406+
6407+ -- Forcing these fixes a leak in the code generator, noticed while
6408+ -- profiling for trac #4367
6409+@@ -583,7 +583,7 @@ coreToStgApp f args ticks = do
6410+ -- This is the guy that turns applications into A-normal form
6411+ -- ---------------------------------------------------------------------------
6412+
6413+-coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [Tickish Id])
6414++coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish])
6415+ coreToStgArgs []
6416+ = return ([], [])
6417+
6418+@@ -598,7 +598,8 @@ coreToStgArgs (Coercion _ : args) -- Coercion argument; See Note [Coercion token
6419+ coreToStgArgs (Tick t e : args)
6420+ = ASSERT( not (tickishIsCode t) )
6421+ do { (args', ts) <- coreToStgArgs (e : args)
6422+- ; return (args', t:ts) }
6423++ ; let !t' = coreToStgTick (exprType e) t
6424++ ; return (args', t':ts) }
6425+
6426+ coreToStgArgs (arg : args) = do -- Non-type argument
6427+ (stg_args, ticks) <- coreToStgArgs args
6428+@@ -630,6 +631,13 @@ coreToStgArgs (arg : args) = do -- Non-type argument
6429+ WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )
6430+ return (stg_arg : stg_args, ticks ++ aticks)
6431+
6432++coreToStgTick :: Type -- type of the ticked expression
6433++ -> CoreTickish
6434++ -> StgTickish
6435++coreToStgTick _ty (HpcTick m i) = HpcTick m i
6436++coreToStgTick _ty (SourceNote span nm) = SourceNote span nm
6437++coreToStgTick _ty (ProfNote cc cnt scope) = ProfNote cc cnt scope
6438++coreToStgTick !ty (Breakpoint _ bid fvs) = Breakpoint ty bid fvs
6439+
6440+ -- ---------------------------------------------------------------------------
6441+ -- The magic for lets:
6442+@@ -936,7 +944,7 @@ myCollectBinders expr
6443+
6444+ -- | Precondition: argument expression is an 'App', and there is a 'Var' at the
6445+ -- head of the 'App' chain.
6446+-myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id])
6447++myCollectArgs :: CoreExpr -> (Id, [CoreArg], [CoreTickish])
6448+ myCollectArgs expr
6449+ = go expr [] []
6450+ where
6451+diff --git a/compiler/stgSyn/StgFVs.hs b/compiler/stgSyn/StgFVs.hs
6452+index edfc94ed2d..22bb20b97c 100644
6453+--- a/compiler/stgSyn/StgFVs.hs
6454++++ b/compiler/stgSyn/StgFVs.hs
6455+@@ -1,4 +1,5 @@
6456+ -- | Free variable analysis on STG terms.
6457++{-# LANGUAGE TypeFamilies #-}
6458+ module StgFVs (
6459+ annTopBindingsFreeVars,
6460+ annBindingFreeVars
6461+@@ -9,7 +10,7 @@ import GhcPrelude
6462+ import StgSyn
6463+ import Id
6464+ import VarSet
6465+-import CoreSyn ( Tickish(Breakpoint) )
6466++import CoreSyn ( GenTickish(Breakpoint) )
6467+ import Outputable
6468+ import Util
6469+
6470+@@ -103,8 +104,8 @@ expr env = go
6471+ where
6472+ (e', fvs) = go e
6473+ fvs' = unionDVarSet (tickish tick) fvs
6474+- tickish (Breakpoint _ ids) = mkDVarSet ids
6475+- tickish _ = emptyDVarSet
6476++ tickish (Breakpoint _ _ ids) = mkDVarSet ids
6477++ tickish _ = emptyDVarSet
6478+
6479+ go_bind dc bind body = (dc bind' body', fvs)
6480+ where
6481+diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs
6482+index f83b44859c..f6fb1357e8 100644
6483+--- a/compiler/stgSyn/StgLint.hs
6484++++ b/compiler/stgSyn/StgLint.hs
6485+@@ -40,6 +40,8 @@ module StgLint ( lintStgTopBindings ) where
6486+ import GhcPrelude
6487+
6488+ import StgSyn
6489++import HscTypes
6490++import CoreLint ( interactiveInScope )
6491+
6492+ import DynFlags
6493+ import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
6494+@@ -61,14 +63,14 @@ import Control.Applicative ((<|>))
6495+ import Control.Monad
6496+
6497+ lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
6498+- => DynFlags
6499++ => HscEnv
6500+ -> Module -- ^ module being compiled
6501+ -> Bool -- ^ have we run Unarise yet?
6502+ -> String -- ^ who produced the STG?
6503+ -> [GenStgTopBinding a]
6504+ -> IO ()
6505+
6506+-lintStgTopBindings dflags this_mod unarised whodunnit binds
6507++lintStgTopBindings hsc_env this_mod unarised whodunnit binds
6508+ = {-# SCC "StgLint" #-}
6509+ case initL this_mod unarised top_level_binds (lint_binds binds) of
6510+ Nothing ->
6511+@@ -84,9 +86,12 @@ lintStgTopBindings dflags this_mod unarised whodunnit binds
6512+ text "*** End of Offense ***"])
6513+ Err.ghcExit dflags 1
6514+ where
6515++ dflags = hsc_dflags hsc_env
6516+ -- Bring all top-level binds into scope because CoreToStg does not generate
6517+ -- bindings in dependency order (so we may see a use before its definition).
6518+- top_level_binds = mkVarSet (bindersOfTopBinds binds)
6519++ top_level_binds = mkVarSet (bindersOfTopBinds binds ++
6520++ interactiveInScope hsc_env
6521++ )
6522+
6523+ lint_binds :: [GenStgTopBinding a] -> LintM ()
6524+
6525+diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
6526+index 052ef2b6c7..22b9d159ca 100644
6527+--- a/compiler/stgSyn/StgSyn.hs
6528++++ b/compiler/stgSyn/StgSyn.hs
6529+@@ -54,14 +54,15 @@ module StgSyn (
6530+ stripStgTicksTop, stripStgTicksTopE,
6531+ stgCaseBndrInScope,
6532+
6533+- pprStgBinding, pprGenStgTopBindings, pprStgTopBindings
6534++ pprStgBinding, pprGenStgTopBindings, pprStgTopBindings,
6535++ pprStgExpr, pprStgRhs
6536+ ) where
6537+
6538+ #include "HsVersions.h"
6539+
6540+ import GhcPrelude
6541+
6542+-import CoreSyn ( AltCon, Tickish )
6543++import CoreSyn ( AltCon, StgTickish )
6544+ import CostCentre ( CostCentreStack )
6545+ import Data.ByteString ( ByteString )
6546+ import Data.Data ( Data )
6547+@@ -168,13 +169,13 @@ stgArgType (StgLitArg lit) = literalType lit
6548+
6549+
6550+ -- | Strip ticks of a given type from an STG expression.
6551+-stripStgTicksTop :: (Tickish Id -> Bool) -> GenStgExpr p -> ([Tickish Id], GenStgExpr p)
6552++stripStgTicksTop :: (StgTickish -> Bool) -> GenStgExpr p -> ([StgTickish], GenStgExpr p)
6553+ stripStgTicksTop p = go []
6554+ where go ts (StgTick t e) | p t = go (t:ts) e
6555+ go ts other = (reverse ts, other)
6556+
6557+ -- | Strip ticks of a given type from an STG expression returning only the expression.
6558+-stripStgTicksTopE :: (Tickish Id -> Bool) -> GenStgExpr p -> GenStgExpr p
6559++stripStgTicksTopE :: (StgTickish -> Bool) -> GenStgExpr p -> GenStgExpr p
6560+ stripStgTicksTopE p = go
6561+ where go (StgTick t e) | p t = go e
6562+ go other = other
6563+@@ -376,7 +377,7 @@ Finally for @hpc@ expressions we introduce a new STG construct.
6564+ -}
6565+
6566+ | StgTick
6567+- (Tickish Id)
6568++ StgTickish
6569+ (GenStgExpr pass) -- sub expression
6570+
6571+ -- END of GenStgExpr
6572+diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
6573+index a9de7ac1f6..b2288b0742 100644
6574+--- a/compiler/typecheck/TcBinds.hs
6575++++ b/compiler/typecheck/TcBinds.hs
6576+@@ -20,7 +20,7 @@ import GhcPrelude
6577+ import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
6578+ import {-# SOURCE #-} TcExpr ( tcMonoExpr )
6579+ import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind )
6580+-import CoreSyn (Tickish (..))
6581++import CoreSyn (CoreTickish, GenTickish (..))
6582+ import CostCentre (mkUserCC, CCFlavour(DeclCC))
6583+ import DynFlags
6584+ import FastString
6585+@@ -738,7 +738,7 @@ tcPolyCheck _prag_fn sig bind
6586+ = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)
6587+
6588+ funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]
6589+- -> TcM [Tickish TcId]
6590++ -> TcM [CoreTickish]
6591+ funBindTicks loc fun_id mod sigs
6592+ | (mb_cc_str : _) <- [ cc_name | (dL->L _ (SCCFunSig _ _ _ cc_name)) <- sigs ]
6593+ -- this can only be a singleton list, as duplicate pragmas are rejected
6476594diff --git a/includes/rts/Bytecodes.h b/includes/rts/Bytecodes.h
6486595index e5d55f694f..88748ea184 100644
6496596--- a/includes/rts/Bytecodes.h
@@ -741,10 +6688,18 @@ index 01d6c3b1d9..bae23c1f17 100644
7416688 default:
7426689 barf("disInstr: unknown opcode %u", (unsigned int) instr);
7436690diff --git a/rts/Interpreter.c b/rts/Interpreter.c
744−index 463ddae18b..f33fb9c73e 100644
6691+index 463ddae18b..49d881e2e0 100644
7456692--- a/rts/Interpreter.c
7466693+++ b/rts/Interpreter.c
747−@@ -681,12 +681,13 @@ do_return_unboxed:
6694+@@ -4,6 +4,7 @@
6695+ * Copyright (c) The GHC Team, 1994-2002.
6696+ * ---------------------------------------------------------------------------*/
6697+
6698++
6699+ #include "PosixSource.h"
6700+ #include "Rts.h"
6701+ #include "RtsAPI.h"
6702+@@ -681,12 +682,13 @@ do_return_unboxed:
7486703 || SpW(0) == (W_)&stg_ret_f_info
7496704 || SpW(0) == (W_)&stg_ret_d_info
7506705 || SpW(0) == (W_)&stg_ret_l_info
@@ -759,16 +6714,60 @@ index 463ddae18b..f33fb9c73e 100644
7596714 debugBelch("Sp = %p\n", Sp);
7606715 #if defined(PROFILING)
7616716 fprintCCS(stderr, cap->r.rCCCS);
762−@@ -697,7 +698,7 @@ do_return_unboxed:
6717+@@ -697,7 +699,7 @@ do_return_unboxed:
7636718 debugBelch("\n\n");
7646719 );
7656720
7666721- // get the offset of the stg_ctoi_ret_XXX itbl
767−+ // get the offset of the stg_ctoi_XXX itbl
6722++ // get the offset of the header of the next stack frame
7686723 offset = stack_frame_sizeW((StgClosure *)Sp);
7696724
7706725 switch (get_itbl((StgClosure*)(Sp_plusW(offset)))->type) {
771−@@ -1326,6 +1327,64 @@ run_BCO:
6726+@@ -934,6 +936,43 @@ run_BCO_return_unboxed:
6727+ // Stack checks aren't necessary at return points, the stack use
6728+ // is aggregated into the enclosing function entry point.
6729+
6730++#if defined(PROFILING)
6731++ /*
6732++ Restore the current cost centre stack if a tuple is being returned.
6733++
6734++ When a "simple" unboxed value is returned, the cccs is restored with
6735++ an stg_restore_cccs frame on the stack, for example:
6736++
6737++ ...
6738++ stg_ctoi_D1
6739++ <CCCS>
6740++ stg_restore_cccs
6741++
6742++ But stg_restore_cccs cannot deal with tuples, which may have more
6743++ things on the stack. Therefore we store the CCCS inside the
6744++ stg_ctoi_t frame.
6745++
6746++ If we have a tuple being returned, the stack looks like this:
6747++
6748++ ...
6749++ <CCCS> <- to restore, Sp offset <next frame + 4 words>
6750++ tuple_BCO
6751++ tuple_info
6752++ cont_BCO
6753++ stg_ctoi_t <- next frame
6754++ tuple_data_1
6755++ ...
6756++ tuple_data_n
6757++ tuple_info
6758++ tuple_BCO
6759++ stg_ret_t <- Sp
6760++ */
6761++
6762++ if(SpW(0) == (W_)&stg_ret_t_info) {
6763++ cap->r.rCCCS = (CostCentreStack*)SpW(stack_frame_sizeW((StgClosure *)Sp) + 4);
6764++ }
6765++#endif
6766++
6767+ goto run_BCO;
6768+
6769+ run_BCO_fun:
6770+@@ -1326,6 +1365,64 @@ run_BCO:
7726771 goto nextInsn;
7736772 }
7746773
@@ -777,6 +6776,11 @@ index 463ddae18b..f33fb9c73e 100644
7776776+ W_ tuple_info = (W_)BCO_LIT(BCO_GET_LARGE_ARG);
7786777+ int o_tuple_bco = BCO_GET_LARGE_ARG;
7796778+
6779++#if defined(PROFILING)
6780++ SpW(-1) = (W_)cap->r.rCCCS;
6781++ Sp_subW(1);
6782++#endif
6783++
7806784+ SpW(-1) = BCO_PTR(o_tuple_bco);
7816785+ SpW(-2) = tuple_info;
7826786+ SpW(-3) = BCO_PTR(o_bco);
@@ -819,21 +6823,16 @@ index 463ddae18b..f33fb9c73e 100644
8196823+
8206824+ default: barf("unsupported tuple size %d", tuple_stack_words);
8216825+ }
6826++
8226827+ SpW(-4) = ctoi_t_offset;
8236828+ Sp_subW(4);
824−+ /* XXX this cannot work yet */
825−+ /* #if defined(PROFILING)
826−+ Sp_subW(2);
827−+ SpW(1) = (W_)cap->r.rCCCS;
828−+ SpW(0) = (W_)&stg_restore_cccs_info;
829−+ #endif */
8306829+ goto nextInsn;
8316830+ }
8326831+
8336832 case bci_PUSH_APPLY_N:
8346833 Sp_subW(1); SpW(0) = (W_)&stg_ap_n_info;
8356834 goto nextInsn;
836−@@ -1705,6 +1764,12 @@ run_BCO:
6835+@@ -1705,6 +1802,12 @@ run_BCO:
8376836 Sp_subW(1);
8386837 SpW(0) = (W_)&stg_ret_v_info;
8396838 goto do_return_unboxed;
@@ -926,10 +6925,10 @@ index 15404e1205..ab2119cf78 100644
9266925 BCO_BITMAP(bco), BCO_BITMAP_SIZE(bco));
9276926 continue;
9286927diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
929−index b2f90a892d..9ad6806c18 100644
6928+index 9ca696c27c..6d5e9805aa 100644
9306929--- a/rts/RtsSymbols.c
9316930+++ b/rts/RtsSymbols.c
932−@@ -551,6 +551,8 @@
6931+@@ -552,6 +552,8 @@
9336932 SymI_HasProto(stg_ret_f_info) \
9346933 SymI_HasProto(stg_ret_d_info) \
9356934 SymI_HasProto(stg_ret_l_info) \
@@ -939,10 +6938,10 @@ index b2f90a892d..9ad6806c18 100644
9396938 SymI_HasProto(stg_gc_prim_pp) \
9406939 SymI_HasProto(stg_gc_prim_n) \
9416940diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
942−index 44d7d302e5..015a6b50f6 100644
6941+index 44d7d302e5..fdc4bc75a2 100644
9436942--- a/rts/StgMiscClosures.cmm
9446943+++ b/rts/StgMiscClosures.cmm
945−@@ -195,6 +195,236 @@ INFO_TABLE_RET( stg_ctoi_V, RET_BCO )
6944+@@ -195,6 +195,240 @@ INFO_TABLE_RET( stg_ctoi_V, RET_BCO )
9466945 jump stg_yield_to_interpreter [];
9476946 }
9486947
@@ -1001,10 +7000,10 @@ index 44d7d302e5..015a6b50f6 100644
10017000+ tuple_BCO
10027001+ stg_apply_interp <- Sp
10037002+
1004−+
7003++
10057004+ tuple_BCO contains the bytecode instructions to return the tuple to
10067005+ cont_BCO. The bitmap in tuple_BCO describes the contents of
1007−+ the tuple to the storage manager.
7006++ the tuple to the storage manager.
10087007+
10097008+ At this point we can safely jump to the interpreter.
10107009+
@@ -1076,6 +7075,10 @@ index 44d7d302e5..015a6b50f6 100644
10767075+ tuple_BCO = Sp(3); /* bytecode object that returns the tuple in
10777076+ the interpreter */
10787077+
7078++#if defined(PROFILING)
7079++ CCCS = Sp(4);
7080++#endif
7081++
10797082+ tuple_stack = tuple_info & 0x3fff; /* number of words spilled on stack */
10807083+ tuple_regs_R = (tuple_info >> 28) & 0xf; /* number of R1..Rn */
10817084+ tuple_regs_F = (tuple_info >> 22) & 0x3f; /* 6 bits bitmap */
@@ -1172,25 +7175,54 @@ index 44d7d302e5..015a6b50f6 100644
11727175+ if((tuple_regs_L & 1) != 0) { L1 = L_[Sp]; Sp = Sp + 8; }
11737176+
11747177+ /* Sp points to the topmost argument now */
1175−+ jump Sp(tuple_stack) [*]; // NB. all registers live!
7178++ jump %ENTRY_CODE(Sp(tuple_stack)) [*]; // NB. all registers live!
11767179+}
11777180+
11787181+
11797182 /*
11807183 * Dummy info table pushed on the top of the stack when the interpreter
11817184 * should apply the BCO on the stack to its arguments, also on the
7185+diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/ByteCode.hs b/testsuite/tests/ghci/should_run/UnboxedTuples/ByteCode.hs
7186+new file mode 100644
7187+index 0000000000..a1bce35ad0
7188+--- /dev/null
7189++++ b/testsuite/tests/ghci/should_run/UnboxedTuples/ByteCode.hs
7190+@@ -0,0 +1,17 @@
7191++{-# LANGUAGE CPP, UnboxedTuples, MagicHash, ScopedTypeVariables, PolyKinds #-}
7192++{-# OPTIONS_GHC -fbyte-code #-}
7193++
7194++#include "MachDeps.h"
7195++
7196++#if WORD_SIZE_IN_BITS < 64
7197++#define WW Word64
7198++#else
7199++#define WW Word
7200++#endif
7201++
7202++module ByteCode where
7203++
7204++import GHC.Exts
7205++import GHC.Word
7206++
7207++#include "Common.hs-incl"
11827208diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/Common.hs-incl b/testsuite/tests/ghci/should_run/UnboxedTuples/Common.hs-incl
11837209new file mode 100644
1184−index 0000000000..80992405b5
7210+index 0000000000..6931397f09
11857211--- /dev/null
11867212+++ b/testsuite/tests/ghci/should_run/UnboxedTuples/Common.hs-incl
1187−@@ -0,0 +1,219 @@
7213+@@ -0,0 +1,368 @@
7214++swap :: (# a, b #) -> (# b, a #)
7215++swap (# x, y #) = (# y, x #)
7216++
11887217+type T1 a = a -> (# a #)
11897218+tuple1 :: T1 a
11907219+tuple1 x = (# x #)
11917220+
1192−+tuple1a :: a -> T1 a -> a
1193−+tuple1a x f = case f x of (# y #) -> y
7221++tuple1_a :: T1 a -> a -> a
7222++tuple1_a f x = case f x of (# y #) -> y
7223++
7224++tuple1_b :: T1 a -> a -> String -> IO ()
7225++tuple1_b f x msg = case f x of (# _ #) -> putStrLn msg
11947226+
11957227+-- can still be returned in registers, pointers
11967228+type T2p a = a -> a -> a -> a -> (# a, a, a, a #)
@@ -1233,7 +7265,7 @@ index 0000000000..80992405b5
12337265+ , a, a, a, a
12347266+ , a, a, a, a
12357267+ )
1236−+tuple3_a f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 =
7268++tuple3_a f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 =
12377269+ case f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 of
12387270+ (# y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12 #) ->
12397271+ (y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12)
@@ -1363,7 +7395,7 @@ index 0000000000..80992405b5
13637395+ -> (# Int, WW#, Int, WW#
13647396+ , Int, WW#, Int, WW#
13657397+ , Int, WW#, Int, WW#
1366−+ , Int, WW#, Int, WW#
7398++ , Int, WW#, Int, WW#
13677399+ #)
13687400+
13697401+tuple5 :: T5
@@ -1404,13 +7436,156 @@ index 0000000000..80992405b5
14047436+ , (j5, W64# x5, j6, W64# x6)
14057437+ , (j7, W64# x7, j8, W64# x8)
14067438+ )
7439++
7440++type T6 = Int ->
7441++ (# Int#, (# Int, (# Int#, (# #) #) #) #)
7442++tuple6 :: T6
7443++tuple6 x@(I# x#) = (# x#, (# x, (# x#, (# #) #) #) #)
7444++
7445++tuple6_a :: T6 -> Int -> String
7446++tuple6_a f x =
7447++ case f x of
7448++ (# x1, (# x2, (# x3, (# #) #) #) #) -> show (I# x1, (x2, (I# x3, ())))
7449++
7450++-- empty tuples and tuples with void
7451++
7452++type TV1 = Bool -> (# #)
7453++
7454++{-# NOINLINE tuple_v1 #-}
7455++tuple_v1 :: TV1
7456++tuple_v1 _ = (# #)
7457++
7458++{-# NOINLINE tuple_v1_a #-}
7459++tuple_v1_a :: TV1 -> Bool -> Bool
7460++tuple_v1_a f x = case f x of (# #) -> True
7461++
7462++
7463++type TV2 = Bool -> (# (# #) #)
7464++
7465++{-# NOINLINE tuple_v2 #-}
7466++tuple_v2 :: TV2
7467++tuple_v2 _ = (# (# #) #)
7468++
7469++{-# NOINLINE tuple_v2_a #-}
7470++tuple_v2_a :: TV2 -> Bool -> Bool
7471++tuple_v2_a f x = case f x of (# _ #) -> True
7472++
7473++
7474++type TV3 a = a -> (# (# #), a #)
7475++
7476++{-# NOINLINE tuple_v3 #-}
7477++tuple_v3 :: TV3 a
7478++tuple_v3 x = (# (# #), x #)
7479++
7480++{-# NOINLINE tuple_v3_a #-}
7481++tuple_v3_a :: TV3 a -> a -> a
7482++tuple_v3_a f x = case f x of (# _, y #) -> y
7483++
7484++
7485++type TV4 a = a -> (# a, (# #) #)
7486++
7487++{-# NOINLINE tuple_v4 #-}
7488++tuple_v4 :: TV4 a
7489++tuple_v4 x = (# x, (# #) #)
7490++
7491++{-# NOINLINE tuple_v4_a #-}
7492++tuple_v4_a :: TV4 a -> a -> a
7493++tuple_v4_a f x = case f x of (# y, _ #) -> y
7494++
7495++
7496++type TV5 a = a -> (# (# #), a, (# #) #)
7497++
7498++{-# NOINLINE tuple_v5 #-}
7499++tuple_v5 :: TV5 a
7500++tuple_v5 x = (# (# #), x, (# #) #)
7501++
7502++{-# NOINLINE tuple_v5_a #-}
7503++tuple_v5_a :: TV5 a -> a -> a
7504++tuple_v5_a f x = case f x of (# _, x, _ #) -> x
7505++
7506++
7507++type TV6 = Int -> Double -> Int -> Double
7508++ -> (# Int#, (# #), Double#, (# #)
7509++ , Int#, (# #), Double#, (# #) #)
7510++
7511++{-# NOINLINE tuple_v6 #-}
7512++tuple_v6 :: TV6
7513++tuple_v6 (I# x) (D# y) (I# z) (D# w) = (# x, (# #), y, (# #), z, (# #), w, (# #) #)
7514++
7515++{-# NOINLINE tuple_v6_a #-}
7516++tuple_v6_a :: TV6 -> Int -> Double -> Int -> Double
7517++ -> (Int, Double, Int, Double)
7518++tuple_v6_a f x y z w = case f x y z w of (# x', _, y', _, z', _, w', _ #) ->
7519++ (I# x', D# y', I# z', D# w')
7520++
7521++-- some levity polymorphic things
7522++{-# NOINLINE lev_poly #-}
7523++lev_poly :: forall r a (b :: TYPE r).
7524++ (a -> a -> a -> a ->
7525++ a -> a -> a -> a ->
7526++ a -> a -> a -> a -> b) -> a -> b
7527++lev_poly f x = f x x x x x x x x x x x x
7528++
7529++{-# NOINLINE lev_poly_a #-}
7530++lev_poly_a :: (t1
7531++ -> t2 -> (# a, b, c, d, e, f, g, h, i, j, k, l #))
7532++ -> t1 -> t2 -> (a, b, c, d, e, f, g, h, i, j, k, l)
7533++lev_poly_a lp t x =
7534++ case lp t x of (# x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12 #) ->
7535++ (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12)
7536++
7537++{-# NOINLINE lev_poly_boxed #-}
7538++lev_poly_boxed x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
7539++ = (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12)
7540++
7541++{-# NOINLINE lev_poly_b #-}
7542++lev_poly_b lp t x =
7543++ case lp t x of (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12)
7544++ -> (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12)
7545++
7546++-- some unboxed sums
7547++type S1 = (# (# Int#, String #) | Bool #)
7548++
7549++{-# NOINLINE sum1 #-}
7550++sum1 :: Int -> Int -> String -> Bool -> S1
7551++sum1 0 (I# x) y _ = (# (# x, y #) | #)
7552++sum1 _ _ _ b = (# | b #)
7553++
7554++{-# NOINLINE sum1_a #-}
7555++sum1_a :: (Int -> Int -> String -> Bool -> S1) -> Int -> Int -> String -> Bool -> Either (Int, String) Bool
7556++sum1_a f n x y b =
7557++ case f n x y b of
7558++ (# (# x, y #) | #) -> Left (I# x, y)
7559++ (# | b #) -> Right b
7560++
7561++
7562++type S2 a = (# (# a, a, a, a #) | (# a, a #) | (# #) | Int# | Int #)
7563++
7564++{-# NOINLINE sum2 #-}
7565++sum2 :: Int -> a -> S2 a
7566++sum2 0 x = (# (# x, x, x, x #) | | | | #)
7567++sum2 1 x = (# | (# x, x #) | | | #)
7568++sum2 2 _ = (# | | (# #) | | #)
7569++sum2 n@(I# n#) _
7570++ | even n = (# | | | n# | #)
7571++ | otherwise = (# | | | | n #)
7572++
7573++{-# NOINLINE sum2_a #-}
7574++sum2_a :: Show a => (Int -> a -> S2 a) -> Int -> a -> String
7575++sum2_a f n x =
7576++ case f n x of
7577++ (# (# x1, x2, x3, x4 #) | | | | #) -> show (x1, x2, x3, x4)
7578++ (# | (# x1, x2 #) | | | #) -> show (x1, x2)
7579++ (# | | (# #) | | #) -> "(# #)"
7580++ (# | | | x# | #) -> show (I# x#) ++ "#"
7581++ (# | | | | x #) -> show x
14077582diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/Obj.hs b/testsuite/tests/ghci/should_run/UnboxedTuples/Obj.hs
14087583new file mode 100644
1409−index 0000000000..e9272583f0
7584+index 0000000000..190b8f1683
14107585--- /dev/null
14117586+++ b/testsuite/tests/ghci/should_run/UnboxedTuples/Obj.hs
14127587@@ -0,0 +1,17 @@
1413−+{-# LANGUAGE CPP, UnboxedTuples, MagicHash #-}
7588++{-# LANGUAGE CPP, UnboxedTuples, MagicHash, ScopedTypeVariables, PolyKinds #-}
14147589+{-# OPTIONS_GHC -fobject-code #-}
14157590+
14167591+#include "MachDeps.h"
@@ -1429,23 +7604,15 @@ index 0000000000..e9272583f0
14297604+#include "Common.hs-incl"
14307605diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.hs b/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.hs
14317606new file mode 100644
1432−index 0000000000..f6cec4206f
7607+index 0000000000..1daec7f207
14337608--- /dev/null
14347609+++ b/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.hs
1435−@@ -0,0 +1,83 @@
1436−+{-# LANGUAGE CPP, UnboxedTuples, MagicHash #-}
7610+@@ -0,0 +1,182 @@
7611++{-# LANGUAGE UnboxedTuples, MagicHash #-}
14377612+{-# OPTIONS_GHC -fbyte-code #-}
14387613+
1439−+#include "MachDeps.h"
1440−+
1441−+#if WORD_SIZE_IN_BITS < 64
1442−+#define WW Word64
1443−+#else
1444−+#define WW Word
1445−+#endif
1446−+
14477614+{-
1448−+ Test unboxed tuples in the bytecode interpreter.
7615++ Test unboxed tuples and sums in the bytecode interpreter.
14497616+
14507617+ The bytecode interpreter uses the stack for everything, while
14517618+ compiled code uses STG registers for arguments and return values.
@@ -1453,7 +7620,8 @@ index 0000000000..f6cec4206f
14537620+
14547621+module Main where
14557622+
1456−+import qualified Obj as O
7623++import qualified Obj as O
7624++import qualified ByteCode as B
14577625+
14587626+import GHC.Exts
14597627+import GHC.Word
@@ -1461,67 +7629,179 @@ index 0000000000..f6cec4206f
14617629+main :: IO ()
14627630+main = do
14637631+
7632++ case B.swap (O.swap (B.swap (O.swap (# "x", 1 #)))) of
7633++ (# y1, y2 #) -> print (y1, y2)
7634++
7635++ -- one-tuples
7636++ testX "tuple1"
7637++ B.tuple1_a O.tuple1_a
7638++ B.tuple1 O.tuple1
7639++ (\f -> f 90053)
7640++
7641++ -- check that the contents of a one-tuple aren't evaluated
7642++ B.tuple1_b B.tuple1 (error "error tuple1_b") "tuple1_b"
7643++ B.tuple1_b O.tuple1 (error "error tuple1_b") "tuple1_b"
7644++ O.tuple1_b B.tuple1 (error "error tuple1_b") "tuple1_b"
7645++ O.tuple1_b O.tuple1 (error "error tuple1_b") "tuple1_b"
7646++
7647++ -- various size tuples with boxed/unboxed elements
14647648+ testX "tuple2p"
1465−+ tuple2p_a O.tuple2p_a
1466−+ tuple2p O.tuple2p
7649++ B.tuple2p_a O.tuple2p_a
7650++ B.tuple2p O.tuple2p
14677651+ (\f -> f (1234::Integer) 1235 1236 1237)
14687652+
14697653+ testX "tuple2n"
1470−+ tuple2n_a O.tuple2n_a
1471−+ tuple2n O.tuple2n
7654++ B.tuple2n_a O.tuple2n_a
7655++ B.tuple2n O.tuple2n
14727656+ (\f -> f 7654 7653 7652 7651)
14737657+
14747658+ testX "tuple3"
1475−+ tuple3_a O.tuple3_a
1476−+ tuple3 O.tuple3
7659++ B.tuple3_a O.tuple3_a
7660++ B.tuple3 O.tuple3
14777661+ (\f -> f (1000::Integer) 1001 1002 1003
14787662+ 1004 1005 1006 1007
14797663+ 1008 1009 1010 1011)
14807664+
14817665+ testX "tuple4a"
1482−+ tuple4a_a O.tuple4a_a
1483−+ tuple4a O.tuple4a
7666++ B.tuple4a_a O.tuple4a_a
7667++ B.tuple4a O.tuple4a
14847668+ (\f -> f 2000 2001 2002 2003)
14857669+
14867670+ testX "tuple4b"
1487−+ tuple4b_a O.tuple4b_a
1488−+ tuple4b O.tuple4b
1489−+ (\f -> f 3000 3001 3002 3003
7671++ B.tuple4b_a O.tuple4b_a
7672++ B.tuple4b O.tuple4b
7673++ (\f -> f 3000 3001 3002 3003
14907674+ 3004 3005 3006 3007
14917675+ 3008 3009 3010 3011
14927676+ 3012 3013 3014 3015
14937677+ 3016 3017 3018 3019)
14947678+
14957679+ testX "tuple4c"
1496−+ tuple4c_a O.tuple4c_a
1497−+ tuple4c O.tuple4c
1498−+ (\f -> f 3000 3001 3002 3003
7680++ B.tuple4c_a O.tuple4c_a
7681++ B.tuple4c O.tuple4c
7682++ (\f -> f 3000 3001 3002 3003
14997683+ 3004 3005 3006 3007
15007684+ 3008 3009 3010 3011
15017685+ 3012 3013 3014 3015)
15027686+
15037687+ testX "tuple5"
1504−+ tuple5_a O.tuple5_a
1505−+ tuple5 O.tuple5
7688++ B.tuple5_a O.tuple5_a
7689++ B.tuple5 O.tuple5
15067690+ (\f -> f 4000 4001 4002 4003
1507−+ 4004 4005 4006 4007
1508−+ 4008 4009 4010 4011
7691++ 4004 4005 4006 4007
7692++ 4008 4009 4010 4011
15097693+ 4012 4013 4014 4015)
15107694+
7695++ testX "tuple6"
7696++ B.tuple6_a O.tuple6_a
7697++ B.tuple6 O.tuple6
7698++ (\f -> f 6006)
7699++
7700++ -- tuples with void and empty tuples
7701++ testX "tuplev1"
7702++ B.tuple_v1_a O.tuple_v1_a
7703++ B.tuple_v1 O.tuple_v1
7704++ (\f -> f False)
7705++
7706++ testX "tuplev2"
7707++ B.tuple_v2_a O.tuple_v2_a
7708++ B.tuple_v2 O.tuple_v2
7709++ (\f -> f False)
7710++
7711++ testX "tuplev3"
7712++ B.tuple_v3_a O.tuple_v3_a
7713++ B.tuple_v3 O.tuple_v3
7714++ (\f -> f 30001)
7715++
7716++ testX "tuplev4"
7717++ B.tuple_v4_a O.tuple_v4_a
7718++ B.tuple_v4 O.tuple_v4
7719++ (\f -> f 40001)
7720++
7721++ testX "tuplev5"
7722++ B.tuple_v5_a O.tuple_v5_a
7723++ B.tuple_v5 O.tuple_v5
7724++ (\f -> f 50001)
7725++
7726++ testX "tuplev6"
7727++ B.tuple_v6_a O.tuple_v6_a
7728++ B.tuple_v6 O.tuple_v6
7729++ (\f -> f 601 602 603 604)
7730++
7731++ -- levity polymorphic
7732++ print $ B.lev_poly_a B.lev_poly B.tuple3 991
7733++ print $ B.lev_poly_a B.lev_poly O.tuple3 992
7734++ print $ B.lev_poly_a O.lev_poly B.tuple3 993
7735++ print $ B.lev_poly_a O.lev_poly O.tuple3 994
7736++ print $ O.lev_poly_a B.lev_poly B.tuple3 995
7737++ print $ O.lev_poly_a B.lev_poly O.tuple3 996
7738++ print $ O.lev_poly_a O.lev_poly B.tuple3 997
7739++ print $ O.lev_poly_a O.lev_poly O.tuple3 998
7740++
7741++ print $ B.lev_poly_b B.lev_poly B.lev_poly_boxed 981
7742++ print $ B.lev_poly_b B.lev_poly O.lev_poly_boxed 982
7743++ print $ B.lev_poly_b O.lev_poly B.lev_poly_boxed 983
7744++ print $ B.lev_poly_b O.lev_poly O.lev_poly_boxed 984
7745++ print $ O.lev_poly_b B.lev_poly B.lev_poly_boxed 985
7746++ print $ O.lev_poly_b B.lev_poly O.lev_poly_boxed 986
7747++ print $ O.lev_poly_b O.lev_poly B.lev_poly_boxed 987
7748++ print $ O.lev_poly_b O.lev_poly O.lev_poly_boxed 988
7749++
7750++ -- sums
7751++ testX "sum1a"
7752++ B.sum1_a O.sum1_a
7753++ B.sum1 O.sum1
7754++ (\f -> f 0 1 "23" True)
7755++
7756++ testX "sum1b"
7757++ B.sum1_a O.sum1_a
7758++ B.sum1 O.sum1
7759++ (\f -> f 1 1 "23" True)
7760++
7761++ testX "sum2a"
7762++ B.sum2_a O.sum2_a
7763++ B.sum2 O.sum2
7764++ (\f -> f 0 "sum2")
7765++
7766++ testX "sum2b"
7767++ B.sum2_a O.sum2_a
7768++ B.sum2 O.sum2
7769++ (\f -> f 1 "sum2")
7770++
7771++ testX "sum2c"
7772++ B.sum2_a O.sum2_a
7773++ B.sum2 O.sum2
7774++ (\f -> f 2 "sum2")
7775++
7776++ testX "sum2d"
7777++ B.sum2_a O.sum2_a
7778++ B.sum2 O.sum2
7779++ (\f -> f 3 "sum2")
7780++
7781++ testX "sum2e"
7782++ B.sum2_a O.sum2_a
7783++ B.sum2 O.sum2
7784++ (\f -> f 4 "sum2")
7785++
7786++
15117787+
15127788+testX :: (Eq a, Show a)
15137789+ => String -> (p -> t) -> (p -> t) -> p -> p -> (t -> a) -> IO ()
15147790+testX msg a1 a2 b1 b2 ap =
15157791+ let (r:rs) = [ap (f g) | f <- [a1,a2], g <- [b1,b2]]
15167792+ in putStrLn (msg ++ " " ++ (show $ all (==r) rs) ++ " " ++ show r)
1517−+
1518−+#include "Common.hs-incl"
15197793diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.stdout b/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.stdout
15207794new file mode 100644
1521−index 0000000000..30acb50b07
7795+index 0000000000..82619b86fc
15227796--- /dev/null
15237797+++ b/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.stdout
1524−@@ -0,0 +1,7 @@
7798+@@ -0,0 +1,43 @@
7799++("x",1)
7800++tuple1 True 90053
7801++tuple1_b
7802++tuple1_b
7803++tuple1_b
7804++tuple1_b
15257805+tuple2p True (1234,1235,1236,1237)
15267806+tuple2n True (7654,7653,7652,7651)
15277807+tuple3 True (1000,1001,1002,1003,1004,1005,1006,1007,1008,1009,1010,1011)
@@ -1529,11 +7809,49 @@ index 0000000000..30acb50b07
15297809+tuple4b True ((3000.0,3001.0,3002.0,3003.0),(3004.0,3005.0,3006.0,3007.0),(3008.0,3009.0,3010.0,3011.0),(3012.0,3013.0,3014.0,3015.0),(3016.0,3017.0,3018.0,3019.0))
15307810+tuple4c True ((3000.0,3001.0,3002,3003),(3004.0,3005.0,3006,3007),(3008.0,3009.0,3010,3011),(3012.0,3013.0,3014,3015))
15317811+tuple5 True ((4000,4001,4002,4003),(4004,4005,4006,4007),(4008,4009,4010,4011),(4012,4013,4014,4015))
7812++tuple6 True "(6006,(6006,(6006,())))"
7813++tuplev1 True True
7814++tuplev2 True True
7815++tuplev3 True 30001
7816++tuplev4 True 40001
7817++tuplev5 True 50001
7818++tuplev6 True (601,602.0,603,604.0)
7819++(991,991,991,991,991,991,991,991,991,991,991,991)
7820++(992,992,992,992,992,992,992,992,992,992,992,992)
7821++(993,993,993,993,993,993,993,993,993,993,993,993)
7822++(994,994,994,994,994,994,994,994,994,994,994,994)
7823++(995,995,995,995,995,995,995,995,995,995,995,995)
7824++(996,996,996,996,996,996,996,996,996,996,996,996)
7825++(997,997,997,997,997,997,997,997,997,997,997,997)
7826++(998,998,998,998,998,998,998,998,998,998,998,998)
7827++(981,981,981,981,981,981,981,981,981,981,981,981)
7828++(982,982,982,982,982,982,982,982,982,982,982,982)
7829++(983,983,983,983,983,983,983,983,983,983,983,983)
7830++(984,984,984,984,984,984,984,984,984,984,984,984)
7831++(985,985,985,985,985,985,985,985,985,985,985,985)
7832++(986,986,986,986,986,986,986,986,986,986,986,986)
7833++(987,987,987,987,987,987,987,987,987,987,987,987)
7834++(988,988,988,988,988,988,988,988,988,988,988,988)
7835++sum1a True Left (1,"23")
7836++sum1b True Right True
7837++sum2a True "(\"sum2\",\"sum2\",\"sum2\",\"sum2\")"
7838++sum2b True "(\"sum2\",\"sum2\")"
7839++sum2c True "(# #)"
7840++sum2d True "3"
7841++sum2e True "4#"
15327842diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/unboxedtuples.T b/testsuite/tests/ghci/should_run/UnboxedTuples/unboxedtuples.T
15337843new file mode 100644
1534−index 0000000000..9439257683
7844+index 0000000000..4166c82f7f
15357845--- /dev/null
15367846+++ b/testsuite/tests/ghci/should_run/UnboxedTuples/unboxedtuples.T
1537−@@ -0,0 +1,2 @@
1538−+test('UnboxedTuples', [extra_files(['Obj.hs', 'Common.hs-incl']),
1539−+ only_ways(['ghci'])], compile_and_run, [''])
7847+@@ -0,0 +1,10 @@
7848++test('UnboxedTuples',
7849++ [ extra_files(['Obj.hs', 'ByteCode.hs', 'Common.hs-incl']),
7850++ req_interp,
7851++ extra_ways(['ghci']),
7852++ when(config.have_ext_interp, extra_ways(['ghci', 'ghci-ext'])),
7853++ when(config.have_ext_interp and config.have_profiling, extra_ways(['ghci', 'ghci-ext', 'ghci-ext-prof']))
7854++ ],
7855++ compile_and_run,
7856++ ['']
7857++ )