Add static flag -fsimple-list-literals

[ghc-hetmet.git] / compiler / deSugar / DsExpr.lhs

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 37129d8..6126b63 100644 (file)
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -47,6 +47,7 @@ import CoreUtils
 import MkCore
 
 import DynFlags
+import StaticFlags
 import CostCentre
 import Id
 import PrelInfo
@@ -451,24 +452,32 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
 
     do { record_expr' <- dsLExpr record_expr
        ; 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
+       ; 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 (Id, CoreExpr)
+    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)
-                           ; return (unLoc (hsRecFieldId rec_field), rhs) }
+                           ; 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)
+    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
@@ -476,7 +485,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
     in_ty     = mkTyConApp tycon in_inst_tys
     in_out_ty = mkFunTy in_ty (mkFamilyTyConApp tycon out_inst_tys)
 
-    mk_alt con
+    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)
@@ -487,6 +496,8 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
           ; 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` 
@@ -514,11 +525,6 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
                                         , pat_ty = in_ty }
           ; return (mkSimpleMatch [pat] wrapped_rhs) }
 
-    upd_field_ids :: NameEnv Id        -- Maps field name to the LocalId of the field binding
-    upd_field_ids = mkNameEnv [ (idName field_id, field_id) 
-                             | rec_fld <- fields, let field_id = unLoc (hsRecFieldId rec_fld) ]
-    mk_val_arg field_name pat_arg_id 
-      = nlHsVar (lookupNameEnv upd_field_ids field_name `orElse` pat_arg_id)
 \end{code}
 
 Here is where we desugar the Template Haskell brackets and escapes
@@ -604,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
@@ -611,7 +634,7 @@ dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
 dsExplicitList elt_ty xs = do
     dflags <- getDOptsDs
     xs' <- mapM dsLExpr xs
-    if not (dopt Opt_EnableRewriteRules dflags)
+    if  opt_SimpleListLiterals || not (dopt Opt_EnableRewriteRules dflags)
         then return $ mkListExpr elt_ty xs'
         else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs')
   where