Merge remote-tracking branch 'origin/master' into newcg

Conflicts:
	compiler/cmm/CmmLint.hs
	compiler/cmm/OldCmm.hs
	compiler/codeGen/CgMonad.lhs
	compiler/main/CodeOutput.lhs

1 files changed, 407 insertions, 381 deletions

diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs
index 6e164ce9ee..f907f85071 100644
--- a/compiler/codeGen/CgMonad.lhs
+++ b/compiler/codeGen/CgMonad.lhs
@@ -4,20 +4,19 @@
 %
 \section[CgMonad]{The code generation monad}
 
-See the beginning of the top-level @CodeGen@ module, to see how this
-monadic stuff fits into the Big Picture.
+See the beginning of the top-level @CodeGen@ module, to see how this monadic
+stuff fits into the Big Picture.
 
 \begin{code}
 
 {-# LANGUAGE BangPatterns #-}
 module CgMonad (
-        Code,
-        FCode,
+        Code, FCode,
 
         initC, runC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
         returnFC, fixC, fixC_, checkedAbsC, 
         stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC,
-        newUnique, newUniqSupply, 
+        newUnique, newUniqSupply,
 
         CgStmts, emitCgStmts, forkCgStmts, cgStmtsToBlocks,
         getCgStmts', getCgStmts,
@@ -35,7 +34,7 @@ module CgMonad (
         setEndOfBlockInfo, getEndOfBlockInfo,
 
         setSRT, getSRT,
-        setSRTLabel, getSRTLabel, 
+        setSRTLabel, getSRTLabel,
         setTickyCtrLabel, getTickyCtrLabel,
 
         StackUsage(..), HeapUsage(..),
@@ -48,10 +47,11 @@ module CgMonad (
 
         Sequel(..),
 
-        -- ideally we wouldn't export these, but some other modules access internal state
-        getState, setState, getInfoDown, getDynFlags, getThisPackage, 
+        -- ideally we wouldn't export these, but some other modules access
+        -- internal state
+        getState, setState, getInfoDown, getDynFlags, getThisPackage,
 
-        -- more localised access to monad state 
+        -- more localised access to monad state
         getStkUsage, setStkUsage,
         getBinds, setBinds, getStaticBinds,
 
@@ -92,82 +92,86 @@ infixr 9 `thenFC`
 %*                                                                      *
 %************************************************************************
 
-This monadery has some information that it only passes {\em
-downwards}, as well as some ``state'' which is modified as we go
-along.
+This monadery has some information that it only passes {\em downwards}, as well
+as some ``state'' which is modified as we go along.
 
 \begin{code}
-data CgInfoDownwards    -- information only passed *downwards* by the monad
+
+-- | State only passed *downwards* by the monad
+data CgInfoDownwards
   = MkCgInfoDown {
-        cgd_dflags  :: DynFlags,
-        cgd_mod     :: Module,          -- Module being compiled
-        cgd_statics :: CgBindings,      -- [Id -> info] : static environment
-        cgd_srt_lbl :: CLabel,          -- label of the current SRT
-        cgd_srt     :: SRT,             -- the current SRT
-        cgd_ticky   :: CLabel,          -- current destination for ticky counts
-        cgd_eob     :: EndOfBlockInfo   -- Info for stuff to do at end of basic block:
+        cgd_dflags  :: DynFlags,      -- current flag settings
+        cgd_mod     :: Module,        -- Module being compiled
+        cgd_statics :: CgBindings,    -- [Id -> info] : static environment
+        cgd_srt_lbl :: CLabel,        -- label of the current SRT
+        cgd_srt     :: SRT,           -- the current SRT
+        cgd_ticky   :: CLabel,        -- current destination for ticky counts
+        cgd_eob     :: EndOfBlockInfo -- Info for stuff to do at end of basic block:
   }
 
+-- | Setup initial @CgInfoDownwards@ for the code gen
 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
 initCgInfoDown dflags mod
-  = MkCgInfoDown {      cgd_dflags  = dflags,
-                        cgd_mod     = mod,
-                        cgd_statics = emptyVarEnv,
-                        cgd_srt_lbl = error "initC: srt_lbl",
-                        cgd_srt     = error "initC: srt",
-                        cgd_ticky   = mkTopTickyCtrLabel,
-                        cgd_eob     = initEobInfo }
+  = MkCgInfoDown { cgd_dflags  = dflags,
+                   cgd_mod     = mod,
+                   cgd_statics = emptyVarEnv,
+                   cgd_srt_lbl = error "initC: srt_lbl",
+                   cgd_srt     = error "initC: srt",
+                   cgd_ticky   = mkTopTickyCtrLabel,
+                   cgd_eob     = initEobInfo
+  }
 
+-- | State passed around and modified during code generation
 data CgState
   = MkCgState {
-     cgs_stmts :: OrdList CgStmt, -- Current proc
-     cgs_tops  :: OrdList CmmDecl,
-        -- Other procedures and data blocks in this compilation unit
-        -- Both the latter two are ordered only so that we can 
-        -- reduce forward references, when it's easy to do so
-     
-     cgs_binds :: CgBindings,     -- [Id -> info] : *local* bindings environment
-                                  -- Bindings for top-level things are given in
-                                  -- the info-down part
-     
+     cgs_stmts   :: OrdList CgStmt,
+         -- Current proc
+     cgs_tops    :: OrdList CmmDecl,
+         -- Other procedures and data blocks in this compilation unit
+         -- Both the latter two are ordered only so that we can
+         -- reduce forward references, when it's easy to do so
+
+     cgs_binds   :: CgBindings,
+         -- [Id -> info] : *local* bindings environment Bindings for
+         -- top-level things are given in the info-down part
+
      cgs_stk_usg :: StackUsage,
      cgs_hp_usg  :: HeapUsage,
-     
-     cgs_uniqs :: UniqSupply }
+     cgs_uniqs   :: UniqSupply
+  }
 
+-- | Setup initial @CgState@ for the code gen
 initCgState :: UniqSupply -> CgState
 initCgState uniqs
-  = MkCgState { cgs_stmts = nilOL, cgs_tops = nilOL,
-                cgs_binds = emptyVarEnv, 
-                cgs_stk_usg = initStkUsage, 
-                cgs_hp_usg = initHpUsage,
-                cgs_uniqs = uniqs }
-\end{code}
-
-@EndOfBlockInfo@ tells what to do at the end of this block of code or,
-if the expression is a @case@, what to do at the end of each
-alternative.
+  = MkCgState { cgs_stmts   = nilOL,
+                cgs_tops    = nilOL,
+                cgs_binds   = emptyVarEnv,
+                cgs_stk_usg = initStkUsage,
+                cgs_hp_usg  = initHpUsage,
+                cgs_uniqs   = uniqs
+  }
 
-\begin{code}
+-- | @EndOfBlockInfo@ tells what to do at the end of this block of code or, if
+-- the expression is a @case@, what to do at the end of each alternative.
 data EndOfBlockInfo
   = EndOfBlockInfo
-        VirtualSpOffset   -- Args Sp: trim the stack to this point at a
-                          -- return; push arguments starting just
-                          -- above this point on a tail call.
-                          
-                          -- This is therefore the stk ptr as seen
-                          -- by a case alternative.
+        VirtualSpOffset -- Args Sp: trim the stack to this point at a
+                        -- return; push arguments starting just
+                        -- above this point on a tail call.
+                        --
+                        -- This is therefore the stk ptr as seen
+                        -- by a case alternative.
         Sequel
 
+-- | Standard @EndOfBlockInfo@ where the continuation is on the stack
 initEobInfo :: EndOfBlockInfo
 initEobInfo = EndOfBlockInfo 0 OnStack
-\end{code}
 
-Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
-that it must survive stack pointer adjustments at the end of the
-block.
-
-\begin{code}
+-- | @Sequel@ is a representation of the next continuation to jump to
+-- after the current function.
+--
+-- Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
+-- that it must survive stack pointer adjustments at the end of the block.
 data Sequel
   = OnStack          -- Continuation is on the stack
 
@@ -178,9 +182,9 @@ data Sequel
           Id          -- The case binder, only used to see if it's dead
 
 type SemiTaggingStuff
-  = Maybe                   -- Maybe we don't have any semi-tagging stuff...
-     ([(ConTagZ, CmmLit)],  -- Alternatives
-      CmmLit)               -- Default (will be a can't happen RTS label if can't happen)
+  = Maybe                  -- Maybe we don't have any semi-tagging stuff...
+     ([(ConTagZ, CmmLit)], -- Alternatives
+      CmmLit)              -- Default (will be a can't happen RTS label if can't happen)
 
 -- The case branch is executed only from a successful semitagging
 -- venture, when a case has looked at a variable, found that it's
@@ -195,9 +199,9 @@ type SemiTaggingStuff
 %************************************************************************
 
 The CgStmts type is what the code generator outputs: it is a tree of
-statements, including in-line labels.  The job of flattenCgStmts is to
-turn this into a list of basic blocks, each of which ends in a jump
-statement (either a local branch or a non-local jump).
+statements, including in-line labels. The job of flattenCgStmts is to turn
+this into a list of basic blocks, each of which ends in a jump statement
+(either a local branch or a non-local jump).
 
 \begin{code}
 type CgStmts = OrdList CgStmt
@@ -208,7 +212,7 @@ data CgStmt
   | CgFork  BlockId CgStmts
 
 flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock]
-flattenCgStmts id stmts = 
+flattenCgStmts id stmts =
         case flatten (fromOL stmts) of
           ([],blocks)    -> blocks
           (block,blocks) -> BasicBlock id block : blocks
@@ -231,15 +235,15 @@ flattenCgStmts id stmts =
         [CgLabel id]           -> ( [stmt], [BasicBlock id [CmmBranch id]])
         (CgLabel id : stmts)   -> ( [stmt], BasicBlock id block : blocks )
             where (block,blocks) = flatten stmts
-        (CgFork fork_id stmts : ss) -> 
+        (CgFork fork_id stmts : ss) ->
            flatten (CgFork fork_id stmts : CgStmt stmt : ss)
         (CgStmt {} : _) -> panic "CgStmt not seen as ordinary"
 
-  flatten (s:ss) = 
+  flatten (s:ss) =
         case s of
           CgStmt stmt -> (stmt:block,blocks)
           CgLabel id  -> ([CmmBranch id],BasicBlock id block:blocks)
-          CgFork fork_id stmts -> 
+          CgFork fork_id stmts ->
                 (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
                 where (fork_block, fork_blocks) = flatten (fromOL stmts)
     where (block,blocks) = flatten ss
@@ -248,7 +252,7 @@ isJump :: CmmStmt -> Bool
 isJump (CmmJump   _ _) = True
 isJump (CmmBranch _  ) = True
 isJump (CmmSwitch _ _) = True
-isJump (CmmReturn _  ) = True
+isJump (CmmReturn    ) = True
 isJump _               = False
 
 isOrdinaryStmt :: CgStmt -> Bool
@@ -263,10 +267,15 @@ isOrdinaryStmt _          = False
 %************************************************************************
 
 \begin{code}
-type VirtualHpOffset = WordOff  -- Both are in
-type VirtualSpOffset = WordOff  -- units of words
+type VirtualHpOffset = WordOff -- Both are in
+type VirtualSpOffset = WordOff -- units of words
 
-data StackUsage 
+-- | Stack usage information during code generation.
+--
+-- INVARIANT: The environment contains no Stable references to
+--            stack slots below (lower offset) frameSp
+--            It can contain volatile references to this area though.
+data StackUsage
   = StackUsage {
         virtSp :: VirtualSpOffset,
                 -- Virtual offset of topmost allocated slot
@@ -277,83 +286,83 @@ data StackUsage
                 -- all the stack from frameSp downwards
                 -- INVARIANT: less than or equal to virtSp
 
-         freeStk :: [VirtualSpOffset], 
+         freeStk :: [VirtualSpOffset],
                 -- List of free slots, in *increasing* order
                 -- INVARIANT: all <= virtSp
-                -- All slots <= virtSp are taken except these ones
+                --            All slots <= virtSp are taken except these ones
 
-         realSp :: VirtualSpOffset,     
+         realSp :: VirtualSpOffset,
                 -- Virtual offset of real stack pointer register
 
          hwSp :: VirtualSpOffset
-  }                -- Highest value ever taken by virtSp
-
--- INVARIANT: The environment contains no Stable references to
---            stack slots below (lower offset) frameSp
---            It can contain volatile references to this area though.
-
-data HeapUsage =
-  HeapUsage {
-        virtHp :: VirtualHpOffset,      -- Virtual offset of highest-allocated word
-        realHp :: VirtualHpOffset       -- realHp: Virtual offset of real heap ptr
+  }             -- Highest value ever taken by virtSp
+
+-- | Heap usage information during code generation.
+--
+-- virtHp keeps track of the next location to allocate an object at. realHp
+-- keeps track of what the Hp STG register actually points to. The reason these
+-- aren't always the same is that we want to be able to move the realHp in one
+-- go when allocating numerous objects to save having to bump it each time.
+-- virtHp we do bump each time but it doesn't create corresponding inefficient
+-- machine code.
+data HeapUsage
+  = HeapUsage {
+        virtHp :: VirtualHpOffset, -- Virtual offset of highest allocated word
+        realHp :: VirtualHpOffset  -- Virtual offset of real heap ptr
   }
-\end{code}
-
-virtHp keeps track of the next location to allocate an object at. realHp keeps
-track of what the Hp STG register actually points to. The reason these aren't
-always the same is that we want to be able to move the realHp in one go when
-allocating numerous objects to save having to bump it each time. virtHp we do
-bump each time but it doesn't create corresponding inefficient machine code.
 
-\begin{code}
+-- | Return the heap usage high water mark
 heapHWM :: HeapUsage -> VirtualHpOffset
 heapHWM = virtHp
-\end{code}
 
-Initialisation.
 
-\begin{code}
+-- | Initial stack usage
 initStkUsage :: StackUsage
-initStkUsage = StackUsage {
-                        virtSp = 0,
-                        frameSp = 0,
-                        freeStk = [],
-                        realSp = 0,
-                        hwSp = 0
-               }
-                
-initHpUsage :: HeapUsage 
-initHpUsage = HeapUsage {
-                virtHp = 0,
-                realHp = 0
-              }
+initStkUsage
+  = StackUsage {
+        virtSp  = 0,
+        frameSp = 0,
+        freeStk = [],
+        realSp  = 0,
+        hwSp    = 0
+  }
+
+-- | Initial heap usage
+initHpUsage :: HeapUsage
+initHpUsage
+  = HeapUsage {
+        virtHp = 0,
+        realHp = 0
+  }
 
 -- | @stateIncUsafe@ sets the stack and heap high water marks of $arg1$ to
 -- be the max of the high water marks of $arg1$ and $arg2$.
 stateIncUsage :: CgState -> CgState -> CgState
 stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
-     = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg,
-            cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp   stk_usg }
-       `addCodeBlocksFrom` s2
-                
+  = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg,
+         cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp   stk_usg }
+    `addCodeBlocksFrom` s2
+
+-- | Similar to @stateIncUsafe@ but we don't max the heap high-watermark
+-- because @stateIncUsageEval@ is used only in forkEval, which in turn is only
+-- used for blocks of code which do their own heap-check.
 stateIncUsageEval :: CgState -> CgState -> CgState
 stateIncUsageEval s1 s2
-     = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
-       `addCodeBlocksFrom` s2
-        -- We don't max the heap high-watermark because stateIncUsageEval is
-        -- used only in forkEval, which in turn is only used for blocks of code
-        -- which do their own heap-check.
+  = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
+    `addCodeBlocksFrom` s2
 
+-- | Add code blocks from the latter to the former
+-- (The cgs_stmts will often be empty, but not always; see @codeOnly@)
 addCodeBlocksFrom :: CgState -> CgState -> CgState
--- Add code blocks from the latter to the former
--- (The cgs_stmts will often be empty, but not always; see codeOnly)
 s1 `addCodeBlocksFrom` s2
   = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
          cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }
 
+-- | Set @HeapUsage@ virtHp to max of current or $arg2$.
 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
 
+-- | Set @StackUsage@ hwSp to max of current or $arg2$.
 maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
 stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
 \end{code}
@@ -369,15 +378,14 @@ newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
 type Code       = FCode ()
 
 instance Monad FCode where
-        (>>=) = thenFC
+        (>>=)  = thenFC
         return = returnFC
 
 {-# INLINE thenC #-}
 {-# INLINE thenFC #-}
 {-# INLINE returnFC #-}
-\end{code}
-The Abstract~C is not in the environment so as to improve strictness.
 
+<<<<<<< HEAD
 \begin{code}
 initC :: IO CgState
 initC  = do { uniqs <- mkSplitUniqSupply 'c'
@@ -385,35 +393,43 @@ initC  = do { uniqs <- mkSplitUniqSupply 'c'
 
 runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)
 runC dflags mod st (FCode code) = code (initCgInfoDown dflags mod) st
+||||||| merged common ancestors
+\begin{code}
+initC :: DynFlags -> Module -> FCode a -> IO a
+
+initC dflags mod (FCode code)
+  = do  { uniqs <- mkSplitUniqSupply 'c'
+        ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
+              (res, _) -> return res
+        }
+=======
+initC :: DynFlags -> Module -> FCode a -> IO a
+initC dflags mod (FCode code) = do
+    uniqs <- mkSplitUniqSupply 'c'
+    case code (initCgInfoDown dflags mod) (initCgState uniqs) of
+        (res, _) -> return res
+>>>>>>> origin/master
 
 returnFC :: a -> FCode a
-returnFC val = FCode (\_ state -> (val, state))
-\end{code}
+returnFC val = FCode $ \_ state -> (val, state)
 
-\begin{code}
 thenC :: Code -> FCode a -> FCode a
-thenC (FCode m) (FCode k) = 
-        FCode (\info_down state -> let (_,new_state) = m info_down state in 
-                k info_down new_state)
+thenC (FCode m) (FCode k) = FCode $ \info_down state ->
+    let (_,new_state) = m info_down state
+    in k info_down new_state
 
 listCs :: [Code] -> Code
-listCs [] = return ()
-listCs (fc:fcs) = do
-        fc
-        listCs fcs
-        
+listCs []       = return ()
+listCs (fc:fcs) = fc >> listCs fcs
+
 mapCs :: (a -> Code) -> [a] -> Code
 mapCs = mapM_
 
 thenFC  :: FCode a -> (a -> FCode c) -> FCode c
-thenFC (FCode m) k = FCode (
-        \info_down state ->
-                let 
-                        (m_result, new_state) = m info_down state
-                        (FCode kcode) = k m_result
-                in 
-                        kcode info_down new_state
-        )
+thenFC (FCode m) k = FCode $ \info_down state ->
+    let (m_result, new_state) = m info_down state
+        (FCode kcode)         = k m_result
+    in kcode info_down new_state
 
 listFCs :: [FCode a] -> FCode [a]
 listFCs = sequence
@@ -423,11 +439,10 @@ mapFCs = mapM
 
 -- | Knot-tying combinator for @FCode@
 fixC :: (a -> FCode a) -> FCode a
-fixC fcode = FCode $
-        \info_down state -> 
-                let FCode fc     = fcode v
-                    result@(v,_) = fc info_down state
-                in result
+fixC fcode = FCode $ \info_down state ->
+    let FCode fc     = fcode v
+        result@(v,_) = fc info_down state
+    in result
 
 -- | Knot-tying combinator that throws result away
 fixC_ :: (a -> FCode a) -> FCode ()
@@ -442,241 +457,225 @@ fixC_ fcode = fixC fcode >> return ()
 
 \begin{code}
 getState :: FCode CgState
-getState = FCode $ \_ state -> (state,state)
+getState = FCode $ \_ state -> (state, state)
 
 setState :: CgState -> FCode ()
-setState state = FCode $ \_ _ -> ((),state)
+setState state = FCode $ \_ _ -> ((), state)
 
 getStkUsage :: FCode StackUsage
 getStkUsage = do
-        state <- getState
-        return $ cgs_stk_usg state
+    state <- getState
+    return $ cgs_stk_usg state
 
 setStkUsage :: StackUsage -> Code
 setStkUsage new_stk_usg = do
-        state <- getState
-        setState $ state {cgs_stk_usg = new_stk_usg}
+    state <- getState
+    setState $ state {cgs_stk_usg = new_stk_usg}
 
 getHpUsage :: FCode HeapUsage
 getHpUsage = do
-        state <- getState
-        return $ cgs_hp_usg state
-        
+    state <- getState
+    return $ cgs_hp_usg state
+
 setHpUsage :: HeapUsage -> Code
 setHpUsage new_hp_usg = do
-        state <- getState
-        setState $ state {cgs_hp_usg = new_hp_usg}
+    state <- getState
+    setState $ state {cgs_hp_usg = new_hp_usg}
 
 getBinds :: FCode CgBindings
 getBinds = do
-        state <- getState
-        return $ cgs_binds state
-        
+    state <- getState
+    return $ cgs_binds state
+
 setBinds :: CgBindings -> FCode ()
 setBinds new_binds = do
-        state <- getState
-        setState $ state {cgs_binds = new_binds}
+    state <- getState
+    setState $ state {cgs_binds = new_binds}
 
 getStaticBinds :: FCode CgBindings
 getStaticBinds = do
-        info  <- getInfoDown
-        return (cgd_statics info)
+    info  <- getInfoDown
+    return (cgd_statics info)
 
 withState :: FCode a -> CgState -> FCode (a,CgState)
-withState (FCode fcode) newstate = FCode $ \info_down state -> 
-        let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
+withState (FCode fcode) newstate = FCode $ \info_down state ->
+    let (retval, state2) = fcode info_down newstate
+    in ((retval, state2), state)
 
 newUniqSupply :: FCode UniqSupply
 newUniqSupply = do
-        state <- getState
-        let (us1, us2) = splitUniqSupply (cgs_uniqs state)
-        setState $ state { cgs_uniqs = us1 }
-        return us2
+    state <- getState
+    let (us1, us2) = splitUniqSupply (cgs_uniqs state)
+    setState $ state { cgs_uniqs = us1 }
+    return us2
 
 newUnique :: FCode Unique
 newUnique = do
-        us <- newUniqSupply
-        return (uniqFromSupply us)
+    us <- newUniqSupply
+    return (uniqFromSupply us)
 
 getInfoDown :: FCode CgInfoDownwards
-getInfoDown = FCode $ \info_down state -> (info_down,state)
+getInfoDown = FCode $ \info_down state -> (info_down, state)
 
-getDynFlags :: FCode DynFlags
-getDynFlags = liftM cgd_dflags getInfoDown
+instance HasDynFlags FCode where
+    getDynFlags = liftM cgd_dflags getInfoDown
 
 getThisPackage :: FCode PackageId
 getThisPackage = liftM thisPackage getDynFlags
 
 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
-withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state 
+withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
 
 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
 doFCode (FCode fcode) info_down state = fcode info_down state
 \end{code}
 
-
 %************************************************************************
 %*                                                                      *
                 Forking
 %*                                                                      *
 %************************************************************************
 
-@forkClosureBody@ takes a code, $c$, and compiles it in a completely
-fresh environment, except that:
-        - compilation info and statics are passed in unchanged.
-The current environment is passed on completely unaltered, except that
-abstract C from the fork is incorporated.
-
-@forkProc@ takes a code and compiles it in the current environment,
-returning the basic blocks thus constructed.  The current environment
-is passed on completely unchanged.  It is pretty similar to
-@getBlocks@, except that the latter does affect the environment.
-
-@forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
-from the current bindings, but which is otherwise freshly initialised.
-The Abstract~C returned is attached to the current state, but the
-bindings and usage information is otherwise unchanged.
-
 \begin{code}
+
+-- | Takes code and compiles it in a completely fresh environment, except that
+-- compilation info and statics are passed in unchanged. The current
+-- environment is passed on completely unaltered, except that the Cmm code
+-- from the fork is incorporated.
 forkClosureBody :: Code -> Code
-forkClosureBody body_code
-  = do  { info <- getInfoDown
-        ; us   <- newUniqSupply
-        ; state <- getState
-        ; let   body_info_down = info { cgd_eob = initEobInfo }
-                ((),fork_state) = doFCode body_code body_info_down 
-                                          (initCgState us)
-        ; ASSERT( isNilOL (cgs_stmts fork_state) )
-          setState $ state `addCodeBlocksFrom` fork_state }
-        
+forkClosureBody body_code = do
+    info  <- getInfoDown
+    us    <- newUniqSupply
+    state <- getState
+    let body_info_down   = info { cgd_eob = initEobInfo }
+        ((), fork_state) = doFCode body_code body_info_down (initCgState us)
+
+    ASSERT( isNilOL (cgs_stmts fork_state) )
+      setState $ state `addCodeBlocksFrom` fork_state
+
+-- | @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
+-- from the current bindings, but which is otherwise freshly initialised.
+-- The Cmm returned is attached to the current state, but the bindings and
+-- usage information is otherwise unchanged.
 forkStatics :: FCode a -> FCode a
-forkStatics body_code
-  = do  { info  <- getInfoDown
-        ; us    <- newUniqSupply
-        ; state <- getState
-        ; let   rhs_info_down = info { cgd_statics = cgs_binds state,
-                                       cgd_eob     = initEobInfo }
-                (result, fork_state_out) = doFCode body_code rhs_info_down 
-                                                   (initCgState us)
-        ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
-          setState (state `addCodeBlocksFrom` fork_state_out)
-        ; return result }
-
+forkStatics body_code = do
+    info  <- getInfoDown
+    us    <- newUniqSupply
+    state <- getState
+    let rhs_info_down = info { cgd_statics = cgs_binds state,
+                               cgd_eob     = initEobInfo }
+        (result, fork_state_out) = doFCode body_code rhs_info_down (initCgState us)
+
+    ASSERT( isNilOL (cgs_stmts fork_state_out) )
+      setState (state `addCodeBlocksFrom` fork_state_out)
+    return result
+
+-- | @forkProc@ takes a code and compiles it in the current environment,
+-- returning the basic blocks thus constructed. The current environment is
+-- passed on completely unchanged. It is pretty similar to @getBlocks@, except
+-- that the latter does affect the environment.
 forkProc :: Code -> FCode CgStmts
-forkProc body_code
-  = do  { info_down <- getInfoDown
-        ; us    <- newUniqSupply
-        ; state <- getState
-        ; let   fork_state_in = (initCgState us) 
-                                        { cgs_binds   = cgs_binds state,
-                                          cgs_stk_usg = cgs_stk_usg state,
-                                          cgs_hp_usg  = cgs_hp_usg state }
-                        -- ToDo: is the hp usage necesary?
-                (code_blks, fork_state_out) = doFCode (getCgStmts body_code) 
-                                                      info_down fork_state_in
-        ; setState $ state `stateIncUsageEval` fork_state_out
-        ; return code_blks }
+forkProc body_code = do
+    info  <- getInfoDown
+    us    <- newUniqSupply
+    state <- getState
+    let fork_state_in = (initCgState us)
+                            { cgs_binds   = cgs_binds state,
+                              cgs_stk_usg = cgs_stk_usg state,
+                              cgs_hp_usg  = cgs_hp_usg state }
+        (code_blks, fork_state_out) = doFCode (getCgStmts body_code)
+                                              info fork_state_in
+    setState $ state `stateIncUsageEval` fork_state_out
+    return code_blks
 
 -- Emit any code from the inner thing into the outer thing
 -- Do not affect anything else in the outer state
 -- Used in almost-circular code to prevent false loop dependencies
 codeOnly :: Code -> Code
-codeOnly body_code
-  = do  { info_down <- getInfoDown
-        ; us   <- newUniqSupply
-        ; state <- getState
-        ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state,
-                                                   cgs_stk_usg = cgs_stk_usg state,
-                                                   cgs_hp_usg  = cgs_hp_usg state }
-                ((), fork_state_out) = doFCode body_code info_down fork_state_in
-        ; setState $ state `addCodeBlocksFrom` fork_state_out }
-\end{code}
-
-@forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
-an fcode for the default case $d$, and compiles each in the current
-environment.  The current environment is passed on unmodified, except
-that
-        - the worst stack high-water mark is incorporated
-        - the virtual Hp is moved on to the worst virtual Hp for the branches
-
-\begin{code}
+codeOnly body_code = do
+    info  <- getInfoDown
+    us    <- newUniqSupply
+    state <- getState
+    let fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state,
+                                           cgs_stk_usg = cgs_stk_usg state,
+                                           cgs_hp_usg  = cgs_hp_usg state }
+        ((), fork_state_out) = doFCode body_code info fork_state_in
+    setState $ state `addCodeBlocksFrom` fork_state_out
+
+-- | @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and an
+-- an fcode for the default case $d$, and compiles each in the current
+-- environment. The current environment is passed on unmodified, except that:
+--     * the worst stack high-water mark is incorporated
+--     * the virtual Hp is moved on to the worst virtual Hp for the branches
 forkAlts :: [FCode a] -> FCode [a]
-
-forkAlts branch_fcodes
-  = do  { info_down <- getInfoDown
-        ; us <- newUniqSupply
-        ; state <- getState
-        ; let compile us branch 
-                = (us2, doFCode branch info_down branch_state)
-                where
-                  (us1,us2) = splitUniqSupply us
-                  branch_state = (initCgState us1) {
-                                        cgs_binds   = cgs_binds state,
-                                        cgs_stk_usg = cgs_stk_usg state,
-                                        cgs_hp_usg  = cgs_hp_usg state }
-
-              (_us, results) = mapAccumL compile us branch_fcodes
-              (branch_results, branch_out_states) = unzip results
-        ; setState $ foldl stateIncUsage state branch_out_states
-                -- NB foldl.  state is the *left* argument to stateIncUsage
-        ; return branch_results }
-\end{code}
-
-@forkEval@ takes two blocks of code.
-
-   -  The first meddles with the environment to set it up as expected by
-      the alternatives of a @case@ which does an eval (or gc-possible primop).
-   -  The second block is the code for the alternatives.
-      (plus info for semi-tagging purposes)
-
-@forkEval@ picks up the virtual stack pointer and returns a suitable
-@EndOfBlockInfo@ for the caller to use, together with whatever value
-is returned by the second block.
-
-It uses @initEnvForAlternatives@ to initialise the environment, and
-@stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
-usage.
-
-\begin{code}
-forkEval :: EndOfBlockInfo              -- For the body
-         -> Code                        -- Code to set environment
-         -> FCode Sequel                -- Semi-tagging info to store
-         -> FCode EndOfBlockInfo        -- The new end of block info
-
-forkEval body_eob_info env_code body_code
-  = do  { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
-        ; returnFC (EndOfBlockInfo v sequel) }
-
+forkAlts branch_fcodes = do 
+    info  <- getInfoDown
+    us    <- newUniqSupply
+    state <- getState
+    let compile us branch = (us2, doFCode branch info branch_state)
+            where
+                (us1,us2)    = splitUniqSupply us
+                branch_state = (initCgState us1) {
+                                   cgs_binds   = cgs_binds state,
+                                   cgs_stk_usg = cgs_stk_usg state,
+                                   cgs_hp_usg  = cgs_hp_usg state }
+        (_us, results) = mapAccumL compile us branch_fcodes
+        (branch_results, branch_out_states) = unzip results
+    -- NB foldl. state is the *left* argument to stateIncUsage
+    setState $ foldl stateIncUsage state branch_out_states
+    return branch_results
+
+-- | @forkEval@ takes two blocks of code.
+-- 
+--   *  The first meddles with the environment to set it up as expected by
+--      the alternatives of a @case@ which does an eval (or gc-possible primop).
+--   *  The second block is the code for the alternatives.
+--      (plus info for semi-tagging purposes)
+--
+-- @forkEval@ picks up the virtual stack pointer and returns a suitable
+-- @EndOfBlockInfo@ for the caller to use, together with whatever value
+-- is returned by the second block.
+-- 
+-- It uses @initEnvForAlternatives@ to initialise the environment, and
+-- @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap usage.
+forkEval :: EndOfBlockInfo       -- For the body
+         -> Code                 -- Code to set environment
+         -> FCode Sequel         -- Semi-tagging info to store
+         -> FCode EndOfBlockInfo -- The new end of block info
+forkEval body_eob_info env_code body_code = do
+    (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
+    returnFC (EndOfBlockInfo v sequel)
+
+-- A disturbingly complicated function
 forkEvalHelp :: EndOfBlockInfo  -- For the body
              -> Code            -- Code to set environment
              -> FCode a         -- The code to do after the eval
              -> FCode (VirtualSpOffset, -- Sp
                        a)               -- Result of the FCode
-        -- A disturbingly complicated function
-forkEvalHelp body_eob_info env_code body_code
-  = do  { info_down <- getInfoDown
-        ; us   <- newUniqSupply
-        ; state <- getState
-        ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
-              ; (_, env_state) = doFCode env_code info_down_for_body 
-                                         (state {cgs_uniqs = us})
-              ; state_for_body = (initCgState (cgs_uniqs env_state)) 
-                                        { cgs_binds   = binds_for_body,
-                                          cgs_stk_usg = stk_usg_for_body }
-              ; binds_for_body   = nukeVolatileBinds (cgs_binds env_state)
-              ; stk_usg_from_env = cgs_stk_usg env_state
-              ; virtSp_from_env  = virtSp stk_usg_from_env
-              ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
-                                                     hwSp   = virtSp_from_env}
-              ; (value_returned, state_at_end_return)
-                        = doFCode body_code info_down_for_body state_for_body           
-          } 
-        ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
-                 -- The code coming back should consist only of nested declarations,
-                 -- notably of the return vector!
-          setState $ state `stateIncUsageEval` state_at_end_return
-        ; return (virtSp_from_env, value_returned) }
-
+forkEvalHelp body_eob_info env_code body_code = do
+    info  <- getInfoDown
+    us    <- newUniqSupply
+    state <- getState
+
+    let info_body      = info { cgd_eob = body_eob_info }
+        (_, env_state) = doFCode env_code info_body
+                                 (state {cgs_uniqs = us})
+        state_for_body = (initCgState (cgs_uniqs env_state))
+                            { cgs_binds   = binds_for_body,
+                              cgs_stk_usg = stk_usg_for_body }
+        binds_for_body   = nukeVolatileBinds (cgs_binds env_state)
+        stk_usg_from_env = cgs_stk_usg env_state
+        virtSp_from_env  = virtSp stk_usg_from_env
+        stk_usg_for_body = stk_usg_from_env { realSp = virtSp_from_env,
+                                              hwSp   = virtSp_from_env }
+        (value_returned, state_at_end_return)
+            = doFCode body_code info_body state_for_body
+
+    -- The code coming back should consist only of nested declarations,
+    -- notably of the return vector!
+    ASSERT( isNilOL (cgs_stmts state_at_end_return) )
+      setState $ state `stateIncUsageEval` state_at_end_return
+    return (virtSp_from_env, value_returned)
 
 -- ----------------------------------------------------------------------------
 -- Combinators for emitting code
@@ -697,20 +696,20 @@ labelC :: BlockId -> Code
 labelC id = emitCgStmt (CgLabel id)
 
 newLabelC :: FCode BlockId
-newLabelC = do { u <- newUnique
-               ; return $ mkBlockId u }
+newLabelC = do
+    u <- newUnique
+    return $ mkBlockId u
 
 -- Emit code, eliminating no-ops
 checkedAbsC :: CmmStmt -> Code
-checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
-                              else unitOL stmt)
+checkedAbsC stmt = emitStmts $ if isNopStmt stmt then nilOL else unitOL stmt
 
 stmtsC :: [CmmStmt] -> Code
-stmtsC stmts = emitStmts (toOL stmts)
+stmtsC stmts = emitStmts $ toOL stmts
 
 -- Emit code; no no-op checking
 emitStmts :: CmmStmts -> Code
-emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
+emitStmts stmts = emitCgStmts $ fmap CgStmt stmts
 
 -- forkLabelledCode is for emitting a chunk of code with a label, outside
 -- of the current instruction stream.
@@ -718,40 +717,64 @@ forkLabelledCode :: Code -> FCode BlockId
 forkLabelledCode code = getCgStmts code >>= forkCgStmts
 
 emitCgStmt :: CgStmt -> Code
-emitCgStmt stmt
-  = do  { state <- getState
-        ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
-        }
+emitCgStmt stmt = do
+    state <- getState
+    setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
 
 emitDecl :: CmmDecl -> Code
-emitDecl decl
-  = do  { state <- getState
-        ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
+emitDecl decl = do
+    state <- getState
+    setState $ state { cgs_tops = cgs_tops state `snocOL` decl }
 
+<<<<<<< HEAD
 emitProc :: CmmInfoTable -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
 emitProc info lbl [] blocks
   = do  { let proc_block = CmmProc info lbl (ListGraph blocks)
         ; state <- getState
         ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
+||||||| merged common ancestors
+emitProc :: CmmInfo -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
+emitProc info lbl [] blocks
+  = do  { let proc_block = CmmProc info lbl (ListGraph blocks)
+        ; state <- getState
+        ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
+=======
+emitProc :: CmmInfo -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
+emitProc info lbl [] blocks = do
+    let proc_block = CmmProc info lbl (ListGraph blocks)
+    state <- getState
+    setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block }
+>>>>>>> origin/master
 emitProc _ _ (_:_) _ = panic "emitProc called with nonempty args"
 
 -- Emit a procedure whose body is the specified code; no info table
 emitSimpleProc :: CLabel -> Code -> Code
+<<<<<<< HEAD
 emitSimpleProc lbl code
   = do  { stmts <- getCgStmts code
         ; blks <- cgStmtsToBlocks stmts
         ; emitProc CmmNonInfoTable lbl [] blks }
+||||||| merged common ancestors
+emitSimpleProc lbl code
+  = do  { stmts <- getCgStmts code
+        ; blks <- cgStmtsToBlocks stmts
+        ; emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks }
+=======
+emitSimpleProc lbl code = do
+    stmts <- getCgStmts code
+    blks <- cgStmtsToBlocks stmts
+    emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks
+>>>>>>> origin/master
 
 -- Get all the CmmTops (there should be no stmts)
 -- Return a single Cmm which may be split from other Cmms by
 -- object splitting (at a later stage)
 getCmm :: Code -> FCode CmmGroup
-getCmm code 
-  = do  { state1 <- getState
-        ; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })
-        ; setState $ state2 { cgs_tops = cgs_tops state1 } 
-        ; return (fromOL (cgs_tops state2))
-        }
+getCmm code = do
+    state1 <- getState
+    ((), state2) <- withState code (state1 { cgs_tops  = nilOL })
+    setState $ state2 { cgs_tops = cgs_tops state1 }
+    return (fromOL (cgs_tops state2))
 
 -- ----------------------------------------------------------------------------
 -- CgStmts
@@ -759,38 +782,37 @@ getCmm code
 -- These functions deal in terms of CgStmts, which is an abstract type
 -- representing the code in the current proc.
 
-
 -- emit CgStmts into the current instruction stream
 emitCgStmts :: CgStmts -> Code
-emitCgStmts stmts
-  = do  { state <- getState
-        ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
+emitCgStmts stmts = do
+    state <- getState
+    setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts }
 
 -- emit CgStmts outside the current instruction stream, and return a label
 forkCgStmts :: CgStmts -> FCode BlockId
-forkCgStmts stmts
-  = do  { id <- newLabelC
-        ; emitCgStmt (CgFork id stmts)
-        ; return id
-        }
+forkCgStmts stmts = do
+    id <- newLabelC
+    emitCgStmt (CgFork id stmts)
+    return id
 
 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
 cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
-cgStmtsToBlocks stmts
-  = do  { id <- newLabelC
-        ; return (flattenCgStmts id stmts)
-        }       
+cgStmtsToBlocks stmts = do
+    id <- newLabelC
+    return (flattenCgStmts id stmts)
 
 -- collect the code emitted by an FCode computation
 getCgStmts' :: FCode a -> FCode (a, CgStmts)
-getCgStmts' fcode
-  = do  { state1 <- getState
-        ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
-        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }
-        ; return (a, cgs_stmts state2) }
+getCgStmts' fcode = do
+    state1 <- getState
+    (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
+    setState $ state2 { cgs_stmts = cgs_stmts state1  }
+    return (a, cgs_stmts state2)
 
 getCgStmts :: FCode a -> FCode CgStmts
-getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
+getCgStmts fcode = do
+    (_,stmts) <- getCgStmts' fcode
+    return stmts
 
 -- Simple ways to construct CgStmts:
 noCgStmts :: CgStmts
@@ -806,56 +828,60 @@ consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
 -- Get the current module name
 
 getModuleName :: FCode Module
-getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
+getModuleName = do
+    info <- getInfoDown
+    return (cgd_mod info)
 
 -- ----------------------------------------------------------------------------
 -- Get/set the end-of-block info
 
 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
 setEndOfBlockInfo eob_info code = do
-        info  <- getInfoDown
-        withInfoDown code (info {cgd_eob = eob_info})
+    info  <- getInfoDown
+    withInfoDown code (info {cgd_eob = eob_info})
 
 getEndOfBlockInfo :: FCode EndOfBlockInfo
 getEndOfBlockInfo = do
-        info <- getInfoDown
-        return (cgd_eob info)
+    info <- getInfoDown
+    return (cgd_eob info)
 
 -- ----------------------------------------------------------------------------
 -- Get/set the current SRT label
 
 -- There is just one SRT for each top level binding; all the nested
--- bindings use sub-sections of this SRT.  The label is passed down to
+-- bindings use sub-sections of this SRT. The label is passed down to
 -- the nested bindings via the monad.
 
 getSRTLabel :: FCode CLabel     -- Used only by cgPanic
-getSRTLabel = do info  <- getInfoDown
-                 return (cgd_srt_lbl info)
+getSRTLabel = do
+    info  <- getInfoDown
+    return (cgd_srt_lbl info)
 
 setSRTLabel :: CLabel -> FCode a -> FCode a
-setSRTLabel srt_lbl code
-  = do  info <- getInfoDown
-        withInfoDown code (info { cgd_srt_lbl = srt_lbl})
+setSRTLabel srt_lbl code = do
+    info <- getInfoDown
+    withInfoDown code (info { cgd_srt_lbl = srt_lbl})
 
 getSRT :: FCode SRT
-getSRT = do info <- getInfoDown
-            return (cgd_srt info)
+getSRT = do
+    info <- getInfoDown
+    return (cgd_srt info)
 
 setSRT :: SRT -> FCode a -> FCode a
-setSRT srt code
-  = do info <- getInfoDown
-       withInfoDown code (info { cgd_srt = srt})
+setSRT srt code = do
+    info <- getInfoDown
+    withInfoDown code (info { cgd_srt = srt})
 
 -- ----------------------------------------------------------------------------
 -- Get/set the current ticky counter label
 
 getTickyCtrLabel :: FCode CLabel
 getTickyCtrLabel = do
-        info <- getInfoDown
-        return (cgd_ticky info)
+    info <- getInfoDown
+    return (cgd_ticky info)
 
 setTickyCtrLabel :: CLabel -> Code -> Code
 setTickyCtrLabel ticky code = do
-        info <- getInfoDown
-        withInfoDown code (info {cgd_ticky = ticky})
+    info <- getInfoDown
+    withInfoDown code (info {cgd_ticky = ticky})
 \end{code}