diff options
Diffstat (limited to 'compiler/GHC/HsToCore.hs')
| -rw-r--r-- | compiler/GHC/HsToCore.hs | 545 |
1 files changed, 545 insertions, 0 deletions
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. +-} |