From 422c4afec31ae9776d20d7e9d01ed899f3047197 Mon Sep 17 00:00:00 2001 From: Hamish Mackenzie Date: Fri, 12 Feb 2021 23:06:08 +1300 Subject: [PATCH] Update unboxed tuple patch (#1037) Also Includes aarch64 fix in ghc 8.10.4 See https://github.com/input-output-hk/haskell.nix/issues/1027 --- overlays/bootstrap.nix | 5 +- overlays/patches/ghc/ghc-8.10.3-ubxt.patch | 6800 +++++++++++++++++++- 2 files changed, 6563 insertions(+), 242 deletions(-) diff --git a/overlays/bootstrap.nix b/overlays/bootstrap.nix index c77937f8..6820ac31 100644 --- a/overlays/bootstrap.nix +++ b/overlays/bootstrap.nix @@ -142,7 +142,10 @@ in { ++ final.lib.optional (versionAtLeast "8.6.4" && versionLessThan "8.8") ./patches/ghc/ghc-no-system-linker.patch ++ fromUntil "8.10.2" "8.10.3" ./patches/ghc/MR3714-backported-to-8.10.2.patch - ++ final.lib.optional (version == "8.10.3" && final.targetPlatform.isAarch64) ./patches/ghc/3434.patch + + # See https://github.com/input-output-hk/haskell.nix/issues/1027 + ++ final.lib.optional (versionAtLeast "8.10.3" && final.targetPlatform.isAarch64) ./patches/ghc/3434.patch + ++ from "8.10.1" ./patches/ghc/ghc-acrt-iob-func.patch ++ fromUntil "8.10.1" "8.10.3" ./patches/ghc/ghc-8.10-ubxt.patch diff --git a/overlays/patches/ghc/ghc-8.10.3-ubxt.patch b/overlays/patches/ghc/ghc-8.10.3-ubxt.patch index 52d2e586..365c1303 100644 --- a/overlays/patches/ghc/ghc-8.10.3-ubxt.patch +++ b/overlays/patches/ghc/ghc-8.10.3-ubxt.patch @@ -1,5 +1,4077 @@ +diff --git a/compiler/GHC/Core/Map/Expr.hs b/compiler/GHC/Core/Map/Expr.hs +new file mode 100644 +index 0000000000..04c786deec +--- /dev/null ++++ b/compiler/GHC/Core/Map/Expr.hs +@@ -0,0 +1,392 @@ ++{-# LANGUAGE CPP #-} ++{-# LANGUAGE FlexibleContexts #-} ++{-# LANGUAGE FlexibleInstances #-} ++{-# LANGUAGE RankNTypes #-} ++{-# LANGUAGE ScopedTypeVariables #-} ++{-# LANGUAGE TypeFamilies #-} ++{-# LANGUAGE UndecidableInstances #-} ++ ++{- ++(c) The University of Glasgow 2006 ++(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 ++-} ++ ++{-# OPTIONS_GHC -Wno-orphans #-} ++ -- Eq (DeBruijn CoreExpr) and Eq (DeBruijn CoreAlt) ++ ++module GHC.Core.Map.Expr ( ++ -- * Maps over Core expressions ++ CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, ++ -- * 'TrieMap' class reexports ++ TrieMap(..), insertTM, deleteTM, ++ lkDFreeVar, xtDFreeVar, ++ lkDNamed, xtDNamed, ++ (>.>), (|>), (|>>), ++ ) where ++ ++#include "HsVersions.h" ++ ++import GHC.Prelude ++ ++import GHC.Data.TrieMap ++import GHC.Core.Map.Type ++import GHC.Core ++import GHC.Core.Type ++import GHC.Types.Var ++ ++import GHC.Utils.Misc ++import GHC.Utils.Outputable ++ ++import qualified Data.Map as Map ++import GHC.Types.Name.Env ++import Control.Monad( (>=>) ) ++ ++{- ++This module implements TrieMaps over Core related data structures ++like CoreExpr or Type. It is built on the Tries from the TrieMap ++module. ++ ++The code is very regular and boilerplate-like, but there is ++some neat handling of *binders*. In effect they are deBruijn ++numbered on the fly. ++ ++ ++-} ++ ++---------------------- ++-- Recall that ++-- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c ++ ++-- The CoreMap makes heavy use of GenMap. However the CoreMap Types are not ++-- known when defining GenMap so we can only specialize them here. ++ ++{-# SPECIALIZE lkG :: Key CoreMapX -> CoreMapG a -> Maybe a #-} ++{-# SPECIALIZE xtG :: Key CoreMapX -> XT a -> CoreMapG a -> CoreMapG a #-} ++{-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a -> CoreMapG b #-} ++{-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a -> b -> b #-} ++ ++ ++{- ++************************************************************************ ++* * ++ CoreMap ++* * ++************************************************************************ ++-} ++ ++{- ++Note [Binders] ++~~~~~~~~~~~~~~ ++ * In general we check binders as late as possible because types are ++ less likely to differ than expression structure. That's why ++ cm_lam :: CoreMapG (TypeMapG a) ++ rather than ++ cm_lam :: TypeMapG (CoreMapG a) ++ ++ * We don't need to look at the type of some binders, notably ++ - the case binder in (Case _ b _ _) ++ - the binders in an alternative ++ because they are totally fixed by the context ++ ++Note [Empty case alternatives] ++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ++* For a key (Case e b ty (alt:alts)) we don't need to look the return type ++ 'ty', because every alternative has that type. ++ ++* For a key (Case e b ty []) we MUST look at the return type 'ty', because ++ otherwise (Case (error () "urk") _ Int []) would compare equal to ++ (Case (error () "urk") _ Bool []) ++ which is utterly wrong (#6097) ++ ++We could compare the return type regardless, but the wildly common case ++is that it's unnecessary, so we have two fields (cm_case and cm_ecase) ++for the two possibilities. Only cm_ecase looks at the type. ++ ++See also Note [Empty case alternatives] in GHC.Core. ++-} ++ ++-- | @CoreMap a@ is a map from 'CoreExpr' to @a@. If you are a client, this ++-- is the type you want. ++newtype CoreMap a = CoreMap (CoreMapG a) ++ ++instance TrieMap CoreMap where ++ type Key CoreMap = CoreExpr ++ emptyTM = CoreMap emptyTM ++ lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m ++ alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m) ++ foldTM k (CoreMap m) = foldTM k m ++ mapTM f (CoreMap m) = CoreMap (mapTM f m) ++ filterTM f (CoreMap m) = CoreMap (filterTM f m) ++ ++-- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@. The extended ++-- key makes it suitable for recursive traversal, since it can track binders, ++-- but it is strictly internal to this module. If you are including a 'CoreMap' ++-- inside another 'TrieMap', this is the type you want. ++type CoreMapG = GenMap CoreMapX ++ ++-- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without ++-- the 'GenMap' optimization. ++data CoreMapX a ++ = CM { cm_var :: VarMap a ++ , cm_lit :: LiteralMap a ++ , cm_co :: CoercionMapG a ++ , cm_type :: TypeMapG a ++ , cm_cast :: CoreMapG (CoercionMapG a) ++ , cm_tick :: CoreMapG (TickishMap a) ++ , cm_app :: CoreMapG (CoreMapG a) ++ , cm_lam :: CoreMapG (BndrMap a) -- Note [Binders] ++ , cm_letn :: CoreMapG (CoreMapG (BndrMap a)) ++ , cm_letr :: ListMap CoreMapG (CoreMapG (ListMap BndrMap a)) ++ , cm_case :: CoreMapG (ListMap AltMap a) ++ , cm_ecase :: CoreMapG (TypeMapG a) -- Note [Empty case alternatives] ++ } ++ ++instance Eq (DeBruijn CoreExpr) where ++ D env1 e1 == D env2 e2 = go e1 e2 where ++ go (Var v1) (Var v2) ++ = case (lookupCME env1 v1, lookupCME env2 v2) of ++ (Just b1, Just b2) -> b1 == b2 ++ (Nothing, Nothing) -> v1 == v2 ++ _ -> False ++ go (Lit lit1) (Lit lit2) = lit1 == lit2 ++ go (Type t1) (Type t2) = D env1 t1 == D env2 t2 ++ go (Coercion co1) (Coercion co2) = D env1 co1 == D env2 co2 ++ go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2 ++ go (App f1 a1) (App f2 a2) = go f1 f2 && go a1 a2 ++ -- This seems a bit dodgy, see 'eqTickish' ++ go (Tick n1 e1) (Tick n2 e2) = n1 == n2 && go e1 e2 ++ ++ go (Lam b1 e1) (Lam b2 e2) ++ = D env1 (varType b1) == D env2 (varType b2) ++ && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2) ++ && D (extendCME env1 b1) e1 == D (extendCME env2 b2) e2 ++ ++ go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) ++ = go r1 r2 ++ && D (extendCME env1 v1) e1 == D (extendCME env2 v2) e2 ++ ++ go (Let (Rec ps1) e1) (Let (Rec ps2) e2) ++ = equalLength ps1 ps2 ++ && D env1' rs1 == D env2' rs2 ++ && D env1' e1 == D env2' e2 ++ where ++ (bs1,rs1) = unzip ps1 ++ (bs2,rs2) = unzip ps2 ++ env1' = extendCMEs env1 bs1 ++ env2' = extendCMEs env2 bs2 ++ ++ go (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) ++ | null a1 -- See Note [Empty case alternatives] ++ = null a2 && go e1 e2 && D env1 t1 == D env2 t2 ++ | otherwise ++ = go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2 ++ ++ go _ _ = False ++ ++emptyE :: CoreMapX a ++emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM ++ , cm_co = emptyTM, cm_type = emptyTM ++ , cm_cast = emptyTM, cm_app = emptyTM ++ , cm_lam = emptyTM, cm_letn = emptyTM ++ , cm_letr = emptyTM, cm_case = emptyTM ++ , cm_ecase = emptyTM, cm_tick = emptyTM } ++ ++instance TrieMap CoreMapX where ++ type Key CoreMapX = DeBruijn CoreExpr ++ emptyTM = emptyE ++ lookupTM = lkE ++ alterTM = xtE ++ foldTM = fdE ++ mapTM = mapE ++ filterTM = ftE ++ ++-------------------------- ++mapE :: (a->b) -> CoreMapX a -> CoreMapX b ++mapE f (CM { cm_var = cvar, cm_lit = clit ++ , cm_co = cco, cm_type = ctype ++ , cm_cast = ccast , cm_app = capp ++ , cm_lam = clam, cm_letn = cletn ++ , cm_letr = cletr, cm_case = ccase ++ , cm_ecase = cecase, cm_tick = ctick }) ++ = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit ++ , cm_co = mapTM f cco, cm_type = mapTM f ctype ++ , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp ++ , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn ++ , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase ++ , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick } ++ ++ftE :: (a->Bool) -> CoreMapX a -> CoreMapX a ++ftE f (CM { cm_var = cvar, cm_lit = clit ++ , cm_co = cco, cm_type = ctype ++ , cm_cast = ccast , cm_app = capp ++ , cm_lam = clam, cm_letn = cletn ++ , cm_letr = cletr, cm_case = ccase ++ , cm_ecase = cecase, cm_tick = ctick }) ++ = CM { cm_var = filterTM f cvar, cm_lit = filterTM f clit ++ , cm_co = filterTM f cco, cm_type = filterTM f ctype ++ , cm_cast = mapTM (filterTM f) ccast, cm_app = mapTM (filterTM f) capp ++ , cm_lam = mapTM (filterTM f) clam, cm_letn = mapTM (mapTM (filterTM f)) cletn ++ , cm_letr = mapTM (mapTM (filterTM f)) cletr, cm_case = mapTM (filterTM f) ccase ++ , cm_ecase = mapTM (filterTM f) cecase, cm_tick = mapTM (filterTM f) ctick } ++ ++-------------------------- ++lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a ++lookupCoreMap cm e = lookupTM e cm ++ ++extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a ++extendCoreMap m e v = alterTM e (\_ -> Just v) m ++ ++foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b ++foldCoreMap k z m = foldTM k m z ++ ++emptyCoreMap :: CoreMap a ++emptyCoreMap = emptyTM ++ ++instance Outputable a => Outputable (CoreMap a) where ++ ppr m = text "CoreMap elts" <+> ppr (foldTM (:) m []) ++ ++------------------------- ++fdE :: (a -> b -> b) -> CoreMapX a -> b -> b ++fdE k m ++ = foldTM k (cm_var m) ++ . foldTM k (cm_lit m) ++ . foldTM k (cm_co m) ++ . foldTM k (cm_type m) ++ . foldTM (foldTM k) (cm_cast m) ++ . foldTM (foldTM k) (cm_tick m) ++ . foldTM (foldTM k) (cm_app m) ++ . foldTM (foldTM k) (cm_lam m) ++ . foldTM (foldTM (foldTM k)) (cm_letn m) ++ . foldTM (foldTM (foldTM k)) (cm_letr m) ++ . foldTM (foldTM k) (cm_case m) ++ . foldTM (foldTM k) (cm_ecase m) ++ ++-- lkE: lookup in trie for expressions ++lkE :: DeBruijn CoreExpr -> CoreMapX a -> Maybe a ++lkE (D env expr) cm = go expr cm ++ where ++ go (Var v) = cm_var >.> lkVar env v ++ go (Lit l) = cm_lit >.> lookupTM l ++ go (Type t) = cm_type >.> lkG (D env t) ++ go (Coercion c) = cm_co >.> lkG (D env c) ++ go (Cast e c) = cm_cast >.> lkG (D env e) >=> lkG (D env c) ++ go (Tick tickish e) = cm_tick >.> lkG (D env e) >=> lkTickish tickish ++ go (App e1 e2) = cm_app >.> lkG (D env e2) >=> lkG (D env e1) ++ go (Lam v e) = cm_lam >.> lkG (D (extendCME env v) e) ++ >=> lkBndr env v ++ go (Let (NonRec b r) e) = cm_letn >.> lkG (D env r) ++ >=> lkG (D (extendCME env b) e) >=> lkBndr env b ++ go (Let (Rec prs) e) = let (bndrs,rhss) = unzip prs ++ env1 = extendCMEs env bndrs ++ in cm_letr ++ >.> lkList (lkG . D env1) rhss ++ >=> lkG (D env1 e) ++ >=> lkList (lkBndr env1) bndrs ++ go (Case e b ty as) -- See Note [Empty case alternatives] ++ | null as = cm_ecase >.> lkG (D env e) >=> lkG (D env ty) ++ | otherwise = cm_case >.> lkG (D env e) ++ >=> lkList (lkA (extendCME env b)) as ++ ++xtE :: DeBruijn CoreExpr -> XT a -> CoreMapX a -> CoreMapX a ++xtE (D env (Var v)) f m = m { cm_var = cm_var m ++ |> xtVar env v f } ++xtE (D env (Type t)) f m = m { cm_type = cm_type m ++ |> xtG (D env t) f } ++xtE (D env (Coercion c)) f m = m { cm_co = cm_co m ++ |> xtG (D env c) f } ++xtE (D _ (Lit l)) f m = m { cm_lit = cm_lit m |> alterTM l f } ++xtE (D env (Cast e c)) f m = m { cm_cast = cm_cast m |> xtG (D env e) ++ |>> xtG (D env c) f } ++xtE (D env (Tick t e)) f m = m { cm_tick = cm_tick m |> xtG (D env e) ++ |>> xtTickish t f } ++xtE (D env (App e1 e2)) f m = m { cm_app = cm_app m |> xtG (D env e2) ++ |>> xtG (D env e1) f } ++xtE (D env (Lam v e)) f m = m { cm_lam = cm_lam m ++ |> xtG (D (extendCME env v) e) ++ |>> xtBndr env v f } ++xtE (D env (Let (NonRec b r) e)) f m = m { cm_letn = cm_letn m ++ |> xtG (D (extendCME env b) e) ++ |>> xtG (D env r) ++ |>> xtBndr env b f } ++xtE (D env (Let (Rec prs) e)) f m = m { cm_letr = ++ let (bndrs,rhss) = unzip prs ++ env1 = extendCMEs env bndrs ++ in cm_letr m ++ |> xtList (xtG . D env1) rhss ++ |>> xtG (D env1 e) ++ |>> xtList (xtBndr env1) ++ bndrs f } ++xtE (D env (Case e b ty as)) f m ++ | null as = m { cm_ecase = cm_ecase m |> xtG (D env e) ++ |>> xtG (D env ty) f } ++ | otherwise = m { cm_case = cm_case m |> xtG (D env e) ++ |>> let env1 = extendCME env b ++ in xtList (xtA env1) as f } ++ ++-- TODO: this seems a bit dodgy, see 'eqTickish' ++type TickishMap a = Map.Map CoreTickish a ++lkTickish :: CoreTickish -> TickishMap a -> Maybe a ++lkTickish = lookupTM ++ ++xtTickish :: CoreTickish -> XT a -> TickishMap a -> TickishMap a ++xtTickish = alterTM ++ ++------------------------ ++data AltMap a -- A single alternative ++ = AM { am_deflt :: CoreMapG a ++ , am_data :: DNameEnv (CoreMapG a) ++ , am_lit :: LiteralMap (CoreMapG a) } ++ ++instance TrieMap AltMap where ++ type Key AltMap = CoreAlt ++ emptyTM = AM { am_deflt = emptyTM ++ , am_data = emptyDNameEnv ++ , am_lit = emptyTM } ++ lookupTM = lkA emptyCME ++ alterTM = xtA emptyCME ++ foldTM = fdA ++ mapTM = mapA ++ filterTM = ftA ++ ++instance Eq (DeBruijn CoreAlt) where ++ D env1 a1 == D env2 a2 = go a1 a2 where ++ go (Alt DEFAULT _ rhs1) (Alt DEFAULT _ rhs2) ++ = D env1 rhs1 == D env2 rhs2 ++ go (Alt (LitAlt lit1) _ rhs1) (Alt (LitAlt lit2) _ rhs2) ++ = lit1 == lit2 && D env1 rhs1 == D env2 rhs2 ++ go (Alt (DataAlt dc1) bs1 rhs1) (Alt (DataAlt dc2) bs2 rhs2) ++ = dc1 == dc2 && ++ D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2 ++ go _ _ = False ++ ++mapA :: (a->b) -> AltMap a -> AltMap b ++mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) ++ = AM { am_deflt = mapTM f adeflt ++ , am_data = mapTM (mapTM f) adata ++ , am_lit = mapTM (mapTM f) alit } ++ ++ftA :: (a->Bool) -> AltMap a -> AltMap a ++ftA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) ++ = AM { am_deflt = filterTM f adeflt ++ , am_data = mapTM (filterTM f) adata ++ , am_lit = mapTM (filterTM f) alit } ++ ++lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a ++lkA env (Alt DEFAULT _ rhs) = am_deflt >.> lkG (D env rhs) ++lkA env (Alt (LitAlt lit) _ rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs) ++lkA env (Alt (DataAlt dc) bs rhs) = am_data >.> lkDNamed dc ++ >=> lkG (D (extendCMEs env bs) rhs) ++ ++xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a ++xtA env (Alt DEFAULT _ rhs) f m = ++ m { am_deflt = am_deflt m |> xtG (D env rhs) f } ++xtA env (Alt (LitAlt l) _ rhs) f m = ++ m { am_lit = am_lit m |> alterTM l |>> xtG (D env rhs) f } ++xtA env (Alt (DataAlt d) bs rhs) f m = ++ m { am_data = am_data m |> xtDNamed d ++ |>> xtG (D (extendCMEs env bs) rhs) f } ++ ++fdA :: (a -> b -> b) -> AltMap a -> b -> b ++fdA k m = foldTM k (am_deflt m) ++ . foldTM (foldTM k) (am_data m) ++ . foldTM (foldTM k) (am_lit m) +diff --git a/compiler/GHC/Core/Opt/CallerCC.hs b/compiler/GHC/Core/Opt/CallerCC.hs +new file mode 100644 +index 0000000000..68875dc18f +--- /dev/null ++++ b/compiler/GHC/Core/Opt/CallerCC.hs +@@ -0,0 +1,223 @@ ++{-# LANGUAGE NamedFieldPuns #-} ++{-# LANGUAGE TypeApplications #-} ++{-# LANGUAGE DeriveGeneric #-} ++{-# LANGUAGE DeriveDataTypeable #-} ++{-# LANGUAGE DeriveAnyClass #-} ++{-# LANGUAGE DerivingStrategies #-} ++{-# LANGUAGE TupleSections #-} ++ ++-- | Adds cost-centers to call sites selected with the @-fprof-caller=...@ ++-- flag. ++module GHC.Core.Opt.CallerCC ++ ( addCallerCostCentres ++ , CallerCcFilter ++ , parseCallerCcFilter ++ ) where ++ ++import Data.Bifunctor ++import Data.Word (Word8) ++import Data.Maybe ++import qualified Text.Parsec as P ++ ++import Control.Applicative ++import Control.Monad.Trans.State.Strict ++import Data.Either ++import Control.Monad ++ ++import GHC.Prelude ++import GHC.Utils.Outputable as Outputable ++import GHC.Driver.Session ++import GHC.Driver.Ppr ++import GHC.Types.CostCentre ++import GHC.Types.CostCentre.State ++import GHC.Types.Name hiding (varName) ++import GHC.Unit.Module.Name ++import GHC.Unit.Module.ModGuts ++import GHC.Types.SrcLoc ++import GHC.Types.Var ++import GHC.Unit.Types ++import GHC.Data.FastString ++import GHC.Core ++import GHC.Core.Opt.Monad ++import GHC.Utils.Panic ++import qualified GHC.Utils.Binary as B ++ ++addCallerCostCentres :: ModGuts -> CoreM ModGuts ++addCallerCostCentres guts = do ++ dflags <- getDynFlags ++ let filters = callerCcFilters dflags ++ let env :: Env ++ env = Env ++ { thisModule = mg_module guts ++ , ccState = newCostCentreState ++ , dflags = dflags ++ , revParents = [] ++ , filters = filters ++ } ++ let guts' = guts { mg_binds = doCoreProgram env (mg_binds guts) ++ } ++ return guts' ++ ++doCoreProgram :: Env -> CoreProgram -> CoreProgram ++doCoreProgram env binds = flip evalState newCostCentreState $ do ++ mapM (doBind env) binds ++ ++doBind :: Env -> CoreBind -> M CoreBind ++doBind env (NonRec b rhs) = NonRec b <$> doExpr (addParent b env) rhs ++doBind env (Rec bs) = Rec <$> mapM doPair bs ++ where ++ doPair (b,rhs) = (b,) <$> doExpr (addParent b env) rhs ++ ++doExpr :: Env -> CoreExpr -> M CoreExpr ++doExpr env e@(Var v) ++ | needsCallSiteCostCentre env v = do ++ let nameDoc :: SDoc ++ nameDoc = withUserStyle alwaysQualify DefaultDepth $ ++ hcat (punctuate dot (map ppr (parents env))) <> parens (text "calling:" <> ppr v) ++ ++ ccName :: CcName ++ ccName = mkFastString $ showSDoc (dflags env) nameDoc ++ ccIdx <- getCCIndex' ccName ++ let span = case revParents env of ++ top:_ -> nameSrcSpan $ varName top ++ _ -> noSrcSpan ++ cc = NormalCC (ExprCC ccIdx) ccName (thisModule env) span ++ tick :: CoreTickish ++ tick = ProfNote cc True True ++ pure $ Tick tick e ++ | otherwise = pure e ++doExpr _env e@(Lit _) = pure e ++doExpr env (f `App` x) = App <$> doExpr env f <*> doExpr env x ++doExpr env (Lam b x) = Lam b <$> doExpr env x ++doExpr env (Let b rhs) = Let <$> doBind env b <*> doExpr env rhs ++doExpr env (Case scrut b ty alts) = ++ Case <$> doExpr env scrut <*> pure b <*> pure ty <*> mapM doAlt alts ++ where ++ doAlt (Alt con bs rhs) = Alt con bs <$> doExpr env rhs ++doExpr env (Cast expr co) = Cast <$> doExpr env expr <*> pure co ++doExpr env (Tick t e) = Tick t <$> doExpr env e ++doExpr _env e@(Type _) = pure e ++doExpr _env e@(Coercion _) = pure e ++ ++type M = State CostCentreState ++ ++getCCIndex' :: FastString -> M CostCentreIndex ++getCCIndex' name = state (getCCIndex name) ++ ++data Env = Env ++ { thisModule :: Module ++ , dflags :: DynFlags ++ , ccState :: CostCentreState ++ , revParents :: [Id] ++ , filters :: [CallerCcFilter] ++ } ++ ++addParent :: Id -> Env -> Env ++addParent i env = env { revParents = i : revParents env } ++ ++parents :: Env -> [Id] ++parents env = reverse (revParents env) ++ ++needsCallSiteCostCentre :: Env -> Id -> Bool ++needsCallSiteCostCentre env i = ++ any matches (filters env) ++ where ++ matches :: CallerCcFilter -> Bool ++ matches ccf = ++ checkModule && checkFunc ++ where ++ checkModule = ++ case ccfModuleName ccf of ++ Just modFilt ++ | Just iMod <- nameModule_maybe (varName i) ++ -> moduleName iMod == modFilt ++ | otherwise -> False ++ Nothing -> True ++ checkFunc = ++ occNameMatches (ccfFuncName ccf) (getOccName i) ++ ++data NamePattern ++ = PChar Char NamePattern ++ | PWildcard NamePattern ++ | PEnd ++ ++instance Outputable NamePattern where ++ ppr (PChar c rest) = char c <> ppr rest ++ ppr (PWildcard rest) = char '*' <> ppr rest ++ ppr PEnd = Outputable.empty ++ ++instance B.Binary NamePattern where ++ get bh = do ++ tag <- B.get bh ++ case tag :: Word8 of ++ 0 -> PChar <$> B.get bh <*> B.get bh ++ 1 -> PWildcard <$> B.get bh ++ 2 -> pure PEnd ++ _ -> panic "Binary(NamePattern): Invalid tag" ++ put_ bh (PChar x y) = B.put_ bh (0 :: Word8) >> B.put_ bh x >> B.put_ bh y ++ put_ bh (PWildcard x) = B.put_ bh (1 :: Word8) >> B.put_ bh x ++ put_ bh PEnd = B.put_ bh (2 :: Word8) ++ ++occNameMatches :: NamePattern -> OccName -> Bool ++occNameMatches pat = go pat . occNameString ++ where ++ go :: NamePattern -> String -> Bool ++ go PEnd "" = True ++ go (PChar c rest) (d:s) ++ = d == c && go rest s ++ go (PWildcard rest) s ++ = go rest s || go (PWildcard rest) (tail s) ++ go _ _ = False ++ ++type Parser = P.Parsec String () ++ ++parseNamePattern :: Parser NamePattern ++parseNamePattern = pattern ++ where ++ pattern = star <|> wildcard <|> char <|> end ++ star = PChar '*' <$ P.string "\\*" <*> pattern ++ wildcard = do ++ void $ P.char '*' ++ PWildcard <$> pattern ++ char = PChar <$> P.anyChar <*> pattern ++ end = PEnd <$ P.eof ++ ++data CallerCcFilter ++ = CallerCcFilter { ccfModuleName :: Maybe ModuleName ++ , ccfFuncName :: NamePattern ++ } ++ ++instance Outputable CallerCcFilter where ++ ppr ccf = ++ maybe (char '*') ppr (ccfModuleName ccf) ++ <> char '.' ++ <> ppr (ccfFuncName ccf) ++ ++instance B.Binary CallerCcFilter where ++ get bh = CallerCcFilter <$> B.get bh <*> B.get bh ++ put_ bh (CallerCcFilter x y) = B.put_ bh x >> B.put_ bh y ++ ++parseCallerCcFilter :: String -> Either String CallerCcFilter ++parseCallerCcFilter = ++ first show . P.parse parseCallerCcFilter' "caller-CC filter" ++ ++parseCallerCcFilter' :: Parser CallerCcFilter ++parseCallerCcFilter' = ++ CallerCcFilter ++ <$> moduleFilter ++ <* P.char '.' ++ <*> parseNamePattern ++ where ++ moduleFilter :: Parser (Maybe ModuleName) ++ moduleFilter = ++ (Just . mkModuleName <$> moduleName) ++ <|> ++ (Nothing <$ P.char '*') ++ ++ moduleName :: Parser String ++ moduleName = do ++ c <- P.upper ++ cs <- some $ P.upper <|> P.lower <|> P.digit <|> P.oneOf "_" ++ rest <- optional $ P.try $ P.char '.' >> fmap ('.':) moduleName ++ return $ c : (cs ++ fromMaybe "" rest) ++ +diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs +index 68b9f00798..b93935816f 100644 +--- a/compiler/GHC/Hs/Binds.hs ++++ b/compiler/GHC/Hs/Binds.hs +@@ -242,7 +242,7 @@ data HsBindLR idL idR + -- type Int -> forall a'. a' -> a' + -- Notice that the coercion captures the free a'. + +- fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any ++ fun_tick :: [CoreTickish] -- ^ Ticks to put on the rhs, if any + } + + -- | Pattern Binding +@@ -262,7 +262,7 @@ data HsBindLR idL idR + pat_ext :: XPatBind idL idR, -- ^ See Note [Bind free vars] + pat_lhs :: LPat idL, + pat_rhs :: GRHSs idR (LHsExpr idR), +- pat_ticks :: ([Tickish Id], [[Tickish Id]]) ++ pat_ticks :: ([CoreTickish], [[CoreTickish]]) + -- ^ Ticks to put on the rhs, if any, and ticks to put on + -- the bound variables. + } +diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs +index 09b9f6ef8a..f95fd4ff1b 100644 +--- a/compiler/GHC/Hs/Expr.hs ++++ b/compiler/GHC/Hs/Expr.hs +@@ -601,7 +601,7 @@ data HsExpr p + + | HsTick + (XTick p) +- (Tickish (IdP p)) ++ CoreTickish + (LHsExpr p) -- sub-expression + + | HsBinTick +diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs +index 07113a4e82..aaba4e3499 100644 +--- a/compiler/GHC/StgToCmm/Expr.hs ++++ b/compiler/GHC/StgToCmm/Expr.hs +@@ -1147,7 +1147,7 @@ emitEnter fun = do + -- | Generate Cmm code for a tick. Depending on the type of Tickish, + -- this will either generate actual Cmm instrumentation code, or + -- simply pass on the annotation as a @CmmTickish@. +-cgTick :: Tickish Id -> FCode () ++cgTick :: StgTickish -> FCode () + cgTick tick + = do { dflags <- getDynFlags + ; case tick of +diff --git a/compiler/Language/Haskell/Syntax/Binds.hs b/compiler/Language/Haskell/Syntax/Binds.hs +new file mode 100644 +index 0000000000..ebd93d3ecd +--- /dev/null ++++ b/compiler/Language/Haskell/Syntax/Binds.hs +@@ -0,0 +1,944 @@ ++{-# LANGUAGE ConstraintKinds #-} ++{-# LANGUAGE DeriveDataTypeable #-} ++{-# LANGUAGE DeriveFunctor #-} ++{-# LANGUAGE FlexibleContexts #-} ++{-# LANGUAGE FlexibleInstances #-} ++{-# LANGUAGE LambdaCase #-} ++{-# LANGUAGE ScopedTypeVariables #-} ++{-# LANGUAGE TypeApplications #-} ++{-# LANGUAGE TypeFamilies #-} ++{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] ++ -- in module Language.Haskell.Syntax.Extension ++{-# LANGUAGE ViewPatterns #-} ++ ++ ++{- ++(c) The University of Glasgow 2006 ++(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 ++ ++\section[HsBinds]{Abstract syntax: top-level bindings and signatures} ++ ++Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. ++-} ++ ++-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* ++module Language.Haskell.Syntax.Binds where ++ ++import GHC.Prelude ++ ++import {-# SOURCE #-} Language.Haskell.Syntax.Expr ++ ( LHsExpr ++ , MatchGroup ++ , GRHSs ) ++import {-# SOURCE #-} Language.Haskell.Syntax.Pat ++ ( LPat ) ++ ++import Language.Haskell.Syntax.Extension ++import Language.Haskell.Syntax.Type ++import GHC.Core ++import GHC.Tc.Types.Evidence ++import GHC.Core.Type ++import GHC.Types.Basic ++import GHC.Types.SourceText ++import GHC.Types.SrcLoc as SrcLoc ++import GHC.Types.Var ++import GHC.Types.Fixity ++import GHC.Data.Bag ++import GHC.Data.BooleanFormula (LBooleanFormula) ++ ++import GHC.Utils.Outputable ++ ++import Data.Data hiding ( Fixity ) ++import Data.Void ++ ++{- ++************************************************************************ ++* * ++\subsection{Bindings: @BindGroup@} ++* * ++************************************************************************ ++ ++Global bindings (where clauses) ++-} ++ ++-- During renaming, we need bindings where the left-hand sides ++-- have been renamed but the right-hand sides have not. ++-- Other than during renaming, these will be the same. ++ ++-- | Haskell Local Bindings ++type HsLocalBinds id = HsLocalBindsLR id id ++ ++-- | Located Haskell local bindings ++type LHsLocalBinds id = XRec id (HsLocalBinds id) ++ ++-- | Haskell Local Bindings with separate Left and Right identifier types ++-- ++-- Bindings in a 'let' expression ++-- or a 'where' clause ++data HsLocalBindsLR idL idR ++ = HsValBinds ++ (XHsValBinds idL idR) ++ (HsValBindsLR idL idR) ++ -- ^ Haskell Value Bindings ++ ++ -- There should be no pattern synonyms in the HsValBindsLR ++ -- These are *local* (not top level) bindings ++ -- The parser accepts them, however, leaving the ++ -- renamer to report them ++ ++ | HsIPBinds ++ (XHsIPBinds idL idR) ++ (HsIPBinds idR) ++ -- ^ Haskell Implicit Parameter Bindings ++ ++ | EmptyLocalBinds (XEmptyLocalBinds idL idR) ++ -- ^ Empty Local Bindings ++ ++ | XHsLocalBindsLR ++ !(XXHsLocalBindsLR idL idR) ++ ++type LHsLocalBindsLR idL idR = XRec idL (HsLocalBindsLR idL idR) ++ ++ ++-- | Haskell Value Bindings ++type HsValBinds id = HsValBindsLR id id ++ ++-- | Haskell Value bindings with separate Left and Right identifier types ++-- (not implicit parameters) ++-- Used for both top level and nested bindings ++-- May contain pattern synonym bindings ++data HsValBindsLR idL idR ++ = -- | Value Bindings In ++ -- ++ -- Before renaming RHS; idR is always RdrName ++ -- Not dependency analysed ++ -- Recursive by default ++ ValBinds ++ (XValBinds idL idR) ++ (LHsBindsLR idL idR) [LSig idR] ++ ++ -- | Value Bindings Out ++ -- ++ -- After renaming RHS; idR can be Name or Id Dependency analysed, ++ -- later bindings in the list may depend on earlier ones. ++ | XValBindsLR ++ !(XXValBindsLR idL idR) ++ ++-- --------------------------------------------------------------------- ++ ++-- | Located Haskell Binding ++type LHsBind id = LHsBindLR id id ++ ++-- | Located Haskell Bindings ++type LHsBinds id = LHsBindsLR id id ++ ++-- | Haskell Binding ++type HsBind id = HsBindLR id id ++ ++-- | Located Haskell Bindings with separate Left and Right identifier types ++type LHsBindsLR idL idR = Bag (LHsBindLR idL idR) ++ ++-- | Located Haskell Binding with separate Left and Right identifier types ++type LHsBindLR idL idR = XRec idL (HsBindLR idL idR) ++ ++{- Note [FunBind vs PatBind] ++ ~~~~~~~~~~~~~~~~~~~~~~~~~ ++The distinction between FunBind and PatBind is a bit subtle. FunBind covers ++patterns which resemble function bindings and simple variable bindings. ++ ++ f x = e ++ f !x = e ++ f = e ++ !x = e -- FunRhs has SrcStrict ++ x `f` y = e -- FunRhs has Infix ++ ++The actual patterns and RHSs of a FunBind are encoding in fun_matches. ++The m_ctxt field of each Match in fun_matches will be FunRhs and carries ++two bits of information about the match, ++ ++ * The mc_fixity field on each Match describes the fixity of the ++ function binder in that match. E.g. this is legal: ++ f True False = e1 ++ True `f` True = e2 ++ ++ * The mc_strictness field is used /only/ for nullary FunBinds: ones ++ with one Match, which has no pats. For these, it describes whether ++ the match is decorated with a bang (e.g. `!x = e`). ++ ++By contrast, PatBind represents data constructor patterns, as well as a few ++other interesting cases. Namely, ++ ++ Just x = e ++ (x) = e ++ x :: Ty = e ++-} ++ ++-- | Haskell Binding with separate Left and Right id's ++data HsBindLR idL idR ++ = -- | Function-like Binding ++ -- ++ -- FunBind is used for both functions @f x = e@ ++ -- and variables @f = \x -> e@ ++ -- and strict variables @!x = x + 1@ ++ -- ++ -- Reason 1: Special case for type inference: see 'GHC.Tc.Gen.Bind.tcMonoBinds'. ++ -- ++ -- Reason 2: Instance decls can only have FunBinds, which is convenient. ++ -- If you change this, you'll need to change e.g. rnMethodBinds ++ -- ++ -- But note that the form @f :: a->a = ...@ ++ -- parses as a pattern binding, just like ++ -- @(f :: a -> a) = ... @ ++ -- ++ -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their ++ -- 'MatchContext'. See Note [FunBind vs PatBind] for ++ -- details about the relationship between FunBind and PatBind. ++ -- ++ -- 'GHC.Parser.Annotation.AnnKeywordId's ++ -- ++ -- - 'GHC.Parser.Annotation.AnnFunId', attached to each element of fun_matches ++ -- ++ -- - 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere', ++ -- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose', ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ FunBind { ++ ++ fun_ext :: XFunBind idL idR, ++ ++ -- ^ After the renamer (but before the type-checker), this contains the ++ -- locally-bound free variables of this defn. See Note [Bind free vars] ++ -- ++ -- After the type-checker, this contains a coercion from the type of ++ -- the MatchGroup to the type of the Id. Example: ++ -- ++ -- @ ++ -- f :: Int -> forall a. a -> a ++ -- f x y = y ++ -- @ ++ -- ++ -- Then the MatchGroup will have type (Int -> a' -> a') ++ -- (with a free type variable a'). The coercion will take ++ -- a CoreExpr of this type and convert it to a CoreExpr of ++ -- type Int -> forall a'. a' -> a' ++ -- Notice that the coercion captures the free a'. ++ ++ fun_id :: LIdP idL, -- Note [fun_id in Match] in GHC.Hs.Expr ++ ++ fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload ++ ++ fun_tick :: [CoreTickish] -- ^ Ticks to put on the rhs, if any ++ } ++ ++ -- | Pattern Binding ++ -- ++ -- The pattern is never a simple variable; ++ -- That case is done by FunBind. ++ -- See Note [FunBind vs PatBind] for details about the ++ -- relationship between FunBind and PatBind. ++ ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang', ++ -- 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere', ++ -- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose', ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | PatBind { ++ pat_ext :: XPatBind idL idR, -- ^ See Note [Bind free vars] ++ pat_lhs :: LPat idL, ++ pat_rhs :: GRHSs idR (LHsExpr idR), ++ pat_ticks :: ([CoreTickish], [[CoreTickish]]) ++ -- ^ Ticks to put on the rhs, if any, and ticks to put on ++ -- the bound variables. ++ } ++ ++ -- | Variable Binding ++ -- ++ -- Dictionary binding and suchlike. ++ -- All VarBinds are introduced by the type checker ++ | VarBind { ++ var_ext :: XVarBind idL idR, ++ var_id :: IdP idL, ++ var_rhs :: LHsExpr idR -- ^ Located only for consistency ++ } ++ ++ -- | Abstraction Bindings ++ | AbsBinds { -- Binds abstraction; TRANSLATION ++ abs_ext :: XAbsBinds idL idR, ++ abs_tvs :: [TyVar], ++ abs_ev_vars :: [EvVar], -- ^ Includes equality constraints ++ ++ -- | AbsBinds only gets used when idL = idR after renaming, ++ -- but these need to be idL's for the collect... code in HsUtil ++ -- to have the right type ++ abs_exports :: [ABExport idL], ++ ++ -- | Evidence bindings ++ -- Why a list? See "GHC.Tc.TyCl.Instance" ++ -- Note [Typechecking plan for instance declarations] ++ abs_ev_binds :: [TcEvBinds], ++ ++ -- | Typechecked user bindings ++ abs_binds :: LHsBinds idL, ++ ++ abs_sig :: Bool -- See Note [The abs_sig field of AbsBinds] ++ } ++ ++ -- | Patterns Synonym Binding ++ | PatSynBind ++ (XPatSynBind idL idR) ++ (PatSynBind idL idR) ++ -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern', ++ -- 'GHC.Parser.Annotation.AnnLarrow','GHC.Parser.Annotation.AnnEqual', ++ -- 'GHC.Parser.Annotation.AnnWhere' ++ -- 'GHC.Parser.Annotation.AnnOpen' @'{'@,'GHC.Parser.Annotation.AnnClose' @'}'@ ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ ++ | XHsBindsLR !(XXHsBindsLR idL idR) ++ ++ ++ -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] ++ -- ++ -- Creates bindings for (polymorphic, overloaded) poly_f ++ -- in terms of monomorphic, non-overloaded mono_f ++ -- ++ -- Invariants: ++ -- 1. 'binds' binds mono_f ++ -- 2. ftvs is a subset of tvs ++ -- 3. ftvs includes all tyvars free in ds ++ -- ++ -- See Note [AbsBinds] ++ ++-- | Abstraction Bindings Export ++data ABExport p ++ = ABE { abe_ext :: XABE p ++ , abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id ++ , abe_mono :: IdP p ++ , abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper] ++ -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly ++ , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas ++ } ++ | XABExport !(XXABExport p) ++ ++ ++-- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern', ++-- 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnLarrow', ++-- 'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen' @'{'@, ++-- 'GHC.Parser.Annotation.AnnClose' @'}'@, ++ ++-- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ ++-- | Pattern Synonym binding ++data PatSynBind idL idR ++ = PSB { psb_ext :: XPSB idL idR, -- ^ Post renaming, FVs. ++ -- See Note [Bind free vars] ++ psb_id :: LIdP idL, -- ^ Name of the pattern synonym ++ psb_args :: HsPatSynDetails idR, -- ^ Formal parameter names ++ psb_def :: LPat idR, -- ^ Right-hand side ++ psb_dir :: HsPatSynDir idR -- ^ Directionality ++ } ++ | XPatSynBind !(XXPatSynBind idL idR) ++ ++{- ++Note [AbsBinds] ++~~~~~~~~~~~~~~~ ++The AbsBinds constructor is used in the output of the type checker, to ++record *typechecked* and *generalised* bindings. Specifically ++ ++ AbsBinds { abs_tvs = tvs ++ , abs_ev_vars = [d1,d2] ++ , abs_exports = [ABE { abe_poly = fp, abe_mono = fm ++ , abe_wrap = fwrap } ++ ABE { slly for g } ] ++ , abs_ev_binds = DBINDS ++ , abs_binds = BIND[fm,gm] } ++ ++where 'BIND' binds the monomorphic Ids 'fm' and 'gm', means ++ ++ fp = fwrap [/\ tvs. \d1 d2. letrec { DBINDS ] ++ [ ; BIND[fm,gm] } ] ++ [ in fm ] ++ ++ gp = ...same again, with gm instead of fm ++ ++The 'fwrap' is an impedance-matcher that typically does nothing; see ++Note [ABExport wrapper]. ++ ++This is a pretty bad translation, because it duplicates all the bindings. ++So the desugarer tries to do a better job: ++ ++ fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of ++ (fm,gm) -> fm ++ ..ditto for gp.. ++ ++ tp = /\ [a,b] -> \ [d1,d2] -> letrec { DBINDS; BIND } ++ in (fm,gm) ++ ++In general: ++ ++ * abs_tvs are the type variables over which the binding group is ++ generalised ++ * abs_ev_var are the evidence variables (usually dictionaries) ++ over which the binding group is generalised ++ * abs_binds are the monomorphic bindings ++ * abs_ex_binds are the evidence bindings that wrap the abs_binds ++ * abs_exports connects the monomorphic Ids bound by abs_binds ++ with the polymorphic Ids bound by the AbsBinds itself. ++ ++For example, consider a module M, with this top-level binding, where ++there is no type signature for M.reverse, ++ M.reverse [] = [] ++ M.reverse (x:xs) = M.reverse xs ++ [x] ++ ++In Hindley-Milner, a recursive binding is typechecked with the ++*recursive* uses being *monomorphic*. So after typechecking *and* ++desugaring we will get something like this ++ ++ M.reverse :: forall a. [a] -> [a] ++ = /\a. letrec ++ reverse :: [a] -> [a] = \xs -> case xs of ++ [] -> [] ++ (x:xs) -> reverse xs ++ [x] ++ in reverse ++ ++Notice that 'M.reverse' is polymorphic as expected, but there is a local ++definition for plain 'reverse' which is *monomorphic*. The type variable ++'a' scopes over the entire letrec. ++ ++That's after desugaring. What about after type checking but before ++desugaring? That's where AbsBinds comes in. It looks like this: ++ ++ AbsBinds { abs_tvs = [a] ++ , abs_ev_vars = [] ++ , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a], ++ , abe_mono = reverse :: [a] -> [a]}] ++ , abs_ev_binds = {} ++ , abs_binds = { reverse :: [a] -> [a] ++ = \xs -> case xs of ++ [] -> [] ++ (x:xs) -> reverse xs ++ [x] } } ++ ++Here, ++ ++ * abs_tvs says what type variables are abstracted over the binding ++ group, just 'a' in this case. ++ * abs_binds is the *monomorphic* bindings of the group ++ * abs_exports describes how to get the polymorphic Id 'M.reverse' ++ from the monomorphic one 'reverse' ++ ++Notice that the *original* function (the polymorphic one you thought ++you were defining) appears in the abe_poly field of the ++abs_exports. The bindings in abs_binds are for fresh, local, Ids with ++a *monomorphic* Id. ++ ++If there is a group of mutually recursive (see Note [Polymorphic ++recursion]) functions without type signatures, we get one AbsBinds ++with the monomorphic versions of the bindings in abs_binds, and one ++element of abe_exports for each variable bound in the mutually ++recursive group. This is true even for pattern bindings. Example: ++ (f,g) = (\x -> x, f) ++After type checking we get ++ AbsBinds { abs_tvs = [a] ++ , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a ++ , abe_mono = f :: a -> a } ++ , ABE { abe_poly = M.g :: forall a. a -> a ++ , abe_mono = g :: a -> a }] ++ , abs_binds = { (f,g) = (\x -> x, f) } ++ ++Note [Polymorphic recursion] ++~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ++Consider ++ Rec { f x = ...(g ef)... ++ ++ ; g :: forall a. [a] -> [a] ++ ; g y = ...(f eg)... } ++ ++These bindings /are/ mutually recursive (f calls g, and g calls f). ++But we can use the type signature for g to break the recursion, ++like this: ++ ++ 1. Add g :: forall a. [a] -> [a] to the type environment ++ ++ 2. Typecheck the definition of f, all by itself, ++ including generalising it to find its most general ++ type, say f :: forall b. b -> b -> [b] ++ ++ 3. Extend the type environment with that type for f ++ ++ 4. Typecheck the definition of g, all by itself, ++ checking that it has the type claimed by its signature ++ ++Steps 2 and 4 each generate a separate AbsBinds, so we end ++up with ++ Rec { AbsBinds { ...for f ... } ++ ; AbsBinds { ...for g ... } } ++ ++This approach allows both f and to call each other ++polymorphically, even though only g has a signature. ++ ++We get an AbsBinds that encompasses multiple source-program ++bindings only when ++ * Each binding in the group has at least one binder that ++ lacks a user type signature ++ * The group forms a strongly connected component ++ ++ ++Note [The abs_sig field of AbsBinds] ++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ++The abs_sig field supports a couple of special cases for bindings. ++Consider ++ ++ x :: Num a => (# a, a #) ++ x = (# 3, 4 #) ++ ++The general desugaring for AbsBinds would give ++ ++ x = /\a. \ ($dNum :: Num a) -> ++ letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in ++ xm ++ ++But that has an illegal let-binding for an unboxed tuple. In this ++case we'd prefer to generate the (more direct) ++ ++ x = /\ a. \ ($dNum :: Num a) -> ++ (# fromInteger $dNum 3, fromInteger $dNum 4 #) ++ ++A similar thing happens with representation-polymorphic defns ++(#11405): ++ ++ undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a ++ undef = error "undef" ++ ++Again, the vanilla desugaring gives a local let-binding for a ++representation-polymorphic (undefm :: a), which is illegal. But ++again we can desugar without a let: ++ ++ undef = /\ a. \ (d:HasCallStack) -> error a d "undef" ++ ++The abs_sig field supports this direct desugaring, with no local ++let-binding. When abs_sig = True ++ ++ * the abs_binds is single FunBind ++ ++ * the abs_exports is a singleton ++ ++ * we have a complete type sig for binder ++ and hence the abs_binds is non-recursive ++ (it binds the mono_id but refers to the poly_id ++ ++These properties are exploited in GHC.HsToCore.Binds.dsAbsBinds to ++generate code without a let-binding. ++ ++Note [ABExport wrapper] ++~~~~~~~~~~~~~~~~~~~~~~~ ++Consider ++ (f,g) = (\x.x, \y.y) ++This ultimately desugars to something like this: ++ tup :: forall a b. (a->a, b->b) ++ tup = /\a b. (\x:a.x, \y:b.y) ++ f :: forall a. a -> a ++ f = /\a. case tup a Any of ++ (fm::a->a,gm:Any->Any) -> fm ++ ...similarly for g... ++ ++The abe_wrap field deals with impedance-matching between ++ (/\a b. case tup a b of { (f,g) -> f }) ++and the thing we really want, which may have fewer type ++variables. The action happens in GHC.Tc.Gen.Bind.mkExport. ++ ++Note [Bind free vars] ++~~~~~~~~~~~~~~~~~~~~~ ++The bind_fvs field of FunBind and PatBind records the free variables ++of the definition. It is used for the following purposes ++ ++a) Dependency analysis prior to type checking ++ (see GHC.Tc.Gen.Bind.tc_group) ++ ++b) Deciding whether we can do generalisation of the binding ++ (see GHC.Tc.Gen.Bind.decideGeneralisationPlan) ++ ++c) Deciding whether the binding can be used in static forms ++ (see GHC.Tc.Gen.Expr.checkClosedInStaticForm for the HsStatic case and ++ GHC.Tc.Gen.Bind.isClosedBndrGroup). ++ ++Specifically, ++ ++ * bind_fvs includes all free vars that are defined in this module ++ (including top-level things and lexically scoped type variables) ++ ++ * bind_fvs excludes imported vars; this is just to keep the set smaller ++ ++ * Before renaming, and after typechecking, the field is unused; ++ it's just an error thunk ++-} ++ ++ ++{- ++************************************************************************ ++* * ++ Implicit parameter bindings ++* * ++************************************************************************ ++-} ++ ++-- | Haskell Implicit Parameter Bindings ++data HsIPBinds id ++ = IPBinds ++ (XIPBinds id) ++ [LIPBind id] ++ -- TcEvBinds -- Only in typechecker output; binds ++ -- -- uses of the implicit parameters ++ | XHsIPBinds !(XXHsIPBinds id) ++ ++ ++-- | Located Implicit Parameter Binding ++type LIPBind id = XRec id (IPBind id) ++-- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a ++-- list ++ ++-- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ ++-- | Implicit parameter bindings. ++-- ++-- These bindings start off as (Left "x") in the parser and stay ++-- that way until after type-checking when they are replaced with ++-- (Right d), where "d" is the name of the dictionary holding the ++-- evidence for the implicit parameter. ++-- ++-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual' ++ ++-- For details on above see note [Api annotations] in GHC.Parser.Annotation ++data IPBind id ++ = IPBind ++ (XCIPBind id) ++ (Either (XRec id HsIPName) (IdP id)) ++ (LHsExpr id) ++ | XIPBind !(XXIPBind id) ++ ++{- ++************************************************************************ ++* * ++\subsection{@Sig@: type signatures and value-modifying user pragmas} ++* * ++************************************************************************ ++ ++It is convenient to lump ``value-modifying'' user-pragmas (e.g., ++``specialise this function to these four types...'') in with type ++signatures. Then all the machinery to move them into place, etc., ++serves for both. ++-} ++ ++-- | Located Signature ++type LSig pass = XRec pass (Sig pass) ++ ++-- | Signatures and pragmas ++data Sig pass ++ = -- | An ordinary type signature ++ -- ++ -- > f :: Num a => a -> a ++ -- ++ -- After renaming, this list of Names contains the named ++ -- wildcards brought into scope by this signature. For a signature ++ -- @_ -> _a -> Bool@, the renamer will leave the unnamed wildcard @_@ ++ -- untouched, and the named wildcard @_a@ is then replaced with ++ -- fresh meta vars in the type. Their names are stored in the type ++ -- signature that brought them into scope, in this third field to be ++ -- more specific. ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon', ++ -- 'GHC.Parser.Annotation.AnnComma' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ TypeSig ++ (XTypeSig pass) ++ [LIdP pass] -- LHS of the signature; e.g. f,g,h :: blah ++ (LHsSigWcType pass) -- RHS of the signature; can have wildcards ++ ++ -- | A pattern synonym type signature ++ -- ++ -- > pattern Single :: () => (Show a) => a -> [a] ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern', ++ -- 'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnForall' ++ -- 'GHC.Parser.Annotation.AnnDot','GHC.Parser.Annotation.AnnDarrow' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | PatSynSig (XPatSynSig pass) [LIdP pass] (LHsSigType pass) ++ -- P :: forall a b. Req => Prov => ty ++ ++ -- | A signature for a class method ++ -- False: ordinary class-method signature ++ -- True: generic-default class method signature ++ -- e.g. class C a where ++ -- op :: a -> a -- Ordinary ++ -- default op :: Eq a => a -> a -- Generic default ++ -- No wildcards allowed here ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDefault', ++ -- 'GHC.Parser.Annotation.AnnDcolon' ++ | ClassOpSig (XClassOpSig pass) Bool [LIdP pass] (LHsSigType pass) ++ ++ -- | A type signature in generated code, notably the code ++ -- generated for record selectors. We simply record ++ -- the desired Id itself, replete with its name, type ++ -- and IdDetails. Otherwise it's just like a type ++ -- signature: there should be an accompanying binding ++ | IdSig (XIdSig pass) Id ++ ++ -- | An ordinary fixity declaration ++ -- ++ -- > infixl 8 *** ++ -- ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnInfix', ++ -- 'GHC.Parser.Annotation.AnnVal' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | FixSig (XFixSig pass) (FixitySig pass) ++ ++ -- | An inline pragma ++ -- ++ -- > {#- INLINE f #-} ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : ++ -- 'GHC.Parser.Annotation.AnnOpen' @'{-\# INLINE'@ and @'['@, ++ -- 'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnOpen', ++ -- 'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnTilde', ++ -- 'GHC.Parser.Annotation.AnnClose' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | InlineSig (XInlineSig pass) ++ (LIdP pass) -- Function name ++ InlinePragma -- Never defaultInlinePragma ++ ++ -- | A specialisation pragma ++ -- ++ -- > {-# SPECIALISE f :: Int -> Int #-} ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', ++ -- 'GHC.Parser.Annotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@, ++ -- 'GHC.Parser.Annotation.AnnTilde', ++ -- 'GHC.Parser.Annotation.AnnVal', ++ -- 'GHC.Parser.Annotation.AnnClose' @']'@ and @'\#-}'@, ++ -- 'GHC.Parser.Annotation.AnnDcolon' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | SpecSig (XSpecSig pass) ++ (LIdP pass) -- Specialise a function or datatype ... ++ [LHsSigType pass] -- ... to these types ++ InlinePragma -- The pragma on SPECIALISE_INLINE form. ++ -- If it's just defaultInlinePragma, then we said ++ -- SPECIALISE, not SPECIALISE_INLINE ++ ++ -- | A specialisation pragma for instance declarations only ++ -- ++ -- > {-# SPECIALISE instance Eq [Int] #-} ++ -- ++ -- (Class tys); should be a specialisation of the ++ -- current instance declaration ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', ++ -- 'GHC.Parser.Annotation.AnnInstance','GHC.Parser.Annotation.AnnClose' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass) ++ -- Note [Pragma source text] in GHC.Types.SourceText ++ ++ -- | A minimal complete definition pragma ++ -- ++ -- > {-# MINIMAL a | (b, c | (d | e)) #-} ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', ++ -- 'GHC.Parser.Annotation.AnnVbar','GHC.Parser.Annotation.AnnComma', ++ -- 'GHC.Parser.Annotation.AnnClose' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | MinimalSig (XMinimalSig pass) ++ SourceText (LBooleanFormula (LIdP pass)) ++ -- Note [Pragma source text] in GHC.Types.SourceText ++ ++ -- | A "set cost centre" pragma for declarations ++ -- ++ -- > {-# SCC funName #-} ++ -- ++ -- or ++ -- ++ -- > {-# SCC funName "cost_centre_name" #-} ++ ++ | SCCFunSig (XSCCFunSig pass) ++ SourceText -- Note [Pragma source text] in GHC.Types.SourceText ++ (LIdP pass) -- Function name ++ (Maybe (XRec pass StringLiteral)) ++ -- | A complete match pragma ++ -- ++ -- > {-# COMPLETE C, D [:: T] #-} ++ -- ++ -- Used to inform the pattern match checker about additional ++ -- complete matchings which, for example, arise from pattern ++ -- synonym definitions. ++ | CompleteMatchSig (XCompleteMatchSig pass) ++ SourceText ++ (XRec pass [LIdP pass]) ++ (Maybe (LIdP pass)) ++ | XSig !(XXSig pass) ++ ++-- | Located Fixity Signature ++type LFixitySig pass = XRec pass (FixitySig pass) ++ ++-- | Fixity Signature ++data FixitySig pass = FixitySig (XFixitySig pass) [LIdP pass] Fixity ++ | XFixitySig !(XXFixitySig pass) ++ ++-- | Type checker Specialisation Pragmas ++-- ++-- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer ++data TcSpecPrags ++ = IsDefaultMethod -- ^ Super-specialised: a default method should ++ -- be macro-expanded at every call site ++ | SpecPrags [LTcSpecPrag] ++ deriving Data ++ ++-- | Located Type checker Specification Pragmas ++type LTcSpecPrag = Located TcSpecPrag ++ ++-- | Type checker Specification Pragma ++data TcSpecPrag ++ = SpecPrag ++ Id ++ HsWrapper ++ InlinePragma ++ -- ^ The Id to be specialised, a wrapper that specialises the ++ -- polymorphic function, and inlining spec for the specialised function ++ deriving Data ++ ++noSpecPrags :: TcSpecPrags ++noSpecPrags = SpecPrags [] ++ ++hasSpecPrags :: TcSpecPrags -> Bool ++hasSpecPrags (SpecPrags ps) = not (null ps) ++hasSpecPrags IsDefaultMethod = False ++ ++isDefaultMethod :: TcSpecPrags -> Bool ++isDefaultMethod IsDefaultMethod = True ++isDefaultMethod (SpecPrags {}) = False ++ ++isFixityLSig :: forall p. UnXRec p => LSig p -> Bool ++isFixityLSig (unXRec @p -> FixSig {}) = True ++isFixityLSig _ = False ++ ++isTypeLSig :: forall p. UnXRec p => LSig p -> Bool -- Type signatures ++isTypeLSig (unXRec @p -> TypeSig {}) = True ++isTypeLSig (unXRec @p -> ClassOpSig {}) = True ++isTypeLSig (unXRec @p -> IdSig {}) = True ++isTypeLSig _ = False ++ ++isSpecLSig :: forall p. UnXRec p => LSig p -> Bool ++isSpecLSig (unXRec @p -> SpecSig {}) = True ++isSpecLSig _ = False ++ ++isSpecInstLSig :: forall p. UnXRec p => LSig p -> Bool ++isSpecInstLSig (unXRec @p -> SpecInstSig {}) = True ++isSpecInstLSig _ = False ++ ++isPragLSig :: forall p. UnXRec p => LSig p -> Bool ++-- Identifies pragmas ++isPragLSig (unXRec @p -> SpecSig {}) = True ++isPragLSig (unXRec @p -> InlineSig {}) = True ++isPragLSig (unXRec @p -> SCCFunSig {}) = True ++isPragLSig (unXRec @p -> CompleteMatchSig {}) = True ++isPragLSig _ = False ++ ++isInlineLSig :: forall p. UnXRec p => LSig p -> Bool ++-- Identifies inline pragmas ++isInlineLSig (unXRec @p -> InlineSig {}) = True ++isInlineLSig _ = False ++ ++isMinimalLSig :: forall p. UnXRec p => LSig p -> Bool ++isMinimalLSig (unXRec @p -> MinimalSig {}) = True ++isMinimalLSig _ = False ++ ++isSCCFunSig :: forall p. UnXRec p => LSig p -> Bool ++isSCCFunSig (unXRec @p -> SCCFunSig {}) = True ++isSCCFunSig _ = False ++ ++isCompleteMatchSig :: forall p. UnXRec p => LSig p -> Bool ++isCompleteMatchSig (unXRec @p -> CompleteMatchSig {} ) = True ++isCompleteMatchSig _ = False ++ ++hsSigDoc :: Sig name -> SDoc ++hsSigDoc (TypeSig {}) = text "type signature" ++hsSigDoc (PatSynSig {}) = text "pattern synonym signature" ++hsSigDoc (ClassOpSig _ is_deflt _ _) ++ | is_deflt = text "default type signature" ++ | otherwise = text "class method signature" ++hsSigDoc (IdSig {}) = text "id signature" ++hsSigDoc (SpecSig _ _ _ inl) ++ = ppr inl <+> text "pragma" ++hsSigDoc (InlineSig _ _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma" ++hsSigDoc (SpecInstSig _ src _) ++ = pprWithSourceText src empty <+> text "instance pragma" ++hsSigDoc (FixSig {}) = text "fixity declaration" ++hsSigDoc (MinimalSig {}) = text "MINIMAL pragma" ++hsSigDoc (SCCFunSig {}) = text "SCC pragma" ++hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma" ++hsSigDoc (XSig {}) = text "XSIG TTG extension" ++ ++{- ++************************************************************************ ++* * ++\subsection[PatSynBind]{A pattern synonym definition} ++* * ++************************************************************************ ++-} ++ ++-- | Haskell Pattern Synonym Details ++type HsPatSynDetails pass = HsConDetails Void (LIdP pass) [RecordPatSynField pass] ++ ++-- See Note [Record PatSyn Fields] ++-- | Record Pattern Synonym Field ++data RecordPatSynField pass ++ = RecordPatSynField ++ { recordPatSynField :: FieldOcc pass ++ -- ^ Field label visible in rest of the file ++ , recordPatSynPatVar :: LIdP pass ++ -- ^ Filled in by renamer, the name used internally by the pattern ++ } ++ ++ ++{- ++Note [Record PatSyn Fields] ++~~~~~~~~~~~~~~~~~~~~~~~~~~~ ++ ++Consider the following two pattern synonyms. ++ ++ pattern P x y = ([x,True], [y,'v']) ++ pattern Q{ x, y } =([x,True], [y,'v']) ++ ++In P, we just have two local binders, x and y. ++ ++In Q, we have local binders but also top-level record selectors ++ x :: ([Bool], [Char]) -> Bool ++ y :: ([Bool], [Char]) -> Char ++ ++Both are recorded in the `RecordPatSynField`s for `x` and `y`: ++* recordPatSynField: the top-level record selector ++* recordPatSynPatVar: the local `x`, bound only in the RHS of the pattern synonym. ++ ++It would make sense to support record-like syntax ++ ++ pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v']) ++ ++when we have a different name for the local and top-level binder, ++making the distinction between the two names clear. ++ ++-} ++instance Outputable (RecordPatSynField a) where ++ ppr (RecordPatSynField { recordPatSynField = v }) = ppr v ++ ++ ++-- | Haskell Pattern Synonym Direction ++data HsPatSynDir id ++ = Unidirectional ++ | ImplicitBidirectional ++ | ExplicitBidirectional (MatchGroup id (LHsExpr id)) +diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs +new file mode 100644 +index 0000000000..478ac1e2ac +--- /dev/null ++++ b/compiler/Language/Haskell/Syntax/Expr.hs +@@ -0,0 +1,1775 @@ ++{-# LANGUAGE CPP #-} ++{-# LANGUAGE ConstraintKinds #-} ++{-# LANGUAGE DataKinds #-} ++{-# LANGUAGE DeriveDataTypeable #-} ++{-# LANGUAGE ExistentialQuantification #-} ++{-# LANGUAGE FlexibleContexts #-} ++{-# LANGUAGE FlexibleInstances #-} ++{-# LANGUAGE LambdaCase #-} ++{-# LANGUAGE ScopedTypeVariables #-} ++{-# LANGUAGE StandaloneDeriving #-} ++{-# LANGUAGE TypeApplications #-} ++{-# LANGUAGE TypeFamilyDependencies #-} ++{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] ++ -- in module Language.Haskell.Syntax.Extension ++ ++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} ++ ++{- ++(c) The University of Glasgow 2006 ++(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 ++-} ++ ++-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* ++ ++-- | Abstract Haskell syntax for expressions. ++module Language.Haskell.Syntax.Expr where ++ ++#include "HsVersions.h" ++ ++-- friends: ++import GHC.Prelude ++ ++import Language.Haskell.Syntax.Decls ++import Language.Haskell.Syntax.Pat ++import Language.Haskell.Syntax.Lit ++import Language.Haskell.Syntax.Extension ++import Language.Haskell.Syntax.Type ++import Language.Haskell.Syntax.Binds ++ ++-- others: ++import GHC.Tc.Types.Evidence ++import GHC.Core ++import GHC.Types.Name ++import GHC.Types.Basic ++import GHC.Types.Fixity ++import GHC.Types.SourceText ++import GHC.Types.SrcLoc ++import GHC.Core.ConLike ++import GHC.Unit.Module (ModuleName) ++import GHC.Utils.Outputable ++import GHC.Utils.Panic ++import GHC.Data.FastString ++import GHC.Core.Type ++ ++-- libraries: ++import Data.Data hiding (Fixity(..)) ++import qualified Data.Data as Data (Fixity(..)) ++ ++import GHCi.RemoteTypes ( ForeignRef ) ++import qualified Language.Haskell.TH as TH (Q) ++ ++{- ++************************************************************************ ++* * ++\subsection{Expressions proper} ++* * ++************************************************************************ ++-} ++ ++-- * Expressions proper ++ ++-- | Located Haskell Expression ++type LHsExpr p = XRec p (HsExpr p) ++ -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when ++ -- in a list ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ ++------------------------- ++{- Note [NoSyntaxExpr] ++~~~~~~~~~~~~~~~~~~~~~~ ++Syntax expressions can be missing (NoSyntaxExprRn or NoSyntaxExprTc) ++for several reasons: ++ ++ 1. As described in Note [Rebindable if] ++ ++ 2. In order to suppress "not in scope: xyz" messages when a bit of ++ rebindable syntax does not apply. For example, when using an irrefutable ++ pattern in a BindStmt, we don't need a `fail` operator. ++ ++ 3. Rebindable syntax might just not make sense. For example, a BodyStmt ++ contains the syntax for `guard`, but that's used only in monad comprehensions. ++ If we had more of a whiz-bang type system, we might be able to rule this ++ case out statically. ++-} ++ ++-- | Syntax Expression ++-- ++-- SyntaxExpr is represents the function used in interpreting rebindable ++-- syntax. In the parser, we have no information to supply; in the renamer, ++-- we have the name of the function (but see ++-- Note [Monad fail : Rebindable syntax, overloaded strings] for a wrinkle) ++-- and in the type-checker we have a more elaborate structure 'SyntaxExprTc'. ++-- ++-- In some contexts, rebindable syntax is not implemented, and so we have ++-- constructors to represent that possibility in both the renamer and ++-- typechecker instantiations. ++-- ++-- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for ++-- @(>>=)@, and then instantiated by the type checker with its type args ++-- etc ++type family SyntaxExpr p ++ ++-- | Command Syntax Table (for Arrow syntax) ++type CmdSyntaxTable p = [(Name, HsExpr p)] ++-- See Note [CmdSyntaxTable] ++ ++{- ++Note [CmdSyntaxTable] ++~~~~~~~~~~~~~~~~~~~~~ ++Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps ++track of the methods needed for a Cmd. ++ ++* Before the renamer, this list is an empty list ++ ++* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ ++ For example, for the 'arr' method ++ * normal case: (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr) ++ * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22) ++ where @arr_22@ is whatever 'arr' is in scope ++ ++* After the type checker, it takes the form [(std_name, )] ++ where is the evidence for the method. This evidence is ++ instantiated with the class, but is still polymorphic in everything ++ else. For example, in the case of 'arr', the evidence has type ++ forall b c. (b->c) -> a b c ++ where 'a' is the ambient type of the arrow. This polymorphism is ++ important because the desugarer uses the same evidence at multiple ++ different types. ++ ++This is Less Cool than what we normally do for rebindable syntax, which is to ++make fully-instantiated piece of evidence at every use site. The Cmd way ++is Less Cool because ++ * The renamer has to predict which methods are needed. ++ See the tedious GHC.Rename.Expr.methodNamesCmd. ++ ++ * The desugarer has to know the polymorphic type of the instantiated ++ method. This is checked by Inst.tcSyntaxName, but is less flexible ++ than the rest of rebindable syntax, where the type is less ++ pre-ordained. (And this flexibility is useful; for example we can ++ typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.) ++-} ++ ++-- | A Haskell expression. ++data HsExpr p ++ = HsVar (XVar p) ++ (LIdP p) -- ^ Variable ++ -- See Note [Located RdrNames] ++ ++ | HsUnboundVar (XUnboundVar p) ++ OccName -- ^ Unbound variable; also used for "holes" ++ -- (_ or _x). ++ -- Turned from HsVar to HsUnboundVar by the ++ -- renamer, when it finds an out-of-scope ++ -- variable or hole. ++ -- The (XUnboundVar p) field becomes an HoleExprRef ++ -- after typechecking; this is where the ++ -- erroring expression will be written after ++ -- solving. See Note [Holes] in GHC.Tc.Types.Constraint. ++ ++ | HsConLikeOut (XConLikeOut p) ++ ConLike -- ^ After typechecker only; must be different ++ -- HsVar for pretty printing ++ ++ | HsRecFld (XRecFld p) ++ (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector ++ -- The parser produces HsVars ++ -- The renamer renames record-field selectors to HsRecFld ++ -- The typechecker preserves HsRecFld ++ ++ | HsOverLabel (XOverLabel p) ++ (Maybe (IdP p)) FastString ++ -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels) ++ -- @Just id@ means @RebindableSyntax@ is in use, and gives the id of the ++ -- in-scope 'fromLabel'. ++ -- NB: Not in use after typechecking ++ ++ | HsIPVar (XIPVar p) ++ HsIPName -- ^ Implicit parameter (not in use after typechecking) ++ | HsOverLit (XOverLitE p) ++ (HsOverLit p) -- ^ Overloaded literals ++ ++ | HsLit (XLitE p) ++ (HsLit p) -- ^ Simple (non-overloaded) literals ++ ++ | HsLam (XLam p) ++ (MatchGroup p (LHsExpr p)) ++ -- ^ Lambda abstraction. Currently always a single match ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam', ++ -- 'GHC.Parser.Annotation.AnnRarrow', ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ ++ | HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p)) -- ^ Lambda-case ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam', ++ -- 'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen', ++ -- 'GHC.Parser.Annotation.AnnClose' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ ++ | HsApp (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application ++ ++ | HsAppType (XAppTypeE p) -- After typechecking: the type argument ++ (LHsExpr p) ++ (LHsWcType (NoGhcTc p)) -- ^ Visible type application ++ -- ++ -- Explicit type argument; e.g f @Int x y ++ -- NB: Has wildcards, but no implicit quantification ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnAt', ++ ++ -- | Operator applications: ++ -- NB Bracketed ops such as (+) come out as Vars. ++ ++ -- NB We need an expr for the operator in an OpApp/Section since ++ -- the typechecker may need to apply the operator to a few types. ++ ++ | OpApp (XOpApp p) ++ (LHsExpr p) -- left operand ++ (LHsExpr p) -- operator ++ (LHsExpr p) -- right operand ++ ++ -- | Negation operator. Contains the negated expression and the name ++ -- of 'negate' ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnMinus' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | NegApp (XNegApp p) ++ (LHsExpr p) ++ (SyntaxExpr p) ++ ++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@, ++ -- 'GHC.Parser.Annotation.AnnClose' @')'@ ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | HsPar (XPar p) ++ (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn] ++ ++ | SectionL (XSectionL p) ++ (LHsExpr p) -- operand; see Note [Sections in HsSyn] ++ (LHsExpr p) -- operator ++ | SectionR (XSectionR p) ++ (LHsExpr p) -- operator; see Note [Sections in HsSyn] ++ (LHsExpr p) -- operand ++ ++ -- | Used for explicit tuples and sections thereof ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', ++ -- 'GHC.Parser.Annotation.AnnClose' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ -- Note [ExplicitTuple] ++ | ExplicitTuple ++ (XExplicitTuple p) ++ [LHsTupArg p] ++ Boxity ++ ++ -- | Used for unboxed sum types ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'(#'@, ++ -- 'GHC.Parser.Annotation.AnnVbar', 'GHC.Parser.Annotation.AnnClose' @'#)'@, ++ -- ++ -- There will be multiple 'GHC.Parser.Annotation.AnnVbar', (1 - alternative) before ++ -- the expression, (arity - alternative) after it ++ | ExplicitSum ++ (XExplicitSum p) ++ ConTag -- Alternative (one-based) ++ Arity -- Sum arity ++ (LHsExpr p) ++ ++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnCase', ++ -- 'GHC.Parser.Annotation.AnnOf','GHC.Parser.Annotation.AnnOpen' @'{'@, ++ -- 'GHC.Parser.Annotation.AnnClose' @'}'@ ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | HsCase (XCase p) ++ (LHsExpr p) ++ (MatchGroup p (LHsExpr p)) ++ ++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf', ++ -- 'GHC.Parser.Annotation.AnnSemi', ++ -- 'GHC.Parser.Annotation.AnnThen','GHC.Parser.Annotation.AnnSemi', ++ -- 'GHC.Parser.Annotation.AnnElse', ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | HsIf (XIf p) -- GhcPs: this is a Bool; False <=> do not use ++ -- rebindable syntax ++ (LHsExpr p) -- predicate ++ (LHsExpr p) -- then part ++ (LHsExpr p) -- else part ++ ++ -- | Multi-way if ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf' ++ -- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose', ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | HsMultiIf (XMultiIf p) [LGRHS p (LHsExpr p)] ++ ++ -- | let(rec) ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet', ++ -- 'GHC.Parser.Annotation.AnnOpen' @'{'@, ++ -- 'GHC.Parser.Annotation.AnnClose' @'}'@,'GHC.Parser.Annotation.AnnIn' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | HsLet (XLet p) ++ (LHsLocalBinds p) ++ (LHsExpr p) ++ ++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo', ++ -- 'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnSemi', ++ -- 'GHC.Parser.Annotation.AnnVbar', ++ -- 'GHC.Parser.Annotation.AnnClose' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | HsDo (XDo p) -- Type of the whole expression ++ (HsStmtContext (HsDoRn p)) ++ -- The parameterisation of the above is unimportant ++ -- because in this context we never use ++ -- the PatGuard or ParStmt variant ++ (XRec p [ExprLStmt p]) -- "do":one or more stmts ++ ++ -- | Syntactic list: [a,b,c,...] ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@, ++ -- 'GHC.Parser.Annotation.AnnClose' @']'@ ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ -- See Note [Empty lists] ++ | ExplicitList ++ (XExplicitList p) -- Gives type of components of list ++ (Maybe (SyntaxExpr p)) ++ -- For OverloadedLists, the fromListN witness ++ [LHsExpr p] ++ ++ -- | Record construction ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@, ++ -- 'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose' @'}'@ ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | RecordCon ++ { rcon_ext :: XRecordCon p ++ , rcon_con :: XRec p (ConLikeP p) -- The constructor ++ , rcon_flds :: HsRecordBinds p } -- The fields ++ ++ -- | Record update ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@, ++ -- 'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose' @'}'@ ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | RecordUpd ++ { rupd_ext :: XRecordUpd p ++ , rupd_expr :: LHsExpr p ++ , rupd_flds :: [LHsRecUpdField p] ++ } ++ -- For a type family, the arg types are of the *instance* tycon, ++ -- not the family tycon ++ ++ -- | Expression with an explicit type signature. @e :: type@ ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | ExprWithTySig ++ (XExprWithTySig p) ++ ++ (LHsExpr p) ++ (LHsSigWcType (NoGhcTc p)) ++ ++ -- | Arithmetic sequence ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@, ++ -- 'GHC.Parser.Annotation.AnnComma','GHC.Parser.Annotation.AnnDotdot', ++ -- 'GHC.Parser.Annotation.AnnClose' @']'@ ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | ArithSeq ++ (XArithSeq p) ++ (Maybe (SyntaxExpr p)) ++ -- For OverloadedLists, the fromList witness ++ (ArithSeqInfo p) ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ ++ ----------------------------------------------------------- ++ -- MetaHaskell Extensions ++ ++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', ++ -- 'GHC.Parser.Annotation.AnnOpenE','GHC.Parser.Annotation.AnnOpenEQ', ++ -- 'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnCloseQ' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | HsBracket (XBracket p) (HsBracket p) ++ ++ -- See Note [Pending Splices] ++ | HsRnBracketOut ++ (XRnBracketOut p) ++ (HsBracket (HsBracketRn p)) -- Output of the renamer is the *original* renamed ++ -- expression, plus ++ [PendingRnSplice' p] -- _renamed_ splices to be type checked ++ ++ | HsTcBracketOut ++ (XTcBracketOut p) ++ (Maybe QuoteWrapper) -- The wrapper to apply type and dictionary argument ++ -- to the quote. ++ (HsBracket (HsBracketRn p)) -- Output of the type checker is the *original* ++ -- renamed expression, plus ++ [PendingTcSplice' p] -- _typechecked_ splices to be ++ -- pasted back in by the desugarer ++ ++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', ++ -- 'GHC.Parser.Annotation.AnnClose' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | HsSpliceE (XSpliceE p) (HsSplice p) ++ ++ ----------------------------------------------------------- ++ -- Arrow notation extension ++ ++ -- | @proc@ notation for Arrows ++ -- ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnProc', ++ -- 'GHC.Parser.Annotation.AnnRarrow' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | HsProc (XProc p) ++ (LPat p) -- arrow abstraction, proc ++ (LHsCmdTop p) -- body of the abstraction ++ -- always has an empty stack ++ ++ --------------------------------------- ++ -- static pointers extension ++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnStatic', ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | HsStatic (XStatic p) -- Free variables of the body ++ (LHsExpr p) -- Body ++ ++ --------------------------------------- ++ -- Haskell program coverage (Hpc) Support ++ ++ | HsTick ++ (XTick p) ++ CoreTickish ++ (LHsExpr p) -- sub-expression ++ ++ | HsBinTick ++ (XBinTick p) ++ Int -- module-local tick number for True ++ Int -- module-local tick number for False ++ (LHsExpr p) -- sub-expression ++ ++ --------------------------------------- ++ -- Expressions annotated with pragmas, written as {-# ... #-} ++ | HsPragE (XPragE p) (HsPragE p) (LHsExpr p) ++ ++ | XExpr !(XXExpr p) ++ -- Note [Trees that Grow] extension constructor for the ++ -- general idea, and Note [Rebindable syntax and HsExpansion] ++ -- for an example of how we use it. ++ ++-- | The AST used to hard-refer to GhcPass, which was a layer violation. For now, ++-- we paper it over with this new extension point. ++type family HsDoRn p ++type family HsBracketRn p ++type family PendingRnSplice' p ++type family PendingTcSplice' p ++ ++-- --------------------------------------------------------------------- ++ ++{- ++Note [Rebindable syntax and HsExpansion] ++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ++ ++We implement rebindable syntax (RS) support by performing a desugaring ++in the renamer. We transform GhcPs expressions affected by RS into the ++appropriate desugared form, but **annotated with the original expression**. ++ ++Let us consider a piece of code like: ++ ++ {-# LANGUAGE RebindableSyntax #-} ++ ifThenElse :: Char -> () -> () -> () ++ ifThenElse _ _ _ = () ++ x = if 'a' then () else True ++ ++The parsed AST for the RHS of x would look something like (slightly simplified): ++ ++ L locif (HsIf (L loca 'a') (L loctrue ()) (L locfalse True)) ++ ++Upon seeing such an AST with RS on, we could transform it into a ++mere function call, as per the RS rules, equivalent to the ++following function application: ++ ++ ifThenElse 'a' () True ++ ++which doesn't typecheck. But GHC would report an error about ++not being able to match the third argument's type (Bool) with the ++expected type: (), in the expression _as desugared_, i.e in ++the aforementioned function application. But the user never ++wrote a function application! This would be pretty bad. ++ ++To remedy this, instead of transforming the original HsIf ++node into mere applications of 'ifThenElse', we keep the ++original 'if' expression around too, using the TTG ++XExpr extension point to allow GHC to construct an ++'HsExpansion' value that will keep track of the original ++expression in its first field, and the desugared one in the ++second field. The resulting renamed AST would look like: ++ ++ L locif (XExpr ++ (HsExpanded ++ (HsIf (L loca 'a') ++ (L loctrue ()) ++ (L locfalse True) ++ ) ++ (App (L generatedSrcSpan ++ (App (L generatedSrcSpan ++ (App (L generatedSrcSpan (Var ifThenElse)) ++ (L loca 'a') ++ ) ++ ) ++ (L loctrue ()) ++ ) ++ ) ++ (L locfalse True) ++ ) ++ ) ++ ) ++ ++When comes the time to typecheck the program, we end up calling ++tcMonoExpr on the AST above. If this expression gives rise to ++a type error, then it will appear in a context line and GHC ++will pretty-print it using the 'Outputable (HsExpansion a b)' ++instance defined below, which *only prints the original ++expression*. This is the gist of the idea, but is not quite ++enough to recover the error messages that we had with the ++SyntaxExpr-based, typechecking/desugaring-to-core time ++implementation of rebindable syntax. The key idea is to decorate ++some elements of the desugared expression so as to be able to ++give them a special treatment when typechecking the desugared ++expression, to print a different context line or skip one ++altogether. ++ ++Whenever we 'setSrcSpan' a 'generatedSrcSpan', we update a field in ++TcLclEnv called 'tcl_in_gen_code', setting it to True, which indicates that we ++entered generated code, i.e code fabricated by the compiler when rebinding some ++syntax. If someone tries to push some error context line while that field is set ++to True, the pushing won't actually happen and the context line is just dropped. ++Once we 'setSrcSpan' a real span (for an expression that was in the original ++source code), we set 'tcl_in_gen_code' back to False, indicating that we ++"emerged from the generated code tunnel", and that the expressions we will be ++processing are relevant to report in context lines again. ++ ++You might wonder why we store a RealSrcSpan in addition to a Bool in ++the TcLclEnv: could we not store a Maybe RealSrcSpan? The problem is ++that we still generate constraints when processing generated code, ++and a CtLoc must contain a RealSrcSpan -- otherwise, error messages ++might appear without source locations. So we keep the RealSrcSpan of ++the last location spotted that wasn't generated; it's as good as ++we're going to get in generated code. Once we get to sub-trees that ++are not generated, then we update the RealSrcSpan appropriately, and ++set the tcl_in_gen_code Bool to False. ++ ++--- ++ ++A general recipe to follow this approach for new constructs could go as follows: ++ ++- Remove any GhcRn-time SyntaxExpr extensions to the relevant constructor for your ++ construct, in HsExpr or related syntax data types. ++- At renaming-time: ++ - take your original node of interest (HsIf above) ++ - rename its subexpressions (condition, true branch, false branch above) ++ - construct the suitable "rebound"-and-renamed result (ifThenElse call ++ above), where the 'SrcSpan' attached to any _fabricated node_ (the ++ HsVar/HsApp nodes, above) is set to 'generatedSrcSpan' ++ - take both the original node and that rebound-and-renamed result and wrap ++ them in an XExpr: XExpr (HsExpanded ) ++ - At typechecking-time: ++ - remove any logic that was previously dealing with your rebindable ++ construct, typically involving [tc]SyntaxOp, SyntaxExpr and friends. ++ - the XExpr (HsExpanded ... ...) case in tcExpr already makes sure that we ++ typecheck the desugared expression while reporting the original one in ++ errors ++ ++-} ++ ++-- See Note [Rebindable syntax and HsExpansion] just above. ++data HsExpansion a b ++ = HsExpanded a b ++ deriving Data ++ ++-- | Build a "wrapped" 'HsExpansion' out of an extension constructor, ++-- and the two components of the expansion: original and desugared ++-- expressions. ++-- ++-- See Note [Rebindable Syntax and HsExpansion] above for more details. ++mkExpanded ++ :: (HsExpansion a b -> b) -- ^ XExpr, XCmd, ... ++ -> a -- ^ source expression ('GhcPs') ++ -> b -- ^ "desugared" expression ++ -- ('GhcRn') ++ -> b -- ^ suitably wrapped ++ -- 'HsExpansion' ++mkExpanded xwrap a b = xwrap (HsExpanded a b) ++ ++-- | Just print the original expression (the @a@). ++instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where ++ ppr (HsExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a) ++ ++-- --------------------------------------------------------------------- ++ ++-- | A pragma, written as {-# ... #-}, that may appear within an expression. ++data HsPragE p ++ = HsPragSCC (XSCC p) ++ SourceText -- Note [Pragma source text] in GHC.Types.SourceText ++ StringLiteral -- "set cost centre" SCC pragma ++ ++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', ++ -- 'GHC.Parser.Annotation.AnnOpen' @'{-\# GENERATED'@, ++ -- 'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnVal', ++ -- 'GHC.Parser.Annotation.AnnColon','GHC.Parser.Annotation.AnnVal', ++ -- 'GHC.Parser.Annotation.AnnMinus', ++ -- 'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnColon', ++ -- 'GHC.Parser.Annotation.AnnVal', ++ -- 'GHC.Parser.Annotation.AnnClose' @'\#-}'@ ++ ++ | XHsPragE !(XXPragE p) ++ ++-- | Located Haskell Tuple Argument ++-- ++-- 'HsTupArg' is used for tuple sections ++-- @(,a,)@ is represented by ++-- @ExplicitTuple [Missing ty1, Present a, Missing ty3]@ ++-- Which in turn stands for @(\x:ty1 \y:ty2. (x,a,y))@ ++type LHsTupArg id = XRec id (HsTupArg id) ++-- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' ++ ++-- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ ++-- | Haskell Tuple Argument ++data HsTupArg id ++ = Present (XPresent id) (LHsExpr id) -- ^ The argument ++ | Missing (XMissing id) -- ^ The argument is missing, but this is its type ++ | XTupArg !(XXTupArg id) -- ^ Note [Trees that Grow] extension point ++ ++{- ++Note [Parens in HsSyn] ++~~~~~~~~~~~~~~~~~~~~~~ ++HsPar (and ParPat in patterns, HsParTy in types) is used as follows ++ ++ * HsPar is required; the pretty printer does not add parens. ++ ++ * HsPars are respected when rearranging operator fixities. ++ So a * (b + c) means what it says (where the parens are an HsPar) ++ ++ * For ParPat and HsParTy the pretty printer does add parens but this should be ++ a no-op for ParsedSource, based on the pretty printer round trip feature ++ introduced in ++ https://phabricator.haskell.org/rGHC499e43824bda967546ebf95ee33ec1f84a114a7c ++ ++ * ParPat and HsParTy are pretty printed as '( .. )' regardless of whether or ++ not they are strictly necessary. This should be addressed when #13238 is ++ completed, to be treated the same as HsPar. ++ ++ ++Note [Sections in HsSyn] ++~~~~~~~~~~~~~~~~~~~~~~~~ ++Sections should always appear wrapped in an HsPar, thus ++ HsPar (SectionR ...) ++The parser parses sections in a wider variety of situations ++(See Note [Parsing sections]), but the renamer checks for those ++parens. This invariant makes pretty-printing easier; we don't need ++a special case for adding the parens round sections. ++ ++Note [Rebindable if] ++~~~~~~~~~~~~~~~~~~~~ ++The rebindable syntax for 'if' is a bit special, because when ++rebindable syntax is *off* we do not want to treat ++ (if c then t else e) ++as if it was an application (ifThenElse c t e). Why not? ++Because we allow an 'if' to return *unboxed* results, thus ++ if blah then 3# else 4# ++whereas that would not be possible using a all to a polymorphic function ++(because you can't call a polymorphic function at an unboxed type). ++ ++So we use NoSyntaxExpr to mean "use the old built-in typing rule". ++ ++A further complication is that, in the `deriving` code, we never want ++to use rebindable syntax. So, even in GhcPs, we want to denote whether ++to use rebindable syntax or not. This is done via the type instance ++for XIf GhcPs. ++ ++Note [Record Update HsWrapper] ++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ++There is a wrapper in RecordUpd which is used for the *required* ++constraints for pattern synonyms. This wrapper is created in the ++typechecking and is then directly used in the desugaring without ++modification. ++ ++For example, if we have the record pattern synonym P, ++ pattern P :: (Show a) => a -> Maybe a ++ pattern P{x} = Just x ++ ++ foo = (Just True) { x = False } ++then `foo` desugars to something like ++ foo = case Just True of ++ P x -> P False ++hence we need to provide the correct dictionaries to P's matcher on ++the RHS so that we can build the expression. ++ ++Note [Located RdrNames] ++~~~~~~~~~~~~~~~~~~~~~~~ ++A number of syntax elements have seemingly redundant locations attached to them. ++This is deliberate, to allow transformations making use of the API Annotations ++to easily correlate a Located Name in the RenamedSource with a Located RdrName ++in the ParsedSource. ++ ++There are unfortunately enough differences between the ParsedSource and the ++RenamedSource that the API Annotations cannot be used directly with ++RenamedSource, so this allows a simple mapping to be used based on the location. ++ ++Note [ExplicitTuple] ++~~~~~~~~~~~~~~~~~~~~ ++An ExplicitTuple is never just a data constructor like (,,,). ++That is, the `[LHsTupArg p]` argument of `ExplicitTuple` has at least ++one `Present` member (and is thus never empty). ++ ++A tuple data constructor like () or (,,,) is parsed as an `HsVar`, not an ++`ExplicitTuple`, and stays that way. This is important for two reasons: ++ ++ 1. We don't need -XTupleSections for (,,,) ++ 2. The type variables in (,,,) can be instantiated with visible type application. ++ That is, ++ ++ (,,) :: forall a b c. a -> b -> c -> (a,b,c) ++ (True,,) :: forall {b} {c}. b -> c -> (Bool,b,c) ++ ++ Note that the tuple section has *inferred* arguments, while the data ++ constructor has *specified* ones. ++ (See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl ++ for background.) ++ ++Sadly, the grammar for this is actually ambiguous, and it's only thanks to the ++preference of a shift in a shift/reduce conflict that the parser works as this ++Note details. Search for a reference to this Note in GHC.Parser for further ++explanation. ++ ++Note [Empty lists] ++~~~~~~~~~~~~~~~~~~ ++An empty list could be considered either a data constructor (stored with ++HsVar) or an ExplicitList. This Note describes how empty lists flow through the ++various phases and why. ++ ++Parsing ++------- ++An empty list is parsed by the sysdcon nonterminal. It thus comes to life via ++HsVar nilDataCon (defined in GHC.Builtin.Types). A freshly-parsed (HsExpr GhcPs) empty list ++is never a ExplicitList. ++ ++Renaming ++-------- ++If -XOverloadedLists is enabled, we must type-check the empty list as if it ++were a call to fromListN. (This is true regardless of the setting of ++-XRebindableSyntax.) This is very easy if the empty list is an ExplicitList, ++but an annoying special case if it's an HsVar. So the renamer changes a ++HsVar nilDataCon to an ExplicitList [], but only if -XOverloadedLists is on. ++(Why not always? Read on, dear friend.) This happens in the HsVar case of rnExpr. ++ ++Type-checking ++------------- ++We want to accept an expression like [] @Int. To do this, we must infer that ++[] :: forall a. [a]. This is easy if [] is a HsVar with the right DataCon inside. ++However, the type-checking for explicit lists works differently: [x,y,z] is never ++polymorphic. Instead, we unify the types of x, y, and z together, and use the ++unified type as the argument to the cons and nil constructors. Thus, treating ++[] as an empty ExplicitList in the type-checker would prevent [] @Int from working. ++ ++However, if -XOverloadedLists is on, then [] @Int really shouldn't be allowed: ++it's just like fromListN 0 [] @Int. Since ++ fromListN :: forall list. IsList list => Int -> [Item list] -> list ++that expression really should be rejected. Thus, the renamer's behaviour is ++exactly what we want: treat [] as a datacon when -XNoOverloadedLists, and as ++an empty ExplicitList when -XOverloadedLists. ++ ++See also #13680, which requested [] @Int to work. ++-} ++ ++ ++----------------------- ++pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc ++pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4)) ++ = ppr (src,(n1,n2),(n3,n4)) ++ ++{- ++HsSyn records exactly where the user put parens, with HsPar. ++So generally speaking we print without adding any parens. ++However, some code is internally generated, and in some places ++parens are absolutely required; so for these places we use ++pprParendLExpr (but don't print double parens of course). ++ ++For operator applications we don't add parens, because the operator ++fixities should do the job, except in debug mode (-dppr-debug) so we ++can see the structure of the parse tree. ++-} ++ ++{- ++************************************************************************ ++* * ++\subsection{Commands (in arrow abstractions)} ++* * ++************************************************************************ ++ ++We re-use HsExpr to represent these. ++-} ++ ++-- | Located Haskell Command (for arrow syntax) ++type LHsCmd id = XRec id (HsCmd id) ++ ++-- | Haskell Command (e.g. a "statement" in an Arrow proc block) ++data HsCmd id ++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.Annlarrowtail', ++ -- 'GHC.Parser.Annotation.Annrarrowtail','GHC.Parser.Annotation.AnnLarrowtail', ++ -- 'GHC.Parser.Annotation.AnnRarrowtail' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ = HsCmdArrApp -- Arrow tail, or arrow application (f -< arg) ++ (XCmdArrApp id) -- type of the arrow expressions f, ++ -- of the form a t t', where arg :: t ++ (LHsExpr id) -- arrow expression, f ++ (LHsExpr id) -- input expression, arg ++ HsArrAppType -- higher-order (-<<) or first-order (-<) ++ Bool -- True => right-to-left (f -< arg) ++ -- False => left-to-right (arg >- f) ++ ++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpenB' @'(|'@, ++ -- 'GHC.Parser.Annotation.AnnCloseB' @'|)'@ ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |) ++ (XCmdArrForm id) ++ (LHsExpr id) -- The operator. ++ -- After type-checking, a type abstraction to be ++ -- applied to the type of the local environment tuple ++ LexicalFixity -- Whether the operator appeared prefix or infix when ++ -- parsed. ++ (Maybe Fixity) -- fixity (filled in by the renamer), for forms that ++ -- were converted from OpApp's by the renamer ++ [LHsCmdTop id] -- argument commands ++ ++ | HsCmdApp (XCmdApp id) ++ (LHsCmd id) ++ (LHsExpr id) ++ ++ | HsCmdLam (XCmdLam id) ++ (MatchGroup id (LHsCmd id)) -- kappa ++ -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam', ++ -- 'GHC.Parser.Annotation.AnnRarrow', ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ ++ | HsCmdPar (XCmdPar id) ++ (LHsCmd id) -- parenthesised command ++ -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@, ++ -- 'GHC.Parser.Annotation.AnnClose' @')'@ ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ ++ | HsCmdCase (XCmdCase id) ++ (LHsExpr id) ++ (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's ++ -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnCase', ++ -- 'GHC.Parser.Annotation.AnnOf','GHC.Parser.Annotation.AnnOpen' @'{'@, ++ -- 'GHC.Parser.Annotation.AnnClose' @'}'@ ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ ++ | HsCmdLamCase (XCmdLamCase id) ++ (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's ++ -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam', ++ -- 'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen' @'{'@, ++ -- 'GHC.Parser.Annotation.AnnClose' @'}'@ ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ ++ | HsCmdIf (XCmdIf id) ++ (SyntaxExpr id) -- cond function ++ (LHsExpr id) -- predicate ++ (LHsCmd id) -- then part ++ (LHsCmd id) -- else part ++ -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf', ++ -- 'GHC.Parser.Annotation.AnnSemi', ++ -- 'GHC.Parser.Annotation.AnnThen','GHC.Parser.Annotation.AnnSemi', ++ -- 'GHC.Parser.Annotation.AnnElse', ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ ++ | HsCmdLet (XCmdLet id) ++ (LHsLocalBinds id) -- let(rec) ++ (LHsCmd id) ++ -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet', ++ -- 'GHC.Parser.Annotation.AnnOpen' @'{'@, ++ -- 'GHC.Parser.Annotation.AnnClose' @'}'@,'GHC.Parser.Annotation.AnnIn' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ ++ | HsCmdDo (XCmdDo id) -- Type of the whole expression ++ (XRec id [CmdLStmt id]) ++ -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo', ++ -- 'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnSemi', ++ -- 'GHC.Parser.Annotation.AnnVbar', ++ -- 'GHC.Parser.Annotation.AnnClose' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ ++ | XCmd !(XXCmd id) -- Note [Trees that Grow] extension point ++ ++ ++-- | Haskell Array Application Type ++data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp ++ deriving Data ++ ++ ++{- | Top-level command, introducing a new arrow. ++This may occur inside a proc (where the stack is empty) or as an ++argument of a command-forming operator. ++-} ++ ++-- | Located Haskell Top-level Command ++type LHsCmdTop p = XRec p (HsCmdTop p) ++ ++-- | Haskell Top-level Command ++data HsCmdTop p ++ = HsCmdTop (XCmdTop p) ++ (LHsCmd p) ++ | XCmdTop !(XXCmdTop p) -- Note [Trees that Grow] extension point ++ ++----------------------- ++ ++{- ++************************************************************************ ++* * ++\subsection{Record binds} ++* * ++************************************************************************ ++-} ++ ++-- | Haskell Record Bindings ++type HsRecordBinds p = HsRecFields p (LHsExpr p) ++ ++{- ++************************************************************************ ++* * ++\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} ++* * ++************************************************************************ ++ ++@Match@es are sets of pattern bindings and right hand sides for ++functions, patterns or case branches. For example, if a function @g@ ++is defined as: ++\begin{verbatim} ++g (x,y) = y ++g ((x:ys),y) = y+1, ++\end{verbatim} ++then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@. ++ ++It is always the case that each element of an @[Match]@ list has the ++same number of @pats@s inside it. This corresponds to saying that ++a function defined by pattern matching must have the same number of ++patterns in each equation. ++-} ++ ++data MatchGroup p body ++ = MG { mg_ext :: XMG p body -- Post-typechecker, types of args and result ++ , mg_alts :: XRec p [LMatch p body] -- The alternatives ++ , mg_origin :: Origin } ++ -- The type is the type of the entire group ++ -- t1 -> ... -> tn -> tr ++ -- where there are n patterns ++ | XMatchGroup !(XXMatchGroup p body) ++ ++data MatchGroupTc ++ = MatchGroupTc ++ { mg_arg_tys :: [Scaled Type] -- Types of the arguments, t1..tn ++ , mg_res_ty :: Type -- Type of the result, tr ++ } deriving Data ++ ++-- | Located Match ++type LMatch id body = XRec id (Match id body) ++-- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a ++-- list ++ ++-- For details on above see note [Api annotations] in GHC.Parser.Annotation ++data Match p body ++ = Match { ++ m_ext :: XCMatch p body, ++ m_ctxt :: HsMatchContext (NoGhcTc p), ++ -- See note [m_ctxt in Match] ++ m_pats :: [LPat p], -- The patterns ++ m_grhss :: (GRHSs p body) ++ } ++ | XMatch !(XXMatch p body) ++ ++{- ++Note [m_ctxt in Match] ++~~~~~~~~~~~~~~~~~~~~~~ ++ ++A Match can occur in a number of contexts, such as a FunBind, HsCase, HsLam and ++so on. ++ ++In order to simplify tooling processing and pretty print output, the provenance ++is captured in an HsMatchContext. ++ ++This is particularly important for the API Annotations for a multi-equation ++FunBind. ++ ++The parser initially creates a FunBind with a single Match in it for ++every function definition it sees. ++ ++These are then grouped together by getMonoBind into a single FunBind, ++where all the Matches are combined. ++ ++In the process, all the original FunBind fun_id's bar one are ++discarded, including the locations. ++ ++This causes a problem for source to source conversions via API ++Annotations, so the original fun_ids and infix flags are preserved in ++the Match, when it originates from a FunBind. ++ ++Example infix function definition requiring individual API Annotations ++ ++ (&&& ) [] [] = [] ++ xs &&& [] = xs ++ ( &&& ) [] ys = ys ++ ++ ++ ++-} ++ ++ ++isInfixMatch :: Match id body -> Bool ++isInfixMatch match = case m_ctxt match of ++ FunRhs {mc_fixity = Infix} -> True ++ _ -> False ++ ++-- | Guarded Right-Hand Sides ++-- ++-- GRHSs are used both for pattern bindings and for Matches ++-- ++-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVbar', ++-- 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere', ++-- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose' ++-- 'GHC.Parser.Annotation.AnnRarrow','GHC.Parser.Annotation.AnnSemi' ++ ++-- For details on above see note [Api annotations] in GHC.Parser.Annotation ++data GRHSs p body ++ = GRHSs { ++ grhssExt :: XCGRHSs p body, ++ grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs ++ grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause ++ } ++ | XGRHSs !(XXGRHSs p body) ++ ++-- | Located Guarded Right-Hand Side ++type LGRHS id body = XRec id (GRHS id body) ++ ++-- | Guarded Right Hand Side. ++data GRHS p body = GRHS (XCGRHS p body) ++ [GuardLStmt p] -- Guards ++ body -- Right hand side ++ | XGRHS !(XXGRHS p body) ++ ++-- We know the list must have at least one @Match@ in it. ++ ++{- ++************************************************************************ ++* * ++\subsection{Do stmts and list comprehensions} ++* * ++************************************************************************ ++-} ++ ++-- | Located @do@ block Statement ++type LStmt id body = XRec id (StmtLR id id body) ++ ++-- | Located Statement with separate Left and Right id's ++type LStmtLR idL idR body = XRec idL (StmtLR idL idR body) ++ ++-- | @do@ block Statement ++type Stmt id body = StmtLR id id body ++ ++-- | Command Located Statement ++type CmdLStmt id = LStmt id (LHsCmd id) ++ ++-- | Command Statement ++type CmdStmt id = Stmt id (LHsCmd id) ++ ++-- | Expression Located Statement ++type ExprLStmt id = LStmt id (LHsExpr id) ++ ++-- | Expression Statement ++type ExprStmt id = Stmt id (LHsExpr id) ++ ++-- | Guard Located Statement ++type GuardLStmt id = LStmt id (LHsExpr id) ++ ++-- | Guard Statement ++type GuardStmt id = Stmt id (LHsExpr id) ++ ++-- | Ghci Located Statement ++type GhciLStmt id = LStmt id (LHsExpr id) ++ ++-- | Ghci Statement ++type GhciStmt id = Stmt id (LHsExpr id) ++ ++-- The SyntaxExprs in here are used *only* for do-notation and monad ++-- comprehensions, which have rebindable syntax. Otherwise they are unused. ++-- | API Annotations when in qualifier lists or guards ++-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVbar', ++-- 'GHC.Parser.Annotation.AnnComma','GHC.Parser.Annotation.AnnThen', ++-- 'GHC.Parser.Annotation.AnnBy','GHC.Parser.Annotation.AnnBy', ++-- 'GHC.Parser.Annotation.AnnGroup','GHC.Parser.Annotation.AnnUsing' ++ ++-- For details on above see note [Api annotations] in GHC.Parser.Annotation ++data StmtLR idL idR body -- body should always be (LHs**** idR) ++ = LastStmt -- Always the last Stmt in ListComp, MonadComp, ++ -- and (after the renamer, see GHC.Rename.Expr.checkLastStmt) DoExpr, MDoExpr ++ -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff ++ (XLastStmt idL idR body) ++ body ++ (Maybe Bool) -- Whether return was stripped ++ -- Just True <=> return with a dollar was stripped by ApplicativeDo ++ -- Just False <=> return without a dollar was stripped by ApplicativeDo ++ -- Nothing <=> Nothing was stripped ++ (SyntaxExpr idR) -- The return operator ++ -- The return operator is used only for MonadComp ++ -- For ListComp we use the baked-in 'return' ++ -- For DoExpr, MDoExpr, we don't apply a 'return' at all ++ -- See Note [Monad Comprehensions] ++ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLarrow' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | BindStmt (XBindStmt idL idR body) ++ -- ^ Post renaming has optional fail and bind / (>>=) operator. ++ -- Post typechecking, also has multiplicity of the argument ++ -- and the result type of the function passed to bind; ++ -- that is, (P, S) in (>>=) :: Q -> (R # P -> S) -> T ++ -- See Note [The type of bind in Stmts] ++ (LPat idL) ++ body ++ ++ -- | 'ApplicativeStmt' represents an applicative expression built with ++ -- '<$>' and '<*>'. It is generated by the renamer, and is desugared into the ++ -- appropriate applicative expression by the desugarer, but it is intended ++ -- to be invisible in error messages. ++ -- ++ -- For full details, see Note [ApplicativeDo] in "GHC.Rename.Expr" ++ -- ++ | ApplicativeStmt ++ (XApplicativeStmt idL idR body) -- Post typecheck, Type of the body ++ [ ( SyntaxExpr idR ++ , ApplicativeArg idL) ] ++ -- [(<$>, e1), (<*>, e2), ..., (<*>, en)] ++ (Maybe (SyntaxExpr idR)) -- 'join', if necessary ++ ++ | BodyStmt (XBodyStmt idL idR body) -- Post typecheck, element type ++ -- of the RHS (used for arrows) ++ body -- See Note [BodyStmt] ++ (SyntaxExpr idR) -- The (>>) operator ++ (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp ++ -- See notes [Monad Comprehensions] ++ ++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet' ++ -- 'GHC.Parser.Annotation.AnnOpen' @'{'@,'GHC.Parser.Annotation.AnnClose' @'}'@, ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | LetStmt (XLetStmt idL idR body) (LHsLocalBindsLR idL idR) ++ ++ -- ParStmts only occur in a list/monad comprehension ++ | ParStmt (XParStmt idL idR body) -- Post typecheck, ++ -- S in (>>=) :: Q -> (R -> S) -> T ++ [ParStmtBlock idL idR] ++ (HsExpr idR) -- Polymorphic `mzip` for monad comprehensions ++ (SyntaxExpr idR) -- The `>>=` operator ++ -- See notes [Monad Comprehensions] ++ -- After renaming, the ids are the binders ++ -- bound by the stmts and used after themp ++ ++ | TransStmt { ++ trS_ext :: XTransStmt idL idR body, -- Post typecheck, ++ -- R in (>>=) :: Q -> (R -> S) -> T ++ trS_form :: TransForm, ++ trS_stmts :: [ExprLStmt idL], -- Stmts to the *left* of the 'group' ++ -- which generates the tuples to be grouped ++ ++ trS_bndrs :: [(IdP idR, IdP idR)], -- See Note [TransStmt binder map] ++ ++ trS_using :: LHsExpr idR, ++ trS_by :: Maybe (LHsExpr idR), -- "by e" (optional) ++ -- Invariant: if trS_form = GroupBy, then grp_by = Just e ++ ++ trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for ++ -- the inner monad comprehensions ++ trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator ++ trS_fmap :: HsExpr idR -- The polymorphic 'fmap' function for desugaring ++ -- Only for 'group' forms ++ -- Just a simple HsExpr, because it's ++ -- too polymorphic for tcSyntaxOp ++ } -- See Note [Monad Comprehensions] ++ ++ -- Recursive statement (see Note [How RecStmt works] below) ++ -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRec' ++ ++ -- For details on above see note [Api annotations] in GHC.Parser.Annotation ++ | RecStmt ++ { recS_ext :: XRecStmt idL idR body ++ , recS_stmts :: [LStmtLR idL idR body] ++ ++ -- The next two fields are only valid after renaming ++ , recS_later_ids :: [IdP idR] ++ -- The ids are a subset of the variables bound by the ++ -- stmts that are used in stmts that follow the RecStmt ++ ++ , recS_rec_ids :: [IdP idR] ++ -- Ditto, but these variables are the "recursive" ones, ++ -- that are used before they are bound in the stmts of ++ -- the RecStmt. ++ -- An Id can be in both groups ++ -- Both sets of Ids are (now) treated monomorphically ++ -- See Note [How RecStmt works] for why they are separate ++ ++ -- Rebindable syntax ++ , recS_bind_fn :: SyntaxExpr idR -- The bind function ++ , recS_ret_fn :: SyntaxExpr idR -- The return function ++ , recS_mfix_fn :: SyntaxExpr idR -- The mfix function ++ } ++ | XStmtLR !(XXStmtLR idL idR body) ++ ++data TransForm -- The 'f' below is the 'using' function, 'e' is the by function ++ = ThenForm -- then f or then f by e (depending on trS_by) ++ | GroupForm -- then group using f or then group by e using f (depending on trS_by) ++ deriving Data ++ ++-- | Parenthesised Statement Block ++data ParStmtBlock idL idR ++ = ParStmtBlock ++ (XParStmtBlock idL idR) ++ [ExprLStmt idL] ++ [IdP idR] -- The variables to be returned ++ (SyntaxExpr idR) -- The return operator ++ | XParStmtBlock !(XXParStmtBlock idL idR) ++ ++-- | The fail operator ++-- ++-- This is used for `.. <-` "bind statments" in do notation, including ++-- non-monadic "binds" in applicative. ++-- ++-- The fail operator is 'Just expr' if it potentially fail monadically. if the ++-- pattern match cannot fail, or shouldn't fail monadically (regular incomplete ++-- pattern exception), it is 'Nothing'. ++-- ++-- See Note [Monad fail : Rebindable syntax, overloaded strings] for the type of ++-- expression in the 'Just' case, and why it is so. ++-- ++-- See Note [Failing pattern matches in Stmts] for which contexts for ++-- '@BindStmt@'s should use the monadic fail and which shouldn't. ++type FailOperator id = Maybe (SyntaxExpr id) ++ ++-- | Applicative Argument ++data ApplicativeArg idL ++ = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt) ++ { xarg_app_arg_one :: XApplicativeArgOne idL ++ -- ^ The fail operator, after renaming ++ -- ++ -- The fail operator is needed if this is a BindStmt ++ -- where the pattern can fail. E.g.: ++ -- (Just a) <- stmt ++ -- The fail operator will be invoked if the pattern ++ -- match fails. ++ -- It is also used for guards in MonadComprehensions. ++ -- The fail operator is Nothing ++ -- if the pattern match can't fail ++ , app_arg_pattern :: LPat idL -- WildPat if it was a BodyStmt (see below) ++ , arg_expr :: LHsExpr idL ++ , is_body_stmt :: Bool ++ -- ^ True <=> was a BodyStmt, ++ -- False <=> was a BindStmt. ++ -- See Note [Applicative BodyStmt] ++ } ++ | ApplicativeArgMany -- do { stmts; return vars } ++ { xarg_app_arg_many :: XApplicativeArgMany idL ++ , app_stmts :: [ExprLStmt idL] -- stmts ++ , final_expr :: HsExpr idL -- return (v1,..,vn), or just (v1,..,vn) ++ , bv_pattern :: LPat idL -- (v1,...,vn) ++ , stmt_context :: HsStmtContext (ApplicativeArgStmCtxPass idL) ++ -- ^ context of the do expression, used in pprArg ++ } ++ | XApplicativeArg !(XXApplicativeArg idL) ++ ++type family ApplicativeArgStmCtxPass idL ++ ++{- ++Note [The type of bind in Stmts] ++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ++Some Stmts, notably BindStmt, keep the (>>=) bind operator. ++We do NOT assume that it has type ++ (>>=) :: m a -> (a -> m b) -> m b ++In some cases (see #303, #1537) it might have a more ++exotic type, such as ++ (>>=) :: m i j a -> (a -> m j k b) -> m i k b ++So we must be careful not to make assumptions about the type. ++In particular, the monad may not be uniform throughout. ++ ++Note [TransStmt binder map] ++~~~~~~~~~~~~~~~~~~~~~~~~~~~ ++The [(idR,idR)] in a TransStmt behaves as follows: ++ ++ * Before renaming: [] ++ ++ * After renaming: ++ [ (x27,x27), ..., (z35,z35) ] ++ These are the variables ++ bound by the stmts to the left of the 'group' ++ and used either in the 'by' clause, ++ or in the stmts following the 'group' ++ Each item is a pair of identical variables. ++ ++ * After typechecking: ++ [ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ] ++ Each pair has the same unique, but different *types*. ++ ++Note [BodyStmt] ++~~~~~~~~~~~~~~~ ++BodyStmts are a bit tricky, because what they mean ++depends on the context. Consider the following contexts: ++ ++ A do expression of type (m res_ty) ++ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ++ * BodyStmt E any_ty: do { ....; E; ... } ++ E :: m any_ty ++ Translation: E >> ... ++ ++ A list comprehensions of type [elt_ty] ++ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ++ * BodyStmt E Bool: [ .. | .... E ] ++ [ .. | ..., E, ... ] ++ [ .. | .... | ..., E | ... ] ++ E :: Bool ++ Translation: if E then fail else ... ++ ++ A guard list, guarding a RHS of type rhs_ty ++ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ++ * BodyStmt E BooParStmtBlockl: f x | ..., E, ... = ...rhs... ++ E :: Bool ++ Translation: if E then fail else ... ++ ++ A monad comprehension of type (m res_ty) ++ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ++ * BodyStmt E Bool: [ .. | .... E ] ++ E :: Bool ++ Translation: guard E >> ... ++ ++Array comprehensions are handled like list comprehensions. ++ ++Note [How RecStmt works] ++~~~~~~~~~~~~~~~~~~~~~~~~ ++Example: ++ HsDo [ BindStmt x ex ++ ++ , RecStmt { recS_rec_ids = [a, c] ++ , recS_stmts = [ BindStmt b (return (a,c)) ++ , LetStmt a = ...b... ++ , BindStmt c ec ] ++ , recS_later_ids = [a, b] ++ ++ , return (a b) ] ++ ++Here, the RecStmt binds a,b,c; but ++ - Only a,b are used in the stmts *following* the RecStmt, ++ - Only a,c are used in the stmts *inside* the RecStmt ++ *before* their bindings ++ ++Why do we need *both* rec_ids and later_ids? For monads they could be ++combined into a single set of variables, but not for arrows. That ++follows from the types of the respective feedback operators: ++ ++ mfix :: MonadFix m => (a -> m a) -> m a ++ loop :: ArrowLoop a => a (b,d) (c,d) -> a b c ++ ++* For mfix, the 'a' covers the union of the later_ids and the rec_ids ++* For 'loop', 'c' is the later_ids and 'd' is the rec_ids ++ ++Note [Typing a RecStmt] ++~~~~~~~~~~~~~~~~~~~~~~~ ++A (RecStmt stmts) types as if you had written ++ ++ (v1,..,vn, _, ..., _) <- mfix (\~(_, ..., _, r1, ..., rm) -> ++ do { stmts ++ ; return (v1,..vn, r1, ..., rm) }) ++ ++where v1..vn are the later_ids ++ r1..rm are the rec_ids ++ ++Note [Monad Comprehensions] ++~~~~~~~~~~~~~~~~~~~~~~~~~~~ ++Monad comprehensions require separate functions like 'return' and ++'>>=' for desugaring. These functions are stored in the statements ++used in monad comprehensions. For example, the 'return' of the 'LastStmt' ++expression is used to lift the body of the monad comprehension: ++ ++ [ body | stmts ] ++ => ++ stmts >>= \bndrs -> return body ++ ++In transform and grouping statements ('then ..' and 'then group ..') the ++'return' function is required for nested monad comprehensions, for example: ++ ++ [ body | stmts, then f, rest ] ++ => ++ f [ env | stmts ] >>= \bndrs -> [ body | rest ] ++ ++BodyStmts require the 'Control.Monad.guard' function for boolean ++expressions: ++ ++ [ body | exp, stmts ] ++ => ++ guard exp >> [ body | stmts ] ++ ++Parallel statements require the 'Control.Monad.Zip.mzip' function: ++ ++ [ body | stmts1 | stmts2 | .. ] ++ => ++ mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body ++ ++In any other context than 'MonadComp', the fields for most of these ++'SyntaxExpr's stay bottom. ++ ++ ++Note [Applicative BodyStmt] ++ ++(#12143) For the purposes of ApplicativeDo, we treat any BodyStmt ++as if it was a BindStmt with a wildcard pattern. For example, ++ ++ do ++ x <- A ++ B ++ return x ++ ++is transformed as if it were ++ ++ do ++ x <- A ++ _ <- B ++ return x ++ ++so it transforms to ++ ++ (\(x,_) -> x) <$> A <*> B ++ ++But we have to remember when we treat a BodyStmt like a BindStmt, ++because in error messages we want to emit the original syntax the user ++wrote, not our internal representation. So ApplicativeArgOne has a ++Bool flag that is True when the original statement was a BodyStmt, so ++that we can pretty-print it correctly. ++-} ++ ++ ++{- ++************************************************************************ ++* * ++ Template Haskell quotation brackets ++* * ++************************************************************************ ++-} ++ ++-- | Haskell Splice ++data HsSplice id ++ = HsTypedSplice -- $$z or $$(f 4) ++ (XTypedSplice id) ++ SpliceDecoration -- Whether $$( ) variant found, for pretty printing ++ (IdP id) -- A unique name to identify this splice point ++ (LHsExpr id) -- See Note [Pending Splices] ++ ++ | HsUntypedSplice -- $z or $(f 4) ++ (XUntypedSplice id) ++ SpliceDecoration -- Whether $( ) variant found, for pretty printing ++ (IdP id) -- A unique name to identify this splice point ++ (LHsExpr id) -- See Note [Pending Splices] ++ ++ | HsQuasiQuote -- See Note [Quasi-quote overview] in GHC.Tc.Gen.Splice ++ (XQuasiQuote id) ++ (IdP id) -- Splice point ++ (IdP id) -- Quoter ++ SrcSpan -- The span of the enclosed string ++ FastString -- The enclosed string ++ ++ -- AZ:TODO: use XSplice instead of HsSpliced ++ | HsSpliced -- See Note [Delaying modFinalizers in untyped splices] in ++ -- GHC.Rename.Splice. ++ -- This is the result of splicing a splice. It is produced by ++ -- the renamer and consumed by the typechecker. It lives only ++ -- between the two. ++ (XSpliced id) ++ ThModFinalizers -- TH finalizers produced by the splice. ++ (HsSplicedThing id) -- The result of splicing ++ | XSplice !(XXSplice id) -- Note [Trees that Grow] extension point ++ ++-- | A splice can appear with various decorations wrapped around it. This data ++-- type captures explicitly how it was originally written, for use in the pretty ++-- printer. ++data SpliceDecoration ++ = DollarSplice -- ^ $splice or $$splice ++ | BareSplice -- ^ bare splice ++ deriving (Data, Eq, Show) ++ ++instance Outputable SpliceDecoration where ++ ppr x = text $ show x ++ ++ ++isTypedSplice :: HsSplice id -> Bool ++isTypedSplice (HsTypedSplice {}) = True ++isTypedSplice _ = False -- Quasi-quotes are untyped splices ++ ++-- | Finalizers produced by a splice with ++-- 'Language.Haskell.TH.Syntax.addModFinalizer' ++-- ++-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. For how ++-- this is used. ++-- ++newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())] ++ ++-- A Data instance which ignores the argument of 'ThModFinalizers'. ++instance Data ThModFinalizers where ++ gunfold _ z _ = z $ ThModFinalizers [] ++ toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix ++ dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a] ++ ++-- | Haskell Spliced Thing ++-- ++-- Values that can result from running a splice. ++data HsSplicedThing id ++ = HsSplicedExpr (HsExpr id) -- ^ Haskell Spliced Expression ++ | HsSplicedTy (HsType id) -- ^ Haskell Spliced Type ++ | HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern ++ ++ ++-- See Note [Pending Splices] ++type SplicePointName = Name ++ ++data UntypedSpliceFlavour ++ = UntypedExpSplice ++ | UntypedPatSplice ++ | UntypedTypeSplice ++ | UntypedDeclSplice ++ deriving Data ++ ++-- | Haskell Bracket ++data HsBracket p ++ = ExpBr (XExpBr p) (LHsExpr p) -- [| expr |] ++ | PatBr (XPatBr p) (LPat p) -- [p| pat |] ++ | DecBrL (XDecBrL p) [LHsDecl p] -- [d| decls |]; result of parser ++ | DecBrG (XDecBrG p) (HsGroup p) -- [d| decls |]; result of renamer ++ | TypBr (XTypBr p) (LHsType p) -- [t| type |] ++ | VarBr (XVarBr p) Bool (IdP p) -- True: 'x, False: ''T ++ -- (The Bool flag is used only in pprHsBracket) ++ | TExpBr (XTExpBr p) (LHsExpr p) -- [|| expr ||] ++ | XBracket !(XXBracket p) -- Note [Trees that Grow] extension point ++ ++isTypedBracket :: HsBracket id -> Bool ++isTypedBracket (TExpBr {}) = True ++isTypedBracket _ = False ++ ++{- ++************************************************************************ ++* * ++\subsection{Enumerations and list comprehensions} ++* * ++************************************************************************ ++-} ++ ++-- | Arithmetic Sequence Information ++data ArithSeqInfo id ++ = From (LHsExpr id) ++ | FromThen (LHsExpr id) ++ (LHsExpr id) ++ | FromTo (LHsExpr id) ++ (LHsExpr id) ++ | FromThenTo (LHsExpr id) ++ (LHsExpr id) ++ (LHsExpr id) ++-- AZ: Should ArithSeqInfo have a TTG extension? ++ ++{- ++************************************************************************ ++* * ++\subsection{HsMatchCtxt} ++* * ++************************************************************************ ++-} ++ ++-- | Haskell Match Context ++-- ++-- Context of a pattern match. This is more subtle than it would seem. See Note ++-- [Varieties of pattern matches]. ++data HsMatchContext p ++ = FunRhs { mc_fun :: LIdP p -- ^ function binder of @f@ ++ , mc_fixity :: LexicalFixity -- ^ fixing of @f@ ++ , mc_strictness :: SrcStrictness -- ^ was @f@ banged? ++ -- See Note [FunBind vs PatBind] ++ } ++ -- ^A pattern matching on an argument of a ++ -- function binding ++ | LambdaExpr -- ^Patterns of a lambda ++ | CaseAlt -- ^Patterns and guards on a case alternative ++ | IfAlt -- ^Guards of a multi-way if alternative ++ | ProcExpr -- ^Patterns of a proc ++ | PatBindRhs -- ^A pattern binding eg [y] <- e = e ++ | PatBindGuards -- ^Guards of pattern bindings, e.g., ++ -- (Just b) | Just _ <- x = e ++ -- | otherwise = e' ++ ++ | RecUpd -- ^Record update [used only in GHC.HsToCore.Expr to ++ -- tell matchWrapper what sort of ++ -- runtime error message to generate] ++ ++ | StmtCtxt (HsStmtContext p) -- ^Pattern of a do-stmt, list comprehension, ++ -- pattern guard, etc ++ ++ | ThPatSplice -- ^A Template Haskell pattern splice ++ | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] ++ | PatSyn -- ^A pattern synonym declaration ++ ++isPatSynCtxt :: HsMatchContext p -> Bool ++isPatSynCtxt ctxt = ++ case ctxt of ++ PatSyn -> True ++ _ -> False ++ ++-- | Haskell Statement Context. ++data HsStmtContext p ++ = ListComp ++ | MonadComp ++ ++ | DoExpr (Maybe ModuleName) -- ^[ModuleName.]do { ... } ++ | MDoExpr (Maybe ModuleName) -- ^[ModuleName.]mdo { ... } ie recursive do-expression ++ | ArrowExpr -- ^do-notation in an arrow-command context ++ ++ | GhciStmtCtxt -- ^A command-line Stmt in GHCi pat <- rhs ++ | PatGuard (HsMatchContext p) -- ^Pattern guard for specified thing ++ | ParStmtCtxt (HsStmtContext p) -- ^A branch of a parallel stmt ++ | TransStmtCtxt (HsStmtContext p) -- ^A branch of a transform stmt ++ ++qualifiedDoModuleName_maybe :: HsStmtContext p -> Maybe ModuleName ++qualifiedDoModuleName_maybe ctxt = case ctxt of ++ DoExpr m -> m ++ MDoExpr m -> m ++ _ -> Nothing ++ ++isComprehensionContext :: HsStmtContext id -> Bool ++-- Uses comprehension syntax [ e | quals ] ++isComprehensionContext ListComp = True ++isComprehensionContext MonadComp = True ++isComprehensionContext (ParStmtCtxt c) = isComprehensionContext c ++isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c ++isComprehensionContext _ = False ++ ++-- | Is this a monadic context? ++isMonadStmtContext :: HsStmtContext id -> Bool ++isMonadStmtContext MonadComp = True ++isMonadStmtContext DoExpr{} = True ++isMonadStmtContext MDoExpr{} = True ++isMonadStmtContext GhciStmtCtxt = True ++isMonadStmtContext (ParStmtCtxt ctxt) = isMonadStmtContext ctxt ++isMonadStmtContext (TransStmtCtxt ctxt) = isMonadStmtContext ctxt ++isMonadStmtContext _ = False -- ListComp, PatGuard, ArrowExpr ++ ++isMonadCompContext :: HsStmtContext id -> Bool ++isMonadCompContext MonadComp = True ++isMonadCompContext _ = False ++ ++matchSeparator :: HsMatchContext p -> SDoc ++matchSeparator (FunRhs {}) = text "=" ++matchSeparator CaseAlt = text "->" ++matchSeparator IfAlt = text "->" ++matchSeparator LambdaExpr = text "->" ++matchSeparator ProcExpr = text "->" ++matchSeparator PatBindRhs = text "=" ++matchSeparator PatBindGuards = text "=" ++matchSeparator (StmtCtxt _) = text "<-" ++matchSeparator RecUpd = text "=" -- This can be printed by the pattern ++ -- match checker trace ++matchSeparator ThPatSplice = panic "unused" ++matchSeparator ThPatQuote = panic "unused" ++matchSeparator PatSyn = panic "unused" ++ ++pprMatchContext :: (Outputable (IdP p), UnXRec p) ++ => HsMatchContext p -> SDoc ++pprMatchContext ctxt ++ | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt ++ | otherwise = text "a" <+> pprMatchContextNoun ctxt ++ where ++ want_an (FunRhs {}) = True -- Use "an" in front ++ want_an ProcExpr = True ++ want_an _ = False ++ ++pprMatchContextNoun :: forall p. (Outputable (IdP p), UnXRec p) ++ => HsMatchContext p -> SDoc ++pprMatchContextNoun (FunRhs {mc_fun=fun}) ++ = text "equation for" ++ <+> quotes (ppr (unXRec @p fun)) ++pprMatchContextNoun CaseAlt = text "case alternative" ++pprMatchContextNoun IfAlt = text "multi-way if alternative" ++pprMatchContextNoun RecUpd = text "record-update construct" ++pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice" ++pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation" ++pprMatchContextNoun PatBindRhs = text "pattern binding" ++pprMatchContextNoun PatBindGuards = text "pattern binding guards" ++pprMatchContextNoun LambdaExpr = text "lambda abstraction" ++pprMatchContextNoun ProcExpr = text "arrow abstraction" ++pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" ++ $$ pprAStmtContext ctxt ++pprMatchContextNoun PatSyn = text "pattern synonym declaration" ++ ++----------------- ++pprAStmtContext, pprStmtContext :: (Outputable (IdP p), UnXRec p) ++ => HsStmtContext p -> SDoc ++pprAStmtContext ctxt = article <+> pprStmtContext ctxt ++ where ++ pp_an = text "an" ++ pp_a = text "a" ++ article = case ctxt of ++ MDoExpr Nothing -> pp_an ++ GhciStmtCtxt -> pp_an ++ _ -> pp_a ++ ++ ++----------------- ++pprStmtContext GhciStmtCtxt = text "interactive GHCi command" ++pprStmtContext (DoExpr m) = prependQualified m (text "'do' block") ++pprStmtContext (MDoExpr m) = prependQualified m (text "'mdo' block") ++pprStmtContext ArrowExpr = text "'do' block in an arrow command" ++pprStmtContext ListComp = text "list comprehension" ++pprStmtContext MonadComp = text "monad comprehension" ++pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt ++ ++-- Drop the inner contexts when reporting errors, else we get ++-- Unexpected transform statement ++-- in a transformed branch of ++-- transformed branch of ++-- transformed branch of monad comprehension ++pprStmtContext (ParStmtCtxt c) = ++ ifPprDebug (sep [text "parallel branch of", pprAStmtContext c]) ++ (pprStmtContext c) ++pprStmtContext (TransStmtCtxt c) = ++ ifPprDebug (sep [text "transformed branch of", pprAStmtContext c]) ++ (pprStmtContext c) ++ ++prependQualified :: Maybe ModuleName -> SDoc -> SDoc ++prependQualified Nothing t = t ++prependQualified (Just _) t = text "qualified" <+> t +diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs +index 9d6fa7f29b..a11cf728ae 100644 +--- a/compiler/cmm/CmmNode.hs ++++ b/compiler/cmm/CmmNode.hs +@@ -34,7 +34,7 @@ import FastString + import ForeignCall + import Outputable + import SMRep +-import CoreSyn (Tickish) ++import CoreSyn (CmmTickish) + import qualified Unique as U + + import Hoopl.Block +@@ -592,9 +592,6 @@ mapCollectSuccessors _ n = (n, []) + + -- ----------------------------------------------------------------------------- + +--- | Tickish in Cmm context (annotations only) +-type CmmTickish = Tickish () +- + -- | Tick scope identifier, allowing us to reason about what + -- annotations in a Cmm block should scope over. We especially take + -- care to allow optimisations to reorganise blocks without losing +diff --git a/compiler/cmm/CmmParse.hs b/compiler/cmm/CmmParse.hs +index e7527f8e50..454c0efd21 100644 +--- a/compiler/cmm/CmmParse.hs ++++ b/compiler/cmm/CmmParse.hs +@@ -220,7 +220,7 @@ import GHC.StgToCmm.Closure + import GHC.StgToCmm.Layout hiding (ArgRep(..)) + import GHC.StgToCmm.Ticky + import GHC.StgToCmm.Bind ( emitBlackHoleCode, emitUpdateFrame ) +-import CoreSyn ( Tickish(SourceNote) ) ++import CoreSyn ( GenTickish(SourceNote) ) + + import CmmOpt + import MkGraph +diff --git a/compiler/cmm/CmmParse.y.source b/compiler/cmm/CmmParse.y.source +index e7527f8e50..454c0efd21 100644 +--- a/compiler/cmm/CmmParse.y.source ++++ b/compiler/cmm/CmmParse.y.source +@@ -220,7 +220,7 @@ import GHC.StgToCmm.Closure + import GHC.StgToCmm.Layout hiding (ArgRep(..)) + import GHC.StgToCmm.Ticky + import GHC.StgToCmm.Bind ( emitBlackHoleCode, emitUpdateFrame ) +-import CoreSyn ( Tickish(SourceNote) ) ++import CoreSyn ( GenTickish(SourceNote) ) + + import CmmOpt + import MkGraph +diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs +index 7f52054496..2d7421634b 100644 +--- a/compiler/coreSyn/CoreFVs.hs ++++ b/compiler/coreSyn/CoreFVs.hs +@@ -6,6 +6,7 @@ Taken quite directly from the Peyton Jones/Lester paper. + -} + + {-# LANGUAGE CPP #-} ++{-# LANGUAGE TypeFamilies #-} + + -- | A module concerned with finding the free variables of an expression. + module CoreFVs ( +@@ -289,8 +290,8 @@ rhs_fvs (bndr, rhs) = expr_fvs rhs `unionFV` + exprs_fvs :: [CoreExpr] -> FV + exprs_fvs exprs = mapUnionFV expr_fvs exprs + +-tickish_fvs :: Tickish Id -> FV +-tickish_fvs (Breakpoint _ ids) = FV.mkFVs ids ++tickish_fvs :: CoreTickish -> FV ++tickish_fvs (Breakpoint _ _ ids) = FV.mkFVs ids + tickish_fvs _ = emptyFV + + {- +@@ -771,8 +772,8 @@ freeVars = go + , AnnTick tickish expr2 ) + where + expr2 = go expr +- tickishFVs (Breakpoint _ ids) = mkDVarSet ids +- tickishFVs _ = emptyDVarSet ++ tickishFVs (Breakpoint _ _ ids) = mkDVarSet ids ++ tickishFVs _ = emptyDVarSet + + go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty) + go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co) +diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs +index def51f5010..f5a3d0f713 100644 +--- a/compiler/coreSyn/CoreLint.hs ++++ b/compiler/coreSyn/CoreLint.hs +@@ -15,6 +15,8 @@ module CoreLint ( + lintPassResult, lintInteractiveExpr, lintExpr, + lintAnnots, lintTypes, + ++ interactiveInScope, ++ + -- ** Debug output + endPass, endPassIO, + dumpPassResult, +@@ -735,10 +737,10 @@ lintCoreExpr (Cast expr co) + + lintCoreExpr (Tick tickish expr) + = do case tickish of +- Breakpoint _ ids -> forM_ ids $ \id -> do +- checkDeadIdOcc id +- lookupIdInScope id +- _ -> return () ++ Breakpoint _ _ ids -> forM_ ids $ \id -> do ++ checkDeadIdOcc id ++ lookupIdInScope id ++ _ -> return () + markAllJoinsBadIf block_joins $ lintCoreExpr expr + where + block_joins = not (tickish `tickishScopesLike` SoftScope) +diff --git a/compiler/coreSyn/CoreMap.hs b/compiler/coreSyn/CoreMap.hs +index d50dcbf1bc..73f8a75d54 100644 +--- a/compiler/coreSyn/CoreMap.hs ++++ b/compiler/coreSyn/CoreMap.hs +@@ -343,11 +343,11 @@ xtE (D env (Case e b ty as)) f m + in xtList (xtA env1) as f } + + -- TODO: this seems a bit dodgy, see 'eqTickish' +-type TickishMap a = Map.Map (Tickish Id) a +-lkTickish :: Tickish Id -> TickishMap a -> Maybe a ++type TickishMap a = Map.Map CoreTickish a ++lkTickish :: CoreTickish -> TickishMap a -> Maybe a + lkTickish = lookupTM + +-xtTickish :: Tickish Id -> XT a -> TickishMap a -> TickishMap a ++xtTickish :: CoreTickish -> XT a -> TickishMap a -> TickishMap a + xtTickish = alterTM + + ------------------------ +diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs +index a2eeb9beb8..1c598f4aec 100644 +--- a/compiler/coreSyn/CoreOpt.hs ++++ b/compiler/coreSyn/CoreOpt.hs +@@ -1168,7 +1168,7 @@ Currently, it is used in Rules.match, and is required to make + -} + + exprIsLambda_maybe :: InScopeEnv -> CoreExpr +- -> Maybe (Var, CoreExpr,[Tickish Id]) ++ -> Maybe (Var, CoreExpr,[CoreTickish]) + -- See Note [exprIsLambda_maybe] + + -- The simple case: It is a lambda already +diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs +index 09f53276bd..fa5a32cb4d 100644 +--- a/compiler/coreSyn/CorePrep.hs ++++ b/compiler/coreSyn/CorePrep.hs +@@ -636,9 +636,9 @@ cpeRhsE env (Tick tickish expr) + = do { body <- cpeBodyNF env expr + ; return (emptyFloats, mkTick tickish' body) } + where +- tickish' | Breakpoint n fvs <- tickish ++ tickish' | Breakpoint ext n fvs <- tickish + -- See also 'substTickish' +- = Breakpoint n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs) ++ = Breakpoint ext n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs) + | otherwise + = tickish + +@@ -784,7 +784,7 @@ rhsToBody expr = return (emptyFloats, expr) + + data ArgInfo = CpeApp CoreArg + | CpeCast Coercion +- | CpeTick (Tickish Id) ++ | CpeTick CoreTickish + + {- Note [runRW arg] + ~~~~~~~~~~~~~~~~~~~ +@@ -1218,7 +1218,7 @@ data FloatingBind + Bool -- The bool indicates "ok-for-speculation" + + -- | See Note [Floating Ticks in CorePrep] +- | FloatTick (Tickish Id) ++ | FloatTick CoreTickish + + data Floats = Floats OkToSpec (OrdList FloatingBind) + +diff --git a/compiler/coreSyn/CoreSeq.hs b/compiler/coreSyn/CoreSeq.hs +index 7de8923a71..a0b5f2ee17 100644 +--- a/compiler/coreSyn/CoreSeq.hs ++++ b/compiler/coreSyn/CoreSeq.hs +@@ -20,7 +20,7 @@ import VarSet( seqDVarSet ) + import Var( varType, tyVarKind ) + import Type( seqType, isTyVar ) + import Coercion( seqCo ) +-import Id( Id, idInfo ) ++import Id( idInfo ) + + -- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the + -- compiler +@@ -69,7 +69,7 @@ seqExprs :: [CoreExpr] -> () + seqExprs [] = () + seqExprs (e:es) = seqExpr e `seq` seqExprs es + +-seqTickish :: Tickish Id -> () ++seqTickish :: CoreTickish -> () + seqTickish ProfNote{ profNoteCC = cc } = cc `seq` () + seqTickish HpcTick{} = () + seqTickish Breakpoint{ breakpointFVs = ids } = seqBndrs ids +diff --git a/compiler/coreSyn/CoreStats.hs b/compiler/coreSyn/CoreStats.hs +index fde107b372..a03d62472f 100644 +--- a/compiler/coreSyn/CoreStats.hs ++++ b/compiler/coreSyn/CoreStats.hs +@@ -116,7 +116,7 @@ exprSize (Tick n e) = tickSize n + exprSize e + exprSize (Type _) = 1 + exprSize (Coercion _) = 1 + +-tickSize :: Tickish Id -> Int ++tickSize :: CoreTickish -> Int + tickSize (ProfNote _ _ _) = 1 + tickSize _ = 1 + +diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs +index 0eedca4201..1675b16318 100644 +--- a/compiler/coreSyn/CoreSubst.hs ++++ b/compiler/coreSyn/CoreSubst.hs +@@ -705,9 +705,9 @@ substDVarSet subst fvs + | otherwise = tyCoFVsOfType (lookupTCvSubst subst fv) (const True) emptyVarSet $! acc + + ------------------ +-substTickish :: Subst -> Tickish Id -> Tickish Id +-substTickish subst (Breakpoint n ids) +- = Breakpoint n (map do_one ids) ++substTickish :: Subst -> CoreTickish -> CoreTickish ++substTickish subst (Breakpoint ext n ids) ++ = Breakpoint ext n (map do_one ids) + where + do_one = getIdFromTrivialExpr . lookupIdSubst (text "subst_tickish") subst + substTickish _subst other = other +diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs +index e3ad4715f1..9655d3ad09 100644 +--- a/compiler/coreSyn/CoreSyn.hs ++++ b/compiler/coreSyn/CoreSyn.hs +@@ -6,12 +6,18 @@ + {-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts #-} + {-# LANGUAGE NamedFieldPuns #-} + {-# LANGUAGE BangPatterns #-} ++{-# LANGUAGE KindSignatures #-} ++{-# LANGUAGE DataKinds #-} ++{-# LANGUAGE StandaloneDeriving #-} ++{-# LANGUAGE TypeFamilies #-} ++{-# LANGUAGE FlexibleInstances #-} + + -- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection + module CoreSyn ( + -- * Main data types + Expr(..), Alt, Bind(..), AltCon(..), Arg, +- Tickish(..), TickishScoping(..), TickishPlacement(..), ++ CoreTickish, StgTickish, CmmTickish, XTickishId, ++ GenTickish(..), TickishScoping(..), TickishPlacement(..), + CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr, + TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr, + +@@ -118,6 +124,8 @@ import UniqSet + import SrcLoc ( RealSrcSpan, containsSpan ) + import Binary + ++import GHC.Hs.Extension ( NoExtField ) ++ + import Data.Data hiding (TyCon) + import Data.Int + import Data.Word +@@ -260,7 +268,7 @@ data Expr b + | Case (Expr b) b Type [Alt b] -- See Note [Case expression invariants] + -- and Note [Why does Case have a 'Type' field?] + | Cast (Expr b) Coercion +- | Tick (Tickish Id) (Expr b) ++ | Tick CoreTickish (Expr b) + | Type Type + | Coercion Coercion + deriving Data +@@ -932,9 +940,31 @@ type MOutCoercion = MCoercion + + -- | Allows attaching extra information to points in expressions + ++-- | Used as a data type index for the GenTickish annotations ++data TickishPass ++ = TickishCore ++ | TickishStg ++ | TickishCmm ++ ++type family XBreakpoint (pass :: TickishPass) ++type instance XBreakpoint 'TickishCore = NoExtField ++-- | Keep track of the type of breakpoints in STG, for GHCi ++type instance XBreakpoint 'TickishStg = Type ++type instance XBreakpoint 'TickishCmm = NoExtField ++ ++type family XTickishId (pass :: TickishPass) ++type instance XTickishId 'TickishCore = Id ++type instance XTickishId 'TickishStg = Id ++type instance XTickishId 'TickishCmm = NoExtField ++ ++type CoreTickish = GenTickish 'TickishCore ++type StgTickish = GenTickish 'TickishStg ++-- | Tickish in Cmm context (annotations only) ++type CmmTickish = GenTickish 'TickishCmm ++ + -- If you edit this type, you may need to update the GHC formalism + -- See Note [GHC Formalism] in coreSyn/CoreLint.hs +-data Tickish id = ++data GenTickish pass = + -- | An @{-# SCC #-}@ profiling annotation, either automatically + -- added by the desugarer as a result of -auto-all, or added by + -- the user. +@@ -959,8 +989,10 @@ data Tickish id = + -- NB. we must take account of these Ids when (a) counting free variables, + -- and (b) substituting (don't substitute for them) + | Breakpoint +- { breakpointId :: !Int +- , breakpointFVs :: [id] -- ^ the order of this list is important: ++ { breakpointExt :: XBreakpoint pass ++ , breakpointId :: !Int ++ , breakpointFVs :: [XTickishId pass] ++ -- ^ the order of this list is important: + -- it matches the order of the lists in the + -- appropriate entry in HscTypes.ModBreaks. + -- +@@ -990,7 +1022,16 @@ data Tickish id = + -- (uses same names as CCs) + } + +- deriving (Eq, Ord, Data) ++deriving instance Eq (GenTickish 'TickishCore) ++deriving instance Ord (GenTickish 'TickishCore) ++deriving instance Data (GenTickish 'TickishCore) ++ ++deriving instance Data (GenTickish 'TickishStg) ++ ++deriving instance Eq (GenTickish 'TickishCmm) ++deriving instance Ord (GenTickish 'TickishCmm) ++deriving instance Data (GenTickish 'TickishCmm) ++ + + -- | A "counting tick" (where tickishCounts is True) is one that + -- counts evaluations in some way. We cannot discard a counting tick, +@@ -1000,7 +1041,7 @@ data Tickish id = + -- However, we still allow the simplifier to increase or decrease + -- sharing, so in practice the actual number of ticks may vary, except + -- that we never change the value from zero to non-zero or vice versa. +-tickishCounts :: Tickish id -> Bool ++tickishCounts :: GenTickish pass -> Bool + tickishCounts n@ProfNote{} = profNoteCount n + tickishCounts HpcTick{} = True + tickishCounts Breakpoint{} = True +@@ -1069,7 +1110,7 @@ data TickishScoping = + deriving (Eq) + + -- | Returns the intended scoping rule for a Tickish +-tickishScoped :: Tickish id -> TickishScoping ++tickishScoped :: GenTickish pass -> TickishScoping + tickishScoped n@ProfNote{} + | profNoteScope n = CostCentreScope + | otherwise = NoScope +@@ -1082,7 +1123,7 @@ tickishScoped SourceNote{} = SoftScope + + -- | Returns whether the tick scoping rule is at least as permissive + -- as the given scoping rule. +-tickishScopesLike :: Tickish id -> TickishScoping -> Bool ++tickishScopesLike :: GenTickish pass -> TickishScoping -> Bool + tickishScopesLike t scope = tickishScoped t `like` scope + where NoScope `like` _ = True + _ `like` NoScope = False +@@ -1101,24 +1142,24 @@ tickishScopesLike t scope = tickishScoped t `like` scope + -- @tickishCounts@. Note that in principle splittable ticks can become + -- floatable using @mkNoTick@ -- even though there's currently no + -- tickish for which that is the case. +-tickishFloatable :: Tickish id -> Bool ++tickishFloatable :: GenTickish pass -> Bool + tickishFloatable t = t `tickishScopesLike` SoftScope && not (tickishCounts t) + + -- | Returns @True@ for a tick that is both counting /and/ scoping and + -- can be split into its (tick, scope) parts using 'mkNoScope' and + -- 'mkNoTick' respectively. +-tickishCanSplit :: Tickish id -> Bool ++tickishCanSplit :: GenTickish pass -> Bool + tickishCanSplit ProfNote{profNoteScope = True, profNoteCount = True} + = True + tickishCanSplit _ = False + +-mkNoCount :: Tickish id -> Tickish id ++mkNoCount :: GenTickish pass -> GenTickish pass + mkNoCount n | not (tickishCounts n) = n + | not (tickishCanSplit n) = panic "mkNoCount: Cannot split!" + mkNoCount n@ProfNote{} = n {profNoteCount = False} + mkNoCount _ = panic "mkNoCount: Undefined split!" + +-mkNoScope :: Tickish id -> Tickish id ++mkNoScope :: GenTickish pass -> GenTickish pass + mkNoScope n | tickishScoped n == NoScope = n + | not (tickishCanSplit n) = panic "mkNoScope: Cannot split!" + mkNoScope n@ProfNote{} = n {profNoteScope = False} +@@ -1139,7 +1180,7 @@ mkNoScope _ = panic "mkNoScope: Undefined split!" + -- Here there is just no operational difference between the first and + -- the second version. Therefore code generation should simply + -- translate the code as if it found the latter. +-tickishIsCode :: Tickish id -> Bool ++tickishIsCode :: GenTickish pass -> Bool + tickishIsCode SourceNote{} = False + tickishIsCode _tickish = True -- all the rest for now + +@@ -1179,7 +1220,7 @@ data TickishPlacement = + deriving (Eq) + + -- | Placement behaviour we want for the ticks +-tickishPlace :: Tickish id -> TickishPlacement ++tickishPlace :: GenTickish pass -> TickishPlacement + tickishPlace n@ProfNote{} + | profNoteCount n = PlaceRuntime + | otherwise = PlaceCostCentre +@@ -1189,7 +1230,8 @@ tickishPlace SourceNote{} = PlaceNonLam + + -- | Returns whether one tick "contains" the other one, therefore + -- making the second tick redundant. +-tickishContains :: Eq b => Tickish b -> Tickish b -> Bool ++tickishContains :: Eq (GenTickish pass) ++ => GenTickish pass -> GenTickish pass -> Bool + tickishContains (SourceNote sp1 n1) (SourceNote sp2 n2) + = containsSpan sp1 sp2 && n1 == n2 + -- compare the String last +@@ -2187,8 +2229,8 @@ stripNArgs _ _ = Nothing + + -- | Like @collectArgs@, but also collects looks through floatable + -- ticks if it means that we can find more arguments. +-collectArgsTicks :: (Tickish Id -> Bool) -> Expr b +- -> (Expr b, [Arg b], [Tickish Id]) ++collectArgsTicks :: (CoreTickish -> Bool) -> Expr b ++ -> (Expr b, [Arg b], [CoreTickish]) + collectArgsTicks skipTick expr + = go expr [] [] + where +@@ -2273,7 +2315,7 @@ data AnnExpr' bndr annot + | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot) + | AnnCast (AnnExpr bndr annot) (annot, Coercion) + -- Put an annotation on the (root of) the coercion +- | AnnTick (Tickish Id) (AnnExpr bndr annot) ++ | AnnTick CoreTickish (AnnExpr bndr annot) + | AnnType Type + | AnnCoercion Coercion + +@@ -2294,8 +2336,8 @@ collectAnnArgs expr + go (_, AnnApp f a) as = go f (a:as) + go e as = (e, as) + +-collectAnnArgsTicks :: (Tickish Var -> Bool) -> AnnExpr b a +- -> (AnnExpr b a, [AnnExpr b a], [Tickish Var]) ++collectAnnArgsTicks :: (CoreTickish -> Bool) -> AnnExpr b a ++ -> (AnnExpr b a, [AnnExpr b a], [CoreTickish]) + collectAnnArgsTicks tickishOk expr + = go expr [] [] + where +diff --git a/compiler/coreSyn/CoreTidy.hs b/compiler/coreSyn/CoreTidy.hs +index 3c924663f5..e6009445cb 100644 +--- a/compiler/coreSyn/CoreTidy.hs ++++ b/compiler/coreSyn/CoreTidy.hs +@@ -86,8 +86,9 @@ tidyAlt env (con, vs, rhs) + (con, vs, tidyExpr env' rhs) + + ------------ Tickish -------------- +-tidyTickish :: TidyEnv -> Tickish Id -> Tickish Id +-tidyTickish env (Breakpoint ix ids) = Breakpoint ix (map (tidyVarOcc env) ids) ++tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish ++tidyTickish env (Breakpoint ext ix ids) ++ = Breakpoint ext ix (map (tidyVarOcc env) ids) + tidyTickish _ other_tickish = other_tickish + + ------------ Rules -------------- +diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs +index 16f4a00341..283a9c7fdd 100644 +--- a/compiler/coreSyn/CoreUtils.hs ++++ b/compiler/coreSyn/CoreUtils.hs +@@ -295,7 +295,7 @@ mkCast expr co + + -- | Wraps the given expression in the source annotation, dropping the + -- annotation if possible. +-mkTick :: Tickish Id -> CoreExpr -> CoreExpr ++mkTick :: CoreTickish -> CoreExpr -> CoreExpr + mkTick t orig_expr = mkTick' id id orig_expr + where + -- Some ticks (cost-centres) can be split in two, with the +@@ -380,7 +380,7 @@ mkTick t orig_expr = mkTick' id id orig_expr + -- Catch-all: Annotate where we stand + _any -> top $ Tick t $ rest expr + +-mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr ++mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr + mkTicks ticks expr = foldr mkTick expr ticks + + isSaturatedConApp :: CoreExpr -> Bool +@@ -391,13 +391,13 @@ isSaturatedConApp e = go e [] + go (Cast f _) as = go f as + go _ _ = False + +-mkTickNoHNF :: Tickish Id -> CoreExpr -> CoreExpr ++mkTickNoHNF :: CoreTickish -> CoreExpr -> CoreExpr + mkTickNoHNF t e + | exprIsHNF e = tickHNFArgs t e + | otherwise = mkTick t e + + -- push a tick into the arguments of a HNF (call or constructor app) +-tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr ++tickHNFArgs :: CoreTickish -> CoreExpr -> CoreExpr + tickHNFArgs t e = push t e + where + push t (App f (Type u)) = App (push t f) (Type u) +@@ -405,28 +405,28 @@ tickHNFArgs t e = push t e + push _t e = e + + -- | Strip ticks satisfying a predicate from top of an expression +-stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b) ++stripTicksTop :: (CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b) + stripTicksTop p = go [] + where go ts (Tick t e) | p t = go (t:ts) e + go ts other = (reverse ts, other) + + -- | Strip ticks satisfying a predicate from top of an expression, + -- returning the remaining expression +-stripTicksTopE :: (Tickish Id -> Bool) -> Expr b -> Expr b ++stripTicksTopE :: (CoreTickish -> Bool) -> Expr b -> Expr b + stripTicksTopE p = go + where go (Tick t e) | p t = go e + go other = other + + -- | Strip ticks satisfying a predicate from top of an expression, + -- returning the ticks +-stripTicksTopT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id] ++stripTicksTopT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish] + stripTicksTopT p = go [] + where go ts (Tick t e) | p t = go (t:ts) e + go ts _ = ts + + -- | Completely strip ticks satisfying a predicate from an + -- expression. Note this is O(n) in the size of the expression! +-stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b ++stripTicksE :: (CoreTickish -> Bool) -> Expr b -> Expr b + stripTicksE p expr = go expr + where go (App e a) = App (go e) (go a) + go (Lam b e) = Lam b (go e) +@@ -442,7 +442,7 @@ stripTicksE p expr = go expr + go_b (b, e) = (b, go e) + go_a (c,bs,e) = (c,bs, go e) + +-stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id] ++stripTicksT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish] + stripTicksT p expr = fromOL $ go expr + where go (App e a) = go e `appOL` go a + go (Lam _ e) = go e +@@ -2059,7 +2059,7 @@ cheapEqExpr :: Expr b -> Expr b -> Bool + cheapEqExpr = cheapEqExpr' (const False) + + -- | Cheap expression equality test, can ignore ticks by type. +-cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool ++cheapEqExpr' :: (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool + cheapEqExpr' ignoreTick = go_s + where go_s = go `on` stripTicksTopE ignoreTick + go (Var v1) (Var v2) = v1 == v2 +@@ -2136,8 +2136,8 @@ eqExpr in_scope e1 e2 + go_alt env (c1, bs1, e1) (c2, bs2, e2) + = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2 + +-eqTickish :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool +-eqTickish env (Breakpoint lid lids) (Breakpoint rid rids) ++eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool ++eqTickish env (Breakpoint _ lid lids) (Breakpoint _ rid rids) + = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids + eqTickish _ l r = l == r + +@@ -2443,7 +2443,7 @@ tryEtaReduce bndrs body + -> Coercion -- Of kind (t1~t2) + -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) + -- (and similarly for tyvars, coercion args) +- , [Tickish Var]) ++ , [CoreTickish]) + -- See Note [Eta reduction with casted arguments] + ok_arg bndr (Type ty) co + | Just tv <- getTyVar_maybe ty +diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs +index c959fc1c4e..e78e5f6b0f 100644 +--- a/compiler/coreSyn/PprCore.hs ++++ b/compiler/coreSyn/PprCore.hs +@@ -7,6 +7,8 @@ Printing of Core syntax + -} + + {-# LANGUAGE MultiWayIf #-} ++{-# LANGUAGE FlexibleContexts #-} ++{-# LANGUAGE UndecidableInstances #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} + module PprCore ( + pprCoreExpr, pprParendExpr, +@@ -597,13 +599,13 @@ pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, + ----------------------------------------------------- + -} + +-instance Outputable id => Outputable (Tickish id) where ++instance Outputable (XTickishId pass) => Outputable (GenTickish pass) where + ppr (HpcTick modl ix) = + hcat [text "hpc<", + ppr modl, comma, + ppr ix, + text ">"] +- ppr (Breakpoint ix vars) = ++ ppr (Breakpoint _ext ix vars) = + hcat [text "break<", + ppr ix, + text ">", +diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs +index 91b632f27e..ac5c0cd8e6 100644 +--- a/compiler/deSugar/Coverage.hs ++++ b/compiler/deSugar/Coverage.hs +@@ -366,7 +366,7 @@ addTickLHsBind _ = panic "addTickLHsBind: Impossible Match" -- due to #15884 + + + bindTick +- :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id)) ++ :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe CoreTickish) + bindTick density name pos fvs = do + decl_path <- getPathEntry + let +@@ -1189,7 +1189,7 @@ allocTickBox boxLabel countEntries topOnly pos m = + -- the tick application inherits the source position of its + -- expression argument to support nested box allocations + allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars +- -> TM (Maybe (Tickish Id)) ++ -> TM (Maybe CoreTickish) + allocATickBox boxLabel countEntries topOnly pos fvs = + ifGoodTickSrcSpan pos (do + let +@@ -1203,7 +1203,7 @@ allocATickBox boxLabel countEntries topOnly pos fvs = + + + mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String] +- -> TM (Tickish Id) ++ -> TM CoreTickish + mkTickish boxLabel countEntries topOnly pos fvs decl_path = do + + let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs +@@ -1238,7 +1238,7 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do + c <- liftM tickBoxCount getState + setState $ \st -> st { tickBoxCount = c + 1 + , mixEntries = me:mixEntries st } +- return $ Breakpoint c ids ++ return $ Breakpoint noExtField c ids + + SourceNotes | RealSrcSpan pos' <- pos -> + return $ SourceNote pos' cc_name +diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs +index b76c4f0592..c94595b29d 100644 +--- a/compiler/deSugar/DsUtils.hs ++++ b/compiler/deSugar/DsUtils.hs +@@ -665,7 +665,7 @@ work out well: + which is better. + -} + +-mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly ++mkSelectorBinds :: [[CoreTickish]] -- ^ ticks to add, possibly + -> LPat GhcTc -- ^ The pattern + -> CoreExpr -- ^ Expression to which the pattern is bound + -> DsM (Id,[(Id,CoreExpr)]) +@@ -890,7 +890,7 @@ the tail call property. For example, see #3403. + * * + ********************************************************************* -} + +-mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr ++mkOptTickBox :: [CoreTickish] -> CoreExpr -> CoreExpr + mkOptTickBox = flip (foldr Tick) + + mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs -index 44876efc91..8b0fb9a17e 100644 +index 44876efc91..9d2aea3d4a 100644 --- a/compiler/ghci/ByteCodeAsm.hs +++ b/compiler/ghci/ByteCodeAsm.hs @@ -7,10 +7,10 @@ @@ -11,7 +4083,7 @@ index 44876efc91..8b0fb9a17e 100644 SizedSeq, sizeSS, ssElts, - iNTERP_STACK_CHECK_THRESH + iNTERP_STACK_CHECK_THRESH, -+ mkTupleInfoSig ++ mkTupleInfoLit ) where #include "HsVersions.h" @@ -40,7 +4112,7 @@ index 44876efc91..8b0fb9a17e 100644 CCALL off m_addr i -> do np <- addr m_addr emit bci_CCALL [SmallOp off, Op np, SmallOp i] BRK_FUN index uniq cc -> do p1 <- ptr BCOPtrBreakArray -@@ -501,6 +512,41 @@ return_ubx V16 = error "return_ubx: vector" +@@ -501,6 +512,64 @@ return_ubx V16 = error "return_ubx: vector" return_ubx V32 = error "return_ubx: vector" return_ubx V64 = error "return_ubx: vector" @@ -58,10 +4130,29 @@ index 44876efc91..8b0fb9a17e 100644 + because we need a stg_ctoi_tN stack frame for each size N + + If needed, you can support larger tuples by adding more in -+ StgMiscClosures.cmm and MiscClosures.h -+ -} ++ StgMiscClosures.cmm and MiscClosures.h and raising this limit. ++ -} + | tupleNativeStackSize > 32 = + pprPanic "mkTupleInfoSig: tuple too big" (ppr tupleNativeStackSize) ++ {- ++ Check that we aren't using too many registers for argument passing. ++ If this panic is triggered, the calling convention uses more. ++ ++ You can raise the limits after modifying stg_ctoi_t and stg_ret_t ++ (StgMiscClosures.cmm) to save and restore the additional registers. ++ -} ++ | tupleVanillaRegs >= 64 = -- at most 6 vanilla registers ++ pprPanic "mkTupleInfoSig: too many vanilla registers" (ppr tupleVanillaRegs) ++ | tupleLongRegs >= 2 = -- at most 1 long register ++ pprPanic "mkTupleInfoSig: too many long registers" (ppr tupleLongRegs) ++ | tupleFloatRegs >= 64 = -- at most 6 float registers ++ pprPanic "mkTupleInfoSig: too many float registers" (ppr tupleFloatRegs) ++ | tupleDoubleRegs >= 64 = -- at most 6 double registers ++ pprPanic "mkTupleInfoSig: too many double registers" (ppr tupleDoubleRegs) ++ {- ++ Check that we can pack the register counts/bitmaps and stack size ++ in the information word. ++ -} + | tupleNativeStackSize < 16384 && + tupleDoubleRegs < 64 && -- 6 bit bitmap (these can be shared with float) + tupleFloatRegs < 64 && -- 6 bit bitmap (these can be shared with double) @@ -78,27 +4169,235 @@ index 44876efc91..8b0fb9a17e 100644 + where + w :: Int -> Word32 + w = fromIntegral ++ ++mkTupleInfoLit :: DynFlags -> TupleInfo -> Literal ++mkTupleInfoLit dflags tuple_info = ++ mkLitWord dflags . fromIntegral $ mkTupleInfoSig tuple_info + -- Make lists of host-sized words for literals, so that when the -- words are placed in memory at increasing addresses, the -- bit pattern is correct for the host's word size and endianness. diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs -index fb60c21f9d..62e8457c5a 100644 +index fb60c21f9d..d28e35d808 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs -@@ -17,6 +17,11 @@ import ByteCodeInstr - import ByteCodeAsm - import ByteCodeTypes - +@@ -30,12 +30,9 @@ import Id + import Var ( updateVarType ) + import ForeignCall + import HscTypes +-import CoreUtils + import CoreSyn +-import PprCore + import Literal + import PrimOp +-import CoreFVs + import Type + import RepType + import DataCon +@@ -55,6 +52,12 @@ import Bitmap + import OrdList + import Maybes + import VarEnv +import CmmCallConv ++import CmmType +import CmmExpr +import CmmNode +import CmmUtils ++import PrelInfo + + import Data.List + import Foreign +@@ -76,12 +79,16 @@ import Data.Ord + import GHC.Stack.CCS + import Data.Either ( partitionEithers ) + ++import qualified CostCentre as CC ++import StgSyn ++import StgFVs + - import GHCi - import GHCi.FFI - import GHCi.RemoteTypes -@@ -195,12 +200,6 @@ simpleFreeVars = freeVars + -- ----------------------------------------------------------------------------- + -- Generating byte code for a complete module + + byteCodeGen :: HscEnv + -> Module +- -> CoreProgram ++ -> [StgTopBinding] + -> [TyCon] + -> Maybe ModBreaks + -> IO CompiledByteCode +@@ -91,17 +98,22 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks + (const ()) $ do + -- Split top-level binds into strings and others. + -- See Note [generating code for top-level string literal bindings]. +- let (strings, flatBinds) = partitionEithers $ do -- list monad +- (bndr, rhs) <- flattenBinds binds +- return $ case exprIsTickedString_maybe rhs of +- Just str -> Left (bndr, str) +- _ -> Right (bndr, simpleFreeVars rhs) ++ let (strings, lifted_binds) = partitionEithers $ do -- list monad ++ bnd <- binds ++ case bnd of ++ StgTopLifted bnd -> [Right bnd] ++ StgTopStringLit b str -> [Left (b, str)] ++ flattenBind (StgNonRec b e) = [(b,e)] ++ flattenBind (StgRec bs) = bs + stringPtrs <- allocateTopStrings hsc_env strings + + us <- mkSplitUniqSupply 'y' + (BcM_State{..}, proto_bcos) <- +- runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $ +- mapM schemeTopBind flatBinds ++ runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $ do ++ prepd_binds <- mapM bcPrepBind lifted_binds ++ let flattened_binds = ++ concatMap (flattenBind . annBindingFreeVars) (reverse prepd_binds) ++ mapM schemeTopBind flattened_binds + + when (notNull ffis) + (panic "ByteCodeGen.byteCodeGen: missing final emitBc?") +@@ -155,23 +167,25 @@ literals: + -- Returns: the root BCO for this expression + coreExprToBCOs :: HscEnv + -> Module +- -> CoreExpr ++ -> Id ++ -> StgRhs + -> IO UnlinkedBCO +-coreExprToBCOs hsc_env this_mod expr ++coreExprToBCOs hsc_env this_mod bndr expr + = withTiming dflags + (text "ByteCodeGen"<+>brackets (ppr this_mod)) + (const ()) $ do +- -- create a totally bogus name for the top-level BCO; this +- -- should be harmless, since it's never used for anything +- let invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel") +- invented_id = Id.mkLocalId invented_name (panic "invented_id's type") + + -- the uniques are needed to generate fresh variables when we introduce new + -- let bindings for ticked expressions + us <- mkSplitUniqSupply 'y' + (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco) +- <- runBc hsc_env us this_mod Nothing emptyVarEnv $ +- schemeTopBind (invented_id, simpleFreeVars expr) ++ <- runBc hsc_env us this_mod Nothing emptyVarEnv $ do ++ prepd_expr <- annBindingFreeVars <$> ++ bcPrepBind (StgNonRec bndr expr) ++ case prepd_expr of ++ (StgNonRec _ cg_expr) -> schemeR [] (idName bndr, cg_expr) ++ _ -> ++ panic "GHC.CoreToByteCode.coreExprToBCOs" + + when (notNull mallocd) + (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?") +@@ -181,26 +195,106 @@ coreExprToBCOs hsc_env this_mod expr + assembleOneBCO hsc_env proto_bco + where dflags = hsc_dflags hsc_env + +--- The regular freeVars function gives more information than is useful to +--- us here. We need only the free variables, not everything in an FVAnn. +--- Historical note: At one point FVAnn was more sophisticated than just +--- a set. Now it isn't. So this function is much simpler. Keeping it around +--- so that if someone changes FVAnn, they will get a nice type error right +--- here. +-simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet +-simpleFreeVars = freeVars ++{- ++ Prepare the STG for bytecode generation: ++ ++ - Ensure that all breakpoints are directly under ++ a let-binding, introducing a new binding for ++ those that aren't already. ++ ++ - Protect Not-necessarily lifted join points, see ++ Note [Not-necessarily-lifted join points] ++ ++ -} ++ ++bcPrepRHS :: StgRhs -> BcM StgRhs ++-- explicitly match all constructors so we get a warning if we miss any ++bcPrepRHS (StgRhsClosure fvs cc upd args (StgTick bp@Breakpoint{} expr)) = do ++ {- If we have a breakpoint directly under an StgRhsClosure we don't ++ need to introduce a new binding for it. ++ -} ++ expr' <- bcPrepExpr expr ++ pure (StgRhsClosure fvs cc upd args (StgTick bp expr')) ++bcPrepRHS (StgRhsClosure fvs cc upd args expr) = ++ StgRhsClosure fvs cc upd args <$> bcPrepExpr expr ++bcPrepRHS con@StgRhsCon{} = pure con ++ ++bcPrepExpr :: StgExpr -> BcM StgExpr ++-- explicitly match all constructors so we get a warning if we miss any ++bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs) ++ | isLiftedTypeKind (typeKind tick_ty) = do ++ id <- newId tick_ty ++ rhs' <- bcPrepExpr rhs ++ let expr' = StgTick bp rhs' ++ bnd = StgNonRec id (StgRhsClosure noExtFieldSilent ++ CC.dontCareCCS ++ ReEntrant ++ [] ++ expr' ++ ) ++ letExp = StgLet noExtFieldSilent bnd (StgApp id []) ++ pure letExp ++ | otherwise = do ++ id <- newId (mkVisFunTy realWorldStatePrimTy tick_ty) ++ st <- newId realWorldStatePrimTy ++ rhs' <- bcPrepExpr rhs ++ let expr' = StgTick bp rhs' ++ bnd = StgNonRec id (StgRhsClosure noExtFieldSilent ++ CC.dontCareCCS ++ ReEntrant ++ [voidArgId] ++ expr' ++ ) ++ pure $ StgLet noExtFieldSilent bnd (StgApp id [StgVarArg st]) ++bcPrepExpr (StgTick tick rhs) = ++ StgTick tick <$> bcPrepExpr rhs ++bcPrepExpr (StgLet xlet bnds expr) = ++ StgLet xlet <$> bcPrepBind bnds ++ <*> bcPrepExpr expr ++bcPrepExpr (StgLetNoEscape xlne bnds expr) = ++ StgLet xlne <$> bcPrepBind bnds ++ <*> bcPrepExpr expr ++bcPrepExpr (StgCase expr bndr alt_type alts) = ++ StgCase <$> bcPrepExpr expr ++ <*> pure bndr ++ <*> pure alt_type ++ <*> mapM bcPrepAlt alts ++bcPrepExpr lit@StgLit{} = pure lit ++-- See Note [Not-necessarily-lifted join points], step 3. ++bcPrepExpr (StgApp x []) ++ | isNNLJoinPoint x = pure $ ++ StgApp (protectNNLJoinPointId x) [StgVarArg voidPrimId] ++bcPrepExpr app@StgApp{} = pure app ++bcPrepExpr app@StgConApp{} = pure app ++bcPrepExpr app@StgOpApp{} = pure app ++bcPrepExpr StgLam{} = panic "bcPrepExpr: StgLam" ++ ++bcPrepAlt :: StgAlt -> BcM StgAlt ++bcPrepAlt (ac, bndrs, expr) = (,,) ac bndrs <$> bcPrepExpr expr ++ ++bcPrepBind :: StgBinding -> BcM StgBinding ++-- explicitly match all constructors so we get a warning if we miss any ++bcPrepBind (StgNonRec bndr rhs) = ++ let (bndr', rhs') = bcPrepSingleBind (bndr, rhs) ++ in StgNonRec bndr' <$> bcPrepRHS rhs' ++bcPrepBind (StgRec bnds) = ++ StgRec <$> mapM ((\(b,r) -> (,) b <$> bcPrepRHS r) . bcPrepSingleBind) ++ bnds ++ ++bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs) ++-- If necessary, modify this Id and body to protect not-necessarily-lifted join points. ++-- See Note [Not-necessarily-lifted join points], step 2. ++bcPrepSingleBind (x, StgRhsClosure ext cc upd_flag args body) ++ | isNNLJoinPoint x ++ = ( protectNNLJoinPointId x ++ , StgRhsClosure ext cc upd_flag (args ++ [voidArgId]) body) ++bcPrepSingleBind bnd = bnd + + -- ----------------------------------------------------------------------------- + -- Compilation schema for the bytecode generator type BCInstrList = OrdList BCInstr @@ -111,7 +4410,7 @@ index fb60c21f9d..62e8457c5a 100644 wordsToBytes :: DynFlags -> WordOff -> ByteOff wordsToBytes dflags = fromIntegral . (* wORD_SIZE dflags) . fromIntegral -@@ -230,7 +229,7 @@ ppBCEnv p +@@ -230,7 +324,7 @@ ppBCEnv p $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p)))) $$ text "end-env" where @@ -120,7 +4419,16 @@ index fb60c21f9d..62e8457c5a 100644 cmp_snd x y = compare (snd x) (snd y) -} -@@ -299,6 +298,11 @@ argBits dflags (rep : args) +@@ -240,7 +334,7 @@ mkProtoBCO + :: DynFlags + -> name + -> BCInstrList +- -> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet) ++ -> Either [CgStgAlt] (CgStgRhs) + -- ^ original expression; for debugging only + -> Int + -> Word16 +@@ -299,12 +393,17 @@ argBits dflags (rep : args) | isFollowableArg rep = False : argBits dflags args | otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args @@ -132,125 +4440,667 @@ index fb60c21f9d..62e8457c5a 100644 -- ----------------------------------------------------------------------------- -- schemeTopBind -@@ -482,6 +486,57 @@ returnUnboxedAtom d s p e e_rep = do - `appOL` mkSlideB dflags szb (d - s) -- clear to sequel - `snocOL` RETURN_UBX e_rep) -- go + -- Compile code for the right-hand side of a top-level binding -+-- XXX merge the two functions below -+-- XXX use the old special cases if possible (more efficient) +-schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name) ++schemeTopBind :: (Id, CgStgRhs) -> BcM (ProtoBCO Name) + schemeTopBind (id, rhs) + | Just data_con <- isDataConWorkId_maybe id, + isNullaryRepDataCon data_con = do +@@ -321,7 +420,7 @@ schemeTopBind (id, rhs) + (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) + + | otherwise +- = schemeR [{- No free variables -}] (id, rhs) ++ = schemeR [{- No free variables -}] (getName id, rhs) + + + -- ----------------------------------------------------------------------------- +@@ -333,46 +432,29 @@ schemeTopBind (id, rhs) + -- removing the free variables and arguments. + -- + -- Park the resulting BCO in the monad. Also requires the +--- variable to which this value was bound, so as to give the +--- resulting BCO a name. +- ++-- name of the variable to which this value was bound, ++-- so as to give the resulting BCO a name. + schemeR :: [Id] -- Free vars of the RHS, ordered as they + -- will appear in the thunk. Empty for + -- top-level things, which have no free vars. +- -> (Id, AnnExpr Id DVarSet) ++ -> (Name, CgStgRhs) + -> BcM (ProtoBCO Name) + schemeR fvs (nm, rhs) +-{- +- | trace (showSDoc ( +- (char ' ' +- $$ (ppr.filter (not.isTyVar).dVarSetElems.fst) rhs +- $$ pprCoreExpr (deAnnotate rhs) +- $$ char ' ' +- ))) False +- = undefined +- | otherwise +--} + = schemeR_wrk fvs nm rhs (collect rhs) + + -- If an expression is a lambda (after apply bcView), return the + -- list of arguments to the lambda (in R-to-L order) and the + -- underlying expression +-collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet) +-collect (_, e) = go [] e +- where +- go xs e | Just e' <- bcView e = go xs e' +- go xs (AnnLam x (_,e)) +- | typePrimRep (idType x) `lengthExceeds` 1 +- = multiValException +- | otherwise +- = go (x:xs) e +- go xs not_lambda = (reverse xs, not_lambda) ++ ++collect :: CgStgRhs -> ([Var], CgStgExpr) ++collect (StgRhsClosure _ _ _ args body) = (args, body) ++collect (StgRhsCon _cc dc args) = ([], StgConApp dc args []) + + schemeR_wrk + :: [Id] +- -> Id +- -> AnnExpr Id DVarSet -- expression e, for debugging only +- -> ([Var], AnnExpr' Var DVarSet) -- result of collect on e ++ -> Name ++ -> CgStgRhs -- expression e, for debugging only ++ -> ([Var], CgStgExpr) -- result of collect on e + -> BcM (ProtoBCO Name) + schemeR_wrk fvs nm original_body (args, body) + = do +@@ -400,17 +482,16 @@ schemeR_wrk fvs nm original_body (args, body) + arity bitmap_size bitmap False{-not alts-}) + + -- introduce break instructions for ticked expressions +-schemeER_wrk :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList +-schemeER_wrk d p rhs +- | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs +- = do code <- schemeE d 0 p newRhs ++schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList ++schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs) rhs) ++ = do code <- schemeE d 0 p rhs + cc_arr <- getCCArray + this_mod <- moduleName <$> getCurrentModule + dflags <- getDynFlags + let idOffSets = getVarOffSets dflags d p fvs + let breakInfo = CgBreakInfo + { cgb_vars = idOffSets +- , cgb_resty = exprType (deAnnotate' newRhs) ++ , cgb_resty = tick_ty + } + newBreakInfo tick_no breakInfo + dflags <- getDynFlags +@@ -418,7 +499,7 @@ schemeER_wrk d p rhs + | otherwise = toRemotePtr nullPtr + let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc + return $ breakInstr `consOL` code +- | otherwise = schemeE d 0 p rhs ++schemeER_wrk d p rhs = schemeE d 0 p rhs + + getVarOffSets :: DynFlags -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)] + getVarOffSets dflags depth env = map getOffSet +@@ -450,7 +531,7 @@ trunc16B = truncIntegral16 + trunc16W :: WordOff -> Word16 + trunc16W = truncIntegral16 + +-fvsToEnv :: BCEnv -> DVarSet -> [Id] ++fvsToEnv :: BCEnv -> CgStgRhs -> [Id] + -- Takes the free variables of a right-hand side, and + -- delivers an ordered list of the local variables that will + -- be captured in the thunk for the RHS +@@ -459,88 +540,126 @@ fvsToEnv :: BCEnv -> DVarSet -> [Id] + -- + -- The code that constructs the thunk, and the code that executes + -- it, have to agree about this layout +-fvsToEnv p fvs = [v | v <- dVarSetElems fvs, +- isId v, -- Could be a type variable +- v `Map.member` p] ++ ++fvsToEnv p (StgRhsClosure fvs _ _ _ _) = ++ [v | v <- dVarSetElems fvs, ++ v `Map.member` p] ++fvsToEnv _ _ = [] + + -- ----------------------------------------------------------------------------- + -- schemeE + ++-- Returning an unlifted value. ++-- Heave it on the stack, SLIDE, and RETURN. + returnUnboxedAtom + :: StackDepth + -> Sequel + -> BCEnv +- -> AnnExpr' Id DVarSet +- -> ArgRep ++ -> StgArg + -> BcM BCInstrList +--- Returning an unlifted value. +--- Heave it on the stack, SLIDE, and RETURN. +-returnUnboxedAtom d s p e e_rep = do +- dflags <- getDynFlags ++returnUnboxedAtom d s p e = do ++ let reps = case e of ++ StgLitArg lit -> typePrimRepArgs (literalType lit) ++ StgVarArg i -> bcIdPrimReps i + (push, szb) <- pushAtom d p e +- return (push -- value onto stack +- `appOL` mkSlideB dflags szb (d - s) -- clear to sequel +- `snocOL` RETURN_UBX e_rep) -- go ++ ret <- returnUnboxedReps d s szb reps ++ return (push `appOL` ret) ++ ++-- return an unboxed value from the top of the stack ++returnUnboxedReps ++ :: StackDepth ++ -> Sequel ++ -> ByteOff -- size of the thing we're returning ++ -> [PrimRep] -- representations ++ -> BcM BCInstrList ++returnUnboxedReps d s szb reps = do ++ dflags <- getDynFlags ++ let non_void VoidRep = False ++ non_void _ = True ++ ret <- case filter non_void reps of ++ -- use RETURN_UBX for unary representations ++ [] -> return (unitOL $ RETURN_UBX V) ++ [rep] -> return (unitOL $ RETURN_UBX (toArgRep rep)) ++ -- otherwise use RETURN_T with a tuple descriptor ++ nv_reps -> do ++ let (tuple_info, args_offsets) = layoutTuple dflags 0 (primRepCmmType dflags) nv_reps ++ args_ptrs = map (\(rep, off) -> (isFollowableArg (toArgRep rep), off)) args_offsets ++ tuple_bco <- emitBc (tupleBCO dflags tuple_info args_ptrs) ++ return $ PUSH_UBX (mkTupleInfoLit dflags tuple_info) 1 `consOL` ++ PUSH_BCO tuple_bco `consOL` ++ unitOL RETURN_T ++ return ( mkSlideB dflags szb (d - s) -- clear to sequel ++ `appOL` ret) -- go ++ ++-- construct and return an unboxed tuple +returnUnboxedTuple + :: StackDepth + -> Sequel + -> BCEnv -+ -> [AnnExpr' Id DVarSet] ++ -> [StgArg] + -> BcM BCInstrList +returnUnboxedTuple d s p es = do + dflags <- getDynFlags + let arg_ty e = primRepCmmType dflags (atomPrimRep e) + (tuple_info, tuple_components) = layoutTuple dflags d arg_ty es -+ args_ptrs = map (\(e, off) -> (isFollowableArg (atomRep e), off)) tuple_components + go _ pushes [] = return (reverse pushes) + go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a + MASSERT(off == dd + szb) + go (dd + szb) (push:pushes) cs + pushes <- go d [] tuple_components -+ tuple_bco <- emitBc (tupleBCO dflags tuple_info args_ptrs) -+ return (mconcat pushes -+ `appOL` mkSlideB dflags (wordsToBytes dflags $ tupleSize tuple_info) (d - s) -- clear to sequel -+ `snocOL` PUSH_UBX (mkLitWord dflags . fromIntegral $ mkTupleInfoSig tuple_info) 1 -- add info word -+ `snocOL` PUSH_BCO tuple_bco -- add info BCO -+ `snocOL` RETURN_T) -- go -+ -+ -+ -+-- return a tuple that's already on the stack in the right order -+returnUnboxedTuple' -+ :: StackDepth -- ^ current stack depth -+ -> Sequel -- ^ depth of sequel -+ -> BCEnv -+ -> StackDepth -- ^ depth of start of tuple -+ -> [PrimRep] -+ -> BcM BCInstrList -+returnUnboxedTuple' d s _p d_tuple t_reps = do -+ dflags <- getDynFlags -+ let arg_ty :: PrimRep -> CmmType -+ arg_ty e = primRepCmmType dflags e -+ (tuple_info, tuple_components) = layoutTuple dflags d arg_ty t_reps -+ args_ptrs = map (\(rep, off) -> (isFollowableArg (toArgRep rep), off)) tuple_components -+ tuple_offset = trunc16W $ bytesToWords dflags (d - d_tuple) + tupleSize tuple_info - 1 -+ copyTuple = replicate (fromIntegral $ tupleSize tuple_info) -+ (PUSH_L tuple_offset) -+ tuple_bco <- emitBc (tupleBCO dflags tuple_info args_ptrs) -+ return (toOL copyTuple -+ `appOL` mkSlideB dflags (wordsToBytes dflags $ tupleSize tuple_info) (d - s) -- clear to sequel -+ `snocOL` PUSH_UBX (mkLitWord dflags . fromIntegral $ mkTupleInfoSig tuple_info) 1 -- add info word -+ `snocOL` PUSH_BCO tuple_bco -+ `snocOL` RETURN_T) -- go -+ ++ ret <- returnUnboxedReps d ++ s ++ (wordsToBytes dflags $ tupleSize tuple_info) ++ (map atomPrimRep es) ++ return (mconcat pushes `appOL` ret) + -- Compile code to apply the given expression to the remaining args -- on the stack, returning a HNF. schemeE -@@ -499,6 +554,10 @@ schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V - schemeE d s p e@(AnnVar v) - -- See Note [Not-necessarily-lifted join points], step 3. - | isNNLJoinPoint v = doTailCall d s p (protectNNLJoinPointId v) [AnnVar voidPrimId] -+ | isUnboxedTupleType (idType v) = -+ let d_tuple = fromMaybe (panic "CoreToByteCode.schemeE: global unboxed tuples are not supported") -+ (lookupBCEnv_maybe v p) -+ in returnUnboxedTuple' d s p d_tuple (bcIdPrimReps v) --- XXX should this be arg reps instead? - | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v) - | otherwise = schemeT d s p e +- :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList +-schemeE d s p e +- | Just e' <- bcView e +- = schemeE d s p e' ++ :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList ++schemeE d s p (StgLit lit) = returnUnboxedAtom d s p (StgLitArg lit) ++schemeE d s p (StgApp x []) ++ | isUnliftedType (idType x) = returnUnboxedAtom d s p (StgVarArg x) ++schemeE _ _ _ (StgLam {}) = panic "schemeE: StgLam" -@@ -817,7 +876,8 @@ schemeT d s p app - unboxedTupleReturn d s p arg2 - [arg1,arg2] | isVAtom arg2 -> - unboxedTupleReturn d s p arg1 + -- Delegate tail-calls to schemeT. +-schemeE d s p e@(AnnApp _ _) = schemeT d s p e +- +-schemeE d s p e@(AnnLit lit) = returnUnboxedAtom d s p e (typeArgRep (literalType lit)) +-schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V +- +-schemeE d s p e@(AnnVar v) +- -- See Note [Not-necessarily-lifted join points], step 3. +- | isNNLJoinPoint v = doTailCall d s p (protectNNLJoinPointId v) [AnnVar voidPrimId] +- | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v) +- | otherwise = schemeT d s p e +- +-schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) +- | (AnnVar v, args_r_to_l) <- splitApp rhs, +- Just data_con <- isDataConWorkId_maybe v, +- dataConRepArity data_con == length args_r_to_l ++schemeE d s p e@(StgApp {}) = schemeT d s p e ++schemeE d s p e@(StgConApp {}) = schemeT d s p e ++schemeE d s p e@(StgOpApp {}) = schemeT d s p e ++schemeE d s p (StgLetNoEscape xlet bnd body) ++ = schemeE d s p (StgLet xlet bnd body) ++schemeE d s p (StgLet _xlet (StgNonRec x (StgRhsCon _cc data_con args)) body) + = do -- Special case for a non-recursive let whose RHS is a + -- saturated constructor application. + -- Just allocate the constructor and carry on +- alloc_code <- mkConAppCode d s p data_con args_r_to_l ++ alloc_code <- mkConAppCode d s p data_con args + dflags <- getDynFlags + let !d2 = d + wordSize dflags + body_code <- schemeE d2 s (Map.insert x d2 p) body + return (alloc_code `appOL` body_code) +- + -- General case for let. Generates correct, if inefficient, code in + -- all situations. +-schemeE d s p (AnnLet binds (_,body)) = do ++schemeE d s p (StgLet _ext binds body) = do + dflags <- getDynFlags +- let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs]) +- AnnRec xs_n_rhss -> unzip xs_n_rhss ++ let (xs,rhss) = case binds of StgNonRec x rhs -> ([x],[rhs]) ++ StgRec xs_n_rhss -> unzip xs_n_rhss + n_binds = genericLength xs + +- fvss = map (fvsToEnv p' . fst) rhss +- +- -- See Note [Not-necessarily-lifted join points], step 2. +- (xs',rhss') = zipWithAndUnzip protectNNLJoinPointBind xs rhss ++ fvss = map (fvsToEnv p') rhss + + -- Sizes of free vars + size_w = trunc16W . idSizeW dflags + sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss + + -- the arity of each rhs +- arities = map (genericLength . fst . collect) rhss' ++ arities = map (genericLength . fst . collect) rhss + + -- This p', d' defn is safe because all the items being pushed + -- are ptrs, so all have size 1 word. d' and p' reflect the stack + -- after the closures have been allocated in the heap (but not + -- filled in), and pointers to them parked on the stack. + offsets = mkStackOffsets d (genericReplicate n_binds (wordSize dflags)) +- p' = Map.insertList (zipE xs' offsets) p ++ p' = Map.insertList (zipE xs offsets) p + d' = d + wordsToBytes dflags n_binds + zipE = zipEqual "schemeE" + +@@ -559,7 +678,7 @@ schemeE d s p (AnnLet binds (_,body)) = do + mkap | arity == 0 = MKAP + | otherwise = MKPAP + build_thunk dd (fv:fvs) size bco off arity = do +- (push_code, pushed_szb) <- pushAtom dd p' (AnnVar fv) ++ (push_code, pushed_szb) <- pushAtom dd p' (StgVarArg fv) + more_push_code <- + build_thunk (dd + pushed_szb) fvs size bco off arity + return (push_code `appOL` more_push_code) +@@ -571,109 +690,35 @@ schemeE d s p (AnnLet binds (_,body)) = do + mkAlloc sz arity = ALLOC_PAP arity sz + + is_tick = case binds of +- AnnNonRec id _ -> occNameFS (getOccName id) == tickFS ++ StgNonRec id _ -> occNameFS (getOccName id) == tickFS + _other -> False + + compile_bind d' fvs x rhs size arity off = do +- bco <- schemeR fvs (x,rhs) ++ bco <- schemeR fvs (getName x,rhs) + build_thunk d' fvs size bco off arity + + compile_binds = + [ compile_bind d' fvs x rhs size arity (trunc16W n) + | (fvs, x, rhs, size, arity, n) <- +- zip6 fvss xs' rhss' sizes arities [n_binds, n_binds-1 .. 1] ++ zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1] + ] + body_code <- schemeE d' s p' body + thunk_codes <- sequence compile_binds + return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) + +--- Introduce a let binding for a ticked case expression. This rule +--- *should* only fire when the expression was not already let-bound +--- (the code gen for let bindings should take care of that). Todo: we +--- call exprFreeVars on a deAnnotated expression, this may not be the +--- best way to calculate the free vars but it seemed like the least +--- intrusive thing to do +-schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs) +- | isLiftedTypeKind (typeKind ty) +- = do id <- newId ty +- -- Todo: is emptyVarSet correct on the next line? +- let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id) +- schemeE d s p letExp +- +- | otherwise +- = do -- If the result type is not definitely lifted, then we must generate +- -- let f = \s . tick e +- -- in f realWorld# +- -- When we stop at the breakpoint, _result will have an unlifted +- -- type and hence won't be bound in the environment, but the +- -- breakpoint will otherwise work fine. +- -- +- -- NB (#12007) this /also/ applies for if (ty :: TYPE r), where +- -- r :: RuntimeRep is a variable. This can happen in the +- -- continuations for a pattern-synonym matcher +- -- match = /\(r::RuntimeRep) /\(a::TYPE r). +- -- \(k :: Int -> a) \(v::T). +- -- case v of MkV n -> k n +- -- Here (k n) :: a :: Type r, so we don't know if it's lifted +- -- or not; but that should be fine provided we add that void arg. +- +- id <- newId (mkVisFunTy realWorldStatePrimTy ty) +- st <- newId realWorldStatePrimTy +- let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp))) +- (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id) +- (emptyDVarSet, AnnVar realWorldPrimId))) +- schemeE d s p letExp +- +- where +- exp' = deAnnotate' exp +- fvs = exprFreeVarsDSet exp' +- ty = exprType exp' ++schemeE _d _s _p (StgTick (Breakpoint _ bp_id _) _rhs) ++ = panic ("schemeE: Breakpoint without let binding: " ++ ++ show bp_id ++ ++ " forgot to run bcPrep?") + + -- ignore other kinds of tick +-schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs +- +-schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut +- -- no alts: scrut is guaranteed to diverge +- +-schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) +- | isUnboxedTupleCon dc -- handles pairs with one void argument (e.g. state token) +- -- Convert +- -- case .... of x { (# V'd-thing, a #) -> ... } +- -- to +- -- case .... of a { DEFAULT -> ... } +- -- because the return convention for both are identical. +- -- +- -- Note that it does not matter losing the void-rep thing from the +- -- envt (it won't be bound now) because we never look such things up. +- , Just res <- case (typePrimRep (idType bind1), typePrimRep (idType bind2)) of +- ([], [_]) +- -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr) +- ([_], []) +- -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) +- _ -> Nothing +- = res +- +-schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)]) +- | isUnboxedTupleCon dc +- , typePrimRep (idType bndr) `lengthAtMost` 1 -- handles unit tuples +- = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) +- +-schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)]) +- | isUnboxedTupleType (idType bndr) +- , Just ty <- case typePrimRep (idType bndr) of +- [_] -> Just (unwrapType (idType bndr)) +- [] -> Just voidPrimTy +- _ -> Nothing +- -- handles any pattern with a single non-void binder; in particular I/O +- -- monad returns (# RealWorld#, a #) +- = doCase d s p scrut (bndr `setIdType` ty) alt (Just bndr) +- +-schemeE d s p (AnnCase scrut bndr _ alts) +- = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-} +- +-schemeE _ _ _ expr +- = pprPanic "ByteCodeGen.schemeE: unhandled case" +- (pprCoreExpr (deAnnotate' expr)) ++schemeE d s p (StgTick _ rhs) = schemeE d s p rhs ++ ++-- no alts: scrut is guaranteed to diverge ++schemeE d s p (StgCase scrut _ _ []) = schemeE d s p scrut ++ ++schemeE d s p (StgCase scrut bndr _ alts) ++ = doCase d s p scrut bndr alts + + -- Is this Id a not-necessarily-lifted join point? + -- See Note [Not-necessarily-lifted join points], step 1 +@@ -681,16 +726,6 @@ isNNLJoinPoint :: Id -> Bool + isNNLJoinPoint x = isJoinId x && + Just True /= isLiftedType_maybe (idType x) + +--- If necessary, modify this Id and body to protect not-necessarily-lifted join points. +--- See Note [Not-necessarily-lifted join points], step 2. +-protectNNLJoinPointBind :: Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet) +-protectNNLJoinPointBind x rhs@(fvs, _) +- | isNNLJoinPoint x +- = (protectNNLJoinPointId x, (fvs, AnnLam voidArgId rhs)) +- +- | otherwise +- = (x, rhs) +- + -- Update an Id's type to take a Void# argument. + -- Precondition: the Id is a not-necessarily-lifted join point. + -- See Note [Not-necessarily-lifted join points] +@@ -778,10 +813,8 @@ Right Fix is to take advantage of join points as goto-labels. + -- + -- 1. The fn denotes a ccall. Defer to generateCCall. + -- +--- 2. (Another nasty hack). Spot (# a::V, b #) and treat +--- it simply as b -- since the representations are identical +--- (the V takes up zero stack space). Also, spot +--- (# b #) and treat it as b. ++-- 2. An unboxed tuple: push the components on the top of ++-- the stack and return. + -- + -- 3. Application of a constructor, by defn saturated. + -- Split the args into ptrs and non-ptrs, and push the nonptrs, +@@ -793,57 +826,45 @@ Right Fix is to take advantage of join points as goto-labels. + schemeT :: StackDepth -- Stack depth + -> Sequel -- Sequel depth + -> BCEnv -- stack env +- -> AnnExpr' Id DVarSet ++ -> CgStgExpr + -> BcM BCInstrList + +-schemeT d s p app +- + -- Case 0 ++schemeT d s p app + | Just (arg, constr_names) <- maybe_is_tagToEnum_call app + = implement_tagToId d s p arg constr_names + + -- Case 1 +- | Just (CCall ccall_spec) <- isFCallId_maybe fn ++schemeT d s p (StgOpApp (StgFCallOp (CCall ccall_spec) _ty) args result_ty) + = if isSupportedCConv ccall_spec +- then generateCCall d s p ccall_spec fn args_r_to_l ++ then generateCCall d s p ccall_spec result_ty (reverse args) + else unsupportedCConvException + ++schemeT d s p (StgOpApp (StgPrimOp op) args _ty) ++ = doTailCall d s p (primOpId op) (reverse args) ++ ++schemeT _d _s _p (StgOpApp (StgPrimCallOp {}) _args _ty) ++ = unsupportedCConvException + +- -- Case 2: Constructor application +- | Just con <- maybe_saturated_dcon +- , isUnboxedTupleCon con +- = case args_r_to_l of +- [arg1,arg2] | isVAtom arg1 -> +- unboxedTupleReturn d s p arg2 +- [arg1,arg2] | isVAtom arg2 -> +- unboxedTupleReturn d s p arg1 - _other -> multiValException -+ -- XXX find if we can work the above cases into the general version -+ other -> returnUnboxedTuple d s p (reverse other) ++ -- Case 2: Unboxed tuple ++schemeT d s p (StgConApp con args _tys) ++ | isUnboxedTupleCon con || isUnboxedSumCon con ++ = returnUnboxedTuple d s p args -- Case 3: Ordinary data constructor - | Just con <- maybe_saturated_dcon -@@ -979,12 +1039,12 @@ doCase - -- don't enter the result +- | Just con <- maybe_saturated_dcon +- = do alloc_con <- mkConAppCode d s p con args_r_to_l ++ | otherwise ++ = do alloc_con <- mkConAppCode d s p con args + dflags <- getDynFlags + return (alloc_con `appOL` + mkSlideW 1 (bytesToWords dflags $ d - s) `snocOL` + ENTER) + + -- Case 4: Tail call of function +- | otherwise +- = doTailCall d s p fn args_r_to_l +- +- where +- -- Extract the args (R->L) and fn +- -- The function will necessarily be a variable, +- -- because we are compiling a tail call +- (AnnVar fn, args_r_to_l) = splitApp app +- +- -- Only consider this to be a constructor application iff it is +- -- saturated. Otherwise, we'll call the constructor wrapper. +- n_args = length args_r_to_l +- maybe_saturated_dcon +- = case isDataConWorkId_maybe fn of +- Just con | dataConRepArity con == n_args -> Just con +- _ -> Nothing ++schemeT d s p (StgApp fn args) ++ = doTailCall d s p fn (reverse args) ++ ++schemeT _ _ _ e = pprPanic "GHC.CoreToByteCode.schemeT" ++ (pprStgExpr e) + + -- ----------------------------------------------------------------------------- + -- Generate code to build a constructor application, +@@ -854,25 +875,16 @@ mkConAppCode + -> Sequel + -> BCEnv + -> DataCon -- The data constructor +- -> [AnnExpr' Id DVarSet] -- Args, in *reverse* order ++ -> [StgArg] -- Args, in *reverse* order -> BcM BCInstrList - doCase d s p (_,scrut) bndr alts is_unboxed_tuple +-mkConAppCode _ _ _ con [] -- Nullary constructor +- = ASSERT( isNullaryRepDataCon con ) +- return (unitOL (PUSH_G (getName (dataConWorkId con)))) +- -- Instead of doing a PACK, which would allocate a fresh +- -- copy of this constructor, use the single shared version. +- +-mkConAppCode orig_d _ p con args_r_to_l = +- ASSERT( args_r_to_l `lengthIs` dataConRepArity con ) app_code ++mkConAppCode orig_d _ p con args = app_code + where + app_code = do + dflags <- getDynFlags + +- -- The args are initially in reverse order, but mkVirtHeapOffsets +- -- expects them to be left-to-right. + let non_voids = + [ NonVoid (prim_rep, arg) +- | arg <- reverse args_r_to_l ++ | arg <- args + , let prim_rep = atomPrimRep arg + , not (isVoidRep prim_rep) + ] +@@ -892,18 +904,6 @@ mkConAppCode orig_d _ p con args_r_to_l = + -- Push on the stack in the reverse order. + do_pushery orig_d (reverse args_offsets) + +- +--- ----------------------------------------------------------------------------- +--- Returning an unboxed tuple with one non-void component (the only +--- case we can handle). +--- +--- Remember, we don't want to *evaluate* the component that is being +--- returned, even if it is a pointed type. We always just return. +- +-unboxedTupleReturn +- :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList +-unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg) +- + -- ----------------------------------------------------------------------------- + -- Generate code for a tail-call + +@@ -912,13 +912,13 @@ doTailCall + -> Sequel + -> BCEnv + -> Id +- -> [AnnExpr' Id DVarSet] ++ -> [StgArg] + -> BcM BCInstrList + doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args) + where + do_pushes !d [] reps = do + ASSERT( null reps ) return () +- (push_fn, sz) <- pushAtom d p (AnnVar fn) ++ (push_fn, sz) <- pushAtom d p (StgVarArg fn) + dflags <- getDynFlags + ASSERT( sz == wordSize dflags ) return () + let slide = mkSlideB dflags (d - init_d + wordSize dflags) (init_d - s) +@@ -972,19 +972,26 @@ doCase + :: StackDepth + -> Sequel + -> BCEnv +- -> AnnExpr Id DVarSet ++ -> CgStgExpr + -> Id +- -> [AnnAlt Id DVarSet] +- -> Maybe Id -- Just x <=> is an unboxed tuple case with scrut binder, +- -- don't enter the result ++ -> [CgStgAlt] + -> BcM BCInstrList +-doCase d s p (_,scrut) bndr alts is_unboxed_tuple - | typePrimRep (idType bndr) `lengthExceeds` 1 - = multiValException - | otherwise ++doCase d s p scrut bndr alts = do dflags <- getDynFlags let -+ -- XXX handle general unboxed tuples and the old special cased ones properly here -+ utup = isUnboxedTupleType bndr_ty && length (non_void (typeArgReps bndr_ty)) > 1 ++ ++ -- Are we dealing with an unboxed tuple with a tuple return frame? ++ -- ++ -- 'Simple' tuples with at most one non-void component, ++ -- like (# Word# #) or (# Int#, State# RealWorld# #) do not have a ++ -- tuple return frame ++ ubx_tuple_frame = ++ (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) && ++ length non_void_arg_reps > 1 ++ ++ non_void_arg_reps = non_void (typeArgReps bndr_ty) + profiling | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags | otherwise = rtsIsProfiled -@@ -994,8 +1054,9 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple +@@ -994,53 +1001,84 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple -- When an alt is entered, it assumes the returned value is -- on top of the itbl. ret_frame_size_b :: StackDepth - ret_frame_size_b = 2 * wordSize dflags -- -+ ret_frame_size_b | utup = 4 * wordSize dflags ++ ret_frame_size_b | ubx_tuple_frame = ++ (if profiling then 5 else 4) * wordSize dflags + | otherwise = 2 * wordSize dflags -+ - -- The extra frame we push to save/restor the CCCS when profiling - save_ccs_size_b | profiling = 2 * wordSize dflags + +- -- The extra frame we push to save/restor the CCCS when profiling +- save_ccs_size_b | profiling = 2 * wordSize dflags ++ -- The stack space used to save/restore the CCCS when profiling ++ save_ccs_size_b | profiling && ++ not ubx_tuple_frame = 2 * wordSize dflags | otherwise = 0 -@@ -1004,16 +1065,22 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple + + -- An unlifted value gets an extra info table pushed on top -- when it is returned. unlifted_itbl_size_b :: StackDepth - unlifted_itbl_size_b | isAlgCase = 0 +- unlifted_itbl_size_b | isAlgCase = 0 - | otherwise = wordSize dflags -+ | utup = 3 * wordSize dflags -+ | otherwise = wordSize dflags ++ unlifted_itbl_size_b | isAlgCase = 0 ++ | ubx_tuple_frame = 3 * wordSize dflags ++ | otherwise = wordSize dflags + -+ bndr_size | utup = let bndr_ty = primRepCmmType dflags -+ (tuple_info, _) = layoutTuple dflags 0 bndr_ty (bcIdPrimReps bndr) -+ in wordsToBytes dflags (tupleSize tuple_info) -+ | otherwise = wordsToBytes dflags (idSizeW dflags bndr) ++ (bndr_size, tuple_info, args_offsets) ++ | ubx_tuple_frame = ++ let bndr_ty = primRepCmmType dflags ++ bndr_reps = filter (not.isVoidRep) (bcIdPrimReps bndr) ++ (tuple_info, args_offsets) = ++ layoutTuple dflags 0 bndr_ty bndr_reps ++ in ( wordsToBytes dflags (tupleSize tuple_info) ++ , tuple_info ++ , args_offsets ++ ) ++ | otherwise = ( wordsToBytes dflags (idSizeW dflags bndr) ++ , voidTupleInfo ++ , [] ++ ) -- depth of stack after the return value has been pushed d_bndr = @@ -265,7 +5115,26 @@ index fb60c21f9d..62e8457c5a 100644 -- Env in which to compile the alts, not including -- any vars bound by the alts themselves -@@ -1036,11 +1103,26 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple +- p_alts0 = Map.insert bndr d_bndr p +- +- p_alts = case is_unboxed_tuple of +- Just ubx_bndr -> Map.insert ubx_bndr d_bndr p_alts0 +- Nothing -> p_alts0 ++ p_alts = Map.insert bndr d_bndr p + + bndr_ty = idType bndr +- isAlgCase = not (isUnliftedType bndr_ty) && isNothing is_unboxed_tuple ++ isAlgCase = not (isUnliftedType bndr_ty) + + -- given an alt, return a discr and code for it. +- codeAlt (DEFAULT, _, (_,rhs)) ++ codeAlt (DEFAULT, _, rhs) + = do rhs_code <- schemeE d_alts s p_alts rhs + return (NoDiscr, rhs_code) + +- codeAlt alt@(_, bndrs, (_,rhs)) ++ codeAlt alt@(_, bndrs, rhs) + -- primitive or nullary constructor alt: no need to UNPACK | null real_bndrs = do rhs_code <- schemeE d_alts s p_alts rhs return (my_discr alt, rhs_code) @@ -274,7 +5143,7 @@ index fb60c21f9d..62e8457c5a 100644 - -- (See #14608.) - | any (\bndr -> typePrimRep (idType bndr) `lengthExceeds` 1) bndrs - = multiValException -+ | utup = ++ | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty = + let bndr_ty = primRepCmmType dflags . bcIdPrimRep + tuple_start = d_bndr + (tuple_info, args_offsets) = @@ -286,18 +5155,19 @@ index fb60c21f9d..62e8457c5a 100644 + stack_bot = d_alts + + p' = Map.insertList -+ [ (arg, tuple_start - wordsToBytes dflags (tupleSize tuple_info) + offset) ++ [ (arg, tuple_start - ++ wordsToBytes dflags (tupleSize tuple_info) + ++ offset) + | (arg, offset) <- args_offsets + , not (isVoidRep $ bcIdPrimRep arg)] + p_alts + in do -+ -- traceCBC ("ubx tup cont: " ++ show (stack_bot,tuple_start,tot_wds) ++ "\n" ++ show args_offsets) + rhs_code <- schemeE stack_bot s p' rhs + return (NoDiscr, rhs_code) -- algebraic alt with some binders | otherwise = let (tot_wds, _ptrs_wds, args_offsets) = -@@ -1068,7 +1150,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple +@@ -1068,16 +1106,16 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-} my_discr (DataAlt dc, _, _) | isUnboxedTupleCon dc || isUnboxedSumCon dc @@ -306,34 +5176,61 @@ index fb60c21f9d..62e8457c5a 100644 | otherwise = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG)) my_discr (LitAlt l, _, _) -@@ -1100,17 +1182,22 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple +- = case l of LitNumber LitNumInt i _ -> DiscrI (fromInteger i) +- LitNumber LitNumWord w _ -> DiscrW (fromInteger w) ++ = case l of LitNumber LitNumInt i _ -> DiscrI (fromInteger i) ++ LitNumber LitNumWord w _ -> DiscrW (fromInteger w) + LitFloat r -> DiscrF (fromRational r) + LitDouble r -> DiscrD (fromRational r) + LitChar i -> DiscrI (ord i) +- _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l) ++ _ -> pprPanic "schemeE(StgCase).my_discr" (ppr l) + + maybe_ncons + | not isAlgCase = Nothing +@@ -1100,20 +1138,36 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple -- really want a bitmap up to depth (d-s). This affects compilation of -- case-of-case expressions, which is the only time we can be compiling a -- case expression with s /= 0. - bitmap_size = trunc16W $ bytesToWords dflags (d - s) -+ bitmap_size | utup = trunc16W $ 2 + bytesToWords dflags (d - s) -+ | otherwise = trunc16W $ bytesToWords dflags (d - s) ++ ++ -- unboxed tuples get two more words, the second is a pointer (tuple_bco) ++ (extra_pointers, extra_slots) ++ | ubx_tuple_frame && profiling = ([1], 3) -- tuple_info, tuple_BCO, CCCS ++ | ubx_tuple_frame = ([1], 2) -- tuple_info, tuple_BCO ++ | otherwise = ([], 0) ++ ++ bitmap_size = trunc16W $ fromIntegral extra_slots + ++ bytesToWords dflags (d - s) ++ bitmap_size' :: Int bitmap_size' = fromIntegral bitmap_size - bitmap = intsToReverseBitmap dflags bitmap_size'{-size-} - (sort (filter (< bitmap_size') rel_slots)) -+ -- unboxed tuples get two more words, the second is a pointer (tuple_bco) -+ bitmap | utup = intsToReverseBitmap dflags bitmap_size'{-size-} -+ (1 : sort (filter (< bitmap_size') (map (+2) rel_slots))) -+ | otherwise = intsToReverseBitmap dflags bitmap_size'{-size-} -+ (sort (filter (< bitmap_size') rel_slots)) ++ ++ ++ pointers = ++ extra_pointers ++ ++ sort (filter (< bitmap_size') (map (+extra_slots) rel_slots)) where binds = Map.toList p -- NB: unboxed tuple cases bind the scrut binder to the same offset -- as one of the alt binders, so we have to remove any duplicates here: - rel_slots = nub $ map fromIntegral $ concat (map spread binds) +- rel_slots = nub $ map fromIntegral $ concat (map spread binds) - spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ] -+ spread (id, offset) | isUnboxedTupleType (idType id) = [] ++ rel_slots = nub $ map fromIntegral $ concatMap spread binds ++ spread (id, offset) | isUnboxedTupleType (idType id) || ++ isUnboxedSumType (idType id) = [] + | isFollowableArg (bcIdArgRep id) = [ rel_offset ] | otherwise = [] where rel_offset = trunc16W $ bytesToWords dflags (d - offset) -@@ -1121,19 +1208,117 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple ++ bitmap = intsToReverseBitmap dflags bitmap_size'{-size-} pointers ++ + alt_stuff <- mapM codeAlt alts + alt_final <- mkMultiBranch maybe_ncons alt_stuff + +@@ -1121,18 +1175,118 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple alt_bco_name = getName bndr alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts) 0{-no arity-} bitmap_size bitmap True{-is alts-} @@ -348,25 +5245,27 @@ index fb60c21f9d..62e8457c5a 100644 - | isAlgCase = PUSH_ALTS alt_bco' - | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty) - return (push_alts `consOL` scrut_code) -+ if utup ++ if ubx_tuple_frame + then do -+ -- XXX we shouldn't call layoutTuple twice -+ let (tuple_info, args_offsets) = -+ layoutTuple dflags -+ 0 -+ (primRepCmmType dflags) -+ (bcIdPrimReps bndr) -+ args_ptrs = map (\(rep, off) -> (isFollowableArg (toArgRep rep), off)) args_offsets ++ let args_ptrs = ++ map (\(rep, off) -> (isFollowableArg (toArgRep rep), off)) ++ args_offsets + tuple_bco <- emitBc (tupleBCO dflags tuple_info args_ptrs) + return (PUSH_ALTS_T alt_bco' tuple_info tuple_bco + `consOL` scrut_code) + else let push_alts -+ | isAlgCase = PUSH_ALTS alt_bco' -+ | otherwise = PUSH_ALTS_UNLIFTED alt_bco' -+ (typeArgRep bndr_ty) ++ | isAlgCase ++ = PUSH_ALTS alt_bco' ++ | otherwise ++ = let unlifted_rep = ++ case non_void_arg_reps of ++ [] -> V ++ [rep] -> rep ++ _ -> panic "schemeE(StgCase).push_alts" ++ in PUSH_ALTS_UNLIFTED alt_bco' unlifted_rep + in return (push_alts `consOL` scrut_code) - - ++ ++ +-- ----------------------------------------------------------------------------- +-- Deal with tuples + @@ -407,7 +5306,7 @@ index fb60c21f9d..62e8457c5a 100644 + DoubleReg n -> (v, f, a d n, l ) + LongReg n -> (v, f, d, a l n) + _ -> -+ pprPanic "CoreToByteCode.layoutTuple count_reg" ++ pprPanic "CoreToByteCode.layoutTuple unsupported register type" + (ppr r) + where a bmp n = bmp .|. (1 `shiftL` (n-1)) + @@ -436,7 +5335,7 @@ index fb60c21f9d..62e8457c5a 100644 +tupleBCO dflags info pointers = + mkProtoBCO dflags invented_name body_code (Left []) + 0{-no arity-} bitmap_size bitmap False{-is alts-} -+ + + where + {- + The tuple BCO is never referred to by name, so we can get away @@ -454,11 +5353,291 @@ index fb60c21f9d..62e8457c5a 100644 + (filter fst pointers) + body_code = mkSlideW 0 1 -- pop frame header + `snocOL` RETURN_T -- and add it again -+ + -- ----------------------------------------------------------------------------- -- Deal with a CCall. +@@ -1148,10 +1302,10 @@ generateCCall + -> Sequel + -> BCEnv + -> CCallSpec -- where to call +- -> Id -- of target, for type info +- -> [AnnExpr' Id DVarSet] -- args (atoms) ++ -> Type ++ -> [StgArg] -- args (atoms) + -> BcM BCInstrList +-generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l ++generateCCall d0 s p (CCallSpec target cconv safety) result_ty args_r_to_l + = do + dflags <- getDynFlags -@@ -1814,6 +1999,9 @@ bcIdPrimRep id +@@ -1160,56 +1314,40 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l + addr_size_b :: ByteOff + addr_size_b = wordSize dflags + ++ arrayish_rep_hdr_size :: TyCon -> Maybe Int ++ arrayish_rep_hdr_size t ++ | t == arrayPrimTyCon || t == mutableArrayPrimTyCon ++ = Just (arrPtrsHdrSize dflags) ++ | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon ++ = Just (smallArrPtrsHdrSize dflags) ++ | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon ++ = Just (arrWordsHdrSize dflags) ++ | otherwise ++ = Nothing ++ + -- Get the args on the stack, with tags and suitably + -- dereferenced for the CCall. For each arg, return the + -- depth to the first word of the bits for that arg, and the + -- ArgRep of what was actually pushed. + + pargs +- :: ByteOff -> [AnnExpr' Id DVarSet] -> BcM [(BCInstrList, PrimRep)] ++ :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimRep)] + pargs _ [] = return [] +- pargs d (a:az) +- = let arg_ty = unwrapType (exprType (deAnnotate' a)) +- +- in case tyConAppTyCon_maybe arg_ty of +- -- Don't push the FO; instead push the Addr# it +- -- contains. +- Just t +- | t == arrayPrimTyCon || t == mutableArrayPrimTyCon +- -> do rest <- pargs (d + addr_size_b) az +- code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a +- return ((code,AddrRep):rest) +- +- | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon +- -> do rest <- pargs (d + addr_size_b) az +- code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize dflags)) d p a +- return ((code,AddrRep):rest) +- +- | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon +- -> do rest <- pargs (d + addr_size_b) az +- code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a +- return ((code,AddrRep):rest) +- +- -- Default case: push taggedly, but otherwise intact. +- _ +- -> do (code_a, sz_a) <- pushAtom d p a +- rest <- pargs (d + sz_a) az +- return ((code_a, atomPrimRep a) : rest) +- +- -- Do magic for Ptr/Byte arrays. Push a ptr to the array on +- -- the stack but then advance it over the headers, so as to +- -- point to the payload. +- parg_ArrayishRep +- :: Word16 +- -> StackDepth +- -> BCEnv +- -> AnnExpr' Id DVarSet +- -> BcM BCInstrList +- parg_ArrayishRep hdrSize d p a +- = do (push_fo, _) <- pushAtom d p a ++ pargs d (aa@(StgVarArg a):az) ++ | Just t <- tyConAppTyCon_maybe (idType a) ++ , Just hdr_sz <- arrayish_rep_hdr_size t ++ -- Do magic for Ptr/Byte arrays. Push a ptr to the array on ++ -- the stack but then advance it over the headers, so as to ++ -- point to the payload. ++ = do rest <- pargs (d + addr_size_b) az ++ (push_fo, _) <- pushAtom d p aa + -- The ptr points at the header. Advance it over the + -- header and then pretend this is an Addr#. +- return (push_fo `snocOL` SWIZZLE 0 hdrSize) ++ let code = push_fo `snocOL` SWIZZLE 0 (fromIntegral hdr_sz) ++ return ((code, AddrRep) : rest) ++ pargs d (aa:az) = do (code_a, sz_a) <- pushAtom d p aa ++ rest <- pargs (d + sz_a) az ++ return ((code_a, atomPrimRep aa) : rest) + + code_n_reps <- pargs d0 args_r_to_l + let +@@ -1230,7 +1368,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l + + -- Get the result rep. + (returns_void, r_rep) +- = case maybe_getCCallReturnRep (idType fn) of ++ = case maybe_getCCallReturnRep result_ty of + Nothing -> (True, VoidRep) + Just rr -> (False, rr) + {- +@@ -1421,14 +1559,10 @@ maybe_getCCallReturnRep fn_ty + -- valid return value placeholder on the stack + _ -> blargh + +-maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name]) ++maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name]) + -- Detect and extract relevant info for the tagToEnum kludge. +-maybe_is_tagToEnum_call app +- | AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg <- app +- , Just TagToEnumOp <- isPrimOpId_maybe v +- = Just (snd arg, extract_constr_Names t) +- | otherwise +- = Nothing ++maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) [StgVarArg v] t) ++ = Just (v, extract_constr_Names t) + where + extract_constr_Names ty + | rep_ty <- unwrapType ty +@@ -1439,6 +1573,7 @@ maybe_is_tagToEnum_call app + -- the DataCon. See DataCon.hs for details. + | otherwise + = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty) ++maybe_is_tagToEnum_call _ = Nothing + + {- ----------------------------------------------------------------------------- + Note [Implementing tagToEnum#] +@@ -1482,13 +1617,13 @@ implement_tagToId + :: StackDepth + -> Sequel + -> BCEnv +- -> AnnExpr' Id DVarSet ++ -> Id + -> [Name] + -> BcM BCInstrList + -- See Note [Implementing tagToEnum#] + implement_tagToId d s p arg names + = ASSERT( notNull names ) +- do (push_arg, arg_bytes) <- pushAtom d p arg ++ do (push_arg, arg_bytes) <- pushAtom d p (StgVarArg arg) + labels <- getLabelsBc (genericLength names) + label_fail <- getLabelBc + label_exit <- getLabelBc +@@ -1530,21 +1665,12 @@ implement_tagToId d s p arg names + -- depth 6 stack has valid words 0 .. 5. + + pushAtom +- :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff) +-pushAtom d p e +- | Just e' <- bcView e +- = pushAtom d p e' +- +-pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things, +- = return (nilOL, 0) -- treated just like a variable V ++ :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff) + + -- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs + -- and Note [Bottoming expressions] in coreSyn/CoreUtils.hs: + -- The scrutinee of an empty case evaluates to bottom +-pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128 +- = pushAtom d p a +- +-pushAtom d p (AnnVar var) ++pushAtom d p (StgVarArg var) + | [] <- typePrimRep (idType var) + = return (nilOL, 0) + +@@ -1583,55 +1709,57 @@ pushAtom d p (AnnVar var) + = do topStrings <- getTopStrings + dflags <- getDynFlags + case lookupVarEnv topStrings var of +- Just ptr -> pushAtom d p $ AnnLit $ mkLitWord dflags $ ++ Just ptr -> pushAtom d p $ StgLitArg $ mkLitWord dflags $ + fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr + Nothing -> do + let sz = idSizeCon dflags var + MASSERT( sz == wordSize dflags ) + return (unitOL (PUSH_G (getName var)), sz) + +- +-pushAtom _ _ (AnnLit lit) = do ++pushAtom _ _ (StgLitArg lit) = do + dflags <- getDynFlags +- let code rep +- = let size_words = WordOff (argRepSizeW dflags rep) +- in return (unitOL (PUSH_UBX lit (trunc16W size_words)), +- wordsToBytes dflags size_words) ++ let code :: PrimRep -> BcM (BCInstrList, ByteOff) ++ code rep = ++ return (unitOL instr, size_bytes) ++ where ++ size_bytes = ByteOff $ primRepSizeB dflags rep ++ -- Here we handle the non-word-width cases specifically since we ++ -- must emit different bytecode for them. ++ instr = ++ case size_bytes of ++ 1 -> PUSH_UBX8 lit ++ 2 -> PUSH_UBX16 lit ++ 4 -> PUSH_UBX32 lit ++ _ -> PUSH_UBX lit (trunc16W $ bytesToWords dflags size_bytes) + + case lit of +- LitLabel _ _ _ -> code N +- LitFloat _ -> code F +- LitDouble _ -> code D +- LitChar _ -> code N +- LitNullAddr -> code N +- LitString _ -> code N +- LitRubbish -> code N ++ LitLabel _ _ _ -> code AddrRep ++ LitFloat _ -> code FloatRep ++ LitDouble _ -> code DoubleRep ++ LitChar _ -> code AddrRep ++ LitNullAddr -> code AddrRep ++ LitString _ -> code AddrRep ++ LitRubbish -> code AddrRep + LitNumber nt _ _ -> case nt of +- LitNumInt -> code N +- LitNumWord -> code N +- LitNumInt64 -> code L +- LitNumWord64 -> code L ++ LitNumInt -> code IntRep ++ LitNumWord -> code WordRep ++ LitNumInt64 -> code Int64Rep ++ LitNumWord64 -> code Word64Rep + -- No LitInteger's or LitNatural's should be left by the time this is + -- called. CorePrep should have converted them all to a real core + -- representation. + LitNumInteger -> panic "pushAtom: LitInteger" + LitNumNatural -> panic "pushAtom: LitNatural" + +-pushAtom _ _ expr +- = pprPanic "ByteCodeGen.pushAtom" +- (pprCoreExpr (deAnnotate' expr)) +- +- + -- | Push an atom for constructor (i.e., PACK instruction) onto the stack. + -- This is slightly different to @pushAtom@ due to the fact that we allow + -- packing constructor fields. See also @mkConAppCode@ and @pushPadding@. + pushConstrAtom +- :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff) +- +-pushConstrAtom _ _ (AnnLit lit@(LitFloat _)) = ++ :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff) ++pushConstrAtom _ _ (StgLitArg lit@(LitFloat _)) = + return (unitOL (PUSH_UBX32 lit), 4) + +-pushConstrAtom d p (AnnVar v) ++pushConstrAtom d p va@(StgVarArg v) + | Just d_v <- lookupBCEnv_maybe v p = do -- v is a local variable + dflags <- getDynFlags + let !szb = idSizeCon dflags v +@@ -1642,7 +1770,7 @@ pushConstrAtom d p (AnnVar v) + 1 -> done PUSH8 + 2 -> done PUSH16 + 4 -> done PUSH32 +- _ -> pushAtom d p (AnnVar v) ++ _ -> pushAtom d p va + + pushConstrAtom d p expr = pushAtom d p expr + +@@ -1802,7 +1930,14 @@ idSizeW :: DynFlags -> Id -> WordOff + idSizeW dflags = WordOff . argRepSizeW dflags . bcIdArgRep + + idSizeCon :: DynFlags -> Id -> ByteOff +-idSizeCon dflags = ByteOff . primRepSizeB dflags . bcIdPrimRep ++idSizeCon dflags var ++ -- unboxed tuple components are padded to word size ++ | isUnboxedTupleType (idType var) || ++ isUnboxedSumType (idType var) = ++ wordsToBytes dflags . ++ WordOff . sum . map (argRepSizeW dflags . toArgRep) . ++ bcIdPrimReps $ var ++ | otherwise = ByteOff (primRepSizeB dflags (bcIdPrimRep var)) + + bcIdArgRep :: Id -> ArgRep + bcIdArgRep = toArgRep . bcIdPrimRep +@@ -1814,6 +1949,9 @@ bcIdPrimRep id | otherwise = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) @@ -468,22 +5647,134 @@ index fb60c21f9d..62e8457c5a 100644 repSizeWords :: DynFlags -> PrimRep -> WordOff repSizeWords dflags rep = WordOff $ argRepSizeW dflags (toArgRep rep) -@@ -1921,6 +2109,10 @@ mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb) - typeArgRep :: Type -> ArgRep - typeArgRep = toArgRep . typePrimRep1 +@@ -1821,17 +1959,6 @@ isFollowableArg :: ArgRep -> Bool + isFollowableArg P = True + isFollowableArg _ = False -+-- XXX this can be removed? +-isVoidArg :: ArgRep -> Bool +-isVoidArg V = True +-isVoidArg _ = False +- +--- See bug #1257 +-multiValException :: a +-multiValException = throwGhcException (ProgramError +- ("Error: bytecode compiler can't handle unboxed tuples and sums.\n"++ +- " Possibly due to foreign import/export decls in source.\n"++ +- " Workaround: use -fobject-code, or compile this module to .o separately.")) +- + -- | Indicate if the calling convention is supported + isSupportedCConv :: CCallSpec -> Bool + isSupportedCConv (CCallSpec _ cconv _) = case cconv of +@@ -1867,49 +1994,11 @@ mkSlideW !n !ws + limit :: Word16 + limit = maxBound + +-splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann]) +- -- The arguments are returned in *right-to-left* order +-splitApp e | Just e' <- bcView e = splitApp e' +-splitApp (AnnApp (_,f) (_,a)) = case splitApp f of +- (f', as) -> (f', a:as) +-splitApp e = (e, []) +- +- +-bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann) +--- The "bytecode view" of a term discards +--- a) type abstractions +--- b) type applications +--- c) casts +--- d) ticks (but not breakpoints) +--- Type lambdas *can* occur in random expressions, +--- whereas value lambdas cannot; that is why they are nuked here +-bcView (AnnCast (_,e) _) = Just e +-bcView (AnnLam v (_,e)) | isTyVar v = Just e +-bcView (AnnApp (_,e) (_, AnnType _)) = Just e +-bcView (AnnTick Breakpoint{} _) = Nothing +-bcView (AnnTick _other_tick (_,e)) = Just e +-bcView _ = Nothing +- +-isVAtom :: AnnExpr' Var ann -> Bool +-isVAtom e | Just e' <- bcView e = isVAtom e' +-isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v) +-isVAtom (AnnCoercion {}) = True +-isVAtom _ = False +- +-atomPrimRep :: AnnExpr' Id ann -> PrimRep +-atomPrimRep e | Just e' <- bcView e = atomPrimRep e' +-atomPrimRep (AnnVar v) = bcIdPrimRep v +-atomPrimRep (AnnLit l) = typePrimRep1 (literalType l) +- +--- #12128: +--- A case expression can be an atom because empty cases evaluate to bottom. +--- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs +-atomPrimRep (AnnCase _ _ ty _) = +- ASSERT(case typePrimRep ty of [LiftedRep] -> True; _ -> False) LiftedRep +-atomPrimRep (AnnCoercion {}) = VoidRep +-atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other)) ++atomPrimRep :: StgArg -> PrimRep ++atomPrimRep (StgVarArg v) = bcIdPrimRep v ++atomPrimRep (StgLitArg l) = typePrimRep1 (literalType l) + +-atomRep :: AnnExpr' Id ann -> ArgRep ++atomRep :: StgArg -> ArgRep + atomRep e = toArgRep (atomPrimRep e) + + -- | Let szsw be the sizes in bytes of some items pushed onto the stack, which +@@ -1918,8 +2007,8 @@ atomRep e = toArgRep (atomPrimRep e) + mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff] + mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb) + +-typeArgRep :: Type -> ArgRep +-typeArgRep = toArgRep . typePrimRep1 +typeArgReps :: Type -> [ArgRep] -+typeArgReps = map toArgRep . typePrimRepArgs -- typePrimRepArgs (idType id) -+ ++typeArgReps = map toArgRep . typePrimRepArgs + -- ----------------------------------------------------------------------------- -- The bytecode generator's monad - diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs -index c386ece52a..d8f902546f 100644 +index c386ece52a..af7cfee394 100644 --- a/compiler/ghci/ByteCodeInstr.hs +++ b/compiler/ghci/ByteCodeInstr.hs -@@ -86,6 +86,9 @@ data BCInstr +@@ -1,4 +1,5 @@ +-{-# LANGUAGE CPP, MagicHash #-} ++{-# LANGUAGE CPP #-} ++{-# LANGUAGE FlexibleContexts #-} + {-# OPTIONS_GHC -funbox-strict-fields #-} + -- + -- (c) The University of Glasgow 2002-2006 +@@ -17,22 +18,18 @@ import ByteCodeTypes + import GHCi.RemoteTypes + import GHCi.FFI (C_ffi_cif) + import GHC.StgToCmm.Layout ( ArgRep(..) ) +-import PprCore + import Outputable +-import FastString + import Name + import Unique +-import Id +-import CoreSyn + import Literal + import DataCon +-import VarSet + import PrimOp + import SMRep + + import Data.Word + import GHC.Stack.CCS (CostCentre) + ++import StgSyn + -- ---------------------------------------------------------------------------- + -- Bytecode instructions + +@@ -45,7 +42,7 @@ data ProtoBCO a + protoBCOBitmapSize :: Word16, + protoBCOArity :: Int, + -- what the BCO came from, for debugging only +- protoBCOExpr :: Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet), ++ protoBCOExpr :: Either [CgStgAlt] CgStgRhs, + -- malloc'd pointers + protoBCOFFIs :: [FFIInfo] + } +@@ -86,6 +83,9 @@ data BCInstr -- Push an alt continuation | PUSH_ALTS (ProtoBCO Name) | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep @@ -493,7 +5784,7 @@ index c386ece52a..d8f902546f 100644 -- Pushing 8, 16 and 32 bits of padding (for constructors). | PUSH_PAD8 -@@ -168,8 +171,9 @@ data BCInstr +@@ -168,8 +168,9 @@ data BCInstr -- To Infinity And Beyond | ENTER @@ -504,7 +5795,77 @@ index c386ece52a..d8f902546f 100644 -- Breakpoints | BRK_FUN Word16 Unique (RemotePtr CostCentre) -@@ -234,8 +238,13 @@ instance Outputable BCInstr where +@@ -188,36 +189,45 @@ instance Outputable a => Outputable (ProtoBCO a) where + = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity + <+> text (show ffis) <> colon) + $$ nest 3 (case origin of +- Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';')) +- (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}' +- Right rhs -> pprCoreExprShort (deAnnotate rhs)) ++ Left alts -> ++ vcat (zipWith (<+>) (char '{' : repeat (char ';')) ++ (map pprStgAltShort alts)) ++ Right rhs -> ++ pprStgRhsShort rhs ++ ) + $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap) + $$ nest 3 (vcat (map ppr instrs)) + +--- Print enough of the Core expression to enable the reader to find +--- the expression in the -ddump-prep output. That is, we need to ++-- Print enough of the STG expression to enable the reader to find ++-- the expression in the -ddump-stg output. That is, we need to + -- include at least a binder. + +-pprCoreExprShort :: CoreExpr -> SDoc +-pprCoreExprShort expr@(Lam _ _) +- = let +- (bndrs, _) = collectBinders expr +- in +- char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> text "..." ++pprStgExprShort :: OutputablePass pass => GenStgExpr pass -> SDoc ++pprStgExprShort (StgCase _expr var _ty _alts) = ++ text "case of" <+> ppr var ++pprStgExprShort (StgLet _ bnd _) = ++ text "let" <+> pprStgBindShort bnd <+> text "in ..." ++pprStgExprShort (StgLetNoEscape _ bnd _) = ++ text "let-no-escape" <+> pprStgBindShort bnd <+> text "in ..." ++pprStgExprShort (StgTick t e) = ppr t <+> pprStgExprShort e ++pprStgExprShort e = pprStgExpr e ++ ++pprStgBindShort :: OutputablePass pass => GenStgBinding pass -> SDoc ++pprStgBindShort (StgNonRec x _) = ++ ppr x <+> text "= ..." ++pprStgBindShort (StgRec bs) = ++ char '{' <+> ppr (fst (head bs)) <+> text "= ...; ... }" ++ ++pprStgAltShort :: OutputablePass pass => GenStgAlt pass -> SDoc ++pprStgAltShort (con, args, expr) = ++ ppr con <+> sep (map ppr args) <+> text "->" <+> pprStgExprShort expr ++ ++pprStgRhsShort :: OutputablePass pass => GenStgRhs pass -> SDoc ++pprStgRhsShort (StgRhsClosure _ext _cc upd_flag args body) = ++ hang (hsep [ char '\\' <> ppr upd_flag, brackets (interppSP args) ]) ++ 4 (pprStgExprShort body) ++pprStgRhsShort rhs = pprStgRhs rhs + +-pprCoreExprShort (Case _expr var _ty _alts) +- = text "case of" <+> ppr var +- +-pprCoreExprShort (Let (NonRec x _) _) = text "let" <+> ppr x <+> ptext (sLit ("= ... in ...")) +-pprCoreExprShort (Let (Rec bs) _) = text "let {" <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ...")) +- +-pprCoreExprShort (Tick t e) = ppr t <+> pprCoreExprShort e +-pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> text "`cast` T" +- +-pprCoreExprShort e = pprCoreExpr e +- +-pprCoreAltShort :: CoreAlt -> SDoc +-pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> text "->" <+> pprCoreExprShort expr + + instance Outputable BCInstr where + ppr (STKCHECK n) = text "STKCHECK" <+> ppr n +@@ -234,8 +244,13 @@ instance Outputable BCInstr where ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers." <> ppr op ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco) @@ -518,7 +5879,7 @@ index c386ece52a..d8f902546f 100644 ppr PUSH_PAD8 = text "PUSH_PAD8" ppr PUSH_PAD16 = text "PUSH_PAD16" -@@ -292,8 +301,11 @@ instance Outputable BCInstr where +@@ -292,8 +307,11 @@ instance Outputable BCInstr where ppr ENTER = text "ENTER" ppr RETURN = text "RETURN" ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk @@ -530,7 +5891,7 @@ index c386ece52a..d8f902546f 100644 -- ----------------------------------------------------------------------------- -- The stack use, in words, of each bytecode insn. These _must_ be -- correct, or overestimates of reality, to be safe. -@@ -321,8 +333,14 @@ bciStackUse PUSH32_W{} = 1 -- takes exactly 1 word +@@ -321,8 +339,14 @@ bciStackUse PUSH32_W{} = 1 -- takes exactly 1 word bciStackUse PUSH_G{} = 1 bciStackUse PUSH_PRIMOP{} = 1 bciStackUse PUSH_BCO{} = 1 @@ -547,7 +5908,7 @@ index c386ece52a..d8f902546f 100644 bciStackUse (PUSH_PAD8) = 1 -- overapproximation bciStackUse (PUSH_PAD16) = 1 -- overapproximation bciStackUse (PUSH_PAD32) = 1 -- overapproximation on 64bit arch -@@ -361,6 +379,7 @@ bciStackUse JMP{} = 0 +@@ -361,6 +385,7 @@ bciStackUse JMP{} = 0 bciStackUse ENTER{} = 0 bciStackUse RETURN{} = 0 bciStackUse RETURN_UBX{} = 1 @@ -556,19 +5917,21 @@ index c386ece52a..d8f902546f 100644 bciStackUse SWIZZLE{} = 0 bciStackUse BRK_FUN{} = 0 diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs -index 0c0c34ad64..71378b27f3 100644 +index 0c0c34ad64..617126196e 100644 --- a/compiler/ghci/ByteCodeTypes.hs +++ b/compiler/ghci/ByteCodeTypes.hs -@@ -8,6 +8,8 @@ module ByteCodeTypes - ( CompiledByteCode(..), seqCompiledByteCode, FFIInfo(..) +@@ -5,7 +5,9 @@ + + -- | Bytecode assembler types + module ByteCodeTypes +- ( CompiledByteCode(..), seqCompiledByteCode, FFIInfo(..) ++ ( CompiledByteCode(..), seqCompiledByteCode ++ , FFIInfo(..), TupleInfo(..), voidTupleInfo ++ , ByteOff(..), WordOff(..) , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..) , ItblEnv, ItblPtr(..) -+ , TupleInfo(..) -+ , ByteOff(..), WordOff(..) , CgBreakInfo(..) - , ModBreaks (..), BreakIndex, emptyModBreaks - , CCostCentre -@@ -67,6 +69,34 @@ seqCompiledByteCode CompiledByteCode{..} = +@@ -67,6 +69,37 @@ seqCompiledByteCode CompiledByteCode{..} = rnf bc_strs `seq` rnf (fmap seqModBreaks bc_breaks) @@ -599,51 +5962,635 @@ index 0c0c34ad64..71378b27f3 100644 + char 'F' <> ppr tupleFloatRegs <+> + char 'D' <> ppr tupleDoubleRegs <> + char '>' ++ ++voidTupleInfo :: TupleInfo ++voidTupleInfo = TupleInfo 0 0 0 0 0 0 + type ItblEnv = NameEnv (Name, ItblPtr) -- We need the Name in the range so we know which -- elements to filter out when unloading a module +diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs +index 077c66371e..d5a0b22ff1 100644 +--- a/compiler/iface/TcIface.hs ++++ b/compiler/iface/TcIface.hs +@@ -1372,7 +1372,7 @@ tcIfaceExpr (IfaceTick tickish expr) = do + return (Tick tickish' expr') + + ------------------------- +-tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id) ++tcIfaceTickish :: IfaceTickish -> IfM lcl CoreTickish + tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix) + tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push) + tcIfaceTickish (IfaceSource src name) = return (SourceNote src name) +diff --git a/compiler/iface/ToIface.hs b/compiler/iface/ToIface.hs +index d32a0529af..92ae16d7ea 100644 +--- a/compiler/iface/ToIface.hs ++++ b/compiler/iface/ToIface.hs +@@ -550,7 +550,7 @@ toIfaceOneShot id | isId id + = IfaceNoOneShot + + --------------------- +-toIfaceTickish :: Tickish Id -> Maybe IfaceTickish ++toIfaceTickish :: CoreTickish -> Maybe IfaceTickish + toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push) + toIfaceTickish (HpcTick modl ix) = Just (IfaceHpcTick modl ix) + toIfaceTickish (SourceNote src names) = Just (IfaceSource src names) diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs -index 6599da07f4..d587f9c88e 100644 +index dc8344d14d..b32b383510 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs -@@ -2078,7 +2078,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots - (defaultObjectTarget dflags) - map0 - else if hscTarget dflags == HscInterpreted +@@ -66,7 +66,6 @@ import TcBackpack + import Packages + import UniqSet + import Util +-import qualified GHC.LanguageExtensions as LangExt + import NameEnv + import FileCleanup + +@@ -2074,15 +2073,12 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots + -- otherwise those modules will fail to compile. + -- See Note [-fno-code mode] #8025 + map1 <- if hscTarget dflags == HscNothing +- then enableCodeGenForTH +- (defaultObjectTarget dflags) +- map0 +- else if hscTarget dflags == HscInterpreted - then enableCodeGenForUnboxedTuplesOrSums -+ then enableCodeGenForUnboxedSums - (defaultObjectTarget dflags) - map0 - else return map0 -@@ -2177,23 +2177,21 @@ enableCodeGenForTH = - -- - -- This is used used in order to load code that uses unboxed tuples - -- or sums into GHCi while still allowing some code to be interpreted. +- (defaultObjectTarget dflags) +- map0 +- else return map0 ++ then enableCodeGenForTH ++ (defaultObjectTarget dflags) ++ map0 ++ else return map0 + return $ concat $ nodeMapElts map1 ++ + where + calcDeps = msDeps + +@@ -2170,30 +2166,8 @@ enableCodeGenForTH = + -- can't compile anything anyway! See #16219. + not (isIndefinite dflags) + +--- | Update the every ModSummary that is depended on +--- by a module that needs unboxed tuples. We enable codegen to +--- the specified target, disable optimization and change the .hi +--- and .o file locations to be temporary files. +--- +--- This is used used in order to load code that uses unboxed tuples +--- or sums into GHCi while still allowing some code to be interpreted. -enableCodeGenForUnboxedTuplesOrSums :: HscTarget -+enableCodeGenForUnboxedSums :: HscTarget - -> NodeMap [Either ErrorMessages ModSummary] - -> IO (NodeMap [Either ErrorMessages ModSummary]) +- -> NodeMap [Either ErrorMessages ModSummary] +- -> IO (NodeMap [Either ErrorMessages ModSummary]) -enableCodeGenForUnboxedTuplesOrSums = -+enableCodeGenForUnboxedSums = - enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule - where - condition ms = +- enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule +- where +- condition ms = - unboxed_tuples_or_sums (ms_hspp_opts ms) && -+ xopt LangExt.UnboxedSums (ms_hspp_opts ms) && - not (gopt Opt_ByteCodeIfUnboxed (ms_hspp_opts ms)) && - not (isBootSummary ms) +- not (gopt Opt_ByteCodeIfUnboxed (ms_hspp_opts ms)) && +- not (isBootSummary ms) - unboxed_tuples_or_sums d = - xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d - should_modify (ModSummary { ms_hspp_opts = dflags }) = - hscTarget dflags == HscInterpreted - - -- | Helper used to implement 'enableCodeGenForTH' and +- should_modify (ModSummary { ms_hspp_opts = dflags }) = +- hscTarget dflags == HscInterpreted +- +--- | Helper used to implement 'enableCodeGenForTH' and --- 'enableCodeGenForUnboxedTuples'. In particular, this enables -+-- 'enableCodeGenForUnboxedSums'. In particular, this enables ++-- | Helper used to implement 'enableCodeGenForTH'. ++-- In particular, this enables -- unoptimized code generation for all modules that meet some -- condition (first parameter), or are dependencies of those -- modules. The second parameter is a condition to check before +diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs +index 9bb6b4e391..e4dd13b9d7 100644 +--- a/compiler/main/HscMain.hs ++++ b/compiler/main/HscMain.hs +@@ -123,8 +123,10 @@ import MkIface + import Desugar + import SimplCore + import TidyPgm ++import Unique + import CorePrep + import CoreToStg ( coreToStg ) ++import CoreUtils ( exprType ) + import qualified GHC.StgToCmm as StgToCmm ( codeGen ) + import StgSyn + import StgFVs ( annTopBindingsFreeVars ) +@@ -1432,7 +1434,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do + ----------------- Convert to STG ------------------ + (stg_binds, (caf_ccs, caf_cc_stacks)) + <- {-# SCC "CoreToStg" #-} +- myCoreToStg dflags this_mod prepd_binds ++ myCoreToStg hsc_env this_mod prepd_binds + + let cost_centre_info = + (S.toList local_ccs ++ caf_ccs, caf_cc_stacks) +@@ -1494,8 +1496,12 @@ hscInteractive hsc_env cgguts location = do + -- Do saturation and convert to A-normal form + (prepd_binds, _) <- {-# SCC "CorePrep" #-} + corePrepPgm hsc_env this_mod location core_binds data_tycons ++ ++ (stg_binds, _caf_ccs__caf_cc_stacks) ++ <- {-# SCC "CoreToStg" #-} ++ myCoreToStg hsc_env this_mod prepd_binds + ----------------- Generate byte code ------------------ +- comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks ++ comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks + ------------------ Create f-x-dynamic C-side stuff ----- + (_istub_h_exists, istub_c_exists) + <- outputForeignStubs dflags this_mod location foreign_stubs +@@ -1572,21 +1578,20 @@ doCodeGen hsc_env this_mod data_tycons + + + +-myCoreToStg :: DynFlags -> Module -> CoreProgram ++myCoreToStg :: HscEnv -> Module -> CoreProgram + -> IO ( [StgTopBinding] -- output program + , CollectedCCs ) -- CAF cost centre info (declared and used) +-myCoreToStg dflags this_mod prepd_binds = do ++myCoreToStg hsc_env this_mod prepd_binds = do + let (stg_binds, cost_centre_info) + = {-# SCC "Core2Stg" #-} +- coreToStg dflags this_mod prepd_binds ++ coreToStg (hsc_dflags hsc_env) this_mod prepd_binds + + stg_binds2 + <- {-# SCC "Stg2Stg" #-} +- stg2stg dflags this_mod stg_binds ++ stg2stg hsc_env this_mod stg_binds + + return (stg_binds2, cost_centre_info) + +- + {- ********************************************************************** + %* * + \subsection{Compiling a do-statement} +@@ -1722,9 +1727,13 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do + (prepd_binds, _) <- {-# SCC "CorePrep" #-} + liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons + ++ (stg_binds, _caf_ccs__caf_cc_stacks) ++ <- {-# SCC "CoreToStg" #-} ++ liftIO $ myCoreToStg hsc_env this_mod prepd_binds ++ + {- Generate byte code -} + cbc <- liftIO $ byteCodeGen hsc_env this_mod +- prepd_binds data_tycons mod_breaks ++ stg_binds data_tycons mod_breaks + + let src_span = srcLocSpan interactiveSrcLoc + liftIO $ linkDecls hsc_env src_span cbc +@@ -1887,9 +1896,20 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr + {- Lint if necessary -} + ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr + ++ {- Create a temporary binding and convert to STG -} ++ ; let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel") ++ (mkPseudoUniqueE 0) ++ (exprType prepd_expr) ++ ; ([StgTopLifted (StgNonRec _ stg_expr)], _) <- ++ myCoreToStg hsc_env ++ (icInteractiveModule (hsc_IC hsc_env)) ++ [NonRec bco_tmp_id prepd_expr] ++ + {- Convert to BCOs -} + ; bcos <- coreExprToBCOs hsc_env +- (icInteractiveModule (hsc_IC hsc_env)) prepd_expr ++ (icInteractiveModule (hsc_IC hsc_env)) ++ bco_tmp_id ++ stg_expr + + {- link it -} + ; hval <- linkExpr hsc_env srcspan bcos +diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs +index ae491ac02d..2131b0f30c 100644 +--- a/compiler/main/TidyPgm.hs ++++ b/compiler/main/TidyPgm.hs +@@ -769,7 +769,7 @@ dffvExpr :: CoreExpr -> DFFV () + dffvExpr (Var v) = insert v + dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 + dffvExpr (Lam v e) = extendScope v (dffvExpr e) +-dffvExpr (Tick (Breakpoint _ ids) e) = mapM_ insert ids >> dffvExpr e ++dffvExpr (Tick (Breakpoint _ _ ids) e) = mapM_ insert ids >> dffvExpr e + dffvExpr (Tick _other e) = dffvExpr e + dffvExpr (Cast e _) = dffvExpr e + dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e) +diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs +index 33f1c5b2f7..9b252bc01c 100644 +--- a/compiler/nativeGen/Dwarf.hs ++++ b/compiler/nativeGen/Dwarf.hs +@@ -7,7 +7,7 @@ import GhcPrelude + import CLabel + import CmmExpr ( GlobalReg(..) ) + import Config ( cProjectName, cProjectVersion ) +-import CoreSyn ( Tickish(..) ) ++import CoreSyn ( CmmTickish, GenTickish(..) ) + import Debug + import DynFlags + import Module +@@ -207,7 +207,7 @@ blockToDwarf df blk + | Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk + | otherwise = Nothing -- block was optimized out + +-tickToDwarf :: DynFlags -> Tickish () -> [DwarfInfo] ++tickToDwarf :: DynFlags -> CmmTickish -> [DwarfInfo] + tickToDwarf _ (SourceNote ss _) = [DwarfSrcNote ss] + tickToDwarf _ _ = [] + +diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs +index 702cd98e77..6ed38ede7c 100644 +--- a/compiler/nativeGen/X86/CodeGen.hs ++++ b/compiler/nativeGen/X86/CodeGen.hs +@@ -69,7 +69,7 @@ import Hoopl.Collections + import Hoopl.Graph + import Hoopl.Label + import CLabel +-import CoreSyn ( Tickish(..) ) ++import CoreSyn ( GenTickish(..) ) + import SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) + + -- The rest: +diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs +index 015d096a0a..e594aa2e73 100644 +--- a/compiler/simplCore/FloatOut.hs ++++ b/compiler/simplCore/FloatOut.hs +@@ -733,7 +733,7 @@ atJoinCeiling (fs, floats, expr') + where + (floats', ceils) = partitionAtJoinCeiling floats + +-wrapTick :: Tickish Id -> FloatBinds -> FloatBinds ++wrapTick :: CoreTickish -> FloatBinds -> FloatBinds + wrapTick t (FB tops ceils defns) + = FB (mapBag wrap_bind tops) (wrap_defns ceils) + (M.map (M.map wrap_defns) defns) +diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs +index 7c3ed3f16a..7524c8e577 100644 +--- a/compiler/simplCore/OccurAnal.hs ++++ b/compiler/simplCore/OccurAnal.hs +@@ -1708,7 +1708,7 @@ occAnal env (Tick tickish body) + | tickish `tickishScopesLike` SoftScope + = (markAllNonTailCalled usage, Tick tickish body') + +- | Breakpoint _ ids <- tickish ++ | Breakpoint _ _ ids <- tickish + = (usage_lam `andUDs` foldr addManyOccs emptyDetails ids, Tick tickish body') + -- never substitute for any of the Ids in a Breakpoint + +@@ -1841,7 +1841,7 @@ Constructors are rather like lambdas in this way. + -} + + occAnalApp :: OccEnv +- -> (Expr CoreBndr, [Arg CoreBndr], [Tickish Id]) ++ -> (Expr CoreBndr, [Arg CoreBndr], [CoreTickish]) + -> (UsageDetails, Expr CoreBndr) + occAnalApp env (Var fun, args, ticks) + | null ticks = (uds, mkApps (Var fun) args') +diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs +index 149a079a0a..45e9036162 100644 +--- a/compiler/simplCore/SimplCore.hs ++++ b/compiler/simplCore/SimplCore.hs +@@ -900,7 +900,7 @@ ticks. More often than not, other references will be unfoldings of + x_exported, and therefore carry the tick anyway. + -} + +-type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks ++type IndEnv = IdEnv (Id, [CoreTickish]) -- Maps local_id -> exported_id, ticks + + shortOutIndirections :: CoreProgram -> CoreProgram + shortOutIndirections binds +diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs +index bad66e3d8b..1b854a1459 100644 +--- a/compiler/simplCore/SimplUtils.hs ++++ b/compiler/simplCore/SimplUtils.hs +@@ -155,7 +155,7 @@ data SimplCont + , sc_cont :: SimplCont } + + | TickIt -- (TickIt t K)[e] = K[ tick t e ] +- (Tickish Id) -- Tick tickish ++ CoreTickish -- Tick tickish + SimplCont + + type StaticEnv = SimplEnv -- Just the static part is relevant +diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs +index 569bcfd3dc..b361364f92 100644 +--- a/compiler/simplCore/Simplify.hs ++++ b/compiler/simplCore/Simplify.hs +@@ -5,6 +5,7 @@ + -} + + {-# LANGUAGE CPP #-} ++{-# LANGUAGE TypeFamilies #-} + + module Simplify ( simplTopBinds, simplExpr, simplRules ) where + +@@ -1061,7 +1062,7 @@ simplCoercion env co + -- long as this is a non-scoping tick, to let case and application + -- optimisations apply. + +-simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont ++simplTick :: SimplEnv -> CoreTickish -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + simplTick env tickish expr cont + -- A scoped tick turns into a continuation, so that we can spot +@@ -1155,8 +1156,8 @@ simplTick env tickish expr cont + + + simplTickish env tickish +- | Breakpoint n ids <- tickish +- = Breakpoint n (map (getDoneId . substId env) ids) ++ | Breakpoint ext n ids <- tickish ++ = Breakpoint ext n (map (getDoneId . substId env) ids) + | otherwise = tickish + + -- Push type application and coercion inside a tick +diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs +index 89b7d4205e..a05d66788d 100644 +--- a/compiler/simplStg/SimplStg.hs ++++ b/compiler/simplStg/SimplStg.hs +@@ -17,6 +17,7 @@ import GhcPrelude + + import StgSyn + ++import HscTypes ( HscEnv, hsc_dflags ) + import StgLint ( lintStgTopBindings ) + import StgStats ( showStgStats ) + import UnariseStg ( unarise ) +@@ -44,12 +45,12 @@ instance MonadUnique StgM where + runStgM :: Char -> StgM a -> IO a + runStgM mask (StgM m) = evalStateT m mask + +-stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do ++stg2stg :: HscEnv -- includes spec of what stg-to-stg passes to do + -> Module -- module being compiled + -> [StgTopBinding] -- input program + -> IO [StgTopBinding] -- output program + +-stg2stg dflags this_mod binds ++stg2stg hsc_env this_mod binds + = do { dump_when Opt_D_dump_stg "STG:" binds + ; showPass dflags "Stg2Stg" + -- Do the main business! +@@ -62,9 +63,10 @@ stg2stg dflags this_mod binds + } + + where ++ dflags = hsc_dflags hsc_env + stg_linter unarised + | gopt Opt_DoStgLinting dflags +- = lintStgTopBindings dflags this_mod unarised ++ = lintStgTopBindings hsc_env this_mod unarised + | otherwise + = \ _whodunnit _binds -> return () + +diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs +index dc48d75eb8..adee4e7532 100644 +--- a/compiler/specialise/Specialise.hs ++++ b/compiler/specialise/Specialise.hs +@@ -952,9 +952,9 @@ specLam env bndrs body + ; return (mkLams bndrs (wrapDictBindsE dumped_dbs body'), free_uds) } + + -------------- +-specTickish :: SpecEnv -> Tickish Id -> Tickish Id +-specTickish env (Breakpoint ix ids) +- = Breakpoint ix [ id' | id <- ids, Var id' <- [specVar env id]] ++specTickish :: SpecEnv -> CoreTickish -> CoreTickish ++specTickish env (Breakpoint ext ix ids) ++ = Breakpoint ext ix [ id' | id <- ids, Var id' <- [specVar env id]] + -- drop vars from the list if they have a non-variable substitution. + -- should never happen, but it's harmless to drop them anyway. + specTickish _ other_tickish = other_tickish +diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs +index 634b74be5b..f24e824525 100644 +--- a/compiler/stgSyn/CoreToStg.hs ++++ b/compiler/stgSyn/CoreToStg.hs +@@ -1,4 +1,6 @@ + {-# LANGUAGE CPP, DeriveFunctor #-} ++{-# LANGUAGE BangPatterns #-} ++{-# LANGUAGE TypeFamilies #-} + + -- + -- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +@@ -429,13 +431,10 @@ coreToStgExpr expr@(Lam _ _) + return result_expr + + coreToStgExpr (Tick tick expr) +- = do case tick of +- HpcTick{} -> return () +- ProfNote{} -> return () +- SourceNote{} -> return () +- Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen" ++ = do ++ let !stg_tick = coreToStgTick (exprType expr) tick + expr2 <- coreToStgExpr expr +- return (StgTick tick expr2) ++ return (StgTick stg_tick expr2) + + coreToStgExpr (Cast expr _) + = coreToStgExpr expr +@@ -526,7 +525,7 @@ mkStgAltType bndr alts + + coreToStgApp :: Id -- Function + -> [CoreArg] -- Arguments +- -> [Tickish Id] -- Debug ticks ++ -> [CoreTickish] -- Debug ticks + -> CtsM StgExpr + coreToStgApp f args ticks = do + (args', ticks') <- coreToStgArgs args +@@ -572,7 +571,8 @@ coreToStgApp f args ticks = do + TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args') + _other -> StgApp f args' + +- tapp = foldr StgTick app (ticks ++ ticks') ++ add_tick !t !e = StgTick t e ++ tapp = foldr add_tick app (map (coreToStgTick res_ty) ticks ++ ticks') + + -- Forcing these fixes a leak in the code generator, noticed while + -- profiling for trac #4367 +@@ -583,7 +583,7 @@ coreToStgApp f args ticks = do + -- This is the guy that turns applications into A-normal form + -- --------------------------------------------------------------------------- + +-coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [Tickish Id]) ++coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish]) + coreToStgArgs [] + = return ([], []) + +@@ -598,7 +598,8 @@ coreToStgArgs (Coercion _ : args) -- Coercion argument; See Note [Coercion token + coreToStgArgs (Tick t e : args) + = ASSERT( not (tickishIsCode t) ) + do { (args', ts) <- coreToStgArgs (e : args) +- ; return (args', t:ts) } ++ ; let !t' = coreToStgTick (exprType e) t ++ ; return (args', t':ts) } + + coreToStgArgs (arg : args) = do -- Non-type argument + (stg_args, ticks) <- coreToStgArgs args +@@ -630,6 +631,13 @@ coreToStgArgs (arg : args) = do -- Non-type argument + WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg ) + return (stg_arg : stg_args, ticks ++ aticks) + ++coreToStgTick :: Type -- type of the ticked expression ++ -> CoreTickish ++ -> StgTickish ++coreToStgTick _ty (HpcTick m i) = HpcTick m i ++coreToStgTick _ty (SourceNote span nm) = SourceNote span nm ++coreToStgTick _ty (ProfNote cc cnt scope) = ProfNote cc cnt scope ++coreToStgTick !ty (Breakpoint _ bid fvs) = Breakpoint ty bid fvs + + -- --------------------------------------------------------------------------- + -- The magic for lets: +@@ -936,7 +944,7 @@ myCollectBinders expr + + -- | Precondition: argument expression is an 'App', and there is a 'Var' at the + -- head of the 'App' chain. +-myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id]) ++myCollectArgs :: CoreExpr -> (Id, [CoreArg], [CoreTickish]) + myCollectArgs expr + = go expr [] [] + where +diff --git a/compiler/stgSyn/StgFVs.hs b/compiler/stgSyn/StgFVs.hs +index edfc94ed2d..22bb20b97c 100644 +--- a/compiler/stgSyn/StgFVs.hs ++++ b/compiler/stgSyn/StgFVs.hs +@@ -1,4 +1,5 @@ + -- | Free variable analysis on STG terms. ++{-# LANGUAGE TypeFamilies #-} + module StgFVs ( + annTopBindingsFreeVars, + annBindingFreeVars +@@ -9,7 +10,7 @@ import GhcPrelude + import StgSyn + import Id + import VarSet +-import CoreSyn ( Tickish(Breakpoint) ) ++import CoreSyn ( GenTickish(Breakpoint) ) + import Outputable + import Util + +@@ -103,8 +104,8 @@ expr env = go + where + (e', fvs) = go e + fvs' = unionDVarSet (tickish tick) fvs +- tickish (Breakpoint _ ids) = mkDVarSet ids +- tickish _ = emptyDVarSet ++ tickish (Breakpoint _ _ ids) = mkDVarSet ids ++ tickish _ = emptyDVarSet + + go_bind dc bind body = (dc bind' body', fvs) + where +diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs +index f83b44859c..f6fb1357e8 100644 +--- a/compiler/stgSyn/StgLint.hs ++++ b/compiler/stgSyn/StgLint.hs +@@ -40,6 +40,8 @@ module StgLint ( lintStgTopBindings ) where + import GhcPrelude + + import StgSyn ++import HscTypes ++import CoreLint ( interactiveInScope ) + + import DynFlags + import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) +@@ -61,14 +63,14 @@ import Control.Applicative ((<|>)) + import Control.Monad + + lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id) +- => DynFlags ++ => HscEnv + -> Module -- ^ module being compiled + -> Bool -- ^ have we run Unarise yet? + -> String -- ^ who produced the STG? + -> [GenStgTopBinding a] + -> IO () + +-lintStgTopBindings dflags this_mod unarised whodunnit binds ++lintStgTopBindings hsc_env this_mod unarised whodunnit binds + = {-# SCC "StgLint" #-} + case initL this_mod unarised top_level_binds (lint_binds binds) of + Nothing -> +@@ -84,9 +86,12 @@ lintStgTopBindings dflags this_mod unarised whodunnit binds + text "*** End of Offense ***"]) + Err.ghcExit dflags 1 + where ++ dflags = hsc_dflags hsc_env + -- Bring all top-level binds into scope because CoreToStg does not generate + -- bindings in dependency order (so we may see a use before its definition). +- top_level_binds = mkVarSet (bindersOfTopBinds binds) ++ top_level_binds = mkVarSet (bindersOfTopBinds binds ++ ++ interactiveInScope hsc_env ++ ) + + lint_binds :: [GenStgTopBinding a] -> LintM () + +diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs +index 052ef2b6c7..22b9d159ca 100644 +--- a/compiler/stgSyn/StgSyn.hs ++++ b/compiler/stgSyn/StgSyn.hs +@@ -54,14 +54,15 @@ module StgSyn ( + stripStgTicksTop, stripStgTicksTopE, + stgCaseBndrInScope, + +- pprStgBinding, pprGenStgTopBindings, pprStgTopBindings ++ pprStgBinding, pprGenStgTopBindings, pprStgTopBindings, ++ pprStgExpr, pprStgRhs + ) where + + #include "HsVersions.h" + + import GhcPrelude + +-import CoreSyn ( AltCon, Tickish ) ++import CoreSyn ( AltCon, StgTickish ) + import CostCentre ( CostCentreStack ) + import Data.ByteString ( ByteString ) + import Data.Data ( Data ) +@@ -168,13 +169,13 @@ stgArgType (StgLitArg lit) = literalType lit + + + -- | Strip ticks of a given type from an STG expression. +-stripStgTicksTop :: (Tickish Id -> Bool) -> GenStgExpr p -> ([Tickish Id], GenStgExpr p) ++stripStgTicksTop :: (StgTickish -> Bool) -> GenStgExpr p -> ([StgTickish], GenStgExpr p) + stripStgTicksTop p = go [] + where go ts (StgTick t e) | p t = go (t:ts) e + go ts other = (reverse ts, other) + + -- | Strip ticks of a given type from an STG expression returning only the expression. +-stripStgTicksTopE :: (Tickish Id -> Bool) -> GenStgExpr p -> GenStgExpr p ++stripStgTicksTopE :: (StgTickish -> Bool) -> GenStgExpr p -> GenStgExpr p + stripStgTicksTopE p = go + where go (StgTick t e) | p t = go e + go other = other +@@ -376,7 +377,7 @@ Finally for @hpc@ expressions we introduce a new STG construct. + -} + + | StgTick +- (Tickish Id) ++ StgTickish + (GenStgExpr pass) -- sub expression + + -- END of GenStgExpr +diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs +index a9de7ac1f6..b2288b0742 100644 +--- a/compiler/typecheck/TcBinds.hs ++++ b/compiler/typecheck/TcBinds.hs +@@ -20,7 +20,7 @@ import GhcPrelude + import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) + import {-# SOURCE #-} TcExpr ( tcMonoExpr ) + import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind ) +-import CoreSyn (Tickish (..)) ++import CoreSyn (CoreTickish, GenTickish (..)) + import CostCentre (mkUserCC, CCFlavour(DeclCC)) + import DynFlags + import FastString +@@ -738,7 +738,7 @@ tcPolyCheck _prag_fn sig bind + = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind) + + funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] +- -> TcM [Tickish TcId] ++ -> TcM [CoreTickish] + funBindTicks loc fun_id mod sigs + | (mb_cc_str : _) <- [ cc_name | (dL->L _ (SCCFunSig _ _ _ cc_name)) <- sigs ] + -- this can only be a singleton list, as duplicate pragmas are rejected diff --git a/includes/rts/Bytecodes.h b/includes/rts/Bytecodes.h index e5d55f694f..88748ea184 100644 --- a/includes/rts/Bytecodes.h @@ -741,10 +6688,18 @@ index 01d6c3b1d9..bae23c1f17 100644 default: barf("disInstr: unknown opcode %u", (unsigned int) instr); diff --git a/rts/Interpreter.c b/rts/Interpreter.c -index 463ddae18b..f33fb9c73e 100644 +index 463ddae18b..49d881e2e0 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c -@@ -681,12 +681,13 @@ do_return_unboxed: +@@ -4,6 +4,7 @@ + * Copyright (c) The GHC Team, 1994-2002. + * ---------------------------------------------------------------------------*/ + ++ + #include "PosixSource.h" + #include "Rts.h" + #include "RtsAPI.h" +@@ -681,12 +682,13 @@ do_return_unboxed: || SpW(0) == (W_)&stg_ret_f_info || SpW(0) == (W_)&stg_ret_d_info || SpW(0) == (W_)&stg_ret_l_info @@ -759,16 +6714,60 @@ index 463ddae18b..f33fb9c73e 100644 debugBelch("Sp = %p\n", Sp); #if defined(PROFILING) fprintCCS(stderr, cap->r.rCCCS); -@@ -697,7 +698,7 @@ do_return_unboxed: +@@ -697,7 +699,7 @@ do_return_unboxed: debugBelch("\n\n"); ); - // get the offset of the stg_ctoi_ret_XXX itbl -+ // get the offset of the stg_ctoi_XXX itbl ++ // get the offset of the header of the next stack frame offset = stack_frame_sizeW((StgClosure *)Sp); switch (get_itbl((StgClosure*)(Sp_plusW(offset)))->type) { -@@ -1326,6 +1327,64 @@ run_BCO: +@@ -934,6 +936,43 @@ run_BCO_return_unboxed: + // Stack checks aren't necessary at return points, the stack use + // is aggregated into the enclosing function entry point. + ++#if defined(PROFILING) ++ /* ++ Restore the current cost centre stack if a tuple is being returned. ++ ++ When a "simple" unboxed value is returned, the cccs is restored with ++ an stg_restore_cccs frame on the stack, for example: ++ ++ ... ++ stg_ctoi_D1 ++ ++ stg_restore_cccs ++ ++ But stg_restore_cccs cannot deal with tuples, which may have more ++ things on the stack. Therefore we store the CCCS inside the ++ stg_ctoi_t frame. ++ ++ If we have a tuple being returned, the stack looks like this: ++ ++ ... ++ <- to restore, Sp offset ++ tuple_BCO ++ tuple_info ++ cont_BCO ++ stg_ctoi_t <- next frame ++ tuple_data_1 ++ ... ++ tuple_data_n ++ tuple_info ++ tuple_BCO ++ stg_ret_t <- Sp ++ */ ++ ++ if(SpW(0) == (W_)&stg_ret_t_info) { ++ cap->r.rCCCS = (CostCentreStack*)SpW(stack_frame_sizeW((StgClosure *)Sp) + 4); ++ } ++#endif ++ + goto run_BCO; + + run_BCO_fun: +@@ -1326,6 +1365,64 @@ run_BCO: goto nextInsn; } @@ -777,6 +6776,11 @@ index 463ddae18b..f33fb9c73e 100644 + W_ tuple_info = (W_)BCO_LIT(BCO_GET_LARGE_ARG); + int o_tuple_bco = BCO_GET_LARGE_ARG; + ++#if defined(PROFILING) ++ SpW(-1) = (W_)cap->r.rCCCS; ++ Sp_subW(1); ++#endif ++ + SpW(-1) = BCO_PTR(o_tuple_bco); + SpW(-2) = tuple_info; + SpW(-3) = BCO_PTR(o_bco); @@ -819,21 +6823,16 @@ index 463ddae18b..f33fb9c73e 100644 + + default: barf("unsupported tuple size %d", tuple_stack_words); + } ++ + SpW(-4) = ctoi_t_offset; + Sp_subW(4); -+ /* XXX this cannot work yet */ -+ /* #if defined(PROFILING) -+ Sp_subW(2); -+ SpW(1) = (W_)cap->r.rCCCS; -+ SpW(0) = (W_)&stg_restore_cccs_info; -+ #endif */ + goto nextInsn; + } + case bci_PUSH_APPLY_N: Sp_subW(1); SpW(0) = (W_)&stg_ap_n_info; goto nextInsn; -@@ -1705,6 +1764,12 @@ run_BCO: +@@ -1705,6 +1802,12 @@ run_BCO: Sp_subW(1); SpW(0) = (W_)&stg_ret_v_info; goto do_return_unboxed; @@ -926,10 +6925,10 @@ index 15404e1205..ab2119cf78 100644 BCO_BITMAP(bco), BCO_BITMAP_SIZE(bco)); continue; diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c -index b2f90a892d..9ad6806c18 100644 +index 9ca696c27c..6d5e9805aa 100644 --- a/rts/RtsSymbols.c +++ b/rts/RtsSymbols.c -@@ -551,6 +551,8 @@ +@@ -552,6 +552,8 @@ SymI_HasProto(stg_ret_f_info) \ SymI_HasProto(stg_ret_d_info) \ SymI_HasProto(stg_ret_l_info) \ @@ -939,10 +6938,10 @@ index b2f90a892d..9ad6806c18 100644 SymI_HasProto(stg_gc_prim_pp) \ SymI_HasProto(stg_gc_prim_n) \ diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm -index 44d7d302e5..015a6b50f6 100644 +index 44d7d302e5..fdc4bc75a2 100644 --- a/rts/StgMiscClosures.cmm +++ b/rts/StgMiscClosures.cmm -@@ -195,6 +195,236 @@ INFO_TABLE_RET( stg_ctoi_V, RET_BCO ) +@@ -195,6 +195,240 @@ INFO_TABLE_RET( stg_ctoi_V, RET_BCO ) jump stg_yield_to_interpreter []; } @@ -1001,10 +7000,10 @@ index 44d7d302e5..015a6b50f6 100644 + tuple_BCO + stg_apply_interp <- Sp + -+ ++ + tuple_BCO contains the bytecode instructions to return the tuple to + cont_BCO. The bitmap in tuple_BCO describes the contents of -+ the tuple to the storage manager. ++ the tuple to the storage manager. + + At this point we can safely jump to the interpreter. + @@ -1076,6 +7075,10 @@ index 44d7d302e5..015a6b50f6 100644 + tuple_BCO = Sp(3); /* bytecode object that returns the tuple in + the interpreter */ + ++#if defined(PROFILING) ++ CCCS = Sp(4); ++#endif ++ + tuple_stack = tuple_info & 0x3fff; /* number of words spilled on stack */ + tuple_regs_R = (tuple_info >> 28) & 0xf; /* number of R1..Rn */ + tuple_regs_F = (tuple_info >> 22) & 0x3f; /* 6 bits bitmap */ @@ -1172,25 +7175,54 @@ index 44d7d302e5..015a6b50f6 100644 + if((tuple_regs_L & 1) != 0) { L1 = L_[Sp]; Sp = Sp + 8; } + + /* Sp points to the topmost argument now */ -+ jump Sp(tuple_stack) [*]; // NB. all registers live! ++ jump %ENTRY_CODE(Sp(tuple_stack)) [*]; // NB. all registers live! +} + + /* * Dummy info table pushed on the top of the stack when the interpreter * should apply the BCO on the stack to its arguments, also on the +diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/ByteCode.hs b/testsuite/tests/ghci/should_run/UnboxedTuples/ByteCode.hs +new file mode 100644 +index 0000000000..a1bce35ad0 +--- /dev/null ++++ b/testsuite/tests/ghci/should_run/UnboxedTuples/ByteCode.hs +@@ -0,0 +1,17 @@ ++{-# LANGUAGE CPP, UnboxedTuples, MagicHash, ScopedTypeVariables, PolyKinds #-} ++{-# OPTIONS_GHC -fbyte-code #-} ++ ++#include "MachDeps.h" ++ ++#if WORD_SIZE_IN_BITS < 64 ++#define WW Word64 ++#else ++#define WW Word ++#endif ++ ++module ByteCode where ++ ++import GHC.Exts ++import GHC.Word ++ ++#include "Common.hs-incl" diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/Common.hs-incl b/testsuite/tests/ghci/should_run/UnboxedTuples/Common.hs-incl new file mode 100644 -index 0000000000..80992405b5 +index 0000000000..6931397f09 --- /dev/null +++ b/testsuite/tests/ghci/should_run/UnboxedTuples/Common.hs-incl -@@ -0,0 +1,219 @@ +@@ -0,0 +1,368 @@ ++swap :: (# a, b #) -> (# b, a #) ++swap (# x, y #) = (# y, x #) ++ +type T1 a = a -> (# a #) +tuple1 :: T1 a +tuple1 x = (# x #) + -+tuple1a :: a -> T1 a -> a -+tuple1a x f = case f x of (# y #) -> y ++tuple1_a :: T1 a -> a -> a ++tuple1_a f x = case f x of (# y #) -> y ++ ++tuple1_b :: T1 a -> a -> String -> IO () ++tuple1_b f x msg = case f x of (# _ #) -> putStrLn msg + +-- can still be returned in registers, pointers +type T2p a = a -> a -> a -> a -> (# a, a, a, a #) @@ -1233,7 +7265,7 @@ index 0000000000..80992405b5 + , a, a, a, a + , a, a, a, a + ) -+tuple3_a f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 = ++tuple3_a f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 = + case f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 of + (# y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12 #) -> + (y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12) @@ -1363,7 +7395,7 @@ index 0000000000..80992405b5 + -> (# Int, WW#, Int, WW# + , Int, WW#, Int, WW# + , Int, WW#, Int, WW# -+ , Int, WW#, Int, WW# ++ , Int, WW#, Int, WW# + #) + +tuple5 :: T5 @@ -1404,13 +7436,156 @@ index 0000000000..80992405b5 + , (j5, W64# x5, j6, W64# x6) + , (j7, W64# x7, j8, W64# x8) + ) ++ ++type T6 = Int -> ++ (# Int#, (# Int, (# Int#, (# #) #) #) #) ++tuple6 :: T6 ++tuple6 x@(I# x#) = (# x#, (# x, (# x#, (# #) #) #) #) ++ ++tuple6_a :: T6 -> Int -> String ++tuple6_a f x = ++ case f x of ++ (# x1, (# x2, (# x3, (# #) #) #) #) -> show (I# x1, (x2, (I# x3, ()))) ++ ++-- empty tuples and tuples with void ++ ++type TV1 = Bool -> (# #) ++ ++{-# NOINLINE tuple_v1 #-} ++tuple_v1 :: TV1 ++tuple_v1 _ = (# #) ++ ++{-# NOINLINE tuple_v1_a #-} ++tuple_v1_a :: TV1 -> Bool -> Bool ++tuple_v1_a f x = case f x of (# #) -> True ++ ++ ++type TV2 = Bool -> (# (# #) #) ++ ++{-# NOINLINE tuple_v2 #-} ++tuple_v2 :: TV2 ++tuple_v2 _ = (# (# #) #) ++ ++{-# NOINLINE tuple_v2_a #-} ++tuple_v2_a :: TV2 -> Bool -> Bool ++tuple_v2_a f x = case f x of (# _ #) -> True ++ ++ ++type TV3 a = a -> (# (# #), a #) ++ ++{-# NOINLINE tuple_v3 #-} ++tuple_v3 :: TV3 a ++tuple_v3 x = (# (# #), x #) ++ ++{-# NOINLINE tuple_v3_a #-} ++tuple_v3_a :: TV3 a -> a -> a ++tuple_v3_a f x = case f x of (# _, y #) -> y ++ ++ ++type TV4 a = a -> (# a, (# #) #) ++ ++{-# NOINLINE tuple_v4 #-} ++tuple_v4 :: TV4 a ++tuple_v4 x = (# x, (# #) #) ++ ++{-# NOINLINE tuple_v4_a #-} ++tuple_v4_a :: TV4 a -> a -> a ++tuple_v4_a f x = case f x of (# y, _ #) -> y ++ ++ ++type TV5 a = a -> (# (# #), a, (# #) #) ++ ++{-# NOINLINE tuple_v5 #-} ++tuple_v5 :: TV5 a ++tuple_v5 x = (# (# #), x, (# #) #) ++ ++{-# NOINLINE tuple_v5_a #-} ++tuple_v5_a :: TV5 a -> a -> a ++tuple_v5_a f x = case f x of (# _, x, _ #) -> x ++ ++ ++type TV6 = Int -> Double -> Int -> Double ++ -> (# Int#, (# #), Double#, (# #) ++ , Int#, (# #), Double#, (# #) #) ++ ++{-# NOINLINE tuple_v6 #-} ++tuple_v6 :: TV6 ++tuple_v6 (I# x) (D# y) (I# z) (D# w) = (# x, (# #), y, (# #), z, (# #), w, (# #) #) ++ ++{-# NOINLINE tuple_v6_a #-} ++tuple_v6_a :: TV6 -> Int -> Double -> Int -> Double ++ -> (Int, Double, Int, Double) ++tuple_v6_a f x y z w = case f x y z w of (# x', _, y', _, z', _, w', _ #) -> ++ (I# x', D# y', I# z', D# w') ++ ++-- some levity polymorphic things ++{-# NOINLINE lev_poly #-} ++lev_poly :: forall r a (b :: TYPE r). ++ (a -> a -> a -> a -> ++ a -> a -> a -> a -> ++ a -> a -> a -> a -> b) -> a -> b ++lev_poly f x = f x x x x x x x x x x x x ++ ++{-# NOINLINE lev_poly_a #-} ++lev_poly_a :: (t1 ++ -> t2 -> (# a, b, c, d, e, f, g, h, i, j, k, l #)) ++ -> t1 -> t2 -> (a, b, c, d, e, f, g, h, i, j, k, l) ++lev_poly_a lp t x = ++ case lp t x of (# x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12 #) -> ++ (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12) ++ ++{-# NOINLINE lev_poly_boxed #-} ++lev_poly_boxed x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 ++ = (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12) ++ ++{-# NOINLINE lev_poly_b #-} ++lev_poly_b lp t x = ++ case lp t x of (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12) ++ -> (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12) ++ ++-- some unboxed sums ++type S1 = (# (# Int#, String #) | Bool #) ++ ++{-# NOINLINE sum1 #-} ++sum1 :: Int -> Int -> String -> Bool -> S1 ++sum1 0 (I# x) y _ = (# (# x, y #) | #) ++sum1 _ _ _ b = (# | b #) ++ ++{-# NOINLINE sum1_a #-} ++sum1_a :: (Int -> Int -> String -> Bool -> S1) -> Int -> Int -> String -> Bool -> Either (Int, String) Bool ++sum1_a f n x y b = ++ case f n x y b of ++ (# (# x, y #) | #) -> Left (I# x, y) ++ (# | b #) -> Right b ++ ++ ++type S2 a = (# (# a, a, a, a #) | (# a, a #) | (# #) | Int# | Int #) ++ ++{-# NOINLINE sum2 #-} ++sum2 :: Int -> a -> S2 a ++sum2 0 x = (# (# x, x, x, x #) | | | | #) ++sum2 1 x = (# | (# x, x #) | | | #) ++sum2 2 _ = (# | | (# #) | | #) ++sum2 n@(I# n#) _ ++ | even n = (# | | | n# | #) ++ | otherwise = (# | | | | n #) ++ ++{-# NOINLINE sum2_a #-} ++sum2_a :: Show a => (Int -> a -> S2 a) -> Int -> a -> String ++sum2_a f n x = ++ case f n x of ++ (# (# x1, x2, x3, x4 #) | | | | #) -> show (x1, x2, x3, x4) ++ (# | (# x1, x2 #) | | | #) -> show (x1, x2) ++ (# | | (# #) | | #) -> "(# #)" ++ (# | | | x# | #) -> show (I# x#) ++ "#" ++ (# | | | | x #) -> show x diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/Obj.hs b/testsuite/tests/ghci/should_run/UnboxedTuples/Obj.hs new file mode 100644 -index 0000000000..e9272583f0 +index 0000000000..190b8f1683 --- /dev/null +++ b/testsuite/tests/ghci/should_run/UnboxedTuples/Obj.hs @@ -0,0 +1,17 @@ -+{-# LANGUAGE CPP, UnboxedTuples, MagicHash #-} ++{-# LANGUAGE CPP, UnboxedTuples, MagicHash, ScopedTypeVariables, PolyKinds #-} +{-# OPTIONS_GHC -fobject-code #-} + +#include "MachDeps.h" @@ -1429,23 +7604,15 @@ index 0000000000..e9272583f0 +#include "Common.hs-incl" diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.hs b/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.hs new file mode 100644 -index 0000000000..f6cec4206f +index 0000000000..1daec7f207 --- /dev/null +++ b/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.hs -@@ -0,0 +1,83 @@ -+{-# LANGUAGE CPP, UnboxedTuples, MagicHash #-} +@@ -0,0 +1,182 @@ ++{-# LANGUAGE UnboxedTuples, MagicHash #-} +{-# OPTIONS_GHC -fbyte-code #-} + -+#include "MachDeps.h" -+ -+#if WORD_SIZE_IN_BITS < 64 -+#define WW Word64 -+#else -+#define WW Word -+#endif -+ +{- -+ Test unboxed tuples in the bytecode interpreter. ++ Test unboxed tuples and sums in the bytecode interpreter. + + The bytecode interpreter uses the stack for everything, while + compiled code uses STG registers for arguments and return values. @@ -1453,7 +7620,8 @@ index 0000000000..f6cec4206f + +module Main where + -+import qualified Obj as O ++import qualified Obj as O ++import qualified ByteCode as B + +import GHC.Exts +import GHC.Word @@ -1461,67 +7629,179 @@ index 0000000000..f6cec4206f +main :: IO () +main = do + ++ case B.swap (O.swap (B.swap (O.swap (# "x", 1 #)))) of ++ (# y1, y2 #) -> print (y1, y2) ++ ++ -- one-tuples ++ testX "tuple1" ++ B.tuple1_a O.tuple1_a ++ B.tuple1 O.tuple1 ++ (\f -> f 90053) ++ ++ -- check that the contents of a one-tuple aren't evaluated ++ B.tuple1_b B.tuple1 (error "error tuple1_b") "tuple1_b" ++ B.tuple1_b O.tuple1 (error "error tuple1_b") "tuple1_b" ++ O.tuple1_b B.tuple1 (error "error tuple1_b") "tuple1_b" ++ O.tuple1_b O.tuple1 (error "error tuple1_b") "tuple1_b" ++ ++ -- various size tuples with boxed/unboxed elements + testX "tuple2p" -+ tuple2p_a O.tuple2p_a -+ tuple2p O.tuple2p ++ B.tuple2p_a O.tuple2p_a ++ B.tuple2p O.tuple2p + (\f -> f (1234::Integer) 1235 1236 1237) + + testX "tuple2n" -+ tuple2n_a O.tuple2n_a -+ tuple2n O.tuple2n ++ B.tuple2n_a O.tuple2n_a ++ B.tuple2n O.tuple2n + (\f -> f 7654 7653 7652 7651) + + testX "tuple3" -+ tuple3_a O.tuple3_a -+ tuple3 O.tuple3 ++ B.tuple3_a O.tuple3_a ++ B.tuple3 O.tuple3 + (\f -> f (1000::Integer) 1001 1002 1003 + 1004 1005 1006 1007 + 1008 1009 1010 1011) + + testX "tuple4a" -+ tuple4a_a O.tuple4a_a -+ tuple4a O.tuple4a ++ B.tuple4a_a O.tuple4a_a ++ B.tuple4a O.tuple4a + (\f -> f 2000 2001 2002 2003) + + testX "tuple4b" -+ tuple4b_a O.tuple4b_a -+ tuple4b O.tuple4b -+ (\f -> f 3000 3001 3002 3003 ++ B.tuple4b_a O.tuple4b_a ++ B.tuple4b O.tuple4b ++ (\f -> f 3000 3001 3002 3003 + 3004 3005 3006 3007 + 3008 3009 3010 3011 + 3012 3013 3014 3015 + 3016 3017 3018 3019) + + testX "tuple4c" -+ tuple4c_a O.tuple4c_a -+ tuple4c O.tuple4c -+ (\f -> f 3000 3001 3002 3003 ++ B.tuple4c_a O.tuple4c_a ++ B.tuple4c O.tuple4c ++ (\f -> f 3000 3001 3002 3003 + 3004 3005 3006 3007 + 3008 3009 3010 3011 + 3012 3013 3014 3015) + + testX "tuple5" -+ tuple5_a O.tuple5_a -+ tuple5 O.tuple5 ++ B.tuple5_a O.tuple5_a ++ B.tuple5 O.tuple5 + (\f -> f 4000 4001 4002 4003 -+ 4004 4005 4006 4007 -+ 4008 4009 4010 4011 ++ 4004 4005 4006 4007 ++ 4008 4009 4010 4011 + 4012 4013 4014 4015) + ++ testX "tuple6" ++ B.tuple6_a O.tuple6_a ++ B.tuple6 O.tuple6 ++ (\f -> f 6006) ++ ++ -- tuples with void and empty tuples ++ testX "tuplev1" ++ B.tuple_v1_a O.tuple_v1_a ++ B.tuple_v1 O.tuple_v1 ++ (\f -> f False) ++ ++ testX "tuplev2" ++ B.tuple_v2_a O.tuple_v2_a ++ B.tuple_v2 O.tuple_v2 ++ (\f -> f False) ++ ++ testX "tuplev3" ++ B.tuple_v3_a O.tuple_v3_a ++ B.tuple_v3 O.tuple_v3 ++ (\f -> f 30001) ++ ++ testX "tuplev4" ++ B.tuple_v4_a O.tuple_v4_a ++ B.tuple_v4 O.tuple_v4 ++ (\f -> f 40001) ++ ++ testX "tuplev5" ++ B.tuple_v5_a O.tuple_v5_a ++ B.tuple_v5 O.tuple_v5 ++ (\f -> f 50001) ++ ++ testX "tuplev6" ++ B.tuple_v6_a O.tuple_v6_a ++ B.tuple_v6 O.tuple_v6 ++ (\f -> f 601 602 603 604) ++ ++ -- levity polymorphic ++ print $ B.lev_poly_a B.lev_poly B.tuple3 991 ++ print $ B.lev_poly_a B.lev_poly O.tuple3 992 ++ print $ B.lev_poly_a O.lev_poly B.tuple3 993 ++ print $ B.lev_poly_a O.lev_poly O.tuple3 994 ++ print $ O.lev_poly_a B.lev_poly B.tuple3 995 ++ print $ O.lev_poly_a B.lev_poly O.tuple3 996 ++ print $ O.lev_poly_a O.lev_poly B.tuple3 997 ++ print $ O.lev_poly_a O.lev_poly O.tuple3 998 ++ ++ print $ B.lev_poly_b B.lev_poly B.lev_poly_boxed 981 ++ print $ B.lev_poly_b B.lev_poly O.lev_poly_boxed 982 ++ print $ B.lev_poly_b O.lev_poly B.lev_poly_boxed 983 ++ print $ B.lev_poly_b O.lev_poly O.lev_poly_boxed 984 ++ print $ O.lev_poly_b B.lev_poly B.lev_poly_boxed 985 ++ print $ O.lev_poly_b B.lev_poly O.lev_poly_boxed 986 ++ print $ O.lev_poly_b O.lev_poly B.lev_poly_boxed 987 ++ print $ O.lev_poly_b O.lev_poly O.lev_poly_boxed 988 ++ ++ -- sums ++ testX "sum1a" ++ B.sum1_a O.sum1_a ++ B.sum1 O.sum1 ++ (\f -> f 0 1 "23" True) ++ ++ testX "sum1b" ++ B.sum1_a O.sum1_a ++ B.sum1 O.sum1 ++ (\f -> f 1 1 "23" True) ++ ++ testX "sum2a" ++ B.sum2_a O.sum2_a ++ B.sum2 O.sum2 ++ (\f -> f 0 "sum2") ++ ++ testX "sum2b" ++ B.sum2_a O.sum2_a ++ B.sum2 O.sum2 ++ (\f -> f 1 "sum2") ++ ++ testX "sum2c" ++ B.sum2_a O.sum2_a ++ B.sum2 O.sum2 ++ (\f -> f 2 "sum2") ++ ++ testX "sum2d" ++ B.sum2_a O.sum2_a ++ B.sum2 O.sum2 ++ (\f -> f 3 "sum2") ++ ++ testX "sum2e" ++ B.sum2_a O.sum2_a ++ B.sum2 O.sum2 ++ (\f -> f 4 "sum2") ++ ++ + +testX :: (Eq a, Show a) + => String -> (p -> t) -> (p -> t) -> p -> p -> (t -> a) -> IO () +testX msg a1 a2 b1 b2 ap = + let (r:rs) = [ap (f g) | f <- [a1,a2], g <- [b1,b2]] + in putStrLn (msg ++ " " ++ (show $ all (==r) rs) ++ " " ++ show r) -+ -+#include "Common.hs-incl" diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.stdout b/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.stdout new file mode 100644 -index 0000000000..30acb50b07 +index 0000000000..82619b86fc --- /dev/null +++ b/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.stdout -@@ -0,0 +1,7 @@ +@@ -0,0 +1,43 @@ ++("x",1) ++tuple1 True 90053 ++tuple1_b ++tuple1_b ++tuple1_b ++tuple1_b +tuple2p True (1234,1235,1236,1237) +tuple2n True (7654,7653,7652,7651) +tuple3 True (1000,1001,1002,1003,1004,1005,1006,1007,1008,1009,1010,1011) @@ -1529,11 +7809,49 @@ index 0000000000..30acb50b07 +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)) +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)) +tuple5 True ((4000,4001,4002,4003),(4004,4005,4006,4007),(4008,4009,4010,4011),(4012,4013,4014,4015)) ++tuple6 True "(6006,(6006,(6006,())))" ++tuplev1 True True ++tuplev2 True True ++tuplev3 True 30001 ++tuplev4 True 40001 ++tuplev5 True 50001 ++tuplev6 True (601,602.0,603,604.0) ++(991,991,991,991,991,991,991,991,991,991,991,991) ++(992,992,992,992,992,992,992,992,992,992,992,992) ++(993,993,993,993,993,993,993,993,993,993,993,993) ++(994,994,994,994,994,994,994,994,994,994,994,994) ++(995,995,995,995,995,995,995,995,995,995,995,995) ++(996,996,996,996,996,996,996,996,996,996,996,996) ++(997,997,997,997,997,997,997,997,997,997,997,997) ++(998,998,998,998,998,998,998,998,998,998,998,998) ++(981,981,981,981,981,981,981,981,981,981,981,981) ++(982,982,982,982,982,982,982,982,982,982,982,982) ++(983,983,983,983,983,983,983,983,983,983,983,983) ++(984,984,984,984,984,984,984,984,984,984,984,984) ++(985,985,985,985,985,985,985,985,985,985,985,985) ++(986,986,986,986,986,986,986,986,986,986,986,986) ++(987,987,987,987,987,987,987,987,987,987,987,987) ++(988,988,988,988,988,988,988,988,988,988,988,988) ++sum1a True Left (1,"23") ++sum1b True Right True ++sum2a True "(\"sum2\",\"sum2\",\"sum2\",\"sum2\")" ++sum2b True "(\"sum2\",\"sum2\")" ++sum2c True "(# #)" ++sum2d True "3" ++sum2e True "4#" diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/unboxedtuples.T b/testsuite/tests/ghci/should_run/UnboxedTuples/unboxedtuples.T new file mode 100644 -index 0000000000..9439257683 +index 0000000000..4166c82f7f --- /dev/null +++ b/testsuite/tests/ghci/should_run/UnboxedTuples/unboxedtuples.T -@@ -0,0 +1,2 @@ -+test('UnboxedTuples', [extra_files(['Obj.hs', 'Common.hs-incl']), -+ only_ways(['ghci'])], compile_and_run, ['']) +@@ -0,0 +1,10 @@ ++test('UnboxedTuples', ++ [ extra_files(['Obj.hs', 'ByteCode.hs', 'Common.hs-incl']), ++ req_interp, ++ extra_ways(['ghci']), ++ when(config.have_ext_interp, extra_ways(['ghci', 'ghci-ext'])), ++ when(config.have_ext_interp and config.have_profiling, extra_ways(['ghci', 'ghci-ext', 'ghci-ext-prof'])) ++ ], ++ compile_and_run, ++ [''] ++ )