[project @ 2001-10-15 15:06:01 by simonpj]

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

diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs
index 2f45691..4e1a4d5 100644 (file)
--- a/ghc/compiler/coreSyn/CoreTidy.lhs
+++ b/ghc/compiler/coreSyn/CoreTidy.lhs
@@ -15,24 +15,27 @@ import CmdLineOpts  ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
 import CoreSyn
 import CoreUnfold      ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
 import CoreFVs         ( ruleSomeFreeVars, exprSomeFreeVars )
 import CoreSyn
 import CoreUnfold      ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
 import CoreFVs         ( ruleSomeFreeVars, exprSomeFreeVars )

+import PprCore         ( pprIdCoreRule )

 import CoreLint                ( showPass, endPass )
 import VarEnv
 import VarSet
 import Var             ( Id, Var )
 import Id              ( idType, idInfo, idName, isExportedId, 
                          idSpecialisation, idUnique, isDataConWrapId,
 import CoreLint                ( showPass, endPass )
 import VarEnv
 import VarSet
 import Var             ( Id, Var )
 import Id              ( idType, idInfo, idName, isExportedId, 
                          idSpecialisation, idUnique, isDataConWrapId,

-                         mkVanillaGlobal, isLocalId, isRecordSelector,
-                         setIdUnfolding, hasNoBinding, mkUserLocal,
-                         idNewDemandInfo, setIdNewDemandInfo
+                         mkVanillaGlobal, mkGlobalId, isLocalId, 
+                         isDataConId, mkUserLocal, isGlobalId, globalIdDetails,
+                         idNewDemandInfo, setIdNewDemandInfo, setIdCgInfo,
+                         idNewStrictness, setIdNewStrictness

                        ) 
 import IdInfo          {- loads of stuff -}
                        ) 
 import IdInfo          {- loads of stuff -}

-import NewDemand       ( isBottomingSig, topSig, isStrictDmd )
+import NewDemand       ( isBottomingSig, topSig )
+import BasicTypes      ( isNeverActive )

 import Name            ( getOccName, nameOccName, globaliseName, setNameOcc, 
                          localiseName, isGlobalName, setNameUnique
                        )
 import NameEnv         ( filterNameEnv )
 import OccName         ( TidyOccEnv, initTidyOccEnv, tidyOccName )
 import Name            ( getOccName, nameOccName, globaliseName, setNameOcc, 
                          localiseName, isGlobalName, setNameUnique
                        )
 import NameEnv         ( filterNameEnv )
 import OccName         ( TidyOccEnv, initTidyOccEnv, tidyOccName )

-import Type            ( tidyTopType, tidyType, tidyTyVar )
+import Type            ( tidyTopType, tidyType, tidyTyVarBndr )

 import Module          ( Module, moduleName )
 import HscTypes                ( PersistentCompilerState( pcs_PRS ), 
                          PersistentRenamerState( prsOrig ),
 import Module          ( Module, moduleName )
 import HscTypes                ( PersistentCompilerState( pcs_PRS ), 
                          PersistentRenamerState( prsOrig ),

@@ -41,13 +44,14 @@ import HscTypes             ( PersistentCompilerState( pcs_PRS ),
                          ModDetails(..), TyThing(..)
                        )
 import FiniteMap       ( lookupFM, addToFM )
                          ModDetails(..), TyThing(..)
                        )
 import FiniteMap       ( lookupFM, addToFM )

-import Maybes          ( maybeToBool, orElse )
-import ErrUtils                ( showPass )
+import Maybes          ( orElse )
+import ErrUtils                ( showPass, dumpIfSet_core )

 import SrcLoc          ( noSrcLoc )
 import UniqFM          ( mapUFM )
 import UniqSupply      ( splitUniqSupply, uniqFromSupply )
 import List            ( partition )
 import Util            ( mapAccumL )
 import SrcLoc          ( noSrcLoc )
 import UniqFM          ( mapUFM )
 import UniqSupply      ( splitUniqSupply, uniqFromSupply )
 import List            ( partition )
 import Util            ( mapAccumL )

+import Maybe           ( isJust )

 import Outputable
 \end{code}
 
 import Outputable
 \end{code}
 

@@ -95,7 +99,8 @@ binder
     to ensure that the unique assigned is the same as the Id had 
     in any previous compilation run.
   
     to ensure that the unique assigned is the same as the Id had 
     in any previous compilation run.
   

- 3. If it's an external Id, make it have a global Name and vice versa.
+ 3. If it's an external Id, make it have a global Name, otherwise
+    make it have a local Name.

     This is used by the code generator to decide whether
     to make the label externally visible
 
     This is used by the code generator to decide whether
     to make the label externally visible
 

@@ -150,7 +155,7 @@ tidyCorePgm dflags mod pcs cg_info_env
                                                   isGlobalName (idName bndr)]
 
        ; let ((orig_ns', occ_env, subst_env), tidy_binds) 
                                                   isGlobalName (idName bndr)]
 
        ; let ((orig_ns', occ_env, subst_env), tidy_binds) 

-                       = mapAccumL (tidyTopBind mod ext_ids cg_info_env) 
+                       = mapAccumL (tidyTopBind mod ext_ids) 

                                    init_tidy_env binds_in
 
        ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules
                                    init_tidy_env binds_in
 
        ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules

@@ -158,7 +163,8 @@ tidyCorePgm dflags mod pcs cg_info_env
        ; let prs' = prs { prsOrig = orig_ns' }
              pcs' = pcs { pcs_PRS = prs' }
 
        ; let prs' = prs { prsOrig = orig_ns' }
              pcs' = pcs { pcs_PRS = prs' }
 

-       ; let final_ids  = [ id | bind <- tidy_binds
+       ; let final_ids  = [ addCgInfo cg_info_env id 
+                          | bind <- tidy_binds

                           , id <- bindersOf bind
                           , isGlobalName (idName id)]
 
                           , id <- bindersOf bind
                           , isGlobalName (idName id)]
 

@@ -177,10 +183,23 @@ tidyCorePgm dflags mod pcs cg_info_env
                                          md_binds = tidy_binds }
 
        ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds
                                          md_binds = tidy_binds }
 
        ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds

+       ; dumpIfSet_core dflags Opt_D_dump_simpl
+               "Tidy Core Rules"
+               (vcat (map pprIdCoreRule tidy_rules))

 
        ; return (pcs', tidy_details)
        }
 
 
        ; return (pcs', tidy_details)
        }
 

+addCgInfo :: CgInfoEnv -> Id -> Id
+-- Pin on the info that comes from the code generator
+-- This doesn't make its way into the *bindings* that 
+-- go on to the code generator (that might give black holes etc)
+-- Rather, it's pinned onto the Id in the type environment 
+-- that (a) generates the interface file
+--     (b) in GHCi goes into subsequent compilations
+addCgInfo cg_info_env id 
+  = id `setIdCgInfo` lookupCgInfo cg_info_env (idName id)
+

 tidyCoreExpr :: CoreExpr -> IO CoreExpr
 tidyCoreExpr expr = return (tidyExpr emptyTidyEnv expr)
 \end{code}
 tidyCoreExpr :: CoreExpr -> IO CoreExpr
 tidyCoreExpr expr = return (tidyExpr emptyTidyEnv expr)
 \end{code}

@@ -216,9 +235,9 @@ mkFinalTypeEnv type_env final_ids
        -- in interface files, because they are needed by importing modules when
        -- using the compilation manager
 
        -- in interface files, because they are needed by importing modules when
        -- using the compilation manager
 

-       -- We keep "hasNoBinding" Ids, notably constructor workers, 
+       -- We keep constructor workers, 

        -- because they won't appear in the bindings from which final_ids are derived!
        -- because they won't appear in the bindings from which final_ids are derived!

-    keep_it (AnId id) = hasNoBinding id        -- Remove all Ids except constructor workers
+    keep_it (AnId id) = isDataConId id -- Remove all Ids except constructor workers

     keep_it other     = True           -- Keep all TyCons and Classes
 \end{code}
 
     keep_it other     = True           -- Keep all TyCons and Classes
 \end{code}
 

@@ -306,7 +325,7 @@ addExternal (id,rhs) needed
                                                spec_ids
 
     idinfo        = idInfo id
                                                spec_ids
 
     idinfo        = idInfo id

-    dont_inline           = isNeverInlinePrag (inlinePragInfo idinfo)
+    dont_inline           = isNeverActive (inlinePragInfo idinfo)

     loop_breaker   = isLoopBreaker (occInfo idinfo)
     bottoming_fn   = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
     spec_ids      = rulesRhsFreeVars (specInfo idinfo)
     loop_breaker   = isLoopBreaker (occInfo idinfo)
     bottoming_fn   = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
     spec_ids      = rulesRhsFreeVars (specInfo idinfo)

@@ -367,19 +386,18 @@ type TopTidyEnv = (NameSupply, TidyOccEnv, VarEnv Var)
 tidyTopBind :: Module
            -> IdEnv Bool       -- Domain = Ids that should be external
                                -- True <=> their unfolding is external too
 tidyTopBind :: Module
            -> IdEnv Bool       -- Domain = Ids that should be external
                                -- True <=> their unfolding is external too

-           -> CgInfoEnv

            -> TopTidyEnv -> CoreBind
            -> (TopTidyEnv, CoreBind)
 
            -> TopTidyEnv -> CoreBind
            -> (TopTidyEnv, CoreBind)
 

-tidyTopBind mod ext_ids cg_info_env top_tidy_env (NonRec bndr rhs)
+tidyTopBind mod ext_ids top_tidy_env (NonRec bndr rhs)

   = ((orig,occ,subst) , NonRec bndr' rhs')
   where
     ((orig,occ,subst), bndr')
   = ((orig,occ,subst) , NonRec bndr' rhs')
   where
     ((orig,occ,subst), bndr')

-        = tidyTopBinder mod ext_ids cg_info_env rec_tidy_env rhs' top_tidy_env bndr
+        = tidyTopBinder mod ext_ids rec_tidy_env rhs' top_tidy_env bndr

     rec_tidy_env = (occ,subst)
     rhs' = tidyExpr rec_tidy_env rhs
 
     rec_tidy_env = (occ,subst)
     rhs' = tidyExpr rec_tidy_env rhs
 

-tidyTopBind mod ext_ids cg_info_env top_tidy_env (Rec prs)
+tidyTopBind mod ext_ids top_tidy_env (Rec prs)

   = (final_env, Rec prs')
   where
     (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs
   = (final_env, Rec prs')
   where
     (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs

@@ -389,13 +407,12 @@ tidyTopBind mod ext_ids cg_info_env top_tidy_env (Rec prs)
        = ((orig,occ,subst), (bndr',rhs'))
        where
        ((orig,occ,subst), bndr')
        = ((orig,occ,subst), (bndr',rhs'))
        where
        ((orig,occ,subst), bndr')

-          = tidyTopBinder mod ext_ids cg_info_env 
+          = tidyTopBinder mod ext_ids

                rec_tidy_env rhs' top_tidy_env bndr
 
         rhs' = tidyExpr rec_tidy_env rhs
 
 tidyTopBinder :: Module -> IdEnv Bool
                rec_tidy_env rhs' top_tidy_env bndr
 
         rhs' = tidyExpr rec_tidy_env rhs
 
 tidyTopBinder :: Module -> IdEnv Bool

-             -> CgInfoEnv

              -> TidyEnv -> CoreExpr
                        -- The TidyEnv is used to tidy the IdInfo
                        -- The expr is the already-tided RHS
              -> TidyEnv -> CoreExpr
                        -- The TidyEnv is used to tidy the IdInfo
                        -- The expr is the already-tided RHS

@@ -403,7 +420,7 @@ tidyTopBinder :: Module -> IdEnv Bool
              -> TopTidyEnv -> Id -> (TopTidyEnv, Id)
   -- NB: tidyTopBinder doesn't affect the unique supply
 
              -> TopTidyEnv -> Id -> (TopTidyEnv, Id)
   -- NB: tidyTopBinder doesn't affect the unique supply
 

-tidyTopBinder mod ext_ids cg_info_env tidy_env rhs
+tidyTopBinder mod ext_ids tidy_env rhs

              env@(ns2, occ_env2, subst_env2) id
 
   | isDataConWrapId id -- Don't tidy constructor wrappers
              env@(ns2, occ_env2, subst_env2) id
 
   | isDataConWrapId id -- Don't tidy constructor wrappers

@@ -428,11 +445,6 @@ tidyTopBinder mod ext_ids cg_info_env tidy_env rhs
 -- all, but in any case it will have the error message inline so it won't matter.
 
 
 -- all, but in any case it will have the error message inline so it won't matter.
 
 

-  | isRecordSelector id        -- We can't use the "otherwise" case, because that
-                       -- forgets the IdDetails, which forgets that this is
-                       -- a record selector, which confuses an importing module
-  = (env, id `setIdUnfolding` unfold_info)
-

   | otherwise
        -- This function is the heart of Step 2
        -- The second env is the one to use for the IdInfo
   | otherwise
        -- This function is the heart of Step 2
        -- The second env is the one to use for the IdInfo

@@ -448,14 +460,17 @@ tidyTopBinder mod ext_ids cg_info_env tidy_env rhs
                                               is_external
                                               (idName id)
     ty'            = tidyTopType (idType id)
                                               is_external
                                               (idName id)
     ty'            = tidyTopType (idType id)

-    cg_info = lookupCgInfo cg_info_env name'
-    idinfo' = tidyIdInfo tidy_env is_external unfold_info cg_info id
+    idinfo' = tidyIdInfo tidy_env is_external unfold_info id
+
+    id' | isGlobalId id = mkGlobalId (globalIdDetails id) name' ty' idinfo'
+       | otherwise     = mkVanillaGlobal                 name' ty' idinfo'
+       -- The test ensures that record selectors (which must be tidied; see above)
+       -- retain their details.  If it's forgotten, importing modules get confused.

 
 

-    id'               = mkVanillaGlobal name' ty' idinfo'

     subst_env' = extendVarEnv subst_env2 id id'
 
     maybe_external = lookupVarEnv ext_ids id
     subst_env' = extendVarEnv subst_env2 id id'
 
     maybe_external = lookupVarEnv ext_ids id

-    is_external    = maybeToBool maybe_external
+    is_external    = isJust maybe_external

 
     -- Expose an unfolding if ext_ids tells us to
     show_unfold = maybe_external `orElse` False
 
     -- Expose an unfolding if ext_ids tells us to
     show_unfold = maybe_external `orElse` False

@@ -463,17 +478,17 @@ tidyTopBinder mod ext_ids cg_info_env tidy_env rhs
                | otherwise   = noUnfolding
 
 
                | otherwise   = noUnfolding
 
 

-tidyIdInfo tidy_env is_external unfold_info cg_info id
+tidyIdInfo tidy_env is_external unfold_info id

   | opt_OmitInterfacePragmas || not is_external
        -- No IdInfo if the Id isn't external, or if we don't have -O
   = vanillaIdInfo 
   | opt_OmitInterfacePragmas || not is_external
        -- No IdInfo if the Id isn't external, or if we don't have -O
   = vanillaIdInfo 

-       `setCgInfo`            cg_info
+       `setArityInfo`         arityInfo core_idinfo

        `setNewStrictnessInfo` newStrictnessInfo core_idinfo
        `setNewStrictnessInfo` newStrictnessInfo core_idinfo

-       -- Keep strictness; it's used by CorePrep
+       -- Keep strictness and arity; both are used by CorePrep

 
   | otherwise
   =  vanillaIdInfo 
 
   | otherwise
   =  vanillaIdInfo 

-       `setCgInfo`            cg_info
+       `setArityInfo`         arityInfo core_idinfo

        `setNewStrictnessInfo` newStrictnessInfo core_idinfo
        `setInlinePragInfo`    inlinePragInfo core_idinfo
        `setUnfoldingInfo`     unfold_info
        `setNewStrictnessInfo` newStrictnessInfo core_idinfo
        `setInlinePragInfo`    inlinePragInfo core_idinfo
        `setUnfoldingInfo`     unfold_info

@@ -540,11 +555,11 @@ tidyIdRules env ((fn,rule) : rules)
      ((tidyVarOcc env fn, rule) : rules)
 
 tidyRule :: TidyEnv -> CoreRule -> CoreRule
      ((tidyVarOcc env fn, rule) : rules)
 
 tidyRule :: TidyEnv -> CoreRule -> CoreRule

-tidyRule env rule@(BuiltinRule _) = rule
-tidyRule env (Rule name vars tpl_args rhs)
+tidyRule env rule@(BuiltinRule _ _) = rule
+tidyRule env (Rule name act vars tpl_args rhs)

   = tidyBndrs env vars                 =: \ (env', vars) ->
     map (tidyExpr env') tpl_args       =: \ tpl_args ->
   = tidyBndrs env vars                 =: \ (env', vars) ->
     map (tidyExpr env') tpl_args       =: \ tpl_args ->

-     (Rule name vars tpl_args (tidyExpr env' rhs))
+     (Rule name act vars tpl_args (tidyExpr env' rhs))

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -559,11 +574,11 @@ tidyBind :: TidyEnv
         ->  (TidyEnv, CoreBind)
 
 tidyBind env (NonRec bndr rhs)
         ->  (TidyEnv, CoreBind)
 
 tidyBind env (NonRec bndr rhs)

-  = tidyBndrWithRhs env (bndr,rhs) =: \ (env', bndr') ->
+  = tidyLetBndr env (bndr,rhs)         =: \ (env', bndr') ->

     (env', NonRec bndr' (tidyExpr env' rhs))
 
 tidyBind env (Rec prs)
     (env', NonRec bndr' (tidyExpr env' rhs))
 
 tidyBind env (Rec prs)

-  = mapAccumL tidyBndrWithRhs env prs  =: \ (env', bndrs') ->
+  = mapAccumL tidyLetBndr env prs      =: \ (env', bndrs') ->

     map (tidyExpr env') (map snd prs)  =: \ rhss' ->
     (env', Rec (zip bndrs' rhss'))
 
     map (tidyExpr env') (map snd prs)  =: \ rhss' ->
     (env', Rec (zip bndrs' rhss'))
 

@@ -610,26 +625,37 @@ tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of
 -- tidyBndr is used for lambda and case binders
 tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
 tidyBndr env var
 -- tidyBndr is used for lambda and case binders
 tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
 tidyBndr env var

-  | isTyVar var = tidyTyVar env var
-  | otherwise   = tidyId env var
+  | isTyVar var = tidyTyVarBndr env var
+  | otherwise   = tidyIdBndr env var

 
 tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
 tidyBndrs env vars = mapAccumL tidyBndr env vars
 
 
 tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
 tidyBndrs env vars = mapAccumL tidyBndr env vars
 

--- tidyBndrWithRhs is used for let binders
-tidyBndrWithRhs :: TidyEnv -> (Id, CoreExpr) -> (TidyEnv, Var)
-tidyBndrWithRhs env (id,rhs) 
-  = add_dmd_info (tidyId env id)
+tidyLetBndr :: TidyEnv -> (Id, CoreExpr) -> (TidyEnv, Var)
+-- Used for local (non-top-level) let(rec)s
+tidyLetBndr env (id,rhs) 
+  = ((tidy_env,new_var_env), final_id)

   where
   where

-       -- We add demand info for let(rec) binders, because
-       -- that's what tells CorePrep to generate a case instead of a thunk
-    add_dmd_info (env,new_id) 
-       | isStrictDmd dmd_info = (env, setIdNewDemandInfo new_id dmd_info)
-       | otherwise            = (env, new_id)
-    dmd_info = idNewDemandInfo id
-
-tidyId :: TidyEnv -> Id -> (TidyEnv, Id)
-tidyId env@(tidy_env, var_env) id
+    ((tidy_env,var_env), new_id) = tidyIdBndr env id
+
+       -- We need to keep around any interesting strictness and demand info
+       -- because later on we may need to use it when converting to A-normal form.
+       -- eg.
+       --      f (g x),  where f is strict in its argument, will be converted
+       --      into  case (g x) of z -> f z  by CorePrep, but only if f still
+       --      has its strictness info.
+       --
+       -- Similarly for the demand info - on a let binder, this tells 
+       -- CorePrep to turn the let into a case.
+    final_id = new_id `setIdNewDemandInfo` idNewDemandInfo id
+                     `setIdNewStrictness` idNewStrictness id
+
+    -- Override the env we get back from tidyId with the new IdInfo
+    -- so it gets propagated to the usage sites.
+    new_var_env = extendVarEnv var_env id final_id
+
+tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)
+tidyIdBndr env@(tidy_env, var_env) id

   =    -- Non-top-level variables
     let 
        -- Give the Id a fresh print-name, *and* rename its type
   =    -- Non-top-level variables
     let 
        -- Give the Id a fresh print-name, *and* rename its type

@@ -639,7 +665,7 @@ tidyId env@(tidy_env, var_env) id
        -- All local Ids now have the same IdInfo, which should save some
        -- space.
        (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
        -- All local Ids now have the same IdInfo, which should save some
        -- space.
        (tidy_env', occ') = tidyOccName tidy_env (getOccName id)

-        ty'              = tidyType (tidy_env,var_env) (idType id)
+        ty'              = tidyType env (idType id)

        id'               = mkUserLocal occ' (idUnique id) ty' noSrcLoc
        var_env'          = extendVarEnv var_env id id'
     in
        id'               = mkUserLocal occ' (idUnique id) ty' noSrcLoc
        var_env'          = extendVarEnv var_env id id'
     in