\begin{code}
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs,
- dsCoercion,
- AutoScc(..)
+ dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds,
+ DsEvBind(..), AutoScc(..)
) where
#include "HsVersions.h"
import CoreArity ( etaExpand )
import CoreUnfold
import CoreFVs
+import Digraph
import TcType
+import Type
import TysPrim ( anyTypeOfKind )
import CostCentre
import Module
import Id
+import TyCon ( tyConDataCons )
+import Class
+import DataCon ( dataConRepType )
import Name ( localiseName )
import MkId ( seqId )
-import Var ( Var, TyVar, tyVarKind )
-import IdInfo ( vanillaIdInfo )
+import Var
import VarSet
import Rules
import VarEnv
import Outputable
import SrcLoc
import Maybes
+import OrdList
import Bag
import BasicTypes hiding ( TopLevel )
import FastString
-import StaticFlags ( opt_DsMultiTyVar )
-import Util ( count, lengthExceeds )
+-- import StaticFlags ( opt_DsMultiTyVar )
+import Util
import MonadUtils
-import Control.Monad
\end{code}
%************************************************************************
\begin{code}
dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
-dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
+dsTopLHsBinds auto_scc binds = do { binds' <- ds_lhs_binds auto_scc binds
+ ; return (fromOL binds') }
dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
-dsLHsBinds binds = ds_lhs_binds NoSccs binds
-
+dsLHsBinds binds = do { binds' <- ds_lhs_binds NoSccs binds
+ ; return (fromOL binds') }
------------------------
-ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
+ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
-- scc annotation policy (see below)
-ds_lhs_binds auto_scc binds = foldM (dsLHsBind auto_scc) [] (bagToList binds)
+ds_lhs_binds auto_scc binds = do { ds_bs <- mapBagM (dsLHsBind auto_scc) binds
+ ; return (foldBag appOL id nilOL ds_bs) }
-dsLHsBind :: AutoScc
- -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
- -> LHsBind Id
- -> DsM [(Id,CoreExpr)] -- Result
-dsLHsBind auto_scc rest (L loc bind)
- = putSrcSpanDs loc $ dsHsBind auto_scc rest bind
+dsLHsBind :: AutoScc -> LHsBind Id -> DsM (OrdList (Id,CoreExpr))
+dsLHsBind auto_scc (L loc bind)
+ = putSrcSpanDs loc $ dsHsBind auto_scc bind
-dsHsBind :: AutoScc
- -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
- -> HsBind Id
- -> DsM [(Id,CoreExpr)] -- Result
+dsHsBind :: AutoScc -> HsBind Id -> DsM (OrdList (Id,CoreExpr))
-dsHsBind _ rest (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
+dsHsBind _ (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
= do { core_expr <- dsLExpr expr
-- Dictionary bindings are always VarBinds,
; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr'
| otherwise = var
- ; return ((var', core_expr') : rest) }
+ ; return (unitOL (var', core_expr')) }
-dsHsBind _ rest
- (FunBind { fun_id = L _ fun, fun_matches = matches,
- fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf })
+dsHsBind _ (FunBind { fun_id = L _ fun, fun_matches = matches
+ , fun_co_fn = co_fn, fun_tick = tick
+ , fun_infix = inf })
= do { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
; body' <- mkOptTickBox tick body
- ; wrap_fn' <- dsCoercion co_fn
- ; return ((fun, wrap_fn' (mkLams args body')) : rest) }
+ ; wrap_fn' <- dsHsWrapper co_fn
+ ; return (unitOL (fun, wrap_fn' (mkLams args body'))) }
-dsHsBind _ rest
- (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
+dsHsBind _ (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
= do { body_expr <- dsGuarded grhss ty
; sel_binds <- mkSelectorBinds pat body_expr
- ; return (sel_binds ++ rest) }
+ ; return (toOL sel_binds) }
-dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
- = do { core_prs <- ds_lhs_binds NoSccs binds
- ; let env = mkABEnv exports
+{-
+dsHsBind auto_scc (AbsBinds { abs_tvs = [], abs_ev_vars = []
+ , abs_exports = exports, abs_ev_binds = ev_binds
+ , abs_binds = binds })
+ = do { bind_prs <- ds_lhs_binds NoSccs binds
+ ; ds_ev_binds <- dsTcEvBinds ev_binds
+
+ ; let core_prs = addEvPairs ds_ev_binds bind_prs
+ env = mkABEnv exports
do_one (lcl_id, rhs)
| Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
= do { let rhs' = addAutoScc auto_scc gbl_id rhs
-- because we can rely on the enclosing dsBind to wrap in Rec
-dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
+dsHsBind auto_scc rest (AbsBinds { abs_tvs = tyvars, abs_ev_vars = []
+ , abs_exports = exports, abs_ev_binds = ev_binds
+ , abs_binds = binds })
| opt_DsMultiTyVar -- This (static) debug flag just lets us
-- switch on and off this optimisation to
-- see if it has any impact; it is on by default
+ , allOL isLazyEvBind ev_binds
= -- Note [Abstracting over tyvars only]
- do { core_prs <- ds_lhs_binds NoSccs binds
- ; let arby_env = mkArbitraryTypeEnv tyvars exports
+ do { bind_prs <- ds_lhs_binds NoSccs binds
+ ; ds_ev_binds <- dsTcEvBinds ev_binds
+
+ ; let core_prs = addEvPairs ds_ev_binds bind_prs
+ arby_env = mkArbitraryTypeEnv tyvars exports
bndrs = mkVarSet (map fst core_prs)
add_lets | core_prs `lengthExceeds` 10 = add_some
; (_, core_prs') <- fixDs (\ ~(lg_binds, _) -> mapAndUnzipM (do_one lg_binds) core_prs)
; return (concat core_prs' ++ rest) }
+-}
- -- Another common case: one exported variable
+ -- A common case: one exported variable
-- Non-recursive bindings come through this way
-- So do self-recursive bindings, and recursive bindings
-- that have been chopped up with type signatures
-dsHsBind auto_scc rest
- (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds)
+dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
+ , abs_exports = [(tyvars, global, local, prags)]
+ , abs_ev_binds = ev_binds, abs_binds = binds })
= ASSERT( all (`elem` tyvars) all_tyvars )
- do { core_prs <- ds_lhs_binds NoSccs binds
+ do { bind_prs <- ds_lhs_binds NoSccs binds
+ ; ds_ev_binds <- dsTcEvBinds ev_binds
- ; let -- Always treat the binds as recursive, because the
- -- typechecker makes rather mixed-up dictionary bindings
- core_bind = Rec core_prs
+ ; let core_bind = Rec (fromOL bind_prs)
rhs = addAutoScc auto_scc global $
- mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
+ mkLams tyvars $ mkLams dicts $
+ wrapDsEvBinds ds_ev_binds $
+ Let core_bind $
+ Var local
; (spec_binds, rules) <- dsSpecs global rhs prags
main_bind = makeCorePair global' (isDefaultMethod prags)
(dictArity dicts) rhs
- ; return (main_bind : spec_binds ++ rest) }
+ ; return (main_bind `consOL` spec_binds) }
-dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
- = do { core_prs <- ds_lhs_binds NoSccs binds
+dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
+ , abs_exports = exports, abs_ev_binds = ev_binds
+ , abs_binds = binds })
+ = do { bind_prs <- ds_lhs_binds NoSccs binds
+ ; ds_ev_binds <- dsTcEvBinds ev_binds
; let env = mkABEnv exports
do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
= (lcl_id, addAutoScc auto_scc gbl_id rhs)
| otherwise = (lcl_id,rhs)
- -- Rec because of mixed-up dictionary bindings
- core_bind = Rec (map do_one core_prs)
+ core_bind = Rec (map do_one (fromOL bind_prs))
+ -- Monomorphic recursion possible, hence Rec
tup_expr = mkBigCoreVarTup locals
tup_ty = exprType tup_expr
poly_tup_rhs = mkLams all_tyvars $ mkLams dicts $
- Let core_bind tup_expr
+ wrapDsEvBinds ds_ev_binds $
+ Let core_bind $
+ tup_expr
locals = [local | (_, _, local, _) <- exports]
local_tys = map idType locals
(Let (NonRec poly_tup_id poly_tup_rhs) rhs)
spec_prags
; let global' = addIdSpecialisations global rules
- ; return ((global', rhs) : spec_binds) }
+ ; return ((global', rhs) `consOL` spec_binds) }
where
mk_ty_arg all_tyvar
| all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
; export_binds_s <- mapM mk_bind (exports `zip` [0..])
-- Don't scc (auto-)annotate the tuple itself.
- ; return ((poly_tup_id, poly_tup_rhs) :
- (concat export_binds_s ++ rest)) }
+ ; return ((poly_tup_id, poly_tup_rhs) `consOL`
+ concatOL export_binds_s) }
+
+--------------------------------------
+data DsEvBind
+ = LetEvBind -- Dictionary or coercion
+ CoreBind -- recursive or non-recursive
+ | CaseEvBind -- Coercion binding by superclass selection
+ -- Desugars to case d of d { K _ g _ _ _ -> ... }
+ DictId -- b The dictionary
+ AltCon -- K Its constructor
+ [CoreBndr] -- _ g _ _ _ The binders in the alternative
+
+wrapDsEvBinds :: [DsEvBind] -> CoreExpr -> CoreExpr
+wrapDsEvBinds ds_ev_binds body = foldr wrap_one body ds_ev_binds
+ where
+ body_ty = exprType body
+ wrap_one (LetEvBind b) body = Let b body
+ wrap_one (CaseEvBind x k xs) body = Case (Var x) x body_ty [(k,xs,body)]
+
+dsTcEvBinds :: TcEvBinds -> DsM [DsEvBind]
+dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
+dsTcEvBinds (EvBinds bs) = dsEvBinds bs
+
+dsEvBinds :: Bag EvBind -> DsM [DsEvBind]
+dsEvBinds bs = return (map dsEvGroup sccs)
+ where
+ sccs :: [SCC EvBind]
+ sccs = stronglyConnCompFromEdgedVertices edges
+
+ edges :: [(EvBind, EvVar, [EvVar])]
+ edges = foldrBag ((:) . mk_node) [] bs
+
+ mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
+ mk_node b@(EvBind var term) = (b, var, free_vars_of term)
+
+ free_vars_of :: EvTerm -> [EvVar]
+ free_vars_of (EvId v) = [v]
+ free_vars_of (EvCast v co) = v : varSetElems (tyVarsOfType co)
+ free_vars_of (EvCoercion co) = varSetElems (tyVarsOfType co)
+ free_vars_of (EvDFunApp _ _ vs) = vs
+ free_vars_of (EvSuperClass d _) = [d]
+
+dsEvGroup :: SCC EvBind -> DsEvBind
+dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n)))
+ | isCoVar co_var -- An equality superclass
+ = ASSERT( null other_data_cons )
+ CaseEvBind dict (DataAlt data_con) bndrs
+ where
+ (cls, tys) = getClassPredTys (evVarPred dict)
+ (data_con:other_data_cons) = tyConDataCons (classTyCon cls)
+ (ex_tvs, theta, rho) = tcSplitSigmaTy (applyTys (dataConRepType data_con) tys)
+ (arg_tys, _) = splitFunTys rho
+ bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..])
+ ++ map mkWildValBinder arg_tys
+ mk_wild_pred (p, i) | i==n = ASSERT( p `tcEqPred` (coVarPred co_var))
+ co_var
+ | otherwise = mkWildEvBinder p
+
+dsEvGroup (AcyclicSCC (EvBind v r))
+ = LetEvBind (NonRec v (dsEvTerm r))
+
+dsEvGroup (CyclicSCC bs)
+ = LetEvBind (Rec (map ds_pair bs))
+ where
+ ds_pair (EvBind v r) = (v, dsEvTerm r)
+
+dsEvTerm :: EvTerm -> CoreExpr
+dsEvTerm (EvId v) = Var v
+dsEvTerm (EvCast v co) = Cast (Var v) co
+dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
+dsEvTerm (EvCoercion co) = Type co
+dsEvTerm (EvSuperClass d n)
+ = ASSERT( isClassPred (classSCTheta cls !! n) )
+ -- We can only select *dictionary* superclasses
+ -- in terms. Equality superclasses are dealt with
+ -- in dsEvGroup, where they can generate a case expression
+ Var sc_sel_id `mkTyApps` tys `App` Var d
+ where
+ sc_sel_id = classSCSelId cls n -- Zero-indexed
+ (cls, tys) = getClassPredTys (evVarPred d)
+
------------------------
makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
makeCorePair gbl_id is_default_method dict_arity rhs
dsSpecs :: Id -- The polymorphic Id
-> CoreExpr -- Its rhs
-> TcSpecPrags
- -> DsM ( [(Id,CoreExpr)] -- Binding for specialised Ids
+ -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids
, [CoreRule] ) -- Rules for the Global Ids
-- See Note [Implementing SPECIALISE pragmas]
dsSpecs poly_id poly_rhs prags
= case prags of
- IsDefaultMethod -> return ([], [])
+ IsDefaultMethod -> return (nilOL, [])
SpecPrags sps -> do { pairs <- mapMaybeM spec_one sps
; let (spec_binds_s, rules) = unzip pairs
- ; return (concat spec_binds_s, rules) }
+ ; return (concatOL spec_binds_s, rules) }
where
- spec_one :: Located TcSpecPrag -> DsM (Maybe ([(Id,CoreExpr)], CoreRule))
+ spec_one :: Located TcSpecPrag -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
spec_one (L loc (SpecPrag spec_co spec_inl))
= putSrcSpanDs loc $
do { let poly_name = idName poly_id
; spec_name <- newLocalName poly_name
- ; wrap_fn <- dsCoercion spec_co
- ; let ds_spec_expr = wrap_fn (Var poly_id)
- spec_ty = exprType ds_spec_expr
- ; case decomposeRuleLhs ds_spec_expr of {
+ ; wrap_fn <- dsHsWrapper spec_co
+ ; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id))
+ spec_ty = mkPiTypes bndrs (exprType ds_lhs)
+ ; case decomposeRuleLhs ds_lhs of {
Nothing -> do { warnDs (decomp_msg spec_co)
; return Nothing } ;
- Just (bndrs, _fn, args) ->
+ Just (_fn, args) ->
-- Check for dead binders: Note [Unused spec binders]
- case filter isDeadBinder bndrs of {
- bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
- | otherwise -> do
+ let arg_fvs = exprsFreeVars args
+ bad_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs
+ in if not (null bad_bndrs)
+ then do { warnDs (dead_msg bad_bndrs); return Nothing }
+ else do
{ (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
-- See Note [Constant rule dicts]
- | d <- varSetElems (exprFreeVars ds_spec_expr)
+ | d <- varSetElems (arg_fvs `delVarSetList` bndrs)
, isDictId d]
rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
spec_rhs = wrap_fn poly_rhs
spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
- ; return (Just (spec_pair : unf_pairs, rule))
- } } } }
+ ; return (Just (spec_pair `consOL` unf_pairs, rule))
+ } } }
dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
<+> ptext (sLit "in specialied type:"),
specUnfolding :: (CoreExpr -> CoreExpr) -> Type
- -> Unfolding -> DsM (Unfolding, [(Id,CoreExpr)])
+ -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
= do { let spec_rhss = map wrap_fn ops
; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
- ; return (mkDFunUnfolding spec_ty (map Var spec_ids), spec_ids `zip` spec_rhss) }
+ ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
specUnfolding _ _ _
- = return (noUnfolding, [])
+ = return (noUnfolding, nilOL)
+{-
mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
-- If any of the tyvars is missing from any of the lists in
-- the second arg, return a binding in the result
, not (tv `elemVarEnv` env)]
extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
+-}
dsMkArbitraryType :: TcTyVar -> Type
dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
%************************************************************************
\begin{code}
-decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr])
+decomposeRuleLhs :: CoreExpr -> Maybe (Id, [CoreExpr])
-- Take apart the LHS of a RULE. It's suuposed to look like
-- /\a. f a Int dOrdInt
-- or /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
-- That is, the RULE binders are lambda-bound
-- Returns Nothing if the LHS isn't of the expected shape
decomposeRuleLhs lhs
- = case collectArgs body of
- (Var fn, args) -> Just (bndrs, fn, args)
+ = -- Note [Simplifying the left-hand side of a RULE]
+ case collectArgs (simpleOptExpr lhs) of
+ (Var fn, args) -> Just (fn, args)
(Case scrut bndr ty [(DEFAULT, _, body)], args)
| isDeadBinder bndr -- Note [Matching seqId]
- -> Just (bndrs, seqId, args' ++ args)
+ -> Just (seqId, args' ++ args)
where
args' = [Type (idType bndr), Type ty, scrut, body]
_other -> Nothing -- Unexpected shape
- where
- (bndrs, body) = collectBinders (simpleOptExpr lhs)
- -- simpleOptExpr occurrence-analyses and simplifies the lhs
- -- and thereby
- -- (a) identifies unused binders: Note [Unused spec binders]
- -- (b) sorts dict bindings into NonRecs
- -- so they can be inlined by 'decomp'
- -- (c) 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
- -- NB: tcSimplifyRuleLhs is very careful not to generate complicated
- -- dictionary expressions that we might have to match
\end{code}
+Note [Simplifying the left-hand side of a RULE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+simpleOptExpr occurrence-analyses and simplifies the lhs
+and thereby
+(a) sorts dict bindings into NonRecs and inlines them
+(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) does eta reduction
+
+For (c) 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)
+
+NB: tcSimplifyRuleLhs is very careful not to generate complicated
+ dictionary expressions that we might have to match
+
+
Note [Matching seqId]
~~~~~~~~~~~~~~~~~~~
The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
\begin{code}
-dsCoercion :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
-dsCoercion WpHole = return (\e -> e)
-dsCoercion (WpCompose c1 c2) = do { k1 <- dsCoercion c1
- ; k2 <- dsCoercion c2
- ; return (k1 . k2) }
-dsCoercion (WpCast co) = return (\e -> Cast e co)
-dsCoercion (WpLam id) = return (\e -> Lam id e)
-dsCoercion (WpTyLam tv) = return (\e -> Lam tv e)
-dsCoercion (WpApp v) | isTyVar v -- Probably a coercion var
- = return (\e -> App e (Type (mkTyVarTy v)))
- | otherwise
- = return (\e -> App e (Var v))
-dsCoercion (WpTyApp ty) = return (\e -> App e (Type ty))
-dsCoercion (WpLet bs) = do { prs <- dsLHsBinds bs
- ; return (\e -> Let (Rec prs) e) }
+dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
+dsHsWrapper WpHole = return (\e -> e)
+dsHsWrapper (WpTyApp ty) = return (\e -> App e (Type ty))
+dsHsWrapper (WpLet ev_binds) = do { ds_ev_binds <- dsTcEvBinds ev_binds
+ ; return (wrapDsEvBinds ds_ev_binds) }
+dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1
+ ; k2 <- dsHsWrapper c2
+ ; return (k1 . k2) }
+dsHsWrapper (WpCast co) = return (\e -> Cast e co)
+dsHsWrapper (WpEvLam ev) = return (\e -> Lam ev e)
+dsHsWrapper (WpTyLam tv) = return (\e -> Lam tv e)
+dsHsWrapper (WpEvApp evtrm) = return (\e -> App e (dsEvTerm evtrm))
\end{code}
projects / ghc-hetmet.git / blobdiff