[project @ 2000-12-01 13:42:52 by simonpj]

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

diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index bfd7f70..9f0c1a3 100644 (file)
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -29,11 +29,11 @@ import Id           ( Id, idType, idInfo, isDataConId,
                          zapLamIdInfo, setOneShotLambda, 
                        )
 import IdInfo          ( OccInfo(..), isDeadOcc, isLoopBreaker,
-                         ArityInfo, setArityInfo, unknownArity,
+                         setArityInfo, unknownArity,
                          setUnfoldingInfo,
                          occInfo
                        )
-import Demand          ( Demand, isStrict )
+import Demand          ( isStrict )
 import DataCon         ( dataConNumInstArgs, dataConRepStrictness,
                          dataConSig, dataConArgTys
                        )
@@ -42,18 +42,19 @@ import CoreFVs              ( mustHaveLocalBinding, exprFreeVars )
 import CoreUnfold      ( mkOtherCon, mkUnfolding, otherCons,
                          callSiteInline
                        )
-import CoreUtils       ( cheapEqExpr, exprIsDupable, exprIsTrivial, exprIsConApp_maybe,
+import CoreUtils       ( cheapEqExpr, exprIsDupable, exprIsTrivial, 
+                         exprIsConApp_maybe, mkPiType,
                          exprType, coreAltsType, exprIsValue, idAppIsCheap,
-                         exprOkForSpeculation, etaReduceExpr,
+                         exprOkForSpeculation, 
                          mkCoerce, mkSCC, mkInlineMe, mkAltExpr
                        )
 import Rules           ( lookupRule )
 import CostCentre      ( currentCCS )
 import Type            ( mkTyVarTys, isUnLiftedType, seqType,
-                         mkFunTy, splitFunTy, splitTyConApp_maybe, 
+                         mkFunTy, splitTyConApp_maybe, tyConAppArgs,
                          funResultTy
                        )
-import Subst           ( mkSubst, substTy, substExpr,
+import Subst           ( mkSubst, substTy, 
                          isInScope, lookupIdSubst, substIdInfo
                        )
 import TyCon           ( isDataTyCon, tyConDataConsIfAvailable )
@@ -345,7 +346,7 @@ completeLam rev_bndrs body cont
 
        Nothing       -> rebuild (foldl (flip Lam) body' rev_bndrs) cont
   where
-       -- We don't use CoreUtils.etaReduceExpr, because we can be more
+       -- We don't use CoreUtils.etaReduce, because we can be more
        -- efficient here: (a) we already have the binders, (b) we can do
        -- the triviality test before computing the free vars
     try_eta body | not opt_SimplDoEtaReduction = Nothing
@@ -564,7 +565,6 @@ completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside
     old_info          = idInfo old_bndr
     occ_info          = occInfo old_info
     loop_breaker      = isLoopBreaker occ_info
-    trivial_rhs              = exprIsTrivial new_rhs 
     must_keep_binding = black_listed || loop_breaker || isExportedId old_bndr
 
     finally_bind_it arity_info new_rhs
@@ -772,6 +772,7 @@ completeCall var occ cont
   = getBlackList               `thenSmpl` \ black_list_fn ->
     getInScope                 `thenSmpl` \ in_scope ->
     getContArgs var cont       `thenSmpl` \ (args, call_cont, inline_call) ->
+    getDOptsSmpl               `thenSmpl` \ dflags ->
     let
        black_listed       = black_list_fn var
        arg_infos          = [ interestingArg in_scope arg subst 
@@ -784,7 +785,7 @@ completeCall var occ cont
        inline_cont | inline_call = discardInline cont
                    | otherwise   = cont
 
-       maybe_inline = callSiteInline black_listed inline_call occ
+       maybe_inline = callSiteInline dflags black_listed inline_call occ
                                      var arg_infos interesting_cont
     in
        -- First, look for an inlining
@@ -930,7 +931,7 @@ even if they occur exactly once.  Reason:
        (a) some might appear as a function argument, so we simply
                replace static allocation with dynamic allocation:
                   l = <...>
-                  x = f x
+                  x = f l
        becomes
                   x = f <...>
 
@@ -1344,8 +1345,7 @@ prepareCaseAlts _ _ scrut_cons alts
 simplAlts zap_occ_info scrut_cons case_bndr' alts cont'
   = mapSmpl simpl_alt alts
   where
-    inst_tys' = case splitTyConApp_maybe (idType case_bndr') of
-                       Just (tycon, inst_tys) -> inst_tys
+    inst_tys' = tyConAppArgs (idType case_bndr')
 
        -- handled_cons is all the constructors that are dealt
        -- with, either by being impossible, or by there being an alternative
@@ -1557,12 +1557,31 @@ mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs)
        `thenSmpl` \ (final_bndrs', final_args) ->
 
        -- See comment about "$j" name above
-    newId SLIT("$j") (foldr (mkFunTy . idType) rhs_ty' final_bndrs')   $ \ join_bndr ->
-
-       -- Notice that we make the lambdas into one-shot-lambdas.  The
+    newId SLIT("$j") (foldr mkPiType rhs_ty' final_bndrs')     $ \ join_bndr ->
+       -- Notice the funky mkPiType.  If the contructor has existentials
+       -- it's possible that the join point will be abstracted over
+       -- type varaibles as well as term variables.
+       --  Example:  Suppose we have
+       --      data T = forall t.  C [t]
+       --  Then faced with
+       --      case (case e of ...) of
+       --          C t xs::[t] -> rhs
+       --  We get the join point
+       --      let j :: forall t. [t] -> ...
+       --          j = /\t \xs::[t] -> rhs
+       --      in
+       --      case (case e of ...) of
+       --          C t xs::[t] -> j t xs
+
+    let 
+       -- We make the lambdas into one-shot-lambdas.  The
        -- join point is sure to be applied at most once, and doing so
        -- prevents the body of the join point being floated out by
        -- the full laziness pass
-    returnSmpl ([NonRec join_bndr (mkLams (map setOneShotLambda final_bndrs') rhs')],
+       really_final_bndrs = map one_shot final_bndrs'
+       one_shot v | isId v    = setOneShotLambda v
+                  | otherwise = v
+    in
+    returnSmpl ([NonRec join_bndr (mkLams really_final_bndrs rhs')],
                (con, bndrs, mkApps (Var join_bndr) final_args))
 \end{code}