fix Win32 build

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

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

-import CmdLineOpts     ( opt_D_verbose_core2core, opt_LiberateCaseThreshold )
-import CoreLint                ( beginPass, endPass )
+import DynFlags                ( DynFlags, DynFlag(..) )
+import StaticFlags     ( opt_LiberateCaseThreshold )
+import CoreLint                ( showPass, endPass )

 import CoreSyn
 import CoreUnfold      ( couldBeSmallEnoughToInline )
 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 +43,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.
 

@@ -125,7 +130,7 @@ data LibCaseEnv
                                -- (top-level and imported things have
                                -- a level of zero)
 
                                -- (top-level and imported things have
                                -- a level of zero)
 

-       (IdEnv CoreBind)-- Binds *only* recursively defined
+       (IdEnv CoreBind)        -- Binds *only* recursively defined

                                -- Ids, to their own binding group,
                                -- and *only* in their own RHSs
 
                                -- Ids, to their own binding group,
                                -- and *only* in their own RHSs
 

@@ -148,14 +153,13 @@ bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size
 Programs
 ~~~~~~~~
 \begin{code}
 Programs
 ~~~~~~~~
 \begin{code}

-liberateCase :: [CoreBind] -> IO [CoreBind]
-liberateCase binds
+liberateCase :: DynFlags -> [CoreBind] -> IO [CoreBind]
+liberateCase dflags binds

   = do {
   = do {

-       beginPass "Liberate case" ;
+       showPass dflags "Liberate case" ;

        let { binds' = do_prog (initEnv opt_LiberateCaseThreshold) binds } ;
        let { binds' = do_prog (initEnv opt_LiberateCaseThreshold) binds } ;

-       endPass "Liberate case" 
-               opt_D_verbose_core2core         {- no specific flag for dumping -} 
-               binds'
+       endPass dflags "Liberate case" Opt_D_verbose_core2core binds'
+                               {- no specific flag for dumping -} 

     }
   where
     do_prog env [] = []
     }
   where
     do_prog env [] = []

@@ -187,28 +191,24 @@ 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)
-                       | (binder, rhs) <- pairs ]
-
-       -- Why "localiseId" above?  Because we're creating a new local
-       -- copy of the original binding.  In particular, the original
-       -- binding might have been for a top-level, and this copy clearly
-       -- will not be top-level!
-
-       -- It is enough to change just the binder, because subsequent
-       -- simplification will propagate the right info from the binder.
-
-       -- Why does it matter?  Because the codeGen keeps a separate
-       -- environment for top-level Ids, and it is disastrous for it
-       -- to think that something is top-level when it isn't.

        --
        --

-       -- [May 98: all this is now handled by SimplCore.tidyCore]
+    extended_env = addRecBinds env [ (adjust binder, libCase env_body rhs)
+                                  | (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
 
     rhs_small_enough rhs = couldBeSmallEnoughToInline lIBERATE_BOMB_SIZE rhs

-
-    lIBERATE_BOMB_SIZE = bombOutSize env
+    lIBERATE_BOMB_SIZE   = bombOutSize env

 \end{code}
 
 
 \end{code}
 
 

@@ -234,8 +234,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

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

-  | maybeToBool maybe_rec_bind &&      -- 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

-    maybe_rec_bind :: Maybe CoreBind   -- The binding of the recursive thingy
-    maybe_rec_bind = lookupRecId env v
-    Just the_bind  = maybe_rec_bind
-

     rec_id_level = lookupLevel env v
     rec_id_level = lookupLevel env v

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

 \end{code}
 
 
 \end{code}
 
 

@@ -305,13 +300,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

@@ -321,10 +310,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}