[project @ 2005-03-07 17:46:24 by simonpj]

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

diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs
index 2ca9e83..a5aab26 100644 (file)
--- a/ghc/compiler/simplCore/LiberateCase.lhs
+++ b/ghc/compiler/simplCore/LiberateCase.lhs
@@ -8,13 +8,15 @@ module LiberateCase ( liberateCase ) where
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

-import CmdLineOpts     ( DynFlags, DynFlag(..), dopt, opt_LiberateCaseThreshold )
+import CmdLineOpts     ( DynFlags, DynFlag(..), opt_LiberateCaseThreshold )

 import CoreLint                ( showPass, endPass )
 import CoreSyn
 import CoreUnfold      ( couldBeSmallEnoughToInline )
 import CoreLint                ( showPass, endPass )
 import CoreSyn
 import CoreUnfold      ( couldBeSmallEnoughToInline )

-import Var             ( Id )
+import Id              ( Id, setIdName, idName, setIdNotExported )

 import VarEnv
 import VarEnv

-import Maybes
+import Name            ( localiseName )
+import Outputable
+import Util             ( notNull )

 \end{code}
 
 This module walks over @Core@, and looks for @case@ on free variables.
 \end{code}
 
 This module walks over @Core@, and looks for @case@ on free variables.

@@ -40,13 +42,15 @@ f = \ t -> case v of
 \end{verbatim}
 (note the NEED for shadowing)
 
 \end{verbatim}
 (note the NEED for shadowing)
 

-=> Run Andr\'e's wonder pass ...
+=> Simplify
+

 \begin{verbatim}
 f = \ t -> case v of
               V a b -> a : (letrec
                                f = \ t -> a : f t
                             in f t)
 \begin{verbatim}
 \begin{verbatim}
 f = \ t -> case v of
               V a b -> a : (letrec
                                f = \ t -> a : f t
                             in f t)
 \begin{verbatim}

+

 Better code, because 'a' is  free inside the inner letrec, rather
 than needing projection from v.
 
 Better code, because 'a' is  free inside the inner letrec, rather
 than needing projection from v.
 

@@ -186,10 +190,22 @@ libCaseBind env (Rec pairs)
        -- We extend the rec-env by binding each Id to its rhs, first
        -- processing the rhs with an *un-extended* environment, so
        -- that the same process doesn't occur for ever!
        -- We extend the rec-env by binding each Id to its rhs, first
        -- processing the rhs with an *un-extended* environment, so
        -- that the same process doesn't occur for ever!

-
-    extended_env = addRecBinds env [ (binder, libCase env_body rhs)
+       --
+    extended_env = addRecBinds env [ (setIdNotExported binder, libCase env_body rhs)

                                   | (binder, rhs) <- pairs ]
 
                                   | (binder, rhs) <- pairs ]
 

+       -- Two subtle things: 
+       -- (a)  Reset the export flags on the binders so
+       --      that we don't get name clashes on exported things if the 
+       --      local binding floats out to top level.  This is most unlikely
+       --      to happen, since the whole point concerns free variables. 
+       --      But resetting the export flag is right regardless.
+       -- 
+       -- (b)  Make the name an Internal one.  External Names should never be
+       --      nested; if it were floated to the top level, we'd get a name
+       --      clash at code generation time.
+    adjust bndr = setIdNotExported (setIdName bndr (localiseName (idName bndr)))
+

     rhs_small_enough rhs = couldBeSmallEnoughToInline lIBERATE_BOMB_SIZE rhs
     lIBERATE_BOMB_SIZE   = bombOutSize env
 \end{code}
     rhs_small_enough rhs = couldBeSmallEnoughToInline lIBERATE_BOMB_SIZE rhs
     lIBERATE_BOMB_SIZE   = bombOutSize env
 \end{code}

@@ -217,8 +233,8 @@ libCase env (Let bind body)
   where
     (env_body, bind') = libCaseBind env bind
 
   where
     (env_body, bind') = libCaseBind env bind
 

-libCase env (Case scrut bndr alts)
-  = Case (libCase env scrut) bndr (map (libCaseAlt env_alts) alts)
+libCase env (Case scrut bndr ty alts)
+  = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts)

   where
     env_alts = addBinders env_with_scrut [bndr]
     env_with_scrut = case scrut of
   where
     env_alts = addBinders env_with_scrut [bndr]
     env_with_scrut = case scrut of

@@ -233,16 +249,16 @@ Ids
 \begin{code}
 libCaseId :: LibCaseEnv -> Id -> CoreExpr
 libCaseId env v
 \begin{code}
 libCaseId :: LibCaseEnv -> Id -> CoreExpr
 libCaseId env v

-  | Just the_bind <- lookupRecId env v,        -- It's a use of a recursive thing
-    there_are_free_scruts              -- with free vars scrutinised in RHS
+  | Just the_bind <- lookupRecId env v -- It's a use of a recursive thing
+  , notNull free_scruts                -- with free vars scrutinised in RHS

   = Let the_bind (Var v)
 
   | otherwise
   = Var v
 
   where
   = Let the_bind (Var v)
 
   | otherwise
   = Var v
 
   where

-    rec_id_level         = lookupLevel env v
-    there_are_free_scruts = freeScruts env rec_id_level
+    rec_id_level = lookupLevel env v
+    free_scruts  = freeScruts env rec_id_level

 \end{code}
 
 
 \end{code}
 
 

@@ -283,13 +299,7 @@ addScrutedVar env@(LibCaseEnv bomb lvl lvl_env rec_env scruts) scrut_var
 
 lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind
 lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
 
 lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind
 lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id

-#ifndef DEBUG

   = lookupVarEnv rec_env id
   = lookupVarEnv rec_env id

-#else
-  = case (lookupVarEnv rec_env id) of
-      xxx@(Just _) -> xxx
-      xxx         -> xxx
-#endif

 
 lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
 lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
 
 lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
 lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id

@@ -299,10 +309,8 @@ lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
 
 freeScruts :: LibCaseEnv
           -> LibCaseLevel      -- Level of the recursive Id
 
 freeScruts :: LibCaseEnv
           -> LibCaseLevel      -- Level of the recursive Id

-          -> Bool              -- True <=> there is an enclosing case of a variable
-                               -- bound outside (ie level <=) the recursive Id.
+          -> [Id]              -- Ids that are scrutinised between the binding
+                               -- of the recursive Id and here

 freeScruts (LibCaseEnv bomb lvl lvl_env rec_env scruts) rec_bind_lvl
 freeScruts (LibCaseEnv bomb lvl lvl_env rec_env scruts) rec_bind_lvl

-  = not (null free_scruts)
-  where
-    free_scruts = [v | (v,lvl) <- scruts, lvl <= rec_bind_lvl]
+  = [v | (v,scrut_lvl) <- scruts, scrut_lvl > rec_bind_lvl]

 \end{code}
 \end{code}