import DsArrows
import DsMonad
import Name
+import NameEnv
#ifdef GHCI
import PrelNames
-- 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
import TysWiredIn
import BasicTypes
import PrelNames
+import Maybes
import SrcLoc
import Util
import Bag
= 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
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
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
\begin{code}
-#ifdef DEBUG
-- HsSyn constructs that just shouldn't be here:
dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
-#endif
findField :: [HsRecField Id arg] -> Name -> [arg]
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! However, if it does occur
- then we can potentially save quite a bit of allocation (up to 25\%
- of the total in some nofib programs!)
+ 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
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
projects / ghc-hetmet.git / blobdiff