X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=eed7f87d8f304c49d989ff832729f5325d368fb0;hp=5366c568df7e95719e9291c4741c4f947b6a78fe;hb=27de38efce6d73d2a0209f803cfa98c82773e773;hpb=4c6c0d44321d8481537a31b02dbaf39b3eeb8513 diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 5366c56..eed7f87 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -17,7 +17,6 @@ module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where #include "HsVersions.h" - import Match import MatchLit import DsBinds @@ -43,7 +42,9 @@ import TcType import Type import CoreSyn import CoreUtils +import MkCore +import DynFlags import CostCentre import Id import PrelInfo @@ -211,7 +212,7 @@ dsExpr (HsLam a_Match) = 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 @@ -238,10 +239,10 @@ will sort it out. \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 @@ -253,7 +254,7 @@ 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 @@ -265,10 +266,15 @@ dsExpr (HsSCC cc expr) = do 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 @@ -306,11 +312,8 @@ dsExpr (HsIf guard_expr then_expr else_expr) \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' @@ -508,10 +511,8 @@ dsExpr (HsBinTick ixT ixF e) = do \begin{code} -#ifdef DEBUG -- HsSyn constructs that just shouldn't be here: dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig" -#endif findField :: [HsRecField Id arg] -> Name -> [arg] @@ -522,6 +523,64 @@ findField rbinds lbl %-------------------------------------------------------------------- +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: