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 MkCore
 
 import DynFlags

+import StaticFlags

 import CostCentre
 import Id
 import PrelInfo
 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
 
     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.
 
        -- 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
        ; ([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)
     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 [] 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
 
        -- 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)
 
     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)
       = 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
           ; 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` 
                 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) }
 
                                         , 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
 \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.
 
 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
 \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
 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
         then return $ mkListExpr elt_ty xs'
         else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs')
   where