X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=6126b6302e2de99ab7412413674b40147e19536e;hb=6f547477aba779646caa7043d65825c59f10256b;hp=043f54fa8066f491968487ea1b50355be150a329;hpb=146d36e87447f34fd9d0f6a1135173f899aa7f52;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 043f54f..6126b63 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -26,6 +26,7 @@ import DsUtils import DsArrows import DsMonad import Name +import NameEnv #ifdef GHCI import PrelNames @@ -40,11 +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 @@ -52,6 +55,7 @@ import DataCon import TysWiredIn import BasicTypes import PrelNames +import Maybes import SrcLoc import Util import Bag @@ -266,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 @@ -310,20 +319,20 @@ dsExpr (HsIf guard_expr then_expr else_expr) 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 @@ -421,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 @@ -552,6 +610,23 @@ allocation in some nofib programs. Specifically 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 @@ -559,7 +634,7 @@ dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr dsExplicitList elt_ty xs = do dflags <- getDOptsDs xs' <- mapM dsLExpr xs - if not (dopt Opt_RewriteRules dflags) + if opt_SimpleListLiterals || not (dopt Opt_EnableRewriteRules dflags) then return $ mkListExpr elt_ty xs' else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs') where