#include "HsVersions.h"
-
import Match
import MatchLit
import DsBinds
import Type
import CoreSyn
import CoreUtils
+import MkCore
+import DynFlags
import CostCentre
import Id
import PrelInfo
= uncurry mkLams <$> matchWrapper LambdaExpr a_Match
dsExpr (HsApp fun arg)
- = mkDsApp <$> dsLExpr fun <*> dsLExpr arg
+ = mkCoreApp <$> dsLExpr fun <*> dsLExpr arg
\end{code}
Operator sections. At first it looks as if we can convert
\begin{code}
dsExpr (OpApp e1 op _ e2)
= -- for the type of y, we need the type of op's 2nd argument
- mkDsApps <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
+ mkCoreApps <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
- = mkDsApp <$> dsLExpr op <*> dsLExpr expr
+ = mkCoreApp <$> dsLExpr op <*> dsLExpr expr
-- dsLExpr (SectionR op expr) -- \ x -> op x expr
dsExpr (SectionR op expr) = do
x_id <- newSysLocalDs x_ty
y_id <- newSysLocalDs y_ty
return (bindNonRec y_id y_core $
- Lam x_id (mkDsApps core_op [Var x_id, Var y_id]))
+ Lam x_id (mkCoreApps core_op [Var x_id, Var y_id]))
dsExpr (HsSCC cc expr) = do
mod_name <- getModuleDs
dsExpr (HsCoreAnn fs expr)
= Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
-dsExpr (HsCase discrim matches) = do
- core_discrim <- dsLExpr discrim
- ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
- return (scrungleMatch discrim_var core_discrim matching_code)
+dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty))
+ | isEmptyMatchGroup matches -- A Core 'case' is always non-empty
+ = -- So desugar empty HsCase to error call
+ mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) "case"
+
+ | otherwise
+ = do { core_discrim <- dsLExpr discrim
+ ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
+ ; return (scrungleMatch discrim_var core_discrim matching_code) }
-- Pepe: The binds are in scope in the body but NOT in the binding group
-- This is to avoid silliness in breakpoints
\underline{\bf Various data construction things}
% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-dsExpr (ExplicitList ty xs)
- = go xs
- where
- go [] = return (mkNilExpr ty)
- go (x:xs) = mkConsExpr ty <$> dsLExpr x <*> go xs
+dsExpr (ExplicitList elt_ty xs)
+ = dsExplicitList elt_ty xs
-- we create a list from the array elements and convert them into a list using
-- `PrelPArr.toP'
\begin{code}
-#ifdef DEBUG
-- HsSyn constructs that just shouldn't be here:
dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
-#endif
findField :: [HsRecField Id arg] -> Name -> [arg]
%--------------------------------------------------------------------
+Note [Desugaring explicit lists]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Explicit lists are desugared in a cleverer way to prevent some
+fruitless allocations. Essentially, whenever we see a list literal
+[x_1, ..., x_n] we:
+
+1. Find the tail of the list that can be allocated statically (say
+ [x_k, ..., x_n]) by later stages and ensure we desugar that
+ normally: this makes sure that we don't cause a code size increase
+ by having the cons in that expression fused (see later) and hence
+ being unable to statically allocate any more
+
+2. For the prefix of the list which cannot be allocated statically,
+ say [x_1, ..., x_(k-1)], we turn it into an expression involving
+ build so that if we find any foldrs over it it will fuse away
+ entirely!
+
+ So in this example we will desugar to:
+ build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
+
+ If fusion fails to occur then build will get inlined and (since we
+ defined a RULE for foldr (:) []) we will get back exactly the
+ normal desugaring for an explicit list.
+
+This optimisation can be worth a lot: up to 25% of the total
+allocation in some nofib programs. Specifically
+
+ Program Size Allocs Runtime CompTime
+ rewrite +0.0% -26.3% 0.02 -1.8%
+ ansi -0.3% -13.8% 0.00 +0.0%
+ lift +0.0% -8.7% 0.00 -2.3%
+
+Of course, if rules aren't turned on then there is pretty much no
+point doing this fancy stuff, and it may even be harmful.
+\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 not (dopt Opt_RewriteRules dflags)
+ then return $ mkListExpr elt_ty xs'
+ else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs')
+ 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
+
+spanTail :: (a -> Bool) -> [a] -> ([a], [a])
+spanTail f xs = (reverse rejected, reverse satisfying)
+ where (satisfying, rejected) = span f $ reverse xs
+\end{code}
+
Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
handled in DsListComp). Basically does the translation given in the
Haskell 98 report:
projects / ghc-hetmet.git / blobdiff