From cf739945b8b28ff463dc44925348f20b3c1f22cb Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Sun, 26 Jan 2020 03:15:37 +0100 Subject: Module hierarchy: HsToCore (cf #13009) --- compiler/GHC/Hs/Binds.hs | 2 +- compiler/GHC/Hs/Decls.hs | 8 +- compiler/GHC/Hs/Expr.hs | 6 +- compiler/GHC/Hs/Lit.hs | 2 +- compiler/GHC/Hs/Pat.hs | 2 +- compiler/GHC/Hs/Utils.hs | 12 +- compiler/GHC/HsToCore.hs | 545 ++++ compiler/GHC/HsToCore/Arrows.hs | 1270 +++++++++ compiler/GHC/HsToCore/Binds.hs | 1327 +++++++++ compiler/GHC/HsToCore/Binds.hs-boot | 6 + compiler/GHC/HsToCore/Coverage.hs | 1368 +++++++++ compiler/GHC/HsToCore/Docs.hs | 360 +++ compiler/GHC/HsToCore/Expr.hs | 1204 ++++++++ compiler/GHC/HsToCore/Expr.hs-boot | 12 + compiler/GHC/HsToCore/Foreign/Call.hs | 383 +++ compiler/GHC/HsToCore/Foreign/Decl.hs | 820 ++++++ compiler/GHC/HsToCore/GuardedRHSs.hs | 155 + compiler/GHC/HsToCore/ListComp.hs | 676 +++++ compiler/GHC/HsToCore/Match.hs | 1151 ++++++++ compiler/GHC/HsToCore/Match.hs-boot | 36 + compiler/GHC/HsToCore/Match/Constructor.hs | 296 ++ compiler/GHC/HsToCore/Match/Literal.hs | 522 ++++ compiler/GHC/HsToCore/Monad.hs | 598 ++++ compiler/GHC/HsToCore/PmCheck.hs | 18 +- compiler/GHC/HsToCore/PmCheck/Oracle.hs | 2 +- compiler/GHC/HsToCore/Quote.hs | 2958 ++++++++++++++++++++ compiler/GHC/HsToCore/Usage.hs | 375 +++ compiler/GHC/HsToCore/Utils.hs | 1001 +++++++ compiler/GHC/Iface/Ext/Ast.hs | 2 +- compiler/GHC/Iface/Utils.hs | 4 +- compiler/GHC/Rename/Expr.hs | 6 +- compiler/GHC/ThToHs.hs | 9 +- compiler/basicTypes/BasicTypes.hs | 6 +- compiler/basicTypes/DataCon.hs | 3 +- compiler/basicTypes/Id.hs | 2 +- compiler/basicTypes/MkId.hs | 4 +- compiler/basicTypes/NameCache.hs | 4 +- compiler/coreSyn/CoreOpt.hs | 2 +- compiler/coreSyn/CoreSubst.hs | 2 +- compiler/coreSyn/CoreSyn.hs | 2 +- compiler/deSugar/Coverage.hs | 1368 --------- compiler/deSugar/Desugar.hs | 545 ---- compiler/deSugar/DsArrows.hs | 1270 --------- compiler/deSugar/DsBinds.hs | 1325 --------- compiler/deSugar/DsBinds.hs-boot | 6 - compiler/deSugar/DsCCall.hs | 381 --- compiler/deSugar/DsExpr.hs | 1201 -------- compiler/deSugar/DsExpr.hs-boot | 12 - compiler/deSugar/DsForeign.hs | 820 ------ compiler/deSugar/DsGRHSs.hs | 155 - compiler/deSugar/DsListComp.hs | 676 ----- compiler/deSugar/DsMeta.hs | 2958 -------------------- compiler/deSugar/DsMonad.hs | 598 ---- compiler/deSugar/DsUsage.hs | 375 --- compiler/deSugar/DsUtils.hs | 1001 ------- compiler/deSugar/ExtractDocs.hs | 360 --- compiler/deSugar/Match.hs | 1148 -------- compiler/deSugar/Match.hs-boot | 36 - compiler/deSugar/MatchCon.hs | 296 -- compiler/deSugar/MatchLit.hs | 520 ---- compiler/ghc.cabal.in | 35 +- compiler/main/DriverPipeline.hs | 4 +- compiler/main/HscMain.hs | 2 +- compiler/main/HscTypes.hs | 4 +- compiler/prelude/THNames.hs | 4 +- compiler/prelude/TysWiredIn.hs | 2 +- compiler/specialise/Rules.hs | 2 +- compiler/typecheck/TcEvidence.hs | 4 +- compiler/typecheck/TcHoleErrors.hs | 2 +- compiler/typecheck/TcHsSyn.hs | 4 +- compiler/typecheck/TcInstDcls.hs | 2 +- compiler/typecheck/TcMType.hs | 4 +- compiler/typecheck/TcPatSyn.hs | 2 +- compiler/typecheck/TcRnMonad.hs | 2 +- compiler/typecheck/TcSigs.hs | 2 +- compiler/typecheck/TcSplice.hs | 14 +- compiler/typecheck/TcTyClsDecls.hs | 2 +- ghc/GHCi/UI/Info.hs | 2 +- .../template-haskell/Language/Haskell/TH/Syntax.hs | 5 +- 79 files changed, 15162 insertions(+), 15148 deletions(-) create mode 100644 compiler/GHC/HsToCore.hs create mode 100644 compiler/GHC/HsToCore/Arrows.hs create mode 100644 compiler/GHC/HsToCore/Binds.hs create mode 100644 compiler/GHC/HsToCore/Binds.hs-boot create mode 100644 compiler/GHC/HsToCore/Coverage.hs create mode 100644 compiler/GHC/HsToCore/Docs.hs create mode 100644 compiler/GHC/HsToCore/Expr.hs create mode 100644 compiler/GHC/HsToCore/Expr.hs-boot create mode 100644 compiler/GHC/HsToCore/Foreign/Call.hs create mode 100644 compiler/GHC/HsToCore/Foreign/Decl.hs create mode 100644 compiler/GHC/HsToCore/GuardedRHSs.hs create mode 100644 compiler/GHC/HsToCore/ListComp.hs create mode 100644 compiler/GHC/HsToCore/Match.hs create mode 100644 compiler/GHC/HsToCore/Match.hs-boot create mode 100644 compiler/GHC/HsToCore/Match/Constructor.hs create mode 100644 compiler/GHC/HsToCore/Match/Literal.hs create mode 100644 compiler/GHC/HsToCore/Monad.hs create mode 100644 compiler/GHC/HsToCore/Quote.hs create mode 100644 compiler/GHC/HsToCore/Usage.hs create mode 100644 compiler/GHC/HsToCore/Utils.hs delete mode 100644 compiler/deSugar/Coverage.hs delete mode 100644 compiler/deSugar/Desugar.hs delete mode 100644 compiler/deSugar/DsArrows.hs delete mode 100644 compiler/deSugar/DsBinds.hs delete mode 100644 compiler/deSugar/DsBinds.hs-boot delete mode 100644 compiler/deSugar/DsCCall.hs delete mode 100644 compiler/deSugar/DsExpr.hs delete mode 100644 compiler/deSugar/DsExpr.hs-boot delete mode 100644 compiler/deSugar/DsForeign.hs delete mode 100644 compiler/deSugar/DsGRHSs.hs delete mode 100644 compiler/deSugar/DsListComp.hs delete mode 100644 compiler/deSugar/DsMeta.hs delete mode 100644 compiler/deSugar/DsMonad.hs delete mode 100644 compiler/deSugar/DsUsage.hs delete mode 100644 compiler/deSugar/DsUtils.hs delete mode 100644 compiler/deSugar/ExtractDocs.hs delete mode 100644 compiler/deSugar/Match.hs delete mode 100644 compiler/deSugar/Match.hs-boot delete mode 100644 compiler/deSugar/MatchCon.hs delete mode 100644 compiler/deSugar/MatchLit.hs diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index 1c393bbe99..2014d92c25 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -574,7 +574,7 @@ let-binding. When abs_sig = True and hence the abs_binds is non-recursive (it binds the mono_id but refers to the poly_id -These properties are exploited in DsBinds.dsAbsBinds to +These properties are exploited in GHC.HsToCore.Binds.dsAbsBinds to generate code without a let-binding. Note [ABExport wrapper] diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index abfd0ec476..490113f2eb 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -210,10 +210,10 @@ information from an `HsGroup`. One might wonder why we even bother separating top-level fixity signatures into two places at all. That is, why not just take the fixity signatures from `hs_tyclds` and put them into `hs_fixds` so that they are all in one -location? This ends up causing problems for `DsMeta.repTopDs`, which translates -each fixity signature in `hs_fixds` and `hs_tyclds` into a Template Haskell -`Dec`. If there are any duplicate signatures between the two fields, this will -result in an error (#17608). +location? This ends up causing problems for `GHC.HsToCore.Quote.repTopDs`, +which translates each fixity signature in `hs_fixds` and `hs_tyclds` into a +Template Haskell `Dec`. If there are any duplicate signatures between the two +fields, this will result in an error (#17608). -} -- | Haskell Group diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index f70d5c0382..6890484472 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -577,8 +577,8 @@ data RecordUpdTc = RecordUpdTc -- | HsWrap appears only in typechecker output -- Invariant: The contained Expr is *NOT* itself an HsWrap. --- See Note [Detecting forced eta expansion] in DsExpr. This invariant --- is maintained by GHC.Hs.Utils.mkHsWrap. +-- See Note [Detecting forced eta expansion] in GHC.HsToCore.Expr. +-- This invariant is maintained by GHC.Hs.Utils.mkHsWrap. -- hs_syn is something like HsExpr or HsCmd data HsWrap hs_syn = HsWrap HsWrapper -- the wrapper (hs_syn GhcTc) -- the thing that is wrapped @@ -2693,7 +2693,7 @@ data HsMatchContext p -- (Just b) | Just _ <- x = e -- | otherwise = e' - | RecUpd -- ^Record update [used only in DsExpr to + | RecUpd -- ^Record update [used only in GHC.HsToCore.Expr to -- tell matchWrapper what sort of -- runtime error message to generate] diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs index a023755ffc..dac9f4de93 100644 --- a/compiler/GHC/Hs/Lit.hs +++ b/compiler/GHC/Hs/Lit.hs @@ -199,7 +199,7 @@ found to have. -} -- Comparison operations are needed when grouping literals --- for compiling pattern-matching (module MatchLit) +-- for compiling pattern-matching (module GHC.HsToCore.Match.Literal) instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2 (XOverLit val1) == (XOverLit val2) = val1 == val2 diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index 0a5bcb81d5..50db04e92e 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -425,7 +425,7 @@ data HsRecField' id arg = HsRecField { -- -- The renamer produces an Unambiguous result if it can, rather than -- just doing the lookup in the typechecker, so that completely --- unambiguous updates can be represented by 'DsMeta.repUpdFields'. +-- unambiguous updates can be represented by 'GHC.HsToCore.Quote.repUpdFields'. -- -- For example, suppose we have: -- diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 6cb8a7bda2..3864164263 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -759,7 +759,7 @@ mkLHsWrap :: HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) -- | Avoid @'HsWrap' co1 ('HsWrap' co2 _)@ and @'HsWrap' co1 ('HsPar' _ _)@ --- See Note [Detecting forced eta expansion] in "DsExpr" +-- See Note [Detecting forced eta expansion] in "GHC.HsToCore.Expr" mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc mkHsWrap co_fn e | isIdHsWrapper co_fn = e mkHsWrap co_fn (XExpr (HsWrap co_fn' e)) = mkHsWrap (co_fn <.> co_fn') e @@ -935,7 +935,7 @@ BUT we have a special case when abs_sig is true; -- | Should we treat this as an unlifted bind? This will be true for any -- bind that binds an unlifted variable, but we must be careful around -- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage --- information, see Note [Strict binds check] is DsBinds. +-- information, see Note [Strict binds check] is GHC.HsToCore.Binds. isUnliftedHsBind :: HsBind GhcTc -> Bool -- works only over typechecked binds isUnliftedHsBind bind | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind @@ -1103,17 +1103,17 @@ collect_lpat p bndrs go (XPat {}) = bndrs {- -Note [Dictionary binders in ConPatOut] See also same Note in DsArrows +Note [Dictionary binders in ConPatOut] See also same Note in GHC.HsToCore.Arrows ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Do *not* gather (a) dictionary and (b) dictionary bindings as binders of a ConPatOut pattern. For most calls it doesn't matter, because it's pre-typechecker and there are no ConPatOuts. But it does matter -more in the desugarer; for example, DsUtils.mkSelectorBinds uses +more in the desugarer; for example, GHC.HsToCore.Utils.mkSelectorBinds uses collectPatBinders. In a lazy pattern, for example f ~(C x y) = ..., we want to generate bindings for x,y but not for dictionaries bound by C. (The type checker ensures they would not be used.) -Desugaring of arrow case expressions needs these bindings (see DsArrows +Desugaring of arrow case expressions needs these bindings (see GHC.HsToCore.Arrows and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its own pat-binder-collector: @@ -1127,7 +1127,7 @@ f ~(C (n+1) m) = (n,m) Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a), and *also* uses that dictionary to match the (n+1) pattern. Yet, the variables bound by the lazy pattern are n,m, *not* the dictionary d. -So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound. +So in mkSelectorBinds in GHC.HsToCore.Utils, we want just m,n as the variables bound. -} hsGroupBinders :: HsGroup GhcRn -> [Name] diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs new file mode 100644 index 0000000000..6802319be2 --- /dev/null +++ b/compiler/GHC/HsToCore.hs @@ -0,0 +1,545 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +The Desugarer: turning HsSyn into Core. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.HsToCore ( + -- * Desugaring operations + deSugar, deSugarExpr + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.HsToCore.Usage +import DynFlags +import HscTypes +import GHC.Hs +import TcRnTypes +import TcRnMonad ( finalSafeMode, fixSafeInstances ) +import TcRnDriver ( runTcInteractive ) +import Id +import Name +import Type +import Avail +import CoreSyn +import CoreFVs ( exprsSomeFreeVarsList ) +import CoreOpt ( simpleOptPgm, simpleOptExpr ) +import PprCore +import GHC.HsToCore.Monad +import GHC.HsToCore.Expr +import GHC.HsToCore.Binds +import GHC.HsToCore.Foreign.Decl +import PrelNames ( coercibleTyConKey ) +import TysPrim ( eqReprPrimTyCon ) +import Unique ( hasKey ) +import Coercion ( mkCoVarCo ) +import TysWiredIn ( coercibleDataCon ) +import DataCon ( dataConWrapId ) +import MkCore ( mkCoreLet ) +import Module +import NameSet +import NameEnv +import Rules +import BasicTypes ( Activation(.. ), competesWith, pprRuleName ) +import CoreMonad ( CoreToDo(..) ) +import CoreLint ( endPassIO ) +import VarSet +import FastString +import ErrUtils +import Outputable +import SrcLoc +import GHC.HsToCore.Coverage +import Util +import MonadUtils +import OrdList +import GHC.HsToCore.Docs + +import Data.List +import Data.IORef +import Control.Monad( when ) +import Plugins ( LoadedPlugin(..) ) + +{- +************************************************************************ +* * +* The main function: deSugar +* * +************************************************************************ +-} + +-- | Main entry point to the desugarer. +deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts) +-- Can modify PCS by faulting in more declarations + +deSugar hsc_env + mod_loc + tcg_env@(TcGblEnv { tcg_mod = id_mod, + tcg_semantic_mod = mod, + tcg_src = hsc_src, + tcg_type_env = type_env, + tcg_imports = imports, + tcg_exports = exports, + tcg_keep = keep_var, + tcg_th_splice_used = tc_splice_used, + tcg_rdr_env = rdr_env, + tcg_fix_env = fix_env, + tcg_inst_env = inst_env, + tcg_fam_inst_env = fam_inst_env, + tcg_merged = merged, + tcg_warns = warns, + tcg_anns = anns, + tcg_binds = binds, + tcg_imp_specs = imp_specs, + tcg_dependent_files = dependent_files, + tcg_ev_binds = ev_binds, + tcg_th_foreign_files = th_foreign_files_var, + tcg_fords = fords, + tcg_rules = rules, + tcg_patsyns = patsyns, + tcg_tcs = tcs, + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_hpc = other_hpc_info, + tcg_complete_matches = complete_matches + }) + + = do { let dflags = hsc_dflags hsc_env + print_unqual = mkPrintUnqualified dflags rdr_env + ; withTiming dflags + (text "Desugar"<+>brackets (ppr mod)) + (const ()) $ + do { -- Desugar the program + ; let export_set = availsToNameSet exports + target = hscTarget dflags + hpcInfo = emptyHpcInfo other_hpc_info + + ; (binds_cvr, ds_hpc_info, modBreaks) + <- if not (isHsBootOrSig hsc_src) + then addTicksToBinds hsc_env mod mod_loc + export_set (typeEnvTyCons type_env) binds + else return (binds, hpcInfo, Nothing) + ; (msgs, mb_res) <- initDs hsc_env tcg_env $ + do { ds_ev_binds <- dsEvBinds ev_binds + ; core_prs <- dsTopLHsBinds binds_cvr + ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs + ; (ds_fords, foreign_prs) <- dsForeigns fords + ; ds_rules <- mapMaybeM dsRule rules + ; let hpc_init + | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info + | otherwise = empty + ; return ( ds_ev_binds + , foreign_prs `appOL` core_prs `appOL` spec_prs + , spec_rules ++ ds_rules + , ds_fords `appendStubC` hpc_init) } + + ; case mb_res of { + Nothing -> return (msgs, Nothing) ; + Just (ds_ev_binds, all_prs, all_rules, ds_fords) -> + + do { -- Add export flags to bindings + keep_alive <- readIORef keep_var + ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules + final_prs = addExportFlagsAndRules target export_set keep_alive + rules_for_locals (fromOL all_prs) + + final_pgm = combineEvBinds ds_ev_binds final_prs + -- Notice that we put the whole lot in a big Rec, even the foreign binds + -- When compiling PrelFloat, which defines data Float = F# Float# + -- we want F# to be in scope in the foreign marshalling code! + -- You might think it doesn't matter, but the simplifier brings all top-level + -- things into the in-scope set before simplifying; so we get no unfolding for F#! + + ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps + ; (ds_binds, ds_rules_for_imps) + <- simpleOptPgm dflags mod final_pgm rules_for_imps + -- The simpleOptPgm gets rid of type + -- bindings plus any stupid dead code + + ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps + + ; let used_names = mkUsedNames tcg_env + pluginModules = + map lpModule (cachedPlugins (hsc_dflags hsc_env)) + ; deps <- mkDependencies (thisInstalledUnitId (hsc_dflags hsc_env)) + (map mi_module pluginModules) tcg_env + + ; used_th <- readIORef tc_splice_used + ; dep_files <- readIORef dependent_files + ; safe_mode <- finalSafeMode dflags tcg_env + ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names + dep_files merged pluginModules + -- id_mod /= mod when we are processing an hsig, but hsigs + -- never desugared and compiled (there's no code!) + -- Consequently, this should hold for any ModGuts that make + -- past desugaring. See Note [Identity versus semantic module]. + ; MASSERT( id_mod == mod ) + + ; foreign_files <- readIORef th_foreign_files_var + + ; let (doc_hdr, decl_docs, arg_docs) = extractDocs tcg_env + + ; let mod_guts = ModGuts { + mg_module = mod, + mg_hsc_src = hsc_src, + mg_loc = mkFileSrcSpan mod_loc, + mg_exports = exports, + mg_usages = usages, + mg_deps = deps, + mg_used_th = used_th, + mg_rdr_env = rdr_env, + mg_fix_env = fix_env, + mg_warns = warns, + mg_anns = anns, + mg_tcs = tcs, + mg_insts = fixSafeInstances safe_mode insts, + mg_fam_insts = fam_insts, + mg_inst_env = inst_env, + mg_fam_inst_env = fam_inst_env, + mg_patsyns = patsyns, + mg_rules = ds_rules_for_imps, + mg_binds = ds_binds, + mg_foreign = ds_fords, + mg_foreign_files = foreign_files, + mg_hpc_info = ds_hpc_info, + mg_modBreaks = modBreaks, + mg_safe_haskell = safe_mode, + mg_trust_pkg = imp_trust_own_pkg imports, + mg_complete_sigs = complete_matches, + mg_doc_hdr = doc_hdr, + mg_decl_docs = decl_docs, + mg_arg_docs = arg_docs + } + ; return (msgs, Just mod_guts) + }}}} + +mkFileSrcSpan :: ModLocation -> SrcSpan +mkFileSrcSpan mod_loc + = case ml_hs_file mod_loc of + Just file_path -> mkGeneralSrcSpan (mkFastString file_path) + Nothing -> interactiveSrcSpan -- Presumably + +dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule]) +dsImpSpecs imp_specs + = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs + ; let (spec_binds, spec_rules) = unzip spec_prs + ; return (concatOL spec_binds, spec_rules) } + +combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind] +-- Top-level bindings can include coercion bindings, but not via superclasses +-- See Note [Top-level evidence] +combineEvBinds [] val_prs + = [Rec val_prs] +combineEvBinds (NonRec b r : bs) val_prs + | isId b = combineEvBinds bs ((b,r):val_prs) + | otherwise = NonRec b r : combineEvBinds bs val_prs +combineEvBinds (Rec prs : bs) val_prs + = combineEvBinds bs (prs ++ val_prs) + +{- +Note [Top-level evidence] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Top-level evidence bindings may be mutually recursive with the top-level value +bindings, so we must put those in a Rec. But we can't put them *all* in a Rec +because the occurrence analyser doesn't take account of type/coercion variables +when computing dependencies. + +So we pull out the type/coercion variables (which are in dependency order), +and Rec the rest. +-} + +deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages, Maybe CoreExpr) + +deSugarExpr hsc_env tc_expr = do { + let dflags = hsc_dflags hsc_env + + ; showPass dflags "Desugar" + + -- Do desugaring + ; (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $ + dsLExpr tc_expr + + ; case mb_core_expr of + Nothing -> return () + Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" + FormatCore (pprCoreExpr expr) + + ; return (msgs, mb_core_expr) } + +{- +************************************************************************ +* * +* Add rules and export flags to binders +* * +************************************************************************ +-} + +addExportFlagsAndRules + :: HscTarget -> NameSet -> NameSet -> [CoreRule] + -> [(Id, t)] -> [(Id, t)] +addExportFlagsAndRules target exports keep_alive rules prs + = mapFst add_one prs + where + add_one bndr = add_rules name (add_export name bndr) + where + name = idName bndr + + ---------- Rules -------- + -- See Note [Attach rules to local ids] + -- NB: the binder might have some existing rules, + -- arising from specialisation pragmas + add_rules name bndr + | Just rules <- lookupNameEnv rule_base name + = bndr `addIdSpecialisations` rules + | otherwise + = bndr + rule_base = extendRuleBaseList emptyRuleBase rules + + ---------- Export flag -------- + -- See Note [Adding export flags] + add_export name bndr + | dont_discard name = setIdExported bndr + | otherwise = bndr + + dont_discard :: Name -> Bool + dont_discard name = is_exported name + || name `elemNameSet` keep_alive + + -- In interactive mode, we don't want to discard any top-level + -- entities at all (eg. do not inline them away during + -- simplification), and retain them all in the TypeEnv so they are + -- available from the command line. + -- + -- isExternalName separates the user-defined top-level names from those + -- introduced by the type checker. + is_exported :: Name -> Bool + is_exported | targetRetainsAllBindings target = isExternalName + | otherwise = (`elemNameSet` exports) + +{- +Note [Adding export flags] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Set the no-discard flag if either + a) the Id is exported + b) it's mentioned in the RHS of an orphan rule + c) it's in the keep-alive set + +It means that the binding won't be discarded EVEN if the binding +ends up being trivial (v = w) -- the simplifier would usually just +substitute w for v throughout, but we don't apply the substitution to +the rules (maybe we should?), so this substitution would make the rule +bogus. + +You might wonder why exported Ids aren't already marked as such; +it's just because the type checker is rather busy already and +I didn't want to pass in yet another mapping. + +Note [Attach rules to local ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Find the rules for locally-defined Ids; then we can attach them +to the binders in the top-level bindings + +Reason + - It makes the rules easier to look up + - It means that transformation rules and specialisations for + locally defined Ids are handled uniformly + - It keeps alive things that are referred to only from a rule + (the occurrence analyser knows about rules attached to Ids) + - It makes sure that, when we apply a rule, the free vars + of the RHS are more likely to be in scope + - The imported rules are carried in the in-scope set + which is extended on each iteration by the new wave of + local binders; any rules which aren't on the binding will + thereby get dropped + + +************************************************************************ +* * +* Desugaring transformation rules +* * +************************************************************************ +-} + +dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule) +dsRule (L loc (HsRule { rd_name = name + , rd_act = rule_act + , rd_tmvs = vars + , rd_lhs = lhs + , rd_rhs = rhs })) + = putSrcSpanDs loc $ + do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars] + + ; lhs' <- unsetGOptM Opt_EnableRewriteRules $ + unsetWOptM Opt_WarnIdentities $ + dsLExpr lhs -- Note [Desugaring RULE left hand sides] + + ; rhs' <- dsLExpr rhs + ; this_mod <- getModule + + ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs' + + -- Substitute the dict bindings eagerly, + -- and take the body apart into a (f args) form + ; dflags <- getDynFlags + ; case decomposeRuleLhs dflags bndrs'' lhs'' of { + Left msg -> do { warnDs NoReason msg; return Nothing } ; + Right (final_bndrs, fn_id, args) -> do + + { let is_local = isLocalId fn_id + -- NB: isLocalId is False of implicit Ids. This is good because + -- we don't want to attach rules to the bindings of implicit Ids, + -- because they don't show up in the bindings until just before code gen + fn_name = idName fn_id + final_rhs = simpleOptExpr dflags rhs'' -- De-crap it + rule_name = snd (unLoc name) + final_bndrs_set = mkVarSet final_bndrs + arg_ids = filterOut (`elemVarSet` final_bndrs_set) $ + exprsSomeFreeVarsList isId args + + ; rule <- dsMkUserRule this_mod is_local + rule_name rule_act fn_name final_bndrs args + final_rhs + ; when (wopt Opt_WarnInlineRuleShadowing dflags) $ + warnRuleShadowing rule_name rule_act fn_id arg_ids + + ; return (Just rule) + } } } +dsRule (L _ (XRuleDecl nec)) = noExtCon nec + +warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM () +-- See Note [Rules and inlining/other rules] +warnRuleShadowing rule_name rule_act fn_id arg_ids + = do { check False fn_id -- We often have multiple rules for the same Id in a + -- module. Maybe we should check that they don't overlap + -- but currently we don't + ; mapM_ (check True) arg_ids } + where + check check_rules_too lhs_id + | isLocalId lhs_id || canUnfold (idUnfolding lhs_id) + -- If imported with no unfolding, no worries + , idInlineActivation lhs_id `competesWith` rule_act + = warnDs (Reason Opt_WarnInlineRuleShadowing) + (vcat [ hang (text "Rule" <+> pprRuleName rule_name + <+> text "may never fire") + 2 (text "because" <+> quotes (ppr lhs_id) + <+> text "might inline first") + , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for" + <+> quotes (ppr lhs_id) + , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ]) + + | check_rules_too + , bad_rule : _ <- get_bad_rules lhs_id + = warnDs (Reason Opt_WarnInlineRuleShadowing) + (vcat [ hang (text "Rule" <+> pprRuleName rule_name + <+> text "may never fire") + 2 (text "because rule" <+> pprRuleName (ruleName bad_rule) + <+> text "for"<+> quotes (ppr lhs_id) + <+> text "might fire first") + , text "Probable fix: add phase [n] or [~n] to the competing rule" + , whenPprDebug (ppr bad_rule) ]) + + | otherwise + = return () + + get_bad_rules lhs_id + = [ rule | rule <- idCoreRules lhs_id + , ruleActivation rule `competesWith` rule_act ] + +-- See Note [Desugaring coerce as cast] +unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr) +unfold_coerce bndrs lhs rhs = do + (bndrs', wrap) <- go bndrs + return (bndrs', wrap lhs, wrap rhs) + where + go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr) + go [] = return ([], id) + go (v:vs) + | Just (tc, [k, t1, t2]) <- splitTyConApp_maybe (idType v) + , tc `hasKey` coercibleTyConKey = do + u <- newUnique + + let ty' = mkTyConApp eqReprPrimTyCon [k, k, t1, t2] + v' = mkLocalCoVar + (mkDerivedInternalName mkRepEqOcc u (getName v)) ty' + box = Var (dataConWrapId coercibleDataCon) `mkTyApps` + [k, t1, t2] `App` + Coercion (mkCoVarCo v') + + (bndrs, wrap) <- go vs + return (v':bndrs, mkCoreLet (NonRec v box) . wrap) + | otherwise = do + (bndrs,wrap) <- go vs + return (v:bndrs, wrap) + +{- Note [Desugaring RULE left hand sides] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the LHS of a RULE we do *not* want to desugar + [x] to build (\cn. x `c` n) +We want to leave explicit lists simply as chains +of cons's. We can achieve that slightly indirectly by +switching off EnableRewriteRules. See GHC.HsToCore.Expr.dsExplicitList. + +That keeps the desugaring of list comprehensions simple too. + +Nor do we want to warn of conversion identities on the LHS; +the rule is precisely to optimise them: + {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-} + +Note [Desugaring coerce as cast] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want the user to express a rule saying roughly “mapping a coercion over a +list can be replaced by a coercion”. But the cast operator of Core (▷) cannot +be written in Haskell. So we use `coerce` for that (#2110). The user writes + map coerce = coerce +as a RULE, and this optimizes any kind of mapped' casts away, including `map +MkNewtype`. + +For that we replace any forall'ed `c :: Coercible a b` value in a RULE by +corresponding `co :: a ~#R b` and wrap the LHS and the RHS in +`let c = MkCoercible co in ...`. This is later simplified to the desired form +by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS). +See also Note [Getting the map/coerce RULE to work] in CoreSubst. + +Note [Rules and inlining/other rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you have + f x = ... + g x = ... + {-# RULES "rule-for-f" forall x. f (g x) = ... #-} +then there's a good chance that in a potential rule redex + ...f (g e)... +then 'f' or 'g' will inline before the rule can fire. Solution: add an +INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'. + +Note that this applies to all the free variables on the LHS, both the +main function and things in its arguments. + +We also check if there are Ids on the LHS that have competing RULES. +In the above example, suppose we had + {-# RULES "rule-for-g" forally. g [y] = ... #-} +Then "rule-for-f" and "rule-for-g" would compete. Better to add phase +control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes +active; or perhaps after "rule-for-g" has become inactive. This is checked +by 'competesWith' + +Class methods have a built-in RULE to select the method from the dictionary, +so you can't change the phase on this. That makes id very dubious to +match on class methods in RULE lhs's. See #10595. I'm not happy +about this. For example in Control.Arrow we have + +{-# RULES "compose/arr" forall f g . + (arr f) . (arr g) = arr (f . g) #-} + +and similar, which will elicit exactly these warnings, and risk never +firing. But it's not clear what to do instead. We could make the +class method rules inactive in phase 2, but that would delay when +subsequent transformations could fire. +-} diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs new file mode 100644 index 0000000000..450c879b90 --- /dev/null +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -0,0 +1,1270 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Desugaring arrow commands +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.HsToCore.Arrows ( dsProcExpr ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.HsToCore.Match +import GHC.HsToCore.Utils +import GHC.HsToCore.Monad + +import GHC.Hs hiding (collectPatBinders, collectPatsBinders, + collectLStmtsBinders, collectLStmtBinders, + collectStmtBinders ) +import TcHsSyn +import qualified GHC.Hs.Utils as HsUtils + +-- NB: The desugarer, which straddles the source and Core worlds, sometimes +-- needs to see source types (newtypes etc), and sometimes not +-- So WATCH OUT; check each use of split*Ty functions. +-- Sigh. This is a pain. + +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, + dsSyntaxExpr ) + +import TcType +import Type ( splitPiTy ) +import TcEvidence +import CoreSyn +import CoreFVs +import CoreUtils +import MkCore +import GHC.HsToCore.Binds (dsHsWrapper) + +import Id +import ConLike +import TysWiredIn +import BasicTypes +import PrelNames +import Outputable +import VarSet +import SrcLoc +import ListSetOps( assocMaybe ) +import Data.List +import Util +import UniqDSet + +data DsCmdEnv = DsCmdEnv { + arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr + } + +mkCmdEnv :: CmdSyntaxTable GhcTc -> DsM ([CoreBind], DsCmdEnv) +-- See Note [CmdSyntaxTable] in GHC.Hs.Expr +mkCmdEnv tc_meths + = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths + + -- NB: Some of these lookups might fail, but that's OK if the + -- symbol is never used. That's why we use Maybe first and then + -- panic. An eager panic caused trouble in typecheck/should_compile/tc192 + ; let the_arr_id = assocMaybe prs arrAName + the_compose_id = assocMaybe prs composeAName + the_first_id = assocMaybe prs firstAName + the_app_id = assocMaybe prs appAName + the_choice_id = assocMaybe prs choiceAName + the_loop_id = assocMaybe prs loopAName + + -- used as an argument in, e.g., do_premap + ; check_lev_poly 3 the_arr_id + + -- used as an argument in, e.g., dsCmdStmt/BodyStmt + ; check_lev_poly 5 the_compose_id + + -- used as an argument in, e.g., dsCmdStmt/BodyStmt + ; check_lev_poly 4 the_first_id + + -- the result of the_app_id is used as an argument in, e.g., + -- dsCmd/HsCmdArrApp/HsHigherOrderApp + ; check_lev_poly 2 the_app_id + + -- used as an argument in, e.g., HsCmdIf + ; check_lev_poly 5 the_choice_id + + -- used as an argument in, e.g., RecStmt + ; check_lev_poly 4 the_loop_id + + ; return (meth_binds, DsCmdEnv { + arr_id = Var (unmaybe the_arr_id arrAName), + compose_id = Var (unmaybe the_compose_id composeAName), + first_id = Var (unmaybe the_first_id firstAName), + app_id = Var (unmaybe the_app_id appAName), + choice_id = Var (unmaybe the_choice_id choiceAName), + loop_id = Var (unmaybe the_loop_id loopAName) + }) } + where + mk_bind (std_name, expr) + = do { rhs <- dsExpr expr + ; id <- newSysLocalDs (exprType rhs) + -- no check needed; these are functions + ; return (NonRec id rhs, (std_name, id)) } + + unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name) + unmaybe (Just id) _ = id + + -- returns the result type of a pi-type (that is, a forall or a function) + -- Note that this result type may be ill-scoped. + res_type :: Type -> Type + res_type ty = res_ty + where + (_, res_ty) = splitPiTy ty + + check_lev_poly :: Int -- arity + -> Maybe Id -> DsM () + check_lev_poly _ Nothing = return () + check_lev_poly arity (Just id) + = dsNoLevPoly (nTimes arity res_type (idType id)) + (text "In the result of the function" <+> quotes (ppr id)) + + +-- arr :: forall b c. (b -> c) -> a b c +do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr +do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f] + +-- (>>>) :: forall b c d. a b c -> a c d -> a b d +do_compose :: DsCmdEnv -> Type -> Type -> Type -> + CoreExpr -> CoreExpr -> CoreExpr +do_compose ids b_ty c_ty d_ty f g + = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g] + +-- first :: forall b c d. a b c -> a (b,d) (c,d) +do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr +do_first ids b_ty c_ty d_ty f + = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f] + +-- app :: forall b c. a (a b c, b) c +do_app :: DsCmdEnv -> Type -> Type -> CoreExpr +do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty] + +-- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d +-- note the swapping of d and c +do_choice :: DsCmdEnv -> Type -> Type -> Type -> + CoreExpr -> CoreExpr -> CoreExpr +do_choice ids b_ty c_ty d_ty f g + = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g] + +-- loop :: forall b d c. a (b,d) (c,d) -> a b c +-- note the swapping of d and c +do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr +do_loop ids b_ty c_ty d_ty f + = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f] + +-- premap :: forall b c d. (b -> c) -> a c d -> a b d +-- premap f g = arr f >>> g +do_premap :: DsCmdEnv -> Type -> Type -> Type -> + CoreExpr -> CoreExpr -> CoreExpr +do_premap ids b_ty c_ty d_ty f g + = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g + +mkFailExpr :: HsMatchContext GhcRn -> Type -> DsM CoreExpr +mkFailExpr ctxt ty + = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt) + +-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a +mkFstExpr :: Type -> Type -> DsM CoreExpr +mkFstExpr a_ty b_ty = do + a_var <- newSysLocalDs a_ty + b_var <- newSysLocalDs b_ty + pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty) + return (Lam pair_var + (coreCasePair pair_var a_var b_var (Var a_var))) + +-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b +mkSndExpr :: Type -> Type -> DsM CoreExpr +mkSndExpr a_ty b_ty = do + a_var <- newSysLocalDs a_ty + b_var <- newSysLocalDs b_ty + pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty) + return (Lam pair_var + (coreCasePair pair_var a_var b_var (Var b_var))) + +{- +Build case analysis of a tuple. This cannot be done in the DsM monad, +because the list of variables is typically not yet defined. +-} + +-- coreCaseTuple [u1..] v [x1..xn] body +-- = case v of v { (x1, .., xn) -> body } +-- But the matching may be nested if the tuple is very big + +coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr +coreCaseTuple uniqs scrut_var vars body + = mkTupleCase uniqs vars body scrut_var (Var scrut_var) + +coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr +coreCasePair scrut_var var1 var2 body + = Case (Var scrut_var) scrut_var (exprType body) + [(DataAlt (tupleDataCon Boxed 2), [var1, var2], body)] + +mkCorePairTy :: Type -> Type -> Type +mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2] + +mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr +mkCorePairExpr e1 e2 = mkCoreTup [e1, e2] + +mkCoreUnitExpr :: CoreExpr +mkCoreUnitExpr = mkCoreTup [] + +{- +The input is divided into a local environment, which is a flat tuple +(unless it's too big), and a stack, which is a right-nested pair. +In general, the input has the form + + ((x1,...,xn), (s1,...(sk,())...)) + +where xi are the environment values, and si the ones on the stack, +with s1 being the "top", the first one to be matched with a lambda. +-} + +envStackType :: [Id] -> Type -> Type +envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty + +-- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t) +splitTypeAt :: Int -> Type -> ([Type], Type) +splitTypeAt n ty + | n == 0 = ([], ty) + | otherwise = case tcTyConAppArgs ty of + [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r) + _ -> pprPanic "splitTypeAt" (ppr ty) + +---------------------------------------------- +-- buildEnvStack +-- +-- ((x1,...,xn),stk) + +buildEnvStack :: [Id] -> Id -> CoreExpr +buildEnvStack env_ids stack_id + = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id) + +---------------------------------------------- +-- matchEnvStack +-- +-- \ ((x1,...,xn),stk) -> body +-- => +-- \ pair -> +-- case pair of (tup,stk) -> +-- case tup of (x1,...,xn) -> +-- body + +matchEnvStack :: [Id] -- x1..xn + -> Id -- stk + -> CoreExpr -- e + -> DsM CoreExpr +matchEnvStack env_ids stack_id body = do + uniqs <- newUniqueSupply + tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids) + let match_env = coreCaseTuple uniqs tup_var env_ids body + pair_id <- newSysLocalDs (mkCorePairTy (idType tup_var) (idType stack_id)) + return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env)) + +---------------------------------------------- +-- matchEnv +-- +-- \ (x1,...,xn) -> body +-- => +-- \ tup -> +-- case tup of (x1,...,xn) -> +-- body + +matchEnv :: [Id] -- x1..xn + -> CoreExpr -- e + -> DsM CoreExpr +matchEnv env_ids body = do + uniqs <- newUniqueSupply + tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids) + return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body)) + +---------------------------------------------- +-- matchVarStack +-- +-- case (x1, ...(xn, s)...) -> e +-- => +-- case z0 of (x1,z1) -> +-- case zn-1 of (xn,s) -> +-- e +matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr) +matchVarStack [] stack_id body = return (stack_id, body) +matchVarStack (param_id:param_ids) stack_id body = do + (tail_id, tail_code) <- matchVarStack param_ids stack_id body + pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id)) + return (pair_id, coreCasePair pair_id param_id tail_id tail_code) + +mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc +mkHsEnvStackExpr env_ids stack_id + = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id] + +-- Translation of arrow abstraction + +-- D; xs |-a c : () --> t' ---> c' +-- -------------------------- +-- D |- proc p -> c :: a t t' ---> premap (\ p -> ((xs),())) c' +-- +-- where (xs) is the tuple of variables bound by p + +dsProcExpr + :: LPat GhcTc + -> LHsCmdTop GhcTc + -> DsM CoreExpr +dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do + (meth_binds, meth_ids) <- mkCmdEnv ids + let locals = mkVarSet (collectPatBinders pat) + (core_cmd, _free_vars, env_ids) + <- dsfixCmd meth_ids locals unitTy cmd_ty cmd + let env_ty = mkBigCoreVarTupTy env_ids + let env_stk_ty = mkCorePairTy env_ty unitTy + let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr + fail_expr <- mkFailExpr ProcExpr env_stk_ty + var <- selectSimpleMatchVarL pat + match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr + let pat_ty = hsLPatType pat + let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty + (Lam var match_code) + core_cmd + return (mkLets meth_binds proc_code) +dsProcExpr _ _ = panic "dsProcExpr" + +{- +Translation of a command judgement of the form + + D; xs |-a c : stk --> t + +to an expression e such that + + D |- e :: a (xs, stk) t +-} + +dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd GhcTc -> [Id] + -> DsM (CoreExpr, DIdSet) +dsLCmd ids local_vars stk_ty res_ty cmd env_ids + = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids + +dsCmd :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this command + -> Type -- type of the stack (right-nested tuple) + -> Type -- return type of the command + -> HsCmd GhcTc -- command to desugar + -> [Id] -- list of vars in the input to this command + -- This is typically fed back, + -- so don't pull on it too early + -> DsM (CoreExpr, -- desugared expression + DIdSet) -- subset of local vars that occur free + +-- D |- fun :: a t1 t2 +-- D, xs |- arg :: t1 +-- ----------------------------- +-- D; xs |-a fun -< arg : stk --> t2 +-- +-- ---> premap (\ ((xs), _stk) -> arg) fun + +dsCmd ids local_vars stack_ty res_ty + (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _) + env_ids = do + let + (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty + (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty + core_arrow <- dsLExprNoLP arrow + core_arg <- dsLExpr arg + stack_id <- newSysLocalDs stack_ty + core_make_arg <- matchEnvStack env_ids stack_id core_arg + return (do_premap ids + (envStackType env_ids stack_ty) + arg_ty + res_ty + core_make_arg + core_arrow, + exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars) + +-- D, xs |- fun :: a t1 t2 +-- D, xs |- arg :: t1 +-- ------------------------------ +-- D; xs |-a fun -<< arg : stk --> t2 +-- +-- ---> premap (\ ((xs), _stk) -> (fun, arg)) app + +dsCmd ids local_vars stack_ty res_ty + (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _) + env_ids = do + let + (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty + (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty + + core_arrow <- dsLExpr arrow + core_arg <- dsLExpr arg + stack_id <- newSysLocalDs stack_ty + core_make_pair <- matchEnvStack env_ids stack_id + (mkCorePairExpr core_arrow core_arg) + + return (do_premap ids + (envStackType env_ids stack_ty) + (mkCorePairTy arrow_ty arg_ty) + res_ty + core_make_pair + (do_app ids arg_ty res_ty), + (exprsFreeIdsDSet [core_arrow, core_arg]) + `uniqDSetIntersectUniqSet` local_vars) + +-- D; ys |-a cmd : (t,stk) --> t' +-- D, xs |- exp :: t +-- ------------------------ +-- D; xs |-a cmd exp : stk --> t' +-- +-- ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd + +dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do + core_arg <- dsLExpr arg + let + arg_ty = exprType core_arg + stack_ty' = mkCorePairTy arg_ty stack_ty + (core_cmd, free_vars, env_ids') + <- dsfixCmd ids local_vars stack_ty' res_ty cmd + stack_id <- newSysLocalDs stack_ty + arg_id <- newSysLocalDsNoLP arg_ty + -- push the argument expression onto the stack + let + stack' = mkCorePairExpr (Var arg_id) (Var stack_id) + core_body = bindNonRec arg_id core_arg + (mkCorePairExpr (mkBigCoreVarTup env_ids') stack') + + -- match the environment and stack against the input + core_map <- matchEnvStack env_ids stack_id core_body + return (do_premap ids + (envStackType env_ids stack_ty) + (envStackType env_ids' stack_ty') + res_ty + core_map + core_cmd, + free_vars `unionDVarSet` + (exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars)) + +-- D; ys |-a cmd : stk t' +-- ----------------------------------------------- +-- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t' +-- +-- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd + +dsCmd ids local_vars stack_ty res_ty + (HsCmdLam _ (MG { mg_alts + = (L _ [L _ (Match { m_pats = pats + , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })]) })) + env_ids = do + let pat_vars = mkVarSet (collectPatsBinders pats) + let + local_vars' = pat_vars `unionVarSet` local_vars + (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty + (core_body, free_vars, env_ids') + <- dsfixCmd ids local_vars' stack_ty' res_ty body + param_ids <- mapM newSysLocalDsNoLP pat_tys + stack_id' <- newSysLocalDs stack_ty' + + -- the expression is built from the inside out, so the actions + -- are presented in reverse order + + let + -- build a new environment, plus what's left of the stack + core_expr = buildEnvStack env_ids' stack_id' + in_ty = envStackType env_ids stack_ty + in_ty' = envStackType env_ids' stack_ty' + + fail_expr <- mkFailExpr LambdaExpr in_ty' + -- match the patterns against the parameters + match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr + fail_expr + -- match the parameters against the top of the old stack + (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code + -- match the old environment and stack against the input + select_code <- matchEnvStack env_ids stack_id param_code + return (do_premap ids in_ty in_ty' res_ty select_code core_body, + free_vars `uniqDSetMinusUniqSet` pat_vars) + +dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids + = dsLCmd ids local_vars stack_ty res_ty cmd env_ids + +-- D, xs |- e :: Bool +-- D; xs1 |-a c1 : stk --> t +-- D; xs2 |-a c2 : stk --> t +-- ---------------------------------------- +-- D; xs |-a if e then c1 else c2 : stk --> t +-- +-- ---> premap (\ ((xs),stk) -> +-- if e then Left ((xs1),stk) else Right ((xs2),stk)) +-- (c1 ||| c2) + +dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd) + env_ids = do + core_cond <- dsLExpr cond + (core_then, fvs_then, then_ids) + <- dsfixCmd ids local_vars stack_ty res_ty then_cmd + (core_else, fvs_else, else_ids) + <- dsfixCmd ids local_vars stack_ty res_ty else_cmd + stack_id <- newSysLocalDs stack_ty + either_con <- dsLookupTyCon eitherTyConName + left_con <- dsLookupDataCon leftDataConName + right_con <- dsLookupDataCon rightDataConName + + let mk_left_expr ty1 ty2 e = mkCoreConApps left_con [Type ty1,Type ty2, e] + mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1,Type ty2, e] + + in_ty = envStackType env_ids stack_ty + then_ty = envStackType then_ids stack_ty + else_ty = envStackType else_ids stack_ty + sum_ty = mkTyConApp either_con [then_ty, else_ty] + fvs_cond = exprFreeIdsDSet core_cond + `uniqDSetIntersectUniqSet` local_vars + + core_left = mk_left_expr then_ty else_ty + (buildEnvStack then_ids stack_id) + core_right = mk_right_expr then_ty else_ty + (buildEnvStack else_ids stack_id) + + core_if <- case mb_fun of + NoSyntaxExprTc -> matchEnvStack env_ids stack_id $ + mkIfThenElse core_cond core_left core_right + _ -> do { fun_apps <- dsSyntaxExpr mb_fun + [core_cond, core_left, core_right] + ; matchEnvStack env_ids stack_id fun_apps } + + return (do_premap ids in_ty sum_ty res_ty + core_if + (do_choice ids then_ty else_ty res_ty core_then core_else), + fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else) + +{- +Case commands are treated in much the same way as if commands +(see above) except that there are more alternatives. For example + + case e of { p1 -> c1; p2 -> c2; p3 -> c3 } + +is translated to + + premap (\ ((xs)*ts) -> case e of + p1 -> (Left (Left (xs1)*ts)) + p2 -> Left ((Right (xs2)*ts)) + p3 -> Right ((xs3)*ts)) + ((c1 ||| c2) ||| c3) + +The idea is to extract the commands from the case, build a balanced tree +of choices, and replace the commands with expressions that build tagged +tuples, obtaining a case expression that can be desugared normally. +To build all this, we use triples describing segments of the list of +case bodies, containing the following fields: + * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put + into the case replacing the commands + * a sum type that is the common type of these expressions, and also the + input type of the arrow + * a CoreExpr for an arrow built by combining the translated command + bodies with |||. +-} + +dsCmd ids local_vars stack_ty res_ty + (HsCmdCase _ exp (MG { mg_alts = L l matches + , mg_ext = MatchGroupTc arg_tys _ + , mg_origin = origin })) + env_ids = do + stack_id <- newSysLocalDs stack_ty + + -- Extract and desugar the leaf commands in the case, building tuple + -- expressions that will (after tagging) replace these leaves + + let + leaves = concatMap leavesMatch matches + make_branch (leaf, bound_vars) = do + (core_leaf, _fvs, leaf_ids) + <- dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty + res_ty leaf + return ([mkHsEnvStackExpr leaf_ids stack_id], + envStackType leaf_ids stack_ty, + core_leaf) + + branches <- mapM make_branch leaves + either_con <- dsLookupTyCon eitherTyConName + left_con <- dsLookupDataCon leftDataConName + right_con <- dsLookupDataCon rightDataConName + let + left_id = HsConLikeOut noExtField (RealDataCon left_con) + right_id = HsConLikeOut noExtField (RealDataCon right_con) + left_expr ty1 ty2 e = noLoc $ HsApp noExtField + (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e + right_expr ty1 ty2 e = noLoc $ HsApp noExtField + (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e + + -- Prefix each tuple with a distinct series of Left's and Right's, + -- in a balanced way, keeping track of the types. + + merge_branches (builds1, in_ty1, core_exp1) + (builds2, in_ty2, core_exp2) + = (map (left_expr in_ty1 in_ty2) builds1 ++ + map (right_expr in_ty1 in_ty2) builds2, + mkTyConApp either_con [in_ty1, in_ty2], + do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2) + (leaves', sum_ty, core_choices) = foldb merge_branches branches + + -- Replace the commands in the case with these tagged tuples, + -- yielding a HsExpr Id we can feed to dsExpr. + + (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches + in_ty = envStackType env_ids stack_ty + + core_body <- dsExpr (HsCase noExtField exp + (MG { mg_alts = L l matches' + , mg_ext = MatchGroupTc arg_tys sum_ty + , mg_origin = origin })) + -- Note that we replace the HsCase result type by sum_ty, + -- which is the type of matches' + + core_matches <- matchEnvStack env_ids stack_id core_body + return (do_premap ids in_ty sum_ty res_ty core_matches core_choices, + exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars) + +-- D; ys |-a cmd : stk --> t +-- ---------------------------------- +-- D; xs |-a let binds in cmd : stk --> t +-- +-- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c + +dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body) + env_ids = do + let + defined_vars = mkVarSet (collectLocalBinders binds) + local_vars' = defined_vars `unionVarSet` local_vars + + (core_body, _free_vars, env_ids') + <- dsfixCmd ids local_vars' stack_ty res_ty body + stack_id <- newSysLocalDs stack_ty + -- build a new environment, plus the stack, using the let bindings + core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id) + -- match the old environment and stack against the input + core_map <- matchEnvStack env_ids stack_id core_binds + return (do_premap ids + (envStackType env_ids stack_ty) + (envStackType env_ids' stack_ty) + res_ty + core_map + core_body, + exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars) + +-- D; xs |-a ss : t +-- ---------------------------------- +-- D; xs |-a do { ss } : () --> t +-- +-- ---> premap (\ (env,stk) -> env) c + +dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty + (L loc stmts)) + env_ids = do + putSrcSpanDs loc $ + dsNoLevPoly stmts_ty + (text "In the do-command:" <+> ppr do_block) + (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids + let env_ty = mkBigCoreVarTupTy env_ids + core_fst <- mkFstExpr env_ty stack_ty + return (do_premap ids + (mkCorePairTy env_ty stack_ty) + env_ty + res_ty + core_fst + core_stmts, + env_ids') + +-- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t +-- D; xs |-a ci :: stki --> ti +-- ----------------------------------- +-- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn + +dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do + let env_ty = mkBigCoreVarTupTy env_ids + core_op <- dsLExpr op + (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args + return (mkApps (App core_op (Type env_ty)) core_args, + unionDVarSets fv_sets) + +dsCmd ids local_vars stack_ty res_ty (XCmd (HsWrap wrap cmd)) env_ids = do + (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids + core_wrap <- dsHsWrapper wrap + return (core_wrap core_cmd, env_ids') + +dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) + +-- D; ys |-a c : stk --> t (ys <= xs) +-- --------------------- +-- D; xs |-a c : stk --> t ---> premap (\ ((xs),stk) -> ((ys),stk)) c + +dsTrimCmdArg + :: IdSet -- set of local vars available to this command + -> [Id] -- list of vars in the input to this command + -> LHsCmdTop GhcTc -- command argument to desugar + -> DsM (CoreExpr, -- desugared expression + DIdSet) -- subset of local vars that occur free +dsTrimCmdArg local_vars env_ids + (L _ (HsCmdTop + (CmdTopTc stack_ty cmd_ty ids) cmd )) = do + (meth_binds, meth_ids) <- mkCmdEnv ids + (core_cmd, free_vars, env_ids') + <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd + stack_id <- newSysLocalDs stack_ty + trim_code + <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id) + let + in_ty = envStackType env_ids stack_ty + in_ty' = envStackType env_ids' stack_ty + arg_code = if env_ids' == env_ids then core_cmd else + do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd + return (mkLets meth_binds arg_code, free_vars) +dsTrimCmdArg _ _ _ = panic "dsTrimCmdArg" + +-- Given D; xs |-a c : stk --> t, builds c with xs fed back. +-- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk)) + +dsfixCmd + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this command + -> Type -- type of the stack (right-nested tuple) + -> Type -- return type of the command + -> LHsCmd GhcTc -- command to desugar + -> DsM (CoreExpr, -- desugared expression + DIdSet, -- subset of local vars that occur free + [Id]) -- the same local vars as a list, fed back +dsfixCmd ids local_vars stk_ty cmd_ty cmd + = do { putSrcSpanDs (getLoc cmd) $ dsNoLevPoly cmd_ty + (text "When desugaring the command:" <+> ppr cmd) + ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) } + +-- Feed back the list of local variables actually used a command, +-- for use as the input tuple of the generated arrow. + +trimInput + :: ([Id] -> DsM (CoreExpr, DIdSet)) + -> DsM (CoreExpr, -- desugared expression + DIdSet, -- subset of local vars that occur free + [Id]) -- same local vars as a list, fed back to + -- the inner function to form the tuple of + -- inputs to the arrow. +trimInput build_arrow + = fixDs (\ ~(_,_,env_ids) -> do + (core_cmd, free_vars) <- build_arrow env_ids + return (core_cmd, free_vars, dVarSetElems free_vars)) + +{- +Translation of command judgements of the form + + D |-a do { ss } : t +-} + +dsCmdDo :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> Type -- return type of the statement + -> [CmdLStmt GhcTc] -- statements to desugar + -> [Id] -- list of vars in the input to this statement + -- This is typically fed back, + -- so don't pull on it too early + -> DsM (CoreExpr, -- desugared expression + DIdSet) -- subset of local vars that occur free + +dsCmdDo _ _ _ [] _ = panic "dsCmdDo" + +-- D; xs |-a c : () --> t +-- -------------------------- +-- D; xs |-a do { c } : t +-- +-- ---> premap (\ (xs) -> ((xs), ())) c + +dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do + putSrcSpanDs loc $ dsNoLevPoly res_ty + (text "In the command:" <+> ppr body) + (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids + let env_ty = mkBigCoreVarTupTy env_ids + env_var <- newSysLocalDs env_ty + let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr) + return (do_premap ids + env_ty + (mkCorePairTy env_ty unitTy) + res_ty + core_map + core_body, + env_ids') + +dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do + let bound_vars = mkVarSet (collectLStmtBinders stmt) + let local_vars' = bound_vars `unionVarSet` local_vars + (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts) + (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids + return (do_compose ids + (mkBigCoreVarTupTy env_ids) + (mkBigCoreVarTupTy env_ids') + res_ty + core_stmt + core_stmts, + fv_stmt) + +{- +A statement maps one local environment to another, and is represented +as an arrow from one tuple type to another. A statement sequence is +translated to a composition of such arrows. +-} + +dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt GhcTc -> [Id] + -> DsM (CoreExpr, DIdSet) +dsCmdLStmt ids local_vars out_ids cmd env_ids + = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids + +dsCmdStmt + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> [Id] -- list of vars in the output of this statement + -> CmdStmt GhcTc -- statement to desugar + -> [Id] -- list of vars in the input to this statement + -- This is typically fed back, + -- so don't pull on it too early + -> DsM (CoreExpr, -- desugared expression + DIdSet) -- subset of local vars that occur free + +-- D; xs1 |-a c : () --> t +-- D; xs' |-a do { ss } : t' +-- ------------------------------ +-- D; xs |-a do { c; ss } : t' +-- +-- ---> premap (\ ((xs)) -> (((xs1),()),(xs'))) +-- (first c >>> arr snd) >>> ss + +dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do + (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd + core_mux <- matchEnv env_ids + (mkCorePairExpr + (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr) + (mkBigCoreVarTup out_ids)) + let + in_ty = mkBigCoreVarTupTy env_ids + in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy + out_ty = mkBigCoreVarTupTy out_ids + before_c_ty = mkCorePairTy in_ty1 out_ty + after_c_ty = mkCorePairTy c_ty out_ty + dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here + snd_fn <- mkSndExpr c_ty out_ty + return (do_premap ids in_ty before_c_ty out_ty core_mux $ + do_compose ids before_c_ty after_c_ty out_ty + (do_first ids in_ty1 c_ty out_ty core_cmd) $ + do_arr ids after_c_ty out_ty snd_fn, + extendDVarSetList fv_cmd out_ids) + +-- D; xs1 |-a c : () --> t +-- D; xs' |-a do { ss } : t' xs2 = xs' - defs(p) +-- ----------------------------------- +-- D; xs |-a do { p <- c; ss } : t' +-- +-- ---> premap (\ (xs) -> (((xs1),()),(xs2))) +-- (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss +-- +-- It would be simpler and more consistent to do this using second, +-- but that's likely to be defined in terms of first. + +dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do + let pat_ty = hsLPatType pat + (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd + let pat_vars = mkVarSet (collectPatBinders pat) + let + env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids + env_ty2 = mkBigCoreVarTupTy env_ids2 + + -- multiplexing function + -- \ (xs) -> (((xs1),()),(xs2)) + + core_mux <- matchEnv env_ids + (mkCorePairExpr + (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr) + (mkBigCoreVarTup env_ids2)) + + -- projection function + -- \ (p, (xs2)) -> (zs) + + env_id <- newSysLocalDs env_ty2 + uniqs <- newUniqueSupply + let + after_c_ty = mkCorePairTy pat_ty env_ty2 + out_ty = mkBigCoreVarTupTy out_ids + body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids) + + fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty + pat_id <- selectSimpleMatchVarL pat + match_code + <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr + pair_id <- newSysLocalDs after_c_ty + let + proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code) + + -- put it all together + let + in_ty = mkBigCoreVarTupTy env_ids + in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy + in_ty2 = mkBigCoreVarTupTy env_ids2 + before_c_ty = mkCorePairTy in_ty1 in_ty2 + return (do_premap ids in_ty before_c_ty out_ty core_mux $ + do_compose ids before_c_ty after_c_ty out_ty + (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $ + do_arr ids after_c_ty out_ty proj_expr, + fv_cmd `unionDVarSet` (mkDVarSet out_ids + `uniqDSetMinusUniqSet` pat_vars)) + +-- D; xs' |-a do { ss } : t +-- -------------------------------------- +-- D; xs |-a do { let binds; ss } : t +-- +-- ---> arr (\ (xs) -> let binds in (xs')) >>> ss + +dsCmdStmt ids local_vars out_ids (LetStmt _ binds) env_ids = do + -- build a new environment using the let bindings + core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids) + -- match the old environment against the input + core_map <- matchEnv env_ids core_binds + return (do_arr ids + (mkBigCoreVarTupTy env_ids) + (mkBigCoreVarTupTy out_ids) + core_map, + exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars) + +-- D; ys |-a do { ss; returnA -< ((xs1), (ys2)) } : ... +-- D; xs' |-a do { ss' } : t +-- ------------------------------------ +-- D; xs |-a do { rec ss; ss' } : t +-- +-- xs1 = xs' /\ defs(ss) +-- xs2 = xs' - defs(ss) +-- ys1 = ys - defs(ss) +-- ys2 = ys /\ defs(ss) +-- +-- ---> arr (\(xs) -> ((ys1),(xs2))) >>> +-- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>> +-- arr (\((xs1),(xs2)) -> (xs')) >>> ss' + +dsCmdStmt ids local_vars out_ids + (RecStmt { recS_stmts = stmts + , recS_later_ids = later_ids, recS_rec_ids = rec_ids + , recS_ext = RecStmtTc { recS_later_rets = later_rets + , recS_rec_rets = rec_rets } }) + env_ids = do + let + later_ids_set = mkVarSet later_ids + env2_ids = filterOut (`elemVarSet` later_ids_set) out_ids + env2_id_set = mkDVarSet env2_ids + env2_ty = mkBigCoreVarTupTy env2_ids + + -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) + + uniqs <- newUniqueSupply + env2_id <- newSysLocalDs env2_ty + let + later_ty = mkBigCoreVarTupTy later_ids + post_pair_ty = mkCorePairTy later_ty env2_ty + post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids) + + post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body + + --- loop (...) + + (core_loop, env1_id_set, env1_ids) + <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets + + -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids)) + + let + env1_ty = mkBigCoreVarTupTy env1_ids + pre_pair_ty = mkCorePairTy env1_ty env2_ty + pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids) + (mkBigCoreVarTup env2_ids) + + pre_loop_fn <- matchEnv env_ids pre_loop_body + + -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn + + let + env_ty = mkBigCoreVarTupTy env_ids + out_ty = mkBigCoreVarTupTy out_ids + core_body = do_premap ids env_ty pre_pair_ty out_ty + pre_loop_fn + (do_compose ids pre_pair_ty post_pair_ty out_ty + (do_first ids env1_ty later_ty env2_ty + core_loop) + (do_arr ids post_pair_ty out_ty + post_loop_fn)) + + return (core_body, env1_id_set `unionDVarSet` env2_id_set) + +dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s) + +-- loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) +-- (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>> + +dsRecCmd + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> [CmdLStmt GhcTc] -- list of statements inside the RecCmd + -> [Id] -- list of vars defined here and used later + -> [HsExpr GhcTc] -- expressions corresponding to later_ids + -> [Id] -- list of vars fed back through the loop + -> [HsExpr GhcTc] -- expressions corresponding to rec_ids + -> DsM (CoreExpr, -- desugared statement + DIdSet, -- subset of local vars that occur free + [Id]) -- same local vars as a list + +dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do + let + later_id_set = mkVarSet later_ids + rec_id_set = mkVarSet rec_ids + local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars + + -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets)) + + core_later_rets <- mapM dsExpr later_rets + core_rec_rets <- mapM dsExpr rec_rets + let + -- possibly polymorphic version of vars of later_ids and rec_ids + out_ids = exprsFreeIdsList (core_later_rets ++ core_rec_rets) + out_ty = mkBigCoreVarTupTy out_ids + + later_tuple = mkBigCoreTup core_later_rets + later_ty = mkBigCoreVarTupTy later_ids + + rec_tuple = mkBigCoreTup core_rec_rets + rec_ty = mkBigCoreVarTupTy rec_ids + + out_pair = mkCorePairExpr later_tuple rec_tuple + out_pair_ty = mkCorePairTy later_ty rec_ty + + mk_pair_fn <- matchEnv out_ids out_pair + + -- ss + + (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts + + -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids) + + rec_id <- newSysLocalDs rec_ty + let + env1_id_set = fv_stmts `uniqDSetMinusUniqSet` rec_id_set + env1_ids = dVarSetElems env1_id_set + env1_ty = mkBigCoreVarTupTy env1_ids + in_pair_ty = mkCorePairTy env1_ty rec_ty + core_body = mkBigCoreTup (map selectVar env_ids) + where + selectVar v + | v `elemVarSet` rec_id_set + = mkTupleSelector rec_ids v rec_id (Var rec_id) + | otherwise = Var v + + squash_pair_fn <- matchEnvStack env1_ids rec_id core_body + + -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn)) + + let + env_ty = mkBigCoreVarTupTy env_ids + core_loop = do_loop ids env1_ty later_ty rec_ty + (do_premap ids in_pair_ty env_ty out_pair_ty + squash_pair_fn + (do_compose ids env_ty out_ty out_pair_ty + core_stmts + (do_arr ids out_ty out_pair_ty mk_pair_fn))) + + return (core_loop, env1_id_set, env1_ids) + +{- +A sequence of statements (as in a rec) is desugared to an arrow between +two environments (no stack) +-} + +dsfixCmdStmts + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> [Id] -- output vars of these statements + -> [CmdLStmt GhcTc] -- statements to desugar + -> DsM (CoreExpr, -- desugared expression + DIdSet, -- subset of local vars that occur free + [Id]) -- same local vars as a list + +dsfixCmdStmts ids local_vars out_ids stmts + = trimInput (dsCmdStmts ids local_vars out_ids stmts) + -- TODO: Add levity polymorphism check for the resulting expression. + -- But I (Richard E.) don't know enough about arrows to do so. + +dsCmdStmts + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> [Id] -- output vars of these statements + -> [CmdLStmt GhcTc] -- statements to desugar + -> [Id] -- list of vars in the input to these statements + -> DsM (CoreExpr, -- desugared expression + DIdSet) -- subset of local vars that occur free + +dsCmdStmts ids local_vars out_ids [stmt] env_ids + = dsCmdLStmt ids local_vars out_ids stmt env_ids + +dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do + let bound_vars = mkVarSet (collectLStmtBinders stmt) + let local_vars' = bound_vars `unionVarSet` local_vars + (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts + (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids + return (do_compose ids + (mkBigCoreVarTupTy env_ids) + (mkBigCoreVarTupTy env_ids') + (mkBigCoreVarTupTy out_ids) + core_stmt + core_stmts, + fv_stmt) + +dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []" + +-- Match a list of expressions against a list of patterns, left-to-right. + +matchSimplys :: [CoreExpr] -- Scrutinees + -> HsMatchContext GhcRn -- Match kind + -> [LPat GhcTc] -- Patterns they should match + -> CoreExpr -- Return this if they all match + -> CoreExpr -- Return this if they don't + -> DsM CoreExpr +matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr +matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do + match_code <- matchSimplys exps ctxt pats result_expr fail_expr + matchSimply exp ctxt pat match_code fail_expr +matchSimplys _ _ _ _ _ = panic "matchSimplys" + +-- List of leaf expressions, with set of variables bound in each + +leavesMatch :: LMatch GhcTc (Located (body GhcTc)) + -> [(Located (body GhcTc), IdSet)] +leavesMatch (L _ (Match { m_pats = pats + , m_grhss = GRHSs _ grhss (L _ binds) })) + = let + defined_vars = mkVarSet (collectPatsBinders pats) + `unionVarSet` + mkVarSet (collectLocalBinders binds) + in + [(body, + mkVarSet (collectLStmtsBinders stmts) + `unionVarSet` defined_vars) + | L _ (GRHS _ stmts body) <- grhss] +leavesMatch _ = panic "leavesMatch" + +-- Replace the leaf commands in a match + +replaceLeavesMatch + :: Type -- new result type + -> [Located (body' GhcTc)] -- replacement leaf expressions of that type + -> LMatch GhcTc (Located (body GhcTc)) -- the matches of a case command + -> ([Located (body' GhcTc)], -- remaining leaf expressions + LMatch GhcTc (Located (body' GhcTc))) -- updated match +replaceLeavesMatch _res_ty leaves + (L loc + match@(Match { m_grhss = GRHSs x grhss binds })) + = let + (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss + in + (leaves', L loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds })) +replaceLeavesMatch _ _ _ = panic "replaceLeavesMatch" + +replaceLeavesGRHS + :: [Located (body' GhcTc)] -- replacement leaf expressions of that type + -> LGRHS GhcTc (Located (body GhcTc)) -- rhss of a case command + -> ([Located (body' GhcTc)], -- remaining leaf expressions + LGRHS GhcTc (Located (body' GhcTc))) -- updated GRHS +replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _)) + = (leaves, L loc (GRHS x stmts leaf)) +replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" +replaceLeavesGRHS _ _ = panic "replaceLeavesGRHS" + +-- Balanced fold of a non-empty list. + +foldb :: (a -> a -> a) -> [a] -> a +foldb _ [] = error "foldb of empty list" +foldb _ [x] = x +foldb f xs = foldb f (fold_pairs xs) + where + fold_pairs [] = [] + fold_pairs [x] = [x] + fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs + +{- +Note [Dictionary binders in ConPatOut] See also same Note in GHC.Hs.Utils +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The following functions to collect value variables from patterns are +copied from GHC.Hs.Utils, with one change: we also collect the dictionary +bindings (pat_binds) from ConPatOut. We need them for cases like + +h :: Arrow a => Int -> a (Int,Int) Int +h x = proc (y,z) -> case compare x y of + GT -> returnA -< z+x + +The type checker turns the case into + + case compare x y of + GT { p77 = plusInt } -> returnA -< p77 z x + +Here p77 is a local binding for the (+) operation. + +See comments in GHC.Hs.Utils for why the other version does not include +these bindings. +-} + +collectPatBinders :: LPat GhcTc -> [Id] +collectPatBinders pat = collectl pat [] + +collectPatsBinders :: [LPat GhcTc] -> [Id] +collectPatsBinders pats = foldr collectl [] pats + +--------------------- +collectl :: LPat GhcTc -> [Id] -> [Id] +-- See Note [Dictionary binders in ConPatOut] +collectl (L _ pat) bndrs + = go pat + where + go (VarPat _ (L _ var)) = var : bndrs + go (WildPat _) = bndrs + go (LazyPat _ pat) = collectl pat bndrs + go (BangPat _ pat) = collectl pat bndrs + go (AsPat _ (L _ a) pat) = a : collectl pat bndrs + go (ParPat _ pat) = collectl pat bndrs + + go (ListPat _ pats) = foldr collectl bndrs pats + go (TuplePat _ pats _) = foldr collectl bndrs pats + go (SumPat _ pat _ _) = collectl pat bndrs + + go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps) + go (ConPatOut {pat_args=ps, pat_binds=ds}) = + collectEvBinders ds + ++ foldr collectl bndrs (hsConPatArgs ps) + go (LitPat _ _) = bndrs + go (NPat {}) = bndrs + go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs + + go (SigPat _ pat _) = collectl pat bndrs + go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs + go (ViewPat _ _ pat) = collectl pat bndrs + go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p) + go p@(XPat {}) = pprPanic "collectl/go" (ppr p) + +collectEvBinders :: TcEvBinds -> [Id] +collectEvBinders (EvBinds bs) = foldr add_ev_bndr [] bs +collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders" + +add_ev_bndr :: EvBind -> [Id] -> [Id] +add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs + | otherwise = bs + -- A worry: what about coercion variable binders?? + +collectLStmtsBinders :: [LStmt GhcTc body] -> [Id] +collectLStmtsBinders = concatMap collectLStmtBinders + +collectLStmtBinders :: LStmt GhcTc body -> [Id] +collectLStmtBinders = collectStmtBinders . unLoc + +collectStmtBinders :: Stmt GhcTc body -> [Id] +collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids +collectStmtBinders stmt = HsUtils.collectStmtBinders stmt diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs new file mode 100644 index 0000000000..a6bbe4ca54 --- /dev/null +++ b/compiler/GHC/HsToCore/Binds.hs @@ -0,0 +1,1327 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Pattern-matching bindings (HsBinds and MonoBinds) + +Handles @HsBinds@; those at the top level require different handling, +in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at +lower levels it is preserved with @let@/@letrec@s). +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.HsToCore.Binds + ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec + , dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule + ) +where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr ) +import {-# SOURCE #-} GHC.HsToCore.Match ( matchWrapper ) + +import GHC.HsToCore.Monad +import GHC.HsToCore.GuardedRHSs +import GHC.HsToCore.Utils +import GHC.HsToCore.PmCheck ( needToRunPmCheck, addTyCsDs, checkGuardMatches ) + +import GHC.Hs -- lots of things +import CoreSyn -- lots of things +import CoreOpt ( simpleOptExpr ) +import OccurAnal ( occurAnalyseExpr ) +import MkCore +import CoreUtils +import CoreArity ( etaExpand ) +import CoreUnfold +import CoreFVs +import Digraph +import Predicate + +import PrelNames +import TyCon +import TcEvidence +import TcType +import Type +import Coercion +import TysWiredIn ( typeNatKind, typeSymbolKind ) +import Id +import MkId(proxyHashId) +import Name +import VarSet +import Rules +import VarEnv +import Var( EvVar ) +import Outputable +import Module +import SrcLoc +import Maybes +import OrdList +import Bag +import BasicTypes +import DynFlags +import FastString +import Util +import UniqSet( nonDetEltsUniqSet ) +import MonadUtils +import qualified GHC.LanguageExtensions as LangExt +import Control.Monad + +{-********************************************************************** +* * + Desugaring a MonoBinds +* * +**********************************************************************-} + +-- | Desugar top level binds, strict binds are treated like normal +-- binds since there is no good time to force before first usage. +dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr)) +dsTopLHsBinds binds + -- see Note [Strict binds checks] + | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds) + = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds + ; mapBagM_ (top_level_err "strict bindings") bang_binds + ; return nilOL } + + | otherwise + = do { (force_vars, prs) <- dsLHsBinds binds + ; when debugIsOn $ + do { xstrict <- xoptM LangExt.Strict + ; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr force_vars ) } + -- with -XStrict, even top-level vars are listed as force vars. + + ; return (toOL prs) } + + where + unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds + bang_binds = filterBag (isBangedHsBind . unLoc) binds + + top_level_err desc (L loc bind) + = putSrcSpanDs loc $ + errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:") + 2 (ppr bind)) + + +-- | Desugar all other kind of bindings, Ids of strict binds are returned to +-- later be forced in the binding group body, see Note [Desugar Strict binds] +dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)]) +dsLHsBinds binds + = do { ds_bs <- mapBagM dsLHsBind binds + ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b')) + id ([], []) ds_bs) } + +------------------------ +dsLHsBind :: LHsBind GhcTc + -> DsM ([Id], [(Id,CoreExpr)]) +dsLHsBind (L loc bind) = do dflags <- getDynFlags + putSrcSpanDs loc $ dsHsBind dflags bind + +-- | Desugar a single binding (or group of recursive binds). +dsHsBind :: DynFlags + -> HsBind GhcTc + -> DsM ([Id], [(Id,CoreExpr)]) + -- ^ The Ids of strict binds, to be forced in the body of the + -- binding group see Note [Desugar Strict binds] and all + -- bindings and their desugared right hand sides. + +dsHsBind dflags (VarBind { var_id = var + , var_rhs = expr + , var_inline = inline_regardless }) + = do { core_expr <- dsLExpr expr + -- Dictionary bindings are always VarBinds, + -- so we only need do this here + ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr + | otherwise = var + ; let core_bind@(id,_) = makeCorePair dflags var' False 0 core_expr + force_var = if xopt LangExt.Strict dflags + then [id] + else [] + ; return (force_var, [core_bind]) } + +dsHsBind dflags b@(FunBind { fun_id = L _ fun + , fun_matches = matches + , fun_ext = co_fn + , fun_tick = tick }) + = do { (args, body) <- matchWrapper + (mkPrefixFunRhs (noLoc $ idName fun)) + Nothing matches + ; core_wrap <- dsHsWrapper co_fn + ; let body' = mkOptTickBox tick body + rhs = core_wrap (mkLams args body') + core_binds@(id,_) = makeCorePair dflags fun False 0 rhs + force_var + -- Bindings are strict when -XStrict is enabled + | xopt LangExt.Strict dflags + , matchGroupArity matches == 0 -- no need to force lambdas + = [id] + | isBangedHsBind b + = [id] + | otherwise + = [] + ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun) + -- , ppr (mg_alts matches) + -- , ppr args, ppr core_binds]) $ + return (force_var, [core_binds]) } + +dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss + , pat_ext = NPatBindTc _ ty + , pat_ticks = (rhs_tick, var_ticks) }) + = do { body_expr <- dsGuarded grhss ty + ; checkGuardMatches PatBindGuards grhss + ; let body' = mkOptTickBox rhs_tick body_expr + pat' = decideBangHood dflags pat + ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body' + -- We silently ignore inline pragmas; no makeCorePair + -- Not so cool, but really doesn't matter + ; let force_var' = if isBangedLPat pat' + then [force_var] + else [] + ; return (force_var', sel_binds) } + +dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts + , abs_exports = exports + , abs_ev_binds = ev_binds + , abs_binds = binds, abs_sig = has_sig }) + = do { ds_binds <- applyWhen (needToRunPmCheck dflags FromSource) + -- FromSource might not be accurate, but at worst + -- we do superfluous calls to the pattern match + -- oracle. + -- addTyCsDs: push type constraints deeper + -- for inner pattern match check + -- See Check, Note [Type and Term Equality Propagation] + (addTyCsDs (listToBag dicts)) + (dsLHsBinds binds) + + ; ds_ev_binds <- dsTcEvBinds_s ev_binds + + -- dsAbsBinds does the hard work + ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig } + +dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" +dsHsBind _ (XHsBindsLR nec) = noExtCon nec + + +----------------------- +dsAbsBinds :: DynFlags + -> [TyVar] -> [EvVar] -> [ABExport GhcTc] + -> [CoreBind] -- Desugared evidence bindings + -> ([Id], [(Id,CoreExpr)]) -- Desugared value bindings + -> Bool -- Single binding with signature + -> DsM ([Id], [(Id,CoreExpr)]) + +dsAbsBinds dflags tyvars dicts exports + ds_ev_binds (force_vars, bind_prs) has_sig + + -- A very important common case: one exported variable + -- Non-recursive bindings come through this way + -- So do self-recursive bindings + | [export] <- exports + , ABE { abe_poly = global_id, abe_mono = local_id + , abe_wrap = wrap, abe_prags = prags } <- export + , Just force_vars' <- case force_vars of + [] -> Just [] + [v] | v == local_id -> Just [global_id] + _ -> Nothing + -- If there is a variable to force, it's just the + -- single variable we are binding here + = do { core_wrap <- dsHsWrapper wrap -- Usually the identity + + ; let rhs = core_wrap $ + mkLams tyvars $ mkLams dicts $ + mkCoreLets ds_ev_binds $ + body + + body | has_sig + , [(_, lrhs)] <- bind_prs + = lrhs + | otherwise + = mkLetRec bind_prs (Var local_id) + + ; (spec_binds, rules) <- dsSpecs rhs prags + + ; let global_id' = addIdSpecialisations global_id rules + main_bind = makeCorePair dflags global_id' + (isDefaultMethod prags) + (dictArity dicts) rhs + + ; return (force_vars', main_bind : fromOL spec_binds) } + + -- Another common case: no tyvars, no dicts + -- In this case we can have a much simpler desugaring + | null tyvars, null dicts + + = do { let mk_bind (ABE { abe_wrap = wrap + , abe_poly = global + , abe_mono = local + , abe_prags = prags }) + = do { core_wrap <- dsHsWrapper wrap + ; return (makeCorePair dflags global + (isDefaultMethod prags) + 0 (core_wrap (Var local))) } + mk_bind (XABExport nec) = noExtCon nec + ; main_binds <- mapM mk_bind exports + + ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) } + + -- The general case + -- See Note [Desugaring AbsBinds] + | otherwise + = do { let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs + | (lcl_id, rhs) <- bind_prs ] + -- Monomorphic recursion possible, hence Rec + new_force_vars = get_new_force_vars force_vars + locals = map abe_mono exports + all_locals = locals ++ new_force_vars + tup_expr = mkBigCoreVarTup all_locals + tup_ty = exprType tup_expr + ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $ + mkCoreLets ds_ev_binds $ + mkLet core_bind $ + tup_expr + + ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs) + + -- Find corresponding global or make up a new one: sometimes + -- we need to make new export to desugar strict binds, see + -- Note [Desugar Strict binds] + ; (exported_force_vars, extra_exports) <- get_exports force_vars + + ; let mk_bind (ABE { abe_wrap = wrap + , abe_poly = global + , abe_mono = local, abe_prags = spec_prags }) + -- See Note [AbsBinds wrappers] in HsBinds + = do { tup_id <- newSysLocalDs tup_ty + ; core_wrap <- dsHsWrapper wrap + ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $ + mkTupleSelector all_locals local tup_id $ + mkVarApps (Var poly_tup_id) (tyvars ++ dicts) + rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs + ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags + ; let global' = (global `setInlinePragma` defaultInlinePragma) + `addIdSpecialisations` rules + -- Kill the INLINE pragma because it applies to + -- the user written (local) function. The global + -- Id is just the selector. Hmm. + ; return ((global', rhs) : fromOL spec_binds) } + mk_bind (XABExport nec) = noExtCon nec + + ; export_binds_s <- mapM mk_bind (exports ++ extra_exports) + + ; return ( exported_force_vars + , (poly_tup_id, poly_tup_rhs) : + concat export_binds_s) } + where + inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with + -- the inline pragma from the source + -- The type checker put the inline pragma + -- on the *global* Id, so we need to transfer it + inline_env + = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag) + | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports + , let prag = idInlinePragma gbl_id ] + + add_inline :: Id -> Id -- tran + add_inline lcl_id = lookupVarEnv inline_env lcl_id + `orElse` lcl_id + + global_env :: IdEnv Id -- Maps local Id to its global exported Id + global_env = + mkVarEnv [ (local, global) + | ABE { abe_mono = local, abe_poly = global } <- exports + ] + + -- find variables that are not exported + get_new_force_vars lcls = + foldr (\lcl acc -> case lookupVarEnv global_env lcl of + Just _ -> acc + Nothing -> lcl:acc) + [] lcls + + -- find exports or make up new exports for force variables + get_exports :: [Id] -> DsM ([Id], [ABExport GhcTc]) + get_exports lcls = + foldM (\(glbls, exports) lcl -> + case lookupVarEnv global_env lcl of + Just glbl -> return (glbl:glbls, exports) + Nothing -> do export <- mk_export lcl + let glbl = abe_poly export + return (glbl:glbls, export:exports)) + ([],[]) lcls + + mk_export local = + do global <- newSysLocalDs + (exprType (mkLams tyvars (mkLams dicts (Var local)))) + return (ABE { abe_ext = noExtField + , abe_poly = global + , abe_mono = local + , abe_wrap = WpHole + , abe_prags = SpecPrags [] }) + +-- | This is where we apply INLINE and INLINABLE pragmas. All we need to +-- do is to attach the unfolding information to the Id. +-- +-- Other decisions about whether to inline are made in +-- `calcUnfoldingGuidance` but the decision about whether to then expose +-- the unfolding in the interface file is made in `GHC.Iface.Tidy.addExternal` +-- using this information. +------------------------ +makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr + -> (Id, CoreExpr) +makeCorePair dflags gbl_id is_default_method dict_arity rhs + | is_default_method -- Default methods are *always* inlined + -- See Note [INLINE and default methods] in TcInstDcls + = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs) + + | otherwise + = case inlinePragmaSpec inline_prag of + NoUserInline -> (gbl_id, rhs) + NoInline -> (gbl_id, rhs) + Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs) + Inline -> inline_pair + + where + inline_prag = idInlinePragma gbl_id + inlinable_unf = mkInlinableUnfolding dflags rhs + inline_pair + | Just arity <- inlinePragmaSat inline_prag + -- Add an Unfolding for an INLINE (but not for NOINLINE) + -- And eta-expand the RHS; see Note [Eta-expanding INLINE things] + , let real_arity = dict_arity + arity + -- NB: The arity in the InlineRule takes account of the dictionaries + = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity rhs + , etaExpand real_arity rhs) + + | otherwise + = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $ + (gbl_id `setIdUnfolding` mkInlineUnfolding rhs, rhs) + +dictArity :: [Var] -> Arity +-- Don't count coercion variables in arity +dictArity dicts = count isId dicts + +{- +Note [Desugaring AbsBinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the general AbsBinds case we desugar the binding to this: + + tup a (d:Num a) = let fm = ...gm... + gm = ...fm... + in (fm,gm) + f a d = case tup a d of { (fm,gm) -> fm } + g a d = case tup a d of { (fm,gm) -> fm } + +Note [Rules and inlining] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Common special case: no type or dictionary abstraction +This is a bit less trivial than you might suppose +The naive way would be to desugar to something like + f_lcl = ...f_lcl... -- The "binds" from AbsBinds + M.f = f_lcl -- Generated from "exports" +But we don't want that, because if M.f isn't exported, +it'll be inlined unconditionally at every call site (its rhs is +trivial). That would be ok unless it has RULES, which would +thereby be completely lost. Bad, bad, bad. + +Instead we want to generate + M.f = ...f_lcl... + f_lcl = M.f +Now all is cool. The RULES are attached to M.f (by SimplCore), +and f_lcl is rapidly inlined away. + +This does not happen in the same way to polymorphic binds, +because they desugar to + M.f = /\a. let f_lcl = ...f_lcl... in f_lcl +Although I'm a bit worried about whether full laziness might +float the f_lcl binding out and then inline M.f at its call site + +Note [Specialising in no-dict case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Even if there are no tyvars or dicts, we may have specialisation pragmas. +Class methods can generate + AbsBinds [] [] [( ... spec-prag] + { AbsBinds [tvs] [dicts] ...blah } +So the overloading is in the nested AbsBinds. A good example is in GHC.Float: + + class (Real a, Fractional a) => RealFrac a where + round :: (Integral b) => a -> b + + instance RealFrac Float where + {-# SPECIALIZE round :: Float -> Int #-} + +The top-level AbsBinds for $cround has no tyvars or dicts (because the +instance does not). But the method is locally overloaded! + +Note [Abstracting over tyvars only] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When abstracting over type variable only (not dictionaries), we don't really need to +built a tuple and select from it, as we do in the general case. Instead we can take + + AbsBinds [a,b] [ ([a,b], fg, fl, _), + ([b], gg, gl, _) ] + { fl = e1 + gl = e2 + h = e3 } + +and desugar it to + + fg = /\ab. let B in e1 + gg = /\b. let a = () in let B in S(e2) + h = /\ab. let B in e3 + +where B is the *non-recursive* binding + fl = fg a b + gl = gg b + h = h a b -- See (b); note shadowing! + +Notice (a) g has a different number of type variables to f, so we must + use the mkArbitraryType thing to fill in the gaps. + We use a type-let to do that. + + (b) The local variable h isn't in the exports, and rather than + clone a fresh copy we simply replace h by (h a b), where + the two h's have different types! Shadowing happens here, + which looks confusing but works fine. + + (c) The result is *still* quadratic-sized if there are a lot of + small bindings. So if there are more than some small + number (10), we filter the binding set B by the free + variables of the particular RHS. Tiresome. + +Why got to this trouble? It's a common case, and it removes the +quadratic-sized tuple desugaring. Less clutter, hopefully faster +compilation, especially in a case where there are a *lot* of +bindings. + + +Note [Eta-expanding INLINE things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + foo :: Eq a => a -> a + {-# INLINE foo #-} + foo x = ... + +If (foo d) ever gets floated out as a common sub-expression (which can +happen as a result of method sharing), there's a danger that we never +get to do the inlining, which is a Terribly Bad thing given that the +user said "inline"! + +To avoid this we pre-emptively eta-expand the definition, so that foo +has the arity with which it is declared in the source code. In this +example it has arity 2 (one for the Eq and one for x). Doing this +should mean that (foo d) is a PAP and we don't share it. + +Note [Nested arities] +~~~~~~~~~~~~~~~~~~~~~ +For reasons that are not entirely clear, method bindings come out looking like +this: + + AbsBinds [] [] [$cfromT <= [] fromT] + $cfromT [InlPrag=INLINE] :: T Bool -> Bool + { AbsBinds [] [] [fromT <= [] fromT_1] + fromT :: T Bool -> Bool + { fromT_1 ((TBool b)) = not b } } } + +Note the nested AbsBind. The arity for the InlineRule on $cfromT should be +gotten from the binding for fromT_1. + +It might be better to have just one level of AbsBinds, but that requires more +thought! + + +Note [Desugar Strict binds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma + +Desugaring strict variable bindings looks as follows (core below ==>) + + let !x = rhs + in body +==> + let x = rhs + in x `seq` body -- seq the variable + +and if it is a pattern binding the desugaring looks like + + let !pat = rhs + in body +==> + let x = rhs -- bind the rhs to a new variable + pat = x + in x `seq` body -- seq the new variable + +if there is no variable in the pattern desugaring looks like + + let False = rhs + in body +==> + let x = case rhs of {False -> (); _ -> error "Match failed"} + in x `seq` body + +In order to force the Ids in the binding group they are passed around +in the dsHsBind family of functions, and later seq'ed in GHC.HsToCore.Expr.ds_val_bind. + +Consider a recursive group like this + + letrec + f : g = rhs[f,g] + in + +Without `Strict`, we get a translation like this: + + let t = /\a. letrec tm = rhs[fm,gm] + fm = case t of fm:_ -> fm + gm = case t of _:gm -> gm + in + (fm,gm) + + in let f = /\a. case t a of (fm,_) -> fm + in let g = /\a. case t a of (_,gm) -> gm + in + +Here `tm` is the monomorphic binding for `rhs`. + +With `Strict`, we want to force `tm`, but NOT `fm` or `gm`. +Alas, `tm` isn't in scope in the `in ` part. + +The simplest thing is to return it in the polymorphic +tuple `t`, thus: + + let t = /\a. letrec tm = rhs[fm,gm] + fm = case t of fm:_ -> fm + gm = case t of _:gm -> gm + in + (tm, fm, gm) + + in let f = /\a. case t a of (_,fm,_) -> fm + in let g = /\a. case t a of (_,_,gm) -> gm + in let tm = /\a. case t a of (tm,_,_) -> tm + in tm `seq` + + +See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma for a more +detailed explanation of the desugaring of strict bindings. + +Note [Strict binds checks] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are several checks around properly formed strict bindings. They +all link to this Note. These checks must be here in the desugarer because +we cannot know whether or not a type is unlifted until after zonking, due +to levity polymorphism. These checks all used to be handled in the typechecker +in checkStrictBinds (before Jan '17). + +We define an "unlifted bind" to be any bind that binds an unlifted id. Note that + + x :: Char + (# True, x #) = blah + +is *not* an unlifted bind. Unlifted binds are detected by GHC.Hs.Utils.isUnliftedHsBind. + +Define a "banged bind" to have a top-level bang. Detected by GHC.Hs.Pat.isBangedHsBind. +Define a "strict bind" to be either an unlifted bind or a banged bind. + +The restrictions are: + 1. Strict binds may not be top-level. Checked in dsTopLHsBinds. + + 2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged + unlifted bind, but an unbanged bind looks lazy, and we don't want users to be + surprised by the strictness of an unlifted bind.) Checked in first clause + of GHC.HsToCore.Expr.ds_val_bind. + + 3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type + variables or constraints.) Checked in first clause + of GHC.HsToCore.Expr.ds_val_bind. + + 4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind. + +-} + +------------------------ +dsSpecs :: CoreExpr -- Its rhs + -> TcSpecPrags + -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids + , [CoreRule] ) -- Rules for the Global Ids +-- See Note [Handling SPECIALISE pragmas] in TcBinds +dsSpecs _ IsDefaultMethod = return (nilOL, []) +dsSpecs poly_rhs (SpecPrags sps) + = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps + ; let (spec_binds_s, rules) = unzip pairs + ; return (concatOL spec_binds_s, rules) } + +dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding + -- Nothing => RULE is for an imported Id + -- rhs is in the Id's unfolding + -> Located TcSpecPrag + -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule)) +dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) + | isJust (isClassOpId_maybe poly_id) + = putSrcSpanDs loc $ + do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector" + <+> quotes (ppr poly_id)) + ; return Nothing } -- There is no point in trying to specialise a class op + -- Moreover, classops don't (currently) have an inl_sat arity set + -- (it would be Just 0) and that in turn makes makeCorePair bleat + + | no_act_spec && isNeverActive rule_act + = putSrcSpanDs loc $ + do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:" + <+> quotes (ppr poly_id)) + ; return Nothing } -- Function is NOINLINE, and the specialisation inherits that + -- See Note [Activation pragmas for SPECIALISE] + + | otherwise + = putSrcSpanDs loc $ + do { uniq <- newUnique + ; let poly_name = idName poly_id + spec_occ = mkSpecOcc (getOccName poly_name) + spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name) + (spec_bndrs, spec_app) = collectHsWrapBinders spec_co + -- spec_co looks like + -- \spec_bndrs. [] spec_args + -- perhaps with the body of the lambda wrapped in some WpLets + -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2 + + ; core_app <- dsHsWrapper spec_app + + ; let ds_lhs = core_app (Var poly_id) + spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs) + ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id + -- , text "spec_co:" <+> ppr spec_co + -- , text "ds_rhs:" <+> ppr ds_lhs ]) $ + dflags <- getDynFlags + ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of { + Left msg -> do { warnDs NoReason msg; return Nothing } ; + Right (rule_bndrs, _fn, args) -> do + + { this_mod <- getModule + ; let fn_unf = realIdUnfolding poly_id + spec_unf = specUnfolding dflags spec_bndrs core_app arity_decrease fn_unf + spec_id = mkLocalId spec_name spec_ty + `setInlinePragma` inl_prag + `setIdUnfolding` spec_unf + arity_decrease = count isValArg args - count isId spec_bndrs + + ; rule <- dsMkUserRule this_mod is_local_id + (mkFastString ("SPEC " ++ showPpr dflags poly_name)) + rule_act poly_name + rule_bndrs args + (mkVarApps (Var spec_id) spec_bndrs) + + ; let spec_rhs = mkLams spec_bndrs (core_app poly_rhs) + +-- Commented out: see Note [SPECIALISE on INLINE functions] +-- ; when (isInlinePragma id_inl) +-- (warnDs $ text "SPECIALISE pragma on INLINE function probably won't fire:" +-- <+> quotes (ppr poly_name)) + + ; return (Just (unitOL (spec_id, spec_rhs), rule)) + -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because + -- makeCorePair overwrites the unfolding, which we have + -- just created using specUnfolding + } } } + where + is_local_id = isJust mb_poly_rhs + poly_rhs | Just rhs <- mb_poly_rhs + = rhs -- Local Id; this is its rhs + | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id) + = unfolding -- Imported Id; this is its unfolding + -- Use realIdUnfolding so we get the unfolding + -- even when it is a loop breaker. + -- We want to specialise recursive functions! + | otherwise = pprPanic "dsImpSpecs" (ppr poly_id) + -- The type checker has checked that it *has* an unfolding + + id_inl = idInlinePragma poly_id + + -- See Note [Activation pragmas for SPECIALISE] + inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl + | not is_local_id -- See Note [Specialising imported functions] + -- in OccurAnal + , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma + | otherwise = id_inl + -- Get the INLINE pragma from SPECIALISE declaration, or, + -- failing that, from the original Id + + spec_prag_act = inlinePragmaActivation spec_inl + + -- See Note [Activation pragmas for SPECIALISE] + -- no_act_spec is True if the user didn't write an explicit + -- phase specification in the SPECIALISE pragma + no_act_spec = case inlinePragmaSpec spec_inl of + NoInline -> isNeverActive spec_prag_act + _ -> isAlwaysActive spec_prag_act + rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit + | otherwise = spec_prag_act -- Specified by user + + +dsMkUserRule :: Module -> Bool -> RuleName -> Activation + -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule +dsMkUserRule this_mod is_local name act fn bndrs args rhs = do + let rule = mkRule this_mod False is_local name act fn bndrs args rhs + dflags <- getDynFlags + when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $ + warnDs (Reason Opt_WarnOrphans) (ruleOrphWarn rule) + return rule + +ruleOrphWarn :: CoreRule -> SDoc +ruleOrphWarn rule = text "Orphan rule:" <+> ppr rule + +{- Note [SPECIALISE on INLINE functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to warn that using SPECIALISE for a function marked INLINE +would be a no-op; but it isn't! Especially with worker/wrapper split +we might have + {-# INLINE f #-} + f :: Ord a => Int -> a -> ... + f d x y = case x of I# x' -> $wf d x' y + +We might want to specialise 'f' so that we in turn specialise '$wf'. +We can't even /name/ '$wf' in the source code, so we can't specialise +it even if we wanted to. #10721 is a case in point. + +Note [Activation pragmas for SPECIALISE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +From a user SPECIALISE pragma for f, we generate + a) A top-level binding spec_fn = rhs + b) A RULE f dOrd = spec_fn + +We need two pragma-like things: + +* spec_fn's inline pragma: inherited from f's inline pragma (ignoring + activation on SPEC), unless overridden by SPEC INLINE + +* Activation of RULE: from SPECIALISE pragma (if activation given) + otherwise from f's inline pragma + +This is not obvious (see #5237)! + +Examples Rule activation Inline prag on spec'd fn +--------------------------------------------------------------------- +SPEC [n] f :: ty [n] Always, or NOINLINE [n] + copy f's prag + +NOINLINE f +SPEC [n] f :: ty [n] NOINLINE + copy f's prag + +NOINLINE [k] f +SPEC [n] f :: ty [n] NOINLINE [k] + copy f's prag + +INLINE [k] f +SPEC [n] f :: ty [n] INLINE [k] + copy f's prag + +SPEC INLINE [n] f :: ty [n] INLINE [n] + (ignore INLINE prag on f, + same activation for rule and spec'd fn) + +NOINLINE [k] f +SPEC f :: ty [n] INLINE [k] + + +************************************************************************ +* * +\subsection{Adding inline pragmas} +* * +************************************************************************ +-} + +decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr + -> Either SDoc ([Var], Id, [CoreExpr]) +-- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE, +-- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs +-- may add some extra dictionary binders (see Note [Free dictionaries]) +-- +-- Returns an error message if the LHS isn't of the expected shape +-- Note [Decomposing the left-hand side of a RULE] +decomposeRuleLhs dflags orig_bndrs orig_lhs + | not (null unbound) -- Check for things unbound on LHS + -- See Note [Unused spec binders] + = Left (vcat (map dead_msg unbound)) + | Var funId <- fun2 + , Just con <- isDataConId_maybe funId + = Left (constructor_msg con) -- See Note [No RULES on datacons] + | Just (fn_id, args) <- decompose fun2 args2 + , let extra_bndrs = mk_extra_bndrs fn_id args + = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs + -- , text "orig_lhs:" <+> ppr orig_lhs + -- , text "lhs1:" <+> ppr lhs1 + -- , text "extra_dict_bndrs:" <+> ppr extra_dict_bndrs + -- , text "fn_id:" <+> ppr fn_id + -- , text "args:" <+> ppr args]) $ + Right (orig_bndrs ++ extra_bndrs, fn_id, args) + + | otherwise + = Left bad_shape_msg + where + lhs1 = drop_dicts orig_lhs + lhs2 = simpleOptExpr dflags lhs1 -- See Note [Simplify rule LHS] + (fun2,args2) = collectArgs lhs2 + + lhs_fvs = exprFreeVars lhs2 + unbound = filterOut (`elemVarSet` lhs_fvs) orig_bndrs + + orig_bndr_set = mkVarSet orig_bndrs + + -- Add extra tyvar binders: Note [Free tyvars in rule LHS] + -- and extra dict binders: Note [Free dictionaries in rule LHS] + mk_extra_bndrs fn_id args + = scopedSort unbound_tvs ++ unbound_dicts + where + unbound_tvs = [ v | v <- unbound_vars, isTyVar v ] + unbound_dicts = [ mkLocalId (localiseName (idName d)) (idType d) + | d <- unbound_vars, isDictId d ] + unbound_vars = [ v | v <- exprsFreeVarsList args + , not (v `elemVarSet` orig_bndr_set) + , not (v == fn_id) ] + -- fn_id: do not quantify over the function itself, which may + -- itself be a dictionary (in pathological cases, #10251) + + decompose (Var fn_id) args + | not (fn_id `elemVarSet` orig_bndr_set) + = Just (fn_id, args) + + decompose _ _ = Nothing + + bad_shape_msg = hang (text "RULE left-hand side too complicated to desugar") + 2 (vcat [ text "Optimised lhs:" <+> ppr lhs2 + , text "Orig lhs:" <+> ppr orig_lhs]) + dead_msg bndr = hang (sep [ text "Forall'd" <+> pp_bndr bndr + , text "is not bound in RULE lhs"]) + 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs + , text "Orig lhs:" <+> ppr orig_lhs + , text "optimised lhs:" <+> ppr lhs2 ]) + pp_bndr bndr + | isTyVar bndr = text "type variable" <+> quotes (ppr bndr) + | isEvVar bndr = text "constraint" <+> quotes (ppr (varType bndr)) + | otherwise = text "variable" <+> quotes (ppr bndr) + + constructor_msg con = vcat + [ text "A constructor," <+> ppr con <> + text ", appears as outermost match in RULE lhs." + , text "This rule will be ignored." ] + + drop_dicts :: CoreExpr -> CoreExpr + drop_dicts e + = wrap_lets needed bnds body + where + needed = orig_bndr_set `minusVarSet` exprFreeVars body + (bnds, body) = split_lets (occurAnalyseExpr e) + -- The occurAnalyseExpr drops dead bindings which is + -- crucial to ensure that every binding is used later; + -- which in turn makes wrap_lets work right + + split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr) + split_lets (Let (NonRec d r) body) + | isDictId d + = ((d,r):bs, body') + where (bs, body') = split_lets body + + -- handle "unlifted lets" too, needed for "map/coerce" + split_lets (Case r d _ [(DEFAULT, _, body)]) + | isCoVar d + = ((d,r):bs, body') + where (bs, body') = split_lets body + + split_lets e = ([], e) + + wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr + wrap_lets _ [] body = body + wrap_lets needed ((d, r) : bs) body + | rhs_fvs `intersectsVarSet` needed = mkCoreLet (NonRec d r) (wrap_lets needed' bs body) + | otherwise = wrap_lets needed bs body + where + rhs_fvs = exprFreeVars r + needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d + +{- +Note [Decomposing the left-hand side of a RULE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are several things going on here. +* drop_dicts: see Note [Drop dictionary bindings on rule LHS] +* simpleOptExpr: see Note [Simplify rule LHS] +* extra_dict_bndrs: see Note [Free dictionaries] + +Note [Free tyvars on rule LHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a = C + + foo :: T a -> Int + foo C = 1 + + {-# RULES "myrule" foo C = 1 #-} + +After type checking the LHS becomes (foo alpha (C alpha)), where alpha +is an unbound meta-tyvar. The zonker in TcHsSyn is careful not to +turn the free alpha into Any (as it usually does). Instead it turns it +into a TyVar 'a'. See TcHsSyn Note [Zonking the LHS of a RULE]. + +Now we must quantify over that 'a'. It's /really/ inconvenient to do that +in the zonker, because the HsExpr data type is very large. But it's /easy/ +to do it here in the desugarer. + +Moreover, we have to do something rather similar for dictionaries; +see Note [Free dictionaries on rule LHS]. So that's why we look for +type variables free on the LHS, and quantify over them. + +Note [Free dictionaries on rule LHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, +which is presumably in scope at the function definition site, we can quantify +over it too. *Any* dict with that type will do. + +So for example when you have + f :: Eq a => a -> a + f = + ... SPECIALISE f :: Int -> Int ... + +Then we get the SpecPrag + SpecPrag (f Int dInt) + +And from that we want the rule + + RULE forall dInt. f Int dInt = f_spec + f_spec = let f = in f Int dInt + +But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External +Name, and you can't bind them in a lambda or forall without getting things +confused. Likewise it might have an InlineRule or something, which would be +utterly bogus. So we really make a fresh Id, with the same unique and type +as the old one, but with an Internal name and no IdInfo. + +Note [Drop dictionary bindings on rule LHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +drop_dicts drops dictionary bindings on the LHS where possible. + E.g. let d:Eq [Int] = $fEqList $fEqInt in f d + --> f d + Reasoning here is that there is only one d:Eq [Int], and so we can + quantify over it. That makes 'd' free in the LHS, but that is later + picked up by extra_dict_bndrs (Note [Dead spec binders]). + + NB 1: We can only drop the binding if the RHS doesn't bind + one of the orig_bndrs, which we assume occur on RHS. + Example + f :: (Eq a) => b -> a -> a + {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-} + Here we want to end up with + RULE forall d:Eq a. f ($dfEqList d) = f_spec d + Of course, the ($dfEqlist d) in the pattern makes it less likely + to match, but there is no other way to get d:Eq a + + NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all + the evidence bindings to be wrapped around the outside of the + LHS. (After simplOptExpr they'll usually have been inlined.) + dsHsWrapper does dependency analysis, so that civilised ones + will be simple NonRec bindings. We don't handle recursive + dictionaries! + + NB3: In the common case of a non-overloaded, but perhaps-polymorphic + specialisation, we don't need to bind *any* dictionaries for use + in the RHS. For example (#8331) + {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-} + useAbstractMonad :: MonadAbstractIOST m => m Int + Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code + but the RHS uses no dictionaries, so we want to end up with + RULE forall s (d :: MonadAbstractIOST (ReaderT s)). + useAbstractMonad (ReaderT s) d = $suseAbstractMonad s + + #8848 is a good example of where there are some interesting + dictionary bindings to discard. + +The drop_dicts algorithm is based on these observations: + + * Given (let d = rhs in e) where d is a DictId, + matching 'e' will bind e's free variables. + + * So we want to keep the binding if one of the needed variables (for + which we need a binding) is in fv(rhs) but not already in fv(e). + + * The "needed variables" are simply the orig_bndrs. Consider + f :: (Eq a, Show b) => a -> b -> String + ... SPECIALISE f :: (Show b) => Int -> b -> String ... + Then orig_bndrs includes the *quantified* dictionaries of the type + namely (dsb::Show b), but not the one for Eq Int + +So we work inside out, applying the above criterion at each step. + + +Note [Simplify rule LHS] +~~~~~~~~~~~~~~~~~~~~~~~~ +simplOptExpr occurrence-analyses and simplifies the LHS: + + (a) Inline any remaining dictionary bindings (which hopefully + occur just once) + + (b) Substitute trivial lets, so that they don't get in the way. + Note that we substitute the function too; we might + have this as a LHS: let f71 = M.f Int in f71 + + (c) Do eta reduction. To see why, consider the fold/build rule, + which without simplification looked like: + fold k z (build (/\a. g a)) ==> ... + This doesn't match unless you do eta reduction on the build argument. + Similarly for a LHS like + augment g (build h) + we do not want to get + augment (\a. g a) (build h) + otherwise we don't match when given an argument like + augment (\a. h a a) (build h) + +Note [Unused spec binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: a -> a + ... SPECIALISE f :: Eq a => a -> a ... +It's true that this *is* a more specialised type, but the rule +we get is something like this: + f_spec d = f + RULE: f = f_spec d +Note that the rule is bogus, because it mentions a 'd' that is +not bound on the LHS! But it's a silly specialisation anyway, because +the constraint is unused. We could bind 'd' to (error "unused") +but it seems better to reject the program because it's almost certainly +a mistake. That's what the isDeadBinder call detects. + +Note [No RULES on datacons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Previously, `RULES` like + + "JustNothing" forall x . Just x = Nothing + +were allowed. Simon Peyton Jones says this seems to have been a +mistake, that such rules have never been supported intentionally, +and that he doesn't know if they can break in horrible ways. +Furthermore, Ben Gamari and Reid Barton are considering trying to +detect the presence of "static data" that the simplifier doesn't +need to traverse at all. Such rules do not play well with that. +So for now, we ban them altogether as requested by #13290. See also #7398. + + +************************************************************************ +* * + Desugaring evidence +* * +************************************************************************ + +-} + +dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr) +dsHsWrapper WpHole = return $ \e -> e +dsHsWrapper (WpTyApp ty) = return $ \e -> App e (Type ty) +dsHsWrapper (WpEvLam ev) = return $ Lam ev +dsHsWrapper (WpTyLam tv) = return $ Lam tv +dsHsWrapper (WpLet ev_binds) = do { bs <- dsTcEvBinds ev_binds + ; return (mkCoreLets bs) } +dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1 + ; w2 <- dsHsWrapper c2 + ; return (w1 . w2) } + -- See comments on WpFun in TcEvidence for an explanation of what + -- the specification of this clause is +dsHsWrapper (WpFun c1 c2 t1 doc) + = do { x <- newSysLocalDsNoLP t1 + ; w1 <- dsHsWrapper c1 + ; w2 <- dsHsWrapper c2 + ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a + arg = w1 (Var x) + ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc + ; if ok + then return (\e -> (Lam x (w2 (app e arg)))) + else return id } -- this return is irrelevant +dsHsWrapper (WpCast co) = ASSERT(coercionRole co == Representational) + return $ \e -> mkCastDs e co +dsHsWrapper (WpEvApp tm) = do { core_tm <- dsEvTerm tm + ; return (\e -> App e core_tm) } + +-------------------------------------- +dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind] +dsTcEvBinds_s [] = return [] +dsTcEvBinds_s (b:rest) = ASSERT( null rest ) -- Zonker ensures null + dsTcEvBinds b + +dsTcEvBinds :: TcEvBinds -> DsM [CoreBind] +dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this +dsTcEvBinds (EvBinds bs) = dsEvBinds bs + +dsEvBinds :: Bag EvBind -> DsM [CoreBind] +dsEvBinds bs + = do { ds_bs <- mapBagM dsEvBind bs + ; return (mk_ev_binds ds_bs) } + +mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind] +-- We do SCC analysis of the evidence bindings, /after/ desugaring +-- them. This is convenient: it means we can use the CoreSyn +-- free-variable functions rather than having to do accurate free vars +-- for EvTerm. +mk_ev_binds ds_binds + = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges) + where + edges :: [ Node EvVar (EvVar,CoreExpr) ] + edges = foldr ((:) . mk_node) [] ds_binds + + mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr) + mk_node b@(var, rhs) + = DigraphNode { node_payload = b + , node_key = var + , node_dependencies = nonDetEltsUniqSet $ + exprFreeVars rhs `unionVarSet` + coVarsOfType (varType var) } + -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices + -- is still deterministic even if the edges are in nondeterministic order + -- as explained in Note [Deterministic SCC] in Digraph. + + ds_scc (AcyclicSCC (v,r)) = NonRec v r + ds_scc (CyclicSCC prs) = Rec prs + +dsEvBind :: EvBind -> DsM (Id, CoreExpr) +dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r) + + +{-********************************************************************** +* * + Desugaring EvTerms +* * +**********************************************************************-} + +dsEvTerm :: EvTerm -> DsM CoreExpr +dsEvTerm (EvExpr e) = return e +dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev +dsEvTerm (EvFun { et_tvs = tvs, et_given = given + , et_binds = ev_binds, et_body = wanted_id }) + = do { ds_ev_binds <- dsTcEvBinds ev_binds + ; return $ (mkLams (tvs ++ given) $ + mkCoreLets ds_ev_binds $ + Var wanted_id) } + + +{-********************************************************************** +* * + Desugaring Typeable dictionaries +* * +**********************************************************************-} + +dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr +-- Return a CoreExpr :: Typeable ty +-- This code is tightly coupled to the representation +-- of TypeRep, in base library Data.Typeable.Internals +dsEvTypeable ty ev + = do { tyCl <- dsLookupTyCon typeableClassName -- Typeable + ; let kind = typeKind ty + Just typeable_data_con + = tyConSingleDataCon_maybe tyCl -- "Data constructor" + -- for Typeable + + ; rep_expr <- ds_ev_typeable ty ev -- :: TypeRep a + + -- Package up the method as `Typeable` dictionary + ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] } + +type TypeRepExpr = CoreExpr + +-- | Returns a @CoreExpr :: TypeRep ty@ +ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr +ds_ev_typeable ty (EvTypeableTyCon tc kind_ev) + = do { mkTrCon <- dsLookupGlobalId mkTrConName + -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a + ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName + ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName + -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep + + ; tc_rep <- tyConRep tc -- :: TyCon + ; let ks = tyConAppArgs ty + -- Construct a SomeTypeRep + toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr + toSomeTypeRep t ev = do + rep <- getRep ev t + return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep] + ; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev -- :: TypeRep t + ; let -- :: [SomeTypeRep] + kind_args = mkListExpr (mkTyConTy someTypeRepTyCon) kind_arg_reps + + -- Note that we use the kind of the type, not the TyCon from which it + -- is constructed since the latter may be kind polymorphic whereas the + -- former we know is not (we checked in the solver). + ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty) + , Type ty + , tc_rep + , kind_args ] + -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr + ; return expr + } + +ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) + | Just (t1,t2) <- splitAppTy_maybe ty + = do { e1 <- getRep ev1 t1 + ; e2 <- getRep ev2 t2 + ; mkTrApp <- dsLookupGlobalId mkTrAppName + -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1). + -- TypeRep a -> TypeRep b -> TypeRep (a b) + ; let (k1, k2) = splitFunTy (typeKind t1) + ; let expr = mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ]) + [ e1, e2 ] + -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr + ; return expr + } + +ds_ev_typeable ty (EvTypeableTrFun ev1 ev2) + | Just (t1,t2) <- splitFunTy_maybe ty + = do { e1 <- getRep ev1 t1 + ; e2 <- getRep ev2 t2 + ; mkTrFun <- dsLookupGlobalId mkTrFunName + -- mkTrFun :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). + -- TypeRep a -> TypeRep b -> TypeRep (a -> b) + ; let r1 = getRuntimeRep t1 + r2 = getRuntimeRep t2 + ; return $ mkApps (mkTyApps (Var mkTrFun) [r1, r2, t1, t2]) + [ e1, e2 ] + } + +ds_ev_typeable ty (EvTypeableTyLit ev) + = -- See Note [Typeable for Nat and Symbol] in TcInteract + do { fun <- dsLookupGlobalId tr_fun + ; dict <- dsEvTerm ev -- Of type KnownNat/KnownSymbol + ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty] + ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) } + where + ty_kind = typeKind ty + + -- tr_fun is the Name of + -- typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep a + -- of typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep a + tr_fun | ty_kind `eqType` typeNatKind = typeNatTypeRepName + | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName + | otherwise = panic "dsEvTypeable: unknown type lit kind" + +ds_ev_typeable ty ev + = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev) + +getRep :: EvTerm -- ^ EvTerm for @Typeable ty@ + -> Type -- ^ The type @ty@ + -> DsM TypeRepExpr -- ^ Return @CoreExpr :: TypeRep ty@ + -- namely @typeRep# dict@ +-- Remember that +-- typeRep# :: forall k (a::k). Typeable k a -> TypeRep a +getRep ev ty + = do { typeable_expr <- dsEvTerm ev + ; typeRepId <- dsLookupGlobalId typeRepIdName + ; let ty_args = [typeKind ty, ty] + ; return (mkApps (mkTyApps (Var typeRepId) ty_args) [ typeable_expr ]) } + +tyConRep :: TyCon -> DsM CoreExpr +-- Returns CoreExpr :: TyCon +tyConRep tc + | Just tc_rep_nm <- tyConRepName_maybe tc + = do { tc_rep_id <- dsLookupGlobalId tc_rep_nm + ; return (Var tc_rep_id) } + | otherwise + = pprPanic "tyConRep" (ppr tc) diff --git a/compiler/GHC/HsToCore/Binds.hs-boot b/compiler/GHC/HsToCore/Binds.hs-boot new file mode 100644 index 0000000000..36e158b279 --- /dev/null +++ b/compiler/GHC/HsToCore/Binds.hs-boot @@ -0,0 +1,6 @@ +module GHC.HsToCore.Binds where +import GHC.HsToCore.Monad ( DsM ) +import CoreSyn ( CoreExpr ) +import TcEvidence (HsWrapper) + +dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr) diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs new file mode 100644 index 0000000000..ace0b27b4e --- /dev/null +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -0,0 +1,1368 @@ +{- +(c) Galois, 2006 +(c) University of Glasgow, 2007 +-} + +{-# LANGUAGE NondecreasingIndentation, RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.HsToCore.Coverage (addTicksToBinds, hpcInitCode) where + +import GhcPrelude as Prelude + +import qualified GHC.Runtime.Interpreter as GHCi +import GHCi.RemoteTypes +import Data.Array +import GHC.ByteCode.Types +import GHC.Stack.CCS +import Type +import GHC.Hs +import Module +import Outputable +import DynFlags +import ConLike +import Control.Monad +import SrcLoc +import ErrUtils +import NameSet hiding (FreeVars) +import Name +import Bag +import CostCentre +import CostCentreState +import CoreSyn +import Id +import VarSet +import Data.List +import FastString +import HscTypes +import TyCon +import BasicTypes +import MonadUtils +import Maybes +import GHC.Cmm.CLabel +import Util + +import Data.Time +import System.Directory + +import Trace.Hpc.Mix +import Trace.Hpc.Util + +import qualified Data.ByteString as BS +import Data.Map (Map) +import qualified Data.Map as Map + +{- +************************************************************************ +* * +* The main function: addTicksToBinds +* * +************************************************************************ +-} + +addTicksToBinds + :: HscEnv + -> Module + -> ModLocation -- ... off the current module + -> NameSet -- Exported Ids. When we call addTicksToBinds, + -- isExportedId doesn't work yet (the desugarer + -- hasn't set it), so we have to work from this set. + -> [TyCon] -- Type constructor in this module + -> LHsBinds GhcTc + -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks) + +addTicksToBinds hsc_env mod mod_loc exports tyCons binds + | let dflags = hsc_dflags hsc_env + passes = coveragePasses dflags, not (null passes), + Just orig_file <- ml_hs_file mod_loc, + not ("boot" `isSuffixOf` orig_file) = do + + let orig_file2 = guessSourceFile binds orig_file + + tickPass tickish (binds,st) = + let env = TTE + { fileName = mkFastString orig_file2 + , declPath = [] + , tte_dflags = dflags + , exports = exports + , inlines = emptyVarSet + , inScope = emptyVarSet + , blackList = Map.fromList + [ (getSrcSpan (tyConName tyCon),()) + | tyCon <- tyCons ] + , density = mkDensity tickish dflags + , this_mod = mod + , tickishType = tickish + } + (binds',_,st') = unTM (addTickLHsBinds binds) env st + in (binds', st') + + initState = TT { tickBoxCount = 0 + , mixEntries = [] + , ccIndices = newCostCentreState + } + + (binds1,st) = foldr tickPass (binds, initState) passes + + let tickCount = tickBoxCount st + entries = reverse $ mixEntries st + hashNo <- writeMixEntries dflags mod tickCount entries orig_file2 + modBreaks <- mkModBreaks hsc_env mod tickCount entries + + dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" FormatHaskell + (pprLHsBinds binds1) + + return (binds1, HpcInfo tickCount hashNo, Just modBreaks) + + | otherwise = return (binds, emptyHpcInfo False, Nothing) + +guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath +guessSourceFile binds orig_file = + -- Try look for a file generated from a .hsc file to a + -- .hs file, by peeking ahead. + let top_pos = catMaybes $ foldr (\ (L pos _) rest -> + srcSpanFileName_maybe pos : rest) [] binds + in + case top_pos of + (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name + -> unpackFS file_name + _ -> orig_file + + +mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks +mkModBreaks hsc_env mod count entries + | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do + breakArray <- GHCi.newBreakArray hsc_env (length entries) + ccs <- mkCCSArray hsc_env mod count entries + let + locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ] + varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ] + declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ] + return emptyModBreaks + { modBreaks_flags = breakArray + , modBreaks_locs = locsTicks + , modBreaks_vars = varsTicks + , modBreaks_decls = declsTicks + , modBreaks_ccs = ccs + } + | otherwise = return emptyModBreaks + +mkCCSArray + :: HscEnv -> Module -> Int -> [MixEntry_] + -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre)) +mkCCSArray hsc_env modul count entries = do + if interpreterProfiled dflags + then do + let module_str = moduleNameString (moduleName modul) + costcentres <- GHCi.mkCostCentres hsc_env module_str (map mk_one entries) + return (listArray (0,count-1) costcentres) + else do + return (listArray (0,-1) []) + where + dflags = hsc_dflags hsc_env + mk_one (srcspan, decl_path, _, _) = (name, src) + where name = concat (intersperse "." decl_path) + src = showSDoc dflags (ppr srcspan) + + +writeMixEntries + :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int +writeMixEntries dflags mod count entries filename + | not (gopt Opt_Hpc dflags) = return 0 + | otherwise = do + let + hpc_dir = hpcDir dflags + mod_name = moduleNameString (moduleName mod) + + hpc_mod_dir + | moduleUnitId mod == mainUnitId = hpc_dir + | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod) + + tabStop = 8 -- counts as a normal char in GHC's + -- location ranges. + + createDirectoryIfMissing True hpc_mod_dir + modTime <- getModificationUTCTime filename + let entries' = [ (hpcPos, box) + | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ] + when (entries' `lengthIsNot` count) $ do + panic "the number of .mix entries are inconsistent" + let hashNo = mixHash filename modTime tabStop entries' + mixCreate hpc_mod_dir mod_name + $ Mix filename modTime (toHash hashNo) tabStop entries' + return hashNo + + +-- ----------------------------------------------------------------------------- +-- TickDensity: where to insert ticks + +data TickDensity + = TickForCoverage -- for Hpc + | TickForBreakPoints -- for GHCi + | TickAllFunctions -- for -prof-auto-all + | TickTopFunctions -- for -prof-auto-top + | TickExportedFunctions -- for -prof-auto-exported + | TickCallSites -- for stack tracing + deriving Eq + +mkDensity :: TickishType -> DynFlags -> TickDensity +mkDensity tickish dflags = case tickish of + HpcTicks -> TickForCoverage + SourceNotes -> TickForCoverage + Breakpoints -> TickForBreakPoints + ProfNotes -> + case profAuto dflags of + ProfAutoAll -> TickAllFunctions + ProfAutoTop -> TickTopFunctions + ProfAutoExports -> TickExportedFunctions + ProfAutoCalls -> TickCallSites + _other -> panic "mkDensity" + +-- | Decide whether to add a tick to a binding or not. +shouldTickBind :: TickDensity + -> Bool -- top level? + -> Bool -- exported? + -> Bool -- simple pat bind? + -> Bool -- INLINE pragma? + -> Bool + +shouldTickBind density top_lev exported _simple_pat inline + = case density of + TickForBreakPoints -> False + -- we never add breakpoints to simple pattern bindings + -- (there's always a tick on the rhs anyway). + TickAllFunctions -> not inline + TickTopFunctions -> top_lev && not inline + TickExportedFunctions -> exported && not inline + TickForCoverage -> True + TickCallSites -> False + +shouldTickPatBind :: TickDensity -> Bool -> Bool +shouldTickPatBind density top_lev + = case density of + TickForBreakPoints -> False + TickAllFunctions -> True + TickTopFunctions -> top_lev + TickExportedFunctions -> False + TickForCoverage -> False + TickCallSites -> False + +-- ----------------------------------------------------------------------------- +-- Adding ticks to bindings + +addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc) +addTickLHsBinds = mapBagM addTickLHsBind + +addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) +addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, + abs_exports = abs_exports })) = do + withEnv add_exports $ do + withEnv add_inlines $ do + binds' <- addTickLHsBinds binds + return $ L pos $ bind { abs_binds = binds' } + where + -- in AbsBinds, the Id on each binding is not the actual top-level + -- Id that we are defining, they are related by the abs_exports + -- field of AbsBinds. So if we're doing TickExportedFunctions we need + -- to add the local Ids to the set of exported Names so that we know to + -- tick the right bindings. + add_exports env = + env{ exports = exports env `extendNameSetList` + [ idName mid + | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports + , idName pid `elemNameSet` (exports env) ] } + + -- See Note [inline sccs] + add_inlines env = + env{ inlines = inlines env `extendVarSetList` + [ mid + | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports + , isInlinePragma (idInlinePragma pid) ] } + +addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do + let name = getOccString id + decl_path <- getPathEntry + density <- getDensity + + inline_ids <- liftM inlines getEnv + -- See Note [inline sccs] + let inline = isInlinePragma (idInlinePragma id) + || id `elemVarSet` inline_ids + + -- See Note [inline sccs] + tickish <- tickishType `liftM` getEnv + if inline && tickish == ProfNotes then return (L pos funBind) else do + + (fvs, mg) <- + getFreeVars $ + addPathEntry name $ + addTickMatchGroup False (fun_matches funBind) + + case mg of + MG {} -> return () + _ -> panic "addTickLHsBind" + + blackListed <- isBlackListed pos + exported_names <- liftM exports getEnv + + -- We don't want to generate code for blacklisted positions + -- We don't want redundant ticks on simple pattern bindings + -- We don't want to tick non-exported bindings in TickExportedFunctions + let simple = isSimplePatBind funBind + toplev = null decl_path + exported = idName id `elemNameSet` exported_names + + tick <- if not blackListed && + shouldTickBind density toplev exported simple inline + then + bindTick density name pos fvs + else + return Nothing + + let mbCons = maybe Prelude.id (:) + return $ L pos $ funBind { fun_matches = mg + , fun_tick = tick `mbCons` fun_tick funBind } + + where + -- a binding is a simple pattern binding if it is a funbind with + -- zero patterns + isSimplePatBind :: HsBind GhcTc -> Bool + isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0 + +-- TODO: Revisit this +addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs + , pat_rhs = rhs }))) = do + + let simplePatId = isSimplePat lhs + + -- TODO: better name for rhs's for non-simple patterns? + let name = maybe "(...)" getOccString simplePatId + + (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs + let pat' = pat { pat_rhs = rhs'} + + -- Should create ticks here? + density <- getDensity + decl_path <- getPathEntry + let top_lev = null decl_path + if not (shouldTickPatBind density top_lev) + then return (L pos pat') + else do + + let mbCons = maybe id (:) + + let (initial_rhs_ticks, initial_patvar_tickss) = pat_ticks pat' + + -- Allocate the ticks + + rhs_tick <- bindTick density name pos fvs + let rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks + + patvar_tickss <- case simplePatId of + Just{} -> return initial_patvar_tickss + Nothing -> do + let patvars = map getOccString (collectPatBinders lhs) + patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars + return + (zipWith mbCons patvar_ticks + (initial_patvar_tickss ++ repeat [])) + + return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) } + +-- Only internal stuff, not from source, uses VarBind, so we ignore it. +addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind +addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind +addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind + +bindTick + :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id)) +bindTick density name pos fvs = do + decl_path <- getPathEntry + let + toplev = null decl_path + count_entries = toplev || density == TickAllFunctions + top_only = density /= TickAllFunctions + box_label = if toplev then TopLevelBox [name] + else LocalBox (decl_path ++ [name]) + -- + allocATickBox box_label count_entries top_only pos fvs + + +-- Note [inline sccs] +-- +-- The reason not to add ticks to INLINE functions is that this is +-- sometimes handy for avoiding adding a tick to a particular function +-- (see #6131) +-- +-- So for now we do not add any ticks to INLINE functions at all. +-- +-- We used to use isAnyInlinePragma to figure out whether to avoid adding +-- ticks for this purpose. However, #12962 indicates that this contradicts +-- the documentation on profiling (which only mentions INLINE pragmas). +-- So now we're more careful about what we avoid adding ticks to. + +-- ----------------------------------------------------------------------------- +-- Decorate an LHsExpr with ticks + +-- selectively add ticks to interesting expressions +addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExpr e@(L pos e0) = do + d <- getDensity + case d of + TickForBreakPoints | isGoodBreakExpr e0 -> tick_it + TickForCoverage -> tick_it + TickCallSites | isCallSite e0 -> tick_it + _other -> dont_tick_it + where + tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 + dont_tick_it = addTickLHsExprNever e + +-- Add a tick to an expression which is the RHS of an equation or a binding. +-- We always consider these to be breakpoints, unless the expression is a 'let' +-- (because the body will definitely have a tick somewhere). ToDo: perhaps +-- we should treat 'case' and 'if' the same way? +addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExprRHS e@(L pos e0) = do + d <- getDensity + case d of + TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it + | otherwise -> tick_it + TickForCoverage -> tick_it + TickCallSites | isCallSite e0 -> tick_it + _other -> dont_tick_it + where + tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 + dont_tick_it = addTickLHsExprNever e + +-- The inner expression of an evaluation context: +-- let binds in [], ( [] ) +-- we never tick these if we're doing HPC, but otherwise +-- we treat it like an ordinary expression. +addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExprEvalInner e = do + d <- getDensity + case d of + TickForCoverage -> addTickLHsExprNever e + _otherwise -> addTickLHsExpr e + +-- | A let body is treated differently from addTickLHsExprEvalInner +-- above with TickForBreakPoints, because for breakpoints we always +-- want to tick the body, even if it is not a redex. See test +-- break012. This gives the user the opportunity to inspect the +-- values of the let-bound variables. +addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExprLetBody e@(L pos e0) = do + d <- getDensity + case d of + TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it + | otherwise -> tick_it + _other -> addTickLHsExprEvalInner e + where + tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 + dont_tick_it = addTickLHsExprNever e + +-- version of addTick that does not actually add a tick, +-- because the scope of this tick is completely subsumed by +-- another. +addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExprNever (L pos e0) = do + e1 <- addTickHsExpr e0 + return $ L pos e1 + +-- general heuristic: expressions which do not denote values are good +-- break points +isGoodBreakExpr :: HsExpr GhcTc -> Bool +isGoodBreakExpr (HsApp {}) = True +isGoodBreakExpr (HsAppType {}) = True +isGoodBreakExpr (OpApp {}) = True +isGoodBreakExpr _other = False + +isCallSite :: HsExpr GhcTc -> Bool +isCallSite HsApp{} = True +isCallSite HsAppType{} = True +isCallSite OpApp{} = True +isCallSite _ = False + +addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExprOptAlt oneOfMany (L pos e0) + = ifDensity TickForCoverage + (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0) + (addTickLHsExpr (L pos e0)) + +addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addBinTickLHsExpr boxLabel (L pos e0) + = ifDensity TickForCoverage + (allocBinTickBox boxLabel pos $ addTickHsExpr e0) + (addTickLHsExpr (L pos e0)) + + +-- ----------------------------------------------------------------------------- +-- Decorate the body of an HsExpr with ticks. +-- (Whether to put a tick around the whole expression was already decided, +-- in the addTickLHsExpr family of functions.) + +addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) +addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e +addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" +addTickHsExpr e@(HsConLikeOut _ con) + | Just id <- conLikeWrapId_maybe con = do freeVar id; return e +addTickHsExpr e@(HsIPVar {}) = return e +addTickHsExpr e@(HsOverLit {}) = return e +addTickHsExpr e@(HsOverLabel{}) = return e +addTickHsExpr e@(HsLit {}) = return e +addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x) + (addTickMatchGroup True matchgroup) +addTickHsExpr (HsLamCase x mgs) = liftM (HsLamCase x) + (addTickMatchGroup True mgs) +addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1) + (addTickLHsExpr e2) +addTickHsExpr (HsAppType x e ty) = liftM3 HsAppType (return x) + (addTickLHsExprNever e) + (return ty) + +addTickHsExpr (OpApp fix e1 e2 e3) = + liftM4 OpApp + (return fix) + (addTickLHsExpr e1) + (addTickLHsExprNever e2) + (addTickLHsExpr e3) +addTickHsExpr (NegApp x e neg) = + liftM2 (NegApp x) + (addTickLHsExpr e) + (addTickSyntaxExpr hpcSrcSpan neg) +addTickHsExpr (HsPar x e) = + liftM (HsPar x) (addTickLHsExprEvalInner e) +addTickHsExpr (SectionL x e1 e2) = + liftM2 (SectionL x) + (addTickLHsExpr e1) + (addTickLHsExprNever e2) +addTickHsExpr (SectionR x e1 e2) = + liftM2 (SectionR x) + (addTickLHsExprNever e1) + (addTickLHsExpr e2) +addTickHsExpr (ExplicitTuple x es boxity) = + liftM2 (ExplicitTuple x) + (mapM addTickTupArg es) + (return boxity) +addTickHsExpr (ExplicitSum ty tag arity e) = do + e' <- addTickLHsExpr e + return (ExplicitSum ty tag arity e') +addTickHsExpr (HsCase x e mgs) = + liftM2 (HsCase x) + (addTickLHsExpr e) -- not an EvalInner; e might not necessarily + -- be evaluated. + (addTickMatchGroup False mgs) +addTickHsExpr (HsIf x cnd e1 e2 e3) = + liftM3 (HsIf x cnd) + (addBinTickLHsExpr (BinBox CondBinBox) e1) + (addTickLHsExprOptAlt True e2) + (addTickLHsExprOptAlt True e3) +addTickHsExpr (HsMultiIf ty alts) + = do { let isOneOfMany = case alts of [_] -> False; _ -> True + ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts + ; return $ HsMultiIf ty alts' } +addTickHsExpr (HsLet x (L l binds) e) = + bindLocals (collectLocalBinders binds) $ + liftM2 (HsLet x . L l) + (addTickHsLocalBinds binds) -- to think about: !patterns. + (addTickLHsExprLetBody e) +addTickHsExpr (HsDo srcloc cxt (L l stmts)) + = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) + ; return (HsDo srcloc cxt (L l stmts')) } + where + forQual = case cxt of + ListComp -> Just $ BinBox QualBinBox + _ -> Nothing +addTickHsExpr (ExplicitList ty wit es) = + liftM3 ExplicitList + (return ty) + (addTickWit wit) + (mapM (addTickLHsExpr) es) + where addTickWit Nothing = return Nothing + addTickWit (Just fln) + = do fln' <- addTickSyntaxExpr hpcSrcSpan fln + return (Just fln') + +addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e + +addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds }) + = do { rec_binds' <- addTickHsRecordBinds rec_binds + ; return (expr { rcon_flds = rec_binds' }) } + +addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds }) + = do { e' <- addTickLHsExpr e + ; flds' <- mapM addTickHsRecField flds + ; return (expr { rupd_expr = e', rupd_flds = flds' }) } + +addTickHsExpr (ExprWithTySig x e ty) = + liftM3 ExprWithTySig + (return x) + (addTickLHsExprNever e) -- No need to tick the inner expression + -- for expressions with signatures + (return ty) +addTickHsExpr (ArithSeq ty wit arith_seq) = + liftM3 ArithSeq + (return ty) + (addTickWit wit) + (addTickArithSeqInfo arith_seq) + where addTickWit Nothing = return Nothing + addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl + return (Just fl') + +-- We might encounter existing ticks (multiple Coverage passes) +addTickHsExpr (HsTick x t e) = + liftM (HsTick x t) (addTickLHsExprNever e) +addTickHsExpr (HsBinTick x t0 t1 e) = + liftM (HsBinTick x t0 t1) (addTickLHsExprNever e) + +addTickHsExpr (HsPragE _ HsPragTick{} (L pos e0)) = do + e2 <- allocTickBox (ExpBox False) False False pos $ + addTickHsExpr e0 + return $ unLoc e2 +addTickHsExpr (HsPragE x p e) = + liftM (HsPragE x p) (addTickLHsExpr e) +addTickHsExpr e@(HsBracket {}) = return e +addTickHsExpr e@(HsTcBracketOut {}) = return e +addTickHsExpr e@(HsRnBracketOut {}) = return e +addTickHsExpr e@(HsSpliceE {}) = return e +addTickHsExpr (HsProc x pat cmdtop) = + liftM2 (HsProc x) + (addTickLPat pat) + (liftL (addTickHsCmdTop) cmdtop) +addTickHsExpr (XExpr (HsWrap w e)) = + liftM XExpr $ + liftM (HsWrap w) + (addTickHsExpr e) -- Explicitly no tick on inside + +-- Others should never happen in expression content. +addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) + +addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc) +addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e + ; return (L l (Present x e')) } +addTickTupArg (L l (Missing ty)) = return (L l (Missing ty)) +addTickTupArg (L _ (XTupArg nec)) = noExtCon nec + + +addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc) + -> TM (MatchGroup GhcTc (LHsExpr GhcTc)) +addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do + let isOneOfMany = matchesOneOfMany matches + matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches + return $ mg { mg_alts = L l matches' } +addTickMatchGroup _ (XMatchGroup nec) = noExtCon nec + +addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc) + -> TM (Match GhcTc (LHsExpr GhcTc)) +addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats + , m_grhss = gRHSs }) = + bindLocals (collectPatsBinders pats) $ do + gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs + return $ match { m_grhss = gRHSs' } +addTickMatch _ _ (XMatch nec) = noExtCon nec + +addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) + -> TM (GRHSs GhcTc (LHsExpr GhcTc)) +addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do + bindLocals binders $ do + local_binds' <- addTickHsLocalBinds local_binds + guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded + return $ GRHSs x guarded' (L l local_binds') + where + binders = collectLocalBinders local_binds +addTickGRHSs _ _ (XGRHSs nec) = noExtCon nec + +addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc) + -> TM (GRHS GhcTc (LHsExpr GhcTc)) +addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do + (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts + (addTickGRHSBody isOneOfMany isLambda expr) + return $ GRHS x stmts' expr' +addTickGRHS _ _ (XGRHS nec) = noExtCon nec + +addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do + d <- getDensity + case d of + TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr + TickAllFunctions | isLambda -> + addPathEntry "\\" $ + allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $ + addTickHsExpr e0 + _otherwise -> + addTickLHsExprRHS expr + +addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] + -> TM [ExprLStmt GhcTc] +addTickLStmts isGuard stmts = do + (stmts, _) <- addTickLStmts' isGuard stmts (return ()) + return stmts + +addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a + -> TM ([ExprLStmt GhcTc], a) +addTickLStmts' isGuard lstmts res + = bindLocals (collectLStmtsBinders lstmts) $ + do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts + ; a <- res + ; return (lstmts', a) } + +addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc) + -> TM (Stmt GhcTc (LHsExpr GhcTc)) +addTickStmt _isGuard (LastStmt x e noret ret) = do + liftM3 (LastStmt x) + (addTickLHsExpr e) + (pure noret) + (addTickSyntaxExpr hpcSrcSpan ret) +addTickStmt _isGuard (BindStmt x pat e bind fail) = do + liftM4 (BindStmt x) + (addTickLPat pat) + (addTickLHsExprRHS e) + (addTickSyntaxExpr hpcSrcSpan bind) + (addTickSyntaxExpr hpcSrcSpan fail) +addTickStmt isGuard (BodyStmt x e bind' guard') = do + liftM3 (BodyStmt x) + (addTick isGuard e) + (addTickSyntaxExpr hpcSrcSpan bind') + (addTickSyntaxExpr hpcSrcSpan guard') +addTickStmt _isGuard (LetStmt x (L l binds)) = do + liftM (LetStmt x . L l) + (addTickHsLocalBinds binds) +addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do + liftM3 (ParStmt x) + (mapM (addTickStmtAndBinders isGuard) pairs) + (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr)) + (addTickSyntaxExpr hpcSrcSpan bindExpr) +addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do + args' <- mapM (addTickApplicativeArg isGuard) args + return (ApplicativeStmt body_ty args' mb_join) + +addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts + , trS_by = by, trS_using = using + , trS_ret = returnExpr, trS_bind = bindExpr + , trS_fmap = liftMExpr }) = do + t_s <- addTickLStmts isGuard stmts + t_y <- fmapMaybeM addTickLHsExprRHS by + t_u <- addTickLHsExprRHS using + t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr + t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr + t_m <- fmap unLoc (addTickLHsExpr (L hpcSrcSpan liftMExpr)) + return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u + , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m } + +addTickStmt isGuard stmt@(RecStmt {}) + = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt) + ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) + ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) + ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) + ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' + , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } + +addTickStmt _ (XStmtLR nec) = noExtCon nec + +addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e + | otherwise = addTickLHsExprRHS e + +addTickApplicativeArg + :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) + -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc) +addTickApplicativeArg isGuard (op, arg) = + liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) + where + addTickArg (ApplicativeArgOne x pat expr isBody fail) = + (ApplicativeArgOne x) + <$> addTickLPat pat + <*> addTickLHsExpr expr + <*> pure isBody + <*> addTickSyntaxExpr hpcSrcSpan fail + addTickArg (ApplicativeArgMany x stmts ret pat) = + (ApplicativeArgMany x) + <$> addTickLStmts isGuard stmts + <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret)) + <*> addTickLPat pat + addTickArg (XApplicativeArg nec) = noExtCon nec + +addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc + -> TM (ParStmtBlock GhcTc GhcTc) +addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) = + liftM3 (ParStmtBlock x) + (addTickLStmts isGuard stmts) + (return ids) + (addTickSyntaxExpr hpcSrcSpan returnExpr) +addTickStmtAndBinders _ (XParStmtBlock nec) = noExtCon nec + +addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc) +addTickHsLocalBinds (HsValBinds x binds) = + liftM (HsValBinds x) + (addTickHsValBinds binds) +addTickHsLocalBinds (HsIPBinds x binds) = + liftM (HsIPBinds x) + (addTickHsIPBinds binds) +addTickHsLocalBinds (EmptyLocalBinds x) = return (EmptyLocalBinds x) +addTickHsLocalBinds (XHsLocalBindsLR x) = return (XHsLocalBindsLR x) + +addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a) + -> TM (HsValBindsLR GhcTc (GhcPass b)) +addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do + b <- liftM2 NValBinds + (mapM (\ (rec,binds') -> + liftM2 (,) + (return rec) + (addTickLHsBinds binds')) + binds) + (return sigs) + return $ XValBindsLR b +addTickHsValBinds _ = panic "addTickHsValBinds" + +addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc) +addTickHsIPBinds (IPBinds dictbinds ipbinds) = + liftM2 IPBinds + (return dictbinds) + (mapM (liftL (addTickIPBind)) ipbinds) +addTickHsIPBinds (XHsIPBinds x) = return (XHsIPBinds x) + +addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc) +addTickIPBind (IPBind x nm e) = + liftM2 (IPBind x) + (return nm) + (addTickLHsExpr e) +addTickIPBind (XIPBind x) = return (XIPBind x) + +-- There is no location here, so we might need to use a context location?? +addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) +addTickSyntaxExpr pos syn@(SyntaxExprTc { syn_expr = x }) = do + x' <- fmap unLoc (addTickLHsExpr (L pos x)) + return $ syn { syn_expr = x' } +addTickSyntaxExpr _ NoSyntaxExprTc = return NoSyntaxExprTc + +-- we do not walk into patterns. +addTickLPat :: LPat GhcTc -> TM (LPat GhcTc) +addTickLPat pat = return pat + +addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc) +addTickHsCmdTop (HsCmdTop x cmd) = + liftM2 HsCmdTop + (return x) + (addTickLHsCmd cmd) +addTickHsCmdTop (XCmdTop nec) = noExtCon nec + +addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc) +addTickLHsCmd (L pos c0) = do + c1 <- addTickHsCmd c0 + return $ L pos c1 + +addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc) +addTickHsCmd (HsCmdLam x matchgroup) = + liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup) +addTickHsCmd (HsCmdApp x c e) = + liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e) +{- +addTickHsCmd (OpApp e1 c2 fix c3) = + liftM4 OpApp + (addTickLHsExpr e1) + (addTickLHsCmd c2) + (return fix) + (addTickLHsCmd c3) +-} +addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e) +addTickHsCmd (HsCmdCase x e mgs) = + liftM2 (HsCmdCase x) + (addTickLHsExpr e) + (addTickCmdMatchGroup mgs) +addTickHsCmd (HsCmdIf x cnd e1 c2 c3) = + liftM3 (HsCmdIf x cnd) + (addBinTickLHsExpr (BinBox CondBinBox) e1) + (addTickLHsCmd c2) + (addTickLHsCmd c3) +addTickHsCmd (HsCmdLet x (L l binds) c) = + bindLocals (collectLocalBinders binds) $ + liftM2 (HsCmdLet x . L l) + (addTickHsLocalBinds binds) -- to think about: !patterns. + (addTickLHsCmd c) +addTickHsCmd (HsCmdDo srcloc (L l stmts)) + = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) + ; return (HsCmdDo srcloc (L l stmts')) } + +addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) = + liftM5 HsCmdArrApp + (return arr_ty) + (addTickLHsExpr e1) + (addTickLHsExpr e2) + (return ty1) + (return lr) +addTickHsCmd (HsCmdArrForm x e f fix cmdtop) = + liftM4 (HsCmdArrForm x) + (addTickLHsExpr e) + (return f) + (return fix) + (mapM (liftL (addTickHsCmdTop)) cmdtop) + +addTickHsCmd (XCmd (HsWrap w cmd)) = + liftM XCmd $ + liftM (HsWrap w) (addTickHsCmd cmd) + +-- Others should never happen in a command context. +--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) + +addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc) + -> TM (MatchGroup GhcTc (LHsCmd GhcTc)) +addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do + matches' <- mapM (liftL addTickCmdMatch) matches + return $ mg { mg_alts = L l matches' } +addTickCmdMatchGroup (XMatchGroup nec) = noExtCon nec + +addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) +addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) = + bindLocals (collectPatsBinders pats) $ do + gRHSs' <- addTickCmdGRHSs gRHSs + return $ match { m_grhss = gRHSs' } +addTickCmdMatch (XMatch nec) = noExtCon nec + +addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) +addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do + bindLocals binders $ do + local_binds' <- addTickHsLocalBinds local_binds + guarded' <- mapM (liftL addTickCmdGRHS) guarded + return $ GRHSs x guarded' (L l local_binds') + where + binders = collectLocalBinders local_binds +addTickCmdGRHSs (XGRHSs nec) = noExtCon nec + +addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)) +-- The *guards* are *not* Cmds, although the body is +-- C.f. addTickGRHS for the BinBox stuff +addTickCmdGRHS (GRHS x stmts cmd) + = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) + stmts (addTickLHsCmd cmd) + ; return $ GRHS x stmts' expr' } +addTickCmdGRHS (XGRHS nec) = noExtCon nec + +addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)] + -> TM [LStmt GhcTc (LHsCmd GhcTc)] +addTickLCmdStmts stmts = do + (stmts, _) <- addTickLCmdStmts' stmts (return ()) + return stmts + +addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a + -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a) +addTickLCmdStmts' lstmts res + = bindLocals binders $ do + lstmts' <- mapM (liftL addTickCmdStmt) lstmts + a <- res + return (lstmts', a) + where + binders = collectLStmtsBinders lstmts + +addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc)) +addTickCmdStmt (BindStmt x pat c bind fail) = do + liftM4 (BindStmt x) + (addTickLPat pat) + (addTickLHsCmd c) + (return bind) + (return fail) +addTickCmdStmt (LastStmt x c noret ret) = do + liftM3 (LastStmt x) + (addTickLHsCmd c) + (pure noret) + (addTickSyntaxExpr hpcSrcSpan ret) +addTickCmdStmt (BodyStmt x c bind' guard') = do + liftM3 (BodyStmt x) + (addTickLHsCmd c) + (addTickSyntaxExpr hpcSrcSpan bind') + (addTickSyntaxExpr hpcSrcSpan guard') +addTickCmdStmt (LetStmt x (L l binds)) = do + liftM (LetStmt x . L l) + (addTickHsLocalBinds binds) +addTickCmdStmt stmt@(RecStmt {}) + = do { stmts' <- addTickLCmdStmts (recS_stmts stmt) + ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) + ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) + ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) + ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' + , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } +addTickCmdStmt ApplicativeStmt{} = + panic "ToDo: addTickCmdStmt ApplicativeLastStmt" +addTickCmdStmt (XStmtLR nec) = + noExtCon nec + +-- Others should never happen in a command context. +addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt) + +addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc) +addTickHsRecordBinds (HsRecFields fields dd) + = do { fields' <- mapM addTickHsRecField fields + ; return (HsRecFields fields' dd) } + +addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc) + -> TM (LHsRecField' id (LHsExpr GhcTc)) +addTickHsRecField (L l (HsRecField id expr pun)) + = do { expr' <- addTickLHsExpr expr + ; return (L l (HsRecField id expr' pun)) } + + +addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc) +addTickArithSeqInfo (From e1) = + liftM From + (addTickLHsExpr e1) +addTickArithSeqInfo (FromThen e1 e2) = + liftM2 FromThen + (addTickLHsExpr e1) + (addTickLHsExpr e2) +addTickArithSeqInfo (FromTo e1 e2) = + liftM2 FromTo + (addTickLHsExpr e1) + (addTickLHsExpr e2) +addTickArithSeqInfo (FromThenTo e1 e2 e3) = + liftM3 FromThenTo + (addTickLHsExpr e1) + (addTickLHsExpr e2) + (addTickLHsExpr e3) + +data TickTransState = TT { tickBoxCount:: Int + , mixEntries :: [MixEntry_] + , ccIndices :: CostCentreState + } + +data TickTransEnv = TTE { fileName :: FastString + , density :: TickDensity + , tte_dflags :: DynFlags + , exports :: NameSet + , inlines :: VarSet + , declPath :: [String] + , inScope :: VarSet + , blackList :: Map SrcSpan () + , this_mod :: Module + , tickishType :: TickishType + } + +-- deriving Show + +data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes + deriving (Eq) + +coveragePasses :: DynFlags -> [TickishType] +coveragePasses dflags = + ifa (hscTarget dflags == HscInterpreted) Breakpoints $ + ifa (gopt Opt_Hpc dflags) HpcTicks $ + ifa (gopt Opt_SccProfilingOn dflags && + profAuto dflags /= NoProfAuto) ProfNotes $ + ifa (debugLevel dflags > 0) SourceNotes [] + where ifa f x xs | f = x:xs + | otherwise = xs + +-- | Tickishs that only make sense when their source code location +-- refers to the current file. This might not always be true due to +-- LINE pragmas in the code - which would confuse at least HPC. +tickSameFileOnly :: TickishType -> Bool +tickSameFileOnly HpcTicks = True +tickSameFileOnly _other = False + +type FreeVars = OccEnv Id +noFVs :: FreeVars +noFVs = emptyOccEnv + +-- Note [freevars] +-- For breakpoints we want to collect the free variables of an +-- expression for pinning on the HsTick. We don't want to collect +-- *all* free variables though: in particular there's no point pinning +-- on free variables that are will otherwise be in scope at the GHCi +-- prompt, which means all top-level bindings. Unfortunately detecting +-- top-level bindings isn't easy (collectHsBindsBinders on the top-level +-- bindings doesn't do it), so we keep track of a set of "in-scope" +-- variables in addition to the free variables, and the former is used +-- to filter additions to the latter. This gives us complete control +-- over what free variables we track. + +newtype TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) } + deriving (Functor) + -- a combination of a state monad (TickTransState) and a writer + -- monad (FreeVars). + +instance Applicative TM where + pure a = TM $ \ _env st -> (a,noFVs,st) + (<*>) = ap + +instance Monad TM where + (TM m) >>= k = TM $ \ env st -> + case m env st of + (r1,fv1,st1) -> + case unTM (k r1) env st1 of + (r2,fv2,st2) -> + (r2, fv1 `plusOccEnv` fv2, st2) + +instance HasDynFlags TM where + getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st) + +-- | Get the next HPC cost centre index for a given centre name +getCCIndexM :: FastString -> TM CostCentreIndex +getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $ + ccIndices st + in (idx, noFVs, st { ccIndices = is' }) + +getState :: TM TickTransState +getState = TM $ \ _ st -> (st, noFVs, st) + +setState :: (TickTransState -> TickTransState) -> TM () +setState f = TM $ \ _ st -> ((), noFVs, f st) + +getEnv :: TM TickTransEnv +getEnv = TM $ \ env st -> (env, noFVs, st) + +withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a +withEnv f (TM m) = TM $ \ env st -> + case m (f env) st of + (a, fvs, st') -> (a, fvs, st') + +getDensity :: TM TickDensity +getDensity = TM $ \env st -> (density env, noFVs, st) + +ifDensity :: TickDensity -> TM a -> TM a -> TM a +ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el + +getFreeVars :: TM a -> TM (FreeVars, a) +getFreeVars (TM m) + = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st') + +freeVar :: Id -> TM () +freeVar id = TM $ \ env st -> + if id `elemVarSet` inScope env + then ((), unitOccEnv (nameOccName (idName id)) id, st) + else ((), noFVs, st) + +addPathEntry :: String -> TM a -> TM a +addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] }) + +getPathEntry :: TM [String] +getPathEntry = declPath `liftM` getEnv + +getFileName :: TM FastString +getFileName = fileName `liftM` getEnv + +isGoodSrcSpan' :: SrcSpan -> Bool +isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos +isGoodSrcSpan' (UnhelpfulSpan _) = False + +isGoodTickSrcSpan :: SrcSpan -> TM Bool +isGoodTickSrcSpan pos = do + file_name <- getFileName + tickish <- tickishType `liftM` getEnv + let need_same_file = tickSameFileOnly tickish + same_file = Just file_name == srcSpanFileName_maybe pos + return (isGoodSrcSpan' pos && (not need_same_file || same_file)) + +ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a +ifGoodTickSrcSpan pos then_code else_code = do + good <- isGoodTickSrcSpan pos + if good then then_code else else_code + +bindLocals :: [Id] -> TM a -> TM a +bindLocals new_ids (TM m) + = TM $ \ env st -> + case m env{ inScope = inScope env `extendVarSetList` new_ids } st of + (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st') + where occs = [ nameOccName (idName id) | id <- new_ids ] + +isBlackListed :: SrcSpan -> TM Bool +isBlackListed pos = TM $ \ env st -> + case Map.lookup pos (blackList env) of + Nothing -> (False,noFVs,st) + Just () -> (True,noFVs,st) + +-- the tick application inherits the source position of its +-- expression argument to support nested box allocations +allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc) + -> TM (LHsExpr GhcTc) +allocTickBox boxLabel countEntries topOnly pos m = + ifGoodTickSrcSpan pos (do + (fvs, e) <- getFreeVars m + env <- getEnv + tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) + return (L pos (HsTick noExtField tickish (L pos e))) + ) (do + e <- m + return (L pos e) + ) + +-- 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)) +allocATickBox boxLabel countEntries topOnly pos fvs = + ifGoodTickSrcSpan pos (do + let + mydecl_path = case boxLabel of + TopLevelBox x -> x + LocalBox xs -> xs + _ -> panic "allocATickBox" + tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path + return (Just tickish) + ) (return Nothing) + + +mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String] + -> TM (Tickish Id) +mkTickish boxLabel countEntries topOnly pos fvs decl_path = do + + let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs + -- unlifted types cause two problems here: + -- * we can't bind them at the GHCi prompt + -- (bindLocalsAtBreakpoint already filters them out), + -- * the simplifier might try to substitute a literal for + -- the Id, and we can't handle that. + + me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel) + + cc_name | topOnly = head decl_path + | otherwise = concat (intersperse "." decl_path) + + dflags <- getDynFlags + env <- getEnv + case tickishType env of + HpcTicks -> do + c <- liftM tickBoxCount getState + setState $ \st -> st { tickBoxCount = c + 1 + , mixEntries = me : mixEntries st } + return $ HpcTick (this_mod env) c + + ProfNotes -> do + let nm = mkFastString cc_name + flavour <- HpcCC <$> getCCIndexM nm + let cc = mkUserCC nm (this_mod env) pos flavour + count = countEntries && gopt Opt_ProfCountEntries dflags + return $ ProfNote cc count True{-scopes-} + + Breakpoints -> do + c <- liftM tickBoxCount getState + setState $ \st -> st { tickBoxCount = c + 1 + , mixEntries = me:mixEntries st } + return $ Breakpoint c ids + + SourceNotes | RealSrcSpan pos' <- pos -> + return $ SourceNote pos' cc_name + + _otherwise -> panic "mkTickish: bad source span!" + + +allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc) + -> TM (LHsExpr GhcTc) +allocBinTickBox boxLabel pos m = do + env <- getEnv + case tickishType env of + HpcTicks -> do e <- liftM (L pos) m + ifGoodTickSrcSpan pos + (mkBinTickBoxHpc boxLabel pos e) + (return e) + _other -> allocTickBox (ExpBox False) False False pos m + +mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc + -> TM (LHsExpr GhcTc) +mkBinTickBoxHpc boxLabel pos e = + TM $ \ env st -> + let meT = (pos,declPath env, [],boxLabel True) + meF = (pos,declPath env, [],boxLabel False) + meE = (pos,declPath env, [],ExpBox False) + c = tickBoxCount st + mes = mixEntries st + in + ( L pos $ HsTick noExtField (HpcTick (this_mod env) c) + $ L pos $ HsBinTick noExtField (c+1) (c+2) e + -- notice that F and T are reversed, + -- because we are building the list in + -- reverse... + , noFVs + , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes} + ) + +mkHpcPos :: SrcSpan -> HpcPos +mkHpcPos pos@(RealSrcSpan s) + | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s, + srcSpanStartCol s, + srcSpanEndLine s, + srcSpanEndCol s - 1) + -- the end column of a SrcSpan is one + -- greater than the last column of the + -- span (see SrcLoc), whereas HPC + -- expects to the column range to be + -- inclusive, hence we subtract one above. +mkHpcPos _ = panic "bad source span; expected such spans to be filtered out" + +hpcSrcSpan :: SrcSpan +hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") + +matchesOneOfMany :: [LMatch GhcTc body] -> Bool +matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 + where + matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ })) + = length grhss + matchCount (L _ (Match { m_grhss = XGRHSs nec })) + = noExtCon nec + matchCount (L _ (XMatch nec)) = noExtCon nec + +type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) + +-- For the hash value, we hash everything: the file name, +-- the timestamp of the original source file, the tab stop, +-- and the mix entries. We cheat, and hash the show'd string. +-- This hash only has to be hashed at Mix creation time, +-- and is for sanity checking only. + +mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int +mixHash file tm tabstop entries = fromIntegral $ hashString + (show $ Mix file tm 0 tabstop entries) + +{- +************************************************************************ +* * +* initialisation +* * +************************************************************************ + +Each module compiled with -fhpc declares an initialisation function of +the form `hpc_init_()`, which is emitted into the _stub.c file +and annotated with __attribute__((constructor)) so that it gets +executed at startup time. + +The function's purpose is to call hs_hpc_module to register this +module with the RTS, and it looks something like this: + +static void hpc_init_Main(void) __attribute__((constructor)); +static void hpc_init_Main(void) +{extern StgWord64 _hpc_tickboxes_Main_hpc[]; + hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);} +-} + +hpcInitCode :: Module -> HpcInfo -> SDoc +hpcInitCode _ (NoHpcInfo {}) = Outputable.empty +hpcInitCode this_mod (HpcInfo tickCount hashNo) + = vcat + [ text "static void hpc_init_" <> ppr this_mod + <> text "(void) __attribute__((constructor));" + , text "static void hpc_init_" <> ppr this_mod <> text "(void)" + , braces (vcat [ + text "extern StgWord64 " <> tickboxes <> + text "[]" <> semi, + text "hs_hpc_module" <> + parens (hcat (punctuate comma [ + doubleQuotes full_name_str, + int tickCount, -- really StgWord32 + int hashNo, -- really StgWord32 + tickboxes + ])) <> semi + ]) + ] + where + tickboxes = ppr (mkHpcTicksLabel $ this_mod) + + module_name = hcat (map (text.charToC) $ BS.unpack $ + bytesFS (moduleNameFS (Module.moduleName this_mod))) + package_name = hcat (map (text.charToC) $ BS.unpack $ + bytesFS (unitIdFS (moduleUnitId this_mod))) + full_name_str + | moduleUnitId this_mod == mainUnitId + = module_name + | otherwise + = package_name <> char '/' <> module_name diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs new file mode 100644 index 0000000000..e08b46729e --- /dev/null +++ b/compiler/GHC/HsToCore/Docs.hs @@ -0,0 +1,360 @@ +-- | Extract docs from the renamer output so they can be be serialized. +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.HsToCore.Docs (extractDocs) where + +import GhcPrelude +import Bag +import GHC.Hs.Binds +import GHC.Hs.Doc +import GHC.Hs.Decls +import GHC.Hs.Extension +import GHC.Hs.Types +import GHC.Hs.Utils +import Name +import NameSet +import SrcLoc +import TcRnTypes + +import Control.Applicative +import Data.Bifunctor (first) +import Data.List +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Semigroup + +-- | Extract docs from renamer output. +extractDocs :: TcGblEnv + -> (Maybe HsDocString, DeclDocMap, ArgDocMap) + -- ^ + -- 1. Module header + -- 2. Docs on top level declarations + -- 3. Docs on arguments +extractDocs TcGblEnv { tcg_semantic_mod = mod + , tcg_rn_decls = mb_rn_decls + , tcg_insts = insts + , tcg_fam_insts = fam_insts + , tcg_doc_hdr = mb_doc_hdr + } = + (unLoc <$> mb_doc_hdr, DeclDocMap doc_map, ArgDocMap arg_map) + where + (doc_map, arg_map) = maybe (M.empty, M.empty) + (mkMaps local_insts) + mb_decls_with_docs + mb_decls_with_docs = topDecls <$> mb_rn_decls + local_insts = filter (nameIsLocalOrFrom mod) + $ map getName insts ++ map getName fam_insts + +-- | Create decl and arg doc-maps by looping through the declarations. +-- For each declaration, find its names, its subordinates, and its doc strings. +mkMaps :: [Name] + -> [(LHsDecl GhcRn, [HsDocString])] + -> (Map Name (HsDocString), Map Name (Map Int (HsDocString))) +mkMaps instances decls = + ( f' (map (nubByName fst) decls') + , f (filterMapping (not . M.null) args) + ) + where + (decls', args) = unzip (map mappings decls) + + f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b + f = M.fromListWith (<>) . concat + + f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString + f' = M.fromListWith appendDocs . concat + + filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]] + filterMapping p = map (filter (p . snd)) + + mappings :: (LHsDecl GhcRn, [HsDocString]) + -> ( [(Name, HsDocString)] + , [(Name, Map Int (HsDocString))] + ) + mappings (L l decl, docStrs) = + (dm, am) + where + doc = concatDocs docStrs + args = declTypeDocs decl + + subs :: [(Name, [(HsDocString)], Map Int (HsDocString))] + subs = subordinates instanceMap decl + + (subDocs, subArgs) = + unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs) + + ns = names l decl + subNs = [ n | (n, _, _) <- subs ] + dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs] + am = [(n, args) | n <- ns] ++ zip subNs subArgs + + instanceMap :: Map SrcSpan Name + instanceMap = M.fromList [(getSrcSpan n, n) | n <- instances] + + names :: SrcSpan -> HsDecl GhcRn -> [Name] + names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See + -- Note [1]. + where loc = case d of + TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only + -- for TFs + _ -> getInstLoc d + names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1]. + names _ decl = getMainDeclBinder decl + +{- +Note [1]: +--------- +We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried +inside them. That should work for normal user-written instances (from +looking at GHC sources). We can assume that commented instances are +user-written. This lets us relate Names (from ClsInsts) to comments +(associated with InstDecls and DerivDecls). +-} + +getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)] +getMainDeclBinder (TyClD _ d) = [tcdName d] +getMainDeclBinder (ValD _ d) = + case collectHsBindBinders d of + [] -> [] + (name:_) -> [name] +getMainDeclBinder (SigD _ d) = sigNameNoLoc d +getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name] +getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = [] +getMainDeclBinder _ = [] + +sigNameNoLoc :: Sig pass -> [IdP pass] +sigNameNoLoc (TypeSig _ ns _) = map unLoc ns +sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns +sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns +sigNameNoLoc (SpecSig _ n _ _) = [unLoc n] +sigNameNoLoc (InlineSig _ n _) = [unLoc n] +sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns +sigNameNoLoc _ = [] + +-- Extract the source location where an instance is defined. This is used +-- to correlate InstDecls with their Instance/CoAxiom Names, via the +-- instanceMap. +getInstLoc :: InstDecl (GhcPass p) -> SrcSpan +getInstLoc = \case + ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty) + DataFamInstD _ (DataFamInstDecl + { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l + TyFamInstD _ (TyFamInstDecl + -- Since CoAxioms' Names refer to the whole line for type family instances + -- in particular, we need to dig a bit deeper to pull out the entire + -- equation. This does not happen for data family instances, for some + -- reason. + { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}}) -> l + ClsInstD _ (XClsInstDecl _) -> error "getInstLoc" + DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" + TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" + XInstDecl _ -> error "getInstLoc" + DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc" + TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc" + +-- | Get all subordinate declarations inside a declaration, and their docs. +-- A subordinate declaration is something like the associate type or data +-- family of a type class. +subordinates :: Map SrcSpan Name + -> HsDecl GhcRn + -> [(Name, [(HsDocString)], Map Int (HsDocString))] +subordinates instMap decl = case decl of + InstD _ (ClsInstD _ d) -> do + DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_tycon = L l _ + , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d + [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn + + InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d }))) + -> dataSubs (feqn_rhs d) + TyClD _ d | isClassDecl d -> classSubs d + | isDataDecl d -> dataSubs (tcdDataDefn d) + _ -> [] + where + classSubs dd = [ (name, doc, declTypeDocs d) + | (L _ d, doc) <- classDecls dd + , name <- getMainDeclBinder d, not (isValD d) + ] + dataSubs :: HsDataDefn GhcRn + -> [(Name, [HsDocString], Map Int (HsDocString))] + dataSubs dd = constrs ++ fields ++ derivs + where + cons = map unLoc $ (dd_cons dd) + constrs = [ ( unLoc cname + , maybeToList $ fmap unLoc $ con_doc c + , conArgDocs c) + | c <- cons, cname <- getConNames c ] + fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty) + | RecCon flds <- map getConArgs cons + , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds) + , (L _ n) <- ns ] + derivs = [ (instName, [unLoc doc], M.empty) + | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $ + concatMap (unLoc . deriv_clause_tys . unLoc) $ + unLoc $ dd_derivs dd + , Just instName <- [M.lookup l instMap] ] + + extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString) + extract_deriv_ty (L l ty) = + case ty of + -- deriving (forall a. C a {- ^ Doc comment -}) + HsForAllTy{ hst_fvf = ForallInvis + , hst_body = L _ (HsDocTy _ _ doc) } + -> Just (l, doc) + -- deriving (C a {- ^ Doc comment -}) + HsDocTy _ _ doc -> Just (l, doc) + _ -> Nothing + +-- | Extract constructor argument docs from inside constructor decls. +conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString) +conArgDocs con = case getConArgs con of + PrefixCon args -> go 0 (map unLoc args ++ ret) + InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret) + RecCon _ -> go 1 ret + where + go n = M.fromList . catMaybes . zipWith f [n..] + where + f n (HsDocTy _ _ lds) = Just (n, unLoc lds) + f _ _ = Nothing + + ret = case con of + ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ] + _ -> [] + +isValD :: HsDecl a -> Bool +isValD (ValD _ _) = True +isValD _ = False + +-- | All the sub declarations of a class (that we handle), ordered by +-- source location, with documentation attached if it exists. +classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] +classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls + where + decls = docs ++ defs ++ sigs ++ ats + docs = mkDecls tcdDocs (DocD noExtField) class_ + defs = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_ + sigs = mkDecls tcdSigs (SigD noExtField) class_ + ats = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_ + +-- | Extract function argument docs from inside top-level decls. +declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString) +declTypeDocs = \case + SigD _ (TypeSig _ _ ty) -> typeDocs (unLoc (hsSigWcType ty)) + SigD _ (ClassOpSig _ _ _ ty) -> typeDocs (unLoc (hsSigType ty)) + SigD _ (PatSynSig _ _ ty) -> typeDocs (unLoc (hsSigType ty)) + ForD _ (ForeignImport _ _ ty _) -> typeDocs (unLoc (hsSigType ty)) + TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty) + _ -> M.empty + +nubByName :: (a -> Name) -> [a] -> [a] +nubByName f ns = go emptyNameSet ns + where + go _ [] = [] + go s (x:xs) + | y `elemNameSet` s = go s xs + | otherwise = let s' = extendNameSet s y + in x : go s' xs + where + y = f x + +-- | Extract function argument docs from inside types. +typeDocs :: HsType GhcRn -> Map Int (HsDocString) +typeDocs = go 0 + where + go n = \case + HsForAllTy { hst_body = ty } -> go n (unLoc ty) + HsQualTy { hst_body = ty } -> go n (unLoc ty) + HsFunTy _ (unLoc->HsDocTy _ _ x) ty -> M.insert n (unLoc x) $ go (n+1) (unLoc ty) + HsFunTy _ _ ty -> go (n+1) (unLoc ty) + HsDocTy _ _ doc -> M.singleton n (unLoc doc) + _ -> M.empty + +-- | The top-level declarations of a module that we care about, +-- ordered by source location, with documentation attached if it exists. +topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])] +topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup + +-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. +ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] +ungroup group_ = + mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField) group_ ++ + mkDecls hs_derivds (DerivD noExtField) group_ ++ + mkDecls hs_defds (DefD noExtField) group_ ++ + mkDecls hs_fords (ForD noExtField) group_ ++ + mkDecls hs_docs (DocD noExtField) group_ ++ + mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField) group_ ++ + mkDecls (typesigs . hs_valds) (SigD noExtField) group_ ++ + mkDecls (valbinds . hs_valds) (ValD noExtField) group_ + where + typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig + typesigs ValBinds{} = error "expected XValBindsLR" + + valbinds (XValBindsLR (NValBinds binds _)) = + concatMap bagToList . snd . unzip $ binds + valbinds ValBinds{} = error "expected XValBindsLR" + +-- | Sort by source location +sortByLoc :: [Located a] -> [Located a] +sortByLoc = sortOn getLoc + +-- | Collect docs and attach them to the right declarations. +-- +-- A declaration may have multiple doc strings attached to it. +collectDocs :: [LHsDecl pass] -> [(LHsDecl pass, [HsDocString])] +-- ^ This is an example. +collectDocs = go [] Nothing + where + go docs mprev decls = case (decls, mprev) of + ((unLoc->DocD _ (DocCommentNext s)) : ds, Nothing) -> go (s:docs) Nothing ds + ((unLoc->DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds + ((unLoc->DocD _ (DocCommentPrev s)) : ds, mprev) -> go (s:docs) mprev ds + (d : ds, Nothing) -> go docs (Just d) ds + (d : ds, Just prev) -> finished prev docs $ go [] (Just d) ds + ([] , Nothing) -> [] + ([] , Just prev) -> finished prev docs [] + + finished decl docs rest = (decl, reverse docs) : rest + +-- | Filter out declarations that we don't handle in Haddock +filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] +filterDecls = filter (isHandled . unLoc . fst) + where + isHandled (ForD _ (ForeignImport {})) = True + isHandled (TyClD {}) = True + isHandled (InstD {}) = True + isHandled (DerivD {}) = True + isHandled (SigD _ d) = isUserSig d + isHandled (ValD {}) = True + -- we keep doc declarations to be able to get at named docs + isHandled (DocD {}) = True + isHandled _ = False + + +-- | Go through all class declarations and filter their sub-declarations +filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] +filterClasses = map (first (mapLoc filterClass)) + where + filterClass (TyClD x c@(ClassDecl {})) = + TyClD x $ c { tcdSigs = + filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) } + filterClass d = d + +-- | Was this signature given by the user? +isUserSig :: Sig name -> Bool +isUserSig TypeSig {} = True +isUserSig ClassOpSig {} = True +isUserSig PatSynSig {} = True +isUserSig _ = False + +-- | Take a field of declarations from a data structure and create HsDecls +-- using the given constructor +mkDecls :: (struct -> [Located decl]) + -> (decl -> hsDecl) + -> struct + -> [Located hsDecl] +mkDecls field con = map (mapLoc con) . field diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs new file mode 100644 index 0000000000..0d927e4e59 --- /dev/null +++ b/compiler/GHC/HsToCore/Expr.hs @@ -0,0 +1,1204 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Desugaring expressions. +-} + +{-# LANGUAGE CPP, MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.HsToCore.Expr + ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds + , dsValBinds, dsLit, dsSyntaxExpr + , dsHandleMonadicFailure + ) +where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.HsToCore.Match +import GHC.HsToCore.Match.Literal +import GHC.HsToCore.Binds +import GHC.HsToCore.GuardedRHSs +import GHC.HsToCore.ListComp +import GHC.HsToCore.Utils +import GHC.HsToCore.Arrows +import GHC.HsToCore.Monad +import GHC.HsToCore.PmCheck ( checkGuardMatches ) +import Name +import NameEnv +import FamInstEnv( topNormaliseType ) +import GHC.HsToCore.Quote +import GHC.Hs + +-- NB: The desugarer, which straddles the source and Core worlds, sometimes +-- needs to see source types +import TcType +import TcEvidence +import TcRnMonad +import Type +import CoreSyn +import CoreUtils +import MkCore + +import DynFlags +import CostCentre +import Id +import MkId +import Module +import ConLike +import DataCon +import TyCoPpr( pprWithTYPE ) +import TysWiredIn +import PrelNames +import BasicTypes +import Maybes +import VarEnv +import SrcLoc +import Util +import Bag +import Outputable +import PatSyn + +import Control.Monad + +{- +************************************************************************ +* * + dsLocalBinds, dsValBinds +* * +************************************************************************ +-} + +dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr +dsLocalBinds (L _ (EmptyLocalBinds _)) body = return body +dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $ + dsValBinds binds body +dsLocalBinds (L _ (HsIPBinds _ binds)) body = dsIPBinds binds body +dsLocalBinds _ _ = panic "dsLocalBinds" + +------------------------- +-- caller sets location +dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr +dsValBinds (XValBindsLR (NValBinds binds _)) body + = foldrM ds_val_bind body binds +dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn" + +------------------------- +dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr +dsIPBinds (IPBinds ev_binds ip_binds) body + = do { ds_binds <- dsTcEvBinds ev_binds + ; let inner = mkCoreLets ds_binds body + -- The dict bindings may not be in + -- dependency order; hence Rec + ; foldrM ds_ip_bind inner ip_binds } + where + ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body + = do e' <- dsLExpr e + return (Let (NonRec n e') body) + ds_ip_bind _ _ = panic "dsIPBinds" +dsIPBinds (XHsIPBinds nec) _ = noExtCon nec + +------------------------- +-- caller sets location +ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr +-- Special case for bindings which bind unlifted variables +-- We need to do a case right away, rather than building +-- a tuple and doing selections. +-- Silently ignore INLINE and SPECIALISE pragmas... +ds_val_bind (NonRecursive, hsbinds) body + | [L loc bind] <- bagToList hsbinds + -- Non-recursive, non-overloaded bindings only come in ones + -- ToDo: in some bizarre case it's conceivable that there + -- could be dict binds in the 'binds'. (See the notes + -- below. Then pattern-match would fail. Urk.) + , isUnliftedHsBind bind + = putSrcSpanDs loc $ + -- see Note [Strict binds checks] in GHC.HsToCore.Binds + if is_polymorphic bind + then errDsCoreExpr (poly_bind_err bind) + -- data Ptr a = Ptr Addr# + -- f x = let p@(Ptr y) = ... in ... + -- Here the binding for 'p' is polymorphic, but does + -- not mix with an unlifted binding for 'y'. You should + -- use a bang pattern. #6078. + + else do { when (looksLazyPatBind bind) $ + warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind) + -- Complain about a binding that looks lazy + -- e.g. let I# y = x in ... + -- Remember, in checkStrictBinds we are going to do strict + -- matching, so (for software engineering reasons) we insist + -- that the strictness is manifest on each binding + -- However, lone (unboxed) variables are ok + + + ; dsUnliftedBind bind body } + where + is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }) + = not (null tvs && null evs) + is_polymorphic _ = False + + unlifted_must_be_bang bind + = hang (text "Pattern bindings containing unlifted types should use" $$ + text "an outermost bang pattern:") + 2 (ppr bind) + + poly_bind_err bind + = hang (text "You can't mix polymorphic and unlifted bindings:") + 2 (ppr bind) $$ + text "Probable fix: add a type signature" + +ds_val_bind (is_rec, binds) _body + | anyBag (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in GHC.HsToCore.Binds + = ASSERT( isRec is_rec ) + errDsCoreExpr $ + hang (text "Recursive bindings for unlifted types aren't allowed:") + 2 (vcat (map ppr (bagToList binds))) + +-- Ordinary case for bindings; none should be unlifted +ds_val_bind (is_rec, binds) body + = do { MASSERT( isRec is_rec || isSingletonBag binds ) + -- we should never produce a non-recursive list of multiple binds + + ; (force_vars,prs) <- dsLHsBinds binds + ; let body' = foldr seqVar body force_vars + ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds ) + case prs of + [] -> return body + _ -> return (Let (Rec prs) body') } + -- Use a Rec regardless of is_rec. + -- Why? Because it allows the binds to be all + -- mixed up, which is what happens in one rare case + -- Namely, for an AbsBind with no tyvars and no dicts, + -- but which does have dictionary bindings. + -- See notes with TcSimplify.inferLoop [NO TYVARS] + -- It turned out that wrapping a Rec here was the easiest solution + -- + -- NB The previous case dealt with unlifted bindings, so we + -- only have to deal with lifted ones now; so Rec is ok + +------------------ +dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr +dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] + , abs_exports = exports + , abs_ev_binds = ev_binds + , abs_binds = lbinds }) body + = do { let body1 = foldr bind_export body exports + bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b + ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body) + body1 lbinds + ; ds_binds <- dsTcEvBinds_s ev_binds + ; return (mkCoreLets ds_binds body2) } + +dsUnliftedBind (FunBind { fun_id = L l fun + , fun_matches = matches + , fun_ext = co_fn + , fun_tick = tick }) body + -- Can't be a bang pattern (that looks like a PatBind) + -- so must be simply unboxed + = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun)) + Nothing matches + ; MASSERT( null args ) -- Functions aren't lifted + ; MASSERT( isIdHsWrapper co_fn ) + ; let rhs' = mkOptTickBox tick rhs + ; return (bindNonRec fun rhs' body) } + +dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss + , pat_ext = NPatBindTc _ ty }) body + = -- let C x# y# = rhs in body + -- ==> case rhs of C x# y# -> body + do { rhs <- dsGuarded grhss ty + ; checkGuardMatches PatBindGuards grhss + ; let upat = unLoc pat + eqn = EqnInfo { eqn_pats = [upat], + eqn_orig = FromSource, + eqn_rhs = cantFailMatchResult body } + ; var <- selectMatchVar upat + ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) + ; return (bindNonRec var rhs result) } + +dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) + +{- +************************************************************************ +* * +* Variables, constructors, literals * +* * +************************************************************************ +-} + +dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr + +dsLExpr (L loc e) + = putSrcSpanDs loc $ + do { core_expr <- dsExpr e + -- uncomment this check to test the hsExprType function in TcHsSyn + -- ; MASSERT2( exprType core_expr `eqType` hsExprType e + -- , ppr e <+> dcolon <+> ppr (hsExprType e) $$ + -- ppr core_expr <+> dcolon <+> ppr (exprType core_expr) ) + ; return core_expr } + +-- | Variant of 'dsLExpr' that ensures that the result is not levity +-- polymorphic. This should be used when the resulting expression will +-- be an argument to some other function. +-- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad +-- See Note [Levity polymorphism invariants] in CoreSyn +dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr +dsLExprNoLP (L loc e) + = putSrcSpanDs loc $ + do { e' <- dsExpr e + ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e) + ; return e' } + +dsExpr :: HsExpr GhcTc -> DsM CoreExpr +dsExpr (HsPar _ e) = dsLExpr e +dsExpr (ExprWithTySig _ e _) = dsLExpr e +dsExpr (HsVar _ (L _ var)) = dsHsVar var +dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them +dsExpr (HsConLikeOut _ con) = dsConLike con +dsExpr (HsIPVar {}) = panic "dsExpr: HsIPVar" +dsExpr (HsOverLabel{}) = panic "dsExpr: HsOverLabel" + +dsExpr (HsLit _ lit) + = do { warnAboutOverflowedLit lit + ; dsLit (convertLit lit) } + +dsExpr (HsOverLit _ lit) + = do { warnAboutOverflowedOverLit lit + ; dsOverLit lit } + +dsExpr hswrap@(XExpr (HsWrap co_fn e)) + = do { e' <- case e of + HsVar _ (L _ var) -> return $ varToCoreExpr var + HsConLikeOut _ (RealDataCon dc) -> return $ varToCoreExpr (dataConWrapId dc) + XExpr (HsWrap _ _) -> pprPanic "dsExpr: HsWrap inside HsWrap" (ppr hswrap) + HsPar _ _ -> pprPanic "dsExpr: HsPar inside HsWrap" (ppr hswrap) + _ -> dsExpr e + -- See Note [Detecting forced eta expansion] + ; wrap' <- dsHsWrapper co_fn + ; dflags <- getDynFlags + ; let wrapped_e = wrap' e' + wrapped_ty = exprType wrapped_e + ; checkForcedEtaExpansion e (ppr hswrap) wrapped_ty -- See Note [Detecting forced eta expansion] + -- Pass HsWrap, so that the user can see entire expression with -fprint-typechecker-elaboration + ; warnAboutIdentities dflags e' wrapped_ty + ; return wrapped_e } + +dsExpr (NegApp _ (L loc + (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i}))) + neg_expr) + = do { expr' <- putSrcSpanDs loc $ do + { warnAboutOverflowedOverLit + (lit { ol_val = HsIntegral (negateIntegralLit i) }) + ; dsOverLit lit } + ; dsSyntaxExpr neg_expr [expr'] } + +dsExpr (NegApp _ expr neg_expr) + = do { expr' <- dsLExpr expr + ; dsSyntaxExpr neg_expr [expr'] } + +dsExpr (HsLam _ a_Match) + = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match + +dsExpr (HsLamCase _ matches) + = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches + ; return $ Lam discrim_var matching_code } + +dsExpr e@(HsApp _ fun arg) + = do { fun' <- dsLExpr fun + ; dsWhenNoErrs (dsLExprNoLP arg) + (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') } + +dsExpr (HsAppType _ e _) + -- ignore type arguments here; they're in the wrappers instead at this point + = dsLExpr e + +{- +Note [Desugaring vars] +~~~~~~~~~~~~~~~~~~~~~~ +In one situation we can get a *coercion* variable in a HsVar, namely +the support method for an equality superclass: + class (a~b) => C a b where ... + instance (blah) => C (T a) (T b) where .. +Then we get + $dfCT :: forall ab. blah => C (T a) (T b) + $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah) + + $c$p1C :: forall ab. blah => (T a ~ T b) + $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g + +That 'g' in the 'in' part is an evidence variable, and when +converting to core it must become a CO. + +Operator sections. At first it looks as if we can convert +\begin{verbatim} + (expr op) +\end{verbatim} +to +\begin{verbatim} + \x -> op expr x +\end{verbatim} + +But no! expr might be a redex, and we can lose laziness badly this +way. Consider +\begin{verbatim} + map (expr op) xs +\end{verbatim} +for example. So we convert instead to +\begin{verbatim} + let y = expr in \x -> op y x +\end{verbatim} +If \tr{expr} is actually just a variable, say, then the simplifier +will sort it out. +-} + +dsExpr e@(OpApp _ e1 op e2) + = -- for the type of y, we need the type of op's 2nd argument + do { op' <- dsLExpr op + ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2]) + (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') } + +dsExpr (SectionL _ expr op) -- Desugar (e !) to ((!) e) + = do { op' <- dsLExpr op + ; dsWhenNoErrs (dsLExprNoLP expr) + (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') } + +-- dsLExpr (SectionR op expr) -- \ x -> op x expr +dsExpr e@(SectionR _ op expr) = do + core_op <- dsLExpr op + -- for the type of x, we need the type of op's 2nd argument + let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) + -- See comment with SectionL + y_core <- dsLExpr expr + dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty]) + (\[x_id, y_id] -> bindNonRec y_id y_core $ + Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) + core_op [Var x_id, Var y_id])) + +dsExpr (ExplicitTuple _ tup_args boxity) + = do { let go (lam_vars, args) (L _ (Missing ty)) + -- For every missing expression, we need + -- another lambda in the desugaring. + = do { lam_var <- newSysLocalDsNoLP ty + ; return (lam_var : lam_vars, Var lam_var : args) } + go (lam_vars, args) (L _ (Present _ expr)) + -- Expressions that are present don't generate + -- lambdas, just arguments. + = do { core_expr <- dsLExprNoLP expr + ; return (lam_vars, core_expr : args) } + go _ _ = panic "dsExpr" + + ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args)) + -- The reverse is because foldM goes left-to-right + (\(lam_vars, args) -> mkCoreLams lam_vars $ + mkCoreTupBoxity boxity args) } + -- See Note [Don't flatten tuples from HsSyn] in MkCore + +dsExpr (ExplicitSum types alt arity expr) + = do { dsWhenNoErrs (dsLExprNoLP expr) + (\core_expr -> mkCoreConApps (sumDataCon alt arity) + (map (Type . getRuntimeRep) types ++ + map Type types ++ + [core_expr]) ) } + +dsExpr (HsPragE _ prag expr) = + ds_prag_expr prag expr + +dsExpr (HsCase _ discrim matches) + = do { core_discrim <- dsLExpr discrim + ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches + ; return (bindNonRec discrim_var core_discrim matching_code) } + +-- Pepe: The binds are in scope in the body but NOT in the binding group +-- This is to avoid silliness in breakpoints +dsExpr (HsLet _ binds body) = do + body' <- dsLExpr body + dsLocalBinds binds body' + +-- We need the `ListComp' form to use `deListComp' (rather than the "do" form) +-- because the interpretation of `stmts' depends on what sort of thing it is. +-- +dsExpr (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty +dsExpr (HsDo _ DoExpr (L _ stmts)) = dsDo stmts +dsExpr (HsDo _ GhciStmtCtxt (L _ stmts)) = dsDo stmts +dsExpr (HsDo _ MDoExpr (L _ stmts)) = dsDo stmts +dsExpr (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts + +dsExpr (HsIf _ fun guard_expr then_expr else_expr) + = do { pred <- dsLExpr guard_expr + ; b1 <- dsLExpr then_expr + ; b2 <- dsLExpr else_expr + ; case fun of -- See Note [Rebindable if] in Hs.Expr + (SyntaxExprTc {}) -> dsSyntaxExpr fun [pred, b1, b2] + NoSyntaxExprTc -> return $ mkIfThenElse pred b1 b2 } + +dsExpr (HsMultiIf res_ty alts) + | null alts + = mkErrorExpr + + | otherwise + = do { match_result <- liftM (foldr1 combineMatchResults) + (mapM (dsGRHS IfAlt res_ty) alts) + ; checkGuardMatches IfAlt (GRHSs noExtField alts (noLoc emptyLocalBinds)) + ; error_expr <- mkErrorExpr + ; extractMatchResult match_result error_expr } + where + mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty + (text "multi-way if") + +{- +\noindent +\underline{\bf Various data construction things} + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-} + +dsExpr (ExplicitList elt_ty wit xs) + = dsExplicitList elt_ty wit xs + +dsExpr (ArithSeq expr witness seq) + = case witness of + Nothing -> dsArithSeq expr seq + Just fl -> do { newArithSeq <- dsArithSeq expr seq + ; dsSyntaxExpr fl [newArithSeq] } + +{- +Static Pointers +~~~~~~~~~~~~~~~ + +See Note [Grand plan for static forms] in StaticPtrTable for an overview. + + g = ... static f ... +==> + g = ... makeStatic loc f ... +-} + +dsExpr (HsStatic _ expr@(L loc _)) = do + expr_ds <- dsLExprNoLP expr + let ty = exprType expr_ds + makeStaticId <- dsLookupGlobalId makeStaticName + + dflags <- getDynFlags + let (line, col) = case loc of + RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r + , srcLocCol $ realSrcSpanStart r + ) + _ -> (0, 0) + srcLoc = mkCoreConApps (tupleDataCon Boxed 2) + [ Type intTy , Type intTy + , mkIntExprInt dflags line, mkIntExprInt dflags col + ] + + putSrcSpanDs loc $ return $ + mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ] + +{- +\noindent +\underline{\bf Record construction and update} + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For record construction we do this (assuming T has three arguments) +\begin{verbatim} + T { op2 = e } +==> + let err = /\a -> recConErr a + T (recConErr t1 "M.hs/230/op1") + e + (recConErr t1 "M.hs/230/op3") +\end{verbatim} +@recConErr@ then converts its argument string into a proper message +before printing it as +\begin{verbatim} + M.hs, line 230: missing field op1 was evaluated +\end{verbatim} + +We also handle @C{}@ as valid construction syntax for an unlabelled +constructor @C@, setting all of @C@'s fields to bottom. +-} + +dsExpr (RecordCon { rcon_flds = rbinds + , rcon_ext = RecordConTc { rcon_con_expr = con_expr + , rcon_con_like = con_like }}) + = do { con_expr' <- dsExpr con_expr + ; let + (arg_tys, _) = tcSplitFunTys (exprType con_expr') + -- A newtype in the corner should be opaque; + -- hence TcType.tcSplitFunTys + + mk_arg (arg_ty, fl) + = case findField (rec_flds rbinds) (flSelector fl) of + (rhs:rhss) -> ASSERT( null rhss ) + dsLExprNoLP rhs + [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl)) + unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty + + labels = conLikeFieldLabels con_like + + ; con_args <- if null labels + then mapM unlabelled_bottom arg_tys + else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels) + + ; return (mkCoreApps con_expr' con_args) } + +{- +Record update is a little harder. Suppose we have the decl: +\begin{verbatim} + data T = T1 {op1, op2, op3 :: Int} + | T2 {op4, op2 :: Int} + | T3 +\end{verbatim} +Then we translate as follows: +\begin{verbatim} + r { op2 = e } +===> + let op2 = e in + case r of + T1 op1 _ op3 -> T1 op1 op2 op3 + T2 op4 _ -> T2 op4 op2 + other -> recUpdError "M.hs/230" +\end{verbatim} +It's important that we use the constructor Ids for @T1@, @T2@ etc on the +RHSs, and do not generate a Core constructor application directly, because the constructor +might do some argument-evaluation first; and may have to throw away some +dictionaries. + +Note [Update for GADTs] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a b where + T1 :: { f1 :: a } -> T a Int + +Then the wrapper function for T1 has type + $WT1 :: a -> T a Int +But if x::T a b, then + x { f1 = v } :: T a b (not T a Int!) +So we need to cast (T a Int) to (T a b). Sigh. + +-} + +dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields + , rupd_ext = RecordUpdTc + { rupd_cons = cons_to_upd + , rupd_in_tys = in_inst_tys + , rupd_out_tys = out_inst_tys + , rupd_wrap = dict_req_wrap }} ) + | null fields + = dsLExpr record_expr + | otherwise + = ASSERT2( notNull cons_to_upd, ppr expr ) + + do { record_expr' <- dsLExpr record_expr + ; field_binds' <- mapM ds_field fields + ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding + upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds'] + + -- It's important to generate the match with matchWrapper, + -- and the right hand sides with applications of the wrapper Id + -- so that everything works when we are doing fancy unboxing on the + -- constructor arguments. + ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd + ; ([discrim_var], matching_code) + <- matchWrapper RecUpd (Just record_expr) -- See Note [Scrutinee in Record updates] + (MG { mg_alts = noLoc alts + , mg_ext = MatchGroupTc [in_ty] out_ty + , mg_origin = FromSource }) + -- FromSource is not strictly right, but we + -- want incomplete pattern-match warnings + + ; return (add_field_binds field_binds' $ + bindNonRec discrim_var record_expr' matching_code) } + where + ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr) + -- Clone the Id in the HsRecField, because its Name is that + -- of the record selector, and we must not make that a local binder + -- else we shadow other uses of the record selector + -- Hence 'lcl_id'. Cf #2735 + ds_field (L _ rec_field) + = do { rhs <- dsLExpr (hsRecFieldArg rec_field) + ; let fld_id = unLoc (hsRecUpdFieldId rec_field) + ; lcl_id <- newSysLocalDs (idType fld_id) + ; return (idName fld_id, lcl_id, rhs) } + + add_field_binds [] expr = expr + add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr) + + -- Awkwardly, for families, the match goes + -- from instance type to family type + (in_ty, out_ty) = + case (head cons_to_upd) of + RealDataCon data_con -> + let tycon = dataConTyCon data_con in + (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys) + PatSynCon pat_syn -> + ( patSynInstResTy pat_syn in_inst_tys + , patSynInstResTy pat_syn out_inst_tys) + mk_alt upd_fld_env con + = do { let (univ_tvs, ex_tvs, eq_spec, + prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con + user_tvs = + case con of + RealDataCon data_con -> dataConUserTyVars data_con + PatSynCon _ -> univ_tvs ++ ex_tvs + -- The order here is because of the order in `TcPatSyn`. + in_subst = zipTvSubst univ_tvs in_inst_tys + out_subst = zipTvSubst univ_tvs out_inst_tys + + -- I'm not bothering to clone the ex_tvs + ; eqs_vars <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec)) + ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta) + ; arg_ids <- newSysLocalsDs (substTysUnchecked in_subst arg_tys) + ; let field_labels = conLikeFieldLabels con + val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg + field_labels arg_ids + mk_val_arg fl pat_arg_id + = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) + + inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExtField con) + -- Reconstruct with the WrapId so that unpacking happens + wrap = mkWpEvVarApps theta_vars <.> + dict_req_wrap <.> + mkWpTyApps [ lookupTyVar out_subst tv + `orElse` mkTyVarTy tv + | tv <- user_tvs + , not (tv `elemVarEnv` wrap_subst) ] + -- Be sure to use user_tvs (which may be ordered + -- differently than `univ_tvs ++ ex_tvs) above. + -- See Note [DataCon user type variable binders] + -- in DataCon. + rhs = foldl' (\a b -> nlHsApp a b) inst_con val_args + + -- Tediously wrap the application in a cast + -- Note [Update for GADTs] + wrapped_rhs = + case con of + RealDataCon data_con -> + let + wrap_co = + mkTcTyConAppCo Nominal + (dataConTyCon data_con) + [ lookup tv ty + | (tv,ty) <- univ_tvs `zip` out_inst_tys ] + lookup univ_tv ty = + case lookupVarEnv wrap_subst univ_tv of + Just co' -> co' + Nothing -> mkTcReflCo Nominal ty + in if null eq_spec + then rhs + else mkLHsWrap (mkWpCastN wrap_co) rhs + -- eq_spec is always null for a PatSynCon + PatSynCon _ -> rhs + + wrap_subst = + mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var)) + | (spec, eq_var) <- eq_spec `zip` eqs_vars + , let tv = eqSpecTyVar spec ] + + req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys + + pat = noLoc $ ConPatOut { pat_con = noLoc con + , pat_tvs = ex_tvs + , pat_dicts = eqs_vars ++ theta_vars + , pat_binds = emptyTcEvBinds + , pat_args = PrefixCon $ map nlVarPat arg_ids + , pat_arg_tys = in_inst_tys + , pat_wrap = req_wrap } + ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) } + +{- Note [Scrutinee in Record updates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider #17783: + + data PartialRec = No + | Yes { a :: Int, b :: Bool } + update No = No + update r@(Yes {}) = r { b = False } + +In the context of pattern-match checking, the occurrence of @r@ in +@r { b = False }@ is to be treated as if it was a scrutinee, as can be seen by +the following desugaring: + + r { b = False } ==> case r of Yes a b -> Yes a False + +Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above. +-} + +-- Here is where we desugar the Template Haskell brackets and escapes + +-- Template Haskell stuff + +dsExpr (HsRnBracketOut _ _ _) = panic "dsExpr HsRnBracketOut" +dsExpr (HsTcBracketOut _ hs_wrapper x ps) = dsBracket hs_wrapper x ps +dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s) + +-- Arrow notation extension +dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd + +-- Hpc Support + +dsExpr (HsTick _ tickish e) = do + e' <- dsLExpr e + return (Tick tickish e') + +-- There is a problem here. The then and else branches +-- have no free variables, so they are open to lifting. +-- We need someway of stopping this. +-- This will make no difference to binary coverage +-- (did you go here: YES or NO), but will effect accurate +-- tick counting. + +dsExpr (HsBinTick _ ixT ixF e) = do + e2 <- dsLExpr e + do { ASSERT(exprType e2 `eqType` boolTy) + mkBinaryTickBox ixT ixF e2 + } + +-- HsSyn constructs that just shouldn't be here: +dsExpr (HsBracket {}) = panic "dsExpr:HsBracket" +dsExpr (HsDo {}) = panic "dsExpr:HsDo" +dsExpr (HsRecFld {}) = panic "dsExpr:HsRecFld" + +ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr +ds_prag_expr (HsPragSCC _ _ cc) expr = do + dflags <- getDynFlags + if gopt Opt_SccProfilingOn dflags + then do + mod_name <- getModule + count <- goptM Opt_ProfCountEntries + let nm = sl_fs cc + flavour <- ExprCC <$> getCCIndexM nm + Tick (ProfNote (mkUserCC nm mod_name (getLoc expr) flavour) count True) + <$> dsLExpr expr + else dsLExpr expr +ds_prag_expr (HsPragCore _ _ _) expr + = dsLExpr expr +ds_prag_expr (HsPragTick _ _ _ _) expr = do + dflags <- getDynFlags + if gopt Opt_Hpc dflags + then panic "dsExpr:HsPragTick" + else dsLExpr expr +ds_prag_expr (XHsPragE x) _ = noExtCon x + +------------------------------ +dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr +dsSyntaxExpr (SyntaxExprTc { syn_expr = expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) + arg_exprs + = do { fun <- dsExpr expr + ; core_arg_wraps <- mapM dsHsWrapper arg_wraps + ; core_res_wrap <- dsHsWrapper res_wrap + ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs + ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ]) + (\_ -> core_res_wrap (mkApps fun wrapped_args)) } + where + mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr) +dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr" + +findField :: [LHsRecField GhcTc arg] -> Name -> [arg] +findField rbinds sel + = [hsRecFieldArg fld | L _ fld <- rbinds + , sel == idName (unLoc $ hsRecFieldId fld) ] + +{- +%-------------------------------------------------------------------- + +Note [Desugaring explicit lists] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Explicit lists are desugared in a cleverer way to prevent some +fruitless allocations. Essentially, whenever we see a list literal +[x_1, ..., x_n] we generate the corresponding expression in terms of +build: + +Explicit lists (literals) are desugared to allow build/foldr fusion when +beneficial. This is a bit of a trade-off, + + * build/foldr fusion can generate far larger code than the corresponding + cons-chain (e.g. see #11707) + + * even when it doesn't produce more code, build can still fail to fuse, + requiring that the simplifier do more work to bring the expression + back into cons-chain form; this costs compile time + + * when it works, fusion can be a significant win. Allocations are reduced + by up to 25% in some nofib programs. Specifically, + + Program Size Allocs Runtime CompTime + rewrite +0.0% -26.3% 0.02 -1.8% + ansi -0.3% -13.8% 0.00 +0.0% + lift +0.0% -8.7% 0.00 -2.3% + +At the moment we use a simple heuristic to determine whether build will be +fruitful: for small lists we assume the benefits of fusion will be worthwhile; +for long lists we assume that the benefits will be outweighted by the cost of +code duplication. This magic length threshold is @maxBuildLength@. Also, fusion +won't work at all if rewrite rules are disabled, so we don't use the build-based +desugaring in this case. + +We used to have a more complex heuristic which would try to break the list into +"static" and "dynamic" parts and only build-desugar the dynamic part. +Unfortunately, determining "static-ness" reliably is a bit tricky and the +heuristic at times produced surprising behavior (see #11710) so it was dropped. +-} + +{- | The longest list length which we will desugar using @build@. + +This is essentially a magic number and its setting is unfortunate rather +arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists], +is to avoid deforesting large static data into large(r) code. Ideally we'd +want a smaller threshold with larger consumers and vice-versa, but we have no +way of knowing what will be consuming our list in the desugaring impossible to +set generally correctly. + +The effect of reducing this number will be that 'build' fusion is applied +less often. From a runtime performance perspective, applying 'build' more +liberally on "moderately" sized lists should rarely hurt and will often it can +only expose further optimization opportunities; if no fusion is possible it will +eventually get rule-rewritten back to a list). We do, however, pay in compile +time. +-} +maxBuildLength :: Int +maxBuildLength = 32 + +dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] + -> DsM CoreExpr +-- See Note [Desugaring explicit lists] +dsExplicitList elt_ty Nothing xs + = do { dflags <- getDynFlags + ; xs' <- mapM dsLExprNoLP xs + ; if xs' `lengthExceeds` maxBuildLength + -- Don't generate builds if the list is very long. + || null xs' + -- Don't generate builds when the [] constructor will do + || not (gopt Opt_EnableRewriteRules dflags) -- Rewrite rules off + -- Don't generate a build if there are no rules to eliminate it! + -- See Note [Desugaring RULE left hand sides] in GHC.HsToCore + then return $ mkListExpr elt_ty xs' + else mkBuildExpr elt_ty (mk_build_list xs') } + where + mk_build_list xs' (cons, _) (nil, _) + = return (foldr (App . App (Var cons)) (Var nil) xs') + +dsExplicitList elt_ty (Just fln) xs + = do { list <- dsExplicitList elt_ty Nothing xs + ; dflags <- getDynFlags + ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] } + +dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr +dsArithSeq expr (From from) + = App <$> dsExpr expr <*> dsLExprNoLP from +dsArithSeq expr (FromTo from to) + = do dflags <- getDynFlags + warnAboutEmptyEnumerations dflags from Nothing to + expr' <- dsExpr expr + from' <- dsLExprNoLP from + to' <- dsLExprNoLP to + return $ mkApps expr' [from', to'] +dsArithSeq expr (FromThen from thn) + = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn] +dsArithSeq expr (FromThenTo from thn to) + = do dflags <- getDynFlags + warnAboutEmptyEnumerations dflags from (Just thn) to + expr' <- dsExpr expr + from' <- dsLExprNoLP from + thn' <- dsLExprNoLP thn + to' <- dsLExprNoLP to + return $ mkApps expr' [from', thn', to'] + +{- +Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're +handled in GHC.HsToCore.ListComp). Basically does the translation given in the +Haskell 98 report: +-} + +dsDo :: [ExprLStmt GhcTc] -> DsM CoreExpr +dsDo stmts + = goL stmts + where + goL [] = panic "dsDo" + goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) + + go _ (LastStmt _ body _ _) stmts + = ASSERT( null stmts ) dsLExpr body + -- The 'return' op isn't used for 'do' expressions + + go _ (BodyStmt _ rhs then_expr _) stmts + = do { rhs2 <- dsLExpr rhs + ; warnDiscardedDoBindings rhs (exprType rhs2) + ; rest <- goL stmts + ; dsSyntaxExpr then_expr [rhs2, rest] } + + go _ (LetStmt _ binds) stmts + = do { rest <- goL stmts + ; dsLocalBinds binds rest } + + go _ (BindStmt res1_ty pat rhs bind_op fail_op) stmts + = do { body <- goL stmts + ; rhs' <- dsLExpr rhs + ; var <- selectSimpleMatchVarL pat + ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat + res1_ty (cantFailMatchResult body) + ; match_code <- dsHandleMonadicFailure pat match fail_op + ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } + + go _ (ApplicativeStmt body_ty args mb_join) stmts + = do { + let + (pats, rhss) = unzip (map (do_arg . snd) args) + + do_arg (ApplicativeArgOne _ pat expr _ fail_op) = + ((pat, fail_op), dsLExpr expr) + do_arg (ApplicativeArgMany _ stmts ret pat) = + ((pat, noSyntaxExpr), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)])) + do_arg (XApplicativeArg nec) = noExtCon nec + + ; rhss' <- sequence rhss + + ; body' <- dsLExpr $ noLoc $ HsDo body_ty DoExpr (noLoc stmts) + + ; let match_args (pat, fail_op) (vs,body) + = do { var <- selectSimpleMatchVarL pat + ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat + body_ty (cantFailMatchResult body) + ; match_code <- dsHandleMonadicFailure pat match fail_op + ; return (var:vs, match_code) + } + + ; (vars, body) <- foldrM match_args ([],body') pats + ; let fun' = mkLams vars body + ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r] + ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss') + ; case mb_join of + Nothing -> return expr + Just join_op -> dsSyntaxExpr join_op [expr] } + + go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids + , recS_rec_ids = rec_ids, recS_ret_fn = return_op + , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op + , recS_ext = RecStmtTc + { recS_bind_ty = bind_ty + , recS_rec_rets = rec_rets + , recS_ret_ty = body_ty} }) stmts + = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' } + where + new_bind_stmt = L loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats) + mfix_app bind_op + noSyntaxExpr -- Tuple cannot fail + + tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids + tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case + rec_tup_pats = map nlVarPat tup_ids + later_pats = rec_tup_pats + rets = map noLoc rec_rets + mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] + mfix_arg = noLoc $ HsLam noExtField + (MG { mg_alts = noLoc [mkSimpleMatch + LambdaExpr + [mfix_pat] body] + , mg_ext = MatchGroupTc [tup_ty] body_ty + , mg_origin = Generated }) + mfix_pat = noLoc $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats + body = noLoc $ HsDo body_ty + DoExpr (noLoc (rec_stmts ++ [ret_stmt])) + ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets] + ret_stmt = noLoc $ mkLastStmt ret_app + -- This LastStmt will be desugared with dsDo, + -- which ignores the return_op in the LastStmt, + -- so we must apply the return_op explicitly + + go _ (ParStmt {}) _ = panic "dsDo ParStmt" + go _ (TransStmt {}) _ = panic "dsDo TransStmt" + go _ (XStmtLR nec) _ = noExtCon nec + +dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr + -- In a do expression, pattern-match failure just calls + -- the monadic 'fail' rather than throwing an exception +dsHandleMonadicFailure pat match fail_op + | matchCanFail match + = do { dflags <- getDynFlags + ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat) + ; fail_expr <- dsSyntaxExpr fail_op [fail_msg] + ; extractMatchResult match fail_expr } + | otherwise + = extractMatchResult match (error "It can't fail") + +mk_fail_msg :: DynFlags -> Located e -> String +mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ + showPpr dflags (getLoc pat) + +{- +************************************************************************ +* * + Desugaring Variables +* * +************************************************************************ +-} + +dsHsVar :: Id -> DsM CoreExpr +dsHsVar var + -- See Wrinkle in Note [Detecting forced eta expansion] + = ASSERT2(null (badUseOfLevPolyPrimop var ty), ppr var $$ ppr ty) + return (varToCoreExpr var) -- See Note [Desugaring vars] + + where + ty = idType var + +dsConLike :: ConLike -> DsM CoreExpr +dsConLike (RealDataCon dc) = dsHsVar (dataConWrapId dc) +dsConLike (PatSynCon ps) = return $ case patSynBuilder ps of + Just (id, add_void) + | add_void -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId) + | otherwise -> Var id + _ -> pprPanic "dsConLike" (ppr ps) + +{- +************************************************************************ +* * +\subsection{Errors and contexts} +* * +************************************************************************ +-} + +-- Warn about certain types of values discarded in monadic bindings (#3263) +warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM () +warnDiscardedDoBindings rhs rhs_ty + | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty + = do { warn_unused <- woptM Opt_WarnUnusedDoBind + ; warn_wrong <- woptM Opt_WarnWrongDoBind + ; when (warn_unused || warn_wrong) $ + do { fam_inst_envs <- dsGetFamInstEnvs + ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty + + -- Warn about discarding non-() things in 'monadic' binding + ; if warn_unused && not (isUnitTy norm_elt_ty) + then warnDs (Reason Opt_WarnUnusedDoBind) + (badMonadBind rhs elt_ty) + else + + -- Warn about discarding m a things in 'monadic' binding of the same type, + -- but only if we didn't already warn due to Opt_WarnUnusedDoBind + when warn_wrong $ + do { case tcSplitAppTy_maybe norm_elt_ty of + Just (elt_m_ty, _) + | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty + -> warnDs (Reason Opt_WarnWrongDoBind) + (badMonadBind rhs elt_ty) + _ -> return () } } } + + | otherwise -- RHS does have type of form (m ty), which is weird + = return () -- but at least this warning is irrelevant + +badMonadBind :: LHsExpr GhcTc -> Type -> SDoc +badMonadBind rhs elt_ty + = vcat [ hang (text "A do-notation statement discarded a result of type") + 2 (quotes (ppr elt_ty)) + , hang (text "Suppress this warning by saying") + 2 (quotes $ text "_ <-" <+> ppr rhs) + ] + +{- +************************************************************************ +* * + Forced eta expansion and levity polymorphism +* * +************************************************************************ + +Note [Detecting forced eta expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We cannot have levity polymorphic function arguments. See +Note [Levity polymorphism invariants] in CoreSyn. But we *can* have +functions that take levity polymorphic arguments, as long as these +functions are eta-reduced. (See #12708 for an example.) + +However, we absolutely cannot do this for functions that have no +binding (i.e., say True to Id.hasNoBinding), like primops and unboxed +tuple constructors. These get eta-expanded in CorePrep.maybeSaturate. + +Detecting when this is about to happen is a bit tricky, though. When +the desugarer is looking at the Id itself (let's be concrete and +suppose we have (#,#)), we don't know whether it will be levity +polymorphic. So the right spot seems to be to look after the Id has +been applied to its type arguments. To make the algorithm efficient, +it's important to be able to spot ((#,#) @a @b @c @d) without looking +past all the type arguments. We thus require that + * The body of an HsWrap is not an HsWrap, nor an HsPar. +This invariant is checked in dsExpr. +With that representation invariant, we simply look inside every HsWrap +to see if its body is an HsVar whose Id hasNoBinding. Then, we look +at the wrapped type. If it has any levity polymorphic arguments, reject. + +Interestingly, this approach does not look to see whether the Id in +question will be eta expanded. The logic is this: + * Either the Id in question is saturated or not. + * If it is, then it surely can't have levity polymorphic arguments. + If its wrapped type contains levity polymorphic arguments, reject. + * If it's not, then it can't be eta expanded with levity polymorphic + argument. If its wrapped type contains levity polymorphic arguments, reject. +So, either way, we're good to reject. + +Wrinkle +~~~~~~~ +Currently, all levity-polymorphic Ids are wrapped in HsWrap. + +However, this is not set in stone, in the future we might make +instantiation more lazy. (See "Visible type application", ESOP '16.) +If we spot a levity-polymorphic hasNoBinding Id without a wrapper, +then that is surely a problem. In this case, we raise an assertion failure. +This failure can be changed to a call to `levPolyPrimopErr` in the future, +if we decide to change instantiation. + +We can just check HsVar and HsConLikeOut for RealDataCon, since +we don't have levity-polymorphic pattern synonyms. (This might change +in the future.) +-} + +-- | Takes an expression and its instantiated type. If the expression is an +-- HsVar with a hasNoBinding primop and the type has levity-polymorphic arguments, +-- issue an error. See Note [Detecting forced eta expansion] +checkForcedEtaExpansion :: HsExpr GhcTc -> SDoc -> Type -> DsM () +checkForcedEtaExpansion expr expr_doc ty + | Just var <- case expr of + HsVar _ (L _ var) -> Just var + HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc) + _ -> Nothing + , let bad_tys = badUseOfLevPolyPrimop var ty + , not (null bad_tys) + = levPolyPrimopErr expr_doc ty bad_tys +checkForcedEtaExpansion _ _ _ = return () + +-- | Is this a hasNoBinding Id with a levity-polymorphic type? +-- Returns the arguments that are levity polymorphic if they are bad; +-- or an empty list otherwise +-- See Note [Detecting forced eta expansion] +badUseOfLevPolyPrimop :: Id -> Type -> [Type] +badUseOfLevPolyPrimop id ty + | hasNoBinding id + = filter isTypeLevPoly arg_tys + | otherwise + = [] + where + (binders, _) = splitPiTys ty + arg_tys = mapMaybe binderRelevantType_maybe binders + +levPolyPrimopErr :: SDoc -> Type -> [Type] -> DsM () +levPolyPrimopErr expr_doc ty bad_tys + = errDs $ vcat + [ hang (text "Cannot use function with levity-polymorphic arguments:") + 2 (expr_doc <+> dcolon <+> pprWithTYPE ty) + , sdocWithDynFlags $ \dflags -> + if not (gopt Opt_PrintTypecheckerElaboration dflags) then vcat + [ text "(Note that levity-polymorphic primops such as 'coerce' and unboxed tuples" + , text "are eta-expanded internally because they must occur fully saturated." + , text "Use -fprint-typechecker-elaboration to display the full expression.)" + ] else empty + , hang (text "Levity-polymorphic arguments:") + 2 $ vcat $ map + (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t)) + bad_tys + ] diff --git a/compiler/GHC/HsToCore/Expr.hs-boot b/compiler/GHC/HsToCore/Expr.hs-boot new file mode 100644 index 0000000000..b717c1bee8 --- /dev/null +++ b/compiler/GHC/HsToCore/Expr.hs-boot @@ -0,0 +1,12 @@ +module GHC.HsToCore.Expr where +import GHC.Hs ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr ) +import GHC.HsToCore.Monad ( DsM, MatchResult ) +import CoreSyn ( CoreExpr ) +import GHC.Hs.Extension ( GhcTc) + +dsExpr :: HsExpr GhcTc -> DsM CoreExpr +dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr +dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr +dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr + +dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs new file mode 100644 index 0000000000..abbc9f3f79 --- /dev/null +++ b/compiler/GHC/HsToCore/Foreign/Call.hs @@ -0,0 +1,383 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + + +Desugaring foreign calls +-} + +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.HsToCore.Foreign.Call + ( dsCCall + , mkFCall + , unboxArg + , boxResult + , resultWrapper + ) +where + +#include "HsVersions.h" + + +import GhcPrelude + +import CoreSyn + +import GHC.HsToCore.Monad +import CoreUtils +import MkCore +import MkId +import ForeignCall +import DataCon +import GHC.HsToCore.Utils + +import TcType +import Type +import Id ( Id ) +import Coercion +import PrimOp +import TysPrim +import TyCon +import TysWiredIn +import BasicTypes +import Literal +import PrelNames +import DynFlags +import Outputable +import Util + +import Data.Maybe + +{- +Desugaring of @ccall@s consists of adding some state manipulation, +unboxing any boxed primitive arguments and boxing the result if +desired. + +The state stuff just consists of adding in +@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place. + +The unboxing is straightforward, as all information needed to unbox is +available from the type. For each boxed-primitive argument, we +transform: +\begin{verbatim} + _ccall_ foo [ r, t1, ... tm ] e1 ... em + | + | + V + case e1 of { T1# x1# -> + ... + case em of { Tm# xm# -> xm# + ccall# foo [ r, t1#, ... tm# ] x1# ... xm# + } ... } +\end{verbatim} + +The reboxing of a @_ccall_@ result is a bit tricker: the types don't +contain information about the state-pairing functions so we have to +keep a list of \tr{(type, s-p-function)} pairs. We transform as +follows: +\begin{verbatim} + ccall# foo [ r, t1#, ... tm# ] e1# ... em# + | + | + V + \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of + (StateAnd# result# state#) -> (R# result#, realWorld#) +\end{verbatim} +-} + +dsCCall :: CLabelString -- C routine to invoke + -> [CoreExpr] -- Arguments (desugared) + -- Precondition: none have levity-polymorphic types + -> Safety -- Safety of the call + -> Type -- Type of the result: IO t + -> DsM CoreExpr -- Result, of type ??? + +dsCCall lbl args may_gc result_ty + = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args + (ccall_result_ty, res_wrapper) <- boxResult result_ty + uniq <- newUnique + dflags <- getDynFlags + let + target = StaticTarget NoSourceText lbl Nothing True + the_fcall = CCall (CCallSpec target CCallConv may_gc) + the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty + return (foldr ($) (res_wrapper the_prim_app) arg_wrappers) + +mkFCall :: DynFlags -> Unique -> ForeignCall + -> [CoreExpr] -- Args + -> Type -- Result type + -> CoreExpr +-- Construct the ccall. The only tricky bit is that the ccall Id should have +-- no free vars, so if any of the arg tys do we must give it a polymorphic type. +-- [I forget *why* it should have no free vars!] +-- For example: +-- mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char] +-- +-- Here we build a ccall thus +-- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr)) +-- a b s x c +mkFCall dflags uniq the_fcall val_args res_ty + = ASSERT( all isTyVar tyvars ) -- this must be true because the type is top-level + mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args + where + arg_tys = map exprType val_args + body_ty = (mkVisFunTys arg_tys res_ty) + tyvars = tyCoVarsOfTypeWellScoped body_ty + ty = mkInvForAllTys tyvars body_ty + the_fcall_id = mkFCallId dflags uniq the_fcall ty + +unboxArg :: CoreExpr -- The supplied argument, not levity-polymorphic + -> DsM (CoreExpr, -- To pass as the actual argument + CoreExpr -> CoreExpr -- Wrapper to unbox the arg + ) +-- Example: if the arg is e::Int, unboxArg will return +-- (x#::Int#, \W. case x of I# x# -> W) +-- where W is a CoreExpr that probably mentions x# + +-- always returns a non-levity-polymorphic expression + +unboxArg arg + -- Primitive types: nothing to unbox + | isPrimitiveType arg_ty + = return (arg, \body -> body) + + -- Recursive newtypes + | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty + = unboxArg (mkCastDs arg co) + + -- Booleans + | Just tc <- tyConAppTyCon_maybe arg_ty, + tc `hasKey` boolTyConKey + = do dflags <- getDynFlags + prim_arg <- newSysLocalDs intPrimTy + return (Var prim_arg, + \ body -> Case (mkWildCase arg arg_ty intPrimTy + [(DataAlt falseDataCon,[],mkIntLit dflags 0), + (DataAlt trueDataCon, [],mkIntLit dflags 1)]) + -- In increasing tag order! + prim_arg + (exprType body) + [(DEFAULT,[],body)]) + + -- Data types with a single constructor, which has a single, primitive-typed arg + -- This deals with Int, Float etc; also Ptr, ForeignPtr + | is_product_type && data_con_arity == 1 + = ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty) + -- Typechecker ensures this + do case_bndr <- newSysLocalDs arg_ty + prim_arg <- newSysLocalDs data_con_arg_ty1 + return (Var prim_arg, + \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)] + ) + + -- Byte-arrays, both mutable and otherwise; hack warning + -- We're looking for values of type ByteArray, MutableByteArray + -- data ByteArray ix = ByteArray ix ix ByteArray# + -- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s) + | is_product_type && + data_con_arity == 3 && + isJust maybe_arg3_tycon && + (arg3_tycon == byteArrayPrimTyCon || + arg3_tycon == mutableByteArrayPrimTyCon) + = do case_bndr <- newSysLocalDs arg_ty + vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys + return (Var arr_cts_var, + \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)] + ) + + | otherwise + = do l <- getSrcSpanDs + pprPanic "unboxArg: " (ppr l <+> ppr arg_ty) + where + arg_ty = exprType arg + maybe_product_type = splitDataProductType_maybe arg_ty + is_product_type = isJust maybe_product_type + Just (_, _, data_con, data_con_arg_tys) = maybe_product_type + data_con_arity = dataConSourceArity data_con + (data_con_arg_ty1 : _) = data_con_arg_tys + + (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys + maybe_arg3_tycon = tyConAppTyCon_maybe data_con_arg_ty3 + Just arg3_tycon = maybe_arg3_tycon + +boxResult :: Type + -> DsM (Type, CoreExpr -> CoreExpr) + +-- Takes the result of the user-level ccall: +-- either (IO t), +-- or maybe just t for a side-effect-free call +-- Returns a wrapper for the primitive ccall itself, along with the +-- type of the result of the primitive ccall. This result type +-- will be of the form +-- State# RealWorld -> (# State# RealWorld, t' #) +-- where t' is the unwrapped form of t. If t is simply (), then +-- the result type will be +-- State# RealWorld -> (# State# RealWorld #) + +boxResult result_ty + | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty + -- isIOType_maybe handles the case where the type is a + -- simple wrapping of IO. E.g. + -- newtype Wrap a = W (IO a) + -- No coercion necessary because its a non-recursive newtype + -- (If we wanted to handle a *recursive* newtype too, we'd need + -- another case, and a coercion.) + -- The result is IO t, so wrap the result in an IO constructor + = do { res <- resultWrapper io_res_ty + ; let extra_result_tys + = case res of + (Just ty,_) + | isUnboxedTupleType ty + -> let Just ls = tyConAppArgs_maybe ty in tail ls + _ -> [] + + return_result state anss + = mkCoreUbxTup + (realWorldStatePrimTy : io_res_ty : extra_result_tys) + (state : anss) + + ; (ccall_res_ty, the_alt) <- mk_alt return_result res + + ; state_id <- newSysLocalDs realWorldStatePrimTy + ; let io_data_con = head (tyConDataCons io_tycon) + toIOCon = dataConWrapId io_data_con + + wrap the_call = + mkApps (Var toIOCon) + [ Type io_res_ty, + Lam state_id $ + mkWildCase (App the_call (Var state_id)) + ccall_res_ty + (coreAltType the_alt) + [the_alt] + ] + + ; return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap) } + +boxResult result_ty + = do -- It isn't IO, so do unsafePerformIO + -- It's not conveniently available, so we inline it + res <- resultWrapper result_ty + (ccall_res_ty, the_alt) <- mk_alt return_result res + let + wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId)) + ccall_res_ty + (coreAltType the_alt) + [the_alt] + return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap) + where + return_result _ [ans] = ans + return_result _ _ = panic "return_result: expected single result" + + +mk_alt :: (Expr Var -> [Expr Var] -> Expr Var) + -> (Maybe Type, Expr Var -> Expr Var) + -> DsM (Type, (AltCon, [Id], Expr Var)) +mk_alt return_result (Nothing, wrap_result) + = do -- The ccall returns () + state_id <- newSysLocalDs realWorldStatePrimTy + let + the_rhs = return_result (Var state_id) + [wrap_result (panic "boxResult")] + + ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy] + the_alt = (DataAlt (tupleDataCon Unboxed 1), [state_id], the_rhs) + + return (ccall_res_ty, the_alt) + +mk_alt return_result (Just prim_res_ty, wrap_result) + = -- The ccall returns a non-() value + ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty ) + -- True because resultWrapper ensures it is so + do { result_id <- newSysLocalDs prim_res_ty + ; state_id <- newSysLocalDs realWorldStatePrimTy + ; let the_rhs = return_result (Var state_id) + [wrap_result (Var result_id)] + ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty] + the_alt = (DataAlt (tupleDataCon Unboxed 2), [state_id, result_id], the_rhs) + ; return (ccall_res_ty, the_alt) } + + +resultWrapper :: Type + -> DsM (Maybe Type, -- Type of the expected result, if any + CoreExpr -> CoreExpr) -- Wrapper for the result +-- resultWrapper deals with the result *value* +-- E.g. foreign import foo :: Int -> IO T +-- Then resultWrapper deals with marshalling the 'T' part +-- So if resultWrapper ty = (Just ty_rep, marshal) +-- then marshal (e :: ty_rep) :: ty +-- That is, 'marshal' wrape the result returned by the foreign call, +-- of type ty_rep, into the value Haskell expected, of type 'ty' +-- +-- Invariant: ty_rep is always a primitive type +-- i.e. (isPrimitiveType ty_rep) is True + +resultWrapper result_ty + -- Base case 1: primitive types + | isPrimitiveType result_ty + = return (Just result_ty, \e -> e) + + -- Base case 2: the unit type () + | Just (tc,_) <- maybe_tc_app + , tc `hasKey` unitTyConKey + = return (Nothing, \_ -> Var unitDataConId) + + -- Base case 3: the boolean type + | Just (tc,_) <- maybe_tc_app + , tc `hasKey` boolTyConKey + = do { dflags <- getDynFlags + ; let marshal_bool e + = mkWildCase e intPrimTy boolTy + [ (DEFAULT ,[],Var trueDataConId ) + , (LitAlt (mkLitInt dflags 0),[],Var falseDataConId)] + ; return (Just intPrimTy, marshal_bool) } + + -- Newtypes + | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty + = do { (maybe_ty, wrapper) <- resultWrapper rep_ty + ; return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) } + + -- The type might contain foralls (eg. for dummy type arguments, + -- referring to 'Ptr a' is legal). + | Just (tyvar, rest) <- splitForAllTy_maybe result_ty + = do { (maybe_ty, wrapper) <- resultWrapper rest + ; return (maybe_ty, \e -> Lam tyvar (wrapper e)) } + + -- Data types with a single constructor, which has a single arg + -- This includes types like Ptr and ForeignPtr + | Just (tycon, tycon_arg_tys) <- maybe_tc_app + , Just data_con <- isDataProductTyCon_maybe tycon -- One constructor, no existentials + , [unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys -- One argument + = do { dflags <- getDynFlags + ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty + ; let narrow_wrapper = maybeNarrow dflags tycon + marshal_con e = Var (dataConWrapId data_con) + `mkTyApps` tycon_arg_tys + `App` wrapper (narrow_wrapper e) + ; return (maybe_ty, marshal_con) } + + | otherwise + = pprPanic "resultWrapper" (ppr result_ty) + where + maybe_tc_app = splitTyConApp_maybe result_ty + +-- When the result of a foreign call is smaller than the word size, we +-- need to sign- or zero-extend the result up to the word size. The C +-- standard appears to say that this is the responsibility of the +-- caller, not the callee. + +maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr) +maybeNarrow dflags tycon + | tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e + | tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e + | tycon `hasKey` int32TyConKey + && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e + + | tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e + | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e + | tycon `hasKey` word32TyConKey + && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e + | otherwise = id diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs new file mode 100644 index 0000000000..de14f6ee12 --- /dev/null +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -0,0 +1,820 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1998 + + +Desugaring foreign declarations (see also GHC.HsToCore.Foreign.Call). +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.HsToCore.Foreign.Decl ( dsForeigns ) where + +#include "HsVersions.h" +import GhcPrelude + +import TcRnMonad -- temp + +import CoreSyn + +import GHC.HsToCore.Foreign.Call +import GHC.HsToCore.Monad + +import GHC.Hs +import DataCon +import CoreUnfold +import Id +import Literal +import Module +import Name +import Type +import GHC.Types.RepType +import TyCon +import Coercion +import TcEnv +import TcType + +import GHC.Cmm.Expr +import GHC.Cmm.Utils +import HscTypes +import ForeignCall +import TysWiredIn +import TysPrim +import PrelNames +import BasicTypes +import SrcLoc +import Outputable +import FastString +import DynFlags +import GHC.Platform +import OrdList +import Util +import Hooks +import Encoding + +import Data.Maybe +import Data.List + +{- +Desugaring of @foreign@ declarations is naturally split up into +parts, an @import@ and an @export@ part. A @foreign import@ +declaration +\begin{verbatim} + foreign import cc nm f :: prim_args -> IO prim_res +\end{verbatim} +is the same as +\begin{verbatim} + f :: prim_args -> IO prim_res + f a1 ... an = _ccall_ nm cc a1 ... an +\end{verbatim} +so we reuse the desugaring code in @GHC.HsToCore.Foreign.Call@ to deal with these. +-} + +type Binding = (Id, CoreExpr) -- No rec/nonrec structure; + -- the occurrence analyser will sort it all out + +dsForeigns :: [LForeignDecl GhcTc] + -> DsM (ForeignStubs, OrdList Binding) +dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos) + +dsForeigns' :: [LForeignDecl GhcTc] + -> DsM (ForeignStubs, OrdList Binding) +dsForeigns' [] + = return (NoStubs, nilOL) +dsForeigns' fos = do + fives <- mapM do_ldecl fos + let + (hs, cs, idss, bindss) = unzip4 fives + fe_ids = concat idss + fe_init_code = map foreignExportInitialiser fe_ids + -- + return (ForeignStubs + (vcat hs) + (vcat cs $$ vcat fe_init_code), + foldr (appOL . toOL) nilOL bindss) + where + do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl) + + do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do + traceIf (text "fi start" <+> ppr id) + let id' = unLoc id + (bs, h, c) <- dsFImport id' co spec + traceIf (text "fi end" <+> ppr id) + return (h, c, [], bs) + + do_decl (ForeignExport { fd_name = L _ id + , fd_e_ext = co + , fd_fe = CExport + (L _ (CExportStatic _ ext_nm cconv)) _ }) = do + (h, c, _, _) <- dsFExport id co ext_nm cconv False + return (h, c, [id], []) + do_decl (XForeignDecl nec) = noExtCon nec + +{- +************************************************************************ +* * +\subsection{Foreign import} +* * +************************************************************************ + +Desugaring foreign imports is just the matter of creating a binding +that on its RHS unboxes its arguments, performs the external call +(using the @CCallOp@ primop), before boxing the result up and returning it. + +However, we create a worker/wrapper pair, thus: + + foreign import f :: Int -> IO Int +==> + f x = IO ( \s -> case x of { I# x# -> + case fw s x# of { (# s1, y# #) -> + (# s1, I# y# #)}}) + + fw s x# = ccall f s x# + +The strictness/CPR analyser won't do this automatically because it doesn't look +inside returned tuples; but inlining this wrapper is a Really Good Idea +because it exposes the boxing to the call site. +-} + +dsFImport :: Id + -> Coercion + -> ForeignImport + -> DsM ([Binding], SDoc, SDoc) +dsFImport id co (CImport cconv safety mHeader spec _) = + dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader + +dsCImport :: Id + -> Coercion + -> CImportSpec + -> CCallConv + -> Safety + -> Maybe Header + -> DsM ([Binding], SDoc, SDoc) +dsCImport id co (CLabel cid) cconv _ _ = do + dflags <- getDynFlags + let ty = coercionLKind co + fod = case tyConAppTyCon_maybe (dropForAlls ty) of + Just tycon + | tyConUnique tycon == funPtrTyConKey -> + IsFunction + _ -> IsData + (resTy, foRhs) <- resultWrapper ty + ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this + let + rhs = foRhs (Lit (LitLabel cid stdcall_info fod)) + rhs' = Cast rhs co + stdcall_info = fun_type_arg_stdcall_info dflags cconv ty + in + return ([(id, rhs')], empty, empty) + +dsCImport id co (CFunction target) cconv@PrimCallConv safety _ + = dsPrimCall id co (CCall (CCallSpec target cconv safety)) +dsCImport id co (CFunction target) cconv safety mHeader + = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader +dsCImport id co CWrapper cconv _ _ + = dsFExportDynamic id co cconv + +-- For stdcall labels, if the type was a FunPtr or newtype thereof, +-- then we need to calculate the size of the arguments in order to add +-- the @n suffix to the label. +fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int +fun_type_arg_stdcall_info dflags StdCallConv ty + | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty, + tyConUnique tc == funPtrTyConKey + = let + (bndrs, _) = tcSplitPiTys arg_ty + fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs + in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys) +fun_type_arg_stdcall_info _ _other_conv _ + = Nothing + +{- +************************************************************************ +* * +\subsection{Foreign calls} +* * +************************************************************************ +-} + +dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header + -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) +dsFCall fn_id co fcall mDeclHeader = do + let + ty = coercionLKind co + (tv_bndrs, rho) = tcSplitForAllVarBndrs ty + (arg_tys, io_res_ty) = tcSplitFunTys rho + + args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism + (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args) + + let + work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars + + (ccall_result_ty, res_wrapper) <- boxResult io_res_ty + + ccall_uniq <- newUnique + work_uniq <- newUnique + + dflags <- getDynFlags + (fcall', cDoc) <- + case fcall of + CCall (CCallSpec (StaticTarget _ cName mUnitId isFun) + CApiConv safety) -> + do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName) + let fcall' = CCall (CCallSpec + (StaticTarget NoSourceText + wrapperName mUnitId + True) + CApiConv safety) + c = includes + $$ fun_proto <+> braces (cRet <> semi) + includes = vcat [ text "#include \"" <> ftext h + <> text "\"" + | Header _ h <- nub headers ] + fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes + cRet + | isVoidRes = cCall + | otherwise = text "return" <+> cCall + cCall = if isFun + then ppr cName <> parens argVals + else if null arg_tys + then ppr cName + else panic "dsFCall: Unexpected arguments to FFI value import" + raw_res_ty = case tcSplitIOType_maybe io_res_ty of + Just (_ioTyCon, res_ty) -> res_ty + Nothing -> io_res_ty + isVoidRes = raw_res_ty `eqType` unitTy + (mHeader, cResType) + | isVoidRes = (Nothing, text "void") + | otherwise = toCType raw_res_ty + pprCconv = ccallConvAttribute CApiConv + mHeadersArgTypeList + = [ (header, cType <+> char 'a' <> int n) + | (t, n) <- zip arg_tys [1..] + , let (header, cType) = toCType t ] + (mHeaders, argTypeList) = unzip mHeadersArgTypeList + argTypes = if null argTypeList + then text "void" + else hsep $ punctuate comma argTypeList + mHeaders' = mDeclHeader : mHeader : mHeaders + headers = catMaybes mHeaders' + argVals = hsep $ punctuate comma + [ char 'a' <> int n + | (_, n) <- zip arg_tys [1..] ] + return (fcall', c) + _ -> + return (fcall, empty) + let + -- Build the worker + worker_ty = mkForAllTys tv_bndrs (mkVisFunTys (map idType work_arg_ids) ccall_result_ty) + tvs = map binderVar tv_bndrs + the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty + work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) + work_id = mkSysLocal (fsLit "$wccall") work_uniq worker_ty + + -- Build the wrapper + work_app = mkApps (mkVarApps (Var work_id) tvs) val_args + wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers + wrap_rhs = mkLams (tvs ++ args) wrapper_body + wrap_rhs' = Cast wrap_rhs co + fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity + (length args) wrap_rhs' + + return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc) + +{- +************************************************************************ +* * +\subsection{Primitive calls} +* * +************************************************************************ + +This is for `@foreign import prim@' declarations. + +Currently, at the core level we pretend that these primitive calls are +foreign calls. It may make more sense in future to have them as a distinct +kind of Id, or perhaps to bundle them with PrimOps since semantically and +for calling convention they are really prim ops. +-} + +dsPrimCall :: Id -> Coercion -> ForeignCall + -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) +dsPrimCall fn_id co fcall = do + let + ty = coercionLKind co + (tvs, fun_ty) = tcSplitForAllTys ty + (arg_tys, io_res_ty) = tcSplitFunTys fun_ty + + args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism + + ccall_uniq <- newUnique + dflags <- getDynFlags + let + call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty + rhs = mkLams tvs (mkLams args call_app) + rhs' = Cast rhs co + return ([(fn_id, rhs')], empty, empty) + +{- +************************************************************************ +* * +\subsection{Foreign export} +* * +************************************************************************ + +The function that does most of the work for `@foreign export@' declarations. +(see below for the boilerplate code a `@foreign export@' declaration expands + into.) + +For each `@foreign export foo@' in a module M we generate: +\begin{itemize} +\item a C function `@foo@', which calls +\item a Haskell stub `@M.\$ffoo@', which calls +\end{itemize} +the user-written Haskell function `@M.foo@'. +-} + +dsFExport :: Id -- Either the exported Id, + -- or the foreign-export-dynamic constructor + -> Coercion -- Coercion between the Haskell type callable + -- from C, and its representation type + -> CLabelString -- The name to export to C land + -> CCallConv + -> Bool -- True => foreign export dynamic + -- so invoke IO action that's hanging off + -- the first argument's stable pointer + -> DsM ( SDoc -- contents of Module_stub.h + , SDoc -- contents of Module_stub.c + , String -- string describing type to pass to createAdj. + , Int -- size of args to stub function + ) + +dsFExport fn_id co ext_name cconv isDyn = do + let + ty = coercionRKind co + (bndrs, orig_res_ty) = tcSplitPiTys ty + fe_arg_tys' = mapMaybe binderRelevantType_maybe bndrs + -- We must use tcSplits here, because we want to see + -- the (IO t) in the corner of the type! + fe_arg_tys | isDyn = tail fe_arg_tys' + | otherwise = fe_arg_tys' + + -- Look at the result type of the exported function, orig_res_ty + -- If it's IO t, return (t, True) + -- If it's plain t, return (t, False) + (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of + -- The function already returns IO t + Just (_ioTyCon, res_ty) -> (res_ty, True) + -- The function returns t + Nothing -> (orig_res_ty, False) + + dflags <- getDynFlags + return $ + mkFExportCBits dflags ext_name + (if isDyn then Nothing else Just fn_id) + fe_arg_tys res_ty is_IO_res_ty cconv + +{- +@foreign import "wrapper"@ (previously "foreign export dynamic") lets +you dress up Haskell IO actions of some fixed type behind an +externally callable interface (i.e., as a C function pointer). Useful +for callbacks and stuff. + +\begin{verbatim} +type Fun = Bool -> Int -> IO Int +foreign import "wrapper" f :: Fun -> IO (FunPtr Fun) + +-- Haskell-visible constructor, which is generated from the above: +-- SUP: No check for NULL from createAdjustor anymore??? + +f :: Fun -> IO (FunPtr Fun) +f cback = + bindIO (newStablePtr cback) + (\StablePtr sp# -> IO (\s1# -> + case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of + (# s2#, a# #) -> (# s2#, A# a# #))) + +foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun) + +-- and the helper in C: (approximately; see `mkFExportCBits` below) + +f_helper(StablePtr s, HsBool b, HsInt i) +{ + Capability *cap; + cap = rts_lock(); + rts_evalIO(&cap, + rts_apply(rts_apply(deRefStablePtr(s), + rts_mkBool(b)), rts_mkInt(i))); + rts_unlock(cap); +} +\end{verbatim} +-} + +dsFExportDynamic :: Id + -> Coercion + -> CCallConv + -> DsM ([Binding], SDoc, SDoc) +dsFExportDynamic id co0 cconv = do + mod <- getModule + dflags <- getDynFlags + let fe_nm = mkFastString $ zEncodeString + (moduleStableString mod ++ "$" ++ toCName dflags id) + -- Construct the label based on the passed id, don't use names + -- depending on Unique. See #13807 and Note [Unique Determinism]. + cback <- newSysLocalDs arg_ty + newStablePtrId <- dsLookupGlobalId newStablePtrName + stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName + let + stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty] + export_ty = mkVisFunTy stable_ptr_ty arg_ty + bindIOId <- dsLookupGlobalId bindIOName + stbl_value <- newSysLocalDs stable_ptr_ty + (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True + let + {- + The arguments to the external function which will + create a little bit of (template) code on the fly + for allowing the (stable pointed) Haskell closure + to be entered using an external calling convention + (stdcall, ccall). + -} + adj_args = [ mkIntLitInt dflags (ccallConvToInt cconv) + , Var stbl_value + , Lit (LitLabel fe_nm mb_sz_args IsFunction) + , Lit (mkLitString typestring) + ] + -- name of external entry point providing these services. + -- (probably in the RTS.) + adjustor = fsLit "createAdjustor" + + -- Determine the number of bytes of arguments to the stub function, + -- so that we can attach the '@N' suffix to its label if it is a + -- stdcall on Windows. + mb_sz_args = case cconv of + StdCallConv -> Just args_size + _ -> Nothing + + ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty]) + -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback + + let io_app = mkLams tvs $ + Lam cback $ + mkApps (Var bindIOId) + [ Type stable_ptr_ty + , Type res_ty + , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ] + , Lam stbl_value ccall_adj + ] + + fed = (id `setInlineActivation` NeverActive, Cast io_app co0) + -- Never inline the f.e.d. function, because the litlit + -- might not be in scope in other modules. + + return ([fed], h_code, c_code) + + where + ty = coercionLKind co0 + (tvs,sans_foralls) = tcSplitForAllTys ty + ([arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls + Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty + -- Must have an IO type; hence Just + + +toCName :: DynFlags -> Id -> String +toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i))) + +{- +* + +\subsection{Generating @foreign export@ stubs} + +* + +For each @foreign export@ function, a C stub function is generated. +The C stub constructs the application of the exported Haskell function +using the hugs/ghc rts invocation API. +-} + +mkFExportCBits :: DynFlags + -> FastString + -> Maybe Id -- Just==static, Nothing==dynamic + -> [Type] + -> Type + -> Bool -- True <=> returns an IO type + -> CCallConv + -> (SDoc, + SDoc, + String, -- the argument reps + Int -- total size of arguments + ) +mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc + = (header_bits, c_bits, type_string, + sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args + -- NB. the calculation here isn't strictly speaking correct. + -- We have a primitive Haskell type (eg. Int#, Double#), and + -- we want to know the size, when passed on the C stack, of + -- the associated C type (eg. HsInt, HsDouble). We don't have + -- this information to hand, but we know what GHC's conventions + -- are for passing around the primitive Haskell types, so we + -- use that instead. I hope the two coincide --SDM + ) + where + -- list the arguments to the C function + arg_info :: [(SDoc, -- arg name + SDoc, -- C type + Type, -- Haskell type + CmmType)] -- the CmmType + arg_info = [ let stg_type = showStgType ty in + (arg_cname n stg_type, + stg_type, + ty, + typeCmmType dflags (getPrimTyOf ty)) + | (ty,n) <- zip arg_htys [1::Int ..] ] + + arg_cname n stg_ty + | libffi = char '*' <> parens (stg_ty <> char '*') <> + text "args" <> brackets (int (n-1)) + | otherwise = text ('a':show n) + + -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled + libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target + + type_string + -- libffi needs to know the result type too: + | libffi = primTyDescChar dflags res_hty : arg_type_string + | otherwise = arg_type_string + + arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info] + -- just the real args + + -- add some auxiliary args; the stable ptr in the wrapper case, and + -- a slot for the dummy return address in the wrapper + ccall case + aug_arg_info + | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info + | otherwise = arg_info + + stable_ptr_arg = + (text "the_stableptr", text "StgStablePtr", undefined, + typeCmmType dflags (mkStablePtrPrimTy alphaTy)) + + -- stuff to do with the return type of the C function + res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes + + cResType | res_hty_is_unit = text "void" + | otherwise = showStgType res_hty + + -- when the return type is integral and word-sized or smaller, it + -- must be assigned as type ffi_arg (#3516). To see what type + -- libffi is expecting here, take a look in its own testsuite, e.g. + -- libffi/testsuite/libffi.call/cls_align_ulonglong.c + ffi_cResType + | is_ffi_arg_type = text "ffi_arg" + | otherwise = cResType + where + res_ty_key = getUnique (getName (typeTyCon res_hty)) + is_ffi_arg_type = res_ty_key `notElem` + [floatTyConKey, doubleTyConKey, + int64TyConKey, word64TyConKey] + + -- Now we can cook up the prototype for the exported function. + pprCconv = ccallConvAttribute cc + + header_bits = text "extern" <+> fun_proto <> semi + + fun_args + | null aug_arg_info = text "void" + | otherwise = hsep $ punctuate comma + $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info + + fun_proto + | libffi + = text "void" <+> ftext c_nm <> + parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr") + | otherwise + = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args + + -- the target which will form the root of what we ask rts_evalIO to run + the_cfun + = case maybe_target of + Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)" + Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure" + + cap = text "cap" <> comma + + -- the expression we give to rts_evalIO + expr_to_run + = foldl' appArg the_cfun arg_info -- NOT aug_arg_info + where + appArg acc (arg_cname, _, arg_hty, _) + = text "rts_apply" + <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname)) + + -- various other bits for inside the fn + declareResult = text "HaskellObj ret;" + declareCResult | res_hty_is_unit = empty + | otherwise = cResType <+> text "cret;" + + assignCResult | res_hty_is_unit = empty + | otherwise = + text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi + + -- an extern decl for the fn being called + extern_decl + = case maybe_target of + Nothing -> empty + Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi + + + -- finally, the whole darn thing + c_bits = + space $$ + extern_decl $$ + fun_proto $$ + vcat + [ lbrace + , text "Capability *cap;" + , declareResult + , declareCResult + , text "cap = rts_lock();" + -- create the application + perform it. + , text "rts_evalIO" <> parens ( + char '&' <> cap <> + text "rts_apply" <> parens ( + cap <> + text "(HaskellObj)" + <> ptext (if is_IO_res_ty + then (sLit "runIO_closure") + else (sLit "runNonIO_closure")) + <> comma + <> expr_to_run + ) <+> comma + <> text "&ret" + ) <> semi + , text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm) + <> comma <> text "cap") <> semi + , assignCResult + , text "rts_unlock(cap);" + , ppUnless res_hty_is_unit $ + if libffi + then char '*' <> parens (ffi_cResType <> char '*') <> + text "resp = cret;" + else text "return cret;" + , rbrace + ] + + +foreignExportInitialiser :: Id -> SDoc +foreignExportInitialiser hs_fn = + -- Initialise foreign exports by registering a stable pointer from an + -- __attribute__((constructor)) function. + -- The alternative is to do this from stginit functions generated in + -- codeGen/CodeGen.hs; however, stginit functions have a negative impact + -- on binary sizes and link times because the static linker will think that + -- all modules that are imported directly or indirectly are actually used by + -- the program. + -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL) + vcat + [ text "static void stginit_export_" <> ppr hs_fn + <> text "() __attribute__((constructor));" + , text "static void stginit_export_" <> ppr hs_fn <> text "()" + , braces (text "foreignExportStablePtr" + <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure") + <> semi) + ] + + +mkHObj :: Type -> SDoc +mkHObj t = text "rts_mk" <> text (showFFIType t) + +unpackHObj :: Type -> SDoc +unpackHObj t = text "rts_get" <> text (showFFIType t) + +showStgType :: Type -> SDoc +showStgType t = text "Hs" <> text (showFFIType t) + +showFFIType :: Type -> String +showFFIType t = getOccString (getName (typeTyCon t)) + +toCType :: Type -> (Maybe Header, SDoc) +toCType = f False + where f voidOK t + -- First, if we have (Ptr t) of (FunPtr t), then we need to + -- convert t to a C type and put a * after it. If we don't + -- know a type for t, then "void" is fine, though. + | Just (ptr, [t']) <- splitTyConApp_maybe t + , tyConName ptr `elem` [ptrTyConName, funPtrTyConName] + = case f True t' of + (mh, cType') -> + (mh, cType' <> char '*') + -- Otherwise, if we have a type constructor application, then + -- see if there is a C type associated with that constructor. + -- Note that we aren't looking through type synonyms or + -- anything, as it may be the synonym that is annotated. + | Just tycon <- tyConAppTyConPicky_maybe t + , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon + = (mHeader, ftext cType) + -- If we don't know a C type for this type, then try looking + -- through one layer of type synonym etc. + | Just t' <- coreView t + = f voidOK t' + -- This may be an 'UnliftedFFITypes'-style ByteArray# argument + -- (which is marshalled like a Ptr) + | Just byteArrayPrimTyCon == tyConAppTyConPicky_maybe t + = (Nothing, text "const void*") + | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t + = (Nothing, text "void*") + -- Otherwise we don't know the C type. If we are allowing + -- void then return that; otherwise something has gone wrong. + | voidOK = (Nothing, text "void") + | otherwise + = pprPanic "toCType" (ppr t) + +typeTyCon :: Type -> TyCon +typeTyCon ty + | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty) + = tc + | otherwise + = pprPanic "GHC.HsToCore.Foreign.Decl.typeTyCon" (ppr ty) + +insertRetAddr :: DynFlags -> CCallConv + -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] +insertRetAddr dflags CCallConv args + = case platformArch platform of + ArchX86_64 + | platformOS platform == OSMinGW32 -> + -- On other Windows x86_64 we insert the return address + -- after the 4th argument, because this is the point + -- at which we need to flush a register argument to the stack + -- (See rts/Adjustor.c for details). + let go :: Int -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] + go 4 args = ret_addr_arg dflags : args + go n (arg:args) = arg : go (n+1) args + go _ [] = [] + in go 0 args + | otherwise -> + -- On other x86_64 platforms we insert the return address + -- after the 6th integer argument, because this is the point + -- at which we need to flush a register argument to the stack + -- (See rts/Adjustor.c for details). + let go :: Int -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] + go 6 args = ret_addr_arg dflags : args + go n (arg@(_,_,_,rep):args) + | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args + | otherwise = arg : go n args + go _ [] = [] + in go 0 args + _ -> + ret_addr_arg dflags : args + where platform = targetPlatform dflags +insertRetAddr _ _ args = args + +ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType) +ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined, + typeCmmType dflags addrPrimTy) + +-- This function returns the primitive type associated with the boxed +-- type argument to a foreign export (eg. Int ==> Int#). +getPrimTyOf :: Type -> UnaryType +getPrimTyOf ty + | isBoolTy rep_ty = intPrimTy + -- Except for Bool, the types we are interested in have a single constructor + -- with a single primitive-typed argument (see TcType.legalFEArgTyCon). + | otherwise = + case splitDataProductType_maybe rep_ty of + Just (_, _, data_con, [prim_ty]) -> + ASSERT(dataConSourceArity data_con == 1) + ASSERT2(isUnliftedType prim_ty, ppr prim_ty) + prim_ty + _other -> pprPanic "GHC.HsToCore.Foreign.Decl.getPrimTyOf" (ppr ty) + where + rep_ty = unwrapType ty + +-- represent a primitive type as a Char, for building a string that +-- described the foreign function type. The types are size-dependent, +-- e.g. 'W' is a signed 32-bit integer. +primTyDescChar :: DynFlags -> Type -> Char +primTyDescChar dflags ty + | ty `eqType` unitTy = 'v' + | otherwise + = case typePrimRep1 (getPrimTyOf ty) of + IntRep -> signed_word + WordRep -> unsigned_word + Int64Rep -> 'L' + Word64Rep -> 'l' + AddrRep -> 'p' + FloatRep -> 'f' + DoubleRep -> 'd' + _ -> pprPanic "primTyDescChar" (ppr ty) + where + (signed_word, unsigned_word) + | wORD_SIZE dflags == 4 = ('W','w') + | wORD_SIZE dflags == 8 = ('L','l') + | otherwise = panic "primTyDescChar" diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs new file mode 100644 index 0000000000..94821ec68e --- /dev/null +++ b/compiler/GHC/HsToCore/GuardedRHSs.hs @@ -0,0 +1,155 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Matching guarded right-hand-sides (GRHSs) +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.HsToCore.GuardedRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr, dsLocalBinds ) +import {-# SOURCE #-} GHC.HsToCore.Match ( matchSinglePatVar ) + +import GHC.Hs +import MkCore +import CoreSyn +import CoreUtils (bindNonRec) + +import BasicTypes (Origin(FromSource)) +import DynFlags +import GHC.HsToCore.PmCheck (needToRunPmCheck, addTyCsDs, addPatTmCs, addScrutTmCs) +import GHC.HsToCore.Monad +import GHC.HsToCore.Utils +import Type ( Type ) +import Util +import SrcLoc +import Outputable + +{- +@dsGuarded@ is used for pattern bindings. +It desugars: +\begin{verbatim} + | g1 -> e1 + ... + | gn -> en + where binds +\end{verbatim} +producing an expression with a runtime error in the corner if +necessary. The type argument gives the type of the @ei@. +-} + +dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM CoreExpr +dsGuarded grhss rhs_ty = do + match_result <- dsGRHSs PatBindRhs grhss rhs_ty + error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty + extractMatchResult match_result error_expr + +-- In contrast, @dsGRHSs@ produces a @MatchResult@. + +dsGRHSs :: HsMatchContext GhcRn + -> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs + -> Type -- Type of RHS + -> DsM MatchResult +dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty + = ASSERT( notNull grhss ) + do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss + ; let match_result1 = foldr1 combineMatchResults match_results + match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1 + -- NB: nested dsLet inside matchResult + ; return match_result2 } +dsGRHSs _ (XGRHSs nec) _ = noExtCon nec + +dsGRHS :: HsMatchContext GhcRn -> Type -> LGRHS GhcTc (LHsExpr GhcTc) + -> DsM MatchResult +dsGRHS hs_ctx rhs_ty (L _ (GRHS _ guards rhs)) + = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty +dsGRHS _ _ (L _ (XGRHS nec)) = noExtCon nec + +{- +************************************************************************ +* * +* matchGuard : make a MatchResult from a guarded RHS * +* * +************************************************************************ +-} + +matchGuards :: [GuardStmt GhcTc] -- Guard + -> HsStmtContext GhcRn -- Context + -> LHsExpr GhcTc -- RHS + -> Type -- Type of RHS of guard + -> DsM MatchResult + +-- See comments with HsExpr.Stmt re what a BodyStmt means +-- Here we must be in a guard context (not do-expression, nor list-comp) + +matchGuards [] _ rhs _ + = do { core_rhs <- dsLExpr rhs + ; return (cantFailMatchResult core_rhs) } + + -- BodyStmts must be guards + -- Turn an "otherwise" guard is a no-op. This ensures that + -- you don't get a "non-exhaustive eqns" message when the guards + -- finish in "otherwise". + -- NB: The success of this clause depends on the typechecker not + -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors + -- If it does, you'll get bogus overlap warnings +matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty + | Just addTicks <- isTrueLHsExpr e = do + match_result <- matchGuards stmts ctx rhs rhs_ty + return (adjustMatchResultDs addTicks match_result) +matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do + match_result <- matchGuards stmts ctx rhs rhs_ty + pred_expr <- dsLExpr expr + return (mkGuardedMatchResult pred_expr match_result) + +matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do + match_result <- matchGuards stmts ctx rhs rhs_ty + return (adjustMatchResultDs (dsLocalBinds binds) match_result) + -- NB the dsLet occurs inside the match_result + -- Reason: dsLet takes the body expression as its argument + -- so we can't desugar the bindings without the + -- body expression in hand + +matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do + let upat = unLoc pat + dicts = collectEvVarsPat upat + match_var <- selectMatchVar upat + + dflags <- getDynFlags + match_result <- + -- See Note [Type and Term Equality Propagation] in Check + applyWhen (needToRunPmCheck dflags FromSource) + -- FromSource might not be accurate, but at worst + -- we do superfluous calls to the pattern match + -- oracle. + (addTyCsDs dicts . addScrutTmCs (Just bind_rhs) [match_var] . addPatTmCs [upat] [match_var]) + (matchGuards stmts ctx rhs rhs_ty) + core_rhs <- dsLExpr bind_rhs + match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty + match_result + pure $ adjustMatchResult (bindNonRec match_var core_rhs) match_result' + +matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt" +matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt" +matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt" +matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt" +matchGuards (ApplicativeStmt {} : _) _ _ _ = + panic "matchGuards ApplicativeLastStmt" +matchGuards (XStmtLR nec : _) _ _ _ = + noExtCon nec + +{- +Should {\em fail} if @e@ returns @D@ +\begin{verbatim} +f x | p <- e', let C y# = e, f y# = r1 + | otherwise = r2 +\end{verbatim} +-} diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs new file mode 100644 index 0000000000..a8ed3bbcb3 --- /dev/null +++ b/compiler/GHC/HsToCore/ListComp.hs @@ -0,0 +1,676 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Desugaring list comprehensions, monad comprehensions and array comprehensions +-} + +{-# LANGUAGE CPP, NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.HsToCore.ListComp ( dsListComp, dsMonadComp ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsHandleMonadicFailure, dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) + +import GHC.Hs +import TcHsSyn +import CoreSyn +import MkCore + +import GHC.HsToCore.Monad -- the monadery used in the desugarer +import GHC.HsToCore.Utils + +import DynFlags +import CoreUtils +import Id +import Type +import TysWiredIn +import GHC.HsToCore.Match +import PrelNames +import SrcLoc +import Outputable +import TcType +import ListSetOps( getNth ) +import Util + +{- +List comprehensions may be desugared in one of two ways: ``ordinary'' +(as you would expect if you read SLPJ's book) and ``with foldr/build +turned on'' (if you read Gill {\em et al.}'s paper on the subject). + +There will be at least one ``qualifier'' in the input. +-} + +dsListComp :: [ExprLStmt GhcTc] + -> Type -- Type of entire list + -> DsM CoreExpr +dsListComp lquals res_ty = do + dflags <- getDynFlags + let quals = map unLoc lquals + elt_ty = case tcTyConAppArgs res_ty of + [elt_ty] -> elt_ty + _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals) + + if not (gopt Opt_EnableRewriteRules dflags) || gopt Opt_IgnoreInterfacePragmas dflags + -- Either rules are switched off, or we are ignoring what there are; + -- Either way foldr/build won't happen, so use the more efficient + -- Wadler-style desugaring + || isParallelComp quals + -- Foldr-style desugaring can't handle parallel list comprehensions + then deListComp quals (mkNilExpr elt_ty) + else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals) + -- Foldr/build should be enabled, so desugar + -- into foldrs and builds + + where + -- We must test for ParStmt anywhere, not just at the head, because an extension + -- to list comprehensions would be to add brackets to specify the associativity + -- of qualifier lists. This is really easy to do by adding extra ParStmts into the + -- mix of possibly a single element in length, so we do this to leave the possibility open + isParallelComp = any isParallelStmt + + isParallelStmt (ParStmt {}) = True + isParallelStmt _ = False + + +-- This function lets you desugar a inner list comprehension and a list of the binders +-- of that comprehension that we need in the outer comprehension into such an expression +-- and the type of the elements that it outputs (tuples of binders) +dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type) +dsInnerListComp (ParStmtBlock _ stmts bndrs _) + = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs + list_ty = mkListTy bndrs_tuple_type + + -- really use original bndrs below! + ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty + + ; return (expr, bndrs_tuple_type) } +dsInnerListComp (XParStmtBlock nec) = noExtCon nec + +-- This function factors out commonality between the desugaring strategies for GroupStmt. +-- Given such a statement it gives you back an expression representing how to compute the transformed +-- list and the tuple that you need to bind from that list in order to proceed with your desugaring +dsTransStmt :: ExprStmt GhcTc -> DsM (CoreExpr, LPat GhcTc) +dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap + , trS_by = by, trS_using = using }) = do + let (from_bndrs, to_bndrs) = unzip binderMap + + let from_bndrs_tys = map idType from_bndrs + to_bndrs_tys = map idType to_bndrs + + to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys + + -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders + (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExtField stmts + from_bndrs noSyntaxExpr) + + -- Work out what arguments should be supplied to that expression: i.e. is an extraction + -- function required? If so, create that desugared function and add to arguments + usingExpr' <- dsLExpr using + usingArgs' <- case by of + Nothing -> return [expr'] + Just by_e -> do { by_e' <- dsLExpr by_e + ; lam' <- matchTuple from_bndrs by_e' + ; return [lam', expr'] } + + -- Create an unzip function for the appropriate arity and element types and find "map" + unzip_stuff' <- mkUnzipBind form from_bndrs_tys + map_id <- dsLookupGlobalId mapName + + -- Generate the expressions to build the grouped list + let -- First we apply the grouping function to the inner list + inner_list_expr' = mkApps usingExpr' usingArgs' + -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists + -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and + -- the "b" to be a tuple of "to" lists! + -- Then finally we bind the unzip function around that expression + bound_unzipped_inner_list_expr' + = case unzip_stuff' of + Nothing -> inner_list_expr' + Just (unzip_fn', unzip_rhs') -> + Let (Rec [(unzip_fn', unzip_rhs')]) $ + mkApps (Var map_id) $ + [ Type (mkListTy from_tup_ty) + , Type to_bndrs_tup_ty + , Var unzip_fn' + , inner_list_expr' ] + + dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr')) + (text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using) + + -- Build a pattern that ensures the consumer binds into the NEW binders, + -- which hold lists rather than single values + let pat = mkBigLHsVarPatTupId to_bndrs -- NB: no '! + return (bound_unzipped_inner_list_expr', pat) + +dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt" + +{- +************************************************************************ +* * +* Ordinary desugaring of list comprehensions * +* * +************************************************************************ + +Just as in Phil's chapter~7 in SLPJ, using the rules for +optimally-compiled list comprehensions. This is what Kevin followed +as well, and I quite happily do the same. The TQ translation scheme +transforms a list of qualifiers (either boolean expressions or +generators) into a single expression which implements the list +comprehension. Because we are generating 2nd-order polymorphic +lambda-calculus, calls to NIL and CONS must be applied to a type +argument, as well as their usual value arguments. +\begin{verbatim} +TE << [ e | qs ] >> = TQ << [ e | qs ] ++ Nil (typeOf e) >> + +(Rule C) +TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <> TE <> + +(Rule B) +TQ << [ e | b , qs ] ++ L >> = + if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >> + +(Rule A') +TQ << [ e | p <- L1, qs ] ++ L2 >> = + letrec + h = \ u1 -> + case u1 of + [] -> TE << L2 >> + (u2 : u3) -> + (( \ TE << p >> -> ( TQ << [e | qs] ++ (h u3) >> )) u2) + [] (h u3) + in + h ( TE << L1 >> ) + +"h", "u1", "u2", and "u3" are new variables. +\end{verbatim} + +@deListComp@ is the TQ translation scheme. Roughly speaking, @dsExpr@ +is the TE translation scheme. Note that we carry around the @L@ list +already desugared. @dsListComp@ does the top TE rule mentioned above. + +To the above, we add an additional rule to deal with parallel list +comprehensions. The translation goes roughly as follows: + [ e | p1 <- e11, let v1 = e12, p2 <- e13 + | q1 <- e21, let v2 = e22, q2 <- e23] + => + [ e | ((x1, .., xn), (y1, ..., ym)) <- + zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13] + [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]] +where (x1, .., xn) are the variables bound in p1, v1, p2 + (y1, .., ym) are the variables bound in q1, v2, q2 + +In the translation below, the ParStmt branch translates each parallel branch +into a sub-comprehension, and desugars each independently. The resulting lists +are fed to a zip function, we create a binding for all the variables bound in all +the comprehensions, and then we hand things off the desugarer for bindings. +The zip function is generated here a) because it's small, and b) because then we +don't have to deal with arbitrary limits on the number of zip functions in the +prelude, nor which library the zip function came from. +The introduced tuples are Boxed, but only because I couldn't get it to work +with the Unboxed variety. +-} + +deListComp :: [ExprStmt GhcTc] -> CoreExpr -> DsM CoreExpr + +deListComp [] _ = panic "deListComp" + +deListComp (LastStmt _ body _ _ : quals) list + = -- Figure 7.4, SLPJ, p 135, rule C above + ASSERT( null quals ) + do { core_body <- dsLExpr body + ; return (mkConsExpr (exprType core_body) core_body list) } + + -- Non-last: must be a guard +deListComp (BodyStmt _ guard _ _ : quals) list = do -- rule B above + core_guard <- dsLExpr guard + core_rest <- deListComp quals list + return (mkIfThenElse core_guard core_rest list) + +-- [e | let B, qs] = let B in [e | qs] +deListComp (LetStmt _ binds : quals) list = do + core_rest <- deListComp quals list + dsLocalBinds binds core_rest + +deListComp (stmt@(TransStmt {}) : quals) list = do + (inner_list_expr, pat) <- dsTransStmt stmt + deBindComp pat inner_list_expr quals list + +deListComp (BindStmt _ pat list1 _ _ : quals) core_list2 = do -- rule A' above + core_list1 <- dsLExprNoLP list1 + deBindComp pat core_list1 quals core_list2 + +deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list + = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs + ; let (exps, qual_tys) = unzip exps_and_qual_tys + + ; (zip_fn, zip_rhs) <- mkZipBind qual_tys + + -- Deal with [e | pat <- zip l1 .. ln] in example above + ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) + quals list } + where + bndrs_s = [bs | ParStmtBlock _ _ bs _ <- stmtss_w_bndrs] + + -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above + pat = mkBigLHsPatTupId pats + pats = map mkBigLHsVarPatTupId bndrs_s + +deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt" + +deListComp (ApplicativeStmt {} : _) _ = + panic "deListComp ApplicativeStmt" + +deListComp (XStmtLR nec : _) _ = + noExtCon nec + +deBindComp :: OutPat GhcTc + -> CoreExpr + -> [ExprStmt GhcTc] + -> CoreExpr + -> DsM (Expr Id) +deBindComp pat core_list1 quals core_list2 = do + let u3_ty@u1_ty = exprType core_list1 -- two names, same thing + + -- u1_ty is a [alpha] type, and u2_ty = alpha + let u2_ty = hsLPatType pat + + let res_ty = exprType core_list2 + h_ty = u1_ty `mkVisFunTy` res_ty + + -- no levity polymorphism here, as list comprehensions don't work + -- with RebindableSyntax. NB: These are *not* monad comps. + [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] + + -- the "fail" value ... + let + core_fail = App (Var h) (Var u3) + letrec_body = App (Var h) core_list1 + + rest_expr <- deListComp quals core_fail + core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail + + let + rhs = Lam u1 $ + Case (Var u1) u1 res_ty + [(DataAlt nilDataCon, [], core_list2), + (DataAlt consDataCon, [u2, u3], core_match)] + -- Increasing order of tag + + return (Let (Rec [(h, rhs)]) letrec_body) + +{- +************************************************************************ +* * +* Foldr/Build desugaring of list comprehensions * +* * +************************************************************************ + +@dfListComp@ are the rules used with foldr/build turned on: + +\begin{verbatim} +TE[ e | ] c n = c e n +TE[ e | b , q ] c n = if b then TE[ e | q ] c n else n +TE[ e | p <- l , q ] c n = let + f = \ x b -> case x of + p -> TE[ e | q ] c b + _ -> b + in + foldr f n l +\end{verbatim} +-} + +dfListComp :: Id -> Id -- 'c' and 'n' + -> [ExprStmt GhcTc] -- the rest of the qual's + -> DsM CoreExpr + +dfListComp _ _ [] = panic "dfListComp" + +dfListComp c_id n_id (LastStmt _ body _ _ : quals) + = ASSERT( null quals ) + do { core_body <- dsLExprNoLP body + ; return (mkApps (Var c_id) [core_body, Var n_id]) } + + -- Non-last: must be a guard +dfListComp c_id n_id (BodyStmt _ guard _ _ : quals) = do + core_guard <- dsLExpr guard + core_rest <- dfListComp c_id n_id quals + return (mkIfThenElse core_guard core_rest (Var n_id)) + +dfListComp c_id n_id (LetStmt _ binds : quals) = do + -- new in 1.3, local bindings + core_rest <- dfListComp c_id n_id quals + dsLocalBinds binds core_rest + +dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do + (inner_list_expr, pat) <- dsTransStmt stmt + -- Anyway, we bind the newly grouped list via the generic binding function + dfBindComp c_id n_id (pat, inner_list_expr) quals + +dfListComp c_id n_id (BindStmt _ pat list1 _ _ : quals) = do + -- evaluate the two lists + core_list1 <- dsLExpr list1 + + -- Do the rest of the work in the generic binding builder + dfBindComp c_id n_id (pat, core_list1) quals + +dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt" +dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt" +dfListComp _ _ (ApplicativeStmt {} : _) = + panic "dfListComp ApplicativeStmt" +dfListComp _ _ (XStmtLR nec : _) = + noExtCon nec + +dfBindComp :: Id -> Id -- 'c' and 'n' + -> (LPat GhcTc, CoreExpr) + -> [ExprStmt GhcTc] -- the rest of the qual's + -> DsM CoreExpr +dfBindComp c_id n_id (pat, core_list1) quals = do + -- find the required type + let x_ty = hsLPatType pat + let b_ty = idType n_id + + -- create some new local id's + b <- newSysLocalDs b_ty + x <- newSysLocalDs x_ty + + -- build rest of the comprehension + core_rest <- dfListComp c_id b quals + + -- build the pattern match + core_expr <- matchSimply (Var x) (StmtCtxt ListComp) + pat core_rest (Var b) + + -- now build the outermost foldr, and return + mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1 + +{- +************************************************************************ +* * +\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring} +* * +************************************************************************ +-} + +mkZipBind :: [Type] -> DsM (Id, CoreExpr) +-- mkZipBind [t1, t2] +-- = (zip, \as1:[t1] as2:[t2] +-- -> case as1 of +-- [] -> [] +-- (a1:as'1) -> case as2 of +-- [] -> [] +-- (a2:as'2) -> (a1, a2) : zip as'1 as'2)] + +mkZipBind elt_tys = do + ass <- mapM newSysLocalDs elt_list_tys + as' <- mapM newSysLocalDs elt_tys + as's <- mapM newSysLocalDs elt_list_tys + + zip_fn <- newSysLocalDs zip_fn_ty + + let inner_rhs = mkConsExpr elt_tuple_ty + (mkBigCoreVarTup as') + (mkVarApps (Var zip_fn) as's) + zip_body = foldr mk_case inner_rhs (zip3 ass as' as's) + + return (zip_fn, mkLams ass zip_body) + where + elt_list_tys = map mkListTy elt_tys + elt_tuple_ty = mkBigCoreTupTy elt_tys + elt_tuple_list_ty = mkListTy elt_tuple_ty + + zip_fn_ty = mkVisFunTys elt_list_tys elt_tuple_list_ty + + mk_case (as, a', as') rest + = Case (Var as) as elt_tuple_list_ty + [(DataAlt nilDataCon, [], mkNilExpr elt_tuple_ty), + (DataAlt consDataCon, [a', as'], rest)] + -- Increasing order of tag + + +mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr)) +-- mkUnzipBind [t1, t2] +-- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2]) +-- -> case ax of +-- (x1, x2) -> case axs of +-- (xs1, xs2) -> (x1 : xs1, x2 : xs2)) +-- ([], []) +-- ys) +-- +-- We use foldr here in all cases, even if rules are turned off, because we may as well! +mkUnzipBind ThenForm _ + = return Nothing -- No unzipping for ThenForm +mkUnzipBind _ elt_tys + = do { ax <- newSysLocalDs elt_tuple_ty + ; axs <- newSysLocalDs elt_list_tuple_ty + ; ys <- newSysLocalDs elt_tuple_list_ty + ; xs <- mapM newSysLocalDs elt_tys + ; xss <- mapM newSysLocalDs elt_list_tys + + ; unzip_fn <- newSysLocalDs unzip_fn_ty + + ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply] + + ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys) + concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss)) + tupled_concat_expression = mkBigCoreTup concat_expressions + + folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs) + folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax) + folder_body = mkLams [ax, axs] folder_body_outer_case + + ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys) + ; return (Just (unzip_fn, mkLams [ys] unzip_body)) } + where + elt_tuple_ty = mkBigCoreTupTy elt_tys + elt_tuple_list_ty = mkListTy elt_tuple_ty + elt_list_tys = map mkListTy elt_tys + elt_list_tuple_ty = mkBigCoreTupTy elt_list_tys + + unzip_fn_ty = elt_tuple_list_ty `mkVisFunTy` elt_list_tuple_ty + + mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail + +-- Translation for monad comprehensions + +-- Entry point for monad comprehension desugaring +dsMonadComp :: [ExprLStmt GhcTc] -> DsM CoreExpr +dsMonadComp stmts = dsMcStmts stmts + +dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr +dsMcStmts [] = panic "dsMcStmts" +dsMcStmts ((L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) + +--------------- +dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr + +dsMcStmt (LastStmt _ body _ ret_op) stmts + = ASSERT( null stmts ) + do { body' <- dsLExpr body + ; dsSyntaxExpr ret_op [body'] } + +-- [ .. | let binds, stmts ] +dsMcStmt (LetStmt _ binds) stmts + = do { rest <- dsMcStmts stmts + ; dsLocalBinds binds rest } + +-- [ .. | a <- m, stmts ] +dsMcStmt (BindStmt bind_ty pat rhs bind_op fail_op) stmts + = do { rhs' <- dsLExpr rhs + ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts } + +-- Apply `guard` to the `exp` expression +-- +-- [ .. | exp, stmts ] +-- +dsMcStmt (BodyStmt _ exp then_exp guard_exp) stmts + = do { exp' <- dsLExpr exp + ; rest <- dsMcStmts stmts + ; guard_exp' <- dsSyntaxExpr guard_exp [exp'] + ; dsSyntaxExpr then_exp [guard_exp', rest] } + +-- Group statements desugar like this: +-- +-- [| (q, then group by e using f); rest |] +-- ---> f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup -> +-- case unzip n_tup of qv' -> [| rest |] +-- +-- where variables (v1:t1, ..., vk:tk) are bound by q +-- qv = (v1, ..., vk) +-- qt = (t1, ..., tk) +-- (>>=) :: m2 a -> (a -> m3 b) -> m3 b +-- f :: forall a. (a -> t) -> m1 a -> m2 (n a) +-- n_tup :: n qt +-- unzip :: n qt -> (n t1, ..., n tk) (needs Functor n) + +dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs + , trS_by = by, trS_using = using + , trS_ret = return_op, trS_bind = bind_op + , trS_ext = n_tup_ty' -- n (a,b,c) + , trS_fmap = fmap_op, trS_form = form }) stmts_rest + = do { let (from_bndrs, to_bndrs) = unzip bndrs + + ; let from_bndr_tys = map idType from_bndrs -- Types ty + + + -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders + ; expr' <- dsInnerMonadComp stmts from_bndrs return_op + + -- Work out what arguments should be supplied to that expression: i.e. is an extraction + -- function required? If so, create that desugared function and add to arguments + ; usingExpr' <- dsLExpr using + ; usingArgs' <- case by of + Nothing -> return [expr'] + Just by_e -> do { by_e' <- dsLExpr by_e + ; lam' <- matchTuple from_bndrs by_e' + ; return [lam', expr'] } + + -- Generate the expressions to build the grouped list + -- Build a pattern that ensures the consumer binds into the NEW binders, + -- which hold monads rather than single values + ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs + + ; body <- dsMcStmts stmts_rest + ; n_tup_var' <- newSysLocalDsNoLP n_tup_ty' + ; tup_n_var' <- newSysLocalDs tup_n_ty' + ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys + ; us <- newUniqueSupply + ; let rhs' = mkApps usingExpr' usingArgs' + body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr' + + ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] } + +-- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel +-- statements, for example: +-- +-- [ body | qs1 | qs2 | qs3 ] +-- -> [ body | (bndrs1, (bndrs2, bndrs3)) +-- <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ] +-- +-- where `mzip` has type +-- mzip :: forall a b. m a -> m b -> m (a,b) +-- NB: we need a polymorphic mzip because we call it several times + +dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest + = do { exps_w_tys <- mapM ds_inner blocks -- Pairs (exp :: m ty, ty) + ; mzip_op' <- dsExpr mzip_op + + ; let -- The pattern variables + pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- blocks] + -- Pattern with tuples of variables + -- [v1,v2,v3] => (v1, (v2, v3)) + pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats + (rhs, _) = foldr1 (\(e1,t1) (e2,t2) -> + (mkApps mzip_op' [Type t1, Type t2, e1, e2], + mkBoxedTupleTy [t1,t2])) + exps_w_tys + + ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest } + where + ds_inner (ParStmtBlock _ stmts bndrs return_op) + = do { exp <- dsInnerMonadComp stmts bndrs return_op + ; return (exp, mkBigCoreVarTupTy bndrs) } + ds_inner (XParStmtBlock nec) = noExtCon nec + +dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) + + +matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr +-- (matchTuple [a,b,c] body) +-- returns the Core term +-- \x. case x of (a,b,c) -> body +matchTuple ids body + = do { us <- newUniqueSupply + ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids) + ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) } + +-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a +-- desugared `CoreExpr` +dsMcBindStmt :: LPat GhcTc + -> CoreExpr -- ^ the desugared rhs of the bind statement + -> SyntaxExpr GhcTc + -> SyntaxExpr GhcTc + -> Type -- ^ S in (>>=) :: Q -> (R -> S) -> T + -> [ExprLStmt GhcTc] + -> DsM CoreExpr +dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts + = do { body <- dsMcStmts stmts + ; var <- selectSimpleMatchVarL pat + ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat + res1_ty (cantFailMatchResult body) + ; match_code <- dsHandleMonadicFailure pat match fail_op + ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } + +-- Desugar nested monad comprehensions, for example in `then..` constructs +-- dsInnerMonadComp quals [a,b,c] ret_op +-- returns the desugaring of +-- [ (a,b,c) | quals ] + +dsInnerMonadComp :: [ExprLStmt GhcTc] + -> [Id] -- Return a tuple of these variables + -> SyntaxExpr GhcTc -- The monomorphic "return" operator + -> DsM CoreExpr +dsInnerMonadComp stmts bndrs ret_op + = dsMcStmts (stmts ++ + [noLoc (LastStmt noExtField (mkBigLHsVarTupId bndrs) False ret_op)]) + + +-- The `unzip` function for `GroupStmt` in a monad comprehensions +-- +-- unzip :: m (a,b,..) -> (m a,m b,..) +-- unzip m_tuple = ( liftM selN1 m_tuple +-- , liftM selN2 m_tuple +-- , .. ) +-- +-- mkMcUnzipM fmap ys [t1, t2] +-- = ( fmap (selN1 :: (t1, t2) -> t1) ys +-- , fmap (selN2 :: (t1, t2) -> t2) ys ) + +mkMcUnzipM :: TransForm + -> HsExpr GhcTcId -- fmap + -> Id -- Of type n (a,b,c) + -> [Type] -- [a,b,c] (not levity-polymorphic) + -> DsM CoreExpr -- Of type (n a, n b, n c) +mkMcUnzipM ThenForm _ ys _ + = return (Var ys) -- No unzipping to do + +mkMcUnzipM _ fmap_op ys elt_tys + = do { fmap_op' <- dsExpr fmap_op + ; xs <- mapM newSysLocalDs elt_tys + ; let tup_ty = mkBigCoreTupTy elt_tys + ; tup_xs <- newSysLocalDs tup_ty + + ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b + [ Type tup_ty, Type (getNth elt_tys i) + , mk_sel i, Var ys] + + mk_sel n = Lam tup_xs $ + mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs) + + ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) } diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs new file mode 100644 index 0000000000..16bf73aab8 --- /dev/null +++ b/compiler/GHC/HsToCore/Match.hs @@ -0,0 +1,1151 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +The @match@ function +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.HsToCore.Match + ( match, matchEquations, matchWrapper, matchSimply + , matchSinglePat, matchSinglePatVar + ) +where + +#include "HsVersions.h" + +import GhcPrelude + +import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr) + +import BasicTypes ( Origin(..) ) +import DynFlags +import GHC.Hs +import TcHsSyn +import TcEvidence +import TcRnMonad +import GHC.HsToCore.PmCheck +import CoreSyn +import Literal +import CoreUtils +import MkCore +import GHC.HsToCore.Monad +import GHC.HsToCore.Binds +import GHC.HsToCore.GuardedRHSs +import GHC.HsToCore.Utils +import Id +import ConLike +import DataCon +import PatSyn +import GHC.HsToCore.Match.Constructor +import GHC.HsToCore.Match.Literal +import Type +import Coercion ( eqCoercion ) +import TyCon( isNewTyCon ) +import TysWiredIn +import SrcLoc +import Maybes +import Util +import Name +import Outputable +import BasicTypes ( isGenerated, il_value, fl_value ) +import FastString +import Unique +import UniqDFM + +import Control.Monad( when, unless ) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NEL +import qualified Data.Map as Map + +{- +************************************************************************ +* * + The main matching function +* * +************************************************************************ + +The function @match@ is basically the same as in the Wadler chapter +from "The Implementation of Functional Programming Languages", +except it is monadised, to carry around the name supply, info about +annotations, etc. + +Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns: +\begin{enumerate} +\item +A list of $n$ variable names, those variables presumably bound to the +$n$ expressions being matched against the $n$ patterns. Using the +list of $n$ expressions as the first argument showed no benefit and +some inelegance. + +\item +The second argument, a list giving the ``equation info'' for each of +the $m$ equations: +\begin{itemize} +\item +the $n$ patterns for that equation, and +\item +a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on +the front'' of the matching code, as in: +\begin{verbatim} +let +in +\end{verbatim} +\item +and finally: (ToDo: fill in) + +The right way to think about the ``after-match function'' is that it +is an embryonic @CoreExpr@ with a ``hole'' at the end for the +final ``else expression''. +\end{itemize} + +There is a data type, @EquationInfo@, defined in module @GHC.HsToCore.Monad@. + +An experiment with re-ordering this information about equations (in +particular, having the patterns available in column-major order) +showed no benefit. + +\item +A default expression---what to evaluate if the overall pattern-match +fails. This expression will (almost?) always be +a measly expression @Var@, unless we know it will only be used once +(as we do in @glue_success_exprs@). + +Leaving out this third argument to @match@ (and slamming in lots of +@Var "fail"@s) is a positively {\em bad} idea, because it makes it +impossible to share the default expressions. (Also, it stands no +chance of working in our post-upheaval world of @Locals@.) +\end{enumerate} + +Note: @match@ is often called via @matchWrapper@ (end of this module), +a function that does much of the house-keeping that goes with a call +to @match@. + +It is also worth mentioning the {\em typical} way a block of equations +is desugared with @match@. At each stage, it is the first column of +patterns that is examined. The steps carried out are roughly: +\begin{enumerate} +\item +Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add +bindings to the second component of the equation-info): +\item +Now {\em unmix} the equations into {\em blocks} [w\/ local function +@match_groups@], in which the equations in a block all have the same + match group. +(see ``the mixture rule'' in SLPJ). +\item +Call the right match variant on each block of equations; it will do the +appropriate thing for each kind of column-1 pattern. +\end{enumerate} + +We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87) +than the Wadler-chapter code for @match@ (p.~93, first @match@ clause). +And gluing the ``success expressions'' together isn't quite so pretty. + +This @match@ uses @tidyEqnInfo@ +to get `as'- and `twiddle'-patterns out of the way (tidying), before +applying ``the mixture rule'' (SLPJ, p.~88) [which really {\em +un}mixes the equations], producing a list of equation-info +blocks, each block having as its first column patterns compatible with each other. + +Note [Match Ids] +~~~~~~~~~~~~~~~~ +Most of the matching functions take an Id or [Id] as argument. This Id +is the scrutinee(s) of the match. The desugared expression may +sometimes use that Id in a local binding or as a case binder. So it +should not have an External name; Lint rejects non-top-level binders +with External names (#13043). + +See also Note [Localise pattern binders] in GHC.HsToCore.Utils +-} + +type MatchId = Id -- See Note [Match Ids] + +match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with. See Note [Match Ids] + -> Type -- ^ Type of the case expression + -> [EquationInfo] -- ^ Info about patterns, etc. (type synonym below) + -> DsM MatchResult -- ^ Desugared result! + +match [] ty eqns + = ASSERT2( not (null eqns), ppr ty ) + return (foldr1 combineMatchResults match_results) + where + match_results = [ ASSERT( null (eqn_pats eqn) ) + eqn_rhs eqn + | eqn <- eqns ] + +match (v:vs) ty eqns -- Eqns *can* be empty + = ASSERT2( all (isInternalName . idName) vars, ppr vars ) + do { dflags <- getDynFlags + -- Tidy the first pattern, generating + -- auxiliary bindings if necessary + ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns + -- Group the equations and match each group in turn + ; let grouped = groupEquations dflags tidy_eqns + + -- print the view patterns that are commoned up to help debug + ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped) + + ; match_results <- match_groups grouped + ; return (adjustMatchResult (foldr (.) id aux_binds) $ + foldr1 combineMatchResults match_results) } + where + vars = v :| vs + + dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo + dropGroup = fmap snd + + match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty MatchResult) + -- Result list of [MatchResult] is always non-empty + match_groups [] = matchEmpty v ty + match_groups (g:gs) = mapM match_group $ g :| gs + + match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM MatchResult + match_group eqns@((group,_) :| _) + = case group of + PgCon {} -> matchConFamily vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns']) + PgSyn {} -> matchPatSyn vars ty (dropGroup eqns) + PgLit {} -> matchLiterals vars ty (ne $ subGroupOrd [(l,e) | (PgLit l, e) <- eqns']) + PgAny -> matchVariables vars ty (dropGroup eqns) + PgN {} -> matchNPats vars ty (dropGroup eqns) + PgOverS {}-> matchNPats vars ty (dropGroup eqns) + PgNpK {} -> matchNPlusKPats vars ty (dropGroup eqns) + PgBang -> matchBangs vars ty (dropGroup eqns) + PgCo {} -> matchCoercion vars ty (dropGroup eqns) + PgView {} -> matchView vars ty (dropGroup eqns) + PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns) + where eqns' = NEL.toList eqns + ne l = case NEL.nonEmpty l of + Just nel -> nel + Nothing -> pprPanic "match match_group" $ text "Empty result should be impossible since input was non-empty" + + -- FIXME: we should also warn about view patterns that should be + -- commoned up but are not + + -- print some stuff to see what's getting grouped + -- use -dppr-debug to see the resolution of overloaded literals + debug eqns = + let gs = map (\group -> foldr (\ (p,_) -> \acc -> + case p of PgView e _ -> e:acc + _ -> acc) [] group) eqns + maybeWarn [] = return () + maybeWarn l = warnDs NoReason (vcat l) + in + maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g)) + (filter (not . null) gs)) + +matchEmpty :: MatchId -> Type -> DsM (NonEmpty MatchResult) +-- See Note [Empty case expressions] +matchEmpty var res_ty + = return [MatchResult CanFail mk_seq] + where + mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty + [(DEFAULT, [], fail)] + +matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult +-- Real true variables, just like in matchVar, SLPJ p 94 +-- No binding to do: they'll all be wildcards by now (done in tidy) +matchVariables (_ :| vars) ty eqns = match vars ty $ NEL.toList $ shiftEqns eqns + +matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult +matchBangs (var :| vars) ty eqns + = do { match_result <- match (var:vars) ty $ NEL.toList $ + decomposeFirstPat getBangPat <$> eqns + ; return (mkEvalMatchResult var ty match_result) } + +matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult +-- Apply the coercion to the match variable and then match that +matchCoercion (var :| vars) ty (eqns@(eqn1 :| _)) + = do { let CoPat _ co pat _ = firstPat eqn1 + ; let pat_ty' = hsPatType pat + ; var' <- newUniqueId var pat_ty' + ; match_result <- match (var':vars) ty $ NEL.toList $ + decomposeFirstPat getCoPat <$> eqns + ; core_wrap <- dsHsWrapper co + ; let bind = NonRec var' (core_wrap (Var var)) + ; return (mkCoLetMatchResult bind match_result) } + +matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult +-- Apply the view function to the match variable and then match that +matchView (var :| vars) ty (eqns@(eqn1 :| _)) + = do { -- we could pass in the expr from the PgView, + -- but this needs to extract the pat anyway + -- to figure out the type of the fresh variable + let ViewPat _ viewExpr (L _ pat) = firstPat eqn1 + -- do the rest of the compilation + ; let pat_ty' = hsPatType pat + ; var' <- newUniqueId var pat_ty' + ; match_result <- match (var':vars) ty $ NEL.toList $ + decomposeFirstPat getViewPat <$> eqns + -- compile the view expressions + ; viewExpr' <- dsLExpr viewExpr + ; return (mkViewMatchResult var' + (mkCoreAppDs (text "matchView") viewExpr' (Var var)) + match_result) } + +matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult +matchOverloadedList (var :| vars) ty (eqns@(eqn1 :| _)) +-- Since overloaded list patterns are treated as view patterns, +-- the code is roughly the same as for matchView + = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1 + ; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand + ; match_result <- match (var':vars) ty $ NEL.toList $ + decomposeFirstPat getOLPat <$> eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern + ; e' <- dsSyntaxExpr e [Var var] + ; return (mkViewMatchResult var' e' match_result) + } + +-- decompose the first pattern and leave the rest alone +decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo +decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) + = eqn { eqn_pats = extractpat pat : pats} +decomposeFirstPat _ _ = panic "decomposeFirstPat" + +getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc +getCoPat (CoPat _ _ pat _) = pat +getCoPat _ = panic "getCoPat" +getBangPat (BangPat _ pat ) = unLoc pat +getBangPat _ = panic "getBangPat" +getViewPat (ViewPat _ _ pat) = unLoc pat +getViewPat _ = panic "getViewPat" +getOLPat (ListPat (ListPatTc ty (Just _)) pats) + = ListPat (ListPatTc ty Nothing) pats +getOLPat _ = panic "getOLPat" + +{- +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The list of EquationInfo can be empty, arising from + case x of {} or \case {} +In that situation we desugar to + case x of { _ -> error "pattern match failure" } +The *desugarer* isn't certain whether there really should be no +alternatives, so it adds a default case, as it always does. A later +pass may remove it if it's inaccessible. (See also Note [Empty case +alternatives] in CoreSyn.) + +We do *not* desugar simply to + error "empty case" +or some such, because 'x' might be bound to (error "hello"), in which +case we want to see that "hello" exception, not (error "empty case"). +See also Note [Case elimination: lifted case] in Simplify. + + +************************************************************************ +* * + Tidying patterns +* * +************************************************************************ + +Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@ +which will be scrutinised. + +This makes desugaring the pattern match simpler by transforming some of +the patterns to simpler forms. (Tuples to Constructor Patterns) + +Among other things in the resulting Pattern: +* Variables and irrefutable(lazy) patterns are replaced by Wildcards +* As patterns are replaced by the patterns they wrap. + +The bindings created by the above patterns are put into the returned wrapper +instead. + +This means a definition of the form: + f x = rhs +when called with v get's desugared to the equivalent of: + let x = v + in + f _ = rhs + +The same principle holds for as patterns (@) and +irrefutable/lazy patterns (~). +In the case of irrefutable patterns the irrefutable pattern is pushed into +the binding. + +Pattern Constructors which only represent syntactic sugar are converted into +their desugared representation. +This usually means converting them to Constructor patterns but for some +depends on enabled extensions. (Eg OverloadedLists) + +GHC also tries to convert overloaded Literals into regular ones. + +The result of this tidying is that the column of patterns will include +only these which can be assigned a PatternGroup (see patGroup). + +-} + +tidyEqnInfo :: Id -> EquationInfo + -> DsM (DsWrapper, EquationInfo) + -- DsM'd because of internal call to dsLHsBinds + -- and mkSelectorBinds. + -- "tidy1" does the interesting stuff, looking at + -- one pattern and fiddling the list of bindings. + -- + -- POST CONDITION: head pattern in the EqnInfo is + -- one of these for which patGroup is defined. + +tidyEqnInfo _ (EqnInfo { eqn_pats = [] }) + = panic "tidyEqnInfo" + +tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig }) + = do { (wrap, pat') <- tidy1 v orig pat + ; return (wrap, eqn { eqn_pats = do pat' : pats }) } + +tidy1 :: Id -- The Id being scrutinised + -> Origin -- Was this a pattern the user wrote? + -> Pat GhcTc -- The pattern against which it is to be matched + -> DsM (DsWrapper, -- Extra bindings to do before the match + Pat GhcTc) -- Equivalent pattern + +------------------------------------------------------- +-- (pat', mr') = tidy1 v pat mr +-- tidies the *outer level only* of pat, giving pat' +-- It eliminates many pattern forms (as-patterns, variable patterns, +-- list patterns, etc) and returns any created bindings in the wrapper. + +tidy1 v o (ParPat _ pat) = tidy1 v o (unLoc pat) +tidy1 v o (SigPat _ pat _) = tidy1 v o (unLoc pat) +tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty) +tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p + + -- case v of { x -> mr[] } + -- = case v of { _ -> let x=v in mr[] } +tidy1 v _ (VarPat _ (L _ var)) + = return (wrapBind var v, WildPat (idType var)) + + -- case v of { x@p -> mr[] } + -- = case v of { p -> let x=v in mr[] } +tidy1 v o (AsPat _ (L _ var) pat) + = do { (wrap, pat') <- tidy1 v o (unLoc pat) + ; return (wrapBind var v . wrap, pat') } + +{- now, here we handle lazy patterns: + tidy1 v ~p bs = (v, v1 = case v of p -> v1 : + v2 = case v of p -> v2 : ... : bs ) + + where the v_i's are the binders in the pattern. + + ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing? + + The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr +-} + +tidy1 v _ (LazyPat _ pat) + -- This is a convenient place to check for unlifted types under a lazy pattern. + -- Doing this check during type-checking is unsatisfactory because we may + -- not fully know the zonked types yet. We sure do here. + = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat) + ; unless (null unlifted_bndrs) $ + putSrcSpanDs (getLoc pat) $ + errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$ + text "Unlifted variables:") + 2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id)) + unlifted_bndrs))) + + ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v) + ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] + ; return (mkCoreLets sel_binds, WildPat (idType v)) } + +tidy1 _ _ (ListPat (ListPatTc ty Nothing) pats ) + = return (idDsWrapper, unLoc list_ConPat) + where + list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty]) + (mkNilPat ty) + pats + +tidy1 _ _ (TuplePat tys pats boxity) + = return (idDsWrapper, unLoc tuple_ConPat) + where + arity = length pats + tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys + +tidy1 _ _ (SumPat tys pat alt arity) + = return (idDsWrapper, unLoc sum_ConPat) + where + sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys + +-- LitPats: we *might* be able to replace these w/ a simpler form +tidy1 _ o (LitPat _ lit) + = do { unless (isGenerated o) $ + warnAboutOverflowedLit lit + ; return (idDsWrapper, tidyLitPat lit) } + +-- NPats: we *might* be able to replace these w/ a simpler form +tidy1 _ o (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq) + = do { unless (isGenerated o) $ + let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v } + | otherwise = lit + in warnAboutOverflowedOverLit lit' + ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) } + +-- NPlusKPat: we may want to warn about the literals +tidy1 _ o n@(NPlusKPat _ _ (L _ lit1) lit2 _ _) + = do { unless (isGenerated o) $ do + warnAboutOverflowedOverLit lit1 + warnAboutOverflowedOverLit lit2 + ; return (idDsWrapper, n) } + +-- Everything else goes through unchanged... +tidy1 _ _ non_interesting_pat + = return (idDsWrapper, non_interesting_pat) + +-------------------- +tidy_bang_pat :: Id -> Origin -> SrcSpan -> Pat GhcTc + -> DsM (DsWrapper, Pat GhcTc) + +-- Discard par/sig under a bang +tidy_bang_pat v o _ (ParPat _ (L l p)) = tidy_bang_pat v o l p +tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p + +-- Push the bang-pattern inwards, in the hope that +-- it may disappear next time +tidy_bang_pat v o l (AsPat x v' p) + = tidy1 v o (AsPat x v' (L l (BangPat noExtField p))) +tidy_bang_pat v o l (CoPat x w p t) + = tidy1 v o (CoPat x w (BangPat noExtField (L l p)) t) + +-- Discard bang around strict pattern +tidy_bang_pat v o _ p@(LitPat {}) = tidy1 v o p +tidy_bang_pat v o _ p@(ListPat {}) = tidy1 v o p +tidy_bang_pat v o _ p@(TuplePat {}) = tidy1 v o p +tidy_bang_pat v o _ p@(SumPat {}) = tidy1 v o p + +-- Data/newtype constructors +tidy_bang_pat v o l p@(ConPatOut { pat_con = L _ (RealDataCon dc) + , pat_args = args + , pat_arg_tys = arg_tys }) + -- Newtypes: push bang inwards (#9844) + = + if isNewTyCon (dataConTyCon dc) + then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l ty args }) + else tidy1 v o p -- Data types: discard the bang + where + (ty:_) = dataConInstArgTys dc arg_tys + +------------------- +-- Default case, leave the bang there: +-- VarPat, +-- LazyPat, +-- WildPat, +-- ViewPat, +-- pattern synonyms (ConPatOut with PatSynCon) +-- NPat, +-- NPlusKPat +-- +-- For LazyPat, remember that it's semantically like a VarPat +-- i.e. !(~p) is not like ~p, or p! (#8952) +-- +-- NB: SigPatIn, ConPatIn should not happen + +tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p)) + +------------------- +push_bang_into_newtype_arg :: SrcSpan + -> Type -- The type of the argument we are pushing + -- onto + -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc +-- See Note [Bang patterns and newtypes] +-- We are transforming !(N p) into (N !p) +push_bang_into_newtype_arg l _ty (PrefixCon (arg:args)) + = ASSERT( null args) + PrefixCon [L l (BangPat noExtField arg)] +push_bang_into_newtype_arg l _ty (RecCon rf) + | HsRecFields { rec_flds = L lf fld : flds } <- rf + , HsRecField { hsRecFieldArg = arg } <- fld + = ASSERT( null flds) + RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg + = L l (BangPat noExtField arg) })] }) +push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {}) + | HsRecFields { rec_flds = [] } <- rf + = PrefixCon [L l (BangPat noExtField (noLoc (WildPat ty)))] +push_bang_into_newtype_arg _ _ cd + = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) + +{- +Note [Bang patterns and newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the pattern !(Just pat) we can discard the bang, because +the pattern is strict anyway. But for !(N pat), where + newtype NT = N Int +we definitely can't discard the bang. #9844. + +So what we do is to push the bang inwards, in the hope that it will +get discarded there. So we transform + !(N pat) into (N !pat) + +But what if there is nothing to push the bang onto? In at least one instance +a user has written !(N {}) which we translate into (N !_). See #13215 + + +\noindent +{\bf Previous @matchTwiddled@ stuff:} + +Now we get to the only interesting part; note: there are choices for +translation [from Simon's notes]; translation~1: +\begin{verbatim} +deTwiddle [s,t] e +\end{verbatim} +returns +\begin{verbatim} +[ w = e, + s = case w of [s,t] -> s + t = case w of [s,t] -> t +] +\end{verbatim} + +Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple +evaluation of \tr{e}. An alternative translation (No.~2): +\begin{verbatim} +[ w = case e of [s,t] -> (s,t) + s = case w of (s,t) -> s + t = case w of (s,t) -> t +] +\end{verbatim} + +************************************************************************ +* * +\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing} +* * +************************************************************************ + +We might be able to optimise unmixing when confronted by +only-one-constructor-possible, of which tuples are the most notable +examples. Consider: +\begin{verbatim} +f (a,b,c) ... = ... +f d ... (e:f) = ... +f (g,h,i) ... = ... +f j ... = ... +\end{verbatim} +This definition would normally be unmixed into four equation blocks, +one per equation. But it could be unmixed into just one equation +block, because if the one equation matches (on the first column), +the others certainly will. + +You have to be careful, though; the example +\begin{verbatim} +f j ... = ... +------------------- +f (a,b,c) ... = ... +f d ... (e:f) = ... +f (g,h,i) ... = ... +\end{verbatim} +{\em must} be broken into two blocks at the line shown; otherwise, you +are forcing unnecessary evaluation. In any case, the top-left pattern +always gives the cue. You could then unmix blocks into groups of... +\begin{description} +\item[all variables:] +As it is now. +\item[constructors or variables (mixed):] +Need to make sure the right names get bound for the variable patterns. +\item[literals or variables (mixed):] +Presumably just a variant on the constructor case (as it is now). +\end{description} + +************************************************************************ +* * +* matchWrapper: a convenient way to call @match@ * +* * +************************************************************************ +\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@} + +Calls to @match@ often involve similar (non-trivial) work; that work +is collected here, in @matchWrapper@. This function takes as +arguments: +\begin{itemize} +\item +Typechecked @Matches@ (of a function definition, or a case or lambda +expression)---the main input; +\item +An error message to be inserted into any (runtime) pattern-matching +failure messages. +\end{itemize} + +As results, @matchWrapper@ produces: +\begin{itemize} +\item +A list of variables (@Locals@) that the caller must ``promise'' to +bind to appropriate values; and +\item +a @CoreExpr@, the desugared output (main result). +\end{itemize} + +The main actions of @matchWrapper@ include: +\begin{enumerate} +\item +Flatten the @[TypecheckedMatch]@ into a suitable list of +@EquationInfo@s. +\item +Create as many new variables as there are patterns in a pattern-list +(in any one of the @EquationInfo@s). +\item +Create a suitable ``if it fails'' expression---a call to @error@ using +the error-string input; the {\em type} of this fail value can be found +by examining one of the RHS expressions in one of the @EquationInfo@s. +\item +Call @match@ with all of this information! +\end{enumerate} +-} + +matchWrapper + :: HsMatchContext GhcRn -- ^ For shadowing warning messages + -> Maybe (LHsExpr GhcTc) -- ^ Scrutinee. (Just scrut) for a case expr + -- case scrut of { p1 -> e1 ... } + -- (and in this case the MatchGroup will + -- have all singleton patterns) + -- Nothing for a function definition + -- f p1 q1 = ... -- No "scrutinee" + -- f p2 q2 = ... -- in this case + -> MatchGroup GhcTc (LHsExpr GhcTc) -- ^ Matches being desugared + -> DsM ([Id], CoreExpr) -- ^ Results (usually passed to 'match') + +{- + There is one small problem with the Lambda Patterns, when somebody + writes something similar to: +\begin{verbatim} + (\ (x:xs) -> ...) +\end{verbatim} + he/she don't want a warning about incomplete patterns, that is done with + the flag @opt_WarnSimplePatterns@. + This problem also appears in the: +\begin{itemize} +\item @do@ patterns, but if the @do@ can fail + it creates another equation if the match can fail + (see @GHC.HsToCore.Expr.doDo@ function) +\item @let@ patterns, are treated by @matchSimply@ + List Comprension Patterns, are treated by @matchSimply@ also +\end{itemize} + +We can't call @matchSimply@ with Lambda patterns, +due to the fact that lambda patterns can have more than +one pattern, and match simply only accepts one pattern. + +JJQC 30-Nov-1997 +-} + +matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches + , mg_ext = MatchGroupTc arg_tys rhs_ty + , mg_origin = origin }) + = do { dflags <- getDynFlags + ; locn <- getSrcSpanDs + + ; new_vars <- case matches of + [] -> mapM newSysLocalDsNoLP arg_tys + (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m)) + + ; eqns_info <- mapM (mk_eqn_info new_vars) matches + + -- Pattern match check warnings for /this match-group/ + ; when (isMatchContextPmChecked dflags origin ctxt) $ + addScrutTmCs mb_scr new_vars $ + -- See Note [Type and Term Equality Propagation] + checkMatches dflags (DsMatchContext ctxt locn) new_vars matches + + ; result_expr <- handleWarnings $ + matchEquations ctxt new_vars eqns_info rhs_ty + ; return (new_vars, result_expr) } + where + -- Called once per equation in the match, or alternative in the case + mk_eqn_info vars (L _ (Match { m_pats = pats, m_grhss = grhss })) + = do { dflags <- getDynFlags + ; let upats = map (unLoc . decideBangHood dflags) pats + dicts = collectEvVarsPats upats + + ; match_result <- + -- Extend the environment with knowledge about + -- the matches before desugaring the RHS + -- See Note [Type and Term Equality Propagation] + applyWhen (needToRunPmCheck dflags origin) + (addTyCsDs dicts . addScrutTmCs mb_scr vars . addPatTmCs upats vars) + (dsGRHSs ctxt grhss rhs_ty) + + ; return (EqnInfo { eqn_pats = upats + , eqn_orig = FromSource + , eqn_rhs = match_result }) } + mk_eqn_info _ (L _ (XMatch nec)) = noExtCon nec + + handleWarnings = if isGenerated origin + then discardWarningsDs + else id +matchWrapper _ _ (XMatchGroup nec) = noExtCon nec + +matchEquations :: HsMatchContext GhcRn + -> [MatchId] -> [EquationInfo] -> Type + -> DsM CoreExpr +matchEquations ctxt vars eqns_info rhs_ty + = do { let error_doc = matchContextErrString ctxt + + ; match_result <- match vars rhs_ty eqns_info + + ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc + ; extractMatchResult match_result fail_expr } + +{- +************************************************************************ +* * +\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern} +* * +************************************************************************ + +@mkSimpleMatch@ is a wrapper for @match@ which deals with the +situation where we want to match a single expression against a single +pattern. It returns an expression. +-} + +matchSimply :: CoreExpr -- ^ Scrutinee + -> HsMatchContext GhcRn -- ^ Match kind + -> LPat GhcTc -- ^ Pattern it should match + -> CoreExpr -- ^ Return this if it matches + -> CoreExpr -- ^ Return this if it doesn't + -> DsM CoreExpr +-- Do not warn about incomplete patterns; see matchSinglePat comments +matchSimply scrut hs_ctx pat result_expr fail_expr = do + let + match_result = cantFailMatchResult result_expr + rhs_ty = exprType fail_expr + -- Use exprType of fail_expr, because won't refine in the case of failure! + match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result + extractMatchResult match_result' fail_expr + +matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc + -> Type -> MatchResult -> DsM MatchResult +-- matchSinglePat ensures that the scrutinee is a variable +-- and then calls matchSinglePatVar +-- +-- matchSinglePat does not warn about incomplete patterns +-- Used for things like [ e | pat <- stuff ], where +-- incomplete patterns are just fine + +matchSinglePat (Var var) ctx pat ty match_result + | not (isExternalName (idName var)) + = matchSinglePatVar var ctx pat ty match_result + +matchSinglePat scrut hs_ctx pat ty match_result + = do { var <- selectSimpleMatchVarL pat + ; match_result' <- matchSinglePatVar var hs_ctx pat ty match_result + ; return (adjustMatchResult (bindNonRec var scrut) match_result') } + +matchSinglePatVar :: Id -- See Note [Match Ids] + -> HsMatchContext GhcRn -> LPat GhcTc + -> Type -> MatchResult -> DsM MatchResult +matchSinglePatVar var ctx pat ty match_result + = ASSERT2( isInternalName (idName var), ppr var ) + do { dflags <- getDynFlags + ; locn <- getSrcSpanDs + + -- Pattern match check warnings + ; checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat) + + ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)] + , eqn_orig = FromSource + , eqn_rhs = match_result } + ; match [var] ty [eqn_info] } + + +{- +************************************************************************ +* * + Pattern classification +* * +************************************************************************ +-} + +data PatGroup + = PgAny -- Immediate match: variables, wildcards, + -- lazy patterns + | PgCon DataCon -- Constructor patterns (incl list, tuple) + | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups] + | PgLit Literal -- Literal patterns + | PgN Rational -- Overloaded numeric literals; + -- see Note [Don't use Literal for PgN] + | PgOverS FastString -- Overloaded string literals + | PgNpK Integer -- n+k patterns + | PgBang -- Bang patterns + | PgCo Type -- Coercion patterns; the type is the type + -- of the pattern *inside* + | PgView (LHsExpr GhcTc) -- view pattern (e -> p): + -- the LHsExpr is the expression e + Type -- the Type is the type of p (equivalently, the result type of e) + | PgOverloadedList + +{- Note [Don't use Literal for PgN] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Previously we had, as PatGroup constructors + + | ... + | PgN Literal -- Overloaded literals + | PgNpK Literal -- n+k patterns + | ... + +But Literal is really supposed to represent an *unboxed* literal, like Int#. +We were sticking the literal from, say, an overloaded numeric literal pattern +into a LitInt constructor. This didn't really make sense; and we now have +the invariant that value in a LitInt must be in the range of the target +machine's Int# type, and an overloaded literal could meaningfully be larger. + +Solution: For pattern grouping purposes, just store the literal directly in +the PgN constructor as a Rational if numeric, and add a PgOverStr constructor +for overloaded strings. +-} + +groupEquations :: DynFlags -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)] +-- If the result is of form [g1, g2, g3], +-- (a) all the (pg,eq) pairs in g1 have the same pg +-- (b) none of the gi are empty +-- The ordering of equations is unchanged +groupEquations dflags eqns + = NEL.groupBy same_gp $ [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns] + -- comprehension on NonEmpty + where + same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool + (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 + +-- TODO Make subGroup1 using a NonEmptyMap +subGroup :: (m -> [NonEmpty EquationInfo]) -- Map.elems + -> m -- Map.empty + -> (a -> m -> Maybe (NonEmpty EquationInfo)) -- Map.lookup + -> (a -> NonEmpty EquationInfo -> m -> m) -- Map.insert + -> [(a, EquationInfo)] -> [NonEmpty EquationInfo] +-- Input is a particular group. The result sub-groups the +-- equations by with particular constructor, literal etc they match. +-- Each sub-list in the result has the same PatGroup +-- See Note [Take care with pattern order] +-- Parameterized by map operations to allow different implementations +-- and constraints, eg. types without Ord instance. +subGroup elems empty lookup insert group + = fmap NEL.reverse $ elems $ foldl' accumulate empty group + where + accumulate pg_map (pg, eqn) + = case lookup pg pg_map of + Just eqns -> insert pg (NEL.cons eqn eqns) pg_map + Nothing -> insert pg [eqn] pg_map + -- pg_map :: Map a [EquationInfo] + -- Equations seen so far in reverse order of appearance + +subGroupOrd :: Ord a => [(a, EquationInfo)] -> [NonEmpty EquationInfo] +subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert + +subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [NonEmpty EquationInfo] +subGroupUniq = + subGroup eltsUDFM emptyUDFM (flip lookupUDFM) (\k v m -> addToUDFM m k v) + +{- Note [Pattern synonym groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we see + f (P a) = e1 + f (P b) = e2 + ... +where P is a pattern synonym, can we put (P a -> e1) and (P b -> e2) in the +same group? We can if P is a constructor, but /not/ if P is a pattern synonym. +Consider (#11224) + -- readMaybe :: Read a => String -> Maybe a + pattern PRead :: Read a => () => a -> String + pattern PRead a <- (readMaybe -> Just a) + + f (PRead (x::Int)) = e1 + f (PRead (y::Bool)) = e2 +This is all fine: we match the string by trying to read an Int; if that +fails we try to read a Bool. But clearly we can't combine the two into a single +match. + +Conclusion: we can combine when we invoke PRead /at the same type/. Hence +in PgSyn we record the instantiating types, and use them in sameGroup. + +Note [Take care with pattern order] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the subGroup function we must be very careful about pattern re-ordering, +Consider the patterns [ (True, Nothing), (False, x), (True, y) ] +Then in bringing together the patterns for True, we must not +swap the Nothing and y! +-} + +sameGroup :: PatGroup -> PatGroup -> Bool +-- Same group means that a single case expression +-- or test will suffice to match both, *and* the order +-- of testing within the group is insignificant. +sameGroup PgAny PgAny = True +sameGroup PgBang PgBang = True +sameGroup (PgCon _) (PgCon _) = True -- One case expression +sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2 + -- eqTypes: See Note [Pattern synonym groups] +sameGroup (PgLit _) (PgLit _) = True -- One case expression +sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant +sameGroup (PgOverS s1) (PgOverS s2) = s1==s2 +sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns] +sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2 + -- CoPats are in the same goup only if the type of the + -- enclosed pattern is the same. The patterns outside the CoPat + -- always have the same type, so this boils down to saying that + -- the two coercions are identical. +sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2) + -- ViewPats are in the same group iff the expressions + -- are "equal"---conservatively, we use syntactic equality +sameGroup _ _ = False + +-- An approximation of syntactic equality used for determining when view +-- exprs are in the same group. +-- This function can always safely return false; +-- but doing so will result in the application of the view function being repeated. +-- +-- Currently: compare applications of literals and variables +-- and anything else that we can do without involving other +-- HsSyn types in the recursion +-- +-- NB we can't assume that the two view expressions have the same type. Consider +-- f (e1 -> True) = ... +-- f (e2 -> "hi") = ... +viewLExprEq :: (LHsExpr GhcTc,Type) -> (LHsExpr GhcTc,Type) -> Bool +viewLExprEq (e1,_) (e2,_) = lexp e1 e2 + where + lexp :: LHsExpr GhcTc -> LHsExpr GhcTc -> Bool + lexp e e' = exp (unLoc e) (unLoc e') + + --------- + exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool + -- real comparison is on HsExpr's + -- strip parens + exp (HsPar _ (L _ e)) e' = exp e e' + exp e (HsPar _ (L _ e')) = exp e e' + -- because the expressions do not necessarily have the same type, + -- we have to compare the wrappers + exp (XExpr (HsWrap h e)) (XExpr (HsWrap h' e')) = wrap h h' && exp e e' + exp (HsVar _ i) (HsVar _ i') = i == i' + exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c' + -- the instance for IPName derives using the id, so this works if the + -- above does + exp (HsIPVar _ i) (HsIPVar _ i') = i == i' + exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x' + exp (HsOverLit _ l) (HsOverLit _ l') = + -- Overloaded lits are equal if they have the same type + -- and the data is the same. + -- this is coarser than comparing the SyntaxExpr's in l and l', + -- which resolve the overloading (e.g., fromInteger 1), + -- because these expressions get written as a bunch of different variables + -- (presumably to improve sharing) + eqType (overLitType l) (overLitType l') && l == l' + exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2' + -- the fixities have been straightened out by now, so it's safe + -- to ignore them? + exp (OpApp _ l o ri) (OpApp _ l' o' ri') = + lexp l l' && lexp o o' && lexp ri ri' + exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n' + exp (SectionL _ e1 e2) (SectionL _ e1' e2') = + lexp e1 e1' && lexp e2 e2' + exp (SectionR _ e1 e2) (SectionR _ e1' e2') = + lexp e1 e1' && lexp e2 e2' + exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) = + eq_list tup_arg es1 es2 + exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e' + exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') = + lexp e e' && lexp e1 e1' && lexp e2 e2' + + -- Enhancement: could implement equality for more expressions + -- if it seems useful + -- But no need for HsLit, ExplicitList, ExplicitTuple, + -- because they cannot be functions + exp _ _ = False + + --------- + syn_exp :: SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool + syn_exp (SyntaxExprTc { syn_expr = expr1 + , syn_arg_wraps = arg_wraps1 + , syn_res_wrap = res_wrap1 }) + (SyntaxExprTc { syn_expr = expr2 + , syn_arg_wraps = arg_wraps2 + , syn_res_wrap = res_wrap2 }) + = exp expr1 expr2 && + and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) && + wrap res_wrap1 res_wrap2 + syn_exp NoSyntaxExprTc NoSyntaxExprTc = True + syn_exp _ _ = False + + --------- + tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2 + tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2 + tup_arg _ _ = False + + --------- + wrap :: HsWrapper -> HsWrapper -> Bool + -- Conservative, in that it demands that wrappers be + -- syntactically identical and doesn't look under binders + -- + -- Coarser notions of equality are possible + -- (e.g., reassociating compositions, + -- equating different ways of writing a coercion) + wrap WpHole WpHole = True + wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2' + wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2' + wrap (WpCast co) (WpCast co') = co `eqCoercion` co' + wrap (WpEvApp et1) (WpEvApp et2) = et1 `ev_term` et2 + wrap (WpTyApp t) (WpTyApp t') = eqType t t' + -- Enhancement: could implement equality for more wrappers + -- if it seems useful (lams and lets) + wrap _ _ = False + + --------- + ev_term :: EvTerm -> EvTerm -> Bool + ev_term (EvExpr (Var a)) (EvExpr (Var b)) = a==b + ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b)) = a `eqCoercion` b + ev_term _ _ = False + + --------- + eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool + eq_list _ [] [] = True + eq_list _ [] (_:_) = False + eq_list _ (_:_) [] = False + eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys + +patGroup :: DynFlags -> Pat GhcTc -> PatGroup +patGroup _ (ConPatOut { pat_con = L _ con + , pat_arg_tys = tys }) + | RealDataCon dcon <- con = PgCon dcon + | PatSynCon psyn <- con = PgSyn psyn tys +patGroup _ (WildPat {}) = PgAny +patGroup _ (BangPat {}) = PgBang +patGroup _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) = + case (oval, isJust mb_neg) of + (HsIntegral i, False) -> PgN (fromInteger (il_value i)) + (HsIntegral i, True ) -> PgN (-fromInteger (il_value i)) + (HsFractional r, False) -> PgN (fl_value r) + (HsFractional r, True ) -> PgN (-fl_value r) + (HsIsString _ s, _) -> ASSERT(isNothing mb_neg) + PgOverS s +patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) = + case oval of + HsIntegral i -> PgNpK (il_value i) + _ -> pprPanic "patGroup NPlusKPat" (ppr oval) +patGroup _ (CoPat _ _ p _) = PgCo (hsPatType p) + -- Type of innelexp pattern +patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p)) +patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList +patGroup dflags (LitPat _ lit) = PgLit (hsLitKey dflags lit) +patGroup _ pat = pprPanic "patGroup" (ppr pat) + +{- +Note [Grouping overloaded literal patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +WATCH OUT! Consider + + f (n+1) = ... + f (n+2) = ... + f (n+1) = ... + +We can't group the first and third together, because the second may match +the same thing as the first. Same goes for *overloaded* literal patterns + f 1 True = ... + f 2 False = ... + f 1 False = ... +If the first arg matches '1' but the second does not match 'True', we +cannot jump to the third equation! Because the same argument might +match '2'! +Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group. +-} diff --git a/compiler/GHC/HsToCore/Match.hs-boot b/compiler/GHC/HsToCore/Match.hs-boot new file mode 100644 index 0000000000..dbed65dd0d --- /dev/null +++ b/compiler/GHC/HsToCore/Match.hs-boot @@ -0,0 +1,36 @@ +module GHC.HsToCore.Match where + +import GhcPrelude +import Var ( Id ) +import TcType ( Type ) +import GHC.HsToCore.Monad ( DsM, EquationInfo, MatchResult ) +import CoreSyn ( CoreExpr ) +import GHC.Hs ( LPat, HsMatchContext, MatchGroup, LHsExpr ) +import GHC.Hs.Extension ( GhcRn, GhcTc ) + +match :: [Id] + -> Type + -> [EquationInfo] + -> DsM MatchResult + +matchWrapper + :: HsMatchContext GhcRn + -> Maybe (LHsExpr GhcTc) + -> MatchGroup GhcTc (LHsExpr GhcTc) + -> DsM ([Id], CoreExpr) + +matchSimply + :: CoreExpr + -> HsMatchContext GhcRn + -> LPat GhcTc + -> CoreExpr + -> CoreExpr + -> DsM CoreExpr + +matchSinglePatVar + :: Id + -> HsMatchContext GhcRn + -> LPat GhcTc + -> Type + -> MatchResult + -> DsM MatchResult diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs new file mode 100644 index 0000000000..37a9f753a6 --- /dev/null +++ b/compiler/GHC/HsToCore/Match/Constructor.hs @@ -0,0 +1,296 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Pattern-matching constructors +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.HsToCore.Match.Constructor ( matchConFamily, matchPatSyn ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.HsToCore.Match ( match ) + +import GHC.Hs +import GHC.HsToCore.Binds +import ConLike +import BasicTypes ( Origin(..) ) +import TcType +import GHC.HsToCore.Monad +import GHC.HsToCore.Utils +import MkCore ( mkCoreLets ) +import Util +import Id +import NameEnv +import FieldLabel ( flSelector ) +import SrcLoc +import Outputable +import Control.Monad(liftM) +import Data.List (groupBy) +import Data.List.NonEmpty (NonEmpty(..)) + +{- +We are confronted with the first column of patterns in a set of +equations, all beginning with constructors from one ``family'' (e.g., +@[]@ and @:@ make up the @List@ ``family''). We want to generate the +alternatives for a @Case@ expression. There are several choices: +\begin{enumerate} +\item +Generate an alternative for every constructor in the family, whether +they are used in this set of equations or not; this is what the Wadler +chapter does. +\begin{description} +\item[Advantages:] +(a)~Simple. (b)~It may also be that large sparsely-used constructor +families are mainly handled by the code for literals. +\item[Disadvantages:] +(a)~Not practical for large sparsely-used constructor families, e.g., +the ASCII character set. (b)~Have to look up a list of what +constructors make up the whole family. +\end{description} + +\item +Generate an alternative for each constructor used, then add a default +alternative in case some constructors in the family weren't used. +\begin{description} +\item[Advantages:] +(a)~Alternatives aren't generated for unused constructors. (b)~The +STG is quite happy with defaults. (c)~No lookup in an environment needed. +\item[Disadvantages:] +(a)~A spurious default alternative may be generated. +\end{description} + +\item +``Do it right:'' generate an alternative for each constructor used, +and add a default alternative if all constructors in the family +weren't used. +\begin{description} +\item[Advantages:] +(a)~You will get cases with only one alternative (and no default), +which should be amenable to optimisation. Tuples are a common example. +\item[Disadvantages:] +(b)~Have to look up constructor families in TDE (as above). +\end{description} +\end{enumerate} + +We are implementing the ``do-it-right'' option for now. The arguments +to @matchConFamily@ are the same as to @match@; the extra @Int@ +returned is the number of constructors in the family. + +The function @matchConFamily@ is concerned with this +have-we-used-all-the-constructors? question; the local function +@match_cons_used@ does all the real work. +-} + +matchConFamily :: NonEmpty Id + -> Type + -> NonEmpty (NonEmpty EquationInfo) + -> DsM MatchResult +-- Each group of eqns is for a single constructor +matchConFamily (var :| vars) ty groups + = do alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups + return (mkCoAlgCaseMatchResult var ty alts) + where + toRealAlt alt = case alt_pat alt of + RealDataCon dcon -> alt{ alt_pat = dcon } + _ -> panic "matchConFamily: not RealDataCon" + +matchPatSyn :: NonEmpty Id + -> Type + -> NonEmpty EquationInfo + -> DsM MatchResult +matchPatSyn (var :| vars) ty eqns + = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns + return (mkCoSynCaseMatchResult var ty alt) + where + toSynAlt alt = case alt_pat alt of + PatSynCon psyn -> alt{ alt_pat = psyn } + _ -> panic "matchPatSyn: not PatSynCon" + +type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc)) + +matchOneConLike :: [Id] + -> Type + -> NonEmpty EquationInfo + -> DsM (CaseAlt ConLike) +matchOneConLike vars ty (eqn1 :| eqns) -- All eqns for a single constructor + = do { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs ) + -- ex_tvs can only be tyvars as data types in source + -- Haskell cannot mention covar yet (Aug 2018). + ASSERT( tvs1 `equalLength` ex_tvs ) + arg_tys ++ mkTyVarTys tvs1 + + val_arg_tys = conLikeInstOrigArgTys con1 inst_tys + -- dataConInstOrigArgTys takes the univ and existential tyvars + -- and returns the types of the *value* args, which is what we want + + match_group :: [Id] + -> [(ConArgPats, EquationInfo)] -> DsM MatchResult + -- All members of the group have compatible ConArgPats + match_group arg_vars arg_eqn_prs + = ASSERT( notNull arg_eqn_prs ) + do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs) + ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs + ; match_result <- match (group_arg_vars ++ vars) ty eqns' + ; return (adjustMatchResult (foldr1 (.) wraps) match_result) } + + shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds, + pat_binds = bind, pat_args = args + } : pats })) + = do ds_bind <- dsTcEvBinds bind + return ( wrapBinds (tvs `zip` tvs1) + . wrapBinds (ds `zip` dicts1) + . mkCoreLets ds_bind + , eqn { eqn_orig = Generated + , eqn_pats = conArgPats val_arg_tys args ++ pats } + ) + shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps) + + ; arg_vars <- selectConMatchVars val_arg_tys args1 + -- Use the first equation as a source of + -- suggestions for the new variables + + -- Divide into sub-groups; see Note [Record patterns] + ; let groups :: [[(ConArgPats, EquationInfo)]] + groups = groupBy compatible_pats [ (pat_args (firstPat eqn), eqn) + | eqn <- eqn1:eqns ] + + ; match_results <- mapM (match_group arg_vars) groups + + ; return $ MkCaseAlt{ alt_pat = con1, + alt_bndrs = tvs1 ++ dicts1 ++ arg_vars, + alt_wrapper = wrapper1, + alt_result = foldr1 combineMatchResults match_results } } + where + ConPatOut { pat_con = L _ con1 + , pat_arg_tys = arg_tys, pat_wrap = wrapper1, + pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 } + = firstPat eqn1 + fields1 = map flSelector (conLikeFieldLabels con1) + + ex_tvs = conLikeExTyCoVars con1 + + -- Choose the right arg_vars in the right order for this group + -- Note [Record patterns] + select_arg_vars :: [Id] -> [(ConArgPats, EquationInfo)] -> [Id] + select_arg_vars arg_vars ((arg_pats, _) : _) + | RecCon flds <- arg_pats + , let rpats = rec_flds flds + , not (null rpats) -- Treated specially; cf conArgPats + = ASSERT2( fields1 `equalLength` arg_vars, + ppr con1 $$ ppr fields1 $$ ppr arg_vars ) + map lookup_fld rpats + | otherwise + = arg_vars + where + fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars + lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env + (idName (unLoc (hsRecFieldId rpat))) + select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []" + +----------------- +compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool +-- Two constructors have compatible argument patterns if the number +-- and order of sub-matches is the same in both cases +compatible_pats (RecCon flds1, _) (RecCon flds2, _) = same_fields flds1 flds2 +compatible_pats (RecCon flds1, _) _ = null (rec_flds flds1) +compatible_pats _ (RecCon flds2, _) = null (rec_flds flds2) +compatible_pats _ _ = True -- Prefix or infix con + +same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc) + -> Bool +same_fields flds1 flds2 + = all2 (\(L _ f1) (L _ f2) + -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2)) + (rec_flds flds1) (rec_flds flds2) + + +----------------- +selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id] +selectConMatchVars arg_tys (RecCon {}) = newSysLocalsDsNoLP arg_tys +selectConMatchVars _ (PrefixCon ps) = selectMatchVars (map unLoc ps) +selectConMatchVars _ (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2] + +conArgPats :: [Type] -- Instantiated argument types + -- Used only to fill in the types of WildPats, which + -- are probably never looked at anyway + -> ConArgPats + -> [Pat GhcTc] +conArgPats _arg_tys (PrefixCon ps) = map unLoc ps +conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2] +conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats })) + | null rpats = map WildPat arg_tys + -- Important special case for C {}, which can be used for a + -- datacon that isn't declared to have fields at all + | otherwise = map (unLoc . hsRecFieldArg . unLoc) rpats + +{- +Note [Record patterns] +~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = T { x,y,z :: Bool } + + f (T { y=True, x=False }) = ... + +We must match the patterns IN THE ORDER GIVEN, thus for the first +one we match y=True before x=False. See #246; or imagine +matching against (T { y=False, x=undefined }): should fail without +touching the undefined. + +Now consider: + + f (T { y=True, x=False }) = ... + f (T { x=True, y= False}) = ... + +In the first we must test y first; in the second we must test x +first. So we must divide even the equations for a single constructor +T into sub-groups, based on whether they match the same field in the +same order. That's what the (groupBy compatible_pats) grouping. + +All non-record patterns are "compatible" in this sense, because the +positional patterns (T a b) and (a `T` b) all match the arguments +in order. Also T {} is special because it's equivalent to (T _ _). +Hence the (null rpats) checks here and there. + + +Note [Existentials in shift_con_pat] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = forall a. Ord a => T a (a->Int) + + f (T x f) True = ...expr1... + f (T y g) False = ...expr2.. + +When we put in the tyvars etc we get + + f (T a (d::Ord a) (x::a) (f::a->Int)) True = ...expr1... + f (T b (e::Ord b) (y::a) (g::a->Int)) True = ...expr2... + +After desugaring etc we'll get a single case: + + f = \t::T b::Bool -> + case t of + T a (d::Ord a) (x::a) (f::a->Int)) -> + case b of + True -> ...expr1... + False -> ...expr2... + +*** We have to substitute [a/b, d/e] in expr2! ** +Hence + False -> ....((/\b\(e:Ord b).expr2) a d).... + +Originally I tried to use + (\b -> let e = d in expr2) a +to do this substitution. While this is "correct" in a way, it fails +Lint, because e::Ord b but d::Ord a. + +-} diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs new file mode 100644 index 0000000000..350a5ed8eb --- /dev/null +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -0,0 +1,522 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Pattern-matching literal patterns +-} + +{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.HsToCore.Match.Literal + ( dsLit, dsOverLit, hsLitKey + , tidyLitPat, tidyNPat + , matchLiterals, matchNPlusKPats, matchNPats + , warnAboutIdentities + , warnAboutOverflowedOverLit, warnAboutOverflowedLit + , warnAboutEmptyEnumerations + ) +where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.HsToCore.Match ( match ) +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsSyntaxExpr ) + +import GHC.HsToCore.Monad +import GHC.HsToCore.Utils + +import GHC.Hs + +import Id +import CoreSyn +import MkCore +import TyCon +import DataCon +import TcHsSyn ( shortCutLit ) +import TcType +import Name +import Type +import PrelNames +import TysWiredIn +import TysPrim +import Literal +import SrcLoc +import Data.Ratio +import Outputable +import BasicTypes +import DynFlags +import Util +import FastString +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Data.Int +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NEL +import Data.Word +import Data.Proxy + +{- +************************************************************************ +* * + Desugaring literals + [used to be in GHC.HsToCore.Expr, but GHC.HsToCore.Quote needs it, + and it's nice to avoid a loop] +* * +************************************************************************ + +We give int/float literals type @Integer@ and @Rational@, respectively. +The typechecker will (presumably) have put \tr{from{Integer,Rational}s} +around them. + +ToDo: put in range checks for when converting ``@i@'' +(or should that be in the typechecker?) + +For numeric literals, we try to detect there use at a standard type +(@Int@, @Float@, etc.) are directly put in the right constructor. +[NB: down with the @App@ conversion.] + +See also below where we look for @DictApps@ for \tr{plusInt}, etc. +-} + +dsLit :: HsLit GhcRn -> DsM CoreExpr +dsLit l = do + dflags <- getDynFlags + case l of + HsStringPrim _ s -> return (Lit (LitString s)) + HsCharPrim _ c -> return (Lit (LitChar c)) + HsIntPrim _ i -> return (Lit (mkLitIntWrap dflags i)) + HsWordPrim _ w -> return (Lit (mkLitWordWrap dflags w)) + HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap dflags i)) + HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap dflags w)) + HsFloatPrim _ f -> return (Lit (LitFloat (fl_value f))) + HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d))) + HsChar _ c -> return (mkCharExpr c) + HsString _ str -> mkStringExprFS str + HsInteger _ i _ -> mkIntegerExpr i + HsInt _ i -> return (mkIntExpr dflags (il_value i)) + XLit nec -> noExtCon nec + HsRat _ (FL _ _ val) ty -> do + num <- mkIntegerExpr (numerator val) + denom <- mkIntegerExpr (denominator val) + return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) + where + (ratio_data_con, integer_ty) + = case tcSplitTyConApp ty of + (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) + (head (tyConDataCons tycon), i_ty) + x -> pprPanic "dsLit" (ppr x) + +dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr +-- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains +-- (an expression for) the literal value itself. +dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty + , ol_witness = witness }) = do + dflags <- getDynFlags + case shortCutLit dflags val ty of + Just expr | not rebindable -> dsExpr expr -- Note [Literal short cut] + _ -> dsExpr witness +dsOverLit (XOverLit nec) = noExtCon nec +{- +Note [Literal short cut] +~~~~~~~~~~~~~~~~~~~~~~~~ +The type checker tries to do this short-cutting as early as possible, but +because of unification etc, more information is available to the desugarer. +And where it's possible to generate the correct literal right away, it's +much better to do so. + + +************************************************************************ +* * + Warnings about overflowed literals +* * +************************************************************************ + +Warn about functions like toInteger, fromIntegral, that convert +between one type and another when the to- and from- types are the +same. Then it's probably (albeit not definitely) the identity +-} + +warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM () +warnAboutIdentities dflags (Var conv_fn) type_of_conv + | wopt Opt_WarnIdentities dflags + , idName conv_fn `elem` conversionNames + , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv + , arg_ty `eqType` res_ty -- So we are converting ty -> ty + = warnDs (Reason Opt_WarnIdentities) + (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv + , nest 2 $ text "can probably be omitted" + ]) +warnAboutIdentities _ _ _ = return () + +conversionNames :: [Name] +conversionNames + = [ toIntegerName, toRationalName + , fromIntegralName, realToFracName ] + -- We can't easily add fromIntegerName, fromRationalName, + -- because they are generated by literals + + +-- | Emit warnings on overloaded integral literals which overflow the bounds +-- implied by their type. +warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM () +warnAboutOverflowedOverLit hsOverLit = do + dflags <- getDynFlags + warnAboutOverflowedLiterals dflags (getIntegralLit hsOverLit) + +-- | Emit warnings on integral literals which overflow the bounds implied by +-- their type. +warnAboutOverflowedLit :: HsLit GhcTc -> DsM () +warnAboutOverflowedLit hsLit = do + dflags <- getDynFlags + warnAboutOverflowedLiterals dflags (getSimpleIntegralLit hsLit) + +-- | Emit warnings on integral literals which overflow the bounds implied by +-- their type. +warnAboutOverflowedLiterals + :: DynFlags + -> Maybe (Integer, Name) -- ^ the literal value and name of its tycon + -> DsM () +warnAboutOverflowedLiterals dflags lit + | wopt Opt_WarnOverflowedLiterals dflags + , Just (i, tc) <- lit + = if tc == intTyConName then check i tc (Proxy :: Proxy Int) + + -- These only show up via the 'HsOverLit' route + else if tc == int8TyConName then check i tc (Proxy :: Proxy Int8) + else if tc == int16TyConName then check i tc (Proxy :: Proxy Int16) + else if tc == int32TyConName then check i tc (Proxy :: Proxy Int32) + else if tc == int64TyConName then check i tc (Proxy :: Proxy Int64) + else if tc == wordTyConName then check i tc (Proxy :: Proxy Word) + else if tc == word8TyConName then check i tc (Proxy :: Proxy Word8) + else if tc == word16TyConName then check i tc (Proxy :: Proxy Word16) + else if tc == word32TyConName then check i tc (Proxy :: Proxy Word32) + else if tc == word64TyConName then check i tc (Proxy :: Proxy Word64) + else if tc == naturalTyConName then checkPositive i tc + + -- These only show up via the 'HsLit' route + else if tc == intPrimTyConName then check i tc (Proxy :: Proxy Int) + else if tc == int8PrimTyConName then check i tc (Proxy :: Proxy Int8) + else if tc == int32PrimTyConName then check i tc (Proxy :: Proxy Int32) + else if tc == int64PrimTyConName then check i tc (Proxy :: Proxy Int64) + else if tc == wordPrimTyConName then check i tc (Proxy :: Proxy Word) + else if tc == word8PrimTyConName then check i tc (Proxy :: Proxy Word8) + else if tc == word32PrimTyConName then check i tc (Proxy :: Proxy Word32) + else if tc == word64PrimTyConName then check i tc (Proxy :: Proxy Word64) + + else return () + + | otherwise = return () + where + + checkPositive :: Integer -> Name -> DsM () + checkPositive i tc + = when (i < 0) $ do + warnDs (Reason Opt_WarnOverflowedLiterals) + (vcat [ text "Literal" <+> integer i + <+> text "is negative but" <+> ppr tc + <+> ptext (sLit "only supports positive numbers") + ]) + + check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM () + check i tc _proxy + = when (i < minB || i > maxB) $ do + warnDs (Reason Opt_WarnOverflowedLiterals) + (vcat [ text "Literal" <+> integer i + <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range") + <+> integer minB <> text ".." <> integer maxB + , sug ]) + where + minB = toInteger (minBound :: a) + maxB = toInteger (maxBound :: a) + sug | minB == -i -- Note [Suggest NegativeLiterals] + , i > 0 + , not (xopt LangExt.NegativeLiterals dflags) + = text "If you are trying to write a large negative literal, use NegativeLiterals" + | otherwise = Outputable.empty + +{- +Note [Suggest NegativeLiterals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you write + x :: Int8 + x = -128 +it'll parse as (negate 128), and overflow. In this case, suggest NegativeLiterals. +We get an erroneous suggestion for + x = 128 +but perhaps that does not matter too much. +-} + +warnAboutEmptyEnumerations :: DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc) + -> LHsExpr GhcTc -> DsM () +-- ^ Warns about @[2,3 .. 1]@ which returns the empty list. +-- Only works for integral types, not floating point. +warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr + | wopt Opt_WarnEmptyEnumerations dflags + , Just (from,tc) <- getLHsIntegralLit fromExpr + , Just mThn <- traverse getLHsIntegralLit mThnExpr + , Just (to,_) <- getLHsIntegralLit toExpr + , let check :: forall a. (Enum a, Num a) => Proxy a -> DsM () + check _proxy + = when (null enumeration) $ + warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty") + where + enumeration :: [a] + enumeration = case mThn of + Nothing -> [fromInteger from .. fromInteger to] + Just (thn,_) -> [fromInteger from, fromInteger thn .. fromInteger to] + + = if tc == intTyConName then check (Proxy :: Proxy Int) + else if tc == int8TyConName then check (Proxy :: Proxy Int8) + else if tc == int16TyConName then check (Proxy :: Proxy Int16) + else if tc == int32TyConName then check (Proxy :: Proxy Int32) + else if tc == int64TyConName then check (Proxy :: Proxy Int64) + else if tc == wordTyConName then check (Proxy :: Proxy Word) + else if tc == word8TyConName then check (Proxy :: Proxy Word8) + else if tc == word16TyConName then check (Proxy :: Proxy Word16) + else if tc == word32TyConName then check (Proxy :: Proxy Word32) + else if tc == word64TyConName then check (Proxy :: Proxy Word64) + else if tc == integerTyConName then check (Proxy :: Proxy Integer) + else if tc == naturalTyConName then check (Proxy :: Proxy Integer) + -- We use 'Integer' because otherwise a negative 'Natural' literal + -- could cause a compile time crash (instead of a runtime one). + -- See the T10930b test case for an example of where this matters. + else return () + + | otherwise = return () + +getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name) +-- ^ See if the expression is an 'Integral' literal. +-- Remember to look through automatically-added tick-boxes! (#8384) +getLHsIntegralLit (L _ (HsPar _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsTick _ _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit +getLHsIntegralLit (L _ (HsLit _ lit)) = getSimpleIntegralLit lit +getLHsIntegralLit _ = Nothing + +-- | If 'Integral', extract the value and type name of the overloaded literal. +getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name) +getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty }) + | Just tc <- tyConAppTyCon_maybe ty + = Just (il_value i, tyConName tc) +getIntegralLit _ = Nothing + +-- | If 'Integral', extract the value and type name of the non-overloaded +-- literal. +getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Name) +getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTyConName) +getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTyConName) +getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTyConName) +getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTyConName) +getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTyConName) +getSimpleIntegralLit (HsInteger _ i ty) + | Just tc <- tyConAppTyCon_maybe ty + = Just (i, tyConName tc) +getSimpleIntegralLit _ = Nothing + +{- +************************************************************************ +* * + Tidying lit pats +* * +************************************************************************ +-} + +tidyLitPat :: HsLit GhcTc -> Pat GhcTc +-- Result has only the following HsLits: +-- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim +-- HsDoublePrim, HsStringPrim, HsString +-- * HsInteger, HsRat, HsInt can't show up in LitPats +-- * We get rid of HsChar right here +tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c) +tidyLitPat (HsString src s) + | lengthFS s <= 1 -- Short string literals only + = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon + [mkCharLitPat src c, pat] [charTy]) + (mkNilPat charTy) (unpackFS s) + -- The stringTy is the type of the whole pattern, not + -- the type to instantiate (:) or [] with! +tidyLitPat lit = LitPat noExtField lit + +---------------- +tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc + -> Type + -> Pat GhcTc +tidyNPat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty + -- False: Take short cuts only if the literal is not using rebindable syntax + -- + -- Once that is settled, look for cases where the type of the + -- entire overloaded literal matches the type of the underlying literal, + -- and in that case take the short cut + -- NB: Watch out for weird cases like #3382 + -- f :: Int -> Int + -- f "blah" = 4 + -- which might be ok if we have 'instance IsString Int' + -- + | not type_change, isIntTy ty, Just int_lit <- mb_int_lit + = mk_con_pat intDataCon (HsIntPrim NoSourceText int_lit) + | not type_change, isWordTy ty, Just int_lit <- mb_int_lit + = mk_con_pat wordDataCon (HsWordPrim NoSourceText int_lit) + | not type_change, isStringTy ty, Just str_lit <- mb_str_lit + = tidyLitPat (HsString NoSourceText str_lit) + -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3 + -- If we do convert to the constructor form, we'll generate a case + -- expression on a Float# or Double# and that's not allowed in Core; see + -- #9238 and Note [Rules for floating-point comparisons] in PrelRules + where + -- Sometimes (like in test case + -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include + -- type-changing wrappers (for example, from Id Int to Int, for the identity + -- type family Id). In these cases, we can't do the short-cut. + type_change = not (outer_ty `eqType` ty) + + mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc + mk_con_pat con lit + = unLoc (mkPrefixConPat con [noLoc $ LitPat noExtField lit] []) + + mb_int_lit :: Maybe Integer + mb_int_lit = case (mb_neg, val) of + (Nothing, HsIntegral i) -> Just (il_value i) + (Just _, HsIntegral i) -> Just (-(il_value i)) + _ -> Nothing + + mb_str_lit :: Maybe FastString + mb_str_lit = case (mb_neg, val) of + (Nothing, HsIsString _ s) -> Just s + _ -> Nothing + +tidyNPat over_lit mb_neg eq outer_ty + = NPat outer_ty (noLoc over_lit) mb_neg eq + +{- +************************************************************************ +* * + Pattern matching on LitPat +* * +************************************************************************ +-} + +matchLiterals :: NonEmpty Id + -> Type -- ^ Type of the whole case expression + -> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits + -> DsM MatchResult + +matchLiterals (var :| vars) ty sub_groups + = do { -- Deal with each group + ; alts <- mapM match_group sub_groups + + -- Combine results. For everything except String + -- we can use a case expression; for String we need + -- a chain of if-then-else + ; if isStringTy (idType var) then + do { eq_str <- dsLookupGlobalId eqStringName + ; mrs <- mapM (wrap_str_guard eq_str) alts + ; return (foldr1 combineMatchResults mrs) } + else + return (mkCoPrimCaseMatchResult var ty $ NEL.toList alts) + } + where + match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult) + match_group eqns@(firstEqn :| _) + = do { dflags <- getDynFlags + ; let LitPat _ hs_lit = firstPat firstEqn + ; match_result <- match vars ty (NEL.toList $ shiftEqns eqns) + ; return (hsLitKey dflags hs_lit, match_result) } + + wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult + -- Equality check for string literals + wrap_str_guard eq_str (LitString s, mr) + = do { -- We now have to convert back to FastString. Perhaps there + -- should be separate LitBytes and LitString constructors? + let s' = mkFastStringByteString s + ; lit <- mkStringExprFS s' + ; let pred = mkApps (Var eq_str) [Var var, lit] + ; return (mkGuardedMatchResult pred mr) } + wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l) + + +--------------------------- +hsLitKey :: DynFlags -> HsLit GhcTc -> Literal +-- Get the Core literal corresponding to a HsLit. +-- It only works for primitive types and strings; +-- others have been removed by tidy +-- For HsString, it produces a LitString, which really represents an _unboxed_ +-- string literal; and we deal with it in matchLiterals above. Otherwise, it +-- produces a primitive Literal of type matching the original HsLit. +-- In the case of the fixed-width numeric types, we need to wrap here +-- because Literal has an invariant that the literal is in range, while +-- HsLit does not. +hsLitKey dflags (HsIntPrim _ i) = mkLitIntWrap dflags i +hsLitKey dflags (HsWordPrim _ w) = mkLitWordWrap dflags w +hsLitKey dflags (HsInt64Prim _ i) = mkLitInt64Wrap dflags i +hsLitKey dflags (HsWord64Prim _ w) = mkLitWord64Wrap dflags w +hsLitKey _ (HsCharPrim _ c) = mkLitChar c +hsLitKey _ (HsFloatPrim _ f) = mkLitFloat (fl_value f) +hsLitKey _ (HsDoublePrim _ d) = mkLitDouble (fl_value d) +hsLitKey _ (HsString _ s) = LitString (bytesFS s) +hsLitKey _ l = pprPanic "hsLitKey" (ppr l) + +{- +************************************************************************ +* * + Pattern matching on NPat +* * +************************************************************************ +-} + +matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult +matchNPats (var :| vars) ty (eqn1 :| eqns) -- All for the same literal + = do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1 + ; lit_expr <- dsOverLit lit + ; neg_lit <- case mb_neg of + Nothing -> return lit_expr + Just neg -> dsSyntaxExpr neg [lit_expr] + ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit] + ; match_result <- match vars ty (shiftEqns (eqn1:eqns)) + ; return (mkGuardedMatchResult pred_expr match_result) } + +{- +************************************************************************ +* * + Pattern matching on n+k patterns +* * +************************************************************************ + +For an n+k pattern, we use the various magic expressions we've been given. +We generate: +\begin{verbatim} + if ge var lit then + let n = sub var lit + in + else + +\end{verbatim} +-} + +matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult +-- All NPlusKPats, for the *same* literal k +matchNPlusKPats (var :| vars) ty (eqn1 :| eqns) + = do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus + = firstPat eqn1 + ; lit1_expr <- dsOverLit lit1 + ; lit2_expr <- dsOverLit lit2 + ; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr] + ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr] + ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns) + ; match_result <- match vars ty eqns' + ; return (mkGuardedMatchResult pred_expr $ + mkCoLetMatchResult (NonRec n1 minusk_expr) $ + adjustMatchResult (foldr1 (.) wraps) $ + match_result) } + where + shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats }) + = (wrapBind n n1, eqn { eqn_pats = pats }) + -- The wrapBind is a no-op for the first equation + shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e) diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs new file mode 100644 index 0000000000..4dc7590a47 --- /dev/null +++ b/compiler/GHC/HsToCore/Monad.hs @@ -0,0 +1,598 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Monadery used in desugaring +-} + +{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan +{-# LANGUAGE ViewPatterns #-} + +module GHC.HsToCore.Monad ( + DsM, mapM, mapAndUnzipM, + initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs, + foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM, + Applicative(..),(<$>), + + duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs, + newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId, + newFailLocalDs, newPredVarDs, + getSrcSpanDs, putSrcSpanDs, + mkPrintUnqualifiedDs, + newUnique, + UniqSupply, newUniqueSupply, + getGhcModeDs, dsGetFamInstEnvs, + dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, + dsLookupDataCon, dsLookupConLike, + + DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, + + -- Getting and setting pattern match oracle states + getPmDelta, updPmDelta, + + -- Get COMPLETE sets of a TyCon + dsGetCompleteMatches, + + -- Warnings and errors + DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr, + failWithDs, failDs, discardWarningsDs, + askNoErrsDs, + + -- Data types + DsMatchContext(..), + EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper, + CanItFail(..), orFail, + + -- Levity polymorphism + dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs, + + -- Trace injection + pprRuntimeTrace + ) where + +import GhcPrelude + +import TcRnMonad +import FamInstEnv +import CoreSyn +import MkCore ( unitExpr ) +import CoreUtils ( exprType, isExprLevPoly ) +import GHC.Hs +import GHC.IfaceToCore +import TcMType ( checkForLevPolyX, formatLevPolyErr ) +import PrelNames +import RdrName +import HscTypes +import Bag +import BasicTypes ( Origin ) +import DataCon +import ConLike +import TyCon +import GHC.HsToCore.PmCheck.Types +import Id +import Module +import Outputable +import SrcLoc +import Type +import UniqSupply +import Name +import NameEnv +import DynFlags +import ErrUtils +import FastString +import UniqFM ( lookupWithDefaultUFM ) +import Literal ( mkLitString ) +import CostCentreState + +import Data.IORef + +{- +************************************************************************ +* * + Data types for the desugarer +* * +************************************************************************ +-} + +data DsMatchContext + = DsMatchContext (HsMatchContext GhcRn) SrcSpan + deriving () + +instance Outputable DsMatchContext where + ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match + +data EquationInfo + = EqnInfo { eqn_pats :: [Pat GhcTc] + -- ^ The patterns for an equation + -- + -- NB: We have /already/ applied 'decideBangHood' to + -- these patterns. See Note [decideBangHood] in GHC.HsToCore.Utils + + , eqn_orig :: Origin + -- ^ Was this equation present in the user source? + -- + -- This helps us avoid warnings on patterns that GHC elaborated. + -- + -- For instance, the pattern @-1 :: Word@ gets desugared into + -- @W# -1## :: Word@, but we shouldn't warn about an overflowed + -- literal for /both/ of these cases. + + , eqn_rhs :: MatchResult + -- ^ What to do after match + } + +instance Outputable EquationInfo where + ppr (EqnInfo pats _ _) = ppr pats + +type DsWrapper = CoreExpr -> CoreExpr +idDsWrapper :: DsWrapper +idDsWrapper e = e + +-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult +-- \fail. wrap (case vs of { pats -> rhs fail }) +-- where vs are not bound by wrap + + +-- A MatchResult is an expression with a hole in it +data MatchResult + = MatchResult + CanItFail -- Tells whether the failure expression is used + (CoreExpr -> DsM CoreExpr) + -- Takes a expression to plug in at the + -- failure point(s). The expression should + -- be duplicatable! + +data CanItFail = CanFail | CantFail + +orFail :: CanItFail -> CanItFail -> CanItFail +orFail CantFail CantFail = CantFail +orFail _ _ = CanFail + +{- +************************************************************************ +* * + Monad functions +* * +************************************************************************ +-} + +-- Compatibility functions +fixDs :: (a -> DsM a) -> DsM a +fixDs = fixM + +type DsWarning = (SrcSpan, SDoc) + -- Not quite the same as a WarnMsg, we have an SDoc here + -- and we'll do the print_unqual stuff later on to turn it + -- into a Doc. + +-- | Run a 'DsM' action inside the 'TcM' monad. +initDsTc :: DsM a -> TcM a +initDsTc thing_inside + = do { tcg_env <- getGblEnv + ; msg_var <- getErrsVar + ; hsc_env <- getTopEnv + ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env + ; setEnvs envs thing_inside + } + +-- | Run a 'DsM' action inside the 'IO' monad. +initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a) +initDs hsc_env tcg_env thing_inside + = do { msg_var <- newIORef emptyMessages + ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env + ; runDs hsc_env envs thing_inside + } + +-- | Build a set of desugarer environments derived from a 'TcGblEnv'. +mkDsEnvsFromTcGbl :: MonadIO m + => HscEnv -> IORef Messages -> TcGblEnv + -> m (DsGblEnv, DsLclEnv) +mkDsEnvsFromTcGbl hsc_env msg_var tcg_env + = do { cc_st_var <- liftIO $ newIORef newCostCentreState + ; let dflags = hsc_dflags hsc_env + this_mod = tcg_mod tcg_env + type_env = tcg_type_env tcg_env + rdr_env = tcg_rdr_env tcg_env + fam_inst_env = tcg_fam_inst_env tcg_env + complete_matches = hptCompleteSigs hsc_env + ++ tcg_complete_matches tcg_env + ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env + msg_var cc_st_var complete_matches + } + +runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a) +runDs hsc_env (ds_gbl, ds_lcl) thing_inside + = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl + (tryM thing_inside) + ; msgs <- readIORef (ds_msgs ds_gbl) + ; let final_res + | errorsFound dflags msgs = Nothing + | Right r <- res = Just r + | otherwise = panic "initDs" + ; return (msgs, final_res) + } + where dflags = hsc_dflags hsc_env + +-- | Run a 'DsM' action in the context of an existing 'ModGuts' +initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a) +initDsWithModGuts hsc_env guts thing_inside + = do { cc_st_var <- newIORef newCostCentreState + ; msg_var <- newIORef emptyMessages + ; let dflags = hsc_dflags hsc_env + type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts) + rdr_env = mg_rdr_env guts + fam_inst_env = mg_fam_inst_env guts + this_mod = mg_module guts + complete_matches = hptCompleteSigs hsc_env + ++ mg_complete_sigs guts + + bindsToIds (NonRec v _) = [v] + bindsToIds (Rec binds) = map fst binds + ids = concatMap bindsToIds (mg_binds guts) + + envs = mkDsEnvs dflags this_mod rdr_env type_env + fam_inst_env msg_var cc_st_var + complete_matches + ; runDs hsc_env envs thing_inside + } + +initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a) +-- Spin up a TcM context so that we can run the constraint solver +-- Returns any error messages generated by the constraint solver +-- and (Just res) if no error happened; Nothing if an error happened +-- +-- Simon says: I'm not very happy about this. We spin up a complete TcM monad +-- only to immediately refine it to a TcS monad. +-- Better perhaps to make TcS into its own monad, rather than building on TcS +-- But that may in turn interact with plugins + +initTcDsForSolver thing_inside + = do { (gbl, lcl) <- getEnvs + ; hsc_env <- getTopEnv + + ; let DsGblEnv { ds_mod = mod + , ds_fam_inst_env = fam_inst_env } = gbl + + DsLclEnv { dsl_loc = loc } = lcl + + ; liftIO $ initTc hsc_env HsSrcFile False mod loc $ + updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $ + thing_inside } + +mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv + -> IORef Messages -> IORef CostCentreState -> [CompleteMatch] + -> (DsGblEnv, DsLclEnv) +mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var + complete_matches + = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs", + if_rec_types = Just (mod, return type_env) } + if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod) + False -- not boot! + real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1) + completeMatchMap = mkCompleteMatchMap complete_matches + gbl_env = DsGblEnv { ds_mod = mod + , ds_fam_inst_env = fam_inst_env + , ds_if_env = (if_genv, if_lenv) + , ds_unqual = mkPrintUnqualified dflags rdr_env + , ds_msgs = msg_var + , ds_complete_matches = completeMatchMap + , ds_cc_st = cc_st_var + } + lcl_env = DsLclEnv { dsl_meta = emptyNameEnv + , dsl_loc = real_span + , dsl_delta = initDelta + } + in (gbl_env, lcl_env) + + +{- +************************************************************************ +* * + Operations in the monad +* * +************************************************************************ + +And all this mysterious stuff is so we can occasionally reach out and +grab one or more names. @newLocalDs@ isn't exported---exported +functions are defined with it. The difference in name-strings makes +it easier to read debugging output. + +Note [Levity polymorphism checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +According to the "Levity Polymorphism" paper (PLDI '17), levity +polymorphism is forbidden in precisely two places: in the type of a bound +term-level argument and in the type of an argument to a function. The paper +explains it more fully, but briefly: expressions in these contexts need to be +stored in registers, and it's hard (read, impossible) to store something +that's levity polymorphic. + +We cannot check for bad levity polymorphism conveniently in the type checker, +because we can't tell, a priori, which levity metavariables will be solved. +At one point, I (Richard) thought we could check in the zonker, but it's hard +to know where precisely are the abstracted variables and the arguments. So +we check in the desugarer, the only place where we can see the Core code and +still report respectable syntax to the user. This covers the vast majority +of cases; see calls to GHC.HsToCore.Monad.dsNoLevPoly and friends. + +Levity polymorphism is also prohibited in the types of binders, and the +desugarer checks for this in GHC-generated Ids. (The zonker handles +the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP. +The newSysLocalDs variant is used in the vast majority of cases where +the binder is obviously not levity polymorphic, omitting the check. +It would be nice to ASSERT that there is no levity polymorphism here, +but we can't, because of the fixM in GHC.HsToCore.Arrows. It's all OK, though: +Core Lint will catch an error here. + +However, the desugarer is the wrong place for certain checks. In particular, +the desugarer can't report a sensible error message if an HsWrapper is malformed. +After all, GHC itself produced the HsWrapper. So we store some message text +in the appropriate HsWrappers (e.g. WpFun) that we can print out in the +desugarer. + +There are a few more checks in places where Core is generated outside the +desugarer. For example, in datatype and class declarations, where levity +polymorphism is checked for during validity checking. It would be nice to +have one central place for all this, but that doesn't seem possible while +still reporting nice error messages. + +-} + +-- Make a new Id with the same print name, but different type, and new unique +newUniqueId :: Id -> Type -> DsM Id +newUniqueId id = mk_local (occNameFS (nameOccName (idName id))) + +duplicateLocalDs :: Id -> DsM Id +duplicateLocalDs old_local + = do { uniq <- newUnique + ; return (setIdUnique old_local uniq) } + +newPredVarDs :: PredType -> DsM Var +newPredVarDs + = mkSysLocalOrCoVarM (fsLit "ds") -- like newSysLocalDs, but we allow covars + +newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id +newSysLocalDsNoLP = mk_local (fsLit "ds") + +-- this variant should be used when the caller can be sure that the variable type +-- is not levity-polymorphic. It is necessary when the type is knot-tied because +-- of the fixM used in GHC.HsToCore.Arrows. See Note [Levity polymorphism checking] +newSysLocalDs = mkSysLocalM (fsLit "ds") +newFailLocalDs = mkSysLocalM (fsLit "fail") + -- the fail variable is used only in a situation where we can tell that + -- levity-polymorphism is impossible. + +newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id] +newSysLocalsDsNoLP = mapM newSysLocalDsNoLP +newSysLocalsDs = mapM newSysLocalDs + +mk_local :: FastString -> Type -> DsM Id +mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+> + ppr ty) -- could improve the msg with another + -- parameter indicating context + ; mkSysLocalOrCoVarM fs ty } + +{- +We can also reach out and either set/grab location information from +the @SrcSpan@ being carried around. +-} + +getGhcModeDs :: DsM GhcMode +getGhcModeDs = getDynFlags >>= return . ghcMode + +-- | Get the current pattern match oracle state. See 'dsl_delta'. +getPmDelta :: DsM Delta +getPmDelta = do { env <- getLclEnv; return (dsl_delta env) } + +-- | Set the pattern match oracle state within the scope of the given action. +-- See 'dsl_delta'. +updPmDelta :: Delta -> DsM a -> DsM a +updPmDelta delta = updLclEnv (\env -> env { dsl_delta = delta }) + +getSrcSpanDs :: DsM SrcSpan +getSrcSpanDs = do { env <- getLclEnv + ; return (RealSrcSpan (dsl_loc env)) } + +putSrcSpanDs :: SrcSpan -> DsM a -> DsM a +putSrcSpanDs (UnhelpfulSpan {}) thing_inside + = thing_inside +putSrcSpanDs (RealSrcSpan real_span) thing_inside + = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside + +-- | Emit a warning for the current source location +-- NB: Warns whether or not -Wxyz is set +warnDs :: WarnReason -> SDoc -> DsM () +warnDs reason warn + = do { env <- getGblEnv + ; loc <- getSrcSpanDs + ; dflags <- getDynFlags + ; let msg = makeIntoWarning reason $ + mkWarnMsg dflags loc (ds_unqual env) warn + ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) } + +-- | Emit a warning only if the correct WarnReason is set in the DynFlags +warnIfSetDs :: WarningFlag -> SDoc -> DsM () +warnIfSetDs flag warn + = whenWOptM flag $ + warnDs (Reason flag) warn + +errDs :: SDoc -> DsM () +errDs err + = do { env <- getGblEnv + ; loc <- getSrcSpanDs + ; dflags <- getDynFlags + ; let msg = mkErrMsg dflags loc (ds_unqual env) err + ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) } + +-- | Issue an error, but return the expression for (), so that we can continue +-- reporting errors. +errDsCoreExpr :: SDoc -> DsM CoreExpr +errDsCoreExpr err + = do { errDs err + ; return unitExpr } + +failWithDs :: SDoc -> DsM a +failWithDs err + = do { errDs err + ; failM } + +failDs :: DsM a +failDs = failM + +-- (askNoErrsDs m) runs m +-- If m fails, +-- then (askNoErrsDs m) fails +-- If m succeeds with result r, +-- then (askNoErrsDs m) succeeds with result (r, b), +-- where b is True iff m generated no errors +-- Regardless of success or failure, +-- propagate any errors/warnings generated by m +-- +-- c.f. TcRnMonad.askNoErrs +askNoErrsDs :: DsM a -> DsM (a, Bool) +askNoErrsDs thing_inside + = do { errs_var <- newMutVar emptyMessages + ; env <- getGblEnv + ; mb_res <- tryM $ -- Be careful to catch exceptions + -- so that we propagate errors correctly + -- (#13642) + setGblEnv (env { ds_msgs = errs_var }) $ + thing_inside + + -- Propagate errors + ; msgs@(warns, errs) <- readMutVar errs_var + ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs)) + + -- And return + ; case mb_res of + Left _ -> failM + Right res -> do { dflags <- getDynFlags + ; let errs_found = errorsFound dflags msgs + ; return (res, not errs_found) } } + +mkPrintUnqualifiedDs :: DsM PrintUnqualified +mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv + +instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where + lookupThing = dsLookupGlobal + +dsLookupGlobal :: Name -> DsM TyThing +-- Very like TcEnv.tcLookupGlobal +dsLookupGlobal name + = do { env <- getGblEnv + ; setEnvs (ds_if_env env) + (tcIfaceGlobal name) } + +dsLookupGlobalId :: Name -> DsM Id +dsLookupGlobalId name + = tyThingId <$> dsLookupGlobal name + +dsLookupTyCon :: Name -> DsM TyCon +dsLookupTyCon name + = tyThingTyCon <$> dsLookupGlobal name + +dsLookupDataCon :: Name -> DsM DataCon +dsLookupDataCon name + = tyThingDataCon <$> dsLookupGlobal name + +dsLookupConLike :: Name -> DsM ConLike +dsLookupConLike name + = tyThingConLike <$> dsLookupGlobal name + + +dsGetFamInstEnvs :: DsM FamInstEnvs +-- Gets both the external-package inst-env +-- and the home-pkg inst env (includes module being compiled) +dsGetFamInstEnvs + = do { eps <- getEps; env <- getGblEnv + ; return (eps_fam_inst_env eps, ds_fam_inst_env env) } + +dsGetMetaEnv :: DsM (NameEnv DsMetaVal) +dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) } + +-- | The @COMPLETE@ pragmas provided by the user for a given `TyCon`. +dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch] +dsGetCompleteMatches tc = do + eps <- getEps + env <- getGblEnv + let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc + eps_matches_list = lookup_completes $ eps_complete_matches eps + env_matches_list = lookup_completes $ ds_complete_matches env + return $ eps_matches_list ++ env_matches_list + +dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal) +dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) } + +dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a +dsExtendMetaEnv menv thing_inside + = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside + +discardWarningsDs :: DsM a -> DsM a +-- Ignore warnings inside the thing inside; +-- used to ignore inaccessible cases etc. inside generated code +discardWarningsDs thing_inside + = do { env <- getGblEnv + ; old_msgs <- readTcRef (ds_msgs env) + + ; result <- thing_inside + + -- Revert messages to old_msgs + ; writeTcRef (ds_msgs env) old_msgs + + ; return result } + +-- | Fail with an error message if the type is levity polymorphic. +dsNoLevPoly :: Type -> SDoc -> DsM () +-- See Note [Levity polymorphism checking] +dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty + +-- | Check an expression for levity polymorphism, failing if it is +-- levity polymorphic. +dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM () +-- See Note [Levity polymorphism checking] +dsNoLevPolyExpr e doc + | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc) + | otherwise = return () + +-- | Runs the thing_inside. If there are no errors, then returns the expr +-- given. Otherwise, returns unitExpr. This is useful for doing a bunch +-- of levity polymorphism checks and then avoiding making a core App. +-- (If we make a core App on a levity polymorphic argument, detecting how +-- to handle the let/app invariant might call isUnliftedType, which panics +-- on a levity polymorphic type.) +-- See #12709 for an example of why this machinery is necessary. +dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr +dsWhenNoErrs thing_inside mk_expr + = do { (result, no_errs) <- askNoErrsDs thing_inside + ; return $ if no_errs + then mk_expr result + else unitExpr } + +-- | Inject a trace message into the compiled program. Whereas +-- pprTrace prints out information *while compiling*, pprRuntimeTrace +-- captures that information and causes it to be printed *at runtime* +-- using Debug.Trace.trace. +-- +-- pprRuntimeTrace hdr doc expr +-- +-- will produce an expression that looks like +-- +-- trace (hdr + doc) expr +-- +-- When using this to debug a module that Debug.Trace depends on, +-- it is necessary to import {-# SOURCE #-} Debug.Trace () in that +-- module. We could avoid this inconvenience by wiring in Debug.Trace.trace, +-- but that doesn't seem worth the effort and maintenance cost. +pprRuntimeTrace :: String -- ^ header + -> SDoc -- ^ information to output + -> CoreExpr -- ^ expression + -> DsM CoreExpr +pprRuntimeTrace str doc expr = do + traceId <- dsLookupGlobalId traceName + unpackCStringId <- dsLookupGlobalId unpackCStringName + dflags <- getDynFlags + let message :: CoreExpr + message = App (Var unpackCStringId) $ + Lit $ mkLitString $ showSDoc dflags (hang (text str) 4 doc) + return $ mkApps (Var traceId) [Type (exprType expr), message, expr] diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs index 3c9300c71e..4b1ff614d6 100644 --- a/compiler/GHC/HsToCore/PmCheck.hs +++ b/compiler/GHC/HsToCore/PmCheck.hs @@ -47,16 +47,16 @@ import Var (EvVar) import Coercion import TcEvidence import TcType (evVarPred) -import {-# SOURCE #-} DsExpr (dsExpr, dsLExpr, dsSyntaxExpr) -import {-# SOURCE #-} DsBinds (dsHsWrapper) -import DsUtils (selectMatchVar) -import MatchLit (dsLit, dsOverLit) -import DsMonad +import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr) +import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper) +import GHC.HsToCore.Utils (selectMatchVar) +import GHC.HsToCore.Match.Literal (dsLit, dsOverLit) +import GHC.HsToCore.Monad import Bag import OrdList import TyCoRep import Type -import DsUtils (isTrueLHsExpr) +import GHC.HsToCore.Utils (isTrueLHsExpr) import Maybes import qualified GHC.LanguageExtensions as LangExt @@ -482,7 +482,7 @@ translatePat fam_insts x pat = case pat of translateConPatOut fam_insts x con arg_tys ex_tvs dicts ps NPat ty (L _ olit) mb_neg _ -> do - -- See Note [Literal short cut] in MatchLit.hs + -- See Note [Literal short cut] in GHC.HsToCore.Match.Literal.hs -- We inline the Literal short cut for @ty@ here, because @ty@ is more -- precise than the field of OverLitTc, which is all that dsOverLit (which -- normally does the literal short cut) can look at. Also @ty@ matches the @@ -982,8 +982,8 @@ checkGrdTree guards deltas = do ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When checking a match it would be great to have all type and term information available so we can get more precise results. For this reason we have functions -`addDictsDs' and `addTmVarCsDs' in DsMonad that store in the environment type and -term constraints (respectively) as we go deeper. +`addDictsDs' and `addTmVarCsDs' in GHC.HsToCore.Monad that store in the +environment type and term constraints (respectively) as we go deeper. The type constraints we propagate inwards are collected by `collectEvVarsPats' in GHC.Hs.Pat. This handles bug #4139 ( see example diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs index a8fc154765..ab0f8ccc29 100644 --- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs +++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs @@ -66,7 +66,7 @@ import Unify (tcMatchTy) import TcRnTypes (completeMatchConLikes) import Coercion import MonadUtils hiding (foldlM) -import DsMonad hiding (foldlM) +import GHC.HsToCore.Monad hiding (foldlM) import FamInst import FamInstEnv diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs new file mode 100644 index 0000000000..970fc82463 --- /dev/null +++ b/compiler/GHC/HsToCore/Quote.hs @@ -0,0 +1,2958 @@ +{-# LANGUAGE CPP, TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2006 +-- +-- The purpose of this module is to transform an HsExpr into a CoreExpr which +-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the +-- input HsExpr. We do this in the DsM monad, which supplies access to +-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype. +-- +-- It also defines a bunch of knownKeyNames, in the same way as is done +-- in prelude/PrelNames. It's much more convenient to do it here, because +-- otherwise we have to recompile PrelNames whenever we add a Name, which is +-- a Royal Pain (triggers other recompilation). +----------------------------------------------------------------------------- + +module GHC.HsToCore.Quote( dsBracket ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr ) + +import GHC.HsToCore.Match.Literal +import GHC.HsToCore.Monad + +import qualified Language.Haskell.TH as TH + +import GHC.Hs +import PrelNames +-- To avoid clashes with GHC.HsToCore.Quote.varName we must make a local alias +-- for OccName.varName. We do this by removing varName from the import of OccName +-- above, making a qualified instance of OccName and using OccNameAlias.varName +-- where varName ws previously used in this file. +import qualified OccName( isDataOcc, isVarOcc, isTcOcc ) + +import Module +import Id +import Name hiding( isVarOcc, isTcOcc, varName, tcName ) +import THNames +import NameEnv +import TcType +import TyCon +import TysWiredIn +import CoreSyn +import MkCore +import CoreUtils +import SrcLoc +import Unique +import BasicTypes +import Outputable +import Bag +import DynFlags +import FastString +import ForeignCall +import Util +import Maybes +import MonadUtils +import TcEvidence +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class +import Class +import HscTypes ( MonadThings ) +import DataCon +import Var +import GHC.HsToCore.Binds + +import GHC.TypeLits +import Data.Kind (Constraint) + +import Data.ByteString ( unpack ) +import Control.Monad +import Data.List + +data MetaWrappers = MetaWrappers { + -- Applies its argument to a type argument `m` and dictionary `Quote m` + quoteWrapper :: CoreExpr -> CoreExpr + -- Apply its argument to a type argument `m` and a dictionary `Monad m` + , monadWrapper :: CoreExpr -> CoreExpr + -- Apply the container typed variable `m` to the argument type `T` to get `m T`. + , metaTy :: Type -> Type + -- Information about the wrappers which be printed to be inspected + , _debugWrappers :: (HsWrapper, HsWrapper, Type) + } + +-- | Construct the functions which will apply the relevant part of the +-- QuoteWrapper to identifiers during desugaring. +mkMetaWrappers :: QuoteWrapper -> DsM MetaWrappers +mkMetaWrappers q@(QuoteWrapper quote_var_raw m_var) = do + let quote_var = Var quote_var_raw + -- Get the superclass selector to select the Monad dictionary, going + -- to be used to construct the monadWrapper. + quote_tc <- dsLookupTyCon quoteClassName + monad_tc <- dsLookupTyCon monadClassName + let Just cls = tyConClass_maybe quote_tc + Just monad_cls = tyConClass_maybe monad_tc + -- Quote m -> Monad m + monad_sel = classSCSelId cls 0 + + -- Only used for the defensive assertion that the selector has + -- the expected type + tyvars = dataConUserTyVarBinders (classDataCon cls) + expected_ty = mkForAllTys tyvars $ + mkInvisFunTy (mkClassPred cls (mkTyVarTys (binderVars tyvars))) + (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars))) + + MASSERT2( idType monad_sel `eqType` expected_ty, ppr monad_sel $$ ppr expected_ty) + + let m_ty = Type m_var + -- Construct the contents of MetaWrappers + quoteWrapper = applyQuoteWrapper q + monadWrapper = mkWpEvApps [EvExpr $ mkCoreApps (Var monad_sel) [m_ty, quote_var]] <.> + mkWpTyApps [m_var] + tyWrapper t = mkAppTy m_var t + debug = (quoteWrapper, monadWrapper, m_var) + q_f <- dsHsWrapper quoteWrapper + m_f <- dsHsWrapper monadWrapper + return (MetaWrappers q_f m_f tyWrapper debug) + +-- Turn A into m A +wrapName :: Name -> MetaM Type +wrapName n = do + t <- lookupType n + wrap_fn <- asks metaTy + return (wrap_fn t) + +-- The local state is always the same, calculated from the passed in +-- wrapper +type MetaM a = ReaderT MetaWrappers DsM a + +----------------------------------------------------------------------------- +dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr + -> HsBracket GhcRn + -> [PendingTcSplice] + -> DsM CoreExpr +-- See Note [Desugaring Brackets] +-- Returns a CoreExpr of type (M TH.Exp) +-- The quoted thing is parameterised over Name, even though it has +-- been type checked. We don't want all those type decorations! + +dsBracket wrap brack splices + = do_brack brack + + where + runOverloaded act = do + -- In the overloaded case we have to get given a wrapper, it is just + -- for variable quotations that there is no wrapper, because they + -- have a simple type. + mw <- mkMetaWrappers (expectJust "runOverloaded" wrap) + runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw + + + new_bit = mkNameEnv [(n, DsSplice (unLoc e)) + | PendingTcSplice n e <- splices] + + do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOccDsM n ; return e1 } + do_brack (ExpBr _ e) = runOverloaded $ do { MkC e1 <- repLE e ; return e1 } + do_brack (PatBr _ p) = runOverloaded $ do { MkC p1 <- repTopP p ; return p1 } + do_brack (TypBr _ t) = runOverloaded $ do { MkC t1 <- repLTy t ; return t1 } + do_brack (DecBrG _ gp) = runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 } + do_brack (DecBrL {}) = panic "dsBracket: unexpected DecBrL" + do_brack (TExpBr _ e) = runOverloaded $ do { MkC e1 <- repLE e ; return e1 } + do_brack (XBracket nec) = noExtCon nec + +{- +Note [Desugaring Brackets] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In the old days (pre Dec 2019) quotation brackets used to be monomorphic, ie +an expression bracket was of type Q Exp. This made the desugaring process simple +as there were no complicated type variables to keep consistent throughout the +whole AST. Due to the overloaded quotations proposal a quotation bracket is now +of type `Quote m => m Exp` and all the combinators defined in TH.Lib have been +generalised to work with any monad implementing a minimal interface. + +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0246-overloaded-bracket.rst + +Users can rejoice at the flexibility but now there is some additional complexity in +how brackets are desugared as all these polymorphic combinators need their arguments +instantiated. + +> IF YOU ARE MODIFYING THIS MODULE DO NOT USE ANYTHING SPECIFIC TO Q. INSTEAD +> USE THE `wrapName` FUNCTION TO APPLY THE `m` TYPE VARIABLE TO A TYPE CONSTRUCTOR. + +What the arguments should be instantiated to is supplied by the `QuoteWrapper` +datatype which is produced by `TcSplice`. It is a pair of an evidence variable +for `Quote m` and a type variable `m`. All the polymorphic combinators in desugaring +need to be applied to these two type variables. + +There are three important functions which do the application. + +1. The default is `rep2` which takes a function name of type `Quote m => T` as an argument. +2. `rep2M` takes a function name of type `Monad m => T` as an argument +3. `rep2_nw` takes a function name without any constraints as an argument. + +These functions then use the information in QuoteWrapper to apply the correct +arguments to the functions as the representation is constructed. + +The `MetaM` monad carries around an environment of three functions which are +used in order to wrap the polymorphic combinators and instantiate the arguments +to the correct things. + +1. quoteWrapper wraps functions of type `forall m . Quote m => T` +2. monadWrapper wraps functions of type `forall m . Monad m => T` +3. metaTy wraps a type in the polymorphic `m` variable of the whole representation. + +Historical note about the implementation: At the first attempt, I attempted to +lie that the type of any quotation was `Quote m => m Exp` and then specialise it +by applying a wrapper to pass the `m` and `Quote m` arguments. This approach was +simpler to implement but didn't work because of nested splices. For example, +you might have a nested splice of a more specific type which fixes the type of +the overall quote and so all the combinators used must also be instantiated to +that specific type. Therefore you really have to use the contents of the quote +wrapper to directly apply the right type to the combinators rather than +first generate a polymorphic definition and then just apply the wrapper at the end. + +-} + +{- -------------- Examples -------------------- + + [| \x -> x |] +====> + gensym (unpackString "x"#) `bindQ` \ x1::String -> + lam (pvar x1) (var x1) + + + [| \x -> $(f [| x |]) |] +====> + gensym (unpackString "x"#) `bindQ` \ x1::String -> + lam (pvar x1) (f (var x1)) +-} + + +------------------------------------------------------- +-- Declarations +------------------------------------------------------- + +-- Proxy for the phantom type of `Core`. All the generated fragments have +-- type something like `Quote m => m Exp` so to keep things simple we represent fragments +-- of that type as `M Exp`. +data M a + +repTopP :: LPat GhcRn -> MetaM (Core (M TH.Pat)) +repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat) + ; pat' <- addBinds ss (repLP pat) + ; wrapGenSyms ss pat' } + +repTopDs :: HsGroup GhcRn -> MetaM (Core (M [TH.Dec])) +repTopDs group@(HsGroup { hs_valds = valds + , hs_splcds = splcds + , hs_tyclds = tyclds + , hs_derivds = derivds + , hs_fixds = fixds + , hs_defds = defds + , hs_fords = fords + , hs_warnds = warnds + , hs_annds = annds + , hs_ruleds = ruleds + , hs_docs = docs }) + = do { let { bndrs = hsScopedTvBinders valds + ++ hsGroupBinders group + ++ hsPatSynSelectors valds + ; instds = tyclds >>= group_instds } ; + ss <- mkGenSyms bndrs ; + + -- Bind all the names mainly to avoid repeated use of explicit strings. + -- Thus we get + -- do { t :: String <- genSym "T" ; + -- return (Data t [] ...more t's... } + -- The other important reason is that the output must mention + -- only "T", not "Foo:T" where Foo is the current module + + decls <- addBinds ss ( + do { val_ds <- rep_val_binds valds + ; _ <- mapM no_splice splcds + ; tycl_ds <- mapM repTyClD (tyClGroupTyClDecls tyclds) + ; role_ds <- mapM repRoleD (concatMap group_roles tyclds) + ; kisig_ds <- mapM repKiSigD (concatMap group_kisigs tyclds) + ; inst_ds <- mapM repInstD instds + ; deriv_ds <- mapM repStandaloneDerivD derivds + ; fix_ds <- mapM repLFixD fixds + ; _ <- mapM no_default_decl defds + ; for_ds <- mapM repForD fords + ; _ <- mapM no_warn (concatMap (wd_warnings . unLoc) + warnds) + ; ann_ds <- mapM repAnnD annds + ; rule_ds <- mapM repRuleD (concatMap (rds_rules . unLoc) + ruleds) + ; _ <- mapM no_doc docs + + -- more needed + ; return (de_loc $ sort_by_loc $ + val_ds ++ catMaybes tycl_ds ++ role_ds + ++ kisig_ds + ++ (concat fix_ds) + ++ inst_ds ++ rule_ds ++ for_ds + ++ ann_ds ++ deriv_ds) }) ; + + core_list <- repListM decTyConName return decls ; + + dec_ty <- lookupType decTyConName ; + q_decs <- repSequenceM dec_ty core_list ; + + wrapGenSyms ss q_decs + } + where + no_splice (L loc _) + = notHandledL loc "Splices within declaration brackets" empty + no_default_decl (L loc decl) + = notHandledL loc "Default declarations" (ppr decl) + no_warn (L loc (Warning _ thing _)) + = notHandledL loc "WARNING and DEPRECATION pragmas" $ + text "Pragma for declaration of" <+> ppr thing + no_warn (L _ (XWarnDecl nec)) = noExtCon nec + no_doc (L loc _) + = notHandledL loc "Haddock documentation" empty +repTopDs (XHsGroup nec) = noExtCon nec + +hsScopedTvBinders :: HsValBinds GhcRn -> [Name] +-- See Note [Scoped type variables in bindings] +hsScopedTvBinders binds + = concatMap get_scoped_tvs sigs + where + sigs = case binds of + ValBinds _ _ sigs -> sigs + XValBindsLR (NValBinds _ sigs) -> sigs + +get_scoped_tvs :: LSig GhcRn -> [Name] +get_scoped_tvs (L _ signature) + | TypeSig _ _ sig <- signature + = get_scoped_tvs_from_sig (hswc_body sig) + | ClassOpSig _ _ _ sig <- signature + = get_scoped_tvs_from_sig sig + | PatSynSig _ _ sig <- signature + = get_scoped_tvs_from_sig sig + | otherwise + = [] + where + get_scoped_tvs_from_sig sig + -- Both implicit and explicit quantified variables + -- We need the implicit ones for f :: forall (a::k). blah + -- here 'k' scopes too + | HsIB { hsib_ext = implicit_vars + , hsib_body = hs_ty } <- sig + , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty + = implicit_vars ++ hsLTyVarNames explicit_vars + get_scoped_tvs_from_sig (XHsImplicitBndrs nec) + = noExtCon nec + +{- Notes + +Note [Scoped type variables in bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: forall a. a -> a + f x = x::a +Here the 'forall a' brings 'a' into scope over the binding group. +To achieve this we + + a) Gensym a binding for 'a' at the same time as we do one for 'f' + collecting the relevant binders with hsScopedTvBinders + + b) When processing the 'forall', don't gensym + +The relevant places are signposted with references to this Note + +Note [Scoped type variables in class and instance declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Scoped type variables may occur in default methods and default +signatures. We need to bring the type variables in 'foralls' +into the scope of the method bindings. + +Consider + class Foo a where + foo :: forall (b :: k). a -> Proxy b -> Proxy b + foo _ x = (x :: Proxy b) + +We want to ensure that the 'b' in the type signature and the default +implementation are the same, so we do the following: + + a) Before desugaring the signature and binding of 'foo', use + get_scoped_tvs to collect type variables in 'forall' and + create symbols for them. + b) Use 'addBinds' to bring these symbols into the scope of the type + signatures and bindings. + c) Use these symbols to generate Core for the class/instance declaration. + +Note that when desugaring the signatures, we lookup the type variables +from the scope rather than recreate symbols for them. See more details +in "rep_ty_sig" and in Trac#14885. + +Note [Binders and occurrences] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we desugar [d| data T = MkT |] +we want to get + Data "T" [] [Con "MkT" []] [] +and *not* + Data "Foo:T" [] [Con "Foo:MkT" []] [] +That is, the new data decl should fit into whatever new module it is +asked to fit in. We do *not* clone, though; no need for this: + Data "T79" .... + +But if we see this: + data T = MkT + foo = reifyDecl T + +then we must desugar to + foo = Data "Foo:T" [] [Con "Foo:MkT" []] [] + +So in repTopDs we bring the binders into scope with mkGenSyms and addBinds. +And we use lookupOcc, rather than lookupBinder +in repTyClD and repC. + +Note [Don't quantify implicit type variables in quotes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you're not careful, it's surprisingly easy to take this quoted declaration: + + [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b + idProxy x = x + |] + +and have Template Haskell turn it into this: + + idProxy :: forall k proxy (b :: k). proxy b -> proxy b + idProxy x = x + +Notice that we explicitly quantified the variable `k`! The latter declaration +isn't what the user wrote in the first place. + +Usually, the culprit behind these bugs is taking implicitly quantified type +variables (often from the hsib_vars field of HsImplicitBinders) and putting +them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123. +-} + +-- represent associated family instances +-- +repTyClD :: LTyClDecl GhcRn -> MetaM (Maybe (SrcSpan, Core (M TH.Dec))) + +repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ + repFamilyDecl (L loc fam) + +repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs })) + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; dec <- addTyClTyVarBinds tvs $ \bndrs -> + repSynDecl tc1 bndrs rhs + ; return (Just (loc, dec)) } + +repTyClD (L loc (DataDecl { tcdLName = tc + , tcdTyVars = tvs + , tcdDataDefn = defn })) + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; dec <- addTyClTyVarBinds tvs $ \bndrs -> + repDataDefn tc1 (Left bndrs) defn + ; return (Just (loc, dec)) } + +repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, + tcdTyVars = tvs, tcdFDs = fds, + tcdSigs = sigs, tcdMeths = meth_binds, + tcdATs = ats, tcdATDefs = atds })) + = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences] + ; dec <- addTyVarBinds tvs $ \bndrs -> + do { cxt1 <- repLContext cxt + -- See Note [Scoped type variables in class and instance declarations] + ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds + ; fds1 <- repLFunDeps fds + ; ats1 <- repFamilyDecls ats + ; atds1 <- mapM (repAssocTyFamDefaultD . unLoc) atds + ; decls1 <- repListM decTyConName return (ats1 ++ atds1 ++ sigs_binds) + ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1 + ; wrapGenSyms ss decls2 } + ; return $ Just (loc, dec) + } + +repTyClD (L _ (XTyClDecl nec)) = noExtCon nec + +------------------------- +repRoleD :: LRoleAnnotDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repRoleD (L loc (RoleAnnotDecl _ tycon roles)) + = do { tycon1 <- lookupLOcc tycon + ; roles1 <- mapM repRole roles + ; roles2 <- coreList roleTyConName roles1 + ; dec <- repRoleAnnotD tycon1 roles2 + ; return (loc, dec) } +repRoleD (L _ (XRoleAnnotDecl nec)) = noExtCon nec + +------------------------- +repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repKiSigD (L loc kisig) = + case kisig of + StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v + XStandaloneKindSig nec -> noExtCon nec + +------------------------- +repDataDefn :: Core TH.Name + -> Either (Core [(M TH.TyVarBndr)]) + -- the repTyClD case + (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type)) + -- the repDataFamInstD case + -> HsDataDefn GhcRn + -> MetaM (Core (M TH.Dec)) +repDataDefn tc opts + (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig + , dd_cons = cons, dd_derivs = mb_derivs }) + = do { cxt1 <- repLContext cxt + ; derivs1 <- repDerivs mb_derivs + ; case (new_or_data, cons) of + (NewType, [con]) -> do { con' <- repC con + ; ksig' <- repMaybeLTy ksig + ; repNewtype cxt1 tc opts ksig' con' + derivs1 } + (NewType, _) -> lift $ failWithDs (text "Multiple constructors for newtype:" + <+> pprQuotedList + (getConNames $ unLoc $ head cons)) + (DataType, _) -> do { ksig' <- repMaybeLTy ksig + ; consL <- mapM repC cons + ; cons1 <- coreListM conTyConName consL + ; repData cxt1 tc opts ksig' cons1 + derivs1 } + } +repDataDefn _ _ (XHsDataDefn nec) = noExtCon nec + +repSynDecl :: Core TH.Name -> Core [(M TH.TyVarBndr)] + -> LHsType GhcRn + -> MetaM (Core (M TH.Dec)) +repSynDecl tc bndrs ty + = do { ty1 <- repLTy ty + ; repTySyn tc bndrs ty1 } + +repFamilyDecl :: LFamilyDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info + , fdLName = tc + , fdTyVars = tvs + , fdResultSig = L _ resultSig + , fdInjectivityAnn = injectivity })) + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn + mkHsQTvs tvs = HsQTvs { hsq_ext = [] + , hsq_explicit = tvs } + resTyVar = case resultSig of + TyVarSig _ bndr -> mkHsQTvs [bndr] + _ -> mkHsQTvs [] + ; dec <- addTyClTyVarBinds tvs $ \bndrs -> + addTyClTyVarBinds resTyVar $ \_ -> + case info of + ClosedTypeFamily Nothing -> + notHandled "abstract closed type family" (ppr decl) + ClosedTypeFamily (Just eqns) -> + do { eqns1 <- mapM (repTyFamEqn . unLoc) eqns + ; eqns2 <- coreListM tySynEqnTyConName eqns1 + ; result <- repFamilyResultSig resultSig + ; inj <- repInjectivityAnn injectivity + ; repClosedFamilyD tc1 bndrs result inj eqns2 } + OpenTypeFamily -> + do { result <- repFamilyResultSig resultSig + ; inj <- repInjectivityAnn injectivity + ; repOpenFamilyD tc1 bndrs result inj } + DataFamily -> + do { kind <- repFamilyResultSigToMaybeKind resultSig + ; repDataFamilyD tc1 bndrs kind } + ; return (loc, dec) + } +repFamilyDecl (L _ (XFamilyDecl nec)) = noExtCon nec + +-- | Represent result signature of a type family +repFamilyResultSig :: FamilyResultSig GhcRn -> MetaM (Core (M TH.FamilyResultSig)) +repFamilyResultSig (NoSig _) = repNoSig +repFamilyResultSig (KindSig _ ki) = do { ki' <- repLTy ki + ; repKindSig ki' } +repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr + ; repTyVarSig bndr' } +repFamilyResultSig (XFamilyResultSig nec) = noExtCon nec + +-- | Represent result signature using a Maybe Kind. Used with data families, +-- where the result signature can be either missing or a kind but never a named +-- result variable. +repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn + -> MetaM (Core (Maybe (M TH.Kind))) +repFamilyResultSigToMaybeKind (NoSig _) = + do { coreNothingM kindTyConName } +repFamilyResultSigToMaybeKind (KindSig _ ki) = + do { coreJustM kindTyConName =<< repLTy ki } +repFamilyResultSigToMaybeKind TyVarSig{} = + panic "repFamilyResultSigToMaybeKind: unexpected TyVarSig" +repFamilyResultSigToMaybeKind (XFamilyResultSig nec) = noExtCon nec + +-- | Represent injectivity annotation of a type family +repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) + -> MetaM (Core (Maybe TH.InjectivityAnn)) +repInjectivityAnn Nothing = + do { coreNothing injAnnTyConName } +repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) = + do { lhs' <- lookupBinder (unLoc lhs) + ; rhs1 <- mapM (lookupBinder . unLoc) rhs + ; rhs2 <- coreList nameTyConName rhs1 + ; injAnn <- rep2_nw injectivityAnnName [unC lhs', unC rhs2] + ; coreJust injAnnTyConName injAnn } + +repFamilyDecls :: [LFamilyDecl GhcRn] -> MetaM [Core (M TH.Dec)] +repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds) + +repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> MetaM (Core (M TH.Dec)) +repAssocTyFamDefaultD = repTyFamInstD + +------------------------- +-- represent fundeps +-- +repLFunDeps :: [LHsFunDep GhcRn] -> MetaM (Core [TH.FunDep]) +repLFunDeps fds = repList funDepTyConName repLFunDep fds + +repLFunDep :: LHsFunDep GhcRn -> MetaM (Core TH.FunDep) +repLFunDep (L _ (xs, ys)) + = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs + ys' <- repList nameTyConName (lookupBinder . unLoc) ys + repFunDep xs' ys' + +-- Represent instance declarations +-- +repInstD :: LInstDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repInstD (L loc (TyFamInstD { tfid_inst = fi_decl })) + = do { dec <- repTyFamInstD fi_decl + ; return (loc, dec) } +repInstD (L loc (DataFamInstD { dfid_inst = fi_decl })) + = do { dec <- repDataFamInstD fi_decl + ; return (loc, dec) } +repInstD (L loc (ClsInstD { cid_inst = cls_decl })) + = do { dec <- repClsInstD cls_decl + ; return (loc, dec) } +repInstD (L _ (XInstDecl nec)) = noExtCon nec + +repClsInstD :: ClsInstDecl GhcRn -> MetaM (Core (M TH.Dec)) +repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds + , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_datafam_insts = adts + , cid_overlap_mode = overlap + }) + = addSimpleTyVarBinds tvs $ + -- We must bring the type variables into scope, so their + -- occurrences don't fail, even though the binders don't + -- appear in the resulting data structure + -- + -- But we do NOT bring the binders of 'binds' into scope + -- because they are properly regarded as occurrences + -- For example, the method names should be bound to + -- the selector Ids, not to fresh names (#5410) + -- + do { cxt1 <- repLContext cxt + ; inst_ty1 <- repLTy inst_ty + -- See Note [Scoped type variables in class and instance declarations] + ; (ss, sigs_binds) <- rep_sigs_binds sigs binds + ; ats1 <- mapM (repTyFamInstD . unLoc) ats + ; adts1 <- mapM (repDataFamInstD . unLoc) adts + ; decls1 <- coreListM decTyConName (ats1 ++ adts1 ++ sigs_binds) + ; rOver <- repOverlap (fmap unLoc overlap) + ; decls2 <- repInst rOver cxt1 inst_ty1 decls1 + ; wrapGenSyms ss decls2 } + where + (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty +repClsInstD (XClsInstDecl nec) = noExtCon nec + +repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat + , deriv_type = ty })) + = do { dec <- addSimpleTyVarBinds tvs $ + do { cxt' <- repLContext cxt + ; strat' <- repDerivStrategy strat + ; inst_ty' <- repLTy inst_ty + ; repDeriv strat' cxt' inst_ty' } + ; return (loc, dec) } + where + (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty) +repStandaloneDerivD (L _ (XDerivDecl nec)) = noExtCon nec + +repTyFamInstD :: TyFamInstDecl GhcRn -> MetaM (Core (M TH.Dec)) +repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) + = do { eqn1 <- repTyFamEqn eqn + ; repTySynInst eqn1 } + +repTyFamEqn :: TyFamInstEqn GhcRn -> MetaM (Core (M TH.TySynEqn)) +repTyFamEqn (HsIB { hsib_ext = var_names + , hsib_body = FamEqn { feqn_tycon = tc_name + , feqn_bndrs = mb_bndrs + , feqn_pats = tys + , feqn_fixity = fixity + , feqn_rhs = rhs }}) + = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] + ; let hs_tvs = HsQTvs { hsq_ext = var_names + , hsq_explicit = fromMaybe [] mb_bndrs } + ; addTyClTyVarBinds hs_tvs $ \ _ -> + do { mb_bndrs1 <- repMaybeListM tyVarBndrTyConName + repTyVarBndr + mb_bndrs + ; tys1 <- case fixity of + Prefix -> repTyArgs (repNamedTyCon tc) tys + Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys + ; t1' <- repLTy t1 + ; t2' <- repLTy t2 + ; repTyArgs (repTInfix t1' tc t2') args } + ; rhs1 <- repLTy rhs + ; repTySynEqn mb_bndrs1 tys1 rhs1 } } + where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn] + checkTys tys@(HsValArg _:HsValArg _:_) = return tys + checkTys _ = panic "repTyFamEqn:checkTys" +repTyFamEqn (XHsImplicitBndrs nec) = noExtCon nec +repTyFamEqn (HsIB _ (XFamEqn nec)) = noExtCon nec + +repTyArgs :: MetaM (Core (M TH.Type)) -> [LHsTypeArg GhcRn] -> MetaM (Core (M TH.Type)) +repTyArgs f [] = f +repTyArgs f (HsValArg ty : as) = do { f' <- f + ; ty' <- repLTy ty + ; repTyArgs (repTapp f' ty') as } +repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f + ; ki' <- repLTy ki + ; repTyArgs (repTappKind f' ki') as } +repTyArgs f (HsArgPar _ : as) = repTyArgs f as + +repDataFamInstD :: DataFamInstDecl GhcRn -> MetaM (Core (M TH.Dec)) +repDataFamInstD (DataFamInstDecl { dfid_eqn = + (HsIB { hsib_ext = var_names + , hsib_body = FamEqn { feqn_tycon = tc_name + , feqn_bndrs = mb_bndrs + , feqn_pats = tys + , feqn_fixity = fixity + , feqn_rhs = defn }})}) + = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] + ; let hs_tvs = HsQTvs { hsq_ext = var_names + , hsq_explicit = fromMaybe [] mb_bndrs } + ; addTyClTyVarBinds hs_tvs $ \ _ -> + do { mb_bndrs1 <- repMaybeListM tyVarBndrTyConName + repTyVarBndr + mb_bndrs + ; tys1 <- case fixity of + Prefix -> repTyArgs (repNamedTyCon tc) tys + Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys + ; t1' <- repLTy t1 + ; t2' <- repLTy t2 + ; repTyArgs (repTInfix t1' tc t2') args } + ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } } + + where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn] + checkTys tys@(HsValArg _: HsValArg _: _) = return tys + checkTys _ = panic "repDataFamInstD:checkTys" + +repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs nec)) + = noExtCon nec +repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn nec))) + = noExtCon nec + +repForD :: Located (ForeignDecl GhcRn) -> MetaM (SrcSpan, Core (M TH.Dec)) +repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ + , fd_fi = CImport (L _ cc) + (L _ s) mch cis _ })) + = do MkC name' <- lookupLOcc name + MkC typ' <- repHsSigType typ + MkC cc' <- repCCallConv cc + MkC s' <- repSafety s + cis' <- conv_cimportspec cis + MkC str <- coreStringLit (static ++ chStr ++ cis') + dec <- rep2 forImpDName [cc', s', str, name', typ'] + return (loc, dec) + where + conv_cimportspec (CLabel cls) + = notHandled "Foreign label" (doubleQuotes (ppr cls)) + conv_cimportspec (CFunction DynamicTarget) = return "dynamic" + conv_cimportspec (CFunction (StaticTarget _ fs _ True)) + = return (unpackFS fs) + conv_cimportspec (CFunction (StaticTarget _ _ _ False)) + = panic "conv_cimportspec: values not supported yet" + conv_cimportspec CWrapper = return "wrapper" + -- these calling conventions do not support headers and the static keyword + raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv + static = case cis of + CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static " + _ -> "" + chStr = case mch of + Just (Header _ h) | not raw_cconv -> unpackFS h ++ " " + _ -> "" +repForD decl@(L _ ForeignExport{}) = notHandled "Foreign export" (ppr decl) +repForD (L _ (XForeignDecl nec)) = noExtCon nec + +repCCallConv :: CCallConv -> MetaM (Core TH.Callconv) +repCCallConv CCallConv = rep2_nw cCallName [] +repCCallConv StdCallConv = rep2_nw stdCallName [] +repCCallConv CApiConv = rep2_nw cApiCallName [] +repCCallConv PrimCallConv = rep2_nw primCallName [] +repCCallConv JavaScriptCallConv = rep2_nw javaScriptCallName [] + +repSafety :: Safety -> MetaM (Core TH.Safety) +repSafety PlayRisky = rep2_nw unsafeName [] +repSafety PlayInterruptible = rep2_nw interruptibleName [] +repSafety PlaySafe = rep2_nw safeName [] + +repLFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] +repLFixD (L loc fix_sig) = rep_fix_d loc fix_sig + +rep_fix_d :: SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_fix_d loc (FixitySig _ names (Fixity _ prec dir)) + = do { MkC prec' <- coreIntLit prec + ; let rep_fn = case dir of + InfixL -> infixLDName + InfixR -> infixRDName + InfixN -> infixNDName + ; let do_one name + = do { MkC name' <- lookupLOcc name + ; dec <- rep2 rep_fn [prec', name'] + ; return (loc,dec) } + ; mapM do_one names } +rep_fix_d _ (XFixitySig nec) = noExtCon nec + +repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repRuleD (L loc (HsRule { rd_name = n + , rd_act = act + , rd_tyvs = ty_bndrs + , rd_tmvs = tm_bndrs + , rd_lhs = lhs + , rd_rhs = rhs })) + = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs -> + do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs + ; ss <- mkGenSyms tm_bndr_names + ; rule <- addBinds ss $ + do { elt_ty <- wrapName tyVarBndrTyConName + ; ty_bndrs' <- return $ case ty_bndrs of + Nothing -> coreNothing' (mkListTy elt_ty) + Just _ -> coreJust' (mkListTy elt_ty) ex_bndrs + ; tm_bndrs' <- repListM ruleBndrTyConName + repRuleBndr + tm_bndrs + ; n' <- coreStringLit $ unpackFS $ snd $ unLoc n + ; act' <- repPhases act + ; lhs' <- repLE lhs + ; rhs' <- repLE rhs + ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' } + ; wrapGenSyms ss rule } + ; return (loc, rule) } +repRuleD (L _ (XRuleDecl nec)) = noExtCon nec + +ruleBndrNames :: LRuleBndr GhcRn -> [Name] +ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n] +ruleBndrNames (L _ (RuleBndrSig _ n sig)) + | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig + = unLoc n : vars +ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs nec)))) + = noExtCon nec +ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs nec))) + = noExtCon nec +ruleBndrNames (L _ (XRuleBndr nec)) = noExtCon nec + +repRuleBndr :: LRuleBndr GhcRn -> MetaM (Core (M TH.RuleBndr)) +repRuleBndr (L _ (RuleBndr _ n)) + = do { MkC n' <- lookupLBinder n + ; rep2 ruleVarName [n'] } +repRuleBndr (L _ (RuleBndrSig _ n sig)) + = do { MkC n' <- lookupLBinder n + ; MkC ty' <- repLTy (hsSigWcType sig) + ; rep2 typedRuleVarName [n', ty'] } +repRuleBndr (L _ (XRuleBndr nec)) = noExtCon nec + +repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp))) + = do { target <- repAnnProv ann_prov + ; exp' <- repE exp + ; dec <- repPragAnn target exp' + ; return (loc, dec) } +repAnnD (L _ (XAnnDecl nec)) = noExtCon nec + +repAnnProv :: AnnProvenance Name -> MetaM (Core TH.AnnTarget) +repAnnProv (ValueAnnProvenance (L _ n)) + = do { MkC n' <- lift $ globalVar n -- ANNs are allowed only at top-level + ; rep2_nw valueAnnotationName [ n' ] } +repAnnProv (TypeAnnProvenance (L _ n)) + = do { MkC n' <- lift $ globalVar n + ; rep2_nw typeAnnotationName [ n' ] } +repAnnProv ModuleAnnProvenance + = rep2_nw moduleAnnotationName [] + +------------------------------------------------------- +-- Constructors +------------------------------------------------------- + +repC :: LConDecl GhcRn -> MetaM (Core (M TH.Con)) +repC (L _ (ConDeclH98 { con_name = con + , con_forall = (L _ False) + , con_mb_cxt = Nothing + , con_args = args })) + = repDataCon con args + +repC (L _ (ConDeclH98 { con_name = con + , con_forall = L _ is_existential + , con_ex_tvs = con_tvs + , con_mb_cxt = mcxt + , con_args = args })) + = do { addHsTyVarBinds con_tvs $ \ ex_bndrs -> + do { c' <- repDataCon con args + ; ctxt' <- repMbContext mcxt + ; if not is_existential && isNothing mcxt + then return c' + else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) + } + } + +repC (L _ (ConDeclGADT { con_names = cons + , con_qvars = qtvs + , con_mb_cxt = mcxt + , con_args = args + , con_res_ty = res_ty })) + | isEmptyLHsQTvs qtvs -- No implicit or explicit variables + , Nothing <- mcxt -- No context + -- ==> no need for a forall + = repGadtDataCons cons args res_ty + + | otherwise + = addTyVarBinds qtvs $ \ ex_bndrs -> + -- See Note [Don't quantify implicit type variables in quotes] + do { c' <- repGadtDataCons cons args res_ty + ; ctxt' <- repMbContext mcxt + ; if null (hsQTvExplicit qtvs) && isNothing mcxt + then return c' + else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } + +repC (L _ (XConDecl nec)) = noExtCon nec + + +repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt)) +repMbContext Nothing = repContext [] +repMbContext (Just (L _ cxt)) = repContext cxt + +repSrcUnpackedness :: SrcUnpackedness -> MetaM (Core (M TH.SourceUnpackedness)) +repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName [] +repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName [] +repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName [] + +repSrcStrictness :: SrcStrictness -> MetaM (Core (M TH.SourceStrictness)) +repSrcStrictness SrcLazy = rep2 sourceLazyName [] +repSrcStrictness SrcStrict = rep2 sourceStrictName [] +repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName [] + +repBangTy :: LBangType GhcRn -> MetaM (Core (M TH.BangType)) +repBangTy ty = do + MkC u <- repSrcUnpackedness su' + MkC s <- repSrcStrictness ss' + MkC b <- rep2 bangName [u, s] + MkC t <- repLTy ty' + rep2 bangTypeName [b, t] + where + (su', ss', ty') = case unLoc ty of + HsBangTy _ (HsSrcBang _ su ss) ty -> (su, ss, ty) + _ -> (NoSrcUnpack, NoSrcStrict, ty) + +------------------------------------------------------- +-- Deriving clauses +------------------------------------------------------- + +repDerivs :: HsDeriving GhcRn -> MetaM (Core [M TH.DerivClause]) +repDerivs (L _ clauses) + = repListM derivClauseTyConName repDerivClause clauses + +repDerivClause :: LHsDerivingClause GhcRn + -> MetaM (Core (M TH.DerivClause)) +repDerivClause (L _ (HsDerivingClause + { deriv_clause_strategy = dcs + , deriv_clause_tys = L _ dct })) + = do MkC dcs' <- repDerivStrategy dcs + MkC dct' <- repListM typeTyConName (rep_deriv_ty . hsSigType) dct + rep2 derivClauseName [dcs',dct'] + where + rep_deriv_ty :: LHsType GhcRn -> MetaM (Core (M TH.Type)) + rep_deriv_ty ty = repLTy ty +repDerivClause (L _ (XHsDerivingClause nec)) = noExtCon nec + +rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn + -> MetaM ([GenSymBind], [Core (M TH.Dec)]) +-- Represent signatures and methods in class/instance declarations. +-- See Note [Scoped type variables in class and instance declarations] +-- +-- Why not use 'repBinds': we have already created symbols for methods in +-- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate +-- these fun_id via 'collectHsValBinders decs', which would lead to the +-- instance declarations failing in TH. +rep_sigs_binds sigs binds + = do { let tvs = concatMap get_scoped_tvs sigs + ; ss <- mkGenSyms tvs + ; sigs1 <- addBinds ss $ rep_sigs sigs + ; binds1 <- addBinds ss $ rep_binds binds + ; return (ss, de_loc (sort_by_loc (sigs1 ++ binds1))) } + +------------------------------------------------------- +-- Signatures in a class decl, or a group of bindings +------------------------------------------------------- + +rep_sigs :: [LSig GhcRn] -> MetaM [(SrcSpan, Core (M TH.Dec))] + -- We silently ignore ones we don't recognise +rep_sigs = concatMapM rep_sig + +rep_sig :: LSig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_sig (L loc (TypeSig _ nms ty)) + = mapM (rep_wc_ty_sig sigDName loc ty) nms +rep_sig (L loc (PatSynSig _ nms ty)) + = mapM (rep_patsyn_ty_sig loc ty) nms +rep_sig (L loc (ClassOpSig _ is_deflt nms ty)) + | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms + | otherwise = mapM (rep_ty_sig sigDName loc ty) nms +rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) +rep_sig (L loc (FixSig _ fix_sig)) = rep_fix_d loc fix_sig +rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc +rep_sig (L loc (SpecSig _ nm tys ispec)) + = concatMapM (\t -> rep_specialise nm t ispec loc) tys +rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc +rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty +rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty +rep_sig (L loc (CompleteMatchSig _ _st cls mty)) + = rep_complete_sig cls mty loc +rep_sig (L _ (XSig nec)) = noExtCon nec + +rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name + -> MetaM (SrcSpan, Core (M TH.Dec)) +-- Don't create the implicit and explicit variables when desugaring signatures, +-- see Note [Scoped type variables in class and instance declarations]. +-- and Note [Don't quantify implicit type variables in quotes] +rep_ty_sig mk_sig loc sig_ty nm + | HsIB { hsib_body = hs_ty } <- sig_ty + , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis hs_ty + = do { nm1 <- lookupLOcc nm + ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) + ; repTyVarBndrWithKind tv name } + ; th_explicit_tvs <- repListM tyVarBndrTyConName rep_in_scope_tv + explicit_tvs + + -- NB: Don't pass any implicit type variables to repList above + -- See Note [Don't quantify implicit type variables in quotes] + + ; th_ctxt <- repLContext ctxt + ; th_ty <- repLTy ty + ; ty1 <- if null explicit_tvs && null (unLoc ctxt) + then return th_ty + else repTForall th_explicit_tvs th_ctxt th_ty + ; sig <- repProto mk_sig nm1 ty1 + ; return (loc, sig) } +rep_ty_sig _ _ (XHsImplicitBndrs nec) _ = noExtCon nec + +rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name + -> MetaM (SrcSpan, Core (M TH.Dec)) +-- represents a pattern synonym type signature; +-- see Note [Pattern synonym type signatures and Template Haskell] in Convert +-- +-- Don't create the implicit and explicit variables when desugaring signatures, +-- see Note [Scoped type variables in class and instance declarations] +-- and Note [Don't quantify implicit type variables in quotes] +rep_patsyn_ty_sig loc sig_ty nm + | HsIB { hsib_body = hs_ty } <- sig_ty + , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty + = do { nm1 <- lookupLOcc nm + ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) + ; repTyVarBndrWithKind tv name } + ; th_univs <- repListM tyVarBndrTyConName rep_in_scope_tv univs + ; th_exis <- repListM tyVarBndrTyConName rep_in_scope_tv exis + + -- NB: Don't pass any implicit type variables to repList above + -- See Note [Don't quantify implicit type variables in quotes] + + ; th_reqs <- repLContext reqs + ; th_provs <- repLContext provs + ; th_ty <- repLTy ty + ; ty1 <- repTForall th_univs th_reqs =<< + repTForall th_exis th_provs th_ty + ; sig <- repProto patSynSigDName nm1 ty1 + ; return (loc, sig) } +rep_patsyn_ty_sig _ (XHsImplicitBndrs nec) _ = noExtCon nec + +rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name + -> MetaM (SrcSpan, Core (M TH.Dec)) +rep_wc_ty_sig mk_sig loc sig_ty nm + = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm + +rep_inline :: Located Name + -> InlinePragma -- Never defaultInlinePragma + -> SrcSpan + -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_inline nm ispec loc + = do { nm1 <- lookupLOcc nm + ; inline <- repInline $ inl_inline ispec + ; rm <- repRuleMatch $ inl_rule ispec + ; phases <- repPhases $ inl_act ispec + ; pragma <- repPragInl nm1 inline rm phases + ; return [(loc, pragma)] + } + +rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma + -> SrcSpan + -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_specialise nm ty ispec loc + = do { nm1 <- lookupLOcc nm + ; ty1 <- repHsSigType ty + ; phases <- repPhases $ inl_act ispec + ; let inline = inl_inline ispec + ; pragma <- if noUserInlineSpec inline + then -- SPECIALISE + repPragSpec nm1 ty1 phases + else -- SPECIALISE INLINE + do { inline1 <- repInline inline + ; repPragSpecInl nm1 ty1 inline1 phases } + ; return [(loc, pragma)] + } + +rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan + -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_specialiseInst ty loc + = do { ty1 <- repHsSigType ty + ; pragma <- repPragSpecInst ty1 + ; return [(loc, pragma)] } + +repInline :: InlineSpec -> MetaM (Core TH.Inline) +repInline NoInline = dataCon noInlineDataConName +repInline Inline = dataCon inlineDataConName +repInline Inlinable = dataCon inlinableDataConName +repInline NoUserInline = notHandled "NOUSERINLINE" empty + +repRuleMatch :: RuleMatchInfo -> MetaM (Core TH.RuleMatch) +repRuleMatch ConLike = dataCon conLikeDataConName +repRuleMatch FunLike = dataCon funLikeDataConName + +repPhases :: Activation -> MetaM (Core TH.Phases) +repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i + ; dataCon' beforePhaseDataConName [arg] } +repPhases (ActiveAfter _ i) = do { MkC arg <- coreIntLit i + ; dataCon' fromPhaseDataConName [arg] } +repPhases _ = dataCon allPhasesDataConName + +rep_complete_sig :: Located [Located Name] + -> Maybe (Located Name) + -> SrcSpan + -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_complete_sig (L _ cls) mty loc + = do { mty' <- repMaybe nameTyConName lookupLOcc mty + ; cls' <- repList nameTyConName lookupLOcc cls + ; sig <- repPragComplete cls' mty' + ; return [(loc, sig)] } + +------------------------------------------------------- +-- Types +------------------------------------------------------- + +addSimpleTyVarBinds :: [Name] -- the binders to be added + -> MetaM (Core (M a)) -- action in the ext env + -> MetaM (Core (M a)) +addSimpleTyVarBinds names thing_inside + = do { fresh_names <- mkGenSyms names + ; term <- addBinds fresh_names thing_inside + ; wrapGenSyms fresh_names term } + +addHsTyVarBinds :: [LHsTyVarBndr GhcRn] -- the binders to be added + -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a))) -- action in the ext env + -> MetaM (Core (M a)) +addHsTyVarBinds exp_tvs thing_inside + = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs) + ; term <- addBinds fresh_exp_names $ + do { kbs <- repListM tyVarBndrTyConName mk_tv_bndr + (exp_tvs `zip` fresh_exp_names) + ; thing_inside kbs } + ; wrapGenSyms fresh_exp_names term } + where + mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) + +addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added + -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a))) -- action in the ext env + -> MetaM (Core (M a)) +-- gensym a list of type variables and enter them into the meta environment; +-- the computations passed as the second argument is executed in that extended +-- meta environment and gets the *new* names on Core-level as an argument +addTyVarBinds (HsQTvs { hsq_ext = imp_tvs + , hsq_explicit = exp_tvs }) + thing_inside + = addSimpleTyVarBinds imp_tvs $ + addHsTyVarBinds exp_tvs $ + thing_inside +addTyVarBinds (XLHsQTyVars nec) _ = noExtCon nec + +addTyClTyVarBinds :: LHsQTyVars GhcRn + -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a))) + -> MetaM (Core (M a)) + +-- Used for data/newtype declarations, and family instances, +-- so that the nested type variables work right +-- instance C (T a) where +-- type W (T a) = blah +-- The 'a' in the type instance is the one bound by the instance decl +addTyClTyVarBinds tvs m + = do { let tv_names = hsAllLTyVarNames tvs + ; env <- lift $ dsGetMetaEnv + ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names) + -- Make fresh names for the ones that are not already in scope + -- This makes things work for family declarations + + ; term <- addBinds freshNames $ + do { kbs <- repListM tyVarBndrTyConName mk_tv_bndr + (hsQTvExplicit tvs) + ; m kbs } + + ; wrapGenSyms freshNames term } + where + mk_tv_bndr :: LHsTyVarBndr GhcRn -> MetaM (Core (M TH.TyVarBndr)) + mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv) + ; repTyVarBndrWithKind tv v } + +-- Produce kinded binder constructors from the Haskell tyvar binders +-- +repTyVarBndrWithKind :: LHsTyVarBndr GhcRn + -> Core TH.Name -> MetaM (Core (M TH.TyVarBndr)) +repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm + = repPlainTV nm +repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm + = repLTy ki >>= repKindedTV nm +repTyVarBndrWithKind (L _ (XTyVarBndr nec)) _ = noExtCon nec + +-- | Represent a type variable binder +repTyVarBndr :: LHsTyVarBndr GhcRn -> MetaM (Core (M TH.TyVarBndr)) +repTyVarBndr (L _ (UserTyVar _ (L _ nm)) ) + = do { nm' <- lookupBinder nm + ; repPlainTV nm' } +repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki)) + = do { nm' <- lookupBinder nm + ; ki' <- repLTy ki + ; repKindedTV nm' ki' } +repTyVarBndr (L _ (XTyVarBndr nec)) = noExtCon nec + +-- represent a type context +-- +repLContext :: LHsContext GhcRn -> MetaM (Core (M TH.Cxt)) +repLContext ctxt = repContext (unLoc ctxt) + +repContext :: HsContext GhcRn -> MetaM (Core (M TH.Cxt)) +repContext ctxt = do preds <- repListM typeTyConName repLTy ctxt + repCtxt preds + +repHsSigType :: LHsSigType GhcRn -> MetaM (Core (M TH.Type)) +repHsSigType (HsIB { hsib_ext = implicit_tvs + , hsib_body = body }) + | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis body + = addSimpleTyVarBinds implicit_tvs $ + -- See Note [Don't quantify implicit type variables in quotes] + addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs -> + do { th_ctxt <- repLContext ctxt + ; th_ty <- repLTy ty + ; if null explicit_tvs && null (unLoc ctxt) + then return th_ty + else repTForall th_explicit_tvs th_ctxt th_ty } +repHsSigType (XHsImplicitBndrs nec) = noExtCon nec + +repHsSigWcType :: LHsSigWcType GhcRn -> MetaM (Core (M TH.Type)) +repHsSigWcType (HsWC { hswc_body = sig1 }) + = repHsSigType sig1 +repHsSigWcType (XHsWildCardBndrs nec) = noExtCon nec + +-- yield the representation of a list of types +repLTys :: [LHsType GhcRn] -> MetaM [Core (M TH.Type)] +repLTys tys = mapM repLTy tys + +-- represent a type +repLTy :: LHsType GhcRn -> MetaM (Core (M TH.Type)) +repLTy ty = repTy (unLoc ty) + +-- Desugar a type headed by an invisible forall (e.g., @forall a. a@) or +-- a context (e.g., @Show a => a@) into a ForallT from L.H.TH.Syntax. +-- In other words, the argument to this function is always an +-- @HsForAllTy ForallInvis@ or @HsQualTy@. +-- Types headed by visible foralls (which are desugared to ForallVisT) are +-- handled separately in repTy. +repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type)) +repForallT ty + | (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLoc ty) + = addHsTyVarBinds tvs $ \bndrs -> + do { ctxt1 <- repLContext ctxt + ; tau1 <- repLTy tau + ; repTForall bndrs ctxt1 tau1 -- forall a. C a => {...} + } + +repTy :: HsType GhcRn -> MetaM (Core (M TH.Type)) +repTy ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = body }) = + case fvf of + ForallInvis -> repForallT ty + ForallVis -> addHsTyVarBinds tvs $ \bndrs -> + do body1 <- repLTy body + repTForallVis bndrs body1 +repTy ty@(HsQualTy {}) = repForallT ty + +repTy (HsTyVar _ _ (L _ n)) + | isLiftedTypeKindTyConName n = repTStar + | n `hasKey` constraintKindTyConKey = repTConstraint + | n `hasKey` funTyConKey = repArrowTyCon + | isTvOcc occ = do tv1 <- lookupOcc n + repTvar tv1 + | isDataOcc occ = do tc1 <- lookupOcc n + repPromotedDataCon tc1 + | n == eqTyConName = repTequality + | otherwise = do tc1 <- lookupOcc n + repNamedTyCon tc1 + where + occ = nameOccName n + +repTy (HsAppTy _ f a) = do + f1 <- repLTy f + a1 <- repLTy a + repTapp f1 a1 +repTy (HsAppKindTy _ ty ki) = do + ty1 <- repLTy ty + ki1 <- repLTy ki + repTappKind ty1 ki1 +repTy (HsFunTy _ f a) = do + f1 <- repLTy f + a1 <- repLTy a + tcon <- repArrowTyCon + repTapps tcon [f1, a1] +repTy (HsListTy _ t) = do + t1 <- repLTy t + tcon <- repListTyCon + repTapp tcon t1 +repTy (HsTupleTy _ HsUnboxedTuple tys) = do + tys1 <- repLTys tys + tcon <- repUnboxedTupleTyCon (length tys) + repTapps tcon tys1 +repTy (HsTupleTy _ _ tys) = do tys1 <- repLTys tys + tcon <- repTupleTyCon (length tys) + repTapps tcon tys1 +repTy (HsSumTy _ tys) = do tys1 <- repLTys tys + tcon <- repUnboxedSumTyCon (length tys) + repTapps tcon tys1 +repTy (HsOpTy _ ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) + `nlHsAppTy` ty2) +repTy (HsParTy _ t) = repLTy t +repTy (HsStarTy _ _) = repTStar +repTy (HsKindSig _ t k) = do + t1 <- repLTy t + k1 <- repLTy k + repTSig t1 k1 +repTy (HsSpliceTy _ splice) = repSplice splice +repTy (HsExplicitListTy _ _ tys) = do + tys1 <- repLTys tys + repTPromotedList tys1 +repTy (HsExplicitTupleTy _ tys) = do + tys1 <- repLTys tys + tcon <- repPromotedTupleTyCon (length tys) + repTapps tcon tys1 +repTy (HsTyLit _ lit) = do + lit' <- repTyLit lit + repTLit lit' +repTy (HsWildCardTy _) = repTWildCard +repTy (HsIParamTy _ n t) = do + n' <- rep_implicit_param_name (unLoc n) + t' <- repLTy t + repTImplicitParam n' t' + +repTy ty = notHandled "Exotic form of type" (ppr ty) + +repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit)) +repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i + rep2 numTyLitName [iExpr] +repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s + ; rep2 strTyLitName [s'] + } + +-- | Represent a type wrapped in a Maybe +repMaybeLTy :: Maybe (LHsKind GhcRn) + -> MetaM (Core (Maybe (M TH.Type))) +repMaybeLTy m = do + k_ty <- wrapName kindTyConName + repMaybeT k_ty repLTy m + +repRole :: Located (Maybe Role) -> MetaM (Core TH.Role) +repRole (L _ (Just Nominal)) = rep2_nw nominalRName [] +repRole (L _ (Just Representational)) = rep2_nw representationalRName [] +repRole (L _ (Just Phantom)) = rep2_nw phantomRName [] +repRole (L _ Nothing) = rep2_nw inferRName [] + +----------------------------------------------------------------------------- +-- Splices +----------------------------------------------------------------------------- + +repSplice :: HsSplice GhcRn -> MetaM (Core a) +-- See Note [How brackets and nested splices are handled] in TcSplice +-- We return a CoreExpr of any old type; the context should know +repSplice (HsTypedSplice _ _ n _) = rep_splice n +repSplice (HsUntypedSplice _ _ n _) = rep_splice n +repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n +repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e) +repSplice e@(HsSplicedT {}) = pprPanic "repSpliceT" (ppr e) +repSplice (XSplice nec) = noExtCon nec + +rep_splice :: Name -> MetaM (Core a) +rep_splice splice_name + = do { mb_val <- lift $ dsLookupMetaEnv splice_name + ; case mb_val of + Just (DsSplice e) -> do { e' <- lift $ dsExpr e + ; return (MkC e') } + _ -> pprPanic "HsSplice" (ppr splice_name) } + -- Should not happen; statically checked + +----------------------------------------------------------------------------- +-- Expressions +----------------------------------------------------------------------------- + +repLEs :: [LHsExpr GhcRn] -> MetaM (Core [(M TH.Exp)]) +repLEs es = repListM expTyConName repLE es + +-- FIXME: some of these panics should be converted into proper error messages +-- unless we can make sure that constructs, which are plainly not +-- supported in TH already lead to error messages at an earlier stage +repLE :: LHsExpr GhcRn -> MetaM (Core (M TH.Exp)) +repLE (L loc e) = mapReaderT (putSrcSpanDs loc) (repE e) + +repE :: HsExpr GhcRn -> MetaM (Core (M TH.Exp)) +repE (HsVar _ (L _ x)) = + do { mb_val <- lift $ dsLookupMetaEnv x + ; case mb_val of + Nothing -> do { str <- lift $ globalVar x + ; repVarOrCon x str } + Just (DsBound y) -> repVarOrCon x (coreVar y) + Just (DsSplice e) -> do { e' <- lift $ dsExpr e + ; return (MkC e') } } +repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar +repE (HsOverLabel _ _ s) = repOverLabel s + +repE e@(HsRecFld _ f) = case f of + Unambiguous x _ -> repE (HsVar noExtField (noLoc x)) + Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e) + XAmbiguousFieldOcc nec -> noExtCon nec + + -- Remember, we're desugaring renamer output here, so + -- HsOverlit can definitely occur +repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a } +repE (HsLit _ l) = do { a <- repLiteral l; repLit a } +repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m +repE (HsLamCase _ (MG { mg_alts = (L _ ms) })) + = do { ms' <- mapM repMatchTup ms + ; core_ms <- coreListM matchTyConName ms' + ; repLamCase core_ms } +repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b} +repE (HsAppType _ e t) = do { a <- repLE e + ; s <- repLTy (hswc_body t) + ; repAppType a s } + +repE (OpApp _ e1 op e2) = + do { arg1 <- repLE e1; + arg2 <- repLE e2; + the_op <- repLE op ; + repInfixApp arg1 the_op arg2 } +repE (NegApp _ x _) = do + a <- repLE x + negateVar <- lookupOcc negateName >>= repVar + negateVar `repApp` a +repE (HsPar _ x) = repLE x +repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } +repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } +repE (HsCase _ e (MG { mg_alts = (L _ ms) })) + = do { arg <- repLE e + ; ms2 <- mapM repMatchTup ms + ; core_ms2 <- coreListM matchTyConName ms2 + ; repCaseE arg core_ms2 } +repE (HsIf _ _ x y z) = do + a <- repLE x + b <- repLE y + c <- repLE z + repCond a b c +repE (HsMultiIf _ alts) + = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts + ; expr' <- repMultiIf (nonEmptyCoreList alts') + ; wrapGenSyms (concat binds) expr' } +repE (HsLet _ (L _ bs) e) = do { (ss,ds) <- repBinds bs + ; e2 <- addBinds ss (repLE e) + ; z <- repLetE ds e2 + ; wrapGenSyms ss z } + +-- FIXME: I haven't got the types here right yet +repE e@(HsDo _ ctxt (L _ sts)) + | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False } + = do { (ss,zs) <- repLSts sts; + e' <- repDoE (nonEmptyCoreList zs); + wrapGenSyms ss e' } + + | ListComp <- ctxt + = do { (ss,zs) <- repLSts sts; + e' <- repComp (nonEmptyCoreList zs); + wrapGenSyms ss e' } + + | MDoExpr <- ctxt + = do { (ss,zs) <- repLSts sts; + e' <- repMDoE (nonEmptyCoreList zs); + wrapGenSyms ss e' } + + | otherwise + = notHandled "monad comprehension and [: :]" (ppr e) + +repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } +repE (ExplicitTuple _ es boxity) = + let tupArgToCoreExp :: LHsTupArg GhcRn -> MetaM (Core (Maybe (M TH.Exp))) + tupArgToCoreExp (L _ a) + | (Present _ e) <- a = do { e' <- repLE e + ; coreJustM expTyConName e' } + | otherwise = coreNothingM expTyConName + + in do { args <- mapM tupArgToCoreExp es + ; expTy <- wrapName expTyConName + ; let maybeExpQTy = mkTyConApp maybeTyCon [expTy] + listArg = coreList' maybeExpQTy args + ; if isBoxed boxity + then repTup listArg + else repUnboxedTup listArg } + +repE (ExplicitSum _ alt arity e) + = do { e1 <- repLE e + ; repUnboxedSum e1 alt arity } + +repE (RecordCon { rcon_con_name = c, rcon_flds = flds }) + = do { x <- lookupLOcc c; + fs <- repFields flds; + repRecCon x fs } +repE (RecordUpd { rupd_expr = e, rupd_flds = flds }) + = do { x <- repLE e; + fs <- repUpdFields flds; + repRecUpd x fs } + +repE (ExprWithTySig _ e ty) + = do { e1 <- repLE e + ; t1 <- repHsSigWcType ty + ; repSigExp e1 t1 } + +repE (ArithSeq _ _ aseq) = + case aseq of + From e -> do { ds1 <- repLE e; repFrom ds1 } + FromThen e1 e2 -> do + ds1 <- repLE e1 + ds2 <- repLE e2 + repFromThen ds1 ds2 + FromTo e1 e2 -> do + ds1 <- repLE e1 + ds2 <- repLE e2 + repFromTo ds1 ds2 + FromThenTo e1 e2 e3 -> do + ds1 <- repLE e1 + ds2 <- repLE e2 + ds3 <- repLE e3 + repFromThenTo ds1 ds2 ds3 + +repE (HsSpliceE _ splice) = repSplice splice +repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC +repE (HsUnboundVar _ uv) = do + occ <- occNameLit uv + sname <- repNameS occ + repUnboundVar sname + +repE e@(HsPragE _ HsPragCore {} _) = notHandled "Core annotations" (ppr e) +repE e@(HsPragE _ HsPragSCC {} _) = notHandled "Cost centres" (ppr e) +repE e@(HsPragE _ HsPragTick {} _) = notHandled "Tick Pragma" (ppr e) +repE (XExpr nec) = noExtCon nec +repE e = notHandled "Expression form" (ppr e) + +----------------------------------------------------------------------------- +-- Building representations of auxiliary structures like Match, Clause, Stmt, + +repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Match)) +repMatchTup (L _ (Match { m_pats = [p] + , m_grhss = GRHSs _ guards (L _ wheres) })) = + do { ss1 <- mkGenSyms (collectPatBinders p) + ; addBinds ss1 $ do { + ; p1 <- repLP p + ; (ss2,ds) <- repBinds wheres + ; addBinds ss2 $ do { + ; gs <- repGuards guards + ; match <- repMatch p1 gs ds + ; wrapGenSyms (ss1++ss2) match }}} +repMatchTup _ = panic "repMatchTup: case alt with more than one arg" + +repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Clause)) +repClauseTup (L _ (Match { m_pats = ps + , m_grhss = GRHSs _ guards (L _ wheres) })) = + do { ss1 <- mkGenSyms (collectPatsBinders ps) + ; addBinds ss1 $ do { + ps1 <- repLPs ps + ; (ss2,ds) <- repBinds wheres + ; addBinds ss2 $ do { + gs <- repGuards guards + ; clause <- repClause ps1 gs ds + ; wrapGenSyms (ss1++ss2) clause }}} +repClauseTup (L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec +repClauseTup (L _ (XMatch nec)) = noExtCon nec + +repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> MetaM (Core (M TH.Body)) +repGuards [L _ (GRHS _ [] e)] + = do {a <- repLE e; repNormal a } +repGuards other + = do { zs <- mapM repLGRHS other + ; let (xs, ys) = unzip zs + ; gd <- repGuarded (nonEmptyCoreList ys) + ; wrapGenSyms (concat xs) gd } + +repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn) + -> MetaM ([GenSymBind], (Core (M (TH.Guard, TH.Exp)))) +repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2)) + = do { guarded <- repLNormalGE e1 e2 + ; return ([], guarded) } +repLGRHS (L _ (GRHS _ ss rhs)) + = do { (gs, ss') <- repLSts ss + ; rhs' <- addBinds gs $ repLE rhs + ; guarded <- repPatGE (nonEmptyCoreList ss') rhs' + ; return (gs, guarded) } +repLGRHS (L _ (XGRHS nec)) = noExtCon nec + +repFields :: HsRecordBinds GhcRn -> MetaM (Core [M TH.FieldExp]) +repFields (HsRecFields { rec_flds = flds }) + = repListM fieldExpTyConName rep_fld flds + where + rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn) + -> MetaM (Core (M TH.FieldExp)) + rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld) + ; e <- repLE (hsRecFieldArg fld) + ; repFieldExp fn e } + +repUpdFields :: [LHsRecUpdField GhcRn] -> MetaM (Core [M TH.FieldExp]) +repUpdFields = repListM fieldExpTyConName rep_fld + where + rep_fld :: LHsRecUpdField GhcRn -> MetaM (Core (M TH.FieldExp)) + rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of + Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name) + ; e <- repLE (hsRecFieldArg fld) + ; repFieldExp fn e } + Ambiguous{} -> notHandled "Ambiguous record updates" (ppr fld) + XAmbiguousFieldOcc nec -> noExtCon nec + + + +----------------------------------------------------------------------------- +-- Representing Stmt's is tricky, especially if bound variables +-- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |] +-- First gensym new names for every variable in any of the patterns. +-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y")) +-- if variables didn't shadow, the static gensym wouldn't be necessary +-- and we could reuse the original names (x and x). +-- +-- do { x'1 <- gensym "x" +-- ; x'2 <- gensym "x" +-- ; doE [ BindSt (pvar x'1) [| f 1 |] +-- , BindSt (pvar x'2) [| f x |] +-- , NoBindSt [| g x |] +-- ] +-- } + +-- The strategy is to translate a whole list of do-bindings by building a +-- bigger environment, and a bigger set of meta bindings +-- (like: x'1 <- gensym "x" ) and then combining these with the translations +-- of the expressions within the Do + +----------------------------------------------------------------------------- +-- The helper function repSts computes the translation of each sub expression +-- and a bunch of prefix bindings denoting the dynamic renaming. + +repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)]) +repLSts stmts = repSts (map unLoc stmts) + +repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)]) +repSts (BindStmt _ p e _ _ : ss) = + do { e2 <- repLE e + ; ss1 <- mkGenSyms (collectPatBinders p) + ; addBinds ss1 $ do { + ; p1 <- repLP p; + ; (ss2,zs) <- repSts ss + ; z <- repBindSt p1 e2 + ; return (ss1++ss2, z : zs) }} +repSts (LetStmt _ (L _ bs) : ss) = + do { (ss1,ds) <- repBinds bs + ; z <- repLetSt ds + ; (ss2,zs) <- addBinds ss1 (repSts ss) + ; return (ss1++ss2, z : zs) } +repSts (BodyStmt _ e _ _ : ss) = + do { e2 <- repLE e + ; z <- repNoBindSt e2 + ; (ss2,zs) <- repSts ss + ; return (ss2, z : zs) } +repSts (ParStmt _ stmt_blocks _ _ : ss) = + do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks + ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1 + ss1 = concat ss_s + ; z <- repParSt stmt_blocks2 + ; (ss2, zs) <- addBinds ss1 (repSts ss) + ; return (ss1++ss2, z : zs) } + where + rep_stmt_block :: ParStmtBlock GhcRn GhcRn + -> MetaM ([GenSymBind], Core [(M TH.Stmt)]) + rep_stmt_block (ParStmtBlock _ stmts _ _) = + do { (ss1, zs) <- repSts (map unLoc stmts) + ; zs1 <- coreListM stmtTyConName zs + ; return (ss1, zs1) } + rep_stmt_block (XParStmtBlock nec) = noExtCon nec +repSts [LastStmt _ e _ _] + = do { e2 <- repLE e + ; z <- repNoBindSt e2 + ; return ([], [z]) } +repSts (stmt@RecStmt{} : ss) + = do { let binders = collectLStmtsBinders (recS_stmts stmt) + ; ss1 <- mkGenSyms binders + -- Bring all of binders in the recursive group into scope for the + -- whole group. + ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt)) + ; MASSERT(sort ss1 == sort ss1_other) + ; z <- repRecSt (nonEmptyCoreList rss) + ; (ss2,zs) <- addBinds ss1 (repSts ss) + ; return (ss1++ss2, z : zs) } +repSts (XStmtLR nec : _) = noExtCon nec +repSts [] = return ([],[]) +repSts other = notHandled "Exotic statement" (ppr other) + + +----------------------------------------------------------- +-- Bindings +----------------------------------------------------------- + +repBinds :: HsLocalBinds GhcRn -> MetaM ([GenSymBind], Core [(M TH.Dec)]) +repBinds (EmptyLocalBinds _) + = do { core_list <- coreListM decTyConName [] + ; return ([], core_list) } + +repBinds (HsIPBinds _ (IPBinds _ decs)) + = do { ips <- mapM rep_implicit_param_bind decs + ; core_list <- coreListM decTyConName + (de_loc (sort_by_loc ips)) + ; return ([], core_list) + } + +repBinds (HsIPBinds _ (XHsIPBinds nec)) = noExtCon nec + +repBinds (HsValBinds _ decs) + = do { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs } + -- No need to worry about detailed scopes within + -- the binding group, because we are talking Names + -- here, so we can safely treat it as a mutually + -- recursive group + -- For hsScopedTvBinders see Note [Scoped type variables in bindings] + ; ss <- mkGenSyms bndrs + ; prs <- addBinds ss (rep_val_binds decs) + ; core_list <- coreListM decTyConName + (de_loc (sort_by_loc prs)) + ; return (ss, core_list) } +repBinds (XHsLocalBindsLR nec) = noExtCon nec + +rep_implicit_param_bind :: LIPBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs))) + = do { name <- case ename of + Left (L _ n) -> rep_implicit_param_name n + Right _ -> + panic "rep_implicit_param_bind: post typechecking" + ; rhs' <- repE rhs + ; ipb <- repImplicitParamBind name rhs' + ; return (loc, ipb) } +rep_implicit_param_bind (L _ (XIPBind nec)) = noExtCon nec + +rep_implicit_param_name :: HsIPName -> MetaM (Core String) +rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name) + +rep_val_binds :: HsValBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] +-- Assumes: all the binders of the binding are already in the meta-env +rep_val_binds (XValBindsLR (NValBinds binds sigs)) + = do { core1 <- rep_binds (unionManyBags (map snd binds)) + ; core2 <- rep_sigs sigs + ; return (core1 ++ core2) } +rep_val_binds (ValBinds _ _ _) + = panic "rep_val_binds: ValBinds" + +rep_binds :: LHsBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_binds = mapM rep_bind . bagToList + +rep_bind :: LHsBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +-- Assumes: all the binders of the binding are already in the meta-env + +-- Note GHC treats declarations of a variable (not a pattern) +-- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match +-- with an empty list of patterns +rep_bind (L loc (FunBind + { fun_id = fn, + fun_matches = MG { mg_alts + = (L _ [L _ (Match + { m_pats = [] + , m_grhss = GRHSs _ guards (L _ wheres) } + )]) } })) + = do { (ss,wherecore) <- repBinds wheres + ; guardcore <- addBinds ss (repGuards guards) + ; fn' <- lookupLBinder fn + ; p <- repPvar fn' + ; ans <- repVal p guardcore wherecore + ; ans' <- wrapGenSyms ss ans + ; return (loc, ans') } + +rep_bind (L loc (FunBind { fun_id = fn + , fun_matches = MG { mg_alts = L _ ms } })) + = do { ms1 <- mapM repClauseTup ms + ; fn' <- lookupLBinder fn + ; ans <- repFun fn' (nonEmptyCoreList ms1) + ; return (loc, ans) } + +rep_bind (L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec + +rep_bind (L loc (PatBind { pat_lhs = pat + , pat_rhs = GRHSs _ guards (L _ wheres) })) + = do { patcore <- repLP pat + ; (ss,wherecore) <- repBinds wheres + ; guardcore <- addBinds ss (repGuards guards) + ; ans <- repVal patcore guardcore wherecore + ; ans' <- wrapGenSyms ss ans + ; return (loc, ans') } +rep_bind (L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec + +rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) + = do { v' <- lookupBinder v + ; e2 <- repLE e + ; x <- repNormal e2 + ; patcore <- repPvar v' + ; empty_decls <- coreListM decTyConName [] + ; ans <- repVal patcore x empty_decls + ; return (srcLocSpan (getSrcLoc v), ans) } + +rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" +rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn + , psb_args = args + , psb_def = pat + , psb_dir = dir }))) + = do { syn' <- lookupLBinder syn + ; dir' <- repPatSynDir dir + ; ss <- mkGenArgSyms args + ; patSynD' <- addBinds ss ( + do { args' <- repPatSynArgs args + ; pat' <- repLP pat + ; repPatSynD syn' args' dir' pat' }) + ; patSynD'' <- wrapGenArgSyms args ss patSynD' + ; return (loc, patSynD'') } + where + mkGenArgSyms :: HsPatSynDetails (Located Name) -> MetaM [GenSymBind] + -- for Record Pattern Synonyms we want to conflate the selector + -- and the pattern-only names in order to provide a nicer TH + -- API. Whereas inside GHC, record pattern synonym selectors and + -- their pattern-only bound right hand sides have different names, + -- we want to treat them the same in TH. This is the reason why we + -- need an adjusted mkGenArgSyms in the `RecCon` case below. + mkGenArgSyms (PrefixCon args) = mkGenSyms (map unLoc args) + mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2] + mkGenArgSyms (RecCon fields) + = do { let pats = map (unLoc . recordPatSynPatVar) fields + sels = map (unLoc . recordPatSynSelectorId) fields + ; ss <- mkGenSyms sels + ; return $ replaceNames (zip sels pats) ss } + + replaceNames selsPats genSyms + = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats + , sel == sel' ] + + wrapGenArgSyms :: HsPatSynDetails (Located Name) + -> [GenSymBind] -> Core (M TH.Dec) -> MetaM (Core (M TH.Dec)) + wrapGenArgSyms (RecCon _) _ dec = return dec + wrapGenArgSyms _ ss dec = wrapGenSyms ss dec + +rep_bind (L _ (PatSynBind _ (XPatSynBind nec))) = noExtCon nec +rep_bind (L _ (XHsBindsLR nec)) = noExtCon nec + +repPatSynD :: Core TH.Name + -> Core (M TH.PatSynArgs) + -> Core (M TH.PatSynDir) + -> Core (M TH.Pat) + -> MetaM (Core (M TH.Dec)) +repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat) + = rep2 patSynDName [syn, args, dir, pat] + +repPatSynArgs :: HsPatSynDetails (Located Name) -> MetaM (Core (M TH.PatSynArgs)) +repPatSynArgs (PrefixCon args) + = do { args' <- repList nameTyConName lookupLOcc args + ; repPrefixPatSynArgs args' } +repPatSynArgs (InfixCon arg1 arg2) + = do { arg1' <- lookupLOcc arg1 + ; arg2' <- lookupLOcc arg2 + ; repInfixPatSynArgs arg1' arg2' } +repPatSynArgs (RecCon fields) + = do { sels' <- repList nameTyConName lookupLOcc sels + ; repRecordPatSynArgs sels' } + where sels = map recordPatSynSelectorId fields + +repPrefixPatSynArgs :: Core [TH.Name] -> MetaM (Core (M TH.PatSynArgs)) +repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms] + +repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> MetaM (Core (M TH.PatSynArgs)) +repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2] + +repRecordPatSynArgs :: Core [TH.Name] + -> MetaM (Core (M TH.PatSynArgs)) +repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels] + +repPatSynDir :: HsPatSynDir GhcRn -> MetaM (Core (M TH.PatSynDir)) +repPatSynDir Unidirectional = rep2 unidirPatSynName [] +repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName [] +repPatSynDir (ExplicitBidirectional (MG { mg_alts = (L _ clauses) })) + = do { clauses' <- mapM repClauseTup clauses + ; repExplBidirPatSynDir (nonEmptyCoreList clauses') } +repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec + +repExplBidirPatSynDir :: Core [(M TH.Clause)] -> MetaM (Core (M TH.PatSynDir)) +repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls] + + +----------------------------------------------------------------------------- +-- Since everything in a Bind is mutually recursive we need rename all +-- all the variables simultaneously. For example: +-- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to +-- do { f'1 <- gensym "f" +-- ; g'2 <- gensym "g" +-- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]}, +-- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]} +-- ]} +-- This requires collecting the bindings (f'1 <- gensym "f"), and the +-- environment ( f |-> f'1 ) from each binding, and then unioning them +-- together. As we do this we collect GenSymBinds's which represent the renamed +-- variables bound by the Bindings. In order not to lose track of these +-- representations we build a shadow datatype MB with the same structure as +-- MonoBinds, but which has slots for the representations + + +----------------------------------------------------------------------------- +-- GHC allows a more general form of lambda abstraction than specified +-- by Haskell 98. In particular it allows guarded lambda's like : +-- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in +-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like +-- (\ p1 .. pn -> exp) by causing an error. + +repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Exp)) +repLambda (L _ (Match { m_pats = ps + , m_grhss = GRHSs _ [L _ (GRHS _ [] e)] + (L _ (EmptyLocalBinds _)) } )) + = do { let bndrs = collectPatsBinders ps ; + ; ss <- mkGenSyms bndrs + ; lam <- addBinds ss ( + do { xs <- repLPs ps; body <- repLE e; repLam xs body }) + ; wrapGenSyms ss lam } +repLambda (L _ (Match { m_grhss = GRHSs _ [L _ (GRHS _ [] _)] + (L _ (XHsLocalBindsLR nec)) } )) + = noExtCon nec + +repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m) + + +----------------------------------------------------------------------------- +-- Patterns +-- repP deals with patterns. It assumes that we have already +-- walked over the pattern(s) once to collect the binders, and +-- have extended the environment. So every pattern-bound +-- variable should already appear in the environment. + +-- Process a list of patterns +repLPs :: [LPat GhcRn] -> MetaM (Core [(M TH.Pat)]) +repLPs ps = repListM patTyConName repLP ps + +repLP :: LPat GhcRn -> MetaM (Core (M TH.Pat)) +repLP p = repP (unLoc p) + +repP :: Pat GhcRn -> MetaM (Core (M TH.Pat)) +repP (WildPat _) = repPwild +repP (LitPat _ l) = do { l2 <- repLiteral l; repPlit l2 } +repP (VarPat _ x) = do { x' <- lookupBinder (unLoc x); repPvar x' } +repP (LazyPat _ p) = do { p1 <- repLP p; repPtilde p1 } +repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 } +repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p + ; repPaspat x' p1 } +repP (ParPat _ p) = repLP p +repP (ListPat Nothing ps) = do { qs <- repLPs ps; repPlist qs } +repP (ListPat (Just (SyntaxExprRn e)) ps) = do { p <- repP (ListPat Nothing ps) + ; e' <- repE e + ; repPview e' p} +repP (ListPat _ ps) = pprPanic "repP missing SyntaxExprRn" (ppr ps) +repP (TuplePat _ ps boxed) + | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } + | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } +repP (SumPat _ p alt arity) = do { p1 <- repLP p + ; repPunboxedSum p1 alt arity } +repP (ConPatIn dc details) + = do { con_str <- lookupLOcc dc + ; case details of + PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs } + RecCon rec -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec) + ; repPrec con_str fps } + InfixCon p1 p2 -> do { p1' <- repLP p1; + p2' <- repLP p2; + repPinfix p1' con_str p2' } + } + where + rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> MetaM (Core (M (TH.Name, TH.Pat))) + rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld) + ; MkC p <- repLP (hsRecFieldArg fld) + ; rep2 fieldPatName [v,p] } + +repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l + ; repPlit a } +repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } +repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) +repP (SigPat _ p t) = do { p' <- repLP p + ; t' <- repLTy (hsSigWcType t) + ; repPsig p' t' } +repP (SplicePat _ splice) = repSplice splice +repP (XPat nec) = noExtCon nec +repP other = notHandled "Exotic pattern" (ppr other) + +---------------------------------------------------------- +-- Declaration ordering helpers + +sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)] +sort_by_loc xs = sortBy comp xs + where comp x y = compare (fst x) (fst y) + +de_loc :: [(a, b)] -> [b] +de_loc = map snd + +---------------------------------------------------------- +-- The meta-environment + +-- A name/identifier association for fresh names of locally bound entities +type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id + -- I.e. (x, x_id) means + -- let x_id = gensym "x" in ... + +-- Generate a fresh name for a locally bound entity + +mkGenSyms :: [Name] -> MetaM [GenSymBind] +-- We can use the existing name. For example: +-- [| \x_77 -> x_77 + x_77 |] +-- desugars to +-- do { x_77 <- genSym "x"; .... } +-- We use the same x_77 in the desugared program, but with the type Bndr +-- instead of Int +-- +-- We do make it an Internal name, though (hence localiseName) +-- +-- Nevertheless, it's monadic because we have to generate nameTy +mkGenSyms ns = do { var_ty <- lookupType nameTyConName + ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] } + + +addBinds :: [GenSymBind] -> MetaM a -> MetaM a +-- Add a list of fresh names for locally bound entities to the +-- meta environment (which is part of the state carried around +-- by the desugarer monad) +addBinds bs m = mapReaderT (dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs])) m + +-- Look up a locally bound name +-- +lookupLBinder :: Located Name -> MetaM (Core TH.Name) +lookupLBinder n = lookupBinder (unLoc n) + +lookupBinder :: Name -> MetaM (Core TH.Name) +lookupBinder = lookupOcc + -- Binders are brought into scope before the pattern or what-not is + -- desugared. Moreover, in instance declaration the binder of a method + -- will be the selector Id and hence a global; so we need the + -- globalVar case of lookupOcc + +-- Look up a name that is either locally bound or a global name +-- +-- * If it is a global name, generate the "original name" representation (ie, +-- the : form) for the associated entity +-- +lookupLOcc :: Located Name -> MetaM (Core TH.Name) +-- Lookup an occurrence; it can't be a splice. +-- Use the in-scope bindings if they exist +lookupLOcc n = lookupOcc (unLoc n) + +lookupOcc :: Name -> MetaM (Core TH.Name) +lookupOcc = lift . lookupOccDsM + +lookupOccDsM :: Name -> DsM (Core TH.Name) +lookupOccDsM n + = do { mb_val <- dsLookupMetaEnv n ; + case mb_val of + Nothing -> globalVar n + Just (DsBound x) -> return (coreVar x) + Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n) + } + +globalVar :: Name -> DsM (Core TH.Name) +-- Not bound by the meta-env +-- Could be top-level; or could be local +-- f x = $(g [| x |]) +-- Here the x will be local +globalVar name + | isExternalName name + = do { MkC mod <- coreStringLit name_mod + ; MkC pkg <- coreStringLit name_pkg + ; MkC occ <- nameLit name + ; rep2_nwDsM mk_varg [pkg,mod,occ] } + | otherwise + = do { MkC occ <- nameLit name + ; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name)) + ; rep2_nwDsM mkNameLName [occ,uni] } + where + mod = ASSERT( isExternalName name) nameModule name + name_mod = moduleNameString (moduleName mod) + name_pkg = unitIdString (moduleUnitId mod) + name_occ = nameOccName name + mk_varg | OccName.isDataOcc name_occ = mkNameG_dName + | OccName.isVarOcc name_occ = mkNameG_vName + | OccName.isTcOcc name_occ = mkNameG_tcName + | otherwise = pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name) + +lookupType :: Name -- Name of type constructor (e.g. (M TH.Exp)) + -> MetaM Type -- The type +lookupType tc_name = do { tc <- lift $ dsLookupTyCon tc_name ; + return (mkTyConApp tc []) } + +wrapGenSyms :: [GenSymBind] + -> Core (M a) -> MetaM (Core (M a)) +-- wrapGenSyms [(nm1,id1), (nm2,id2)] y +-- --> bindQ (gensym nm1) (\ id1 -> +-- bindQ (gensym nm2 (\ id2 -> +-- y)) + +wrapGenSyms binds body@(MkC b) + = do { var_ty <- lookupType nameTyConName + ; go var_ty binds } + where + (_, [elt_ty]) = tcSplitAppTys (exprType b) + -- b :: m a, so we can get the type 'a' by looking at the + -- argument type. NB: this relies on Q being a data/newtype, + -- not a type synonym + + go _ [] = return body + go var_ty ((name,id) : binds) + = do { MkC body' <- go var_ty binds + ; lit_str <- lift $ nameLit name + ; gensym_app <- repGensym lit_str + ; repBindM var_ty elt_ty + gensym_app (MkC (Lam id body')) } + +nameLit :: Name -> DsM (Core String) +nameLit n = coreStringLit (occNameString (nameOccName n)) + +occNameLit :: OccName -> MetaM (Core String) +occNameLit name = coreStringLit (occNameString name) + + +-- %********************************************************************* +-- %* * +-- Constructing code +-- %* * +-- %********************************************************************* + +----------------------------------------------------------------------------- +-- PHANTOM TYPES for consistency. In order to make sure we do this correct +-- we invent a new datatype which uses phantom types. + +newtype Core a = MkC CoreExpr +unC :: Core a -> CoreExpr +unC (MkC x) = x + +type family NotM a where + NotM (M _) = TypeError ('Text ("rep2_nw must not produce something of overloaded type")) + NotM _other = (() :: Constraint) + +rep2M :: Name -> [CoreExpr] -> MetaM (Core (M a)) +rep2 :: Name -> [CoreExpr] -> MetaM (Core (M a)) +rep2_nw :: NotM a => Name -> [CoreExpr] -> MetaM (Core a) +rep2_nwDsM :: NotM a => Name -> [CoreExpr] -> DsM (Core a) +rep2 = rep2X lift (asks quoteWrapper) +rep2M = rep2X lift (asks monadWrapper) +rep2_nw n xs = lift (rep2_nwDsM n xs) +rep2_nwDsM = rep2X id (return id) + +rep2X :: Monad m => (forall z . DsM z -> m z) + -> m (CoreExpr -> CoreExpr) + -> Name + -> [ CoreExpr ] + -> m (Core a) +rep2X lift_dsm get_wrap n xs = do + { rep_id <- lift_dsm $ dsLookupGlobalId n + ; wrap <- get_wrap + ; return (MkC $ (foldl' App (wrap (Var rep_id)) xs)) } + + +dataCon' :: Name -> [CoreExpr] -> MetaM (Core a) +dataCon' n args = do { id <- lift $ dsLookupDataCon n + ; return $ MkC $ mkCoreConApps id args } + +dataCon :: Name -> MetaM (Core a) +dataCon n = dataCon' n [] + + +-- %********************************************************************* +-- %* * +-- The 'smart constructors' +-- %* * +-- %********************************************************************* + +--------------- Patterns ----------------- +repPlit :: Core TH.Lit -> MetaM (Core (M TH.Pat)) +repPlit (MkC l) = rep2 litPName [l] + +repPvar :: Core TH.Name -> MetaM (Core (M TH.Pat)) +repPvar (MkC s) = rep2 varPName [s] + +repPtup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) +repPtup (MkC ps) = rep2 tupPName [ps] + +repPunboxedTup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) +repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps] + +repPunboxedSum :: Core (M TH.Pat) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Pat)) +-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here +repPunboxedSum (MkC p) alt arity + = do { dflags <- getDynFlags + ; rep2 unboxedSumPName [ p + , mkIntExprInt dflags alt + , mkIntExprInt dflags arity ] } + +repPcon :: Core TH.Name -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) +repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps] + +repPrec :: Core TH.Name -> Core [M (TH.Name, TH.Pat)] -> MetaM (Core (M TH.Pat)) +repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps] + +repPinfix :: Core (M TH.Pat) -> Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) +repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2] + +repPtilde :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) +repPtilde (MkC p) = rep2 tildePName [p] + +repPbang :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) +repPbang (MkC p) = rep2 bangPName [p] + +repPaspat :: Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) +repPaspat (MkC s) (MkC p) = rep2 asPName [s, p] + +repPwild :: MetaM (Core (M TH.Pat)) +repPwild = rep2 wildPName [] + +repPlist :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) +repPlist (MkC ps) = rep2 listPName [ps] + +repPview :: Core (M TH.Exp) -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) +repPview (MkC e) (MkC p) = rep2 viewPName [e,p] + +repPsig :: Core (M TH.Pat) -> Core (M TH.Type) -> MetaM (Core (M TH.Pat)) +repPsig (MkC p) (MkC t) = rep2 sigPName [p, t] + +--------------- Expressions ----------------- +repVarOrCon :: Name -> Core TH.Name -> MetaM (Core (M TH.Exp)) +repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str + | otherwise = repVar str + +repVar :: Core TH.Name -> MetaM (Core (M TH.Exp)) +repVar (MkC s) = rep2 varEName [s] + +repCon :: Core TH.Name -> MetaM (Core (M TH.Exp)) +repCon (MkC s) = rep2 conEName [s] + +repLit :: Core TH.Lit -> MetaM (Core (M TH.Exp)) +repLit (MkC c) = rep2 litEName [c] + +repApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repApp (MkC x) (MkC y) = rep2 appEName [x,y] + +repAppType :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp)) +repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y] + +repLam :: Core [(M TH.Pat)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e] + +repLamCase :: Core [(M TH.Match)] -> MetaM (Core (M TH.Exp)) +repLamCase (MkC ms) = rep2 lamCaseEName [ms] + +repTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp)) +repTup (MkC es) = rep2 tupEName [es] + +repUnboxedTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp)) +repUnboxedTup (MkC es) = rep2 unboxedTupEName [es] + +repUnboxedSum :: Core (M TH.Exp) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Exp)) +-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here +repUnboxedSum (MkC e) alt arity + = do { dflags <- getDynFlags + ; rep2 unboxedSumEName [ e + , mkIntExprInt dflags alt + , mkIntExprInt dflags arity ] } + +repCond :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] + +repMultiIf :: Core [M (TH.Guard, TH.Exp)] -> MetaM (Core (M TH.Exp)) +repMultiIf (MkC alts) = rep2 multiIfEName [alts] + +repLetE :: Core [(M TH.Dec)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] + +repCaseE :: Core (M TH.Exp) -> Core [(M TH.Match)] -> MetaM (Core (M TH.Exp)) +repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms] + +repDoE :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp)) +repDoE (MkC ss) = rep2 doEName [ss] + +repMDoE :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp)) +repMDoE (MkC ss) = rep2 mdoEName [ss] + +repComp :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp)) +repComp (MkC ss) = rep2 compEName [ss] + +repListExp :: Core [(M TH.Exp)] -> MetaM (Core (M TH.Exp)) +repListExp (MkC es) = rep2 listEName [es] + +repSigExp :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp)) +repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t] + +repRecCon :: Core TH.Name -> Core [M TH.FieldExp]-> MetaM (Core (M TH.Exp)) +repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs] + +repRecUpd :: Core (M TH.Exp) -> Core [M TH.FieldExp] -> MetaM (Core (M TH.Exp)) +repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs] + +repFieldExp :: Core TH.Name -> Core (M TH.Exp) -> MetaM (Core (M TH.FieldExp)) +repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x] + +repInfixApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z] + +repSectionL :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y] + +repSectionR :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y] + +repImplicitParamVar :: Core String -> MetaM (Core (M TH.Exp)) +repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x] + +------------ Right hand sides (guarded expressions) ---- +repGuarded :: Core [M (TH.Guard, TH.Exp)] -> MetaM (Core (M TH.Body)) +repGuarded (MkC pairs) = rep2 guardedBName [pairs] + +repNormal :: Core (M TH.Exp) -> MetaM (Core (M TH.Body)) +repNormal (MkC e) = rep2 normalBName [e] + +------------ Guards ---- +repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn + -> MetaM (Core (M (TH.Guard, TH.Exp))) +repLNormalGE g e = do g' <- repLE g + e' <- repLE e + repNormalGE g' e' + +repNormalGE :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M (TH.Guard, TH.Exp))) +repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e] + +repPatGE :: Core [(M TH.Stmt)] -> Core (M TH.Exp) -> MetaM (Core (M (TH.Guard, TH.Exp))) +repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e] + +------------- Stmts ------------------- +repBindSt :: Core (M TH.Pat) -> Core (M TH.Exp) -> MetaM (Core (M TH.Stmt)) +repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e] + +repLetSt :: Core [(M TH.Dec)] -> MetaM (Core (M TH.Stmt)) +repLetSt (MkC ds) = rep2 letSName [ds] + +repNoBindSt :: Core (M TH.Exp) -> MetaM (Core (M TH.Stmt)) +repNoBindSt (MkC e) = rep2 noBindSName [e] + +repParSt :: Core [[(M TH.Stmt)]] -> MetaM (Core (M TH.Stmt)) +repParSt (MkC sss) = rep2 parSName [sss] + +repRecSt :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Stmt)) +repRecSt (MkC ss) = rep2 recSName [ss] + +-------------- Range (Arithmetic sequences) ----------- +repFrom :: Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repFrom (MkC x) = rep2 fromEName [x] + +repFromThen :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y] + +repFromTo :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y] + +repFromThenTo :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z] + +------------ Match and Clause Tuples ----------- +repMatch :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Match)) +repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds] + +repClause :: Core [(M TH.Pat)] -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Clause)) +repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds] + +-------------- Dec ----------------------------- +repVal :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec)) +repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds] + +repFun :: Core TH.Name -> Core [(M TH.Clause)] -> MetaM (Core (M TH.Dec)) +repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] + +repData :: Core (M TH.Cxt) -> Core TH.Name + -> Either (Core [(M TH.TyVarBndr)]) + (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type)) + -> Core (Maybe (M TH.Kind)) -> Core [(M TH.Con)] -> Core [M TH.DerivClause] + -> MetaM (Core (M TH.Dec)) +repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs) + = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs] +repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons) + (MkC derivs) + = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs] + +repNewtype :: Core (M TH.Cxt) -> Core TH.Name + -> Either (Core [(M TH.TyVarBndr)]) + (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type)) + -> Core (Maybe (M TH.Kind)) -> Core (M TH.Con) -> Core [M TH.DerivClause] + -> MetaM (Core (M TH.Dec)) +repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con) + (MkC derivs) + = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs] +repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con) + (MkC derivs) + = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs] + +repTySyn :: Core TH.Name -> Core [(M TH.TyVarBndr)] + -> Core (M TH.Type) -> MetaM (Core (M TH.Dec)) +repTySyn (MkC nm) (MkC tvs) (MkC rhs) + = rep2 tySynDName [nm, tvs, rhs] + +repInst :: Core (Maybe TH.Overlap) -> + Core (M TH.Cxt) -> Core (M TH.Type) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec)) +repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName + [o, cxt, ty, ds] + +repDerivStrategy :: Maybe (LDerivStrategy GhcRn) + -> MetaM (Core (Maybe (M TH.DerivStrategy))) +repDerivStrategy mds = + case mds of + Nothing -> nothing + Just ds -> + case unLoc ds of + StockStrategy -> just =<< repStockStrategy + AnyclassStrategy -> just =<< repAnyclassStrategy + NewtypeStrategy -> just =<< repNewtypeStrategy + ViaStrategy ty -> do ty' <- repLTy (hsSigType ty) + via_strat <- repViaStrategy ty' + just via_strat + where + nothing = coreNothingM derivStrategyTyConName + just = coreJustM derivStrategyTyConName + +repStockStrategy :: MetaM (Core (M TH.DerivStrategy)) +repStockStrategy = rep2 stockStrategyName [] + +repAnyclassStrategy :: MetaM (Core (M TH.DerivStrategy)) +repAnyclassStrategy = rep2 anyclassStrategyName [] + +repNewtypeStrategy :: MetaM (Core (M TH.DerivStrategy)) +repNewtypeStrategy = rep2 newtypeStrategyName [] + +repViaStrategy :: Core (M TH.Type) -> MetaM (Core (M TH.DerivStrategy)) +repViaStrategy (MkC t) = rep2 viaStrategyName [t] + +repOverlap :: Maybe OverlapMode -> MetaM (Core (Maybe TH.Overlap)) +repOverlap mb = + case mb of + Nothing -> nothing + Just o -> + case o of + NoOverlap _ -> nothing + Overlappable _ -> just =<< dataCon overlappableDataConName + Overlapping _ -> just =<< dataCon overlappingDataConName + Overlaps _ -> just =<< dataCon overlapsDataConName + Incoherent _ -> just =<< dataCon incoherentDataConName + where + nothing = coreNothing overlapTyConName + just = coreJust overlapTyConName + + +repClass :: Core (M TH.Cxt) -> Core TH.Name -> Core [(M TH.TyVarBndr)] + -> Core [TH.FunDep] -> Core [(M TH.Dec)] + -> MetaM (Core (M TH.Dec)) +repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) + = rep2 classDName [cxt, cls, tvs, fds, ds] + +repDeriv :: Core (Maybe (M TH.DerivStrategy)) + -> Core (M TH.Cxt) -> Core (M TH.Type) + -> MetaM (Core (M TH.Dec)) +repDeriv (MkC ds) (MkC cxt) (MkC ty) + = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty] + +repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch + -> Core TH.Phases -> MetaM (Core (M TH.Dec)) +repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases) + = rep2 pragInlDName [nm, inline, rm, phases] + +repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Core TH.Phases + -> MetaM (Core (M TH.Dec)) +repPragSpec (MkC nm) (MkC ty) (MkC phases) + = rep2 pragSpecDName [nm, ty, phases] + +repPragSpecInl :: Core TH.Name -> Core (M TH.Type) -> Core TH.Inline + -> Core TH.Phases -> MetaM (Core (M TH.Dec)) +repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases) + = rep2 pragSpecInlDName [nm, ty, inline, phases] + +repPragSpecInst :: Core (M TH.Type) -> MetaM (Core (M TH.Dec)) +repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty] + +repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> MetaM (Core (M TH.Dec)) +repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty] + +repPragRule :: Core String -> Core (Maybe [(M TH.TyVarBndr)]) + -> Core [(M TH.RuleBndr)] -> Core (M TH.Exp) -> Core (M TH.Exp) + -> Core TH.Phases -> MetaM (Core (M TH.Dec)) +repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases) + = rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases] + +repPragAnn :: Core TH.AnnTarget -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec)) +repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e] + +repTySynInst :: Core (M TH.TySynEqn) -> MetaM (Core (M TH.Dec)) +repTySynInst (MkC eqn) + = rep2 tySynInstDName [eqn] + +repDataFamilyD :: Core TH.Name -> Core [(M TH.TyVarBndr)] + -> Core (Maybe (M TH.Kind)) -> MetaM (Core (M TH.Dec)) +repDataFamilyD (MkC nm) (MkC tvs) (MkC kind) + = rep2 dataFamilyDName [nm, tvs, kind] + +repOpenFamilyD :: Core TH.Name + -> Core [(M TH.TyVarBndr)] + -> Core (M TH.FamilyResultSig) + -> Core (Maybe TH.InjectivityAnn) + -> MetaM (Core (M TH.Dec)) +repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj) + = rep2 openTypeFamilyDName [nm, tvs, result, inj] + +repClosedFamilyD :: Core TH.Name + -> Core [(M TH.TyVarBndr)] + -> Core (M TH.FamilyResultSig) + -> Core (Maybe TH.InjectivityAnn) + -> Core [(M TH.TySynEqn)] + -> MetaM (Core (M TH.Dec)) +repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns) + = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns] + +repTySynEqn :: Core (Maybe [(M TH.TyVarBndr)]) -> + Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.TySynEqn)) +repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs) + = rep2 tySynEqnName [mb_bndrs, lhs, rhs] + +repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> MetaM (Core (M TH.Dec)) +repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles] + +repFunDep :: Core [TH.Name] -> Core [TH.Name] -> MetaM (Core TH.FunDep) +repFunDep (MkC xs) (MkC ys) = rep2_nw funDepName [xs, ys] + +repProto :: Name -> Core TH.Name -> Core (M TH.Type) -> MetaM (Core (M TH.Dec)) +repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty] + +repImplicitParamBind :: Core String -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec)) +repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e] + +repCtxt :: Core [(M TH.Pred)] -> MetaM (Core (M TH.Cxt)) +repCtxt (MkC tys) = rep2 cxtName [tys] + +repDataCon :: Located Name + -> HsConDeclDetails GhcRn + -> MetaM (Core (M TH.Con)) +repDataCon con details + = do con' <- lookupLOcc con -- See Note [Binders and occurrences] + repConstr details Nothing [con'] + +repGadtDataCons :: [Located Name] + -> HsConDeclDetails GhcRn + -> LHsType GhcRn + -> MetaM (Core (M TH.Con)) +repGadtDataCons cons details res_ty + = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences] + repConstr details (Just res_ty) cons' + +-- Invariant: +-- * for plain H98 data constructors second argument is Nothing and third +-- argument is a singleton list +-- * for GADTs data constructors second argument is (Just return_type) and +-- third argument is a non-empty list +repConstr :: HsConDeclDetails GhcRn + -> Maybe (LHsType GhcRn) + -> [Core TH.Name] + -> MetaM (Core (M TH.Con)) +repConstr (PrefixCon ps) Nothing [con] + = do arg_tys <- repListM bangTypeTyConName repBangTy ps + rep2 normalCName [unC con, unC arg_tys] + +repConstr (PrefixCon ps) (Just res_ty) cons + = do arg_tys <- repListM bangTypeTyConName repBangTy ps + res_ty' <- repLTy res_ty + rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty'] + +repConstr (RecCon ips) resTy cons + = do args <- concatMapM rep_ip (unLoc ips) + arg_vtys <- coreListM varBangTypeTyConName args + case resTy of + Nothing -> rep2 recCName [unC (head cons), unC arg_vtys] + Just res_ty -> do + res_ty' <- repLTy res_ty + rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys, + unC res_ty'] + + where + rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) + + rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType)) + rep_one_ip t n = do { MkC v <- lookupOcc (extFieldOcc $ unLoc n) + ; MkC ty <- repBangTy t + ; rep2 varBangTypeName [v,ty] } + +repConstr (InfixCon st1 st2) Nothing [con] + = do arg1 <- repBangTy st1 + arg2 <- repBangTy st2 + rep2 infixCName [unC arg1, unC con, unC arg2] + +repConstr (InfixCon {}) (Just _) _ = + panic "repConstr: infix GADT constructor should be in a PrefixCon" +repConstr _ _ _ = + panic "repConstr: invariant violated" + +------------ Types ------------------- + +repTForall :: Core [(M TH.TyVarBndr)] -> Core (M TH.Cxt) -> Core (M TH.Type) + -> MetaM (Core (M TH.Type)) +repTForall (MkC tvars) (MkC ctxt) (MkC ty) + = rep2 forallTName [tvars, ctxt, ty] + +repTForallVis :: Core [(M TH.TyVarBndr)] -> Core (M TH.Type) + -> MetaM (Core (M TH.Type)) +repTForallVis (MkC tvars) (MkC ty) = rep2 forallVisTName [tvars, ty] + +repTvar :: Core TH.Name -> MetaM (Core (M TH.Type)) +repTvar (MkC s) = rep2 varTName [s] + +repTapp :: Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.Type)) +repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2] + +repTappKind :: Core (M TH.Type) -> Core (M TH.Kind) -> MetaM (Core (M TH.Type)) +repTappKind (MkC ty) (MkC ki) = rep2 appKindTName [ty,ki] + +repTapps :: Core (M TH.Type) -> [Core (M TH.Type)] -> MetaM (Core (M TH.Type)) +repTapps f [] = return f +repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts } + +repTSig :: Core (M TH.Type) -> Core (M TH.Kind) -> MetaM (Core (M TH.Type)) +repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki] + +repTequality :: MetaM (Core (M TH.Type)) +repTequality = rep2 equalityTName [] + +repTPromotedList :: [Core (M TH.Type)] -> MetaM (Core (M TH.Type)) +repTPromotedList [] = repPromotedNilTyCon +repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon + ; f <- repTapp tcon t + ; t' <- repTPromotedList ts + ; repTapp f t' + } + +repTLit :: Core (M TH.TyLit) -> MetaM (Core (M TH.Type)) +repTLit (MkC lit) = rep2 litTName [lit] + +repTWildCard :: MetaM (Core (M TH.Type)) +repTWildCard = rep2 wildCardTName [] + +repTImplicitParam :: Core String -> Core (M TH.Type) -> MetaM (Core (M TH.Type)) +repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e] + +repTStar :: MetaM (Core (M TH.Type)) +repTStar = rep2 starKName [] + +repTConstraint :: MetaM (Core (M TH.Type)) +repTConstraint = rep2 constraintKName [] + +--------- Type constructors -------------- + +repNamedTyCon :: Core TH.Name -> MetaM (Core (M TH.Type)) +repNamedTyCon (MkC s) = rep2 conTName [s] + +repTInfix :: Core (M TH.Type) -> Core TH.Name -> Core (M TH.Type) + -> MetaM (Core (M TH.Type)) +repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2] + +repTupleTyCon :: Int -> MetaM (Core (M TH.Type)) +-- Note: not Core Int; it's easier to be direct here +repTupleTyCon i = do dflags <- getDynFlags + rep2 tupleTName [mkIntExprInt dflags i] + +repUnboxedTupleTyCon :: Int -> MetaM (Core (M TH.Type)) +-- Note: not Core Int; it's easier to be direct here +repUnboxedTupleTyCon i = do dflags <- getDynFlags + rep2 unboxedTupleTName [mkIntExprInt dflags i] + +repUnboxedSumTyCon :: TH.SumArity -> MetaM (Core (M TH.Type)) +-- Note: not Core TH.SumArity; it's easier to be direct here +repUnboxedSumTyCon arity = do dflags <- getDynFlags + rep2 unboxedSumTName [mkIntExprInt dflags arity] + +repArrowTyCon :: MetaM (Core (M TH.Type)) +repArrowTyCon = rep2 arrowTName [] + +repListTyCon :: MetaM (Core (M TH.Type)) +repListTyCon = rep2 listTName [] + +repPromotedDataCon :: Core TH.Name -> MetaM (Core (M TH.Type)) +repPromotedDataCon (MkC s) = rep2 promotedTName [s] + +repPromotedTupleTyCon :: Int -> MetaM (Core (M TH.Type)) +repPromotedTupleTyCon i = do dflags <- getDynFlags + rep2 promotedTupleTName [mkIntExprInt dflags i] + +repPromotedNilTyCon :: MetaM (Core (M TH.Type)) +repPromotedNilTyCon = rep2 promotedNilTName [] + +repPromotedConsTyCon :: MetaM (Core (M TH.Type)) +repPromotedConsTyCon = rep2 promotedConsTName [] + +------------ TyVarBndrs ------------------- + +repPlainTV :: Core TH.Name -> MetaM (Core (M TH.TyVarBndr)) +repPlainTV (MkC nm) = rep2 plainTVName [nm] + +repKindedTV :: Core TH.Name -> Core (M TH.Kind) -> MetaM (Core (M TH.TyVarBndr)) +repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki] + +---------------------------------------------------------- +-- Type family result signature + +repNoSig :: MetaM (Core (M TH.FamilyResultSig)) +repNoSig = rep2 noSigName [] + +repKindSig :: Core (M TH.Kind) -> MetaM (Core (M TH.FamilyResultSig)) +repKindSig (MkC ki) = rep2 kindSigName [ki] + +repTyVarSig :: Core (M TH.TyVarBndr) -> MetaM (Core (M TH.FamilyResultSig)) +repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr] + +---------------------------------------------------------- +-- Literals + +repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit) +repLiteral (HsStringPrim _ bs) + = do dflags <- getDynFlags + word8_ty <- lookupType word8TyConName + let w8s = unpack bs + w8s_expr = map (\w8 -> mkCoreConApps word8DataCon + [mkWordLit dflags (toInteger w8)]) w8s + rep2_nw stringPrimLName [mkListExpr word8_ty w8s_expr] +repLiteral lit + = do lit' <- case lit of + HsIntPrim _ i -> mk_integer i + HsWordPrim _ w -> mk_integer w + HsInt _ i -> mk_integer (il_value i) + HsFloatPrim _ r -> mk_rational r + HsDoublePrim _ r -> mk_rational r + HsCharPrim _ c -> mk_char c + _ -> return lit + lit_expr <- lift $ dsLit lit' + case mb_lit_name of + Just lit_name -> rep2_nw lit_name [lit_expr] + Nothing -> notHandled "Exotic literal" (ppr lit) + where + mb_lit_name = case lit of + HsInteger _ _ _ -> Just integerLName + HsInt _ _ -> Just integerLName + HsIntPrim _ _ -> Just intPrimLName + HsWordPrim _ _ -> Just wordPrimLName + HsFloatPrim _ _ -> Just floatPrimLName + HsDoublePrim _ _ -> Just doublePrimLName + HsChar _ _ -> Just charLName + HsCharPrim _ _ -> Just charPrimLName + HsString _ _ -> Just stringLName + HsRat _ _ _ -> Just rationalLName + _ -> Nothing + +mk_integer :: Integer -> MetaM (HsLit GhcRn) +mk_integer i = do integer_ty <- lookupType integerTyConName + return $ HsInteger NoSourceText i integer_ty + +mk_rational :: FractionalLit -> MetaM (HsLit GhcRn) +mk_rational r = do rat_ty <- lookupType rationalTyConName + return $ HsRat noExtField r rat_ty +mk_string :: FastString -> MetaM (HsLit GhcRn) +mk_string s = return $ HsString NoSourceText s + +mk_char :: Char -> MetaM (HsLit GhcRn) +mk_char c = return $ HsChar NoSourceText c + +repOverloadedLiteral :: HsOverLit GhcRn -> MetaM (Core TH.Lit) +repOverloadedLiteral (OverLit { ol_val = val}) + = do { lit <- mk_lit val; repLiteral lit } + -- The type Rational will be in the environment, because + -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, + -- and rationalL is sucked in when any TH stuff is used +repOverloadedLiteral (XOverLit nec) = noExtCon nec + +mk_lit :: OverLitVal -> MetaM (HsLit GhcRn) +mk_lit (HsIntegral i) = mk_integer (il_value i) +mk_lit (HsFractional f) = mk_rational f +mk_lit (HsIsString _ s) = mk_string s + +repNameS :: Core String -> MetaM (Core TH.Name) +repNameS (MkC name) = rep2_nw mkNameSName [name] + +--------------- Miscellaneous ------------------- + +repGensym :: Core String -> MetaM (Core (M TH.Name)) +repGensym (MkC lit_str) = rep2 newNameName [lit_str] + +repBindM :: Type -> Type -- a and b + -> Core (M a) -> Core (a -> M b) -> MetaM (Core (M b)) +repBindM ty_a ty_b (MkC x) (MkC y) + = rep2M bindMName [Type ty_a, Type ty_b, x, y] + +repSequenceM :: Type -> Core [M a] -> MetaM (Core (M [a])) +repSequenceM ty_a (MkC list) + = rep2M sequenceQName [Type ty_a, list] + +repUnboundVar :: Core TH.Name -> MetaM (Core (M TH.Exp)) +repUnboundVar (MkC name) = rep2 unboundVarEName [name] + +repOverLabel :: FastString -> MetaM (Core (M TH.Exp)) +repOverLabel fs = do + (MkC s) <- coreStringLit $ unpackFS fs + rep2 labelEName [s] + + +------------ Lists ------------------- +-- turn a list of patterns into a single pattern matching a list + +repList :: Name -> (a -> MetaM (Core b)) + -> [a] -> MetaM (Core [b]) +repList tc_name f args + = do { args1 <- mapM f args + ; coreList tc_name args1 } + +-- Create a list of m a values +repListM :: Name -> (a -> MetaM (Core b)) + -> [a] -> MetaM (Core [b]) +repListM tc_name f args + = do { ty <- wrapName tc_name + ; args1 <- mapM f args + ; return $ coreList' ty args1 } + +coreListM :: Name -> [Core a] -> MetaM (Core [a]) +coreListM tc as = repListM tc return as + +coreList :: Name -- Of the TyCon of the element type + -> [Core a] -> MetaM (Core [a]) +coreList tc_name es + = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) } + +coreList' :: Type -- The element type + -> [Core a] -> Core [a] +coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es )) + +nonEmptyCoreList :: [Core a] -> Core [a] + -- The list must be non-empty so we can get the element type + -- Otherwise use coreList +nonEmptyCoreList [] = panic "coreList: empty argument" +nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs)) + + +coreStringLit :: MonadThings m => String -> m (Core String) +coreStringLit s = do { z <- mkStringExpr s; return(MkC z) } + +------------------- Maybe ------------------ + +repMaybe :: Name -> (a -> MetaM (Core b)) + -> Maybe a -> MetaM (Core (Maybe b)) +repMaybe tc_name f m = do + t <- lookupType tc_name + repMaybeT t f m + +repMaybeT :: Type -> (a -> MetaM (Core b)) + -> Maybe a -> MetaM (Core (Maybe b)) +repMaybeT ty _ Nothing = return $ coreNothing' ty +repMaybeT ty f (Just es) = coreJust' ty <$> f es + +-- | Construct Core expression for Nothing of a given type name +coreNothing :: Name -- ^ Name of the TyCon of the element type + -> MetaM (Core (Maybe a)) +coreNothing tc_name = + do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) } + +coreNothingM :: Name -> MetaM (Core (Maybe a)) +coreNothingM tc_name = + do { elt_ty <- wrapName tc_name; return (coreNothing' elt_ty) } + +-- | Construct Core expression for Nothing of a given type +coreNothing' :: Type -- ^ The element type + -> Core (Maybe a) +coreNothing' elt_ty = MkC (mkNothingExpr elt_ty) + +-- | Store given Core expression in a Just of a given type name +coreJust :: Name -- ^ Name of the TyCon of the element type + -> Core a -> MetaM (Core (Maybe a)) +coreJust tc_name es + = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) } + +coreJustM :: Name -> Core a -> MetaM (Core (Maybe a)) +coreJustM tc_name es = do { elt_ty <- wrapName tc_name; return (coreJust' elt_ty es) } + +-- | Store given Core expression in a Just of a given type +coreJust' :: Type -- ^ The element type + -> Core a -> Core (Maybe a) +coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es)) + +------------------- Maybe Lists ------------------ + +-- Lookup the name and wrap it with the m variable +repMaybeListM :: Name -> (a -> MetaM (Core b)) + -> Maybe [a] -> MetaM (Core (Maybe [b])) +repMaybeListM tc_name f xs = do + elt_ty <- wrapName tc_name + repMaybeListT elt_ty f xs + + +repMaybeListT :: Type -> (a -> MetaM (Core b)) + -> Maybe [a] -> MetaM (Core (Maybe [b])) +repMaybeListT elt_ty _ Nothing = coreNothingList elt_ty +repMaybeListT elt_ty f (Just args) + = do { args1 <- mapM f args + ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) } + +coreNothingList :: Type -> MetaM (Core (Maybe [a])) +coreNothingList elt_ty = return $ coreNothing' (mkListTy elt_ty) + +------------ Literals & Variables ------------------- + +coreIntLit :: Int -> MetaM (Core Int) +coreIntLit i = do dflags <- getDynFlags + return (MkC (mkIntExprInt dflags i)) + +coreIntegerLit :: MonadThings m => Integer -> m (Core Integer) +coreIntegerLit i = fmap MkC (mkIntegerExpr i) + +coreVar :: Id -> Core TH.Name -- The Id has type Name +coreVar id = MkC (Var id) + +----------------- Failure ----------------------- +notHandledL :: SrcSpan -> String -> SDoc -> MetaM a +notHandledL loc what doc + | isGoodSrcSpan loc + = mapReaderT (putSrcSpanDs loc) $ notHandled what doc + | otherwise + = notHandled what doc + +notHandled :: String -> SDoc -> MetaM a +notHandled what doc = lift $ failWithDs msg + where + msg = hang (text what <+> text "not (yet) handled by Template Haskell") + 2 doc diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs new file mode 100644 index 0000000000..f771608a94 --- /dev/null +++ b/compiler/GHC/HsToCore/Usage.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.HsToCore.Usage ( + -- * Dependency/fingerprinting code (used by GHC.Iface.Utils) + mkUsageInfo, mkUsedNames, mkDependencies + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import DynFlags +import HscTypes +import TcRnTypes +import Name +import NameSet +import Module +import Outputable +import Util +import UniqSet +import UniqFM +import Fingerprint +import Maybes +import Packages +import Finder + +import Control.Monad (filterM) +import Data.List +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set +import System.Directory +import System.FilePath + +{- Note [Module self-dependency] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC.Rename.Names.calculateAvails asserts the invariant that a module must not occur in +its own dep_orphs or dep_finsts. However, if we aren't careful this can occur +in the presence of hs-boot files: Consider that we have two modules, A and B, +both with hs-boot files, + + A.hs contains a SOURCE import of B B.hs-boot contains a SOURCE import of A + A.hs-boot declares an orphan instance A.hs defines the orphan instance + +In this case, B's dep_orphs will contain A due to its SOURCE import of A. +Consequently, A will contain itself in its imp_orphs due to its import of B. +This fact would end up being recorded in A's interface file. This would then +break the invariant asserted by calculateAvails that a module does not itself in +its dep_orphs. This was the cause of #14128. + +-} + +-- | Extract information from the rename and typecheck phases to produce +-- a dependencies information for the module being compiled. +-- +-- The first argument is additional dependencies from plugins +mkDependencies :: InstalledUnitId -> [Module] -> TcGblEnv -> IO Dependencies +mkDependencies iuid pluginModules + (TcGblEnv{ tcg_mod = mod, + tcg_imports = imports, + tcg_th_used = th_var + }) + = do + -- Template Haskell used? + let (dep_plgins, ms) = unzip [ (moduleName mn, mn) | mn <- pluginModules ] + plugin_dep_pkgs = filter (/= iuid) (map (toInstalledUnitId . moduleUnitId) ms) + th_used <- readIORef th_var + let dep_mods = modDepsElts (delFromUFM (imp_dep_mods imports) + (moduleName mod)) + -- M.hi-boot can be in the imp_dep_mods, but we must remove + -- it before recording the modules on which this one depends! + -- (We want to retain M.hi-boot in imp_dep_mods so that + -- loadHiBootInterface can see if M's direct imports depend + -- on M.hi-boot, and hence that we should do the hi-boot consistency + -- check.) + + dep_orphs = filter (/= mod) (imp_orphs imports) + -- We must also remove self-references from imp_orphs. See + -- Note [Module self-dependency] + + raw_pkgs = foldr Set.insert (imp_dep_pkgs imports) plugin_dep_pkgs + + pkgs | th_used = Set.insert (toInstalledUnitId thUnitId) raw_pkgs + | otherwise = raw_pkgs + + -- Set the packages required to be Safe according to Safe Haskell. + -- See Note [Tracking Trust Transitively] in GHC.Rename.Names + sorted_pkgs = sort (Set.toList pkgs) + trust_pkgs = imp_trust_pkgs imports + dep_pkgs' = map (\x -> (x, x `Set.member` trust_pkgs)) sorted_pkgs + + return Deps { dep_mods = dep_mods, + dep_pkgs = dep_pkgs', + dep_orphs = dep_orphs, + dep_plgins = dep_plgins, + dep_finsts = sortBy stableModuleCmp (imp_finsts imports) } + -- sort to get into canonical order + -- NB. remember to use lexicographic ordering + +mkUsedNames :: TcGblEnv -> NameSet +mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus + +mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] + -> [(Module, Fingerprint)] -> [ModIface] -> IO [Usage] +mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged + pluginModules + = do + eps <- hscEPS hsc_env + hashes <- mapM getFileHash dependent_files + plugin_usages <- mapM (mkPluginUsage hsc_env) pluginModules + let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod + dir_imp_mods used_names + usages = mod_usages ++ [ UsageFile { usg_file_path = f + , usg_file_hash = hash } + | (f, hash) <- zip dependent_files hashes ] + ++ [ UsageMergedRequirement + { usg_mod = mod, + usg_mod_hash = hash + } + | (mod, hash) <- merged ] + ++ concat plugin_usages + usages `seqList` return usages + -- seq the list of Usages returned: occasionally these + -- don't get evaluated for a while and we can end up hanging on to + -- the entire collection of Ifaces. + +{- Note [Plugin dependencies] +Modules for which plugins were used in the compilation process, should be +recompiled whenever one of those plugins changes. But how do we know if a +plugin changed from the previous time a module was compiled? + +We could try storing the fingerprints of the interface files of plugins in +the interface file of the module. And see if there are changes between +compilation runs. However, this is pretty much a non-option because interface +fingerprints of plugin modules are fairly stable, unless you compile plugins +with optimisations turned on, and give basically all binders an INLINE pragma. + +So instead: + + * For plugins that were built locally: we store the filepath and hash of the + object files of the module with the `plugin` binder, and the object files of + modules that are dependencies of the plugin module and belong to the same + `UnitId` as the plugin + * For plugins in an external package: we store the filepath and hash of + the dynamic library containing the plugin module. + +During recompilation we then compare the hashes of those files again to see +if anything has changed. + +One issue with this approach is that object files are currently (GHC 8.6.1) +not created fully deterministicly, which could sometimes induce accidental +recompilation of a module for which plugins were used in the compile process. + +One way to improve this is to either: + + * Have deterministic object file creation + * Create and store implementation hashes, which would be based on the Core + of the module and the implementation hashes of its dependencies, and then + compare implementation hashes for recompilation. Creation of implementation + hashes is however potentially expensive. +-} +mkPluginUsage :: HscEnv -> ModIface -> IO [Usage] +mkPluginUsage hsc_env pluginModule + = case lookupPluginModuleWithSuggestions dflags pNm Nothing of + LookupFound _ pkg -> do + -- The plugin is from an external package: + -- search for the library files containing the plugin. + let searchPaths = collectLibraryPaths dflags [pkg] + useDyn = WayDyn `elem` ways dflags + suffix = if useDyn then soExt platform else "a" + libLocs = [ searchPath "lib" ++ libLoc <.> suffix + | searchPath <- searchPaths + , libLoc <- packageHsLibs dflags pkg + ] + -- we also try to find plugin library files by adding WayDyn way, + -- if it isn't already present (see trac #15492) + paths = + if useDyn + then libLocs + else + let dflags' = updateWays (addWay' WayDyn dflags) + dlibLocs = [ searchPath mkHsSOName platform dlibLoc + | searchPath <- searchPaths + , dlibLoc <- packageHsLibs dflags' pkg + ] + in libLocs ++ dlibLocs + files <- filterM doesFileExist paths + case files of + [] -> + pprPanic + ( "mkPluginUsage: missing plugin library, tried:\n" + ++ unlines paths + ) + (ppr pNm) + _ -> mapM hashFile (nub files) + _ -> do + foundM <- findPluginModule hsc_env pNm + case foundM of + -- The plugin was built locally: look up the object file containing + -- the `plugin` binder, and all object files belong to modules that are + -- transitive dependencies of the plugin that belong to the same package. + Found ml _ -> do + pluginObject <- hashFile (ml_obj_file ml) + depObjects <- catMaybes <$> mapM lookupObjectFile deps + return (nub (pluginObject : depObjects)) + _ -> pprPanic "mkPluginUsage: no object file found" (ppr pNm) + where + dflags = hsc_dflags hsc_env + platform = targetPlatform dflags + pNm = moduleName (mi_module pluginModule) + pPkg = moduleUnitId (mi_module pluginModule) + deps = map fst (dep_mods (mi_deps pluginModule)) + + -- Lookup object file for a plugin dependency, + -- from the same package as the plugin. + lookupObjectFile nm = do + foundM <- findImportedModule hsc_env nm Nothing + case foundM of + Found ml m + | moduleUnitId m == pPkg -> Just <$> hashFile (ml_obj_file ml) + | otherwise -> return Nothing + _ -> pprPanic "mkPluginUsage: no object for dependency" + (ppr pNm <+> ppr nm) + + hashFile f = do + fExist <- doesFileExist f + if fExist + then do + h <- getFileHash f + return (UsageFile f h) + else pprPanic "mkPluginUsage: file not found" (ppr pNm <+> text f) + +mk_mod_usage_info :: PackageIfaceTable + -> HscEnv + -> Module + -> ImportedMods + -> NameSet + -> [Usage] +mk_mod_usage_info pit hsc_env this_mod direct_imports used_names + = mapMaybe mkUsage usage_mods + where + hpt = hsc_HPT hsc_env + dflags = hsc_dflags hsc_env + this_pkg = thisPackage dflags + + used_mods = moduleEnvKeys ent_map + dir_imp_mods = moduleEnvKeys direct_imports + all_mods = used_mods ++ filter (`notElem` used_mods) dir_imp_mods + usage_mods = sortBy stableModuleCmp all_mods + -- canonical order is imported, to avoid interface-file + -- wobblage. + + -- ent_map groups together all the things imported and used + -- from a particular module + ent_map :: ModuleEnv [OccName] + ent_map = nonDetFoldUniqSet add_mv emptyModuleEnv used_names + -- nonDetFoldUFM is OK here. If you follow the logic, we sort by OccName + -- in ent_hashs + where + add_mv name mv_map + | isWiredInName name = mv_map -- ignore wired-in names + | otherwise + = case nameModule_maybe name of + Nothing -> ASSERT2( isSystemName name, ppr name ) mv_map + -- See Note [Internal used_names] + + Just mod -> + -- See Note [Identity versus semantic module] + let mod' = if isHoleModule mod + then mkModule this_pkg (moduleName mod) + else mod + -- This lambda function is really just a + -- specialised (++); originally came about to + -- avoid quadratic behaviour (trac #2680) + in extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod' [occ] + where occ = nameOccName name + + -- We want to create a Usage for a home module if + -- a) we used something from it; has something in used_names + -- b) we imported it, even if we used nothing from it + -- (need to recompile if its export list changes: export_fprint) + mkUsage :: Module -> Maybe Usage + mkUsage mod + | isNothing maybe_iface -- We can't depend on it if we didn't + -- load its interface. + || mod == this_mod -- We don't care about usages of + -- things in *this* module + = Nothing + + | moduleUnitId mod /= this_pkg + = Just UsagePackageModule{ usg_mod = mod, + usg_mod_hash = mod_hash, + usg_safe = imp_safe } + -- for package modules, we record the module hash only + + | (null used_occs + && isNothing export_hash + && not is_direct_import + && not finsts_mod) + = Nothing -- Record no usage info + -- for directly-imported modules, we always want to record a usage + -- on the orphan hash. This is what triggers a recompilation if + -- an orphan is added or removed somewhere below us in the future. + + | otherwise + = Just UsageHomeModule { + usg_mod_name = moduleName mod, + usg_mod_hash = mod_hash, + usg_exports = export_hash, + usg_entities = Map.toList ent_hashs, + usg_safe = imp_safe } + where + maybe_iface = lookupIfaceByModule hpt pit mod + -- In one-shot mode, the interfaces for home-package + -- modules accumulate in the PIT not HPT. Sigh. + + Just iface = maybe_iface + finsts_mod = mi_finsts (mi_final_exts iface) + hash_env = mi_hash_fn (mi_final_exts iface) + mod_hash = mi_mod_hash (mi_final_exts iface) + export_hash | depend_on_exports = Just (mi_exp_hash (mi_final_exts iface)) + | otherwise = Nothing + + by_is_safe (ImportedByUser imv) = imv_is_safe imv + by_is_safe _ = False + (is_direct_import, imp_safe) + = case lookupModuleEnv direct_imports mod of + -- ezyang: I'm not sure if any is the correct + -- metric here. If safety was guaranteed to be uniform + -- across all imports, why did the old code only look + -- at the first import? + Just bys -> (True, any by_is_safe bys) + Nothing -> (False, safeImplicitImpsReq dflags) + -- Nothing case is for references to entities which were + -- not directly imported (NB: the "implicit" Prelude import + -- counts as directly imported! An entity is not directly + -- imported if, e.g., we got a reference to it from a + -- reexport of another module.) + + used_occs = lookupModuleEnv ent_map mod `orElse` [] + + -- Making a Map here ensures that (a) we remove duplicates + -- when we have usages on several subordinates of a single parent, + -- and (b) that the usages emerge in a canonical order, which + -- is why we use Map rather than OccEnv: Map works + -- using Ord on the OccNames, which is a lexicographic ordering. + ent_hashs :: Map OccName Fingerprint + ent_hashs = Map.fromList (map lookup_occ used_occs) + + lookup_occ occ = + case hash_env occ of + Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names) + Just r -> r + + depend_on_exports = is_direct_import + {- True + Even if we used 'import M ()', we have to register a + usage on the export list because we are sensitive to + changes in orphan instances/rules. + False + In GHC 6.8.x we always returned true, and in + fact it recorded a dependency on *all* the + modules underneath in the dependency tree. This + happens to make orphans work right, but is too + expensive: it'll read too many interface files. + The 'isNothing maybe_iface' check above saved us + from generating many of these usages (at least in + one-shot mode), but that's even more bogus! + -} diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs new file mode 100644 index 0000000000..3c95e55b19 --- /dev/null +++ b/compiler/GHC/HsToCore/Utils.hs @@ -0,0 +1,1001 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Utilities for desugaring + +This module exports some utility functions of no great interest. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Utility functions for constructing Core syntax, principally for desugaring +module GHC.HsToCore.Utils ( + EquationInfo(..), + firstPat, shiftEqns, + + MatchResult(..), CanItFail(..), CaseAlt(..), + cantFailMatchResult, alwaysFailMatchResult, + extractMatchResult, combineMatchResults, + adjustMatchResult, adjustMatchResultDs, + mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, + matchCanFail, mkEvalMatchResult, + mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult, + wrapBind, wrapBinds, + + mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs, + + seqVar, + + -- LHs tuples + mkLHsPatTup, mkVanillaTuplePat, + mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId, + + mkSelectorBinds, + + selectSimpleMatchVarL, selectMatchVars, selectMatchVar, + mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang, + isTrueLHsExpr + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply ) +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr ) + +import GHC.Hs +import TcHsSyn +import TcType( tcSplitTyConApp ) +import CoreSyn +import GHC.HsToCore.Monad + +import CoreUtils +import MkCore +import MkId +import Id +import Literal +import TyCon +import DataCon +import PatSyn +import Type +import Coercion +import TysPrim +import TysWiredIn +import BasicTypes +import ConLike +import UniqSet +import UniqSupply +import Module +import PrelNames +import Name( isInternalName ) +import Outputable +import SrcLoc +import Util +import DynFlags +import FastString +import qualified GHC.LanguageExtensions as LangExt + +import TcEvidence + +import Control.Monad ( zipWithM ) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NEL + +{- +************************************************************************ +* * +\subsection{ Selecting match variables} +* * +************************************************************************ + +We're about to match against some patterns. We want to make some +@Ids@ to use as match variables. If a pattern has an @Id@ readily at +hand, which should indeed be bound to the pattern as a whole, then use it; +otherwise, make one up. +-} + +selectSimpleMatchVarL :: LPat GhcTc -> DsM Id +-- Postcondition: the returned Id has an Internal Name +selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) + +-- (selectMatchVars ps tys) chooses variables of type tys +-- to use for matching ps against. If the pattern is a variable, +-- we try to use that, to save inventing lots of fresh variables. +-- +-- OLD, but interesting note: +-- But even if it is a variable, its type might not match. Consider +-- data T a where +-- T1 :: Int -> T Int +-- T2 :: a -> T a +-- +-- f :: T a -> a -> Int +-- f (T1 i) (x::Int) = x +-- f (T2 i) (y::a) = 0 +-- Then we must not choose (x::Int) as the matching variable! +-- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat + +selectMatchVars :: [Pat GhcTc] -> DsM [Id] +-- Postcondition: the returned Ids have Internal Names +selectMatchVars ps = mapM selectMatchVar ps + +selectMatchVar :: Pat GhcTc -> DsM Id +-- Postcondition: the returned Id has an Internal Name +selectMatchVar (BangPat _ pat) = selectMatchVar (unLoc pat) +selectMatchVar (LazyPat _ pat) = selectMatchVar (unLoc pat) +selectMatchVar (ParPat _ pat) = selectMatchVar (unLoc pat) +selectMatchVar (VarPat _ var) = return (localiseId (unLoc var)) + -- Note [Localise pattern binders] +selectMatchVar (AsPat _ var _) = return (unLoc var) +selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat) + -- OK, better make up one... + +{- Note [Localise pattern binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider module M where + [Just a] = e +After renaming it looks like + module M where + [Just M.a] = e + +We don't generalise, since it's a pattern binding, monomorphic, etc, +so after desugaring we may get something like + M.a = case e of (v:_) -> + case v of Just M.a -> M.a +Notice the "M.a" in the pattern; after all, it was in the original +pattern. However, after optimisation those pattern binders can become +let-binders, and then end up floated to top level. They have a +different *unique* by then (the simplifier is good about maintaining +proper scoping), but it's BAD to have two top-level bindings with the +External Name M.a, because that turns into two linker symbols for M.a. +It's quite rare for this to actually *happen* -- the only case I know +of is tc003 compiled with the 'hpc' way -- but that only makes it +all the more annoying. + +To avoid this, we craftily call 'localiseId' in the desugarer, which +simply turns the External Name for the Id into an Internal one, but +doesn't change the unique. So the desugarer produces this: + M.a{r8} = case e of (v:_) -> + case v of Just a{r8} -> M.a{r8} +The unique is still 'r8', but the binding site in the pattern +is now an Internal Name. Now the simplifier's usual mechanisms +will propagate that Name to all the occurrence sites, as well as +un-shadowing it, so we'll get + M.a{r8} = case e of (v:_) -> + case v of Just a{s77} -> a{s77} +In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr +runs on the output of the desugarer, so all is well by the end of +the desugaring pass. + +See also Note [MatchIds] in GHC.HsToCore.Match + +************************************************************************ +* * +* type synonym EquationInfo and access functions for its pieces * +* * +************************************************************************ +\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym} + +The ``equation info'' used by @match@ is relatively complicated and +worthy of a type synonym and a few handy functions. +-} + +firstPat :: EquationInfo -> Pat GhcTc +firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn) + +shiftEqns :: Functor f => f EquationInfo -> f EquationInfo +-- Drop the first pattern in each equation +shiftEqns = fmap $ \eqn -> eqn { eqn_pats = tail (eqn_pats eqn) } + +-- Functions on MatchResults + +matchCanFail :: MatchResult -> Bool +matchCanFail (MatchResult CanFail _) = True +matchCanFail (MatchResult CantFail _) = False + +alwaysFailMatchResult :: MatchResult +alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail) + +cantFailMatchResult :: CoreExpr -> MatchResult +cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr) + +extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr +extractMatchResult (MatchResult CantFail match_fn) _ + = match_fn (error "It can't fail!") + +extractMatchResult (MatchResult CanFail match_fn) fail_expr = do + (fail_bind, if_it_fails) <- mkFailurePair fail_expr + body <- match_fn if_it_fails + return (mkCoreLet fail_bind body) + + +combineMatchResults :: MatchResult -> MatchResult -> MatchResult +combineMatchResults (MatchResult CanFail body_fn1) + (MatchResult can_it_fail2 body_fn2) + = MatchResult can_it_fail2 body_fn + where + body_fn fail = do body2 <- body_fn2 fail + (fail_bind, duplicatable_expr) <- mkFailurePair body2 + body1 <- body_fn1 duplicatable_expr + return (Let fail_bind body1) + +combineMatchResults match_result1@(MatchResult CantFail _) _ + = match_result1 + +adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult +adjustMatchResult encl_fn (MatchResult can_it_fail body_fn) + = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail) + +adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult +adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn) + = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail) + +wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr +wrapBinds [] e = e +wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e) + +wrapBind :: Var -> Var -> CoreExpr -> CoreExpr +wrapBind new old body -- NB: this function must deal with term + | new==old = body -- variables, type variables or coercion variables + | otherwise = Let (NonRec new (varToCoreExpr old)) body + +seqVar :: Var -> CoreExpr -> CoreExpr +seqVar var body = mkDefaultCase (Var var) var body + +mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult +mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind) + +-- (mkViewMatchResult var' viewExpr mr) makes the expression +-- let var' = viewExpr in mr +mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult +mkViewMatchResult var' viewExpr = + adjustMatchResult (mkCoreLet (NonRec var' viewExpr)) + +mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult +mkEvalMatchResult var ty + = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)]) + +mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult +mkGuardedMatchResult pred_expr (MatchResult _ body_fn) + = MatchResult CanFail (\fail -> do body <- body_fn fail + return (mkIfThenElse pred_expr body fail)) + +mkCoPrimCaseMatchResult :: Id -- Scrutinee + -> Type -- Type of the case + -> [(Literal, MatchResult)] -- Alternatives + -> MatchResult -- Literals are all unlifted +mkCoPrimCaseMatchResult var ty match_alts + = MatchResult CanFail mk_case + where + mk_case fail = do + alts <- mapM (mk_alt fail) sorted_alts + return (Case (Var var) var ty ((DEFAULT, [], fail) : alts)) + + sorted_alts = sortWith fst match_alts -- Right order for a Case + mk_alt fail (lit, MatchResult _ body_fn) + = ASSERT( not (litIsLifted lit) ) + do body <- body_fn fail + return (LitAlt lit, [], body) + +data CaseAlt a = MkCaseAlt{ alt_pat :: a, + alt_bndrs :: [Var], + alt_wrapper :: HsWrapper, + alt_result :: MatchResult } + +mkCoAlgCaseMatchResult + :: Id -- ^ Scrutinee + -> Type -- ^ Type of exp + -> NonEmpty (CaseAlt DataCon) -- ^ Alternatives (bndrs *include* tyvars, dicts) + -> MatchResult +mkCoAlgCaseMatchResult var ty match_alts + | isNewtype -- Newtype case; use a let + = ASSERT( null match_alts_tail && null (tail arg_ids1) ) + mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1 + + | otherwise + = mkDataConCase var ty match_alts + where + isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1)) + + -- [Interesting: because of GADTs, we can't rely on the type of + -- the scrutinised Id to be sufficiently refined to have a TyCon in it] + + alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } :| match_alts_tail + = match_alts + -- Stuff for newtype + arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1 + var_ty = idType var + (tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes + -- (not that splitTyConApp does, these days) + newtype_rhs = unwrapNewTypeBody tc ty_args (Var var) + +mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult +mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt + +mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr +mkPatSynCase var ty alt fail = do + matcher <- dsLExpr $ mkLHsWrap wrapper $ + nlHsTyApp matcher [getRuntimeRep ty, ty] + let MatchResult _ mkCont = match_result + cont <- mkCoreLams bndrs <$> mkCont fail + return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail] + where + MkCaseAlt{ alt_pat = psyn, + alt_bndrs = bndrs, + alt_wrapper = wrapper, + alt_result = match_result} = alt + (matcher, needs_void_lam) = patSynMatcher psyn + + -- See Note [Matchers and builders for pattern synonyms] in PatSyns + -- on these extra Void# arguments + ensure_unstrict cont | needs_void_lam = Lam voidArgId cont + | otherwise = cont + +mkDataConCase :: Id -> Type -> NonEmpty (CaseAlt DataCon) -> MatchResult +mkDataConCase var ty alts@(alt1 :| _) = MatchResult fail_flag mk_case + where + con1 = alt_pat alt1 + tycon = dataConTyCon con1 + data_cons = tyConDataCons tycon + match_results = fmap alt_result alts + + sorted_alts :: NonEmpty (CaseAlt DataCon) + sorted_alts = NEL.sortWith (dataConTag . alt_pat) alts + + var_ty = idType var + (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes + -- (not that splitTyConApp does, these days) + + mk_case :: CoreExpr -> DsM CoreExpr + mk_case fail = do + alts <- mapM (mk_alt fail) sorted_alts + return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ NEL.toList alts) + + mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt + mk_alt fail MkCaseAlt{ alt_pat = con, + alt_bndrs = args, + alt_result = MatchResult _ body_fn } + = do { body <- body_fn fail + ; case dataConBoxer con of { + Nothing -> return (DataAlt con, args, body) ; + Just (DCB boxer) -> + do { us <- newUniqueSupply + ; let (rep_ids, binds) = initUs_ us (boxer ty_args args) + ; return (DataAlt con, rep_ids, mkLets binds body) } } } + + mk_default :: CoreExpr -> [CoreAlt] + mk_default fail | exhaustive_case = [] + | otherwise = [(DEFAULT, [], fail)] + + fail_flag :: CanItFail + fail_flag | exhaustive_case + = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- NEL.toList match_results] + | otherwise + = CanFail + + mentioned_constructors = mkUniqSet $ map alt_pat $ NEL.toList alts + un_mentioned_constructors + = mkUniqSet data_cons `minusUniqSet` mentioned_constructors + exhaustive_case = isEmptyUniqSet un_mentioned_constructors + +{- +************************************************************************ +* * +\subsection{Desugarer's versions of some Core functions} +* * +************************************************************************ +-} + +mkErrorAppDs :: Id -- The error function + -> Type -- Type to which it should be applied + -> SDoc -- The error message string to pass + -> DsM CoreExpr + +mkErrorAppDs err_id ty msg = do + src_loc <- getSrcSpanDs + dflags <- getDynFlags + let + full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg]) + core_msg = Lit (mkLitString full_msg) + -- mkLitString returns a result of type String# + return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg]) + +{- +'mkCoreAppDs' and 'mkCoreAppsDs' handle the special-case desugaring of 'seq'. + +Note [Desugaring seq] +~~~~~~~~~~~~~~~~~~~~~ + +There are a few subtleties in the desugaring of `seq`: + + 1. (as described in #1031) + + Consider, + f x y = x `seq` (y `seq` (# x,y #)) + + The [CoreSyn let/app invariant] means that, other things being equal, because + the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus: + + f x y = case (y `seq` (# x,y #)) of v -> x `seq` v + + But that is bad for two reasons: + (a) we now evaluate y before x, and + (b) we can't bind v to an unboxed pair + + Seq is very, very special! So we recognise it right here, and desugar to + case x of _ -> case y of _ -> (# x,y #) + + 2. (as described in #2273) + + Consider + let chp = case b of { True -> fst x; False -> 0 } + in chp `seq` ...chp... + Here the seq is designed to plug the space leak of retaining (snd x) + for too long. + + If we rely on the ordinary inlining of seq, we'll get + let chp = case b of { True -> fst x; False -> 0 } + case chp of _ { I# -> ...chp... } + + But since chp is cheap, and the case is an alluring contet, we'll + inline chp into the case scrutinee. Now there is only one use of chp, + so we'll inline a second copy. Alas, we've now ruined the purpose of + the seq, by re-introducing the space leak: + case (case b of {True -> fst x; False -> 0}) of + I# _ -> ...case b of {True -> fst x; False -> 0}... + + We can try to avoid doing this by ensuring that the binder-swap in the + case happens, so we get his at an early stage: + case chp of chp2 { I# -> ...chp2... } + But this is fragile. The real culprit is the source program. Perhaps we + should have said explicitly + let !chp2 = chp in ...chp2... + + But that's painful. So the code here does a little hack to make seq + more robust: a saturated application of 'seq' is turned *directly* into + the case expression, thus: + x `seq` e2 ==> case x of x -> e2 -- Note shadowing! + e1 `seq` e2 ==> case x of _ -> e2 + + So we desugar our example to: + let chp = case b of { True -> fst x; False -> 0 } + case chp of chp { I# -> ...chp... } + And now all is well. + + The reason it's a hack is because if you define mySeq=seq, the hack + won't work on mySeq. + + 3. (as described in #2409) + + The isLocalId ensures that we don't turn + True `seq` e + into + case True of True { ... } + which stupidly tries to bind the datacon 'True'. +-} + +-- NB: Make sure the argument is not levity polymorphic +mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr +mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2 + | f `hasKey` seqIdKey -- Note [Desugaring seq], points (1) and (2) + = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)] + where + case_bndr = case arg1 of + Var v1 | isInternalName (idName v1) + -> v1 -- Note [Desugaring seq], points (2) and (3) + _ -> mkWildValBinder ty1 + +mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in MkCore + +-- NB: No argument can be levity polymorphic +mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr +mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args + +mkCastDs :: CoreExpr -> Coercion -> CoreExpr +-- We define a desugarer-specific version of CoreUtils.mkCast, +-- because in the immediate output of the desugarer, we can have +-- apparently-mis-matched coercions: E.g. +-- let a = b +-- in (x :: a) |> (co :: b ~ Int) +-- Lint know about type-bindings for let and does not complain +-- So here we do not make the assertion checks that we make in +-- CoreUtils.mkCast; and we do less peephole optimisation too +mkCastDs e co | isReflCo co = e + | otherwise = Cast e co + +{- +************************************************************************ +* * + Tuples and selector bindings +* * +************************************************************************ + +This is used in various places to do with lazy patterns. +For each binder $b$ in the pattern, we create a binding: +\begin{verbatim} + b = case v of pat' -> b' +\end{verbatim} +where @pat'@ is @pat@ with each binder @b@ cloned into @b'@. + +ToDo: making these bindings should really depend on whether there's +much work to be done per binding. If the pattern is complex, it +should be de-mangled once, into a tuple (and then selected from). +Otherwise the demangling can be in-line in the bindings (as here). + +Boring! Boring! One error message per binder. The above ToDo is +even more helpful. Something very similar happens for pattern-bound +expressions. + +Note [mkSelectorBinds] +~~~~~~~~~~~~~~~~~~~~~~ +mkSelectorBinds is used to desugar a pattern binding {p = e}, +in a binding group: + let { ...; p = e; ... } in body +where p binds x,y (this list of binders can be empty). +There are two cases. + +------ Special case (A) ------- + For a pattern that is just a variable, + let !x = e in body + ==> + let x = e in x `seq` body + So we return the binding, with 'x' as the variable to seq. + +------ Special case (B) ------- + For a pattern that is essentially just a tuple: + * A product type, so cannot fail + * Only one level, so that + - generating multiple matches is fine + - seq'ing it evaluates the same as matching it + Then instead we generate + { v = e + ; x = case v of p -> x + ; y = case v of p -> y } + with 'v' as the variable to force + +------ General case (C) ------- + In the general case we generate these bindings: + let { ...; p = e; ... } in body + ==> + let { t = case e of p -> (x,y) + ; x = case t of (x,y) -> x + ; y = case t of (x,y) -> y } + in t `seq` body + + Note that we return 't' as the variable to force if the pattern + is strict (i.e. with -XStrict or an outermost-bang-pattern) + + Note that (A) /includes/ the situation where + + * The pattern binds exactly one variable + let !(Just (Just x) = e in body + ==> + let { t = case e of Just (Just v) -> Unit v + ; v = case t of Unit v -> v } + in t `seq` body + The 'Unit' is a one-tuple; see Note [One-tuples] in TysWiredIn + Note that forcing 't' makes the pattern match happen, + but does not force 'v'. + + * The pattern binds no variables + let !(True,False) = e in body + ==> + let t = case e of (True,False) -> () + in t `seq` body + + +------ Examples ---------- + * !(_, (_, a)) = e + ==> + t = case e of (_, (_, a)) -> Unit a + a = case t of Unit a -> a + + Note that + - Forcing 't' will force the pattern to match fully; + e.g. will diverge if (snd e) is bottom + - But 'a' itself is not forced; it is wrapped in a one-tuple + (see Note [One-tuples] in TysWiredIn) + + * !(Just x) = e + ==> + t = case e of Just x -> Unit x + x = case t of Unit x -> x + + Again, forcing 't' will fail if 'e' yields Nothing. + +Note that even though this is rather general, the special cases +work out well: + +* One binder, not -XStrict: + + let Just (Just v) = e in body + ==> + let t = case e of Just (Just v) -> Unit v + v = case t of Unit v -> v + in body + ==> + let v = case (case e of Just (Just v) -> Unit v) of + Unit v -> v + in body + ==> + let v = case e of Just (Just v) -> v + in body + +* Non-recursive, -XStrict + let p = e in body + ==> + let { t = case e of p -> (x,y) + ; x = case t of (x,y) -> x + ; y = case t of (x,y) -> x } + in t `seq` body + ==> {inline seq, float x,y bindings inwards} + let t = case e of p -> (x,y) in + case t of t' -> + let { x = case t' of (x,y) -> x + ; y = case t' of (x,y) -> x } in + body + ==> {inline t, do case of case} + case e of p -> + let t = (x,y) in + let { x = case t' of (x,y) -> x + ; y = case t' of (x,y) -> x } in + body + ==> {case-cancellation, drop dead code} + case e of p -> body + +* Special case (B) is there to avoid fruitlessly taking the tuple + apart and rebuilding it. For example, consider + { K x y = e } + where K is a product constructor. Then general case (A) does: + { t = case e of K x y -> (x,y) + ; x = case t of (x,y) -> x + ; y = case t of (x,y) -> y } + In the lazy case we can't optimise out this fruitless taking apart + and rebuilding. Instead (B) builds + { v = e + ; x = case v of K x y -> x + ; y = case v of K x y -> y } + which is better. +-} + +mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly + -> LPat GhcTc -- ^ The pattern + -> CoreExpr -- ^ Expression to which the pattern is bound + -> DsM (Id,[(Id,CoreExpr)]) + -- ^ Id the rhs is bound to, for desugaring strict + -- binds (see Note [Desugar Strict binds] in GHC.HsToCore.Binds) + -- and all the desugared binds + +mkSelectorBinds ticks pat val_expr + | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A) + = return (v, [(v, val_expr)]) + + | is_flat_prod_lpat pat' -- Special case (B) + = do { let pat_ty = hsLPatType pat' + ; val_var <- newSysLocalDsNoLP pat_ty + + ; let mk_bind tick bndr_var + -- (mk_bind sv bv) generates bv = case sv of { pat -> bv } + -- Remember, 'pat' binds 'bv' + = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat' + (Var bndr_var) + (Var bndr_var) -- Neat hack + -- Neat hack: since 'pat' can't fail, the + -- "fail-expr" passed to matchSimply is not + -- used. But it /is/ used for its type, and for + -- that bndr_var is just the ticket. + ; return (bndr_var, mkOptTickBox tick rhs_expr) } + + ; binds <- zipWithM mk_bind ticks' binders + ; return ( val_var, (val_var, val_expr) : binds) } + + | otherwise -- General case (C) + = do { tuple_var <- newSysLocalDs tuple_ty + ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat') + ; tuple_expr <- matchSimply val_expr PatBindRhs pat + local_tuple error_expr + ; let mk_tup_bind tick binder + = (binder, mkOptTickBox tick $ + mkTupleSelector1 local_binders binder + tuple_var (Var tuple_var)) + tup_binds = zipWith mk_tup_bind ticks' binders + ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) } + where + pat' = strip_bangs pat + -- Strip the bangs before looking for case (A) or (B) + -- The incoming pattern may well have a bang on it + + binders = collectPatBinders pat' + ticks' = ticks ++ repeat [] + + local_binders = map localiseId binders -- See Note [Localise pattern binders] + local_tuple = mkBigCoreVarTup1 binders + tuple_ty = exprType local_tuple + +strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p) +-- Remove outermost bangs and parens +strip_bangs (L _ (ParPat _ p)) = strip_bangs p +strip_bangs (L _ (BangPat _ p)) = strip_bangs p +strip_bangs lp = lp + +is_flat_prod_lpat :: LPat (GhcPass p) -> Bool +is_flat_prod_lpat = is_flat_prod_pat . unLoc + +is_flat_prod_pat :: Pat (GhcPass p) -> Bool +is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p +is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps +is_flat_prod_pat (ConPatOut { pat_con = L _ pcon + , pat_args = ps}) + | RealDataCon con <- pcon + , isProductTyCon (dataConTyCon con) + = all is_triv_lpat (hsConPatArgs ps) +is_flat_prod_pat _ = False + +is_triv_lpat :: LPat (GhcPass p) -> Bool +is_triv_lpat = is_triv_pat . unLoc + +is_triv_pat :: Pat (GhcPass p) -> Bool +is_triv_pat (VarPat {}) = True +is_triv_pat (WildPat{}) = True +is_triv_pat (ParPat _ p) = is_triv_lpat p +is_triv_pat _ = False + + +{- ********************************************************************* +* * + Creating big tuples and their types for full Haskell expressions. + They work over *Ids*, and create tuples replete with their types, + which is whey they are not in GHC.Hs.Utils. +* * +********************************************************************* -} + +mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc +mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed +mkLHsPatTup [lpat] = lpat +mkLHsPatTup lpats = L (getLoc (head lpats)) $ + mkVanillaTuplePat lpats Boxed + +mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc +-- A vanilla tuple pattern simply gets its type from its sub-patterns +mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box + +-- The Big equivalents for the source tuple expressions +mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc +mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids) + +mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc +mkBigLHsTupId = mkChunkified mkLHsTupleExpr + +-- The Big equivalents for the source tuple patterns +mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc +mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs) + +mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc +mkBigLHsPatTupId = mkChunkified mkLHsPatTup + +{- +************************************************************************ +* * + Code for pattern-matching and other failures +* * +************************************************************************ + +Generally, we handle pattern matching failure like this: let-bind a +fail-variable, and use that variable if the thing fails: +\begin{verbatim} + let fail.33 = error "Help" + in + case x of + p1 -> ... + p2 -> fail.33 + p3 -> fail.33 + p4 -> ... +\end{verbatim} +Then +\begin{itemize} +\item +If the case can't fail, then there'll be no mention of @fail.33@, and the +simplifier will later discard it. + +\item +If it can fail in only one way, then the simplifier will inline it. + +\item +Only if it is used more than once will the let-binding remain. +\end{itemize} + +There's a problem when the result of the case expression is of +unboxed type. Then the type of @fail.33@ is unboxed too, and +there is every chance that someone will change the let into a case: +\begin{verbatim} + case error "Help" of + fail.33 -> case .... +\end{verbatim} + +which is of course utterly wrong. Rather than drop the condition that +only boxed types can be let-bound, we just turn the fail into a function +for the primitive case: +\begin{verbatim} + let fail.33 :: Void -> Int# + fail.33 = \_ -> error "Help" + in + case x of + p1 -> ... + p2 -> fail.33 void + p3 -> fail.33 void + p4 -> ... +\end{verbatim} + +Now @fail.33@ is a function, so it can be let-bound. + +We would *like* to use join points here; in fact, these "fail variables" are +paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as +CPS functions - i.e. they take "join points" as parameters. It's not impossible +to imagine extending our type system to allow passing join points around (very +carefully), but we certainly don't support it now. + +99.99% of the time, the fail variables wind up as join points in short order +anyway, and the Void# doesn't do much harm. +-} + +mkFailurePair :: CoreExpr -- Result type of the whole case expression + -> DsM (CoreBind, -- Binds the newly-created fail variable + -- to \ _ -> expression + CoreExpr) -- Fail variable applied to realWorld# +-- See Note [Failure thunks and CPR] +mkFailurePair expr + = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkVisFunTy` ty) + ; fail_fun_arg <- newSysLocalDs voidPrimTy + ; let real_arg = setOneShotLambda fail_fun_arg + ; return (NonRec fail_fun_var (Lam real_arg expr), + App (Var fail_fun_var) (Var voidPrimId)) } + where + ty = exprType expr + +{- +Note [Failure thunks and CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(This note predates join points as formal entities (hence the quotation marks). +We can't use actual join points here (see above); if we did, this would also +solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR +join points] in WorkWrap.) + +When we make a failure point we ensure that it +does not look like a thunk. Example: + + let fail = \rw -> error "urk" + in case x of + [] -> fail realWorld# + (y:ys) -> case ys of + [] -> fail realWorld# + (z:zs) -> (y,z) + +Reason: we know that a failure point is always a "join point" and is +entered at most once. Adding a dummy 'realWorld' token argument makes +it clear that sharing is not an issue. And that in turn makes it more +CPR-friendly. This matters a lot: if you don't get it right, you lose +the tail call property. For example, see #3403. + + +************************************************************************ +* * + Ticks +* * +********************************************************************* -} + +mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr +mkOptTickBox = flip (foldr Tick) + +mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr +mkBinaryTickBox ixT ixF e = do + uq <- newUnique + this_mod <- getModule + let bndr1 = mkSysLocal (fsLit "t1") uq boolTy + let + falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId) + trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId) + -- + return $ Case e bndr1 boolTy + [ (DataAlt falseDataCon, [], falseBox) + , (DataAlt trueDataCon, [], trueBox) + ] + + + +-- ******************************************************************* + +{- Note [decideBangHood] +~~~~~~~~~~~~~~~~~~~~~~~~ +With -XStrict we may make /outermost/ patterns more strict. +E.g. + let (Just x) = e in ... + ==> + let !(Just x) = e in ... +and + f x = e + ==> + f !x = e + +This adjustment is done by decideBangHood, + + * Just before constructing an EqnInfo, in GHC.HsToCore.Match + (matchWrapper and matchSinglePat) + + * When desugaring a pattern-binding in GHC.HsToCore.Binds.dsHsBind + +Note that it is /not/ done recursively. See the -XStrict +spec in the user manual. + +Specifically: + ~pat => pat -- when -XStrict (even if pat = ~pat') + !pat => !pat -- always + pat => !pat -- when -XStrict + pat => pat -- otherwise +-} + + +-- | Use -XStrict to add a ! or remove a ~ +-- See Note [decideBangHood] +decideBangHood :: DynFlags + -> LPat GhcTc -- ^ Original pattern + -> LPat GhcTc -- Pattern with bang if necessary +decideBangHood dflags lpat + | not (xopt LangExt.Strict dflags) + = lpat + | otherwise -- -XStrict + = go lpat + where + go lp@(L l p) + = case p of + ParPat x p -> L l (ParPat x (go p)) + LazyPat _ lp' -> lp' + BangPat _ _ -> lp + _ -> L l (BangPat noExtField lp) + +-- | Unconditionally make a 'Pat' strict. +addBang :: LPat GhcTc -- ^ Original pattern + -> LPat GhcTc -- ^ Banged pattern +addBang = go + where + go lp@(L l p) + = case p of + ParPat x p -> L l (ParPat x (go p)) + LazyPat _ lp' -> L l (BangPat noExtField lp') + -- Should we bring the extension value over? + BangPat _ _ -> lp + _ -> L l (BangPat noExtField lp) + +isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) + +-- Returns Just {..} if we're sure that the expression is True +-- I.e. * 'True' datacon +-- * 'otherwise' Id +-- * Trivial wappings of these +-- The arguments to Just are any HsTicks that we have found, +-- because we still want to tick then, even it they are always evaluated. +isTrueLHsExpr (L _ (HsVar _ (L _ v))) + | v `hasKey` otherwiseIdKey + || v `hasKey` getUnique trueDataConId + = Just return + -- trueDataConId doesn't have the same unique as trueDataCon +isTrueLHsExpr (L _ (HsConLikeOut _ con)) + | con `hasKey` getUnique trueDataCon = Just return +isTrueLHsExpr (L _ (HsTick _ tickish e)) + | Just ticks <- isTrueLHsExpr e + = Just (\x -> do wrapped <- ticks x + return (Tick tickish wrapped)) + -- This encodes that the result is constant True for Hpc tick purposes; + -- which is specifically what isTrueLHsExpr is trying to find out. +isTrueLHsExpr (L _ (HsBinTick _ ixT _ e)) + | Just ticks <- isTrueLHsExpr e + = Just (\x -> do e <- ticks x + this_mod <- getModule + return (Tick (HpcTick this_mod ixT) e)) + +isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e +isTrueLHsExpr _ = Nothing diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 10986769ed..943b5a1562 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -25,7 +25,7 @@ import BooleanFormula import Class ( FunDep ) import CoreUtils ( exprType ) import ConLike ( conLikeName ) -import Desugar ( deSugarExpr ) +import GHC.HsToCore ( deSugarExpr ) import FieldLabel import GHC.Hs import HscTypes diff --git a/compiler/GHC/Iface/Utils.hs b/compiler/GHC/Iface/Utils.hs index c90cfe13a5..bf221bd88c 100644 --- a/compiler/GHC/Iface/Utils.hs +++ b/compiler/GHC/Iface/Utils.hs @@ -68,7 +68,7 @@ import GHC.Iface.Load import GHC.CoreToIface import FlagChecker -import DsUsage ( mkUsageInfo, mkUsedNames, mkDependencies ) +import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies ) import Id import Annotations import CoreSyn @@ -109,7 +109,7 @@ import Fingerprint import Exception import UniqSet import Packages -import ExtractDocs +import GHC.HsToCore.Docs import Control.Monad import Data.Function diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 333e3c3f5a..70b466ef2b 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -704,7 +704,7 @@ postProcessStmtsForApplicativeDo ctxt stmts ; let is_do_expr | DoExpr <- ctxt = True | otherwise = False -- don't apply the transformation inside TH brackets, because - -- DsMeta does not handle ApplicativeDo. + -- GHC.HsToCore.Quote does not handle ApplicativeDo. ; in_th_bracket <- isBrackStage <$> getStage ; if ado_is_on && is_do_expr && not in_th_bracket then do { traceRn "ppsfa" (ppr stmts) @@ -984,7 +984,7 @@ lookupStmtNamePoly ctxt name -- | Is this a context where we respect RebindableSyntax? -- but ListComp are never rebindable --- Neither is ArrowExpr, which has its own desugarer in DsArrows +-- Neither is ArrowExpr, which has its own desugarer in GHC.HsToCore.Arrows rebindableContext :: HsStmtContext GhcRn -> Bool rebindableContext ctxt = case ctxt of ListComp -> False @@ -1511,7 +1511,7 @@ ApplicativeDo touches a few phases in the compiler: * Desugarer: Any do-block which contains applicative statements is desugared as outlined above, to use the Applicative combinators. - Relevant module: DsExpr + Relevant module: GHC.HsToCore.Expr -} diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 808cd21803..7c9077d516 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -1594,8 +1594,9 @@ The hsSyn representation of parsed source explicitly contains all the original parens, as written in the source. When a Template Haskell (TH) splice is evaluated, the original splice is first -renamed and type checked and then finally converted to core in DsMeta. This core -is then run in the TH engine, and the result comes back as a TH AST. +renamed and type checked and then finally converted to core in +GHC.HsToCore.Quote. This core is then run in the TH engine, and the result +comes back as a TH AST. In the process, all parens are stripped out, as they are not needed. @@ -1996,11 +1997,11 @@ with the following parts: Due to the two forall quantifiers and constraint contexts (either of which might be empty), pattern synonym type signatures are treated -specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and +specially in `GHC.HsToCore.Quote`, `GHC.ThToHs`, and `typecheck/TcSplice.hs`: (a) When desugaring a pattern synonym from HsSyn to TH.Dec in - `deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.: + `GHC.HsToCore.Quote`, we represent its *full* type signature in TH, i.e.: ForallT univs reqs (ForallT exis provs ty) (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t) diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index 046b208983..bff97a1887 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -1327,7 +1327,7 @@ if an Id has defaultInlinePragma it means the user didn't specify anything. If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding. -If you want to know where InlinePragmas take effect: Look in DsBinds.makeCorePair +If you want to know where InlinePragmas take effect: Look in GHC.HsToCore.Binds.makeCorePair Note [inl_inline and inl_act] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1526,7 +1526,7 @@ competesWith (ActiveAfter _ a) (ActiveAfter _ b) = a >= b {- Note [Competing activations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Sometimes a RULE and an inlining may compete, or two RULES. -See Note [Rules and inlining/other rules] in Desugar. +See Note [Rules and inlining/other rules] in GHC.HsToCore. We say that act1 "competes with" act2 iff act1 is active in the phase when act2 *becomes* active @@ -1615,7 +1615,7 @@ integralFractionalLit neg i = FL { fl_text = SourceText (show i), fl_value = fromInteger i } -- Comparison operations are needed when grouping literals --- for compiling pattern-matching (module MatchLit) +-- for compiling pattern-matching (module GHC.HsToCore.Match.Literal) instance Eq IntegralLit where (==) = (==) `on` il_value diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index fcc5fcfed0..4c429ea61d 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -1310,7 +1310,8 @@ dataConInstOrigArgTys -- equality constraints or dicts -> [Type] -- For vanilla datacons, it's all quite straightforward --- But for the call in MatchCon, we really do want just the value args +-- But for the call in GHC.HsToCore.Match.Constructor, we really do want just +-- the value args dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs}) inst_tys diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs index 9efc512997..ff32323fd9 100644 --- a/compiler/basicTypes/Id.hs +++ b/compiler/basicTypes/Id.hs @@ -565,7 +565,7 @@ lambdas if it is not applied to enough arguments; e.g. (#14561) bad :: forall (a :: TYPE r). a -> a bad = unsafeCoerce# -The desugar has special magic to detect such cases: DsExpr.badUseOfLevPolyPrimop. +The desugar has special magic to detect such cases: GHC.HsToCore.Expr.badUseOfLevPolyPrimop. And we want that magic to apply to levity-polymorphic compulsory-inline things. The easiest way to do this is for hasNoBinding to return True of all things that have compulsory unfolding. Some Ids with a compulsory unfolding also diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index 34183cbeab..a0b84a6aa5 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -354,7 +354,7 @@ argument is not levity-polymorphic (which it can't be, according to Note [Levity polymorphism invariants] in CoreSyn), and it's saturated, no levity-polymorphic code ends up in the code generator. The saturation condition is effectively checked by Note [Detecting forced eta expansion] -in DsExpr. +in GHC.HsToCore.Expr. However, if we make a *wrapper* for a newtype, we get into trouble. The saturation condition is no longer checked (because hasNoBinding @@ -1510,7 +1510,7 @@ Note [seqId magic] a) Its fixity is set in GHC.Iface.Load.ghcPrimIface b) It has quite a bit of desugaring magic. - See DsUtils.hs Note [Desugaring seq (1)] and (2) and (3) + See GHC.HsToCore.Utils.hs Note [Desugaring seq (1)] and (2) and (3) c) There is some special rule handing: Note [User-defined RULES for seq] diff --git a/compiler/basicTypes/NameCache.hs b/compiler/basicTypes/NameCache.hs index 3bbdf745c8..8b63e3d687 100644 --- a/compiler/basicTypes/NameCache.hs +++ b/compiler/basicTypes/NameCache.hs @@ -66,8 +66,8 @@ are two reasons why we might look up an Orig RdrName for built-in syntax, turned into an Orig RdrName. * Template Haskell turns a BuiltInSyntax Name into a TH.NameG - (DsMeta.globalVar), and parses a NameG into an Orig RdrName - (Convert.thRdrName). So, e.g. $(do { reify '(,); ... }) will + (GHC.HsToCore.Quote.globalVar), and parses a NameG into an Orig RdrName + (GHC.ThToHs.thRdrName). So, e.g. $(do { reify '(,); ... }) will go this route (#8954). -} diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs index c516799bef..2c775353be 100644 --- a/compiler/coreSyn/CoreOpt.hs +++ b/compiler/coreSyn/CoreOpt.hs @@ -669,7 +669,7 @@ When the user writes `RULES map coerce = coerce` as a rule, the rule will only ever match if simpleOptExpr replaces coerce by its unfolding on the LHS, because that is the core that the rule matching engine will find. So do that for everything that has a compulsory -unfolding. Also see Note [Desugaring coerce as cast] in Desugar. +unfolding. Also see Note [Desugaring coerce as cast] in GHC.HsToCore. However, we don't want to inline 'seq', which happens to also have a compulsory unfolding, so we only do this unfolding only for things diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs index 669026c641..ec55f688a9 100644 --- a/compiler/coreSyn/CoreSubst.hs +++ b/compiler/coreSyn/CoreSubst.hs @@ -739,7 +739,7 @@ and abstractions to get back to an Id, with getIdFromTrivialExpr. Second, we have to ensure that we never try to substitute a literal for an Id in a breakpoint. We ensure this by never storing an Id with -an unlifted type in a Breakpoint - see Coverage.mkTickish. +an unlifted type in a Breakpoint - see GHC.HsToCore.Coverage.mkTickish. Breakpoints can't handle free variables with unlifted types anyway. -} diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs index ffc9c6867e..72c7e5211a 100644 --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -560,7 +560,7 @@ For example \(r::RuntimeRep). \(a::TYPE r). \(x::a). e is illegal because x's type has kind (TYPE r), which has 'r' free. -See Note [Levity polymorphism checking] in DsMonad to see where these +See Note [Levity polymorphism checking] in GHC.HsToCore.Monad to see where these invariants are established for user-written code. Note [CoreSyn let goal] diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs deleted file mode 100644 index 3e124b5829..0000000000 --- a/compiler/deSugar/Coverage.hs +++ /dev/null @@ -1,1368 +0,0 @@ -{- -(c) Galois, 2006 -(c) University of Glasgow, 2007 --} - -{-# LANGUAGE NondecreasingIndentation, RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveFunctor #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module Coverage (addTicksToBinds, hpcInitCode) where - -import GhcPrelude as Prelude - -import qualified GHC.Runtime.Interpreter as GHCi -import GHCi.RemoteTypes -import Data.Array -import GHC.ByteCode.Types -import GHC.Stack.CCS -import Type -import GHC.Hs -import Module -import Outputable -import DynFlags -import ConLike -import Control.Monad -import SrcLoc -import ErrUtils -import NameSet hiding (FreeVars) -import Name -import Bag -import CostCentre -import CostCentreState -import CoreSyn -import Id -import VarSet -import Data.List -import FastString -import HscTypes -import TyCon -import BasicTypes -import MonadUtils -import Maybes -import GHC.Cmm.CLabel -import Util - -import Data.Time -import System.Directory - -import Trace.Hpc.Mix -import Trace.Hpc.Util - -import qualified Data.ByteString as BS -import Data.Map (Map) -import qualified Data.Map as Map - -{- -************************************************************************ -* * -* The main function: addTicksToBinds -* * -************************************************************************ --} - -addTicksToBinds - :: HscEnv - -> Module - -> ModLocation -- ... off the current module - -> NameSet -- Exported Ids. When we call addTicksToBinds, - -- isExportedId doesn't work yet (the desugarer - -- hasn't set it), so we have to work from this set. - -> [TyCon] -- Type constructor in this module - -> LHsBinds GhcTc - -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks) - -addTicksToBinds hsc_env mod mod_loc exports tyCons binds - | let dflags = hsc_dflags hsc_env - passes = coveragePasses dflags, not (null passes), - Just orig_file <- ml_hs_file mod_loc, - not ("boot" `isSuffixOf` orig_file) = do - - let orig_file2 = guessSourceFile binds orig_file - - tickPass tickish (binds,st) = - let env = TTE - { fileName = mkFastString orig_file2 - , declPath = [] - , tte_dflags = dflags - , exports = exports - , inlines = emptyVarSet - , inScope = emptyVarSet - , blackList = Map.fromList - [ (getSrcSpan (tyConName tyCon),()) - | tyCon <- tyCons ] - , density = mkDensity tickish dflags - , this_mod = mod - , tickishType = tickish - } - (binds',_,st') = unTM (addTickLHsBinds binds) env st - in (binds', st') - - initState = TT { tickBoxCount = 0 - , mixEntries = [] - , ccIndices = newCostCentreState - } - - (binds1,st) = foldr tickPass (binds, initState) passes - - let tickCount = tickBoxCount st - entries = reverse $ mixEntries st - hashNo <- writeMixEntries dflags mod tickCount entries orig_file2 - modBreaks <- mkModBreaks hsc_env mod tickCount entries - - dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" FormatHaskell - (pprLHsBinds binds1) - - return (binds1, HpcInfo tickCount hashNo, Just modBreaks) - - | otherwise = return (binds, emptyHpcInfo False, Nothing) - -guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath -guessSourceFile binds orig_file = - -- Try look for a file generated from a .hsc file to a - -- .hs file, by peeking ahead. - let top_pos = catMaybes $ foldr (\ (L pos _) rest -> - srcSpanFileName_maybe pos : rest) [] binds - in - case top_pos of - (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name - -> unpackFS file_name - _ -> orig_file - - -mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks -mkModBreaks hsc_env mod count entries - | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do - breakArray <- GHCi.newBreakArray hsc_env (length entries) - ccs <- mkCCSArray hsc_env mod count entries - let - locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ] - varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ] - declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ] - return emptyModBreaks - { modBreaks_flags = breakArray - , modBreaks_locs = locsTicks - , modBreaks_vars = varsTicks - , modBreaks_decls = declsTicks - , modBreaks_ccs = ccs - } - | otherwise = return emptyModBreaks - -mkCCSArray - :: HscEnv -> Module -> Int -> [MixEntry_] - -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre)) -mkCCSArray hsc_env modul count entries = do - if interpreterProfiled dflags - then do - let module_str = moduleNameString (moduleName modul) - costcentres <- GHCi.mkCostCentres hsc_env module_str (map mk_one entries) - return (listArray (0,count-1) costcentres) - else do - return (listArray (0,-1) []) - where - dflags = hsc_dflags hsc_env - mk_one (srcspan, decl_path, _, _) = (name, src) - where name = concat (intersperse "." decl_path) - src = showSDoc dflags (ppr srcspan) - - -writeMixEntries - :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int -writeMixEntries dflags mod count entries filename - | not (gopt Opt_Hpc dflags) = return 0 - | otherwise = do - let - hpc_dir = hpcDir dflags - mod_name = moduleNameString (moduleName mod) - - hpc_mod_dir - | moduleUnitId mod == mainUnitId = hpc_dir - | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod) - - tabStop = 8 -- counts as a normal char in GHC's - -- location ranges. - - createDirectoryIfMissing True hpc_mod_dir - modTime <- getModificationUTCTime filename - let entries' = [ (hpcPos, box) - | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ] - when (entries' `lengthIsNot` count) $ do - panic "the number of .mix entries are inconsistent" - let hashNo = mixHash filename modTime tabStop entries' - mixCreate hpc_mod_dir mod_name - $ Mix filename modTime (toHash hashNo) tabStop entries' - return hashNo - - --- ----------------------------------------------------------------------------- --- TickDensity: where to insert ticks - -data TickDensity - = TickForCoverage -- for Hpc - | TickForBreakPoints -- for GHCi - | TickAllFunctions -- for -prof-auto-all - | TickTopFunctions -- for -prof-auto-top - | TickExportedFunctions -- for -prof-auto-exported - | TickCallSites -- for stack tracing - deriving Eq - -mkDensity :: TickishType -> DynFlags -> TickDensity -mkDensity tickish dflags = case tickish of - HpcTicks -> TickForCoverage - SourceNotes -> TickForCoverage - Breakpoints -> TickForBreakPoints - ProfNotes -> - case profAuto dflags of - ProfAutoAll -> TickAllFunctions - ProfAutoTop -> TickTopFunctions - ProfAutoExports -> TickExportedFunctions - ProfAutoCalls -> TickCallSites - _other -> panic "mkDensity" - --- | Decide whether to add a tick to a binding or not. -shouldTickBind :: TickDensity - -> Bool -- top level? - -> Bool -- exported? - -> Bool -- simple pat bind? - -> Bool -- INLINE pragma? - -> Bool - -shouldTickBind density top_lev exported _simple_pat inline - = case density of - TickForBreakPoints -> False - -- we never add breakpoints to simple pattern bindings - -- (there's always a tick on the rhs anyway). - TickAllFunctions -> not inline - TickTopFunctions -> top_lev && not inline - TickExportedFunctions -> exported && not inline - TickForCoverage -> True - TickCallSites -> False - -shouldTickPatBind :: TickDensity -> Bool -> Bool -shouldTickPatBind density top_lev - = case density of - TickForBreakPoints -> False - TickAllFunctions -> True - TickTopFunctions -> top_lev - TickExportedFunctions -> False - TickForCoverage -> False - TickCallSites -> False - --- ----------------------------------------------------------------------------- --- Adding ticks to bindings - -addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc) -addTickLHsBinds = mapBagM addTickLHsBind - -addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) -addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, - abs_exports = abs_exports })) = do - withEnv add_exports $ do - withEnv add_inlines $ do - binds' <- addTickLHsBinds binds - return $ L pos $ bind { abs_binds = binds' } - where - -- in AbsBinds, the Id on each binding is not the actual top-level - -- Id that we are defining, they are related by the abs_exports - -- field of AbsBinds. So if we're doing TickExportedFunctions we need - -- to add the local Ids to the set of exported Names so that we know to - -- tick the right bindings. - add_exports env = - env{ exports = exports env `extendNameSetList` - [ idName mid - | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports - , idName pid `elemNameSet` (exports env) ] } - - -- See Note [inline sccs] - add_inlines env = - env{ inlines = inlines env `extendVarSetList` - [ mid - | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports - , isInlinePragma (idInlinePragma pid) ] } - -addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do - let name = getOccString id - decl_path <- getPathEntry - density <- getDensity - - inline_ids <- liftM inlines getEnv - -- See Note [inline sccs] - let inline = isInlinePragma (idInlinePragma id) - || id `elemVarSet` inline_ids - - -- See Note [inline sccs] - tickish <- tickishType `liftM` getEnv - if inline && tickish == ProfNotes then return (L pos funBind) else do - - (fvs, mg) <- - getFreeVars $ - addPathEntry name $ - addTickMatchGroup False (fun_matches funBind) - - case mg of - MG {} -> return () - _ -> panic "addTickLHsBind" - - blackListed <- isBlackListed pos - exported_names <- liftM exports getEnv - - -- We don't want to generate code for blacklisted positions - -- We don't want redundant ticks on simple pattern bindings - -- We don't want to tick non-exported bindings in TickExportedFunctions - let simple = isSimplePatBind funBind - toplev = null decl_path - exported = idName id `elemNameSet` exported_names - - tick <- if not blackListed && - shouldTickBind density toplev exported simple inline - then - bindTick density name pos fvs - else - return Nothing - - let mbCons = maybe Prelude.id (:) - return $ L pos $ funBind { fun_matches = mg - , fun_tick = tick `mbCons` fun_tick funBind } - - where - -- a binding is a simple pattern binding if it is a funbind with - -- zero patterns - isSimplePatBind :: HsBind GhcTc -> Bool - isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0 - --- TODO: Revisit this -addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs - , pat_rhs = rhs }))) = do - - let simplePatId = isSimplePat lhs - - -- TODO: better name for rhs's for non-simple patterns? - let name = maybe "(...)" getOccString simplePatId - - (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs - let pat' = pat { pat_rhs = rhs'} - - -- Should create ticks here? - density <- getDensity - decl_path <- getPathEntry - let top_lev = null decl_path - if not (shouldTickPatBind density top_lev) - then return (L pos pat') - else do - - let mbCons = maybe id (:) - - let (initial_rhs_ticks, initial_patvar_tickss) = pat_ticks pat' - - -- Allocate the ticks - - rhs_tick <- bindTick density name pos fvs - let rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks - - patvar_tickss <- case simplePatId of - Just{} -> return initial_patvar_tickss - Nothing -> do - let patvars = map getOccString (collectPatBinders lhs) - patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars - return - (zipWith mbCons patvar_ticks - (initial_patvar_tickss ++ repeat [])) - - return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) } - --- Only internal stuff, not from source, uses VarBind, so we ignore it. -addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind -addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind -addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind - -bindTick - :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id)) -bindTick density name pos fvs = do - decl_path <- getPathEntry - let - toplev = null decl_path - count_entries = toplev || density == TickAllFunctions - top_only = density /= TickAllFunctions - box_label = if toplev then TopLevelBox [name] - else LocalBox (decl_path ++ [name]) - -- - allocATickBox box_label count_entries top_only pos fvs - - --- Note [inline sccs] --- --- The reason not to add ticks to INLINE functions is that this is --- sometimes handy for avoiding adding a tick to a particular function --- (see #6131) --- --- So for now we do not add any ticks to INLINE functions at all. --- --- We used to use isAnyInlinePragma to figure out whether to avoid adding --- ticks for this purpose. However, #12962 indicates that this contradicts --- the documentation on profiling (which only mentions INLINE pragmas). --- So now we're more careful about what we avoid adding ticks to. - --- ----------------------------------------------------------------------------- --- Decorate an LHsExpr with ticks - --- selectively add ticks to interesting expressions -addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExpr e@(L pos e0) = do - d <- getDensity - case d of - TickForBreakPoints | isGoodBreakExpr e0 -> tick_it - TickForCoverage -> tick_it - TickCallSites | isCallSite e0 -> tick_it - _other -> dont_tick_it - where - tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 - dont_tick_it = addTickLHsExprNever e - --- Add a tick to an expression which is the RHS of an equation or a binding. --- We always consider these to be breakpoints, unless the expression is a 'let' --- (because the body will definitely have a tick somewhere). ToDo: perhaps --- we should treat 'case' and 'if' the same way? -addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprRHS e@(L pos e0) = do - d <- getDensity - case d of - TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it - | otherwise -> tick_it - TickForCoverage -> tick_it - TickCallSites | isCallSite e0 -> tick_it - _other -> dont_tick_it - where - tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 - dont_tick_it = addTickLHsExprNever e - --- The inner expression of an evaluation context: --- let binds in [], ( [] ) --- we never tick these if we're doing HPC, but otherwise --- we treat it like an ordinary expression. -addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprEvalInner e = do - d <- getDensity - case d of - TickForCoverage -> addTickLHsExprNever e - _otherwise -> addTickLHsExpr e - --- | A let body is treated differently from addTickLHsExprEvalInner --- above with TickForBreakPoints, because for breakpoints we always --- want to tick the body, even if it is not a redex. See test --- break012. This gives the user the opportunity to inspect the --- values of the let-bound variables. -addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprLetBody e@(L pos e0) = do - d <- getDensity - case d of - TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it - | otherwise -> tick_it - _other -> addTickLHsExprEvalInner e - where - tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 - dont_tick_it = addTickLHsExprNever e - --- version of addTick that does not actually add a tick, --- because the scope of this tick is completely subsumed by --- another. -addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprNever (L pos e0) = do - e1 <- addTickHsExpr e0 - return $ L pos e1 - --- general heuristic: expressions which do not denote values are good --- break points -isGoodBreakExpr :: HsExpr GhcTc -> Bool -isGoodBreakExpr (HsApp {}) = True -isGoodBreakExpr (HsAppType {}) = True -isGoodBreakExpr (OpApp {}) = True -isGoodBreakExpr _other = False - -isCallSite :: HsExpr GhcTc -> Bool -isCallSite HsApp{} = True -isCallSite HsAppType{} = True -isCallSite OpApp{} = True -isCallSite _ = False - -addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprOptAlt oneOfMany (L pos e0) - = ifDensity TickForCoverage - (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0) - (addTickLHsExpr (L pos e0)) - -addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addBinTickLHsExpr boxLabel (L pos e0) - = ifDensity TickForCoverage - (allocBinTickBox boxLabel pos $ addTickHsExpr e0) - (addTickLHsExpr (L pos e0)) - - --- ----------------------------------------------------------------------------- --- Decorate the body of an HsExpr with ticks. --- (Whether to put a tick around the whole expression was already decided, --- in the addTickLHsExpr family of functions.) - -addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) -addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e -addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" -addTickHsExpr e@(HsConLikeOut _ con) - | Just id <- conLikeWrapId_maybe con = do freeVar id; return e -addTickHsExpr e@(HsIPVar {}) = return e -addTickHsExpr e@(HsOverLit {}) = return e -addTickHsExpr e@(HsOverLabel{}) = return e -addTickHsExpr e@(HsLit {}) = return e -addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x) - (addTickMatchGroup True matchgroup) -addTickHsExpr (HsLamCase x mgs) = liftM (HsLamCase x) - (addTickMatchGroup True mgs) -addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1) - (addTickLHsExpr e2) -addTickHsExpr (HsAppType x e ty) = liftM3 HsAppType (return x) - (addTickLHsExprNever e) - (return ty) - -addTickHsExpr (OpApp fix e1 e2 e3) = - liftM4 OpApp - (return fix) - (addTickLHsExpr e1) - (addTickLHsExprNever e2) - (addTickLHsExpr e3) -addTickHsExpr (NegApp x e neg) = - liftM2 (NegApp x) - (addTickLHsExpr e) - (addTickSyntaxExpr hpcSrcSpan neg) -addTickHsExpr (HsPar x e) = - liftM (HsPar x) (addTickLHsExprEvalInner e) -addTickHsExpr (SectionL x e1 e2) = - liftM2 (SectionL x) - (addTickLHsExpr e1) - (addTickLHsExprNever e2) -addTickHsExpr (SectionR x e1 e2) = - liftM2 (SectionR x) - (addTickLHsExprNever e1) - (addTickLHsExpr e2) -addTickHsExpr (ExplicitTuple x es boxity) = - liftM2 (ExplicitTuple x) - (mapM addTickTupArg es) - (return boxity) -addTickHsExpr (ExplicitSum ty tag arity e) = do - e' <- addTickLHsExpr e - return (ExplicitSum ty tag arity e') -addTickHsExpr (HsCase x e mgs) = - liftM2 (HsCase x) - (addTickLHsExpr e) -- not an EvalInner; e might not necessarily - -- be evaluated. - (addTickMatchGroup False mgs) -addTickHsExpr (HsIf x cnd e1 e2 e3) = - liftM3 (HsIf x cnd) - (addBinTickLHsExpr (BinBox CondBinBox) e1) - (addTickLHsExprOptAlt True e2) - (addTickLHsExprOptAlt True e3) -addTickHsExpr (HsMultiIf ty alts) - = do { let isOneOfMany = case alts of [_] -> False; _ -> True - ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts - ; return $ HsMultiIf ty alts' } -addTickHsExpr (HsLet x (L l binds) e) = - bindLocals (collectLocalBinders binds) $ - liftM2 (HsLet x . L l) - (addTickHsLocalBinds binds) -- to think about: !patterns. - (addTickLHsExprLetBody e) -addTickHsExpr (HsDo srcloc cxt (L l stmts)) - = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) - ; return (HsDo srcloc cxt (L l stmts')) } - where - forQual = case cxt of - ListComp -> Just $ BinBox QualBinBox - _ -> Nothing -addTickHsExpr (ExplicitList ty wit es) = - liftM3 ExplicitList - (return ty) - (addTickWit wit) - (mapM (addTickLHsExpr) es) - where addTickWit Nothing = return Nothing - addTickWit (Just fln) - = do fln' <- addTickSyntaxExpr hpcSrcSpan fln - return (Just fln') - -addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e - -addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds }) - = do { rec_binds' <- addTickHsRecordBinds rec_binds - ; return (expr { rcon_flds = rec_binds' }) } - -addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds }) - = do { e' <- addTickLHsExpr e - ; flds' <- mapM addTickHsRecField flds - ; return (expr { rupd_expr = e', rupd_flds = flds' }) } - -addTickHsExpr (ExprWithTySig x e ty) = - liftM3 ExprWithTySig - (return x) - (addTickLHsExprNever e) -- No need to tick the inner expression - -- for expressions with signatures - (return ty) -addTickHsExpr (ArithSeq ty wit arith_seq) = - liftM3 ArithSeq - (return ty) - (addTickWit wit) - (addTickArithSeqInfo arith_seq) - where addTickWit Nothing = return Nothing - addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl - return (Just fl') - --- We might encounter existing ticks (multiple Coverage passes) -addTickHsExpr (HsTick x t e) = - liftM (HsTick x t) (addTickLHsExprNever e) -addTickHsExpr (HsBinTick x t0 t1 e) = - liftM (HsBinTick x t0 t1) (addTickLHsExprNever e) - -addTickHsExpr (HsPragE _ HsPragTick{} (L pos e0)) = do - e2 <- allocTickBox (ExpBox False) False False pos $ - addTickHsExpr e0 - return $ unLoc e2 -addTickHsExpr (HsPragE x p e) = - liftM (HsPragE x p) (addTickLHsExpr e) -addTickHsExpr e@(HsBracket {}) = return e -addTickHsExpr e@(HsTcBracketOut {}) = return e -addTickHsExpr e@(HsRnBracketOut {}) = return e -addTickHsExpr e@(HsSpliceE {}) = return e -addTickHsExpr (HsProc x pat cmdtop) = - liftM2 (HsProc x) - (addTickLPat pat) - (liftL (addTickHsCmdTop) cmdtop) -addTickHsExpr (XExpr (HsWrap w e)) = - liftM XExpr $ - liftM (HsWrap w) - (addTickHsExpr e) -- Explicitly no tick on inside - --- Others should never happen in expression content. -addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) - -addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc) -addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e - ; return (L l (Present x e')) } -addTickTupArg (L l (Missing ty)) = return (L l (Missing ty)) -addTickTupArg (L _ (XTupArg nec)) = noExtCon nec - - -addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc) - -> TM (MatchGroup GhcTc (LHsExpr GhcTc)) -addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do - let isOneOfMany = matchesOneOfMany matches - matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches - return $ mg { mg_alts = L l matches' } -addTickMatchGroup _ (XMatchGroup nec) = noExtCon nec - -addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc) - -> TM (Match GhcTc (LHsExpr GhcTc)) -addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats - , m_grhss = gRHSs }) = - bindLocals (collectPatsBinders pats) $ do - gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs - return $ match { m_grhss = gRHSs' } -addTickMatch _ _ (XMatch nec) = noExtCon nec - -addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) - -> TM (GRHSs GhcTc (LHsExpr GhcTc)) -addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do - bindLocals binders $ do - local_binds' <- addTickHsLocalBinds local_binds - guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded - return $ GRHSs x guarded' (L l local_binds') - where - binders = collectLocalBinders local_binds -addTickGRHSs _ _ (XGRHSs nec) = noExtCon nec - -addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc) - -> TM (GRHS GhcTc (LHsExpr GhcTc)) -addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do - (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts - (addTickGRHSBody isOneOfMany isLambda expr) - return $ GRHS x stmts' expr' -addTickGRHS _ _ (XGRHS nec) = noExtCon nec - -addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do - d <- getDensity - case d of - TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr - TickAllFunctions | isLambda -> - addPathEntry "\\" $ - allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $ - addTickHsExpr e0 - _otherwise -> - addTickLHsExprRHS expr - -addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] - -> TM [ExprLStmt GhcTc] -addTickLStmts isGuard stmts = do - (stmts, _) <- addTickLStmts' isGuard stmts (return ()) - return stmts - -addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a - -> TM ([ExprLStmt GhcTc], a) -addTickLStmts' isGuard lstmts res - = bindLocals (collectLStmtsBinders lstmts) $ - do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts - ; a <- res - ; return (lstmts', a) } - -addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc) - -> TM (Stmt GhcTc (LHsExpr GhcTc)) -addTickStmt _isGuard (LastStmt x e noret ret) = do - liftM3 (LastStmt x) - (addTickLHsExpr e) - (pure noret) - (addTickSyntaxExpr hpcSrcSpan ret) -addTickStmt _isGuard (BindStmt x pat e bind fail) = do - liftM4 (BindStmt x) - (addTickLPat pat) - (addTickLHsExprRHS e) - (addTickSyntaxExpr hpcSrcSpan bind) - (addTickSyntaxExpr hpcSrcSpan fail) -addTickStmt isGuard (BodyStmt x e bind' guard') = do - liftM3 (BodyStmt x) - (addTick isGuard e) - (addTickSyntaxExpr hpcSrcSpan bind') - (addTickSyntaxExpr hpcSrcSpan guard') -addTickStmt _isGuard (LetStmt x (L l binds)) = do - liftM (LetStmt x . L l) - (addTickHsLocalBinds binds) -addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do - liftM3 (ParStmt x) - (mapM (addTickStmtAndBinders isGuard) pairs) - (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr)) - (addTickSyntaxExpr hpcSrcSpan bindExpr) -addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do - args' <- mapM (addTickApplicativeArg isGuard) args - return (ApplicativeStmt body_ty args' mb_join) - -addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts - , trS_by = by, trS_using = using - , trS_ret = returnExpr, trS_bind = bindExpr - , trS_fmap = liftMExpr }) = do - t_s <- addTickLStmts isGuard stmts - t_y <- fmapMaybeM addTickLHsExprRHS by - t_u <- addTickLHsExprRHS using - t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr - t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr - t_m <- fmap unLoc (addTickLHsExpr (L hpcSrcSpan liftMExpr)) - return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u - , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m } - -addTickStmt isGuard stmt@(RecStmt {}) - = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt) - ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) - ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) - ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) - ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' - , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } - -addTickStmt _ (XStmtLR nec) = noExtCon nec - -addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e - | otherwise = addTickLHsExprRHS e - -addTickApplicativeArg - :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) - -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -addTickApplicativeArg isGuard (op, arg) = - liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) - where - addTickArg (ApplicativeArgOne x pat expr isBody fail) = - (ApplicativeArgOne x) - <$> addTickLPat pat - <*> addTickLHsExpr expr - <*> pure isBody - <*> addTickSyntaxExpr hpcSrcSpan fail - addTickArg (ApplicativeArgMany x stmts ret pat) = - (ApplicativeArgMany x) - <$> addTickLStmts isGuard stmts - <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret)) - <*> addTickLPat pat - addTickArg (XApplicativeArg nec) = noExtCon nec - -addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc - -> TM (ParStmtBlock GhcTc GhcTc) -addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) = - liftM3 (ParStmtBlock x) - (addTickLStmts isGuard stmts) - (return ids) - (addTickSyntaxExpr hpcSrcSpan returnExpr) -addTickStmtAndBinders _ (XParStmtBlock nec) = noExtCon nec - -addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc) -addTickHsLocalBinds (HsValBinds x binds) = - liftM (HsValBinds x) - (addTickHsValBinds binds) -addTickHsLocalBinds (HsIPBinds x binds) = - liftM (HsIPBinds x) - (addTickHsIPBinds binds) -addTickHsLocalBinds (EmptyLocalBinds x) = return (EmptyLocalBinds x) -addTickHsLocalBinds (XHsLocalBindsLR x) = return (XHsLocalBindsLR x) - -addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a) - -> TM (HsValBindsLR GhcTc (GhcPass b)) -addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do - b <- liftM2 NValBinds - (mapM (\ (rec,binds') -> - liftM2 (,) - (return rec) - (addTickLHsBinds binds')) - binds) - (return sigs) - return $ XValBindsLR b -addTickHsValBinds _ = panic "addTickHsValBinds" - -addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc) -addTickHsIPBinds (IPBinds dictbinds ipbinds) = - liftM2 IPBinds - (return dictbinds) - (mapM (liftL (addTickIPBind)) ipbinds) -addTickHsIPBinds (XHsIPBinds x) = return (XHsIPBinds x) - -addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc) -addTickIPBind (IPBind x nm e) = - liftM2 (IPBind x) - (return nm) - (addTickLHsExpr e) -addTickIPBind (XIPBind x) = return (XIPBind x) - --- There is no location here, so we might need to use a context location?? -addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) -addTickSyntaxExpr pos syn@(SyntaxExprTc { syn_expr = x }) = do - x' <- fmap unLoc (addTickLHsExpr (L pos x)) - return $ syn { syn_expr = x' } -addTickSyntaxExpr _ NoSyntaxExprTc = return NoSyntaxExprTc - --- we do not walk into patterns. -addTickLPat :: LPat GhcTc -> TM (LPat GhcTc) -addTickLPat pat = return pat - -addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc) -addTickHsCmdTop (HsCmdTop x cmd) = - liftM2 HsCmdTop - (return x) - (addTickLHsCmd cmd) -addTickHsCmdTop (XCmdTop nec) = noExtCon nec - -addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc) -addTickLHsCmd (L pos c0) = do - c1 <- addTickHsCmd c0 - return $ L pos c1 - -addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc) -addTickHsCmd (HsCmdLam x matchgroup) = - liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup) -addTickHsCmd (HsCmdApp x c e) = - liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e) -{- -addTickHsCmd (OpApp e1 c2 fix c3) = - liftM4 OpApp - (addTickLHsExpr e1) - (addTickLHsCmd c2) - (return fix) - (addTickLHsCmd c3) --} -addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e) -addTickHsCmd (HsCmdCase x e mgs) = - liftM2 (HsCmdCase x) - (addTickLHsExpr e) - (addTickCmdMatchGroup mgs) -addTickHsCmd (HsCmdIf x cnd e1 c2 c3) = - liftM3 (HsCmdIf x cnd) - (addBinTickLHsExpr (BinBox CondBinBox) e1) - (addTickLHsCmd c2) - (addTickLHsCmd c3) -addTickHsCmd (HsCmdLet x (L l binds) c) = - bindLocals (collectLocalBinders binds) $ - liftM2 (HsCmdLet x . L l) - (addTickHsLocalBinds binds) -- to think about: !patterns. - (addTickLHsCmd c) -addTickHsCmd (HsCmdDo srcloc (L l stmts)) - = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) - ; return (HsCmdDo srcloc (L l stmts')) } - -addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) = - liftM5 HsCmdArrApp - (return arr_ty) - (addTickLHsExpr e1) - (addTickLHsExpr e2) - (return ty1) - (return lr) -addTickHsCmd (HsCmdArrForm x e f fix cmdtop) = - liftM4 (HsCmdArrForm x) - (addTickLHsExpr e) - (return f) - (return fix) - (mapM (liftL (addTickHsCmdTop)) cmdtop) - -addTickHsCmd (XCmd (HsWrap w cmd)) = - liftM XCmd $ - liftM (HsWrap w) (addTickHsCmd cmd) - --- Others should never happen in a command context. ---addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) - -addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc) - -> TM (MatchGroup GhcTc (LHsCmd GhcTc)) -addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do - matches' <- mapM (liftL addTickCmdMatch) matches - return $ mg { mg_alts = L l matches' } -addTickCmdMatchGroup (XMatchGroup nec) = noExtCon nec - -addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) -addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) = - bindLocals (collectPatsBinders pats) $ do - gRHSs' <- addTickCmdGRHSs gRHSs - return $ match { m_grhss = gRHSs' } -addTickCmdMatch (XMatch nec) = noExtCon nec - -addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) -addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do - bindLocals binders $ do - local_binds' <- addTickHsLocalBinds local_binds - guarded' <- mapM (liftL addTickCmdGRHS) guarded - return $ GRHSs x guarded' (L l local_binds') - where - binders = collectLocalBinders local_binds -addTickCmdGRHSs (XGRHSs nec) = noExtCon nec - -addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)) --- The *guards* are *not* Cmds, although the body is --- C.f. addTickGRHS for the BinBox stuff -addTickCmdGRHS (GRHS x stmts cmd) - = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) - stmts (addTickLHsCmd cmd) - ; return $ GRHS x stmts' expr' } -addTickCmdGRHS (XGRHS nec) = noExtCon nec - -addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)] - -> TM [LStmt GhcTc (LHsCmd GhcTc)] -addTickLCmdStmts stmts = do - (stmts, _) <- addTickLCmdStmts' stmts (return ()) - return stmts - -addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a - -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a) -addTickLCmdStmts' lstmts res - = bindLocals binders $ do - lstmts' <- mapM (liftL addTickCmdStmt) lstmts - a <- res - return (lstmts', a) - where - binders = collectLStmtsBinders lstmts - -addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc)) -addTickCmdStmt (BindStmt x pat c bind fail) = do - liftM4 (BindStmt x) - (addTickLPat pat) - (addTickLHsCmd c) - (return bind) - (return fail) -addTickCmdStmt (LastStmt x c noret ret) = do - liftM3 (LastStmt x) - (addTickLHsCmd c) - (pure noret) - (addTickSyntaxExpr hpcSrcSpan ret) -addTickCmdStmt (BodyStmt x c bind' guard') = do - liftM3 (BodyStmt x) - (addTickLHsCmd c) - (addTickSyntaxExpr hpcSrcSpan bind') - (addTickSyntaxExpr hpcSrcSpan guard') -addTickCmdStmt (LetStmt x (L l binds)) = do - liftM (LetStmt x . L l) - (addTickHsLocalBinds binds) -addTickCmdStmt stmt@(RecStmt {}) - = do { stmts' <- addTickLCmdStmts (recS_stmts stmt) - ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) - ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) - ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) - ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' - , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } -addTickCmdStmt ApplicativeStmt{} = - panic "ToDo: addTickCmdStmt ApplicativeLastStmt" -addTickCmdStmt (XStmtLR nec) = - noExtCon nec - --- Others should never happen in a command context. -addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt) - -addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc) -addTickHsRecordBinds (HsRecFields fields dd) - = do { fields' <- mapM addTickHsRecField fields - ; return (HsRecFields fields' dd) } - -addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc) - -> TM (LHsRecField' id (LHsExpr GhcTc)) -addTickHsRecField (L l (HsRecField id expr pun)) - = do { expr' <- addTickLHsExpr expr - ; return (L l (HsRecField id expr' pun)) } - - -addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc) -addTickArithSeqInfo (From e1) = - liftM From - (addTickLHsExpr e1) -addTickArithSeqInfo (FromThen e1 e2) = - liftM2 FromThen - (addTickLHsExpr e1) - (addTickLHsExpr e2) -addTickArithSeqInfo (FromTo e1 e2) = - liftM2 FromTo - (addTickLHsExpr e1) - (addTickLHsExpr e2) -addTickArithSeqInfo (FromThenTo e1 e2 e3) = - liftM3 FromThenTo - (addTickLHsExpr e1) - (addTickLHsExpr e2) - (addTickLHsExpr e3) - -data TickTransState = TT { tickBoxCount:: Int - , mixEntries :: [MixEntry_] - , ccIndices :: CostCentreState - } - -data TickTransEnv = TTE { fileName :: FastString - , density :: TickDensity - , tte_dflags :: DynFlags - , exports :: NameSet - , inlines :: VarSet - , declPath :: [String] - , inScope :: VarSet - , blackList :: Map SrcSpan () - , this_mod :: Module - , tickishType :: TickishType - } - --- deriving Show - -data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes - deriving (Eq) - -coveragePasses :: DynFlags -> [TickishType] -coveragePasses dflags = - ifa (hscTarget dflags == HscInterpreted) Breakpoints $ - ifa (gopt Opt_Hpc dflags) HpcTicks $ - ifa (gopt Opt_SccProfilingOn dflags && - profAuto dflags /= NoProfAuto) ProfNotes $ - ifa (debugLevel dflags > 0) SourceNotes [] - where ifa f x xs | f = x:xs - | otherwise = xs - --- | Tickishs that only make sense when their source code location --- refers to the current file. This might not always be true due to --- LINE pragmas in the code - which would confuse at least HPC. -tickSameFileOnly :: TickishType -> Bool -tickSameFileOnly HpcTicks = True -tickSameFileOnly _other = False - -type FreeVars = OccEnv Id -noFVs :: FreeVars -noFVs = emptyOccEnv - --- Note [freevars] --- For breakpoints we want to collect the free variables of an --- expression for pinning on the HsTick. We don't want to collect --- *all* free variables though: in particular there's no point pinning --- on free variables that are will otherwise be in scope at the GHCi --- prompt, which means all top-level bindings. Unfortunately detecting --- top-level bindings isn't easy (collectHsBindsBinders on the top-level --- bindings doesn't do it), so we keep track of a set of "in-scope" --- variables in addition to the free variables, and the former is used --- to filter additions to the latter. This gives us complete control --- over what free variables we track. - -newtype TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) } - deriving (Functor) - -- a combination of a state monad (TickTransState) and a writer - -- monad (FreeVars). - -instance Applicative TM where - pure a = TM $ \ _env st -> (a,noFVs,st) - (<*>) = ap - -instance Monad TM where - (TM m) >>= k = TM $ \ env st -> - case m env st of - (r1,fv1,st1) -> - case unTM (k r1) env st1 of - (r2,fv2,st2) -> - (r2, fv1 `plusOccEnv` fv2, st2) - -instance HasDynFlags TM where - getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st) - --- | Get the next HPC cost centre index for a given centre name -getCCIndexM :: FastString -> TM CostCentreIndex -getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $ - ccIndices st - in (idx, noFVs, st { ccIndices = is' }) - -getState :: TM TickTransState -getState = TM $ \ _ st -> (st, noFVs, st) - -setState :: (TickTransState -> TickTransState) -> TM () -setState f = TM $ \ _ st -> ((), noFVs, f st) - -getEnv :: TM TickTransEnv -getEnv = TM $ \ env st -> (env, noFVs, st) - -withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a -withEnv f (TM m) = TM $ \ env st -> - case m (f env) st of - (a, fvs, st') -> (a, fvs, st') - -getDensity :: TM TickDensity -getDensity = TM $ \env st -> (density env, noFVs, st) - -ifDensity :: TickDensity -> TM a -> TM a -> TM a -ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el - -getFreeVars :: TM a -> TM (FreeVars, a) -getFreeVars (TM m) - = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st') - -freeVar :: Id -> TM () -freeVar id = TM $ \ env st -> - if id `elemVarSet` inScope env - then ((), unitOccEnv (nameOccName (idName id)) id, st) - else ((), noFVs, st) - -addPathEntry :: String -> TM a -> TM a -addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] }) - -getPathEntry :: TM [String] -getPathEntry = declPath `liftM` getEnv - -getFileName :: TM FastString -getFileName = fileName `liftM` getEnv - -isGoodSrcSpan' :: SrcSpan -> Bool -isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos -isGoodSrcSpan' (UnhelpfulSpan _) = False - -isGoodTickSrcSpan :: SrcSpan -> TM Bool -isGoodTickSrcSpan pos = do - file_name <- getFileName - tickish <- tickishType `liftM` getEnv - let need_same_file = tickSameFileOnly tickish - same_file = Just file_name == srcSpanFileName_maybe pos - return (isGoodSrcSpan' pos && (not need_same_file || same_file)) - -ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a -ifGoodTickSrcSpan pos then_code else_code = do - good <- isGoodTickSrcSpan pos - if good then then_code else else_code - -bindLocals :: [Id] -> TM a -> TM a -bindLocals new_ids (TM m) - = TM $ \ env st -> - case m env{ inScope = inScope env `extendVarSetList` new_ids } st of - (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st') - where occs = [ nameOccName (idName id) | id <- new_ids ] - -isBlackListed :: SrcSpan -> TM Bool -isBlackListed pos = TM $ \ env st -> - case Map.lookup pos (blackList env) of - Nothing -> (False,noFVs,st) - Just () -> (True,noFVs,st) - --- the tick application inherits the source position of its --- expression argument to support nested box allocations -allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc) - -> TM (LHsExpr GhcTc) -allocTickBox boxLabel countEntries topOnly pos m = - ifGoodTickSrcSpan pos (do - (fvs, e) <- getFreeVars m - env <- getEnv - tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) - return (L pos (HsTick noExtField tickish (L pos e))) - ) (do - e <- m - return (L pos e) - ) - --- 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)) -allocATickBox boxLabel countEntries topOnly pos fvs = - ifGoodTickSrcSpan pos (do - let - mydecl_path = case boxLabel of - TopLevelBox x -> x - LocalBox xs -> xs - _ -> panic "allocATickBox" - tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path - return (Just tickish) - ) (return Nothing) - - -mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String] - -> TM (Tickish Id) -mkTickish boxLabel countEntries topOnly pos fvs decl_path = do - - let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs - -- unlifted types cause two problems here: - -- * we can't bind them at the GHCi prompt - -- (bindLocalsAtBreakpoint already filters them out), - -- * the simplifier might try to substitute a literal for - -- the Id, and we can't handle that. - - me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel) - - cc_name | topOnly = head decl_path - | otherwise = concat (intersperse "." decl_path) - - dflags <- getDynFlags - env <- getEnv - case tickishType env of - HpcTicks -> do - c <- liftM tickBoxCount getState - setState $ \st -> st { tickBoxCount = c + 1 - , mixEntries = me : mixEntries st } - return $ HpcTick (this_mod env) c - - ProfNotes -> do - let nm = mkFastString cc_name - flavour <- HpcCC <$> getCCIndexM nm - let cc = mkUserCC nm (this_mod env) pos flavour - count = countEntries && gopt Opt_ProfCountEntries dflags - return $ ProfNote cc count True{-scopes-} - - Breakpoints -> do - c <- liftM tickBoxCount getState - setState $ \st -> st { tickBoxCount = c + 1 - , mixEntries = me:mixEntries st } - return $ Breakpoint c ids - - SourceNotes | RealSrcSpan pos' <- pos -> - return $ SourceNote pos' cc_name - - _otherwise -> panic "mkTickish: bad source span!" - - -allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc) - -> TM (LHsExpr GhcTc) -allocBinTickBox boxLabel pos m = do - env <- getEnv - case tickishType env of - HpcTicks -> do e <- liftM (L pos) m - ifGoodTickSrcSpan pos - (mkBinTickBoxHpc boxLabel pos e) - (return e) - _other -> allocTickBox (ExpBox False) False False pos m - -mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc - -> TM (LHsExpr GhcTc) -mkBinTickBoxHpc boxLabel pos e = - TM $ \ env st -> - let meT = (pos,declPath env, [],boxLabel True) - meF = (pos,declPath env, [],boxLabel False) - meE = (pos,declPath env, [],ExpBox False) - c = tickBoxCount st - mes = mixEntries st - in - ( L pos $ HsTick noExtField (HpcTick (this_mod env) c) - $ L pos $ HsBinTick noExtField (c+1) (c+2) e - -- notice that F and T are reversed, - -- because we are building the list in - -- reverse... - , noFVs - , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes} - ) - -mkHpcPos :: SrcSpan -> HpcPos -mkHpcPos pos@(RealSrcSpan s) - | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s, - srcSpanStartCol s, - srcSpanEndLine s, - srcSpanEndCol s - 1) - -- the end column of a SrcSpan is one - -- greater than the last column of the - -- span (see SrcLoc), whereas HPC - -- expects to the column range to be - -- inclusive, hence we subtract one above. -mkHpcPos _ = panic "bad source span; expected such spans to be filtered out" - -hpcSrcSpan :: SrcSpan -hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") - -matchesOneOfMany :: [LMatch GhcTc body] -> Bool -matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 - where - matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ })) - = length grhss - matchCount (L _ (Match { m_grhss = XGRHSs nec })) - = noExtCon nec - matchCount (L _ (XMatch nec)) = noExtCon nec - -type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) - --- For the hash value, we hash everything: the file name, --- the timestamp of the original source file, the tab stop, --- and the mix entries. We cheat, and hash the show'd string. --- This hash only has to be hashed at Mix creation time, --- and is for sanity checking only. - -mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int -mixHash file tm tabstop entries = fromIntegral $ hashString - (show $ Mix file tm 0 tabstop entries) - -{- -************************************************************************ -* * -* initialisation -* * -************************************************************************ - -Each module compiled with -fhpc declares an initialisation function of -the form `hpc_init_()`, which is emitted into the _stub.c file -and annotated with __attribute__((constructor)) so that it gets -executed at startup time. - -The function's purpose is to call hs_hpc_module to register this -module with the RTS, and it looks something like this: - -static void hpc_init_Main(void) __attribute__((constructor)); -static void hpc_init_Main(void) -{extern StgWord64 _hpc_tickboxes_Main_hpc[]; - hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);} --} - -hpcInitCode :: Module -> HpcInfo -> SDoc -hpcInitCode _ (NoHpcInfo {}) = Outputable.empty -hpcInitCode this_mod (HpcInfo tickCount hashNo) - = vcat - [ text "static void hpc_init_" <> ppr this_mod - <> text "(void) __attribute__((constructor));" - , text "static void hpc_init_" <> ppr this_mod <> text "(void)" - , braces (vcat [ - text "extern StgWord64 " <> tickboxes <> - text "[]" <> semi, - text "hs_hpc_module" <> - parens (hcat (punctuate comma [ - doubleQuotes full_name_str, - int tickCount, -- really StgWord32 - int hashNo, -- really StgWord32 - tickboxes - ])) <> semi - ]) - ] - where - tickboxes = ppr (mkHpcTicksLabel $ this_mod) - - module_name = hcat (map (text.charToC) $ BS.unpack $ - bytesFS (moduleNameFS (Module.moduleName this_mod))) - package_name = hcat (map (text.charToC) $ BS.unpack $ - bytesFS (unitIdFS (moduleUnitId this_mod))) - full_name_str - | moduleUnitId this_mod == mainUnitId - = module_name - | otherwise - = package_name <> char '/' <> module_name diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs deleted file mode 100644 index bbf67cfc48..0000000000 --- a/compiler/deSugar/Desugar.hs +++ /dev/null @@ -1,545 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -The Desugarer: turning HsSyn into Core. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module Desugar ( - -- * Desugaring operations - deSugar, deSugarExpr - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import DsUsage -import DynFlags -import HscTypes -import GHC.Hs -import TcRnTypes -import TcRnMonad ( finalSafeMode, fixSafeInstances ) -import TcRnDriver ( runTcInteractive ) -import Id -import Name -import Type -import Avail -import CoreSyn -import CoreFVs ( exprsSomeFreeVarsList ) -import CoreOpt ( simpleOptPgm, simpleOptExpr ) -import PprCore -import DsMonad -import DsExpr -import DsBinds -import DsForeign -import PrelNames ( coercibleTyConKey ) -import TysPrim ( eqReprPrimTyCon ) -import Unique ( hasKey ) -import Coercion ( mkCoVarCo ) -import TysWiredIn ( coercibleDataCon ) -import DataCon ( dataConWrapId ) -import MkCore ( mkCoreLet ) -import Module -import NameSet -import NameEnv -import Rules -import BasicTypes ( Activation(.. ), competesWith, pprRuleName ) -import CoreMonad ( CoreToDo(..) ) -import CoreLint ( endPassIO ) -import VarSet -import FastString -import ErrUtils -import Outputable -import SrcLoc -import Coverage -import Util -import MonadUtils -import OrdList -import ExtractDocs - -import Data.List -import Data.IORef -import Control.Monad( when ) -import Plugins ( LoadedPlugin(..) ) - -{- -************************************************************************ -* * -* The main function: deSugar -* * -************************************************************************ --} - --- | Main entry point to the desugarer. -deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts) --- Can modify PCS by faulting in more declarations - -deSugar hsc_env - mod_loc - tcg_env@(TcGblEnv { tcg_mod = id_mod, - tcg_semantic_mod = mod, - tcg_src = hsc_src, - tcg_type_env = type_env, - tcg_imports = imports, - tcg_exports = exports, - tcg_keep = keep_var, - tcg_th_splice_used = tc_splice_used, - tcg_rdr_env = rdr_env, - tcg_fix_env = fix_env, - tcg_inst_env = inst_env, - tcg_fam_inst_env = fam_inst_env, - tcg_merged = merged, - tcg_warns = warns, - tcg_anns = anns, - tcg_binds = binds, - tcg_imp_specs = imp_specs, - tcg_dependent_files = dependent_files, - tcg_ev_binds = ev_binds, - tcg_th_foreign_files = th_foreign_files_var, - tcg_fords = fords, - tcg_rules = rules, - tcg_patsyns = patsyns, - tcg_tcs = tcs, - tcg_insts = insts, - tcg_fam_insts = fam_insts, - tcg_hpc = other_hpc_info, - tcg_complete_matches = complete_matches - }) - - = do { let dflags = hsc_dflags hsc_env - print_unqual = mkPrintUnqualified dflags rdr_env - ; withTiming dflags - (text "Desugar"<+>brackets (ppr mod)) - (const ()) $ - do { -- Desugar the program - ; let export_set = availsToNameSet exports - target = hscTarget dflags - hpcInfo = emptyHpcInfo other_hpc_info - - ; (binds_cvr, ds_hpc_info, modBreaks) - <- if not (isHsBootOrSig hsc_src) - then addTicksToBinds hsc_env mod mod_loc - export_set (typeEnvTyCons type_env) binds - else return (binds, hpcInfo, Nothing) - ; (msgs, mb_res) <- initDs hsc_env tcg_env $ - do { ds_ev_binds <- dsEvBinds ev_binds - ; core_prs <- dsTopLHsBinds binds_cvr - ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs - ; (ds_fords, foreign_prs) <- dsForeigns fords - ; ds_rules <- mapMaybeM dsRule rules - ; let hpc_init - | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info - | otherwise = empty - ; return ( ds_ev_binds - , foreign_prs `appOL` core_prs `appOL` spec_prs - , spec_rules ++ ds_rules - , ds_fords `appendStubC` hpc_init) } - - ; case mb_res of { - Nothing -> return (msgs, Nothing) ; - Just (ds_ev_binds, all_prs, all_rules, ds_fords) -> - - do { -- Add export flags to bindings - keep_alive <- readIORef keep_var - ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules - final_prs = addExportFlagsAndRules target export_set keep_alive - rules_for_locals (fromOL all_prs) - - final_pgm = combineEvBinds ds_ev_binds final_prs - -- Notice that we put the whole lot in a big Rec, even the foreign binds - -- When compiling PrelFloat, which defines data Float = F# Float# - -- we want F# to be in scope in the foreign marshalling code! - -- You might think it doesn't matter, but the simplifier brings all top-level - -- things into the in-scope set before simplifying; so we get no unfolding for F#! - - ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps - ; (ds_binds, ds_rules_for_imps) - <- simpleOptPgm dflags mod final_pgm rules_for_imps - -- The simpleOptPgm gets rid of type - -- bindings plus any stupid dead code - - ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps - - ; let used_names = mkUsedNames tcg_env - pluginModules = - map lpModule (cachedPlugins (hsc_dflags hsc_env)) - ; deps <- mkDependencies (thisInstalledUnitId (hsc_dflags hsc_env)) - (map mi_module pluginModules) tcg_env - - ; used_th <- readIORef tc_splice_used - ; dep_files <- readIORef dependent_files - ; safe_mode <- finalSafeMode dflags tcg_env - ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names - dep_files merged pluginModules - -- id_mod /= mod when we are processing an hsig, but hsigs - -- never desugared and compiled (there's no code!) - -- Consequently, this should hold for any ModGuts that make - -- past desugaring. See Note [Identity versus semantic module]. - ; MASSERT( id_mod == mod ) - - ; foreign_files <- readIORef th_foreign_files_var - - ; let (doc_hdr, decl_docs, arg_docs) = extractDocs tcg_env - - ; let mod_guts = ModGuts { - mg_module = mod, - mg_hsc_src = hsc_src, - mg_loc = mkFileSrcSpan mod_loc, - mg_exports = exports, - mg_usages = usages, - mg_deps = deps, - mg_used_th = used_th, - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_warns = warns, - mg_anns = anns, - mg_tcs = tcs, - mg_insts = fixSafeInstances safe_mode insts, - mg_fam_insts = fam_insts, - mg_inst_env = inst_env, - mg_fam_inst_env = fam_inst_env, - mg_patsyns = patsyns, - mg_rules = ds_rules_for_imps, - mg_binds = ds_binds, - mg_foreign = ds_fords, - mg_foreign_files = foreign_files, - mg_hpc_info = ds_hpc_info, - mg_modBreaks = modBreaks, - mg_safe_haskell = safe_mode, - mg_trust_pkg = imp_trust_own_pkg imports, - mg_complete_sigs = complete_matches, - mg_doc_hdr = doc_hdr, - mg_decl_docs = decl_docs, - mg_arg_docs = arg_docs - } - ; return (msgs, Just mod_guts) - }}}} - -mkFileSrcSpan :: ModLocation -> SrcSpan -mkFileSrcSpan mod_loc - = case ml_hs_file mod_loc of - Just file_path -> mkGeneralSrcSpan (mkFastString file_path) - Nothing -> interactiveSrcSpan -- Presumably - -dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule]) -dsImpSpecs imp_specs - = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs - ; let (spec_binds, spec_rules) = unzip spec_prs - ; return (concatOL spec_binds, spec_rules) } - -combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind] --- Top-level bindings can include coercion bindings, but not via superclasses --- See Note [Top-level evidence] -combineEvBinds [] val_prs - = [Rec val_prs] -combineEvBinds (NonRec b r : bs) val_prs - | isId b = combineEvBinds bs ((b,r):val_prs) - | otherwise = NonRec b r : combineEvBinds bs val_prs -combineEvBinds (Rec prs : bs) val_prs - = combineEvBinds bs (prs ++ val_prs) - -{- -Note [Top-level evidence] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Top-level evidence bindings may be mutually recursive with the top-level value -bindings, so we must put those in a Rec. But we can't put them *all* in a Rec -because the occurrence analyser doesn't take account of type/coercion variables -when computing dependencies. - -So we pull out the type/coercion variables (which are in dependency order), -and Rec the rest. --} - -deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages, Maybe CoreExpr) - -deSugarExpr hsc_env tc_expr = do { - let dflags = hsc_dflags hsc_env - - ; showPass dflags "Desugar" - - -- Do desugaring - ; (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $ - dsLExpr tc_expr - - ; case mb_core_expr of - Nothing -> return () - Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" - FormatCore (pprCoreExpr expr) - - ; return (msgs, mb_core_expr) } - -{- -************************************************************************ -* * -* Add rules and export flags to binders -* * -************************************************************************ --} - -addExportFlagsAndRules - :: HscTarget -> NameSet -> NameSet -> [CoreRule] - -> [(Id, t)] -> [(Id, t)] -addExportFlagsAndRules target exports keep_alive rules prs - = mapFst add_one prs - where - add_one bndr = add_rules name (add_export name bndr) - where - name = idName bndr - - ---------- Rules -------- - -- See Note [Attach rules to local ids] - -- NB: the binder might have some existing rules, - -- arising from specialisation pragmas - add_rules name bndr - | Just rules <- lookupNameEnv rule_base name - = bndr `addIdSpecialisations` rules - | otherwise - = bndr - rule_base = extendRuleBaseList emptyRuleBase rules - - ---------- Export flag -------- - -- See Note [Adding export flags] - add_export name bndr - | dont_discard name = setIdExported bndr - | otherwise = bndr - - dont_discard :: Name -> Bool - dont_discard name = is_exported name - || name `elemNameSet` keep_alive - - -- In interactive mode, we don't want to discard any top-level - -- entities at all (eg. do not inline them away during - -- simplification), and retain them all in the TypeEnv so they are - -- available from the command line. - -- - -- isExternalName separates the user-defined top-level names from those - -- introduced by the type checker. - is_exported :: Name -> Bool - is_exported | targetRetainsAllBindings target = isExternalName - | otherwise = (`elemNameSet` exports) - -{- -Note [Adding export flags] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Set the no-discard flag if either - a) the Id is exported - b) it's mentioned in the RHS of an orphan rule - c) it's in the keep-alive set - -It means that the binding won't be discarded EVEN if the binding -ends up being trivial (v = w) -- the simplifier would usually just -substitute w for v throughout, but we don't apply the substitution to -the rules (maybe we should?), so this substitution would make the rule -bogus. - -You might wonder why exported Ids aren't already marked as such; -it's just because the type checker is rather busy already and -I didn't want to pass in yet another mapping. - -Note [Attach rules to local ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Find the rules for locally-defined Ids; then we can attach them -to the binders in the top-level bindings - -Reason - - It makes the rules easier to look up - - It means that transformation rules and specialisations for - locally defined Ids are handled uniformly - - It keeps alive things that are referred to only from a rule - (the occurrence analyser knows about rules attached to Ids) - - It makes sure that, when we apply a rule, the free vars - of the RHS are more likely to be in scope - - The imported rules are carried in the in-scope set - which is extended on each iteration by the new wave of - local binders; any rules which aren't on the binding will - thereby get dropped - - -************************************************************************ -* * -* Desugaring transformation rules -* * -************************************************************************ --} - -dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule) -dsRule (L loc (HsRule { rd_name = name - , rd_act = rule_act - , rd_tmvs = vars - , rd_lhs = lhs - , rd_rhs = rhs })) - = putSrcSpanDs loc $ - do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars] - - ; lhs' <- unsetGOptM Opt_EnableRewriteRules $ - unsetWOptM Opt_WarnIdentities $ - dsLExpr lhs -- Note [Desugaring RULE left hand sides] - - ; rhs' <- dsLExpr rhs - ; this_mod <- getModule - - ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs' - - -- Substitute the dict bindings eagerly, - -- and take the body apart into a (f args) form - ; dflags <- getDynFlags - ; case decomposeRuleLhs dflags bndrs'' lhs'' of { - Left msg -> do { warnDs NoReason msg; return Nothing } ; - Right (final_bndrs, fn_id, args) -> do - - { let is_local = isLocalId fn_id - -- NB: isLocalId is False of implicit Ids. This is good because - -- we don't want to attach rules to the bindings of implicit Ids, - -- because they don't show up in the bindings until just before code gen - fn_name = idName fn_id - final_rhs = simpleOptExpr dflags rhs'' -- De-crap it - rule_name = snd (unLoc name) - final_bndrs_set = mkVarSet final_bndrs - arg_ids = filterOut (`elemVarSet` final_bndrs_set) $ - exprsSomeFreeVarsList isId args - - ; rule <- dsMkUserRule this_mod is_local - rule_name rule_act fn_name final_bndrs args - final_rhs - ; when (wopt Opt_WarnInlineRuleShadowing dflags) $ - warnRuleShadowing rule_name rule_act fn_id arg_ids - - ; return (Just rule) - } } } -dsRule (L _ (XRuleDecl nec)) = noExtCon nec - -warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM () --- See Note [Rules and inlining/other rules] -warnRuleShadowing rule_name rule_act fn_id arg_ids - = do { check False fn_id -- We often have multiple rules for the same Id in a - -- module. Maybe we should check that they don't overlap - -- but currently we don't - ; mapM_ (check True) arg_ids } - where - check check_rules_too lhs_id - | isLocalId lhs_id || canUnfold (idUnfolding lhs_id) - -- If imported with no unfolding, no worries - , idInlineActivation lhs_id `competesWith` rule_act - = warnDs (Reason Opt_WarnInlineRuleShadowing) - (vcat [ hang (text "Rule" <+> pprRuleName rule_name - <+> text "may never fire") - 2 (text "because" <+> quotes (ppr lhs_id) - <+> text "might inline first") - , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for" - <+> quotes (ppr lhs_id) - , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ]) - - | check_rules_too - , bad_rule : _ <- get_bad_rules lhs_id - = warnDs (Reason Opt_WarnInlineRuleShadowing) - (vcat [ hang (text "Rule" <+> pprRuleName rule_name - <+> text "may never fire") - 2 (text "because rule" <+> pprRuleName (ruleName bad_rule) - <+> text "for"<+> quotes (ppr lhs_id) - <+> text "might fire first") - , text "Probable fix: add phase [n] or [~n] to the competing rule" - , whenPprDebug (ppr bad_rule) ]) - - | otherwise - = return () - - get_bad_rules lhs_id - = [ rule | rule <- idCoreRules lhs_id - , ruleActivation rule `competesWith` rule_act ] - --- See Note [Desugaring coerce as cast] -unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr) -unfold_coerce bndrs lhs rhs = do - (bndrs', wrap) <- go bndrs - return (bndrs', wrap lhs, wrap rhs) - where - go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr) - go [] = return ([], id) - go (v:vs) - | Just (tc, [k, t1, t2]) <- splitTyConApp_maybe (idType v) - , tc `hasKey` coercibleTyConKey = do - u <- newUnique - - let ty' = mkTyConApp eqReprPrimTyCon [k, k, t1, t2] - v' = mkLocalCoVar - (mkDerivedInternalName mkRepEqOcc u (getName v)) ty' - box = Var (dataConWrapId coercibleDataCon) `mkTyApps` - [k, t1, t2] `App` - Coercion (mkCoVarCo v') - - (bndrs, wrap) <- go vs - return (v':bndrs, mkCoreLet (NonRec v box) . wrap) - | otherwise = do - (bndrs,wrap) <- go vs - return (v:bndrs, wrap) - -{- Note [Desugaring RULE left hand sides] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For the LHS of a RULE we do *not* want to desugar - [x] to build (\cn. x `c` n) -We want to leave explicit lists simply as chains -of cons's. We can achieve that slightly indirectly by -switching off EnableRewriteRules. See DsExpr.dsExplicitList. - -That keeps the desugaring of list comprehensions simple too. - -Nor do we want to warn of conversion identities on the LHS; -the rule is precisely to optimise them: - {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-} - -Note [Desugaring coerce as cast] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want the user to express a rule saying roughly “mapping a coercion over a -list can be replaced by a coercion”. But the cast operator of Core (▷) cannot -be written in Haskell. So we use `coerce` for that (#2110). The user writes - map coerce = coerce -as a RULE, and this optimizes any kind of mapped' casts away, including `map -MkNewtype`. - -For that we replace any forall'ed `c :: Coercible a b` value in a RULE by -corresponding `co :: a ~#R b` and wrap the LHS and the RHS in -`let c = MkCoercible co in ...`. This is later simplified to the desired form -by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS). -See also Note [Getting the map/coerce RULE to work] in CoreSubst. - -Note [Rules and inlining/other rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If you have - f x = ... - g x = ... - {-# RULES "rule-for-f" forall x. f (g x) = ... #-} -then there's a good chance that in a potential rule redex - ...f (g e)... -then 'f' or 'g' will inline before the rule can fire. Solution: add an -INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'. - -Note that this applies to all the free variables on the LHS, both the -main function and things in its arguments. - -We also check if there are Ids on the LHS that have competing RULES. -In the above example, suppose we had - {-# RULES "rule-for-g" forally. g [y] = ... #-} -Then "rule-for-f" and "rule-for-g" would compete. Better to add phase -control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes -active; or perhaps after "rule-for-g" has become inactive. This is checked -by 'competesWith' - -Class methods have a built-in RULE to select the method from the dictionary, -so you can't change the phase on this. That makes id very dubious to -match on class methods in RULE lhs's. See #10595. I'm not happy -about this. For example in Control.Arrow we have - -{-# RULES "compose/arr" forall f g . - (arr f) . (arr g) = arr (f . g) #-} - -and similar, which will elicit exactly these warnings, and risk never -firing. But it's not clear what to do instead. We could make the -class method rules inactive in phase 2, but that would delay when -subsequent transformations could fire. --} diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs deleted file mode 100644 index 8c1e161dc9..0000000000 --- a/compiler/deSugar/DsArrows.hs +++ /dev/null @@ -1,1270 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Desugaring arrow commands --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module DsArrows ( dsProcExpr ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Match -import DsUtils -import DsMonad - -import GHC.Hs hiding (collectPatBinders, collectPatsBinders, - collectLStmtsBinders, collectLStmtBinders, - collectStmtBinders ) -import TcHsSyn -import qualified GHC.Hs.Utils as HsUtils - --- NB: The desugarer, which straddles the source and Core worlds, sometimes --- needs to see source types (newtypes etc), and sometimes not --- So WATCH OUT; check each use of split*Ty functions. --- Sigh. This is a pain. - -import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, - dsSyntaxExpr ) - -import TcType -import Type ( splitPiTy ) -import TcEvidence -import CoreSyn -import CoreFVs -import CoreUtils -import MkCore -import DsBinds (dsHsWrapper) - -import Id -import ConLike -import TysWiredIn -import BasicTypes -import PrelNames -import Outputable -import VarSet -import SrcLoc -import ListSetOps( assocMaybe ) -import Data.List -import Util -import UniqDSet - -data DsCmdEnv = DsCmdEnv { - arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr - } - -mkCmdEnv :: CmdSyntaxTable GhcTc -> DsM ([CoreBind], DsCmdEnv) --- See Note [CmdSyntaxTable] in GHC.Hs.Expr -mkCmdEnv tc_meths - = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths - - -- NB: Some of these lookups might fail, but that's OK if the - -- symbol is never used. That's why we use Maybe first and then - -- panic. An eager panic caused trouble in typecheck/should_compile/tc192 - ; let the_arr_id = assocMaybe prs arrAName - the_compose_id = assocMaybe prs composeAName - the_first_id = assocMaybe prs firstAName - the_app_id = assocMaybe prs appAName - the_choice_id = assocMaybe prs choiceAName - the_loop_id = assocMaybe prs loopAName - - -- used as an argument in, e.g., do_premap - ; check_lev_poly 3 the_arr_id - - -- used as an argument in, e.g., dsCmdStmt/BodyStmt - ; check_lev_poly 5 the_compose_id - - -- used as an argument in, e.g., dsCmdStmt/BodyStmt - ; check_lev_poly 4 the_first_id - - -- the result of the_app_id is used as an argument in, e.g., - -- dsCmd/HsCmdArrApp/HsHigherOrderApp - ; check_lev_poly 2 the_app_id - - -- used as an argument in, e.g., HsCmdIf - ; check_lev_poly 5 the_choice_id - - -- used as an argument in, e.g., RecStmt - ; check_lev_poly 4 the_loop_id - - ; return (meth_binds, DsCmdEnv { - arr_id = Var (unmaybe the_arr_id arrAName), - compose_id = Var (unmaybe the_compose_id composeAName), - first_id = Var (unmaybe the_first_id firstAName), - app_id = Var (unmaybe the_app_id appAName), - choice_id = Var (unmaybe the_choice_id choiceAName), - loop_id = Var (unmaybe the_loop_id loopAName) - }) } - where - mk_bind (std_name, expr) - = do { rhs <- dsExpr expr - ; id <- newSysLocalDs (exprType rhs) - -- no check needed; these are functions - ; return (NonRec id rhs, (std_name, id)) } - - unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name) - unmaybe (Just id) _ = id - - -- returns the result type of a pi-type (that is, a forall or a function) - -- Note that this result type may be ill-scoped. - res_type :: Type -> Type - res_type ty = res_ty - where - (_, res_ty) = splitPiTy ty - - check_lev_poly :: Int -- arity - -> Maybe Id -> DsM () - check_lev_poly _ Nothing = return () - check_lev_poly arity (Just id) - = dsNoLevPoly (nTimes arity res_type (idType id)) - (text "In the result of the function" <+> quotes (ppr id)) - - --- arr :: forall b c. (b -> c) -> a b c -do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr -do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f] - --- (>>>) :: forall b c d. a b c -> a c d -> a b d -do_compose :: DsCmdEnv -> Type -> Type -> Type -> - CoreExpr -> CoreExpr -> CoreExpr -do_compose ids b_ty c_ty d_ty f g - = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g] - --- first :: forall b c d. a b c -> a (b,d) (c,d) -do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr -do_first ids b_ty c_ty d_ty f - = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f] - --- app :: forall b c. a (a b c, b) c -do_app :: DsCmdEnv -> Type -> Type -> CoreExpr -do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty] - --- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d --- note the swapping of d and c -do_choice :: DsCmdEnv -> Type -> Type -> Type -> - CoreExpr -> CoreExpr -> CoreExpr -do_choice ids b_ty c_ty d_ty f g - = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g] - --- loop :: forall b d c. a (b,d) (c,d) -> a b c --- note the swapping of d and c -do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr -do_loop ids b_ty c_ty d_ty f - = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f] - --- premap :: forall b c d. (b -> c) -> a c d -> a b d --- premap f g = arr f >>> g -do_premap :: DsCmdEnv -> Type -> Type -> Type -> - CoreExpr -> CoreExpr -> CoreExpr -do_premap ids b_ty c_ty d_ty f g - = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g - -mkFailExpr :: HsMatchContext GhcRn -> Type -> DsM CoreExpr -mkFailExpr ctxt ty - = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt) - --- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a -mkFstExpr :: Type -> Type -> DsM CoreExpr -mkFstExpr a_ty b_ty = do - a_var <- newSysLocalDs a_ty - b_var <- newSysLocalDs b_ty - pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty) - return (Lam pair_var - (coreCasePair pair_var a_var b_var (Var a_var))) - --- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b -mkSndExpr :: Type -> Type -> DsM CoreExpr -mkSndExpr a_ty b_ty = do - a_var <- newSysLocalDs a_ty - b_var <- newSysLocalDs b_ty - pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty) - return (Lam pair_var - (coreCasePair pair_var a_var b_var (Var b_var))) - -{- -Build case analysis of a tuple. This cannot be done in the DsM monad, -because the list of variables is typically not yet defined. --} - --- coreCaseTuple [u1..] v [x1..xn] body --- = case v of v { (x1, .., xn) -> body } --- But the matching may be nested if the tuple is very big - -coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr -coreCaseTuple uniqs scrut_var vars body - = mkTupleCase uniqs vars body scrut_var (Var scrut_var) - -coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr -coreCasePair scrut_var var1 var2 body - = Case (Var scrut_var) scrut_var (exprType body) - [(DataAlt (tupleDataCon Boxed 2), [var1, var2], body)] - -mkCorePairTy :: Type -> Type -> Type -mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2] - -mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr -mkCorePairExpr e1 e2 = mkCoreTup [e1, e2] - -mkCoreUnitExpr :: CoreExpr -mkCoreUnitExpr = mkCoreTup [] - -{- -The input is divided into a local environment, which is a flat tuple -(unless it's too big), and a stack, which is a right-nested pair. -In general, the input has the form - - ((x1,...,xn), (s1,...(sk,())...)) - -where xi are the environment values, and si the ones on the stack, -with s1 being the "top", the first one to be matched with a lambda. --} - -envStackType :: [Id] -> Type -> Type -envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty - --- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t) -splitTypeAt :: Int -> Type -> ([Type], Type) -splitTypeAt n ty - | n == 0 = ([], ty) - | otherwise = case tcTyConAppArgs ty of - [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r) - _ -> pprPanic "splitTypeAt" (ppr ty) - ----------------------------------------------- --- buildEnvStack --- --- ((x1,...,xn),stk) - -buildEnvStack :: [Id] -> Id -> CoreExpr -buildEnvStack env_ids stack_id - = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id) - ----------------------------------------------- --- matchEnvStack --- --- \ ((x1,...,xn),stk) -> body --- => --- \ pair -> --- case pair of (tup,stk) -> --- case tup of (x1,...,xn) -> --- body - -matchEnvStack :: [Id] -- x1..xn - -> Id -- stk - -> CoreExpr -- e - -> DsM CoreExpr -matchEnvStack env_ids stack_id body = do - uniqs <- newUniqueSupply - tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids) - let match_env = coreCaseTuple uniqs tup_var env_ids body - pair_id <- newSysLocalDs (mkCorePairTy (idType tup_var) (idType stack_id)) - return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env)) - ----------------------------------------------- --- matchEnv --- --- \ (x1,...,xn) -> body --- => --- \ tup -> --- case tup of (x1,...,xn) -> --- body - -matchEnv :: [Id] -- x1..xn - -> CoreExpr -- e - -> DsM CoreExpr -matchEnv env_ids body = do - uniqs <- newUniqueSupply - tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids) - return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body)) - ----------------------------------------------- --- matchVarStack --- --- case (x1, ...(xn, s)...) -> e --- => --- case z0 of (x1,z1) -> --- case zn-1 of (xn,s) -> --- e -matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr) -matchVarStack [] stack_id body = return (stack_id, body) -matchVarStack (param_id:param_ids) stack_id body = do - (tail_id, tail_code) <- matchVarStack param_ids stack_id body - pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id)) - return (pair_id, coreCasePair pair_id param_id tail_id tail_code) - -mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc -mkHsEnvStackExpr env_ids stack_id - = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id] - --- Translation of arrow abstraction - --- D; xs |-a c : () --> t' ---> c' --- -------------------------- --- D |- proc p -> c :: a t t' ---> premap (\ p -> ((xs),())) c' --- --- where (xs) is the tuple of variables bound by p - -dsProcExpr - :: LPat GhcTc - -> LHsCmdTop GhcTc - -> DsM CoreExpr -dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do - (meth_binds, meth_ids) <- mkCmdEnv ids - let locals = mkVarSet (collectPatBinders pat) - (core_cmd, _free_vars, env_ids) - <- dsfixCmd meth_ids locals unitTy cmd_ty cmd - let env_ty = mkBigCoreVarTupTy env_ids - let env_stk_ty = mkCorePairTy env_ty unitTy - let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr - fail_expr <- mkFailExpr ProcExpr env_stk_ty - var <- selectSimpleMatchVarL pat - match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr - let pat_ty = hsLPatType pat - let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty - (Lam var match_code) - core_cmd - return (mkLets meth_binds proc_code) -dsProcExpr _ _ = panic "dsProcExpr" - -{- -Translation of a command judgement of the form - - D; xs |-a c : stk --> t - -to an expression e such that - - D |- e :: a (xs, stk) t --} - -dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd GhcTc -> [Id] - -> DsM (CoreExpr, DIdSet) -dsLCmd ids local_vars stk_ty res_ty cmd env_ids - = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids - -dsCmd :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this command - -> Type -- type of the stack (right-nested tuple) - -> Type -- return type of the command - -> HsCmd GhcTc -- command to desugar - -> [Id] -- list of vars in the input to this command - -- This is typically fed back, - -- so don't pull on it too early - -> DsM (CoreExpr, -- desugared expression - DIdSet) -- subset of local vars that occur free - --- D |- fun :: a t1 t2 --- D, xs |- arg :: t1 --- ----------------------------- --- D; xs |-a fun -< arg : stk --> t2 --- --- ---> premap (\ ((xs), _stk) -> arg) fun - -dsCmd ids local_vars stack_ty res_ty - (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _) - env_ids = do - let - (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty - (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty - core_arrow <- dsLExprNoLP arrow - core_arg <- dsLExpr arg - stack_id <- newSysLocalDs stack_ty - core_make_arg <- matchEnvStack env_ids stack_id core_arg - return (do_premap ids - (envStackType env_ids stack_ty) - arg_ty - res_ty - core_make_arg - core_arrow, - exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars) - --- D, xs |- fun :: a t1 t2 --- D, xs |- arg :: t1 --- ------------------------------ --- D; xs |-a fun -<< arg : stk --> t2 --- --- ---> premap (\ ((xs), _stk) -> (fun, arg)) app - -dsCmd ids local_vars stack_ty res_ty - (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _) - env_ids = do - let - (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty - (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty - - core_arrow <- dsLExpr arrow - core_arg <- dsLExpr arg - stack_id <- newSysLocalDs stack_ty - core_make_pair <- matchEnvStack env_ids stack_id - (mkCorePairExpr core_arrow core_arg) - - return (do_premap ids - (envStackType env_ids stack_ty) - (mkCorePairTy arrow_ty arg_ty) - res_ty - core_make_pair - (do_app ids arg_ty res_ty), - (exprsFreeIdsDSet [core_arrow, core_arg]) - `uniqDSetIntersectUniqSet` local_vars) - --- D; ys |-a cmd : (t,stk) --> t' --- D, xs |- exp :: t --- ------------------------ --- D; xs |-a cmd exp : stk --> t' --- --- ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd - -dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do - core_arg <- dsLExpr arg - let - arg_ty = exprType core_arg - stack_ty' = mkCorePairTy arg_ty stack_ty - (core_cmd, free_vars, env_ids') - <- dsfixCmd ids local_vars stack_ty' res_ty cmd - stack_id <- newSysLocalDs stack_ty - arg_id <- newSysLocalDsNoLP arg_ty - -- push the argument expression onto the stack - let - stack' = mkCorePairExpr (Var arg_id) (Var stack_id) - core_body = bindNonRec arg_id core_arg - (mkCorePairExpr (mkBigCoreVarTup env_ids') stack') - - -- match the environment and stack against the input - core_map <- matchEnvStack env_ids stack_id core_body - return (do_premap ids - (envStackType env_ids stack_ty) - (envStackType env_ids' stack_ty') - res_ty - core_map - core_cmd, - free_vars `unionDVarSet` - (exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars)) - --- D; ys |-a cmd : stk t' --- ----------------------------------------------- --- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t' --- --- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd - -dsCmd ids local_vars stack_ty res_ty - (HsCmdLam _ (MG { mg_alts - = (L _ [L _ (Match { m_pats = pats - , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })]) })) - env_ids = do - let pat_vars = mkVarSet (collectPatsBinders pats) - let - local_vars' = pat_vars `unionVarSet` local_vars - (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty - (core_body, free_vars, env_ids') - <- dsfixCmd ids local_vars' stack_ty' res_ty body - param_ids <- mapM newSysLocalDsNoLP pat_tys - stack_id' <- newSysLocalDs stack_ty' - - -- the expression is built from the inside out, so the actions - -- are presented in reverse order - - let - -- build a new environment, plus what's left of the stack - core_expr = buildEnvStack env_ids' stack_id' - in_ty = envStackType env_ids stack_ty - in_ty' = envStackType env_ids' stack_ty' - - fail_expr <- mkFailExpr LambdaExpr in_ty' - -- match the patterns against the parameters - match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr - fail_expr - -- match the parameters against the top of the old stack - (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code - -- match the old environment and stack against the input - select_code <- matchEnvStack env_ids stack_id param_code - return (do_premap ids in_ty in_ty' res_ty select_code core_body, - free_vars `uniqDSetMinusUniqSet` pat_vars) - -dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids - = dsLCmd ids local_vars stack_ty res_ty cmd env_ids - --- D, xs |- e :: Bool --- D; xs1 |-a c1 : stk --> t --- D; xs2 |-a c2 : stk --> t --- ---------------------------------------- --- D; xs |-a if e then c1 else c2 : stk --> t --- --- ---> premap (\ ((xs),stk) -> --- if e then Left ((xs1),stk) else Right ((xs2),stk)) --- (c1 ||| c2) - -dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd) - env_ids = do - core_cond <- dsLExpr cond - (core_then, fvs_then, then_ids) - <- dsfixCmd ids local_vars stack_ty res_ty then_cmd - (core_else, fvs_else, else_ids) - <- dsfixCmd ids local_vars stack_ty res_ty else_cmd - stack_id <- newSysLocalDs stack_ty - either_con <- dsLookupTyCon eitherTyConName - left_con <- dsLookupDataCon leftDataConName - right_con <- dsLookupDataCon rightDataConName - - let mk_left_expr ty1 ty2 e = mkCoreConApps left_con [Type ty1,Type ty2, e] - mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1,Type ty2, e] - - in_ty = envStackType env_ids stack_ty - then_ty = envStackType then_ids stack_ty - else_ty = envStackType else_ids stack_ty - sum_ty = mkTyConApp either_con [then_ty, else_ty] - fvs_cond = exprFreeIdsDSet core_cond - `uniqDSetIntersectUniqSet` local_vars - - core_left = mk_left_expr then_ty else_ty - (buildEnvStack then_ids stack_id) - core_right = mk_right_expr then_ty else_ty - (buildEnvStack else_ids stack_id) - - core_if <- case mb_fun of - NoSyntaxExprTc -> matchEnvStack env_ids stack_id $ - mkIfThenElse core_cond core_left core_right - _ -> do { fun_apps <- dsSyntaxExpr mb_fun - [core_cond, core_left, core_right] - ; matchEnvStack env_ids stack_id fun_apps } - - return (do_premap ids in_ty sum_ty res_ty - core_if - (do_choice ids then_ty else_ty res_ty core_then core_else), - fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else) - -{- -Case commands are treated in much the same way as if commands -(see above) except that there are more alternatives. For example - - case e of { p1 -> c1; p2 -> c2; p3 -> c3 } - -is translated to - - premap (\ ((xs)*ts) -> case e of - p1 -> (Left (Left (xs1)*ts)) - p2 -> Left ((Right (xs2)*ts)) - p3 -> Right ((xs3)*ts)) - ((c1 ||| c2) ||| c3) - -The idea is to extract the commands from the case, build a balanced tree -of choices, and replace the commands with expressions that build tagged -tuples, obtaining a case expression that can be desugared normally. -To build all this, we use triples describing segments of the list of -case bodies, containing the following fields: - * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put - into the case replacing the commands - * a sum type that is the common type of these expressions, and also the - input type of the arrow - * a CoreExpr for an arrow built by combining the translated command - bodies with |||. --} - -dsCmd ids local_vars stack_ty res_ty - (HsCmdCase _ exp (MG { mg_alts = L l matches - , mg_ext = MatchGroupTc arg_tys _ - , mg_origin = origin })) - env_ids = do - stack_id <- newSysLocalDs stack_ty - - -- Extract and desugar the leaf commands in the case, building tuple - -- expressions that will (after tagging) replace these leaves - - let - leaves = concatMap leavesMatch matches - make_branch (leaf, bound_vars) = do - (core_leaf, _fvs, leaf_ids) - <- dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty - res_ty leaf - return ([mkHsEnvStackExpr leaf_ids stack_id], - envStackType leaf_ids stack_ty, - core_leaf) - - branches <- mapM make_branch leaves - either_con <- dsLookupTyCon eitherTyConName - left_con <- dsLookupDataCon leftDataConName - right_con <- dsLookupDataCon rightDataConName - let - left_id = HsConLikeOut noExtField (RealDataCon left_con) - right_id = HsConLikeOut noExtField (RealDataCon right_con) - left_expr ty1 ty2 e = noLoc $ HsApp noExtField - (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e - right_expr ty1 ty2 e = noLoc $ HsApp noExtField - (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e - - -- Prefix each tuple with a distinct series of Left's and Right's, - -- in a balanced way, keeping track of the types. - - merge_branches (builds1, in_ty1, core_exp1) - (builds2, in_ty2, core_exp2) - = (map (left_expr in_ty1 in_ty2) builds1 ++ - map (right_expr in_ty1 in_ty2) builds2, - mkTyConApp either_con [in_ty1, in_ty2], - do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2) - (leaves', sum_ty, core_choices) = foldb merge_branches branches - - -- Replace the commands in the case with these tagged tuples, - -- yielding a HsExpr Id we can feed to dsExpr. - - (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches - in_ty = envStackType env_ids stack_ty - - core_body <- dsExpr (HsCase noExtField exp - (MG { mg_alts = L l matches' - , mg_ext = MatchGroupTc arg_tys sum_ty - , mg_origin = origin })) - -- Note that we replace the HsCase result type by sum_ty, - -- which is the type of matches' - - core_matches <- matchEnvStack env_ids stack_id core_body - return (do_premap ids in_ty sum_ty res_ty core_matches core_choices, - exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars) - --- D; ys |-a cmd : stk --> t --- ---------------------------------- --- D; xs |-a let binds in cmd : stk --> t --- --- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c - -dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body) - env_ids = do - let - defined_vars = mkVarSet (collectLocalBinders binds) - local_vars' = defined_vars `unionVarSet` local_vars - - (core_body, _free_vars, env_ids') - <- dsfixCmd ids local_vars' stack_ty res_ty body - stack_id <- newSysLocalDs stack_ty - -- build a new environment, plus the stack, using the let bindings - core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id) - -- match the old environment and stack against the input - core_map <- matchEnvStack env_ids stack_id core_binds - return (do_premap ids - (envStackType env_ids stack_ty) - (envStackType env_ids' stack_ty) - res_ty - core_map - core_body, - exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars) - --- D; xs |-a ss : t --- ---------------------------------- --- D; xs |-a do { ss } : () --> t --- --- ---> premap (\ (env,stk) -> env) c - -dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty - (L loc stmts)) - env_ids = do - putSrcSpanDs loc $ - dsNoLevPoly stmts_ty - (text "In the do-command:" <+> ppr do_block) - (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids - let env_ty = mkBigCoreVarTupTy env_ids - core_fst <- mkFstExpr env_ty stack_ty - return (do_premap ids - (mkCorePairTy env_ty stack_ty) - env_ty - res_ty - core_fst - core_stmts, - env_ids') - --- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t --- D; xs |-a ci :: stki --> ti --- ----------------------------------- --- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn - -dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do - let env_ty = mkBigCoreVarTupTy env_ids - core_op <- dsLExpr op - (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args - return (mkApps (App core_op (Type env_ty)) core_args, - unionDVarSets fv_sets) - -dsCmd ids local_vars stack_ty res_ty (XCmd (HsWrap wrap cmd)) env_ids = do - (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids - core_wrap <- dsHsWrapper wrap - return (core_wrap core_cmd, env_ids') - -dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) - --- D; ys |-a c : stk --> t (ys <= xs) --- --------------------- --- D; xs |-a c : stk --> t ---> premap (\ ((xs),stk) -> ((ys),stk)) c - -dsTrimCmdArg - :: IdSet -- set of local vars available to this command - -> [Id] -- list of vars in the input to this command - -> LHsCmdTop GhcTc -- command argument to desugar - -> DsM (CoreExpr, -- desugared expression - DIdSet) -- subset of local vars that occur free -dsTrimCmdArg local_vars env_ids - (L _ (HsCmdTop - (CmdTopTc stack_ty cmd_ty ids) cmd )) = do - (meth_binds, meth_ids) <- mkCmdEnv ids - (core_cmd, free_vars, env_ids') - <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd - stack_id <- newSysLocalDs stack_ty - trim_code - <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id) - let - in_ty = envStackType env_ids stack_ty - in_ty' = envStackType env_ids' stack_ty - arg_code = if env_ids' == env_ids then core_cmd else - do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd - return (mkLets meth_binds arg_code, free_vars) -dsTrimCmdArg _ _ _ = panic "dsTrimCmdArg" - --- Given D; xs |-a c : stk --> t, builds c with xs fed back. --- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk)) - -dsfixCmd - :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this command - -> Type -- type of the stack (right-nested tuple) - -> Type -- return type of the command - -> LHsCmd GhcTc -- command to desugar - -> DsM (CoreExpr, -- desugared expression - DIdSet, -- subset of local vars that occur free - [Id]) -- the same local vars as a list, fed back -dsfixCmd ids local_vars stk_ty cmd_ty cmd - = do { putSrcSpanDs (getLoc cmd) $ dsNoLevPoly cmd_ty - (text "When desugaring the command:" <+> ppr cmd) - ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) } - --- Feed back the list of local variables actually used a command, --- for use as the input tuple of the generated arrow. - -trimInput - :: ([Id] -> DsM (CoreExpr, DIdSet)) - -> DsM (CoreExpr, -- desugared expression - DIdSet, -- subset of local vars that occur free - [Id]) -- same local vars as a list, fed back to - -- the inner function to form the tuple of - -- inputs to the arrow. -trimInput build_arrow - = fixDs (\ ~(_,_,env_ids) -> do - (core_cmd, free_vars) <- build_arrow env_ids - return (core_cmd, free_vars, dVarSetElems free_vars)) - -{- -Translation of command judgements of the form - - D |-a do { ss } : t --} - -dsCmdDo :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this statement - -> Type -- return type of the statement - -> [CmdLStmt GhcTc] -- statements to desugar - -> [Id] -- list of vars in the input to this statement - -- This is typically fed back, - -- so don't pull on it too early - -> DsM (CoreExpr, -- desugared expression - DIdSet) -- subset of local vars that occur free - -dsCmdDo _ _ _ [] _ = panic "dsCmdDo" - --- D; xs |-a c : () --> t --- -------------------------- --- D; xs |-a do { c } : t --- --- ---> premap (\ (xs) -> ((xs), ())) c - -dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do - putSrcSpanDs loc $ dsNoLevPoly res_ty - (text "In the command:" <+> ppr body) - (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids - let env_ty = mkBigCoreVarTupTy env_ids - env_var <- newSysLocalDs env_ty - let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr) - return (do_premap ids - env_ty - (mkCorePairTy env_ty unitTy) - res_ty - core_map - core_body, - env_ids') - -dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do - let bound_vars = mkVarSet (collectLStmtBinders stmt) - let local_vars' = bound_vars `unionVarSet` local_vars - (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts) - (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids - return (do_compose ids - (mkBigCoreVarTupTy env_ids) - (mkBigCoreVarTupTy env_ids') - res_ty - core_stmt - core_stmts, - fv_stmt) - -{- -A statement maps one local environment to another, and is represented -as an arrow from one tuple type to another. A statement sequence is -translated to a composition of such arrows. --} - -dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt GhcTc -> [Id] - -> DsM (CoreExpr, DIdSet) -dsCmdLStmt ids local_vars out_ids cmd env_ids - = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids - -dsCmdStmt - :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this statement - -> [Id] -- list of vars in the output of this statement - -> CmdStmt GhcTc -- statement to desugar - -> [Id] -- list of vars in the input to this statement - -- This is typically fed back, - -- so don't pull on it too early - -> DsM (CoreExpr, -- desugared expression - DIdSet) -- subset of local vars that occur free - --- D; xs1 |-a c : () --> t --- D; xs' |-a do { ss } : t' --- ------------------------------ --- D; xs |-a do { c; ss } : t' --- --- ---> premap (\ ((xs)) -> (((xs1),()),(xs'))) --- (first c >>> arr snd) >>> ss - -dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do - (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd - core_mux <- matchEnv env_ids - (mkCorePairExpr - (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr) - (mkBigCoreVarTup out_ids)) - let - in_ty = mkBigCoreVarTupTy env_ids - in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy - out_ty = mkBigCoreVarTupTy out_ids - before_c_ty = mkCorePairTy in_ty1 out_ty - after_c_ty = mkCorePairTy c_ty out_ty - dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here - snd_fn <- mkSndExpr c_ty out_ty - return (do_premap ids in_ty before_c_ty out_ty core_mux $ - do_compose ids before_c_ty after_c_ty out_ty - (do_first ids in_ty1 c_ty out_ty core_cmd) $ - do_arr ids after_c_ty out_ty snd_fn, - extendDVarSetList fv_cmd out_ids) - --- D; xs1 |-a c : () --> t --- D; xs' |-a do { ss } : t' xs2 = xs' - defs(p) --- ----------------------------------- --- D; xs |-a do { p <- c; ss } : t' --- --- ---> premap (\ (xs) -> (((xs1),()),(xs2))) --- (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss --- --- It would be simpler and more consistent to do this using second, --- but that's likely to be defined in terms of first. - -dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do - let pat_ty = hsLPatType pat - (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd - let pat_vars = mkVarSet (collectPatBinders pat) - let - env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids - env_ty2 = mkBigCoreVarTupTy env_ids2 - - -- multiplexing function - -- \ (xs) -> (((xs1),()),(xs2)) - - core_mux <- matchEnv env_ids - (mkCorePairExpr - (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr) - (mkBigCoreVarTup env_ids2)) - - -- projection function - -- \ (p, (xs2)) -> (zs) - - env_id <- newSysLocalDs env_ty2 - uniqs <- newUniqueSupply - let - after_c_ty = mkCorePairTy pat_ty env_ty2 - out_ty = mkBigCoreVarTupTy out_ids - body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids) - - fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty - pat_id <- selectSimpleMatchVarL pat - match_code - <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr - pair_id <- newSysLocalDs after_c_ty - let - proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code) - - -- put it all together - let - in_ty = mkBigCoreVarTupTy env_ids - in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy - in_ty2 = mkBigCoreVarTupTy env_ids2 - before_c_ty = mkCorePairTy in_ty1 in_ty2 - return (do_premap ids in_ty before_c_ty out_ty core_mux $ - do_compose ids before_c_ty after_c_ty out_ty - (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $ - do_arr ids after_c_ty out_ty proj_expr, - fv_cmd `unionDVarSet` (mkDVarSet out_ids - `uniqDSetMinusUniqSet` pat_vars)) - --- D; xs' |-a do { ss } : t --- -------------------------------------- --- D; xs |-a do { let binds; ss } : t --- --- ---> arr (\ (xs) -> let binds in (xs')) >>> ss - -dsCmdStmt ids local_vars out_ids (LetStmt _ binds) env_ids = do - -- build a new environment using the let bindings - core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids) - -- match the old environment against the input - core_map <- matchEnv env_ids core_binds - return (do_arr ids - (mkBigCoreVarTupTy env_ids) - (mkBigCoreVarTupTy out_ids) - core_map, - exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars) - --- D; ys |-a do { ss; returnA -< ((xs1), (ys2)) } : ... --- D; xs' |-a do { ss' } : t --- ------------------------------------ --- D; xs |-a do { rec ss; ss' } : t --- --- xs1 = xs' /\ defs(ss) --- xs2 = xs' - defs(ss) --- ys1 = ys - defs(ss) --- ys2 = ys /\ defs(ss) --- --- ---> arr (\(xs) -> ((ys1),(xs2))) >>> --- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>> --- arr (\((xs1),(xs2)) -> (xs')) >>> ss' - -dsCmdStmt ids local_vars out_ids - (RecStmt { recS_stmts = stmts - , recS_later_ids = later_ids, recS_rec_ids = rec_ids - , recS_ext = RecStmtTc { recS_later_rets = later_rets - , recS_rec_rets = rec_rets } }) - env_ids = do - let - later_ids_set = mkVarSet later_ids - env2_ids = filterOut (`elemVarSet` later_ids_set) out_ids - env2_id_set = mkDVarSet env2_ids - env2_ty = mkBigCoreVarTupTy env2_ids - - -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) - - uniqs <- newUniqueSupply - env2_id <- newSysLocalDs env2_ty - let - later_ty = mkBigCoreVarTupTy later_ids - post_pair_ty = mkCorePairTy later_ty env2_ty - post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids) - - post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body - - --- loop (...) - - (core_loop, env1_id_set, env1_ids) - <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets - - -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids)) - - let - env1_ty = mkBigCoreVarTupTy env1_ids - pre_pair_ty = mkCorePairTy env1_ty env2_ty - pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids) - (mkBigCoreVarTup env2_ids) - - pre_loop_fn <- matchEnv env_ids pre_loop_body - - -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn - - let - env_ty = mkBigCoreVarTupTy env_ids - out_ty = mkBigCoreVarTupTy out_ids - core_body = do_premap ids env_ty pre_pair_ty out_ty - pre_loop_fn - (do_compose ids pre_pair_ty post_pair_ty out_ty - (do_first ids env1_ty later_ty env2_ty - core_loop) - (do_arr ids post_pair_ty out_ty - post_loop_fn)) - - return (core_body, env1_id_set `unionDVarSet` env2_id_set) - -dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s) - --- loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) --- (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>> - -dsRecCmd - :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this statement - -> [CmdLStmt GhcTc] -- list of statements inside the RecCmd - -> [Id] -- list of vars defined here and used later - -> [HsExpr GhcTc] -- expressions corresponding to later_ids - -> [Id] -- list of vars fed back through the loop - -> [HsExpr GhcTc] -- expressions corresponding to rec_ids - -> DsM (CoreExpr, -- desugared statement - DIdSet, -- subset of local vars that occur free - [Id]) -- same local vars as a list - -dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do - let - later_id_set = mkVarSet later_ids - rec_id_set = mkVarSet rec_ids - local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars - - -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets)) - - core_later_rets <- mapM dsExpr later_rets - core_rec_rets <- mapM dsExpr rec_rets - let - -- possibly polymorphic version of vars of later_ids and rec_ids - out_ids = exprsFreeIdsList (core_later_rets ++ core_rec_rets) - out_ty = mkBigCoreVarTupTy out_ids - - later_tuple = mkBigCoreTup core_later_rets - later_ty = mkBigCoreVarTupTy later_ids - - rec_tuple = mkBigCoreTup core_rec_rets - rec_ty = mkBigCoreVarTupTy rec_ids - - out_pair = mkCorePairExpr later_tuple rec_tuple - out_pair_ty = mkCorePairTy later_ty rec_ty - - mk_pair_fn <- matchEnv out_ids out_pair - - -- ss - - (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts - - -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids) - - rec_id <- newSysLocalDs rec_ty - let - env1_id_set = fv_stmts `uniqDSetMinusUniqSet` rec_id_set - env1_ids = dVarSetElems env1_id_set - env1_ty = mkBigCoreVarTupTy env1_ids - in_pair_ty = mkCorePairTy env1_ty rec_ty - core_body = mkBigCoreTup (map selectVar env_ids) - where - selectVar v - | v `elemVarSet` rec_id_set - = mkTupleSelector rec_ids v rec_id (Var rec_id) - | otherwise = Var v - - squash_pair_fn <- matchEnvStack env1_ids rec_id core_body - - -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn)) - - let - env_ty = mkBigCoreVarTupTy env_ids - core_loop = do_loop ids env1_ty later_ty rec_ty - (do_premap ids in_pair_ty env_ty out_pair_ty - squash_pair_fn - (do_compose ids env_ty out_ty out_pair_ty - core_stmts - (do_arr ids out_ty out_pair_ty mk_pair_fn))) - - return (core_loop, env1_id_set, env1_ids) - -{- -A sequence of statements (as in a rec) is desugared to an arrow between -two environments (no stack) --} - -dsfixCmdStmts - :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this statement - -> [Id] -- output vars of these statements - -> [CmdLStmt GhcTc] -- statements to desugar - -> DsM (CoreExpr, -- desugared expression - DIdSet, -- subset of local vars that occur free - [Id]) -- same local vars as a list - -dsfixCmdStmts ids local_vars out_ids stmts - = trimInput (dsCmdStmts ids local_vars out_ids stmts) - -- TODO: Add levity polymorphism check for the resulting expression. - -- But I (Richard E.) don't know enough about arrows to do so. - -dsCmdStmts - :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this statement - -> [Id] -- output vars of these statements - -> [CmdLStmt GhcTc] -- statements to desugar - -> [Id] -- list of vars in the input to these statements - -> DsM (CoreExpr, -- desugared expression - DIdSet) -- subset of local vars that occur free - -dsCmdStmts ids local_vars out_ids [stmt] env_ids - = dsCmdLStmt ids local_vars out_ids stmt env_ids - -dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do - let bound_vars = mkVarSet (collectLStmtBinders stmt) - let local_vars' = bound_vars `unionVarSet` local_vars - (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts - (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids - return (do_compose ids - (mkBigCoreVarTupTy env_ids) - (mkBigCoreVarTupTy env_ids') - (mkBigCoreVarTupTy out_ids) - core_stmt - core_stmts, - fv_stmt) - -dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []" - --- Match a list of expressions against a list of patterns, left-to-right. - -matchSimplys :: [CoreExpr] -- Scrutinees - -> HsMatchContext GhcRn -- Match kind - -> [LPat GhcTc] -- Patterns they should match - -> CoreExpr -- Return this if they all match - -> CoreExpr -- Return this if they don't - -> DsM CoreExpr -matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr -matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do - match_code <- matchSimplys exps ctxt pats result_expr fail_expr - matchSimply exp ctxt pat match_code fail_expr -matchSimplys _ _ _ _ _ = panic "matchSimplys" - --- List of leaf expressions, with set of variables bound in each - -leavesMatch :: LMatch GhcTc (Located (body GhcTc)) - -> [(Located (body GhcTc), IdSet)] -leavesMatch (L _ (Match { m_pats = pats - , m_grhss = GRHSs _ grhss (L _ binds) })) - = let - defined_vars = mkVarSet (collectPatsBinders pats) - `unionVarSet` - mkVarSet (collectLocalBinders binds) - in - [(body, - mkVarSet (collectLStmtsBinders stmts) - `unionVarSet` defined_vars) - | L _ (GRHS _ stmts body) <- grhss] -leavesMatch _ = panic "leavesMatch" - --- Replace the leaf commands in a match - -replaceLeavesMatch - :: Type -- new result type - -> [Located (body' GhcTc)] -- replacement leaf expressions of that type - -> LMatch GhcTc (Located (body GhcTc)) -- the matches of a case command - -> ([Located (body' GhcTc)], -- remaining leaf expressions - LMatch GhcTc (Located (body' GhcTc))) -- updated match -replaceLeavesMatch _res_ty leaves - (L loc - match@(Match { m_grhss = GRHSs x grhss binds })) - = let - (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss - in - (leaves', L loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds })) -replaceLeavesMatch _ _ _ = panic "replaceLeavesMatch" - -replaceLeavesGRHS - :: [Located (body' GhcTc)] -- replacement leaf expressions of that type - -> LGRHS GhcTc (Located (body GhcTc)) -- rhss of a case command - -> ([Located (body' GhcTc)], -- remaining leaf expressions - LGRHS GhcTc (Located (body' GhcTc))) -- updated GRHS -replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _)) - = (leaves, L loc (GRHS x stmts leaf)) -replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" -replaceLeavesGRHS _ _ = panic "replaceLeavesGRHS" - --- Balanced fold of a non-empty list. - -foldb :: (a -> a -> a) -> [a] -> a -foldb _ [] = error "foldb of empty list" -foldb _ [x] = x -foldb f xs = foldb f (fold_pairs xs) - where - fold_pairs [] = [] - fold_pairs [x] = [x] - fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs - -{- -Note [Dictionary binders in ConPatOut] See also same Note in GHC.Hs.Utils -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The following functions to collect value variables from patterns are -copied from GHC.Hs.Utils, with one change: we also collect the dictionary -bindings (pat_binds) from ConPatOut. We need them for cases like - -h :: Arrow a => Int -> a (Int,Int) Int -h x = proc (y,z) -> case compare x y of - GT -> returnA -< z+x - -The type checker turns the case into - - case compare x y of - GT { p77 = plusInt } -> returnA -< p77 z x - -Here p77 is a local binding for the (+) operation. - -See comments in GHC.Hs.Utils for why the other version does not include -these bindings. --} - -collectPatBinders :: LPat GhcTc -> [Id] -collectPatBinders pat = collectl pat [] - -collectPatsBinders :: [LPat GhcTc] -> [Id] -collectPatsBinders pats = foldr collectl [] pats - ---------------------- -collectl :: LPat GhcTc -> [Id] -> [Id] --- See Note [Dictionary binders in ConPatOut] -collectl (L _ pat) bndrs - = go pat - where - go (VarPat _ (L _ var)) = var : bndrs - go (WildPat _) = bndrs - go (LazyPat _ pat) = collectl pat bndrs - go (BangPat _ pat) = collectl pat bndrs - go (AsPat _ (L _ a) pat) = a : collectl pat bndrs - go (ParPat _ pat) = collectl pat bndrs - - go (ListPat _ pats) = foldr collectl bndrs pats - go (TuplePat _ pats _) = foldr collectl bndrs pats - go (SumPat _ pat _ _) = collectl pat bndrs - - go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps) - go (ConPatOut {pat_args=ps, pat_binds=ds}) = - collectEvBinders ds - ++ foldr collectl bndrs (hsConPatArgs ps) - go (LitPat _ _) = bndrs - go (NPat {}) = bndrs - go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs - - go (SigPat _ pat _) = collectl pat bndrs - go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs - go (ViewPat _ _ pat) = collectl pat bndrs - go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p) - go p@(XPat {}) = pprPanic "collectl/go" (ppr p) - -collectEvBinders :: TcEvBinds -> [Id] -collectEvBinders (EvBinds bs) = foldr add_ev_bndr [] bs -collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders" - -add_ev_bndr :: EvBind -> [Id] -> [Id] -add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs - | otherwise = bs - -- A worry: what about coercion variable binders?? - -collectLStmtsBinders :: [LStmt GhcTc body] -> [Id] -collectLStmtsBinders = concatMap collectLStmtBinders - -collectLStmtBinders :: LStmt GhcTc body -> [Id] -collectLStmtBinders = collectStmtBinders . unLoc - -collectStmtBinders :: Stmt GhcTc body -> [Id] -collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids -collectStmtBinders stmt = HsUtils.collectStmtBinders stmt diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs deleted file mode 100644 index d573efc0c3..0000000000 --- a/compiler/deSugar/DsBinds.hs +++ /dev/null @@ -1,1325 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Pattern-matching bindings (HsBinds and MonoBinds) - -Handles @HsBinds@; those at the top level require different handling, -in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at -lower levels it is preserved with @let@/@letrec@s). --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE FlexibleContexts #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec, - dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} DsExpr( dsLExpr ) -import {-# SOURCE #-} Match( matchWrapper ) - -import DsMonad -import DsGRHSs -import DsUtils -import GHC.HsToCore.PmCheck ( needToRunPmCheck, addTyCsDs, checkGuardMatches ) - -import GHC.Hs -- lots of things -import CoreSyn -- lots of things -import CoreOpt ( simpleOptExpr ) -import OccurAnal ( occurAnalyseExpr ) -import MkCore -import CoreUtils -import CoreArity ( etaExpand ) -import CoreUnfold -import CoreFVs -import Digraph -import Predicate - -import PrelNames -import TyCon -import TcEvidence -import TcType -import Type -import Coercion -import TysWiredIn ( typeNatKind, typeSymbolKind ) -import Id -import MkId(proxyHashId) -import Name -import VarSet -import Rules -import VarEnv -import Var( EvVar ) -import Outputable -import Module -import SrcLoc -import Maybes -import OrdList -import Bag -import BasicTypes -import DynFlags -import FastString -import Util -import UniqSet( nonDetEltsUniqSet ) -import MonadUtils -import qualified GHC.LanguageExtensions as LangExt -import Control.Monad - -{-********************************************************************** -* * - Desugaring a MonoBinds -* * -**********************************************************************-} - --- | Desugar top level binds, strict binds are treated like normal --- binds since there is no good time to force before first usage. -dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr)) -dsTopLHsBinds binds - -- see Note [Strict binds checks] - | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds) - = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds - ; mapBagM_ (top_level_err "strict bindings") bang_binds - ; return nilOL } - - | otherwise - = do { (force_vars, prs) <- dsLHsBinds binds - ; when debugIsOn $ - do { xstrict <- xoptM LangExt.Strict - ; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr force_vars ) } - -- with -XStrict, even top-level vars are listed as force vars. - - ; return (toOL prs) } - - where - unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds - bang_binds = filterBag (isBangedHsBind . unLoc) binds - - top_level_err desc (L loc bind) - = putSrcSpanDs loc $ - errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:") - 2 (ppr bind)) - - --- | Desugar all other kind of bindings, Ids of strict binds are returned to --- later be forced in the binding group body, see Note [Desugar Strict binds] -dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)]) -dsLHsBinds binds - = do { ds_bs <- mapBagM dsLHsBind binds - ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b')) - id ([], []) ds_bs) } - ------------------------- -dsLHsBind :: LHsBind GhcTc - -> DsM ([Id], [(Id,CoreExpr)]) -dsLHsBind (L loc bind) = do dflags <- getDynFlags - putSrcSpanDs loc $ dsHsBind dflags bind - --- | Desugar a single binding (or group of recursive binds). -dsHsBind :: DynFlags - -> HsBind GhcTc - -> DsM ([Id], [(Id,CoreExpr)]) - -- ^ The Ids of strict binds, to be forced in the body of the - -- binding group see Note [Desugar Strict binds] and all - -- bindings and their desugared right hand sides. - -dsHsBind dflags (VarBind { var_id = var - , var_rhs = expr - , var_inline = inline_regardless }) - = do { core_expr <- dsLExpr expr - -- Dictionary bindings are always VarBinds, - -- so we only need do this here - ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr - | otherwise = var - ; let core_bind@(id,_) = makeCorePair dflags var' False 0 core_expr - force_var = if xopt LangExt.Strict dflags - then [id] - else [] - ; return (force_var, [core_bind]) } - -dsHsBind dflags b@(FunBind { fun_id = L _ fun - , fun_matches = matches - , fun_ext = co_fn - , fun_tick = tick }) - = do { (args, body) <- matchWrapper - (mkPrefixFunRhs (noLoc $ idName fun)) - Nothing matches - ; core_wrap <- dsHsWrapper co_fn - ; let body' = mkOptTickBox tick body - rhs = core_wrap (mkLams args body') - core_binds@(id,_) = makeCorePair dflags fun False 0 rhs - force_var - -- Bindings are strict when -XStrict is enabled - | xopt LangExt.Strict dflags - , matchGroupArity matches == 0 -- no need to force lambdas - = [id] - | isBangedHsBind b - = [id] - | otherwise - = [] - ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun) - -- , ppr (mg_alts matches) - -- , ppr args, ppr core_binds]) $ - return (force_var, [core_binds]) } - -dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss - , pat_ext = NPatBindTc _ ty - , pat_ticks = (rhs_tick, var_ticks) }) - = do { body_expr <- dsGuarded grhss ty - ; checkGuardMatches PatBindGuards grhss - ; let body' = mkOptTickBox rhs_tick body_expr - pat' = decideBangHood dflags pat - ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body' - -- We silently ignore inline pragmas; no makeCorePair - -- Not so cool, but really doesn't matter - ; let force_var' = if isBangedLPat pat' - then [force_var] - else [] - ; return (force_var', sel_binds) } - -dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts - , abs_exports = exports - , abs_ev_binds = ev_binds - , abs_binds = binds, abs_sig = has_sig }) - = do { ds_binds <- applyWhen (needToRunPmCheck dflags FromSource) - -- FromSource might not be accurate, but at worst - -- we do superfluous calls to the pattern match - -- oracle. - -- addTyCsDs: push type constraints deeper - -- for inner pattern match check - -- See Check, Note [Type and Term Equality Propagation] - (addTyCsDs (listToBag dicts)) - (dsLHsBinds binds) - - ; ds_ev_binds <- dsTcEvBinds_s ev_binds - - -- dsAbsBinds does the hard work - ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig } - -dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" -dsHsBind _ (XHsBindsLR nec) = noExtCon nec - - ------------------------ -dsAbsBinds :: DynFlags - -> [TyVar] -> [EvVar] -> [ABExport GhcTc] - -> [CoreBind] -- Desugared evidence bindings - -> ([Id], [(Id,CoreExpr)]) -- Desugared value bindings - -> Bool -- Single binding with signature - -> DsM ([Id], [(Id,CoreExpr)]) - -dsAbsBinds dflags tyvars dicts exports - ds_ev_binds (force_vars, bind_prs) has_sig - - -- A very important common case: one exported variable - -- Non-recursive bindings come through this way - -- So do self-recursive bindings - | [export] <- exports - , ABE { abe_poly = global_id, abe_mono = local_id - , abe_wrap = wrap, abe_prags = prags } <- export - , Just force_vars' <- case force_vars of - [] -> Just [] - [v] | v == local_id -> Just [global_id] - _ -> Nothing - -- If there is a variable to force, it's just the - -- single variable we are binding here - = do { core_wrap <- dsHsWrapper wrap -- Usually the identity - - ; let rhs = core_wrap $ - mkLams tyvars $ mkLams dicts $ - mkCoreLets ds_ev_binds $ - body - - body | has_sig - , [(_, lrhs)] <- bind_prs - = lrhs - | otherwise - = mkLetRec bind_prs (Var local_id) - - ; (spec_binds, rules) <- dsSpecs rhs prags - - ; let global_id' = addIdSpecialisations global_id rules - main_bind = makeCorePair dflags global_id' - (isDefaultMethod prags) - (dictArity dicts) rhs - - ; return (force_vars', main_bind : fromOL spec_binds) } - - -- Another common case: no tyvars, no dicts - -- In this case we can have a much simpler desugaring - | null tyvars, null dicts - - = do { let mk_bind (ABE { abe_wrap = wrap - , abe_poly = global - , abe_mono = local - , abe_prags = prags }) - = do { core_wrap <- dsHsWrapper wrap - ; return (makeCorePair dflags global - (isDefaultMethod prags) - 0 (core_wrap (Var local))) } - mk_bind (XABExport nec) = noExtCon nec - ; main_binds <- mapM mk_bind exports - - ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) } - - -- The general case - -- See Note [Desugaring AbsBinds] - | otherwise - = do { let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs - | (lcl_id, rhs) <- bind_prs ] - -- Monomorphic recursion possible, hence Rec - new_force_vars = get_new_force_vars force_vars - locals = map abe_mono exports - all_locals = locals ++ new_force_vars - tup_expr = mkBigCoreVarTup all_locals - tup_ty = exprType tup_expr - ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $ - mkCoreLets ds_ev_binds $ - mkLet core_bind $ - tup_expr - - ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs) - - -- Find corresponding global or make up a new one: sometimes - -- we need to make new export to desugar strict binds, see - -- Note [Desugar Strict binds] - ; (exported_force_vars, extra_exports) <- get_exports force_vars - - ; let mk_bind (ABE { abe_wrap = wrap - , abe_poly = global - , abe_mono = local, abe_prags = spec_prags }) - -- See Note [AbsBinds wrappers] in HsBinds - = do { tup_id <- newSysLocalDs tup_ty - ; core_wrap <- dsHsWrapper wrap - ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $ - mkTupleSelector all_locals local tup_id $ - mkVarApps (Var poly_tup_id) (tyvars ++ dicts) - rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs - ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags - ; let global' = (global `setInlinePragma` defaultInlinePragma) - `addIdSpecialisations` rules - -- Kill the INLINE pragma because it applies to - -- the user written (local) function. The global - -- Id is just the selector. Hmm. - ; return ((global', rhs) : fromOL spec_binds) } - mk_bind (XABExport nec) = noExtCon nec - - ; export_binds_s <- mapM mk_bind (exports ++ extra_exports) - - ; return ( exported_force_vars - , (poly_tup_id, poly_tup_rhs) : - concat export_binds_s) } - where - inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with - -- the inline pragma from the source - -- The type checker put the inline pragma - -- on the *global* Id, so we need to transfer it - inline_env - = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag) - | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports - , let prag = idInlinePragma gbl_id ] - - add_inline :: Id -> Id -- tran - add_inline lcl_id = lookupVarEnv inline_env lcl_id - `orElse` lcl_id - - global_env :: IdEnv Id -- Maps local Id to its global exported Id - global_env = - mkVarEnv [ (local, global) - | ABE { abe_mono = local, abe_poly = global } <- exports - ] - - -- find variables that are not exported - get_new_force_vars lcls = - foldr (\lcl acc -> case lookupVarEnv global_env lcl of - Just _ -> acc - Nothing -> lcl:acc) - [] lcls - - -- find exports or make up new exports for force variables - get_exports :: [Id] -> DsM ([Id], [ABExport GhcTc]) - get_exports lcls = - foldM (\(glbls, exports) lcl -> - case lookupVarEnv global_env lcl of - Just glbl -> return (glbl:glbls, exports) - Nothing -> do export <- mk_export lcl - let glbl = abe_poly export - return (glbl:glbls, export:exports)) - ([],[]) lcls - - mk_export local = - do global <- newSysLocalDs - (exprType (mkLams tyvars (mkLams dicts (Var local)))) - return (ABE { abe_ext = noExtField - , abe_poly = global - , abe_mono = local - , abe_wrap = WpHole - , abe_prags = SpecPrags [] }) - --- | This is where we apply INLINE and INLINABLE pragmas. All we need to --- do is to attach the unfolding information to the Id. --- --- Other decisions about whether to inline are made in --- `calcUnfoldingGuidance` but the decision about whether to then expose --- the unfolding in the interface file is made in `GHC.Iface.Tidy.addExternal` --- using this information. ------------------------- -makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr - -> (Id, CoreExpr) -makeCorePair dflags gbl_id is_default_method dict_arity rhs - | is_default_method -- Default methods are *always* inlined - -- See Note [INLINE and default methods] in TcInstDcls - = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs) - - | otherwise - = case inlinePragmaSpec inline_prag of - NoUserInline -> (gbl_id, rhs) - NoInline -> (gbl_id, rhs) - Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs) - Inline -> inline_pair - - where - inline_prag = idInlinePragma gbl_id - inlinable_unf = mkInlinableUnfolding dflags rhs - inline_pair - | Just arity <- inlinePragmaSat inline_prag - -- Add an Unfolding for an INLINE (but not for NOINLINE) - -- And eta-expand the RHS; see Note [Eta-expanding INLINE things] - , let real_arity = dict_arity + arity - -- NB: The arity in the InlineRule takes account of the dictionaries - = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity rhs - , etaExpand real_arity rhs) - - | otherwise - = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $ - (gbl_id `setIdUnfolding` mkInlineUnfolding rhs, rhs) - -dictArity :: [Var] -> Arity --- Don't count coercion variables in arity -dictArity dicts = count isId dicts - -{- -Note [Desugaring AbsBinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the general AbsBinds case we desugar the binding to this: - - tup a (d:Num a) = let fm = ...gm... - gm = ...fm... - in (fm,gm) - f a d = case tup a d of { (fm,gm) -> fm } - g a d = case tup a d of { (fm,gm) -> fm } - -Note [Rules and inlining] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Common special case: no type or dictionary abstraction -This is a bit less trivial than you might suppose -The naive way would be to desugar to something like - f_lcl = ...f_lcl... -- The "binds" from AbsBinds - M.f = f_lcl -- Generated from "exports" -But we don't want that, because if M.f isn't exported, -it'll be inlined unconditionally at every call site (its rhs is -trivial). That would be ok unless it has RULES, which would -thereby be completely lost. Bad, bad, bad. - -Instead we want to generate - M.f = ...f_lcl... - f_lcl = M.f -Now all is cool. The RULES are attached to M.f (by SimplCore), -and f_lcl is rapidly inlined away. - -This does not happen in the same way to polymorphic binds, -because they desugar to - M.f = /\a. let f_lcl = ...f_lcl... in f_lcl -Although I'm a bit worried about whether full laziness might -float the f_lcl binding out and then inline M.f at its call site - -Note [Specialising in no-dict case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Even if there are no tyvars or dicts, we may have specialisation pragmas. -Class methods can generate - AbsBinds [] [] [( ... spec-prag] - { AbsBinds [tvs] [dicts] ...blah } -So the overloading is in the nested AbsBinds. A good example is in GHC.Float: - - class (Real a, Fractional a) => RealFrac a where - round :: (Integral b) => a -> b - - instance RealFrac Float where - {-# SPECIALIZE round :: Float -> Int #-} - -The top-level AbsBinds for $cround has no tyvars or dicts (because the -instance does not). But the method is locally overloaded! - -Note [Abstracting over tyvars only] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When abstracting over type variable only (not dictionaries), we don't really need to -built a tuple and select from it, as we do in the general case. Instead we can take - - AbsBinds [a,b] [ ([a,b], fg, fl, _), - ([b], gg, gl, _) ] - { fl = e1 - gl = e2 - h = e3 } - -and desugar it to - - fg = /\ab. let B in e1 - gg = /\b. let a = () in let B in S(e2) - h = /\ab. let B in e3 - -where B is the *non-recursive* binding - fl = fg a b - gl = gg b - h = h a b -- See (b); note shadowing! - -Notice (a) g has a different number of type variables to f, so we must - use the mkArbitraryType thing to fill in the gaps. - We use a type-let to do that. - - (b) The local variable h isn't in the exports, and rather than - clone a fresh copy we simply replace h by (h a b), where - the two h's have different types! Shadowing happens here, - which looks confusing but works fine. - - (c) The result is *still* quadratic-sized if there are a lot of - small bindings. So if there are more than some small - number (10), we filter the binding set B by the free - variables of the particular RHS. Tiresome. - -Why got to this trouble? It's a common case, and it removes the -quadratic-sized tuple desugaring. Less clutter, hopefully faster -compilation, especially in a case where there are a *lot* of -bindings. - - -Note [Eta-expanding INLINE things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - foo :: Eq a => a -> a - {-# INLINE foo #-} - foo x = ... - -If (foo d) ever gets floated out as a common sub-expression (which can -happen as a result of method sharing), there's a danger that we never -get to do the inlining, which is a Terribly Bad thing given that the -user said "inline"! - -To avoid this we pre-emptively eta-expand the definition, so that foo -has the arity with which it is declared in the source code. In this -example it has arity 2 (one for the Eq and one for x). Doing this -should mean that (foo d) is a PAP and we don't share it. - -Note [Nested arities] -~~~~~~~~~~~~~~~~~~~~~ -For reasons that are not entirely clear, method bindings come out looking like -this: - - AbsBinds [] [] [$cfromT <= [] fromT] - $cfromT [InlPrag=INLINE] :: T Bool -> Bool - { AbsBinds [] [] [fromT <= [] fromT_1] - fromT :: T Bool -> Bool - { fromT_1 ((TBool b)) = not b } } } - -Note the nested AbsBind. The arity for the InlineRule on $cfromT should be -gotten from the binding for fromT_1. - -It might be better to have just one level of AbsBinds, but that requires more -thought! - - -Note [Desugar Strict binds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma - -Desugaring strict variable bindings looks as follows (core below ==>) - - let !x = rhs - in body -==> - let x = rhs - in x `seq` body -- seq the variable - -and if it is a pattern binding the desugaring looks like - - let !pat = rhs - in body -==> - let x = rhs -- bind the rhs to a new variable - pat = x - in x `seq` body -- seq the new variable - -if there is no variable in the pattern desugaring looks like - - let False = rhs - in body -==> - let x = case rhs of {False -> (); _ -> error "Match failed"} - in x `seq` body - -In order to force the Ids in the binding group they are passed around -in the dsHsBind family of functions, and later seq'ed in DsExpr.ds_val_bind. - -Consider a recursive group like this - - letrec - f : g = rhs[f,g] - in - -Without `Strict`, we get a translation like this: - - let t = /\a. letrec tm = rhs[fm,gm] - fm = case t of fm:_ -> fm - gm = case t of _:gm -> gm - in - (fm,gm) - - in let f = /\a. case t a of (fm,_) -> fm - in let g = /\a. case t a of (_,gm) -> gm - in - -Here `tm` is the monomorphic binding for `rhs`. - -With `Strict`, we want to force `tm`, but NOT `fm` or `gm`. -Alas, `tm` isn't in scope in the `in ` part. - -The simplest thing is to return it in the polymorphic -tuple `t`, thus: - - let t = /\a. letrec tm = rhs[fm,gm] - fm = case t of fm:_ -> fm - gm = case t of _:gm -> gm - in - (tm, fm, gm) - - in let f = /\a. case t a of (_,fm,_) -> fm - in let g = /\a. case t a of (_,_,gm) -> gm - in let tm = /\a. case t a of (tm,_,_) -> tm - in tm `seq` - - -See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma for a more -detailed explanation of the desugaring of strict bindings. - -Note [Strict binds checks] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are several checks around properly formed strict bindings. They -all link to this Note. These checks must be here in the desugarer because -we cannot know whether or not a type is unlifted until after zonking, due -to levity polymorphism. These checks all used to be handled in the typechecker -in checkStrictBinds (before Jan '17). - -We define an "unlifted bind" to be any bind that binds an unlifted id. Note that - - x :: Char - (# True, x #) = blah - -is *not* an unlifted bind. Unlifted binds are detected by GHC.Hs.Utils.isUnliftedHsBind. - -Define a "banged bind" to have a top-level bang. Detected by GHC.Hs.Pat.isBangedHsBind. -Define a "strict bind" to be either an unlifted bind or a banged bind. - -The restrictions are: - 1. Strict binds may not be top-level. Checked in dsTopLHsBinds. - - 2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged - unlifted bind, but an unbanged bind looks lazy, and we don't want users to be - surprised by the strictness of an unlifted bind.) Checked in first clause - of DsExpr.ds_val_bind. - - 3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type - variables or constraints.) Checked in first clause - of DsExpr.ds_val_bind. - - 4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind. - --} - ------------------------- -dsSpecs :: CoreExpr -- Its rhs - -> TcSpecPrags - -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids - , [CoreRule] ) -- Rules for the Global Ids --- See Note [Handling SPECIALISE pragmas] in TcBinds -dsSpecs _ IsDefaultMethod = return (nilOL, []) -dsSpecs poly_rhs (SpecPrags sps) - = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps - ; let (spec_binds_s, rules) = unzip pairs - ; return (concatOL spec_binds_s, rules) } - -dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding - -- Nothing => RULE is for an imported Id - -- rhs is in the Id's unfolding - -> Located TcSpecPrag - -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule)) -dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) - | isJust (isClassOpId_maybe poly_id) - = putSrcSpanDs loc $ - do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector" - <+> quotes (ppr poly_id)) - ; return Nothing } -- There is no point in trying to specialise a class op - -- Moreover, classops don't (currently) have an inl_sat arity set - -- (it would be Just 0) and that in turn makes makeCorePair bleat - - | no_act_spec && isNeverActive rule_act - = putSrcSpanDs loc $ - do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:" - <+> quotes (ppr poly_id)) - ; return Nothing } -- Function is NOINLINE, and the specialisation inherits that - -- See Note [Activation pragmas for SPECIALISE] - - | otherwise - = putSrcSpanDs loc $ - do { uniq <- newUnique - ; let poly_name = idName poly_id - spec_occ = mkSpecOcc (getOccName poly_name) - spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name) - (spec_bndrs, spec_app) = collectHsWrapBinders spec_co - -- spec_co looks like - -- \spec_bndrs. [] spec_args - -- perhaps with the body of the lambda wrapped in some WpLets - -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2 - - ; core_app <- dsHsWrapper spec_app - - ; let ds_lhs = core_app (Var poly_id) - spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs) - ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id - -- , text "spec_co:" <+> ppr spec_co - -- , text "ds_rhs:" <+> ppr ds_lhs ]) $ - dflags <- getDynFlags - ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of { - Left msg -> do { warnDs NoReason msg; return Nothing } ; - Right (rule_bndrs, _fn, args) -> do - - { this_mod <- getModule - ; let fn_unf = realIdUnfolding poly_id - spec_unf = specUnfolding dflags spec_bndrs core_app arity_decrease fn_unf - spec_id = mkLocalId spec_name spec_ty - `setInlinePragma` inl_prag - `setIdUnfolding` spec_unf - arity_decrease = count isValArg args - count isId spec_bndrs - - ; rule <- dsMkUserRule this_mod is_local_id - (mkFastString ("SPEC " ++ showPpr dflags poly_name)) - rule_act poly_name - rule_bndrs args - (mkVarApps (Var spec_id) spec_bndrs) - - ; let spec_rhs = mkLams spec_bndrs (core_app poly_rhs) - --- Commented out: see Note [SPECIALISE on INLINE functions] --- ; when (isInlinePragma id_inl) --- (warnDs $ text "SPECIALISE pragma on INLINE function probably won't fire:" --- <+> quotes (ppr poly_name)) - - ; return (Just (unitOL (spec_id, spec_rhs), rule)) - -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because - -- makeCorePair overwrites the unfolding, which we have - -- just created using specUnfolding - } } } - where - is_local_id = isJust mb_poly_rhs - poly_rhs | Just rhs <- mb_poly_rhs - = rhs -- Local Id; this is its rhs - | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id) - = unfolding -- Imported Id; this is its unfolding - -- Use realIdUnfolding so we get the unfolding - -- even when it is a loop breaker. - -- We want to specialise recursive functions! - | otherwise = pprPanic "dsImpSpecs" (ppr poly_id) - -- The type checker has checked that it *has* an unfolding - - id_inl = idInlinePragma poly_id - - -- See Note [Activation pragmas for SPECIALISE] - inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl - | not is_local_id -- See Note [Specialising imported functions] - -- in OccurAnal - , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma - | otherwise = id_inl - -- Get the INLINE pragma from SPECIALISE declaration, or, - -- failing that, from the original Id - - spec_prag_act = inlinePragmaActivation spec_inl - - -- See Note [Activation pragmas for SPECIALISE] - -- no_act_spec is True if the user didn't write an explicit - -- phase specification in the SPECIALISE pragma - no_act_spec = case inlinePragmaSpec spec_inl of - NoInline -> isNeverActive spec_prag_act - _ -> isAlwaysActive spec_prag_act - rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit - | otherwise = spec_prag_act -- Specified by user - - -dsMkUserRule :: Module -> Bool -> RuleName -> Activation - -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule -dsMkUserRule this_mod is_local name act fn bndrs args rhs = do - let rule = mkRule this_mod False is_local name act fn bndrs args rhs - dflags <- getDynFlags - when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $ - warnDs (Reason Opt_WarnOrphans) (ruleOrphWarn rule) - return rule - -ruleOrphWarn :: CoreRule -> SDoc -ruleOrphWarn rule = text "Orphan rule:" <+> ppr rule - -{- Note [SPECIALISE on INLINE functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to warn that using SPECIALISE for a function marked INLINE -would be a no-op; but it isn't! Especially with worker/wrapper split -we might have - {-# INLINE f #-} - f :: Ord a => Int -> a -> ... - f d x y = case x of I# x' -> $wf d x' y - -We might want to specialise 'f' so that we in turn specialise '$wf'. -We can't even /name/ '$wf' in the source code, so we can't specialise -it even if we wanted to. #10721 is a case in point. - -Note [Activation pragmas for SPECIALISE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -From a user SPECIALISE pragma for f, we generate - a) A top-level binding spec_fn = rhs - b) A RULE f dOrd = spec_fn - -We need two pragma-like things: - -* spec_fn's inline pragma: inherited from f's inline pragma (ignoring - activation on SPEC), unless overridden by SPEC INLINE - -* Activation of RULE: from SPECIALISE pragma (if activation given) - otherwise from f's inline pragma - -This is not obvious (see #5237)! - -Examples Rule activation Inline prag on spec'd fn ---------------------------------------------------------------------- -SPEC [n] f :: ty [n] Always, or NOINLINE [n] - copy f's prag - -NOINLINE f -SPEC [n] f :: ty [n] NOINLINE - copy f's prag - -NOINLINE [k] f -SPEC [n] f :: ty [n] NOINLINE [k] - copy f's prag - -INLINE [k] f -SPEC [n] f :: ty [n] INLINE [k] - copy f's prag - -SPEC INLINE [n] f :: ty [n] INLINE [n] - (ignore INLINE prag on f, - same activation for rule and spec'd fn) - -NOINLINE [k] f -SPEC f :: ty [n] INLINE [k] - - -************************************************************************ -* * -\subsection{Adding inline pragmas} -* * -************************************************************************ --} - -decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr - -> Either SDoc ([Var], Id, [CoreExpr]) --- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE, --- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs --- may add some extra dictionary binders (see Note [Free dictionaries]) --- --- Returns an error message if the LHS isn't of the expected shape --- Note [Decomposing the left-hand side of a RULE] -decomposeRuleLhs dflags orig_bndrs orig_lhs - | not (null unbound) -- Check for things unbound on LHS - -- See Note [Unused spec binders] - = Left (vcat (map dead_msg unbound)) - | Var funId <- fun2 - , Just con <- isDataConId_maybe funId - = Left (constructor_msg con) -- See Note [No RULES on datacons] - | Just (fn_id, args) <- decompose fun2 args2 - , let extra_bndrs = mk_extra_bndrs fn_id args - = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs - -- , text "orig_lhs:" <+> ppr orig_lhs - -- , text "lhs1:" <+> ppr lhs1 - -- , text "extra_dict_bndrs:" <+> ppr extra_dict_bndrs - -- , text "fn_id:" <+> ppr fn_id - -- , text "args:" <+> ppr args]) $ - Right (orig_bndrs ++ extra_bndrs, fn_id, args) - - | otherwise - = Left bad_shape_msg - where - lhs1 = drop_dicts orig_lhs - lhs2 = simpleOptExpr dflags lhs1 -- See Note [Simplify rule LHS] - (fun2,args2) = collectArgs lhs2 - - lhs_fvs = exprFreeVars lhs2 - unbound = filterOut (`elemVarSet` lhs_fvs) orig_bndrs - - orig_bndr_set = mkVarSet orig_bndrs - - -- Add extra tyvar binders: Note [Free tyvars in rule LHS] - -- and extra dict binders: Note [Free dictionaries in rule LHS] - mk_extra_bndrs fn_id args - = scopedSort unbound_tvs ++ unbound_dicts - where - unbound_tvs = [ v | v <- unbound_vars, isTyVar v ] - unbound_dicts = [ mkLocalId (localiseName (idName d)) (idType d) - | d <- unbound_vars, isDictId d ] - unbound_vars = [ v | v <- exprsFreeVarsList args - , not (v `elemVarSet` orig_bndr_set) - , not (v == fn_id) ] - -- fn_id: do not quantify over the function itself, which may - -- itself be a dictionary (in pathological cases, #10251) - - decompose (Var fn_id) args - | not (fn_id `elemVarSet` orig_bndr_set) - = Just (fn_id, args) - - decompose _ _ = Nothing - - bad_shape_msg = hang (text "RULE left-hand side too complicated to desugar") - 2 (vcat [ text "Optimised lhs:" <+> ppr lhs2 - , text "Orig lhs:" <+> ppr orig_lhs]) - dead_msg bndr = hang (sep [ text "Forall'd" <+> pp_bndr bndr - , text "is not bound in RULE lhs"]) - 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs - , text "Orig lhs:" <+> ppr orig_lhs - , text "optimised lhs:" <+> ppr lhs2 ]) - pp_bndr bndr - | isTyVar bndr = text "type variable" <+> quotes (ppr bndr) - | isEvVar bndr = text "constraint" <+> quotes (ppr (varType bndr)) - | otherwise = text "variable" <+> quotes (ppr bndr) - - constructor_msg con = vcat - [ text "A constructor," <+> ppr con <> - text ", appears as outermost match in RULE lhs." - , text "This rule will be ignored." ] - - drop_dicts :: CoreExpr -> CoreExpr - drop_dicts e - = wrap_lets needed bnds body - where - needed = orig_bndr_set `minusVarSet` exprFreeVars body - (bnds, body) = split_lets (occurAnalyseExpr e) - -- The occurAnalyseExpr drops dead bindings which is - -- crucial to ensure that every binding is used later; - -- which in turn makes wrap_lets work right - - split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr) - split_lets (Let (NonRec d r) body) - | isDictId d - = ((d,r):bs, body') - where (bs, body') = split_lets body - - -- handle "unlifted lets" too, needed for "map/coerce" - split_lets (Case r d _ [(DEFAULT, _, body)]) - | isCoVar d - = ((d,r):bs, body') - where (bs, body') = split_lets body - - split_lets e = ([], e) - - wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr - wrap_lets _ [] body = body - wrap_lets needed ((d, r) : bs) body - | rhs_fvs `intersectsVarSet` needed = mkCoreLet (NonRec d r) (wrap_lets needed' bs body) - | otherwise = wrap_lets needed bs body - where - rhs_fvs = exprFreeVars r - needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d - -{- -Note [Decomposing the left-hand side of a RULE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are several things going on here. -* drop_dicts: see Note [Drop dictionary bindings on rule LHS] -* simpleOptExpr: see Note [Simplify rule LHS] -* extra_dict_bndrs: see Note [Free dictionaries] - -Note [Free tyvars on rule LHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a = C - - foo :: T a -> Int - foo C = 1 - - {-# RULES "myrule" foo C = 1 #-} - -After type checking the LHS becomes (foo alpha (C alpha)), where alpha -is an unbound meta-tyvar. The zonker in TcHsSyn is careful not to -turn the free alpha into Any (as it usually does). Instead it turns it -into a TyVar 'a'. See TcHsSyn Note [Zonking the LHS of a RULE]. - -Now we must quantify over that 'a'. It's /really/ inconvenient to do that -in the zonker, because the HsExpr data type is very large. But it's /easy/ -to do it here in the desugarer. - -Moreover, we have to do something rather similar for dictionaries; -see Note [Free dictionaries on rule LHS]. So that's why we look for -type variables free on the LHS, and quantify over them. - -Note [Free dictionaries on rule LHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, -which is presumably in scope at the function definition site, we can quantify -over it too. *Any* dict with that type will do. - -So for example when you have - f :: Eq a => a -> a - f = - ... SPECIALISE f :: Int -> Int ... - -Then we get the SpecPrag - SpecPrag (f Int dInt) - -And from that we want the rule - - RULE forall dInt. f Int dInt = f_spec - f_spec = let f = in f Int dInt - -But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External -Name, and you can't bind them in a lambda or forall without getting things -confused. Likewise it might have an InlineRule or something, which would be -utterly bogus. So we really make a fresh Id, with the same unique and type -as the old one, but with an Internal name and no IdInfo. - -Note [Drop dictionary bindings on rule LHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -drop_dicts drops dictionary bindings on the LHS where possible. - E.g. let d:Eq [Int] = $fEqList $fEqInt in f d - --> f d - Reasoning here is that there is only one d:Eq [Int], and so we can - quantify over it. That makes 'd' free in the LHS, but that is later - picked up by extra_dict_bndrs (Note [Dead spec binders]). - - NB 1: We can only drop the binding if the RHS doesn't bind - one of the orig_bndrs, which we assume occur on RHS. - Example - f :: (Eq a) => b -> a -> a - {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-} - Here we want to end up with - RULE forall d:Eq a. f ($dfEqList d) = f_spec d - Of course, the ($dfEqlist d) in the pattern makes it less likely - to match, but there is no other way to get d:Eq a - - NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all - the evidence bindings to be wrapped around the outside of the - LHS. (After simplOptExpr they'll usually have been inlined.) - dsHsWrapper does dependency analysis, so that civilised ones - will be simple NonRec bindings. We don't handle recursive - dictionaries! - - NB3: In the common case of a non-overloaded, but perhaps-polymorphic - specialisation, we don't need to bind *any* dictionaries for use - in the RHS. For example (#8331) - {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-} - useAbstractMonad :: MonadAbstractIOST m => m Int - Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code - but the RHS uses no dictionaries, so we want to end up with - RULE forall s (d :: MonadAbstractIOST (ReaderT s)). - useAbstractMonad (ReaderT s) d = $suseAbstractMonad s - - #8848 is a good example of where there are some interesting - dictionary bindings to discard. - -The drop_dicts algorithm is based on these observations: - - * Given (let d = rhs in e) where d is a DictId, - matching 'e' will bind e's free variables. - - * So we want to keep the binding if one of the needed variables (for - which we need a binding) is in fv(rhs) but not already in fv(e). - - * The "needed variables" are simply the orig_bndrs. Consider - f :: (Eq a, Show b) => a -> b -> String - ... SPECIALISE f :: (Show b) => Int -> b -> String ... - Then orig_bndrs includes the *quantified* dictionaries of the type - namely (dsb::Show b), but not the one for Eq Int - -So we work inside out, applying the above criterion at each step. - - -Note [Simplify rule LHS] -~~~~~~~~~~~~~~~~~~~~~~~~ -simplOptExpr occurrence-analyses and simplifies the LHS: - - (a) Inline any remaining dictionary bindings (which hopefully - occur just once) - - (b) Substitute trivial lets, so that they don't get in the way. - Note that we substitute the function too; we might - have this as a LHS: let f71 = M.f Int in f71 - - (c) Do eta reduction. To see why, consider the fold/build rule, - which without simplification looked like: - fold k z (build (/\a. g a)) ==> ... - This doesn't match unless you do eta reduction on the build argument. - Similarly for a LHS like - augment g (build h) - we do not want to get - augment (\a. g a) (build h) - otherwise we don't match when given an argument like - augment (\a. h a a) (build h) - -Note [Unused spec binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: a -> a - ... SPECIALISE f :: Eq a => a -> a ... -It's true that this *is* a more specialised type, but the rule -we get is something like this: - f_spec d = f - RULE: f = f_spec d -Note that the rule is bogus, because it mentions a 'd' that is -not bound on the LHS! But it's a silly specialisation anyway, because -the constraint is unused. We could bind 'd' to (error "unused") -but it seems better to reject the program because it's almost certainly -a mistake. That's what the isDeadBinder call detects. - -Note [No RULES on datacons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Previously, `RULES` like - - "JustNothing" forall x . Just x = Nothing - -were allowed. Simon Peyton Jones says this seems to have been a -mistake, that such rules have never been supported intentionally, -and that he doesn't know if they can break in horrible ways. -Furthermore, Ben Gamari and Reid Barton are considering trying to -detect the presence of "static data" that the simplifier doesn't -need to traverse at all. Such rules do not play well with that. -So for now, we ban them altogether as requested by #13290. See also #7398. - - -************************************************************************ -* * - Desugaring evidence -* * -************************************************************************ - --} - -dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr) -dsHsWrapper WpHole = return $ \e -> e -dsHsWrapper (WpTyApp ty) = return $ \e -> App e (Type ty) -dsHsWrapper (WpEvLam ev) = return $ Lam ev -dsHsWrapper (WpTyLam tv) = return $ Lam tv -dsHsWrapper (WpLet ev_binds) = do { bs <- dsTcEvBinds ev_binds - ; return (mkCoreLets bs) } -dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1 - ; w2 <- dsHsWrapper c2 - ; return (w1 . w2) } - -- See comments on WpFun in TcEvidence for an explanation of what - -- the specification of this clause is -dsHsWrapper (WpFun c1 c2 t1 doc) - = do { x <- newSysLocalDsNoLP t1 - ; w1 <- dsHsWrapper c1 - ; w2 <- dsHsWrapper c2 - ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a - arg = w1 (Var x) - ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc - ; if ok - then return (\e -> (Lam x (w2 (app e arg)))) - else return id } -- this return is irrelevant -dsHsWrapper (WpCast co) = ASSERT(coercionRole co == Representational) - return $ \e -> mkCastDs e co -dsHsWrapper (WpEvApp tm) = do { core_tm <- dsEvTerm tm - ; return (\e -> App e core_tm) } - --------------------------------------- -dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind] -dsTcEvBinds_s [] = return [] -dsTcEvBinds_s (b:rest) = ASSERT( null rest ) -- Zonker ensures null - dsTcEvBinds b - -dsTcEvBinds :: TcEvBinds -> DsM [CoreBind] -dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this -dsTcEvBinds (EvBinds bs) = dsEvBinds bs - -dsEvBinds :: Bag EvBind -> DsM [CoreBind] -dsEvBinds bs - = do { ds_bs <- mapBagM dsEvBind bs - ; return (mk_ev_binds ds_bs) } - -mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind] --- We do SCC analysis of the evidence bindings, /after/ desugaring --- them. This is convenient: it means we can use the CoreSyn --- free-variable functions rather than having to do accurate free vars --- for EvTerm. -mk_ev_binds ds_binds - = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges) - where - edges :: [ Node EvVar (EvVar,CoreExpr) ] - edges = foldr ((:) . mk_node) [] ds_binds - - mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr) - mk_node b@(var, rhs) - = DigraphNode { node_payload = b - , node_key = var - , node_dependencies = nonDetEltsUniqSet $ - exprFreeVars rhs `unionVarSet` - coVarsOfType (varType var) } - -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices - -- is still deterministic even if the edges are in nondeterministic order - -- as explained in Note [Deterministic SCC] in Digraph. - - ds_scc (AcyclicSCC (v,r)) = NonRec v r - ds_scc (CyclicSCC prs) = Rec prs - -dsEvBind :: EvBind -> DsM (Id, CoreExpr) -dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r) - - -{-********************************************************************** -* * - Desugaring EvTerms -* * -**********************************************************************-} - -dsEvTerm :: EvTerm -> DsM CoreExpr -dsEvTerm (EvExpr e) = return e -dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev -dsEvTerm (EvFun { et_tvs = tvs, et_given = given - , et_binds = ev_binds, et_body = wanted_id }) - = do { ds_ev_binds <- dsTcEvBinds ev_binds - ; return $ (mkLams (tvs ++ given) $ - mkCoreLets ds_ev_binds $ - Var wanted_id) } - - -{-********************************************************************** -* * - Desugaring Typeable dictionaries -* * -**********************************************************************-} - -dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr --- Return a CoreExpr :: Typeable ty --- This code is tightly coupled to the representation --- of TypeRep, in base library Data.Typeable.Internals -dsEvTypeable ty ev - = do { tyCl <- dsLookupTyCon typeableClassName -- Typeable - ; let kind = typeKind ty - Just typeable_data_con - = tyConSingleDataCon_maybe tyCl -- "Data constructor" - -- for Typeable - - ; rep_expr <- ds_ev_typeable ty ev -- :: TypeRep a - - -- Package up the method as `Typeable` dictionary - ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] } - -type TypeRepExpr = CoreExpr - --- | Returns a @CoreExpr :: TypeRep ty@ -ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr -ds_ev_typeable ty (EvTypeableTyCon tc kind_ev) - = do { mkTrCon <- dsLookupGlobalId mkTrConName - -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a - ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName - ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName - -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep - - ; tc_rep <- tyConRep tc -- :: TyCon - ; let ks = tyConAppArgs ty - -- Construct a SomeTypeRep - toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr - toSomeTypeRep t ev = do - rep <- getRep ev t - return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep] - ; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev -- :: TypeRep t - ; let -- :: [SomeTypeRep] - kind_args = mkListExpr (mkTyConTy someTypeRepTyCon) kind_arg_reps - - -- Note that we use the kind of the type, not the TyCon from which it - -- is constructed since the latter may be kind polymorphic whereas the - -- former we know is not (we checked in the solver). - ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty) - , Type ty - , tc_rep - , kind_args ] - -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr - ; return expr - } - -ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) - | Just (t1,t2) <- splitAppTy_maybe ty - = do { e1 <- getRep ev1 t1 - ; e2 <- getRep ev2 t2 - ; mkTrApp <- dsLookupGlobalId mkTrAppName - -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1). - -- TypeRep a -> TypeRep b -> TypeRep (a b) - ; let (k1, k2) = splitFunTy (typeKind t1) - ; let expr = mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ]) - [ e1, e2 ] - -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr - ; return expr - } - -ds_ev_typeable ty (EvTypeableTrFun ev1 ev2) - | Just (t1,t2) <- splitFunTy_maybe ty - = do { e1 <- getRep ev1 t1 - ; e2 <- getRep ev2 t2 - ; mkTrFun <- dsLookupGlobalId mkTrFunName - -- mkTrFun :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). - -- TypeRep a -> TypeRep b -> TypeRep (a -> b) - ; let r1 = getRuntimeRep t1 - r2 = getRuntimeRep t2 - ; return $ mkApps (mkTyApps (Var mkTrFun) [r1, r2, t1, t2]) - [ e1, e2 ] - } - -ds_ev_typeable ty (EvTypeableTyLit ev) - = -- See Note [Typeable for Nat and Symbol] in TcInteract - do { fun <- dsLookupGlobalId tr_fun - ; dict <- dsEvTerm ev -- Of type KnownNat/KnownSymbol - ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty] - ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) } - where - ty_kind = typeKind ty - - -- tr_fun is the Name of - -- typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep a - -- of typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep a - tr_fun | ty_kind `eqType` typeNatKind = typeNatTypeRepName - | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName - | otherwise = panic "dsEvTypeable: unknown type lit kind" - -ds_ev_typeable ty ev - = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev) - -getRep :: EvTerm -- ^ EvTerm for @Typeable ty@ - -> Type -- ^ The type @ty@ - -> DsM TypeRepExpr -- ^ Return @CoreExpr :: TypeRep ty@ - -- namely @typeRep# dict@ --- Remember that --- typeRep# :: forall k (a::k). Typeable k a -> TypeRep a -getRep ev ty - = do { typeable_expr <- dsEvTerm ev - ; typeRepId <- dsLookupGlobalId typeRepIdName - ; let ty_args = [typeKind ty, ty] - ; return (mkApps (mkTyApps (Var typeRepId) ty_args) [ typeable_expr ]) } - -tyConRep :: TyCon -> DsM CoreExpr --- Returns CoreExpr :: TyCon -tyConRep tc - | Just tc_rep_nm <- tyConRepName_maybe tc - = do { tc_rep_id <- dsLookupGlobalId tc_rep_nm - ; return (Var tc_rep_id) } - | otherwise - = pprPanic "tyConRep" (ppr tc) diff --git a/compiler/deSugar/DsBinds.hs-boot b/compiler/deSugar/DsBinds.hs-boot deleted file mode 100644 index 71c0040039..0000000000 --- a/compiler/deSugar/DsBinds.hs-boot +++ /dev/null @@ -1,6 +0,0 @@ -module DsBinds where -import DsMonad ( DsM ) -import CoreSyn ( CoreExpr ) -import TcEvidence (HsWrapper) - -dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr) diff --git a/compiler/deSugar/DsCCall.hs b/compiler/deSugar/DsCCall.hs deleted file mode 100644 index fc5f10eb4b..0000000000 --- a/compiler/deSugar/DsCCall.hs +++ /dev/null @@ -1,381 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1994-1998 - - -Desugaring foreign calls --} - -{-# LANGUAGE CPP #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module DsCCall - ( dsCCall - , mkFCall - , unboxArg - , boxResult - , resultWrapper - ) where - -#include "HsVersions.h" - - -import GhcPrelude - -import CoreSyn - -import DsMonad -import CoreUtils -import MkCore -import MkId -import ForeignCall -import DataCon -import DsUtils - -import TcType -import Type -import Id ( Id ) -import Coercion -import PrimOp -import TysPrim -import TyCon -import TysWiredIn -import BasicTypes -import Literal -import PrelNames -import DynFlags -import Outputable -import Util - -import Data.Maybe - -{- -Desugaring of @ccall@s consists of adding some state manipulation, -unboxing any boxed primitive arguments and boxing the result if -desired. - -The state stuff just consists of adding in -@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place. - -The unboxing is straightforward, as all information needed to unbox is -available from the type. For each boxed-primitive argument, we -transform: -\begin{verbatim} - _ccall_ foo [ r, t1, ... tm ] e1 ... em - | - | - V - case e1 of { T1# x1# -> - ... - case em of { Tm# xm# -> xm# - ccall# foo [ r, t1#, ... tm# ] x1# ... xm# - } ... } -\end{verbatim} - -The reboxing of a @_ccall_@ result is a bit tricker: the types don't -contain information about the state-pairing functions so we have to -keep a list of \tr{(type, s-p-function)} pairs. We transform as -follows: -\begin{verbatim} - ccall# foo [ r, t1#, ... tm# ] e1# ... em# - | - | - V - \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of - (StateAnd# result# state#) -> (R# result#, realWorld#) -\end{verbatim} --} - -dsCCall :: CLabelString -- C routine to invoke - -> [CoreExpr] -- Arguments (desugared) - -- Precondition: none have levity-polymorphic types - -> Safety -- Safety of the call - -> Type -- Type of the result: IO t - -> DsM CoreExpr -- Result, of type ??? - -dsCCall lbl args may_gc result_ty - = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args - (ccall_result_ty, res_wrapper) <- boxResult result_ty - uniq <- newUnique - dflags <- getDynFlags - let - target = StaticTarget NoSourceText lbl Nothing True - the_fcall = CCall (CCallSpec target CCallConv may_gc) - the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty - return (foldr ($) (res_wrapper the_prim_app) arg_wrappers) - -mkFCall :: DynFlags -> Unique -> ForeignCall - -> [CoreExpr] -- Args - -> Type -- Result type - -> CoreExpr --- Construct the ccall. The only tricky bit is that the ccall Id should have --- no free vars, so if any of the arg tys do we must give it a polymorphic type. --- [I forget *why* it should have no free vars!] --- For example: --- mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char] --- --- Here we build a ccall thus --- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr)) --- a b s x c -mkFCall dflags uniq the_fcall val_args res_ty - = ASSERT( all isTyVar tyvars ) -- this must be true because the type is top-level - mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args - where - arg_tys = map exprType val_args - body_ty = (mkVisFunTys arg_tys res_ty) - tyvars = tyCoVarsOfTypeWellScoped body_ty - ty = mkInvForAllTys tyvars body_ty - the_fcall_id = mkFCallId dflags uniq the_fcall ty - -unboxArg :: CoreExpr -- The supplied argument, not levity-polymorphic - -> DsM (CoreExpr, -- To pass as the actual argument - CoreExpr -> CoreExpr -- Wrapper to unbox the arg - ) --- Example: if the arg is e::Int, unboxArg will return --- (x#::Int#, \W. case x of I# x# -> W) --- where W is a CoreExpr that probably mentions x# - --- always returns a non-levity-polymorphic expression - -unboxArg arg - -- Primitive types: nothing to unbox - | isPrimitiveType arg_ty - = return (arg, \body -> body) - - -- Recursive newtypes - | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty - = unboxArg (mkCastDs arg co) - - -- Booleans - | Just tc <- tyConAppTyCon_maybe arg_ty, - tc `hasKey` boolTyConKey - = do dflags <- getDynFlags - prim_arg <- newSysLocalDs intPrimTy - return (Var prim_arg, - \ body -> Case (mkWildCase arg arg_ty intPrimTy - [(DataAlt falseDataCon,[],mkIntLit dflags 0), - (DataAlt trueDataCon, [],mkIntLit dflags 1)]) - -- In increasing tag order! - prim_arg - (exprType body) - [(DEFAULT,[],body)]) - - -- Data types with a single constructor, which has a single, primitive-typed arg - -- This deals with Int, Float etc; also Ptr, ForeignPtr - | is_product_type && data_con_arity == 1 - = ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty) - -- Typechecker ensures this - do case_bndr <- newSysLocalDs arg_ty - prim_arg <- newSysLocalDs data_con_arg_ty1 - return (Var prim_arg, - \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)] - ) - - -- Byte-arrays, both mutable and otherwise; hack warning - -- We're looking for values of type ByteArray, MutableByteArray - -- data ByteArray ix = ByteArray ix ix ByteArray# - -- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s) - | is_product_type && - data_con_arity == 3 && - isJust maybe_arg3_tycon && - (arg3_tycon == byteArrayPrimTyCon || - arg3_tycon == mutableByteArrayPrimTyCon) - = do case_bndr <- newSysLocalDs arg_ty - vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys - return (Var arr_cts_var, - \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)] - ) - - | otherwise - = do l <- getSrcSpanDs - pprPanic "unboxArg: " (ppr l <+> ppr arg_ty) - where - arg_ty = exprType arg - maybe_product_type = splitDataProductType_maybe arg_ty - is_product_type = isJust maybe_product_type - Just (_, _, data_con, data_con_arg_tys) = maybe_product_type - data_con_arity = dataConSourceArity data_con - (data_con_arg_ty1 : _) = data_con_arg_tys - - (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys - maybe_arg3_tycon = tyConAppTyCon_maybe data_con_arg_ty3 - Just arg3_tycon = maybe_arg3_tycon - -boxResult :: Type - -> DsM (Type, CoreExpr -> CoreExpr) - --- Takes the result of the user-level ccall: --- either (IO t), --- or maybe just t for a side-effect-free call --- Returns a wrapper for the primitive ccall itself, along with the --- type of the result of the primitive ccall. This result type --- will be of the form --- State# RealWorld -> (# State# RealWorld, t' #) --- where t' is the unwrapped form of t. If t is simply (), then --- the result type will be --- State# RealWorld -> (# State# RealWorld #) - -boxResult result_ty - | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty - -- isIOType_maybe handles the case where the type is a - -- simple wrapping of IO. E.g. - -- newtype Wrap a = W (IO a) - -- No coercion necessary because its a non-recursive newtype - -- (If we wanted to handle a *recursive* newtype too, we'd need - -- another case, and a coercion.) - -- The result is IO t, so wrap the result in an IO constructor - = do { res <- resultWrapper io_res_ty - ; let extra_result_tys - = case res of - (Just ty,_) - | isUnboxedTupleType ty - -> let Just ls = tyConAppArgs_maybe ty in tail ls - _ -> [] - - return_result state anss - = mkCoreUbxTup - (realWorldStatePrimTy : io_res_ty : extra_result_tys) - (state : anss) - - ; (ccall_res_ty, the_alt) <- mk_alt return_result res - - ; state_id <- newSysLocalDs realWorldStatePrimTy - ; let io_data_con = head (tyConDataCons io_tycon) - toIOCon = dataConWrapId io_data_con - - wrap the_call = - mkApps (Var toIOCon) - [ Type io_res_ty, - Lam state_id $ - mkWildCase (App the_call (Var state_id)) - ccall_res_ty - (coreAltType the_alt) - [the_alt] - ] - - ; return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap) } - -boxResult result_ty - = do -- It isn't IO, so do unsafePerformIO - -- It's not conveniently available, so we inline it - res <- resultWrapper result_ty - (ccall_res_ty, the_alt) <- mk_alt return_result res - let - wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId)) - ccall_res_ty - (coreAltType the_alt) - [the_alt] - return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap) - where - return_result _ [ans] = ans - return_result _ _ = panic "return_result: expected single result" - - -mk_alt :: (Expr Var -> [Expr Var] -> Expr Var) - -> (Maybe Type, Expr Var -> Expr Var) - -> DsM (Type, (AltCon, [Id], Expr Var)) -mk_alt return_result (Nothing, wrap_result) - = do -- The ccall returns () - state_id <- newSysLocalDs realWorldStatePrimTy - let - the_rhs = return_result (Var state_id) - [wrap_result (panic "boxResult")] - - ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy] - the_alt = (DataAlt (tupleDataCon Unboxed 1), [state_id], the_rhs) - - return (ccall_res_ty, the_alt) - -mk_alt return_result (Just prim_res_ty, wrap_result) - = -- The ccall returns a non-() value - ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty ) - -- True because resultWrapper ensures it is so - do { result_id <- newSysLocalDs prim_res_ty - ; state_id <- newSysLocalDs realWorldStatePrimTy - ; let the_rhs = return_result (Var state_id) - [wrap_result (Var result_id)] - ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty] - the_alt = (DataAlt (tupleDataCon Unboxed 2), [state_id, result_id], the_rhs) - ; return (ccall_res_ty, the_alt) } - - -resultWrapper :: Type - -> DsM (Maybe Type, -- Type of the expected result, if any - CoreExpr -> CoreExpr) -- Wrapper for the result --- resultWrapper deals with the result *value* --- E.g. foreign import foo :: Int -> IO T --- Then resultWrapper deals with marshalling the 'T' part --- So if resultWrapper ty = (Just ty_rep, marshal) --- then marshal (e :: ty_rep) :: ty --- That is, 'marshal' wrape the result returned by the foreign call, --- of type ty_rep, into the value Haskell expected, of type 'ty' --- --- Invariant: ty_rep is always a primitive type --- i.e. (isPrimitiveType ty_rep) is True - -resultWrapper result_ty - -- Base case 1: primitive types - | isPrimitiveType result_ty - = return (Just result_ty, \e -> e) - - -- Base case 2: the unit type () - | Just (tc,_) <- maybe_tc_app - , tc `hasKey` unitTyConKey - = return (Nothing, \_ -> Var unitDataConId) - - -- Base case 3: the boolean type - | Just (tc,_) <- maybe_tc_app - , tc `hasKey` boolTyConKey - = do { dflags <- getDynFlags - ; let marshal_bool e - = mkWildCase e intPrimTy boolTy - [ (DEFAULT ,[],Var trueDataConId ) - , (LitAlt (mkLitInt dflags 0),[],Var falseDataConId)] - ; return (Just intPrimTy, marshal_bool) } - - -- Newtypes - | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty - = do { (maybe_ty, wrapper) <- resultWrapper rep_ty - ; return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) } - - -- The type might contain foralls (eg. for dummy type arguments, - -- referring to 'Ptr a' is legal). - | Just (tyvar, rest) <- splitForAllTy_maybe result_ty - = do { (maybe_ty, wrapper) <- resultWrapper rest - ; return (maybe_ty, \e -> Lam tyvar (wrapper e)) } - - -- Data types with a single constructor, which has a single arg - -- This includes types like Ptr and ForeignPtr - | Just (tycon, tycon_arg_tys) <- maybe_tc_app - , Just data_con <- isDataProductTyCon_maybe tycon -- One constructor, no existentials - , [unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys -- One argument - = do { dflags <- getDynFlags - ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty - ; let narrow_wrapper = maybeNarrow dflags tycon - marshal_con e = Var (dataConWrapId data_con) - `mkTyApps` tycon_arg_tys - `App` wrapper (narrow_wrapper e) - ; return (maybe_ty, marshal_con) } - - | otherwise - = pprPanic "resultWrapper" (ppr result_ty) - where - maybe_tc_app = splitTyConApp_maybe result_ty - --- When the result of a foreign call is smaller than the word size, we --- need to sign- or zero-extend the result up to the word size. The C --- standard appears to say that this is the responsibility of the --- caller, not the callee. - -maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr) -maybeNarrow dflags tycon - | tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e - | tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e - | tycon `hasKey` int32TyConKey - && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e - - | tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e - | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e - | tycon `hasKey` word32TyConKey - && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e - | otherwise = id diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs deleted file mode 100644 index 23d53ce3ca..0000000000 --- a/compiler/deSugar/DsExpr.hs +++ /dev/null @@ -1,1201 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Desugaring expressions. --} - -{-# LANGUAGE CPP, MultiWayIf #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds - , dsValBinds, dsLit, dsSyntaxExpr - , dsHandleMonadicFailure ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Match -import MatchLit -import DsBinds -import DsGRHSs -import DsListComp -import DsUtils -import DsArrows -import DsMonad -import GHC.HsToCore.PmCheck ( checkGuardMatches ) -import Name -import NameEnv -import FamInstEnv( topNormaliseType ) -import DsMeta -import GHC.Hs - --- NB: The desugarer, which straddles the source and Core worlds, sometimes --- needs to see source types -import TcType -import TcEvidence -import TcRnMonad -import Type -import CoreSyn -import CoreUtils -import MkCore - -import DynFlags -import CostCentre -import Id -import MkId -import Module -import ConLike -import DataCon -import TyCoPpr( pprWithTYPE ) -import TysWiredIn -import PrelNames -import BasicTypes -import Maybes -import VarEnv -import SrcLoc -import Util -import Bag -import Outputable -import PatSyn - -import Control.Monad - -{- -************************************************************************ -* * - dsLocalBinds, dsValBinds -* * -************************************************************************ --} - -dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr -dsLocalBinds (L _ (EmptyLocalBinds _)) body = return body -dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $ - dsValBinds binds body -dsLocalBinds (L _ (HsIPBinds _ binds)) body = dsIPBinds binds body -dsLocalBinds _ _ = panic "dsLocalBinds" - -------------------------- --- caller sets location -dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr -dsValBinds (XValBindsLR (NValBinds binds _)) body - = foldrM ds_val_bind body binds -dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn" - -------------------------- -dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr -dsIPBinds (IPBinds ev_binds ip_binds) body - = do { ds_binds <- dsTcEvBinds ev_binds - ; let inner = mkCoreLets ds_binds body - -- The dict bindings may not be in - -- dependency order; hence Rec - ; foldrM ds_ip_bind inner ip_binds } - where - ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body - = do e' <- dsLExpr e - return (Let (NonRec n e') body) - ds_ip_bind _ _ = panic "dsIPBinds" -dsIPBinds (XHsIPBinds nec) _ = noExtCon nec - -------------------------- --- caller sets location -ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr --- Special case for bindings which bind unlifted variables --- We need to do a case right away, rather than building --- a tuple and doing selections. --- Silently ignore INLINE and SPECIALISE pragmas... -ds_val_bind (NonRecursive, hsbinds) body - | [L loc bind] <- bagToList hsbinds - -- Non-recursive, non-overloaded bindings only come in ones - -- ToDo: in some bizarre case it's conceivable that there - -- could be dict binds in the 'binds'. (See the notes - -- below. Then pattern-match would fail. Urk.) - , isUnliftedHsBind bind - = putSrcSpanDs loc $ - -- see Note [Strict binds checks] in DsBinds - if is_polymorphic bind - then errDsCoreExpr (poly_bind_err bind) - -- data Ptr a = Ptr Addr# - -- f x = let p@(Ptr y) = ... in ... - -- Here the binding for 'p' is polymorphic, but does - -- not mix with an unlifted binding for 'y'. You should - -- use a bang pattern. #6078. - - else do { when (looksLazyPatBind bind) $ - warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind) - -- Complain about a binding that looks lazy - -- e.g. let I# y = x in ... - -- Remember, in checkStrictBinds we are going to do strict - -- matching, so (for software engineering reasons) we insist - -- that the strictness is manifest on each binding - -- However, lone (unboxed) variables are ok - - - ; dsUnliftedBind bind body } - where - is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }) - = not (null tvs && null evs) - is_polymorphic _ = False - - unlifted_must_be_bang bind - = hang (text "Pattern bindings containing unlifted types should use" $$ - text "an outermost bang pattern:") - 2 (ppr bind) - - poly_bind_err bind - = hang (text "You can't mix polymorphic and unlifted bindings:") - 2 (ppr bind) $$ - text "Probable fix: add a type signature" - -ds_val_bind (is_rec, binds) _body - | anyBag (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in DsBinds - = ASSERT( isRec is_rec ) - errDsCoreExpr $ - hang (text "Recursive bindings for unlifted types aren't allowed:") - 2 (vcat (map ppr (bagToList binds))) - --- Ordinary case for bindings; none should be unlifted -ds_val_bind (is_rec, binds) body - = do { MASSERT( isRec is_rec || isSingletonBag binds ) - -- we should never produce a non-recursive list of multiple binds - - ; (force_vars,prs) <- dsLHsBinds binds - ; let body' = foldr seqVar body force_vars - ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds ) - case prs of - [] -> return body - _ -> return (Let (Rec prs) body') } - -- Use a Rec regardless of is_rec. - -- Why? Because it allows the binds to be all - -- mixed up, which is what happens in one rare case - -- Namely, for an AbsBind with no tyvars and no dicts, - -- but which does have dictionary bindings. - -- See notes with TcSimplify.inferLoop [NO TYVARS] - -- It turned out that wrapping a Rec here was the easiest solution - -- - -- NB The previous case dealt with unlifted bindings, so we - -- only have to deal with lifted ones now; so Rec is ok - ------------------- -dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr -dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] - , abs_exports = exports - , abs_ev_binds = ev_binds - , abs_binds = lbinds }) body - = do { let body1 = foldr bind_export body exports - bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b - ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body) - body1 lbinds - ; ds_binds <- dsTcEvBinds_s ev_binds - ; return (mkCoreLets ds_binds body2) } - -dsUnliftedBind (FunBind { fun_id = L l fun - , fun_matches = matches - , fun_ext = co_fn - , fun_tick = tick }) body - -- Can't be a bang pattern (that looks like a PatBind) - -- so must be simply unboxed - = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun)) - Nothing matches - ; MASSERT( null args ) -- Functions aren't lifted - ; MASSERT( isIdHsWrapper co_fn ) - ; let rhs' = mkOptTickBox tick rhs - ; return (bindNonRec fun rhs' body) } - -dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss - , pat_ext = NPatBindTc _ ty }) body - = -- let C x# y# = rhs in body - -- ==> case rhs of C x# y# -> body - do { rhs <- dsGuarded grhss ty - ; checkGuardMatches PatBindGuards grhss - ; let upat = unLoc pat - eqn = EqnInfo { eqn_pats = [upat], - eqn_orig = FromSource, - eqn_rhs = cantFailMatchResult body } - ; var <- selectMatchVar upat - ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) - ; return (bindNonRec var rhs result) } - -dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) - -{- -************************************************************************ -* * -\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals} -* * -************************************************************************ --} - -dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr - -dsLExpr (L loc e) - = putSrcSpanDs loc $ - do { core_expr <- dsExpr e - -- uncomment this check to test the hsExprType function in TcHsSyn - -- ; MASSERT2( exprType core_expr `eqType` hsExprType e - -- , ppr e <+> dcolon <+> ppr (hsExprType e) $$ - -- ppr core_expr <+> dcolon <+> ppr (exprType core_expr) ) - ; return core_expr } - --- | Variant of 'dsLExpr' that ensures that the result is not levity --- polymorphic. This should be used when the resulting expression will --- be an argument to some other function. --- See Note [Levity polymorphism checking] in DsMonad --- See Note [Levity polymorphism invariants] in CoreSyn -dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr -dsLExprNoLP (L loc e) - = putSrcSpanDs loc $ - do { e' <- dsExpr e - ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e) - ; return e' } - -dsExpr :: HsExpr GhcTc -> DsM CoreExpr -dsExpr (HsPar _ e) = dsLExpr e -dsExpr (ExprWithTySig _ e _) = dsLExpr e -dsExpr (HsVar _ (L _ var)) = dsHsVar var -dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them -dsExpr (HsConLikeOut _ con) = dsConLike con -dsExpr (HsIPVar {}) = panic "dsExpr: HsIPVar" -dsExpr (HsOverLabel{}) = panic "dsExpr: HsOverLabel" - -dsExpr (HsLit _ lit) - = do { warnAboutOverflowedLit lit - ; dsLit (convertLit lit) } - -dsExpr (HsOverLit _ lit) - = do { warnAboutOverflowedOverLit lit - ; dsOverLit lit } - -dsExpr hswrap@(XExpr (HsWrap co_fn e)) - = do { e' <- case e of - HsVar _ (L _ var) -> return $ varToCoreExpr var - HsConLikeOut _ (RealDataCon dc) -> return $ varToCoreExpr (dataConWrapId dc) - XExpr (HsWrap _ _) -> pprPanic "dsExpr: HsWrap inside HsWrap" (ppr hswrap) - HsPar _ _ -> pprPanic "dsExpr: HsPar inside HsWrap" (ppr hswrap) - _ -> dsExpr e - -- See Note [Detecting forced eta expansion] - ; wrap' <- dsHsWrapper co_fn - ; dflags <- getDynFlags - ; let wrapped_e = wrap' e' - wrapped_ty = exprType wrapped_e - ; checkForcedEtaExpansion e (ppr hswrap) wrapped_ty -- See Note [Detecting forced eta expansion] - -- Pass HsWrap, so that the user can see entire expression with -fprint-typechecker-elaboration - ; warnAboutIdentities dflags e' wrapped_ty - ; return wrapped_e } - -dsExpr (NegApp _ (L loc - (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i}))) - neg_expr) - = do { expr' <- putSrcSpanDs loc $ do - { warnAboutOverflowedOverLit - (lit { ol_val = HsIntegral (negateIntegralLit i) }) - ; dsOverLit lit } - ; dsSyntaxExpr neg_expr [expr'] } - -dsExpr (NegApp _ expr neg_expr) - = do { expr' <- dsLExpr expr - ; dsSyntaxExpr neg_expr [expr'] } - -dsExpr (HsLam _ a_Match) - = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match - -dsExpr (HsLamCase _ matches) - = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches - ; return $ Lam discrim_var matching_code } - -dsExpr e@(HsApp _ fun arg) - = do { fun' <- dsLExpr fun - ; dsWhenNoErrs (dsLExprNoLP arg) - (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') } - -dsExpr (HsAppType _ e _) - -- ignore type arguments here; they're in the wrappers instead at this point - = dsLExpr e - -{- -Note [Desugaring vars] -~~~~~~~~~~~~~~~~~~~~~~ -In one situation we can get a *coercion* variable in a HsVar, namely -the support method for an equality superclass: - class (a~b) => C a b where ... - instance (blah) => C (T a) (T b) where .. -Then we get - $dfCT :: forall ab. blah => C (T a) (T b) - $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah) - - $c$p1C :: forall ab. blah => (T a ~ T b) - $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g - -That 'g' in the 'in' part is an evidence variable, and when -converting to core it must become a CO. - -Operator sections. At first it looks as if we can convert -\begin{verbatim} - (expr op) -\end{verbatim} -to -\begin{verbatim} - \x -> op expr x -\end{verbatim} - -But no! expr might be a redex, and we can lose laziness badly this -way. Consider -\begin{verbatim} - map (expr op) xs -\end{verbatim} -for example. So we convert instead to -\begin{verbatim} - let y = expr in \x -> op y x -\end{verbatim} -If \tr{expr} is actually just a variable, say, then the simplifier -will sort it out. --} - -dsExpr e@(OpApp _ e1 op e2) - = -- for the type of y, we need the type of op's 2nd argument - do { op' <- dsLExpr op - ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2]) - (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') } - -dsExpr (SectionL _ expr op) -- Desugar (e !) to ((!) e) - = do { op' <- dsLExpr op - ; dsWhenNoErrs (dsLExprNoLP expr) - (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') } - --- dsLExpr (SectionR op expr) -- \ x -> op x expr -dsExpr e@(SectionR _ op expr) = do - core_op <- dsLExpr op - -- for the type of x, we need the type of op's 2nd argument - let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) - -- See comment with SectionL - y_core <- dsLExpr expr - dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty]) - (\[x_id, y_id] -> bindNonRec y_id y_core $ - Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) - core_op [Var x_id, Var y_id])) - -dsExpr (ExplicitTuple _ tup_args boxity) - = do { let go (lam_vars, args) (L _ (Missing ty)) - -- For every missing expression, we need - -- another lambda in the desugaring. - = do { lam_var <- newSysLocalDsNoLP ty - ; return (lam_var : lam_vars, Var lam_var : args) } - go (lam_vars, args) (L _ (Present _ expr)) - -- Expressions that are present don't generate - -- lambdas, just arguments. - = do { core_expr <- dsLExprNoLP expr - ; return (lam_vars, core_expr : args) } - go _ _ = panic "dsExpr" - - ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args)) - -- The reverse is because foldM goes left-to-right - (\(lam_vars, args) -> mkCoreLams lam_vars $ - mkCoreTupBoxity boxity args) } - -- See Note [Don't flatten tuples from HsSyn] in MkCore - -dsExpr (ExplicitSum types alt arity expr) - = do { dsWhenNoErrs (dsLExprNoLP expr) - (\core_expr -> mkCoreConApps (sumDataCon alt arity) - (map (Type . getRuntimeRep) types ++ - map Type types ++ - [core_expr]) ) } - -dsExpr (HsPragE _ prag expr) = - ds_prag_expr prag expr - -dsExpr (HsCase _ discrim matches) - = do { core_discrim <- dsLExpr discrim - ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches - ; return (bindNonRec discrim_var core_discrim matching_code) } - --- Pepe: The binds are in scope in the body but NOT in the binding group --- This is to avoid silliness in breakpoints -dsExpr (HsLet _ binds body) = do - body' <- dsLExpr body - dsLocalBinds binds body' - --- We need the `ListComp' form to use `deListComp' (rather than the "do" form) --- because the interpretation of `stmts' depends on what sort of thing it is. --- -dsExpr (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty -dsExpr (HsDo _ DoExpr (L _ stmts)) = dsDo stmts -dsExpr (HsDo _ GhciStmtCtxt (L _ stmts)) = dsDo stmts -dsExpr (HsDo _ MDoExpr (L _ stmts)) = dsDo stmts -dsExpr (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts - -dsExpr (HsIf _ fun guard_expr then_expr else_expr) - = do { pred <- dsLExpr guard_expr - ; b1 <- dsLExpr then_expr - ; b2 <- dsLExpr else_expr - ; case fun of -- See Note [Rebindable if] in Hs.Expr - (SyntaxExprTc {}) -> dsSyntaxExpr fun [pred, b1, b2] - NoSyntaxExprTc -> return $ mkIfThenElse pred b1 b2 } - -dsExpr (HsMultiIf res_ty alts) - | null alts - = mkErrorExpr - - | otherwise - = do { match_result <- liftM (foldr1 combineMatchResults) - (mapM (dsGRHS IfAlt res_ty) alts) - ; checkGuardMatches IfAlt (GRHSs noExtField alts (noLoc emptyLocalBinds)) - ; error_expr <- mkErrorExpr - ; extractMatchResult match_result error_expr } - where - mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty - (text "multi-way if") - -{- -\noindent -\underline{\bf Various data construction things} - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --} - -dsExpr (ExplicitList elt_ty wit xs) - = dsExplicitList elt_ty wit xs - -dsExpr (ArithSeq expr witness seq) - = case witness of - Nothing -> dsArithSeq expr seq - Just fl -> do { newArithSeq <- dsArithSeq expr seq - ; dsSyntaxExpr fl [newArithSeq] } - -{- -Static Pointers -~~~~~~~~~~~~~~~ - -See Note [Grand plan for static forms] in StaticPtrTable for an overview. - - g = ... static f ... -==> - g = ... makeStatic loc f ... --} - -dsExpr (HsStatic _ expr@(L loc _)) = do - expr_ds <- dsLExprNoLP expr - let ty = exprType expr_ds - makeStaticId <- dsLookupGlobalId makeStaticName - - dflags <- getDynFlags - let (line, col) = case loc of - RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r - , srcLocCol $ realSrcSpanStart r - ) - _ -> (0, 0) - srcLoc = mkCoreConApps (tupleDataCon Boxed 2) - [ Type intTy , Type intTy - , mkIntExprInt dflags line, mkIntExprInt dflags col - ] - - putSrcSpanDs loc $ return $ - mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ] - -{- -\noindent -\underline{\bf Record construction and update} - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For record construction we do this (assuming T has three arguments) -\begin{verbatim} - T { op2 = e } -==> - let err = /\a -> recConErr a - T (recConErr t1 "M.hs/230/op1") - e - (recConErr t1 "M.hs/230/op3") -\end{verbatim} -@recConErr@ then converts its argument string into a proper message -before printing it as -\begin{verbatim} - M.hs, line 230: missing field op1 was evaluated -\end{verbatim} - -We also handle @C{}@ as valid construction syntax for an unlabelled -constructor @C@, setting all of @C@'s fields to bottom. --} - -dsExpr (RecordCon { rcon_flds = rbinds - , rcon_ext = RecordConTc { rcon_con_expr = con_expr - , rcon_con_like = con_like }}) - = do { con_expr' <- dsExpr con_expr - ; let - (arg_tys, _) = tcSplitFunTys (exprType con_expr') - -- A newtype in the corner should be opaque; - -- hence TcType.tcSplitFunTys - - mk_arg (arg_ty, fl) - = case findField (rec_flds rbinds) (flSelector fl) of - (rhs:rhss) -> ASSERT( null rhss ) - dsLExprNoLP rhs - [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl)) - unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty - - labels = conLikeFieldLabels con_like - - ; con_args <- if null labels - then mapM unlabelled_bottom arg_tys - else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels) - - ; return (mkCoreApps con_expr' con_args) } - -{- -Record update is a little harder. Suppose we have the decl: -\begin{verbatim} - data T = T1 {op1, op2, op3 :: Int} - | T2 {op4, op2 :: Int} - | T3 -\end{verbatim} -Then we translate as follows: -\begin{verbatim} - r { op2 = e } -===> - let op2 = e in - case r of - T1 op1 _ op3 -> T1 op1 op2 op3 - T2 op4 _ -> T2 op4 op2 - other -> recUpdError "M.hs/230" -\end{verbatim} -It's important that we use the constructor Ids for @T1@, @T2@ etc on the -RHSs, and do not generate a Core constructor application directly, because the constructor -might do some argument-evaluation first; and may have to throw away some -dictionaries. - -Note [Update for GADTs] -~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a b where - T1 :: { f1 :: a } -> T a Int - -Then the wrapper function for T1 has type - $WT1 :: a -> T a Int -But if x::T a b, then - x { f1 = v } :: T a b (not T a Int!) -So we need to cast (T a Int) to (T a b). Sigh. - --} - -dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields - , rupd_ext = RecordUpdTc - { rupd_cons = cons_to_upd - , rupd_in_tys = in_inst_tys - , rupd_out_tys = out_inst_tys - , rupd_wrap = dict_req_wrap }} ) - | null fields - = dsLExpr record_expr - | otherwise - = ASSERT2( notNull cons_to_upd, ppr expr ) - - do { record_expr' <- dsLExpr record_expr - ; field_binds' <- mapM ds_field fields - ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding - upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds'] - - -- It's important to generate the match with matchWrapper, - -- and the right hand sides with applications of the wrapper Id - -- so that everything works when we are doing fancy unboxing on the - -- constructor arguments. - ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd - ; ([discrim_var], matching_code) - <- matchWrapper RecUpd (Just record_expr) -- See Note [Scrutinee in Record updates] - (MG { mg_alts = noLoc alts - , mg_ext = MatchGroupTc [in_ty] out_ty - , mg_origin = FromSource }) - -- FromSource is not strictly right, but we - -- want incomplete pattern-match warnings - - ; return (add_field_binds field_binds' $ - bindNonRec discrim_var record_expr' matching_code) } - where - ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr) - -- Clone the Id in the HsRecField, because its Name is that - -- of the record selector, and we must not make that a local binder - -- else we shadow other uses of the record selector - -- Hence 'lcl_id'. Cf #2735 - ds_field (L _ rec_field) - = do { rhs <- dsLExpr (hsRecFieldArg rec_field) - ; let fld_id = unLoc (hsRecUpdFieldId rec_field) - ; lcl_id <- newSysLocalDs (idType fld_id) - ; return (idName fld_id, lcl_id, rhs) } - - add_field_binds [] expr = expr - add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr) - - -- Awkwardly, for families, the match goes - -- from instance type to family type - (in_ty, out_ty) = - case (head cons_to_upd) of - RealDataCon data_con -> - let tycon = dataConTyCon data_con in - (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys) - PatSynCon pat_syn -> - ( patSynInstResTy pat_syn in_inst_tys - , patSynInstResTy pat_syn out_inst_tys) - mk_alt upd_fld_env con - = do { let (univ_tvs, ex_tvs, eq_spec, - prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con - user_tvs = - case con of - RealDataCon data_con -> dataConUserTyVars data_con - PatSynCon _ -> univ_tvs ++ ex_tvs - -- The order here is because of the order in `TcPatSyn`. - in_subst = zipTvSubst univ_tvs in_inst_tys - out_subst = zipTvSubst univ_tvs out_inst_tys - - -- I'm not bothering to clone the ex_tvs - ; eqs_vars <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec)) - ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta) - ; arg_ids <- newSysLocalsDs (substTysUnchecked in_subst arg_tys) - ; let field_labels = conLikeFieldLabels con - val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg - field_labels arg_ids - mk_val_arg fl pat_arg_id - = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) - - inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExtField con) - -- Reconstruct with the WrapId so that unpacking happens - wrap = mkWpEvVarApps theta_vars <.> - dict_req_wrap <.> - mkWpTyApps [ lookupTyVar out_subst tv - `orElse` mkTyVarTy tv - | tv <- user_tvs - , not (tv `elemVarEnv` wrap_subst) ] - -- Be sure to use user_tvs (which may be ordered - -- differently than `univ_tvs ++ ex_tvs) above. - -- See Note [DataCon user type variable binders] - -- in DataCon. - rhs = foldl' (\a b -> nlHsApp a b) inst_con val_args - - -- Tediously wrap the application in a cast - -- Note [Update for GADTs] - wrapped_rhs = - case con of - RealDataCon data_con -> - let - wrap_co = - mkTcTyConAppCo Nominal - (dataConTyCon data_con) - [ lookup tv ty - | (tv,ty) <- univ_tvs `zip` out_inst_tys ] - lookup univ_tv ty = - case lookupVarEnv wrap_subst univ_tv of - Just co' -> co' - Nothing -> mkTcReflCo Nominal ty - in if null eq_spec - then rhs - else mkLHsWrap (mkWpCastN wrap_co) rhs - -- eq_spec is always null for a PatSynCon - PatSynCon _ -> rhs - - wrap_subst = - mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var)) - | (spec, eq_var) <- eq_spec `zip` eqs_vars - , let tv = eqSpecTyVar spec ] - - req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys - - pat = noLoc $ ConPatOut { pat_con = noLoc con - , pat_tvs = ex_tvs - , pat_dicts = eqs_vars ++ theta_vars - , pat_binds = emptyTcEvBinds - , pat_args = PrefixCon $ map nlVarPat arg_ids - , pat_arg_tys = in_inst_tys - , pat_wrap = req_wrap } - ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) } - -{- Note [Scrutinee in Record updates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider #17783: - - data PartialRec = No - | Yes { a :: Int, b :: Bool } - update No = No - update r@(Yes {}) = r { b = False } - -In the context of pattern-match checking, the occurrence of @r@ in -@r { b = False }@ is to be treated as if it was a scrutinee, as can be seen by -the following desugaring: - - r { b = False } ==> case r of Yes a b -> Yes a False - -Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above. --} - --- Here is where we desugar the Template Haskell brackets and escapes - --- Template Haskell stuff - -dsExpr (HsRnBracketOut _ _ _) = panic "dsExpr HsRnBracketOut" -dsExpr (HsTcBracketOut _ hs_wrapper x ps) = dsBracket hs_wrapper x ps -dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s) - --- Arrow notation extension -dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd - --- Hpc Support - -dsExpr (HsTick _ tickish e) = do - e' <- dsLExpr e - return (Tick tickish e') - --- There is a problem here. The then and else branches --- have no free variables, so they are open to lifting. --- We need someway of stopping this. --- This will make no difference to binary coverage --- (did you go here: YES or NO), but will effect accurate --- tick counting. - -dsExpr (HsBinTick _ ixT ixF e) = do - e2 <- dsLExpr e - do { ASSERT(exprType e2 `eqType` boolTy) - mkBinaryTickBox ixT ixF e2 - } - --- HsSyn constructs that just shouldn't be here: -dsExpr (HsBracket {}) = panic "dsExpr:HsBracket" -dsExpr (HsDo {}) = panic "dsExpr:HsDo" -dsExpr (HsRecFld {}) = panic "dsExpr:HsRecFld" - -ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr -ds_prag_expr (HsPragSCC _ _ cc) expr = do - dflags <- getDynFlags - if gopt Opt_SccProfilingOn dflags - then do - mod_name <- getModule - count <- goptM Opt_ProfCountEntries - let nm = sl_fs cc - flavour <- ExprCC <$> getCCIndexM nm - Tick (ProfNote (mkUserCC nm mod_name (getLoc expr) flavour) count True) - <$> dsLExpr expr - else dsLExpr expr -ds_prag_expr (HsPragCore _ _ _) expr - = dsLExpr expr -ds_prag_expr (HsPragTick _ _ _ _) expr = do - dflags <- getDynFlags - if gopt Opt_Hpc dflags - then panic "dsExpr:HsPragTick" - else dsLExpr expr -ds_prag_expr (XHsPragE x) _ = noExtCon x - ------------------------------- -dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr -dsSyntaxExpr (SyntaxExprTc { syn_expr = expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) - arg_exprs - = do { fun <- dsExpr expr - ; core_arg_wraps <- mapM dsHsWrapper arg_wraps - ; core_res_wrap <- dsHsWrapper res_wrap - ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs - ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ]) - (\_ -> core_res_wrap (mkApps fun wrapped_args)) } - where - mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr) -dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr" - -findField :: [LHsRecField GhcTc arg] -> Name -> [arg] -findField rbinds sel - = [hsRecFieldArg fld | L _ fld <- rbinds - , sel == idName (unLoc $ hsRecFieldId fld) ] - -{- -%-------------------------------------------------------------------- - -Note [Desugaring explicit lists] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Explicit lists are desugared in a cleverer way to prevent some -fruitless allocations. Essentially, whenever we see a list literal -[x_1, ..., x_n] we generate the corresponding expression in terms of -build: - -Explicit lists (literals) are desugared to allow build/foldr fusion when -beneficial. This is a bit of a trade-off, - - * build/foldr fusion can generate far larger code than the corresponding - cons-chain (e.g. see #11707) - - * even when it doesn't produce more code, build can still fail to fuse, - requiring that the simplifier do more work to bring the expression - back into cons-chain form; this costs compile time - - * when it works, fusion can be a significant win. Allocations are reduced - by up to 25% in some nofib programs. Specifically, - - Program Size Allocs Runtime CompTime - rewrite +0.0% -26.3% 0.02 -1.8% - ansi -0.3% -13.8% 0.00 +0.0% - lift +0.0% -8.7% 0.00 -2.3% - -At the moment we use a simple heuristic to determine whether build will be -fruitful: for small lists we assume the benefits of fusion will be worthwhile; -for long lists we assume that the benefits will be outweighted by the cost of -code duplication. This magic length threshold is @maxBuildLength@. Also, fusion -won't work at all if rewrite rules are disabled, so we don't use the build-based -desugaring in this case. - -We used to have a more complex heuristic which would try to break the list into -"static" and "dynamic" parts and only build-desugar the dynamic part. -Unfortunately, determining "static-ness" reliably is a bit tricky and the -heuristic at times produced surprising behavior (see #11710) so it was dropped. --} - -{- | The longest list length which we will desugar using @build@. - -This is essentially a magic number and its setting is unfortunate rather -arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists], -is to avoid deforesting large static data into large(r) code. Ideally we'd -want a smaller threshold with larger consumers and vice-versa, but we have no -way of knowing what will be consuming our list in the desugaring impossible to -set generally correctly. - -The effect of reducing this number will be that 'build' fusion is applied -less often. From a runtime performance perspective, applying 'build' more -liberally on "moderately" sized lists should rarely hurt and will often it can -only expose further optimization opportunities; if no fusion is possible it will -eventually get rule-rewritten back to a list). We do, however, pay in compile -time. --} -maxBuildLength :: Int -maxBuildLength = 32 - -dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] - -> DsM CoreExpr --- See Note [Desugaring explicit lists] -dsExplicitList elt_ty Nothing xs - = do { dflags <- getDynFlags - ; xs' <- mapM dsLExprNoLP xs - ; if xs' `lengthExceeds` maxBuildLength - -- Don't generate builds if the list is very long. - || null xs' - -- Don't generate builds when the [] constructor will do - || not (gopt Opt_EnableRewriteRules dflags) -- Rewrite rules off - -- Don't generate a build if there are no rules to eliminate it! - -- See Note [Desugaring RULE left hand sides] in Desugar - then return $ mkListExpr elt_ty xs' - else mkBuildExpr elt_ty (mk_build_list xs') } - where - mk_build_list xs' (cons, _) (nil, _) - = return (foldr (App . App (Var cons)) (Var nil) xs') - -dsExplicitList elt_ty (Just fln) xs - = do { list <- dsExplicitList elt_ty Nothing xs - ; dflags <- getDynFlags - ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] } - -dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr -dsArithSeq expr (From from) - = App <$> dsExpr expr <*> dsLExprNoLP from -dsArithSeq expr (FromTo from to) - = do dflags <- getDynFlags - warnAboutEmptyEnumerations dflags from Nothing to - expr' <- dsExpr expr - from' <- dsLExprNoLP from - to' <- dsLExprNoLP to - return $ mkApps expr' [from', to'] -dsArithSeq expr (FromThen from thn) - = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn] -dsArithSeq expr (FromThenTo from thn to) - = do dflags <- getDynFlags - warnAboutEmptyEnumerations dflags from (Just thn) to - expr' <- dsExpr expr - from' <- dsLExprNoLP from - thn' <- dsLExprNoLP thn - to' <- dsLExprNoLP to - return $ mkApps expr' [from', thn', to'] - -{- -Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're -handled in DsListComp). Basically does the translation given in the -Haskell 98 report: --} - -dsDo :: [ExprLStmt GhcTc] -> DsM CoreExpr -dsDo stmts - = goL stmts - where - goL [] = panic "dsDo" - goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - - go _ (LastStmt _ body _ _) stmts - = ASSERT( null stmts ) dsLExpr body - -- The 'return' op isn't used for 'do' expressions - - go _ (BodyStmt _ rhs then_expr _) stmts - = do { rhs2 <- dsLExpr rhs - ; warnDiscardedDoBindings rhs (exprType rhs2) - ; rest <- goL stmts - ; dsSyntaxExpr then_expr [rhs2, rest] } - - go _ (LetStmt _ binds) stmts - = do { rest <- goL stmts - ; dsLocalBinds binds rest } - - go _ (BindStmt res1_ty pat rhs bind_op fail_op) stmts - = do { body <- goL stmts - ; rhs' <- dsLExpr rhs - ; var <- selectSimpleMatchVarL pat - ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat - res1_ty (cantFailMatchResult body) - ; match_code <- dsHandleMonadicFailure pat match fail_op - ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } - - go _ (ApplicativeStmt body_ty args mb_join) stmts - = do { - let - (pats, rhss) = unzip (map (do_arg . snd) args) - - do_arg (ApplicativeArgOne _ pat expr _ fail_op) = - ((pat, fail_op), dsLExpr expr) - do_arg (ApplicativeArgMany _ stmts ret pat) = - ((pat, noSyntaxExpr), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)])) - do_arg (XApplicativeArg nec) = noExtCon nec - - ; rhss' <- sequence rhss - - ; body' <- dsLExpr $ noLoc $ HsDo body_ty DoExpr (noLoc stmts) - - ; let match_args (pat, fail_op) (vs,body) - = do { var <- selectSimpleMatchVarL pat - ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat - body_ty (cantFailMatchResult body) - ; match_code <- dsHandleMonadicFailure pat match fail_op - ; return (var:vs, match_code) - } - - ; (vars, body) <- foldrM match_args ([],body') pats - ; let fun' = mkLams vars body - ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r] - ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss') - ; case mb_join of - Nothing -> return expr - Just join_op -> dsSyntaxExpr join_op [expr] } - - go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids - , recS_rec_ids = rec_ids, recS_ret_fn = return_op - , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op - , recS_ext = RecStmtTc - { recS_bind_ty = bind_ty - , recS_rec_rets = rec_rets - , recS_ret_ty = body_ty} }) stmts - = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' } - where - new_bind_stmt = L loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats) - mfix_app bind_op - noSyntaxExpr -- Tuple cannot fail - - tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids - tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case - rec_tup_pats = map nlVarPat tup_ids - later_pats = rec_tup_pats - rets = map noLoc rec_rets - mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] - mfix_arg = noLoc $ HsLam noExtField - (MG { mg_alts = noLoc [mkSimpleMatch - LambdaExpr - [mfix_pat] body] - , mg_ext = MatchGroupTc [tup_ty] body_ty - , mg_origin = Generated }) - mfix_pat = noLoc $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats - body = noLoc $ HsDo body_ty - DoExpr (noLoc (rec_stmts ++ [ret_stmt])) - ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets] - ret_stmt = noLoc $ mkLastStmt ret_app - -- This LastStmt will be desugared with dsDo, - -- which ignores the return_op in the LastStmt, - -- so we must apply the return_op explicitly - - go _ (ParStmt {}) _ = panic "dsDo ParStmt" - go _ (TransStmt {}) _ = panic "dsDo TransStmt" - go _ (XStmtLR nec) _ = noExtCon nec - -dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr - -- In a do expression, pattern-match failure just calls - -- the monadic 'fail' rather than throwing an exception -dsHandleMonadicFailure pat match fail_op - | matchCanFail match - = do { dflags <- getDynFlags - ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat) - ; fail_expr <- dsSyntaxExpr fail_op [fail_msg] - ; extractMatchResult match fail_expr } - | otherwise - = extractMatchResult match (error "It can't fail") - -mk_fail_msg :: DynFlags -> Located e -> String -mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ - showPpr dflags (getLoc pat) - -{- -************************************************************************ -* * - Desugaring Variables -* * -************************************************************************ --} - -dsHsVar :: Id -> DsM CoreExpr -dsHsVar var - -- See Wrinkle in Note [Detecting forced eta expansion] - = ASSERT2(null (badUseOfLevPolyPrimop var ty), ppr var $$ ppr ty) - return (varToCoreExpr var) -- See Note [Desugaring vars] - - where - ty = idType var - -dsConLike :: ConLike -> DsM CoreExpr -dsConLike (RealDataCon dc) = dsHsVar (dataConWrapId dc) -dsConLike (PatSynCon ps) = return $ case patSynBuilder ps of - Just (id, add_void) - | add_void -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId) - | otherwise -> Var id - _ -> pprPanic "dsConLike" (ppr ps) - -{- -************************************************************************ -* * -\subsection{Errors and contexts} -* * -************************************************************************ --} - --- Warn about certain types of values discarded in monadic bindings (#3263) -warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM () -warnDiscardedDoBindings rhs rhs_ty - | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty - = do { warn_unused <- woptM Opt_WarnUnusedDoBind - ; warn_wrong <- woptM Opt_WarnWrongDoBind - ; when (warn_unused || warn_wrong) $ - do { fam_inst_envs <- dsGetFamInstEnvs - ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty - - -- Warn about discarding non-() things in 'monadic' binding - ; if warn_unused && not (isUnitTy norm_elt_ty) - then warnDs (Reason Opt_WarnUnusedDoBind) - (badMonadBind rhs elt_ty) - else - - -- Warn about discarding m a things in 'monadic' binding of the same type, - -- but only if we didn't already warn due to Opt_WarnUnusedDoBind - when warn_wrong $ - do { case tcSplitAppTy_maybe norm_elt_ty of - Just (elt_m_ty, _) - | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty - -> warnDs (Reason Opt_WarnWrongDoBind) - (badMonadBind rhs elt_ty) - _ -> return () } } } - - | otherwise -- RHS does have type of form (m ty), which is weird - = return () -- but at least this warning is irrelevant - -badMonadBind :: LHsExpr GhcTc -> Type -> SDoc -badMonadBind rhs elt_ty - = vcat [ hang (text "A do-notation statement discarded a result of type") - 2 (quotes (ppr elt_ty)) - , hang (text "Suppress this warning by saying") - 2 (quotes $ text "_ <-" <+> ppr rhs) - ] - -{- -************************************************************************ -* * - Forced eta expansion and levity polymorphism -* * -************************************************************************ - -Note [Detecting forced eta expansion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We cannot have levity polymorphic function arguments. See -Note [Levity polymorphism invariants] in CoreSyn. But we *can* have -functions that take levity polymorphic arguments, as long as these -functions are eta-reduced. (See #12708 for an example.) - -However, we absolutely cannot do this for functions that have no -binding (i.e., say True to Id.hasNoBinding), like primops and unboxed -tuple constructors. These get eta-expanded in CorePrep.maybeSaturate. - -Detecting when this is about to happen is a bit tricky, though. When -the desugarer is looking at the Id itself (let's be concrete and -suppose we have (#,#)), we don't know whether it will be levity -polymorphic. So the right spot seems to be to look after the Id has -been applied to its type arguments. To make the algorithm efficient, -it's important to be able to spot ((#,#) @a @b @c @d) without looking -past all the type arguments. We thus require that - * The body of an HsWrap is not an HsWrap, nor an HsPar. -This invariant is checked in dsExpr. -With that representation invariant, we simply look inside every HsWrap -to see if its body is an HsVar whose Id hasNoBinding. Then, we look -at the wrapped type. If it has any levity polymorphic arguments, reject. - -Interestingly, this approach does not look to see whether the Id in -question will be eta expanded. The logic is this: - * Either the Id in question is saturated or not. - * If it is, then it surely can't have levity polymorphic arguments. - If its wrapped type contains levity polymorphic arguments, reject. - * If it's not, then it can't be eta expanded with levity polymorphic - argument. If its wrapped type contains levity polymorphic arguments, reject. -So, either way, we're good to reject. - -Wrinkle -~~~~~~~ -Currently, all levity-polymorphic Ids are wrapped in HsWrap. - -However, this is not set in stone, in the future we might make -instantiation more lazy. (See "Visible type application", ESOP '16.) -If we spot a levity-polymorphic hasNoBinding Id without a wrapper, -then that is surely a problem. In this case, we raise an assertion failure. -This failure can be changed to a call to `levPolyPrimopErr` in the future, -if we decide to change instantiation. - -We can just check HsVar and HsConLikeOut for RealDataCon, since -we don't have levity-polymorphic pattern synonyms. (This might change -in the future.) --} - --- | Takes an expression and its instantiated type. If the expression is an --- HsVar with a hasNoBinding primop and the type has levity-polymorphic arguments, --- issue an error. See Note [Detecting forced eta expansion] -checkForcedEtaExpansion :: HsExpr GhcTc -> SDoc -> Type -> DsM () -checkForcedEtaExpansion expr expr_doc ty - | Just var <- case expr of - HsVar _ (L _ var) -> Just var - HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc) - _ -> Nothing - , let bad_tys = badUseOfLevPolyPrimop var ty - , not (null bad_tys) - = levPolyPrimopErr expr_doc ty bad_tys -checkForcedEtaExpansion _ _ _ = return () - --- | Is this a hasNoBinding Id with a levity-polymorphic type? --- Returns the arguments that are levity polymorphic if they are bad; --- or an empty list otherwise --- See Note [Detecting forced eta expansion] -badUseOfLevPolyPrimop :: Id -> Type -> [Type] -badUseOfLevPolyPrimop id ty - | hasNoBinding id - = filter isTypeLevPoly arg_tys - | otherwise - = [] - where - (binders, _) = splitPiTys ty - arg_tys = mapMaybe binderRelevantType_maybe binders - -levPolyPrimopErr :: SDoc -> Type -> [Type] -> DsM () -levPolyPrimopErr expr_doc ty bad_tys - = errDs $ vcat - [ hang (text "Cannot use function with levity-polymorphic arguments:") - 2 (expr_doc <+> dcolon <+> pprWithTYPE ty) - , sdocWithDynFlags $ \dflags -> - if not (gopt Opt_PrintTypecheckerElaboration dflags) then vcat - [ text "(Note that levity-polymorphic primops such as 'coerce' and unboxed tuples" - , text "are eta-expanded internally because they must occur fully saturated." - , text "Use -fprint-typechecker-elaboration to display the full expression.)" - ] else empty - , hang (text "Levity-polymorphic arguments:") - 2 $ vcat $ map - (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t)) - bad_tys - ] diff --git a/compiler/deSugar/DsExpr.hs-boot b/compiler/deSugar/DsExpr.hs-boot deleted file mode 100644 index e3eed65538..0000000000 --- a/compiler/deSugar/DsExpr.hs-boot +++ /dev/null @@ -1,12 +0,0 @@ -module DsExpr where -import GHC.Hs ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr ) -import DsMonad ( DsM, MatchResult ) -import CoreSyn ( CoreExpr ) -import GHC.Hs.Extension ( GhcTc) - -dsExpr :: HsExpr GhcTc -> DsM CoreExpr -dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr -dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr -dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr - -dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs deleted file mode 100644 index 5c2b1a8a22..0000000000 --- a/compiler/deSugar/DsForeign.hs +++ /dev/null @@ -1,820 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1998 - - -Desugaring foreign declarations (see also DsCCall). --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module DsForeign ( dsForeigns ) where - -#include "HsVersions.h" -import GhcPrelude - -import TcRnMonad -- temp - -import CoreSyn - -import DsCCall -import DsMonad - -import GHC.Hs -import DataCon -import CoreUnfold -import Id -import Literal -import Module -import Name -import Type -import GHC.Types.RepType -import TyCon -import Coercion -import TcEnv -import TcType - -import GHC.Cmm.Expr -import GHC.Cmm.Utils -import HscTypes -import ForeignCall -import TysWiredIn -import TysPrim -import PrelNames -import BasicTypes -import SrcLoc -import Outputable -import FastString -import DynFlags -import GHC.Platform -import OrdList -import Util -import Hooks -import Encoding - -import Data.Maybe -import Data.List - -{- -Desugaring of @foreign@ declarations is naturally split up into -parts, an @import@ and an @export@ part. A @foreign import@ -declaration -\begin{verbatim} - foreign import cc nm f :: prim_args -> IO prim_res -\end{verbatim} -is the same as -\begin{verbatim} - f :: prim_args -> IO prim_res - f a1 ... an = _ccall_ nm cc a1 ... an -\end{verbatim} -so we reuse the desugaring code in @DsCCall@ to deal with these. --} - -type Binding = (Id, CoreExpr) -- No rec/nonrec structure; - -- the occurrence analyser will sort it all out - -dsForeigns :: [LForeignDecl GhcTc] - -> DsM (ForeignStubs, OrdList Binding) -dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos) - -dsForeigns' :: [LForeignDecl GhcTc] - -> DsM (ForeignStubs, OrdList Binding) -dsForeigns' [] - = return (NoStubs, nilOL) -dsForeigns' fos = do - fives <- mapM do_ldecl fos - let - (hs, cs, idss, bindss) = unzip4 fives - fe_ids = concat idss - fe_init_code = map foreignExportInitialiser fe_ids - -- - return (ForeignStubs - (vcat hs) - (vcat cs $$ vcat fe_init_code), - foldr (appOL . toOL) nilOL bindss) - where - do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl) - - do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do - traceIf (text "fi start" <+> ppr id) - let id' = unLoc id - (bs, h, c) <- dsFImport id' co spec - traceIf (text "fi end" <+> ppr id) - return (h, c, [], bs) - - do_decl (ForeignExport { fd_name = L _ id - , fd_e_ext = co - , fd_fe = CExport - (L _ (CExportStatic _ ext_nm cconv)) _ }) = do - (h, c, _, _) <- dsFExport id co ext_nm cconv False - return (h, c, [id], []) - do_decl (XForeignDecl nec) = noExtCon nec - -{- -************************************************************************ -* * -\subsection{Foreign import} -* * -************************************************************************ - -Desugaring foreign imports is just the matter of creating a binding -that on its RHS unboxes its arguments, performs the external call -(using the @CCallOp@ primop), before boxing the result up and returning it. - -However, we create a worker/wrapper pair, thus: - - foreign import f :: Int -> IO Int -==> - f x = IO ( \s -> case x of { I# x# -> - case fw s x# of { (# s1, y# #) -> - (# s1, I# y# #)}}) - - fw s x# = ccall f s x# - -The strictness/CPR analyser won't do this automatically because it doesn't look -inside returned tuples; but inlining this wrapper is a Really Good Idea -because it exposes the boxing to the call site. --} - -dsFImport :: Id - -> Coercion - -> ForeignImport - -> DsM ([Binding], SDoc, SDoc) -dsFImport id co (CImport cconv safety mHeader spec _) = - dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader - -dsCImport :: Id - -> Coercion - -> CImportSpec - -> CCallConv - -> Safety - -> Maybe Header - -> DsM ([Binding], SDoc, SDoc) -dsCImport id co (CLabel cid) cconv _ _ = do - dflags <- getDynFlags - let ty = coercionLKind co - fod = case tyConAppTyCon_maybe (dropForAlls ty) of - Just tycon - | tyConUnique tycon == funPtrTyConKey -> - IsFunction - _ -> IsData - (resTy, foRhs) <- resultWrapper ty - ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this - let - rhs = foRhs (Lit (LitLabel cid stdcall_info fod)) - rhs' = Cast rhs co - stdcall_info = fun_type_arg_stdcall_info dflags cconv ty - in - return ([(id, rhs')], empty, empty) - -dsCImport id co (CFunction target) cconv@PrimCallConv safety _ - = dsPrimCall id co (CCall (CCallSpec target cconv safety)) -dsCImport id co (CFunction target) cconv safety mHeader - = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader -dsCImport id co CWrapper cconv _ _ - = dsFExportDynamic id co cconv - --- For stdcall labels, if the type was a FunPtr or newtype thereof, --- then we need to calculate the size of the arguments in order to add --- the @n suffix to the label. -fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int -fun_type_arg_stdcall_info dflags StdCallConv ty - | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty, - tyConUnique tc == funPtrTyConKey - = let - (bndrs, _) = tcSplitPiTys arg_ty - fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs - in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys) -fun_type_arg_stdcall_info _ _other_conv _ - = Nothing - -{- -************************************************************************ -* * -\subsection{Foreign calls} -* * -************************************************************************ --} - -dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header - -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) -dsFCall fn_id co fcall mDeclHeader = do - let - ty = coercionLKind co - (tv_bndrs, rho) = tcSplitForAllVarBndrs ty - (arg_tys, io_res_ty) = tcSplitFunTys rho - - args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism - (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args) - - let - work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars - - (ccall_result_ty, res_wrapper) <- boxResult io_res_ty - - ccall_uniq <- newUnique - work_uniq <- newUnique - - dflags <- getDynFlags - (fcall', cDoc) <- - case fcall of - CCall (CCallSpec (StaticTarget _ cName mUnitId isFun) - CApiConv safety) -> - do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName) - let fcall' = CCall (CCallSpec - (StaticTarget NoSourceText - wrapperName mUnitId - True) - CApiConv safety) - c = includes - $$ fun_proto <+> braces (cRet <> semi) - includes = vcat [ text "#include \"" <> ftext h - <> text "\"" - | Header _ h <- nub headers ] - fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes - cRet - | isVoidRes = cCall - | otherwise = text "return" <+> cCall - cCall = if isFun - then ppr cName <> parens argVals - else if null arg_tys - then ppr cName - else panic "dsFCall: Unexpected arguments to FFI value import" - raw_res_ty = case tcSplitIOType_maybe io_res_ty of - Just (_ioTyCon, res_ty) -> res_ty - Nothing -> io_res_ty - isVoidRes = raw_res_ty `eqType` unitTy - (mHeader, cResType) - | isVoidRes = (Nothing, text "void") - | otherwise = toCType raw_res_ty - pprCconv = ccallConvAttribute CApiConv - mHeadersArgTypeList - = [ (header, cType <+> char 'a' <> int n) - | (t, n) <- zip arg_tys [1..] - , let (header, cType) = toCType t ] - (mHeaders, argTypeList) = unzip mHeadersArgTypeList - argTypes = if null argTypeList - then text "void" - else hsep $ punctuate comma argTypeList - mHeaders' = mDeclHeader : mHeader : mHeaders - headers = catMaybes mHeaders' - argVals = hsep $ punctuate comma - [ char 'a' <> int n - | (_, n) <- zip arg_tys [1..] ] - return (fcall', c) - _ -> - return (fcall, empty) - let - -- Build the worker - worker_ty = mkForAllTys tv_bndrs (mkVisFunTys (map idType work_arg_ids) ccall_result_ty) - tvs = map binderVar tv_bndrs - the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty - work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) - work_id = mkSysLocal (fsLit "$wccall") work_uniq worker_ty - - -- Build the wrapper - work_app = mkApps (mkVarApps (Var work_id) tvs) val_args - wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers - wrap_rhs = mkLams (tvs ++ args) wrapper_body - wrap_rhs' = Cast wrap_rhs co - fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity - (length args) wrap_rhs' - - return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc) - -{- -************************************************************************ -* * -\subsection{Primitive calls} -* * -************************************************************************ - -This is for `@foreign import prim@' declarations. - -Currently, at the core level we pretend that these primitive calls are -foreign calls. It may make more sense in future to have them as a distinct -kind of Id, or perhaps to bundle them with PrimOps since semantically and -for calling convention they are really prim ops. --} - -dsPrimCall :: Id -> Coercion -> ForeignCall - -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) -dsPrimCall fn_id co fcall = do - let - ty = coercionLKind co - (tvs, fun_ty) = tcSplitForAllTys ty - (arg_tys, io_res_ty) = tcSplitFunTys fun_ty - - args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism - - ccall_uniq <- newUnique - dflags <- getDynFlags - let - call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty - rhs = mkLams tvs (mkLams args call_app) - rhs' = Cast rhs co - return ([(fn_id, rhs')], empty, empty) - -{- -************************************************************************ -* * -\subsection{Foreign export} -* * -************************************************************************ - -The function that does most of the work for `@foreign export@' declarations. -(see below for the boilerplate code a `@foreign export@' declaration expands - into.) - -For each `@foreign export foo@' in a module M we generate: -\begin{itemize} -\item a C function `@foo@', which calls -\item a Haskell stub `@M.\$ffoo@', which calls -\end{itemize} -the user-written Haskell function `@M.foo@'. --} - -dsFExport :: Id -- Either the exported Id, - -- or the foreign-export-dynamic constructor - -> Coercion -- Coercion between the Haskell type callable - -- from C, and its representation type - -> CLabelString -- The name to export to C land - -> CCallConv - -> Bool -- True => foreign export dynamic - -- so invoke IO action that's hanging off - -- the first argument's stable pointer - -> DsM ( SDoc -- contents of Module_stub.h - , SDoc -- contents of Module_stub.c - , String -- string describing type to pass to createAdj. - , Int -- size of args to stub function - ) - -dsFExport fn_id co ext_name cconv isDyn = do - let - ty = coercionRKind co - (bndrs, orig_res_ty) = tcSplitPiTys ty - fe_arg_tys' = mapMaybe binderRelevantType_maybe bndrs - -- We must use tcSplits here, because we want to see - -- the (IO t) in the corner of the type! - fe_arg_tys | isDyn = tail fe_arg_tys' - | otherwise = fe_arg_tys' - - -- Look at the result type of the exported function, orig_res_ty - -- If it's IO t, return (t, True) - -- If it's plain t, return (t, False) - (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of - -- The function already returns IO t - Just (_ioTyCon, res_ty) -> (res_ty, True) - -- The function returns t - Nothing -> (orig_res_ty, False) - - dflags <- getDynFlags - return $ - mkFExportCBits dflags ext_name - (if isDyn then Nothing else Just fn_id) - fe_arg_tys res_ty is_IO_res_ty cconv - -{- -@foreign import "wrapper"@ (previously "foreign export dynamic") lets -you dress up Haskell IO actions of some fixed type behind an -externally callable interface (i.e., as a C function pointer). Useful -for callbacks and stuff. - -\begin{verbatim} -type Fun = Bool -> Int -> IO Int -foreign import "wrapper" f :: Fun -> IO (FunPtr Fun) - --- Haskell-visible constructor, which is generated from the above: --- SUP: No check for NULL from createAdjustor anymore??? - -f :: Fun -> IO (FunPtr Fun) -f cback = - bindIO (newStablePtr cback) - (\StablePtr sp# -> IO (\s1# -> - case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of - (# s2#, a# #) -> (# s2#, A# a# #))) - -foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun) - --- and the helper in C: (approximately; see `mkFExportCBits` below) - -f_helper(StablePtr s, HsBool b, HsInt i) -{ - Capability *cap; - cap = rts_lock(); - rts_evalIO(&cap, - rts_apply(rts_apply(deRefStablePtr(s), - rts_mkBool(b)), rts_mkInt(i))); - rts_unlock(cap); -} -\end{verbatim} --} - -dsFExportDynamic :: Id - -> Coercion - -> CCallConv - -> DsM ([Binding], SDoc, SDoc) -dsFExportDynamic id co0 cconv = do - mod <- getModule - dflags <- getDynFlags - let fe_nm = mkFastString $ zEncodeString - (moduleStableString mod ++ "$" ++ toCName dflags id) - -- Construct the label based on the passed id, don't use names - -- depending on Unique. See #13807 and Note [Unique Determinism]. - cback <- newSysLocalDs arg_ty - newStablePtrId <- dsLookupGlobalId newStablePtrName - stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName - let - stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty] - export_ty = mkVisFunTy stable_ptr_ty arg_ty - bindIOId <- dsLookupGlobalId bindIOName - stbl_value <- newSysLocalDs stable_ptr_ty - (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True - let - {- - The arguments to the external function which will - create a little bit of (template) code on the fly - for allowing the (stable pointed) Haskell closure - to be entered using an external calling convention - (stdcall, ccall). - -} - adj_args = [ mkIntLitInt dflags (ccallConvToInt cconv) - , Var stbl_value - , Lit (LitLabel fe_nm mb_sz_args IsFunction) - , Lit (mkLitString typestring) - ] - -- name of external entry point providing these services. - -- (probably in the RTS.) - adjustor = fsLit "createAdjustor" - - -- Determine the number of bytes of arguments to the stub function, - -- so that we can attach the '@N' suffix to its label if it is a - -- stdcall on Windows. - mb_sz_args = case cconv of - StdCallConv -> Just args_size - _ -> Nothing - - ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty]) - -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback - - let io_app = mkLams tvs $ - Lam cback $ - mkApps (Var bindIOId) - [ Type stable_ptr_ty - , Type res_ty - , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ] - , Lam stbl_value ccall_adj - ] - - fed = (id `setInlineActivation` NeverActive, Cast io_app co0) - -- Never inline the f.e.d. function, because the litlit - -- might not be in scope in other modules. - - return ([fed], h_code, c_code) - - where - ty = coercionLKind co0 - (tvs,sans_foralls) = tcSplitForAllTys ty - ([arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls - Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty - -- Must have an IO type; hence Just - - -toCName :: DynFlags -> Id -> String -toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i))) - -{- -* - -\subsection{Generating @foreign export@ stubs} - -* - -For each @foreign export@ function, a C stub function is generated. -The C stub constructs the application of the exported Haskell function -using the hugs/ghc rts invocation API. --} - -mkFExportCBits :: DynFlags - -> FastString - -> Maybe Id -- Just==static, Nothing==dynamic - -> [Type] - -> Type - -> Bool -- True <=> returns an IO type - -> CCallConv - -> (SDoc, - SDoc, - String, -- the argument reps - Int -- total size of arguments - ) -mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc - = (header_bits, c_bits, type_string, - sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args - -- NB. the calculation here isn't strictly speaking correct. - -- We have a primitive Haskell type (eg. Int#, Double#), and - -- we want to know the size, when passed on the C stack, of - -- the associated C type (eg. HsInt, HsDouble). We don't have - -- this information to hand, but we know what GHC's conventions - -- are for passing around the primitive Haskell types, so we - -- use that instead. I hope the two coincide --SDM - ) - where - -- list the arguments to the C function - arg_info :: [(SDoc, -- arg name - SDoc, -- C type - Type, -- Haskell type - CmmType)] -- the CmmType - arg_info = [ let stg_type = showStgType ty in - (arg_cname n stg_type, - stg_type, - ty, - typeCmmType dflags (getPrimTyOf ty)) - | (ty,n) <- zip arg_htys [1::Int ..] ] - - arg_cname n stg_ty - | libffi = char '*' <> parens (stg_ty <> char '*') <> - text "args" <> brackets (int (n-1)) - | otherwise = text ('a':show n) - - -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled - libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target - - type_string - -- libffi needs to know the result type too: - | libffi = primTyDescChar dflags res_hty : arg_type_string - | otherwise = arg_type_string - - arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info] - -- just the real args - - -- add some auxiliary args; the stable ptr in the wrapper case, and - -- a slot for the dummy return address in the wrapper + ccall case - aug_arg_info - | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info - | otherwise = arg_info - - stable_ptr_arg = - (text "the_stableptr", text "StgStablePtr", undefined, - typeCmmType dflags (mkStablePtrPrimTy alphaTy)) - - -- stuff to do with the return type of the C function - res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes - - cResType | res_hty_is_unit = text "void" - | otherwise = showStgType res_hty - - -- when the return type is integral and word-sized or smaller, it - -- must be assigned as type ffi_arg (#3516). To see what type - -- libffi is expecting here, take a look in its own testsuite, e.g. - -- libffi/testsuite/libffi.call/cls_align_ulonglong.c - ffi_cResType - | is_ffi_arg_type = text "ffi_arg" - | otherwise = cResType - where - res_ty_key = getUnique (getName (typeTyCon res_hty)) - is_ffi_arg_type = res_ty_key `notElem` - [floatTyConKey, doubleTyConKey, - int64TyConKey, word64TyConKey] - - -- Now we can cook up the prototype for the exported function. - pprCconv = ccallConvAttribute cc - - header_bits = text "extern" <+> fun_proto <> semi - - fun_args - | null aug_arg_info = text "void" - | otherwise = hsep $ punctuate comma - $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info - - fun_proto - | libffi - = text "void" <+> ftext c_nm <> - parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr") - | otherwise - = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args - - -- the target which will form the root of what we ask rts_evalIO to run - the_cfun - = case maybe_target of - Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)" - Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure" - - cap = text "cap" <> comma - - -- the expression we give to rts_evalIO - expr_to_run - = foldl' appArg the_cfun arg_info -- NOT aug_arg_info - where - appArg acc (arg_cname, _, arg_hty, _) - = text "rts_apply" - <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname)) - - -- various other bits for inside the fn - declareResult = text "HaskellObj ret;" - declareCResult | res_hty_is_unit = empty - | otherwise = cResType <+> text "cret;" - - assignCResult | res_hty_is_unit = empty - | otherwise = - text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi - - -- an extern decl for the fn being called - extern_decl - = case maybe_target of - Nothing -> empty - Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi - - - -- finally, the whole darn thing - c_bits = - space $$ - extern_decl $$ - fun_proto $$ - vcat - [ lbrace - , text "Capability *cap;" - , declareResult - , declareCResult - , text "cap = rts_lock();" - -- create the application + perform it. - , text "rts_evalIO" <> parens ( - char '&' <> cap <> - text "rts_apply" <> parens ( - cap <> - text "(HaskellObj)" - <> ptext (if is_IO_res_ty - then (sLit "runIO_closure") - else (sLit "runNonIO_closure")) - <> comma - <> expr_to_run - ) <+> comma - <> text "&ret" - ) <> semi - , text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm) - <> comma <> text "cap") <> semi - , assignCResult - , text "rts_unlock(cap);" - , ppUnless res_hty_is_unit $ - if libffi - then char '*' <> parens (ffi_cResType <> char '*') <> - text "resp = cret;" - else text "return cret;" - , rbrace - ] - - -foreignExportInitialiser :: Id -> SDoc -foreignExportInitialiser hs_fn = - -- Initialise foreign exports by registering a stable pointer from an - -- __attribute__((constructor)) function. - -- The alternative is to do this from stginit functions generated in - -- codeGen/CodeGen.hs; however, stginit functions have a negative impact - -- on binary sizes and link times because the static linker will think that - -- all modules that are imported directly or indirectly are actually used by - -- the program. - -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL) - vcat - [ text "static void stginit_export_" <> ppr hs_fn - <> text "() __attribute__((constructor));" - , text "static void stginit_export_" <> ppr hs_fn <> text "()" - , braces (text "foreignExportStablePtr" - <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure") - <> semi) - ] - - -mkHObj :: Type -> SDoc -mkHObj t = text "rts_mk" <> text (showFFIType t) - -unpackHObj :: Type -> SDoc -unpackHObj t = text "rts_get" <> text (showFFIType t) - -showStgType :: Type -> SDoc -showStgType t = text "Hs" <> text (showFFIType t) - -showFFIType :: Type -> String -showFFIType t = getOccString (getName (typeTyCon t)) - -toCType :: Type -> (Maybe Header, SDoc) -toCType = f False - where f voidOK t - -- First, if we have (Ptr t) of (FunPtr t), then we need to - -- convert t to a C type and put a * after it. If we don't - -- know a type for t, then "void" is fine, though. - | Just (ptr, [t']) <- splitTyConApp_maybe t - , tyConName ptr `elem` [ptrTyConName, funPtrTyConName] - = case f True t' of - (mh, cType') -> - (mh, cType' <> char '*') - -- Otherwise, if we have a type constructor application, then - -- see if there is a C type associated with that constructor. - -- Note that we aren't looking through type synonyms or - -- anything, as it may be the synonym that is annotated. - | Just tycon <- tyConAppTyConPicky_maybe t - , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon - = (mHeader, ftext cType) - -- If we don't know a C type for this type, then try looking - -- through one layer of type synonym etc. - | Just t' <- coreView t - = f voidOK t' - -- This may be an 'UnliftedFFITypes'-style ByteArray# argument - -- (which is marshalled like a Ptr) - | Just byteArrayPrimTyCon == tyConAppTyConPicky_maybe t - = (Nothing, text "const void*") - | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t - = (Nothing, text "void*") - -- Otherwise we don't know the C type. If we are allowing - -- void then return that; otherwise something has gone wrong. - | voidOK = (Nothing, text "void") - | otherwise - = pprPanic "toCType" (ppr t) - -typeTyCon :: Type -> TyCon -typeTyCon ty - | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty) - = tc - | otherwise - = pprPanic "DsForeign.typeTyCon" (ppr ty) - -insertRetAddr :: DynFlags -> CCallConv - -> [(SDoc, SDoc, Type, CmmType)] - -> [(SDoc, SDoc, Type, CmmType)] -insertRetAddr dflags CCallConv args - = case platformArch platform of - ArchX86_64 - | platformOS platform == OSMinGW32 -> - -- On other Windows x86_64 we insert the return address - -- after the 4th argument, because this is the point - -- at which we need to flush a register argument to the stack - -- (See rts/Adjustor.c for details). - let go :: Int -> [(SDoc, SDoc, Type, CmmType)] - -> [(SDoc, SDoc, Type, CmmType)] - go 4 args = ret_addr_arg dflags : args - go n (arg:args) = arg : go (n+1) args - go _ [] = [] - in go 0 args - | otherwise -> - -- On other x86_64 platforms we insert the return address - -- after the 6th integer argument, because this is the point - -- at which we need to flush a register argument to the stack - -- (See rts/Adjustor.c for details). - let go :: Int -> [(SDoc, SDoc, Type, CmmType)] - -> [(SDoc, SDoc, Type, CmmType)] - go 6 args = ret_addr_arg dflags : args - go n (arg@(_,_,_,rep):args) - | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args - | otherwise = arg : go n args - go _ [] = [] - in go 0 args - _ -> - ret_addr_arg dflags : args - where platform = targetPlatform dflags -insertRetAddr _ _ args = args - -ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType) -ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined, - typeCmmType dflags addrPrimTy) - --- This function returns the primitive type associated with the boxed --- type argument to a foreign export (eg. Int ==> Int#). -getPrimTyOf :: Type -> UnaryType -getPrimTyOf ty - | isBoolTy rep_ty = intPrimTy - -- Except for Bool, the types we are interested in have a single constructor - -- with a single primitive-typed argument (see TcType.legalFEArgTyCon). - | otherwise = - case splitDataProductType_maybe rep_ty of - Just (_, _, data_con, [prim_ty]) -> - ASSERT(dataConSourceArity data_con == 1) - ASSERT2(isUnliftedType prim_ty, ppr prim_ty) - prim_ty - _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty) - where - rep_ty = unwrapType ty - --- represent a primitive type as a Char, for building a string that --- described the foreign function type. The types are size-dependent, --- e.g. 'W' is a signed 32-bit integer. -primTyDescChar :: DynFlags -> Type -> Char -primTyDescChar dflags ty - | ty `eqType` unitTy = 'v' - | otherwise - = case typePrimRep1 (getPrimTyOf ty) of - IntRep -> signed_word - WordRep -> unsigned_word - Int64Rep -> 'L' - Word64Rep -> 'l' - AddrRep -> 'p' - FloatRep -> 'f' - DoubleRep -> 'd' - _ -> pprPanic "primTyDescChar" (ppr ty) - where - (signed_word, unsigned_word) - | wORD_SIZE dflags == 4 = ('W','w') - | wORD_SIZE dflags == 8 = ('L','l') - | otherwise = panic "primTyDescChar" diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs deleted file mode 100644 index a424bd9d7b..0000000000 --- a/compiler/deSugar/DsGRHSs.hs +++ /dev/null @@ -1,155 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Matching guarded right-hand-sides (GRHSs) --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} - -module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds ) -import {-# SOURCE #-} Match ( matchSinglePatVar ) - -import GHC.Hs -import MkCore -import CoreSyn -import CoreUtils (bindNonRec) - -import BasicTypes (Origin(FromSource)) -import DynFlags -import GHC.HsToCore.PmCheck (needToRunPmCheck, addTyCsDs, addPatTmCs, addScrutTmCs) -import DsMonad -import DsUtils -import Type ( Type ) -import Util -import SrcLoc -import Outputable - -{- -@dsGuarded@ is used for pattern bindings. -It desugars: -\begin{verbatim} - | g1 -> e1 - ... - | gn -> en - where binds -\end{verbatim} -producing an expression with a runtime error in the corner if -necessary. The type argument gives the type of the @ei@. --} - -dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM CoreExpr -dsGuarded grhss rhs_ty = do - match_result <- dsGRHSs PatBindRhs grhss rhs_ty - error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty - extractMatchResult match_result error_expr - --- In contrast, @dsGRHSs@ produces a @MatchResult@. - -dsGRHSs :: HsMatchContext GhcRn - -> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs - -> Type -- Type of RHS - -> DsM MatchResult -dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty - = ASSERT( notNull grhss ) - do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss - ; let match_result1 = foldr1 combineMatchResults match_results - match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1 - -- NB: nested dsLet inside matchResult - ; return match_result2 } -dsGRHSs _ (XGRHSs nec) _ = noExtCon nec - -dsGRHS :: HsMatchContext GhcRn -> Type -> LGRHS GhcTc (LHsExpr GhcTc) - -> DsM MatchResult -dsGRHS hs_ctx rhs_ty (L _ (GRHS _ guards rhs)) - = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty -dsGRHS _ _ (L _ (XGRHS nec)) = noExtCon nec - -{- -************************************************************************ -* * -* matchGuard : make a MatchResult from a guarded RHS * -* * -************************************************************************ --} - -matchGuards :: [GuardStmt GhcTc] -- Guard - -> HsStmtContext GhcRn -- Context - -> LHsExpr GhcTc -- RHS - -> Type -- Type of RHS of guard - -> DsM MatchResult - --- See comments with HsExpr.Stmt re what a BodyStmt means --- Here we must be in a guard context (not do-expression, nor list-comp) - -matchGuards [] _ rhs _ - = do { core_rhs <- dsLExpr rhs - ; return (cantFailMatchResult core_rhs) } - - -- BodyStmts must be guards - -- Turn an "otherwise" guard is a no-op. This ensures that - -- you don't get a "non-exhaustive eqns" message when the guards - -- finish in "otherwise". - -- NB: The success of this clause depends on the typechecker not - -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors - -- If it does, you'll get bogus overlap warnings -matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty - | Just addTicks <- isTrueLHsExpr e = do - match_result <- matchGuards stmts ctx rhs rhs_ty - return (adjustMatchResultDs addTicks match_result) -matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do - match_result <- matchGuards stmts ctx rhs rhs_ty - pred_expr <- dsLExpr expr - return (mkGuardedMatchResult pred_expr match_result) - -matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do - match_result <- matchGuards stmts ctx rhs rhs_ty - return (adjustMatchResultDs (dsLocalBinds binds) match_result) - -- NB the dsLet occurs inside the match_result - -- Reason: dsLet takes the body expression as its argument - -- so we can't desugar the bindings without the - -- body expression in hand - -matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do - let upat = unLoc pat - dicts = collectEvVarsPat upat - match_var <- selectMatchVar upat - - dflags <- getDynFlags - match_result <- - -- See Note [Type and Term Equality Propagation] in Check - applyWhen (needToRunPmCheck dflags FromSource) - -- FromSource might not be accurate, but at worst - -- we do superfluous calls to the pattern match - -- oracle. - (addTyCsDs dicts . addScrutTmCs (Just bind_rhs) [match_var] . addPatTmCs [upat] [match_var]) - (matchGuards stmts ctx rhs rhs_ty) - core_rhs <- dsLExpr bind_rhs - match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty - match_result - pure $ adjustMatchResult (bindNonRec match_var core_rhs) match_result' - -matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt" -matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt" -matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt" -matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt" -matchGuards (ApplicativeStmt {} : _) _ _ _ = - panic "matchGuards ApplicativeLastStmt" -matchGuards (XStmtLR nec : _) _ _ _ = - noExtCon nec - -{- -Should {\em fail} if @e@ returns @D@ -\begin{verbatim} -f x | p <- e', let C y# = e, f y# = r1 - | otherwise = r2 -\end{verbatim} --} diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs deleted file mode 100644 index 35a71ce8e4..0000000000 --- a/compiler/deSugar/DsListComp.hs +++ /dev/null @@ -1,676 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Desugaring list comprehensions, monad comprehensions and array comprehensions --} - -{-# LANGUAGE CPP, NamedFieldPuns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module DsListComp ( dsListComp, dsMonadComp ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} DsExpr ( dsHandleMonadicFailure, dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) - -import GHC.Hs -import TcHsSyn -import CoreSyn -import MkCore - -import DsMonad -- the monadery used in the desugarer -import DsUtils - -import DynFlags -import CoreUtils -import Id -import Type -import TysWiredIn -import Match -import PrelNames -import SrcLoc -import Outputable -import TcType -import ListSetOps( getNth ) -import Util - -{- -List comprehensions may be desugared in one of two ways: ``ordinary'' -(as you would expect if you read SLPJ's book) and ``with foldr/build -turned on'' (if you read Gill {\em et al.}'s paper on the subject). - -There will be at least one ``qualifier'' in the input. --} - -dsListComp :: [ExprLStmt GhcTc] - -> Type -- Type of entire list - -> DsM CoreExpr -dsListComp lquals res_ty = do - dflags <- getDynFlags - let quals = map unLoc lquals - elt_ty = case tcTyConAppArgs res_ty of - [elt_ty] -> elt_ty - _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals) - - if not (gopt Opt_EnableRewriteRules dflags) || gopt Opt_IgnoreInterfacePragmas dflags - -- Either rules are switched off, or we are ignoring what there are; - -- Either way foldr/build won't happen, so use the more efficient - -- Wadler-style desugaring - || isParallelComp quals - -- Foldr-style desugaring can't handle parallel list comprehensions - then deListComp quals (mkNilExpr elt_ty) - else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals) - -- Foldr/build should be enabled, so desugar - -- into foldrs and builds - - where - -- We must test for ParStmt anywhere, not just at the head, because an extension - -- to list comprehensions would be to add brackets to specify the associativity - -- of qualifier lists. This is really easy to do by adding extra ParStmts into the - -- mix of possibly a single element in length, so we do this to leave the possibility open - isParallelComp = any isParallelStmt - - isParallelStmt (ParStmt {}) = True - isParallelStmt _ = False - - --- This function lets you desugar a inner list comprehension and a list of the binders --- of that comprehension that we need in the outer comprehension into such an expression --- and the type of the elements that it outputs (tuples of binders) -dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type) -dsInnerListComp (ParStmtBlock _ stmts bndrs _) - = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs - list_ty = mkListTy bndrs_tuple_type - - -- really use original bndrs below! - ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty - - ; return (expr, bndrs_tuple_type) } -dsInnerListComp (XParStmtBlock nec) = noExtCon nec - --- This function factors out commonality between the desugaring strategies for GroupStmt. --- Given such a statement it gives you back an expression representing how to compute the transformed --- list and the tuple that you need to bind from that list in order to proceed with your desugaring -dsTransStmt :: ExprStmt GhcTc -> DsM (CoreExpr, LPat GhcTc) -dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap - , trS_by = by, trS_using = using }) = do - let (from_bndrs, to_bndrs) = unzip binderMap - - let from_bndrs_tys = map idType from_bndrs - to_bndrs_tys = map idType to_bndrs - - to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys - - -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders - (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExtField stmts - from_bndrs noSyntaxExpr) - - -- Work out what arguments should be supplied to that expression: i.e. is an extraction - -- function required? If so, create that desugared function and add to arguments - usingExpr' <- dsLExpr using - usingArgs' <- case by of - Nothing -> return [expr'] - Just by_e -> do { by_e' <- dsLExpr by_e - ; lam' <- matchTuple from_bndrs by_e' - ; return [lam', expr'] } - - -- Create an unzip function for the appropriate arity and element types and find "map" - unzip_stuff' <- mkUnzipBind form from_bndrs_tys - map_id <- dsLookupGlobalId mapName - - -- Generate the expressions to build the grouped list - let -- First we apply the grouping function to the inner list - inner_list_expr' = mkApps usingExpr' usingArgs' - -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists - -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and - -- the "b" to be a tuple of "to" lists! - -- Then finally we bind the unzip function around that expression - bound_unzipped_inner_list_expr' - = case unzip_stuff' of - Nothing -> inner_list_expr' - Just (unzip_fn', unzip_rhs') -> - Let (Rec [(unzip_fn', unzip_rhs')]) $ - mkApps (Var map_id) $ - [ Type (mkListTy from_tup_ty) - , Type to_bndrs_tup_ty - , Var unzip_fn' - , inner_list_expr' ] - - dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr')) - (text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using) - - -- Build a pattern that ensures the consumer binds into the NEW binders, - -- which hold lists rather than single values - let pat = mkBigLHsVarPatTupId to_bndrs -- NB: no '! - return (bound_unzipped_inner_list_expr', pat) - -dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt" - -{- -************************************************************************ -* * -\subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions} -* * -************************************************************************ - -Just as in Phil's chapter~7 in SLPJ, using the rules for -optimally-compiled list comprehensions. This is what Kevin followed -as well, and I quite happily do the same. The TQ translation scheme -transforms a list of qualifiers (either boolean expressions or -generators) into a single expression which implements the list -comprehension. Because we are generating 2nd-order polymorphic -lambda-calculus, calls to NIL and CONS must be applied to a type -argument, as well as their usual value arguments. -\begin{verbatim} -TE << [ e | qs ] >> = TQ << [ e | qs ] ++ Nil (typeOf e) >> - -(Rule C) -TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <> TE <> - -(Rule B) -TQ << [ e | b , qs ] ++ L >> = - if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >> - -(Rule A') -TQ << [ e | p <- L1, qs ] ++ L2 >> = - letrec - h = \ u1 -> - case u1 of - [] -> TE << L2 >> - (u2 : u3) -> - (( \ TE << p >> -> ( TQ << [e | qs] ++ (h u3) >> )) u2) - [] (h u3) - in - h ( TE << L1 >> ) - -"h", "u1", "u2", and "u3" are new variables. -\end{verbatim} - -@deListComp@ is the TQ translation scheme. Roughly speaking, @dsExpr@ -is the TE translation scheme. Note that we carry around the @L@ list -already desugared. @dsListComp@ does the top TE rule mentioned above. - -To the above, we add an additional rule to deal with parallel list -comprehensions. The translation goes roughly as follows: - [ e | p1 <- e11, let v1 = e12, p2 <- e13 - | q1 <- e21, let v2 = e22, q2 <- e23] - => - [ e | ((x1, .., xn), (y1, ..., ym)) <- - zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13] - [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]] -where (x1, .., xn) are the variables bound in p1, v1, p2 - (y1, .., ym) are the variables bound in q1, v2, q2 - -In the translation below, the ParStmt branch translates each parallel branch -into a sub-comprehension, and desugars each independently. The resulting lists -are fed to a zip function, we create a binding for all the variables bound in all -the comprehensions, and then we hand things off the desugarer for bindings. -The zip function is generated here a) because it's small, and b) because then we -don't have to deal with arbitrary limits on the number of zip functions in the -prelude, nor which library the zip function came from. -The introduced tuples are Boxed, but only because I couldn't get it to work -with the Unboxed variety. --} - -deListComp :: [ExprStmt GhcTc] -> CoreExpr -> DsM CoreExpr - -deListComp [] _ = panic "deListComp" - -deListComp (LastStmt _ body _ _ : quals) list - = -- Figure 7.4, SLPJ, p 135, rule C above - ASSERT( null quals ) - do { core_body <- dsLExpr body - ; return (mkConsExpr (exprType core_body) core_body list) } - - -- Non-last: must be a guard -deListComp (BodyStmt _ guard _ _ : quals) list = do -- rule B above - core_guard <- dsLExpr guard - core_rest <- deListComp quals list - return (mkIfThenElse core_guard core_rest list) - --- [e | let B, qs] = let B in [e | qs] -deListComp (LetStmt _ binds : quals) list = do - core_rest <- deListComp quals list - dsLocalBinds binds core_rest - -deListComp (stmt@(TransStmt {}) : quals) list = do - (inner_list_expr, pat) <- dsTransStmt stmt - deBindComp pat inner_list_expr quals list - -deListComp (BindStmt _ pat list1 _ _ : quals) core_list2 = do -- rule A' above - core_list1 <- dsLExprNoLP list1 - deBindComp pat core_list1 quals core_list2 - -deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list - = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs - ; let (exps, qual_tys) = unzip exps_and_qual_tys - - ; (zip_fn, zip_rhs) <- mkZipBind qual_tys - - -- Deal with [e | pat <- zip l1 .. ln] in example above - ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) - quals list } - where - bndrs_s = [bs | ParStmtBlock _ _ bs _ <- stmtss_w_bndrs] - - -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above - pat = mkBigLHsPatTupId pats - pats = map mkBigLHsVarPatTupId bndrs_s - -deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt" - -deListComp (ApplicativeStmt {} : _) _ = - panic "deListComp ApplicativeStmt" - -deListComp (XStmtLR nec : _) _ = - noExtCon nec - -deBindComp :: OutPat GhcTc - -> CoreExpr - -> [ExprStmt GhcTc] - -> CoreExpr - -> DsM (Expr Id) -deBindComp pat core_list1 quals core_list2 = do - let u3_ty@u1_ty = exprType core_list1 -- two names, same thing - - -- u1_ty is a [alpha] type, and u2_ty = alpha - let u2_ty = hsLPatType pat - - let res_ty = exprType core_list2 - h_ty = u1_ty `mkVisFunTy` res_ty - - -- no levity polymorphism here, as list comprehensions don't work - -- with RebindableSyntax. NB: These are *not* monad comps. - [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] - - -- the "fail" value ... - let - core_fail = App (Var h) (Var u3) - letrec_body = App (Var h) core_list1 - - rest_expr <- deListComp quals core_fail - core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail - - let - rhs = Lam u1 $ - Case (Var u1) u1 res_ty - [(DataAlt nilDataCon, [], core_list2), - (DataAlt consDataCon, [u2, u3], core_match)] - -- Increasing order of tag - - return (Let (Rec [(h, rhs)]) letrec_body) - -{- -************************************************************************ -* * -\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions} -* * -************************************************************************ - -@dfListComp@ are the rules used with foldr/build turned on: - -\begin{verbatim} -TE[ e | ] c n = c e n -TE[ e | b , q ] c n = if b then TE[ e | q ] c n else n -TE[ e | p <- l , q ] c n = let - f = \ x b -> case x of - p -> TE[ e | q ] c b - _ -> b - in - foldr f n l -\end{verbatim} --} - -dfListComp :: Id -> Id -- 'c' and 'n' - -> [ExprStmt GhcTc] -- the rest of the qual's - -> DsM CoreExpr - -dfListComp _ _ [] = panic "dfListComp" - -dfListComp c_id n_id (LastStmt _ body _ _ : quals) - = ASSERT( null quals ) - do { core_body <- dsLExprNoLP body - ; return (mkApps (Var c_id) [core_body, Var n_id]) } - - -- Non-last: must be a guard -dfListComp c_id n_id (BodyStmt _ guard _ _ : quals) = do - core_guard <- dsLExpr guard - core_rest <- dfListComp c_id n_id quals - return (mkIfThenElse core_guard core_rest (Var n_id)) - -dfListComp c_id n_id (LetStmt _ binds : quals) = do - -- new in 1.3, local bindings - core_rest <- dfListComp c_id n_id quals - dsLocalBinds binds core_rest - -dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do - (inner_list_expr, pat) <- dsTransStmt stmt - -- Anyway, we bind the newly grouped list via the generic binding function - dfBindComp c_id n_id (pat, inner_list_expr) quals - -dfListComp c_id n_id (BindStmt _ pat list1 _ _ : quals) = do - -- evaluate the two lists - core_list1 <- dsLExpr list1 - - -- Do the rest of the work in the generic binding builder - dfBindComp c_id n_id (pat, core_list1) quals - -dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt" -dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt" -dfListComp _ _ (ApplicativeStmt {} : _) = - panic "dfListComp ApplicativeStmt" -dfListComp _ _ (XStmtLR nec : _) = - noExtCon nec - -dfBindComp :: Id -> Id -- 'c' and 'n' - -> (LPat GhcTc, CoreExpr) - -> [ExprStmt GhcTc] -- the rest of the qual's - -> DsM CoreExpr -dfBindComp c_id n_id (pat, core_list1) quals = do - -- find the required type - let x_ty = hsLPatType pat - let b_ty = idType n_id - - -- create some new local id's - b <- newSysLocalDs b_ty - x <- newSysLocalDs x_ty - - -- build rest of the comprehension - core_rest <- dfListComp c_id b quals - - -- build the pattern match - core_expr <- matchSimply (Var x) (StmtCtxt ListComp) - pat core_rest (Var b) - - -- now build the outermost foldr, and return - mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1 - -{- -************************************************************************ -* * -\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring} -* * -************************************************************************ --} - -mkZipBind :: [Type] -> DsM (Id, CoreExpr) --- mkZipBind [t1, t2] --- = (zip, \as1:[t1] as2:[t2] --- -> case as1 of --- [] -> [] --- (a1:as'1) -> case as2 of --- [] -> [] --- (a2:as'2) -> (a1, a2) : zip as'1 as'2)] - -mkZipBind elt_tys = do - ass <- mapM newSysLocalDs elt_list_tys - as' <- mapM newSysLocalDs elt_tys - as's <- mapM newSysLocalDs elt_list_tys - - zip_fn <- newSysLocalDs zip_fn_ty - - let inner_rhs = mkConsExpr elt_tuple_ty - (mkBigCoreVarTup as') - (mkVarApps (Var zip_fn) as's) - zip_body = foldr mk_case inner_rhs (zip3 ass as' as's) - - return (zip_fn, mkLams ass zip_body) - where - elt_list_tys = map mkListTy elt_tys - elt_tuple_ty = mkBigCoreTupTy elt_tys - elt_tuple_list_ty = mkListTy elt_tuple_ty - - zip_fn_ty = mkVisFunTys elt_list_tys elt_tuple_list_ty - - mk_case (as, a', as') rest - = Case (Var as) as elt_tuple_list_ty - [(DataAlt nilDataCon, [], mkNilExpr elt_tuple_ty), - (DataAlt consDataCon, [a', as'], rest)] - -- Increasing order of tag - - -mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr)) --- mkUnzipBind [t1, t2] --- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2]) --- -> case ax of --- (x1, x2) -> case axs of --- (xs1, xs2) -> (x1 : xs1, x2 : xs2)) --- ([], []) --- ys) --- --- We use foldr here in all cases, even if rules are turned off, because we may as well! -mkUnzipBind ThenForm _ - = return Nothing -- No unzipping for ThenForm -mkUnzipBind _ elt_tys - = do { ax <- newSysLocalDs elt_tuple_ty - ; axs <- newSysLocalDs elt_list_tuple_ty - ; ys <- newSysLocalDs elt_tuple_list_ty - ; xs <- mapM newSysLocalDs elt_tys - ; xss <- mapM newSysLocalDs elt_list_tys - - ; unzip_fn <- newSysLocalDs unzip_fn_ty - - ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply] - - ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys) - concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss)) - tupled_concat_expression = mkBigCoreTup concat_expressions - - folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs) - folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax) - folder_body = mkLams [ax, axs] folder_body_outer_case - - ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys) - ; return (Just (unzip_fn, mkLams [ys] unzip_body)) } - where - elt_tuple_ty = mkBigCoreTupTy elt_tys - elt_tuple_list_ty = mkListTy elt_tuple_ty - elt_list_tys = map mkListTy elt_tys - elt_list_tuple_ty = mkBigCoreTupTy elt_list_tys - - unzip_fn_ty = elt_tuple_list_ty `mkVisFunTy` elt_list_tuple_ty - - mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail - --- Translation for monad comprehensions - --- Entry point for monad comprehension desugaring -dsMonadComp :: [ExprLStmt GhcTc] -> DsM CoreExpr -dsMonadComp stmts = dsMcStmts stmts - -dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr -dsMcStmts [] = panic "dsMcStmts" -dsMcStmts ((L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) - ---------------- -dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr - -dsMcStmt (LastStmt _ body _ ret_op) stmts - = ASSERT( null stmts ) - do { body' <- dsLExpr body - ; dsSyntaxExpr ret_op [body'] } - --- [ .. | let binds, stmts ] -dsMcStmt (LetStmt _ binds) stmts - = do { rest <- dsMcStmts stmts - ; dsLocalBinds binds rest } - --- [ .. | a <- m, stmts ] -dsMcStmt (BindStmt bind_ty pat rhs bind_op fail_op) stmts - = do { rhs' <- dsLExpr rhs - ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts } - --- Apply `guard` to the `exp` expression --- --- [ .. | exp, stmts ] --- -dsMcStmt (BodyStmt _ exp then_exp guard_exp) stmts - = do { exp' <- dsLExpr exp - ; rest <- dsMcStmts stmts - ; guard_exp' <- dsSyntaxExpr guard_exp [exp'] - ; dsSyntaxExpr then_exp [guard_exp', rest] } - --- Group statements desugar like this: --- --- [| (q, then group by e using f); rest |] --- ---> f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup -> --- case unzip n_tup of qv' -> [| rest |] --- --- where variables (v1:t1, ..., vk:tk) are bound by q --- qv = (v1, ..., vk) --- qt = (t1, ..., tk) --- (>>=) :: m2 a -> (a -> m3 b) -> m3 b --- f :: forall a. (a -> t) -> m1 a -> m2 (n a) --- n_tup :: n qt --- unzip :: n qt -> (n t1, ..., n tk) (needs Functor n) - -dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs - , trS_by = by, trS_using = using - , trS_ret = return_op, trS_bind = bind_op - , trS_ext = n_tup_ty' -- n (a,b,c) - , trS_fmap = fmap_op, trS_form = form }) stmts_rest - = do { let (from_bndrs, to_bndrs) = unzip bndrs - - ; let from_bndr_tys = map idType from_bndrs -- Types ty - - - -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders - ; expr' <- dsInnerMonadComp stmts from_bndrs return_op - - -- Work out what arguments should be supplied to that expression: i.e. is an extraction - -- function required? If so, create that desugared function and add to arguments - ; usingExpr' <- dsLExpr using - ; usingArgs' <- case by of - Nothing -> return [expr'] - Just by_e -> do { by_e' <- dsLExpr by_e - ; lam' <- matchTuple from_bndrs by_e' - ; return [lam', expr'] } - - -- Generate the expressions to build the grouped list - -- Build a pattern that ensures the consumer binds into the NEW binders, - -- which hold monads rather than single values - ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs - - ; body <- dsMcStmts stmts_rest - ; n_tup_var' <- newSysLocalDsNoLP n_tup_ty' - ; tup_n_var' <- newSysLocalDs tup_n_ty' - ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys - ; us <- newUniqueSupply - ; let rhs' = mkApps usingExpr' usingArgs' - body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr' - - ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] } - --- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel --- statements, for example: --- --- [ body | qs1 | qs2 | qs3 ] --- -> [ body | (bndrs1, (bndrs2, bndrs3)) --- <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ] --- --- where `mzip` has type --- mzip :: forall a b. m a -> m b -> m (a,b) --- NB: we need a polymorphic mzip because we call it several times - -dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest - = do { exps_w_tys <- mapM ds_inner blocks -- Pairs (exp :: m ty, ty) - ; mzip_op' <- dsExpr mzip_op - - ; let -- The pattern variables - pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- blocks] - -- Pattern with tuples of variables - -- [v1,v2,v3] => (v1, (v2, v3)) - pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats - (rhs, _) = foldr1 (\(e1,t1) (e2,t2) -> - (mkApps mzip_op' [Type t1, Type t2, e1, e2], - mkBoxedTupleTy [t1,t2])) - exps_w_tys - - ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest } - where - ds_inner (ParStmtBlock _ stmts bndrs return_op) - = do { exp <- dsInnerMonadComp stmts bndrs return_op - ; return (exp, mkBigCoreVarTupTy bndrs) } - ds_inner (XParStmtBlock nec) = noExtCon nec - -dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) - - -matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr --- (matchTuple [a,b,c] body) --- returns the Core term --- \x. case x of (a,b,c) -> body -matchTuple ids body - = do { us <- newUniqueSupply - ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids) - ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) } - --- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a --- desugared `CoreExpr` -dsMcBindStmt :: LPat GhcTc - -> CoreExpr -- ^ the desugared rhs of the bind statement - -> SyntaxExpr GhcTc - -> SyntaxExpr GhcTc - -> Type -- ^ S in (>>=) :: Q -> (R -> S) -> T - -> [ExprLStmt GhcTc] - -> DsM CoreExpr -dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts - = do { body <- dsMcStmts stmts - ; var <- selectSimpleMatchVarL pat - ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat - res1_ty (cantFailMatchResult body) - ; match_code <- dsHandleMonadicFailure pat match fail_op - ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } - --- Desugar nested monad comprehensions, for example in `then..` constructs --- dsInnerMonadComp quals [a,b,c] ret_op --- returns the desugaring of --- [ (a,b,c) | quals ] - -dsInnerMonadComp :: [ExprLStmt GhcTc] - -> [Id] -- Return a tuple of these variables - -> SyntaxExpr GhcTc -- The monomorphic "return" operator - -> DsM CoreExpr -dsInnerMonadComp stmts bndrs ret_op - = dsMcStmts (stmts ++ - [noLoc (LastStmt noExtField (mkBigLHsVarTupId bndrs) False ret_op)]) - - --- The `unzip` function for `GroupStmt` in a monad comprehensions --- --- unzip :: m (a,b,..) -> (m a,m b,..) --- unzip m_tuple = ( liftM selN1 m_tuple --- , liftM selN2 m_tuple --- , .. ) --- --- mkMcUnzipM fmap ys [t1, t2] --- = ( fmap (selN1 :: (t1, t2) -> t1) ys --- , fmap (selN2 :: (t1, t2) -> t2) ys ) - -mkMcUnzipM :: TransForm - -> HsExpr GhcTcId -- fmap - -> Id -- Of type n (a,b,c) - -> [Type] -- [a,b,c] (not levity-polymorphic) - -> DsM CoreExpr -- Of type (n a, n b, n c) -mkMcUnzipM ThenForm _ ys _ - = return (Var ys) -- No unzipping to do - -mkMcUnzipM _ fmap_op ys elt_tys - = do { fmap_op' <- dsExpr fmap_op - ; xs <- mapM newSysLocalDs elt_tys - ; let tup_ty = mkBigCoreTupTy elt_tys - ; tup_xs <- newSysLocalDs tup_ty - - ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b - [ Type tup_ty, Type (getNth elt_tys i) - , mk_sel i, Var ys] - - mk_sel n = Lam tup_xs $ - mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs) - - ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) } diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs deleted file mode 100644 index 5473682a40..0000000000 --- a/compiler/deSugar/DsMeta.hs +++ /dev/null @@ -1,2958 +0,0 @@ -{-# LANGUAGE CPP, TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow 2006 --- --- The purpose of this module is to transform an HsExpr into a CoreExpr which --- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the --- input HsExpr. We do this in the DsM monad, which supplies access to --- CoreExpr's of the "smart constructors" of the Meta.Exp datatype. --- --- It also defines a bunch of knownKeyNames, in the same way as is done --- in prelude/PrelNames. It's much more convenient to do it here, because --- otherwise we have to recompile PrelNames whenever we add a Name, which is --- a Royal Pain (triggers other recompilation). ------------------------------------------------------------------------------ - -module DsMeta( dsBracket ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} DsExpr ( dsExpr ) - -import MatchLit -import DsMonad - -import qualified Language.Haskell.TH as TH - -import GHC.Hs -import PrelNames --- To avoid clashes with DsMeta.varName we must make a local alias for --- OccName.varName we do this by removing varName from the import of --- OccName above, making a qualified instance of OccName and using --- OccNameAlias.varName where varName ws previously used in this file. -import qualified OccName( isDataOcc, isVarOcc, isTcOcc ) - -import Module -import Id -import Name hiding( isVarOcc, isTcOcc, varName, tcName ) -import THNames -import NameEnv -import TcType -import TyCon -import TysWiredIn -import CoreSyn -import MkCore -import CoreUtils -import SrcLoc -import Unique -import BasicTypes -import Outputable -import Bag -import DynFlags -import FastString -import ForeignCall -import Util -import Maybes -import MonadUtils -import TcEvidence -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Class -import Class -import HscTypes ( MonadThings ) -import DataCon -import Var -import DsBinds - -import GHC.TypeLits -import Data.Kind (Constraint) - -import Data.ByteString ( unpack ) -import Control.Monad -import Data.List - -data MetaWrappers = MetaWrappers { - -- Applies its argument to a type argument `m` and dictionary `Quote m` - quoteWrapper :: CoreExpr -> CoreExpr - -- Apply its argument to a type argument `m` and a dictionary `Monad m` - , monadWrapper :: CoreExpr -> CoreExpr - -- Apply the container typed variable `m` to the argument type `T` to get `m T`. - , metaTy :: Type -> Type - -- Information about the wrappers which be printed to be inspected - , _debugWrappers :: (HsWrapper, HsWrapper, Type) - } - --- | Construct the functions which will apply the relevant part of the --- QuoteWrapper to identifiers during desugaring. -mkMetaWrappers :: QuoteWrapper -> DsM MetaWrappers -mkMetaWrappers q@(QuoteWrapper quote_var_raw m_var) = do - let quote_var = Var quote_var_raw - -- Get the superclass selector to select the Monad dictionary, going - -- to be used to construct the monadWrapper. - quote_tc <- dsLookupTyCon quoteClassName - monad_tc <- dsLookupTyCon monadClassName - let Just cls = tyConClass_maybe quote_tc - Just monad_cls = tyConClass_maybe monad_tc - -- Quote m -> Monad m - monad_sel = classSCSelId cls 0 - - -- Only used for the defensive assertion that the selector has - -- the expected type - tyvars = dataConUserTyVarBinders (classDataCon cls) - expected_ty = mkForAllTys tyvars $ - mkInvisFunTy (mkClassPred cls (mkTyVarTys (binderVars tyvars))) - (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars))) - - MASSERT2( idType monad_sel `eqType` expected_ty, ppr monad_sel $$ ppr expected_ty) - - let m_ty = Type m_var - -- Construct the contents of MetaWrappers - quoteWrapper = applyQuoteWrapper q - monadWrapper = mkWpEvApps [EvExpr $ mkCoreApps (Var monad_sel) [m_ty, quote_var]] <.> - mkWpTyApps [m_var] - tyWrapper t = mkAppTy m_var t - debug = (quoteWrapper, monadWrapper, m_var) - q_f <- dsHsWrapper quoteWrapper - m_f <- dsHsWrapper monadWrapper - return (MetaWrappers q_f m_f tyWrapper debug) - --- Turn A into m A -wrapName :: Name -> MetaM Type -wrapName n = do - t <- lookupType n - wrap_fn <- asks metaTy - return (wrap_fn t) - --- The local state is always the same, calculated from the passed in --- wrapper -type MetaM a = ReaderT MetaWrappers DsM a - ------------------------------------------------------------------------------ -dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr - -> HsBracket GhcRn - -> [PendingTcSplice] - -> DsM CoreExpr --- See Note [Desugaring Brackets] --- Returns a CoreExpr of type (M TH.Exp) --- The quoted thing is parameterised over Name, even though it has --- been type checked. We don't want all those type decorations! - -dsBracket wrap brack splices - = do_brack brack - - where - runOverloaded act = do - -- In the overloaded case we have to get given a wrapper, it is just - -- for variable quotations that there is no wrapper, because they - -- have a simple type. - mw <- mkMetaWrappers (expectJust "runOverloaded" wrap) - runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw - - - new_bit = mkNameEnv [(n, DsSplice (unLoc e)) - | PendingTcSplice n e <- splices] - - do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOccDsM n ; return e1 } - do_brack (ExpBr _ e) = runOverloaded $ do { MkC e1 <- repLE e ; return e1 } - do_brack (PatBr _ p) = runOverloaded $ do { MkC p1 <- repTopP p ; return p1 } - do_brack (TypBr _ t) = runOverloaded $ do { MkC t1 <- repLTy t ; return t1 } - do_brack (DecBrG _ gp) = runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 } - do_brack (DecBrL {}) = panic "dsBracket: unexpected DecBrL" - do_brack (TExpBr _ e) = runOverloaded $ do { MkC e1 <- repLE e ; return e1 } - do_brack (XBracket nec) = noExtCon nec - -{- -Note [Desugaring Brackets] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In the old days (pre Dec 2019) quotation brackets used to be monomorphic, ie -an expression bracket was of type Q Exp. This made the desugaring process simple -as there were no complicated type variables to keep consistent throughout the -whole AST. Due to the overloaded quotations proposal a quotation bracket is now -of type `Quote m => m Exp` and all the combinators defined in TH.Lib have been -generalised to work with any monad implementing a minimal interface. - -https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0246-overloaded-bracket.rst - -Users can rejoice at the flexibility but now there is some additional complexity in -how brackets are desugared as all these polymorphic combinators need their arguments -instantiated. - -> IF YOU ARE MODIFYING THIS MODULE DO NOT USE ANYTHING SPECIFIC TO Q. INSTEAD -> USE THE `wrapName` FUNCTION TO APPLY THE `m` TYPE VARIABLE TO A TYPE CONSTRUCTOR. - -What the arguments should be instantiated to is supplied by the `QuoteWrapper` -datatype which is produced by `TcSplice`. It is a pair of an evidence variable -for `Quote m` and a type variable `m`. All the polymorphic combinators in desugaring -need to be applied to these two type variables. - -There are three important functions which do the application. - -1. The default is `rep2` which takes a function name of type `Quote m => T` as an argument. -2. `rep2M` takes a function name of type `Monad m => T` as an argument -3. `rep2_nw` takes a function name without any constraints as an argument. - -These functions then use the information in QuoteWrapper to apply the correct -arguments to the functions as the representation is constructed. - -The `MetaM` monad carries around an environment of three functions which are -used in order to wrap the polymorphic combinators and instantiate the arguments -to the correct things. - -1. quoteWrapper wraps functions of type `forall m . Quote m => T` -2. monadWrapper wraps functions of type `forall m . Monad m => T` -3. metaTy wraps a type in the polymorphic `m` variable of the whole representation. - -Historical note about the implementation: At the first attempt, I attempted to -lie that the type of any quotation was `Quote m => m Exp` and then specialise it -by applying a wrapper to pass the `m` and `Quote m` arguments. This approach was -simpler to implement but didn't work because of nested splices. For example, -you might have a nested splice of a more specific type which fixes the type of -the overall quote and so all the combinators used must also be instantiated to -that specific type. Therefore you really have to use the contents of the quote -wrapper to directly apply the right type to the combinators rather than -first generate a polymorphic definition and then just apply the wrapper at the end. - --} - -{- -------------- Examples -------------------- - - [| \x -> x |] -====> - gensym (unpackString "x"#) `bindQ` \ x1::String -> - lam (pvar x1) (var x1) - - - [| \x -> $(f [| x |]) |] -====> - gensym (unpackString "x"#) `bindQ` \ x1::String -> - lam (pvar x1) (f (var x1)) --} - - -------------------------------------------------------- --- Declarations -------------------------------------------------------- - --- Proxy for the phantom type of `Core`. All the generated fragments have --- type something like `Quote m => m Exp` so to keep things simple we represent fragments --- of that type as `M Exp`. -data M a - -repTopP :: LPat GhcRn -> MetaM (Core (M TH.Pat)) -repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat) - ; pat' <- addBinds ss (repLP pat) - ; wrapGenSyms ss pat' } - -repTopDs :: HsGroup GhcRn -> MetaM (Core (M [TH.Dec])) -repTopDs group@(HsGroup { hs_valds = valds - , hs_splcds = splcds - , hs_tyclds = tyclds - , hs_derivds = derivds - , hs_fixds = fixds - , hs_defds = defds - , hs_fords = fords - , hs_warnds = warnds - , hs_annds = annds - , hs_ruleds = ruleds - , hs_docs = docs }) - = do { let { bndrs = hsScopedTvBinders valds - ++ hsGroupBinders group - ++ hsPatSynSelectors valds - ; instds = tyclds >>= group_instds } ; - ss <- mkGenSyms bndrs ; - - -- Bind all the names mainly to avoid repeated use of explicit strings. - -- Thus we get - -- do { t :: String <- genSym "T" ; - -- return (Data t [] ...more t's... } - -- The other important reason is that the output must mention - -- only "T", not "Foo:T" where Foo is the current module - - decls <- addBinds ss ( - do { val_ds <- rep_val_binds valds - ; _ <- mapM no_splice splcds - ; tycl_ds <- mapM repTyClD (tyClGroupTyClDecls tyclds) - ; role_ds <- mapM repRoleD (concatMap group_roles tyclds) - ; kisig_ds <- mapM repKiSigD (concatMap group_kisigs tyclds) - ; inst_ds <- mapM repInstD instds - ; deriv_ds <- mapM repStandaloneDerivD derivds - ; fix_ds <- mapM repLFixD fixds - ; _ <- mapM no_default_decl defds - ; for_ds <- mapM repForD fords - ; _ <- mapM no_warn (concatMap (wd_warnings . unLoc) - warnds) - ; ann_ds <- mapM repAnnD annds - ; rule_ds <- mapM repRuleD (concatMap (rds_rules . unLoc) - ruleds) - ; _ <- mapM no_doc docs - - -- more needed - ; return (de_loc $ sort_by_loc $ - val_ds ++ catMaybes tycl_ds ++ role_ds - ++ kisig_ds - ++ (concat fix_ds) - ++ inst_ds ++ rule_ds ++ for_ds - ++ ann_ds ++ deriv_ds) }) ; - - core_list <- repListM decTyConName return decls ; - - dec_ty <- lookupType decTyConName ; - q_decs <- repSequenceM dec_ty core_list ; - - wrapGenSyms ss q_decs - } - where - no_splice (L loc _) - = notHandledL loc "Splices within declaration brackets" empty - no_default_decl (L loc decl) - = notHandledL loc "Default declarations" (ppr decl) - no_warn (L loc (Warning _ thing _)) - = notHandledL loc "WARNING and DEPRECATION pragmas" $ - text "Pragma for declaration of" <+> ppr thing - no_warn (L _ (XWarnDecl nec)) = noExtCon nec - no_doc (L loc _) - = notHandledL loc "Haddock documentation" empty -repTopDs (XHsGroup nec) = noExtCon nec - -hsScopedTvBinders :: HsValBinds GhcRn -> [Name] --- See Note [Scoped type variables in bindings] -hsScopedTvBinders binds - = concatMap get_scoped_tvs sigs - where - sigs = case binds of - ValBinds _ _ sigs -> sigs - XValBindsLR (NValBinds _ sigs) -> sigs - -get_scoped_tvs :: LSig GhcRn -> [Name] -get_scoped_tvs (L _ signature) - | TypeSig _ _ sig <- signature - = get_scoped_tvs_from_sig (hswc_body sig) - | ClassOpSig _ _ _ sig <- signature - = get_scoped_tvs_from_sig sig - | PatSynSig _ _ sig <- signature - = get_scoped_tvs_from_sig sig - | otherwise - = [] - where - get_scoped_tvs_from_sig sig - -- Both implicit and explicit quantified variables - -- We need the implicit ones for f :: forall (a::k). blah - -- here 'k' scopes too - | HsIB { hsib_ext = implicit_vars - , hsib_body = hs_ty } <- sig - , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty - = implicit_vars ++ hsLTyVarNames explicit_vars - get_scoped_tvs_from_sig (XHsImplicitBndrs nec) - = noExtCon nec - -{- Notes - -Note [Scoped type variables in bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: forall a. a -> a - f x = x::a -Here the 'forall a' brings 'a' into scope over the binding group. -To achieve this we - - a) Gensym a binding for 'a' at the same time as we do one for 'f' - collecting the relevant binders with hsScopedTvBinders - - b) When processing the 'forall', don't gensym - -The relevant places are signposted with references to this Note - -Note [Scoped type variables in class and instance declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Scoped type variables may occur in default methods and default -signatures. We need to bring the type variables in 'foralls' -into the scope of the method bindings. - -Consider - class Foo a where - foo :: forall (b :: k). a -> Proxy b -> Proxy b - foo _ x = (x :: Proxy b) - -We want to ensure that the 'b' in the type signature and the default -implementation are the same, so we do the following: - - a) Before desugaring the signature and binding of 'foo', use - get_scoped_tvs to collect type variables in 'forall' and - create symbols for them. - b) Use 'addBinds' to bring these symbols into the scope of the type - signatures and bindings. - c) Use these symbols to generate Core for the class/instance declaration. - -Note that when desugaring the signatures, we lookup the type variables -from the scope rather than recreate symbols for them. See more details -in "rep_ty_sig" and in Trac#14885. - -Note [Binders and occurrences] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we desugar [d| data T = MkT |] -we want to get - Data "T" [] [Con "MkT" []] [] -and *not* - Data "Foo:T" [] [Con "Foo:MkT" []] [] -That is, the new data decl should fit into whatever new module it is -asked to fit in. We do *not* clone, though; no need for this: - Data "T79" .... - -But if we see this: - data T = MkT - foo = reifyDecl T - -then we must desugar to - foo = Data "Foo:T" [] [Con "Foo:MkT" []] [] - -So in repTopDs we bring the binders into scope with mkGenSyms and addBinds. -And we use lookupOcc, rather than lookupBinder -in repTyClD and repC. - -Note [Don't quantify implicit type variables in quotes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If you're not careful, it's surprisingly easy to take this quoted declaration: - - [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b - idProxy x = x - |] - -and have Template Haskell turn it into this: - - idProxy :: forall k proxy (b :: k). proxy b -> proxy b - idProxy x = x - -Notice that we explicitly quantified the variable `k`! The latter declaration -isn't what the user wrote in the first place. - -Usually, the culprit behind these bugs is taking implicitly quantified type -variables (often from the hsib_vars field of HsImplicitBinders) and putting -them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123. --} - --- represent associated family instances --- -repTyClD :: LTyClDecl GhcRn -> MetaM (Maybe (SrcSpan, Core (M TH.Dec))) - -repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ - repFamilyDecl (L loc fam) - -repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs })) - = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; dec <- addTyClTyVarBinds tvs $ \bndrs -> - repSynDecl tc1 bndrs rhs - ; return (Just (loc, dec)) } - -repTyClD (L loc (DataDecl { tcdLName = tc - , tcdTyVars = tvs - , tcdDataDefn = defn })) - = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; dec <- addTyClTyVarBinds tvs $ \bndrs -> - repDataDefn tc1 (Left bndrs) defn - ; return (Just (loc, dec)) } - -repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, - tcdTyVars = tvs, tcdFDs = fds, - tcdSigs = sigs, tcdMeths = meth_binds, - tcdATs = ats, tcdATDefs = atds })) - = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences] - ; dec <- addTyVarBinds tvs $ \bndrs -> - do { cxt1 <- repLContext cxt - -- See Note [Scoped type variables in class and instance declarations] - ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds - ; fds1 <- repLFunDeps fds - ; ats1 <- repFamilyDecls ats - ; atds1 <- mapM (repAssocTyFamDefaultD . unLoc) atds - ; decls1 <- repListM decTyConName return (ats1 ++ atds1 ++ sigs_binds) - ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1 - ; wrapGenSyms ss decls2 } - ; return $ Just (loc, dec) - } - -repTyClD (L _ (XTyClDecl nec)) = noExtCon nec - -------------------------- -repRoleD :: LRoleAnnotDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) -repRoleD (L loc (RoleAnnotDecl _ tycon roles)) - = do { tycon1 <- lookupLOcc tycon - ; roles1 <- mapM repRole roles - ; roles2 <- coreList roleTyConName roles1 - ; dec <- repRoleAnnotD tycon1 roles2 - ; return (loc, dec) } -repRoleD (L _ (XRoleAnnotDecl nec)) = noExtCon nec - -------------------------- -repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) -repKiSigD (L loc kisig) = - case kisig of - StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v - XStandaloneKindSig nec -> noExtCon nec - -------------------------- -repDataDefn :: Core TH.Name - -> Either (Core [(M TH.TyVarBndr)]) - -- the repTyClD case - (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type)) - -- the repDataFamInstD case - -> HsDataDefn GhcRn - -> MetaM (Core (M TH.Dec)) -repDataDefn tc opts - (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig - , dd_cons = cons, dd_derivs = mb_derivs }) - = do { cxt1 <- repLContext cxt - ; derivs1 <- repDerivs mb_derivs - ; case (new_or_data, cons) of - (NewType, [con]) -> do { con' <- repC con - ; ksig' <- repMaybeLTy ksig - ; repNewtype cxt1 tc opts ksig' con' - derivs1 } - (NewType, _) -> lift $ failWithDs (text "Multiple constructors for newtype:" - <+> pprQuotedList - (getConNames $ unLoc $ head cons)) - (DataType, _) -> do { ksig' <- repMaybeLTy ksig - ; consL <- mapM repC cons - ; cons1 <- coreListM conTyConName consL - ; repData cxt1 tc opts ksig' cons1 - derivs1 } - } -repDataDefn _ _ (XHsDataDefn nec) = noExtCon nec - -repSynDecl :: Core TH.Name -> Core [(M TH.TyVarBndr)] - -> LHsType GhcRn - -> MetaM (Core (M TH.Dec)) -repSynDecl tc bndrs ty - = do { ty1 <- repLTy ty - ; repTySyn tc bndrs ty1 } - -repFamilyDecl :: LFamilyDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) -repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info - , fdLName = tc - , fdTyVars = tvs - , fdResultSig = L _ resultSig - , fdInjectivityAnn = injectivity })) - = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn - mkHsQTvs tvs = HsQTvs { hsq_ext = [] - , hsq_explicit = tvs } - resTyVar = case resultSig of - TyVarSig _ bndr -> mkHsQTvs [bndr] - _ -> mkHsQTvs [] - ; dec <- addTyClTyVarBinds tvs $ \bndrs -> - addTyClTyVarBinds resTyVar $ \_ -> - case info of - ClosedTypeFamily Nothing -> - notHandled "abstract closed type family" (ppr decl) - ClosedTypeFamily (Just eqns) -> - do { eqns1 <- mapM (repTyFamEqn . unLoc) eqns - ; eqns2 <- coreListM tySynEqnTyConName eqns1 - ; result <- repFamilyResultSig resultSig - ; inj <- repInjectivityAnn injectivity - ; repClosedFamilyD tc1 bndrs result inj eqns2 } - OpenTypeFamily -> - do { result <- repFamilyResultSig resultSig - ; inj <- repInjectivityAnn injectivity - ; repOpenFamilyD tc1 bndrs result inj } - DataFamily -> - do { kind <- repFamilyResultSigToMaybeKind resultSig - ; repDataFamilyD tc1 bndrs kind } - ; return (loc, dec) - } -repFamilyDecl (L _ (XFamilyDecl nec)) = noExtCon nec - --- | Represent result signature of a type family -repFamilyResultSig :: FamilyResultSig GhcRn -> MetaM (Core (M TH.FamilyResultSig)) -repFamilyResultSig (NoSig _) = repNoSig -repFamilyResultSig (KindSig _ ki) = do { ki' <- repLTy ki - ; repKindSig ki' } -repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr - ; repTyVarSig bndr' } -repFamilyResultSig (XFamilyResultSig nec) = noExtCon nec - --- | Represent result signature using a Maybe Kind. Used with data families, --- where the result signature can be either missing or a kind but never a named --- result variable. -repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn - -> MetaM (Core (Maybe (M TH.Kind))) -repFamilyResultSigToMaybeKind (NoSig _) = - do { coreNothingM kindTyConName } -repFamilyResultSigToMaybeKind (KindSig _ ki) = - do { coreJustM kindTyConName =<< repLTy ki } -repFamilyResultSigToMaybeKind TyVarSig{} = - panic "repFamilyResultSigToMaybeKind: unexpected TyVarSig" -repFamilyResultSigToMaybeKind (XFamilyResultSig nec) = noExtCon nec - --- | Represent injectivity annotation of a type family -repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) - -> MetaM (Core (Maybe TH.InjectivityAnn)) -repInjectivityAnn Nothing = - do { coreNothing injAnnTyConName } -repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) = - do { lhs' <- lookupBinder (unLoc lhs) - ; rhs1 <- mapM (lookupBinder . unLoc) rhs - ; rhs2 <- coreList nameTyConName rhs1 - ; injAnn <- rep2_nw injectivityAnnName [unC lhs', unC rhs2] - ; coreJust injAnnTyConName injAnn } - -repFamilyDecls :: [LFamilyDecl GhcRn] -> MetaM [Core (M TH.Dec)] -repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds) - -repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> MetaM (Core (M TH.Dec)) -repAssocTyFamDefaultD = repTyFamInstD - -------------------------- --- represent fundeps --- -repLFunDeps :: [LHsFunDep GhcRn] -> MetaM (Core [TH.FunDep]) -repLFunDeps fds = repList funDepTyConName repLFunDep fds - -repLFunDep :: LHsFunDep GhcRn -> MetaM (Core TH.FunDep) -repLFunDep (L _ (xs, ys)) - = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs - ys' <- repList nameTyConName (lookupBinder . unLoc) ys - repFunDep xs' ys' - --- Represent instance declarations --- -repInstD :: LInstDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) -repInstD (L loc (TyFamInstD { tfid_inst = fi_decl })) - = do { dec <- repTyFamInstD fi_decl - ; return (loc, dec) } -repInstD (L loc (DataFamInstD { dfid_inst = fi_decl })) - = do { dec <- repDataFamInstD fi_decl - ; return (loc, dec) } -repInstD (L loc (ClsInstD { cid_inst = cls_decl })) - = do { dec <- repClsInstD cls_decl - ; return (loc, dec) } -repInstD (L _ (XInstDecl nec)) = noExtCon nec - -repClsInstD :: ClsInstDecl GhcRn -> MetaM (Core (M TH.Dec)) -repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds - , cid_sigs = sigs, cid_tyfam_insts = ats - , cid_datafam_insts = adts - , cid_overlap_mode = overlap - }) - = addSimpleTyVarBinds tvs $ - -- We must bring the type variables into scope, so their - -- occurrences don't fail, even though the binders don't - -- appear in the resulting data structure - -- - -- But we do NOT bring the binders of 'binds' into scope - -- because they are properly regarded as occurrences - -- For example, the method names should be bound to - -- the selector Ids, not to fresh names (#5410) - -- - do { cxt1 <- repLContext cxt - ; inst_ty1 <- repLTy inst_ty - -- See Note [Scoped type variables in class and instance declarations] - ; (ss, sigs_binds) <- rep_sigs_binds sigs binds - ; ats1 <- mapM (repTyFamInstD . unLoc) ats - ; adts1 <- mapM (repDataFamInstD . unLoc) adts - ; decls1 <- coreListM decTyConName (ats1 ++ adts1 ++ sigs_binds) - ; rOver <- repOverlap (fmap unLoc overlap) - ; decls2 <- repInst rOver cxt1 inst_ty1 decls1 - ; wrapGenSyms ss decls2 } - where - (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty -repClsInstD (XClsInstDecl nec) = noExtCon nec - -repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) -repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat - , deriv_type = ty })) - = do { dec <- addSimpleTyVarBinds tvs $ - do { cxt' <- repLContext cxt - ; strat' <- repDerivStrategy strat - ; inst_ty' <- repLTy inst_ty - ; repDeriv strat' cxt' inst_ty' } - ; return (loc, dec) } - where - (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty) -repStandaloneDerivD (L _ (XDerivDecl nec)) = noExtCon nec - -repTyFamInstD :: TyFamInstDecl GhcRn -> MetaM (Core (M TH.Dec)) -repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) - = do { eqn1 <- repTyFamEqn eqn - ; repTySynInst eqn1 } - -repTyFamEqn :: TyFamInstEqn GhcRn -> MetaM (Core (M TH.TySynEqn)) -repTyFamEqn (HsIB { hsib_ext = var_names - , hsib_body = FamEqn { feqn_tycon = tc_name - , feqn_bndrs = mb_bndrs - , feqn_pats = tys - , feqn_fixity = fixity - , feqn_rhs = rhs }}) - = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] - ; let hs_tvs = HsQTvs { hsq_ext = var_names - , hsq_explicit = fromMaybe [] mb_bndrs } - ; addTyClTyVarBinds hs_tvs $ \ _ -> - do { mb_bndrs1 <- repMaybeListM tyVarBndrTyConName - repTyVarBndr - mb_bndrs - ; tys1 <- case fixity of - Prefix -> repTyArgs (repNamedTyCon tc) tys - Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys - ; t1' <- repLTy t1 - ; t2' <- repLTy t2 - ; repTyArgs (repTInfix t1' tc t2') args } - ; rhs1 <- repLTy rhs - ; repTySynEqn mb_bndrs1 tys1 rhs1 } } - where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn] - checkTys tys@(HsValArg _:HsValArg _:_) = return tys - checkTys _ = panic "repTyFamEqn:checkTys" -repTyFamEqn (XHsImplicitBndrs nec) = noExtCon nec -repTyFamEqn (HsIB _ (XFamEqn nec)) = noExtCon nec - -repTyArgs :: MetaM (Core (M TH.Type)) -> [LHsTypeArg GhcRn] -> MetaM (Core (M TH.Type)) -repTyArgs f [] = f -repTyArgs f (HsValArg ty : as) = do { f' <- f - ; ty' <- repLTy ty - ; repTyArgs (repTapp f' ty') as } -repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f - ; ki' <- repLTy ki - ; repTyArgs (repTappKind f' ki') as } -repTyArgs f (HsArgPar _ : as) = repTyArgs f as - -repDataFamInstD :: DataFamInstDecl GhcRn -> MetaM (Core (M TH.Dec)) -repDataFamInstD (DataFamInstDecl { dfid_eqn = - (HsIB { hsib_ext = var_names - , hsib_body = FamEqn { feqn_tycon = tc_name - , feqn_bndrs = mb_bndrs - , feqn_pats = tys - , feqn_fixity = fixity - , feqn_rhs = defn }})}) - = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] - ; let hs_tvs = HsQTvs { hsq_ext = var_names - , hsq_explicit = fromMaybe [] mb_bndrs } - ; addTyClTyVarBinds hs_tvs $ \ _ -> - do { mb_bndrs1 <- repMaybeListM tyVarBndrTyConName - repTyVarBndr - mb_bndrs - ; tys1 <- case fixity of - Prefix -> repTyArgs (repNamedTyCon tc) tys - Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys - ; t1' <- repLTy t1 - ; t2' <- repLTy t2 - ; repTyArgs (repTInfix t1' tc t2') args } - ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } } - - where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn] - checkTys tys@(HsValArg _: HsValArg _: _) = return tys - checkTys _ = panic "repDataFamInstD:checkTys" - -repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs nec)) - = noExtCon nec -repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn nec))) - = noExtCon nec - -repForD :: Located (ForeignDecl GhcRn) -> MetaM (SrcSpan, Core (M TH.Dec)) -repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ - , fd_fi = CImport (L _ cc) - (L _ s) mch cis _ })) - = do MkC name' <- lookupLOcc name - MkC typ' <- repHsSigType typ - MkC cc' <- repCCallConv cc - MkC s' <- repSafety s - cis' <- conv_cimportspec cis - MkC str <- coreStringLit (static ++ chStr ++ cis') - dec <- rep2 forImpDName [cc', s', str, name', typ'] - return (loc, dec) - where - conv_cimportspec (CLabel cls) - = notHandled "Foreign label" (doubleQuotes (ppr cls)) - conv_cimportspec (CFunction DynamicTarget) = return "dynamic" - conv_cimportspec (CFunction (StaticTarget _ fs _ True)) - = return (unpackFS fs) - conv_cimportspec (CFunction (StaticTarget _ _ _ False)) - = panic "conv_cimportspec: values not supported yet" - conv_cimportspec CWrapper = return "wrapper" - -- these calling conventions do not support headers and the static keyword - raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv - static = case cis of - CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static " - _ -> "" - chStr = case mch of - Just (Header _ h) | not raw_cconv -> unpackFS h ++ " " - _ -> "" -repForD decl@(L _ ForeignExport{}) = notHandled "Foreign export" (ppr decl) -repForD (L _ (XForeignDecl nec)) = noExtCon nec - -repCCallConv :: CCallConv -> MetaM (Core TH.Callconv) -repCCallConv CCallConv = rep2_nw cCallName [] -repCCallConv StdCallConv = rep2_nw stdCallName [] -repCCallConv CApiConv = rep2_nw cApiCallName [] -repCCallConv PrimCallConv = rep2_nw primCallName [] -repCCallConv JavaScriptCallConv = rep2_nw javaScriptCallName [] - -repSafety :: Safety -> MetaM (Core TH.Safety) -repSafety PlayRisky = rep2_nw unsafeName [] -repSafety PlayInterruptible = rep2_nw interruptibleName [] -repSafety PlaySafe = rep2_nw safeName [] - -repLFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] -repLFixD (L loc fix_sig) = rep_fix_d loc fix_sig - -rep_fix_d :: SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] -rep_fix_d loc (FixitySig _ names (Fixity _ prec dir)) - = do { MkC prec' <- coreIntLit prec - ; let rep_fn = case dir of - InfixL -> infixLDName - InfixR -> infixRDName - InfixN -> infixNDName - ; let do_one name - = do { MkC name' <- lookupLOcc name - ; dec <- rep2 rep_fn [prec', name'] - ; return (loc,dec) } - ; mapM do_one names } -rep_fix_d _ (XFixitySig nec) = noExtCon nec - -repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) -repRuleD (L loc (HsRule { rd_name = n - , rd_act = act - , rd_tyvs = ty_bndrs - , rd_tmvs = tm_bndrs - , rd_lhs = lhs - , rd_rhs = rhs })) - = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs -> - do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs - ; ss <- mkGenSyms tm_bndr_names - ; rule <- addBinds ss $ - do { elt_ty <- wrapName tyVarBndrTyConName - ; ty_bndrs' <- return $ case ty_bndrs of - Nothing -> coreNothing' (mkListTy elt_ty) - Just _ -> coreJust' (mkListTy elt_ty) ex_bndrs - ; tm_bndrs' <- repListM ruleBndrTyConName - repRuleBndr - tm_bndrs - ; n' <- coreStringLit $ unpackFS $ snd $ unLoc n - ; act' <- repPhases act - ; lhs' <- repLE lhs - ; rhs' <- repLE rhs - ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' } - ; wrapGenSyms ss rule } - ; return (loc, rule) } -repRuleD (L _ (XRuleDecl nec)) = noExtCon nec - -ruleBndrNames :: LRuleBndr GhcRn -> [Name] -ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n] -ruleBndrNames (L _ (RuleBndrSig _ n sig)) - | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig - = unLoc n : vars -ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs nec)))) - = noExtCon nec -ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs nec))) - = noExtCon nec -ruleBndrNames (L _ (XRuleBndr nec)) = noExtCon nec - -repRuleBndr :: LRuleBndr GhcRn -> MetaM (Core (M TH.RuleBndr)) -repRuleBndr (L _ (RuleBndr _ n)) - = do { MkC n' <- lookupLBinder n - ; rep2 ruleVarName [n'] } -repRuleBndr (L _ (RuleBndrSig _ n sig)) - = do { MkC n' <- lookupLBinder n - ; MkC ty' <- repLTy (hsSigWcType sig) - ; rep2 typedRuleVarName [n', ty'] } -repRuleBndr (L _ (XRuleBndr nec)) = noExtCon nec - -repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) -repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp))) - = do { target <- repAnnProv ann_prov - ; exp' <- repE exp - ; dec <- repPragAnn target exp' - ; return (loc, dec) } -repAnnD (L _ (XAnnDecl nec)) = noExtCon nec - -repAnnProv :: AnnProvenance Name -> MetaM (Core TH.AnnTarget) -repAnnProv (ValueAnnProvenance (L _ n)) - = do { MkC n' <- lift $ globalVar n -- ANNs are allowed only at top-level - ; rep2_nw valueAnnotationName [ n' ] } -repAnnProv (TypeAnnProvenance (L _ n)) - = do { MkC n' <- lift $ globalVar n - ; rep2_nw typeAnnotationName [ n' ] } -repAnnProv ModuleAnnProvenance - = rep2_nw moduleAnnotationName [] - -------------------------------------------------------- --- Constructors -------------------------------------------------------- - -repC :: LConDecl GhcRn -> MetaM (Core (M TH.Con)) -repC (L _ (ConDeclH98 { con_name = con - , con_forall = (L _ False) - , con_mb_cxt = Nothing - , con_args = args })) - = repDataCon con args - -repC (L _ (ConDeclH98 { con_name = con - , con_forall = L _ is_existential - , con_ex_tvs = con_tvs - , con_mb_cxt = mcxt - , con_args = args })) - = do { addHsTyVarBinds con_tvs $ \ ex_bndrs -> - do { c' <- repDataCon con args - ; ctxt' <- repMbContext mcxt - ; if not is_existential && isNothing mcxt - then return c' - else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) - } - } - -repC (L _ (ConDeclGADT { con_names = cons - , con_qvars = qtvs - , con_mb_cxt = mcxt - , con_args = args - , con_res_ty = res_ty })) - | isEmptyLHsQTvs qtvs -- No implicit or explicit variables - , Nothing <- mcxt -- No context - -- ==> no need for a forall - = repGadtDataCons cons args res_ty - - | otherwise - = addTyVarBinds qtvs $ \ ex_bndrs -> - -- See Note [Don't quantify implicit type variables in quotes] - do { c' <- repGadtDataCons cons args res_ty - ; ctxt' <- repMbContext mcxt - ; if null (hsQTvExplicit qtvs) && isNothing mcxt - then return c' - else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } - -repC (L _ (XConDecl nec)) = noExtCon nec - - -repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt)) -repMbContext Nothing = repContext [] -repMbContext (Just (L _ cxt)) = repContext cxt - -repSrcUnpackedness :: SrcUnpackedness -> MetaM (Core (M TH.SourceUnpackedness)) -repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName [] -repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName [] -repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName [] - -repSrcStrictness :: SrcStrictness -> MetaM (Core (M TH.SourceStrictness)) -repSrcStrictness SrcLazy = rep2 sourceLazyName [] -repSrcStrictness SrcStrict = rep2 sourceStrictName [] -repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName [] - -repBangTy :: LBangType GhcRn -> MetaM (Core (M TH.BangType)) -repBangTy ty = do - MkC u <- repSrcUnpackedness su' - MkC s <- repSrcStrictness ss' - MkC b <- rep2 bangName [u, s] - MkC t <- repLTy ty' - rep2 bangTypeName [b, t] - where - (su', ss', ty') = case unLoc ty of - HsBangTy _ (HsSrcBang _ su ss) ty -> (su, ss, ty) - _ -> (NoSrcUnpack, NoSrcStrict, ty) - -------------------------------------------------------- --- Deriving clauses -------------------------------------------------------- - -repDerivs :: HsDeriving GhcRn -> MetaM (Core [M TH.DerivClause]) -repDerivs (L _ clauses) - = repListM derivClauseTyConName repDerivClause clauses - -repDerivClause :: LHsDerivingClause GhcRn - -> MetaM (Core (M TH.DerivClause)) -repDerivClause (L _ (HsDerivingClause - { deriv_clause_strategy = dcs - , deriv_clause_tys = L _ dct })) - = do MkC dcs' <- repDerivStrategy dcs - MkC dct' <- repListM typeTyConName (rep_deriv_ty . hsSigType) dct - rep2 derivClauseName [dcs',dct'] - where - rep_deriv_ty :: LHsType GhcRn -> MetaM (Core (M TH.Type)) - rep_deriv_ty ty = repLTy ty -repDerivClause (L _ (XHsDerivingClause nec)) = noExtCon nec - -rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn - -> MetaM ([GenSymBind], [Core (M TH.Dec)]) --- Represent signatures and methods in class/instance declarations. --- See Note [Scoped type variables in class and instance declarations] --- --- Why not use 'repBinds': we have already created symbols for methods in --- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate --- these fun_id via 'collectHsValBinders decs', which would lead to the --- instance declarations failing in TH. -rep_sigs_binds sigs binds - = do { let tvs = concatMap get_scoped_tvs sigs - ; ss <- mkGenSyms tvs - ; sigs1 <- addBinds ss $ rep_sigs sigs - ; binds1 <- addBinds ss $ rep_binds binds - ; return (ss, de_loc (sort_by_loc (sigs1 ++ binds1))) } - -------------------------------------------------------- --- Signatures in a class decl, or a group of bindings -------------------------------------------------------- - -rep_sigs :: [LSig GhcRn] -> MetaM [(SrcSpan, Core (M TH.Dec))] - -- We silently ignore ones we don't recognise -rep_sigs = concatMapM rep_sig - -rep_sig :: LSig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] -rep_sig (L loc (TypeSig _ nms ty)) - = mapM (rep_wc_ty_sig sigDName loc ty) nms -rep_sig (L loc (PatSynSig _ nms ty)) - = mapM (rep_patsyn_ty_sig loc ty) nms -rep_sig (L loc (ClassOpSig _ is_deflt nms ty)) - | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms - | otherwise = mapM (rep_ty_sig sigDName loc ty) nms -rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) -rep_sig (L loc (FixSig _ fix_sig)) = rep_fix_d loc fix_sig -rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc -rep_sig (L loc (SpecSig _ nm tys ispec)) - = concatMapM (\t -> rep_specialise nm t ispec loc) tys -rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc -rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty -rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty -rep_sig (L loc (CompleteMatchSig _ _st cls mty)) - = rep_complete_sig cls mty loc -rep_sig (L _ (XSig nec)) = noExtCon nec - -rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name - -> MetaM (SrcSpan, Core (M TH.Dec)) --- Don't create the implicit and explicit variables when desugaring signatures, --- see Note [Scoped type variables in class and instance declarations]. --- and Note [Don't quantify implicit type variables in quotes] -rep_ty_sig mk_sig loc sig_ty nm - | HsIB { hsib_body = hs_ty } <- sig_ty - , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis hs_ty - = do { nm1 <- lookupLOcc nm - ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) - ; repTyVarBndrWithKind tv name } - ; th_explicit_tvs <- repListM tyVarBndrTyConName rep_in_scope_tv - explicit_tvs - - -- NB: Don't pass any implicit type variables to repList above - -- See Note [Don't quantify implicit type variables in quotes] - - ; th_ctxt <- repLContext ctxt - ; th_ty <- repLTy ty - ; ty1 <- if null explicit_tvs && null (unLoc ctxt) - then return th_ty - else repTForall th_explicit_tvs th_ctxt th_ty - ; sig <- repProto mk_sig nm1 ty1 - ; return (loc, sig) } -rep_ty_sig _ _ (XHsImplicitBndrs nec) _ = noExtCon nec - -rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name - -> MetaM (SrcSpan, Core (M TH.Dec)) --- represents a pattern synonym type signature; --- see Note [Pattern synonym type signatures and Template Haskell] in Convert --- --- Don't create the implicit and explicit variables when desugaring signatures, --- see Note [Scoped type variables in class and instance declarations] --- and Note [Don't quantify implicit type variables in quotes] -rep_patsyn_ty_sig loc sig_ty nm - | HsIB { hsib_body = hs_ty } <- sig_ty - , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty - = do { nm1 <- lookupLOcc nm - ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) - ; repTyVarBndrWithKind tv name } - ; th_univs <- repListM tyVarBndrTyConName rep_in_scope_tv univs - ; th_exis <- repListM tyVarBndrTyConName rep_in_scope_tv exis - - -- NB: Don't pass any implicit type variables to repList above - -- See Note [Don't quantify implicit type variables in quotes] - - ; th_reqs <- repLContext reqs - ; th_provs <- repLContext provs - ; th_ty <- repLTy ty - ; ty1 <- repTForall th_univs th_reqs =<< - repTForall th_exis th_provs th_ty - ; sig <- repProto patSynSigDName nm1 ty1 - ; return (loc, sig) } -rep_patsyn_ty_sig _ (XHsImplicitBndrs nec) _ = noExtCon nec - -rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name - -> MetaM (SrcSpan, Core (M TH.Dec)) -rep_wc_ty_sig mk_sig loc sig_ty nm - = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm - -rep_inline :: Located Name - -> InlinePragma -- Never defaultInlinePragma - -> SrcSpan - -> MetaM [(SrcSpan, Core (M TH.Dec))] -rep_inline nm ispec loc - = do { nm1 <- lookupLOcc nm - ; inline <- repInline $ inl_inline ispec - ; rm <- repRuleMatch $ inl_rule ispec - ; phases <- repPhases $ inl_act ispec - ; pragma <- repPragInl nm1 inline rm phases - ; return [(loc, pragma)] - } - -rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma - -> SrcSpan - -> MetaM [(SrcSpan, Core (M TH.Dec))] -rep_specialise nm ty ispec loc - = do { nm1 <- lookupLOcc nm - ; ty1 <- repHsSigType ty - ; phases <- repPhases $ inl_act ispec - ; let inline = inl_inline ispec - ; pragma <- if noUserInlineSpec inline - then -- SPECIALISE - repPragSpec nm1 ty1 phases - else -- SPECIALISE INLINE - do { inline1 <- repInline inline - ; repPragSpecInl nm1 ty1 inline1 phases } - ; return [(loc, pragma)] - } - -rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan - -> MetaM [(SrcSpan, Core (M TH.Dec))] -rep_specialiseInst ty loc - = do { ty1 <- repHsSigType ty - ; pragma <- repPragSpecInst ty1 - ; return [(loc, pragma)] } - -repInline :: InlineSpec -> MetaM (Core TH.Inline) -repInline NoInline = dataCon noInlineDataConName -repInline Inline = dataCon inlineDataConName -repInline Inlinable = dataCon inlinableDataConName -repInline NoUserInline = notHandled "NOUSERINLINE" empty - -repRuleMatch :: RuleMatchInfo -> MetaM (Core TH.RuleMatch) -repRuleMatch ConLike = dataCon conLikeDataConName -repRuleMatch FunLike = dataCon funLikeDataConName - -repPhases :: Activation -> MetaM (Core TH.Phases) -repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i - ; dataCon' beforePhaseDataConName [arg] } -repPhases (ActiveAfter _ i) = do { MkC arg <- coreIntLit i - ; dataCon' fromPhaseDataConName [arg] } -repPhases _ = dataCon allPhasesDataConName - -rep_complete_sig :: Located [Located Name] - -> Maybe (Located Name) - -> SrcSpan - -> MetaM [(SrcSpan, Core (M TH.Dec))] -rep_complete_sig (L _ cls) mty loc - = do { mty' <- repMaybe nameTyConName lookupLOcc mty - ; cls' <- repList nameTyConName lookupLOcc cls - ; sig <- repPragComplete cls' mty' - ; return [(loc, sig)] } - -------------------------------------------------------- --- Types -------------------------------------------------------- - -addSimpleTyVarBinds :: [Name] -- the binders to be added - -> MetaM (Core (M a)) -- action in the ext env - -> MetaM (Core (M a)) -addSimpleTyVarBinds names thing_inside - = do { fresh_names <- mkGenSyms names - ; term <- addBinds fresh_names thing_inside - ; wrapGenSyms fresh_names term } - -addHsTyVarBinds :: [LHsTyVarBndr GhcRn] -- the binders to be added - -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a))) -- action in the ext env - -> MetaM (Core (M a)) -addHsTyVarBinds exp_tvs thing_inside - = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs) - ; term <- addBinds fresh_exp_names $ - do { kbs <- repListM tyVarBndrTyConName mk_tv_bndr - (exp_tvs `zip` fresh_exp_names) - ; thing_inside kbs } - ; wrapGenSyms fresh_exp_names term } - where - mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) - -addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added - -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a))) -- action in the ext env - -> MetaM (Core (M a)) --- gensym a list of type variables and enter them into the meta environment; --- the computations passed as the second argument is executed in that extended --- meta environment and gets the *new* names on Core-level as an argument -addTyVarBinds (HsQTvs { hsq_ext = imp_tvs - , hsq_explicit = exp_tvs }) - thing_inside - = addSimpleTyVarBinds imp_tvs $ - addHsTyVarBinds exp_tvs $ - thing_inside -addTyVarBinds (XLHsQTyVars nec) _ = noExtCon nec - -addTyClTyVarBinds :: LHsQTyVars GhcRn - -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a))) - -> MetaM (Core (M a)) - --- Used for data/newtype declarations, and family instances, --- so that the nested type variables work right --- instance C (T a) where --- type W (T a) = blah --- The 'a' in the type instance is the one bound by the instance decl -addTyClTyVarBinds tvs m - = do { let tv_names = hsAllLTyVarNames tvs - ; env <- lift $ dsGetMetaEnv - ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names) - -- Make fresh names for the ones that are not already in scope - -- This makes things work for family declarations - - ; term <- addBinds freshNames $ - do { kbs <- repListM tyVarBndrTyConName mk_tv_bndr - (hsQTvExplicit tvs) - ; m kbs } - - ; wrapGenSyms freshNames term } - where - mk_tv_bndr :: LHsTyVarBndr GhcRn -> MetaM (Core (M TH.TyVarBndr)) - mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv) - ; repTyVarBndrWithKind tv v } - --- Produce kinded binder constructors from the Haskell tyvar binders --- -repTyVarBndrWithKind :: LHsTyVarBndr GhcRn - -> Core TH.Name -> MetaM (Core (M TH.TyVarBndr)) -repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm - = repPlainTV nm -repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm - = repLTy ki >>= repKindedTV nm -repTyVarBndrWithKind (L _ (XTyVarBndr nec)) _ = noExtCon nec - --- | Represent a type variable binder -repTyVarBndr :: LHsTyVarBndr GhcRn -> MetaM (Core (M TH.TyVarBndr)) -repTyVarBndr (L _ (UserTyVar _ (L _ nm)) ) - = do { nm' <- lookupBinder nm - ; repPlainTV nm' } -repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki)) - = do { nm' <- lookupBinder nm - ; ki' <- repLTy ki - ; repKindedTV nm' ki' } -repTyVarBndr (L _ (XTyVarBndr nec)) = noExtCon nec - --- represent a type context --- -repLContext :: LHsContext GhcRn -> MetaM (Core (M TH.Cxt)) -repLContext ctxt = repContext (unLoc ctxt) - -repContext :: HsContext GhcRn -> MetaM (Core (M TH.Cxt)) -repContext ctxt = do preds <- repListM typeTyConName repLTy ctxt - repCtxt preds - -repHsSigType :: LHsSigType GhcRn -> MetaM (Core (M TH.Type)) -repHsSigType (HsIB { hsib_ext = implicit_tvs - , hsib_body = body }) - | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis body - = addSimpleTyVarBinds implicit_tvs $ - -- See Note [Don't quantify implicit type variables in quotes] - addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs -> - do { th_ctxt <- repLContext ctxt - ; th_ty <- repLTy ty - ; if null explicit_tvs && null (unLoc ctxt) - then return th_ty - else repTForall th_explicit_tvs th_ctxt th_ty } -repHsSigType (XHsImplicitBndrs nec) = noExtCon nec - -repHsSigWcType :: LHsSigWcType GhcRn -> MetaM (Core (M TH.Type)) -repHsSigWcType (HsWC { hswc_body = sig1 }) - = repHsSigType sig1 -repHsSigWcType (XHsWildCardBndrs nec) = noExtCon nec - --- yield the representation of a list of types -repLTys :: [LHsType GhcRn] -> MetaM [Core (M TH.Type)] -repLTys tys = mapM repLTy tys - --- represent a type -repLTy :: LHsType GhcRn -> MetaM (Core (M TH.Type)) -repLTy ty = repTy (unLoc ty) - --- Desugar a type headed by an invisible forall (e.g., @forall a. a@) or --- a context (e.g., @Show a => a@) into a ForallT from L.H.TH.Syntax. --- In other words, the argument to this function is always an --- @HsForAllTy ForallInvis@ or @HsQualTy@. --- Types headed by visible foralls (which are desugared to ForallVisT) are --- handled separately in repTy. -repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type)) -repForallT ty - | (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLoc ty) - = addHsTyVarBinds tvs $ \bndrs -> - do { ctxt1 <- repLContext ctxt - ; tau1 <- repLTy tau - ; repTForall bndrs ctxt1 tau1 -- forall a. C a => {...} - } - -repTy :: HsType GhcRn -> MetaM (Core (M TH.Type)) -repTy ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = body }) = - case fvf of - ForallInvis -> repForallT ty - ForallVis -> addHsTyVarBinds tvs $ \bndrs -> - do body1 <- repLTy body - repTForallVis bndrs body1 -repTy ty@(HsQualTy {}) = repForallT ty - -repTy (HsTyVar _ _ (L _ n)) - | isLiftedTypeKindTyConName n = repTStar - | n `hasKey` constraintKindTyConKey = repTConstraint - | n `hasKey` funTyConKey = repArrowTyCon - | isTvOcc occ = do tv1 <- lookupOcc n - repTvar tv1 - | isDataOcc occ = do tc1 <- lookupOcc n - repPromotedDataCon tc1 - | n == eqTyConName = repTequality - | otherwise = do tc1 <- lookupOcc n - repNamedTyCon tc1 - where - occ = nameOccName n - -repTy (HsAppTy _ f a) = do - f1 <- repLTy f - a1 <- repLTy a - repTapp f1 a1 -repTy (HsAppKindTy _ ty ki) = do - ty1 <- repLTy ty - ki1 <- repLTy ki - repTappKind ty1 ki1 -repTy (HsFunTy _ f a) = do - f1 <- repLTy f - a1 <- repLTy a - tcon <- repArrowTyCon - repTapps tcon [f1, a1] -repTy (HsListTy _ t) = do - t1 <- repLTy t - tcon <- repListTyCon - repTapp tcon t1 -repTy (HsTupleTy _ HsUnboxedTuple tys) = do - tys1 <- repLTys tys - tcon <- repUnboxedTupleTyCon (length tys) - repTapps tcon tys1 -repTy (HsTupleTy _ _ tys) = do tys1 <- repLTys tys - tcon <- repTupleTyCon (length tys) - repTapps tcon tys1 -repTy (HsSumTy _ tys) = do tys1 <- repLTys tys - tcon <- repUnboxedSumTyCon (length tys) - repTapps tcon tys1 -repTy (HsOpTy _ ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) - `nlHsAppTy` ty2) -repTy (HsParTy _ t) = repLTy t -repTy (HsStarTy _ _) = repTStar -repTy (HsKindSig _ t k) = do - t1 <- repLTy t - k1 <- repLTy k - repTSig t1 k1 -repTy (HsSpliceTy _ splice) = repSplice splice -repTy (HsExplicitListTy _ _ tys) = do - tys1 <- repLTys tys - repTPromotedList tys1 -repTy (HsExplicitTupleTy _ tys) = do - tys1 <- repLTys tys - tcon <- repPromotedTupleTyCon (length tys) - repTapps tcon tys1 -repTy (HsTyLit _ lit) = do - lit' <- repTyLit lit - repTLit lit' -repTy (HsWildCardTy _) = repTWildCard -repTy (HsIParamTy _ n t) = do - n' <- rep_implicit_param_name (unLoc n) - t' <- repLTy t - repTImplicitParam n' t' - -repTy ty = notHandled "Exotic form of type" (ppr ty) - -repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit)) -repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i - rep2 numTyLitName [iExpr] -repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s - ; rep2 strTyLitName [s'] - } - --- | Represent a type wrapped in a Maybe -repMaybeLTy :: Maybe (LHsKind GhcRn) - -> MetaM (Core (Maybe (M TH.Type))) -repMaybeLTy m = do - k_ty <- wrapName kindTyConName - repMaybeT k_ty repLTy m - -repRole :: Located (Maybe Role) -> MetaM (Core TH.Role) -repRole (L _ (Just Nominal)) = rep2_nw nominalRName [] -repRole (L _ (Just Representational)) = rep2_nw representationalRName [] -repRole (L _ (Just Phantom)) = rep2_nw phantomRName [] -repRole (L _ Nothing) = rep2_nw inferRName [] - ------------------------------------------------------------------------------ --- Splices ------------------------------------------------------------------------------ - -repSplice :: HsSplice GhcRn -> MetaM (Core a) --- See Note [How brackets and nested splices are handled] in TcSplice --- We return a CoreExpr of any old type; the context should know -repSplice (HsTypedSplice _ _ n _) = rep_splice n -repSplice (HsUntypedSplice _ _ n _) = rep_splice n -repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n -repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e) -repSplice e@(HsSplicedT {}) = pprPanic "repSpliceT" (ppr e) -repSplice (XSplice nec) = noExtCon nec - -rep_splice :: Name -> MetaM (Core a) -rep_splice splice_name - = do { mb_val <- lift $ dsLookupMetaEnv splice_name - ; case mb_val of - Just (DsSplice e) -> do { e' <- lift $ dsExpr e - ; return (MkC e') } - _ -> pprPanic "HsSplice" (ppr splice_name) } - -- Should not happen; statically checked - ------------------------------------------------------------------------------ --- Expressions ------------------------------------------------------------------------------ - -repLEs :: [LHsExpr GhcRn] -> MetaM (Core [(M TH.Exp)]) -repLEs es = repListM expTyConName repLE es - --- FIXME: some of these panics should be converted into proper error messages --- unless we can make sure that constructs, which are plainly not --- supported in TH already lead to error messages at an earlier stage -repLE :: LHsExpr GhcRn -> MetaM (Core (M TH.Exp)) -repLE (L loc e) = mapReaderT (putSrcSpanDs loc) (repE e) - -repE :: HsExpr GhcRn -> MetaM (Core (M TH.Exp)) -repE (HsVar _ (L _ x)) = - do { mb_val <- lift $ dsLookupMetaEnv x - ; case mb_val of - Nothing -> do { str <- lift $ globalVar x - ; repVarOrCon x str } - Just (DsBound y) -> repVarOrCon x (coreVar y) - Just (DsSplice e) -> do { e' <- lift $ dsExpr e - ; return (MkC e') } } -repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar -repE (HsOverLabel _ _ s) = repOverLabel s - -repE e@(HsRecFld _ f) = case f of - Unambiguous x _ -> repE (HsVar noExtField (noLoc x)) - Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e) - XAmbiguousFieldOcc nec -> noExtCon nec - - -- Remember, we're desugaring renamer output here, so - -- HsOverlit can definitely occur -repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a } -repE (HsLit _ l) = do { a <- repLiteral l; repLit a } -repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m -repE (HsLamCase _ (MG { mg_alts = (L _ ms) })) - = do { ms' <- mapM repMatchTup ms - ; core_ms <- coreListM matchTyConName ms' - ; repLamCase core_ms } -repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b} -repE (HsAppType _ e t) = do { a <- repLE e - ; s <- repLTy (hswc_body t) - ; repAppType a s } - -repE (OpApp _ e1 op e2) = - do { arg1 <- repLE e1; - arg2 <- repLE e2; - the_op <- repLE op ; - repInfixApp arg1 the_op arg2 } -repE (NegApp _ x _) = do - a <- repLE x - negateVar <- lookupOcc negateName >>= repVar - negateVar `repApp` a -repE (HsPar _ x) = repLE x -repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } -repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } -repE (HsCase _ e (MG { mg_alts = (L _ ms) })) - = do { arg <- repLE e - ; ms2 <- mapM repMatchTup ms - ; core_ms2 <- coreListM matchTyConName ms2 - ; repCaseE arg core_ms2 } -repE (HsIf _ _ x y z) = do - a <- repLE x - b <- repLE y - c <- repLE z - repCond a b c -repE (HsMultiIf _ alts) - = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts - ; expr' <- repMultiIf (nonEmptyCoreList alts') - ; wrapGenSyms (concat binds) expr' } -repE (HsLet _ (L _ bs) e) = do { (ss,ds) <- repBinds bs - ; e2 <- addBinds ss (repLE e) - ; z <- repLetE ds e2 - ; wrapGenSyms ss z } - --- FIXME: I haven't got the types here right yet -repE e@(HsDo _ ctxt (L _ sts)) - | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False } - = do { (ss,zs) <- repLSts sts; - e' <- repDoE (nonEmptyCoreList zs); - wrapGenSyms ss e' } - - | ListComp <- ctxt - = do { (ss,zs) <- repLSts sts; - e' <- repComp (nonEmptyCoreList zs); - wrapGenSyms ss e' } - - | MDoExpr <- ctxt - = do { (ss,zs) <- repLSts sts; - e' <- repMDoE (nonEmptyCoreList zs); - wrapGenSyms ss e' } - - | otherwise - = notHandled "monad comprehension and [: :]" (ppr e) - -repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } -repE (ExplicitTuple _ es boxity) = - let tupArgToCoreExp :: LHsTupArg GhcRn -> MetaM (Core (Maybe (M TH.Exp))) - tupArgToCoreExp (L _ a) - | (Present _ e) <- a = do { e' <- repLE e - ; coreJustM expTyConName e' } - | otherwise = coreNothingM expTyConName - - in do { args <- mapM tupArgToCoreExp es - ; expTy <- wrapName expTyConName - ; let maybeExpQTy = mkTyConApp maybeTyCon [expTy] - listArg = coreList' maybeExpQTy args - ; if isBoxed boxity - then repTup listArg - else repUnboxedTup listArg } - -repE (ExplicitSum _ alt arity e) - = do { e1 <- repLE e - ; repUnboxedSum e1 alt arity } - -repE (RecordCon { rcon_con_name = c, rcon_flds = flds }) - = do { x <- lookupLOcc c; - fs <- repFields flds; - repRecCon x fs } -repE (RecordUpd { rupd_expr = e, rupd_flds = flds }) - = do { x <- repLE e; - fs <- repUpdFields flds; - repRecUpd x fs } - -repE (ExprWithTySig _ e ty) - = do { e1 <- repLE e - ; t1 <- repHsSigWcType ty - ; repSigExp e1 t1 } - -repE (ArithSeq _ _ aseq) = - case aseq of - From e -> do { ds1 <- repLE e; repFrom ds1 } - FromThen e1 e2 -> do - ds1 <- repLE e1 - ds2 <- repLE e2 - repFromThen ds1 ds2 - FromTo e1 e2 -> do - ds1 <- repLE e1 - ds2 <- repLE e2 - repFromTo ds1 ds2 - FromThenTo e1 e2 e3 -> do - ds1 <- repLE e1 - ds2 <- repLE e2 - ds3 <- repLE e3 - repFromThenTo ds1 ds2 ds3 - -repE (HsSpliceE _ splice) = repSplice splice -repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC -repE (HsUnboundVar _ uv) = do - occ <- occNameLit uv - sname <- repNameS occ - repUnboundVar sname - -repE e@(HsPragE _ HsPragCore {} _) = notHandled "Core annotations" (ppr e) -repE e@(HsPragE _ HsPragSCC {} _) = notHandled "Cost centres" (ppr e) -repE e@(HsPragE _ HsPragTick {} _) = notHandled "Tick Pragma" (ppr e) -repE (XExpr nec) = noExtCon nec -repE e = notHandled "Expression form" (ppr e) - ------------------------------------------------------------------------------ --- Building representations of auxiliary structures like Match, Clause, Stmt, - -repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Match)) -repMatchTup (L _ (Match { m_pats = [p] - , m_grhss = GRHSs _ guards (L _ wheres) })) = - do { ss1 <- mkGenSyms (collectPatBinders p) - ; addBinds ss1 $ do { - ; p1 <- repLP p - ; (ss2,ds) <- repBinds wheres - ; addBinds ss2 $ do { - ; gs <- repGuards guards - ; match <- repMatch p1 gs ds - ; wrapGenSyms (ss1++ss2) match }}} -repMatchTup _ = panic "repMatchTup: case alt with more than one arg" - -repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Clause)) -repClauseTup (L _ (Match { m_pats = ps - , m_grhss = GRHSs _ guards (L _ wheres) })) = - do { ss1 <- mkGenSyms (collectPatsBinders ps) - ; addBinds ss1 $ do { - ps1 <- repLPs ps - ; (ss2,ds) <- repBinds wheres - ; addBinds ss2 $ do { - gs <- repGuards guards - ; clause <- repClause ps1 gs ds - ; wrapGenSyms (ss1++ss2) clause }}} -repClauseTup (L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec -repClauseTup (L _ (XMatch nec)) = noExtCon nec - -repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> MetaM (Core (M TH.Body)) -repGuards [L _ (GRHS _ [] e)] - = do {a <- repLE e; repNormal a } -repGuards other - = do { zs <- mapM repLGRHS other - ; let (xs, ys) = unzip zs - ; gd <- repGuarded (nonEmptyCoreList ys) - ; wrapGenSyms (concat xs) gd } - -repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn) - -> MetaM ([GenSymBind], (Core (M (TH.Guard, TH.Exp)))) -repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2)) - = do { guarded <- repLNormalGE e1 e2 - ; return ([], guarded) } -repLGRHS (L _ (GRHS _ ss rhs)) - = do { (gs, ss') <- repLSts ss - ; rhs' <- addBinds gs $ repLE rhs - ; guarded <- repPatGE (nonEmptyCoreList ss') rhs' - ; return (gs, guarded) } -repLGRHS (L _ (XGRHS nec)) = noExtCon nec - -repFields :: HsRecordBinds GhcRn -> MetaM (Core [M TH.FieldExp]) -repFields (HsRecFields { rec_flds = flds }) - = repListM fieldExpTyConName rep_fld flds - where - rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn) - -> MetaM (Core (M TH.FieldExp)) - rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld) - ; e <- repLE (hsRecFieldArg fld) - ; repFieldExp fn e } - -repUpdFields :: [LHsRecUpdField GhcRn] -> MetaM (Core [M TH.FieldExp]) -repUpdFields = repListM fieldExpTyConName rep_fld - where - rep_fld :: LHsRecUpdField GhcRn -> MetaM (Core (M TH.FieldExp)) - rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of - Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name) - ; e <- repLE (hsRecFieldArg fld) - ; repFieldExp fn e } - Ambiguous{} -> notHandled "Ambiguous record updates" (ppr fld) - XAmbiguousFieldOcc nec -> noExtCon nec - - - ------------------------------------------------------------------------------ --- Representing Stmt's is tricky, especially if bound variables --- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |] --- First gensym new names for every variable in any of the patterns. --- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y")) --- if variables didn't shadow, the static gensym wouldn't be necessary --- and we could reuse the original names (x and x). --- --- do { x'1 <- gensym "x" --- ; x'2 <- gensym "x" --- ; doE [ BindSt (pvar x'1) [| f 1 |] --- , BindSt (pvar x'2) [| f x |] --- , NoBindSt [| g x |] --- ] --- } - --- The strategy is to translate a whole list of do-bindings by building a --- bigger environment, and a bigger set of meta bindings --- (like: x'1 <- gensym "x" ) and then combining these with the translations --- of the expressions within the Do - ------------------------------------------------------------------------------ --- The helper function repSts computes the translation of each sub expression --- and a bunch of prefix bindings denoting the dynamic renaming. - -repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)]) -repLSts stmts = repSts (map unLoc stmts) - -repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)]) -repSts (BindStmt _ p e _ _ : ss) = - do { e2 <- repLE e - ; ss1 <- mkGenSyms (collectPatBinders p) - ; addBinds ss1 $ do { - ; p1 <- repLP p; - ; (ss2,zs) <- repSts ss - ; z <- repBindSt p1 e2 - ; return (ss1++ss2, z : zs) }} -repSts (LetStmt _ (L _ bs) : ss) = - do { (ss1,ds) <- repBinds bs - ; z <- repLetSt ds - ; (ss2,zs) <- addBinds ss1 (repSts ss) - ; return (ss1++ss2, z : zs) } -repSts (BodyStmt _ e _ _ : ss) = - do { e2 <- repLE e - ; z <- repNoBindSt e2 - ; (ss2,zs) <- repSts ss - ; return (ss2, z : zs) } -repSts (ParStmt _ stmt_blocks _ _ : ss) = - do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks - ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1 - ss1 = concat ss_s - ; z <- repParSt stmt_blocks2 - ; (ss2, zs) <- addBinds ss1 (repSts ss) - ; return (ss1++ss2, z : zs) } - where - rep_stmt_block :: ParStmtBlock GhcRn GhcRn - -> MetaM ([GenSymBind], Core [(M TH.Stmt)]) - rep_stmt_block (ParStmtBlock _ stmts _ _) = - do { (ss1, zs) <- repSts (map unLoc stmts) - ; zs1 <- coreListM stmtTyConName zs - ; return (ss1, zs1) } - rep_stmt_block (XParStmtBlock nec) = noExtCon nec -repSts [LastStmt _ e _ _] - = do { e2 <- repLE e - ; z <- repNoBindSt e2 - ; return ([], [z]) } -repSts (stmt@RecStmt{} : ss) - = do { let binders = collectLStmtsBinders (recS_stmts stmt) - ; ss1 <- mkGenSyms binders - -- Bring all of binders in the recursive group into scope for the - -- whole group. - ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt)) - ; MASSERT(sort ss1 == sort ss1_other) - ; z <- repRecSt (nonEmptyCoreList rss) - ; (ss2,zs) <- addBinds ss1 (repSts ss) - ; return (ss1++ss2, z : zs) } -repSts (XStmtLR nec : _) = noExtCon nec -repSts [] = return ([],[]) -repSts other = notHandled "Exotic statement" (ppr other) - - ------------------------------------------------------------ --- Bindings ------------------------------------------------------------ - -repBinds :: HsLocalBinds GhcRn -> MetaM ([GenSymBind], Core [(M TH.Dec)]) -repBinds (EmptyLocalBinds _) - = do { core_list <- coreListM decTyConName [] - ; return ([], core_list) } - -repBinds (HsIPBinds _ (IPBinds _ decs)) - = do { ips <- mapM rep_implicit_param_bind decs - ; core_list <- coreListM decTyConName - (de_loc (sort_by_loc ips)) - ; return ([], core_list) - } - -repBinds (HsIPBinds _ (XHsIPBinds nec)) = noExtCon nec - -repBinds (HsValBinds _ decs) - = do { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs } - -- No need to worry about detailed scopes within - -- the binding group, because we are talking Names - -- here, so we can safely treat it as a mutually - -- recursive group - -- For hsScopedTvBinders see Note [Scoped type variables in bindings] - ; ss <- mkGenSyms bndrs - ; prs <- addBinds ss (rep_val_binds decs) - ; core_list <- coreListM decTyConName - (de_loc (sort_by_loc prs)) - ; return (ss, core_list) } -repBinds (XHsLocalBindsLR nec) = noExtCon nec - -rep_implicit_param_bind :: LIPBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) -rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs))) - = do { name <- case ename of - Left (L _ n) -> rep_implicit_param_name n - Right _ -> - panic "rep_implicit_param_bind: post typechecking" - ; rhs' <- repE rhs - ; ipb <- repImplicitParamBind name rhs' - ; return (loc, ipb) } -rep_implicit_param_bind (L _ (XIPBind nec)) = noExtCon nec - -rep_implicit_param_name :: HsIPName -> MetaM (Core String) -rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name) - -rep_val_binds :: HsValBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] --- Assumes: all the binders of the binding are already in the meta-env -rep_val_binds (XValBindsLR (NValBinds binds sigs)) - = do { core1 <- rep_binds (unionManyBags (map snd binds)) - ; core2 <- rep_sigs sigs - ; return (core1 ++ core2) } -rep_val_binds (ValBinds _ _ _) - = panic "rep_val_binds: ValBinds" - -rep_binds :: LHsBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] -rep_binds = mapM rep_bind . bagToList - -rep_bind :: LHsBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) --- Assumes: all the binders of the binding are already in the meta-env - --- Note GHC treats declarations of a variable (not a pattern) --- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match --- with an empty list of patterns -rep_bind (L loc (FunBind - { fun_id = fn, - fun_matches = MG { mg_alts - = (L _ [L _ (Match - { m_pats = [] - , m_grhss = GRHSs _ guards (L _ wheres) } - )]) } })) - = do { (ss,wherecore) <- repBinds wheres - ; guardcore <- addBinds ss (repGuards guards) - ; fn' <- lookupLBinder fn - ; p <- repPvar fn' - ; ans <- repVal p guardcore wherecore - ; ans' <- wrapGenSyms ss ans - ; return (loc, ans') } - -rep_bind (L loc (FunBind { fun_id = fn - , fun_matches = MG { mg_alts = L _ ms } })) - = do { ms1 <- mapM repClauseTup ms - ; fn' <- lookupLBinder fn - ; ans <- repFun fn' (nonEmptyCoreList ms1) - ; return (loc, ans) } - -rep_bind (L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec - -rep_bind (L loc (PatBind { pat_lhs = pat - , pat_rhs = GRHSs _ guards (L _ wheres) })) - = do { patcore <- repLP pat - ; (ss,wherecore) <- repBinds wheres - ; guardcore <- addBinds ss (repGuards guards) - ; ans <- repVal patcore guardcore wherecore - ; ans' <- wrapGenSyms ss ans - ; return (loc, ans') } -rep_bind (L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec - -rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) - = do { v' <- lookupBinder v - ; e2 <- repLE e - ; x <- repNormal e2 - ; patcore <- repPvar v' - ; empty_decls <- coreListM decTyConName [] - ; ans <- repVal patcore x empty_decls - ; return (srcLocSpan (getSrcLoc v), ans) } - -rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" -rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn - , psb_args = args - , psb_def = pat - , psb_dir = dir }))) - = do { syn' <- lookupLBinder syn - ; dir' <- repPatSynDir dir - ; ss <- mkGenArgSyms args - ; patSynD' <- addBinds ss ( - do { args' <- repPatSynArgs args - ; pat' <- repLP pat - ; repPatSynD syn' args' dir' pat' }) - ; patSynD'' <- wrapGenArgSyms args ss patSynD' - ; return (loc, patSynD'') } - where - mkGenArgSyms :: HsPatSynDetails (Located Name) -> MetaM [GenSymBind] - -- for Record Pattern Synonyms we want to conflate the selector - -- and the pattern-only names in order to provide a nicer TH - -- API. Whereas inside GHC, record pattern synonym selectors and - -- their pattern-only bound right hand sides have different names, - -- we want to treat them the same in TH. This is the reason why we - -- need an adjusted mkGenArgSyms in the `RecCon` case below. - mkGenArgSyms (PrefixCon args) = mkGenSyms (map unLoc args) - mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2] - mkGenArgSyms (RecCon fields) - = do { let pats = map (unLoc . recordPatSynPatVar) fields - sels = map (unLoc . recordPatSynSelectorId) fields - ; ss <- mkGenSyms sels - ; return $ replaceNames (zip sels pats) ss } - - replaceNames selsPats genSyms - = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats - , sel == sel' ] - - wrapGenArgSyms :: HsPatSynDetails (Located Name) - -> [GenSymBind] -> Core (M TH.Dec) -> MetaM (Core (M TH.Dec)) - wrapGenArgSyms (RecCon _) _ dec = return dec - wrapGenArgSyms _ ss dec = wrapGenSyms ss dec - -rep_bind (L _ (PatSynBind _ (XPatSynBind nec))) = noExtCon nec -rep_bind (L _ (XHsBindsLR nec)) = noExtCon nec - -repPatSynD :: Core TH.Name - -> Core (M TH.PatSynArgs) - -> Core (M TH.PatSynDir) - -> Core (M TH.Pat) - -> MetaM (Core (M TH.Dec)) -repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat) - = rep2 patSynDName [syn, args, dir, pat] - -repPatSynArgs :: HsPatSynDetails (Located Name) -> MetaM (Core (M TH.PatSynArgs)) -repPatSynArgs (PrefixCon args) - = do { args' <- repList nameTyConName lookupLOcc args - ; repPrefixPatSynArgs args' } -repPatSynArgs (InfixCon arg1 arg2) - = do { arg1' <- lookupLOcc arg1 - ; arg2' <- lookupLOcc arg2 - ; repInfixPatSynArgs arg1' arg2' } -repPatSynArgs (RecCon fields) - = do { sels' <- repList nameTyConName lookupLOcc sels - ; repRecordPatSynArgs sels' } - where sels = map recordPatSynSelectorId fields - -repPrefixPatSynArgs :: Core [TH.Name] -> MetaM (Core (M TH.PatSynArgs)) -repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms] - -repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> MetaM (Core (M TH.PatSynArgs)) -repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2] - -repRecordPatSynArgs :: Core [TH.Name] - -> MetaM (Core (M TH.PatSynArgs)) -repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels] - -repPatSynDir :: HsPatSynDir GhcRn -> MetaM (Core (M TH.PatSynDir)) -repPatSynDir Unidirectional = rep2 unidirPatSynName [] -repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName [] -repPatSynDir (ExplicitBidirectional (MG { mg_alts = (L _ clauses) })) - = do { clauses' <- mapM repClauseTup clauses - ; repExplBidirPatSynDir (nonEmptyCoreList clauses') } -repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec - -repExplBidirPatSynDir :: Core [(M TH.Clause)] -> MetaM (Core (M TH.PatSynDir)) -repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls] - - ------------------------------------------------------------------------------ --- Since everything in a Bind is mutually recursive we need rename all --- all the variables simultaneously. For example: --- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to --- do { f'1 <- gensym "f" --- ; g'2 <- gensym "g" --- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]}, --- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]} --- ]} --- This requires collecting the bindings (f'1 <- gensym "f"), and the --- environment ( f |-> f'1 ) from each binding, and then unioning them --- together. As we do this we collect GenSymBinds's which represent the renamed --- variables bound by the Bindings. In order not to lose track of these --- representations we build a shadow datatype MB with the same structure as --- MonoBinds, but which has slots for the representations - - ------------------------------------------------------------------------------ --- GHC allows a more general form of lambda abstraction than specified --- by Haskell 98. In particular it allows guarded lambda's like : --- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in --- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like --- (\ p1 .. pn -> exp) by causing an error. - -repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Exp)) -repLambda (L _ (Match { m_pats = ps - , m_grhss = GRHSs _ [L _ (GRHS _ [] e)] - (L _ (EmptyLocalBinds _)) } )) - = do { let bndrs = collectPatsBinders ps ; - ; ss <- mkGenSyms bndrs - ; lam <- addBinds ss ( - do { xs <- repLPs ps; body <- repLE e; repLam xs body }) - ; wrapGenSyms ss lam } -repLambda (L _ (Match { m_grhss = GRHSs _ [L _ (GRHS _ [] _)] - (L _ (XHsLocalBindsLR nec)) } )) - = noExtCon nec - -repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m) - - ------------------------------------------------------------------------------ --- Patterns --- repP deals with patterns. It assumes that we have already --- walked over the pattern(s) once to collect the binders, and --- have extended the environment. So every pattern-bound --- variable should already appear in the environment. - --- Process a list of patterns -repLPs :: [LPat GhcRn] -> MetaM (Core [(M TH.Pat)]) -repLPs ps = repListM patTyConName repLP ps - -repLP :: LPat GhcRn -> MetaM (Core (M TH.Pat)) -repLP p = repP (unLoc p) - -repP :: Pat GhcRn -> MetaM (Core (M TH.Pat)) -repP (WildPat _) = repPwild -repP (LitPat _ l) = do { l2 <- repLiteral l; repPlit l2 } -repP (VarPat _ x) = do { x' <- lookupBinder (unLoc x); repPvar x' } -repP (LazyPat _ p) = do { p1 <- repLP p; repPtilde p1 } -repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 } -repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p - ; repPaspat x' p1 } -repP (ParPat _ p) = repLP p -repP (ListPat Nothing ps) = do { qs <- repLPs ps; repPlist qs } -repP (ListPat (Just (SyntaxExprRn e)) ps) = do { p <- repP (ListPat Nothing ps) - ; e' <- repE e - ; repPview e' p} -repP (ListPat _ ps) = pprPanic "repP missing SyntaxExprRn" (ppr ps) -repP (TuplePat _ ps boxed) - | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } - | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } -repP (SumPat _ p alt arity) = do { p1 <- repLP p - ; repPunboxedSum p1 alt arity } -repP (ConPatIn dc details) - = do { con_str <- lookupLOcc dc - ; case details of - PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs } - RecCon rec -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec) - ; repPrec con_str fps } - InfixCon p1 p2 -> do { p1' <- repLP p1; - p2' <- repLP p2; - repPinfix p1' con_str p2' } - } - where - rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> MetaM (Core (M (TH.Name, TH.Pat))) - rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld) - ; MkC p <- repLP (hsRecFieldArg fld) - ; rep2 fieldPatName [v,p] } - -repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l - ; repPlit a } -repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } -repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) -repP (SigPat _ p t) = do { p' <- repLP p - ; t' <- repLTy (hsSigWcType t) - ; repPsig p' t' } -repP (SplicePat _ splice) = repSplice splice -repP (XPat nec) = noExtCon nec -repP other = notHandled "Exotic pattern" (ppr other) - ----------------------------------------------------------- --- Declaration ordering helpers - -sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)] -sort_by_loc xs = sortBy comp xs - where comp x y = compare (fst x) (fst y) - -de_loc :: [(a, b)] -> [b] -de_loc = map snd - ----------------------------------------------------------- --- The meta-environment - --- A name/identifier association for fresh names of locally bound entities -type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id - -- I.e. (x, x_id) means - -- let x_id = gensym "x" in ... - --- Generate a fresh name for a locally bound entity - -mkGenSyms :: [Name] -> MetaM [GenSymBind] --- We can use the existing name. For example: --- [| \x_77 -> x_77 + x_77 |] --- desugars to --- do { x_77 <- genSym "x"; .... } --- We use the same x_77 in the desugared program, but with the type Bndr --- instead of Int --- --- We do make it an Internal name, though (hence localiseName) --- --- Nevertheless, it's monadic because we have to generate nameTy -mkGenSyms ns = do { var_ty <- lookupType nameTyConName - ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] } - - -addBinds :: [GenSymBind] -> MetaM a -> MetaM a --- Add a list of fresh names for locally bound entities to the --- meta environment (which is part of the state carried around --- by the desugarer monad) -addBinds bs m = mapReaderT (dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs])) m - --- Look up a locally bound name --- -lookupLBinder :: Located Name -> MetaM (Core TH.Name) -lookupLBinder n = lookupBinder (unLoc n) - -lookupBinder :: Name -> MetaM (Core TH.Name) -lookupBinder = lookupOcc - -- Binders are brought into scope before the pattern or what-not is - -- desugared. Moreover, in instance declaration the binder of a method - -- will be the selector Id and hence a global; so we need the - -- globalVar case of lookupOcc - --- Look up a name that is either locally bound or a global name --- --- * If it is a global name, generate the "original name" representation (ie, --- the : form) for the associated entity --- -lookupLOcc :: Located Name -> MetaM (Core TH.Name) --- Lookup an occurrence; it can't be a splice. --- Use the in-scope bindings if they exist -lookupLOcc n = lookupOcc (unLoc n) - -lookupOcc :: Name -> MetaM (Core TH.Name) -lookupOcc = lift . lookupOccDsM - -lookupOccDsM :: Name -> DsM (Core TH.Name) -lookupOccDsM n - = do { mb_val <- dsLookupMetaEnv n ; - case mb_val of - Nothing -> globalVar n - Just (DsBound x) -> return (coreVar x) - Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n) - } - -globalVar :: Name -> DsM (Core TH.Name) --- Not bound by the meta-env --- Could be top-level; or could be local --- f x = $(g [| x |]) --- Here the x will be local -globalVar name - | isExternalName name - = do { MkC mod <- coreStringLit name_mod - ; MkC pkg <- coreStringLit name_pkg - ; MkC occ <- nameLit name - ; rep2_nwDsM mk_varg [pkg,mod,occ] } - | otherwise - = do { MkC occ <- nameLit name - ; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name)) - ; rep2_nwDsM mkNameLName [occ,uni] } - where - mod = ASSERT( isExternalName name) nameModule name - name_mod = moduleNameString (moduleName mod) - name_pkg = unitIdString (moduleUnitId mod) - name_occ = nameOccName name - mk_varg | OccName.isDataOcc name_occ = mkNameG_dName - | OccName.isVarOcc name_occ = mkNameG_vName - | OccName.isTcOcc name_occ = mkNameG_tcName - | otherwise = pprPanic "DsMeta.globalVar" (ppr name) - -lookupType :: Name -- Name of type constructor (e.g. (M TH.Exp)) - -> MetaM Type -- The type -lookupType tc_name = do { tc <- lift $ dsLookupTyCon tc_name ; - return (mkTyConApp tc []) } - -wrapGenSyms :: [GenSymBind] - -> Core (M a) -> MetaM (Core (M a)) --- wrapGenSyms [(nm1,id1), (nm2,id2)] y --- --> bindQ (gensym nm1) (\ id1 -> --- bindQ (gensym nm2 (\ id2 -> --- y)) - -wrapGenSyms binds body@(MkC b) - = do { var_ty <- lookupType nameTyConName - ; go var_ty binds } - where - (_, [elt_ty]) = tcSplitAppTys (exprType b) - -- b :: m a, so we can get the type 'a' by looking at the - -- argument type. NB: this relies on Q being a data/newtype, - -- not a type synonym - - go _ [] = return body - go var_ty ((name,id) : binds) - = do { MkC body' <- go var_ty binds - ; lit_str <- lift $ nameLit name - ; gensym_app <- repGensym lit_str - ; repBindM var_ty elt_ty - gensym_app (MkC (Lam id body')) } - -nameLit :: Name -> DsM (Core String) -nameLit n = coreStringLit (occNameString (nameOccName n)) - -occNameLit :: OccName -> MetaM (Core String) -occNameLit name = coreStringLit (occNameString name) - - --- %********************************************************************* --- %* * --- Constructing code --- %* * --- %********************************************************************* - ------------------------------------------------------------------------------ --- PHANTOM TYPES for consistency. In order to make sure we do this correct --- we invent a new datatype which uses phantom types. - -newtype Core a = MkC CoreExpr -unC :: Core a -> CoreExpr -unC (MkC x) = x - -type family NotM a where - NotM (M _) = TypeError ('Text ("rep2_nw must not produce something of overloaded type")) - NotM _other = (() :: Constraint) - -rep2M :: Name -> [CoreExpr] -> MetaM (Core (M a)) -rep2 :: Name -> [CoreExpr] -> MetaM (Core (M a)) -rep2_nw :: NotM a => Name -> [CoreExpr] -> MetaM (Core a) -rep2_nwDsM :: NotM a => Name -> [CoreExpr] -> DsM (Core a) -rep2 = rep2X lift (asks quoteWrapper) -rep2M = rep2X lift (asks monadWrapper) -rep2_nw n xs = lift (rep2_nwDsM n xs) -rep2_nwDsM = rep2X id (return id) - -rep2X :: Monad m => (forall z . DsM z -> m z) - -> m (CoreExpr -> CoreExpr) - -> Name - -> [ CoreExpr ] - -> m (Core a) -rep2X lift_dsm get_wrap n xs = do - { rep_id <- lift_dsm $ dsLookupGlobalId n - ; wrap <- get_wrap - ; return (MkC $ (foldl' App (wrap (Var rep_id)) xs)) } - - -dataCon' :: Name -> [CoreExpr] -> MetaM (Core a) -dataCon' n args = do { id <- lift $ dsLookupDataCon n - ; return $ MkC $ mkCoreConApps id args } - -dataCon :: Name -> MetaM (Core a) -dataCon n = dataCon' n [] - - --- %********************************************************************* --- %* * --- The 'smart constructors' --- %* * --- %********************************************************************* - ---------------- Patterns ----------------- -repPlit :: Core TH.Lit -> MetaM (Core (M TH.Pat)) -repPlit (MkC l) = rep2 litPName [l] - -repPvar :: Core TH.Name -> MetaM (Core (M TH.Pat)) -repPvar (MkC s) = rep2 varPName [s] - -repPtup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) -repPtup (MkC ps) = rep2 tupPName [ps] - -repPunboxedTup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) -repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps] - -repPunboxedSum :: Core (M TH.Pat) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Pat)) --- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here -repPunboxedSum (MkC p) alt arity - = do { dflags <- getDynFlags - ; rep2 unboxedSumPName [ p - , mkIntExprInt dflags alt - , mkIntExprInt dflags arity ] } - -repPcon :: Core TH.Name -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) -repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps] - -repPrec :: Core TH.Name -> Core [M (TH.Name, TH.Pat)] -> MetaM (Core (M TH.Pat)) -repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps] - -repPinfix :: Core (M TH.Pat) -> Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) -repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2] - -repPtilde :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) -repPtilde (MkC p) = rep2 tildePName [p] - -repPbang :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) -repPbang (MkC p) = rep2 bangPName [p] - -repPaspat :: Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) -repPaspat (MkC s) (MkC p) = rep2 asPName [s, p] - -repPwild :: MetaM (Core (M TH.Pat)) -repPwild = rep2 wildPName [] - -repPlist :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) -repPlist (MkC ps) = rep2 listPName [ps] - -repPview :: Core (M TH.Exp) -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) -repPview (MkC e) (MkC p) = rep2 viewPName [e,p] - -repPsig :: Core (M TH.Pat) -> Core (M TH.Type) -> MetaM (Core (M TH.Pat)) -repPsig (MkC p) (MkC t) = rep2 sigPName [p, t] - ---------------- Expressions ----------------- -repVarOrCon :: Name -> Core TH.Name -> MetaM (Core (M TH.Exp)) -repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str - | otherwise = repVar str - -repVar :: Core TH.Name -> MetaM (Core (M TH.Exp)) -repVar (MkC s) = rep2 varEName [s] - -repCon :: Core TH.Name -> MetaM (Core (M TH.Exp)) -repCon (MkC s) = rep2 conEName [s] - -repLit :: Core TH.Lit -> MetaM (Core (M TH.Exp)) -repLit (MkC c) = rep2 litEName [c] - -repApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) -repApp (MkC x) (MkC y) = rep2 appEName [x,y] - -repAppType :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp)) -repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y] - -repLam :: Core [(M TH.Pat)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) -repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e] - -repLamCase :: Core [(M TH.Match)] -> MetaM (Core (M TH.Exp)) -repLamCase (MkC ms) = rep2 lamCaseEName [ms] - -repTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp)) -repTup (MkC es) = rep2 tupEName [es] - -repUnboxedTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp)) -repUnboxedTup (MkC es) = rep2 unboxedTupEName [es] - -repUnboxedSum :: Core (M TH.Exp) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Exp)) --- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here -repUnboxedSum (MkC e) alt arity - = do { dflags <- getDynFlags - ; rep2 unboxedSumEName [ e - , mkIntExprInt dflags alt - , mkIntExprInt dflags arity ] } - -repCond :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) -repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] - -repMultiIf :: Core [M (TH.Guard, TH.Exp)] -> MetaM (Core (M TH.Exp)) -repMultiIf (MkC alts) = rep2 multiIfEName [alts] - -repLetE :: Core [(M TH.Dec)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) -repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] - -repCaseE :: Core (M TH.Exp) -> Core [(M TH.Match)] -> MetaM (Core (M TH.Exp)) -repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms] - -repDoE :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp)) -repDoE (MkC ss) = rep2 doEName [ss] - -repMDoE :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp)) -repMDoE (MkC ss) = rep2 mdoEName [ss] - -repComp :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp)) -repComp (MkC ss) = rep2 compEName [ss] - -repListExp :: Core [(M TH.Exp)] -> MetaM (Core (M TH.Exp)) -repListExp (MkC es) = rep2 listEName [es] - -repSigExp :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp)) -repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t] - -repRecCon :: Core TH.Name -> Core [M TH.FieldExp]-> MetaM (Core (M TH.Exp)) -repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs] - -repRecUpd :: Core (M TH.Exp) -> Core [M TH.FieldExp] -> MetaM (Core (M TH.Exp)) -repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs] - -repFieldExp :: Core TH.Name -> Core (M TH.Exp) -> MetaM (Core (M TH.FieldExp)) -repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x] - -repInfixApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) -repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z] - -repSectionL :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) -repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y] - -repSectionR :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) -repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y] - -repImplicitParamVar :: Core String -> MetaM (Core (M TH.Exp)) -repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x] - ------------- Right hand sides (guarded expressions) ---- -repGuarded :: Core [M (TH.Guard, TH.Exp)] -> MetaM (Core (M TH.Body)) -repGuarded (MkC pairs) = rep2 guardedBName [pairs] - -repNormal :: Core (M TH.Exp) -> MetaM (Core (M TH.Body)) -repNormal (MkC e) = rep2 normalBName [e] - ------------- Guards ---- -repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn - -> MetaM (Core (M (TH.Guard, TH.Exp))) -repLNormalGE g e = do g' <- repLE g - e' <- repLE e - repNormalGE g' e' - -repNormalGE :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M (TH.Guard, TH.Exp))) -repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e] - -repPatGE :: Core [(M TH.Stmt)] -> Core (M TH.Exp) -> MetaM (Core (M (TH.Guard, TH.Exp))) -repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e] - -------------- Stmts ------------------- -repBindSt :: Core (M TH.Pat) -> Core (M TH.Exp) -> MetaM (Core (M TH.Stmt)) -repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e] - -repLetSt :: Core [(M TH.Dec)] -> MetaM (Core (M TH.Stmt)) -repLetSt (MkC ds) = rep2 letSName [ds] - -repNoBindSt :: Core (M TH.Exp) -> MetaM (Core (M TH.Stmt)) -repNoBindSt (MkC e) = rep2 noBindSName [e] - -repParSt :: Core [[(M TH.Stmt)]] -> MetaM (Core (M TH.Stmt)) -repParSt (MkC sss) = rep2 parSName [sss] - -repRecSt :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Stmt)) -repRecSt (MkC ss) = rep2 recSName [ss] - --------------- Range (Arithmetic sequences) ----------- -repFrom :: Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) -repFrom (MkC x) = rep2 fromEName [x] - -repFromThen :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) -repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y] - -repFromTo :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) -repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y] - -repFromThenTo :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) -repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z] - ------------- Match and Clause Tuples ----------- -repMatch :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Match)) -repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds] - -repClause :: Core [(M TH.Pat)] -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Clause)) -repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds] - --------------- Dec ----------------------------- -repVal :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec)) -repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds] - -repFun :: Core TH.Name -> Core [(M TH.Clause)] -> MetaM (Core (M TH.Dec)) -repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] - -repData :: Core (M TH.Cxt) -> Core TH.Name - -> Either (Core [(M TH.TyVarBndr)]) - (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type)) - -> Core (Maybe (M TH.Kind)) -> Core [(M TH.Con)] -> Core [M TH.DerivClause] - -> MetaM (Core (M TH.Dec)) -repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs) - = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs] -repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons) - (MkC derivs) - = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs] - -repNewtype :: Core (M TH.Cxt) -> Core TH.Name - -> Either (Core [(M TH.TyVarBndr)]) - (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type)) - -> Core (Maybe (M TH.Kind)) -> Core (M TH.Con) -> Core [M TH.DerivClause] - -> MetaM (Core (M TH.Dec)) -repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con) - (MkC derivs) - = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs] -repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con) - (MkC derivs) - = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs] - -repTySyn :: Core TH.Name -> Core [(M TH.TyVarBndr)] - -> Core (M TH.Type) -> MetaM (Core (M TH.Dec)) -repTySyn (MkC nm) (MkC tvs) (MkC rhs) - = rep2 tySynDName [nm, tvs, rhs] - -repInst :: Core (Maybe TH.Overlap) -> - Core (M TH.Cxt) -> Core (M TH.Type) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec)) -repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName - [o, cxt, ty, ds] - -repDerivStrategy :: Maybe (LDerivStrategy GhcRn) - -> MetaM (Core (Maybe (M TH.DerivStrategy))) -repDerivStrategy mds = - case mds of - Nothing -> nothing - Just ds -> - case unLoc ds of - StockStrategy -> just =<< repStockStrategy - AnyclassStrategy -> just =<< repAnyclassStrategy - NewtypeStrategy -> just =<< repNewtypeStrategy - ViaStrategy ty -> do ty' <- repLTy (hsSigType ty) - via_strat <- repViaStrategy ty' - just via_strat - where - nothing = coreNothingM derivStrategyTyConName - just = coreJustM derivStrategyTyConName - -repStockStrategy :: MetaM (Core (M TH.DerivStrategy)) -repStockStrategy = rep2 stockStrategyName [] - -repAnyclassStrategy :: MetaM (Core (M TH.DerivStrategy)) -repAnyclassStrategy = rep2 anyclassStrategyName [] - -repNewtypeStrategy :: MetaM (Core (M TH.DerivStrategy)) -repNewtypeStrategy = rep2 newtypeStrategyName [] - -repViaStrategy :: Core (M TH.Type) -> MetaM (Core (M TH.DerivStrategy)) -repViaStrategy (MkC t) = rep2 viaStrategyName [t] - -repOverlap :: Maybe OverlapMode -> MetaM (Core (Maybe TH.Overlap)) -repOverlap mb = - case mb of - Nothing -> nothing - Just o -> - case o of - NoOverlap _ -> nothing - Overlappable _ -> just =<< dataCon overlappableDataConName - Overlapping _ -> just =<< dataCon overlappingDataConName - Overlaps _ -> just =<< dataCon overlapsDataConName - Incoherent _ -> just =<< dataCon incoherentDataConName - where - nothing = coreNothing overlapTyConName - just = coreJust overlapTyConName - - -repClass :: Core (M TH.Cxt) -> Core TH.Name -> Core [(M TH.TyVarBndr)] - -> Core [TH.FunDep] -> Core [(M TH.Dec)] - -> MetaM (Core (M TH.Dec)) -repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) - = rep2 classDName [cxt, cls, tvs, fds, ds] - -repDeriv :: Core (Maybe (M TH.DerivStrategy)) - -> Core (M TH.Cxt) -> Core (M TH.Type) - -> MetaM (Core (M TH.Dec)) -repDeriv (MkC ds) (MkC cxt) (MkC ty) - = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty] - -repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch - -> Core TH.Phases -> MetaM (Core (M TH.Dec)) -repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases) - = rep2 pragInlDName [nm, inline, rm, phases] - -repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Core TH.Phases - -> MetaM (Core (M TH.Dec)) -repPragSpec (MkC nm) (MkC ty) (MkC phases) - = rep2 pragSpecDName [nm, ty, phases] - -repPragSpecInl :: Core TH.Name -> Core (M TH.Type) -> Core TH.Inline - -> Core TH.Phases -> MetaM (Core (M TH.Dec)) -repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases) - = rep2 pragSpecInlDName [nm, ty, inline, phases] - -repPragSpecInst :: Core (M TH.Type) -> MetaM (Core (M TH.Dec)) -repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty] - -repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> MetaM (Core (M TH.Dec)) -repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty] - -repPragRule :: Core String -> Core (Maybe [(M TH.TyVarBndr)]) - -> Core [(M TH.RuleBndr)] -> Core (M TH.Exp) -> Core (M TH.Exp) - -> Core TH.Phases -> MetaM (Core (M TH.Dec)) -repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases) - = rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases] - -repPragAnn :: Core TH.AnnTarget -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec)) -repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e] - -repTySynInst :: Core (M TH.TySynEqn) -> MetaM (Core (M TH.Dec)) -repTySynInst (MkC eqn) - = rep2 tySynInstDName [eqn] - -repDataFamilyD :: Core TH.Name -> Core [(M TH.TyVarBndr)] - -> Core (Maybe (M TH.Kind)) -> MetaM (Core (M TH.Dec)) -repDataFamilyD (MkC nm) (MkC tvs) (MkC kind) - = rep2 dataFamilyDName [nm, tvs, kind] - -repOpenFamilyD :: Core TH.Name - -> Core [(M TH.TyVarBndr)] - -> Core (M TH.FamilyResultSig) - -> Core (Maybe TH.InjectivityAnn) - -> MetaM (Core (M TH.Dec)) -repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj) - = rep2 openTypeFamilyDName [nm, tvs, result, inj] - -repClosedFamilyD :: Core TH.Name - -> Core [(M TH.TyVarBndr)] - -> Core (M TH.FamilyResultSig) - -> Core (Maybe TH.InjectivityAnn) - -> Core [(M TH.TySynEqn)] - -> MetaM (Core (M TH.Dec)) -repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns) - = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns] - -repTySynEqn :: Core (Maybe [(M TH.TyVarBndr)]) -> - Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.TySynEqn)) -repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs) - = rep2 tySynEqnName [mb_bndrs, lhs, rhs] - -repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> MetaM (Core (M TH.Dec)) -repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles] - -repFunDep :: Core [TH.Name] -> Core [TH.Name] -> MetaM (Core TH.FunDep) -repFunDep (MkC xs) (MkC ys) = rep2_nw funDepName [xs, ys] - -repProto :: Name -> Core TH.Name -> Core (M TH.Type) -> MetaM (Core (M TH.Dec)) -repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty] - -repImplicitParamBind :: Core String -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec)) -repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e] - -repCtxt :: Core [(M TH.Pred)] -> MetaM (Core (M TH.Cxt)) -repCtxt (MkC tys) = rep2 cxtName [tys] - -repDataCon :: Located Name - -> HsConDeclDetails GhcRn - -> MetaM (Core (M TH.Con)) -repDataCon con details - = do con' <- lookupLOcc con -- See Note [Binders and occurrences] - repConstr details Nothing [con'] - -repGadtDataCons :: [Located Name] - -> HsConDeclDetails GhcRn - -> LHsType GhcRn - -> MetaM (Core (M TH.Con)) -repGadtDataCons cons details res_ty - = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences] - repConstr details (Just res_ty) cons' - --- Invariant: --- * for plain H98 data constructors second argument is Nothing and third --- argument is a singleton list --- * for GADTs data constructors second argument is (Just return_type) and --- third argument is a non-empty list -repConstr :: HsConDeclDetails GhcRn - -> Maybe (LHsType GhcRn) - -> [Core TH.Name] - -> MetaM (Core (M TH.Con)) -repConstr (PrefixCon ps) Nothing [con] - = do arg_tys <- repListM bangTypeTyConName repBangTy ps - rep2 normalCName [unC con, unC arg_tys] - -repConstr (PrefixCon ps) (Just res_ty) cons - = do arg_tys <- repListM bangTypeTyConName repBangTy ps - res_ty' <- repLTy res_ty - rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty'] - -repConstr (RecCon ips) resTy cons - = do args <- concatMapM rep_ip (unLoc ips) - arg_vtys <- coreListM varBangTypeTyConName args - case resTy of - Nothing -> rep2 recCName [unC (head cons), unC arg_vtys] - Just res_ty -> do - res_ty' <- repLTy res_ty - rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys, - unC res_ty'] - - where - rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) - - rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType)) - rep_one_ip t n = do { MkC v <- lookupOcc (extFieldOcc $ unLoc n) - ; MkC ty <- repBangTy t - ; rep2 varBangTypeName [v,ty] } - -repConstr (InfixCon st1 st2) Nothing [con] - = do arg1 <- repBangTy st1 - arg2 <- repBangTy st2 - rep2 infixCName [unC arg1, unC con, unC arg2] - -repConstr (InfixCon {}) (Just _) _ = - panic "repConstr: infix GADT constructor should be in a PrefixCon" -repConstr _ _ _ = - panic "repConstr: invariant violated" - ------------- Types ------------------- - -repTForall :: Core [(M TH.TyVarBndr)] -> Core (M TH.Cxt) -> Core (M TH.Type) - -> MetaM (Core (M TH.Type)) -repTForall (MkC tvars) (MkC ctxt) (MkC ty) - = rep2 forallTName [tvars, ctxt, ty] - -repTForallVis :: Core [(M TH.TyVarBndr)] -> Core (M TH.Type) - -> MetaM (Core (M TH.Type)) -repTForallVis (MkC tvars) (MkC ty) = rep2 forallVisTName [tvars, ty] - -repTvar :: Core TH.Name -> MetaM (Core (M TH.Type)) -repTvar (MkC s) = rep2 varTName [s] - -repTapp :: Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.Type)) -repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2] - -repTappKind :: Core (M TH.Type) -> Core (M TH.Kind) -> MetaM (Core (M TH.Type)) -repTappKind (MkC ty) (MkC ki) = rep2 appKindTName [ty,ki] - -repTapps :: Core (M TH.Type) -> [Core (M TH.Type)] -> MetaM (Core (M TH.Type)) -repTapps f [] = return f -repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts } - -repTSig :: Core (M TH.Type) -> Core (M TH.Kind) -> MetaM (Core (M TH.Type)) -repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki] - -repTequality :: MetaM (Core (M TH.Type)) -repTequality = rep2 equalityTName [] - -repTPromotedList :: [Core (M TH.Type)] -> MetaM (Core (M TH.Type)) -repTPromotedList [] = repPromotedNilTyCon -repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon - ; f <- repTapp tcon t - ; t' <- repTPromotedList ts - ; repTapp f t' - } - -repTLit :: Core (M TH.TyLit) -> MetaM (Core (M TH.Type)) -repTLit (MkC lit) = rep2 litTName [lit] - -repTWildCard :: MetaM (Core (M TH.Type)) -repTWildCard = rep2 wildCardTName [] - -repTImplicitParam :: Core String -> Core (M TH.Type) -> MetaM (Core (M TH.Type)) -repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e] - -repTStar :: MetaM (Core (M TH.Type)) -repTStar = rep2 starKName [] - -repTConstraint :: MetaM (Core (M TH.Type)) -repTConstraint = rep2 constraintKName [] - ---------- Type constructors -------------- - -repNamedTyCon :: Core TH.Name -> MetaM (Core (M TH.Type)) -repNamedTyCon (MkC s) = rep2 conTName [s] - -repTInfix :: Core (M TH.Type) -> Core TH.Name -> Core (M TH.Type) - -> MetaM (Core (M TH.Type)) -repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2] - -repTupleTyCon :: Int -> MetaM (Core (M TH.Type)) --- Note: not Core Int; it's easier to be direct here -repTupleTyCon i = do dflags <- getDynFlags - rep2 tupleTName [mkIntExprInt dflags i] - -repUnboxedTupleTyCon :: Int -> MetaM (Core (M TH.Type)) --- Note: not Core Int; it's easier to be direct here -repUnboxedTupleTyCon i = do dflags <- getDynFlags - rep2 unboxedTupleTName [mkIntExprInt dflags i] - -repUnboxedSumTyCon :: TH.SumArity -> MetaM (Core (M TH.Type)) --- Note: not Core TH.SumArity; it's easier to be direct here -repUnboxedSumTyCon arity = do dflags <- getDynFlags - rep2 unboxedSumTName [mkIntExprInt dflags arity] - -repArrowTyCon :: MetaM (Core (M TH.Type)) -repArrowTyCon = rep2 arrowTName [] - -repListTyCon :: MetaM (Core (M TH.Type)) -repListTyCon = rep2 listTName [] - -repPromotedDataCon :: Core TH.Name -> MetaM (Core (M TH.Type)) -repPromotedDataCon (MkC s) = rep2 promotedTName [s] - -repPromotedTupleTyCon :: Int -> MetaM (Core (M TH.Type)) -repPromotedTupleTyCon i = do dflags <- getDynFlags - rep2 promotedTupleTName [mkIntExprInt dflags i] - -repPromotedNilTyCon :: MetaM (Core (M TH.Type)) -repPromotedNilTyCon = rep2 promotedNilTName [] - -repPromotedConsTyCon :: MetaM (Core (M TH.Type)) -repPromotedConsTyCon = rep2 promotedConsTName [] - ------------- TyVarBndrs ------------------- - -repPlainTV :: Core TH.Name -> MetaM (Core (M TH.TyVarBndr)) -repPlainTV (MkC nm) = rep2 plainTVName [nm] - -repKindedTV :: Core TH.Name -> Core (M TH.Kind) -> MetaM (Core (M TH.TyVarBndr)) -repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki] - ----------------------------------------------------------- --- Type family result signature - -repNoSig :: MetaM (Core (M TH.FamilyResultSig)) -repNoSig = rep2 noSigName [] - -repKindSig :: Core (M TH.Kind) -> MetaM (Core (M TH.FamilyResultSig)) -repKindSig (MkC ki) = rep2 kindSigName [ki] - -repTyVarSig :: Core (M TH.TyVarBndr) -> MetaM (Core (M TH.FamilyResultSig)) -repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr] - ----------------------------------------------------------- --- Literals - -repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit) -repLiteral (HsStringPrim _ bs) - = do dflags <- getDynFlags - word8_ty <- lookupType word8TyConName - let w8s = unpack bs - w8s_expr = map (\w8 -> mkCoreConApps word8DataCon - [mkWordLit dflags (toInteger w8)]) w8s - rep2_nw stringPrimLName [mkListExpr word8_ty w8s_expr] -repLiteral lit - = do lit' <- case lit of - HsIntPrim _ i -> mk_integer i - HsWordPrim _ w -> mk_integer w - HsInt _ i -> mk_integer (il_value i) - HsFloatPrim _ r -> mk_rational r - HsDoublePrim _ r -> mk_rational r - HsCharPrim _ c -> mk_char c - _ -> return lit - lit_expr <- lift $ dsLit lit' - case mb_lit_name of - Just lit_name -> rep2_nw lit_name [lit_expr] - Nothing -> notHandled "Exotic literal" (ppr lit) - where - mb_lit_name = case lit of - HsInteger _ _ _ -> Just integerLName - HsInt _ _ -> Just integerLName - HsIntPrim _ _ -> Just intPrimLName - HsWordPrim _ _ -> Just wordPrimLName - HsFloatPrim _ _ -> Just floatPrimLName - HsDoublePrim _ _ -> Just doublePrimLName - HsChar _ _ -> Just charLName - HsCharPrim _ _ -> Just charPrimLName - HsString _ _ -> Just stringLName - HsRat _ _ _ -> Just rationalLName - _ -> Nothing - -mk_integer :: Integer -> MetaM (HsLit GhcRn) -mk_integer i = do integer_ty <- lookupType integerTyConName - return $ HsInteger NoSourceText i integer_ty - -mk_rational :: FractionalLit -> MetaM (HsLit GhcRn) -mk_rational r = do rat_ty <- lookupType rationalTyConName - return $ HsRat noExtField r rat_ty -mk_string :: FastString -> MetaM (HsLit GhcRn) -mk_string s = return $ HsString NoSourceText s - -mk_char :: Char -> MetaM (HsLit GhcRn) -mk_char c = return $ HsChar NoSourceText c - -repOverloadedLiteral :: HsOverLit GhcRn -> MetaM (Core TH.Lit) -repOverloadedLiteral (OverLit { ol_val = val}) - = do { lit <- mk_lit val; repLiteral lit } - -- The type Rational will be in the environment, because - -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, - -- and rationalL is sucked in when any TH stuff is used -repOverloadedLiteral (XOverLit nec) = noExtCon nec - -mk_lit :: OverLitVal -> MetaM (HsLit GhcRn) -mk_lit (HsIntegral i) = mk_integer (il_value i) -mk_lit (HsFractional f) = mk_rational f -mk_lit (HsIsString _ s) = mk_string s - -repNameS :: Core String -> MetaM (Core TH.Name) -repNameS (MkC name) = rep2_nw mkNameSName [name] - ---------------- Miscellaneous ------------------- - -repGensym :: Core String -> MetaM (Core (M TH.Name)) -repGensym (MkC lit_str) = rep2 newNameName [lit_str] - -repBindM :: Type -> Type -- a and b - -> Core (M a) -> Core (a -> M b) -> MetaM (Core (M b)) -repBindM ty_a ty_b (MkC x) (MkC y) - = rep2M bindMName [Type ty_a, Type ty_b, x, y] - -repSequenceM :: Type -> Core [M a] -> MetaM (Core (M [a])) -repSequenceM ty_a (MkC list) - = rep2M sequenceQName [Type ty_a, list] - -repUnboundVar :: Core TH.Name -> MetaM (Core (M TH.Exp)) -repUnboundVar (MkC name) = rep2 unboundVarEName [name] - -repOverLabel :: FastString -> MetaM (Core (M TH.Exp)) -repOverLabel fs = do - (MkC s) <- coreStringLit $ unpackFS fs - rep2 labelEName [s] - - ------------- Lists ------------------- --- turn a list of patterns into a single pattern matching a list - -repList :: Name -> (a -> MetaM (Core b)) - -> [a] -> MetaM (Core [b]) -repList tc_name f args - = do { args1 <- mapM f args - ; coreList tc_name args1 } - --- Create a list of m a values -repListM :: Name -> (a -> MetaM (Core b)) - -> [a] -> MetaM (Core [b]) -repListM tc_name f args - = do { ty <- wrapName tc_name - ; args1 <- mapM f args - ; return $ coreList' ty args1 } - -coreListM :: Name -> [Core a] -> MetaM (Core [a]) -coreListM tc as = repListM tc return as - -coreList :: Name -- Of the TyCon of the element type - -> [Core a] -> MetaM (Core [a]) -coreList tc_name es - = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) } - -coreList' :: Type -- The element type - -> [Core a] -> Core [a] -coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es )) - -nonEmptyCoreList :: [Core a] -> Core [a] - -- The list must be non-empty so we can get the element type - -- Otherwise use coreList -nonEmptyCoreList [] = panic "coreList: empty argument" -nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs)) - - -coreStringLit :: MonadThings m => String -> m (Core String) -coreStringLit s = do { z <- mkStringExpr s; return(MkC z) } - -------------------- Maybe ------------------ - -repMaybe :: Name -> (a -> MetaM (Core b)) - -> Maybe a -> MetaM (Core (Maybe b)) -repMaybe tc_name f m = do - t <- lookupType tc_name - repMaybeT t f m - -repMaybeT :: Type -> (a -> MetaM (Core b)) - -> Maybe a -> MetaM (Core (Maybe b)) -repMaybeT ty _ Nothing = return $ coreNothing' ty -repMaybeT ty f (Just es) = coreJust' ty <$> f es - --- | Construct Core expression for Nothing of a given type name -coreNothing :: Name -- ^ Name of the TyCon of the element type - -> MetaM (Core (Maybe a)) -coreNothing tc_name = - do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) } - -coreNothingM :: Name -> MetaM (Core (Maybe a)) -coreNothingM tc_name = - do { elt_ty <- wrapName tc_name; return (coreNothing' elt_ty) } - --- | Construct Core expression for Nothing of a given type -coreNothing' :: Type -- ^ The element type - -> Core (Maybe a) -coreNothing' elt_ty = MkC (mkNothingExpr elt_ty) - --- | Store given Core expression in a Just of a given type name -coreJust :: Name -- ^ Name of the TyCon of the element type - -> Core a -> MetaM (Core (Maybe a)) -coreJust tc_name es - = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) } - -coreJustM :: Name -> Core a -> MetaM (Core (Maybe a)) -coreJustM tc_name es = do { elt_ty <- wrapName tc_name; return (coreJust' elt_ty es) } - --- | Store given Core expression in a Just of a given type -coreJust' :: Type -- ^ The element type - -> Core a -> Core (Maybe a) -coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es)) - -------------------- Maybe Lists ------------------ - --- Lookup the name and wrap it with the m variable -repMaybeListM :: Name -> (a -> MetaM (Core b)) - -> Maybe [a] -> MetaM (Core (Maybe [b])) -repMaybeListM tc_name f xs = do - elt_ty <- wrapName tc_name - repMaybeListT elt_ty f xs - - -repMaybeListT :: Type -> (a -> MetaM (Core b)) - -> Maybe [a] -> MetaM (Core (Maybe [b])) -repMaybeListT elt_ty _ Nothing = coreNothingList elt_ty -repMaybeListT elt_ty f (Just args) - = do { args1 <- mapM f args - ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) } - -coreNothingList :: Type -> MetaM (Core (Maybe [a])) -coreNothingList elt_ty = return $ coreNothing' (mkListTy elt_ty) - ------------- Literals & Variables ------------------- - -coreIntLit :: Int -> MetaM (Core Int) -coreIntLit i = do dflags <- getDynFlags - return (MkC (mkIntExprInt dflags i)) - -coreIntegerLit :: MonadThings m => Integer -> m (Core Integer) -coreIntegerLit i = fmap MkC (mkIntegerExpr i) - -coreVar :: Id -> Core TH.Name -- The Id has type Name -coreVar id = MkC (Var id) - ------------------ Failure ----------------------- -notHandledL :: SrcSpan -> String -> SDoc -> MetaM a -notHandledL loc what doc - | isGoodSrcSpan loc - = mapReaderT (putSrcSpanDs loc) $ notHandled what doc - | otherwise - = notHandled what doc - -notHandled :: String -> SDoc -> MetaM a -notHandled what doc = lift $ failWithDs msg - where - msg = hang (text what <+> text "not (yet) handled by Template Haskell") - 2 doc diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs deleted file mode 100644 index 998d46395d..0000000000 --- a/compiler/deSugar/DsMonad.hs +++ /dev/null @@ -1,598 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -@DsMonad@: monadery used in desugaring --} - -{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan -{-# LANGUAGE ViewPatterns #-} - -module DsMonad ( - DsM, mapM, mapAndUnzipM, - initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs, - foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM, - Applicative(..),(<$>), - - duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs, - newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId, - newFailLocalDs, newPredVarDs, - getSrcSpanDs, putSrcSpanDs, - mkPrintUnqualifiedDs, - newUnique, - UniqSupply, newUniqueSupply, - getGhcModeDs, dsGetFamInstEnvs, - dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, - dsLookupDataCon, dsLookupConLike, - - DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, - - -- Getting and setting pattern match oracle states - getPmDelta, updPmDelta, - - -- Get COMPLETE sets of a TyCon - dsGetCompleteMatches, - - -- Warnings and errors - DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr, - failWithDs, failDs, discardWarningsDs, - askNoErrsDs, - - -- Data types - DsMatchContext(..), - EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper, - CanItFail(..), orFail, - - -- Levity polymorphism - dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs, - - -- Trace injection - pprRuntimeTrace - ) where - -import GhcPrelude - -import TcRnMonad -import FamInstEnv -import CoreSyn -import MkCore ( unitExpr ) -import CoreUtils ( exprType, isExprLevPoly ) -import GHC.Hs -import GHC.IfaceToCore -import TcMType ( checkForLevPolyX, formatLevPolyErr ) -import PrelNames -import RdrName -import HscTypes -import Bag -import BasicTypes ( Origin ) -import DataCon -import ConLike -import TyCon -import GHC.HsToCore.PmCheck.Types -import Id -import Module -import Outputable -import SrcLoc -import Type -import UniqSupply -import Name -import NameEnv -import DynFlags -import ErrUtils -import FastString -import UniqFM ( lookupWithDefaultUFM ) -import Literal ( mkLitString ) -import CostCentreState - -import Data.IORef - -{- -************************************************************************ -* * - Data types for the desugarer -* * -************************************************************************ --} - -data DsMatchContext - = DsMatchContext (HsMatchContext GhcRn) SrcSpan - deriving () - -instance Outputable DsMatchContext where - ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match - -data EquationInfo - = EqnInfo { eqn_pats :: [Pat GhcTc] - -- ^ The patterns for an equation - -- - -- NB: We have /already/ applied 'decideBangHood' to - -- these patterns. See Note [decideBangHood] in "DsUtils" - - , eqn_orig :: Origin - -- ^ Was this equation present in the user source? - -- - -- This helps us avoid warnings on patterns that GHC elaborated. - -- - -- For instance, the pattern @-1 :: Word@ gets desugared into - -- @W# -1## :: Word@, but we shouldn't warn about an overflowed - -- literal for /both/ of these cases. - - , eqn_rhs :: MatchResult - -- ^ What to do after match - } - -instance Outputable EquationInfo where - ppr (EqnInfo pats _ _) = ppr pats - -type DsWrapper = CoreExpr -> CoreExpr -idDsWrapper :: DsWrapper -idDsWrapper e = e - --- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult --- \fail. wrap (case vs of { pats -> rhs fail }) --- where vs are not bound by wrap - - --- A MatchResult is an expression with a hole in it -data MatchResult - = MatchResult - CanItFail -- Tells whether the failure expression is used - (CoreExpr -> DsM CoreExpr) - -- Takes a expression to plug in at the - -- failure point(s). The expression should - -- be duplicatable! - -data CanItFail = CanFail | CantFail - -orFail :: CanItFail -> CanItFail -> CanItFail -orFail CantFail CantFail = CantFail -orFail _ _ = CanFail - -{- -************************************************************************ -* * - Monad functions -* * -************************************************************************ --} - --- Compatibility functions -fixDs :: (a -> DsM a) -> DsM a -fixDs = fixM - -type DsWarning = (SrcSpan, SDoc) - -- Not quite the same as a WarnMsg, we have an SDoc here - -- and we'll do the print_unqual stuff later on to turn it - -- into a Doc. - --- | Run a 'DsM' action inside the 'TcM' monad. -initDsTc :: DsM a -> TcM a -initDsTc thing_inside - = do { tcg_env <- getGblEnv - ; msg_var <- getErrsVar - ; hsc_env <- getTopEnv - ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env - ; setEnvs envs thing_inside - } - --- | Run a 'DsM' action inside the 'IO' monad. -initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a) -initDs hsc_env tcg_env thing_inside - = do { msg_var <- newIORef emptyMessages - ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env - ; runDs hsc_env envs thing_inside - } - --- | Build a set of desugarer environments derived from a 'TcGblEnv'. -mkDsEnvsFromTcGbl :: MonadIO m - => HscEnv -> IORef Messages -> TcGblEnv - -> m (DsGblEnv, DsLclEnv) -mkDsEnvsFromTcGbl hsc_env msg_var tcg_env - = do { cc_st_var <- liftIO $ newIORef newCostCentreState - ; let dflags = hsc_dflags hsc_env - this_mod = tcg_mod tcg_env - type_env = tcg_type_env tcg_env - rdr_env = tcg_rdr_env tcg_env - fam_inst_env = tcg_fam_inst_env tcg_env - complete_matches = hptCompleteSigs hsc_env - ++ tcg_complete_matches tcg_env - ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env - msg_var cc_st_var complete_matches - } - -runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a) -runDs hsc_env (ds_gbl, ds_lcl) thing_inside - = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl - (tryM thing_inside) - ; msgs <- readIORef (ds_msgs ds_gbl) - ; let final_res - | errorsFound dflags msgs = Nothing - | Right r <- res = Just r - | otherwise = panic "initDs" - ; return (msgs, final_res) - } - where dflags = hsc_dflags hsc_env - --- | Run a 'DsM' action in the context of an existing 'ModGuts' -initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a) -initDsWithModGuts hsc_env guts thing_inside - = do { cc_st_var <- newIORef newCostCentreState - ; msg_var <- newIORef emptyMessages - ; let dflags = hsc_dflags hsc_env - type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts) - rdr_env = mg_rdr_env guts - fam_inst_env = mg_fam_inst_env guts - this_mod = mg_module guts - complete_matches = hptCompleteSigs hsc_env - ++ mg_complete_sigs guts - - bindsToIds (NonRec v _) = [v] - bindsToIds (Rec binds) = map fst binds - ids = concatMap bindsToIds (mg_binds guts) - - envs = mkDsEnvs dflags this_mod rdr_env type_env - fam_inst_env msg_var cc_st_var - complete_matches - ; runDs hsc_env envs thing_inside - } - -initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a) --- Spin up a TcM context so that we can run the constraint solver --- Returns any error messages generated by the constraint solver --- and (Just res) if no error happened; Nothing if an error happened --- --- Simon says: I'm not very happy about this. We spin up a complete TcM monad --- only to immediately refine it to a TcS monad. --- Better perhaps to make TcS into its own monad, rather than building on TcS --- But that may in turn interact with plugins - -initTcDsForSolver thing_inside - = do { (gbl, lcl) <- getEnvs - ; hsc_env <- getTopEnv - - ; let DsGblEnv { ds_mod = mod - , ds_fam_inst_env = fam_inst_env } = gbl - - DsLclEnv { dsl_loc = loc } = lcl - - ; liftIO $ initTc hsc_env HsSrcFile False mod loc $ - updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $ - thing_inside } - -mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv - -> IORef Messages -> IORef CostCentreState -> [CompleteMatch] - -> (DsGblEnv, DsLclEnv) -mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var - complete_matches - = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs", - if_rec_types = Just (mod, return type_env) } - if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod) - False -- not boot! - real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1) - completeMatchMap = mkCompleteMatchMap complete_matches - gbl_env = DsGblEnv { ds_mod = mod - , ds_fam_inst_env = fam_inst_env - , ds_if_env = (if_genv, if_lenv) - , ds_unqual = mkPrintUnqualified dflags rdr_env - , ds_msgs = msg_var - , ds_complete_matches = completeMatchMap - , ds_cc_st = cc_st_var - } - lcl_env = DsLclEnv { dsl_meta = emptyNameEnv - , dsl_loc = real_span - , dsl_delta = initDelta - } - in (gbl_env, lcl_env) - - -{- -************************************************************************ -* * - Operations in the monad -* * -************************************************************************ - -And all this mysterious stuff is so we can occasionally reach out and -grab one or more names. @newLocalDs@ isn't exported---exported -functions are defined with it. The difference in name-strings makes -it easier to read debugging output. - -Note [Levity polymorphism checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -According to the "Levity Polymorphism" paper (PLDI '17), levity -polymorphism is forbidden in precisely two places: in the type of a bound -term-level argument and in the type of an argument to a function. The paper -explains it more fully, but briefly: expressions in these contexts need to be -stored in registers, and it's hard (read, impossible) to store something -that's levity polymorphic. - -We cannot check for bad levity polymorphism conveniently in the type checker, -because we can't tell, a priori, which levity metavariables will be solved. -At one point, I (Richard) thought we could check in the zonker, but it's hard -to know where precisely are the abstracted variables and the arguments. So -we check in the desugarer, the only place where we can see the Core code and -still report respectable syntax to the user. This covers the vast majority -of cases; see calls to DsMonad.dsNoLevPoly and friends. - -Levity polymorphism is also prohibited in the types of binders, and the -desugarer checks for this in GHC-generated Ids. (The zonker handles -the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP. -The newSysLocalDs variant is used in the vast majority of cases where -the binder is obviously not levity polymorphic, omitting the check. -It would be nice to ASSERT that there is no levity polymorphism here, -but we can't, because of the fixM in DsArrows. It's all OK, though: -Core Lint will catch an error here. - -However, the desugarer is the wrong place for certain checks. In particular, -the desugarer can't report a sensible error message if an HsWrapper is malformed. -After all, GHC itself produced the HsWrapper. So we store some message text -in the appropriate HsWrappers (e.g. WpFun) that we can print out in the -desugarer. - -There are a few more checks in places where Core is generated outside the -desugarer. For example, in datatype and class declarations, where levity -polymorphism is checked for during validity checking. It would be nice to -have one central place for all this, but that doesn't seem possible while -still reporting nice error messages. - --} - --- Make a new Id with the same print name, but different type, and new unique -newUniqueId :: Id -> Type -> DsM Id -newUniqueId id = mk_local (occNameFS (nameOccName (idName id))) - -duplicateLocalDs :: Id -> DsM Id -duplicateLocalDs old_local - = do { uniq <- newUnique - ; return (setIdUnique old_local uniq) } - -newPredVarDs :: PredType -> DsM Var -newPredVarDs - = mkSysLocalOrCoVarM (fsLit "ds") -- like newSysLocalDs, but we allow covars - -newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id -newSysLocalDsNoLP = mk_local (fsLit "ds") - --- this variant should be used when the caller can be sure that the variable type --- is not levity-polymorphic. It is necessary when the type is knot-tied because --- of the fixM used in DsArrows. See Note [Levity polymorphism checking] -newSysLocalDs = mkSysLocalM (fsLit "ds") -newFailLocalDs = mkSysLocalM (fsLit "fail") - -- the fail variable is used only in a situation where we can tell that - -- levity-polymorphism is impossible. - -newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id] -newSysLocalsDsNoLP = mapM newSysLocalDsNoLP -newSysLocalsDs = mapM newSysLocalDs - -mk_local :: FastString -> Type -> DsM Id -mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+> - ppr ty) -- could improve the msg with another - -- parameter indicating context - ; mkSysLocalOrCoVarM fs ty } - -{- -We can also reach out and either set/grab location information from -the @SrcSpan@ being carried around. --} - -getGhcModeDs :: DsM GhcMode -getGhcModeDs = getDynFlags >>= return . ghcMode - --- | Get the current pattern match oracle state. See 'dsl_delta'. -getPmDelta :: DsM Delta -getPmDelta = do { env <- getLclEnv; return (dsl_delta env) } - --- | Set the pattern match oracle state within the scope of the given action. --- See 'dsl_delta'. -updPmDelta :: Delta -> DsM a -> DsM a -updPmDelta delta = updLclEnv (\env -> env { dsl_delta = delta }) - -getSrcSpanDs :: DsM SrcSpan -getSrcSpanDs = do { env <- getLclEnv - ; return (RealSrcSpan (dsl_loc env)) } - -putSrcSpanDs :: SrcSpan -> DsM a -> DsM a -putSrcSpanDs (UnhelpfulSpan {}) thing_inside - = thing_inside -putSrcSpanDs (RealSrcSpan real_span) thing_inside - = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside - --- | Emit a warning for the current source location --- NB: Warns whether or not -Wxyz is set -warnDs :: WarnReason -> SDoc -> DsM () -warnDs reason warn - = do { env <- getGblEnv - ; loc <- getSrcSpanDs - ; dflags <- getDynFlags - ; let msg = makeIntoWarning reason $ - mkWarnMsg dflags loc (ds_unqual env) warn - ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) } - --- | Emit a warning only if the correct WarnReason is set in the DynFlags -warnIfSetDs :: WarningFlag -> SDoc -> DsM () -warnIfSetDs flag warn - = whenWOptM flag $ - warnDs (Reason flag) warn - -errDs :: SDoc -> DsM () -errDs err - = do { env <- getGblEnv - ; loc <- getSrcSpanDs - ; dflags <- getDynFlags - ; let msg = mkErrMsg dflags loc (ds_unqual env) err - ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) } - --- | Issue an error, but return the expression for (), so that we can continue --- reporting errors. -errDsCoreExpr :: SDoc -> DsM CoreExpr -errDsCoreExpr err - = do { errDs err - ; return unitExpr } - -failWithDs :: SDoc -> DsM a -failWithDs err - = do { errDs err - ; failM } - -failDs :: DsM a -failDs = failM - --- (askNoErrsDs m) runs m --- If m fails, --- then (askNoErrsDs m) fails --- If m succeeds with result r, --- then (askNoErrsDs m) succeeds with result (r, b), --- where b is True iff m generated no errors --- Regardless of success or failure, --- propagate any errors/warnings generated by m --- --- c.f. TcRnMonad.askNoErrs -askNoErrsDs :: DsM a -> DsM (a, Bool) -askNoErrsDs thing_inside - = do { errs_var <- newMutVar emptyMessages - ; env <- getGblEnv - ; mb_res <- tryM $ -- Be careful to catch exceptions - -- so that we propagate errors correctly - -- (#13642) - setGblEnv (env { ds_msgs = errs_var }) $ - thing_inside - - -- Propagate errors - ; msgs@(warns, errs) <- readMutVar errs_var - ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs)) - - -- And return - ; case mb_res of - Left _ -> failM - Right res -> do { dflags <- getDynFlags - ; let errs_found = errorsFound dflags msgs - ; return (res, not errs_found) } } - -mkPrintUnqualifiedDs :: DsM PrintUnqualified -mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv - -instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where - lookupThing = dsLookupGlobal - -dsLookupGlobal :: Name -> DsM TyThing --- Very like TcEnv.tcLookupGlobal -dsLookupGlobal name - = do { env <- getGblEnv - ; setEnvs (ds_if_env env) - (tcIfaceGlobal name) } - -dsLookupGlobalId :: Name -> DsM Id -dsLookupGlobalId name - = tyThingId <$> dsLookupGlobal name - -dsLookupTyCon :: Name -> DsM TyCon -dsLookupTyCon name - = tyThingTyCon <$> dsLookupGlobal name - -dsLookupDataCon :: Name -> DsM DataCon -dsLookupDataCon name - = tyThingDataCon <$> dsLookupGlobal name - -dsLookupConLike :: Name -> DsM ConLike -dsLookupConLike name - = tyThingConLike <$> dsLookupGlobal name - - -dsGetFamInstEnvs :: DsM FamInstEnvs --- Gets both the external-package inst-env --- and the home-pkg inst env (includes module being compiled) -dsGetFamInstEnvs - = do { eps <- getEps; env <- getGblEnv - ; return (eps_fam_inst_env eps, ds_fam_inst_env env) } - -dsGetMetaEnv :: DsM (NameEnv DsMetaVal) -dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) } - --- | The @COMPLETE@ pragmas provided by the user for a given `TyCon`. -dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch] -dsGetCompleteMatches tc = do - eps <- getEps - env <- getGblEnv - let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc - eps_matches_list = lookup_completes $ eps_complete_matches eps - env_matches_list = lookup_completes $ ds_complete_matches env - return $ eps_matches_list ++ env_matches_list - -dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal) -dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) } - -dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a -dsExtendMetaEnv menv thing_inside - = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside - -discardWarningsDs :: DsM a -> DsM a --- Ignore warnings inside the thing inside; --- used to ignore inaccessible cases etc. inside generated code -discardWarningsDs thing_inside - = do { env <- getGblEnv - ; old_msgs <- readTcRef (ds_msgs env) - - ; result <- thing_inside - - -- Revert messages to old_msgs - ; writeTcRef (ds_msgs env) old_msgs - - ; return result } - --- | Fail with an error message if the type is levity polymorphic. -dsNoLevPoly :: Type -> SDoc -> DsM () --- See Note [Levity polymorphism checking] -dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty - --- | Check an expression for levity polymorphism, failing if it is --- levity polymorphic. -dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM () --- See Note [Levity polymorphism checking] -dsNoLevPolyExpr e doc - | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc) - | otherwise = return () - --- | Runs the thing_inside. If there are no errors, then returns the expr --- given. Otherwise, returns unitExpr. This is useful for doing a bunch --- of levity polymorphism checks and then avoiding making a core App. --- (If we make a core App on a levity polymorphic argument, detecting how --- to handle the let/app invariant might call isUnliftedType, which panics --- on a levity polymorphic type.) --- See #12709 for an example of why this machinery is necessary. -dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr -dsWhenNoErrs thing_inside mk_expr - = do { (result, no_errs) <- askNoErrsDs thing_inside - ; return $ if no_errs - then mk_expr result - else unitExpr } - --- | Inject a trace message into the compiled program. Whereas --- pprTrace prints out information *while compiling*, pprRuntimeTrace --- captures that information and causes it to be printed *at runtime* --- using Debug.Trace.trace. --- --- pprRuntimeTrace hdr doc expr --- --- will produce an expression that looks like --- --- trace (hdr + doc) expr --- --- When using this to debug a module that Debug.Trace depends on, --- it is necessary to import {-# SOURCE #-} Debug.Trace () in that --- module. We could avoid this inconvenience by wiring in Debug.Trace.trace, --- but that doesn't seem worth the effort and maintenance cost. -pprRuntimeTrace :: String -- ^ header - -> SDoc -- ^ information to output - -> CoreExpr -- ^ expression - -> DsM CoreExpr -pprRuntimeTrace str doc expr = do - traceId <- dsLookupGlobalId traceName - unpackCStringId <- dsLookupGlobalId unpackCStringName - dflags <- getDynFlags - let message :: CoreExpr - message = App (Var unpackCStringId) $ - Lit $ mkLitString $ showSDoc dflags (hang (text str) 4 doc) - return $ mkApps (Var traceId) [Type (exprType expr), message, expr] diff --git a/compiler/deSugar/DsUsage.hs b/compiler/deSugar/DsUsage.hs deleted file mode 100644 index 8d3517410e..0000000000 --- a/compiler/deSugar/DsUsage.hs +++ /dev/null @@ -1,375 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module DsUsage ( - -- * Dependency/fingerprinting code (used by GHC.Iface.Utils) - mkUsageInfo, mkUsedNames, mkDependencies - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import DynFlags -import HscTypes -import TcRnTypes -import Name -import NameSet -import Module -import Outputable -import Util -import UniqSet -import UniqFM -import Fingerprint -import Maybes -import Packages -import Finder - -import Control.Monad (filterM) -import Data.List -import Data.IORef -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Set as Set -import System.Directory -import System.FilePath - -{- Note [Module self-dependency] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -GHC.Rename.Names.calculateAvails asserts the invariant that a module must not occur in -its own dep_orphs or dep_finsts. However, if we aren't careful this can occur -in the presence of hs-boot files: Consider that we have two modules, A and B, -both with hs-boot files, - - A.hs contains a SOURCE import of B B.hs-boot contains a SOURCE import of A - A.hs-boot declares an orphan instance A.hs defines the orphan instance - -In this case, B's dep_orphs will contain A due to its SOURCE import of A. -Consequently, A will contain itself in its imp_orphs due to its import of B. -This fact would end up being recorded in A's interface file. This would then -break the invariant asserted by calculateAvails that a module does not itself in -its dep_orphs. This was the cause of #14128. - --} - --- | Extract information from the rename and typecheck phases to produce --- a dependencies information for the module being compiled. --- --- The first argument is additional dependencies from plugins -mkDependencies :: InstalledUnitId -> [Module] -> TcGblEnv -> IO Dependencies -mkDependencies iuid pluginModules - (TcGblEnv{ tcg_mod = mod, - tcg_imports = imports, - tcg_th_used = th_var - }) - = do - -- Template Haskell used? - let (dep_plgins, ms) = unzip [ (moduleName mn, mn) | mn <- pluginModules ] - plugin_dep_pkgs = filter (/= iuid) (map (toInstalledUnitId . moduleUnitId) ms) - th_used <- readIORef th_var - let dep_mods = modDepsElts (delFromUFM (imp_dep_mods imports) - (moduleName mod)) - -- M.hi-boot can be in the imp_dep_mods, but we must remove - -- it before recording the modules on which this one depends! - -- (We want to retain M.hi-boot in imp_dep_mods so that - -- loadHiBootInterface can see if M's direct imports depend - -- on M.hi-boot, and hence that we should do the hi-boot consistency - -- check.) - - dep_orphs = filter (/= mod) (imp_orphs imports) - -- We must also remove self-references from imp_orphs. See - -- Note [Module self-dependency] - - raw_pkgs = foldr Set.insert (imp_dep_pkgs imports) plugin_dep_pkgs - - pkgs | th_used = Set.insert (toInstalledUnitId thUnitId) raw_pkgs - | otherwise = raw_pkgs - - -- Set the packages required to be Safe according to Safe Haskell. - -- See Note [Tracking Trust Transitively] in GHC.Rename.Names - sorted_pkgs = sort (Set.toList pkgs) - trust_pkgs = imp_trust_pkgs imports - dep_pkgs' = map (\x -> (x, x `Set.member` trust_pkgs)) sorted_pkgs - - return Deps { dep_mods = dep_mods, - dep_pkgs = dep_pkgs', - dep_orphs = dep_orphs, - dep_plgins = dep_plgins, - dep_finsts = sortBy stableModuleCmp (imp_finsts imports) } - -- sort to get into canonical order - -- NB. remember to use lexicographic ordering - -mkUsedNames :: TcGblEnv -> NameSet -mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus - -mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] - -> [(Module, Fingerprint)] -> [ModIface] -> IO [Usage] -mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged - pluginModules - = do - eps <- hscEPS hsc_env - hashes <- mapM getFileHash dependent_files - plugin_usages <- mapM (mkPluginUsage hsc_env) pluginModules - let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod - dir_imp_mods used_names - usages = mod_usages ++ [ UsageFile { usg_file_path = f - , usg_file_hash = hash } - | (f, hash) <- zip dependent_files hashes ] - ++ [ UsageMergedRequirement - { usg_mod = mod, - usg_mod_hash = hash - } - | (mod, hash) <- merged ] - ++ concat plugin_usages - usages `seqList` return usages - -- seq the list of Usages returned: occasionally these - -- don't get evaluated for a while and we can end up hanging on to - -- the entire collection of Ifaces. - -{- Note [Plugin dependencies] -Modules for which plugins were used in the compilation process, should be -recompiled whenever one of those plugins changes. But how do we know if a -plugin changed from the previous time a module was compiled? - -We could try storing the fingerprints of the interface files of plugins in -the interface file of the module. And see if there are changes between -compilation runs. However, this is pretty much a non-option because interface -fingerprints of plugin modules are fairly stable, unless you compile plugins -with optimisations turned on, and give basically all binders an INLINE pragma. - -So instead: - - * For plugins that were built locally: we store the filepath and hash of the - object files of the module with the `plugin` binder, and the object files of - modules that are dependencies of the plugin module and belong to the same - `UnitId` as the plugin - * For plugins in an external package: we store the filepath and hash of - the dynamic library containing the plugin module. - -During recompilation we then compare the hashes of those files again to see -if anything has changed. - -One issue with this approach is that object files are currently (GHC 8.6.1) -not created fully deterministicly, which could sometimes induce accidental -recompilation of a module for which plugins were used in the compile process. - -One way to improve this is to either: - - * Have deterministic object file creation - * Create and store implementation hashes, which would be based on the Core - of the module and the implementation hashes of its dependencies, and then - compare implementation hashes for recompilation. Creation of implementation - hashes is however potentially expensive. --} -mkPluginUsage :: HscEnv -> ModIface -> IO [Usage] -mkPluginUsage hsc_env pluginModule - = case lookupPluginModuleWithSuggestions dflags pNm Nothing of - LookupFound _ pkg -> do - -- The plugin is from an external package: - -- search for the library files containing the plugin. - let searchPaths = collectLibraryPaths dflags [pkg] - useDyn = WayDyn `elem` ways dflags - suffix = if useDyn then soExt platform else "a" - libLocs = [ searchPath "lib" ++ libLoc <.> suffix - | searchPath <- searchPaths - , libLoc <- packageHsLibs dflags pkg - ] - -- we also try to find plugin library files by adding WayDyn way, - -- if it isn't already present (see trac #15492) - paths = - if useDyn - then libLocs - else - let dflags' = updateWays (addWay' WayDyn dflags) - dlibLocs = [ searchPath mkHsSOName platform dlibLoc - | searchPath <- searchPaths - , dlibLoc <- packageHsLibs dflags' pkg - ] - in libLocs ++ dlibLocs - files <- filterM doesFileExist paths - case files of - [] -> - pprPanic - ( "mkPluginUsage: missing plugin library, tried:\n" - ++ unlines paths - ) - (ppr pNm) - _ -> mapM hashFile (nub files) - _ -> do - foundM <- findPluginModule hsc_env pNm - case foundM of - -- The plugin was built locally: look up the object file containing - -- the `plugin` binder, and all object files belong to modules that are - -- transitive dependencies of the plugin that belong to the same package. - Found ml _ -> do - pluginObject <- hashFile (ml_obj_file ml) - depObjects <- catMaybes <$> mapM lookupObjectFile deps - return (nub (pluginObject : depObjects)) - _ -> pprPanic "mkPluginUsage: no object file found" (ppr pNm) - where - dflags = hsc_dflags hsc_env - platform = targetPlatform dflags - pNm = moduleName (mi_module pluginModule) - pPkg = moduleUnitId (mi_module pluginModule) - deps = map fst (dep_mods (mi_deps pluginModule)) - - -- Lookup object file for a plugin dependency, - -- from the same package as the plugin. - lookupObjectFile nm = do - foundM <- findImportedModule hsc_env nm Nothing - case foundM of - Found ml m - | moduleUnitId m == pPkg -> Just <$> hashFile (ml_obj_file ml) - | otherwise -> return Nothing - _ -> pprPanic "mkPluginUsage: no object for dependency" - (ppr pNm <+> ppr nm) - - hashFile f = do - fExist <- doesFileExist f - if fExist - then do - h <- getFileHash f - return (UsageFile f h) - else pprPanic "mkPluginUsage: file not found" (ppr pNm <+> text f) - -mk_mod_usage_info :: PackageIfaceTable - -> HscEnv - -> Module - -> ImportedMods - -> NameSet - -> [Usage] -mk_mod_usage_info pit hsc_env this_mod direct_imports used_names - = mapMaybe mkUsage usage_mods - where - hpt = hsc_HPT hsc_env - dflags = hsc_dflags hsc_env - this_pkg = thisPackage dflags - - used_mods = moduleEnvKeys ent_map - dir_imp_mods = moduleEnvKeys direct_imports - all_mods = used_mods ++ filter (`notElem` used_mods) dir_imp_mods - usage_mods = sortBy stableModuleCmp all_mods - -- canonical order is imported, to avoid interface-file - -- wobblage. - - -- ent_map groups together all the things imported and used - -- from a particular module - ent_map :: ModuleEnv [OccName] - ent_map = nonDetFoldUniqSet add_mv emptyModuleEnv used_names - -- nonDetFoldUFM is OK here. If you follow the logic, we sort by OccName - -- in ent_hashs - where - add_mv name mv_map - | isWiredInName name = mv_map -- ignore wired-in names - | otherwise - = case nameModule_maybe name of - Nothing -> ASSERT2( isSystemName name, ppr name ) mv_map - -- See Note [Internal used_names] - - Just mod -> - -- See Note [Identity versus semantic module] - let mod' = if isHoleModule mod - then mkModule this_pkg (moduleName mod) - else mod - -- This lambda function is really just a - -- specialised (++); originally came about to - -- avoid quadratic behaviour (trac #2680) - in extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod' [occ] - where occ = nameOccName name - - -- We want to create a Usage for a home module if - -- a) we used something from it; has something in used_names - -- b) we imported it, even if we used nothing from it - -- (need to recompile if its export list changes: export_fprint) - mkUsage :: Module -> Maybe Usage - mkUsage mod - | isNothing maybe_iface -- We can't depend on it if we didn't - -- load its interface. - || mod == this_mod -- We don't care about usages of - -- things in *this* module - = Nothing - - | moduleUnitId mod /= this_pkg - = Just UsagePackageModule{ usg_mod = mod, - usg_mod_hash = mod_hash, - usg_safe = imp_safe } - -- for package modules, we record the module hash only - - | (null used_occs - && isNothing export_hash - && not is_direct_import - && not finsts_mod) - = Nothing -- Record no usage info - -- for directly-imported modules, we always want to record a usage - -- on the orphan hash. This is what triggers a recompilation if - -- an orphan is added or removed somewhere below us in the future. - - | otherwise - = Just UsageHomeModule { - usg_mod_name = moduleName mod, - usg_mod_hash = mod_hash, - usg_exports = export_hash, - usg_entities = Map.toList ent_hashs, - usg_safe = imp_safe } - where - maybe_iface = lookupIfaceByModule hpt pit mod - -- In one-shot mode, the interfaces for home-package - -- modules accumulate in the PIT not HPT. Sigh. - - Just iface = maybe_iface - finsts_mod = mi_finsts (mi_final_exts iface) - hash_env = mi_hash_fn (mi_final_exts iface) - mod_hash = mi_mod_hash (mi_final_exts iface) - export_hash | depend_on_exports = Just (mi_exp_hash (mi_final_exts iface)) - | otherwise = Nothing - - by_is_safe (ImportedByUser imv) = imv_is_safe imv - by_is_safe _ = False - (is_direct_import, imp_safe) - = case lookupModuleEnv direct_imports mod of - -- ezyang: I'm not sure if any is the correct - -- metric here. If safety was guaranteed to be uniform - -- across all imports, why did the old code only look - -- at the first import? - Just bys -> (True, any by_is_safe bys) - Nothing -> (False, safeImplicitImpsReq dflags) - -- Nothing case is for references to entities which were - -- not directly imported (NB: the "implicit" Prelude import - -- counts as directly imported! An entity is not directly - -- imported if, e.g., we got a reference to it from a - -- reexport of another module.) - - used_occs = lookupModuleEnv ent_map mod `orElse` [] - - -- Making a Map here ensures that (a) we remove duplicates - -- when we have usages on several subordinates of a single parent, - -- and (b) that the usages emerge in a canonical order, which - -- is why we use Map rather than OccEnv: Map works - -- using Ord on the OccNames, which is a lexicographic ordering. - ent_hashs :: Map OccName Fingerprint - ent_hashs = Map.fromList (map lookup_occ used_occs) - - lookup_occ occ = - case hash_env occ of - Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names) - Just r -> r - - depend_on_exports = is_direct_import - {- True - Even if we used 'import M ()', we have to register a - usage on the export list because we are sensitive to - changes in orphan instances/rules. - False - In GHC 6.8.x we always returned true, and in - fact it recorded a dependency on *all* the - modules underneath in the dependency tree. This - happens to make orphans work right, but is too - expensive: it'll read too many interface files. - The 'isNothing maybe_iface' check above saved us - from generating many of these usages (at least in - one-shot mode), but that's even more bogus! - -} diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs deleted file mode 100644 index 9d6b709dc9..0000000000 --- a/compiler/deSugar/DsUtils.hs +++ /dev/null @@ -1,1001 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Utilities for desugaring - -This module exports some utility functions of no great interest. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - --- | Utility functions for constructing Core syntax, principally for desugaring -module DsUtils ( - EquationInfo(..), - firstPat, shiftEqns, - - MatchResult(..), CanItFail(..), CaseAlt(..), - cantFailMatchResult, alwaysFailMatchResult, - extractMatchResult, combineMatchResults, - adjustMatchResult, adjustMatchResultDs, - mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, - matchCanFail, mkEvalMatchResult, - mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult, - wrapBind, wrapBinds, - - mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs, - - seqVar, - - -- LHs tuples - mkLHsPatTup, mkVanillaTuplePat, - mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId, - - mkSelectorBinds, - - selectSimpleMatchVarL, selectMatchVars, selectMatchVar, - mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang, - isTrueLHsExpr - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} Match ( matchSimply ) -import {-# SOURCE #-} DsExpr ( dsLExpr ) - -import GHC.Hs -import TcHsSyn -import TcType( tcSplitTyConApp ) -import CoreSyn -import DsMonad - -import CoreUtils -import MkCore -import MkId -import Id -import Literal -import TyCon -import DataCon -import PatSyn -import Type -import Coercion -import TysPrim -import TysWiredIn -import BasicTypes -import ConLike -import UniqSet -import UniqSupply -import Module -import PrelNames -import Name( isInternalName ) -import Outputable -import SrcLoc -import Util -import DynFlags -import FastString -import qualified GHC.LanguageExtensions as LangExt - -import TcEvidence - -import Control.Monad ( zipWithM ) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NEL - -{- -************************************************************************ -* * -\subsection{ Selecting match variables} -* * -************************************************************************ - -We're about to match against some patterns. We want to make some -@Ids@ to use as match variables. If a pattern has an @Id@ readily at -hand, which should indeed be bound to the pattern as a whole, then use it; -otherwise, make one up. --} - -selectSimpleMatchVarL :: LPat GhcTc -> DsM Id --- Postcondition: the returned Id has an Internal Name -selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) - --- (selectMatchVars ps tys) chooses variables of type tys --- to use for matching ps against. If the pattern is a variable, --- we try to use that, to save inventing lots of fresh variables. --- --- OLD, but interesting note: --- But even if it is a variable, its type might not match. Consider --- data T a where --- T1 :: Int -> T Int --- T2 :: a -> T a --- --- f :: T a -> a -> Int --- f (T1 i) (x::Int) = x --- f (T2 i) (y::a) = 0 --- Then we must not choose (x::Int) as the matching variable! --- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat - -selectMatchVars :: [Pat GhcTc] -> DsM [Id] --- Postcondition: the returned Ids have Internal Names -selectMatchVars ps = mapM selectMatchVar ps - -selectMatchVar :: Pat GhcTc -> DsM Id --- Postcondition: the returned Id has an Internal Name -selectMatchVar (BangPat _ pat) = selectMatchVar (unLoc pat) -selectMatchVar (LazyPat _ pat) = selectMatchVar (unLoc pat) -selectMatchVar (ParPat _ pat) = selectMatchVar (unLoc pat) -selectMatchVar (VarPat _ var) = return (localiseId (unLoc var)) - -- Note [Localise pattern binders] -selectMatchVar (AsPat _ var _) = return (unLoc var) -selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat) - -- OK, better make up one... - -{- Note [Localise pattern binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider module M where - [Just a] = e -After renaming it looks like - module M where - [Just M.a] = e - -We don't generalise, since it's a pattern binding, monomorphic, etc, -so after desugaring we may get something like - M.a = case e of (v:_) -> - case v of Just M.a -> M.a -Notice the "M.a" in the pattern; after all, it was in the original -pattern. However, after optimisation those pattern binders can become -let-binders, and then end up floated to top level. They have a -different *unique* by then (the simplifier is good about maintaining -proper scoping), but it's BAD to have two top-level bindings with the -External Name M.a, because that turns into two linker symbols for M.a. -It's quite rare for this to actually *happen* -- the only case I know -of is tc003 compiled with the 'hpc' way -- but that only makes it -all the more annoying. - -To avoid this, we craftily call 'localiseId' in the desugarer, which -simply turns the External Name for the Id into an Internal one, but -doesn't change the unique. So the desugarer produces this: - M.a{r8} = case e of (v:_) -> - case v of Just a{r8} -> M.a{r8} -The unique is still 'r8', but the binding site in the pattern -is now an Internal Name. Now the simplifier's usual mechanisms -will propagate that Name to all the occurrence sites, as well as -un-shadowing it, so we'll get - M.a{r8} = case e of (v:_) -> - case v of Just a{s77} -> a{s77} -In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr -runs on the output of the desugarer, so all is well by the end of -the desugaring pass. - -See also Note [MatchIds] in Match.hs - -************************************************************************ -* * -* type synonym EquationInfo and access functions for its pieces * -* * -************************************************************************ -\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym} - -The ``equation info'' used by @match@ is relatively complicated and -worthy of a type synonym and a few handy functions. --} - -firstPat :: EquationInfo -> Pat GhcTc -firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn) - -shiftEqns :: Functor f => f EquationInfo -> f EquationInfo --- Drop the first pattern in each equation -shiftEqns = fmap $ \eqn -> eqn { eqn_pats = tail (eqn_pats eqn) } - --- Functions on MatchResults - -matchCanFail :: MatchResult -> Bool -matchCanFail (MatchResult CanFail _) = True -matchCanFail (MatchResult CantFail _) = False - -alwaysFailMatchResult :: MatchResult -alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail) - -cantFailMatchResult :: CoreExpr -> MatchResult -cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr) - -extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr -extractMatchResult (MatchResult CantFail match_fn) _ - = match_fn (error "It can't fail!") - -extractMatchResult (MatchResult CanFail match_fn) fail_expr = do - (fail_bind, if_it_fails) <- mkFailurePair fail_expr - body <- match_fn if_it_fails - return (mkCoreLet fail_bind body) - - -combineMatchResults :: MatchResult -> MatchResult -> MatchResult -combineMatchResults (MatchResult CanFail body_fn1) - (MatchResult can_it_fail2 body_fn2) - = MatchResult can_it_fail2 body_fn - where - body_fn fail = do body2 <- body_fn2 fail - (fail_bind, duplicatable_expr) <- mkFailurePair body2 - body1 <- body_fn1 duplicatable_expr - return (Let fail_bind body1) - -combineMatchResults match_result1@(MatchResult CantFail _) _ - = match_result1 - -adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult -adjustMatchResult encl_fn (MatchResult can_it_fail body_fn) - = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail) - -adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult -adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn) - = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail) - -wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr -wrapBinds [] e = e -wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e) - -wrapBind :: Var -> Var -> CoreExpr -> CoreExpr -wrapBind new old body -- NB: this function must deal with term - | new==old = body -- variables, type variables or coercion variables - | otherwise = Let (NonRec new (varToCoreExpr old)) body - -seqVar :: Var -> CoreExpr -> CoreExpr -seqVar var body = mkDefaultCase (Var var) var body - -mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult -mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind) - --- (mkViewMatchResult var' viewExpr mr) makes the expression --- let var' = viewExpr in mr -mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult -mkViewMatchResult var' viewExpr = - adjustMatchResult (mkCoreLet (NonRec var' viewExpr)) - -mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult -mkEvalMatchResult var ty - = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)]) - -mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult -mkGuardedMatchResult pred_expr (MatchResult _ body_fn) - = MatchResult CanFail (\fail -> do body <- body_fn fail - return (mkIfThenElse pred_expr body fail)) - -mkCoPrimCaseMatchResult :: Id -- Scrutinee - -> Type -- Type of the case - -> [(Literal, MatchResult)] -- Alternatives - -> MatchResult -- Literals are all unlifted -mkCoPrimCaseMatchResult var ty match_alts - = MatchResult CanFail mk_case - where - mk_case fail = do - alts <- mapM (mk_alt fail) sorted_alts - return (Case (Var var) var ty ((DEFAULT, [], fail) : alts)) - - sorted_alts = sortWith fst match_alts -- Right order for a Case - mk_alt fail (lit, MatchResult _ body_fn) - = ASSERT( not (litIsLifted lit) ) - do body <- body_fn fail - return (LitAlt lit, [], body) - -data CaseAlt a = MkCaseAlt{ alt_pat :: a, - alt_bndrs :: [Var], - alt_wrapper :: HsWrapper, - alt_result :: MatchResult } - -mkCoAlgCaseMatchResult - :: Id -- ^ Scrutinee - -> Type -- ^ Type of exp - -> NonEmpty (CaseAlt DataCon) -- ^ Alternatives (bndrs *include* tyvars, dicts) - -> MatchResult -mkCoAlgCaseMatchResult var ty match_alts - | isNewtype -- Newtype case; use a let - = ASSERT( null match_alts_tail && null (tail arg_ids1) ) - mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1 - - | otherwise - = mkDataConCase var ty match_alts - where - isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1)) - - -- [Interesting: because of GADTs, we can't rely on the type of - -- the scrutinised Id to be sufficiently refined to have a TyCon in it] - - alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } :| match_alts_tail - = match_alts - -- Stuff for newtype - arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1 - var_ty = idType var - (tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes - -- (not that splitTyConApp does, these days) - newtype_rhs = unwrapNewTypeBody tc ty_args (Var var) - -mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult -mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt - -mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr -mkPatSynCase var ty alt fail = do - matcher <- dsLExpr $ mkLHsWrap wrapper $ - nlHsTyApp matcher [getRuntimeRep ty, ty] - let MatchResult _ mkCont = match_result - cont <- mkCoreLams bndrs <$> mkCont fail - return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail] - where - MkCaseAlt{ alt_pat = psyn, - alt_bndrs = bndrs, - alt_wrapper = wrapper, - alt_result = match_result} = alt - (matcher, needs_void_lam) = patSynMatcher psyn - - -- See Note [Matchers and builders for pattern synonyms] in PatSyns - -- on these extra Void# arguments - ensure_unstrict cont | needs_void_lam = Lam voidArgId cont - | otherwise = cont - -mkDataConCase :: Id -> Type -> NonEmpty (CaseAlt DataCon) -> MatchResult -mkDataConCase var ty alts@(alt1 :| _) = MatchResult fail_flag mk_case - where - con1 = alt_pat alt1 - tycon = dataConTyCon con1 - data_cons = tyConDataCons tycon - match_results = fmap alt_result alts - - sorted_alts :: NonEmpty (CaseAlt DataCon) - sorted_alts = NEL.sortWith (dataConTag . alt_pat) alts - - var_ty = idType var - (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes - -- (not that splitTyConApp does, these days) - - mk_case :: CoreExpr -> DsM CoreExpr - mk_case fail = do - alts <- mapM (mk_alt fail) sorted_alts - return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ NEL.toList alts) - - mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt - mk_alt fail MkCaseAlt{ alt_pat = con, - alt_bndrs = args, - alt_result = MatchResult _ body_fn } - = do { body <- body_fn fail - ; case dataConBoxer con of { - Nothing -> return (DataAlt con, args, body) ; - Just (DCB boxer) -> - do { us <- newUniqueSupply - ; let (rep_ids, binds) = initUs_ us (boxer ty_args args) - ; return (DataAlt con, rep_ids, mkLets binds body) } } } - - mk_default :: CoreExpr -> [CoreAlt] - mk_default fail | exhaustive_case = [] - | otherwise = [(DEFAULT, [], fail)] - - fail_flag :: CanItFail - fail_flag | exhaustive_case - = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- NEL.toList match_results] - | otherwise - = CanFail - - mentioned_constructors = mkUniqSet $ map alt_pat $ NEL.toList alts - un_mentioned_constructors - = mkUniqSet data_cons `minusUniqSet` mentioned_constructors - exhaustive_case = isEmptyUniqSet un_mentioned_constructors - -{- -************************************************************************ -* * -\subsection{Desugarer's versions of some Core functions} -* * -************************************************************************ --} - -mkErrorAppDs :: Id -- The error function - -> Type -- Type to which it should be applied - -> SDoc -- The error message string to pass - -> DsM CoreExpr - -mkErrorAppDs err_id ty msg = do - src_loc <- getSrcSpanDs - dflags <- getDynFlags - let - full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg]) - core_msg = Lit (mkLitString full_msg) - -- mkLitString returns a result of type String# - return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg]) - -{- -'mkCoreAppDs' and 'mkCoreAppsDs' handle the special-case desugaring of 'seq'. - -Note [Desugaring seq] -~~~~~~~~~~~~~~~~~~~~~ - -There are a few subtleties in the desugaring of `seq`: - - 1. (as described in #1031) - - Consider, - f x y = x `seq` (y `seq` (# x,y #)) - - The [CoreSyn let/app invariant] means that, other things being equal, because - the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus: - - f x y = case (y `seq` (# x,y #)) of v -> x `seq` v - - But that is bad for two reasons: - (a) we now evaluate y before x, and - (b) we can't bind v to an unboxed pair - - Seq is very, very special! So we recognise it right here, and desugar to - case x of _ -> case y of _ -> (# x,y #) - - 2. (as described in #2273) - - Consider - let chp = case b of { True -> fst x; False -> 0 } - in chp `seq` ...chp... - Here the seq is designed to plug the space leak of retaining (snd x) - for too long. - - If we rely on the ordinary inlining of seq, we'll get - let chp = case b of { True -> fst x; False -> 0 } - case chp of _ { I# -> ...chp... } - - But since chp is cheap, and the case is an alluring contet, we'll - inline chp into the case scrutinee. Now there is only one use of chp, - so we'll inline a second copy. Alas, we've now ruined the purpose of - the seq, by re-introducing the space leak: - case (case b of {True -> fst x; False -> 0}) of - I# _ -> ...case b of {True -> fst x; False -> 0}... - - We can try to avoid doing this by ensuring that the binder-swap in the - case happens, so we get his at an early stage: - case chp of chp2 { I# -> ...chp2... } - But this is fragile. The real culprit is the source program. Perhaps we - should have said explicitly - let !chp2 = chp in ...chp2... - - But that's painful. So the code here does a little hack to make seq - more robust: a saturated application of 'seq' is turned *directly* into - the case expression, thus: - x `seq` e2 ==> case x of x -> e2 -- Note shadowing! - e1 `seq` e2 ==> case x of _ -> e2 - - So we desugar our example to: - let chp = case b of { True -> fst x; False -> 0 } - case chp of chp { I# -> ...chp... } - And now all is well. - - The reason it's a hack is because if you define mySeq=seq, the hack - won't work on mySeq. - - 3. (as described in #2409) - - The isLocalId ensures that we don't turn - True `seq` e - into - case True of True { ... } - which stupidly tries to bind the datacon 'True'. --} - --- NB: Make sure the argument is not levity polymorphic -mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr -mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2 - | f `hasKey` seqIdKey -- Note [Desugaring seq], points (1) and (2) - = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)] - where - case_bndr = case arg1 of - Var v1 | isInternalName (idName v1) - -> v1 -- Note [Desugaring seq], points (2) and (3) - _ -> mkWildValBinder ty1 - -mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in MkCore - --- NB: No argument can be levity polymorphic -mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr -mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args - -mkCastDs :: CoreExpr -> Coercion -> CoreExpr --- We define a desugarer-specific version of CoreUtils.mkCast, --- because in the immediate output of the desugarer, we can have --- apparently-mis-matched coercions: E.g. --- let a = b --- in (x :: a) |> (co :: b ~ Int) --- Lint know about type-bindings for let and does not complain --- So here we do not make the assertion checks that we make in --- CoreUtils.mkCast; and we do less peephole optimisation too -mkCastDs e co | isReflCo co = e - | otherwise = Cast e co - -{- -************************************************************************ -* * - Tuples and selector bindings -* * -************************************************************************ - -This is used in various places to do with lazy patterns. -For each binder $b$ in the pattern, we create a binding: -\begin{verbatim} - b = case v of pat' -> b' -\end{verbatim} -where @pat'@ is @pat@ with each binder @b@ cloned into @b'@. - -ToDo: making these bindings should really depend on whether there's -much work to be done per binding. If the pattern is complex, it -should be de-mangled once, into a tuple (and then selected from). -Otherwise the demangling can be in-line in the bindings (as here). - -Boring! Boring! One error message per binder. The above ToDo is -even more helpful. Something very similar happens for pattern-bound -expressions. - -Note [mkSelectorBinds] -~~~~~~~~~~~~~~~~~~~~~~ -mkSelectorBinds is used to desugar a pattern binding {p = e}, -in a binding group: - let { ...; p = e; ... } in body -where p binds x,y (this list of binders can be empty). -There are two cases. - ------- Special case (A) ------- - For a pattern that is just a variable, - let !x = e in body - ==> - let x = e in x `seq` body - So we return the binding, with 'x' as the variable to seq. - ------- Special case (B) ------- - For a pattern that is essentially just a tuple: - * A product type, so cannot fail - * Only one level, so that - - generating multiple matches is fine - - seq'ing it evaluates the same as matching it - Then instead we generate - { v = e - ; x = case v of p -> x - ; y = case v of p -> y } - with 'v' as the variable to force - ------- General case (C) ------- - In the general case we generate these bindings: - let { ...; p = e; ... } in body - ==> - let { t = case e of p -> (x,y) - ; x = case t of (x,y) -> x - ; y = case t of (x,y) -> y } - in t `seq` body - - Note that we return 't' as the variable to force if the pattern - is strict (i.e. with -XStrict or an outermost-bang-pattern) - - Note that (A) /includes/ the situation where - - * The pattern binds exactly one variable - let !(Just (Just x) = e in body - ==> - let { t = case e of Just (Just v) -> Unit v - ; v = case t of Unit v -> v } - in t `seq` body - The 'Unit' is a one-tuple; see Note [One-tuples] in TysWiredIn - Note that forcing 't' makes the pattern match happen, - but does not force 'v'. - - * The pattern binds no variables - let !(True,False) = e in body - ==> - let t = case e of (True,False) -> () - in t `seq` body - - ------- Examples ---------- - * !(_, (_, a)) = e - ==> - t = case e of (_, (_, a)) -> Unit a - a = case t of Unit a -> a - - Note that - - Forcing 't' will force the pattern to match fully; - e.g. will diverge if (snd e) is bottom - - But 'a' itself is not forced; it is wrapped in a one-tuple - (see Note [One-tuples] in TysWiredIn) - - * !(Just x) = e - ==> - t = case e of Just x -> Unit x - x = case t of Unit x -> x - - Again, forcing 't' will fail if 'e' yields Nothing. - -Note that even though this is rather general, the special cases -work out well: - -* One binder, not -XStrict: - - let Just (Just v) = e in body - ==> - let t = case e of Just (Just v) -> Unit v - v = case t of Unit v -> v - in body - ==> - let v = case (case e of Just (Just v) -> Unit v) of - Unit v -> v - in body - ==> - let v = case e of Just (Just v) -> v - in body - -* Non-recursive, -XStrict - let p = e in body - ==> - let { t = case e of p -> (x,y) - ; x = case t of (x,y) -> x - ; y = case t of (x,y) -> x } - in t `seq` body - ==> {inline seq, float x,y bindings inwards} - let t = case e of p -> (x,y) in - case t of t' -> - let { x = case t' of (x,y) -> x - ; y = case t' of (x,y) -> x } in - body - ==> {inline t, do case of case} - case e of p -> - let t = (x,y) in - let { x = case t' of (x,y) -> x - ; y = case t' of (x,y) -> x } in - body - ==> {case-cancellation, drop dead code} - case e of p -> body - -* Special case (B) is there to avoid fruitlessly taking the tuple - apart and rebuilding it. For example, consider - { K x y = e } - where K is a product constructor. Then general case (A) does: - { t = case e of K x y -> (x,y) - ; x = case t of (x,y) -> x - ; y = case t of (x,y) -> y } - In the lazy case we can't optimise out this fruitless taking apart - and rebuilding. Instead (B) builds - { v = e - ; x = case v of K x y -> x - ; y = case v of K x y -> y } - which is better. --} - -mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly - -> LPat GhcTc -- ^ The pattern - -> CoreExpr -- ^ Expression to which the pattern is bound - -> DsM (Id,[(Id,CoreExpr)]) - -- ^ Id the rhs is bound to, for desugaring strict - -- binds (see Note [Desugar Strict binds] in DsBinds) - -- and all the desugared binds - -mkSelectorBinds ticks pat val_expr - | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A) - = return (v, [(v, val_expr)]) - - | is_flat_prod_lpat pat' -- Special case (B) - = do { let pat_ty = hsLPatType pat' - ; val_var <- newSysLocalDsNoLP pat_ty - - ; let mk_bind tick bndr_var - -- (mk_bind sv bv) generates bv = case sv of { pat -> bv } - -- Remember, 'pat' binds 'bv' - = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat' - (Var bndr_var) - (Var bndr_var) -- Neat hack - -- Neat hack: since 'pat' can't fail, the - -- "fail-expr" passed to matchSimply is not - -- used. But it /is/ used for its type, and for - -- that bndr_var is just the ticket. - ; return (bndr_var, mkOptTickBox tick rhs_expr) } - - ; binds <- zipWithM mk_bind ticks' binders - ; return ( val_var, (val_var, val_expr) : binds) } - - | otherwise -- General case (C) - = do { tuple_var <- newSysLocalDs tuple_ty - ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat') - ; tuple_expr <- matchSimply val_expr PatBindRhs pat - local_tuple error_expr - ; let mk_tup_bind tick binder - = (binder, mkOptTickBox tick $ - mkTupleSelector1 local_binders binder - tuple_var (Var tuple_var)) - tup_binds = zipWith mk_tup_bind ticks' binders - ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) } - where - pat' = strip_bangs pat - -- Strip the bangs before looking for case (A) or (B) - -- The incoming pattern may well have a bang on it - - binders = collectPatBinders pat' - ticks' = ticks ++ repeat [] - - local_binders = map localiseId binders -- See Note [Localise pattern binders] - local_tuple = mkBigCoreVarTup1 binders - tuple_ty = exprType local_tuple - -strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p) --- Remove outermost bangs and parens -strip_bangs (L _ (ParPat _ p)) = strip_bangs p -strip_bangs (L _ (BangPat _ p)) = strip_bangs p -strip_bangs lp = lp - -is_flat_prod_lpat :: LPat (GhcPass p) -> Bool -is_flat_prod_lpat = is_flat_prod_pat . unLoc - -is_flat_prod_pat :: Pat (GhcPass p) -> Bool -is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p -is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps -is_flat_prod_pat (ConPatOut { pat_con = L _ pcon - , pat_args = ps}) - | RealDataCon con <- pcon - , isProductTyCon (dataConTyCon con) - = all is_triv_lpat (hsConPatArgs ps) -is_flat_prod_pat _ = False - -is_triv_lpat :: LPat (GhcPass p) -> Bool -is_triv_lpat = is_triv_pat . unLoc - -is_triv_pat :: Pat (GhcPass p) -> Bool -is_triv_pat (VarPat {}) = True -is_triv_pat (WildPat{}) = True -is_triv_pat (ParPat _ p) = is_triv_lpat p -is_triv_pat _ = False - - -{- ********************************************************************* -* * - Creating big tuples and their types for full Haskell expressions. - They work over *Ids*, and create tuples replete with their types, - which is whey they are not in GHC.Hs.Utils. -* * -********************************************************************* -} - -mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc -mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed -mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = L (getLoc (head lpats)) $ - mkVanillaTuplePat lpats Boxed - -mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc --- A vanilla tuple pattern simply gets its type from its sub-patterns -mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box - --- The Big equivalents for the source tuple expressions -mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc -mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids) - -mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc -mkBigLHsTupId = mkChunkified mkLHsTupleExpr - --- The Big equivalents for the source tuple patterns -mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc -mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs) - -mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc -mkBigLHsPatTupId = mkChunkified mkLHsPatTup - -{- -************************************************************************ -* * - Code for pattern-matching and other failures -* * -************************************************************************ - -Generally, we handle pattern matching failure like this: let-bind a -fail-variable, and use that variable if the thing fails: -\begin{verbatim} - let fail.33 = error "Help" - in - case x of - p1 -> ... - p2 -> fail.33 - p3 -> fail.33 - p4 -> ... -\end{verbatim} -Then -\begin{itemize} -\item -If the case can't fail, then there'll be no mention of @fail.33@, and the -simplifier will later discard it. - -\item -If it can fail in only one way, then the simplifier will inline it. - -\item -Only if it is used more than once will the let-binding remain. -\end{itemize} - -There's a problem when the result of the case expression is of -unboxed type. Then the type of @fail.33@ is unboxed too, and -there is every chance that someone will change the let into a case: -\begin{verbatim} - case error "Help" of - fail.33 -> case .... -\end{verbatim} - -which is of course utterly wrong. Rather than drop the condition that -only boxed types can be let-bound, we just turn the fail into a function -for the primitive case: -\begin{verbatim} - let fail.33 :: Void -> Int# - fail.33 = \_ -> error "Help" - in - case x of - p1 -> ... - p2 -> fail.33 void - p3 -> fail.33 void - p4 -> ... -\end{verbatim} - -Now @fail.33@ is a function, so it can be let-bound. - -We would *like* to use join points here; in fact, these "fail variables" are -paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as -CPS functions - i.e. they take "join points" as parameters. It's not impossible -to imagine extending our type system to allow passing join points around (very -carefully), but we certainly don't support it now. - -99.99% of the time, the fail variables wind up as join points in short order -anyway, and the Void# doesn't do much harm. --} - -mkFailurePair :: CoreExpr -- Result type of the whole case expression - -> DsM (CoreBind, -- Binds the newly-created fail variable - -- to \ _ -> expression - CoreExpr) -- Fail variable applied to realWorld# --- See Note [Failure thunks and CPR] -mkFailurePair expr - = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkVisFunTy` ty) - ; fail_fun_arg <- newSysLocalDs voidPrimTy - ; let real_arg = setOneShotLambda fail_fun_arg - ; return (NonRec fail_fun_var (Lam real_arg expr), - App (Var fail_fun_var) (Var voidPrimId)) } - where - ty = exprType expr - -{- -Note [Failure thunks and CPR] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(This note predates join points as formal entities (hence the quotation marks). -We can't use actual join points here (see above); if we did, this would also -solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR -join points] in WorkWrap.) - -When we make a failure point we ensure that it -does not look like a thunk. Example: - - let fail = \rw -> error "urk" - in case x of - [] -> fail realWorld# - (y:ys) -> case ys of - [] -> fail realWorld# - (z:zs) -> (y,z) - -Reason: we know that a failure point is always a "join point" and is -entered at most once. Adding a dummy 'realWorld' token argument makes -it clear that sharing is not an issue. And that in turn makes it more -CPR-friendly. This matters a lot: if you don't get it right, you lose -the tail call property. For example, see #3403. - - -************************************************************************ -* * - Ticks -* * -********************************************************************* -} - -mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr -mkOptTickBox = flip (foldr Tick) - -mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr -mkBinaryTickBox ixT ixF e = do - uq <- newUnique - this_mod <- getModule - let bndr1 = mkSysLocal (fsLit "t1") uq boolTy - let - falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId) - trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId) - -- - return $ Case e bndr1 boolTy - [ (DataAlt falseDataCon, [], falseBox) - , (DataAlt trueDataCon, [], trueBox) - ] - - - --- ******************************************************************* - -{- Note [decideBangHood] -~~~~~~~~~~~~~~~~~~~~~~~~ -With -XStrict we may make /outermost/ patterns more strict. -E.g. - let (Just x) = e in ... - ==> - let !(Just x) = e in ... -and - f x = e - ==> - f !x = e - -This adjustment is done by decideBangHood, - - * Just before constructing an EqnInfo, in Match - (matchWrapper and matchSinglePat) - - * When desugaring a pattern-binding in DsBinds.dsHsBind - -Note that it is /not/ done recursively. See the -XStrict -spec in the user manual. - -Specifically: - ~pat => pat -- when -XStrict (even if pat = ~pat') - !pat => !pat -- always - pat => !pat -- when -XStrict - pat => pat -- otherwise --} - - --- | Use -XStrict to add a ! or remove a ~ --- See Note [decideBangHood] -decideBangHood :: DynFlags - -> LPat GhcTc -- ^ Original pattern - -> LPat GhcTc -- Pattern with bang if necessary -decideBangHood dflags lpat - | not (xopt LangExt.Strict dflags) - = lpat - | otherwise -- -XStrict - = go lpat - where - go lp@(L l p) - = case p of - ParPat x p -> L l (ParPat x (go p)) - LazyPat _ lp' -> lp' - BangPat _ _ -> lp - _ -> L l (BangPat noExtField lp) - --- | Unconditionally make a 'Pat' strict. -addBang :: LPat GhcTc -- ^ Original pattern - -> LPat GhcTc -- ^ Banged pattern -addBang = go - where - go lp@(L l p) - = case p of - ParPat x p -> L l (ParPat x (go p)) - LazyPat _ lp' -> L l (BangPat noExtField lp') - -- Should we bring the extension value over? - BangPat _ _ -> lp - _ -> L l (BangPat noExtField lp) - -isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) - --- Returns Just {..} if we're sure that the expression is True --- I.e. * 'True' datacon --- * 'otherwise' Id --- * Trivial wappings of these --- The arguments to Just are any HsTicks that we have found, --- because we still want to tick then, even it they are always evaluated. -isTrueLHsExpr (L _ (HsVar _ (L _ v))) - | v `hasKey` otherwiseIdKey - || v `hasKey` getUnique trueDataConId - = Just return - -- trueDataConId doesn't have the same unique as trueDataCon -isTrueLHsExpr (L _ (HsConLikeOut _ con)) - | con `hasKey` getUnique trueDataCon = Just return -isTrueLHsExpr (L _ (HsTick _ tickish e)) - | Just ticks <- isTrueLHsExpr e - = Just (\x -> do wrapped <- ticks x - return (Tick tickish wrapped)) - -- This encodes that the result is constant True for Hpc tick purposes; - -- which is specifically what isTrueLHsExpr is trying to find out. -isTrueLHsExpr (L _ (HsBinTick _ ixT _ e)) - | Just ticks <- isTrueLHsExpr e - = Just (\x -> do e <- ticks x - this_mod <- getModule - return (Tick (HpcTick this_mod ixT) e)) - -isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e -isTrueLHsExpr _ = Nothing diff --git a/compiler/deSugar/ExtractDocs.hs b/compiler/deSugar/ExtractDocs.hs deleted file mode 100644 index 632207c41f..0000000000 --- a/compiler/deSugar/ExtractDocs.hs +++ /dev/null @@ -1,360 +0,0 @@ --- | Extract docs from the renamer output so they can be be serialized. -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module ExtractDocs (extractDocs) where - -import GhcPrelude -import Bag -import GHC.Hs.Binds -import GHC.Hs.Doc -import GHC.Hs.Decls -import GHC.Hs.Extension -import GHC.Hs.Types -import GHC.Hs.Utils -import Name -import NameSet -import SrcLoc -import TcRnTypes - -import Control.Applicative -import Data.Bifunctor (first) -import Data.List -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe -import Data.Semigroup - --- | Extract docs from renamer output. -extractDocs :: TcGblEnv - -> (Maybe HsDocString, DeclDocMap, ArgDocMap) - -- ^ - -- 1. Module header - -- 2. Docs on top level declarations - -- 3. Docs on arguments -extractDocs TcGblEnv { tcg_semantic_mod = mod - , tcg_rn_decls = mb_rn_decls - , tcg_insts = insts - , tcg_fam_insts = fam_insts - , tcg_doc_hdr = mb_doc_hdr - } = - (unLoc <$> mb_doc_hdr, DeclDocMap doc_map, ArgDocMap arg_map) - where - (doc_map, arg_map) = maybe (M.empty, M.empty) - (mkMaps local_insts) - mb_decls_with_docs - mb_decls_with_docs = topDecls <$> mb_rn_decls - local_insts = filter (nameIsLocalOrFrom mod) - $ map getName insts ++ map getName fam_insts - --- | Create decl and arg doc-maps by looping through the declarations. --- For each declaration, find its names, its subordinates, and its doc strings. -mkMaps :: [Name] - -> [(LHsDecl GhcRn, [HsDocString])] - -> (Map Name (HsDocString), Map Name (Map Int (HsDocString))) -mkMaps instances decls = - ( f' (map (nubByName fst) decls') - , f (filterMapping (not . M.null) args) - ) - where - (decls', args) = unzip (map mappings decls) - - f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b - f = M.fromListWith (<>) . concat - - f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString - f' = M.fromListWith appendDocs . concat - - filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]] - filterMapping p = map (filter (p . snd)) - - mappings :: (LHsDecl GhcRn, [HsDocString]) - -> ( [(Name, HsDocString)] - , [(Name, Map Int (HsDocString))] - ) - mappings (L l decl, docStrs) = - (dm, am) - where - doc = concatDocs docStrs - args = declTypeDocs decl - - subs :: [(Name, [(HsDocString)], Map Int (HsDocString))] - subs = subordinates instanceMap decl - - (subDocs, subArgs) = - unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs) - - ns = names l decl - subNs = [ n | (n, _, _) <- subs ] - dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs] - am = [(n, args) | n <- ns] ++ zip subNs subArgs - - instanceMap :: Map SrcSpan Name - instanceMap = M.fromList [(getSrcSpan n, n) | n <- instances] - - names :: SrcSpan -> HsDecl GhcRn -> [Name] - names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See - -- Note [1]. - where loc = case d of - TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only - -- for TFs - _ -> getInstLoc d - names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1]. - names _ decl = getMainDeclBinder decl - -{- -Note [1]: ---------- -We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried -inside them. That should work for normal user-written instances (from -looking at GHC sources). We can assume that commented instances are -user-written. This lets us relate Names (from ClsInsts) to comments -(associated with InstDecls and DerivDecls). --} - -getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)] -getMainDeclBinder (TyClD _ d) = [tcdName d] -getMainDeclBinder (ValD _ d) = - case collectHsBindBinders d of - [] -> [] - (name:_) -> [name] -getMainDeclBinder (SigD _ d) = sigNameNoLoc d -getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name] -getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = [] -getMainDeclBinder _ = [] - -sigNameNoLoc :: Sig pass -> [IdP pass] -sigNameNoLoc (TypeSig _ ns _) = map unLoc ns -sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns -sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns -sigNameNoLoc (SpecSig _ n _ _) = [unLoc n] -sigNameNoLoc (InlineSig _ n _) = [unLoc n] -sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns -sigNameNoLoc _ = [] - --- Extract the source location where an instance is defined. This is used --- to correlate InstDecls with their Instance/CoAxiom Names, via the --- instanceMap. -getInstLoc :: InstDecl (GhcPass p) -> SrcSpan -getInstLoc = \case - ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty) - DataFamInstD _ (DataFamInstDecl - { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l - TyFamInstD _ (TyFamInstDecl - -- Since CoAxioms' Names refer to the whole line for type family instances - -- in particular, we need to dig a bit deeper to pull out the entire - -- equation. This does not happen for data family instances, for some - -- reason. - { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}}) -> l - ClsInstD _ (XClsInstDecl _) -> error "getInstLoc" - DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" - TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" - XInstDecl _ -> error "getInstLoc" - DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc" - TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc" - --- | Get all subordinate declarations inside a declaration, and their docs. --- A subordinate declaration is something like the associate type or data --- family of a type class. -subordinates :: Map SrcSpan Name - -> HsDecl GhcRn - -> [(Name, [(HsDocString)], Map Int (HsDocString))] -subordinates instMap decl = case decl of - InstD _ (ClsInstD _ d) -> do - DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_tycon = L l _ - , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d - [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn - - InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d }))) - -> dataSubs (feqn_rhs d) - TyClD _ d | isClassDecl d -> classSubs d - | isDataDecl d -> dataSubs (tcdDataDefn d) - _ -> [] - where - classSubs dd = [ (name, doc, declTypeDocs d) - | (L _ d, doc) <- classDecls dd - , name <- getMainDeclBinder d, not (isValD d) - ] - dataSubs :: HsDataDefn GhcRn - -> [(Name, [HsDocString], Map Int (HsDocString))] - dataSubs dd = constrs ++ fields ++ derivs - where - cons = map unLoc $ (dd_cons dd) - constrs = [ ( unLoc cname - , maybeToList $ fmap unLoc $ con_doc c - , conArgDocs c) - | c <- cons, cname <- getConNames c ] - fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty) - | RecCon flds <- map getConArgs cons - , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds) - , (L _ n) <- ns ] - derivs = [ (instName, [unLoc doc], M.empty) - | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $ - concatMap (unLoc . deriv_clause_tys . unLoc) $ - unLoc $ dd_derivs dd - , Just instName <- [M.lookup l instMap] ] - - extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString) - extract_deriv_ty (L l ty) = - case ty of - -- deriving (forall a. C a {- ^ Doc comment -}) - HsForAllTy{ hst_fvf = ForallInvis - , hst_body = L _ (HsDocTy _ _ doc) } - -> Just (l, doc) - -- deriving (C a {- ^ Doc comment -}) - HsDocTy _ _ doc -> Just (l, doc) - _ -> Nothing - --- | Extract constructor argument docs from inside constructor decls. -conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString) -conArgDocs con = case getConArgs con of - PrefixCon args -> go 0 (map unLoc args ++ ret) - InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret) - RecCon _ -> go 1 ret - where - go n = M.fromList . catMaybes . zipWith f [n..] - where - f n (HsDocTy _ _ lds) = Just (n, unLoc lds) - f _ _ = Nothing - - ret = case con of - ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ] - _ -> [] - -isValD :: HsDecl a -> Bool -isValD (ValD _ _) = True -isValD _ = False - --- | All the sub declarations of a class (that we handle), ordered by --- source location, with documentation attached if it exists. -classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] -classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls - where - decls = docs ++ defs ++ sigs ++ ats - docs = mkDecls tcdDocs (DocD noExtField) class_ - defs = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_ - sigs = mkDecls tcdSigs (SigD noExtField) class_ - ats = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_ - --- | Extract function argument docs from inside top-level decls. -declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString) -declTypeDocs = \case - SigD _ (TypeSig _ _ ty) -> typeDocs (unLoc (hsSigWcType ty)) - SigD _ (ClassOpSig _ _ _ ty) -> typeDocs (unLoc (hsSigType ty)) - SigD _ (PatSynSig _ _ ty) -> typeDocs (unLoc (hsSigType ty)) - ForD _ (ForeignImport _ _ ty _) -> typeDocs (unLoc (hsSigType ty)) - TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty) - _ -> M.empty - -nubByName :: (a -> Name) -> [a] -> [a] -nubByName f ns = go emptyNameSet ns - where - go _ [] = [] - go s (x:xs) - | y `elemNameSet` s = go s xs - | otherwise = let s' = extendNameSet s y - in x : go s' xs - where - y = f x - --- | Extract function argument docs from inside types. -typeDocs :: HsType GhcRn -> Map Int (HsDocString) -typeDocs = go 0 - where - go n = \case - HsForAllTy { hst_body = ty } -> go n (unLoc ty) - HsQualTy { hst_body = ty } -> go n (unLoc ty) - HsFunTy _ (unLoc->HsDocTy _ _ x) ty -> M.insert n (unLoc x) $ go (n+1) (unLoc ty) - HsFunTy _ _ ty -> go (n+1) (unLoc ty) - HsDocTy _ _ doc -> M.singleton n (unLoc doc) - _ -> M.empty - --- | The top-level declarations of a module that we care about, --- ordered by source location, with documentation attached if it exists. -topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])] -topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup - --- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. -ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] -ungroup group_ = - mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField) group_ ++ - mkDecls hs_derivds (DerivD noExtField) group_ ++ - mkDecls hs_defds (DefD noExtField) group_ ++ - mkDecls hs_fords (ForD noExtField) group_ ++ - mkDecls hs_docs (DocD noExtField) group_ ++ - mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField) group_ ++ - mkDecls (typesigs . hs_valds) (SigD noExtField) group_ ++ - mkDecls (valbinds . hs_valds) (ValD noExtField) group_ - where - typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig - typesigs ValBinds{} = error "expected XValBindsLR" - - valbinds (XValBindsLR (NValBinds binds _)) = - concatMap bagToList . snd . unzip $ binds - valbinds ValBinds{} = error "expected XValBindsLR" - --- | Sort by source location -sortByLoc :: [Located a] -> [Located a] -sortByLoc = sortOn getLoc - --- | Collect docs and attach them to the right declarations. --- --- A declaration may have multiple doc strings attached to it. -collectDocs :: [LHsDecl pass] -> [(LHsDecl pass, [HsDocString])] --- ^ This is an example. -collectDocs = go [] Nothing - where - go docs mprev decls = case (decls, mprev) of - ((unLoc->DocD _ (DocCommentNext s)) : ds, Nothing) -> go (s:docs) Nothing ds - ((unLoc->DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds - ((unLoc->DocD _ (DocCommentPrev s)) : ds, mprev) -> go (s:docs) mprev ds - (d : ds, Nothing) -> go docs (Just d) ds - (d : ds, Just prev) -> finished prev docs $ go [] (Just d) ds - ([] , Nothing) -> [] - ([] , Just prev) -> finished prev docs [] - - finished decl docs rest = (decl, reverse docs) : rest - --- | Filter out declarations that we don't handle in Haddock -filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] -filterDecls = filter (isHandled . unLoc . fst) - where - isHandled (ForD _ (ForeignImport {})) = True - isHandled (TyClD {}) = True - isHandled (InstD {}) = True - isHandled (DerivD {}) = True - isHandled (SigD _ d) = isUserSig d - isHandled (ValD {}) = True - -- we keep doc declarations to be able to get at named docs - isHandled (DocD {}) = True - isHandled _ = False - - --- | Go through all class declarations and filter their sub-declarations -filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] -filterClasses = map (first (mapLoc filterClass)) - where - filterClass (TyClD x c@(ClassDecl {})) = - TyClD x $ c { tcdSigs = - filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) } - filterClass d = d - --- | Was this signature given by the user? -isUserSig :: Sig name -> Bool -isUserSig TypeSig {} = True -isUserSig ClassOpSig {} = True -isUserSig PatSynSig {} = True -isUserSig _ = False - --- | Take a field of declarations from a data structure and create HsDecls --- using the given constructor -mkDecls :: (struct -> [Located decl]) - -> (decl -> hsDecl) - -> struct - -> [Located hsDecl] -mkDecls field con = map (mapLoc con) . field diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs deleted file mode 100644 index d6ddfb894a..0000000000 --- a/compiler/deSugar/Match.hs +++ /dev/null @@ -1,1148 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -The @match@ function --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module Match ( match, matchEquations, matchWrapper, matchSimply - , matchSinglePat, matchSinglePatVar ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-#SOURCE#-} DsExpr (dsLExpr, dsSyntaxExpr) - -import BasicTypes ( Origin(..) ) -import DynFlags -import GHC.Hs -import TcHsSyn -import TcEvidence -import TcRnMonad -import GHC.HsToCore.PmCheck -import CoreSyn -import Literal -import CoreUtils -import MkCore -import DsMonad -import DsBinds -import DsGRHSs -import DsUtils -import Id -import ConLike -import DataCon -import PatSyn -import MatchCon -import MatchLit -import Type -import Coercion ( eqCoercion ) -import TyCon( isNewTyCon ) -import TysWiredIn -import SrcLoc -import Maybes -import Util -import Name -import Outputable -import BasicTypes ( isGenerated, il_value, fl_value ) -import FastString -import Unique -import UniqDFM - -import Control.Monad( when, unless ) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NEL -import qualified Data.Map as Map - -{- -************************************************************************ -* * - The main matching function -* * -************************************************************************ - -The function @match@ is basically the same as in the Wadler chapter -from "The Implementation of Functional Programming Languages", -except it is monadised, to carry around the name supply, info about -annotations, etc. - -Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns: -\begin{enumerate} -\item -A list of $n$ variable names, those variables presumably bound to the -$n$ expressions being matched against the $n$ patterns. Using the -list of $n$ expressions as the first argument showed no benefit and -some inelegance. - -\item -The second argument, a list giving the ``equation info'' for each of -the $m$ equations: -\begin{itemize} -\item -the $n$ patterns for that equation, and -\item -a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on -the front'' of the matching code, as in: -\begin{verbatim} -let -in -\end{verbatim} -\item -and finally: (ToDo: fill in) - -The right way to think about the ``after-match function'' is that it -is an embryonic @CoreExpr@ with a ``hole'' at the end for the -final ``else expression''. -\end{itemize} - -There is a data type, @EquationInfo@, defined in module @DsMonad@. - -An experiment with re-ordering this information about equations (in -particular, having the patterns available in column-major order) -showed no benefit. - -\item -A default expression---what to evaluate if the overall pattern-match -fails. This expression will (almost?) always be -a measly expression @Var@, unless we know it will only be used once -(as we do in @glue_success_exprs@). - -Leaving out this third argument to @match@ (and slamming in lots of -@Var "fail"@s) is a positively {\em bad} idea, because it makes it -impossible to share the default expressions. (Also, it stands no -chance of working in our post-upheaval world of @Locals@.) -\end{enumerate} - -Note: @match@ is often called via @matchWrapper@ (end of this module), -a function that does much of the house-keeping that goes with a call -to @match@. - -It is also worth mentioning the {\em typical} way a block of equations -is desugared with @match@. At each stage, it is the first column of -patterns that is examined. The steps carried out are roughly: -\begin{enumerate} -\item -Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add -bindings to the second component of the equation-info): -\item -Now {\em unmix} the equations into {\em blocks} [w\/ local function -@match_groups@], in which the equations in a block all have the same - match group. -(see ``the mixture rule'' in SLPJ). -\item -Call the right match variant on each block of equations; it will do the -appropriate thing for each kind of column-1 pattern. -\end{enumerate} - -We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87) -than the Wadler-chapter code for @match@ (p.~93, first @match@ clause). -And gluing the ``success expressions'' together isn't quite so pretty. - -This @match@ uses @tidyEqnInfo@ -to get `as'- and `twiddle'-patterns out of the way (tidying), before -applying ``the mixture rule'' (SLPJ, p.~88) [which really {\em -un}mixes the equations], producing a list of equation-info -blocks, each block having as its first column patterns compatible with each other. - -Note [Match Ids] -~~~~~~~~~~~~~~~~ -Most of the matching functions take an Id or [Id] as argument. This Id -is the scrutinee(s) of the match. The desugared expression may -sometimes use that Id in a local binding or as a case binder. So it -should not have an External name; Lint rejects non-top-level binders -with External names (#13043). - -See also Note [Localise pattern binders] in DsUtils --} - -type MatchId = Id -- See Note [Match Ids] - -match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with. See Note [Match Ids] - -> Type -- ^ Type of the case expression - -> [EquationInfo] -- ^ Info about patterns, etc. (type synonym below) - -> DsM MatchResult -- ^ Desugared result! - -match [] ty eqns - = ASSERT2( not (null eqns), ppr ty ) - return (foldr1 combineMatchResults match_results) - where - match_results = [ ASSERT( null (eqn_pats eqn) ) - eqn_rhs eqn - | eqn <- eqns ] - -match (v:vs) ty eqns -- Eqns *can* be empty - = ASSERT2( all (isInternalName . idName) vars, ppr vars ) - do { dflags <- getDynFlags - -- Tidy the first pattern, generating - -- auxiliary bindings if necessary - ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns - -- Group the equations and match each group in turn - ; let grouped = groupEquations dflags tidy_eqns - - -- print the view patterns that are commoned up to help debug - ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped) - - ; match_results <- match_groups grouped - ; return (adjustMatchResult (foldr (.) id aux_binds) $ - foldr1 combineMatchResults match_results) } - where - vars = v :| vs - - dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo - dropGroup = fmap snd - - match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty MatchResult) - -- Result list of [MatchResult] is always non-empty - match_groups [] = matchEmpty v ty - match_groups (g:gs) = mapM match_group $ g :| gs - - match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM MatchResult - match_group eqns@((group,_) :| _) - = case group of - PgCon {} -> matchConFamily vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns']) - PgSyn {} -> matchPatSyn vars ty (dropGroup eqns) - PgLit {} -> matchLiterals vars ty (ne $ subGroupOrd [(l,e) | (PgLit l, e) <- eqns']) - PgAny -> matchVariables vars ty (dropGroup eqns) - PgN {} -> matchNPats vars ty (dropGroup eqns) - PgOverS {}-> matchNPats vars ty (dropGroup eqns) - PgNpK {} -> matchNPlusKPats vars ty (dropGroup eqns) - PgBang -> matchBangs vars ty (dropGroup eqns) - PgCo {} -> matchCoercion vars ty (dropGroup eqns) - PgView {} -> matchView vars ty (dropGroup eqns) - PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns) - where eqns' = NEL.toList eqns - ne l = case NEL.nonEmpty l of - Just nel -> nel - Nothing -> pprPanic "match match_group" $ text "Empty result should be impossible since input was non-empty" - - -- FIXME: we should also warn about view patterns that should be - -- commoned up but are not - - -- print some stuff to see what's getting grouped - -- use -dppr-debug to see the resolution of overloaded literals - debug eqns = - let gs = map (\group -> foldr (\ (p,_) -> \acc -> - case p of PgView e _ -> e:acc - _ -> acc) [] group) eqns - maybeWarn [] = return () - maybeWarn l = warnDs NoReason (vcat l) - in - maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g)) - (filter (not . null) gs)) - -matchEmpty :: MatchId -> Type -> DsM (NonEmpty MatchResult) --- See Note [Empty case expressions] -matchEmpty var res_ty - = return [MatchResult CanFail mk_seq] - where - mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty - [(DEFAULT, [], fail)] - -matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult --- Real true variables, just like in matchVar, SLPJ p 94 --- No binding to do: they'll all be wildcards by now (done in tidy) -matchVariables (_ :| vars) ty eqns = match vars ty $ NEL.toList $ shiftEqns eqns - -matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult -matchBangs (var :| vars) ty eqns - = do { match_result <- match (var:vars) ty $ NEL.toList $ - decomposeFirstPat getBangPat <$> eqns - ; return (mkEvalMatchResult var ty match_result) } - -matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult --- Apply the coercion to the match variable and then match that -matchCoercion (var :| vars) ty (eqns@(eqn1 :| _)) - = do { let CoPat _ co pat _ = firstPat eqn1 - ; let pat_ty' = hsPatType pat - ; var' <- newUniqueId var pat_ty' - ; match_result <- match (var':vars) ty $ NEL.toList $ - decomposeFirstPat getCoPat <$> eqns - ; core_wrap <- dsHsWrapper co - ; let bind = NonRec var' (core_wrap (Var var)) - ; return (mkCoLetMatchResult bind match_result) } - -matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult --- Apply the view function to the match variable and then match that -matchView (var :| vars) ty (eqns@(eqn1 :| _)) - = do { -- we could pass in the expr from the PgView, - -- but this needs to extract the pat anyway - -- to figure out the type of the fresh variable - let ViewPat _ viewExpr (L _ pat) = firstPat eqn1 - -- do the rest of the compilation - ; let pat_ty' = hsPatType pat - ; var' <- newUniqueId var pat_ty' - ; match_result <- match (var':vars) ty $ NEL.toList $ - decomposeFirstPat getViewPat <$> eqns - -- compile the view expressions - ; viewExpr' <- dsLExpr viewExpr - ; return (mkViewMatchResult var' - (mkCoreAppDs (text "matchView") viewExpr' (Var var)) - match_result) } - -matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult -matchOverloadedList (var :| vars) ty (eqns@(eqn1 :| _)) --- Since overloaded list patterns are treated as view patterns, --- the code is roughly the same as for matchView - = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1 - ; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand - ; match_result <- match (var':vars) ty $ NEL.toList $ - decomposeFirstPat getOLPat <$> eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern - ; e' <- dsSyntaxExpr e [Var var] - ; return (mkViewMatchResult var' e' match_result) - } - --- decompose the first pattern and leave the rest alone -decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo -decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) - = eqn { eqn_pats = extractpat pat : pats} -decomposeFirstPat _ _ = panic "decomposeFirstPat" - -getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc -getCoPat (CoPat _ _ pat _) = pat -getCoPat _ = panic "getCoPat" -getBangPat (BangPat _ pat ) = unLoc pat -getBangPat _ = panic "getBangPat" -getViewPat (ViewPat _ _ pat) = unLoc pat -getViewPat _ = panic "getViewPat" -getOLPat (ListPat (ListPatTc ty (Just _)) pats) - = ListPat (ListPatTc ty Nothing) pats -getOLPat _ = panic "getOLPat" - -{- -Note [Empty case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The list of EquationInfo can be empty, arising from - case x of {} or \case {} -In that situation we desugar to - case x of { _ -> error "pattern match failure" } -The *desugarer* isn't certain whether there really should be no -alternatives, so it adds a default case, as it always does. A later -pass may remove it if it's inaccessible. (See also Note [Empty case -alternatives] in CoreSyn.) - -We do *not* desugar simply to - error "empty case" -or some such, because 'x' might be bound to (error "hello"), in which -case we want to see that "hello" exception, not (error "empty case"). -See also Note [Case elimination: lifted case] in Simplify. - - -************************************************************************ -* * - Tidying patterns -* * -************************************************************************ - -Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@ -which will be scrutinised. - -This makes desugaring the pattern match simpler by transforming some of -the patterns to simpler forms. (Tuples to Constructor Patterns) - -Among other things in the resulting Pattern: -* Variables and irrefutable(lazy) patterns are replaced by Wildcards -* As patterns are replaced by the patterns they wrap. - -The bindings created by the above patterns are put into the returned wrapper -instead. - -This means a definition of the form: - f x = rhs -when called with v get's desugared to the equivalent of: - let x = v - in - f _ = rhs - -The same principle holds for as patterns (@) and -irrefutable/lazy patterns (~). -In the case of irrefutable patterns the irrefutable pattern is pushed into -the binding. - -Pattern Constructors which only represent syntactic sugar are converted into -their desugared representation. -This usually means converting them to Constructor patterns but for some -depends on enabled extensions. (Eg OverloadedLists) - -GHC also tries to convert overloaded Literals into regular ones. - -The result of this tidying is that the column of patterns will include -only these which can be assigned a PatternGroup (see patGroup). - --} - -tidyEqnInfo :: Id -> EquationInfo - -> DsM (DsWrapper, EquationInfo) - -- DsM'd because of internal call to dsLHsBinds - -- and mkSelectorBinds. - -- "tidy1" does the interesting stuff, looking at - -- one pattern and fiddling the list of bindings. - -- - -- POST CONDITION: head pattern in the EqnInfo is - -- one of these for which patGroup is defined. - -tidyEqnInfo _ (EqnInfo { eqn_pats = [] }) - = panic "tidyEqnInfo" - -tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig }) - = do { (wrap, pat') <- tidy1 v orig pat - ; return (wrap, eqn { eqn_pats = do pat' : pats }) } - -tidy1 :: Id -- The Id being scrutinised - -> Origin -- Was this a pattern the user wrote? - -> Pat GhcTc -- The pattern against which it is to be matched - -> DsM (DsWrapper, -- Extra bindings to do before the match - Pat GhcTc) -- Equivalent pattern - -------------------------------------------------------- --- (pat', mr') = tidy1 v pat mr --- tidies the *outer level only* of pat, giving pat' --- It eliminates many pattern forms (as-patterns, variable patterns, --- list patterns, etc) and returns any created bindings in the wrapper. - -tidy1 v o (ParPat _ pat) = tidy1 v o (unLoc pat) -tidy1 v o (SigPat _ pat _) = tidy1 v o (unLoc pat) -tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty) -tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p - - -- case v of { x -> mr[] } - -- = case v of { _ -> let x=v in mr[] } -tidy1 v _ (VarPat _ (L _ var)) - = return (wrapBind var v, WildPat (idType var)) - - -- case v of { x@p -> mr[] } - -- = case v of { p -> let x=v in mr[] } -tidy1 v o (AsPat _ (L _ var) pat) - = do { (wrap, pat') <- tidy1 v o (unLoc pat) - ; return (wrapBind var v . wrap, pat') } - -{- now, here we handle lazy patterns: - tidy1 v ~p bs = (v, v1 = case v of p -> v1 : - v2 = case v of p -> v2 : ... : bs ) - - where the v_i's are the binders in the pattern. - - ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing? - - The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr --} - -tidy1 v _ (LazyPat _ pat) - -- This is a convenient place to check for unlifted types under a lazy pattern. - -- Doing this check during type-checking is unsatisfactory because we may - -- not fully know the zonked types yet. We sure do here. - = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat) - ; unless (null unlifted_bndrs) $ - putSrcSpanDs (getLoc pat) $ - errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$ - text "Unlifted variables:") - 2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id)) - unlifted_bndrs))) - - ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v) - ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] - ; return (mkCoreLets sel_binds, WildPat (idType v)) } - -tidy1 _ _ (ListPat (ListPatTc ty Nothing) pats ) - = return (idDsWrapper, unLoc list_ConPat) - where - list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty]) - (mkNilPat ty) - pats - -tidy1 _ _ (TuplePat tys pats boxity) - = return (idDsWrapper, unLoc tuple_ConPat) - where - arity = length pats - tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys - -tidy1 _ _ (SumPat tys pat alt arity) - = return (idDsWrapper, unLoc sum_ConPat) - where - sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys - --- LitPats: we *might* be able to replace these w/ a simpler form -tidy1 _ o (LitPat _ lit) - = do { unless (isGenerated o) $ - warnAboutOverflowedLit lit - ; return (idDsWrapper, tidyLitPat lit) } - --- NPats: we *might* be able to replace these w/ a simpler form -tidy1 _ o (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq) - = do { unless (isGenerated o) $ - let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v } - | otherwise = lit - in warnAboutOverflowedOverLit lit' - ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) } - --- NPlusKPat: we may want to warn about the literals -tidy1 _ o n@(NPlusKPat _ _ (L _ lit1) lit2 _ _) - = do { unless (isGenerated o) $ do - warnAboutOverflowedOverLit lit1 - warnAboutOverflowedOverLit lit2 - ; return (idDsWrapper, n) } - --- Everything else goes through unchanged... -tidy1 _ _ non_interesting_pat - = return (idDsWrapper, non_interesting_pat) - --------------------- -tidy_bang_pat :: Id -> Origin -> SrcSpan -> Pat GhcTc - -> DsM (DsWrapper, Pat GhcTc) - --- Discard par/sig under a bang -tidy_bang_pat v o _ (ParPat _ (L l p)) = tidy_bang_pat v o l p -tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p - --- Push the bang-pattern inwards, in the hope that --- it may disappear next time -tidy_bang_pat v o l (AsPat x v' p) - = tidy1 v o (AsPat x v' (L l (BangPat noExtField p))) -tidy_bang_pat v o l (CoPat x w p t) - = tidy1 v o (CoPat x w (BangPat noExtField (L l p)) t) - --- Discard bang around strict pattern -tidy_bang_pat v o _ p@(LitPat {}) = tidy1 v o p -tidy_bang_pat v o _ p@(ListPat {}) = tidy1 v o p -tidy_bang_pat v o _ p@(TuplePat {}) = tidy1 v o p -tidy_bang_pat v o _ p@(SumPat {}) = tidy1 v o p - --- Data/newtype constructors -tidy_bang_pat v o l p@(ConPatOut { pat_con = L _ (RealDataCon dc) - , pat_args = args - , pat_arg_tys = arg_tys }) - -- Newtypes: push bang inwards (#9844) - = - if isNewTyCon (dataConTyCon dc) - then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l ty args }) - else tidy1 v o p -- Data types: discard the bang - where - (ty:_) = dataConInstArgTys dc arg_tys - -------------------- --- Default case, leave the bang there: --- VarPat, --- LazyPat, --- WildPat, --- ViewPat, --- pattern synonyms (ConPatOut with PatSynCon) --- NPat, --- NPlusKPat --- --- For LazyPat, remember that it's semantically like a VarPat --- i.e. !(~p) is not like ~p, or p! (#8952) --- --- NB: SigPatIn, ConPatIn should not happen - -tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p)) - -------------------- -push_bang_into_newtype_arg :: SrcSpan - -> Type -- The type of the argument we are pushing - -- onto - -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc --- See Note [Bang patterns and newtypes] --- We are transforming !(N p) into (N !p) -push_bang_into_newtype_arg l _ty (PrefixCon (arg:args)) - = ASSERT( null args) - PrefixCon [L l (BangPat noExtField arg)] -push_bang_into_newtype_arg l _ty (RecCon rf) - | HsRecFields { rec_flds = L lf fld : flds } <- rf - , HsRecField { hsRecFieldArg = arg } <- fld - = ASSERT( null flds) - RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg - = L l (BangPat noExtField arg) })] }) -push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {}) - | HsRecFields { rec_flds = [] } <- rf - = PrefixCon [L l (BangPat noExtField (noLoc (WildPat ty)))] -push_bang_into_newtype_arg _ _ cd - = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) - -{- -Note [Bang patterns and newtypes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For the pattern !(Just pat) we can discard the bang, because -the pattern is strict anyway. But for !(N pat), where - newtype NT = N Int -we definitely can't discard the bang. #9844. - -So what we do is to push the bang inwards, in the hope that it will -get discarded there. So we transform - !(N pat) into (N !pat) - -But what if there is nothing to push the bang onto? In at least one instance -a user has written !(N {}) which we translate into (N !_). See #13215 - - -\noindent -{\bf Previous @matchTwiddled@ stuff:} - -Now we get to the only interesting part; note: there are choices for -translation [from Simon's notes]; translation~1: -\begin{verbatim} -deTwiddle [s,t] e -\end{verbatim} -returns -\begin{verbatim} -[ w = e, - s = case w of [s,t] -> s - t = case w of [s,t] -> t -] -\end{verbatim} - -Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple -evaluation of \tr{e}. An alternative translation (No.~2): -\begin{verbatim} -[ w = case e of [s,t] -> (s,t) - s = case w of (s,t) -> s - t = case w of (s,t) -> t -] -\end{verbatim} - -************************************************************************ -* * -\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing} -* * -************************************************************************ - -We might be able to optimise unmixing when confronted by -only-one-constructor-possible, of which tuples are the most notable -examples. Consider: -\begin{verbatim} -f (a,b,c) ... = ... -f d ... (e:f) = ... -f (g,h,i) ... = ... -f j ... = ... -\end{verbatim} -This definition would normally be unmixed into four equation blocks, -one per equation. But it could be unmixed into just one equation -block, because if the one equation matches (on the first column), -the others certainly will. - -You have to be careful, though; the example -\begin{verbatim} -f j ... = ... -------------------- -f (a,b,c) ... = ... -f d ... (e:f) = ... -f (g,h,i) ... = ... -\end{verbatim} -{\em must} be broken into two blocks at the line shown; otherwise, you -are forcing unnecessary evaluation. In any case, the top-left pattern -always gives the cue. You could then unmix blocks into groups of... -\begin{description} -\item[all variables:] -As it is now. -\item[constructors or variables (mixed):] -Need to make sure the right names get bound for the variable patterns. -\item[literals or variables (mixed):] -Presumably just a variant on the constructor case (as it is now). -\end{description} - -************************************************************************ -* * -* matchWrapper: a convenient way to call @match@ * -* * -************************************************************************ -\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@} - -Calls to @match@ often involve similar (non-trivial) work; that work -is collected here, in @matchWrapper@. This function takes as -arguments: -\begin{itemize} -\item -Typechecked @Matches@ (of a function definition, or a case or lambda -expression)---the main input; -\item -An error message to be inserted into any (runtime) pattern-matching -failure messages. -\end{itemize} - -As results, @matchWrapper@ produces: -\begin{itemize} -\item -A list of variables (@Locals@) that the caller must ``promise'' to -bind to appropriate values; and -\item -a @CoreExpr@, the desugared output (main result). -\end{itemize} - -The main actions of @matchWrapper@ include: -\begin{enumerate} -\item -Flatten the @[TypecheckedMatch]@ into a suitable list of -@EquationInfo@s. -\item -Create as many new variables as there are patterns in a pattern-list -(in any one of the @EquationInfo@s). -\item -Create a suitable ``if it fails'' expression---a call to @error@ using -the error-string input; the {\em type} of this fail value can be found -by examining one of the RHS expressions in one of the @EquationInfo@s. -\item -Call @match@ with all of this information! -\end{enumerate} --} - -matchWrapper - :: HsMatchContext GhcRn -- ^ For shadowing warning messages - -> Maybe (LHsExpr GhcTc) -- ^ Scrutinee. (Just scrut) for a case expr - -- case scrut of { p1 -> e1 ... } - -- (and in this case the MatchGroup will - -- have all singleton patterns) - -- Nothing for a function definition - -- f p1 q1 = ... -- No "scrutinee" - -- f p2 q2 = ... -- in this case - -> MatchGroup GhcTc (LHsExpr GhcTc) -- ^ Matches being desugared - -> DsM ([Id], CoreExpr) -- ^ Results (usually passed to 'match') - -{- - There is one small problem with the Lambda Patterns, when somebody - writes something similar to: -\begin{verbatim} - (\ (x:xs) -> ...) -\end{verbatim} - he/she don't want a warning about incomplete patterns, that is done with - the flag @opt_WarnSimplePatterns@. - This problem also appears in the: -\begin{itemize} -\item @do@ patterns, but if the @do@ can fail - it creates another equation if the match can fail - (see @DsExpr.doDo@ function) -\item @let@ patterns, are treated by @matchSimply@ - List Comprension Patterns, are treated by @matchSimply@ also -\end{itemize} - -We can't call @matchSimply@ with Lambda patterns, -due to the fact that lambda patterns can have more than -one pattern, and match simply only accepts one pattern. - -JJQC 30-Nov-1997 --} - -matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches - , mg_ext = MatchGroupTc arg_tys rhs_ty - , mg_origin = origin }) - = do { dflags <- getDynFlags - ; locn <- getSrcSpanDs - - ; new_vars <- case matches of - [] -> mapM newSysLocalDsNoLP arg_tys - (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m)) - - ; eqns_info <- mapM (mk_eqn_info new_vars) matches - - -- Pattern match check warnings for /this match-group/ - ; when (isMatchContextPmChecked dflags origin ctxt) $ - addScrutTmCs mb_scr new_vars $ - -- See Note [Type and Term Equality Propagation] - checkMatches dflags (DsMatchContext ctxt locn) new_vars matches - - ; result_expr <- handleWarnings $ - matchEquations ctxt new_vars eqns_info rhs_ty - ; return (new_vars, result_expr) } - where - -- Called once per equation in the match, or alternative in the case - mk_eqn_info vars (L _ (Match { m_pats = pats, m_grhss = grhss })) - = do { dflags <- getDynFlags - ; let upats = map (unLoc . decideBangHood dflags) pats - dicts = collectEvVarsPats upats - - ; match_result <- - -- Extend the environment with knowledge about - -- the matches before desugaring the RHS - -- See Note [Type and Term Equality Propagation] - applyWhen (needToRunPmCheck dflags origin) - (addTyCsDs dicts . addScrutTmCs mb_scr vars . addPatTmCs upats vars) - (dsGRHSs ctxt grhss rhs_ty) - - ; return (EqnInfo { eqn_pats = upats - , eqn_orig = FromSource - , eqn_rhs = match_result }) } - mk_eqn_info _ (L _ (XMatch nec)) = noExtCon nec - - handleWarnings = if isGenerated origin - then discardWarningsDs - else id -matchWrapper _ _ (XMatchGroup nec) = noExtCon nec - -matchEquations :: HsMatchContext GhcRn - -> [MatchId] -> [EquationInfo] -> Type - -> DsM CoreExpr -matchEquations ctxt vars eqns_info rhs_ty - = do { let error_doc = matchContextErrString ctxt - - ; match_result <- match vars rhs_ty eqns_info - - ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc - ; extractMatchResult match_result fail_expr } - -{- -************************************************************************ -* * -\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern} -* * -************************************************************************ - -@mkSimpleMatch@ is a wrapper for @match@ which deals with the -situation where we want to match a single expression against a single -pattern. It returns an expression. --} - -matchSimply :: CoreExpr -- ^ Scrutinee - -> HsMatchContext GhcRn -- ^ Match kind - -> LPat GhcTc -- ^ Pattern it should match - -> CoreExpr -- ^ Return this if it matches - -> CoreExpr -- ^ Return this if it doesn't - -> DsM CoreExpr --- Do not warn about incomplete patterns; see matchSinglePat comments -matchSimply scrut hs_ctx pat result_expr fail_expr = do - let - match_result = cantFailMatchResult result_expr - rhs_ty = exprType fail_expr - -- Use exprType of fail_expr, because won't refine in the case of failure! - match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result - extractMatchResult match_result' fail_expr - -matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc - -> Type -> MatchResult -> DsM MatchResult --- matchSinglePat ensures that the scrutinee is a variable --- and then calls matchSinglePatVar --- --- matchSinglePat does not warn about incomplete patterns --- Used for things like [ e | pat <- stuff ], where --- incomplete patterns are just fine - -matchSinglePat (Var var) ctx pat ty match_result - | not (isExternalName (idName var)) - = matchSinglePatVar var ctx pat ty match_result - -matchSinglePat scrut hs_ctx pat ty match_result - = do { var <- selectSimpleMatchVarL pat - ; match_result' <- matchSinglePatVar var hs_ctx pat ty match_result - ; return (adjustMatchResult (bindNonRec var scrut) match_result') } - -matchSinglePatVar :: Id -- See Note [Match Ids] - -> HsMatchContext GhcRn -> LPat GhcTc - -> Type -> MatchResult -> DsM MatchResult -matchSinglePatVar var ctx pat ty match_result - = ASSERT2( isInternalName (idName var), ppr var ) - do { dflags <- getDynFlags - ; locn <- getSrcSpanDs - - -- Pattern match check warnings - ; checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat) - - ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)] - , eqn_orig = FromSource - , eqn_rhs = match_result } - ; match [var] ty [eqn_info] } - - -{- -************************************************************************ -* * - Pattern classification -* * -************************************************************************ --} - -data PatGroup - = PgAny -- Immediate match: variables, wildcards, - -- lazy patterns - | PgCon DataCon -- Constructor patterns (incl list, tuple) - | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups] - | PgLit Literal -- Literal patterns - | PgN Rational -- Overloaded numeric literals; - -- see Note [Don't use Literal for PgN] - | PgOverS FastString -- Overloaded string literals - | PgNpK Integer -- n+k patterns - | PgBang -- Bang patterns - | PgCo Type -- Coercion patterns; the type is the type - -- of the pattern *inside* - | PgView (LHsExpr GhcTc) -- view pattern (e -> p): - -- the LHsExpr is the expression e - Type -- the Type is the type of p (equivalently, the result type of e) - | PgOverloadedList - -{- Note [Don't use Literal for PgN] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Previously we had, as PatGroup constructors - - | ... - | PgN Literal -- Overloaded literals - | PgNpK Literal -- n+k patterns - | ... - -But Literal is really supposed to represent an *unboxed* literal, like Int#. -We were sticking the literal from, say, an overloaded numeric literal pattern -into a LitInt constructor. This didn't really make sense; and we now have -the invariant that value in a LitInt must be in the range of the target -machine's Int# type, and an overloaded literal could meaningfully be larger. - -Solution: For pattern grouping purposes, just store the literal directly in -the PgN constructor as a Rational if numeric, and add a PgOverStr constructor -for overloaded strings. --} - -groupEquations :: DynFlags -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)] --- If the result is of form [g1, g2, g3], --- (a) all the (pg,eq) pairs in g1 have the same pg --- (b) none of the gi are empty --- The ordering of equations is unchanged -groupEquations dflags eqns - = NEL.groupBy same_gp $ [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns] - -- comprehension on NonEmpty - where - same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool - (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 - --- TODO Make subGroup1 using a NonEmptyMap -subGroup :: (m -> [NonEmpty EquationInfo]) -- Map.elems - -> m -- Map.empty - -> (a -> m -> Maybe (NonEmpty EquationInfo)) -- Map.lookup - -> (a -> NonEmpty EquationInfo -> m -> m) -- Map.insert - -> [(a, EquationInfo)] -> [NonEmpty EquationInfo] --- Input is a particular group. The result sub-groups the --- equations by with particular constructor, literal etc they match. --- Each sub-list in the result has the same PatGroup --- See Note [Take care with pattern order] --- Parameterized by map operations to allow different implementations --- and constraints, eg. types without Ord instance. -subGroup elems empty lookup insert group - = fmap NEL.reverse $ elems $ foldl' accumulate empty group - where - accumulate pg_map (pg, eqn) - = case lookup pg pg_map of - Just eqns -> insert pg (NEL.cons eqn eqns) pg_map - Nothing -> insert pg [eqn] pg_map - -- pg_map :: Map a [EquationInfo] - -- Equations seen so far in reverse order of appearance - -subGroupOrd :: Ord a => [(a, EquationInfo)] -> [NonEmpty EquationInfo] -subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert - -subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [NonEmpty EquationInfo] -subGroupUniq = - subGroup eltsUDFM emptyUDFM (flip lookupUDFM) (\k v m -> addToUDFM m k v) - -{- Note [Pattern synonym groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we see - f (P a) = e1 - f (P b) = e2 - ... -where P is a pattern synonym, can we put (P a -> e1) and (P b -> e2) in the -same group? We can if P is a constructor, but /not/ if P is a pattern synonym. -Consider (#11224) - -- readMaybe :: Read a => String -> Maybe a - pattern PRead :: Read a => () => a -> String - pattern PRead a <- (readMaybe -> Just a) - - f (PRead (x::Int)) = e1 - f (PRead (y::Bool)) = e2 -This is all fine: we match the string by trying to read an Int; if that -fails we try to read a Bool. But clearly we can't combine the two into a single -match. - -Conclusion: we can combine when we invoke PRead /at the same type/. Hence -in PgSyn we record the instantiating types, and use them in sameGroup. - -Note [Take care with pattern order] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the subGroup function we must be very careful about pattern re-ordering, -Consider the patterns [ (True, Nothing), (False, x), (True, y) ] -Then in bringing together the patterns for True, we must not -swap the Nothing and y! --} - -sameGroup :: PatGroup -> PatGroup -> Bool --- Same group means that a single case expression --- or test will suffice to match both, *and* the order --- of testing within the group is insignificant. -sameGroup PgAny PgAny = True -sameGroup PgBang PgBang = True -sameGroup (PgCon _) (PgCon _) = True -- One case expression -sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2 - -- eqTypes: See Note [Pattern synonym groups] -sameGroup (PgLit _) (PgLit _) = True -- One case expression -sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant -sameGroup (PgOverS s1) (PgOverS s2) = s1==s2 -sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns] -sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2 - -- CoPats are in the same goup only if the type of the - -- enclosed pattern is the same. The patterns outside the CoPat - -- always have the same type, so this boils down to saying that - -- the two coercions are identical. -sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2) - -- ViewPats are in the same group iff the expressions - -- are "equal"---conservatively, we use syntactic equality -sameGroup _ _ = False - --- An approximation of syntactic equality used for determining when view --- exprs are in the same group. --- This function can always safely return false; --- but doing so will result in the application of the view function being repeated. --- --- Currently: compare applications of literals and variables --- and anything else that we can do without involving other --- HsSyn types in the recursion --- --- NB we can't assume that the two view expressions have the same type. Consider --- f (e1 -> True) = ... --- f (e2 -> "hi") = ... -viewLExprEq :: (LHsExpr GhcTc,Type) -> (LHsExpr GhcTc,Type) -> Bool -viewLExprEq (e1,_) (e2,_) = lexp e1 e2 - where - lexp :: LHsExpr GhcTc -> LHsExpr GhcTc -> Bool - lexp e e' = exp (unLoc e) (unLoc e') - - --------- - exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool - -- real comparison is on HsExpr's - -- strip parens - exp (HsPar _ (L _ e)) e' = exp e e' - exp e (HsPar _ (L _ e')) = exp e e' - -- because the expressions do not necessarily have the same type, - -- we have to compare the wrappers - exp (XExpr (HsWrap h e)) (XExpr (HsWrap h' e')) = wrap h h' && exp e e' - exp (HsVar _ i) (HsVar _ i') = i == i' - exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c' - -- the instance for IPName derives using the id, so this works if the - -- above does - exp (HsIPVar _ i) (HsIPVar _ i') = i == i' - exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x' - exp (HsOverLit _ l) (HsOverLit _ l') = - -- Overloaded lits are equal if they have the same type - -- and the data is the same. - -- this is coarser than comparing the SyntaxExpr's in l and l', - -- which resolve the overloading (e.g., fromInteger 1), - -- because these expressions get written as a bunch of different variables - -- (presumably to improve sharing) - eqType (overLitType l) (overLitType l') && l == l' - exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2' - -- the fixities have been straightened out by now, so it's safe - -- to ignore them? - exp (OpApp _ l o ri) (OpApp _ l' o' ri') = - lexp l l' && lexp o o' && lexp ri ri' - exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n' - exp (SectionL _ e1 e2) (SectionL _ e1' e2') = - lexp e1 e1' && lexp e2 e2' - exp (SectionR _ e1 e2) (SectionR _ e1' e2') = - lexp e1 e1' && lexp e2 e2' - exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) = - eq_list tup_arg es1 es2 - exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e' - exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') = - lexp e e' && lexp e1 e1' && lexp e2 e2' - - -- Enhancement: could implement equality for more expressions - -- if it seems useful - -- But no need for HsLit, ExplicitList, ExplicitTuple, - -- because they cannot be functions - exp _ _ = False - - --------- - syn_exp :: SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool - syn_exp (SyntaxExprTc { syn_expr = expr1 - , syn_arg_wraps = arg_wraps1 - , syn_res_wrap = res_wrap1 }) - (SyntaxExprTc { syn_expr = expr2 - , syn_arg_wraps = arg_wraps2 - , syn_res_wrap = res_wrap2 }) - = exp expr1 expr2 && - and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) && - wrap res_wrap1 res_wrap2 - syn_exp NoSyntaxExprTc NoSyntaxExprTc = True - syn_exp _ _ = False - - --------- - tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2 - tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2 - tup_arg _ _ = False - - --------- - wrap :: HsWrapper -> HsWrapper -> Bool - -- Conservative, in that it demands that wrappers be - -- syntactically identical and doesn't look under binders - -- - -- Coarser notions of equality are possible - -- (e.g., reassociating compositions, - -- equating different ways of writing a coercion) - wrap WpHole WpHole = True - wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2' - wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2' - wrap (WpCast co) (WpCast co') = co `eqCoercion` co' - wrap (WpEvApp et1) (WpEvApp et2) = et1 `ev_term` et2 - wrap (WpTyApp t) (WpTyApp t') = eqType t t' - -- Enhancement: could implement equality for more wrappers - -- if it seems useful (lams and lets) - wrap _ _ = False - - --------- - ev_term :: EvTerm -> EvTerm -> Bool - ev_term (EvExpr (Var a)) (EvExpr (Var b)) = a==b - ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b)) = a `eqCoercion` b - ev_term _ _ = False - - --------- - eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool - eq_list _ [] [] = True - eq_list _ [] (_:_) = False - eq_list _ (_:_) [] = False - eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys - -patGroup :: DynFlags -> Pat GhcTc -> PatGroup -patGroup _ (ConPatOut { pat_con = L _ con - , pat_arg_tys = tys }) - | RealDataCon dcon <- con = PgCon dcon - | PatSynCon psyn <- con = PgSyn psyn tys -patGroup _ (WildPat {}) = PgAny -patGroup _ (BangPat {}) = PgBang -patGroup _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) = - case (oval, isJust mb_neg) of - (HsIntegral i, False) -> PgN (fromInteger (il_value i)) - (HsIntegral i, True ) -> PgN (-fromInteger (il_value i)) - (HsFractional r, False) -> PgN (fl_value r) - (HsFractional r, True ) -> PgN (-fl_value r) - (HsIsString _ s, _) -> ASSERT(isNothing mb_neg) - PgOverS s -patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) = - case oval of - HsIntegral i -> PgNpK (il_value i) - _ -> pprPanic "patGroup NPlusKPat" (ppr oval) -patGroup _ (CoPat _ _ p _) = PgCo (hsPatType p) - -- Type of innelexp pattern -patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p)) -patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList -patGroup dflags (LitPat _ lit) = PgLit (hsLitKey dflags lit) -patGroup _ pat = pprPanic "patGroup" (ppr pat) - -{- -Note [Grouping overloaded literal patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -WATCH OUT! Consider - - f (n+1) = ... - f (n+2) = ... - f (n+1) = ... - -We can't group the first and third together, because the second may match -the same thing as the first. Same goes for *overloaded* literal patterns - f 1 True = ... - f 2 False = ... - f 1 False = ... -If the first arg matches '1' but the second does not match 'True', we -cannot jump to the third equation! Because the same argument might -match '2'! -Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group. --} diff --git a/compiler/deSugar/Match.hs-boot b/compiler/deSugar/Match.hs-boot deleted file mode 100644 index 6d6cf989df..0000000000 --- a/compiler/deSugar/Match.hs-boot +++ /dev/null @@ -1,36 +0,0 @@ -module Match where - -import GhcPrelude -import Var ( Id ) -import TcType ( Type ) -import DsMonad ( DsM, EquationInfo, MatchResult ) -import CoreSyn ( CoreExpr ) -import GHC.Hs ( LPat, HsMatchContext, MatchGroup, LHsExpr ) -import GHC.Hs.Extension ( GhcRn, GhcTc ) - -match :: [Id] - -> Type - -> [EquationInfo] - -> DsM MatchResult - -matchWrapper - :: HsMatchContext GhcRn - -> Maybe (LHsExpr GhcTc) - -> MatchGroup GhcTc (LHsExpr GhcTc) - -> DsM ([Id], CoreExpr) - -matchSimply - :: CoreExpr - -> HsMatchContext GhcRn - -> LPat GhcTc - -> CoreExpr - -> CoreExpr - -> DsM CoreExpr - -matchSinglePatVar - :: Id - -> HsMatchContext GhcRn - -> LPat GhcTc - -> Type - -> MatchResult - -> DsM MatchResult diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs deleted file mode 100644 index b5d5807592..0000000000 --- a/compiler/deSugar/MatchCon.hs +++ /dev/null @@ -1,296 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Pattern-matching constructors --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module MatchCon ( matchConFamily, matchPatSyn ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} Match ( match ) - -import GHC.Hs -import DsBinds -import ConLike -import BasicTypes ( Origin(..) ) -import TcType -import DsMonad -import DsUtils -import MkCore ( mkCoreLets ) -import Util -import Id -import NameEnv -import FieldLabel ( flSelector ) -import SrcLoc -import Outputable -import Control.Monad(liftM) -import Data.List (groupBy) -import Data.List.NonEmpty (NonEmpty(..)) - -{- -We are confronted with the first column of patterns in a set of -equations, all beginning with constructors from one ``family'' (e.g., -@[]@ and @:@ make up the @List@ ``family''). We want to generate the -alternatives for a @Case@ expression. There are several choices: -\begin{enumerate} -\item -Generate an alternative for every constructor in the family, whether -they are used in this set of equations or not; this is what the Wadler -chapter does. -\begin{description} -\item[Advantages:] -(a)~Simple. (b)~It may also be that large sparsely-used constructor -families are mainly handled by the code for literals. -\item[Disadvantages:] -(a)~Not practical for large sparsely-used constructor families, e.g., -the ASCII character set. (b)~Have to look up a list of what -constructors make up the whole family. -\end{description} - -\item -Generate an alternative for each constructor used, then add a default -alternative in case some constructors in the family weren't used. -\begin{description} -\item[Advantages:] -(a)~Alternatives aren't generated for unused constructors. (b)~The -STG is quite happy with defaults. (c)~No lookup in an environment needed. -\item[Disadvantages:] -(a)~A spurious default alternative may be generated. -\end{description} - -\item -``Do it right:'' generate an alternative for each constructor used, -and add a default alternative if all constructors in the family -weren't used. -\begin{description} -\item[Advantages:] -(a)~You will get cases with only one alternative (and no default), -which should be amenable to optimisation. Tuples are a common example. -\item[Disadvantages:] -(b)~Have to look up constructor families in TDE (as above). -\end{description} -\end{enumerate} - -We are implementing the ``do-it-right'' option for now. The arguments -to @matchConFamily@ are the same as to @match@; the extra @Int@ -returned is the number of constructors in the family. - -The function @matchConFamily@ is concerned with this -have-we-used-all-the-constructors? question; the local function -@match_cons_used@ does all the real work. --} - -matchConFamily :: NonEmpty Id - -> Type - -> NonEmpty (NonEmpty EquationInfo) - -> DsM MatchResult --- Each group of eqns is for a single constructor -matchConFamily (var :| vars) ty groups - = do alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups - return (mkCoAlgCaseMatchResult var ty alts) - where - toRealAlt alt = case alt_pat alt of - RealDataCon dcon -> alt{ alt_pat = dcon } - _ -> panic "matchConFamily: not RealDataCon" - -matchPatSyn :: NonEmpty Id - -> Type - -> NonEmpty EquationInfo - -> DsM MatchResult -matchPatSyn (var :| vars) ty eqns - = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns - return (mkCoSynCaseMatchResult var ty alt) - where - toSynAlt alt = case alt_pat alt of - PatSynCon psyn -> alt{ alt_pat = psyn } - _ -> panic "matchPatSyn: not PatSynCon" - -type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc)) - -matchOneConLike :: [Id] - -> Type - -> NonEmpty EquationInfo - -> DsM (CaseAlt ConLike) -matchOneConLike vars ty (eqn1 :| eqns) -- All eqns for a single constructor - = do { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs ) - -- ex_tvs can only be tyvars as data types in source - -- Haskell cannot mention covar yet (Aug 2018). - ASSERT( tvs1 `equalLength` ex_tvs ) - arg_tys ++ mkTyVarTys tvs1 - - val_arg_tys = conLikeInstOrigArgTys con1 inst_tys - -- dataConInstOrigArgTys takes the univ and existential tyvars - -- and returns the types of the *value* args, which is what we want - - match_group :: [Id] - -> [(ConArgPats, EquationInfo)] -> DsM MatchResult - -- All members of the group have compatible ConArgPats - match_group arg_vars arg_eqn_prs - = ASSERT( notNull arg_eqn_prs ) - do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs) - ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs - ; match_result <- match (group_arg_vars ++ vars) ty eqns' - ; return (adjustMatchResult (foldr1 (.) wraps) match_result) } - - shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds, - pat_binds = bind, pat_args = args - } : pats })) - = do ds_bind <- dsTcEvBinds bind - return ( wrapBinds (tvs `zip` tvs1) - . wrapBinds (ds `zip` dicts1) - . mkCoreLets ds_bind - , eqn { eqn_orig = Generated - , eqn_pats = conArgPats val_arg_tys args ++ pats } - ) - shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps) - - ; arg_vars <- selectConMatchVars val_arg_tys args1 - -- Use the first equation as a source of - -- suggestions for the new variables - - -- Divide into sub-groups; see Note [Record patterns] - ; let groups :: [[(ConArgPats, EquationInfo)]] - groups = groupBy compatible_pats [ (pat_args (firstPat eqn), eqn) - | eqn <- eqn1:eqns ] - - ; match_results <- mapM (match_group arg_vars) groups - - ; return $ MkCaseAlt{ alt_pat = con1, - alt_bndrs = tvs1 ++ dicts1 ++ arg_vars, - alt_wrapper = wrapper1, - alt_result = foldr1 combineMatchResults match_results } } - where - ConPatOut { pat_con = L _ con1 - , pat_arg_tys = arg_tys, pat_wrap = wrapper1, - pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 } - = firstPat eqn1 - fields1 = map flSelector (conLikeFieldLabels con1) - - ex_tvs = conLikeExTyCoVars con1 - - -- Choose the right arg_vars in the right order for this group - -- Note [Record patterns] - select_arg_vars :: [Id] -> [(ConArgPats, EquationInfo)] -> [Id] - select_arg_vars arg_vars ((arg_pats, _) : _) - | RecCon flds <- arg_pats - , let rpats = rec_flds flds - , not (null rpats) -- Treated specially; cf conArgPats - = ASSERT2( fields1 `equalLength` arg_vars, - ppr con1 $$ ppr fields1 $$ ppr arg_vars ) - map lookup_fld rpats - | otherwise - = arg_vars - where - fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars - lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env - (idName (unLoc (hsRecFieldId rpat))) - select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []" - ------------------ -compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool --- Two constructors have compatible argument patterns if the number --- and order of sub-matches is the same in both cases -compatible_pats (RecCon flds1, _) (RecCon flds2, _) = same_fields flds1 flds2 -compatible_pats (RecCon flds1, _) _ = null (rec_flds flds1) -compatible_pats _ (RecCon flds2, _) = null (rec_flds flds2) -compatible_pats _ _ = True -- Prefix or infix con - -same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc) - -> Bool -same_fields flds1 flds2 - = all2 (\(L _ f1) (L _ f2) - -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2)) - (rec_flds flds1) (rec_flds flds2) - - ------------------ -selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id] -selectConMatchVars arg_tys (RecCon {}) = newSysLocalsDsNoLP arg_tys -selectConMatchVars _ (PrefixCon ps) = selectMatchVars (map unLoc ps) -selectConMatchVars _ (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2] - -conArgPats :: [Type] -- Instantiated argument types - -- Used only to fill in the types of WildPats, which - -- are probably never looked at anyway - -> ConArgPats - -> [Pat GhcTc] -conArgPats _arg_tys (PrefixCon ps) = map unLoc ps -conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2] -conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats })) - | null rpats = map WildPat arg_tys - -- Important special case for C {}, which can be used for a - -- datacon that isn't declared to have fields at all - | otherwise = map (unLoc . hsRecFieldArg . unLoc) rpats - -{- -Note [Record patterns] -~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T = T { x,y,z :: Bool } - - f (T { y=True, x=False }) = ... - -We must match the patterns IN THE ORDER GIVEN, thus for the first -one we match y=True before x=False. See #246; or imagine -matching against (T { y=False, x=undefined }): should fail without -touching the undefined. - -Now consider: - - f (T { y=True, x=False }) = ... - f (T { x=True, y= False}) = ... - -In the first we must test y first; in the second we must test x -first. So we must divide even the equations for a single constructor -T into sub-groups, based on whether they match the same field in the -same order. That's what the (groupBy compatible_pats) grouping. - -All non-record patterns are "compatible" in this sense, because the -positional patterns (T a b) and (a `T` b) all match the arguments -in order. Also T {} is special because it's equivalent to (T _ _). -Hence the (null rpats) checks here and there. - - -Note [Existentials in shift_con_pat] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T = forall a. Ord a => T a (a->Int) - - f (T x f) True = ...expr1... - f (T y g) False = ...expr2.. - -When we put in the tyvars etc we get - - f (T a (d::Ord a) (x::a) (f::a->Int)) True = ...expr1... - f (T b (e::Ord b) (y::a) (g::a->Int)) True = ...expr2... - -After desugaring etc we'll get a single case: - - f = \t::T b::Bool -> - case t of - T a (d::Ord a) (x::a) (f::a->Int)) -> - case b of - True -> ...expr1... - False -> ...expr2... - -*** We have to substitute [a/b, d/e] in expr2! ** -Hence - False -> ....((/\b\(e:Ord b).expr2) a d).... - -Originally I tried to use - (\b -> let e = d in expr2) a -to do this substitution. While this is "correct" in a way, it fails -Lint, because e::Ord b but d::Ord a. - --} diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs deleted file mode 100644 index a6ec151bfd..0000000000 --- a/compiler/deSugar/MatchLit.hs +++ /dev/null @@ -1,520 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Pattern-matching literal patterns --} - -{-# LANGUAGE CPP, ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module MatchLit ( dsLit, dsOverLit, hsLitKey - , tidyLitPat, tidyNPat - , matchLiterals, matchNPlusKPats, matchNPats - , warnAboutIdentities - , warnAboutOverflowedOverLit, warnAboutOverflowedLit - , warnAboutEmptyEnumerations - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} Match ( match ) -import {-# SOURCE #-} DsExpr ( dsExpr, dsSyntaxExpr ) - -import DsMonad -import DsUtils - -import GHC.Hs - -import Id -import CoreSyn -import MkCore -import TyCon -import DataCon -import TcHsSyn ( shortCutLit ) -import TcType -import Name -import Type -import PrelNames -import TysWiredIn -import TysPrim -import Literal -import SrcLoc -import Data.Ratio -import Outputable -import BasicTypes -import DynFlags -import Util -import FastString -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.Int -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NEL -import Data.Word -import Data.Proxy - -{- -************************************************************************ -* * - Desugaring literals - [used to be in DsExpr, but DsMeta needs it, - and it's nice to avoid a loop] -* * -************************************************************************ - -We give int/float literals type @Integer@ and @Rational@, respectively. -The typechecker will (presumably) have put \tr{from{Integer,Rational}s} -around them. - -ToDo: put in range checks for when converting ``@i@'' -(or should that be in the typechecker?) - -For numeric literals, we try to detect there use at a standard type -(@Int@, @Float@, etc.) are directly put in the right constructor. -[NB: down with the @App@ conversion.] - -See also below where we look for @DictApps@ for \tr{plusInt}, etc. --} - -dsLit :: HsLit GhcRn -> DsM CoreExpr -dsLit l = do - dflags <- getDynFlags - case l of - HsStringPrim _ s -> return (Lit (LitString s)) - HsCharPrim _ c -> return (Lit (LitChar c)) - HsIntPrim _ i -> return (Lit (mkLitIntWrap dflags i)) - HsWordPrim _ w -> return (Lit (mkLitWordWrap dflags w)) - HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap dflags i)) - HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap dflags w)) - HsFloatPrim _ f -> return (Lit (LitFloat (fl_value f))) - HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d))) - HsChar _ c -> return (mkCharExpr c) - HsString _ str -> mkStringExprFS str - HsInteger _ i _ -> mkIntegerExpr i - HsInt _ i -> return (mkIntExpr dflags (il_value i)) - XLit nec -> noExtCon nec - HsRat _ (FL _ _ val) ty -> do - num <- mkIntegerExpr (numerator val) - denom <- mkIntegerExpr (denominator val) - return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) - where - (ratio_data_con, integer_ty) - = case tcSplitTyConApp ty of - (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) - (head (tyConDataCons tycon), i_ty) - x -> pprPanic "dsLit" (ppr x) - -dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr --- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains --- (an expression for) the literal value itself. -dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty - , ol_witness = witness }) = do - dflags <- getDynFlags - case shortCutLit dflags val ty of - Just expr | not rebindable -> dsExpr expr -- Note [Literal short cut] - _ -> dsExpr witness -dsOverLit (XOverLit nec) = noExtCon nec -{- -Note [Literal short cut] -~~~~~~~~~~~~~~~~~~~~~~~~ -The type checker tries to do this short-cutting as early as possible, but -because of unification etc, more information is available to the desugarer. -And where it's possible to generate the correct literal right away, it's -much better to do so. - - -************************************************************************ -* * - Warnings about overflowed literals -* * -************************************************************************ - -Warn about functions like toInteger, fromIntegral, that convert -between one type and another when the to- and from- types are the -same. Then it's probably (albeit not definitely) the identity --} - -warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM () -warnAboutIdentities dflags (Var conv_fn) type_of_conv - | wopt Opt_WarnIdentities dflags - , idName conv_fn `elem` conversionNames - , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv - , arg_ty `eqType` res_ty -- So we are converting ty -> ty - = warnDs (Reason Opt_WarnIdentities) - (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv - , nest 2 $ text "can probably be omitted" - ]) -warnAboutIdentities _ _ _ = return () - -conversionNames :: [Name] -conversionNames - = [ toIntegerName, toRationalName - , fromIntegralName, realToFracName ] - -- We can't easily add fromIntegerName, fromRationalName, - -- because they are generated by literals - - --- | Emit warnings on overloaded integral literals which overflow the bounds --- implied by their type. -warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM () -warnAboutOverflowedOverLit hsOverLit = do - dflags <- getDynFlags - warnAboutOverflowedLiterals dflags (getIntegralLit hsOverLit) - --- | Emit warnings on integral literals which overflow the bounds implied by --- their type. -warnAboutOverflowedLit :: HsLit GhcTc -> DsM () -warnAboutOverflowedLit hsLit = do - dflags <- getDynFlags - warnAboutOverflowedLiterals dflags (getSimpleIntegralLit hsLit) - --- | Emit warnings on integral literals which overflow the bounds implied by --- their type. -warnAboutOverflowedLiterals - :: DynFlags - -> Maybe (Integer, Name) -- ^ the literal value and name of its tycon - -> DsM () -warnAboutOverflowedLiterals dflags lit - | wopt Opt_WarnOverflowedLiterals dflags - , Just (i, tc) <- lit - = if tc == intTyConName then check i tc (Proxy :: Proxy Int) - - -- These only show up via the 'HsOverLit' route - else if tc == int8TyConName then check i tc (Proxy :: Proxy Int8) - else if tc == int16TyConName then check i tc (Proxy :: Proxy Int16) - else if tc == int32TyConName then check i tc (Proxy :: Proxy Int32) - else if tc == int64TyConName then check i tc (Proxy :: Proxy Int64) - else if tc == wordTyConName then check i tc (Proxy :: Proxy Word) - else if tc == word8TyConName then check i tc (Proxy :: Proxy Word8) - else if tc == word16TyConName then check i tc (Proxy :: Proxy Word16) - else if tc == word32TyConName then check i tc (Proxy :: Proxy Word32) - else if tc == word64TyConName then check i tc (Proxy :: Proxy Word64) - else if tc == naturalTyConName then checkPositive i tc - - -- These only show up via the 'HsLit' route - else if tc == intPrimTyConName then check i tc (Proxy :: Proxy Int) - else if tc == int8PrimTyConName then check i tc (Proxy :: Proxy Int8) - else if tc == int32PrimTyConName then check i tc (Proxy :: Proxy Int32) - else if tc == int64PrimTyConName then check i tc (Proxy :: Proxy Int64) - else if tc == wordPrimTyConName then check i tc (Proxy :: Proxy Word) - else if tc == word8PrimTyConName then check i tc (Proxy :: Proxy Word8) - else if tc == word32PrimTyConName then check i tc (Proxy :: Proxy Word32) - else if tc == word64PrimTyConName then check i tc (Proxy :: Proxy Word64) - - else return () - - | otherwise = return () - where - - checkPositive :: Integer -> Name -> DsM () - checkPositive i tc - = when (i < 0) $ do - warnDs (Reason Opt_WarnOverflowedLiterals) - (vcat [ text "Literal" <+> integer i - <+> text "is negative but" <+> ppr tc - <+> ptext (sLit "only supports positive numbers") - ]) - - check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM () - check i tc _proxy - = when (i < minB || i > maxB) $ do - warnDs (Reason Opt_WarnOverflowedLiterals) - (vcat [ text "Literal" <+> integer i - <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range") - <+> integer minB <> text ".." <> integer maxB - , sug ]) - where - minB = toInteger (minBound :: a) - maxB = toInteger (maxBound :: a) - sug | minB == -i -- Note [Suggest NegativeLiterals] - , i > 0 - , not (xopt LangExt.NegativeLiterals dflags) - = text "If you are trying to write a large negative literal, use NegativeLiterals" - | otherwise = Outputable.empty - -{- -Note [Suggest NegativeLiterals] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If you write - x :: Int8 - x = -128 -it'll parse as (negate 128), and overflow. In this case, suggest NegativeLiterals. -We get an erroneous suggestion for - x = 128 -but perhaps that does not matter too much. --} - -warnAboutEmptyEnumerations :: DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc) - -> LHsExpr GhcTc -> DsM () --- ^ Warns about @[2,3 .. 1]@ which returns the empty list. --- Only works for integral types, not floating point. -warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr - | wopt Opt_WarnEmptyEnumerations dflags - , Just (from,tc) <- getLHsIntegralLit fromExpr - , Just mThn <- traverse getLHsIntegralLit mThnExpr - , Just (to,_) <- getLHsIntegralLit toExpr - , let check :: forall a. (Enum a, Num a) => Proxy a -> DsM () - check _proxy - = when (null enumeration) $ - warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty") - where - enumeration :: [a] - enumeration = case mThn of - Nothing -> [fromInteger from .. fromInteger to] - Just (thn,_) -> [fromInteger from, fromInteger thn .. fromInteger to] - - = if tc == intTyConName then check (Proxy :: Proxy Int) - else if tc == int8TyConName then check (Proxy :: Proxy Int8) - else if tc == int16TyConName then check (Proxy :: Proxy Int16) - else if tc == int32TyConName then check (Proxy :: Proxy Int32) - else if tc == int64TyConName then check (Proxy :: Proxy Int64) - else if tc == wordTyConName then check (Proxy :: Proxy Word) - else if tc == word8TyConName then check (Proxy :: Proxy Word8) - else if tc == word16TyConName then check (Proxy :: Proxy Word16) - else if tc == word32TyConName then check (Proxy :: Proxy Word32) - else if tc == word64TyConName then check (Proxy :: Proxy Word64) - else if tc == integerTyConName then check (Proxy :: Proxy Integer) - else if tc == naturalTyConName then check (Proxy :: Proxy Integer) - -- We use 'Integer' because otherwise a negative 'Natural' literal - -- could cause a compile time crash (instead of a runtime one). - -- See the T10930b test case for an example of where this matters. - else return () - - | otherwise = return () - -getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name) --- ^ See if the expression is an 'Integral' literal. --- Remember to look through automatically-added tick-boxes! (#8384) -getLHsIntegralLit (L _ (HsPar _ e)) = getLHsIntegralLit e -getLHsIntegralLit (L _ (HsTick _ _ e)) = getLHsIntegralLit e -getLHsIntegralLit (L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e -getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit -getLHsIntegralLit (L _ (HsLit _ lit)) = getSimpleIntegralLit lit -getLHsIntegralLit _ = Nothing - --- | If 'Integral', extract the value and type name of the overloaded literal. -getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name) -getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty }) - | Just tc <- tyConAppTyCon_maybe ty - = Just (il_value i, tyConName tc) -getIntegralLit _ = Nothing - --- | If 'Integral', extract the value and type name of the non-overloaded --- literal. -getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Name) -getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTyConName) -getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTyConName) -getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTyConName) -getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTyConName) -getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTyConName) -getSimpleIntegralLit (HsInteger _ i ty) - | Just tc <- tyConAppTyCon_maybe ty - = Just (i, tyConName tc) -getSimpleIntegralLit _ = Nothing - -{- -************************************************************************ -* * - Tidying lit pats -* * -************************************************************************ --} - -tidyLitPat :: HsLit GhcTc -> Pat GhcTc --- Result has only the following HsLits: --- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim --- HsDoublePrim, HsStringPrim, HsString --- * HsInteger, HsRat, HsInt can't show up in LitPats --- * We get rid of HsChar right here -tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c) -tidyLitPat (HsString src s) - | lengthFS s <= 1 -- Short string literals only - = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon - [mkCharLitPat src c, pat] [charTy]) - (mkNilPat charTy) (unpackFS s) - -- The stringTy is the type of the whole pattern, not - -- the type to instantiate (:) or [] with! -tidyLitPat lit = LitPat noExtField lit - ----------------- -tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc - -> Type - -> Pat GhcTc -tidyNPat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty - -- False: Take short cuts only if the literal is not using rebindable syntax - -- - -- Once that is settled, look for cases where the type of the - -- entire overloaded literal matches the type of the underlying literal, - -- and in that case take the short cut - -- NB: Watch out for weird cases like #3382 - -- f :: Int -> Int - -- f "blah" = 4 - -- which might be ok if we have 'instance IsString Int' - -- - | not type_change, isIntTy ty, Just int_lit <- mb_int_lit - = mk_con_pat intDataCon (HsIntPrim NoSourceText int_lit) - | not type_change, isWordTy ty, Just int_lit <- mb_int_lit - = mk_con_pat wordDataCon (HsWordPrim NoSourceText int_lit) - | not type_change, isStringTy ty, Just str_lit <- mb_str_lit - = tidyLitPat (HsString NoSourceText str_lit) - -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3 - -- If we do convert to the constructor form, we'll generate a case - -- expression on a Float# or Double# and that's not allowed in Core; see - -- #9238 and Note [Rules for floating-point comparisons] in PrelRules - where - -- Sometimes (like in test case - -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include - -- type-changing wrappers (for example, from Id Int to Int, for the identity - -- type family Id). In these cases, we can't do the short-cut. - type_change = not (outer_ty `eqType` ty) - - mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc - mk_con_pat con lit - = unLoc (mkPrefixConPat con [noLoc $ LitPat noExtField lit] []) - - mb_int_lit :: Maybe Integer - mb_int_lit = case (mb_neg, val) of - (Nothing, HsIntegral i) -> Just (il_value i) - (Just _, HsIntegral i) -> Just (-(il_value i)) - _ -> Nothing - - mb_str_lit :: Maybe FastString - mb_str_lit = case (mb_neg, val) of - (Nothing, HsIsString _ s) -> Just s - _ -> Nothing - -tidyNPat over_lit mb_neg eq outer_ty - = NPat outer_ty (noLoc over_lit) mb_neg eq - -{- -************************************************************************ -* * - Pattern matching on LitPat -* * -************************************************************************ --} - -matchLiterals :: NonEmpty Id - -> Type -- ^ Type of the whole case expression - -> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits - -> DsM MatchResult - -matchLiterals (var :| vars) ty sub_groups - = do { -- Deal with each group - ; alts <- mapM match_group sub_groups - - -- Combine results. For everything except String - -- we can use a case expression; for String we need - -- a chain of if-then-else - ; if isStringTy (idType var) then - do { eq_str <- dsLookupGlobalId eqStringName - ; mrs <- mapM (wrap_str_guard eq_str) alts - ; return (foldr1 combineMatchResults mrs) } - else - return (mkCoPrimCaseMatchResult var ty $ NEL.toList alts) - } - where - match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult) - match_group eqns@(firstEqn :| _) - = do { dflags <- getDynFlags - ; let LitPat _ hs_lit = firstPat firstEqn - ; match_result <- match vars ty (NEL.toList $ shiftEqns eqns) - ; return (hsLitKey dflags hs_lit, match_result) } - - wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult - -- Equality check for string literals - wrap_str_guard eq_str (LitString s, mr) - = do { -- We now have to convert back to FastString. Perhaps there - -- should be separate LitBytes and LitString constructors? - let s' = mkFastStringByteString s - ; lit <- mkStringExprFS s' - ; let pred = mkApps (Var eq_str) [Var var, lit] - ; return (mkGuardedMatchResult pred mr) } - wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l) - - ---------------------------- -hsLitKey :: DynFlags -> HsLit GhcTc -> Literal --- Get the Core literal corresponding to a HsLit. --- It only works for primitive types and strings; --- others have been removed by tidy --- For HsString, it produces a LitString, which really represents an _unboxed_ --- string literal; and we deal with it in matchLiterals above. Otherwise, it --- produces a primitive Literal of type matching the original HsLit. --- In the case of the fixed-width numeric types, we need to wrap here --- because Literal has an invariant that the literal is in range, while --- HsLit does not. -hsLitKey dflags (HsIntPrim _ i) = mkLitIntWrap dflags i -hsLitKey dflags (HsWordPrim _ w) = mkLitWordWrap dflags w -hsLitKey dflags (HsInt64Prim _ i) = mkLitInt64Wrap dflags i -hsLitKey dflags (HsWord64Prim _ w) = mkLitWord64Wrap dflags w -hsLitKey _ (HsCharPrim _ c) = mkLitChar c -hsLitKey _ (HsFloatPrim _ f) = mkLitFloat (fl_value f) -hsLitKey _ (HsDoublePrim _ d) = mkLitDouble (fl_value d) -hsLitKey _ (HsString _ s) = LitString (bytesFS s) -hsLitKey _ l = pprPanic "hsLitKey" (ppr l) - -{- -************************************************************************ -* * - Pattern matching on NPat -* * -************************************************************************ --} - -matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult -matchNPats (var :| vars) ty (eqn1 :| eqns) -- All for the same literal - = do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1 - ; lit_expr <- dsOverLit lit - ; neg_lit <- case mb_neg of - Nothing -> return lit_expr - Just neg -> dsSyntaxExpr neg [lit_expr] - ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit] - ; match_result <- match vars ty (shiftEqns (eqn1:eqns)) - ; return (mkGuardedMatchResult pred_expr match_result) } - -{- -************************************************************************ -* * - Pattern matching on n+k patterns -* * -************************************************************************ - -For an n+k pattern, we use the various magic expressions we've been given. -We generate: -\begin{verbatim} - if ge var lit then - let n = sub var lit - in - else - -\end{verbatim} --} - -matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult --- All NPlusKPats, for the *same* literal k -matchNPlusKPats (var :| vars) ty (eqn1 :| eqns) - = do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus - = firstPat eqn1 - ; lit1_expr <- dsOverLit lit1 - ; lit2_expr <- dsOverLit lit2 - ; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr] - ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr] - ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns) - ; match_result <- match vars ty eqns' - ; return (mkGuardedMatchResult pred_expr $ - mkCoLetMatchResult (NonRec n1 minusk_expr) $ - adjustMatchResult (foldr1 (.) wraps) $ - match_result) } - where - shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats }) - = (wrapBind n n1, eqn { eqn_pats = pats }) - -- The wrapBind is a no-op for the first equation - shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 75172c32a0..2f27d7d116 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -164,7 +164,6 @@ Library basicTypes cmm coreSyn - deSugar iface llvmGen main @@ -324,22 +323,22 @@ Library GHC.HsToCore.PmCheck.Ppr GHC.HsToCore.PmCheck.Types GHC.HsToCore.PmCheck - Coverage - Desugar - DsArrows - DsBinds - DsCCall - DsExpr - DsForeign - DsGRHSs - DsListComp - DsMonad - DsUsage - DsUtils - ExtractDocs - Match - MatchCon - MatchLit + GHC.HsToCore.Coverage + GHC.HsToCore + GHC.HsToCore.Arrows + GHC.HsToCore.Binds + GHC.HsToCore.Foreign.Call + GHC.HsToCore.Expr + GHC.HsToCore.Foreign.Decl + GHC.HsToCore.GuardedRHSs + GHC.HsToCore.ListComp + GHC.HsToCore.Monad + GHC.HsToCore.Usage + GHC.HsToCore.Utils + GHC.HsToCore.Docs + GHC.HsToCore.Match + GHC.HsToCore.Match.Constructor + GHC.HsToCore.Match.Literal GHC.Hs GHC.Hs.Binds GHC.Hs.Decls @@ -526,7 +525,7 @@ Library TcSplice Class Coercion - DsMeta + GHC.HsToCore.Quote THNames FamInstEnv FunDeps diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 5db264254c..6fbf019456 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -965,7 +965,7 @@ runPhase (RealPhase (Unlit sf)) input_fn dflags -- escape the characters \, ", and ', but don't try to escape -- Unicode or anything else (so we don't use Util.charToC -- here). If we get this wrong, then in - -- Coverage.isGoodTickSrcSpan where we check that the filename in + -- GHC.HsToCore.Coverage.isGoodTickSrcSpan where we check that the filename in -- a SrcLoc is the same as the source filenaame, the two will -- look bogusly different. See test: -- libraries/hpc/tests/function/subdir/tough2.hs @@ -2308,7 +2308,7 @@ Introduction 4) -fhpc At some point during compilation with -fhpc, in the function - `deSugar.Coverage.isGoodTickSrcSpan`, we compare the filename that a + `GHC.HsToCore.Coverage.isGoodTickSrcSpan`, we compare the filename that a `SrcSpan` refers to with the name of the file we are currently compiling. For some reason I don't yet understand, they can sometimes legitimally be different, and then hpc ignores that SrcSpan. diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 8e7a9db87a..aa4a6a4875 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -120,7 +120,7 @@ import NameCache ( initNameCache ) import GHC.Iface.Load ( ifaceStats, initExternalPackageState ) import PrelInfo import GHC.Iface.Utils -import Desugar +import GHC.HsToCore import SimplCore import GHC.Iface.Tidy import GHC.CoreToStg.Prep diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 33f827e2c6..223b566031 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -2326,7 +2326,7 @@ class Monad m => MonadThings m where lookupTyCon :: Name -> m TyCon lookupTyCon = liftM tyThingTyCon . lookupThing --- Instance used in DsMeta +-- Instance used in GHC.HsToCore.Quote instance MonadThings m => MonadThings (ReaderT s m) where lookupThing = lift . lookupThing @@ -3237,7 +3237,7 @@ for the same TyCon: And looking up the values in the CompleteMatchMap associated with Boolean would give you [CompleteMatch [F, T1] Boolean, CompleteMatch [F, T2] Boolean]. -dsGetCompleteMatches in DsMeta accomplishes this lookup. +dsGetCompleteMatches in GHC.HsToCore.Quote accomplishes this lookup. Also see Note [Typechecking Complete Matches] in TcBinds for a more detailed explanation for how GHC ensures that all the conlikes in a COMPLETE set are diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs index 0da1c5200a..4b38dbc39a 100644 --- a/compiler/prelude/THNames.hs +++ b/compiler/prelude/THNames.hs @@ -24,7 +24,7 @@ import FastString templateHaskellNames :: [Name] -- The names that are implicitly mentioned by ``bracket'' --- Should stay in sync with the import list of DsMeta +-- Should stay in sync with the import list of GHC.HsToCore.Quote templateHaskellNames = [ returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName, @@ -562,7 +562,7 @@ decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [De typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey patQTyConName = libTc (fsLit "PatQ") patQTyConKey --- These are used in DsMeta but always wrapped in a type variable +-- These are used in GHC.HsToCore.Quote but always wrapped in a type variable stmtTyConName = thTc (fsLit "Stmt") stmtTyConKey conTyConName = thTc (fsLit "Con") conTyConKey bangTypeTyConName = thTc (fsLit "BangType") bangTypeTyConKey diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index bec29ebc76..a14fcc0732 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -702,7 +702,7 @@ Note [One-tuples] GHC supports both boxed and unboxed one-tuples: - Unboxed one-tuples are sometimes useful when returning a single value after CPR analysis - - A boxed one-tuple is used by DsUtils.mkSelectorBinds, when + - A boxed one-tuple is used by GHC.HsToCore.Utils.mkSelectorBinds, when there is just one binder Basically it keeps everything uniform. diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs index 6e391d3fe2..f90ffea54d 100644 --- a/compiler/specialise/Rules.hs +++ b/compiler/specialise/Rules.hs @@ -75,7 +75,7 @@ Note [Overall plumbing for rules] locally-declared rules for imported Ids. - Locally-declared rules for locally-declared Ids are attached to the IdInfo for that Id. See Note [Attach rules to local ids] in - DsBinds + GHC.HsToCore.Binds * GHC.Iface.Tidy strips off all the rules from local Ids and adds them to mg_rules, so that the ModGuts has *all* the locally-declared rules. diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index 557ca5e2fe..f60405e8be 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -212,7 +212,7 @@ data HsWrapper -- The TcType is the "from" type of the first wrapper -- The SDoc explains the circumstances under which we have created this -- WpFun, in case we run afoul of levity polymorphism restrictions in - -- the desugarer. See Note [Levity polymorphism checking] in DsMonad + -- the desugarer. See Note [Levity polymorphism checking] in GHC.HsToCore.Monad | WpCast TcCoercionR -- A cast: [] `cast` co -- Guaranteed not the identity coercion @@ -782,7 +782,7 @@ Important Details: - An EvCallStack term desugars to a CoreExpr of type `IP "some str" CallStack`. The desugarer will need to unwrap the IP newtype before pushing a new - call-site onto a given stack (See DsBinds.dsEvCallStack) + call-site onto a given stack (See GHC.HsToCore.Binds.dsEvCallStack) - When we emit a new wanted CallStack from rule (2) we set its origin to `IPOccOrigin ip_name` instead of the original `OccurrenceOf func` diff --git a/compiler/typecheck/TcHoleErrors.hs b/compiler/typecheck/TcHoleErrors.hs index ba8fa30eb1..1008bc760c 100644 --- a/compiler/typecheck/TcHoleErrors.hs +++ b/compiler/typecheck/TcHoleErrors.hs @@ -51,7 +51,7 @@ import Data.Graph ( graphFromEdges, topSort ) import TcSimplify ( simpl_top, runTcSDeriveds ) import TcUnify ( tcSubType_NC ) -import ExtractDocs ( extractDocs ) +import GHC.HsToCore.Docs ( extractDocs ) import qualified Data.Map as Map import GHC.Hs.Doc ( unpackHDS, DeclDocMap(..) ) import HscTypes ( ModIface_(..) ) diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 3ae4e63fc6..ea533d578e 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -1895,7 +1895,7 @@ zonkTcMethInfoToMethInfoX ze (name, ty, gdm_spec) --------------------------------------- {- Note [Zonking the LHS of a RULE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also DsBinds Note [Free tyvars on rule LHS] +See also GHC.HsToCore.Binds Note [Free tyvars on rule LHS] We need to gather the type variables mentioned on the LHS so we can quantify over them. Example: @@ -1918,7 +1918,7 @@ We do this in two stages. ZonkEnv. (This is in fact the whole reason that the ZonkEnv has a UnboundTyVarZonker.) -* In DsBinds, we quantify over it. See DsBinds +* In GHC.HsToCore.Binds, we quantify over it. See GHC.HsToCore.Binds Note [Free tyvars on rule LHS] Quantifying here is awkward because (a) the data type is big and (b) diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 96775696a9..21e1ba81ba 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -1163,7 +1163,7 @@ addDFunPrags dfun_id sc_meth_ids con_app = mkLams dfun_bndrs $ mkApps (Var (dataConWrapId dict_con)) dict_args -- mkApps is OK because of the checkForLevPoly call in checkValidClass - -- See Note [Levity polymorphism checking] in DsMonad + -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad dict_args = map Type inst_tys ++ [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids] diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index 52599c925c..85a59b697a 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -2333,7 +2333,7 @@ tidySigSkol env cx ty tv_prs * * ************************************************************************* -See Note [Levity polymorphism checking] in DsMonad +See Note [Levity polymorphism checking] in GHC.HsToCore.Monad -} @@ -2354,7 +2354,7 @@ ensureNotLevPoly ty doc -- forall a. a. See, for example, test ghci/scripts/T9140 checkForLevPoly doc ty - -- See Note [Levity polymorphism checking] in DsMonad + -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad checkForLevPoly :: SDoc -> Type -> TcM () checkForLevPoly = checkForLevPolyX addErr diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index ff90b473b2..129a0e5f10 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -1093,7 +1093,7 @@ Note [Record PatSyn Desugaring] It is important that prov_theta comes before req_theta as this ordering is used when desugaring record pattern synonym updates. -Any change to this ordering should make sure to change deSugar/DsExpr.hs if you +Any change to this ordering should make sure to change GHC.HsToCore.Expr if you want to avoid difficult to decipher core lint errors! -} diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 4bf9ad90cf..d346020963 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -242,7 +242,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this -- We want to serialize the documentation in the .hi-files, -- and need to extract it from the renamed syntax first. - -- See 'ExtractDocs.extractDocs'. + -- See 'GHC.HsToCore.Docs.extractDocs'. | gopt Opt_Haddock dflags = Just empty_val | keep_rn_syntax = Just empty_val diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs index 1e284ec0a7..3558ebd733 100644 --- a/compiler/typecheck/TcSigs.hs +++ b/compiler/typecheck/TcSigs.hs @@ -668,7 +668,7 @@ Note that -From the TcSpecPrag, in DsBinds we generate a binding for f_spec and a RULE: +From the TcSpecPrag, in GHC.HsToCore.Binds we generate a binding for f_spec and a RULE: f_spec :: Int -> b -> Int f_spec = wrap diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 485948a5a3..ea848d391f 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -99,8 +99,8 @@ import DataCon import TcEvidence import Id import IdInfo -import DsExpr -import DsMonad +import GHC.HsToCore.Expr +import GHC.HsToCore.Monad import GHC.Serialized import ErrUtils import Util @@ -179,7 +179,7 @@ tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty ; m_var <- mkTyVarTy <$> mkMetaTyVar -- Make sure the type variable satisfies Quote ; ev_var <- emitQuoteWanted m_var - -- Bundle them together so they can be used in DsMeta for desugaring + -- Bundle them together so they can be used in GHC.HsToCore.Quote for desugaring -- brackets. ; let wrapper = QuoteWrapper ev_var m_var -- Typecheck expr to make sure it is valid, @@ -380,7 +380,7 @@ The life cycle of a un-typed bracket: In both cases, desugaring happens like this: - * HsTcBracketOut is desugared by DsMeta.dsBracket. It + * HsTcBracketOut is desugared by GHC.HsToCore.Quote.dsBracket. It a) Extends the ds_meta environment with the PendingSplices attached to the bracket @@ -395,10 +395,10 @@ In both cases, desugaring happens like this: ${n}(e). The name is initialised to an (Unqual "splice") when the splice is created; the renamer gives it a unique. - * When DsMeta (used to desugar the body of the bracket) comes across + * When GHC.HsToCore.Quote (used to desugar the body of the bracket) comes across a splice, it looks up the splice's Name, n, in the ds_meta envt, to find an (HsExpr Id) that should be substituted for the splice; - it just desugars it to get a CoreExpr (DsMeta.repSplice). + it just desugars it to get a CoreExpr (GHC.HsToCore.Quote.repSplice). Example: Source: f = [| Just $(g 3) |] @@ -511,7 +511,7 @@ returned together in a `QuoteWrapper` and then passed along to two further place during compilation: 1. Typechecking nested splices (immediately in tcPendingSplice) -2. Desugaring quotations (see DsMeta) +2. Desugaring quotations (see GHC.HsToCore.Quote) `tcPendingSplice` takes the `m` type variable as an argument and checks each nested splice against this variable `m`. During this diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 3048d6178d..da4cbdb981 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -3956,7 +3956,7 @@ checkValidClass cls -- method in a dictionary -- example of what this prevents: -- class BoundedX (a :: TYPE r) where minBound :: a - -- See Note [Levity polymorphism checking] in DsMonad + -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad ; checkForLevPoly empty tau1 ; unless constrained_class_methods $ diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs index 8302c2ba4f..81e5f4db6f 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -32,7 +32,7 @@ import Prelude hiding (mod,(<>)) import System.Directory import qualified CoreUtils -import Desugar +import GHC.HsToCore import DynFlags (HasDynFlags(..)) import FastString import GHC diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 0abe15f3ea..18300c2d46 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -677,8 +677,9 @@ instance Quasi Q where ---------------------------------------------------- --- The following operations are used solely in DsMeta when desugaring brackets --- They are not necessary for the user, who can use ordinary return and (>>=) etc +-- The following operations are used solely in GHC.HsToCore.Quote when +-- desugaring brackets. They are not necessary for the user, who can use +-- ordinary return and (>>=) etc sequenceQ :: forall m . Monad m => forall a . [m a] -> m [a] sequenceQ = sequence -- cgit v1.2.1