X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=6126b6302e2de99ab7412413674b40147e19536e;hb=6f547477aba779646caa7043d65825c59f10256b;hp=5366c568df7e95719e9291c4741c4f947b6a78fe;hpb=4c6c0d44321d8481537a31b02dbaf39b3eeb8513;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 5366c56..6126b63 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 @@ -27,6 +26,7 @@ import DsUtils import DsArrows import DsMonad import Name +import NameEnv #ifdef GHCI import PrelNames @@ -41,9 +41,13 @@ import TcHsSyn -- needs to see source types import TcType import Type +import Coercion import CoreSyn import CoreUtils +import MkCore +import DynFlags +import StaticFlags import CostCentre import Id import PrelInfo @@ -51,6 +55,7 @@ import DataCon import TysWiredIn import BasicTypes import PrelNames +import Maybes import SrcLoc import Util import Bag @@ -211,7 +216,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 +243,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 +258,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 +270,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,26 +316,23 @@ 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' --- --- * the main disadvantage to this scheme is that `toP' traverses the list --- twice: once to determine the length and a second time to put to elements --- into the array; this inefficiency could be avoided by exposing some of --- the innards of `PrelPArr' to the compiler (ie, have a `PrelPArrBase') so --- that we can exploit the fact that we already know the length of the array --- here at compile time +-- We desugar [:x1, ..., xn:] as +-- singletonP x1 +:+ ... +:+ singletonP xn -- +dsExpr (ExplicitPArr ty []) = do + emptyP <- dsLookupGlobalId emptyPName + return (Var emptyP `App` Type ty) dsExpr (ExplicitPArr ty xs) = do - toP <- dsLookupGlobalId toPName - coreList <- dsExpr (ExplicitList ty xs) - return (mkApps (Var toP) [Type ty, coreList]) + singletonP <- dsLookupGlobalId singletonPName + appP <- dsLookupGlobalId appPName + xs' <- mapM dsLExpr xs + return . foldr1 (binary appP) $ map (unary singletonP) xs' + where + unary fn x = mkApps (Var fn) [Type ty, x] + binary fn x y = mkApps (Var fn) [Type ty, x, y] dsExpr (ExplicitTuple expr_list boxity) = do core_exprs <- mapM dsLExpr expr_list @@ -423,52 +430,101 @@ RHSs, and do not generate a Core constructor application directly, because the c might do some argument-evaluation first; and may have to throw away some dictionaries. +Note [Update for GADTs] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a b where + T1 { f1 :: a } :: T a Int + +Then the wrapper function for T1 has type + $WT1 :: a -> T a Int +But if x::T a b, then + x { f1 = v } :: T a b (not T a Int!) +So we need to cast (T a Int) to (T a b). Sigh. + \begin{code} dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) cons_to_upd in_inst_tys out_inst_tys) | null fields = dsLExpr record_expr | otherwise - = -- Record stuff doesn't work for existentials - -- The type checker checks for this, but we need - -- worry only about the constructors that are to be updated - ASSERT2( notNull cons_to_upd && all isVanillaDataCon cons_to_upd, ppr expr ) + = ASSERT2( notNull cons_to_upd, ppr expr ) do { record_expr' <- dsLExpr record_expr - ; let -- Awkwardly, for families, the match goes - -- from instance type to family type - tycon = dataConTyCon (head cons_to_upd) - in_ty = mkTyConApp tycon in_inst_tys - in_out_ty = mkFunTy in_ty - (mkFamilyTyConApp tycon out_inst_tys) - - mk_val_arg field old_arg_id - = case findField fields field of - (rhs:rest) -> ASSERT(null rest) rhs - [] -> nlHsVar old_arg_id - - mk_alt con - = ASSERT( isVanillaDataCon con ) - do { arg_ids <- newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) - -- This call to dataConInstOrigArgTys won't work for existentials - -- but existentials don't have record types anyway - ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg - (dataConFieldLabels con) arg_ids - rhs = foldl (\a b -> nlHsApp a b) - (nlHsTyApp (dataConWrapId con) out_inst_tys) - val_args - pat = mkPrefixConPat con (map nlVarPat arg_ids) in_ty - - ; return (mkSimpleMatch [pat] rhs) } + ; field_binds' <- mapM ds_field fields + ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding + upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds'] -- It's important to generate the match with matchWrapper, -- and the right hand sides with applications of the wrapper Id -- so that everything works when we are doing fancy unboxing on the -- constructor aguments. - ; alts <- mapM mk_alt cons_to_upd - ; ([discrim_var], matching_code) <- matchWrapper RecUpd (MatchGroup alts in_out_ty) + ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd + ; ([discrim_var], matching_code) + <- matchWrapper RecUpd (MatchGroup alts in_out_ty) + + ; return (add_field_binds field_binds' $ + bindNonRec discrim_var record_expr' matching_code) } + where + ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr) + -- Clone the Id in the HsRecField, because its Name is that + -- of the record selector, and we must not make that a lcoal binder + -- else we shadow other uses of the record selector + -- Hence 'lcl_id'. Cf Trac #2735 + ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field) + ; let fld_id = unLoc (hsRecFieldId rec_field) + ; lcl_id <- newSysLocalDs (idType fld_id) + ; return (idName fld_id, lcl_id, rhs) } + + add_field_binds [] expr = expr + add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr) + + -- Awkwardly, for families, the match goes + -- from instance type to family type + tycon = dataConTyCon (head cons_to_upd) + in_ty = mkTyConApp tycon in_inst_tys + in_out_ty = mkFunTy in_ty (mkFamilyTyConApp tycon out_inst_tys) + + mk_alt upd_fld_env con + = do { let (univ_tvs, ex_tvs, eq_spec, + eq_theta, dict_theta, arg_tys, _) = dataConFullSig con + subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys) + + -- I'm not bothering to clone the ex_tvs + ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec)) + ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta)) + ; arg_ids <- newSysLocalsDs (substTys subst arg_tys) + ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg + (dataConFieldLabels con) arg_ids + mk_val_arg field_name pat_arg_id + = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id) + inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con)) + -- Reconstruct with the WrapId so that unpacking happens + wrap = mkWpApps theta_vars `WpCompose` + mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose` + mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys + , isNothing (lookupTyVar wrap_subst tv) ] + rhs = foldl (\a b -> nlHsApp a b) inst_con val_args + + -- Tediously wrap the application in a cast + -- Note [Update for GADTs] + wrapped_rhs | null eq_spec = rhs + | otherwise = mkLHsWrap (WpCast wrap_co) rhs + wrap_co = mkTyConApp tycon [ lookup tv ty + | (tv,ty) <- univ_tvs `zip` out_inst_tys] + lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of + Just ty' -> ty' + Nothing -> ty + wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var)) + | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ] + + pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs + , pat_dicts = eqs_vars ++ theta_vars + , pat_binds = emptyLHsBinds + , pat_args = PrefixCon $ map nlVarPat arg_ids + , pat_ty = in_ty } + ; return (mkSimpleMatch [pat] wrapped_rhs) } - ; return (bindNonRec discrim_var record_expr' matching_code) } \end{code} Here is where we desugar the Template Haskell brackets and escapes @@ -508,10 +564,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 +576,81 @@ 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. + +=======> Note by SLPJ Dec 08. + +I'm unconvinced that we should *ever* generate a build for an explicit +list. See the comments in GHC.Base about the foldr/cons rule, which +points out that (foldr k z [a,b,c]) may generate *much* less code than +(a `k` b `k` c `k` z). + +Furthermore generating builds messes up the LHS of RULES. +Example: the foldr/single rule in GHC.Base + foldr k z [x] = ... +We do not want to generate a build invocation on the LHS of this RULE! + +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') + 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: