module Desugar (
deSugar, deSugarExpr
) where
#include "HsVersions.h"
import GhcPrelude
import DsUsage
import DynFlags
import HscTypes
import HsSyn
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(..) )
deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
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 (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 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 {
keep_alive <- readIORef keep_var
; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
final_prs = addExportFlagsAndRules target export_set keep_alive
mod rules_for_locals
(fromOL all_prs)
final_pgm = combineEvBinds ds_ev_binds final_prs
; 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
; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
; let used_names = mkUsedNames tcg_env
pluginModules =
map lpModule (plugins (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
; 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
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 GhcTc -> IO (Messages, Maybe CoreExpr)
deSugarExpr hsc_env tc_expr = do {
let dflags = hsc_dflags hsc_env
; showPass dflags "Desugar"
; (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"
(pprCoreExpr expr)
; return (msgs, mb_core_expr) }
addExportFlagsAndRules
:: HscTarget -> NameSet -> NameSet -> Module -> [CoreRule]
-> [(Id, t)] -> [(Id, t)]
addExportFlagsAndRules target exports keep_alive mod 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
|| isInteractiveModule mod = isExternalName
| otherwise = (`elemNameSet` exports)
dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
dsRule (L loc (HsRule _ name rule_act vars lhs 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'
; 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
fn_name = idName fn_id
final_rhs = simpleOptExpr dflags rhs''
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 _)) = panic "dsRule"
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)
, 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 ]
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)