Add static flag -fsimple-list-literals
[ghc-hetmet.git] / compiler / deSugar / DsExpr.lhs
index 6cbd538..6126b63 100644 (file)
@@ -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
@@ -426,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
@@ -557,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
@@ -564,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