X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=eed7f87d8f304c49d989ff832729f5325d368fb0;hp=5191afe4110ba14725ec3f1b654889d5d6d7aa5a;hb=27de38efce6d73d2a0209f803cfa98c82773e773;hpb=794b8adb013dda3b520325e18b43f91370170c4a diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 5191afe..eed7f87 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -6,7 +6,7 @@ Desugaring exporessions. \begin{code} -{-# OPTIONS -w #-} +{-# OPTIONS -fno-warn-incomplete-patterns #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See @@ -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 @@ -76,6 +77,7 @@ dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds ------------------------- +dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr dsIPBinds (IPBinds ip_binds dict_binds) body = do { prs <- dsLHsBinds dict_binds ; let inner = Let (Rec prs) body @@ -131,16 +133,16 @@ ds_val_bind (NonRecursive, hsbinds) body ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) ; return (scrungleMatch var rhs result) } - other -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body) + _ -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body) -- Ordinary case for bindings; none should be unlifted -ds_val_bind (is_rec, binds) body +ds_val_bind (_is_rec, binds) body = do { prs <- dsLHsBinds binds ; ASSERT( not (any (isUnLiftedType . idType . fst) prs) ) case prs of - [] -> return body - other -> return (Let (Rec prs) body) } + [] -> return body + _ -> return (Let (Rec prs) body) } -- Use a Rec regardless of is_rec. -- Why? Because it allows the binds to be all -- mixed up, which is what happens in one rare case @@ -154,7 +156,7 @@ ds_val_bind (is_rec, binds) body isUnboxedTupleBind :: HsBind Id -> Bool isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty -isUnboxedTupleBind other = False +isUnboxedTupleBind _ = False scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr -- Returns something like (let var = scrut in body) @@ -206,11 +208,11 @@ dsExpr (HsWrap co_fn e) = dsCoercion co_fn (dsExpr e) dsExpr (NegApp expr neg_expr) = App <$> dsExpr neg_expr <*> dsLExpr expr -dsExpr expr@(HsLam a_Match) +dsExpr (HsLam a_Match) = uncurry mkLams <$> matchWrapper LambdaExpr a_Match -dsExpr expr@(HsApp fun arg) - = mkDsApp <$> dsLExpr fun <*> dsLExpr arg +dsExpr (HsApp fun arg) + = mkCoreApp <$> dsLExpr fun <*> dsLExpr arg \end{code} Operator sections. At first it looks as if we can convert @@ -237,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 @@ -252,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 @@ -264,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 @@ -305,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' @@ -349,7 +353,7 @@ dsExpr (PArrSeq expr (FromTo from to)) dsExpr (PArrSeq expr (FromThenTo from thn to)) = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to] -dsExpr (PArrSeq expr _) +dsExpr (PArrSeq _ _) = panic "DsExpr.dsExpr: Infinite parallel array!" -- the parser shouldn't have generated it and the renamer and typechecker -- shouldn't have let it through @@ -507,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] @@ -521,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: @@ -531,7 +591,7 @@ dsDo :: [LStmt Id] -> Type -- Type of the whole expression -> DsM CoreExpr -dsDo stmts body result_ty +dsDo stmts body _result_ty = go (map unLoc stmts) where go [] = dsLExpr body @@ -548,13 +608,15 @@ dsDo stmts body result_ty go (BindStmt pat rhs bind_op fail_op : stmts) = - do { body <- go stmts + do { body <- go stmts + ; rhs' <- dsLExpr rhs + ; bind_op' <- dsExpr bind_op ; var <- selectSimpleMatchVarL pat + ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2 + res1_ty = funResultTy (funArgTy (funResultTy bind_ty)) ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat - result_ty (cantFailMatchResult body) + res1_ty (cantFailMatchResult body) ; match_code <- handle_failure pat match fail_op - ; rhs' <- dsLExpr rhs - ; bind_op' <- dsExpr bind_op ; return (mkApps bind_op' [rhs', Lam var match_code]) } -- In a do expression, pattern-match failure just calls @@ -567,6 +629,7 @@ dsDo stmts body result_ty | otherwise = extractMatchResult match (error "It can't fail") +mk_fail_msg :: Located e -> String mk_fail_msg pat = "Pattern match failure in do expression at " ++ showSDoc (ppr (getLoc pat)) \end{code}