Fixed warnings in simplCore/OccurAnal

[ghc-hetmet.git] / compiler / simplCore / SimplUtils.lhs

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index cff659d..6739aaf 100644 (file)
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -56,7 +56,9 @@ import Unify  ( dataConCannotMatch )
 import VarSet
 import BasicTypes
 import Util
+import MonadUtils
 import Outputable
+
 import List( nub )
 \end{code}
 
@@ -95,10 +97,8 @@ data SimplCont
        Bool            -- True <=> There is something interesting about
                        --          the context, and hence the inliner
                        --          should be a bit keener (see interestingCallContext)
-                       -- Two cases:
-                       -- (a) This is the RHS of a thunk whose type suggests
-                       --     that update-in-place would be possible
-                       -- (b) This is an argument of a function that has RULES
+                       -- Specifically:
+                       --     This is an argument of a function that has RULES
                        --     Inlining the call might allow the rule to fire
 
   | CoerceIt           -- C `cast` co
@@ -156,10 +156,10 @@ mkBoringStop :: OutType -> SimplCont
 mkBoringStop ty = Stop ty AnArg False
 
 mkLazyArgStop :: OutType -> Bool -> SimplCont
-mkLazyArgStop ty has_rules = Stop ty AnArg (canUpdateInPlace ty || has_rules)
+mkLazyArgStop ty has_rules = Stop ty AnArg has_rules
 
 mkRhsStop :: OutType -> SimplCont
-mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty)
+mkRhsStop ty = Stop ty AnRhs False
 
 -------------------
 contIsRhsOrArg (Stop {})                = True
@@ -400,27 +400,6 @@ interestingArgContext fn call_cont
     go (StrictBind {})       = False   -- ??
     go (CoerceIt _ c)        = go c
     go (Stop _ _ interesting) = interesting
-
--------------------
-canUpdateInPlace :: Type -> Bool
--- Consider   let x = <wurble> in ...
--- If <wurble> returns an explicit constructor, we might be able
--- to do update in place.  So we treat even a thunk RHS context
--- as interesting if update in place is possible.  We approximate
--- this by seeing if the type has a single constructor with a
--- small arity.  But arity zero isn't good -- we share the single copy
--- for that case, so no point in sharing.
-
-canUpdateInPlace ty 
-  | not opt_UF_UpdateInPlace = False
-  | otherwise
-  = case splitTyConApp_maybe ty of 
-       Nothing         -> False 
-       Just (tycon, _) -> case tyConDataCons_maybe tycon of
-                               Just [dc]  -> arity == 1 || arity == 2
-                                          where
-                                             arity = dataConRepArity dc
-                               other -> False
 \end{code}
 
 
@@ -829,7 +808,7 @@ mkLam bndrs body
           ; return (mkLams bndrs body') }
    
       | otherwise 
-      = returnSmpl (mkLams bndrs body)
+      = return (mkLams bndrs body)
 \end{code}
 
 Note [Casts and lambdas]
@@ -875,8 +854,8 @@ because the latter is not well-kinded.
                        -- if this is indeed a right-hand side; otherwise
                        -- we end up floating the thing out, only for float-in
                        -- to float it right back in again!
- = tryRhsTyLam env bndrs body          `thenSmpl` \ (floats, body') ->
-   returnSmpl (floats, mkLams bndrs body')
+ = do (floats, body') <- tryRhsTyLam env bndrs body
+      return (floats, mkLams bndrs body')
 -}
 
 
@@ -998,9 +977,9 @@ actually computing the expansion.
 \begin{code}
 tryEtaExpansion :: DynFlags -> OutExpr -> SimplM OutExpr
 -- There is at least one runtime binder in the binders
-tryEtaExpansion dflags body
-  = getUniquesSmpl                     `thenSmpl` \ us ->
-    returnSmpl (etaExpand fun_arity us body (exprType body))
+tryEtaExpansion dflags body = do
+    us <- getUniquesM
+    return (etaExpand fun_arity us body (exprType body))
   where
     fun_arity = exprEtaExpandArity dflags body
 \end{code}
@@ -1092,7 +1071,7 @@ it is guarded by the doFloatFromRhs call in simplLazyBind.
 abstractFloats :: [OutTyVar] -> SimplEnv -> OutExpr -> SimplM ([OutBind], OutExpr)
 abstractFloats main_tvs body_env body
   = ASSERT( notNull body_floats )
-    do { (subst, float_binds) <- mapAccumLSmpl abstract empty_subst body_floats
+    do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats
        ; return (float_binds, CoreSubst.substExpr subst body) }
   where
     main_tv_set = mkVarSet main_tvs
@@ -1128,7 +1107,7 @@ abstractFloats main_tvs body_env body
                -- gives rise to problems.   SLPJ June 98
 
     abstract subst (Rec prs)
-       = do { (poly_ids, poly_apps) <- mapAndUnzipSmpl (mk_poly tvs_here) ids
+       = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly tvs_here) ids
            ; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps)
                  poly_rhss = [mkLams tvs_here (CoreSubst.substExpr subst' rhs) | rhs <- rhss]
            ; return (subst', Rec (poly_ids `zip` poly_rhss)) }
@@ -1150,7 +1129,7 @@ abstractFloats main_tvs body_env body
         tvs_here = main_tvs
 
     mk_poly tvs_here var
-      = do { uniq <- getUniqueSmpl
+      = do { uniq <- getUniqueM
           ; let  poly_name = setNameUnique (idName var) uniq           -- Keep same name
                  poly_ty   = mkForAllTys tvs_here (idType var) -- But new type of course
                  poly_id   = mkLocalId poly_name poly_ty 
@@ -1394,7 +1373,7 @@ prepareDefault dflags env case_bndr (Just (tycon, inst_tys)) imposs_cons (Just d
 
        [con] ->        -- It matches exactly one constructor, so fill it in
                 do { tick (FillInCaseDefault case_bndr)
-                    ; us <- getUniquesSmpl
+                    ; us <- getUniquesM
                     ; let (ex_tvs, co_tvs, arg_ids) =
                               dataConRepInstPat us con inst_tys
                     ; return [(DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, deflt_rhs)] }
@@ -1451,8 +1430,8 @@ mkCase scrut case_bndr ty []
 
 mkCase scrut case_bndr ty alts -- Identity case
   | all identity_alt alts
-  = tick (CaseIdentity case_bndr)              `thenSmpl_`
-    returnSmpl (re_cast scrut)
+  = do tick (CaseIdentity case_bndr)
+       return (re_cast scrut)
   where
     identity_alt (con, args, rhs) = check_eq con args (de_cast rhs)
 
@@ -1485,7 +1464,7 @@ mkCase scrut case_bndr ty alts    -- Identity case
 --------------------------------------------------
 --     Catch-all
 --------------------------------------------------
-mkCase scrut bndr ty alts = returnSmpl (Case scrut bndr ty alts)
+mkCase scrut bndr ty alts = return (Case scrut bndr ty alts)
 \end{code}