import Coercion
import CoreSyn
import CoreUtils
+import CoreFVs
import MkCore
import DynFlags
import CostCentre
import Id
import Var
+import VarSet
import PrelInfo
import DataCon
import TysWiredIn
dsExpr (HsIPVar ip) = return (Var (ipNameName ip))
dsExpr (HsLit lit) = dsLit lit
dsExpr (HsOverLit lit) = dsOverLit lit
-dsExpr (HsWrap co_fn e) = dsCoercion co_fn (dsExpr e)
+dsExpr (HsWrap co_fn e) = do { co_fn' <- dsCoercion co_fn
+ ; e' <- dsExpr e
+ ; return (co_fn' e') }
dsExpr (NegApp expr neg_expr)
= App <$> dsExpr neg_expr <*> dsLExpr expr
dsExpr (HsDo DoExpr stmts body result_ty)
= dsDo stmts body result_ty
+dsExpr (HsDo GhciStmt stmts body result_ty)
+ = dsDo stmts body result_ty
+
dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
= dsMDo tbl stmts body result_ty
foldr k z [x] = ...
We do not want to generate a build invocation on the LHS of this RULE!
+We fix this by disabling rules in rule LHSs, and testing that
+flag here; see Note [Desugaring RULE left hand sides] in Desugar
+
To test this I've added a (static) flag -fsimple-list-literals, which
makes all list literals be generated via the simple route.
\begin{code}
-
dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
-- See Note [Desugaring explicit lists]
-dsExplicitList elt_ty xs = do
- dflags <- getDOptsDs
- xs' <- mapM dsLExpr xs
- if opt_SimpleListLiterals || not (dopt Opt_EnableRewriteRules dflags)
- then return $ mkListExpr elt_ty xs'
- else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs')
+dsExplicitList elt_ty xs
+ = do { dflags <- getDOptsDs
+ ; xs' <- mapM dsLExpr xs
+ ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
+ ; if opt_SimpleListLiterals -- -fsimple-list-literals
+ || not (dopt Opt_EnableRewriteRules dflags) -- Rewrite rules off
+ -- Don't generate a build if there are no rules to eliminate it!
+ -- See Note [Desugaring RULE left hand sides] in Desugar
+ || null dynamic_prefix -- Avoid build (\c n. foldr c n xs)!
+ then return $ mkListExpr elt_ty xs'
+ else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }
where
- mkSplitExplicitList this_package xs' (c, _) (n, n_ty) = do
- let (dynamic_prefix, static_suffix) = spanTail (rhsIsStatic this_package) xs'
- static_suffix' = mkListExpr elt_ty static_suffix
-
- folded_static_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) static_suffix'
- let build_body = foldr (App . App (Var c)) folded_static_suffix dynamic_prefix
- return build_body
+ is_static :: CoreExpr -> Bool
+ is_static e = all is_static_var (varSetElems (exprFreeVars e))
+
+ is_static_var :: Var -> Bool
+ is_static_var v
+ | isId v = isExternalName (idName v) -- Top-level things are given external names
+ | otherwise = False -- Type variables
+
+ mkSplitExplicitList prefix suffix (c, _) (n, n_ty)
+ = do { let suffix' = mkListExpr elt_ty suffix
+ ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
+ ; return (foldr (App . App (Var c)) folded_suffix prefix) }
spanTail :: (a -> Bool) -> [a] -> ([a], [a])
spanTail f xs = (reverse rejected, reverse satisfying)
body = noLoc $ HsDo DoExpr rec_stmts return_app body_ty
return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
body_ty = mkAppTy m_ty tup_ty
- tup_ty = mkCoreTupTy (map idType tup_ids)
- -- mkCoreTupTy deals with singleton case
+ tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
-- In a do expression, pattern-match failure just calls
-- the monadic 'fail' rather than throwing an exception
mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
body = noLoc $ HsDo ctxt rec_stmts return_app body_ty
body_ty = mkAppTy m_ty tup_ty
- tup_ty = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
- -- mkCoreTupTy deals with singleton case
+ tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case
return_app = nlHsApp (nlHsTyApp return_id [tup_ty])
(mkLHsTupleExpr rets)