[project @ 2003-06-09 15:37:37 by simonpj]
[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreUtils.lhs
index 88c4c70..28fb335 100644 (file)
@@ -17,9 +17,8 @@ module CoreUtils (
        exprType, coreAltsType, 
        exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, 
        exprIsValue,exprOkForSpeculation, exprIsBig, 
-       exprIsConApp_maybe, exprIsAtom,
-       idAppIsBottom, idAppIsCheap,
-
+       exprIsConApp_maybe, 
+       hasNoRedexes,
 
        -- Arity and eta expansion
        manifestArity, exprArity, 
@@ -44,18 +43,21 @@ import CoreSyn
 import PprCore         ( pprCoreExpr )
 import Var             ( Var, isId, isTyVar )
 import VarEnv
-import Name            ( hashName )
-import Literal         ( hashLiteral, literalType, litIsDupable, isZeroLit )
-import DataCon         ( DataCon, dataConRepArity, dataConArgTys, isExistentialDataCon, dataConTyCon )
+import Name            ( hashName, isDllName )
+import Literal         ( hashLiteral, literalType, litIsDupable, 
+                         litIsTrivial, isZeroLit, isLitLitLit )
+import DataCon         ( DataCon, dataConRepArity, dataConArgTys,
+                         isExistentialDataCon, dataConTyCon, dataConName )
 import PrimOp          ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
 import Id              ( Id, idType, globalIdDetails, idNewStrictness, 
-                         mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
-                         isDataConId_maybe, mkSysLocal, isDataConId, isBottomingId
+                         mkWildId, idArity, idName, idUnfolding, idInfo,
+                         isOneShotLambda, isDataConWorkId_maybe, mkSysLocal,
+                         isDataConWorkId, isBottomingId
                        )
-import IdInfo          ( GlobalIdDetails(..),
-                         megaSeqIdInfo )
+import IdInfo          ( GlobalIdDetails(..), megaSeqIdInfo )
 import NewDemand       ( appIsBottom )
-import Type            ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy,
+import Type            ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
+                         splitFunTy,
                          applyTys, isUnLiftedType, seqType, mkTyVarTy,
                          splitForAllTy_maybe, isForAllTy, splitNewType_maybe, 
                          splitTyConApp_maybe, eqType, funResultTy, applyTy,
@@ -326,21 +328,11 @@ saturating them.
 \begin{code}
 exprIsTrivial (Var v)     = True       -- See notes above
 exprIsTrivial (Type _)    = True
-exprIsTrivial (Lit lit)    = True
+exprIsTrivial (Lit lit)    = litIsTrivial lit
 exprIsTrivial (App e arg)  = not (isRuntimeArg arg) && exprIsTrivial e
 exprIsTrivial (Note _ e)   = exprIsTrivial e
 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
 exprIsTrivial other       = False
-
-exprIsAtom :: CoreExpr -> Bool
--- Used to decide whether to let-binding an STG argument
--- when compiling to ILX => type applications are not allowed
-exprIsAtom (Var v)    = True   -- primOpIsDupable?
-exprIsAtom (Lit lit)  = True
-exprIsAtom (Type ty)  = True
-exprIsAtom (Note (SCC _) e) = False
-exprIsAtom (Note _ e) = exprIsAtom e
-exprIsAtom other      = False
 \end{code}
 
 
@@ -446,10 +438,10 @@ idAppIsCheap id n_val_args
                                -- a variable (f t1 t2 t3)
                                -- counts as WHNF
   | otherwise = case globalIdDetails id of
-                 DataConId _   -> True                 
-                 RecordSelId _ -> True                 -- I'm experimenting with making record selection
-                                                       -- look cheap, so we will substitute it inside a
-                                                       -- lambda.  Particularly for dictionary field selection
+                 DataConWorkId _ -> True                       
+                 RecordSelId _   -> True       -- I'm experimenting with making record selection
+                 ClassOpId _     -> True       -- look cheap, so we will substitute it inside a
+                                               -- lambda.  Particularly for dictionary field selection
 
                  PrimOpId op   -> primOpIsCheap op     -- In principle we should worry about primops
                                                        -- that return a type variable, since the result
@@ -496,7 +488,7 @@ exprOkForSpeculation other_expr
        other         -> False
  
   where
-    spec_ok (DataConId _) args
+    spec_ok (DataConWorkId _) args
       = True   -- The strictness of the constructor has already
                -- been expressed by its "wrapper", so we don't need
                -- to take the arguments into account
@@ -577,7 +569,7 @@ type must be ok-for-speculation (or trivial).
 \begin{code}
 exprIsValue :: CoreExpr -> Bool                -- True => Value-lambda, constructor, PAP
 exprIsValue (Var v)    -- NB: There are no value args at this point
-  =  isDataConId v     -- Catches nullary constructors, 
+  =  isDataConWorkId v         -- Catches nullary constructors, 
                        --      so that [] and () are values, for example
   || idArity v > 0     -- Catches (e.g.) primops that don't have unfoldings
   || isEvaldUnfolding (idUnfolding v)
@@ -596,7 +588,7 @@ exprIsValue other        = False
 
 -- There is at least one value argument
 app_is_value (Var fun) args
-  |  isDataConId fun                   -- Constructor apps are values
+  |  isDataConWorkId fun                       -- Constructor apps are values
   || idArity fun > valArgCount args    -- Under-applied function
   = check_args (idType fun) args
 app_is_value (App f a) as = app_is_value f (a:as)
@@ -665,7 +657,7 @@ exprIsConApp_maybe (Note _ expr)
 exprIsConApp_maybe expr = analyse (collectArgs expr)
   where
     analyse (Var fun, args)
-       | Just con <- isDataConId_maybe fun,
+       | Just con <- isDataConWorkId_maybe fun,
          args `lengthAtLeast` dataConRepArity con
                -- Might be > because the arity excludes type args
        = Just (con,args)
@@ -690,38 +682,62 @@ exprIsConApp_maybe expr = analyse (collectArgs expr)
 
 \begin{code}
 exprEtaExpandArity :: CoreExpr -> Arity
--- The Int is number of value args the thing can be 
---     applied to without doing much work
---
--- This is used when eta expanding
---     e  ==>  \xy -> e x y
---
--- It returns 1 (or more) to:
---     case x of p -> \s -> ...
--- because for I/O ish things we really want to get that \s to the top.
--- We are prepared to evaluate x each time round the loop in order to get that
-
--- It's all a bit more subtle than it looks.  Consider one-shot lambdas
---             let x = expensive in \y z -> E
--- We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
--- Hence the ArityType returned by arityType
-
--- NB: this is particularly important/useful for IO state 
--- transformers, where we often get
---     let x = E in \ s -> ...
--- and the \s is a real-world state token abstraction.  Such 
--- abstractions are almost invariably 1-shot, so we want to
--- pull the \s out, past the let x=E.  
--- The hack is in Id.isOneShotLambda
---
--- Consider also 
---     f = \x -> error "foo"
--- Here, arity 1 is fine.  But if it is
---     f = \x -> case e of 
---                     True  -> error "foo"
---                     False -> \y -> x+y
--- then we want to get arity 2.
--- Hence the ABot/ATop in ArityType
+{- The Arity returned is the number of value args the 
+   thing can be applied to without doing much work
+
+exprEtaExpandArity is used when eta expanding
+       e  ==>  \xy -> e x y
+
+It returns 1 (or more) to:
+       case x of p -> \s -> ...
+because for I/O ish things we really want to get that \s to the top.
+We are prepared to evaluate x each time round the loop in order to get that
+
+It's all a bit more subtle than it looks:
+
+1.  One-shot lambdas
+
+Consider one-shot lambdas
+               let x = expensive in \y z -> E
+We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
+Hence the ArityType returned by arityType
+
+2.  The state-transformer hack
+
+The one-shot lambda special cause is particularly important/useful for
+IO state transformers, where we often get
+       let x = E in \ s -> ...
+
+and the \s is a real-world state token abstraction.  Such abstractions
+are almost invariably 1-shot, so we want to pull the \s out, past the
+let x=E, even if E is expensive.  So we treat state-token lambdas as 
+one-shot even if they aren't really.  The hack is in Id.isOneShotLambda.
+
+3.  Dealing with bottom
+
+Consider also 
+       f = \x -> error "foo"
+Here, arity 1 is fine.  But if it is
+       f = \x -> case x of 
+                       True  -> error "foo"
+                       False -> \y -> x+y
+then we want to get arity 2.  Tecnically, this isn't quite right, because
+       (f True) `seq` 1
+should diverge, but it'll converge if we eta-expand f.  Nevertheless, we
+do so; it improves some programs significantly, and increasing convergence
+isn't a bad thing.  Hence the ABot/ATop in ArityType.
+
+Actually, the situation is worse.  Consider
+       f = \x -> case x of
+                       True  -> \y -> x+y
+                       False -> \y -> x-y
+Can we eta-expand here?  At first the answer looks like "yes of course", but
+consider
+       (f bot) `seq` 1
+This should diverge!  But if we eta-expand, it won't.   Again, we ignore this
+"problem", because being scrupulous would lose an important transformation for
+many programs.
+-}
 
 
 exprEtaExpandArity e = arityDepth (arityType e)
@@ -1045,6 +1061,7 @@ eqExpr e1 e2
     eq_note env (SCC cc1)      (SCC cc2)      = cc1 == cc2
     eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
     eq_note env InlineCall     InlineCall     = True
+    eq_note env (CoreNote s1)  (CoreNote s2)  = s1 == s2
     eq_note env other1        other2         = False
 \end{code}
 
@@ -1075,6 +1092,7 @@ noteSize (SCC cc)       = cc `seq` 1
 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
 noteSize InlineCall     = 1
 noteSize InlineMe       = 1
+noteSize (CoreNote s)   = s `seq` 1  -- hdaume: core annotations
 
 varSize :: Var -> Int
 varSize b  | isTyVar b = 1
@@ -1126,3 +1144,99 @@ fast_hash_expr other             = 1
 hashId :: Id -> Int
 hashId id = hashName (idName id)
 \end{code}
+
+%************************************************************************
+%*                                                                     *
+\subsection{Determining non-updatable right-hand-sides}
+%*                                                                     *
+%************************************************************************
+
+Top-level constructor applications can usually be allocated 
+statically, but they can't if 
+   a) the constructor, or any of the arguments, come from another DLL
+   b) any of the arguments are LitLits
+(because we can't refer to static labels in other DLLs).
+
+If this happens we simply make the RHS into an updatable thunk, 
+and 'exectute' it rather than allocating it statically.
+
+\begin{code}
+hasNoRedexes :: CoreExpr -> Bool
+-- This function is called only on *top-level* right-hand sides
+-- Returns True if 
+--     the expression contains any redex that 
+--     is not under a (value) lambda
+-- and
+--     it contains no cross-DLL references
+--
+-- The real reason: either
+--     a) the rhs *is* a redex, in which case it's a CAF
+--        (remember the arg is always a top-level rhs)
+-- or   b) the nested redex will ultimately be floated by CorePrep
+--        and will be a CAF, so this rhs *refers* to a CAF
+--
+-- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
+-- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
+-- update flag on it.  In case (ii), the ANF-ising of CorePrep means that
+-- (b) cannot be the case, so it must be (a)!
+--
+-- NB: we treat partial applications as redexes,
+-- because in fact we make a thunk for them that runs and builds a PAP
+-- at run-time.  The only appliations that are treated as non-redexes
+-- are saturated applications of constructors
+--
+--
+--     f = \x::Int. x+7        TRUE
+--     p = (True,False)        TRUE
+--
+--     d = (fst p, False)      FALSE because there's a redex inside
+--                             (this particular one doesn't happen but...)
+--
+--     h = D# (1.0## /## 2.0##)        FALSE (redex again)
+--     n = /\a. Nil a                  TRUE
+--
+--     t = /\a. (:) (case w a of ...) (Nil a)  FALSE (redex)
+--
+--
+-- This is a bit like CoreUtils.exprIsValue, with the following differences:
+--    a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
+--
+--    b) (C x xs), where C is a contructors is updatable if the application is
+--        dynamic
+-- 
+--    c) don't look through unfolding of f in (f x).
+--
+-- When opt_RuntimeTypes is on, we keep type lambdas and treat
+-- them as making the RHS re-entrant (non-updatable).
+--
+hasNoRedexes (Lam b e)        = isRuntimeVar b || hasNoRedexes e
+hasNoRedexes (Note (SCC _) e) = False
+hasNoRedexes (Note _ e)       = hasNoRedexes e
+hasNoRedexes (Lit lit)        = not (isLitLitLit lit)
+       -- lit-lit arguments cannot be used in static constructors either.  
+       -- (litlits are deprecated, so I'm not going to bother cleaning up this infelicity --SDM).
+hasNoRedexes other_expr              = go other_expr 0
+  where
+    go (Var f) n_val_args
+       | not (isDllName (idName f))
+       = n_val_args == 0 || saturated_data_con f n_val_args
+
+    go (App f a) n_val_args
+       | isTypeArg a    = go f n_val_args
+       | hasNoRedexes a = go f (n_val_args + 1)
+          -- NB. args sometimes not atomic.  eg.
+          --   x = D# (1.0## /## 2.0##)
+          -- can't float because /## can fail.
+
+    go (Note (SCC _) f) n_val_args = False
+    go (Note _ f) n_val_args       = go f n_val_args
+
+    go other n_val_args = False
+
+    saturated_data_con f n_val_args
+       = case isDataConWorkId_maybe f of
+           Just dc -> n_val_args == dataConRepArity dc
+           Nothing -> False
+\end{code}
+
+