#include "HsVersions.h"
-import CmdLineOpts ( DynFlag(..), DynFlags(..), dopt, opt_SccProfilingOn )
+import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
+import StaticFlags ( opt_SccProfilingOn )
import DriverPhases ( isHsBoot )
-import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), GhciMode(..),
+import HscTypes ( ModGuts(..), HscEnv(..),
Dependencies(..), TypeEnv, IsBootInterface )
-import HsSyn ( RuleDecl(..), RuleBndr(..), HsExpr(..), LHsExpr,
- HsBindGroup(..), LRuleDecl, HsBind(..) )
+import HsSyn ( RuleDecl(..), RuleBndr(..), LHsExpr, LRuleDecl )
import TcRnTypes ( TcGblEnv(..), ImportAvails(..) )
import MkIface ( mkUsageInfo )
-import Id ( Id, setIdExported, idName, idIsFrom )
-import Name ( Name, isExternalName )
+import Id ( Id, setIdExported, idName )
+import Name ( Name, isExternalName, nameIsLocalOrFrom, nameOccName )
import CoreSyn
-import PprCore ( pprIdRules, pprCoreExpr )
-import CoreSubst ( substExpr, mkSubst )
+import PprCore ( pprRules, pprCoreExpr )
import DsMonad
import DsExpr ( dsLExpr )
-import DsBinds ( dsHsBinds, AutoScc(..) )
+import DsBinds ( dsTopLHsBinds, decomposeRuleLhs, AutoScc(..) )
import DsForeign ( dsForeigns )
import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
-- depends on DsExpr.hi-boot.
import Module ( Module, moduleEnvElts, delModuleEnv, moduleFS )
-import Id ( Id )
import RdrName ( GlobalRdrEnv )
import NameSet
-import VarEnv
import VarSet
-import Bag ( Bag, isEmptyBag, emptyBag, bagToList )
+import Bag ( Bag, isEmptyBag, emptyBag )
+import Rules ( roughTopNames )
import CoreLint ( showPass, endPass )
-import CoreFVs ( ruleRhsFreeVars )
+import CoreFVs ( ruleRhsFreeVars, exprsFreeNames )
import Packages ( PackageState(thPackageId), PackageIdH(..) )
import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings,
errorsFound, WarnMsg )
import ListSetOps ( insertList )
import Outputable
import UniqSupply ( mkSplitUniqSupply )
-import SrcLoc ( Located(..), unLoc )
+import SrcLoc ( Located(..) )
import DATA_IOREF ( readIORef )
+import Maybes ( catMaybes )
import FastString
import Util ( sortLe )
\end{code}
tcg_src = hsc_src,
tcg_type_env = type_env,
tcg_imports = imports,
+ tcg_home_mods = home_mods,
tcg_exports = exports,
tcg_dus = dus,
tcg_inst_uses = dfun_uses_var,
-- Desugar the program
; ((all_prs, ds_rules, ds_fords), warns)
<- initDs hsc_env mod rdr_env type_env $ do
- { core_prs <- dsHsBinds auto_scc binds []
+ { core_prs <- dsTopLHsBinds auto_scc binds
; (ds_fords, foreign_prs) <- dsForeigns fords
; let all_prs = foreign_prs ++ core_prs
local_bndrs = mkVarSet (map fst all_prs)
; ds_rules <- mappM (dsRule mod local_bndrs) rules
- ; return (all_prs, ds_rules, ds_fords) }
-
-
+ ; return (all_prs, catMaybes ds_rules, ds_fords) }
-- If warnings are considered errors, leave.
; if errorsFound dflags (warns, emptyBag)
dir_imp_mods = imp_mods imports
- ; usages <- mkUsageInfo hsc_env dir_imp_mods dep_mods used_names
+ ; usages <- mkUsageInfo hsc_env home_mods dir_imp_mods dep_mods used_names
; let
-- Modules don't compare lexicographically usually,
mg_boot = isHsBoot hsc_src,
mg_exports = exports,
mg_deps = deps,
+ mg_home_mods = home_mods,
mg_usages = usages,
mg_dir_imps = [m | (m,_,_) <- moduleEnvElts dir_imp_mods],
mg_rdr_env = rdr_env,
where
dflags = hsc_dflags hsc_env
- ghci_mode = hsc_mode hsc_env
+ ghci_mode = ghcMode (hsc_dflags hsc_env)
auto_scc | opt_SccProfilingOn = TopLevel
| otherwise = NoSccs
| otherwise = bndr
orph_rhs_fvs = unionVarSets [ ruleRhsFreeVars rule
- | IdCoreRule _ is_orphan_rule rule <- rules,
- is_orphan_rule ]
- -- An orphan rule keeps alive the free vars of its right-hand side.
- -- Non-orphan rules are (later, after gentle simplification)
- -- attached to the Id and that keeps the rhs free vars alive
+ | rule <- rules,
+ not (isLocalRule rule) ]
+ -- A non-local rule keeps alive the free vars of its right-hand side.
+ -- (A "non-local" is one whose head function is not locally defined.)
+ -- Local rules are (later, after gentle simplification)
+ -- attached to the Id, and that keeps the rhs free vars alive.
dont_discard bndr = is_exported name
|| name `elemNameSet` keep_alive
ppr_ds_rules [] = empty
ppr_ds_rules rules
= text "" $$ text "-------------- DESUGARED RULES -----------------" $$
- pprIdRules rules
+ pprRules rules
\end{code}
%************************************************************************
\begin{code}
-dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM IdCoreRule
+dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM (Maybe CoreRule)
dsRule mod in_scope (L loc (HsRule name act vars lhs rhs))
= putSrcSpanDs loc $
- ds_lhs all_vars lhs `thenDs` \ (fn, args) ->
- dsLExpr rhs `thenDs` \ core_rhs ->
- returnDs (IdCoreRule fn (is_orphan fn) (Rule name act tpl_vars args core_rhs))
- where
- tpl_vars = [var | RuleBndr (L _ var) <- vars]
- all_vars = mkInScopeSet (extendVarSetList in_scope tpl_vars)
- is_orphan id = not (idIsFrom mod id)
- -- NB we can't use isLocalId in the orphan test,
- -- because isLocalId isn't true of class methods
-
-ds_lhs all_vars lhs
- = let
- (dict_binds, body) =
- case unLoc lhs of
- (HsLet [HsBindGroup dict_binds _ _] body) -> (dict_binds, body)
- other -> (emptyBag, lhs)
- in
- mappM ds_dict_bind (bagToList dict_binds) `thenDs` \ dict_binds' ->
- dsLExpr body `thenDs` \ body' ->
+ do { let bndrs = [var | RuleBndr (L _ var) <- vars]
+ ; lhs' <- dsLExpr lhs
+ ; rhs' <- dsLExpr rhs
+ ; case decomposeRuleLhs bndrs lhs' of {
+ Nothing -> do { dsWarn msg; return Nothing } ;
+ Just (bndrs', fn_id, args) -> do
+
-- Substitute the dict bindings eagerly,
-- and take the body apart into a (f args) form
- let
- subst = mkSubst all_vars emptyVarEnv (mkVarEnv id_pairs)
- id_pairs = [(id, substExpr subst rhs) | (id,rhs) <- dict_binds']
- -- Note recursion here... substitution won't terminate
- -- if there is genuine recursion... which there isn't
-
- body'' = substExpr subst body'
- in
-
- -- Now unpack the resulting body
- let
- pair = case collectArgs body'' of
- (Var fn, args) -> (fn, args)
- other -> pprPanic "dsRule" (ppr lhs)
- in
- returnDs pair
-
-ds_dict_bind (L _ (VarBind id rhs)) =
- dsLExpr rhs `thenDs` \ rhs' ->
- returnDs (id,rhs')
+ { let local_rule = nameIsLocalOrFrom mod fn_name
+ -- NB we can't use isLocalId in the orphan test,
+ -- because isLocalId isn't true of class methods
+ fn_name = idName fn_id
+ lhs_names = fn_name : nameSetToList (exprsFreeNames args)
+ -- No need to delete bndrs, because
+ -- exprsFreeNames finds only External names
+ orph = case filter (nameIsLocalOrFrom mod) lhs_names of
+ (n:ns) -> Just (nameOccName n)
+ [] -> Nothing
+
+ rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act,
+ ru_bndrs = bndrs', ru_args = args, ru_rhs = rhs',
+ ru_rough = roughTopNames args,
+ ru_local = local_rule, ru_orph = orph }
+ ; return (Just rule)
+ } } }
+ where
+ msg = hang (ptext SLIT("RULE left-hand side too complicated to desugar; ignored"))
+ 2 (ppr lhs)
\end{code}
projects / ghc-hetmet.git / blobdiff