compiler: de-lhs simplCore/
authorAustin Seipp <austin@well-typed.com>
Wed, 3 Dec 2014 18:45:25 +0000 (12:45 -0600)
committerAustin Seipp <austin@well-typed.com>
Wed, 3 Dec 2014 19:52:27 +0000 (13:52 -0600)
Signed-off-by: Austin Seipp <austin@well-typed.com>
13 files changed:
compiler/simplCore/CSE.hs [moved from compiler/simplCore/CSE.lhs with 93% similarity]
compiler/simplCore/CoreMonad.hs [moved from compiler/simplCore/CoreMonad.lhs with 90% similarity]
compiler/simplCore/FloatIn.hs [moved from compiler/simplCore/FloatIn.lhs with 93% similarity]
compiler/simplCore/FloatOut.hs [moved from compiler/simplCore/FloatOut.lhs with 92% similarity]
compiler/simplCore/LiberateCase.hs [moved from compiler/simplCore/LiberateCase.lhs with 89% similarity]
compiler/simplCore/OccurAnal.hs [moved from compiler/simplCore/OccurAnal.lhs with 96% similarity]
compiler/simplCore/SAT.hs [moved from compiler/simplCore/SAT.lhs with 95% similarity]
compiler/simplCore/SetLevels.hs [moved from compiler/simplCore/SetLevels.lhs with 95% similarity]
compiler/simplCore/SimplCore.hs [moved from compiler/simplCore/SimplCore.lhs with 93% similarity]
compiler/simplCore/SimplEnv.hs [moved from compiler/simplCore/SimplEnv.lhs with 93% similarity]
compiler/simplCore/SimplMonad.hs [moved from compiler/simplCore/SimplMonad.lhs with 85% similarity]
compiler/simplCore/SimplUtils.hs [moved from compiler/simplCore/SimplUtils.lhs with 95% similarity]
compiler/simplCore/Simplify.hs [moved from compiler/simplCore/Simplify.lhs with 96% similarity]

similarity index 93%
rename from compiler/simplCore/CSE.lhs
rename to compiler/simplCore/CSE.hs
index ccd4b2e..7dbf892 100644 (file)
@@ -1,9 +1,9 @@
-%
-(c) The AQUA Project, Glasgow University, 1993-1998
-%
+{-
+(c) The AQUA Project, Glasgow University, 1993-1998
+
 \section{Common subexpression}
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module CSE (cseProgram) where
@@ -22,9 +22,8 @@ import BasicTypes       ( isAlwaysActive )
 import TrieMap
 
 import Data.List
-\end{code}
-
 
+{-
                         Simple common sub-expression
                         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When we see
@@ -146,13 +145,13 @@ Consider
 Then we can CSE the inner (f x) to y.  In fact 'case' is like a strict
 let-binding, and we can use cseRhs for dealing with the scrutinee.
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \section{Common subexpression}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 cseProgram :: CoreProgram -> CoreProgram
 cseProgram binds = snd (mapAccumL cseBind emptyCSEnv binds)
 
@@ -256,16 +255,15 @@ cseAlts env scrut' bndr bndr' alts
         = (con, args', tryForCSE env' rhs)
         where
           (env', args') = addBinders alt_env args
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \section{The CSE envt}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 type InExpr  = CoreExpr         -- Pre-cloning
 type InBndr  = CoreBndr
 type InAlt   = CoreAlt
@@ -313,4 +311,3 @@ addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
 addRecBinders cse vs = (cse { cs_subst = sub' }, vs')
                 where
                   (sub', vs') = substRecBndrs (cs_subst cse) vs
-\end{code}
similarity index 90%
rename from compiler/simplCore/CoreMonad.lhs
rename to compiler/simplCore/CoreMonad.hs
index c175b07..d50027c 100644 (file)
@@ -1,9 +1,9 @@
-%
-(c) The AQUA Project, Glasgow University, 1993-1998
-%
+{-
+(c) The AQUA Project, Glasgow University, 1993-1998
+
 \section[CoreMonad]{The core pipeline monad}
+-}
 
-\begin{code}
 {-# LANGUAGE CPP, UndecidableInstances #-}
 
 module CoreMonad (
@@ -118,19 +118,19 @@ saveLinkerGlobals = return ()
 restoreLinkerGlobals :: () -> IO ()
 restoreLinkerGlobals () = return ()
 #endif
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                        Debug output
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 These functions are not CoreM monad stuff, but they probably ought to
 be, and it makes a conveneint place.  place for them.  They print out
 stuff before and after core passes, and do Core Lint when necessary.
+-}
 
-\begin{code}
 showPass :: CoreToDo -> CoreM ()
 showPass pass = do { dflags <- getDynFlags
                    ; liftIO $ showPassIO dflags pass }
@@ -286,17 +286,15 @@ interactiveInScope hsc_env
               -- I think it's because of the GHCi debugger, which can bind variables
               --   f :: [t] -> [t]
               -- where t is a RuntimeUnk (see TcType)
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
               The CoreToDo type and related types
           Abstraction of core-to-core passes to run.
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
+*                                                                      *
+************************************************************************
+-}
 
 data CoreToDo           -- These are diff core-to-core passes,
                         -- which may be invoked in any order,
@@ -330,9 +328,6 @@ data CoreToDo           -- These are diff core-to-core passes,
   | CoreTidy
   | CorePrep
 
-\end{code}
-
-\begin{code}
 coreDumpFlag :: CoreToDo -> Maybe DumpFlag
 coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_verbose_core2core
 coreDumpFlag (CoreDoPluginPass {})    = Just Opt_D_verbose_core2core
@@ -384,9 +379,7 @@ pprPassDetails :: CoreToDo -> SDoc
 pprPassDetails (CoreDoSimplify n md) = vcat [ ptext (sLit "Max iterations =") <+> int n
                                             , ppr md ]
 pprPassDetails _ = Outputable.empty
-\end{code}
 
-\begin{code}
 data SimplifierMode             -- See comments in SimplMonad
   = SimplMode
         { sm_names      :: [String] -- Name(s) of the phase
@@ -410,10 +403,7 @@ instance Outputable SimplifierMode where
              , pp_flag cc  (sLit "case-of-case") ])
          where
            pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
-\end{code}
-
 
-\begin{code}
 data FloatOutSwitches = FloatOutSwitches {
   floatOutLambdas   :: Maybe Int,  -- ^ Just n <=> float lambdas to top level, if
                                    -- doing so will abstract over n or fewer
@@ -450,9 +440,7 @@ runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
 runMaybe (Just x) f = f x
 runMaybe Nothing  _ = CoreDoNothing
 
-\end{code}
-
-
+{-
 Note [RULEs enabled in SimplGently]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 RULES are enabled when doing "gentle" simplification.  Two reasons:
@@ -470,13 +458,13 @@ But watch out: list fusion can prevent floating.  So use phase control
 to switch off those rules until after floating.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
              Types for Plugins
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- | A description of the plugin pass itself
 type PluginPass = ModGuts -> CoreM ModGuts
 
@@ -484,16 +472,15 @@ bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
 bindsOnlyPass pass guts
   = do { binds' <- pass (mg_binds guts)
        ; return (guts { mg_binds = binds' }) }
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
              Counting and logging
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 verboseSimplStats :: Bool
 verboseSimplStats = opt_PprStyle_Debug          -- For now, anyway
 
@@ -504,9 +491,7 @@ pprSimplCount      :: SimplCount -> SDoc
 doSimplTick        :: DynFlags -> Tick -> SimplCount -> SimplCount
 doFreeSimplTick    ::             Tick -> SimplCount -> SimplCount
 plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
-\end{code}
 
-\begin{code}
 data SimplCount
    = VerySimplCount !Int        -- Used when don't want detailed stats
 
@@ -608,10 +593,7 @@ pprTickGroup group@((tick1,_):_)
                                     -- flip as we want largest first
                | (tick,n) <- sortBy (flip (comparing snd)) group])
 pprTickGroup [] = panic "pprTickGroup"
-\end{code}
 
-
-\begin{code}
 data Tick
   = PreInlineUnconditionally    Id
   | PostInlineUnconditionally   Id
@@ -725,16 +707,15 @@ cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `com
 cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b
 cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b
 cmpEqTick _                             _                               = EQ
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
              Monad and carried data structure definitions
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 newtype CoreState = CoreState {
         cs_uniq_supply :: UniqSupply
 }
@@ -841,16 +822,13 @@ runCoreM hsc_env rule_base us mod print_unqual m = do
     extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
     extract (value, _, writer) = (value, cw_simpl_count writer)
 
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
              Core combinators, not exported
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
+*                                                                      *
+************************************************************************
+-}
 
 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
 nop s x = do
@@ -869,11 +847,7 @@ modifyS f = CoreM (\s -> nop (f s) ())
 write :: CoreWriter -> CoreM ()
 write w = CoreM (\s -> return ((), s, w))
 
-\end{code}
-
-\subsection{Lifting IO into the monad}
-
-\begin{code}
+-- \subsection{Lifting IO into the monad}
 
 -- | Lift an 'IOEnv' operation into 'CoreM'
 liftIOEnv :: CoreIOEnv a -> CoreM a
@@ -886,16 +860,14 @@ instance MonadIO CoreM where
 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
 
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
              Reader, writer and state accessors
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 getHscEnv :: CoreM HscEnv
 getHscEnv = read cr_hsc_env
 
@@ -928,13 +900,13 @@ getPackageFamInstEnv = do
     hsc_env <- getHscEnv
     eps <- liftIO $ hscEPS hsc_env
     return $ eps_fam_inst_env eps
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
              Initializing globals
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 This is a rather annoying function. When a plugin is loaded, it currently
 gets linked against a *newly loaded* copy of the GHC package. This would
@@ -973,8 +945,8 @@ will have to say `reinitializeGlobals` before it does anything, but never mind.
 I've threaded the cr_globals through CoreM rather than giving them as an
 argument to the plugin function so that we can turn this function into
 (return ()) without breaking any plugins when we eventually get 1. working.
+-}
 
-\begin{code}
 reinitializeGlobals :: CoreM ()
 reinitializeGlobals = do
     linker_globals <- read cr_globals
@@ -982,15 +954,15 @@ reinitializeGlobals = do
     let dflags = hsc_dflags hsc_env
     liftIO $ restoreLinkerGlobals linker_globals
     liftIO $ setUnsafeGlobalDynFlags dflags
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
              Dealing with annotations
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- | Get all annotations of a given type. This happens lazily, that is
 -- no deserialization will take place until the [a] is actually demanded and
 -- the [a] can also be empty (the UniqFM is not filtered).
@@ -1011,8 +983,7 @@ getFirstAnnotations deserialize guts
   = liftM (mapUFM head . filterUFM (not . null))
   $ getAnnotations deserialize guts
 
-\end{code}
-
+{-
 Note [Annotations]
 ~~~~~~~~~~~~~~~~~~
 A Core-to-Core pass that wants to make use of annotations calls
@@ -1031,13 +1002,12 @@ only want to deserialise every annotation once, we would have to build a cache
 for every module in the HTP. In the end, it's probably not worth it as long as
 we aren't using annotations heavily.
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
                 Direct screen output
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
+*                                                                      *
+************************************************************************
+-}
 
 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
 msg how doc = do
@@ -1079,29 +1049,28 @@ debugTraceMsg = msg (flip Err.debugTraceMsg 3)
 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
 dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()
 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                Finding TyThings
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 instance MonadThings CoreM where
     lookupThing name = do
         hsc_env <- getHscEnv
         liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                Template Haskell interoperability
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 #ifdef GHCI
 -- | Attempt to convert a Template Haskell name to one that GHC can
 -- understand. Original TH names such as those you get when you use
@@ -1114,4 +1083,3 @@ thNameToGhcName th_name = do
     hsc_env <- getHscEnv
     liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
 #endif
-\end{code}
similarity index 93%
rename from compiler/simplCore/FloatIn.lhs
rename to compiler/simplCore/FloatIn.hs
index 13d03ef..3425288 100644 (file)
@@ -1,17 +1,17 @@
-%
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-%************************************************************************
-%*                                                                      *
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+************************************************************************
+*                                                                      *
 \section[FloatIn]{Floating Inwards pass}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 The main purpose of @floatInwards@ is floating into branches of a
 case, so that we don't allocate things, save them on the stack, and
 then discover that they aren't needed in the chosen branch.
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module FloatIn ( floatInwards ) where
@@ -31,12 +31,12 @@ import UniqFM
 import DynFlags
 import Outputable
 import Data.List( mapAccumL )
-\end{code}
 
+{-
 Top-level interface function, @floatInwards@.  Note that we do not
 actually float any bindings downwards from the top-level.
+-}
 
-\begin{code}
 floatInwards :: DynFlags -> CoreProgram -> CoreProgram
 floatInwards dflags = map fi_top_bind
   where
@@ -44,13 +44,13 @@ floatInwards dflags = map fi_top_bind
       = NonRec binder (fiExpr dflags [] (freeVars rhs))
     fi_top_bind (Rec pairs)
       = Rec [ (b, fiExpr dflags [] (freeVars rhs)) | (b, rhs) <- pairs ]
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Mail from Andr\'e [edited]}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 {\em Will wrote: What??? I thought the idea was to float as far
 inwards as possible, no matter what.  This is dropping all bindings
@@ -110,13 +110,13 @@ Also, even if a is not found to be strict in the new context and is
 still left as a let, if the branch is not taken (or b is not entered)
 the closure for a is not built.
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{Main floating-inwards code}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 type FreeVarSet  = IdSet
 type BoundVarSet = IdSet
 
@@ -143,13 +143,13 @@ fiExpr dflags to_drop (_, AnnCast expr (fvs_co, co))
     Cast (fiExpr dflags e_drop expr) co
   where
     [drop_here, e_drop, co_drop] = sepBindsByDropPoint dflags False [freeVarsOf expr, fvs_co] to_drop
-\end{code}
 
+{-
 Applications: we do float inside applications, mainly because we
 need to get at all the arguments.  The next simplifier run will
 pull out any silly ones.
+-}
 
-\begin{code}
 fiExpr dflags to_drop ann_expr@(_,AnnApp {})
   = wrapFloats drop_here $ wrapFloats extra_drop $
     mkApps (fiExpr dflags fun_drop ann_fun)
@@ -175,8 +175,8 @@ fiExpr dflags to_drop ann_expr@(_,AnnApp {})
 
     drop_here : extra_drop : fun_drop : arg_drops
       = sepBindsByDropPoint dflags False (extra_fvs : fun_fvs : arg_fvs) to_drop
-\end{code}
 
+{-
 Note [Do not destroy the let/app invariant]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Watch out for
@@ -223,8 +223,8 @@ This is what the 'go' function in the AnnLam case is doing.
 
 Urk! if all are tyvars, and we don't float in, we may miss an
       opportunity to float inside a nested case branch
+-}
 
-\begin{code}
 fiExpr dflags to_drop lam@(_, AnnLam _ _)
   | okToFloatInside bndrs       -- Float in
      -- NB: Must line up with noFloatIntoRhs (AnnLam...); see Trac #7088
@@ -235,14 +235,14 @@ fiExpr dflags to_drop lam@(_, AnnLam _ _)
 
   where
     (bndrs, body) = collectAnnBndrs lam
-\end{code}
 
+{-
 We don't float lets inwards past an SCC.
         ToDo: keep info on current cc, and when passing
         one, if it is not the same, annotate all lets in binds with current
         cc, change current cc to the new one and float binds into expr.
+-}
 
-\begin{code}
 fiExpr dflags to_drop (_, AnnTick tickish expr)
   | tickishScoped tickish
   =     -- Wimp out for now - we could push values in
@@ -250,8 +250,8 @@ fiExpr dflags to_drop (_, AnnTick tickish expr)
 
   | otherwise
   = Tick tickish (fiExpr dflags to_drop expr)
-\end{code}
 
+{-
 For @Lets@, the possible ``drop points'' for the \tr{to_drop}
 bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
 or~(b2), in each of the RHSs of the pairs of a @Rec@.
@@ -300,9 +300,8 @@ Here y is not free in rhs or body; but we still want to dump bindings
 that bind y outside the let.  So we augment extra_fvs with the
 idRuleAndUnfoldingVars of x.  No need for type variables, hence not using
 idFreeVars.
+-}
 
-
-\begin{code}
 fiExpr dflags to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
   = fiExpr dflags new_to_drop body
   where
@@ -365,8 +364,8 @@ fiExpr dflags to_drop (_,AnnLet (AnnRec bindings) body)
     fi_bind to_drops pairs
       = [ (binder, fiExpr dflags to_drop rhs)
         | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
-\end{code}
 
+{-
 For @Case@, the possible ``drop points'' for the \tr{to_drop}
 bindings are: (a)~inside the scrutinee, (b)~inside one of the
 alternatives/default [default FVs always {\em first}!].
@@ -378,8 +377,8 @@ inward. SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed
 scalars also need to be floated inward, but unpacks have a single non-DEFAULT
 alternative that binds the elements of the tuple. We now therefore also support
 floating in cases with a single alternative that may bind values.
+-}
 
-\begin{code}
 fiExpr dflags to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)])
   | isUnLiftedType (idType case_bndr)
   , exprOkForSideEffects (deAnnotate scrut)
@@ -448,14 +447,13 @@ noFloatIntoExpr (AnnLam bndr e)
 noFloatIntoExpr rhs = exprIsExpandable (deAnnotate' rhs)
        -- We'd just float right back out again...
        -- Should match the test in SimplEnv.doFloatFromRhs
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{@sepBindsByDropPoint@}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 This is the crucial function.  The idea is: We have a wad of bindings
 that we'd like to distribute inside a collection of {\em drop points};
@@ -471,8 +469,8 @@ then it has to go in a you-must-drop-it-above-all-these-drop-points
 point.
 
 We have to maintain the order on these drop-point-related lists.
+-}
 
-\begin{code}
 sepBindsByDropPoint
     :: DynFlags
     -> Bool             -- True <=> is case expression
@@ -560,4 +558,3 @@ floatIsDupable :: DynFlags -> FloatBind -> Bool
 floatIsDupable dflags (FloatCase scrut _ _ _) = exprIsDupable dflags scrut
 floatIsDupable dflags (FloatLet (Rec prs))    = all (exprIsDupable dflags . snd) prs
 floatIsDupable dflags (FloatLet (NonRec _ r)) = exprIsDupable dflags r
-\end{code}
similarity index 92%
rename from compiler/simplCore/FloatOut.lhs
rename to compiler/simplCore/FloatOut.hs
index 55ed111..4cd8713 100644 (file)
@@ -1,11 +1,11 @@
-%
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
 \section[FloatOut]{Float bindings outwards (towards the top level)}
 
 ``Long-distance'' floating of bindings towards the top level.
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -31,8 +31,8 @@ import FastString
 import qualified Data.IntMap as M
 
 #include "HsVersions.h"
-\end{code}
 
+{-
         -----------------
         Overall game plan
         -----------------
@@ -106,13 +106,13 @@ vwhich might usefully be separated to
 Well, maybe.  We don't do this at the moment.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 floatOutwards :: FloatOutSwitches
               -> DynFlags
               -> UniqSupply
@@ -144,15 +144,15 @@ floatTopBind bind
     in case bind' of
       Rec prs   -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs)))
       NonRec {} -> (fs, float_bag `snocBag` bind') }
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[FloatOut-Bind]{Floating in a binding (the business end)}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 floatBind :: LevelledBind -> (FloatStats, FloatBinds, CoreBind)
 floatBind (NonRec (TB var _) rhs)
   = case (floatExpr rhs) of { (fs, rhs_floats, rhs') ->
@@ -205,8 +205,8 @@ floatList _ [] = (zeroStats, emptyFloats, [])
 floatList f (a:as) = case f a            of { (fs_a,  binds_a,  b)  ->
                      case floatList f as of { (fs_as, binds_as, bs) ->
                      (fs_a `add_stats` fs_as, binds_a `plusFloats`  binds_as, b:bs) }}
-\end{code}
 
+{-
 Note [Floating out of Rec rhss]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider   Rec { f<1,0> = \xy. body }
@@ -239,13 +239,13 @@ We could perhaps get rid of the 'tops' component of the floating binds,
 but this case works just as well.
 
 
-%************************************************************************
+************************************************************************
 
 \subsection[FloatOut-Expr]{Floating in expressions}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 floatBody :: Level
           -> LevelledExpr
           -> (FloatStats, FloatBinds, CoreExpr)
@@ -342,8 +342,8 @@ floatExpr (Case scrut (TB case_bndr case_spec) ty alts)
     float_alt bind_lvl (con, bs, rhs)
         = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') ->
           (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }
-\end{code}
 
+{-
 Note [Avoiding unnecessary floating]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In general we want to avoid floating a let unnecessarily, because
@@ -383,16 +383,16 @@ altogether when profiling got in the way.
 
 So now we do the partition right at the (Let..) itself.
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{Utility bits for floating stats}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 I didn't implement this with unboxed numbers.  I don't want to be too
 strict in this stuff, as it is rarely turned on.  (WDP 95/09)
+-}
 
-\begin{code}
 data FloatStats
   = FlS Int  -- Number of top-floats * lambda groups they've been past
         Int  -- Number of non-top-floats * lambda groups they've been past
@@ -414,14 +414,13 @@ add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
 add_to_stats :: FloatStats -> FloatBinds -> FloatStats
 add_to_stats (FlS a b c) (FB tops others)
   = FlS (a + lengthBag tops) (b + lengthBag (flattenMajor others)) (c + 1)
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Utility bits for floating}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Representation of FloatBinds]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -441,9 +440,8 @@ That is why MajorEnv is represented as a finite map.
 We keep the bindings destined for the *top* level separate, because
 we float them out even if they don't escape a *value* lambda; see
 partitionByMajorLevel.
+-}
 
-
-\begin{code}
 type FloatLet = CoreBind        -- INVARIANT: a FloatLet is always lifted
 type MajorEnv = M.IntMap MinorEnv         -- Keyed by major level
 type MinorEnv = M.IntMap (Bag FloatBind)  -- Keyed by minor level
@@ -563,4 +561,3 @@ wrapTick t (FB tops defns)
       -- Conversely, inlining of HNFs inside an SCC is allowed, and
       -- indeed the HNF we're floating here might well be inlined back
       -- again, and we don't want to end up with duplicate ticks.
-\end{code}
similarity index 89%
rename from compiler/simplCore/LiberateCase.lhs
rename to compiler/simplCore/LiberateCase.hs
index 21adf20..1df1405 100644 (file)
@@ -1,9 +1,9 @@
-%
-(c) The AQUA Project, Glasgow University, 1994-1998
-%
+{-
+(c) The AQUA Project, Glasgow University, 1994-1998
+
 \section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 module LiberateCase ( liberateCase ) where
 
@@ -15,8 +15,8 @@ import CoreUnfold       ( couldBeSmallEnoughToInline )
 import Id
 import VarEnv
 import Util             ( notNull )
-\end{code}
 
+{-
 The liberate-case transformation
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 This module walks over @Core@, and looks for @case@ on free variables.
@@ -111,13 +111,13 @@ Here, the level of @f@ is zero, the level of @g@ is one,
 and the level of @h@ is zero (NB not one).
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
          Top-level code
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 liberateCase :: DynFlags -> CoreProgram -> CoreProgram
 liberateCase dflags binds = do_prog (initEnv dflags) binds
   where
@@ -125,18 +125,18 @@ liberateCase dflags binds = do_prog (initEnv dflags) binds
     do_prog env (bind:binds) = bind' : do_prog env' binds
                              where
                                (env', bind') = libCaseBind env bind
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
          Main payload
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Bindings
 ~~~~~~~~
-\begin{code}
+-}
+
 libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)
 
 libCaseBind env (NonRec binder rhs)
@@ -164,8 +164,8 @@ libCaseBind env (Rec pairs)
         =  idArity id > 0       -- Note [Only functions!]
         && maybe True (\size -> couldBeSmallEnoughToInline (lc_dflags env) size rhs)
                       (bombOutSize env)
-\end{code}
 
+{-
 Note [Need to localiseId in libCaseBind]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The call to localiseId is needed for two subtle reasons
@@ -191,8 +191,8 @@ rhs_small_enough call in the comprehension for env_rhs does.
 
 Expressions
 ~~~~~~~~~~~
+-}
 
-\begin{code}
 libCase :: LibCaseEnv
         -> CoreExpr
         -> CoreExpr
@@ -224,12 +224,12 @@ libCase env (Case scrut bndr ty alts)
 libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr)
                          -> (AltCon, [CoreBndr], CoreExpr)
 libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
-\end{code}
-
 
+{-
 Ids
 ~~~
-\begin{code}
+-}
+
 libCaseId :: LibCaseEnv -> Id -> CoreExpr
 libCaseId env v
   | Just the_bind <- lookupRecId env v  -- It's a use of a recursive thing
@@ -253,8 +253,8 @@ freeScruts env rec_bind_lvl
        , scrut_at_lvl > rec_bind_lvl]
         -- Note [When to specialise]
         -- Note [Avoiding fruitless liberate-case]
-\end{code}
 
+{-
 Note [When to specialise]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
@@ -294,13 +294,13 @@ an occurrence of 'g', we want to check that there's a scruted-var v st
    b) v's scrutinisation site is *inside* g
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
         Utility functions
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv
 addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders
   = env { lc_lvl_env = lvl_env' }
@@ -342,22 +342,20 @@ lookupLevel env id
   = case lookupVarEnv (lc_lvl_env env) id of
       Just lvl -> lvl
       Nothing  -> topLevel
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
          The environment
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 type LibCaseLevel = Int
 
 topLevel :: LibCaseLevel
 topLevel = 0
-\end{code}
 
-\begin{code}
 data LibCaseEnv
   = LibCaseEnv {
         lc_dflags :: DynFlags,
@@ -408,4 +406,3 @@ initEnv dflags
 -- (passed in from cmd-line args)
 bombOutSize :: LibCaseEnv -> Maybe Int
 bombOutSize = liberateCaseThreshold . lc_dflags
-\end{code}
similarity index 96%
rename from compiler/simplCore/OccurAnal.lhs
rename to compiler/simplCore/OccurAnal.hs
index ef212bc..26aec9d 100644 (file)
@@ -1,17 +1,16 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \section[OccurAnal]{Occurrence analysis pass}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 The occurrence analyser re-typechecks a core expression, returning a new
 core expression with (hopefully) improved usage information.
+-}
 
-\begin{code}
 {-# LANGUAGE CPP, BangPatterns #-}
 
 module OccurAnal (
@@ -41,18 +40,17 @@ import Util
 import Outputable
 import FastString
 import Data.List
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[OccurAnal-main]{Counting occurrences: main function}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Here's the externally-callable interface:
+-}
 
-\begin{code}
 occurAnalysePgm :: Module       -- Used only in debug output
                 -> (Activation -> Bool)
                 -> [CoreRule] -> [CoreVect] -> VarSet
@@ -114,19 +112,18 @@ occurAnalyseExpr' enable_binder_swap expr
     env = (initOccEnv all_active_rules) {occ_binder_swap = enable_binder_swap}
     -- To be conservative, we say that all inlines and rules are active
     all_active_rules = \_ -> True
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[OccurAnal-main]{Counting occurrences: main function}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Bindings
 ~~~~~~~~
+-}
 
-\begin{code}
 occAnalBind :: OccEnv           -- The incoming OccEnv
             -> IdEnv IdSet      -- Mapping from FVs of imported RULE LHSs to RHS FVs
             -> CoreBind
@@ -177,8 +174,8 @@ occAnalRecBind env imp_rules_edges pairs body_usage
 
     nodes :: [Node Details]
     nodes = {-# SCC "occAnalBind.assoc" #-} map (makeNode env imp_rules_edges bndr_set) pairs
-\end{code}
 
+{-
 Note [Dead code]
 ~~~~~~~~~~~~~~~~
 Dropping dead code for a cyclic Strongly Connected Component is done
@@ -634,9 +631,8 @@ But watch out!  If 'fs' is not chosen as a loop breaker, we may get an infinite
   - now there's another opportunity to apply the RULE
 
 This showed up when compiling Control.Concurrent.Chan.getChanContents.
+-}
 
-
-\begin{code}
 type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
                                                 -- which is gotten from the Id.
 data Details
@@ -793,8 +789,8 @@ occAnalRec (CyclicSCC nodes) (body_uds, binds)
         | (ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs },_,_) <- nodes
         , let trimmed_rule_fvs = rule_fvs `intersectVarSet` bndr_set
         , not (isEmptyVarSet trimmed_rule_fvs)]
-\end{code}
 
+{-
 @loopBreakSCC@ is applied to the list of (binder,rhs) pairs for a cyclic
 strongly connected component (there's guaranteed to be a cycle).  It returns the
 same pairs, but
@@ -809,8 +805,8 @@ Furthermore, the order of the binds is such that if we neglect dependencies
 on the no-inline Ids then the binds are topologically sorted.  This means
 that the simplifier will generally do a good job if it works from top bottom,
 recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
+-}
 
-\begin{code}
 type Binding = (Id,CoreExpr)
 
 mk_loop_breaker :: Node Details -> Binding
@@ -944,8 +940,8 @@ reOrderNodes depth bndr_set weak_fvs (node : nodes) binds
     is_con_app (Lam _ e)  = is_con_app e
     is_con_app (Tick _ e) = is_con_app e
     is_con_app _          = False
-\end{code}
 
+{-
 Note [Complexity of loop breaking]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The loop-breaking algorithm knocks out one binder at a time, and
@@ -1067,9 +1063,8 @@ ToDo: try using the occurrence info for the inline'd binder.
 
 [March 97] We do the same for atomic RHSs.  Reason: see notes with loopBreakSCC.
 [June 98, SLPJ]  I've undone this change; I don't understand it.  See notes with loopBreakSCC.
+-}
 
-
-\begin{code}
 occAnalRecRhs :: OccEnv -> CoreExpr    -- Rhs
            -> (UsageDetails, CoreExpr)
               -- Returned usage details covers only the RHS,
@@ -1111,8 +1106,8 @@ addIdOccs usage id_set = foldVarSet add usage id_set
         --   b) We don't want to substitute a BIG expression inside a RULE
         --      even if that's the only occurrence of the thing
         --      (Same goes for INLINE.)
-\end{code}
 
+{-
 Note [Cascading inlines]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 By default we use an rhsCtxt for the RHS of a binding.  This tells the
@@ -1155,7 +1150,8 @@ for the various clauses.
 
 Expressions
 ~~~~~~~~~~~
-\begin{code}
+-}
+
 occAnal :: OccEnv
         -> CoreExpr
         -> (UsageDetails,       -- Gives info only about the "interesting" Ids
@@ -1174,14 +1170,14 @@ occAnal env expr@(Var v)  = (mkOneOcc env v False, expr)
 occAnal _ (Coercion co)
   = (addIdOccs emptyDetails (coVarsOfCo co), Coercion co)
         -- See Note [Gather occurrences of coercion variables]
-\end{code}
 
+{-
 Note [Gather occurrences of coercion variables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We need to gather info about what coercion variables appear, so that
 we can sort them into the right place when doing dependency analysis.
+-}
 
-\begin{code}
 occAnal env (Tick tickish body)
   | Breakpoint _ ids <- tickish
   = (mapVarEnv markInsideSCC usage
@@ -1206,9 +1202,7 @@ occAnal env (Cast expr co)
         -- then mark y as 'Many' so that we don't
         -- immediately inline y again.
     }
-\end{code}
 
-\begin{code}
 occAnal env app@(App _ _)
   = occAnalApp env (collectArgs app)
 
@@ -1286,7 +1280,7 @@ occAnal env (Let bind body)
        (final_usage, mkLets new_binds body') }}
 
 occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr])
-occAnalArgs _ [] _ 
+occAnalArgs _ [] _
   = (emptyDetails, [])
 
 occAnalArgs env (arg:args) one_shots
@@ -1299,8 +1293,8 @@ occAnalArgs env (arg:args) one_shots
     case occAnal arg_env arg             of { (uds1, arg') ->
     case occAnalArgs env args one_shots' of { (uds2, args') ->
     (uds1 +++ uds2, arg':args') }}}
-\end{code}
 
+{-
 Applications are dealt with specially because we want
 the "build hack" to work.
 
@@ -1315,8 +1309,8 @@ that y may be duplicated thereby.
 
 If we aren't careful we duplicate the (expensive x) call!
 Constructors are rather like lambdas in this way.
+-}
 
-\begin{code}
 occAnalApp :: OccEnv
            -> (Expr CoreBndr, [Arg CoreBndr])
            -> (UsageDetails, Expr CoreBndr)
@@ -1371,8 +1365,8 @@ markManyIf :: Bool              -- If this is true
            -> UsageDetails
 markManyIf True  uds = mapVarEnv markMany uds
 markManyIf False uds = uds
-\end{code}
 
+{-
 Note [Use one-shot information]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The occurrrence analyser propagates one-shot-lambda information in two situation
@@ -1402,8 +1396,8 @@ Simplify.mkDupableAlt
 In this example, though, the Simplifier will bring 'a' and 'b' back to
 life, beause it binds 'y' to (a,b) (imagine got inlined and
 scrutinised y).
+-}
 
-\begin{code}
 occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr))
            -> CoreAlt
            -> (UsageDetails, Alt IdWithOccInfo)
@@ -1440,16 +1434,15 @@ wrapAltRHS env (Just (scrut_var, let_rhs)) alt_usg bndrs alt_rhs
 
 wrapAltRHS _ _ alt_usg _ alt_rhs
   = (alt_usg, alt_rhs)
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                     OccEnv
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 data OccEnv
   = OccEnv { occ_encl       :: !OccEncl      -- Enclosing context information
            , occ_one_shots  :: !OneShots     -- Tells about linearity
@@ -1502,16 +1495,16 @@ rhsCtxt :: OccEnv -> OccEnv
 rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] }
 
 argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])
-argCtxt env [] 
+argCtxt env []
   = (env { occ_encl = OccVanilla, occ_one_shots = [] }, [])
-argCtxt env (one_shots:one_shots_s) 
+argCtxt env (one_shots:one_shots_s)
   = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s)
 
 isRhsEnv :: OccEnv -> Bool
 isRhsEnv (OccEnv { occ_encl = OccRhs })     = True
 isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False
 
-oneShotGroup :: OccEnv -> [CoreBndr] 
+oneShotGroup :: OccEnv -> [CoreBndr]
              -> ( OccEnv
                 , [CoreBndr] )
         -- The result binders have one-shot-ness set that they might not have had originally.
@@ -1532,7 +1525,7 @@ oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs
 
     go ctxt (bndr:bndrs) rev_bndrs
       | isId bndr
-      
+
       = case ctxt of
           []                -> go []   bndrs (bndr : rev_bndrs)
           (one_shot : ctxt) -> go ctxt bndrs (bndr': rev_bndrs)
@@ -1544,10 +1537,7 @@ oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs
 addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
 addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args
   = env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt }
-\end{code}
-
 
-\begin{code}
 transClosureFV :: UniqFM VarSet -> UniqFM VarSet
 -- If (f,g), (g,h) are in the input, then (f,h) is in the output
 --                                   as well as (f,g), (g,h)
@@ -1578,14 +1568,13 @@ extendFvs env s
     extras :: VarSet    -- env(s)
     extras = foldUFM unionVarSet emptyVarSet $
              intersectUFM_C (\x _ -> x) env s
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                     Binder swap
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Binder swap]
 ~~~~~~~~~~~~~~~~~~
@@ -1656,7 +1645,7 @@ When the scrutinee is a GlobalId we must take care in two ways
 
  i) In order to *know* whether 'x' occurs free in the RHS, we need its
     occurrence info. BUT, we don't gather occurrence info for
-    GlobalIds.  That's the reason for the (small) occ_gbl_scrut env in 
+    GlobalIds.  That's the reason for the (small) occ_gbl_scrut env in
     OccEnv is for: it says "gather occurrence info for these".
 
  ii) We must call localiseId on 'x' first, in case it's a GlobalId, or
@@ -1734,8 +1723,8 @@ binder-swap in OccAnal:
 It's fixed by doing the binder-swap in OccAnal because we can do the
 binder-swap unconditionally and still get occurrence analysis
 information right.
+-}
 
-\begin{code}
 mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr))
 -- Does two things: a) makes the occ_one_shots = OccVanilla
 --                  b) extends the GlobalScruts if possible
@@ -1758,16 +1747,15 @@ mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr
         -- new binding for it, and it might have an External Name, or
         -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees]
         -- Also we don't want any INLINE or NOINLINE pragmas!
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[OccurAnal-types]{OccEnv}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 type UsageDetails = IdEnv OccInfo       -- A finite map from ids to their usage
                 -- INVARIANT: never IAmDead
                 -- (Deadness is signalled by not being in the map at all)
@@ -1835,16 +1823,15 @@ setBinderOcc usage bndr
   | otherwise = setIdOccInfo bndr occ_info
   where
     occ_info = lookupVarEnv usage bndr `orElse` IAmDead
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Operations over OccInfo}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
 mkOneOcc env id int_cxt
   | isLocalId id
@@ -1882,4 +1869,3 @@ orOccInfo (OneOcc in_lam1 _ int_cxt1)
            (int_cxt1 && int_cxt2)
 orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
                   NoOccInfo
-\end{code}
similarity index 95%
rename from compiler/simplCore/SAT.lhs
rename to compiler/simplCore/SAT.hs
index bd5b718..dc76df0 100644 (file)
@@ -1,12 +1,12 @@
-%
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
 
-%************************************************************************
+************************************************************************
 
                Static Argument Transformation pass
 
-%************************************************************************
+************************************************************************
 
 May be seen as removing invariants from loops:
 Arguments of recursive functions that do not change in recursive
@@ -46,9 +46,8 @@ Geometric Mean  +0.0%     -0.2%     -6.9%
 
 The previous patch, to fix polymorphic floatout demand signatures, is
 essential to make this work well!
+-}
 
-
-\begin{code}
 {-# LANGUAGE CPP #-}
 module SAT ( doStaticArgs ) where
 
@@ -72,17 +71,14 @@ import Data.List
 import FastString
 
 #include "HsVersions.h"
-\end{code}
 
-\begin{code}
 doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram
 doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds
   where
     sat_bind_threaded_us us bind =
         let (us1, us2) = splitUniqSupply us
         in (us1, fst $ runSAT us2 (satBind bind emptyUniqSet))
-\end{code}
-\begin{code}
+
 -- We don't bother to SAT recursive groups since it can lead
 -- to massive code expansion: see Andre Santos' thesis for details.
 -- This means we only apply the actual SAT to Rec groups of one element,
@@ -111,8 +107,7 @@ satBind (Rec pairs) interesting_ids = do
     rhss_SATed <- mapM (\e -> satTopLevelExpr e interesting_ids) rhss
     let (rhss', sat_info_rhss') = unzip rhss_SATed
     return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss')
-\end{code}
-\begin{code}
+
 data App = VarApp Id | TypeApp Type | CoApp Coercion
 data Staticness a = Static a | NotStatic
 
@@ -177,8 +172,7 @@ finalizeApp (Just (v, sat_info')) id_sat_info =
                         Nothing -> sat_info'
                         Just sat_info -> mergeSATInfo sat_info sat_info'
     in extendVarEnv id_sat_info v sat_info''
-\end{code}
-\begin{code}
+
 satTopLevelExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo)
 satTopLevelExpr expr interesting_ids = do
     (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
@@ -249,15 +243,15 @@ satExpr co@(Coercion _) _ = do
 satExpr (Cast expr coercion) interesting_ids = do
     (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
     return (Cast expr' coercion, sat_info_expr, expr_app)
-\end{code}
 
-%************************************************************************
+{-
+************************************************************************
 
                 Static Argument Transformation Monad
 
-%************************************************************************
+************************************************************************
+-}
 
-\begin{code}
 type SatM result = UniqSM result
 
 runSAT :: UniqSupply -> SatM a -> a
@@ -265,14 +259,13 @@ runSAT = initUs_
 
 newUnique :: SatM Unique
 newUnique = getUniqueM
-\end{code}
-
 
-%************************************************************************
+{-
+************************************************************************
 
                 Static Argument Transformation Monad
 
-%************************************************************************
+************************************************************************
 
 To do the transformation, the game plan is to:
 
@@ -368,8 +361,8 @@ GHC.Base.until =
 Where sat_shadow has captured the type variables of x_a6X etc as it has a a_aiK
 type argument. This is bad because it means the application sat_worker_s1aU x_a6X
 is not well typed.
+-}
 
-\begin{code}
 saTransformMaybe :: Id -> Maybe SATInfo -> [Id] -> CoreExpr -> SatM CoreBind
 saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body
   | Just arg_staticness <- maybe_arg_staticness
@@ -436,5 +429,3 @@ saTransform binder arg_staticness rhs_binders rhs_body
 isStaticValue :: Staticness App -> Bool
 isStaticValue (Static (VarApp _)) = True
 isStaticValue _                   = False
-
-\end{code}
similarity index 95%
rename from compiler/simplCore/SetLevels.lhs
rename to compiler/simplCore/SetLevels.hs
index b8726d9..e700040 100644 (file)
@@ -1,6 +1,6 @@
-%
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
 \section{SetLevels}
 
                 ***************************
@@ -40,8 +40,8 @@
   The simplifier tries to get rid of occurrences of x, in favour of wild,
   in the hope that there will only be one remaining occurrence of x, namely
   the scrutinee of the case, and we can inline it.
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 module SetLevels (
         setLevels,
@@ -80,15 +80,15 @@ import UniqSupply
 import Util
 import Outputable
 import FastString
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Level numbers}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 type LevelledExpr = TaggedExpr FloatSpec
 type LevelledBind = TaggedBind FloatSpec
 type LevelledBndr = TaggedBndr FloatSpec
@@ -107,8 +107,8 @@ data FloatSpec
 floatSpecLevel :: FloatSpec -> Level
 floatSpecLevel (FloatMe l) = l
 floatSpecLevel (StayPut l) = l
-\end{code}
 
+{-
 The {\em level number} on a (type-)lambda-bound variable is the
 nesting depth of the (type-)lambda which binds it.  The outermost lambda
 has level 1, so (Level 0 0) means that the variable is bound outside any lambda.
@@ -162,8 +162,8 @@ One particular case is that of workers: we don't want to float the
 call to the worker outside the wrapper, otherwise the worker might get
 inlined into the floated expression, and an importing module won't see
 the worker at all.
+-}
 
-\begin{code}
 instance Outputable FloatSpec where
   ppr (FloatMe l) = char 'F' <> ppr l
   ppr (StayPut l) = ppr l
@@ -199,16 +199,15 @@ instance Outputable Level where
 
 instance Eq Level where
   (Level maj1 min1) == (Level maj2 min2) = maj1 == maj2 && min1 == min2
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Main level-setting code}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 setLevels :: FloatOutSwitches
           -> CoreProgram
           -> UniqSupply
@@ -237,13 +236,13 @@ lvlTopBind env (Rec pairs)
            (env', bndrs') = substAndLvlBndrs Recursive env tOP_LEVEL bndrs
        rhss' <- mapM (lvlExpr env' . freeVars) rhss
        return (Rec (bndrs' `zip` rhss'), env')
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Setting expression levels}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Floating over-saturated applications]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -258,13 +257,13 @@ is minimal, and the extra local thunks allocated cost money.
 Arguably we could float even class-op applications if they were going to
 top level -- but then they must be applied to a constant dictionary and
 will almost certainly be optimised away anyway.
+-}
 
-\begin{code}
 lvlExpr :: LevelEnv             -- Context
         -> CoreExprWithFVs      -- Input expression
         -> LvlM LevelledExpr    -- Result expression
-\end{code}
 
+{-
 The @ctxt_lvl@ is, roughly, the level of the innermost enclosing
 binder.  Here's an example
 
@@ -279,8 +278,8 @@ don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
 --- because it isn't a *maximal* free expression.
 
 If there were another lambda in @r@'s rhs, it would get level-2 as well.
+-}
 
-\begin{code}
 lvlExpr env (_, AnnType ty)     = return (Type (substTy (le_subst env) ty))
 lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co))
 lvlExpr env (_, AnnVar v)       = return (lookupVar env v)
@@ -398,8 +397,8 @@ lvlCase env scrut_fvs scrut' case_bndr ty alts
              ; return (con, bs', rhs') }
         where
           (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs
-\end{code}
 
+{-
 Note [Floating cases]
 ~~~~~~~~~~~~~~~~~~~~~
 Consider this:
@@ -443,8 +442,8 @@ the inner case out, at least not unless x is also evaluated at its
 binding site.
 
 That's why we apply exprOkForSpeculation to scrut' and not to scrut.
+-}
 
-\begin{code}
 lvlMFE ::  Bool                 -- True <=> strict context [body of case or let]
         -> LevelEnv             -- Level of in-scope names/tyvars
         -> CoreExprWithFVs      -- input expression
@@ -516,8 +515,8 @@ lvlMFE strict_ctxt env ann_expr@(fvs, _)
           --
           -- Also a strict contxt includes uboxed values, and they
           -- can't be bound at top level
-\end{code}
 
+{-
 Note [Unlifted MFEs]
 ~~~~~~~~~~~~~~~~~~~~
 We don't float unlifted MFEs, which potentially loses big opportunites.
@@ -566,8 +565,8 @@ Because in doing so we share a tiny bit of computation (the switch) but
 in exchange we build a thunk, which is bad.  This case reduces allocation
 by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem.
 Doesn't change any other allocation at all.
+-}
 
-\begin{code}
 annotateBotStr :: Id -> Maybe (Arity, StrictSig) -> Id
 -- See Note [Bottoming floats] for why we want to add
 -- bottoming information right now
@@ -608,8 +607,8 @@ notWorthFloating e abs_vars
     is_triv (_, AnnApp e (_, AnnType {})) = is_triv e
     is_triv (_, AnnApp e (_, AnnCoercion {})) = is_triv e
     is_triv _                             = False
-\end{code}
 
+{-
 Note [Floating literals]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 It's important to float Integer literals, so that they get shared,
@@ -663,15 +662,15 @@ OLD comment was:
         to the condition above. We should really try this out.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{Bindings}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 The binding stuff works for top level too.
+-}
 
-\begin{code}
 lvlBind :: LevelEnv
         -> CoreBindWithFVs
         -> LvlM (LevelledBind, LevelEnv)
@@ -789,16 +788,15 @@ lvlFloatRhs abs_vars dest_lvl env rhs
        ; return (mkLams abs_vars_w_lvls rhs') }
   where
     (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Deciding floatability}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr])
 substAndLvlBndrs is_rec env lvl bndrs
   = lvlBndrs subst_env lvl subst_bndrs
@@ -847,9 +845,7 @@ lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs
   where
     lvld_bndrs    = [TB bndr (StayPut new_lvl) | bndr <- bndrs]
     add_lvl env v = extendVarEnv env v new_lvl
-\end{code}
 
-\begin{code}
   -- Destination level is the max Id level of the expression
   -- (We'll abstract the type variables, if any.)
 destLevel :: LevelEnv -> VarSet
@@ -895,16 +891,15 @@ countFreeIds = foldVarSet add 0
     add :: Var -> Int -> Int
     add v n | isId v    = n+1
             | otherwise = n
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Free-To-Level Monad}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 type InVar  = Var   -- Pre  cloning
 type InId   = Id    -- Pre  cloning
 type OutVar = Var   -- Post cloning
@@ -1028,17 +1023,12 @@ abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs
     close v = foldVarSet (unionVarSet . close)
                          (unitVarSet v)
                          (varTypeTyVars v)
-\end{code}
 
-\begin{code}
 type LvlM result = UniqSM result
 
 initLvl :: UniqSupply -> UniqSM a -> a
 initLvl = initUs_
-\end{code}
-
 
-\begin{code}
 newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId] -> UniqSM (LevelEnv, [OutId])
 -- The envt is extended to bind the new bndrs to dest_lvl, but
 -- the ctxt_lvl is unaffected
@@ -1109,8 +1099,8 @@ zap_demand_info :: Var -> Var
 zap_demand_info v
   | isId v    = zapDemandIdInfo v
   | otherwise = v
-\end{code}
 
+{-
 Note [Zapping the demand info]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 VERY IMPORTANT: we must zap the demand info if the thing is going to
@@ -1119,3 +1109,4 @@ binding site.  Eg
    f :: Int -> Int
    f x = let v = 3*4 in v+x
 Here v is strict; but if we float v to top level, it isn't any more.
+-}
similarity index 93%
rename from compiler/simplCore/SimplCore.lhs
rename to compiler/simplCore/SimplCore.hs
index 883f2ef..75766e8 100644 (file)
@@ -1,9 +1,9 @@
-%
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
 \section[SimplCore]{Driver for simplifying @Core@ programs}
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module SimplCore ( core2core, simplifyExpr ) where
@@ -55,15 +55,15 @@ import Control.Monad
 import DynamicLoading   ( loadPlugins )
 import Plugins          ( installCoreToDos )
 #endif
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{The driver for the simplifier}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 core2core :: HscEnv -> ModGuts -> IO ModGuts
 core2core hsc_env guts
   = do { us <- mkSplitUniqSupply 's'
@@ -91,16 +91,15 @@ core2core hsc_env guts
     -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
     -- would mean our cached value would go out of date.
     print_unqual = mkPrintUnqualified dflags (mg_rdr_env guts)
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
            Generating the main optimisation pipeline
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 getCoreToDo :: DynFlags -> [CoreToDo]
 getCoreToDo dflags
   = core_todo
@@ -311,11 +310,9 @@ getCoreToDo dflags
 
         maybe_rule_check (Phase 0)
      ]
-\end{code}
 
-Loading plugins
+-- Loading plugins
 
-\begin{code}
 addPluginPasses :: [CoreToDo] -> CoreM [CoreToDo]
 #ifndef GHCI
 addPluginPasses builtin_passes = return builtin_passes
@@ -327,15 +324,15 @@ addPluginPasses builtin_passes
   where
     query_plug todos (_, plug, options) = installCoreToDos plug options todos
 #endif
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                   The CoreToDo interpreter
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts
 runCorePasses passes guts
   = foldM do_pass guts passes
@@ -395,15 +392,15 @@ doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass
 #endif
 
 doCorePass pass = pprPanic "doCorePass" (ppr pass)
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Core pass combinators}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 printCore :: DynFlags -> CoreProgram -> IO ()
 printCore dflags binds
     = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds)
@@ -467,16 +464,15 @@ observe do_pass = doPassM $ \binds -> do
     dflags <- getDynFlags
     _ <- liftIO $ do_pass dflags binds
     return binds
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
         Gentle simplification
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
              -> CoreExpr
              -> IO CoreExpr
@@ -525,16 +521,15 @@ simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 simplExprGently env expr = do
     expr1 <- simplExpr env (occurAnalyseExpr expr)
     simplExpr env (occurAnalyseExpr expr1)
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{The driver for the simplifier}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
 simplifyPgm pass guts
   = do { hsc_env <- getHscEnv
@@ -700,14 +695,13 @@ dump_end_iteration dflags print_unqual iteration_no counts binds rules
     pp_counts = vcat [ ptext (sLit "---- Simplifier counts for") <+> hdr
                      , pprSimplCount counts
                      , ptext (sLit "---- End of simplifier counts for") <+> hdr ]
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Shorting out indirections
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 If we have this:
 
@@ -826,8 +820,8 @@ could be eliminated.  But I don't think it's very common
 and it's dangerous to do this fiddling in STG land
 because we might elminate a binding that's mentioned in the
 unfolding for something.
+-}
 
-\begin{code}
 type IndEnv = IdEnv Id          -- Maps local_id -> exported_id
 
 shortOutIndirections :: CoreProgram -> CoreProgram
@@ -920,4 +914,3 @@ transferIdInfo exported_id local_id
                                (specInfo local_info)
         -- Remember to set the function-name field of the
         -- rules as we transfer them from one function to another
-\end{code}
similarity index 93%
rename from compiler/simplCore/SimplEnv.lhs
rename to compiler/simplCore/SimplEnv.hs
index d8aec03..a5d8551 100644 (file)
@@ -1,9 +1,9 @@
-%
-(c) The AQUA Project, Glasgow University, 1993-1998
-%
+{-
+(c) The AQUA Project, Glasgow University, 1993-1998
+
 \section[SimplMonad]{The simplifier Monad}
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module SimplEnv (
@@ -61,15 +61,15 @@ import FastString
 import Util
 
 import Data.List
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[Simplify-types]{Type declarations}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 type InBndr     = CoreBndr
 type InVar      = Var                   -- Not yet cloned
 type InId       = Id                    -- Not yet cloned
@@ -90,16 +90,15 @@ type OutBind     = CoreBind
 type OutExpr     = CoreExpr
 type OutAlt      = CoreAlt
 type OutArg      = CoreArg
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsubsection{The @SimplEnv@ type}
-%*                                                                      *
-%************************************************************************
-
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 data SimplEnv
   = SimplEnv {
      ----------- Static part of the environment -----------
@@ -159,8 +158,8 @@ instance Outputable SimplSR where
         -- fvs = exprFreeVars e
         -- filter_env env = filterVarEnv_Directly keep env
         -- keep uniq _ = uniq `elemUFM_Directly` fvs
-\end{code}
 
+{-
 Note [SimplEnv invariants]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 seInScope:
@@ -224,9 +223,8 @@ seIdSubst:
   map to the same target:  x->x, y->x.  Notably:
         case y of x { ... }
   That's why the "set" is actually a VarEnv Var
+-}
 
-
-\begin{code}
 mkSimplEnv :: SimplifierMode -> SimplEnv
 mkSimplEnv mode
   = SimplEnv { seMode = mode
@@ -240,8 +238,8 @@ mkSimplEnv mode
 init_in_scope :: InScopeSet
 init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy))
               -- See Note [WildCard binders]
-\end{code}
 
+{-
 Note [WildCard binders]
 ~~~~~~~~~~~~~~~~~~~~~~~
 The program to be simplified may have wild binders
@@ -259,8 +257,8 @@ thing. Generally, you want to run the simplifier to get rid of the
 wild-ids before doing much else.
 
 It's a very dark corner of GHC.  Maybe it should be cleaned up.
+-}
 
-\begin{code}
 getMode :: SimplEnv -> SimplifierMode
 getMode env = seMode env
 
@@ -330,15 +328,13 @@ setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst
 
 mkContEx :: SimplEnv -> InExpr -> SimplSR
 mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e
-\end{code}
-
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Floats}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Simplifier floats]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -359,8 +355,8 @@ Examples
 Can't happen:
   NonRec x# (a /# b)    -- Might fail; does not satisfy let/app
   NonRec x# (f y)       -- Might diverge; does not satisfy let/app
+-}
 
-\begin{code}
 data Floats = Floats (OrdList OutBind) FloatFlag
         -- See Note [Simplifier floats]
 
@@ -399,25 +395,25 @@ doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
 doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})
   =  not (isNilOL fs) && want_to_float && can_float
   where
-     want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs 
+     want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs
                      -- See Note [Float when cheap or expandable]
      can_float = case ff of
                    FltLifted  -> True
                    FltOkSpec  -> isNotTopLevel lvl && isNonRec rec
                    FltCareful -> isNotTopLevel lvl && isNonRec rec && str
-\end{code}
 
+{-
 Note [Float when cheap or expandable]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We want to float a let from a let if the residual RHS is
    a) cheap, such as (\x. blah)
    b) expandable, such as (f b) if f is CONLIKE
-But there are 
+But there are
   - cheap things that are not expandable (eg \x. expensive)
   - expandable things that are not cheap (eg (f b) where b is CONLIKE)
 so we must take the 'or' of the two.
+-}
 
-\begin{code}
 emptyFloats :: Floats
 emptyFloats = Floats nilOL FltLifted
 
@@ -489,8 +485,8 @@ getFloatBinds (SimplEnv {seFloats = Floats bs _})
 isEmptyFloats :: SimplEnv -> Bool
 isEmptyFloats (SimplEnv {seFloats = Floats bs _})
   = isNilOL bs
-\end{code}
 
+{-
 -- mapFloats commented out: used only in a commented-out bit of Simplify,
 -- concerning ticks
 --
@@ -502,11 +498,11 @@ isEmptyFloats (SimplEnv {seFloats = Floats bs _})
 --     app (Rec bs)     = Rec (map fun bs)
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
                 Substitution of Vars
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Global Ids in the substitution]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -518,8 +514,8 @@ for a LocalId version of g (with the same unique though):
                                 ... case X.g_34 of { (p,q) -> ...} ... }
 So we want to look up the inner X.g_34 in the substitution, where we'll
 find that it has been substituted by b.  (Or conceivably cloned.)
+-}
 
-\begin{code}
 substId :: SimplEnv -> InId -> SimplSR
 -- Returns DoneEx only on a non-Var expression
 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
@@ -547,19 +543,18 @@ lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
         Just (DoneId v) -> v
         Just _ -> pprPanic "lookupRecBndr" (ppr v)
         Nothing -> refine in_scope v
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \section{Substituting an Id binder}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 
 These functions are in the monad only so that they can be made strict via seq.
+-}
 
-\begin{code}
 simplBinders, simplLamBndrs
         :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
 simplBinders  env bndrs = mapAccumLM simplBinder  env bndrs
@@ -656,9 +651,7 @@ substNonCoVarIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }
               = extendVarEnv id_subst old_id (DoneId new_id)
               | otherwise
               = delVarEnv id_subst old_id
-\end{code}
 
-\begin{code}
 ------------------------------------
 seqTyVar :: TyVar -> ()
 seqTyVar b = b `seq` ()
@@ -671,9 +664,8 @@ seqId id = seqType (idType id)  `seq`
 seqIds :: [Id] -> ()
 seqIds []       = ()
 seqIds (id:ids) = seqId id `seq` seqIds ids
-\end{code}
-
 
+{-
 Note [Arity robustness]
 ~~~~~~~~~~~~~~~~~~~~~~~
 We *do* transfer the arity from from the in_id of a let binding to the
@@ -719,9 +711,8 @@ cases where he really, really wanted a RULE for a recursive function
 to apply in that function's own right-hand side.
 
 See Note [Loop breaking and RULES] in OccAnal.
+-}
 
-
-\begin{code}
 addBndrRules :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
 -- Rules are added back into the bin
 addBndrRules env in_id out_id
@@ -732,16 +723,15 @@ addBndrRules env in_id out_id
     old_rules = idSpecialisation in_id
     new_rules = CoreSubst.substSpec subst out_id old_rules
     final_id  = out_id `setIdSpecialisation` new_rules
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Impedence matching to type substitution
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 getTvSubst :: SimplEnv -> TvSubst
 getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env })
   = mkTvSubst in_scope tv_env
@@ -813,5 +803,3 @@ substUnfolding :: SimplEnv -> Unfolding -> Unfolding
 substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst (text "subst-unfolding") env) unf
   -- Do *not* short-cut in the case of an empty substitution
   -- See Note [SimplEnv invariants]
-\end{code}
-
similarity index 85%
rename from compiler/simplCore/SimplMonad.lhs
rename to compiler/simplCore/SimplMonad.hs
index ca14688..451bf34 100644 (file)
@@ -1,9 +1,9 @@
-%
-(c) The AQUA Project, Glasgow University, 1993-1998
-%
+{-
+(c) The AQUA Project, Glasgow University, 1993-1998
+
 \section[SimplMonad]{The simplifier Monad}
+-}
 
-\begin{code}
 module SimplMonad (
         -- The monad
         SimplM,
@@ -31,18 +31,18 @@ import FastString
 import MonadUtils
 import ErrUtils
 import Control.Monad       ( when, liftM, ap )
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Monad plumbing}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
 (Command-line switches move around through the explicitly-passed SimplEnv.)
+-}
 
-\begin{code}
 newtype SimplM result
   =  SM  { unSM :: SimplTopEnv  -- Envt that does not change much
                 -> UniqSupply   -- We thread the unique supply because
@@ -57,9 +57,7 @@ data SimplTopEnv
                                -- Zero means infinity!
         , st_rules :: RuleBase
         , st_fams  :: (FamInstEnv, FamInstEnv) }
-\end{code}
 
-\begin{code}
 initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv)
          -> UniqSupply          -- No init count; set to 0
          -> Int                 -- Size of the bindings, used to limit
@@ -136,19 +134,18 @@ thenSmpl_ m k
 traceSmpl :: String -> SDoc -> SimplM ()
 traceSmpl herald doc
   = do { dflags <- getDynFlags
-       ; when (dopt Opt_D_dump_simpl_trace dflags) $ liftIO $ 
+       ; when (dopt Opt_D_dump_simpl_trace dflags) $ liftIO $
          printInfoForUser dflags alwaysQualify $
          hang (text herald) 2 doc }
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{The unique supply}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 instance MonadUnique SimplM where
     getUniqueSupplyM
        = SM (\_st_env us sc -> case splitUniqSupply us of
@@ -179,16 +176,15 @@ getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc))
 newId :: FastString -> Type -> SimplM Id
 newId fs ty = do uniq <- getUniqueM
                  return (mkSysLocal fs uniq ty)
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Counting up what we've done}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 getSimplCount :: SimplM SimplCount
 getSimplCount = SM (\_st_env us sc -> return (sc, us, sc))
 
@@ -220,4 +216,3 @@ freeTick :: Tick -> SimplM ()
 freeTick t
    = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
                            in sc' `seq` return ((), us, sc'))
-\end{code}
similarity index 95%
rename from compiler/simplCore/SimplUtils.lhs
rename to compiler/simplCore/SimplUtils.hs
index 1cfba43..eec0f4b 100644 (file)
@@ -1,9 +1,9 @@
-%
-(c) The AQUA Project, Glasgow University, 1993-1998
-%
+{-
+(c) The AQUA Project, Glasgow University, 1993-1998
+
 \section[SimplUtils]{The simplifier utilities}
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module SimplUtils (
@@ -17,16 +17,16 @@ module SimplUtils (
         simplEnvForGHCi, updModeForStableUnfoldings,
 
         -- The continuation type
-        SimplCont(..), DupFlag(..), 
+        SimplCont(..), DupFlag(..),
         isSimplified,
         contIsDupable, contResultType, contInputType,
         contIsTrivial, contArgs, dropArgs,
-        pushSimplifiedArgs, countValArgs, countArgs, 
+        pushSimplifiedArgs, countValArgs, countArgs,
         mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,
-        interestingCallContext, interestingArg, 
+        interestingCallContext, interestingArg,
 
         -- ArgInfo
-        ArgInfo(..), ArgSpec(..), mkArgInfo, addArgTo, addCastTo, 
+        ArgInfo(..), ArgSpec(..), mkArgInfo, addArgTo, addCastTo,
         argInfoExpr, argInfoValArgs,
 
         abstractFloats
@@ -62,14 +62,13 @@ import FastString
 import Pair
 
 import Control.Monad    ( when )
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 The SimplCont type
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 A SimplCont allows the simplifier to traverse the expression in a
 zipper-like fashion.  The SimplCont represents the rest of the expression,
@@ -90,8 +89,8 @@ Key points:
 
   * A SimplCont describes a context that *does not* bind
     any variables.  E.g. \x. [] is not a SimplCont
+-}
 
-\begin{code}
 data SimplCont
   = Stop                -- An empty context, or <hole>
         OutType         -- Type of the <hole>
@@ -210,8 +209,8 @@ instance Outputable DupFlag where
   ppr OkToDup    = ptext (sLit "ok")
   ppr NoDup      = ptext (sLit "nodup")
   ppr Simplified = ptext (sLit "simpl")
-\end{code}
 
+{-
 Note [DupFlag invariants]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 In both (ApplyTo dup _ env k)
@@ -221,8 +220,8 @@ the following invariants hold
   (a) if dup = OkToDup, then continuation k is also ok-to-dup
   (b) if dup = OkToDup or Simplified, the subst-env is empty
       (and and hence no need to re-simplify)
+-}
 
-\begin{code}
 -------------------
 mkBoringStop :: OutType -> SimplCont
 mkBoringStop ty = Stop ty BoringCtxt
@@ -297,7 +296,7 @@ countArgs _                    = 0
 
 contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)
 -- Summarises value args, discards type args and coercions
--- The returned continuation of the call is only used to 
+-- The returned continuation of the call is only used to
 -- answer questions like "are you interesting?"
 contArgs cont
   | lone cont = (True, [], cont)
@@ -326,9 +325,8 @@ dropArgs :: Int -> SimplCont -> SimplCont
 dropArgs 0 cont = cont
 dropArgs n (ApplyTo _ _ _ cont) = dropArgs (n-1) cont
 dropArgs n other                = pprPanic "dropArgs" (ppr n <+> ppr other)
-\end{code}
-
 
+{-
 Note [Interesting call context]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We want to avoid inlining an expression where there can't possibly be
@@ -361,9 +359,8 @@ since we can just eliminate this case instead (x is in WHNF).  Similar
 applies when x is bound to a lambda expression.  Hence
 contIsInteresting looks for case expressions with just a single
 default case.
+-}
 
-
-\begin{code}
 interestingCallContext :: SimplCont -> CallCtxt
 -- See Note [Interesting call context]
 interestingCallContext cont
@@ -511,14 +508,13 @@ interestingArgContext rules call_cont
 
     interesting RuleArgCtxt = True
     interesting _           = False
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                   SimplifierMode
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 The SimplifierMode controls several switches; see its definition in
 CoreMonad
@@ -526,8 +522,8 @@ CoreMonad
         sm_inline     :: Bool     -- Whether inlining is enabled
         sm_case_case  :: Bool     -- Whether case-of-case is enabled
         sm_eta_expand :: Bool     -- Whether eta-expansion is enabled
+-}
 
-\begin{code}
 simplEnvForGHCi :: DynFlags -> SimplEnv
 simplEnvForGHCi dflags
   = mkSimplEnv $ SimplMode { sm_names = ["GHCi"]
@@ -553,8 +549,8 @@ updModeForStableUnfoldings inline_rule_act current_mode
   where
     phaseFromActivation (ActiveAfter n) = Phase n
     phaseFromActivation _               = InitialPhase
-\end{code}
 
+{-
 Note [Inlining in gentle mode]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Something is inlined if
@@ -670,8 +666,8 @@ the wrapper (initially, the worker's only call site!).  But,
 if the wrapper is sure to be called, the strictness analyser will
 mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
 continuation.
+-}
 
-\begin{code}
 activeUnfolding :: SimplEnv -> Id -> Bool
 activeUnfolding env
   | not (sm_inline mode) = active_unfolding_minimal
@@ -733,15 +729,13 @@ activeRule env
   | otherwise           = isActive (sm_phase mode)
   where
     mode = getMode env
-\end{code}
-
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                   preInlineUnconditionally
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 preInlineUnconditionally
 ~~~~~~~~~~~~~~~~~~~~~~~~
@@ -851,8 +845,8 @@ Note [Do not inline CoVars unconditionally]
 Coercion variables appear inside coercions, and the RHS of a let-binding
 is a term (not a coercion) so we can't necessarily inline the latter in
 the former.
+-}
 
-\begin{code}
 preInlineUnconditionally :: DynFlags -> SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
 -- Precondition: rhs satisfies the let/app invariant
 -- See Note [CoreSyn let/app invariant] in CoreSyn
@@ -922,13 +916,12 @@ preInlineUnconditionally dflags env top_lvl bndr rhs
 -- top level things, but then we become more leery about inlining
 -- them.
 
-\end{code}
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                   postInlineUnconditionally
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 postInlineUnconditionally
 ~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -957,8 +950,8 @@ it's best to inline it anyway.  We often get a=E; b=a from desugaring,
 with both a and b marked NOINLINE.  But that seems incompatible with
 our new view that inlining is like a RULE, so I'm sticking to the 'active'
 story for now.
+-}
 
-\begin{code}
 postInlineUnconditionally
     :: DynFlags -> SimplEnv -> TopLevelFlag
     -> OutId            -- The binder (an InId would be fine too)
@@ -1041,8 +1034,8 @@ postInlineUnconditionally dflags env top_lvl bndr occ_info rhs unfolding
   where
     active = isActive (sm_phase (getMode env)) (idInlineActivation bndr)
         -- See Note [pre/postInlineUnconditionally in gentle mode]
-\end{code}
 
+{-
 Note [Top level and postInlineUnconditionally]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We don't do postInlineUnconditionally for top-level things (even for
@@ -1089,13 +1082,13 @@ won't inline because 'e' is too big.
     c.f. Note [Stable unfoldings and preInlineUnconditionally]
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
         Rebuilding a lambda
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 mkLam :: [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr
 -- mkLam tries three things
 --      a) eta reduction, if that gives a trivial expression
@@ -1138,9 +1131,8 @@ mkLam bndrs body cont
 
       | otherwise
       = return (mkLams bndrs body)
-\end{code}
-
 
+{-
 Note [Eta expanding lambdas]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In general we *do* want to eta-expand lambdas. Consider
@@ -1191,13 +1183,13 @@ It does not make sense to transform
         /\g. e `cast` g  ==>  (/\g.e) `cast` (/\g.g)
 because the latter is not well-kinded.
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
               Eta expansion
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tryEtaExpandRhs :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr)
 -- See Note [Eta-expanding at let bindings]
 tryEtaExpandRhs env bndr rhs
@@ -1226,8 +1218,8 @@ tryEtaExpandRhs env bndr rhs
 
     old_arity    = exprArity rhs -- See Note [Do not expand eta-expand PAPs]
     old_id_arity = idArity bndr
-\end{code}
 
+{-
 Note [Eta-expanding at let bindings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We now eta expand at let-bindings, which is where the payoff comes.
@@ -1256,7 +1248,7 @@ Note [Do not eta-expand PAPs]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We used to have old_arity = manifestArity rhs, which meant that we
 would eta-expand even PAPs.  But this gives no particular advantage,
-and can lead to a massive blow-up in code size, exhibited by Trac #9020.  
+and can lead to a massive blow-up in code size, exhibited by Trac #9020.
 Suppose we have a PAP
     foo :: IO ()
     foo = returnIO ()
@@ -1276,11 +1268,11 @@ Does it matter not eta-expanding such functions?  I'm not sure.  Perhaps
 strictness analysis will have less to bite on?
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{Floating lets out of big lambdas}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Floating and type abstraction]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1356,9 +1348,8 @@ as we would normally do.
 That's why the whole transformation is part of the same process that
 floats let-bindings and constructor arguments out of RHSs.  In particular,
 it is guarded by the doFloatFromRhs call in simplLazyBind.
+-}
 
-
-\begin{code}
 abstractFloats :: [OutTyVar] -> SimplEnv -> OutExpr -> SimplM ([OutBind], OutExpr)
 abstractFloats main_tvs body_env body
   = ASSERT( notNull body_floats )
@@ -1437,8 +1428,8 @@ abstractFloats main_tvs body_env body
                 -- where x* has an INLINE prag on it.  Now, once x* is inlined,
                 -- the occurrences of x' will be just the occurrences originally
                 -- pinned on x.
-\end{code}
 
+{-
 Note [Abstract over coercions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the
@@ -1468,11 +1459,11 @@ Historical note: if you use let-bindings instead of a substitution, beware of th
                 --           to appear many times.  (NB: mkInlineMe eliminates
                 --           such notes on trivial RHSs, so do it manually.)
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
                 prepareAlts
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 prepareAlts tries these things:
 
@@ -1515,8 +1506,8 @@ h y = case y of
 If we inline h into f, the default case of the inlined h can't happen.
 If we don't notice this, we may end up filtering out *all* the cases
 of the inner case y, which give us nowhere to go!
+-}
 
-\begin{code}
 prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])
 -- The returned alternatives can be empty, none are possible
 prepareAlts scrut case_bndr' alts
@@ -1524,18 +1515,18 @@ prepareAlts scrut case_bndr' alts
            --   OutId, it has maximum information; this is important.
            --   Test simpl013 is an example
   = do { us <- getUniquesM
-       ; let (imposs_deflt_cons, refined_deflt, alts') 
+       ; let (imposs_deflt_cons, refined_deflt, alts')
                 = filterAlts us (varType case_bndr') imposs_cons alts
        ; when refined_deflt $ tick (FillInCaseDefault case_bndr')
+
        ; alts'' <- combineIdenticalAlts case_bndr' alts'
        ; return (imposs_deflt_cons, alts'') }
   where
     imposs_cons = case scrut of
                     Var v -> otherCons (idUnfolding v)
                     _     -> []
-\end{code}
 
+{-
 Note [Combine identical alternatives]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  If several alternatives are identical, merge them into
@@ -1578,8 +1569,8 @@ NB: it's important that all this is done in [InAlt], *before* we work
 on the alternatives themselves, because Simpify.simplAlt may zap the
 occurrence info on the binders in the alternatives, which in turn
 defeats combineIdenticalAlts (see Trac #7360).
+-}
 
-\begin{code}
 combineIdenticalAlts :: OutId -> [InAlt] -> SimplM [InAlt]
 -- See Note [Combine identical alternatives]
 combineIdenticalAlts case_bndr ((_con1,bndrs1,rhs1) : con_alts)
@@ -1592,14 +1583,13 @@ combineIdenticalAlts case_bndr ((_con1,bndrs1,rhs1) : con_alts)
     identical_to_alt1 (_con,bndrs,rhs) = all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1
 
 combineIdenticalAlts _ alts = return alts
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 mkCase
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 mkCase tries these things
 
@@ -1628,9 +1618,8 @@ mkCase tries these things
                 False -> False
 
     and similar friends.
+-}
 
-
-\begin{code}
 mkCase, mkCase1, mkCase2
    :: DynFlags
    -> OutExpr -> OutId
@@ -1720,8 +1709,8 @@ mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts
 --------------------------------------------------
 mkCase2 _dflags scrut bndr alts_ty alts
   = return (Case scrut bndr alts_ty alts)
-\end{code}
 
+{-
 Note [Dead binders]
 ~~~~~~~~~~~~~~~~~~~~
 Note that dead-ness is maintained by the simplifier, so that it is
@@ -1787,5 +1776,4 @@ without getting changed to c1=I# c2.
 
 I don't think this is worth fixing, even if I knew how. It'll
 all come out in the next pass anyway.
-
-
+-}
similarity index 96%
rename from compiler/simplCore/Simplify.lhs
rename to compiler/simplCore/Simplify.hs
index cc55529..7611f56 100644 (file)
@@ -1,9 +1,9 @@
-%
-(c) The AQUA Project, Glasgow University, 1993-1998
-%
+{-
+(c) The AQUA Project, Glasgow University, 1993-1998
+
 \section[Simplify]{The main module of the simplifier}
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module Simplify ( simplTopBinds, simplExpr ) where
@@ -49,9 +49,8 @@ import FastString
 import Pair
 import Util
 import ErrUtils
-\end{code}
-
 
+{-
 The guts of the simplifier is in this module, but the driver loop for
 the simplifier is in SimplCore.lhs.
 
@@ -205,13 +204,13 @@ we should eta expand wherever we find a (value) lambda?  Then the eta
 expansion at a let RHS can concentrate solely on the PAP case.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{Bindings}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 simplTopBinds :: SimplEnv -> [InBind] -> SimplM SimplEnv
 
 simplTopBinds env0 binds0
@@ -238,19 +237,18 @@ simplTopBinds env0 binds0
     simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel NonRecursive b b' r
         where
           (env', b') = addBndrRules env b (lookupRecBndr env b)
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Lazy bindings}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 simplRecBind is used for
         * recursive bindings only
+-}
 
-\begin{code}
 simplRecBind :: SimplEnv -> TopLevelFlag
              -> [(InId, InExpr)]
              -> SimplM SimplEnv
@@ -272,15 +270,15 @@ simplRecBind env0 top_lvl pairs0
     go env ((old_bndr, new_bndr, rhs) : pairs)
         = do { env' <- simplRecOrTopPair env top_lvl Recursive old_bndr new_bndr rhs
              ; go env' pairs }
-\end{code}
 
+{-
 simplOrTopPair is used for
         * recursive bindings (whether top level or not)
         * top-level non-recursive bindings
 
 It assumes the binder has already been simplified, but not its IdInfo.
+-}
 
-\begin{code}
 simplRecOrTopPair :: SimplEnv
                   -> TopLevelFlag -> RecFlag
                   -> InId -> OutBndr -> InExpr  -- Binder and rhs
@@ -302,9 +300,8 @@ simplRecOrTopPair env top_lvl is_rec old_bndr new_bndr rhs
       = pprTrace "SimplBind" (ppr old_bndr) thing_inside
         -- trace_bind emits a trace for each top-level binding, which
         -- helps to locate the tracing for inlining and rule firing
-\end{code}
-
 
+{-
 simplLazyBind is used for
   * [simplRecOrTopPair] recursive bindings (whether top level or not)
   * [simplRecOrTopPair] top-level non-recursive bindings
@@ -318,8 +315,8 @@ Nota bene:
 
     3. It does not check for pre-inline-unconditionally;
        that should have been done already.
+-}
 
-\begin{code}
 simplLazyBind :: SimplEnv
               -> TopLevelFlag -> RecFlag
               -> InId -> OutId          -- Binder, both pre-and post simpl
@@ -368,12 +365,12 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
                         ; return (env', rhs') }
 
         ; completeBind env' top_lvl bndr bndr1 rhs' }
-\end{code}
 
+{-
 A specialised variant of simplNonRec used when the RHS is already simplified,
 notably in knownCon.  It uses case-binding where necessary.
+-}
 
-\begin{code}
 simplNonRecX :: SimplEnv
              -> InId            -- Old binder
              -> OutExpr         -- Simplified RHS
@@ -409,8 +406,8 @@ completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
                         ; return (addFloats env env1, rhs1) }   -- Add the floats to the main env
                 else return (env, wrapFloats env1 rhs1)         -- Wrap the floats around the RHS
         ; completeBind env2 NotTopLevel old_bndr new_bndr rhs2 }
-\end{code}
 
+{-
 {- No, no, no!  Do not try preInlineUnconditionally in completeNonRecX
    Doing so risks exponential behaviour, because new_rhs has been simplified once already
    In the cases described by the folowing commment, postInlineUnconditionally will
@@ -451,8 +448,8 @@ We also want to deal well cases like this
 Here we want to make e1,e2 trivial and get
         x1 = e1; x2 = e2; v = (f x1 `cast` co) v2
 That's what the 'go' loop in prepareRhs does
+-}
 
-\begin{code}
 prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr)
 -- Adds new floats to the env iff that allows us to return a good RHS
 prepareRhs top_lvl env id (Cast rhs co)    -- Note [Float coercions]
@@ -491,9 +488,8 @@ prepareRhs top_lvl env0 _ rhs0
 
     go _ env other
         = return (False, env, other)
-\end{code}
-
 
+{-
 Note [Float coercions]
 ~~~~~~~~~~~~~~~~~~~~~~
 When we find the binding
@@ -542,9 +538,8 @@ But 'v' isn't in scope!
 These strange casts can happen as a result of case-of-case
         bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of
                 (# p,q #) -> p+q
+-}
 
-
-\begin{code}
 makeTrivialArg :: SimplEnv -> ArgSpec -> SimplM (SimplEnv, ArgSpec)
 makeTrivialArg env (ValArg e)  = do { (env', e') <- makeTrivial NotTopLevel env e
                                     ; return (env', ValArg e') }
@@ -589,8 +584,8 @@ bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool
 bindingOk top_lvl _ expr_ty
   | isTopLevel top_lvl = not (isUnLiftedType expr_ty)
   | otherwise          = True
-\end{code}
 
+{-
 Note [Cannot trivialise]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 Consider tih
@@ -613,11 +608,11 @@ trivial):
 
 We don't want to ANF-ise this.
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{Completing a lazy binding}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 completeBind
   * deals only with Ids, not TyVars
@@ -637,8 +632,8 @@ It does *not* attempt to do let-to-case.  Why?  Because it is used for
                 (so let-to-case is inappropriate).
 
 Nor does it do the atomic-argument thing
+-}
 
-\begin{code}
 completeBind :: SimplEnv
              -> TopLevelFlag            -- Flag stuck into unfolding
              -> InId                    -- Old binder
@@ -782,8 +777,8 @@ simplUnfolding env top_lvl id new_rhs unf
     act      = idInlineActivation id
     rule_env = updMode (updModeForStableUnfoldings act) env
                -- See Note [Simplifying inside stable unfoldings] in SimplUtils
-\end{code}
 
+{-
 Note [Force bottoming field]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We need to force bottoming, or the new unfolding holds
@@ -845,11 +840,11 @@ After inlining f at some of its call sites the original binding may
 The solution here is a bit ad hoc...
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection[Simplify-simplExpr]{The main function: simplExpr}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 The reason for this OutExprStuff stuff is that we want to float *after*
 simplifying a RHS, not before.  If we do so naively we get quadratic
@@ -887,9 +882,8 @@ whole round if we float first.  This can cascade.  Consider
 
 Only in this second round can the \y be applied, and it
 might do the same again.
+-}
 
-
-\begin{code}
 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 simplExpr env expr = simplExprC env expr (mkBoringStop expr_out_ty)
   where
@@ -1149,16 +1143,15 @@ simplTick env tickish expr cont
 -- So we've moved a constant amount of work out of the scc to expose
 -- the case.  We only do this when the continuation is interesting: in
 -- for now, it has to be another Case (maybe generalise this later).
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{The main rebuilder}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
 -- At this point the substitution in the SimplEnv should be irrelevant
 -- only the in-scope set and floats should matter
@@ -1178,16 +1171,15 @@ rebuild env expr cont
         | otherwise                 -> do { arg' <- simplExpr (se `setInScope` env) arg
                                           ; rebuild env (App expr arg') cont }
       TickIt t cont                 -> rebuild env (mkTick t expr) cont
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Lambdas}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
           -> SimplM (SimplEnv, OutExpr)
 simplCast env body co0 cont0
@@ -1253,14 +1245,13 @@ simplCast env body co0 cont0
            arg_se'    = arg_se `setInScope` env
 
        add_coerce co _ cont = CoerceIt co cont
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Lambdas}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Zap unfolding when beta-reducing]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1274,8 +1265,8 @@ stupid situation of
           let b{Unf=Just x} = y
           in ...b...
 Here it'd be far better to drop the unfolding and use the actual RHS.
+-}
 
-\begin{code}
 simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
          -> SimplM (SimplEnv, OutExpr)
 
@@ -1355,15 +1346,15 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
                  ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
                  ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
                  ; simplLam env3 bndrs body cont }
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                      Variables
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 simplVar :: SimplEnv -> InVar -> SimplM OutExpr
 -- Look up an InVar in the environment
 simplVar env var
@@ -1501,8 +1492,8 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules })
                  -- Rules don't match
            ; Nothing -> rebuild env (argInfoExpr fun rev_args) cont      -- No rules
     } }
-\end{code}
 
+{-
 Note [RULES apply to simplified arguments]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 It's very desirable to try RULES once the arguments have been simplified, because
@@ -1550,13 +1541,13 @@ discard the entire application and replace it with (error "foo").  Getting
 all this at once is TOO HARD!
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
                 Rewrite rules
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tryRules :: SimplEnv -> [CoreRule]
          -> Id -> [OutExpr] -> SimplCont
          -> SimplM (Maybe (CoreExpr, SimplCont))
@@ -1618,8 +1609,8 @@ tryRules env rules fn args call_cont
     log_rule dflags flag hdr details
       = liftIO . dumpSDoc dflags alwaysQualify flag "" $
                    sep [text hdr, nest 4 details]
-\end{code}
 
+{-
 Note [Optimising tagToEnum#]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 If we have an enumeration data type:
@@ -1654,11 +1645,11 @@ is recursive, and hence a loop breaker:
 So it's up to the programmer: rules can cause divergence
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
                 Rebuilding a case expression
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Case elimination]
 ~~~~~~~~~~~~~~~~~~~~~~~
@@ -1754,7 +1745,7 @@ let-bound to (error "good").
 Nevertheless, the paper "A semantics for imprecise exceptions" allows
 this transformation. If you want to fix the evaluation order, use
 'pseq'.  See Trac #8900 for an example where the loss of this
-transformation bit us in practice. 
+transformation bit us in practice.
 
 See also Note [Empty case alternatives] in CoreSyn.
 
@@ -1828,8 +1819,8 @@ Why don't we drop the case?  Because it's strict in v.  It's technically
 wrong to drop even unnecessary evaluations, and in practice they
 may be a result of 'seq' so we *definitely* don't want to drop those.
 I don't really know how to improve this situation.
+-}
 
-\begin{code}
 ---------------------------------------------------------
 --      Eliminate the case if possible
 
@@ -1957,8 +1948,8 @@ reallyRebuildCase env scrut case_bndr alts cont
         -- (which in any case is only build in simplAlts)
         -- The case binder *not* scope over the whole returned case-expression
         ; rebuild env' case_expr nodup_cont }
-\end{code}
 
+{-
 simplCaseBinder checks whether the scrutinee is a variable, v.  If so,
 try to eliminate uses of v in the RHSs in favour of case_bndr; that
 way, there's a chance that v will now only be used once, and hence
@@ -2039,8 +2030,8 @@ taking advantage of the `seq`.
 At one point I did transformation in LiberateCase, but it's more
 robust here.  (Otherwise, there's a danger that we'll simply drop the
 'seq' altogether, before LiberateCase gets to see it.)
+-}
 
-\begin{code}
 simplAlts :: SimplEnv
           -> OutExpr
           -> InId                       -- Case binder
@@ -2183,8 +2174,8 @@ zapBndrOccInfo :: Bool -> Id -> Id
 zapBndrOccInfo keep_occ_info pat_id
   | keep_occ_info = pat_id
   | otherwise     = zapIdOccInfo pat_id
-\end{code}
 
+{-
 Note [Add unfolding for scrutinee]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In general it's unlikely that a variable scrutinee will appear
@@ -2220,11 +2211,11 @@ So instead we add the unfolding x -> Just a, and x -> Nothing in the
 respective RHSs.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{Known constructor}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 We are a bit careful with occurrence info.  Here's an example
 
@@ -2238,8 +2229,8 @@ and then
         f (h v)
 
 All this should happen in one sweep.
+-}
 
-\begin{code}
 knownCon :: SimplEnv
          -> OutExpr                             -- The scrutinee
          -> DataCon -> [OutType] -> [OutExpr]   -- The scrutinee (in pieces)
@@ -2304,16 +2295,15 @@ missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExp
 missingAlt env case_bndr _ cont
   = WARN( True, ptext (sLit "missingAlt") <+> ppr case_bndr )
     return (env, mkImpossibleExpr (contResultType cont))
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Duplicating continuations}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 prepareCaseCont :: SimplEnv
                 -> [InAlt] -> SimplCont
                 -> SimplM (SimplEnv,
@@ -2346,8 +2336,8 @@ prepareCaseCont env alts cont
       | otherwise      = not (all is_bot_alt alts)
 
     is_bot_alt (_,_,rhs) = exprIsBottom rhs
-\end{code}
 
+{-
 Note [Bottom alternatives]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 When we have
@@ -2358,8 +2348,8 @@ will disappear immediately.  This is more direct than creating
 join points and inlining them away; and in some cases we would
 not even create the join points (see Note [Single-alternative case])
 and we would keep the case-of-case which is silly.  See Trac #4930.
+-}
 
-\begin{code}
 mkDupableCont :: SimplEnv -> SimplCont
               -> SimplM (SimplEnv, SimplCont, SimplCont)
 
@@ -2512,8 +2502,8 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') = do
         ; env' <- addPolyBind NotTopLevel env (NonRec (join_bndr `setIdArity` join_arity) join_rhs)
         ; return (env', (con, bndrs', join_call)) }
                 -- See Note [Duplicated env]
-\end{code}
 
+{-
 Note [Fusing case continuations]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 It's important to fuse two successive case continuations when the
@@ -2846,3 +2836,4 @@ whether to use a real join point or just duplicate the continuation:
 
 Hence: check whether the case binder's type is unlifted, because then
 the outer case is *not* a seq.
+-}