[project @ 2001-01-12 11:04:45 by simonmar]

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

diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs
index 1e4ac02..2454748 100644 (file)
--- a/ghc/compiler/coreSyn/CoreTidy.lhs
+++ b/ghc/compiler/coreSyn/CoreTidy.lhs
@@ -14,7 +14,7 @@ module CoreTidy (
 import CmdLineOpts     ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
 import CoreSyn
 import CoreUnfold      ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
 import CmdLineOpts     ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
 import CoreSyn
 import CoreUnfold      ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )

-import CoreUtils       ( exprArity, exprIsBottom )
+import CoreUtils       ( exprArity )

 import CoreFVs         ( ruleSomeFreeVars, exprSomeFreeVars )
 import CoreLint                ( showPass, endPass )
 import VarEnv
 import CoreFVs         ( ruleSomeFreeVars, exprSomeFreeVars )
 import CoreLint                ( showPass, endPass )
 import VarEnv

@@ -22,11 +22,11 @@ import VarSet
 import Var             ( Id, Var )
 import Id              ( idType, idInfo, idName, isExportedId,
                          idCafInfo, mkId, isLocalId, isImplicitId,
 import Var             ( Id, Var )
 import Id              ( idType, idInfo, idName, isExportedId,
                          idCafInfo, mkId, isLocalId, isImplicitId,

-                         idFlavour, modifyIdInfo
+                         idFlavour, modifyIdInfo, idArity

                        ) 
 import IdInfo          {- loads of stuff -}
 import Name            ( getOccName, nameOccName, globaliseName, setNameOcc, 
                        ) 
 import IdInfo          {- loads of stuff -}
 import Name            ( getOccName, nameOccName, globaliseName, setNameOcc, 

-                         localiseName, mkLocalName, isGlobalName
+                         localiseName, mkLocalName, isGlobalName, isDllName

                        )
 import OccName         ( TidyOccEnv, initTidyOccEnv, tidyOccName )
 import Type            ( tidyTopType, tidyType, tidyTyVar )
                        )
 import OccName         ( TidyOccEnv, initTidyOccEnv, tidyOccName )
 import Type            ( tidyTopType, tidyType, tidyTyVar )

@@ -34,9 +34,11 @@ import Module                ( Module, moduleName )
 import PrimOp          ( PrimOp(..), setCCallUnique )
 import HscTypes                ( PersistentCompilerState( pcs_PRS ), 
                          PersistentRenamerState( prsOrig ),
 import PrimOp          ( PrimOp(..), setCCallUnique )
 import HscTypes                ( PersistentCompilerState( pcs_PRS ), 
                          PersistentRenamerState( prsOrig ),

-                         OrigNameEnv( origNames ), OrigNameNameEnv
+                         NameSupply( nsNames ), OrigNameCache

                        )
 import UniqSupply
                        )
 import UniqSupply

+import DataCon         ( dataConName )
+import Literal         ( isLitLitLit )

 import FiniteMap       ( lookupFM, addToFM )
 import Maybes          ( maybeToBool, orElse )
 import ErrUtils                ( showPass )
 import FiniteMap       ( lookupFM, addToFM )
 import Maybes          ( maybeToBool, orElse )
 import ErrUtils                ( showPass )

@@ -94,10 +96,19 @@ binder
     that all Ids are unique, rather than the weaker guarantee of
     no clashes which the simplifier provides.
 
     that all Ids are unique, rather than the weaker guarantee of
     no clashes which the simplifier provides.
 

-  - Give the Id its final IdInfo; in ptic, 
+  - Give each dynamic CCall occurrence a fresh unique; this is
+    rather like the cloning step above.
+
+  - Give the Id its UTTERLY FINAL IdInfo; in ptic, 

        * Its flavour becomes ConstantId, reflecting the fact that
          from now on we regard it as a constant, not local, Id
        * Its flavour becomes ConstantId, reflecting the fact that
          from now on we regard it as a constant, not local, Id

+

        * its unfolding, if it should have one
        * its unfolding, if it should have one

+       
+       * its arity, computed from the number of visible lambdas
+
+       * its CAF info, computed from what is free in its RHS
+

                
 Finally, substitute these new top-level binders consistently
 throughout, including in unfoldings.  We also tidy binders in
                
 Finally, substitute these new top-level binders consistently
 throughout, including in unfoldings.  We also tidy binders in

@@ -122,7 +133,7 @@ tidyCorePgm dflags mod pcs binds_in orphans_in
        ; let (orphans_out, _) 
                   = initUs us1 (tidyIdRules (occ_env,subst_env) orphans_in)
 
        ; let (orphans_out, _) 
                   = initUs us1 (tidyIdRules (occ_env,subst_env) orphans_in)
 

-       ; let prs' = prs { prsOrig = orig { origNames = orig_env' } }
+       ; let prs' = prs { prsOrig = orig { nsNames = orig_env' } }

              pcs' = pcs { pcs_PRS = prs' }
 
        ; endPass dflags "Tidy Core" Opt_D_dump_simpl binds_out
              pcs' = pcs { pcs_PRS = prs' }
 
        ; endPass dflags "Tidy Core" Opt_D_dump_simpl binds_out

@@ -140,7 +151,7 @@ tidyCorePgm dflags mod pcs binds_in orphans_in
        -- decl.  tidyTopId then does a no-op on exported binders.
     prs                     = pcs_PRS pcs
     orig            = prsOrig prs
        -- decl.  tidyTopId then does a no-op on exported binders.
     prs                     = pcs_PRS pcs
     orig            = prsOrig prs

-    orig_env        = origNames orig
+    orig_env        = nsNames orig

 
     init_tidy_env us = (us, orig_env, initTidyOccEnv avoids, emptyVarEnv)
     avoids          = [getOccName bndr | bndr <- bindersOfBinds binds_in,
 
     init_tidy_env us = (us, orig_env, initTidyOccEnv avoids, emptyVarEnv)
     avoids          = [getOccName bndr | bndr <- bindersOfBinds binds_in,

@@ -248,7 +259,7 @@ addExternal (id,rhs) needed
 
 
 \begin{code}
 
 
 \begin{code}

-type TopTidyEnv = (UniqSupply, OrigNameNameEnv, TidyOccEnv, VarEnv Var)
+type TopTidyEnv = (UniqSupply, OrigNameCache, TidyOccEnv, VarEnv Var)

 
 -- TopTidyEnv: when tidying we need to know
 --   * orig_env: Any pre-ordained Names.  These may have arisen because the
 
 -- TopTidyEnv: when tidying we need to know
 --   * orig_env: Any pre-ordained Names.  These may have arisen because the

@@ -354,16 +365,15 @@ tidyTopBinder mod ext_ids tidy_env rhs caf_info
 tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id
   | opt_OmitInterfacePragmas || not is_external
        -- No IdInfo if the Id isn't external, or if we don't have -O
 tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id
   | opt_OmitInterfacePragmas || not is_external
        -- No IdInfo if the Id isn't external, or if we don't have -O

-  = mkIdInfo new_flavour 
+  = mkIdInfo new_flavour caf_info

        `setStrictnessInfo` strictnessInfo core_idinfo
        `setArityInfo`      ArityExactly arity_info
        `setStrictnessInfo` strictnessInfo core_idinfo
        `setArityInfo`      ArityExactly arity_info

-       `setCafInfo`        caf_info

        -- Keep strictness, arity and CAF info; it's used by the code generator
 
   | otherwise
   =  let (rules', _) = initUs us (tidyRules tidy_env (specInfo core_idinfo))
      in
        -- Keep strictness, arity and CAF info; it's used by the code generator
 
   | otherwise
   =  let (rules', _) = initUs us (tidyRules tidy_env (specInfo core_idinfo))
      in

-     mkIdInfo new_flavour
+     mkIdInfo new_flavour caf_info

        `setCprInfo`        cprInfo core_idinfo
        `setStrictnessInfo` strictnessInfo core_idinfo
        `setInlinePragInfo` inlinePragInfo core_idinfo
        `setCprInfo`        cprInfo core_idinfo
        `setStrictnessInfo` strictnessInfo core_idinfo
        `setInlinePragInfo` inlinePragInfo core_idinfo

@@ -371,7 +381,6 @@ tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id
        `setWorkerInfo`     tidyWorker tidy_env arity_info (workerInfo core_idinfo)
        `setSpecInfo`       rules'
        `setArityInfo`      ArityExactly arity_info
        `setWorkerInfo`     tidyWorker tidy_env arity_info (workerInfo core_idinfo)
        `setSpecInfo`       rules'
        `setArityInfo`      ArityExactly arity_info

-       `setCafInfo`        caf_info

                -- this is the final IdInfo, it must agree with the
                -- code finally generated (i.e. NO more transformations
                -- after this!).
                -- this is the final IdInfo, it must agree with the
                -- code finally generated (i.e. NO more transformations
                -- after this!).

@@ -647,15 +656,46 @@ cafRefss p (e:es) = cafRefs p e `fastOr` cafRefss p es
 -- in an SRT or not.
 
 isCAF :: CoreExpr -> Bool
 -- in an SRT or not.
 
 isCAF :: CoreExpr -> Bool

-   -- special case for expressions which are always bottom,
-   -- such as 'error "..."'.  We don't need to record it as
-   -- a CAF, since it can only be entered once.
-isCAF e 
-  | not_function && is_bottom = False
-  | not_function && updatable = True
-  | otherwise                = False
+isCAF e = not (rhsIsNonUpd e)
+  {- ToDo: check type for onceness, i.e. non-updatable thunks? -}
+
+rhsIsNonUpd :: CoreExpr -> Bool        -- True => Value-lambda, constructor, PAP
+rhsIsNonUpd (Lam b e)          = isId b || rhsIsNonUpd e
+rhsIsNonUpd (Note (SCC _) e)   = False
+rhsIsNonUpd (Note _ e)         = rhsIsNonUpd e
+rhsIsNonUpd other_expr
+  = go other_expr 0 []

   where
   where

-    not_function = exprArity e == 0
-    is_bottom    = exprIsBottom e
-    updatable    = True {- ToDo: check type for onceness? -}
+    go (Var f) n_args args = idAppIsNonUpd f n_args args
+       
+    go (App f a) n_args args
+       | isTypeArg a = go f n_args args
+       | otherwise   = go f (n_args + 1) (a:args)
+
+    go (Note (SCC _) f) n_args args = False
+    go (Note _ f) n_args args       = go f n_args args
+
+    go other n_args args = False
+
+idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
+idAppIsNonUpd id n_val_args args
+  = case idFlavour id of
+       DataConId con | not (isDynConApp con args) -> True
+       other -> n_val_args < idArity id
+
+isDynConApp con args = isDllName (dataConName con) || any isDynArg args
+
+       -- Does this argument refer to something in a different DLL,
+       -- or is a LitLit?  Constructor arguments which are in another
+       -- DLL or are LitLits aren't compiled into static constructors
+       -- (see CoreToStg), so we have to take that into account here.
+isDynArg :: CoreExpr -> Bool
+isDynArg (Var v)    = isDllName (idName v)
+isDynArg (Note _ e) = isDynArg e
+isDynArg (Lit lit)  = isLitLitLit lit
+isDynArg (App e _)  = isDynArg e       -- must be a type app
+isDynArg (Lam _ e)  = isDynArg e       -- must be a type lam
+
+-- We consider partial applications to be non-updatable.  NOTE: this
+-- must match how CoreToStg marks the closure.

 \end{code}
 \end{code}