[project @ 2000-12-20 18:32:00 by qrczak]

[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreSat.lhs

diff --git a/ghc/compiler/coreSyn/CoreSat.lhs b/ghc/compiler/coreSyn/CoreSat.lhs
index 56c319e..0544875 100644 (file)
--- a/ghc/compiler/coreSyn/CoreSat.lhs
+++ b/ghc/compiler/coreSyn/CoreSat.lhs
@@ -26,6 +26,7 @@ import Maybes
 import ErrUtils
 import CmdLineOpts
 import Outputable
+import PprCore
 \end{code}
 
 -- ---------------------------------------------------------------------------
@@ -161,8 +162,7 @@ coreSatExprFloat :: CoreExpr -> UniqSM ([FloatingBind], CoreExpr)
 --     f (g x)   ===>   ([v = g x], f v)
 
 coreSatExprFloat (Var v)
-  = fiddleCCall v  `thenUs` \ v ->
-    maybeSaturate v (Var v) 0 (idType v) `thenUs` \ app ->
+  = maybeSaturate v (Var v) 0 (idType v) `thenUs` \ app ->
     returnUs ([], app)
 
 coreSatExprFloat (Lit lit)
@@ -240,8 +240,7 @@ coreSatExprFloat expr@(App _ _)
          returnUs (App fun' arg', hd, res_ty, fs ++ floats, ss_rest)
 
     collect_args (Var v) depth
-       = fiddleCCall v   `thenUs` \ v ->
-         returnUs (Var v, (Var v, depth), idType v, [], stricts)
+       = returnUs (Var v, (Var v, depth), idType v, [], stricts)
        where
          stricts = case idStrictness v of
                        StrictnessInfo demands _ 
@@ -300,54 +299,14 @@ cloneTyVar tv
 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
 maybeSaturate fn expr n_args ty
   = case idFlavour fn of
-      PrimOpId op  -> saturate fn expr n_args ty
-      DataConId dc -> saturate fn expr n_args ty
+      PrimOpId op  -> saturate_it
+      DataConId dc -> saturate_it
       other       -> returnUs expr
-
-saturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
-       -- The type should be the type of expr.
-       -- The returned expression should also have this type
-saturate fn expr n_args ty
-  = go excess_arity expr ty
   where
     fn_arity    = idArity fn
     excess_arity = fn_arity - n_args
-
-    go n expr ty
-      | n == 0 -- Saturated, so nothing to do
-      = returnUs expr
-
-      | otherwise      -- An unsaturated constructor or primop; eta expand it
-      = case splitForAllTy_maybe ty of { 
-         Just (tv,ty') -> go n (App expr (Type (mkTyVarTy tv))) ty' `thenUs` \ expr' ->
-                          returnUs (Lam tv expr') ;
-         Nothing ->
-  
-       case splitFunTy_maybe ty of {
-         Just (arg_ty, res_ty) 
-               -> newVar arg_ty                                `thenUs` \ arg' ->
-                  go (n-1) (App expr (Var arg')) res_ty        `thenUs` \ expr' ->
-                  returnUs (Lam arg' expr') ;
-         Nothing -> 
-  
-       case splitNewType_maybe ty of {
-         Just ty' -> go n (mkCoerce ty' ty expr) ty'   `thenUs` \ expr' ->
-                     returnUs (mkCoerce ty ty' expr') ;
-  
-         Nothing -> pprTrace "Bad saturate" ((ppr fn <+> ppr expr) $$ ppr ty)
-                    returnUs expr
-       }}}
-
-
-fiddleCCall id 
-  = case idFlavour id of
-         PrimOpId (CCallOp ccall) ->
-           -- Make a guaranteed unique name for a dynamic ccall.
-           getUniqueUs         `thenUs` \ uniq ->
-           returnUs (modifyIdInfo (`setFlavourInfo` 
-                           PrimOpId (CCallOp (setCCallUnique ccall uniq))) id)
-        other_flavour ->
-            returnUs id
+    saturate_it  = getUs       `thenUs` \ us ->
+                  returnUs (etaExpand excess_arity us expr ty)
 
 -- ---------------------------------------------------------------------------
 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
@@ -376,7 +335,8 @@ deLam expr@(Lam _ _)
     (bndrs, body) = collectBinders expr
 
     eta expr@(App _ _)
-       | n_remaining >= 0 &&
+       | ok_to_eta_reduce f &&
+         n_remaining >= 0 &&
          and (zipWith ok bndrs last_args) &&
          not (any (`elemVarSet` fvs_remaining) bndrs)
        = Just remaining_expr
@@ -390,6 +350,14 @@ deLam expr@(Lam _ _)
          ok bndr (Var arg) = bndr == arg
          ok bndr other     = False
 
+         -- we can't eta reduce something which must be saturated.
+         ok_to_eta_reduce (Var f)
+                = case idFlavour f of
+                     PrimOpId op  -> False
+                     DataConId dc -> False
+                     other        -> True
+         ok_to_eta_reduce _ = False --safe. ToDo: generalise
+
     eta (Let bind@(NonRec b r) body)
        | not (any (`elemVarSet` fvs) bndrs)
                 = case eta body of