module Desugar (
deSugar, deSugarExpr,
mkUsageInfo, mkUsedNames, mkDependencies
) where
#include "HsVersions.h"
import DynFlags
import HscTypes
import HsSyn
import TcRnTypes
import TcRnMonad ( finalSafeMode, fixSafeInstances )
import Id
import Name
import Type
import FamInstEnv
import InstEnv
import Class
import Avail
import CoreSyn
import CoreFVs( exprsSomeFreeVars )
import CoreSubst
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 StaticPtrTable
import UniqFM
import ListSetOps
import Fingerprint
import Maybes
import Data.Function
import Data.List
import Data.IORef
import Control.Monad( when )
import Data.Map (Map)
import qualified Data.Map as Map
mkDependencies :: TcGblEnv -> IO Dependencies
mkDependencies
TcGblEnv{ tcg_mod = mod,
tcg_imports = imports,
tcg_th_used = th_var
}
= do
th_used <- readIORef th_var
let dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
pkgs | th_used = insertList thUnitId (imp_dep_pkgs imports)
| otherwise = imp_dep_pkgs imports
sorted_pkgs = sortBy stableUnitIdCmp pkgs
trust_pkgs = imp_trust_pkgs imports
dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs
return Deps { dep_mods = sortBy (stableModuleNameCmp `on` fst) dep_mods,
dep_pkgs = dep_pkgs',
dep_orphs = sortBy stableModuleCmp (imp_orphs imports),
dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
mkUsedNames :: TcGblEnv -> NameSet
mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> IO [Usage]
mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files
= do
eps <- hscEPS hsc_env
hashes <- mapM getFileHash dependent_files
let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod
dir_imp_mods used_names
let usages = mod_usages ++ [ UsageFile { usg_file_path = f
, usg_file_hash = hash }
| (f, hash) <- zip dependent_files hashes ]
usages `seqList` return usages
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
ent_map :: ModuleEnv [OccName]
ent_map = foldNameSet add_mv emptyModuleEnv used_names
where
add_mv name mv_map
| isWiredInName name = mv_map
| otherwise
= case nameModule_maybe name of
Nothing -> ASSERT2( isSystemName name, ppr name ) mv_map
Just mod ->
extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod [occ]
where occ = nameOccName name
mkUsage :: Module -> Maybe Usage
mkUsage mod
| isNothing maybe_iface
|| mod == this_mod
= Nothing
| moduleUnitId mod /= this_pkg
= Just UsagePackageModule{ usg_mod = mod,
usg_mod_hash = mod_hash,
usg_safe = imp_safe }
| (null used_occs
&& isNothing export_hash
&& not is_direct_import
&& not finsts_mod)
= Nothing
| 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 dflags hpt pit mod
Just iface = maybe_iface
finsts_mod = mi_finsts iface
hash_env = mi_hash_fn iface
mod_hash = mi_mod_hash iface
export_hash | depend_on_exports = Just (mi_exp_hash iface)
| otherwise = Nothing
(is_direct_import, imp_safe)
= case lookupModuleEnv direct_imports mod of
Just (imv : _xs) -> (True, imv_is_safe imv)
Just _ -> pprPanic "mkUsage: empty direct import" Outputable.empty
Nothing -> (False, safeImplicitImpsReq dflags)
used_occs = lookupModuleEnv ent_map mod `orElse` []
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
deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
deSugar hsc_env
mod_loc
tcg_env@(TcGblEnv { tcg_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_warns = warns,
tcg_anns = anns,
tcg_binds = binds,
tcg_imp_specs = imp_specs,
tcg_dependent_files = dependent_files,
tcg_ev_binds = ev_binds,
tcg_fords = fords,
tcg_rules = rules,
tcg_vects = vects,
tcg_patsyns = patsyns,
tcg_tcs = tcs,
tcg_insts = insts,
tcg_fam_insts = fam_insts,
tcg_hpc = other_hpc_info})
= do { let dflags = hsc_dflags hsc_env
print_unqual = mkPrintUnqualified dflags rdr_env
; withTiming (pure dflags)
(text "Desugar"<+>brackets (ppr mod))
(const ()) $
do {
; 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 mod rdr_env type_env fam_inst_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
; ds_vects <- mapM dsVect vects
; stBinds <- dsGetStaticBindsVar >>=
liftIO . readIORef
; let hpc_init
| gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
| otherwise = empty
spt_init = sptInitCode mod stBinds
; return ( ds_ev_binds
, foreign_prs `appOL` core_prs `appOL` spec_prs
`appOL` toOL (map snd stBinds)
, spec_rules ++ ds_rules, ds_vects
, ds_fords `appendStubC` hpc_init
`appendStubC` spt_init) }
; case mb_res of {
Nothing -> return (msgs, Nothing) ;
Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) ->
do {
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
#ifdef DEBUG
; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
#endif
; (ds_binds, ds_rules_for_imps, ds_vects)
<- simpleOptPgm dflags mod final_pgm rules_for_imps vects0
; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
; let used_names = mkUsedNames tcg_env
; deps <- mkDependencies 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
; 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_hpc_info = ds_hpc_info,
mg_modBreaks = modBreaks,
mg_vect_decls = ds_vects,
mg_vect_info = noVectInfo,
mg_safe_haskell = safe_mode,
mg_trust_pkg = imp_trust_own_pkg imports
}
; 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
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]
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)
deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr)
deSugarExpr hsc_env tc_expr
= do { let dflags = hsc_dflags hsc_env
icntxt = hsc_IC hsc_env
rdr_env = ic_rn_gbl_env icntxt
type_env = mkTypeEnvWithImplicits (ic_tythings icntxt)
fam_insts = snd (ic_instances icntxt)
fam_inst_env = extendFamInstEnvList emptyFamInstEnv fam_insts
; showPass dflags "Desugar"
; (msgs, mb_core_expr) <- initDs hsc_env (icInteractiveModule icntxt) rdr_env
type_env fam_inst_env $
dsLExpr tc_expr
; case mb_core_expr of
Nothing -> return ()
Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
; return (msgs, mb_core_expr) }
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
add_rules name bndr
| Just rules <- lookupNameEnv rule_base name
= bndr `addIdSpecialisations` rules
| otherwise
= bndr
rule_base = extendRuleBaseList emptyRuleBase rules
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
is_exported :: Name -> Bool
is_exported | targetRetainsAllBindings target = isExternalName
| otherwise = (`elemNameSet` exports)
dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
= putSrcSpanDs loc $
do { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars]
; lhs' <- unsetGOptM Opt_EnableRewriteRules $
unsetWOptM Opt_WarnIdentities $
dsLExpr lhs
; rhs' <- dsLExpr rhs
; this_mod <- getModule
; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'
; case decomposeRuleLhs bndrs'' lhs'' of {
Left msg -> do { warnDs NoReason msg; return Nothing } ;
Right (final_bndrs, fn_id, args) -> do
{ let is_local = isLocalId fn_id
fn_name = idName fn_id
final_rhs = simpleOptExpr rhs''
rule_name = snd (unLoc name)
arg_ids = varSetElems (exprsSomeFreeVars isId args `delVarSetList` final_bndrs)
; dflags <- getDynFlags
; 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)
} } }
warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
warnRuleShadowing rule_name rule_act fn_id arg_ids
= do { check False fn_id
; mapM_ (check True) arg_ids }
where
check check_rules_too lhs_id
| isLocalId lhs_id || canUnfold (idUnfolding lhs_id)
, 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)
, ifPprDebug (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"
, ifPprDebug (ppr bad_rule) ])
| otherwise
= return ()
get_bad_rules lhs_id
= [ rule | rule <- idCoreRules lhs_id
, ruleActivation rule `competesWith` rule_act ]
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)
dsVect :: LVectDecl Id -> DsM CoreVect
dsVect (L loc (HsVect _ (L _ v) rhs))
= putSrcSpanDs loc $
do { rhs' <- dsLExpr rhs
; return $ Vect v rhs'
}
dsVect (L _loc (HsNoVect _ (L _ v)))
= return $ NoVect v
dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
= return $ VectType isScalar tycon' rhs_tycon
where
tycon' | Just ty <- coreView $ mkTyConTy tycon
, (tycon', []) <- splitTyConApp ty = tycon'
| otherwise = tycon
dsVect vd@(L _ (HsVectTypeIn _ _ _ _))
= pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
dsVect (L _loc (HsVectClassOut cls))
= return $ VectClass (classTyCon cls)
dsVect vc@(L _ (HsVectClassIn _ _))
= pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
dsVect (L _loc (HsVectInstOut inst))
= return $ VectInst (instanceDFunId inst)
dsVect vi@(L _ (HsVectInstIn _))
= pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)