Merge in new code generator branch.
authorSimon Marlow <marlowsd@gmail.com>
Mon, 24 Jan 2011 12:16:50 +0000 (12:16 +0000)
committerSimon Marlow <marlowsd@gmail.com>
Mon, 24 Jan 2011 12:16:50 +0000 (12:16 +0000)
This changes the new code generator to make use of the Hoopl package
for dataflow analysis.  Hoopl is a new boot package, and is maintained
in a separate upstream git repository (as usual, GHC has its own
lagging darcs mirror in http://darcs.haskell.org/packages/hoopl).

During this merge I squashed recent history into one patch.  I tried
to rebase, but the history had some internal conflicts of its own
which made rebase extremely confusing, so I gave up. The history I
squashed was:

  - Update new codegen to work with latest Hoopl
  - Add some notes on new code gen to cmm-notes
  - Enable Hoopl lag package.
  - Add SPJ note to cmm-notes
  - Improve GC calls on new code generator.

Work in this branch was done by:
   - Milan Straka <fox@ucw.cz>
   - John Dias <dias@cs.tufts.edu>
   - David Terei <davidterei@gmail.com>

Edward Z. Yang <ezyang@mit.edu> merged in further changes from GHC HEAD
and fixed a few bugs.

141 files changed:
compiler/cmm/BlockId.hs
compiler/cmm/Cmm.hs
compiler/cmm/CmmBrokenBlock.hs [deleted file]
compiler/cmm/CmmBuildInfoTables.hs
compiler/cmm/CmmCPS.hs
compiler/cmm/CmmCPSGen.hs [deleted file]
compiler/cmm/CmmCPSZ.hs [deleted file]
compiler/cmm/CmmCallConv.hs
compiler/cmm/CmmCommonBlockElim.hs [moved from compiler/cmm/CmmCommonBlockElimZ.hs with 57% similarity]
compiler/cmm/CmmContFlowOpt.hs
compiler/cmm/CmmCvt.hs
compiler/cmm/CmmDecl.hs [new file with mode: 0644]
compiler/cmm/CmmExpr.hs
compiler/cmm/CmmInfo.hs
compiler/cmm/CmmLex.x
compiler/cmm/CmmLint.hs
compiler/cmm/CmmLive.hs
compiler/cmm/CmmLiveZ.hs [deleted file]
compiler/cmm/CmmMachOp.hs [new file with mode: 0644]
compiler/cmm/CmmNode.hs [new file with mode: 0644]
compiler/cmm/CmmOpt.hs
compiler/cmm/CmmParse.y
compiler/cmm/CmmProcPoint.hs
compiler/cmm/CmmProcPointZ.hs [deleted file]
compiler/cmm/CmmSpillReload.hs
compiler/cmm/CmmStackLayout.hs
compiler/cmm/CmmTx.hs [deleted file]
compiler/cmm/CmmType.hs [new file with mode: 0644]
compiler/cmm/CmmUtils.hs
compiler/cmm/CmmZipUtil.hs [deleted file]
compiler/cmm/DFMonad.hs [deleted file]
compiler/cmm/Dataflow.hs [deleted file]
compiler/cmm/MkGraph.hs [new file with mode: 0644]
compiler/cmm/MkZipCfg.hs [deleted file]
compiler/cmm/MkZipCfgCmm.hs [deleted file]
compiler/cmm/OldCmm.hs [new file with mode: 0644]
compiler/cmm/OldCmmUtils.hs [new file with mode: 0644]
compiler/cmm/OldPprCmm.hs [new file with mode: 0644]
compiler/cmm/OptimizationFuel.hs
compiler/cmm/PprC.hs
compiler/cmm/PprCmm.hs
compiler/cmm/PprCmmDecl.hs [new file with mode: 0644]
compiler/cmm/PprCmmExpr.hs [new file with mode: 0644]
compiler/cmm/PprCmmZ.hs [deleted file]
compiler/cmm/README [deleted file]
compiler/cmm/StackColor.hs [deleted file]
compiler/cmm/StackPlacements.hs [deleted file]
compiler/cmm/ZipCfg.hs [deleted file]
compiler/cmm/ZipCfgCmmRep.hs [deleted file]
compiler/cmm/ZipCfgExtras.hs [deleted file]
compiler/cmm/ZipDataflow.hs [deleted file]
compiler/cmm/cmm-notes
compiler/codeGen/CgBindery.lhs
compiler/codeGen/CgCallConv.hs
compiler/codeGen/CgCase.lhs
compiler/codeGen/CgClosure.lhs
compiler/codeGen/CgCon.lhs
compiler/codeGen/CgExpr.lhs
compiler/codeGen/CgExtCode.hs
compiler/codeGen/CgForeignCall.hs
compiler/codeGen/CgHeapery.lhs
compiler/codeGen/CgHpc.hs
compiler/codeGen/CgInfoTbls.hs
compiler/codeGen/CgLetNoEscape.lhs
compiler/codeGen/CgMonad.lhs
compiler/codeGen/CgParallel.hs
compiler/codeGen/CgPrimOp.hs
compiler/codeGen/CgProf.hs
compiler/codeGen/CgStackery.lhs
compiler/codeGen/CgTailCall.lhs
compiler/codeGen/CgTicky.hs
compiler/codeGen/CgUtils.hs
compiler/codeGen/CodeGen.lhs
compiler/codeGen/SMRep.lhs
compiler/codeGen/StgCmm.hs
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmClosure.hs
compiler/codeGen/StgCmmCon.hs
compiler/codeGen/StgCmmEnv.hs
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmForeign.hs
compiler/codeGen/StgCmmGran.hs
compiler/codeGen/StgCmmHeap.hs
compiler/codeGen/StgCmmHpc.hs
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmMonad.hs
compiler/codeGen/StgCmmPrim.hs
compiler/codeGen/StgCmmProf.hs
compiler/codeGen/StgCmmTicky.hs
compiler/codeGen/StgCmmUtils.hs
compiler/ghc.cabal.in
compiler/llvmGen/LlvmCodeGen.hs
compiler/llvmGen/LlvmCodeGen/Base.hs
compiler/llvmGen/LlvmCodeGen/CodeGen.hs
compiler/llvmGen/LlvmCodeGen/Data.hs
compiler/llvmGen/LlvmCodeGen/Ppr.hs
compiler/main/CodeOutput.lhs
compiler/main/HscMain.lhs
compiler/nativeGen/AsmCodeGen.lhs
compiler/nativeGen/Instruction.hs
compiler/nativeGen/NCGMonad.hs
compiler/nativeGen/PIC.hs
compiler/nativeGen/PPC/CodeGen.hs
compiler/nativeGen/PPC/Instr.hs
compiler/nativeGen/PPC/Ppr.hs
compiler/nativeGen/PPC/RegInfo.hs
compiler/nativeGen/PPC/Regs.hs
compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
compiler/nativeGen/RegAlloc/Graph/Spill.hs
compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
compiler/nativeGen/RegAlloc/Graph/Stats.hs
compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
compiler/nativeGen/RegAlloc/Linear/Main.hs
compiler/nativeGen/RegAlloc/Linear/Stats.hs
compiler/nativeGen/RegAlloc/Liveness.hs
compiler/nativeGen/SPARC/CodeGen.hs
compiler/nativeGen/SPARC/CodeGen/Amode.hs
compiler/nativeGen/SPARC/CodeGen/Base.hs
compiler/nativeGen/SPARC/CodeGen/CCall.hs
compiler/nativeGen/SPARC/CodeGen/CondCode.hs
compiler/nativeGen/SPARC/CodeGen/Expand.hs
compiler/nativeGen/SPARC/CodeGen/Gen32.hs
compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot
compiler/nativeGen/SPARC/CodeGen/Gen64.hs
compiler/nativeGen/SPARC/CodeGen/Sanity.hs
compiler/nativeGen/SPARC/Imm.hs
compiler/nativeGen/SPARC/Instr.hs
compiler/nativeGen/SPARC/Ppr.hs
compiler/nativeGen/SPARC/Regs.hs
compiler/nativeGen/SPARC/ShortcutJump.hs
compiler/nativeGen/Size.hs
compiler/nativeGen/TargetReg.hs
compiler/nativeGen/X86/CodeGen.hs
compiler/nativeGen/X86/Instr.hs
compiler/nativeGen/X86/Ppr.hs
compiler/nativeGen/X86/Regs.hs
ghc.mk
mk/validate-settings.mk
packages
utils/ghc-cabal/Main.hs

index 01ddcd2..c28201c 100644 (file)
@@ -1,23 +1,21 @@
+{- BlockId module should probably go away completely, being superseded by Label -}
 module BlockId
-  ( BlockId(..), mkBlockId     -- ToDo: BlockId should be abstract, but it isn't yet
-  , BlockEnv, emptyBlockEnv, elemBlockEnv, lookupBlockEnv, extendBlockEnv
-  , mkBlockEnv, mapBlockEnv
-  , eltsBlockEnv, plusBlockEnv, delFromBlockEnv, blockEnvToList, lookupWithDefaultBEnv
-  , isNullBEnv, sizeBEnv, foldBlockEnv, foldBlockEnv', addToBEnv_Acc
-  , BlockSet, emptyBlockSet, unitBlockSet, isEmptyBlockSet
-  , elemBlockSet, extendBlockSet, sizeBlockSet, unionBlockSets
-  , removeBlockSet, mkBlockSet, blockSetToList, foldBlockSet
+  ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet
+  , BlockSet, BlockEnv
+  , IsSet(..), setInsertList, setDeleteList, setUnions
+  , IsMap(..), mapInsertList, mapDeleteList, mapUnions
+  , emptyBlockSet, emptyBlockMap
   , blockLbl, infoTblLbl, retPtLbl
   ) where
 
 import CLabel
 import IdInfo
-import Maybes
 import Name
 import Outputable
-import UniqFM
 import Unique
-import UniqSet
+
+import Compiler.Hoopl hiding (Unique)
+import Compiler.Hoopl.GHC (uniqueToInt, uniqueToLbl, lblToUnique)
 
 ----------------------------------------------------------------
 --- Block Ids, their environments, and their sets
@@ -31,129 +29,40 @@ most assembly languages allow, a label is visible throughout the entire
 compilation unit in which it appears.
 -}
 
-data BlockId = BlockId Unique
-  deriving (Eq,Ord)
+type BlockId = Label
 
 instance Uniquable BlockId where
-  getUnique (BlockId id) = id
+  getUnique label = getUnique (uniqueToInt $ lblToUnique label)
 
 mkBlockId :: Unique -> BlockId
-mkBlockId uniq = BlockId uniq
-
-instance Show BlockId where
-  show (BlockId u) = show u
+mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique
 
 instance Outputable BlockId where
-  ppr (BlockId id) = ppr id
+  ppr label = ppr (getUnique label)
 
 retPtLbl :: BlockId -> CLabel
-retPtLbl (BlockId id) = mkReturnPtLabel id
+retPtLbl label = mkReturnPtLabel $ getUnique label
 
 blockLbl :: BlockId -> CLabel
-blockLbl (BlockId id) = mkEntryLabel (mkFCallName id "block") NoCafRefs
+blockLbl label = mkEntryLabel (mkFCallName (getUnique label) "block") NoCafRefs
 
 infoTblLbl :: BlockId -> CLabel
-infoTblLbl (BlockId id) = mkInfoTableLabel (mkFCallName id "block") NoCafRefs
+infoTblLbl label = mkInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs
 
 -- Block environments: Id blocks
-newtype BlockEnv a = BlockEnv (UniqFM {- id -} a)
+type BlockEnv a = LabelMap a
 
 instance Outputable a => Outputable (BlockEnv a) where
-  ppr (BlockEnv env) = ppr env
-
--- This is pretty horrid. There must be common patterns here that can be
--- abstracted into wrappers.
-emptyBlockEnv :: BlockEnv a
-emptyBlockEnv = BlockEnv emptyUFM
-
-isNullBEnv :: BlockEnv a -> Bool
-isNullBEnv (BlockEnv env) = isNullUFM env
-
-sizeBEnv :: BlockEnv a -> Int
-sizeBEnv (BlockEnv env)  = sizeUFM env
-
-mkBlockEnv :: [(BlockId,a)] -> BlockEnv a
-mkBlockEnv = foldl (uncurry . extendBlockEnv) emptyBlockEnv
-
-eltsBlockEnv :: BlockEnv elt -> [elt]
-eltsBlockEnv (BlockEnv env) = eltsUFM env
-
-delFromBlockEnv        :: BlockEnv elt -> BlockId -> BlockEnv elt
-delFromBlockEnv          (BlockEnv env) (BlockId id) = BlockEnv (delFromUFM env id)
-
-lookupBlockEnv :: BlockEnv a -> BlockId -> Maybe a
-lookupBlockEnv (BlockEnv env) (BlockId id) = lookupUFM env id
-
-elemBlockEnv :: BlockEnv a -> BlockId -> Bool
-elemBlockEnv (BlockEnv env) (BlockId id) = isJust $ lookupUFM env id
-
-lookupWithDefaultBEnv :: BlockEnv a -> a -> BlockId -> a
-lookupWithDefaultBEnv env x id = lookupBlockEnv env id `orElse` x
-
-extendBlockEnv :: BlockEnv a -> BlockId -> a -> BlockEnv a
-extendBlockEnv (BlockEnv env) (BlockId id) x = BlockEnv (addToUFM env id x)
-
-mapBlockEnv :: (a -> b) -> BlockEnv a -> BlockEnv b
-mapBlockEnv f (BlockEnv env) = BlockEnv (mapUFM f env)
-
-foldBlockEnv :: (BlockId -> a -> b -> b) -> b -> BlockEnv a -> b
-foldBlockEnv f b (BlockEnv env) = 
-  foldUFM_Directly (\u x y -> f (mkBlockId u) x y) b env
+  ppr = ppr . mapToList
 
-foldBlockEnv' :: (a -> b -> b) -> b -> BlockEnv a -> b
-foldBlockEnv' f b (BlockEnv env) = foldUFM f b env
+emptyBlockMap :: BlockEnv a
+emptyBlockMap = mapEmpty
 
-plusBlockEnv :: BlockEnv elt -> BlockEnv elt -> BlockEnv elt
-plusBlockEnv (BlockEnv x) (BlockEnv y) = BlockEnv (plusUFM x y)
+-- Block sets
+type BlockSet = LabelSet
 
-blockEnvToList :: BlockEnv elt -> [(BlockId, elt)]
-blockEnvToList (BlockEnv env) =
-  map (\ (id, elt) -> (BlockId id, elt)) $ ufmToList env
-
-addToBEnv_Acc  :: (elt -> elts -> elts)        -- Add to existing
-                          -> (elt -> elts)             -- New element
-                          -> BlockEnv elts             -- old
-                          -> BlockId -> elt            -- new
-                          -> BlockEnv elts             -- result
-addToBEnv_Acc add new (BlockEnv old) (BlockId k) v =
-  BlockEnv (addToUFM_Acc add new old k v)
-  -- I believe this is only used by obsolete code.
-
-
-newtype BlockSet = BlockSet (UniqSet Unique)
 instance Outputable BlockSet where
-  ppr (BlockSet set) = ppr set
-
+  ppr = ppr . setElems
 
 emptyBlockSet :: BlockSet
-emptyBlockSet = BlockSet emptyUniqSet
-
-isEmptyBlockSet :: BlockSet -> Bool
-isEmptyBlockSet (BlockSet s) = isEmptyUniqSet s
-
-unitBlockSet :: BlockId -> BlockSet
-unitBlockSet = extendBlockSet emptyBlockSet
-
-elemBlockSet :: BlockId -> BlockSet -> Bool
-elemBlockSet (BlockId id) (BlockSet set) = elementOfUniqSet id set
-
-extendBlockSet :: BlockSet -> BlockId -> BlockSet
-extendBlockSet (BlockSet set) (BlockId id) = BlockSet (addOneToUniqSet set id)
-
-removeBlockSet :: BlockSet -> BlockId -> BlockSet
-removeBlockSet (BlockSet set) (BlockId id) = BlockSet (delOneFromUniqSet set id)
-
-mkBlockSet :: [BlockId] -> BlockSet
-mkBlockSet = foldl extendBlockSet emptyBlockSet
-
-unionBlockSets :: BlockSet -> BlockSet -> BlockSet
-unionBlockSets (BlockSet s) (BlockSet s') = BlockSet (unionUniqSets s s')
-
-sizeBlockSet :: BlockSet -> Int
-sizeBlockSet (BlockSet set) = sizeUniqSet set
-
-blockSetToList :: BlockSet -> [BlockId]
-blockSetToList (BlockSet set) = map BlockId $ uniqSetToList set
-
-foldBlockSet :: (BlockId -> b -> b) -> b -> BlockSet -> b
-foldBlockSet f z (BlockSet set) = foldUniqSet (f . BlockId) z set
+emptyBlockSet = setEmpty
index 4ea7f00..076922e 100644 (file)
------------------------------------------------------------------------------
---
--- Cmm data types
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module Cmm ( 
-        GenCmm(..), Cmm, RawCmm,
-        GenCmmTop(..), CmmTop, RawCmmTop,
-        ListGraph(..),
-        cmmMapGraph, cmmTopMapGraph,
-        cmmMapGraphM, cmmTopMapGraphM,
-        CmmInfo(..), UpdateFrame(..),
-        CmmInfoTable(..), HasStaticClosure, ClosureTypeInfo(..), ConstrDescription,
-        ProfilingInfo(..), ClosureTypeTag,
-        GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
-        CmmReturnInfo(..),
-        CmmStmt(..), CmmActual, CmmActuals, CmmFormal, CmmFormals, 
-        HintedCmmFormal, HintedCmmFormals, HintedCmmActual, HintedCmmActuals,
-        CmmSafety(..),
-        CmmCallTarget(..), CallishMachOp(..), pprCallishMachOp,
-        ForeignHint(..), CmmHinted(..),
-        CmmStatic(..), Section(..),
-        module CmmExpr,
-  ) where
-
-#include "HsVersions.h"
+-- Cmm representations using Hoopl's Graph CmmNode e x.
+{-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
+
+module Cmm
+  ( CmmGraph(..), CmmBlock
+  , CmmStackInfo(..), CmmTopInfo(..), Cmm, CmmTop
+  , CmmReplGraph, CmmFwdRewrite, CmmBwdRewrite
+
+  , lastNode, replaceLastNode, insertBetween
+  , ofBlockMap, toBlockMap, insertBlock
+  , ofBlockList, toBlockList, bodyToBlockList
+  , foldGraphBlocks, mapGraphNodes, postorderDfs
+
+  , analFwd, analBwd, analRewFwd, analRewBwd
+  , dataflowPassFwd, dataflowPassBwd
+  , module CmmNode
+  )
+where
 
 import BlockId
-import CmmExpr
-import CLabel
-import ForeignCall
+import CmmDecl
+import CmmNode
+import OptimizationFuel as F
 import SMRep
+import UniqSupply
 
-import ClosureInfo
-import Outputable
-import FastString
-
-import Data.Word
-
-
--- A [[BlockId]] is a local label.
--- Local labels must be unique within an entire compilation unit, not
--- just a single top-level item, because local labels map one-to-one
--- with assembly-language labels.
-
------------------------------------------------------------------------------
---  Cmm, CmmTop, CmmBasicBlock
------------------------------------------------------------------------------
-
--- A file is a list of top-level chunks.  These may be arbitrarily
--- re-orderd during code generation.
-
--- GenCmm is abstracted over
---   d, the type of static data elements in CmmData
---   h, the static info preceding the code of a CmmProc
---   g, the control-flow graph of a CmmProc
---
--- We expect there to be two main instances of this type:
---   (a) C--, i.e. populated with various C-- constructs
---       (Cmm and RawCmm below)
---   (b) Native code, populated with data/instructions
---
--- A second family of instances based on ZipCfg is work in progress.
---
-newtype GenCmm d h g = Cmm [GenCmmTop d h g]
-
--- | A top-level chunk, abstracted over the type of the contents of
--- the basic blocks (Cmm or instructions are the likely instantiations).
-data GenCmmTop d h g
-  = CmmProc    -- A procedure
-     h                -- Extra header such as the info table
-     CLabel            -- Used to generate both info & entry labels
-     CmmFormals                     -- Argument locals live on entry (C-- procedure params)
-                       -- XXX Odd that there are no kinds, but there you are ---NR
-     g                 -- Control-flow graph for the procedure's code
-
-  | CmmData    -- Static data
-       Section 
-       [d]
-
--- | A control-flow graph represented as a list of extended basic blocks.
-newtype ListGraph i = ListGraph [GenBasicBlock i] 
-   -- ^ Code, may be empty.  The first block is the entry point.  The
-   -- order is otherwise initially unimportant, but at some point the
-   -- code gen will fix the order.
-
-   -- BlockIds must be unique across an entire compilation unit, since
-   -- they are translated to assembly-language labels, which scope
-   -- across a whole compilation unit.
-
--- | Cmm with the info table as a data type
-type Cmm    = GenCmm    CmmStatic CmmInfo (ListGraph CmmStmt)
-type CmmTop = GenCmmTop CmmStatic CmmInfo (ListGraph CmmStmt)
-
--- | Cmm with the info tables converted to a list of 'CmmStatic'
-type RawCmm    = GenCmm    CmmStatic [CmmStatic] (ListGraph CmmStmt)
-type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] (ListGraph CmmStmt)
-
-
--- A basic block containing a single label, at the beginning.
--- The list of basic blocks in a top-level code block may be re-ordered.
--- Fall-through is not allowed: there must be an explicit jump at the
--- end of each basic block, but the code generator might rearrange basic
--- blocks in order to turn some jumps into fallthroughs.
-
-data GenBasicBlock i = BasicBlock BlockId [i]
-type CmmBasicBlock   = GenBasicBlock CmmStmt
-
-instance UserOfLocalRegs i => UserOfLocalRegs (GenBasicBlock i) where
-    foldRegsUsed f set (BasicBlock _ l) = foldRegsUsed f set l
-
-blockId :: GenBasicBlock i -> BlockId
--- The branch block id is that of the first block in 
--- the branch, which is that branch's entry point
-blockId (BasicBlock blk_id _ ) = blk_id
-
-blockStmts :: GenBasicBlock i -> [i]
-blockStmts (BasicBlock _ stmts) = stmts
-
-
-mapBlockStmts :: (i -> i') -> GenBasicBlock i -> GenBasicBlock i'
-mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs)
-----------------------------------------------------------------
---   graph maps
-----------------------------------------------------------------
-
-cmmMapGraph    :: (g -> g') -> GenCmm    d h g -> GenCmm    d h g'
-cmmTopMapGraph :: (g -> g') -> GenCmmTop d h g -> GenCmmTop d h g'
-
-cmmMapGraphM    :: Monad m => (String -> g -> m g') -> GenCmm    d h g -> m (GenCmm    d h g')
-cmmTopMapGraphM :: Monad m => (String -> g -> m g') -> GenCmmTop d h g -> m (GenCmmTop d h g')
-
-cmmMapGraph f (Cmm tops) = Cmm $ map (cmmTopMapGraph f) tops
-cmmTopMapGraph f (CmmProc h l args g) = CmmProc h l args (f g)
-cmmTopMapGraph _ (CmmData s ds)             = CmmData s ds
-
-cmmMapGraphM f (Cmm tops) = mapM (cmmTopMapGraphM f) tops >>= return . Cmm
-cmmTopMapGraphM f (CmmProc h l args g) =
-  f (showSDoc $ ppr l) g >>= return . CmmProc h l args
-cmmTopMapGraphM _ (CmmData s ds)       = return $ CmmData s ds
-
------------------------------------------------------------------------------
---     Info Tables
------------------------------------------------------------------------------
-
-data CmmInfo
-  = CmmInfo
-      (Maybe BlockId)     -- GC target. Nothing <=> CPS won't do stack check
-                          -- JD: NOT USED BY NEW CODE GEN
-      (Maybe UpdateFrame) -- Update frame
-      CmmInfoTable        -- Info table
-
--- Info table as a haskell data type
-data CmmInfoTable
-  = CmmInfoTable
-      HasStaticClosure
-      ProfilingInfo
-      ClosureTypeTag -- Int
-      ClosureTypeInfo
-  | CmmNonInfoTable   -- Procedure doesn't need an info table
-
-type HasStaticClosure = Bool
-
--- TODO: The GC target shouldn't really be part of CmmInfo
--- as it doesn't appear in the resulting info table.
--- It should be factored out.
-
-data ClosureTypeInfo
-  = ConstrInfo ClosureLayout ConstrTag ConstrDescription
-  | FunInfo    ClosureLayout C_SRT FunArity ArgDescr SlowEntry
-  | ThunkInfo  ClosureLayout C_SRT
-  | ThunkSelectorInfo SelectorOffset C_SRT
-  | ContInfo
-      [Maybe LocalReg]  -- Stack layout: Just x, an item x
-                        --               Nothing: a 1-word gap
-                       -- Start of list is the *young* end
-      C_SRT
-
-data CmmReturnInfo = CmmMayReturn
-                   | CmmNeverReturns
-    deriving ( Eq )
-
--- TODO: These types may need refinement
-data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc
-type ClosureTypeTag = StgHalfWord
-type ClosureLayout = (StgHalfWord, StgHalfWord) -- ptrs, nptrs
-type ConstrTag = StgHalfWord
-type ConstrDescription = CmmLit
-type FunArity = StgHalfWord
-type SlowEntry = CmmLit
-  -- We would like this to be a CLabel but
-  -- for now the parser sets this to zero on an INFO_TABLE_FUN.
-type SelectorOffset = StgWord
-
--- | A frame that is to be pushed before entry to the function.
--- Used to handle 'update' frames.
-data UpdateFrame =
-    UpdateFrame
-      CmmExpr    -- Frame header.  Behaves like the target of a 'jump'.
-      [CmmExpr]  -- Frame remainder.  Behaves like the arguments of a 'jump'.
-
------------------------------------------------------------------------------
---             CmmStmt
--- A "statement".  Note that all branches are explicit: there are no
--- control transfers to computed addresses, except when transfering
--- control to a new function.
------------------------------------------------------------------------------
-
-data CmmStmt   -- Old-style
-  = CmmNop
-  | CmmComment FastString
-
-  | CmmAssign CmmReg CmmExpr    -- Assign to register
-
-  | CmmStore CmmExpr CmmExpr     -- Assign to memory location.  Size is
-                                 -- given by cmmExprType of the rhs.
-
-  | CmmCall                     -- A call (forign, native or primitive), with 
-     CmmCallTarget
-     HintedCmmFormals           -- zero or more results
-     HintedCmmActuals           -- zero or more arguments
-     CmmSafety                  -- whether to build a continuation
-     CmmReturnInfo
-
-  | CmmBranch BlockId             -- branch to another BB in this fn
-
-  | CmmCondBranch CmmExpr BlockId -- conditional branch
-
-  | CmmSwitch CmmExpr [Maybe BlockId]   -- Table branch
-       -- The scrutinee is zero-based; 
-       --      zero -> first block
-       --      one  -> second block etc
-       -- Undefined outside range, and when there's a Nothing
-
-  | CmmJump CmmExpr      -- Jump to another C-- function,
-      HintedCmmActuals         -- with these parameters.  (parameters never used)
-
-  | CmmReturn            -- Return from a native C-- function,
-      HintedCmmActuals         -- with these return values. (parameters never used)
-
-type CmmActual = CmmExpr
-type CmmFormal = LocalReg
-type CmmActuals = [CmmActual]
-type CmmFormals = [CmmFormal]
-
-data CmmHinted a = CmmHinted { hintlessCmm :: a, cmmHint :: ForeignHint }
-                deriving( Eq )
-
-type HintedCmmActuals = [HintedCmmActual]
-type HintedCmmFormals = [HintedCmmFormal]
-type HintedCmmFormal  = CmmHinted CmmFormal
-type HintedCmmActual  = CmmHinted CmmActual
-
-data CmmSafety      = CmmUnsafe | CmmSafe C_SRT | CmmInterruptible
-
--- | enable us to fold used registers over 'CmmActuals' and 'CmmFormals'
-instance UserOfLocalRegs CmmStmt where
-  foldRegsUsed f (set::b) s = stmt s set
-    where 
-      stmt :: CmmStmt -> b -> b
-      stmt (CmmNop)                  = id
-      stmt (CmmComment {})           = id
-      stmt (CmmAssign _ e)           = gen e
-      stmt (CmmStore e1 e2)          = gen e1 . gen e2
-      stmt (CmmCall target _ es _ _) = gen target . gen es
-      stmt (CmmBranch _)             = id
-      stmt (CmmCondBranch e _)       = gen e
-      stmt (CmmSwitch e _)           = gen e
-      stmt (CmmJump e es)            = gen e . gen es
-      stmt (CmmReturn es)            = gen es
-
-      gen :: UserOfLocalRegs a => a -> b -> b
-      gen a set = foldRegsUsed f set a
-
-instance UserOfLocalRegs CmmCallTarget where
-    foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e
-    foldRegsUsed _ set (CmmPrim {})    = set
-
-instance UserOfSlots CmmCallTarget where
-    foldSlotsUsed f set (CmmCallee e _) = foldSlotsUsed f set e
-    foldSlotsUsed _ set (CmmPrim {})    = set
-
-instance UserOfLocalRegs a => UserOfLocalRegs (CmmHinted a) where
-  foldRegsUsed f set a = foldRegsUsed f set (hintlessCmm a)
-
-instance UserOfSlots a => UserOfSlots (CmmHinted a) where
-  foldSlotsUsed f set a = foldSlotsUsed f set (hintlessCmm a)
-
-instance DefinerOfLocalRegs a => DefinerOfLocalRegs (CmmHinted a) where
-  foldRegsDefd f set a = foldRegsDefd f set (hintlessCmm a)
-
-{-
-Discussion
-~~~~~~~~~~
-
-One possible problem with the above type is that the only way to do a
-non-local conditional jump is to encode it as a branch to a block that
-contains a single jump.  This leads to inefficient code in the back end.
-
-[N.B. This problem will go away when we make the transition to the
-'zipper' form of control-flow graph, in which both targets of a
-conditional jump are explicit. ---NR]
-
-One possible way to fix this would be:
-
-data CmmStat = 
-  ...
-  | CmmJump CmmBranchDest
-  | CmmCondJump CmmExpr CmmBranchDest
-  ...
-
-data CmmBranchDest
-  = Local BlockId
-  | NonLocal CmmExpr [LocalReg]
-
-In favour:
-
-+ one fewer constructors in CmmStmt
-+ allows both cond branch and switch to jump to non-local destinations
-
-Against:
-
-- not strictly necessary: can already encode as branch+jump
-- not always possible to implement any better in the back end
-- could do the optimisation in the back end (but then plat-specific?)
-- C-- doesn't have it
-- back-end optimisation might be more general (jump shortcutting)
-
-So we'll stick with the way it is, and add the optimisation to the NCG.
--}
-
------------------------------------------------------------------------------
---             CmmCallTarget
---
--- The target of a CmmCall.
------------------------------------------------------------------------------
-
-data CmmCallTarget
-  = CmmCallee          -- Call a function (foreign or native)
-       CmmExpr                 -- literal label <=> static call
-                               -- other expression <=> dynamic call
-       CCallConv               -- The calling convention
-
-  | CmmPrim            -- Call a "primitive" (eg. sin, cos)
-       CallishMachOp           -- These might be implemented as inline
-                               -- code by the backend.
-  deriving Eq
-
-
-data ForeignHint
-  = NoHint | AddrHint | SignedHint
-  deriving( Eq )
-       -- Used to give extra per-argument or per-result
-       -- information needed by foreign calling conventions
-
-
--- CallishMachOps tend to be implemented by foreign calls in some backends,
--- so we separate them out.  In Cmm, these can only occur in a
--- statement position, in contrast to an ordinary MachOp which can occur
--- anywhere in an expression.
-data CallishMachOp
-  = MO_F64_Pwr
-  | MO_F64_Sin
-  | MO_F64_Cos
-  | MO_F64_Tan
-  | MO_F64_Sinh
-  | MO_F64_Cosh
-  | MO_F64_Tanh
-  | MO_F64_Asin
-  | MO_F64_Acos
-  | MO_F64_Atan
-  | MO_F64_Log
-  | MO_F64_Exp
-  | MO_F64_Sqrt
-  | MO_F32_Pwr
-  | MO_F32_Sin
-  | MO_F32_Cos
-  | MO_F32_Tan
-  | MO_F32_Sinh
-  | MO_F32_Cosh
-  | MO_F32_Tanh
-  | MO_F32_Asin
-  | MO_F32_Acos
-  | MO_F32_Atan
-  | MO_F32_Log
-  | MO_F32_Exp
-  | MO_F32_Sqrt
-  | MO_WriteBarrier
-  | MO_Touch         -- Keep variables live (when using interior pointers)
-  deriving (Eq, Show)
-
-pprCallishMachOp :: CallishMachOp -> SDoc
-pprCallishMachOp mo = text (show mo)
-  
------------------------------------------------------------------------------
---             Static Data
------------------------------------------------------------------------------
-
-data Section
-  = Text
-  | Data
-  | ReadOnlyData
-  | RelocatableReadOnlyData
-  | UninitialisedData
-  | ReadOnlyData16     -- .rodata.cst16 on x86_64, 16-byte aligned
-  | OtherSection String
-
-data CmmStatic
-  = CmmStaticLit CmmLit        
-       -- a literal value, size given by cmmLitRep of the literal.
-  | CmmUninitialised Int
-       -- uninitialised data, N bytes long
-  | CmmAlign Int
-       -- align to next N-byte boundary (N must be a power of 2).
-  | CmmDataLabel CLabel
-       -- label the current position in this section.
-  | CmmString [Word8]
-       -- string of 8-bit values only, not zero terminated.
+import Compiler.Hoopl
+import Control.Monad
+import Data.Maybe
+import Panic
+
+#include "HsVersions.h"
 
+-------------------------------------------------
+-- CmmBlock, CmmGraph and Cmm
+
+data CmmGraph = CmmGraph { g_entry :: BlockId, g_graph :: Graph CmmNode C C }
+type CmmBlock = Block CmmNode C C
+
+type CmmReplGraph e x = FuelUniqSM (Maybe (Graph CmmNode e x))
+type CmmFwdRewrite f = FwdRewrite FuelUniqSM CmmNode f
+type CmmBwdRewrite f = BwdRewrite FuelUniqSM CmmNode f
+
+data CmmStackInfo = StackInfo {arg_space :: ByteOff, updfr_space :: Maybe ByteOff}
+data CmmTopInfo   = TopInfo {info_tbl :: CmmInfoTable, stack_info :: CmmStackInfo}
+type Cmm          = GenCmm    CmmStatic CmmTopInfo CmmGraph
+type CmmTop       = GenCmmTop CmmStatic CmmTopInfo CmmGraph
+
+-------------------------------------------------
+-- Manipulating CmmGraphs
+
+toBlockMap :: CmmGraph -> LabelMap CmmBlock
+toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
+--toBlockMap _ = panic "Cmm.toBlockMap"
+
+ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
+ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}
+
+insertBlock :: CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
+insertBlock block map =
+  ASSERT (isNothing $ mapLookup id map)
+  mapInsert id block map
+  where id = entryLabel block
+
+toBlockList :: CmmGraph -> [CmmBlock]
+toBlockList g = mapElems $ toBlockMap g
+
+ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
+ofBlockList entry blocks = CmmGraph {g_entry=entry, g_graph=GMany NothingO body NothingO}
+  where body = foldr addBlock emptyBody blocks
+
+bodyToBlockList :: Body CmmNode -> [CmmBlock]
+bodyToBlockList body = mapElems body
+
+mapGraphNodes :: ( CmmNode C O -> CmmNode C O
+                 , CmmNode O O -> CmmNode O O
+                 , CmmNode O C -> CmmNode O C)
+              -> CmmGraph -> CmmGraph
+mapGraphNodes funs@(mf,_,_) g =
+  ofBlockMap (entryLabel $ mf $ CmmEntry $ g_entry g) $ mapMap (blockMapNodes3 funs) $ toBlockMap g
+
+foldGraphBlocks :: (CmmBlock -> a -> a) -> a -> CmmGraph -> a
+foldGraphBlocks k z g = mapFold k z $ toBlockMap g
+
+postorderDfs :: CmmGraph -> [CmmBlock]
+postorderDfs g = postorder_dfs_from (toBlockMap g) (g_entry g)
+
+-------------------------------------------------
+-- Manipulating CmmBlocks
+
+lastNode :: CmmBlock -> CmmNode O C
+lastNode block = foldBlockNodesF3 (nothing, nothing, const) block ()
+  where nothing :: a -> b -> ()
+        nothing _ _ = ()
+
+replaceLastNode :: Block CmmNode e C -> CmmNode O C -> Block CmmNode e C
+replaceLastNode block last = blockOfNodeList (first, middle, JustC last)
+  where (first, middle, _) = blockToNodeList block
+
+----------------------------------------------------------------------
+----- Splicing between blocks
+-- Given a middle node, a block, and a successor BlockId,
+-- we can insert the middle node between the block and the successor.
+-- We return the updated block and a list of new blocks that must be added
+-- to the graph.
+-- The semantics is a bit tricky. We consider cases on the last node:
+-- o For a branch, we can just insert before the branch,
+--   but sometimes the optimizer does better if we actually insert
+--   a fresh basic block, enabling some common blockification.
+-- o For a conditional branch, switch statement, or call, we must insert
+--   a new basic block.
+-- o For a jump or return, this operation is impossible.
+
+insertBetween :: MonadUnique m => CmmBlock -> [CmmNode O O] -> BlockId -> m (CmmBlock, [CmmBlock])
+insertBetween b ms succId = insert $ lastNode b
+  where insert :: MonadUnique m => CmmNode O C -> m (CmmBlock, [CmmBlock])
+        insert (CmmBranch bid) =
+          if bid == succId then
+            do (bid', bs) <- newBlocks
+               return (replaceLastNode b (CmmBranch bid'), bs)
+          else panic "tried invalid block insertBetween"
+        insert (CmmCondBranch c t f) =
+          do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
+             (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
+             return (replaceLastNode b (CmmCondBranch c t' f'), tbs ++ fbs)
+        insert (CmmSwitch e ks) =
+          do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
+             return (replaceLastNode b (CmmSwitch e ids), join bs)
+        insert (CmmCall {}) =
+          panic "unimp: insertBetween after a call -- probably not a good idea"
+        insert (CmmForeignCall {}) =
+          panic "unimp: insertBetween after a foreign call -- probably not a good idea"
+        --insert _ = panic "Cmm.insertBetween.insert"
+
+        newBlocks :: MonadUnique m => m (BlockId, [CmmBlock])
+        newBlocks = do id <- liftM mkBlockId $ getUniqueM
+                       return $ (id, [blockOfNodeList (JustC (CmmEntry id), ms, JustC (CmmBranch succId))])
+        mbNewBlocks :: MonadUnique m => Maybe BlockId -> m (Maybe BlockId, [CmmBlock])
+        mbNewBlocks (Just k) = if k == succId then liftM fstJust newBlocks
+                               else return (Just k, [])
+        mbNewBlocks Nothing  = return (Nothing, [])
+        fstJust (id, bs) = (Just id, bs)
+
+-------------------------------------------------
+-- Running dataflow analysis and/or rewrites
+
+-- Constructing forward and backward analysis-only pass
+analFwd    :: Monad m => DataflowLattice f -> FwdTransfer CmmNode f -> FwdPass m CmmNode f
+analBwd    :: Monad m => DataflowLattice f -> BwdTransfer CmmNode f -> BwdPass m CmmNode f
+
+analFwd lat xfer = analRewFwd lat xfer noFwdRewrite
+analBwd lat xfer = analRewBwd lat xfer noBwdRewrite
+
+-- Constructing forward and backward analysis + rewrite pass
+analRewFwd :: Monad m => DataflowLattice f -> FwdTransfer CmmNode f -> FwdRewrite m CmmNode f -> FwdPass m CmmNode f
+analRewBwd :: Monad m => DataflowLattice f -> BwdTransfer CmmNode f -> BwdRewrite m CmmNode f -> BwdPass m CmmNode f
+
+analRewFwd lat xfer rew = FwdPass {fp_lattice = lat, fp_transfer = xfer, fp_rewrite = rew}
+analRewBwd lat xfer rew = BwdPass {bp_lattice = lat, bp_transfer = xfer, bp_rewrite = rew}
+
+-- Running forward and backward dataflow analysis + optional rewrite
+dataflowPassFwd :: CmmGraph -> [(BlockId, f)] -> FwdPass FuelUniqSM CmmNode f -> FuelUniqSM (CmmGraph, BlockEnv f)
+dataflowPassFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do
+  (graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
+  return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
+
+dataflowPassBwd :: CmmGraph -> [(BlockId, f)] -> BwdPass FuelUniqSM CmmNode f -> FuelUniqSM (CmmGraph, BlockEnv f)
+dataflowPassBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do
+  (graph, facts, NothingO) <- analyzeAndRewriteBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts)
+  return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
diff --git a/compiler/cmm/CmmBrokenBlock.hs b/compiler/cmm/CmmBrokenBlock.hs
deleted file mode 100644 (file)
index 17b8178..0000000
+++ /dev/null
@@ -1,421 +0,0 @@
-
-module CmmBrokenBlock (
-  BrokenBlock(..),
-  BlockEntryInfo(..),
-  FinalStmt(..),
-  breakBlock,
-  cmmBlockFromBrokenBlock,
-  blocksToBlockEnv,
-  adaptBlockToFormat,
-  selectContinuations,
-  ContFormat,
-  makeContinuationEntries
-  ) where
-
-#include "HsVersions.h"
-
-import BlockId
-import Cmm
-import CmmUtils
-import CLabel
-
-import CgUtils (callerSaveVolatileRegs)
-import ClosureInfo
-
-import Maybes
-import Data.List
-import Panic
-import Unique
-
--- This module takes a 'CmmBasicBlock' which might have 'CmmCall'
--- statements in it with 'CmmSafe' set and breaks it up at each such call.
--- It also collects information about the block for later use
--- by the CPS algorithm.
-
------------------------------------------------------------------------------
--- Data structures
------------------------------------------------------------------------------
-
--- |Similar to a 'CmmBlock' with a little extra information
--- to help the CPS analysis.
-data BrokenBlock
-  = BrokenBlock {
-      brokenBlockId :: BlockId, -- ^ The block's label like a 'CmmBasicBlock'
-      brokenBlockEntry :: BlockEntryInfo,
-                                -- ^ Ways this block can be entered
-
-      brokenBlockStmts :: [CmmStmt],
-                                -- ^ Body like a CmmBasicBlock
-                                -- (but without the last statement)
-
-      brokenBlockTargets :: [BlockId],
-                                -- ^ Blocks that this block could
-                                -- branch to either by conditional
-                                -- branches or via the last statement
-
-      brokenBlockExit :: FinalStmt
-                                -- ^ The final statement of the block
-    }
-
--- | How a block could be entered
--- See Note [An example of CPS conversion]
-data BlockEntryInfo
-  = FunctionEntry CmmInfo CLabel CmmFormals
-      -- ^ Block is the beginning of a function, parameters are:
-      --   1. Function header info
-      --   2. The function name
-      --   3. Aguments to function
-      -- Only the formal parameters are live
-
-  | ContinuationEntry CmmFormals C_SRT Bool
-      -- ^ Return point of a function call, parameters are:
-      --   1. return values (argument to continuation)
-      --   2. SRT for the continuation's info table
-      --   3. True <=> GC block so ignore stack size
-      -- Live variables, other than
-      -- the return values, are on the stack
-
-  | ControlEntry
-      -- ^ Any other kind of block.  Only entered due to control flow.
-
-  -- TODO: Consider adding ProcPointEntry
-  -- no return values, but some live might end up as
-  -- params or possibly in the frame
-
-{-     Note [An example of CPS conversion]
-
-This is NR's and SLPJ's guess about how things might work;
-it may not be consistent with the actual code (particularly
-in the matter of what's in parameters and what's on the stack).
-
-f(x,y) {
-   if x>2 then goto L
-   x = x+1
-L: if x>1 then y = g(y)
-        else x = x+1 ;
-   return( x+y )
-}
-       BECOMES
-
-f(x,y) {   // FunctionEntry
-   if x>2 then goto L
-   x = x+1
-L:        // ControlEntry
-   if x>1 then push x; push f1; jump g(y)
-        else x=x+1; jump f2(x, y)
-}
-
-f1(y) {    // ContinuationEntry
-  pop x; jump f2(x, y);
-}
-  
-f2(x, y) { // ProcPointEntry
-  return (z+y);
-}
-
--}
-
-data ContFormat = ContFormat HintedCmmFormals C_SRT Bool
-      -- ^ Arguments
-      --   1. return values (argument to continuation)
-      --   2. SRT for the continuation's info table
-      --   3. True <=> GC block so ignore stack size
-  deriving (Eq)
-
--- | Final statement in a 'BlokenBlock'.
--- Constructors and arguments match those in 'Cmm',
--- but are restricted to branches, returns, jumps, calls and switches
-data FinalStmt
-  = FinalBranch BlockId
-    -- ^ Same as 'CmmBranch'.  Target must be a ControlEntry
-
-  | FinalReturn HintedCmmActuals
-    -- ^ Same as 'CmmReturn'. Parameter is the return values.
-
-  | FinalJump CmmExpr HintedCmmActuals
-    -- ^ Same as 'CmmJump'.  Parameters:
-    --   1. The function to call,
-    --   2. Arguments of the call
-
-  | FinalCall BlockId CmmCallTarget HintedCmmFormals HintedCmmActuals
-              C_SRT   CmmReturnInfo Bool
-      -- ^ Same as 'CmmCallee' followed by 'CmmGoto'.  Parameters:
-      --   1. Target of the 'CmmGoto' (must be a 'ContinuationEntry')
-      --   2. The function to call
-      --   3. Results from call (redundant with ContinuationEntry)
-      --   4. Arguments to call
-      --   5. SRT for the continuation's info table
-      --   6. Does the function return?
-      --   7. True <=> GC block so ignore stack size
-
-  | FinalSwitch CmmExpr [Maybe BlockId]
-      -- ^ Same as a 'CmmSwitch'.  Paremeters:
-      --   1. Scrutinee (zero based)
-      --   2. Targets
-
------------------------------------------------------------------------------
--- Operations for broken blocks
------------------------------------------------------------------------------
-
--- Naively breaking at *every* CmmCall leads to sub-optimal code.
--- In particular, a CmmCall followed by a CmmBranch would result
--- in a continuation that has the single CmmBranch statement in it.
--- It would be better have the CmmCall directly return to the block
--- that the branch jumps to.
---
--- This requires the target of the branch to look like the parameter
--- format that the CmmCall is expecting.  If other CmmCall/CmmBranch
--- sequences go to the same place they might not be expecting the
--- same format.  So this transformation uses the following solution.
--- First the blocks are broken up but none of the blocks are marked
--- as continuations yet.  This is the 'breakBlock' function.
--- Second, the blocks "vote" on what other blocks need to be continuations
--- and how they should be layed out.  Plurality wins, but other selection
--- methods could be selected at a later time.
--- This is the 'selectContinuations' function.
--- Finally, the blocks are upgraded to 'ContEntry' continuations
--- based on the results with the 'makeContinuationEntries' function,
--- and the blocks that didn't get the format they wanted for their
--- targets get a small adaptor block created for them by
--- the 'adaptBlockToFormat' function.
--- could be 
-
-{-
-UNUSED: 2008-12-29
-
-breakProc ::
-    [BlockId]                   -- ^ Any GC blocks that should be special
-    -> [[Unique]]               -- ^ An infinite list of uniques
-                                -- to create names of the new blocks with
-    -> CmmInfo                  -- ^ Info table for the procedure
-    -> CLabel                   -- ^ Name of the procedure
-    -> CmmFormals               -- ^ Parameters of the procedure
-    -> [CmmBasicBlock]          -- ^ Blocks of the procecure
-                                -- (First block is the entry block)
-    -> [BrokenBlock]
-
-breakProc gc_block_idents uniques info ident params blocks =
-    let
-        (adaptor_uniques : block_uniques) = uniques
-
-        broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
-        broken_blocks =
-            let new_blocks =
-                    zipWith3 (breakBlock gc_block_idents)
-                             block_uniques
-                             blocks
-                             (FunctionEntry info ident params :
-                              repeat ControlEntry)
-            in (concatMap fst new_blocks, concatMap snd new_blocks)
-
-        selected = selectContinuations (fst broken_blocks)
-
-    in map (makeContinuationEntries selected) $
-       concat $
-       zipWith (adaptBlockToFormat selected)
-               adaptor_uniques
-               (snd broken_blocks)
--}
-
------------------------------------------------------------------------------
--- | Takes a 'CmmBasicBlock' and breaks it up into a list of 'BrokenBlock'
--- by splitting on each 'CmmCall' in the 'CmmBasicBlock'.
-
-breakBlock ::
-    [BlockId]                   -- ^ Any GC blocks that should be special
-    -> [Unique]                 -- ^ An infinite list of uniques
-                                -- to create names of the new blocks with
-    -> CmmBasicBlock            -- ^ Input block to break apart
-    -> BlockEntryInfo           -- ^ Info for the first created 'BrokenBlock'
-    -> ([(BlockId, ContFormat)], [BrokenBlock])
-breakBlock gc_block_idents uniques (BasicBlock ident stmts) entry =
-    breakBlock' uniques ident entry [] [] stmts
-    where
-      breakBlock' uniques current_id entry exits accum_stmts stmts =
-          case stmts of
-            [] -> panic "block doesn't end in jump, goto, return or switch"
-
-            -- Last statement.  Make the 'BrokenBlock'
-            [CmmJump target arguments] ->
-                ([],
-                 [BrokenBlock current_id entry accum_stmts
-                              exits
-                              (FinalJump target arguments)])
-            [CmmReturn arguments] ->
-                ([],
-                 [BrokenBlock current_id entry accum_stmts
-                             exits
-                             (FinalReturn arguments)])
-            [CmmBranch target] ->
-                ([],
-                 [BrokenBlock current_id entry accum_stmts
-                             (target:exits)
-                             (FinalBranch target)])
-            [CmmSwitch expr targets] ->
-                ([],
-                 [BrokenBlock current_id entry accum_stmts
-                             (mapMaybe id targets ++ exits)
-                             (FinalSwitch expr targets)])
-
-            -- These shouldn't happen in the middle of a block.
-            -- They would cause dead code.
-            (CmmJump _ _:_) -> panic "jump in middle of block"
-            (CmmReturn _:_) -> panic "return in middle of block"
-            (CmmBranch _:_) -> panic "branch in middle of block"
-            (CmmSwitch _ _:_) -> panic "switch in middle of block"
-
-            -- Detect this special case to remain an inverse of
-            -- 'cmmBlockFromBrokenBlock'
-            [CmmCall target results arguments (CmmSafe srt) ret,
-             CmmBranch next_id] ->
-                ([cont_info], [block])
-                where
-                  cont_info = (next_id,
-                               ContFormat results srt
-                                              (ident `elem` gc_block_idents))
-                  block = do_call current_id entry accum_stmts exits next_id
-                                target results arguments srt ret
-
-            -- Break the block on safe calls (the main job of this function)
-            (CmmCall target results arguments (CmmSafe srt) ret : stmts) ->
-                (cont_info : cont_infos, block : blocks)
-                where
-                  next_id = BlockId $ head uniques
-                  block = do_call current_id entry accum_stmts exits next_id
-                                  target results arguments srt ret
-
-                  cont_info = (next_id,        -- Entry convention for the 
-                                       -- continuation of the call
-                               ContFormat results srt
-                                              (ident `elem` gc_block_idents))
-
-                       -- Break up the part after the call
-                  (cont_infos, blocks) = breakBlock' (tail uniques) next_id
-                                         ControlEntry [] [] stmts
-
-            -- Unsafe calls don't need a continuation
-            -- but they do need to be expanded
-            (CmmCall target results arguments CmmUnsafe ret : stmts) ->
-                breakBlock' remaining_uniques current_id entry exits
-                            (accum_stmts ++
-                             arg_stmts ++
-                             caller_save ++
-                             [CmmCall target results new_args CmmUnsafe ret] ++
-                             caller_load)
-                            stmts
-                where
-                  (remaining_uniques, arg_stmts, new_args) =
-                      loadArgsIntoTemps uniques arguments
-                  (caller_save, caller_load) = callerSaveVolatileRegs (Just [])
-
-            -- Default case.  Just keep accumulating statements
-            -- and branch targets.
-            (s : stmts) ->
-                breakBlock' uniques current_id entry
-                            (cond_branch_target s++exits)
-                            (accum_stmts++[s])
-                            stmts
-
-      do_call current_id entry accum_stmts exits next_id
-              target results arguments srt ret =
-          BrokenBlock current_id entry accum_stmts (next_id:exits)
-                      (FinalCall next_id target results arguments srt ret
-                                     (current_id `elem` gc_block_idents))
-
-      cond_branch_target (CmmCondBranch _ target) = [target]
-      cond_branch_target _ = []
-
------------------------------------------------------------------------------
-
-selectContinuations :: [(BlockId, ContFormat)] -> [(BlockId, ContFormat)]
-selectContinuations needed_continuations = formats
-    where
-      formats = map select_format format_groups
-      format_groups = groupBy by_target needed_continuations
-      by_target x y = fst x == fst y
-
-      select_format formats = winner
-          where
-            winner = head $ head $ sortBy more_votes format_votes
-            format_votes = groupBy by_format formats
-            by_format x y = snd x == snd y
-            more_votes x y = compare (length y) (length x)
-              -- sort so the most votes goes *first*
-              -- (thus the order of x and y is reversed)
-
-makeContinuationEntries :: [(BlockId, ContFormat)]
-                        -> BrokenBlock -> BrokenBlock
-makeContinuationEntries formats
-                        block@(BrokenBlock ident _entry stmts targets exit) =
-    case lookup ident formats of
-      Nothing -> block
-      Just (ContFormat formals srt is_gc) ->
-          BrokenBlock ident (ContinuationEntry (map hintlessCmm formals) srt is_gc)
-                      stmts targets exit
-
-adaptBlockToFormat :: [(BlockId, ContFormat)]
-                   -> Unique
-                   -> BrokenBlock
-                   -> [BrokenBlock]
-adaptBlockToFormat formats unique
-                   block@(BrokenBlock ident entry stmts targets
-                                      (FinalCall next target formals
-                                                 actuals srt ret is_gc)) =
-    if format_formals == formals &&
-       format_srt == srt &&
-       format_is_gc == is_gc
-    then [block] -- Woohoo! This block got the continuation format it wanted
-    else [adaptor_block, revised_block]
-           -- This block didn't get the format it wanted for the
-           -- continuation, so we have to build an adaptor.
-    where
-      (ContFormat format_formals format_srt format_is_gc) =
-          maybe unknown_block id $ lookup next formats
-      unknown_block = panic "unknown block in adaptBlockToFormat"
-
-      revised_block = BrokenBlock ident entry stmts revised_targets revised_exit
-      revised_targets = adaptor_ident : delete next targets
-      revised_exit = FinalCall
-                       adaptor_ident -- The only part that changed
-                       target formals actuals srt ret is_gc
-
-      adaptor_block = mk_adaptor_block adaptor_ident
-                  (ContinuationEntry (map hintlessCmm formals) srt is_gc) next
-      adaptor_ident = BlockId unique
-
-      mk_adaptor_block :: BlockId -> BlockEntryInfo -> BlockId -> BrokenBlock
-      mk_adaptor_block ident entry next =
-          BrokenBlock ident entry [] [next] exit
-              where
-                exit = FinalJump
-                         (CmmLit (CmmLabel (mkReturnPtLabel (getUnique next))))
-                         (map formal_to_actual format_formals)
-
-                formal_to_actual (CmmHinted reg hint)
-                     = (CmmHinted (CmmReg (CmmLocal reg)) hint)
-                -- TODO: Check if NoHint is right.  We're
-                -- jumping to a C-- function not a foreign one
-                -- so it might always be right.
-adaptBlockToFormat _ _ block = [block]
-
------------------------------------------------------------------------------
--- | Convert from a BrokenBlock back to an equivalent CmmBasicBlock
--- Needed by liveness analysis
-cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
-cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
-    BasicBlock ident (stmts++exit_stmt)
-    where
-      exit_stmt =
-          case exit of
-            FinalBranch target -> [CmmBranch target]
-            FinalReturn arguments -> [CmmReturn arguments]
-            FinalJump target arguments -> [CmmJump target arguments]
-            FinalSwitch expr targets -> [CmmSwitch expr targets]
-            FinalCall branch_target call_target results arguments srt ret _ ->
-                [CmmCall call_target results arguments (CmmSafe srt) ret,
-                 CmmBranch branch_target]
-
------------------------------------------------------------------------------
--- | Build a mapping so we can lookup a 'BrokenBlock' by its 'BlockId'
-blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock
-blocksToBlockEnv blocks = mkBlockEnv $ map (\b -> (brokenBlockId b, b)) blocks
index 4e3879f..3d0d6fb 100644 (file)
@@ -1,15 +1,17 @@
-{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+{-# OPTIONS_GHC -XGADTs -XNoMonoLocalBinds #-}
 -- Norman likes local bindings
 -- If this module lives on I'd like to get rid of this flag in due course
 
+-- Todo: remove
+
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 module CmmBuildInfoTables
-    ( CAFSet, CAFEnv, CmmTopForInfoTables(..), cafAnal, localCAFInfo, mkTopCAFInfo
+    ( CAFSet, CAFEnv, cafAnal, localCAFInfo, mkTopCAFInfo
     , setInfoTableSRT, setInfoTableStackMap
     , TopSRT, emptySRT, srtToData
     , bundleCAFs
-    , finishInfoTables, lowerSafeForeignCalls
-    , cafTransfers, liveSlotTransfers
-    , extendEnvWithSafeForeignCalls, extendEnvsForSafeForeignCalls )
+    , lowerSafeForeignCalls
+    , cafTransfers, liveSlotTransfers)
 where
 
 #include "HsVersions.h"
@@ -17,39 +19,34 @@ where
 import Constants
 import Digraph
 import qualified Prelude as P
-import Prelude
+import Prelude hiding (succ)
 import Util (sortLe)
 
 import BlockId
 import Bitmap
 import CLabel
-import Cmm hiding (blockId)
-import CmmInfo
-import CmmProcPointZ
+import Cmm
+import CmmDecl
+import CmmExpr
 import CmmStackLayout
-import CmmTx
-import DFMonad
 import Module
 import FastString
 import ForeignCall
 import IdInfo
 import Data.List
 import Maybes
-import MkZipCfg
-import MkZipCfgCmm hiding (CmmAGraph, CmmBlock, CmmTopZ, CmmZ, CmmGraph)
+import MkGraph as M
 import Control.Monad
 import Name
+import OptimizationFuel
 import Outputable
 import SMRep
 import StgCmmClosure
 import StgCmmForeign
--- import StgCmmMonad
 import StgCmmUtils
 import UniqSupply
-import ZipCfg hiding (zip, unzip, last)
-import qualified ZipCfg as G
-import ZipCfgCmmRep
-import ZipDataflow
+
+import Compiler.Hoopl
 
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -155,21 +152,17 @@ live_ptrs oldByte slotEnv areaMap bid =
           -- pprPanic "CallAreas must not be live across function calls" (ppr bid <+> ppr c)
 
         slots :: SubAreaSet     -- The SubAreaSet for 'bid'
-        slots = expectJust "live_ptrs slots" $ lookupBlockEnv slotEnv bid
+        slots = expectJust "live_ptrs slots" $ mapLookup bid slotEnv
         youngByte = expectJust "live_ptrs bid_pos" $ Map.lookup (CallArea (Young bid)) areaMap
 
--- Construct the stack maps for the given procedure.
-setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmTopForInfoTables -> CmmTopForInfoTables 
-setInfoTableStackMap _ _ t@(NoInfoTable _) = t
-setInfoTableStackMap slotEnv areaMap t@(FloatingInfoTable _ bid updfr_off) =
-  updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t
+-- Construct the stack maps for a procedure _if_ it needs an infotable.
+-- When wouldn't a procedure need an infotable? If it is a procpoint that
+-- is not the successor of a call.
+setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmTop -> CmmTop
 setInfoTableStackMap slotEnv areaMap
-     t@(ProcInfoTable (CmmProc (CmmInfo _ _ _) _ _ ((_, Just updfr_off), _)) procpoints) =
-  case blockSetToList procpoints of
-    [bid] -> updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t
-    _ -> panic "setInfoTableStackMap: unexpected number of procpoints"
-           -- until we stop splitting the graphs at procpoints in the native path
-setInfoTableStackMap _ _ t = pprPanic "unexpected case for setInfoTableStackMap" (ppr t)
+     t@(CmmProc (TopInfo {stack_info=StackInfo {updfr_space = Just updfr_off}}) _ (CmmGraph {g_entry = eid})) =
+  updInfo (const (live_ptrs updfr_off slotEnv areaMap eid)) id t
+setInfoTableStackMap _ _ t = t
                  
 
 
@@ -193,17 +186,15 @@ type CAFEnv = BlockEnv CAFSet
 
 -- First, an analysis to find live CAFs.
 cafLattice :: DataflowLattice CAFSet
-cafLattice = DataflowLattice "live cafs" Map.empty add False
-  where add new old = if Map.size new' > Map.size old
-                      then aTx new'
-                      else noTx new'
-          where new' = new `Map.union` old
-
-cafTransfers :: BackwardTransfers Middle Last CAFSet
-cafTransfers = BackwardTransfers first middle last
+cafLattice = DataflowLattice "live cafs" Map.empty add
+  where add _ (OldFact old) (NewFact new) = case old `Map.union` new of
+                                              new' -> (changeIf $ Map.size new' > Map.size old, new')
+
+cafTransfers :: BwdTransfer CmmNode CAFSet
+cafTransfers = mkBTransfer3 first middle last
   where first  _ live = live
-        middle m live = foldExpDeepMiddle addCaf m live
-        last   l env  = foldExpDeepLast   addCaf l (joinOuts cafLattice env l)
+        middle m live = foldExpDeep addCaf m live
+        last   l live = foldExpDeep addCaf l (joinOutFacts cafLattice l live)
         addCaf e set = case e of
                CmmLit (CmmLabel c)              -> add c set
                CmmLit (CmmLabelOff c _)         -> add c set
@@ -211,11 +202,8 @@ cafTransfers = BackwardTransfers first middle last
                _ -> set
         add l s = if hasCAF l then Map.insert (cvtToClosureLbl l) () s else s
 
-type CafFix a = FuelMonad (BackwardFixedPoint Middle Last CAFSet a)
-cafAnal :: LGraph Middle Last -> FuelMonad CAFEnv
-cafAnal g = liftM zdfFpFacts (res :: CafFix ())
-  where res = zdfSolveFromL emptyBlockEnv "live CAF analysis" cafLattice
-                            cafTransfers (fact_bot cafLattice) g
+cafAnal :: CmmGraph -> FuelUniqSM CAFEnv
+cafAnal g = liftM snd $ dataflowPassBwd g [] $ analBwd cafLattice cafTransfers
 
 -----------------------------------------------------------------------
 -- Building the SRTs
@@ -249,7 +237,7 @@ addCAF caf srt =
       , elt_map  = Map.insert caf last (elt_map srt) }
     where last  = next_elt srt
 
-srtToData :: TopSRT -> CmmZ
+srtToData :: TopSRT -> Cmm
 srtToData srt = Cmm [CmmData RelocatableReadOnlyData (CmmDataLabel (lbl srt) : tbl)]
     where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt))
 
@@ -262,7 +250,7 @@ srtToData srt = Cmm [CmmData RelocatableReadOnlyData (CmmDataLabel (lbl srt) : t
 -- we make sure they're all close enough to the bottom of the table that the
 -- bitmap will be able to cover all of them.
 buildSRTs :: TopSRT -> Map CLabel CAFSet -> CAFSet ->
-             FuelMonad (TopSRT, Maybe CmmTopZ, C_SRT)
+             FuelUniqSM (TopSRT, Maybe CmmTop, C_SRT)
 buildSRTs topSRT topCAFMap cafs =
   do let liftCAF lbl () z = -- get CAFs for functions without static closures
            case Map.lookup lbl topCAFMap of Just cafs -> z `Map.union` cafs
@@ -305,7 +293,7 @@ buildSRTs topSRT topCAFMap cafs =
 -- Construct an SRT bitmap.
 -- Adapted from simpleStg/SRT.lhs, which expects Id's.
 procpointSRT :: CLabel -> Map CLabel Int -> [CLabel] ->
-                FuelMonad (Maybe CmmTopZ, C_SRT)
+                FuelUniqSM (Maybe CmmTop, C_SRT)
 procpointSRT _ _ [] =
  return (Nothing, NoC_SRT)
 procpointSRT top_srt top_table entries =
@@ -323,7 +311,7 @@ maxBmpSize :: Int
 maxBmpSize = widthInBits wordWidth `div` 2
 
 -- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
-to_SRT :: CLabel -> Int -> Int -> Bitmap -> FuelMonad (Maybe CmmTopZ, C_SRT)
+to_SRT :: CLabel -> Int -> Int -> Bitmap -> FuelUniqSM (Maybe CmmTop, C_SRT)
 to_SRT top_srt off len bmp
   | len > maxBmpSize || bmp == [fromIntegral srt_escape]
   = do id <- getUniqueM
@@ -344,13 +332,13 @@ to_SRT top_srt off len bmp
 --  keep its CAFs live.)
 -- Any procedure referring to a non-static CAF c must keep live
 -- any CAF that is reachable from c.
-localCAFInfo :: CAFEnv -> CmmTopZ -> Maybe (CLabel, CAFSet)
+localCAFInfo :: CAFEnv -> CmmTop -> Maybe (CLabel, CAFSet)
 localCAFInfo _      (CmmData _ _) = Nothing
-localCAFInfo cafEnv (CmmProc (CmmInfo _ _ infoTbl) top_l _ (_, LGraph entry _)) =
-  case infoTbl of
+localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) =
+  case info_tbl top_info of
     CmmInfoTable False _ _ _ ->
       Just (cvtToClosureLbl top_l,
-            expectJust "maybeBindCAFs" $ lookupBlockEnv cafEnv entry)
+            expectJust "maybeBindCAFs" $ mapLookup entry cafEnv)
     _ -> Nothing
 
 -- Once we have the local CAF sets for some (possibly) mutually
@@ -383,109 +371,43 @@ mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
 type StackLayout = [Maybe LocalReg]
 
 -- Bundle the CAFs used at a procpoint.
-bundleCAFs :: CAFEnv -> CmmTopForInfoTables -> (CAFSet, CmmTopForInfoTables)
-bundleCAFs cafEnv t@(ProcInfoTable _ procpoints) =
-  case blockSetToList procpoints of
-    [bid] -> (expectJust "bundleCAFs" (lookupBlockEnv cafEnv bid), t)
-    _     -> panic "setInfoTableStackMap: unexpect number of procpoints"
-             -- until we stop splitting the graphs at procpoints in the native path
-bundleCAFs cafEnv t@(FloatingInfoTable _ bid _) =
-  (expectJust "bundleCAFs " (lookupBlockEnv cafEnv bid), t)
-bundleCAFs _ t@(NoInfoTable _) = (Map.empty, t)
+bundleCAFs :: CAFEnv -> CmmTop -> (CAFSet, CmmTop)
+bundleCAFs cafEnv t@(CmmProc _ _ (CmmGraph {g_entry=entry})) =
+  (expectJust "bundleCAFs" (mapLookup entry cafEnv), t)
+bundleCAFs _ t = (Map.empty, t)
 
 -- Construct the SRTs for the given procedure.
-setInfoTableSRT :: Map CLabel CAFSet -> TopSRT -> (CAFSet, CmmTopForInfoTables) ->
-                   FuelMonad (TopSRT, [CmmTopForInfoTables])
-setInfoTableSRT topCAFMap topSRT (cafs, t@(ProcInfoTable _ procpoints)) =
-  case blockSetToList procpoints of
-    [_] -> setSRT cafs topCAFMap topSRT t
-    _   -> panic "setInfoTableStackMap: unexpect number of procpoints"
-           -- until we stop splitting the graphs at procpoints in the native path
-setInfoTableSRT topCAFMap topSRT (cafs, t@(FloatingInfoTable _ _ _)) =
+setInfoTableSRT :: Map CLabel CAFSet -> TopSRT -> (CAFSet, CmmTop) ->
+                   FuelUniqSM (TopSRT, [CmmTop])
+setInfoTableSRT topCAFMap topSRT (cafs, t) =
   setSRT cafs topCAFMap topSRT t
-setInfoTableSRT _ topSRT (_, t@(NoInfoTable _)) = return (topSRT, [t])
 
 setSRT :: CAFSet -> Map CLabel CAFSet -> TopSRT ->
-          CmmTopForInfoTables -> FuelMonad (TopSRT, [CmmTopForInfoTables])
+          CmmTop -> FuelUniqSM (TopSRT, [CmmTop])
 setSRT cafs topCAFMap topSRT t =
   do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap cafs
      let t' = updInfo id (const srt) t
      case cafTable of
-       Just tbl -> return (topSRT, [t', NoInfoTable tbl])
+       Just tbl -> return (topSRT, [t', tbl])
        Nothing  -> return (topSRT, [t'])
 
-updInfo :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) ->
-           CmmTopForInfoTables -> CmmTopForInfoTables 
-updInfo toVars toSrt (ProcInfoTable (CmmProc info top_l top_args g) procpoints) =
-  ProcInfoTable (CmmProc (updInfoTbl toVars toSrt info) top_l top_args g) procpoints
-updInfo toVars toSrt (FloatingInfoTable info bid updfr_off) =
-  FloatingInfoTable (updInfoTbl toVars toSrt info) bid updfr_off
-updInfo _ _ (NoInfoTable _) = panic "can't update NoInfoTable"
-updInfo _ _ _ = panic "unexpected arg to updInfo"
-
-updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfo -> CmmInfo 
-updInfoTbl toVars toSrt (CmmInfo gc upd_fr (CmmInfoTable s p t typeinfo))
-  = CmmInfo gc upd_fr (CmmInfoTable s p t typeinfo')
+updInfo :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmTop -> CmmTop
+updInfo toVars toSrt (CmmProc top_info top_l g) =
+  CmmProc (top_info {info_tbl=updInfoTbl toVars toSrt (info_tbl top_info)}) top_l g
+updInfo _ _ t = t
+
+updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable
+updInfoTbl toVars toSrt (CmmInfoTable s p t typeinfo)
+  = CmmInfoTable s p t typeinfo'
     where typeinfo' = case typeinfo of
             t@(ConstrInfo _ _ _)    -> t
             (FunInfo    c s a d e)  -> FunInfo c (toSrt s) a d e
             (ThunkInfo  c s)        -> ThunkInfo c (toSrt s)
             (ThunkSelectorInfo x s) -> ThunkSelectorInfo x (toSrt s)
             (ContInfo v s)          -> ContInfo (toVars v) (toSrt s)
-updInfoTbl _ _ t@(CmmInfo _ _ CmmNonInfoTable) = t
+updInfoTbl _ _ t@CmmNonInfoTable = t
   
--- Lower the CmmTopForInfoTables type down to good old CmmTopZ
--- by emitting info tables as data where necessary.
-finishInfoTables :: CmmTopForInfoTables -> IO [CmmTopZ]
-finishInfoTables (NoInfoTable t) = return [t]
-finishInfoTables (ProcInfoTable p _) = return [p]
-finishInfoTables (FloatingInfoTable (CmmInfo _ _ infotbl) bid _) =
-  do uniq_supply <- mkSplitUniqSupply 'i'
-     return $ mkBareInfoTable (retPtLbl bid) (uniqFromSupply uniq_supply) infotbl
-
 ----------------------------------------------------------------
--- Safe foreign calls:
--- Our analyses capture the dataflow facts at block boundaries, but we need
--- to extend the CAF and live-slot analyses to safe foreign calls as well,
--- which show up as middle nodes.
-extendEnvWithSafeForeignCalls ::
-  BackwardTransfers Middle Last a -> BlockEnv a -> CmmGraph -> BlockEnv a
-extendEnvWithSafeForeignCalls transfers env g = fold_blocks block env g
-  where block b z =
-          tail (bt_last_in transfers l (lookup env)) z head
-           where (head, last) = goto_end (G.unzip b)
-                 l = case last of LastOther l -> l
-                                  LastExit -> panic "extendEnvs lastExit"
-        tail _ z (ZFirst _) = z
-        tail fact env (ZHead h m@(MidForeignCall (Safe bid _ _) _ _ _)) =
-          tail (mid m fact) (extendBlockEnv env bid fact) h
-        tail fact env (ZHead h m) = tail (mid m fact) env h
-        lookup map k = expectJust "extendEnvWithSafeFCalls" $ lookupBlockEnv map k
-        mid = bt_middle_in transfers
-
-
-extendEnvsForSafeForeignCalls :: CAFEnv -> SlotEnv -> CmmGraph -> (CAFEnv, SlotEnv)
-extendEnvsForSafeForeignCalls cafEnv slotEnv g =
-  fold_blocks block (cafEnv, slotEnv) g
-    where block b z =
-            tail ( bt_last_in cafTransfers      l (lookupFn cafEnv)
-                 , bt_last_in liveSlotTransfers l (lookupFn slotEnv))
-                 z head
-             where (head, last) = goto_end (G.unzip b)
-                   l = case last of LastOther l -> l
-                                    LastExit -> panic "extendEnvs lastExit"
-          tail _ z (ZFirst _) = z
-          tail lives@(cafs, slots) (cafEnv, slotEnv)
-               (ZHead h m@(MidForeignCall (Safe bid _ _) _ _ _)) =
-            let slots'   = removeLiveSlotDefs slots m
-                slotEnv' = extendBlockEnv slotEnv bid slots'
-                cafEnv'  = extendBlockEnv cafEnv  bid cafs
-            in  tail (upd lives m) (cafEnv', slotEnv') h
-          tail lives z (ZHead h m) = tail (upd lives m) z h
-          lookupFn map k = expectJust "extendEnvsForSafeFCalls" $ lookupBlockEnv map k
-          upd (cafs, slots) m =
-            (bt_middle_in cafTransfers m cafs, bt_middle_in liveSlotTransfers m slots)
-
 -- Safe foreign calls: We need to insert the code that suspends and resumes
 -- the thread before and after a safe foreign call.
 -- Why do we do this so late in the pipeline?
@@ -502,96 +424,72 @@ extendEnvsForSafeForeignCalls cafEnv slotEnv g =
 -- a procpoint. The following datatype captures the information
 -- needed to generate the infotables along with the Cmm data and procedures.
 
-data CmmTopForInfoTables
-  = NoInfoTable       CmmTopZ  -- must be CmmData
-  | ProcInfoTable     CmmTopZ BlockSet -- CmmProc; argument is its set of procpoints
-  | FloatingInfoTable CmmInfo BlockId UpdFrameOffset
-instance Outputable CmmTopForInfoTables where
-  ppr (NoInfoTable t) = text "NoInfoTable: " <+> ppr t
-  ppr (ProcInfoTable t bids) = text "ProcInfoTable: " <+> ppr t <+> ppr bids
-  ppr (FloatingInfoTable info bid upd) =
-    text "FloatingInfoTable: " <+> ppr info <+> ppr bid <+> ppr upd
-
--- The `safeState' record collects the info we update while lowering the
--- safe foreign calls in the graph.
-data SafeState = State { s_blocks    :: BlockEnv CmmBlock
-                       , s_pps       :: ProcPointSet
-                       , s_safeCalls :: [CmmTopForInfoTables]}
-
-lowerSafeForeignCalls
-  :: [[CmmTopForInfoTables]] -> CmmTopZ -> FuelMonad [[CmmTopForInfoTables]]
-lowerSafeForeignCalls rst t@(CmmData _ _) = return $ [NoInfoTable t] : rst
-lowerSafeForeignCalls rst (CmmProc info l args (off, g@(LGraph entry _))) = do
-  let init = return $ State emptyBlockEnv emptyBlockSet []
-  let block b@(Block bid _) z = do
-        state@(State {s_pps = ppset, s_blocks = blocks}) <- z
-        let ppset' = if bid == entry then extendBlockSet ppset bid else ppset
-            state' = state { s_pps = ppset' }
-        if hasSafeForeignCall b
-         then lowerSafeCallBlock state' b
-         else return (state' { s_blocks = insertBlock b blocks })
-  State blocks' g_procpoints safeCalls <- fold_blocks block init g
-  let proc = (CmmProc info l args (off, LGraph entry blocks'))
-      procTable = case off of
-                    (_, Just _) -> [ProcInfoTable proc g_procpoints]
-                    _ -> [NoInfoTable proc] -- not a successor of a call
-  return $ safeCalls : procTable : rst
-
--- Check for foreign calls -- if none, then we can avoid copying the block.
-hasSafeForeignCall :: CmmBlock -> Bool
-hasSafeForeignCall (Block _ t) = tail t
-  where tail (ZTail (MidForeignCall (Safe _ _ _) _ _ _) _) = True
-        tail (ZTail _ t) = tail t
-        tail (ZLast _)   = False
-
--- Lower each safe call in the block, update the CAF and slot environments
--- to include each of those calls, and insert the new block in the blockEnv.
-lowerSafeCallBlock :: SafeState-> CmmBlock -> FuelMonad SafeState
-lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last))
-  where (head, last) = goto_end (G.unzip b)
-        tail s b@(ZBlock (ZFirst _) _) =
-          do state <- s
-             return $ state { s_blocks = insertBlock (G.zip b) (s_blocks state) }
-        tail s (ZBlock (ZHead h m@(MidForeignCall (Safe bid updfr_off _) _ _ _)) t) =
-          do state <- s
-             let state' = state
-                   { s_safeCalls = FloatingInfoTable emptyContInfoTable bid updfr_off :
-                                     s_safeCalls state }
-             (state'', t') <- lowerSafeForeignCall state' m t
-             tail (return state'') (ZBlock h t')
-        tail s (ZBlock (ZHead h m) t) = tail s (ZBlock h (ZTail m t))
-           
+-- JD: Why not do this while splitting procedures?
+lowerSafeForeignCalls :: AreaMap -> CmmTop -> FuelUniqSM CmmTop
+lowerSafeForeignCalls _ t@(CmmData _ _) = return t
+lowerSafeForeignCalls areaMap (CmmProc info l g@(CmmGraph {g_entry=entry})) = do
+  let block b mblocks = mblocks >>= lowerSafeCallBlock entry areaMap b
+  blocks <- foldGraphBlocks block (return mapEmpty) g
+  return $ CmmProc info l (ofBlockMap entry blocks)
+
+-- If the block ends with a safe call in the block, lower it to an unsafe
+-- call (with appropriate saves and restores before and after).
+lowerSafeCallBlock :: BlockId -> AreaMap -> CmmBlock -> BlockEnv CmmBlock
+                              -> FuelUniqSM (BlockEnv CmmBlock)
+lowerSafeCallBlock entry areaMap b blocks =
+  case blockToNodeList b of
+    (JustC (CmmEntry id), m, JustC l@(CmmForeignCall {})) -> lowerSafeForeignCall entry areaMap blocks id m l
+    _                                                    -> return $ insertBlock b blocks
 
 -- Late in the code generator, we want to insert the code necessary
 -- to lower a safe foreign call to a sequence of unsafe calls.
-lowerSafeForeignCall ::
-  SafeState -> Middle -> ZTail Middle Last -> FuelMonad (SafeState, ZTail Middle Last)
-lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _ interruptible) _ _ _) tail = do
-    let newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
+lowerSafeForeignCall :: BlockId -> AreaMap -> BlockEnv CmmBlock -> BlockId -> [CmmNode O O] -> CmmNode O C
+                                -> FuelUniqSM (BlockEnv CmmBlock)
+lowerSafeForeignCall entry areaMap blocks bid m
+    (CmmForeignCall {tgt=tgt, res=rs, args=as, succ=succ, updfr = updfr_off, intrbl = intrbl}) =
+ do let newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
     -- Both 'id' and 'new_base' are KindNonPtr because they're
     -- RTS-only objects and are not subject to garbage collection
     id <- newTemp bWord
     new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
-    let (caller_save, caller_load) = callerSaveVolatileRegs 
+    let (caller_save, caller_load) = callerSaveVolatileRegs
     load_tso <- newTemp gcWord -- TODO FIXME NOW
-    let suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread")))
-        resumeThread  = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread")))
-        suspend = mkStore (CmmReg spReg) (CmmLit (CmmBlock infotable)) <*>
-                  saveThreadState <*>
-                  caller_save <*>
+    load_stack <- newTemp gcWord -- TODO FIXME NOW
+    let (<**>) = (M.<*>)
+    let suspendThread = foreignLbl "suspendThread"
+        resumeThread  = foreignLbl "resumeThread"
+        foreignLbl name = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit name)))
+        suspend = saveThreadState <**>
+                  caller_save <**>
                   mkUnsafeCall (ForeignTarget suspendThread
-                                  (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint]))
-                    -- XXX Not sure if the size of the CmmInt is correct
-                    [id] [CmmReg (CmmGlobal BaseReg), CmmLit (CmmInt (fromIntegral (fromEnum interruptible)) wordWidth)]
-        resume = mkUnsafeCall (ForeignTarget resumeThread
-                                  (ForeignConvention CCallConv [AddrHint] [AddrHint]))
-                    [new_base] [CmmReg (CmmLocal id)] <*>
-                 -- Assign the result to BaseReg: we
-                 -- might now have a different Capability!
-                 mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*>
-                 caller_load <*>
-                 loadThreadState load_tso
-    Graph tail' blocks' <-
-      liftUniq (graphOfAGraph (suspend <*> mkMiddle m <*> resume <*> mkZTail tail))
-    return (state {s_blocks = s_blocks state `plusBlockEnv` blocks'}, tail')
-lowerSafeForeignCall _ _ _ = panic "lowerSafeForeignCall was passed something else"
+                                (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint]))
+                               [id] [CmmReg (CmmGlobal BaseReg), CmmLit (CmmInt (fromIntegral (fromEnum intrbl)) wordWidth)]
+        midCall = mkUnsafeCall tgt rs as
+        resume  = mkUnsafeCall (ForeignTarget resumeThread
+                                (ForeignConvention CCallConv [AddrHint] [AddrHint]))
+                     [new_base] [CmmReg (CmmLocal id)] <**>
+                  -- Assign the result to BaseReg: we
+                  -- might now have a different Capability!
+                  mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <**>
+                  caller_load <**>
+                  loadThreadState load_tso load_stack
+        -- We have to save the return value on the stack because its next use
+        -- may appear in a different procedure due to procpoint splitting...
+        saveRetVals = foldl (<**>) emptyAGraph $ map (M.mkMiddle . spill) rs
+        spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r)
+        regSlot r@(LocalReg _ _) = CmmRegOff (CmmGlobal Sp) (sp_off - offset)
+          where offset = w + expectJust "lowerForeign" (Map.lookup (RegSlot r) areaMap)
+                sp_off = wORD_SIZE + expectJust "lowerForeign" (Map.lookup (CallArea area) areaMap)
+                area = if succ == entry then Old else Young succ
+                w = widthInBytes $ typeWidth $ localRegType r
+        -- Note: The successor must be a procpoint, and we have already split,
+        --       so we use a jump, not a branch.
+        succLbl = CmmLit (CmmLabel (infoTblLbl succ))
+        jump = CmmCall { cml_target  = succLbl, cml_cont = Nothing
+                       , cml_args    = widthInBytes wordWidth ,cml_ret_args = 0
+                       , cml_ret_off = updfr_off}
+    graph' <- liftUniq $ labelAGraph bid $ catAGraphs (map M.mkMiddle m) <**>
+                                           suspend <**> midCall <**>
+                                           resume  <**> saveRetVals <**> M.mkLast jump
+    return $ blocks `mapUnion` toBlockMap graph'
+lowerSafeForeignCall _ _ _ _ _ _ = panic "lowerSafeForeignCall was passed something else"
index 7bfdf84..372562c 100644 (file)
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+-- Norman likes local bindings
+-- If this module lives on I'd like to get rid of this flag in due course
 module CmmCPS (
   -- | Converts C-- with full proceedures and parameters
   -- to a CPS transformed C-- with the stack made manifest.
-  cmmCPS
+  -- Well, sort of.
+  protoCmmCPS
 ) where
 
-#include "HsVersions.h"
-
-import BlockId
+import CLabel
 import Cmm
-import CmmLint
-import PprCmm
-
-import CmmLive
-import CmmBrokenBlock
+import CmmDecl
+import CmmBuildInfoTables
+import CmmCommonBlockElim
 import CmmProcPoint
-import CmmCallConv
-import CmmCPSGen
-import CmmUtils
-
-import ClosureInfo
-import CLabel
-import SMRep
-import Constants
+import CmmSpillReload
+import CmmStackLayout
+import OptimizationFuel
 
 import DynFlags
 import ErrUtils
-import Maybes
-import Outputable
-import UniqSupply
-import UniqSet
-import Unique
-
+import HscTypes
+import Data.Maybe
 import Control.Monad
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Outputable
+import StaticFlags
 
 -----------------------------------------------------------------------------
 -- |Top level driver for the CPS pass
 -----------------------------------------------------------------------------
-cmmCPS :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
-       -> [Cmm]    -- ^ Input C-- with Proceedures
-       -> IO [Cmm] -- ^ Output CPS transformed C--
-cmmCPS dflags cmm_with_calls
-  = do { when (dopt Opt_DoCmmLinting dflags) $
-              do showPass dflags "CmmLint"
-                 case firstJusts $ map cmmLint cmm_with_calls of
-                   Just err -> do printDump err
-                                  ghcExit dflags 1
-                   Nothing  -> return ()
-       ; showPass dflags "CPS"
-
-  -- TODO: more lint checking
-  --        check for use of branches to non-existant blocks
-  --        check for use of Sp, SpLim, R1, R2, etc.
-
-       ; uniqSupply <- mkSplitUniqSupply 'p'
-       ; let supplies = listSplitUniqSupply uniqSupply
-       ; let cpsd_cmm = zipWith doCpsProc supplies cmm_with_calls
-
-       ; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms cpsd_cmm)
-
-  -- TODO: add option to dump Cmm to file
-
-       ; return cpsd_cmm }
-
-
------------------------------------------------------------------------------
--- |CPS a single CmmTop (proceedure)
--- Only 'CmmProc' are transformed 'CmmData' will be left alone.
------------------------------------------------------------------------------
-
-doCpsProc :: UniqSupply -> Cmm -> Cmm
-doCpsProc s (Cmm c) 
-  = Cmm $ concat $ zipWith cpsProc (listSplitUniqSupply s) c
-
-cpsProc :: UniqSupply 
-        -> CmmTop     -- ^Input procedure
-        -> [CmmTop]   -- ^Output procedures; 
-                     --   a single input procedure is converted to
-                     --   multiple output procedures
-
--- Data blocks don't need to be CPS transformed
-cpsProc _ proc@(CmmData _ _) = [proc]
-
--- Empty functions just don't work with the CPS algorithm, but
--- they don't need the transformation anyway so just output them directly
-cpsProc _ proc@(CmmProc _ _ _ (ListGraph []))
-  = pprTrace "cpsProc: unexpected empty proc" (ppr proc) [proc]
-
--- CPS transform for those procs that actually need it
--- The plan is this:
---
---   * Introduce a stack-check block as the first block
---   * The first blocks gets a FunctionEntry; the rest are ControlEntry
---   * Now break each block into a bunch of blocks (at call sites); 
---     all but the first will be ContinuationEntry
---
-cpsProc uniqSupply (CmmProc info ident params (ListGraph blocks)) = cps_procs
-    where
-      -- We need to be generating uniques for several things.
-      -- We could make this function monadic to handle that
-      -- but since there is no other reason to make it monadic,
-      -- we instead will just split them all up right here.
-      (uniqSupply1, uniqSupply2) = splitUniqSupply uniqSupply
-      uniques :: [[Unique]]
-      uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply1
-      (stack_check_block_unique:stack_use_unique:adaptor_uniques) :
-       block_uniques = uniques
-      proc_uniques = map (map (map uniqsFromSupply . listSplitUniqSupply) . listSplitUniqSupply) $ listSplitUniqSupply uniqSupply2
-
-      stack_use = CmmLocal (LocalReg stack_use_unique (cmmRegType spReg))
-      stack_check_block_id = BlockId stack_check_block_unique
-      stack_check_block = make_stack_check stack_check_block_id info stack_use (blockId $ head blocks)
-
-      forced_blocks = stack_check_block : blocks
-
-      CmmInfo maybe_gc_block_id update_frame _ = info
-
-      -- Break the block at each function call.
-      -- The part after the function call will have to become a continuation.
-      broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
-      broken_blocks =
-          (\x -> (concatMap fst x, concatMap snd x)) $
-          zipWith3 (breakBlock (maybeToList maybe_gc_block_id))
-                     block_uniques
-                     forced_blocks
-                     (FunctionEntry info ident params :
-                      repeat ControlEntry)
-
-      f' = selectContinuations (fst broken_blocks)
-      broken_blocks' = map (makeContinuationEntries f') $
-                       concat $
-                       zipWith (adaptBlockToFormat f')
-                               adaptor_uniques
-                               (snd broken_blocks)
-
-      -- Calculate live variables for each broken block.
-      --
-      -- Nothing can be live on entry to the first block
-      -- so we could take the tail, but for now we wont
-      -- to help future proof the code.
-      live :: BlockEntryLiveness
-      live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks'
-
-      -- Calculate which blocks must be made into full fledged procedures.
-      proc_points :: UniqSet BlockId
-      proc_points = calculateProcPoints broken_blocks'
-
-      -- Construct a map so we can lookup a broken block by its 'BlockId'.
-      block_env :: BlockEnv BrokenBlock
-      block_env = blocksToBlockEnv broken_blocks'
-
-      -- Group the blocks into continuations based on the set of proc-points.
-      continuations :: [Continuation (Either C_SRT CmmInfo)]
-      continuations = map (gatherBlocksIntoContinuation live proc_points block_env)
-                          (uniqSetToList proc_points)
-
-      -- Select the stack format on entry to each continuation.
-      -- Return the max stack offset and an association list
-      --
-      -- This is an association list instead of a UniqFM because
-      -- CLabel's don't have a 'Uniqueable' instance.
-      formats :: [(CLabel,              -- key
-                   (CmmFormals,         -- arguments
-                    Maybe CLabel,       -- label in top slot
-                    [Maybe LocalReg]))] -- slots
-      formats = selectContinuationFormat live continuations
-
-      -- Do a little meta-processing on the stack formats such as
-      -- getting the individual frame sizes and the maximum frame size
-      formats' :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
-      formats'@(_, _, format_list) = processFormats formats update_frame continuations
-
-      -- Update the info table data on the continuations with
-      -- the selected stack formats.
-      continuations' :: [Continuation CmmInfo]
-      continuations' = map (applyContinuationFormat format_list) continuations
-
-      -- Do the actual CPS transform.
-      cps_procs :: [CmmTop]
-      cps_procs = zipWith (continuationToProc formats' stack_use) proc_uniques continuations'
-
-make_stack_check :: BlockId -> CmmInfo -> CmmReg -> BlockId
-                 -> GenBasicBlock CmmStmt
-make_stack_check stack_check_block_id info stack_use next_block_id =
-    BasicBlock stack_check_block_id $
-                   check_stmts ++ [CmmBranch next_block_id]
-    where
-      check_stmts =
-          case info of
-            -- If we are given a stack check handler,
-            -- then great, well check the stack.
-            CmmInfo (Just gc_block) _ _
-                -> [CmmCondBranch
-                    (CmmMachOp (MO_U_Lt (typeWidth (cmmRegType spReg)))
-                     [CmmReg stack_use, CmmReg spLimReg])
-                    gc_block]
-            -- If we aren't given a stack check handler,
-            -- then humph! we just won't check the stack for them.
-            CmmInfo Nothing _ _
-                -> []
------------------------------------------------------------------------------
-
-collectNonProcPointTargets ::
-    UniqSet BlockId -> BlockEnv BrokenBlock
-    -> UniqSet BlockId -> [BlockId] -> UniqSet BlockId
-collectNonProcPointTargets proc_points blocks current_targets new_blocks =
-    if sizeUniqSet current_targets == sizeUniqSet new_targets
-       then current_targets
-       else foldl
-                (collectNonProcPointTargets proc_points blocks)
-                new_targets
-                (map (:[]) targets)
-    where
-      blocks' = map (lookupWithDefaultBEnv blocks (panic "TODO")) new_blocks
-      targets =
-        -- Note the subtlety that since the extra branch after a call
-        -- will always be to a block that is a proc-point,
-        -- this subtraction will always remove that case
-        uniqSetToList $ (unionManyUniqSets $ map (mkUniqSet . brokenBlockTargets) blocks')
-                          `minusUniqSet` proc_points
-        -- TODO: remove redundant uniqSetToList
-      new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
-
--- TODO: insert proc point code here
---  * Branches and switches to proc points may cause new blocks to be created
---    (or proc points could leave behind phantom blocks that just jump to them)
---  * Proc points might get some live variables passed as arguments
-
-gatherBlocksIntoContinuation ::
-    BlockEntryLiveness -> UniqSet BlockId -> BlockEnv BrokenBlock
-    -> BlockId -> Continuation (Either C_SRT CmmInfo)
-gatherBlocksIntoContinuation live proc_points blocks start =
-  Continuation info_table clabel params is_gc_cont body
-    where
-      children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) [start]) `minusUniqSet` (unitUniqSet start)
-      start_block = lookupWithDefaultBEnv blocks unknown_block start
-      children_blocks = map (lookupWithDefaultBEnv blocks unknown_block) (uniqSetToList children)
-      unknown_block :: a    -- Used at more than one type
-      unknown_block = panic "unknown block in gatherBlocksIntoContinuation"
-      body = start_block : children_blocks
-
-      -- We can't properly annotate the continuation's stack parameters
-      -- at this point because this is before stack selection
-      -- but we want to keep the C_SRT around so we use 'Either'.
-      info_table = case start_block_entry of
-                     FunctionEntry info _ _ -> Right info
-                     ContinuationEntry _ srt _ -> Left srt
-                     ControlEntry -> Right (CmmInfo Nothing Nothing CmmNonInfoTable)
-
-      is_gc_cont = case start_block_entry of
-                     FunctionEntry _ _ _ -> False
-                     ContinuationEntry _ _ gc_cont -> gc_cont
-                     ControlEntry -> False
-
-      start_block_entry = brokenBlockEntry start_block
-      clabel = case start_block_entry of
-                 FunctionEntry _ label _ -> label
-                 _ -> mkReturnPtLabel $ getUnique start
-      params = case start_block_entry of
-                 FunctionEntry _ _ args -> args
-                 ContinuationEntry args _ _ -> args
-                 ControlEntry ->
-                     uniqSetToList $
-                     lookupWithDefaultBEnv live unknown_block start
-                     -- it's a proc-point, pass lives in parameter registers
-
---------------------------------------------------------------------------------
--- For now just select the continuation orders in the order they are in the set with no gaps
-
-selectContinuationFormat :: BlockEnv CmmLive
-                  -> [Continuation (Either C_SRT CmmInfo)]
-                  -> [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]
-selectContinuationFormat live continuations =
-    map (\c -> (continuationLabel c, selectContinuationFormat' c)) continuations
-    where
-      -- User written continuations
-      selectContinuationFormat' (Continuation
-                          (Right (CmmInfo _ _ (CmmInfoTable _ _ _ (ContInfo format _))))
-                          label formals _ _) =
-          (formals, Just label, format)
-      -- Either user written non-continuation code
-      -- or CPS generated proc-points
-      selectContinuationFormat' (Continuation (Right _) _ formals _ _) =
-          (formals, Nothing, [])
-      -- CPS generated continuations
-      selectContinuationFormat' (Continuation (Left _) label formals _ blocks) =
-          -- TODO: assumes the first block is the entry block
-          let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
-          in (formals,
-              Just label,
-              map Just $ uniqSetToList $
-              lookupWithDefaultBEnv live unknown_block ident)
-
-      unknown_block = panic "unknown BlockId in selectContinuationFormat"
-
-processFormats :: [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]
-               -> Maybe UpdateFrame
-               -> [Continuation (Either C_SRT CmmInfo)]
-               -> (WordOff, WordOff, [(CLabel, ContinuationFormat)])
-processFormats formats update_frame continuations =
-    (max_size + update_frame_size, update_frame_size, formats')
-    where
-      max_size = maximum $
-                 0 : map (continuationMaxStack formats') continuations
-      formats' = map make_format formats
-      make_format (label, (formals, top, stack)) =
-          (label,
-           ContinuationFormat {
-             continuation_formals = formals,
-             continuation_label = top,
-             continuation_frame_size = stack_size stack +
-                                if isJust top
-                                then label_size
-                                else 0,
-             continuation_stack = stack })
-
-      update_frame_size = case update_frame of
-                            Nothing -> 0
-                            (Just (UpdateFrame _ args))
-                                -> label_size + update_size args
-
-      update_size [] = 0
-      update_size (expr:exprs) = width + update_size exprs
-          where
-            width = (widthInBytes $ typeWidth $ cmmExprType expr) `quot` wORD_SIZE
-            -- TODO: it would be better if we had a machRepWordWidth
-
-      -- TODO: get rid of "+ 1" etc.
-      label_size = 1 :: WordOff
-
-      stack_size [] = 0
-      stack_size (Nothing:formats) = 1 + stack_size formats -- one dead word
-      stack_size (Just reg:formats) = width + stack_size formats
-          where
-            width = (widthInBytes $ typeWidth $ localRegType reg) `quot` wORD_SIZE
-            -- TODO: it would be better if we had a machRepWordWidth
-
-continuationMaxStack :: [(CLabel, ContinuationFormat)]
-                     -> Continuation a
-                     -> WordOff
-continuationMaxStack _ (Continuation _ _ _ True _) = 0
-continuationMaxStack formats (Continuation _ label _ False blocks) =
-    max_arg_size + continuation_frame_size stack_format
-    where
-      stack_format = maybe unknown_format id $ lookup label formats
-      unknown_format = panic "Unknown format in continuationMaxStack"
-
-      max_arg_size = maximum $ 0 : map block_max_arg_size blocks
-
-      block_max_arg_size block =
-          maximum (final_arg_size (brokenBlockExit block) :
-                   map stmt_arg_size (brokenBlockStmts block))
-
-      final_arg_size (FinalReturn args) =
-          argumentsSize (cmmExprType . hintlessCmm) args
-      final_arg_size (FinalJump _ args) =
-          argumentsSize (cmmExprType . hintlessCmm) args
-      final_arg_size (FinalCall _    _ _ _    _ _ True) = 0
-      final_arg_size (FinalCall next _ _ args _ _ False) =
-          -- We have to account for the stack used when we build a frame
-          -- for the *next* continuation from *this* continuation
-          argumentsSize (cmmExprType . hintlessCmm) args +
-          continuation_frame_size next_format
-          where 
-            next_format = maybe unknown_format id $ lookup next' formats
-            next' = mkReturnPtLabel $ getUnique next
-
-      final_arg_size _ = 0
-
-      stmt_arg_size (CmmJump _ args) =
-          argumentsSize (cmmExprType . hintlessCmm) args
-      stmt_arg_size (CmmCall _ _ _ (CmmSafe _) _) =
-          panic "Safe call in processFormats"
-      stmt_arg_size (CmmReturn _) =
-          panic "CmmReturn in processFormats"
-      stmt_arg_size _ = 0
-
------------------------------------------------------------------------------
-applyContinuationFormat :: [(CLabel, ContinuationFormat)]
-                 -> Continuation (Either C_SRT CmmInfo)
-                 -> Continuation CmmInfo
-
--- User written continuations
-applyContinuationFormat formats
-   (Continuation (Right (CmmInfo gc update_frame
-                             (CmmInfoTable clos prof tag (ContInfo _ srt))))
-                 label formals is_gc blocks) =
-    Continuation (CmmInfo gc update_frame (CmmInfoTable clos prof tag (ContInfo format srt)))
-                 label formals is_gc blocks
-    where
-      format = continuation_stack $ maybe unknown_block id $ lookup label formats
-      unknown_block = panic "unknown BlockId in applyContinuationFormat"
-
--- Either user written non-continuation code or CPS generated proc-point
-applyContinuationFormat _ (Continuation
-                          (Right info) label formals is_gc blocks) =
-    Continuation info label formals is_gc blocks
-
--- CPS generated continuations
-applyContinuationFormat formats (Continuation
-                          (Left srt) label formals is_gc blocks) =
-    Continuation (CmmInfo gc Nothing (CmmInfoTable undefined prof tag (ContInfo (continuation_stack $ format) srt)))
-                 label formals is_gc blocks
-    where
-      gc = Nothing -- Generated continuations never need a stack check
-      -- TODO prof: this is the same as the current implementation
-      -- but I think it could be improved
-      prof = ProfilingInfo zeroCLit zeroCLit
-      tag = rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
-      format = maybe unknown_block id $ lookup label formats
-      unknown_block = panic "unknown BlockId in applyContinuationFormat"
-
+-- There are two complications here:
+-- 1. We need to compile the procedures in two stages because we need
+--    an analysis of the procedures to tell us what CAFs they use.
+--    The first stage returns a map from procedure labels to CAFs,
+--    along with a closure that will compute SRTs and attach them to
+--    the compiled procedures.
+--    The second stage is to combine the CAF information into a top-level
+--    CAF environment mapping non-static closures to the CAFs they keep live,
+--    then pass that environment to the closures returned in the first
+--    stage of compilation.
+-- 2. We need to thread the module's SRT around when the SRT tables
+--    are computed for each procedure.
+--    The SRT needs to be threaded because it is grown lazily.
+protoCmmCPS  :: HscEnv -- Compilation env including
+                       -- dynamic flags: -dcmm-lint -ddump-cps-cmm
+             -> (TopSRT, [Cmm])    -- SRT table and accumulating list of compiled procs
+             -> Cmm                -- Input C-- with Procedures
+             -> IO (TopSRT, [Cmm]) -- Output CPS transformed C--
+protoCmmCPS hsc_env (topSRT, rst) (Cmm tops) =
+  do let dflags = hsc_dflags hsc_env
+     showPass dflags "CPSZ"
+     (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops
+     let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
+     (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
+     let cmms = Cmm (reverse (concat tops))
+     dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
+     return (topSRT, cmms : rst)
+
+{- [Note global fuel]
+~~~~~~~~~~~~~~~~~~~~~
+The identity and the last pass are stored in
+mutable reference cells in an 'HscEnv' and are
+global to one compiler session.
+-}
+
+cpsTop :: HscEnv -> CmmTop -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmTop)])
+cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, p)])
+cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
+    do
+       -- Why bother doing it this early?
+       -- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
+       --                       (dualLivenessWithInsertion callPPs) g
+       -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
+       -- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
+       --                   (removeDeadAssignmentsAndReloads callPPs) g
+       dump Opt_D_dump_cmmz "Pre common block elimination" g
+       g <- return $ elimCommonBlocks g
+       dump Opt_D_dump_cmmz "Post common block elimination" g
+
+       -- Any work storing block Labels must be performed _after_ elimCommonBlocks
+
+       ----------- Proc points -------------------
+       let callPPs = callProcPoints g
+       procPoints <- run $ minimalProcPointSet callPPs g
+       g <- run $ addProcPointProtocols callPPs procPoints g
+       dump Opt_D_dump_cmmz "Post Proc Points Added" g
+
+       ----------- Spills and reloads -------------------
+       g     <- 
+              -- pprTrace "pre Spills" (ppr g) $
+                dual_rewrite Opt_D_dump_cmmz "spills and reloads"
+                             (dualLivenessWithInsertion procPoints) g
+                    -- Insert spills at defns; reloads at return points
+       g     <-
+              -- pprTrace "pre insertLateReloads" (ppr g) $
+                run $ insertLateReloads g -- Duplicate reloads just before uses
+       dump Opt_D_dump_cmmz "Post late reloads" g
+       g     <-
+               -- pprTrace "post insertLateReloads" (ppr g) $
+                dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
+                                        (removeDeadAssignmentsAndReloads procPoints) g
+                    -- Remove redundant reloads (and any other redundant asst)
+
+       ----------- Debug only: add code to put zero in dead stack slots----
+       -- Debugging: stubbing slots on death can cause crashes early
+       g <- -- trace "post dead-assign elim" $
+            if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
+
+
+       --------------- Stack layout ----------------
+       slotEnv <- run $ liveSlotAnal g
+       mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
+       let areaMap = layout procPoints slotEnv entry_off g
+       mbpprTrace "areaMap" (ppr areaMap) $ return ()
+
+       ------------  Manifest the stack pointer --------
+       g  <- run $ manifestSP areaMap entry_off g
+       dump Opt_D_dump_cmmz "after manifestSP" g
+       -- UGH... manifestSP can require updates to the procPointMap.
+       -- We can probably do something quicker here for the update...
+
+       ------------- Split into separate procedures ------------
+       procPointMap  <- run $ procPointAnalysis procPoints g
+       dump Opt_D_dump_cmmz "procpoint map" procPointMap
+       gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
+                                       (CmmProc h l g)
+       mapM_ (dump Opt_D_dump_cmmz "after splitting") gs
+
+       ------------- More CAFs and foreign calls ------------
+       cafEnv <- run $ cafAnal g
+       let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
+       mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
+
+       gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs
+       mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
+
+       -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
+       let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
+       mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
+       let gs'' = map (bundleCAFs cafEnv) gs'
+       mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
+       return (localCAFs, gs'')
+  where dflags = hsc_dflags hsc_env
+        mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
+        dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
+
+        run = runFuelIO (hsc_OptFuel hsc_env)
+
+        dual_rewrite flag txt pass g =
+          do dump flag ("Pre " ++ txt)  g
+             g <- run $ pass g
+             dump flag ("Post " ++ txt) $ g
+             return g
+
+-- This probably belongs in CmmBuildInfoTables?
+-- We're just finishing the job here: once we know what CAFs are defined
+-- in non-static closures, we can build the SRTs.
+toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmTop]])
+                 -> [(CAFSet, CmmTop)] -> IO (TopSRT, [[CmmTop]])
+toTops hsc_env topCAFEnv (topSRT, tops) gs =
+  do let setSRT (topSRT, rst) g =
+           do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
+              return (topSRT, gs : rst)
+     (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
+     return (topSRT, concat gs' : tops)
diff --git a/compiler/cmm/CmmCPSGen.hs b/compiler/cmm/CmmCPSGen.hs
deleted file mode 100644 (file)
index 45d0aeb..0000000
+++ /dev/null
@@ -1,517 +0,0 @@
-module CmmCPSGen (
-  -- | Converts continuations into full proceedures.
-  -- The main work of the CPS transform that everything else is setting-up.
-  continuationToProc,
-  Continuation(..), continuationLabel,
-  ContinuationFormat(..),
-) where
-
-import BlockId
-import Cmm
-import CLabel
-import CmmBrokenBlock -- Data types only
-import CmmUtils
-import CmmCallConv
-import ClosureInfo
-
-import CgProf
-import CgUtils
-import CgInfoTbls
-import SMRep
-import ForeignCall
-
-import Module
-import Constants
-import StaticFlags
-import Unique
-import Data.Maybe
-import FastString
-
-import Panic
-
--- The format for the call to a continuation
--- The fst is the arguments that must be passed to the continuation
--- by the continuation's caller.
--- The snd is the live values that must be saved on stack.
--- A Nothing indicates an ignored slot.
--- The head of each list is the stack top or the first parameter.
-
--- The format for live values for a particular continuation
--- All on stack for now.
--- Head element is the top of the stack (or just under the header).
--- Nothing means an empty slot.
--- Future possibilities include callee save registers (i.e. passing slots in register)
--- and heap memory (not sure if that's usefull at all though, but it may
--- be worth exploring the design space).
-
-continuationLabel :: Continuation (Either C_SRT CmmInfo) -> CLabel
-continuationLabel (Continuation _ l _ _ _) = l
-data Continuation info =
-  Continuation
-     info              -- Left <=> Continuation created by the CPS
-                       -- Right <=> Function or Proc point
-     CLabel            -- Used to generate both info & entry labels
-     CmmFormals        -- Argument locals live on entry (C-- procedure params)
-     Bool              -- True <=> GC block so ignore stack size
-     [BrokenBlock]     -- Code, may be empty.  The first block is
-                       -- the entry point.  The order is otherwise initially 
-                       -- unimportant, but at some point the code gen will
-                       -- fix the order.
-
-                      -- the BlockId of the first block does not give rise
-                      -- to a label.  To jump to the first block in a Proc,
-                      -- use the appropriate CLabel.
-
-data ContinuationFormat
-    = ContinuationFormat {
-        continuation_formals :: CmmFormals,
-        continuation_label :: Maybe CLabel,    -- The label occupying the top slot
-        continuation_frame_size :: WordOff,    -- Total frame size in words (not including arguments)
-        continuation_stack :: [Maybe LocalReg] -- local reg offsets from stack top
-      }
-
--- A block can be a continuation of a call
--- A block can be a continuation of another block (w/ or w/o joins)
--- A block can be an entry to a function
-
------------------------------------------------------------------------------
-continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
-                   -> CmmReg
-                   -> [[[Unique]]]
-                   -> Continuation CmmInfo
-                   -> CmmTop
-continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
-                   (Continuation info label formals _ blocks) =
-    CmmProc info label formals (ListGraph blocks')
-    where
-      blocks' = concat $ zipWith3 continuationToProc' uniques blocks
-                         (True : repeat False)
-      curr_format = maybe unknown_block id $ lookup label formats
-      unknown_block = panic "unknown BlockId in continuationToProc"
-      curr_stack = continuation_frame_size curr_format
-      arg_stack = argumentsSize localRegType formals
-
-      param_stmts :: [CmmStmt]
-      param_stmts = function_entry curr_format
-
-      gc_stmts :: [CmmStmt]
-      gc_stmts =
-        assign_gc_stack_use stack_use arg_stack (max_stack - curr_stack)
-
-      update_stmts :: [CmmStmt]
-      update_stmts =
-          case info of
-            CmmInfo _ (Just (UpdateFrame target args)) _ ->
-                pack_frame curr_stack update_frame_size (Just target) (map Just args) ++
-                adjust_sp_reg (curr_stack - update_frame_size)
-            CmmInfo _ Nothing _ -> []
-
-      continuationToProc' :: [[Unique]]
-                          -> BrokenBlock
-                          -> Bool
-                          -> [CmmBasicBlock]
-      continuationToProc' uniques (BrokenBlock ident entry stmts _ exit) is_entry =
-          prefix_blocks ++ [BasicBlock ident fixed_main_stmts] ++ concat new_blocks
-          where
-            prefix_blocks =
-                if is_entry
-                then [BasicBlock
-                      (BlockId prefix_unique)
-                      (param_stmts ++ [CmmBranch ident])]
-                else []
-
-            (prefix_unique : call_uniques) : new_block_uniques = uniques
-            toCLabel = mkReturnPtLabel . getUnique
-
-            block_for_branch :: Unique -> BlockId -> (BlockId, [CmmBasicBlock])
-            block_for_branch unique next
-                -- branches to the current function don't have to jump
-                | (mkReturnPtLabel $ getUnique next) == label
-                = (next, [])
-
-                -- branches to any other function have to jump
-                | (Just cont_format) <- lookup (toCLabel next) formats
-                = let
-                    new_next = BlockId unique
-                    cont_stack = continuation_frame_size cont_format
-                    arguments = map formal_to_actual (continuation_formals cont_format)
-                  in (new_next,
-                     [BasicBlock new_next $
-                      pack_continuation curr_format cont_format ++
-                      tail_call (curr_stack - cont_stack)
-                                (CmmLit $ CmmLabel $ toCLabel next)
-                                arguments])
-
-                -- branches to blocks in the current function don't have to jump
-                | otherwise
-                = (next, [])
-
-            -- Wrapper for block_for_branch for when the target
-            -- is inside a 'Maybe'.
-            block_for_branch' :: Unique -> Maybe BlockId -> (Maybe BlockId, [CmmBasicBlock])
-            block_for_branch' _ Nothing = (Nothing, [])
-            block_for_branch' unique (Just next) = (Just new_next, new_blocks)
-              where (new_next, new_blocks) = block_for_branch unique next
-
-            -- If the target of a switch, branch or cond branch becomes a proc point
-            -- then we have to make a new block what will then *jump* to the original target.
-            proc_point_fix unique (CmmCondBranch test target)
-                = (CmmCondBranch test new_target, new_blocks)
-                  where (new_target, new_blocks) = block_for_branch (head unique) target
-            proc_point_fix unique (CmmSwitch test targets)
-                = (CmmSwitch test new_targets, concat new_blocks)
-                  where (new_targets, new_blocks) =
-                            unzip $ zipWith block_for_branch' unique targets
-            proc_point_fix unique (CmmBranch target)
-                = (CmmBranch new_target, new_blocks)
-                  where (new_target, new_blocks) = block_for_branch (head unique) target
-            proc_point_fix _ other = (other, [])
-
-            (fixed_main_stmts, new_blocks) = unzip $ zipWith proc_point_fix new_block_uniques main_stmts
-            main_stmts =
-                case entry of
-                  FunctionEntry _ _ _ ->
-                      -- The statements for an update frame must come /after/
-                      -- the GC check that was added at the beginning of the
-                      -- CPS pass.  So we have do edit the statements a bit.
-                      -- This depends on the knowledge that the statements in
-                      -- the first block are only the GC check.  That's
-                      -- fragile but it works for now.
-                      gc_stmts ++ stmts ++ update_stmts ++ postfix_stmts
-                  ControlEntry -> stmts ++ postfix_stmts
-                  ContinuationEntry _ _ _ -> stmts ++ postfix_stmts
-            postfix_stmts = case exit of
-                        -- Branches and switches may get modified by proc_point_fix
-                        FinalBranch next -> [CmmBranch next]
-                        FinalSwitch expr targets -> [CmmSwitch expr targets]
-
-                        -- A return is a tail call to the stack top
-                        FinalReturn arguments ->
-                            tail_call curr_stack
-                                (entryCode (CmmLoad (CmmReg spReg) bWord))
-                                arguments
-
-                        -- A tail call
-                        FinalJump target arguments ->
-                            tail_call curr_stack target arguments
-
-                        -- A regular Cmm function call
-                        FinalCall next (CmmCallee target CmmCallConv)
-                            _ arguments _ _ _ ->
-                                pack_continuation curr_format cont_format ++
-                                tail_call (curr_stack - cont_stack)
-                                              target arguments
-                            where
-                              cont_format = maybe unknown_block id $
-                                            lookup (mkReturnPtLabel $ getUnique next) formats
-                              cont_stack = continuation_frame_size cont_format
-
-                        -- A safe foreign call
-                        FinalCall _ (CmmCallee target conv)
-                            results arguments _ _ _ ->
-                                target_stmts ++
-                                foreignCall call_uniques' (CmmCallee new_target conv)
-                                            results arguments
-                            where
-                              (call_uniques', target_stmts, new_target) =
-                                  maybeAssignTemp call_uniques target
-
-                        -- A safe prim call
-                        FinalCall _ (CmmPrim target)
-                            results arguments _ _ _ ->
-                                foreignCall call_uniques (CmmPrim target)
-                                            results arguments
-
-formal_to_actual :: LocalReg -> CmmHinted CmmExpr
-formal_to_actual reg = CmmHinted (CmmReg (CmmLocal reg)) NoHint
-
-foreignCall :: [Unique] -> CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals -> [CmmStmt]
-foreignCall uniques call results arguments =
-    arg_stmts ++
-    saveThreadState ++
-    caller_save ++
-    [CmmCall (CmmCallee suspendThread CCallConv)
-                [ CmmHinted id AddrHint ]
-                [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint
-                -- XXX: allow for interruptible suspension
-                , CmmHinted (CmmLit (CmmInt 0 wordWidth)) NoHint ]
-                CmmUnsafe
-                 CmmMayReturn,
-     CmmCall call results new_args CmmUnsafe CmmMayReturn,
-     CmmCall (CmmCallee resumeThread CCallConv)
-                 [ CmmHinted new_base AddrHint ]
-                [ CmmHinted (CmmReg (CmmLocal id)) AddrHint ]
-                CmmUnsafe
-                 CmmMayReturn,
-     -- Assign the result to BaseReg: we
-     -- might now have a different Capability!
-     CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++
-    caller_load ++
-    loadThreadState tso_unique ++
-    [CmmJump (CmmReg spReg) (map (formal_to_actual . hintlessCmm) results)]
-    where
-      (_, arg_stmts, new_args) =
-          loadArgsIntoTemps argument_uniques arguments
-      (caller_save, caller_load) =
-          callerSaveVolatileRegs (Just [{-only system regs-}])
-      new_base = LocalReg base_unique (cmmRegType (CmmGlobal BaseReg))
-      id = LocalReg id_unique bWord
-      tso_unique : base_unique : id_unique : argument_uniques = uniques
-
--- -----------------------------------------------------------------------------
--- Save/restore the thread state in the TSO
-
-suspendThread, resumeThread :: CmmExpr
-suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread")))
-resumeThread  = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread")))
-
--- This stuff can't be done in suspendThread/resumeThread, because it
--- refers to global registers which aren't available in the C world.
-
-saveThreadState :: [CmmStmt]
-saveThreadState =
-  -- CurrentTSO->sp = Sp;
-  [CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp,
-  closeNursery] ++
-  -- and save the current cost centre stack in the TSO when profiling:
-  if opt_SccProfilingOn
-  then [CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS]
-  else []
-
-   -- CurrentNursery->free = Hp+1;
-closeNursery :: CmmStmt
-closeNursery = CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
-
-loadThreadState :: Unique -> [CmmStmt]
-loadThreadState tso_unique =
-  [
-       -- tso = CurrentTSO;
-       CmmAssign (CmmLocal tso) stgCurrentTSO,
-       -- Sp = tso->sp;
-       CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
-                             bWord),
-       -- SpLim = tso->stack + RESERVED_STACK_WORDS;
-       CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
-                                   rESERVED_STACK_WORDS)
-  ] ++
-  openNursery ++
-  -- and load the current cost centre stack from the TSO when profiling:
-  if opt_SccProfilingOn 
-  then [CmmStore curCCSAddr 
-       (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord)]
-  else []
-  where tso = LocalReg tso_unique bWord -- TODO FIXME NOW
-
-
-openNursery :: [CmmStmt]
-openNursery = [
-        -- Hp = CurrentNursery->free - 1;
-       CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
-
-        -- HpLim = CurrentNursery->start + 
-       --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
-       CmmAssign hpLim
-           (cmmOffsetExpr
-               (CmmLoad nursery_bdescr_start bWord)
-               (cmmOffset
-                 (CmmMachOp mo_wordMul [
-                   CmmMachOp (MO_SS_Conv W32 wordWidth)
-                     [CmmLoad nursery_bdescr_blocks b32],
-                   CmmLit (mkIntCLit bLOCK_SIZE)
-                  ])
-                 (-1)
-               )
-           )
-   ]
-
-
-nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
-nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
-nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
-nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
-
-tso_SP, tso_STACK, tso_CCCS :: ByteOff
-tso_SP    = tsoFieldB     undefined --oFFSET_StgTSO_sp
-tso_STACK = tsoFieldB     undefined --oFFSET_StgTSO_stack
-tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
-
--- The TSO struct has a variable header, and an optional StgTSOProfInfo in
--- the middle.  The fields we're interested in are after the StgTSOProfInfo.
-tsoFieldB :: ByteOff -> ByteOff
-tsoFieldB off
-  | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
-  | otherwise          = off + fixedHdrSize * wORD_SIZE
-
-tsoProfFieldB :: ByteOff -> ByteOff
-tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
-
-stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
-stgSp            = CmmReg sp
-stgHp            = CmmReg hp
-stgCurrentTSO    = CmmReg currentTSO
-stgCurrentNursery = CmmReg currentNursery
-
-sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
-sp               = CmmGlobal Sp
-spLim            = CmmGlobal SpLim
-hp               = CmmGlobal Hp
-hpLim            = CmmGlobal HpLim
-currentTSO       = CmmGlobal CurrentTSO
-currentNursery           = CmmGlobal CurrentNursery
-
------------------------------------------------------------------------------
--- Functions that generate CmmStmt sequences
--- for packing/unpacking continuations
--- and entering/exiting functions
-
-tail_call :: WordOff -> CmmExpr -> HintedCmmActuals -> [CmmStmt]
-tail_call spRel target arguments
-  = store_arguments ++ adjust_sp_reg spRel ++ jump where
-    store_arguments =
-        [stack_put spRel expr offset
-         | ((CmmHinted expr _), StackParam offset) <- argument_formats] ++
-        [global_put expr global
-         | ((CmmHinted expr _), RegisterParam global) <- argument_formats]
-    jump = [CmmJump target arguments]
-
-    argument_formats = assignArguments (cmmExprType . hintlessCmm) arguments
-
-adjust_sp_reg :: Int -> [CmmStmt]
-adjust_sp_reg spRel =
-    if spRel == 0
-    then []
-    else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
-
-assign_gc_stack_use :: CmmReg -> Int -> Int -> [CmmStmt]
-assign_gc_stack_use stack_use arg_stack max_frame_size =
-    if max_frame_size > arg_stack
-    then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))]
-    else [CmmAssign stack_use (CmmReg spLimReg)]
-         -- Trick the optimizer into eliminating the branch for us
-  
-{-
-UNUSED 2008-12-29
-
-gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
-gc_stack_check gc_block max_frame_size
-  = check_stack_limit where
-    check_stack_limit = [
-     CmmCondBranch
-     (CmmMachOp (MO_U_Lt (typeWidth (cmmRegType spReg)))
-                [CmmRegOff spReg (-max_frame_size*wORD_SIZE),
-                     CmmReg spLimReg])
-     gc_block]
--}
-
-pack_continuation :: ContinuationFormat -- ^ The current format
-                  -> ContinuationFormat -- ^ The return point format
-                  -> [CmmStmt]
-pack_continuation (ContinuationFormat _ curr_id curr_frame_size _)
-                  (ContinuationFormat _ cont_id cont_frame_size live_regs)
-  = pack_frame curr_frame_size cont_frame_size maybe_header continuation_args
-  where
-    continuation_args = map (maybe Nothing (Just . CmmReg . CmmLocal))
-                            live_regs
-    needs_header_set =
-        case (curr_id, cont_id) of
-          (Just x, Just y) -> x /= y
-          _ -> isJust cont_id
-
-    maybe_header = if needs_header_set
-                   then maybe Nothing (Just . CmmLit . CmmLabel . entryLblToInfoLbl) cont_id
-                   else Nothing
-
-pack_frame :: WordOff         -- ^ Current frame size
-           -> WordOff         -- ^ Next frame size
-           -> Maybe CmmExpr   -- ^ Next frame header if any
-           -> [Maybe CmmExpr] -- ^ Next frame data
-           -> [CmmStmt]
-pack_frame curr_frame_size next_frame_size next_frame_header frame_args =
-    store_live_values ++ set_stack_header
-    where
-    -- TODO: only save variables when actually needed
-    -- (may be handled by latter pass)
-    store_live_values =
-        [stack_put spRel expr offset
-         | (expr, offset) <- cont_offsets]
-    set_stack_header =
-        case next_frame_header of
-          Nothing -> []
-          Just expr -> [stack_put spRel expr 0]
-
-    -- TODO: factor with function_entry and CmmInfo.hs(?)
-    cont_offsets = mkOffsets label_size frame_args
-
-    label_size = 1 :: WordOff
-
-    mkOffsets _    [] = []
-    mkOffsets size (Nothing:exprs) = mkOffsets (size+1) exprs
-    mkOffsets size (Just expr:exprs) = (expr, size):mkOffsets (size + width) exprs
-        where
-          width = (widthInBytes $ typeWidth $ cmmExprType expr) `quot` wORD_SIZE
-          -- TODO: it would be better if we had a machRepWordWidth
-
-    spRel = curr_frame_size - next_frame_size
-
-
--- Lazy adjustment of stack headers assumes all blocks
--- that could branch to eachother (i.e. control blocks)
--- have the same stack format (this causes a problem
--- only for proc-point).
-function_entry :: ContinuationFormat -> [CmmStmt]
-function_entry (ContinuationFormat formals _ _ live_regs)
-  = load_live_values ++ load_args where
-    -- TODO: only save variables when actually needed
-    -- (may be handled by latter pass)
-    load_live_values =
-        [stack_get 0 reg offset
-         | (reg, offset) <- curr_offsets]
-    load_args =
-        [stack_get 0 reg offset
-         | (reg, StackParam offset) <- argument_formats] ++
-        [global_get reg global
-         | (reg, RegisterParam global) <- argument_formats]
-
-    argument_formats = assignArguments (localRegType) formals
-
-    -- TODO: eliminate copy/paste with pack_continuation
-    curr_offsets = mkOffsets label_size live_regs
-
-    label_size = 1 :: WordOff
-
-    mkOffsets _    [] = []
-    mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
-    mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
-        where
-          width = (widthInBytes $ typeWidth $ localRegType reg) `quot` wORD_SIZE
-          -- TODO: it would be better if we had a machRepWordWidth
-
------------------------------------------------------------------------------
--- Section: Stack and argument register puts and gets
------------------------------------------------------------------------------
--- TODO: document
-
--- |Construct a 'CmmStmt' that will save a value on the stack
-stack_put :: WordOff            -- ^ Offset from the real 'Sp' that 'offset'
-                                -- is relative to (added to offset)
-          -> CmmExpr            -- ^ What to store onto the stack
-          -> WordOff            -- ^ Where on the stack to store it
-                                -- (positive <=> higher addresses)
-          -> CmmStmt
-stack_put spRel expr offset =
-    CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr
-
---------------------------------
--- |Construct a 
-stack_get :: WordOff
-          -> LocalReg
-          -> WordOff
-          -> CmmStmt
-stack_get spRel reg offset =
-    CmmAssign (CmmLocal reg)
-              (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset)))
-                       (localRegType reg))
-global_put :: CmmExpr -> GlobalReg -> CmmStmt
-global_put expr global = CmmAssign (CmmGlobal global) expr
-global_get :: LocalReg -> GlobalReg -> CmmStmt
-global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))
diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs
deleted file mode 100644 (file)
index 23e57d7..0000000
+++ /dev/null
@@ -1,183 +0,0 @@
-{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
--- Norman likes local bindings
--- If this module lives on I'd like to get rid of this flag in due course
-
-module CmmCPSZ (
-  -- | Converts C-- with full proceedures and parameters
-  -- to a CPS transformed C-- with the stack made manifest.
-  -- Well, sort of.
-  protoCmmCPSZ
-) where
-
-import CLabel
-import Cmm
-import CmmBuildInfoTables
-import CmmCommonBlockElimZ
-import CmmProcPointZ
-import CmmSpillReload
-import CmmStackLayout
-import DFMonad
-import PprCmmZ()
-import ZipCfgCmmRep
-
-import DynFlags
-import ErrUtils
-import HscTypes
-import Data.Maybe
-import Control.Monad
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Outputable
-import StaticFlags
-
------------------------------------------------------------------------------
--- |Top level driver for the CPS pass
------------------------------------------------------------------------------
--- There are two complications here:
--- 1. We need to compile the procedures in two stages because we need
---    an analysis of the procedures to tell us what CAFs they use.
---    The first stage returns a map from procedure labels to CAFs,
---    along with a closure that will compute SRTs and attach them to
---    the compiled procedures.
---    The second stage is to combine the CAF information into a top-level
---    CAF environment mapping non-static closures to the CAFs they keep live,
---    then pass that environment to the closures returned in the first
---    stage of compilation.
--- 2. We need to thread the module's SRT around when the SRT tables
---    are computed for each procedure.
---    The SRT needs to be threaded because it is grown lazily.
-protoCmmCPSZ :: HscEnv -- Compilation env including
-                       -- dynamic flags: -dcmm-lint -ddump-cps-cmm
-             -> (TopSRT, [CmmZ])  -- SRT table and accumulating list of compiled procs
-             -> CmmZ              -- Input C-- with Procedures
-             -> IO (TopSRT, [CmmZ]) -- Output CPS transformed C--
-protoCmmCPSZ hsc_env (topSRT, rst) (Cmm tops) =
-  do let dflags = hsc_dflags hsc_env
-     showPass dflags "CPSZ"
-     (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops
-     let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
-     (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
-     -- (topSRT, tops) <- foldM (\ z f -> f topCAFEnv z) (topSRT, []) toTops 
-     let cmms = Cmm (reverse (concat tops))
-     dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
-     return (topSRT, cmms : rst)
-
-{- [Note global fuel]
-~~~~~~~~~~~~~~~~~~~~~
-The identity and the last pass are stored in
-mutable reference cells in an 'HscEnv' and are
-global to one compiler session.
--}
-
-cpsTop :: HscEnv -> CmmTopZ ->
-          IO ([(CLabel, CAFSet)],
-              [(CAFSet, CmmTopForInfoTables)])
-cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, NoInfoTable p)])
-cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) =
-    do 
-       dump Opt_D_dump_cmmz "Pre Proc Points Added"  g
-       let callPPs = callProcPoints g
-       -- Why bother doing it this early?
-       -- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
-       --                       (dualLivenessWithInsertion callPPs) g
-       -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
-       -- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
-       --                   (removeDeadAssignmentsAndReloads callPPs) g
-       dump Opt_D_dump_cmmz "Pre common block elimination" g
-       g <- return $ elimCommonBlocks g
-       dump Opt_D_dump_cmmz "Post common block elimination" g
-
-       ----------- Proc points -------------------
-       procPoints <- run $ minimalProcPointSet callPPs g
-       g <- run $ addProcPointProtocols callPPs procPoints g
-       dump Opt_D_dump_cmmz "Post Proc Points Added" g
-
-       ----------- Spills and reloads -------------------
-       g     <- 
-              -- pprTrace "pre Spills" (ppr g) $
-                dual_rewrite Opt_D_dump_cmmz "spills and reloads"
-                             (dualLivenessWithInsertion procPoints) g
-                    -- Insert spills at defns; reloads at return points
-       g     <-
-              -- pprTrace "pre insertLateReloads" (ppr g) $
-                run $ insertLateReloads g -- Duplicate reloads just before uses
-       dump Opt_D_dump_cmmz "Post late reloads" g
-       g     <-
-               -- pprTrace "post insertLateReloads" (ppr g) $
-                dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
-                                        (removeDeadAssignmentsAndReloads procPoints) g
-                    -- Remove redundant reloads (and any other redundant asst)
-
-       ----------- Debug only: add code to put zero in dead stack slots----
-       -- Debugging: stubbing slots on death can cause crashes early
-       g <-  
-           -- trace "post dead-assign elim" $
-            if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
-
-
-       --------------- Stack layout ----------------
-       slotEnv <- run $ liveSlotAnal g
-       mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
-       -- cafEnv <- -- trace "post liveSlotAnal" $ run $ cafAnal g
-       -- (cafEnv, slotEnv) <-
-       --  -- trace "post print cafAnal" $
-       --    return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g
-       slotEnv <- return $ extendEnvWithSafeForeignCalls liveSlotTransfers slotEnv g
-       mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return ()
-       let areaMap = layout procPoints slotEnv entry_off g
-       mbpprTrace "areaMap" (ppr areaMap) $ return ()
-
-       ------------  Manifest the the stack pointer --------
-       g  <- run $ manifestSP areaMap entry_off g
-       dump Opt_D_dump_cmmz "after manifestSP" g
-       -- UGH... manifestSP can require updates to the procPointMap.
-       -- We can probably do something quicker here for the update...
-
-       ------------- Split into separate procedures ------------
-       procPointMap  <- run $ procPointAnalysis procPoints g
-       dump Opt_D_dump_cmmz "procpoint map" procPointMap
-       gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
-                                       (CmmProc h l args (stackInfo, g))
-       mapM_ (dump Opt_D_dump_cmmz "after splitting") gs
-
-       ------------- More CAFs and foreign calls ------------
-       cafEnv <- run $ cafAnal g
-       cafEnv <- return $ extendEnvWithSafeForeignCalls cafTransfers cafEnv  g
-       let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
-       mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
-
-       gs <- liftM concat $ run $ foldM lowerSafeForeignCalls [] gs
-       mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
-
-       -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
-       let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
-       mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
-       let gs'' = map (bundleCAFs cafEnv) gs'
-       mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
-       return (localCAFs, gs'')
-  where dflags = hsc_dflags hsc_env
-        mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
-        dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
-
-        run :: FuelMonad a -> IO a
-        run = runFuelIO (hsc_OptFuel hsc_env)
-
-        dual_rewrite flag txt pass g =
-          do dump flag ("Pre " ++ txt)  g
-             g <- run $ pass g
-             dump flag ("Post " ++ txt) $ g
-             return g
-
--- This probably belongs in CmmBuildInfoTables?
--- We're just finishing the job here: once we know what CAFs are defined
--- in non-static closures, we can build the SRTs.
-toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmTopZ]])
-                 -> [(CAFSet, CmmTopForInfoTables)] -> IO (TopSRT, [[CmmTopZ]])
-
-toTops hsc_env topCAFEnv (topSRT, tops) gs =
-  do let setSRT (topSRT, rst) g =
-           do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
-              return (topSRT, gs : rst)
-     (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
-     gs' <- mapM finishInfoTables (concat gs')
-     return (topSRT, concat gs' : tops)
index 3fb347f..24adb99 100644 (file)
@@ -8,9 +8,10 @@ module CmmCallConv (
 
 #include "HsVersions.h"
 
-import Cmm
+import CmmExpr
 import SMRep
-import ZipCfgCmmRep (Convention(..))
+import Cmm (Convention(..))
+import PprCmm ()
 
 import Constants
 import qualified Data.List as L
similarity index 57%
rename from compiler/cmm/CmmCommonBlockElimZ.hs
rename to compiler/cmm/CmmCommonBlockElim.hs
index 90e7008..c0761fc 100644 (file)
@@ -1,15 +1,20 @@
-module CmmCommonBlockElimZ
+{-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
+-- ToDo: remove
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+
+module CmmCommonBlockElim
   ( elimCommonBlocks
   )
 where
 
 
 import BlockId
+import Cmm
 import CmmExpr
-import Prelude hiding (iterate, zip, unzip)
-import ZipCfg
-import ZipCfgCmmRep
+import Prelude hiding (iterate, succ, unzip, zip)
 
+import Compiler.Hoopl
 import Data.Bits
 import qualified Data.List as List
 import Data.Word
@@ -38,8 +43,8 @@ my_trace = if False then pprTrace else \_ _ a -> a
 elimCommonBlocks :: CmmGraph -> CmmGraph
 elimCommonBlocks g =
     upd_graph g . snd $ iterate common_block reset hashed_blocks
-                                (emptyUFM, emptyBlockEnv)
-      where hashed_blocks    = map (\b -> (hash_block b, b)) (reverse (postorder_dfs g))
+                                (emptyUFM, mapEmpty)
+      where hashed_blocks    = map (\b -> (hash_block b, b)) (reverse (postorderDfs g))
             reset (_, subst) = (emptyUFM, subst)
 
 -- Iterate over the blocks until convergence
@@ -57,26 +62,28 @@ common_block :: (Outputable h, Uniquable h) =>  State -> (h, CmmBlock) -> (Bool,
 common_block (bmap, subst) (hash, b) =
   case lookupUFM bmap hash of
     Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs,
-                     lookupBlockEnv subst bid) of
-                 (Just b', Nothing)                      -> addSubst b'
-                 (Just b', Just b'') | blockId b' /= b'' -> addSubst b'
+                     mapLookup bid subst) of
+                 (Just b', Nothing)                         -> addSubst b'
+                 (Just b', Just b'') | entryLabel b' /= b'' -> addSubst b'
                  _ -> (False, (addToUFM bmap hash (b : bs), subst))
     Nothing -> (False, (addToUFM bmap hash [b], subst))
-  where bid = blockId b
-        addSubst b' = my_trace "found new common block" (ppr (blockId b')) $
-                      (True, (bmap, extendBlockEnv subst bid (blockId b')))
+  where bid = entryLabel b
+        addSubst b' = my_trace "found new common block" (ppr (entryLabel b')) $
+                      (True, (bmap, mapInsert bid (entryLabel b') subst))
 
 -- Given the map ``subst'' from BlockId -> BlockId, we rewrite the graph.
 upd_graph :: CmmGraph -> BidMap -> CmmGraph
-upd_graph g subst = map_nodes id middle last g
-  where middle = mapExpDeepMiddle exp
-        last l = last' (mapExpDeepLast exp l)
-        last' (LastBranch bid)            = LastBranch $ sub bid
-        last' (LastCondBranch p t f)      = cond p (sub t) (sub f)
-        last' (LastCall t (Just bid) args res u) = LastCall t (Just $ sub bid) args res u
-        last' l@(LastCall _ Nothing _ _ _)  = l
-        last' (LastSwitch e bs)           = LastSwitch e $ map (liftM sub) bs
-        cond p t f = if t == f then LastBranch t else LastCondBranch p t f
+upd_graph g subst = mapGraphNodes (id, middle, last) g
+  where middle = mapExpDeep exp
+        last l = last' (mapExpDeep exp l)
+        last' :: CmmNode O C -> CmmNode O C
+        last' (CmmBranch bid)              = CmmBranch $ sub bid
+        last' (CmmCondBranch p t f)        = cond p (sub t) (sub f)
+        last' (CmmCall t (Just bid) a r o) = CmmCall t (Just $ sub bid) a r o
+        last' l@(CmmCall _ Nothing _ _ _)  = l
+        last' (CmmForeignCall t r a bid u i) = CmmForeignCall t r a (sub bid) u i
+        last' (CmmSwitch e bs)             = CmmSwitch e $ map (liftM sub) bs
+        cond p t f = if t == f then CmmBranch t else CmmCondBranch p t f
         exp (CmmStackSlot (CallArea (Young id))       off) =
              CmmStackSlot (CallArea (Young (sub id))) off
         exp (CmmLit (CmmBlock id)) = CmmLit (CmmBlock (sub id))
@@ -87,24 +94,36 @@ upd_graph g subst = map_nodes id middle last g
 -- The hashing is a bit arbitrary (the numbers are completely arbitrary),
 -- but it should be fast and good enough.
 hash_block :: CmmBlock -> Int
-hash_block (Block _ t) =
-  fromIntegral (hash_tail t (0 :: Word32) .&. (0x7fffffff :: Word32))
+hash_block block =
+  fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
   -- UniqFM doesn't like negative Ints
-  where hash_mid   (MidComment (FastString u _ _ _ _)) = cvt u
-        hash_mid   (MidAssign r e) = hash_reg r + hash_e e
-        hash_mid   (MidStore e e') = hash_e e + hash_e e'
-        hash_mid   (MidForeignCall _ t _ as) = hash_tgt t + hash_lst hash_e as
+  where hash_fst _ h = h
+        hash_mid m h = hash_node m + h `shiftL` 1
+        hash_lst m h = hash_node m + h `shiftL` 1
+
+        hash_node :: CmmNode O x -> Word32
+        hash_node (CmmComment (FastString u _ _ _ _)) = cvt u
+        hash_node (CmmAssign r e) = hash_reg r + hash_e e
+        hash_node (CmmStore e e') = hash_e e + hash_e e'
+        hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
+        hash_node (CmmBranch _) = 23 -- would be great to hash these properly
+        hash_node (CmmCondBranch p _ _) = hash_e p
+        hash_node (CmmCall e _ _ _ _) = hash_e e
+        hash_node (CmmForeignCall t _ _ _ _ _) = hash_tgt t
+        hash_node (CmmSwitch e _) = hash_e e
+
         hash_reg :: CmmReg -> Word32
-        hash_reg   (CmmLocal l) = hash_local l
+        hash_reg   (CmmLocal _) = 117
         hash_reg   (CmmGlobal _)    = 19
-        hash_local (LocalReg _ _) = 117
+
         hash_e :: CmmExpr -> Word32
         hash_e (CmmLit l) = hash_lit l
         hash_e (CmmLoad e _) = 67 + hash_e e
         hash_e (CmmReg r) = hash_reg r
-        hash_e (CmmMachOp _ es) = hash_lst hash_e es -- pessimal - no operator check
+        hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
         hash_e (CmmRegOff r i) = hash_reg r + cvt i
         hash_e (CmmStackSlot _ _) = 13
+
         hash_lit :: CmmLit -> Word32
         hash_lit (CmmInt i _) = fromInteger i
         hash_lit (CmmFloat r _) = truncate r
@@ -113,16 +132,12 @@ hash_block (Block _ t) =
         hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
         hash_lit (CmmBlock _) = 191 -- ugh
         hash_lit (CmmHighStackMark) = cvt 313
+
         hash_tgt (ForeignTarget e _) = hash_e e
         hash_tgt (PrimTarget _) = 31 -- lots of these
-        hash_lst f = foldl (\z x -> f x + z) (0::Word32)
-        hash_last (LastBranch _) = 23 -- would be great to hash these properly
-        hash_last (LastCondBranch p _ _) = hash_e p 
-        hash_last (LastCall e _ _ _ _) = hash_e e
-        hash_last (LastSwitch e _) = hash_e e
-        hash_tail (ZLast LastExit) v = 29 + v `shiftL` 1
-        hash_tail (ZLast (LastOther l)) v = hash_last l + (v `shiftL` 1)
-        hash_tail (ZTail m t) v = hash_tail t (hash_mid m + (v `shiftL` 1))
+
+        hash_list f = foldl (\z x -> f x + z) (0::Word32)
+
         cvt = fromInteger . toInteger
 -- Utilities: equality and substitution on the graph.
 
@@ -130,33 +145,28 @@ hash_block (Block _ t) =
 eqBid :: BidMap -> BlockId -> BlockId -> Bool
 eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
 lookupBid :: BidMap -> BlockId -> BlockId
-lookupBid subst bid = case lookupBlockEnv subst bid of
+lookupBid subst bid = case mapLookup bid subst of
                         Just bid  -> lookupBid subst bid
                         Nothing -> bid
 
 -- Equality on the body of a block, modulo a function mapping block IDs to block IDs.
 eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
-eqBlockBodyWith eqBid (Block _ t) (Block _ t') = eqTailWith eqBid t t'
-
-type CmmTail = ZTail Middle Last
-eqTailWith :: (BlockId -> BlockId -> Bool) -> CmmTail -> CmmTail -> Bool
-eqTailWith eqBid (ZTail m t) (ZTail m' t') = m == m' && eqTailWith eqBid t t'
-eqTailWith _ (ZLast LastExit) (ZLast LastExit) = True
-eqTailWith eqBid (ZLast (LastOther l)) (ZLast (LastOther l')) = eqLastWith eqBid l l'
-eqTailWith _ _ _ = False
-
-eqLastWith :: (BlockId -> BlockId -> Bool) -> Last -> Last -> Bool
-eqLastWith eqBid (LastBranch bid1) (LastBranch bid2) = eqBid bid1 bid2
-eqLastWith eqBid (LastCondBranch c1 t1 f1) (LastCondBranch c2 t2 f2) =
+eqBlockBodyWith eqBid block block' = middles == middles' && eqLastWith eqBid last last'
+  where (_, middles , JustC last  :: MaybeC C (CmmNode O C)) = blockToNodeList block
+        (_, middles', JustC last' :: MaybeC C (CmmNode O C)) = blockToNodeList block'
+
+eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
+eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
+eqLastWith eqBid (CmmCondBranch c1 t1 f1) (CmmCondBranch c2 t2 f2) =
   c1 == c2 && eqBid t1 t2 && eqBid f1 f2
-eqLastWith eqBid (LastCall t1 c1 a1 r1 u1) (LastCall t2 c2 a2 r2 u2) =
+eqLastWith eqBid (CmmCall t1 c1 a1 r1 u1) (CmmCall t2 c2 a2 r2 u2) =
   t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2
-eqLastWith eqBid (LastSwitch e1 bs1) (LastSwitch e2 bs2) =
-  e1 == e2 && eqLstWith (eqMaybeWith eqBid) bs1 bs2
+eqLastWith eqBid (CmmSwitch e1 bs1) (CmmSwitch e2 bs2) =
+  e1 == e2 && eqListWith (eqMaybeWith eqBid) bs1 bs2
 eqLastWith _ _ _ = False
 
-eqLstWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
-eqLstWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
+eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
+eqListWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
 
 eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
 eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
index 64a2315..42fc239 100644 (file)
@@ -1,88 +1,84 @@
+{-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations -fno-warn-incomplete-patterns #-}
 
 module CmmContFlowOpt
-    ( runCmmOpts, cmmCfgOpts, cmmCfgOptsZ
-    , branchChainElimZ, removeUnreachableBlocksZ, predMap
-    , replaceLabelsZ, replaceBranches, runCmmContFlowOptsZs
+    ( runCmmOpts, oldCmmCfgOpts, cmmCfgOpts
+    , branchChainElim, removeUnreachableBlocks, predMap
+    , replaceLabels, replaceBranches, runCmmContFlowOpts
     )
 where
 
 import BlockId
 import Cmm
-import CmmTx
-import qualified ZipCfg as G
-import ZipCfg
-import ZipCfgCmmRep
+import CmmDecl
+import CmmExpr
+import qualified OldCmm as Old
 
 import Maybes
+import Compiler.Hoopl
 import Control.Monad
 import Outputable
-import Prelude hiding (unzip, zip)
+import Prelude hiding (succ, unzip, zip)
 import Util
 
 ------------------------------------
-runCmmContFlowOptsZs :: [CmmZ] -> [CmmZ]
-runCmmContFlowOptsZs prog
-  = [ runTx (runCmmOpts cmmCfgOptsZ) cmm_top
-    | cmm_top <- prog ]
-
-cmmCfgOpts  :: Tx (ListGraph CmmStmt)
-cmmCfgOptsZ :: Tx (a, CmmGraph)
-
-cmmCfgOpts  = branchChainElim  -- boring, but will get more exciting later
-cmmCfgOptsZ g =
-  optGraph
-    (branchChainElimZ `seqTx` blockConcatZ `seqTx` removeUnreachableBlocksZ) g
+runCmmContFlowOpts :: Cmm -> Cmm
+runCmmContFlowOpts prog = runCmmOpts cmmCfgOpts prog
+
+oldCmmCfgOpts :: Old.ListGraph Old.CmmStmt -> Old.ListGraph Old.CmmStmt
+cmmCfgOpts    :: CmmGraph -> CmmGraph
+
+oldCmmCfgOpts = oldBranchChainElim  -- boring, but will get more exciting later
+cmmCfgOpts    =
+  removeUnreachableBlocks . blockConcat . branchChainElim
         -- Here branchChainElim can ultimately be replaced
         -- with a more exciting combination of optimisations
 
-runCmmOpts :: Tx g -> Tx (GenCmm d h g)
+runCmmOpts :: (g -> g) -> GenCmm d h g -> GenCmm d h g
 -- Lifts a transformer on a single graph to one on the whole program
 runCmmOpts opt = mapProcs (optProc opt)
 
-optProc :: Tx g -> Tx (GenCmmTop d h g)
-optProc _   top@(CmmData {}) = noTx top
-optProc opt (CmmProc info lbl formals g) =
-  fmap (CmmProc info lbl formals) (opt g)
-
-optGraph :: Tx g -> Tx (a, g)
-optGraph opt (a, g) = fmap (\g' -> (a, g')) (opt g)
+optProc :: (g -> g) -> GenCmmTop d h g -> GenCmmTop d h g
+optProc _   top@(CmmData {}) = top
+optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g)
 
 ------------------------------------
-mapProcs :: Tx (GenCmmTop d h s) -> Tx (GenCmm d h s)
-mapProcs f (Cmm tops) = fmap Cmm (mapTx f tops)
+mapProcs :: (GenCmmTop d h s -> GenCmmTop d h s) -> GenCmm d h s -> GenCmm d h s
+mapProcs f (Cmm tops) = Cmm (map f tops)
 
 ----------------------------------------------------------------
-branchChainElim :: Tx (ListGraph CmmStmt)
+oldBranchChainElim :: Old.ListGraph Old.CmmStmt -> Old.ListGraph Old.CmmStmt
 -- If L is not captured in an instruction, we can remove any
 -- basic block of the form L: goto L', and replace L with L' everywhere else.
 -- How does L get captured? In a CallArea.
-branchChainElim (ListGraph blocks)
+oldBranchChainElim (Old.ListGraph blocks)
   | null lone_branch_blocks     -- No blocks to remove
-  = noTx (ListGraph blocks)
+  = Old.ListGraph blocks
   | otherwise
-  = aTx (ListGraph new_blocks)
+  = Old.ListGraph new_blocks
   where
     (lone_branch_blocks, others) = partitionWith isLoneBranch blocks
     new_blocks = map (replaceLabels env) others
     env = mkClosureBlockEnv lone_branch_blocks
 
-isLoneBranch :: CmmBasicBlock -> Either (BlockId, BlockId) CmmBasicBlock
-isLoneBranch (BasicBlock id [CmmBranch target]) | id /= target = Left (id, target)
-isLoneBranch other_block                                       = Right other_block
-   -- An infinite loop is not a link in a branch chain!
+    isLoneBranch :: Old.CmmBasicBlock -> Either (BlockId, BlockId) Old.CmmBasicBlock
+    isLoneBranch (Old.BasicBlock id [Old.CmmBranch target]) | id /= target = Left (id, target)
+    isLoneBranch other_block                                           = Right other_block
+       -- An infinite loop is not a link in a branch chain!
 
-replaceLabels :: BlockEnv BlockId -> CmmBasicBlock -> CmmBasicBlock
-replaceLabels env (BasicBlock id stmts)
-  = BasicBlock id (map replace stmts)
-  where
-    replace (CmmBranch id)       = CmmBranch (lookup id)
-    replace (CmmCondBranch e id) = CmmCondBranch e (lookup id)
-    replace (CmmSwitch e tbl)    = CmmSwitch e (map (fmap lookup) tbl)
-    replace other_stmt           = other_stmt
+    replaceLabels :: BlockEnv BlockId -> Old.CmmBasicBlock -> Old.CmmBasicBlock
+    replaceLabels env (Old.BasicBlock id stmts)
+      = Old.BasicBlock id (map replace stmts)
+      where
+        replace (Old.CmmBranch id)       = Old.CmmBranch (lookup id)
+        replace (Old.CmmCondBranch e id) = Old.CmmCondBranch e (lookup id)
+        replace (Old.CmmSwitch e tbl)    = Old.CmmSwitch e (map (fmap lookup) tbl)
+        replace other_stmt           = other_stmt
+
+        lookup id = mapLookup id env `orElse` id 
 
-    lookup id = lookupBlockEnv env id `orElse` id 
 ----------------------------------------------------------------
-branchChainElimZ :: Tx CmmGraph
+branchChainElim :: CmmGraph -> CmmGraph
 -- Remove any basic block of the form L: goto L',
 -- and replace L with L' everywhere else,
 -- unless L is the successor of a call instruction and L'
@@ -94,131 +90,129 @@ branchChainElimZ :: Tx CmmGraph
 -- JD isn't quite sure when it's safe to share continuations for different
 -- function calls -- have to think about where the SP will be,
 -- so we'll table that problem for now by leaving all call successors alone.
-branchChainElimZ g@(G.LGraph eid _)
+branchChainElim g
   | null lone_branch_blocks     -- No blocks to remove
-  = noTx g
+  = g
   | otherwise
-  = aTx $ replaceLabelsZ env $ G.of_block_list eid (self_branches ++ others)
+  = replaceLabels env $ ofBlockList (g_entry g) (self_branches ++ others)
   where
-    blocks = G.to_block_list g
-    (lone_branch_blocks, others) = partitionWith isLoneBranchZ blocks
-    env = mkClosureBlockEnvZ lone_branch_blocks
+    blocks = toBlockList g
+    (lone_branch_blocks, others) = partitionWith isLoneBranch blocks
+    env = mkClosureBlockEnv lone_branch_blocks
     self_branches =
       let loop_to (id, _) =
             if lookup id == id then
-              Just (G.Block id (G.ZLast (G.mkBranchNode id)))
+              Just $ blockOfNodeList (JustC (CmmEntry id), [], JustC (mkBranchNode id))
             else
               Nothing
       in  mapMaybe loop_to lone_branch_blocks
-    lookup id = lookupBlockEnv env id `orElse` id 
+    lookup id = mapLookup id env `orElse` id
 
     call_succs = foldl add emptyBlockSet blocks
-      where add succs b =
-              case G.last (G.unzip b) of
-                LastOther (LastCall _ (Just k) _ _ _) -> extendBlockSet succs k
-                _ -> succs
-    isLoneBranchZ :: CmmBlock -> Either (BlockId, BlockId) CmmBlock
-    isLoneBranchZ (G.Block id (G.ZLast (G.LastOther (LastBranch target))))
-        | id /= target && not (elemBlockSet id call_succs) = Left (id,target)
-    isLoneBranchZ other = Right other
+      where add :: BlockSet -> CmmBlock -> BlockSet
+            add succs b =
+              case lastNode b of
+                (CmmCall _ (Just k) _ _ _) -> setInsert k succs
+                (CmmForeignCall {succ=k})  -> setInsert k succs
+                _                          -> succs
+    isLoneBranch :: CmmBlock -> Either (BlockId, BlockId) CmmBlock
+    isLoneBranch block | (JustC (CmmEntry id), [], JustC (CmmBranch target)) <- blockToNodeList block,
+                         id /= target && not (setMember id call_succs)
+                       = Left (id,target)
+    isLoneBranch other = Right other
        -- An infinite loop is not a link in a branch chain!
 
-maybeReplaceLabels :: (Last -> Bool) -> BlockEnv BlockId -> CmmGraph -> CmmGraph
+maybeReplaceLabels :: (CmmNode O C -> Bool) -> BlockEnv BlockId -> CmmGraph -> CmmGraph
 maybeReplaceLabels lpred env =
-  replace_eid . G.map_nodes id middle last
+  replace_eid . mapGraphNodes (id, middle, last)
    where
-     replace_eid (G.LGraph eid blocks) = G.LGraph (lookup eid) blocks
-     middle = mapExpDeepMiddle exp
-     last l = if lpred l then mapExpDeepLast exp (last' l) else l
-     last' (LastBranch bid) = LastBranch (lookup bid)
-     last' (LastCondBranch p t f) = LastCondBranch p (lookup t) (lookup f)
-     last' (LastSwitch e arms) = LastSwitch e (map (liftM lookup) arms)
-     last' (LastCall t k a res r) = LastCall t (liftM lookup k) a res r
-     exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid))
-     exp   (CmmStackSlot (CallArea (Young id)) i) =
-       CmmStackSlot (CallArea (Young (lookup id))) i
-     exp e = e
-     lookup id = fmap lookup (lookupBlockEnv env id) `orElse` id 
-
-replaceLabelsZ :: BlockEnv BlockId -> CmmGraph -> CmmGraph
-replaceLabelsZ = maybeReplaceLabels (const True)
-
--- replaceBranchLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
--- replaceBranchLabels env g@(LGraph _ _) = maybeReplaceLabels lpred env g
---   where lpred (LastBranch _) = True
---         lpred _ = False
+     replace_eid g = g {g_entry = lookup (g_entry g)}
+     lookup id = fmap lookup (mapLookup id env) `orElse` id
+     
+     middle = mapExpDeep exp
+     last l = if lpred l then mapExpDeep exp (last' l) else l
+     last' :: CmmNode O C -> CmmNode O C
+     last' (CmmBranch bid)             = CmmBranch (lookup bid)
+     last' (CmmCondBranch p t f)       = CmmCondBranch p (lookup t) (lookup f)
+     last' (CmmSwitch e arms)          = CmmSwitch e (map (liftM lookup) arms)
+     last' (CmmCall t k a res r)       = CmmCall t (liftM lookup k) a res r
+     last' (CmmForeignCall t r a bid u i) = CmmForeignCall t r a (lookup bid) u i
+
+     exp (CmmLit (CmmBlock bid))                = CmmLit (CmmBlock (lookup bid))
+     exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i
+     exp e                                      = e
+
+
+replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
+replaceLabels = maybeReplaceLabels (const True)
 
 replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
-replaceBranches env g = map_nodes id id last g
+replaceBranches env g = mapGraphNodes (id, id, last) g
   where
-    last (LastBranch id)          = LastBranch (lookup id)
-    last (LastCondBranch e ti fi) = LastCondBranch e (lookup ti) (lookup fi)
-    last (LastSwitch e tbl)       = LastSwitch e (map (fmap lookup) tbl)
-    last l@(LastCall {})          = l
-    lookup id = fmap lookup (lookupBlockEnv env id) `orElse` id 
+    last :: CmmNode O C -> CmmNode O C
+    last (CmmBranch id)          = CmmBranch (lookup id)
+    last (CmmCondBranch e ti fi) = CmmCondBranch e (lookup ti) (lookup fi)
+    last (CmmSwitch e tbl)       = CmmSwitch e (map (fmap lookup) tbl)
+    last l@(CmmCall {})          = l
+    last l@(CmmForeignCall {})   = l
+    lookup id = fmap lookup (mapLookup id env) `orElse` id
 
 ----------------------------------------------------------------
 -- Build a map from a block to its set of predecessors. Very useful.
-predMap :: G.LastNode l => G.LGraph m l -> BlockEnv BlockSet
-predMap g = G.fold_blocks add_preds emptyBlockEnv g -- find the back edges
-  where add_preds b env = foldl (add b) env (G.succs b)
-        add (G.Block bid _) env b' =
-          extendBlockEnv env b' $
-                extendBlockSet (lookupBlockEnv env b' `orElse` emptyBlockSet) bid
+predMap :: [CmmBlock] -> BlockEnv BlockSet
+predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
+  where add_preds block env = foldl (add (entryLabel block)) env (successors block)
+        add bid env b' =
+          mapInsert b' (setInsert bid (mapLookup b' env `orElse` setEmpty)) env
 ----------------------------------------------------------------
 -- If a block B branches to a label L, L is not the entry block,
 -- and L has no other predecessors,
 -- then we can splice the block starting with L onto the end of B.
--- Because this optimization can be inhibited by unreachable blocks,
--- we first take a pass to drops unreachable blocks.
 -- Order matters, so we work bottom up (reverse postorder DFS).
+-- This optimization can be inhibited by unreachable blocks, but
+-- the reverse postorder DFS returns only reachable blocks.
 --
 -- To ensure correctness, we have to make sure that the BlockId of the block
 -- we are about to eliminate is not named in another instruction.
 --
 -- Note: This optimization does _not_ subsume branch chain elimination.
-blockConcatZ  :: Tx CmmGraph
-blockConcatZ = removeUnreachableBlocksZ `seqTx` blockConcatZ'
-blockConcatZ' :: Tx CmmGraph
-blockConcatZ' g@(G.LGraph eid blocks) =
-  tx $ replaceLabelsZ concatMap $ G.LGraph eid blocks'
-  where (changed, blocks', concatMap) =
-           foldr maybe_concat (False, blocks, emptyBlockEnv) $ G.postorder_dfs g
-        maybe_concat b@(G.Block bid _) (changed, blocks', concatMap) =
-          let unchanged = (changed, extendBlockEnv blocks' bid b, concatMap)
-          in case G.goto_end $ G.unzip b of
-               (h, G.LastOther (LastBranch b')) ->
+blockConcat  :: CmmGraph -> CmmGraph
+blockConcat g@(CmmGraph {g_entry=eid}) =
+  replaceLabels concatMap $ ofBlockMap (g_entry g) blocks'
+  where blocks = postorderDfs g
+        (blocks', concatMap) =
+           foldr maybe_concat (toBlockMap g, mapEmpty) $ blocks
+        maybe_concat :: CmmBlock -> (LabelMap CmmBlock, LabelMap Label) -> (LabelMap CmmBlock, LabelMap Label)
+        maybe_concat b unchanged@(blocks', concatMap) =
+          let bid = entryLabel b
+          in case blockToNodeList b of
+               (JustC h, m, JustC (CmmBranch b')) ->
                   if canConcatWith b' then
-                    (True, extendBlockEnv blocks' bid $ splice blocks' h b',
-                     extendBlockEnv concatMap b' bid)
+                    (mapInsert bid (splice blocks' h m b') blocks',
+                     mapInsert b' bid concatMap)
                   else unchanged
                _ -> unchanged
-        num_preds bid = liftM sizeBlockSet (lookupBlockEnv backEdges bid) `orElse` 0
+        num_preds bid = liftM setSize (mapLookup bid backEdges) `orElse` 0
         canConcatWith b' = b' /= eid && num_preds b' == 1
-        backEdges = predMap g
-        splice blocks' h bid' =
-          case lookupBlockEnv blocks' bid' of
-            Just (G.Block _ t) -> G.zip $ G.ZBlock h t
+        backEdges = predMap blocks
+        splice :: forall map n e x.
+                  IsMap map =>
+                  map (Block n e x) -> n C O -> [n O O] -> KeyOf map -> Block n C x
+        splice blocks' h m bid' =
+          case mapLookup bid' blocks' of
             Nothing -> panic "unknown successor block"
-        tx = if changed then aTx else noTx
+            Just block | (_, m', l') <- blockToNodeList block -> blockOfNodeList (JustC h, (m ++ m'), l')
 ----------------------------------------------------------------
 mkClosureBlockEnv :: [(BlockId, BlockId)] -> BlockEnv BlockId
-mkClosureBlockEnv blocks = mkBlockEnv $ map follow blocks
-    where singleEnv = mkBlockEnv blocks
-          follow (id, next) = (id, endChain id next)
-          endChain orig id = case lookupBlockEnv singleEnv id of
-                               Just id' | id /= orig -> endChain orig id'
-                               _ -> id
-mkClosureBlockEnvZ :: [(BlockId, BlockId)] -> BlockEnv BlockId
-mkClosureBlockEnvZ blocks = mkBlockEnv $ map follow blocks
-    where singleEnv = mkBlockEnv blocks
+mkClosureBlockEnv blocks = mapFromList $ map follow blocks
+    where singleEnv = mapFromList blocks :: BlockEnv BlockId
           follow (id, next) = (id, endChain id next)
-          endChain orig id = case lookupBlockEnv singleEnv id of
+          endChain orig id = case mapLookup id singleEnv of
                                Just id' | id /= orig -> endChain orig id'
                                _ -> id
 ----------------------------------------------------------------
-removeUnreachableBlocksZ :: Tx CmmGraph
-removeUnreachableBlocksZ g@(G.LGraph id blocks) =
-  if length blocks' < sizeBEnv blocks then aTx $ G.of_block_list id blocks'
-  else noTx g
-    where blocks' = G.postorder_dfs g
+removeUnreachableBlocks :: CmmGraph -> CmmGraph
+removeUnreachableBlocks g =
+  if length blocks < mapSize (toBlockMap g) then ofBlockList (g_entry g) blocks
+                                           else g
+    where blocks = postorderDfs g
index 4d41325..9382d8d 100644 (file)
@@ -1,4 +1,6 @@
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE GADTs #-}
+-- ToDo: remove
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
 
 module CmmCvt
   ( cmmToZgraph, cmmOfZgraph )
@@ -6,179 +8,170 @@ where
 
 import BlockId
 import Cmm
-import MkZipCfgCmm hiding (CmmGraph)
-import ZipCfgCmmRep -- imported for reverse conversion
-import CmmZipUtil
-import PprCmm()
-import qualified ZipCfg as G
+import CmmDecl
+import CmmExpr
+import MkGraph
+import qualified OldCmm as Old
+import OldPprCmm ()
 
-import FastString
+import Compiler.Hoopl hiding ((<*>), mkLabel, mkBranch)
 import Control.Monad
+import Data.Maybe
+import Maybes
 import Outputable
 import UniqSupply
 
-cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h (CmmStackInfo, CmmGraph))
-cmmOfZgraph :: GenCmm d h (CmmStackInfo, CmmGraph)          ->         GenCmm d h (ListGraph CmmStmt)
+cmmToZgraph :: Old.Cmm -> UniqSM Cmm
+cmmOfZgraph :: Cmm     -> Old.Cmm
 
 cmmToZgraph (Cmm tops) = liftM Cmm $ mapM mapTop tops
-  where mapTop (CmmProc h l args g) =
-          toZgraph (showSDoc $ ppr l) args g >>= return . CmmProc h l args
+  where mapTop (CmmProc (Old.CmmInfo _ _ info_tbl) l g) =
+          do (stack_info, g) <- toZgraph (showSDoc $ ppr l) g
+             return $ CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) l g
         mapTop (CmmData s ds) = return $ CmmData s ds
-cmmOfZgraph = cmmMapGraph (ofZgraph . snd)
+cmmOfZgraph (Cmm tops) = Cmm $ map mapTop tops
+  where mapTop (CmmProc h l g) = CmmProc (Old.CmmInfo Nothing Nothing (info_tbl h)) l (ofZgraph g)
+        mapTop (CmmData s ds) = CmmData s ds
 
-toZgraph :: String -> CmmFormals -> ListGraph CmmStmt -> UniqSM (CmmStackInfo, CmmGraph)
-toZgraph _ _ (ListGraph []) =
+toZgraph :: String -> Old.ListGraph Old.CmmStmt -> UniqSM (CmmStackInfo, CmmGraph)
+toZgraph _ (Old.ListGraph []) =
   do g <- lgraphOfAGraph emptyAGraph
-     return ((0, Nothing), g)
-toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = 
-           let (offset, entry) = mkEntry id NativeNodeCall args in
+     return (StackInfo {arg_space=0, updfr_space=Nothing}, g)
+toZgraph fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) = 
+           let (offset, entry) = mkCallEntry NativeNodeCall [] in
            do g <- labelAGraph id $
                      entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
-              return ((offset, Nothing), g)
-  where addBlock (BasicBlock id ss) g =
+              return (StackInfo {arg_space = offset, updfr_space = Nothing}, g)
+  where addBlock (Old.BasicBlock id ss) g =
           mkLabel id <*> mkStmts ss <*> g
         updfr_sz = 0 -- panic "upd frame size lost in cmm conversion"
-        mkStmts (CmmNop        : ss)  = mkNop        <*> mkStmts ss 
-        mkStmts (CmmComment s  : ss)  = mkComment s  <*> mkStmts ss
-        mkStmts (CmmAssign l r : ss)  = mkAssign l r <*> mkStmts ss
-        mkStmts (CmmStore  l r : ss)  = mkStore  l r <*> mkStmts ss
-        mkStmts (CmmCall (CmmCallee f conv) res args (CmmSafe _) CmmMayReturn : ss) =
-            mkCall f (conv', conv') (map hintlessCmm res) (map hintlessCmm args) updfr_sz
-            <*> mkStmts ss 
+        mkStmts (Old.CmmNop        : ss)  = mkNop        <*> mkStmts ss 
+        mkStmts (Old.CmmComment s  : ss)  = mkComment s  <*> mkStmts ss
+        mkStmts (Old.CmmAssign l r : ss)  = mkAssign l r <*> mkStmts ss
+        mkStmts (Old.CmmStore  l r : ss)  = mkStore  l r <*> mkStmts ss
+        mkStmts (Old.CmmCall (Old.CmmCallee f conv) res args (Old.CmmSafe _) Old.CmmMayReturn : ss) =
+            mkCall f (conv', conv') (map Old.hintlessCmm res) (map Old.hintlessCmm args) updfr_sz
+            <*> mkStmts ss
               where conv' = Foreign (ForeignConvention conv [] []) -- JD: DUBIOUS
-        mkStmts (CmmCall (CmmPrim {}) _ _ (CmmSafe _) _ : _) =
+        mkStmts (Old.CmmCall (Old.CmmPrim {}) _ _ (Old.CmmSafe _) _ : _) =
             panic "safe call to a primitive CmmPrim CallishMachOp"
-        mkStmts (CmmCall f res args CmmUnsafe CmmMayReturn : ss) =
+        mkStmts (Old.CmmCall f res args Old.CmmUnsafe Old.CmmMayReturn : ss) =
                       mkUnsafeCall (convert_target f res args)
-                       (strip_hints res) (strip_hints args)
+                        (strip_hints res) (strip_hints args)
                       <*> mkStmts ss
-        mkStmts (CmmCondBranch e l : fbranch) =
+        mkStmts (Old.CmmCondBranch e l : fbranch) =
             mkCmmIfThenElse e (mkBranch l) (mkStmts fbranch)
         mkStmts (last : []) = mkLast last
         mkStmts []          = bad "fell off end"
         mkStmts (_ : _ : _) = bad "last node not at end"
         bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g)
-        mkLast (CmmCall (CmmCallee f conv) []     args _ CmmNeverReturns) =
-            mkFinalCall f conv (map hintlessCmm args) updfr_sz
-        mkLast (CmmCall (CmmPrim {}) _ _ _ CmmNeverReturns) =
+        mkLast (Old.CmmCall (Old.CmmCallee f conv) []     args _ Old.CmmNeverReturns) =
+            mkFinalCall f conv (map Old.hintlessCmm args) updfr_sz
+        mkLast (Old.CmmCall (Old.CmmPrim {}) _ _ _ Old.CmmNeverReturns) =
             panic "Call to CmmPrim never returns?!"
-        mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
+        mkLast (Old.CmmSwitch scrutinee table) = mkSwitch scrutinee table
         -- SURELY, THESE HINTLESS ARGS ARE WRONG AND WILL BE FIXED WHEN CALLING
         -- CONVENTIONS ARE HONORED?
-        mkLast (CmmJump tgt args)          = mkJump   tgt (map hintlessCmm args) updfr_sz
-        mkLast (CmmReturn ress)            =
-          mkReturnSimple (map hintlessCmm ress) updfr_sz
-        mkLast (CmmBranch tgt)             = mkBranch tgt
-        mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) =
+        mkLast (Old.CmmJump tgt args)          = mkJump   tgt (map Old.hintlessCmm args) updfr_sz
+        mkLast (Old.CmmReturn ress)            =
+          mkReturnSimple (map Old.hintlessCmm ress) updfr_sz
+        mkLast (Old.CmmBranch tgt)             = mkBranch tgt
+        mkLast (Old.CmmCall _f (_:_) _args _ Old.CmmNeverReturns) =
                    panic "Call never returns but has results?!"
         mkLast _ = panic "fell off end of block"
 
-strip_hints :: [CmmHinted a] -> [a]
-strip_hints = map hintlessCmm
+strip_hints :: [Old.CmmHinted a] -> [a]
+strip_hints = map Old.hintlessCmm
 
-convert_target :: CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals -> MidCallTarget
-convert_target (CmmCallee e cc) ress  args  = ForeignTarget e (ForeignConvention cc (map cmmHint args) (map cmmHint ress))
-convert_target (CmmPrim op)       _ress _args = PrimTarget op
+convert_target :: Old.CmmCallTarget -> Old.HintedCmmFormals -> Old.HintedCmmActuals -> ForeignTarget
+convert_target (Old.CmmCallee e cc) ress  args  = ForeignTarget e (ForeignConvention cc (map Old.cmmHint args) (map Old.cmmHint ress))
+convert_target (Old.CmmPrim op)           _ress _args = PrimTarget op
 
-add_hints :: Convention -> ValueDirection -> [a] -> [CmmHinted a]
-add_hints conv vd args = zipWith CmmHinted args (get_hints conv vd)
+data ValueDirection = Arguments | Results
+
+add_hints :: Convention -> ValueDirection -> [a] -> [Old.CmmHinted a]
+add_hints conv vd args = zipWith Old.CmmHinted args (get_hints conv vd)
 
 get_hints :: Convention -> ValueDirection -> [ForeignHint]
 get_hints (Foreign (ForeignConvention _ hints _)) Arguments = hints
 get_hints (Foreign (ForeignConvention _ _ hints)) Results   = hints
-get_hints _other_conv                            _vd       = repeat NoHint
+get_hints _other_conv                             _vd       = repeat NoHint
 
-get_conv :: MidCallTarget -> Convention
+get_conv :: ForeignTarget -> Convention
 get_conv (PrimTarget _)       = NativeNodeCall -- JD: SUSPICIOUS
 get_conv (ForeignTarget _ fc) = Foreign fc
 
-cmm_target :: MidCallTarget -> CmmCallTarget
-cmm_target (PrimTarget op) = CmmPrim op
-cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = CmmCallee e cc
-
-ofZgraph :: CmmGraph -> ListGraph CmmStmt
-ofZgraph g = ListGraph $ swallow blocks
-    where blocks = G.postorder_dfs g
-          -- | the next two functions are hooks on which to hang debugging info
-          extend_entry stmts = stmts
-          extend_block _id stmts = stmts
-          _extend_entry stmts = scomment showblocks : scomment cscomm : stmts
-          showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++
-                       concat (map (\(G.Block id _) -> " " ++ show id) blocks)
-          cscomm = "Call successors are" ++
-                   (concat $ map (\id -> " " ++ show id) $ blockSetToList call_succs)
-          swallow [] = []
-          swallow (G.Block id t : rest) = tail id [] t rest
-          tail id prev' (G.ZTail m t)             rest = tail id (mid m : prev') t rest
-          tail id prev' (G.ZLast G.LastExit)      rest = exit id prev' rest
-          tail id prev' (G.ZLast (G.LastOther l)) rest = last id prev' l rest
-          mid (MidComment s)  = CmmComment s
-          mid (MidAssign l r) = CmmAssign l r
-          mid (MidStore  l r) = CmmStore  l r
-          mid (MidForeignCall _ (PrimTarget MO_Touch) _ _) = CmmNop
-          mid (MidForeignCall _ target ress args)
-               = CmmCall (cmm_target target)
-                         (add_hints conv Results   ress) 
-                         (add_hints conv Arguments args) 
-                         CmmUnsafe CmmMayReturn
-               where
-                 conv = get_conv target
-          block' id prev'
-              | id == G.lg_entry g = BasicBlock id $ extend_entry    (reverse prev')
-              | otherwise          = BasicBlock id $ extend_block id (reverse prev')
-          last id prev' l n =
-            let endblock stmt = block' id (stmt : prev') : swallow n in
-            case l of
-              LastBranch tgt ->
-                  case n of
-                    -- THIS OPT IS WRONG -- LABELS CAN SHOW UP ELSEWHERE IN THE GRAPH
-                    --G.Block id' _ t : bs
-                    --    | tgt == id', unique_pred id' 
-                    --    -> tail id prev' t bs -- optimize out redundant labels
-                    _ -> endblock (CmmBranch tgt)
-              LastCondBranch expr tid fid ->
-                  case n of
-                    G.Block id' t : bs
-                      -- It would be better to handle earlier, but we still must
-                      -- generate correct code here.
-                      | id' == fid, tid == fid, unique_pred id' ->
-                                 tail id prev' t bs
-                      | id' == fid, unique_pred id' ->
-                                 tail id (CmmCondBranch expr tid : prev') t bs
-                      | id' == tid, unique_pred id',
-                        Just e' <- maybeInvertCmmExpr expr ->
-                                 tail id (CmmCondBranch e'   fid : prev') t bs
-                    _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
-                         in block' id instrs' : swallow n
-              LastSwitch arg ids   -> endblock $ CmmSwitch arg $ ids
-              LastCall e _ _ _ _ -> endblock $ CmmJump e []
-          exit id prev' n = -- highly irregular (assertion violation?)
-              let endblock stmt = block' id (stmt : prev') : swallow n in
-              case n of [] -> endblock (scomment "procedure falls off end")
-                        G.Block id' t : bs -> 
-                            if unique_pred id' then
-                                tail id (scomment "went thru exit" : prev') t bs 
-                            else
-                                endblock (CmmBranch id')
-          preds = zipPreds g
-          single_preds =
-              let add b single =
-                    let id = G.blockId b
-                    in  case lookupBlockEnv preds id of
-                          Nothing -> single
-                          Just s -> if sizeBlockSet s == 1 then
-                                        extendBlockSet single id
-                                    else single
-              in  G.fold_blocks add emptyBlockSet g
-          unique_pred id = elemBlockSet id single_preds
-          call_succs = 
-              let add b succs =
-                      case G.last (G.unzip b) of
-                        G.LastOther (LastCall _ (Just id) _ _ _) ->
-                          extendBlockSet succs id
-                        _ -> succs
-              in  G.fold_blocks add emptyBlockSet g
-          _is_call_succ id = elemBlockSet id call_succs
-
-scomment :: String -> CmmStmt
-scomment s = CmmComment $ mkFastString s
+cmm_target :: ForeignTarget -> Old.CmmCallTarget
+cmm_target (PrimTarget op) = Old.CmmPrim op
+cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = Old.CmmCallee e cc
+
+ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt
+ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
+  -- We catenated some blocks in the conversion process,
+  -- because of the CmmCondBranch -- the machine code does not have
+  -- 'jump here or there' instruction, but has 'jump if true' instruction.
+  -- As OldCmm has the same instruction, so we use it.
+  -- When we are doing this, we also catenate normal goto-s (it is for free).
+
+  -- Exactly, we catenate blocks with nonentry labes, that are
+  --   a) mentioned exactly once as a successor
+  --   b) any of 1) are a target of a goto
+  --             2) are false branch target of a conditional jump
+  --             3) are true branch target of a conditional jump, and
+  --                  the false branch target is a successor of at least 2 blocks
+  --                  and the condition can be inverted
+  -- The complicated rule 3) is here because we need to assign at most one
+  -- catenable block to a CmmCondBranch.
+    where preds :: BlockEnv [CmmNode O C]
+          preds = mapFold add mapEmpty $ toBlockMap g
+            where add block env = foldr (add' $ lastNode block) env (successors block)
+                  add' :: CmmNode O C -> BlockId -> BlockEnv [CmmNode O C] -> BlockEnv [CmmNode O C]
+                  add' node succ env = mapInsert succ (node : (mapLookup succ env `orElse` [])) env
+
+          to_be_catenated :: BlockId -> Bool
+          to_be_catenated id | id == g_entry g = False
+                             | Just [CmmBranch _] <- mapLookup id preds = True
+                             | Just [CmmCondBranch _ _ f] <- mapLookup id preds
+                             , f == id = True
+                             | Just [CmmCondBranch e t f] <- mapLookup id preds
+                             , t == id
+                             , Just (_:_:_) <- mapLookup f preds
+                             , Just _ <- maybeInvertCmmExpr e = True
+          to_be_catenated _ = False
+
+          convert_block block | to_be_catenated (entryLabel block) = Nothing
+          convert_block block = Just $ foldBlockNodesB3 (first, middle, last) block ()
+            where first :: CmmNode C O -> [Old.CmmStmt] -> Old.CmmBasicBlock
+                  first (CmmEntry bid) stmts = Old.BasicBlock bid stmts
+
+                  middle :: CmmNode O O -> [Old.CmmStmt] -> [Old.CmmStmt]
+                  middle node stmts = stmt : stmts
+                    where stmt :: Old.CmmStmt
+                          stmt = case node of
+                            CmmComment s                                   -> Old.CmmComment s
+                            CmmAssign l r                                  -> Old.CmmAssign l r
+                            CmmStore  l r                                  -> Old.CmmStore  l r
+                            CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop
+                            CmmUnsafeForeignCall target ress args          -> 
+                              Old.CmmCall (cmm_target target)
+                                          (add_hints (get_conv target) Results   ress)
+                                          (add_hints (get_conv target) Arguments args)
+                                          Old.CmmUnsafe Old.CmmMayReturn
+
+                  last :: CmmNode O C -> () -> [Old.CmmStmt]
+                  last node _ = stmts
+                    where stmts :: [Old.CmmStmt]
+                          stmts = case node of
+                            CmmBranch tgt | to_be_catenated tgt -> tail_of tgt
+                                          | otherwise -> [Old.CmmBranch tgt]
+                            CmmCondBranch expr tid fid
+                              | to_be_catenated fid -> Old.CmmCondBranch expr tid : tail_of fid
+                              | to_be_catenated tid
+                              , Just expr' <- maybeInvertCmmExpr expr -> Old.CmmCondBranch expr' fid : tail_of tid
+                              | otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid]
+                            CmmSwitch arg ids -> [Old.CmmSwitch arg ids]
+                            CmmCall e _ _ _ _ -> [Old.CmmJump e []]
+                            CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall"
+                          tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of
+                                          Old.BasicBlock _ stmts -> stmts
+                            where Just block = mapLookup bid $ toBlockMap g
diff --git a/compiler/cmm/CmmDecl.hs b/compiler/cmm/CmmDecl.hs
new file mode 100644 (file)
index 0000000..e2da59b
--- /dev/null
@@ -0,0 +1,150 @@
+-----------------------------------------------------------------------------
+--
+-- Cmm data types
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module CmmDecl (
+        GenCmm(..), GenCmmTop(..),
+        CmmInfoTable(..), HasStaticClosure, ClosureTypeInfo(..), ConstrDescription,
+        ProfilingInfo(..), ClosureTypeTag,
+        CmmActual, CmmActuals, CmmFormal, CmmFormals, ForeignHint(..),
+        CmmStatic(..), Section(..),
+  ) where
+
+#include "HsVersions.h"
+
+import CmmExpr
+import CLabel
+import SMRep
+import ClosureInfo
+
+import Data.Word
+
+
+-- A [[BlockId]] is a local label.
+-- Local labels must be unique within an entire compilation unit, not
+-- just a single top-level item, because local labels map one-to-one
+-- with assembly-language labels.
+
+-----------------------------------------------------------------------------
+--  GenCmm, GenCmmTop
+-----------------------------------------------------------------------------
+
+-- A file is a list of top-level chunks.  These may be arbitrarily
+-- re-orderd during code generation.
+
+-- GenCmm is abstracted over
+--   d, the type of static data elements in CmmData
+--   h, the static info preceding the code of a CmmProc
+--   g, the control-flow graph of a CmmProc
+--
+-- We expect there to be two main instances of this type:
+--   (a) C--, i.e. populated with various C-- constructs
+--       (Cmm and RawCmm in OldCmm.hs)
+--   (b) Native code, populated with data/instructions
+--
+-- A second family of instances based on Hoopl is in Cmm.hs.
+--
+newtype GenCmm d h g = Cmm [GenCmmTop d h g]
+
+-- | A top-level chunk, abstracted over the type of the contents of
+-- the basic blocks (Cmm or instructions are the likely instantiations).
+data GenCmmTop d h g
+  = CmmProc     -- A procedure
+     h                 -- Extra header such as the info table
+     CLabel            -- Used to generate both info & entry labels
+     g                 -- Control-flow graph for the procedure's code
+
+  | CmmData     -- Static data
+        Section
+        [d]
+
+
+-- A basic block containing a single label, at the beginning.
+-- The list of basic blocks in a top-level code block may be re-ordered.
+-- Fall-through is not allowed: there must be an explicit jump at the
+-- end of each basic block, but the code generator might rearrange basic
+-- blocks in order to turn some jumps into fallthroughs.
+
+
+-----------------------------------------------------------------------------
+--     Info Tables
+-----------------------------------------------------------------------------
+
+-- Info table as a haskell data type
+data CmmInfoTable
+  = CmmInfoTable
+      HasStaticClosure
+      ProfilingInfo
+      ClosureTypeTag -- Int
+      ClosureTypeInfo
+  | CmmNonInfoTable   -- Procedure doesn't need an info table
+
+type HasStaticClosure = Bool
+
+-- TODO: The GC target shouldn't really be part of CmmInfo
+-- as it doesn't appear in the resulting info table.
+-- It should be factored out.
+
+data ClosureTypeInfo
+  = ConstrInfo ClosureLayout ConstrTag ConstrDescription
+  | FunInfo    ClosureLayout C_SRT FunArity ArgDescr SlowEntry
+  | ThunkInfo  ClosureLayout C_SRT
+  | ThunkSelectorInfo SelectorOffset C_SRT
+  | ContInfo
+      [Maybe LocalReg]  -- Stack layout: Just x, an item x
+                        --               Nothing: a 1-word gap
+                        -- Start of list is the *young* end
+      C_SRT
+
+-- TODO: These types may need refinement
+data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc
+type ClosureTypeTag = StgHalfWord
+type ClosureLayout = (StgHalfWord, StgHalfWord) -- ptrs, nptrs
+type ConstrTag = StgHalfWord
+type ConstrDescription = CmmLit
+type FunArity = StgHalfWord
+type SlowEntry = CmmLit
+  -- We would like this to be a CLabel but
+  -- for now the parser sets this to zero on an INFO_TABLE_FUN.
+type SelectorOffset = StgWord
+
+type CmmActual = CmmExpr
+type CmmFormal = LocalReg
+type CmmActuals = [CmmActual]
+type CmmFormals = [CmmFormal]
+
+data ForeignHint
+  = NoHint | AddrHint | SignedHint
+  deriving( Eq )
+        -- Used to give extra per-argument or per-result
+        -- information needed by foreign calling conventions
+
+-----------------------------------------------------------------------------
+--              Static Data
+-----------------------------------------------------------------------------
+
+data Section
+  = Text
+  | Data
+  | ReadOnlyData
+  | RelocatableReadOnlyData
+  | UninitialisedData
+  | ReadOnlyData16      -- .rodata.cst16 on x86_64, 16-byte aligned
+  | OtherSection String
+
+data CmmStatic
+  = CmmStaticLit CmmLit
+        -- a literal value, size given by cmmLitRep of the literal.
+  | CmmUninitialised Int
+        -- uninitialised data, N bytes long
+  | CmmAlign Int
+        -- align to next N-byte boundary (N must be a power of 2).
+  | CmmDataLabel CLabel
+        -- label the current position in this section.
+  | CmmString [Word8]
+        -- string of 8-bit values only, not zero terminated.
+
index 8a5bab1..3ae2996 100644 (file)
@@ -1,18 +1,6 @@
 
 module CmmExpr
-    ( CmmType  -- Abstract 
-    , b8, b16, b32, b64, f32, f64, bWord, bHalfWord, gcWord
-    , cInt, cLong
-    , cmmBits, cmmFloat
-    , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood
-    , isFloatType, isGcPtrType, isWord32, isWord64, isFloat64, isFloat32
-    , Width(..)
-    , widthInBits, widthInBytes, widthInLog, widthFromBytes
-    , wordWidth, halfWordWidth, cIntWidth, cLongWidth
-    , narrowU, narrowS
-    , CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
+    ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
     , CmmReg(..), cmmRegType
     , CmmLit(..), cmmLitType
     , LocalReg(..), localRegType
@@ -24,37 +12,20 @@ module CmmExpr
             , plusRegSet, minusRegSet, timesRegSet
     , regUsedIn
     , Area(..), AreaId(..), SubArea, SubAreaSet, AreaMap, isStackSlotOf
-   -- MachOp
-    , MachOp(..) 
-    , pprMachOp, isCommutableMachOp, isAssociativeMachOp
-    , isComparisonMachOp, machOpResultType
-    , machOpArgReps, maybeInvertComparison
-   -- MachOp builders
-    , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
-    , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem
-    , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe 
-    , mo_wordULe, mo_wordUGt, mo_wordULt
-    , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr
-    , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
-    , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord
-    , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32
-   )
+    , module CmmMachOp
+    , module CmmType
+    )
 where
 
 #include "HsVersions.h"
 
+import CmmType
+import CmmMachOp
 import BlockId
 import CLabel
-import Constants
-import FastString
-import Outputable
 import Unique
 import UniqSet
 
-import Data.Word
-import Data.Int
 import Data.Map (Map)
 
 -----------------------------------------------------------------------------
@@ -319,6 +290,12 @@ instance UserOfSlots a => UserOfSlots [a] where
   foldSlotsUsed _ set [] = set
   foldSlotsUsed f set (x:xs) = foldSlotsUsed f (foldSlotsUsed f set x) xs
 
+instance DefinerOfSlots a => DefinerOfSlots [a] where
+  foldSlotsDefd _ set [] = set
+  foldSlotsDefd f set (x:xs) = foldSlotsDefd f (foldSlotsDefd f set x) xs
+
+instance DefinerOfSlots SubArea where
+    foldSlotsDefd f z a = f z a
 
 -----------------------------------------------------------------------------
 --             Global STG registers
@@ -464,695 +441,3 @@ globalRegType (LongReg _)         = cmmBits W64
 globalRegType Hp               = gcWord        -- The initialiser for all 
                                                -- dynamically allocated closures
 globalRegType _                        = bWord
-
-
------------------------------------------------------------------------------
---             CmmType
------------------------------------------------------------------------------
-
-  -- NOTE: CmmType is an abstract type, not exported from this
-  --      module so you can easily change its representation
-  --
-  -- However Width is exported in a concrete way, 
-  -- and is used extensively in pattern-matching
-
-data CmmType   -- The important one!
-  = CmmType CmmCat Width 
-
-data CmmCat    -- "Category" (not exported)
-   = GcPtrCat  -- GC pointer
-   | BitsCat   -- Non-pointer
-   | FloatCat  -- Float
-   deriving( Eq )
-       -- See Note [Signed vs unsigned] at the end
-
-instance Outputable CmmType where
-  ppr (CmmType cat wid) = ppr cat <> ppr (widthInBits wid)
-
-instance Outputable CmmCat where
-  ppr FloatCat = ptext $ sLit("F")
-  ppr _        = ptext $ sLit("I")
--- Temp Jan 08
---  ppr FloatCat       = ptext $ sLit("float")
---  ppr BitsCat   = ptext $ sLit("bits")
---  ppr GcPtrCat  = ptext $ sLit("gcptr")
-
--- Why is CmmType stratified?  For native code generation, 
--- most of the time you just want to know what sort of register
--- to put the thing in, and for this you need to know how
--- many bits thing has and whether it goes in a floating-point
--- register.  By contrast, the distinction between GcPtr and
--- GcNonPtr is of interest to only a few parts of the code generator.
-
--------- Equality on CmmType --------------
--- CmmType is *not* an instance of Eq; sometimes we care about the
--- Gc/NonGc distinction, and sometimes we don't
--- So we use an explicit function to force you to think about it
-cmmEqType :: CmmType -> CmmType -> Bool        -- Exact equality
-cmmEqType (CmmType c1 w1) (CmmType c2 w2) = c1==c2 && w1==w2
-
-cmmEqType_ignoring_ptrhood :: CmmType -> CmmType -> Bool
-  -- This equality is temporary; used in CmmLint
-  -- but the RTS files are not yet well-typed wrt pointers
-cmmEqType_ignoring_ptrhood (CmmType c1 w1) (CmmType c2 w2)
-   = c1 `weak_eq` c2 && w1==w2
-   where
-      FloatCat `weak_eq` FloatCat = True 
-      FloatCat `weak_eq` _other          = False
-      _other   `weak_eq` FloatCat = False
-      _word1   `weak_eq` _word2   = True       -- Ignores GcPtr
-
---- Simple operations on CmmType -----
-typeWidth :: CmmType -> Width
-typeWidth (CmmType _ w) = w
-
-cmmBits, cmmFloat :: Width -> CmmType
-cmmBits  = CmmType BitsCat
-cmmFloat = CmmType FloatCat
-
--------- Common CmmTypes ------------
--- Floats and words of specific widths
-b8, b16, b32, b64, f32, f64 :: CmmType
-b8     = cmmBits W8
-b16    = cmmBits W16
-b32    = cmmBits W32
-b64    = cmmBits W64
-f32    = cmmFloat W32
-f64    = cmmFloat W64
-
--- CmmTypes of native word widths
-bWord, bHalfWord, gcWord :: CmmType
-bWord     = cmmBits wordWidth
-bHalfWord = cmmBits halfWordWidth
-gcWord    = CmmType GcPtrCat wordWidth
-
-cInt, cLong :: CmmType
-cInt  = cmmBits cIntWidth
-cLong = cmmBits cLongWidth
-
-
------------- Predicates ----------------
-isFloatType, isGcPtrType :: CmmType -> Bool
-isFloatType (CmmType FloatCat    _) = True
-isFloatType _other                 = False
-
-isGcPtrType (CmmType GcPtrCat _) = True
-isGcPtrType _other              = False
-
-isWord32, isWord64, isFloat32, isFloat64 :: CmmType -> Bool
--- isWord64 is true of 64-bit non-floats (both gc-ptrs and otherwise)
--- isFloat32 and 64 are obvious
-
-isWord64 (CmmType BitsCat  W64) = True
-isWord64 (CmmType GcPtrCat W64) = True
-isWord64 _other                        = False
-
-isWord32 (CmmType BitsCat  W32) = True
-isWord32 (CmmType GcPtrCat W32) = True
-isWord32 _other                        = False
-
-isFloat32 (CmmType FloatCat W32) = True
-isFloat32 _other                = False
-
-isFloat64 (CmmType FloatCat W64) = True
-isFloat64 _other                = False
-
------------------------------------------------------------------------------
---             Width
------------------------------------------------------------------------------
-
-data Width   = W8 | W16 | W32 | W64 
-            | W80      -- Extended double-precision float, 
-                       -- used in x86 native codegen only.
-                       -- (we use Ord, so it'd better be in this order)
-            | W128
-            deriving (Eq, Ord, Show)
-
-instance Outputable Width where
-   ppr rep = ptext (mrStr rep)
-
-mrStr :: Width -> LitString
-mrStr W8   = sLit("W8")
-mrStr W16  = sLit("W16")
-mrStr W32  = sLit("W32")
-mrStr W64  = sLit("W64")
-mrStr W128 = sLit("W128")
-mrStr W80  = sLit("W80")
-
-
--------- Common Widths  ------------
-wordWidth, halfWordWidth :: Width
-wordWidth | wORD_SIZE == 4 = W32
-         | wORD_SIZE == 8 = W64
-         | otherwise      = panic "MachOp.wordRep: Unknown word size"
-
-halfWordWidth | wORD_SIZE == 4 = W16
-             | wORD_SIZE == 8 = W32
-             | otherwise      = panic "MachOp.halfWordRep: Unknown word size"
-
--- cIntRep is the Width for a C-language 'int'
-cIntWidth, cLongWidth :: Width
-#if SIZEOF_INT == 4
-cIntWidth = W32
-#elif  SIZEOF_INT == 8
-cIntWidth = W64
-#endif
-
-#if SIZEOF_LONG == 4
-cLongWidth = W32
-#elif  SIZEOF_LONG == 8
-cLongWidth = W64
-#endif
-
-widthInBits :: Width -> Int
-widthInBits W8   = 8
-widthInBits W16  = 16
-widthInBits W32  = 32
-widthInBits W64  = 64
-widthInBits W128 = 128
-widthInBits W80  = 80
-
-widthInBytes :: Width -> Int
-widthInBytes W8   = 1
-widthInBytes W16  = 2
-widthInBytes W32  = 4
-widthInBytes W64  = 8
-widthInBytes W128 = 16
-widthInBytes W80  = 10
-
-widthFromBytes :: Int -> Width
-widthFromBytes 1  = W8
-widthFromBytes 2  = W16
-widthFromBytes 4  = W32
-widthFromBytes 8  = W64
-widthFromBytes 16 = W128
-widthFromBytes 10 = W80
-widthFromBytes n  = pprPanic "no width for given number of bytes" (ppr n)
-
--- log_2 of the width in bytes, useful for generating shifts.
-widthInLog :: Width -> Int
-widthInLog W8   = 0
-widthInLog W16  = 1
-widthInLog W32  = 2
-widthInLog W64  = 3
-widthInLog W128 = 4
-widthInLog W80  = panic "widthInLog: F80"
-
--- widening / narrowing
-
-narrowU :: Width -> Integer -> Integer
-narrowU W8  x = fromIntegral (fromIntegral x :: Word8)
-narrowU W16 x = fromIntegral (fromIntegral x :: Word16)
-narrowU W32 x = fromIntegral (fromIntegral x :: Word32)
-narrowU W64 x = fromIntegral (fromIntegral x :: Word64)
-narrowU _ _ = panic "narrowTo"
-
-narrowS :: Width -> Integer -> Integer
-narrowS W8  x = fromIntegral (fromIntegral x :: Int8)
-narrowS W16 x = fromIntegral (fromIntegral x :: Int16)
-narrowS W32 x = fromIntegral (fromIntegral x :: Int32)
-narrowS W64 x = fromIntegral (fromIntegral x :: Int64)
-narrowS _ _ = panic "narrowTo"
-
------------------------------------------------------------------------------
---             MachOp
------------------------------------------------------------------------------
-
-{- 
-Implementation notes:
-
-It might suffice to keep just a width, without distinguishing between
-floating and integer types.  However, keeping the distinction will
-help the native code generator to assign registers more easily.
--}
-
-
-{- |
-Machine-level primops; ones which we can reasonably delegate to the
-native code generators to handle.  Basically contains C's primops
-and no others.
-
-Nomenclature: all ops indicate width and signedness, where
-appropriate.  Widths: 8\/16\/32\/64 means the given size, obviously.
-Nat means the operation works on STG word sized objects.
-Signedness: S means signed, U means unsigned.  For operations where
-signedness is irrelevant or makes no difference (for example
-integer add), the signedness component is omitted.
-
-An exception: NatP is a ptr-typed native word.  From the point of
-view of the native code generators this distinction is irrelevant,
-but the C code generator sometimes needs this info to emit the
-right casts.  
--}
-
-data MachOp
-  -- Integer operations (insensitive to signed/unsigned)
-  = MO_Add Width
-  | MO_Sub Width
-  | MO_Eq  Width
-  | MO_Ne  Width
-  | MO_Mul Width               -- low word of multiply
-
-  -- Signed multiply/divide
-  | MO_S_MulMayOflo Width      -- nonzero if signed multiply overflows
-  | MO_S_Quot Width            -- signed / (same semantics as IntQuotOp)
-  | MO_S_Rem  Width            -- signed % (same semantics as IntRemOp)
-  | MO_S_Neg  Width            -- unary -
-
-  -- Unsigned multiply/divide
-  | MO_U_MulMayOflo Width      -- nonzero if unsigned multiply overflows
-  | MO_U_Quot Width            -- unsigned / (same semantics as WordQuotOp)
-  | MO_U_Rem  Width            -- unsigned % (same semantics as WordRemOp)
-
-  -- Signed comparisons
-  | MO_S_Ge Width
-  | MO_S_Le Width
-  | MO_S_Gt Width
-  | MO_S_Lt Width
-
-  -- Unsigned comparisons
-  | MO_U_Ge Width
-  | MO_U_Le Width
-  | MO_U_Gt Width
-  | MO_U_Lt Width
-
-  -- Floating point arithmetic
-  | MO_F_Add  Width
-  | MO_F_Sub  Width
-  | MO_F_Neg  Width            -- unary -
-  | MO_F_Mul  Width
-  | MO_F_Quot Width
-
-  -- Floating point comparison
-  | MO_F_Eq Width
-  | MO_F_Ne Width
-  | MO_F_Ge Width
-  | MO_F_Le Width
-  | MO_F_Gt Width
-  | MO_F_Lt Width
-
-  -- Bitwise operations.  Not all of these may be supported 
-  -- at all sizes, and only integral Widths are valid.
-  | MO_And   Width
-  | MO_Or    Width
-  | MO_Xor   Width
-  | MO_Not   Width
-  | MO_Shl   Width
-  | MO_U_Shr Width     -- unsigned shift right
-  | MO_S_Shr Width     -- signed shift right
-
-  -- Conversions.  Some of these will be NOPs.
-  -- Floating-point conversions use the signed variant.
-  | MO_SF_Conv Width Width     -- Signed int -> Float
-  | MO_FS_Conv Width Width     -- Float -> Signed int
-  | MO_SS_Conv Width Width     -- Signed int -> Signed int
-  | MO_UU_Conv Width Width     -- unsigned int -> unsigned int
-  | MO_FF_Conv Width Width     -- Float -> Float
-  deriving (Eq, Show)
-
-pprMachOp :: MachOp -> SDoc
-pprMachOp mo = text (show mo)
-
-
-
--- -----------------------------------------------------------------------------
--- Some common MachReps
-
--- A 'wordRep' is a machine word on the target architecture
--- Specifically, it is the size of an Int#, Word#, Addr# 
--- and the unit of allocation on the stack and the heap
--- Any pointer is also guaranteed to be a wordRep.
-
-mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
-    , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem
-    , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe 
-    , mo_wordULe, mo_wordUGt, mo_wordULt
-    , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr
-    , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
-    , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord
-    , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32
-    :: MachOp
-
-mo_wordAdd     = MO_Add wordWidth
-mo_wordSub     = MO_Sub wordWidth
-mo_wordEq      = MO_Eq  wordWidth
-mo_wordNe      = MO_Ne  wordWidth
-mo_wordMul     = MO_Mul wordWidth
-mo_wordSQuot   = MO_S_Quot wordWidth
-mo_wordSRem    = MO_S_Rem wordWidth
-mo_wordSNeg    = MO_S_Neg wordWidth
-mo_wordUQuot   = MO_U_Quot wordWidth
-mo_wordURem    = MO_U_Rem wordWidth
-
-mo_wordSGe     = MO_S_Ge  wordWidth
-mo_wordSLe     = MO_S_Le  wordWidth
-mo_wordSGt     = MO_S_Gt  wordWidth
-mo_wordSLt     = MO_S_Lt  wordWidth
-
-mo_wordUGe     = MO_U_Ge  wordWidth
-mo_wordULe     = MO_U_Le  wordWidth
-mo_wordUGt     = MO_U_Gt  wordWidth
-mo_wordULt     = MO_U_Lt  wordWidth
-
-mo_wordAnd     = MO_And wordWidth
-mo_wordOr      = MO_Or  wordWidth
-mo_wordXor     = MO_Xor wordWidth
-mo_wordNot     = MO_Not wordWidth
-mo_wordShl     = MO_Shl wordWidth
-mo_wordSShr    = MO_S_Shr wordWidth 
-mo_wordUShr    = MO_U_Shr wordWidth 
-
-mo_u_8To32     = MO_UU_Conv W8 W32
-mo_s_8To32     = MO_SS_Conv W8 W32
-mo_u_16To32    = MO_UU_Conv W16 W32
-mo_s_16To32    = MO_SS_Conv W16 W32
-
-mo_u_8ToWord   = MO_UU_Conv W8  wordWidth
-mo_s_8ToWord   = MO_SS_Conv W8  wordWidth
-mo_u_16ToWord  = MO_UU_Conv W16 wordWidth
-mo_s_16ToWord  = MO_SS_Conv W16 wordWidth
-mo_s_32ToWord  = MO_SS_Conv W32 wordWidth
-mo_u_32ToWord  = MO_UU_Conv W32 wordWidth
-
-mo_WordTo8     = MO_UU_Conv wordWidth W8
-mo_WordTo16    = MO_UU_Conv wordWidth W16
-mo_WordTo32    = MO_UU_Conv wordWidth W32
-
-mo_32To8       = MO_UU_Conv W32 W8
-mo_32To16      = MO_UU_Conv W32 W16
-
-
--- ----------------------------------------------------------------------------
--- isCommutableMachOp
-
-{- |
-Returns 'True' if the MachOp has commutable arguments.  This is used
-in the platform-independent Cmm optimisations.
-
-If in doubt, return 'False'.  This generates worse code on the
-native routes, but is otherwise harmless.
--}
-isCommutableMachOp :: MachOp -> Bool
-isCommutableMachOp mop = 
-  case mop of
-       MO_Add _                -> True
-       MO_Eq _                 -> True
-       MO_Ne _                 -> True
-       MO_Mul _                -> True
-       MO_S_MulMayOflo _       -> True
-       MO_U_MulMayOflo _       -> True
-       MO_And _                -> True
-       MO_Or _                 -> True
-       MO_Xor _                -> True
-       _other                  -> False
-
--- ----------------------------------------------------------------------------
--- isAssociativeMachOp
-
-{- |
-Returns 'True' if the MachOp is associative (i.e. @(x+y)+z == x+(y+z)@)
-This is used in the platform-independent Cmm optimisations.
-
-If in doubt, return 'False'.  This generates worse code on the
-native routes, but is otherwise harmless.
--}
-isAssociativeMachOp :: MachOp -> Bool
-isAssociativeMachOp mop = 
-  case mop of
-       MO_Add {} -> True       -- NB: does not include
-       MO_Mul {} -> True --     floatint point!
-       MO_And {} -> True
-       MO_Or  {} -> True
-       MO_Xor {} -> True
-       _other    -> False
-
--- ----------------------------------------------------------------------------
--- isComparisonMachOp
-
-{- | 
-Returns 'True' if the MachOp is a comparison.
-
-If in doubt, return False.  This generates worse code on the
-native routes, but is otherwise harmless.
--}
-isComparisonMachOp :: MachOp -> Bool
-isComparisonMachOp mop = 
-  case mop of
-    MO_Eq   _  -> True
-    MO_Ne   _  -> True
-    MO_S_Ge _  -> True
-    MO_S_Le _  -> True
-    MO_S_Gt _  -> True
-    MO_S_Lt _  -> True
-    MO_U_Ge _  -> True
-    MO_U_Le _  -> True
-    MO_U_Gt _  -> True
-    MO_U_Lt _  -> True
-    MO_F_Eq  {}        -> True
-    MO_F_Ne  {}        -> True
-    MO_F_Ge  {}        -> True
-    MO_F_Le  {}        -> True
-    MO_F_Gt  {}        -> True
-    MO_F_Lt  {}        -> True
-    _other     -> False
-
--- -----------------------------------------------------------------------------
--- Inverting conditions
-
--- Sometimes it's useful to be able to invert the sense of a
--- condition.  Not all conditional tests are invertible: in
--- particular, floating point conditionals cannot be inverted, because
--- there exist floating-point values which return False for both senses
--- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)).
-
-maybeInvertComparison :: MachOp -> Maybe MachOp
-maybeInvertComparison op
-  = case op of -- None of these Just cases include floating point
-       MO_Eq r   -> Just (MO_Ne r)
-       MO_Ne r   -> Just (MO_Eq r)
-       MO_U_Lt r -> Just (MO_U_Ge r)
-       MO_U_Gt r -> Just (MO_U_Le r)
-       MO_U_Le r -> Just (MO_U_Gt r)
-       MO_U_Ge r -> Just (MO_U_Lt r)
-       MO_S_Lt r -> Just (MO_S_Ge r)
-       MO_S_Gt r -> Just (MO_S_Le r)
-       MO_S_Le r -> Just (MO_S_Gt r)
-       MO_S_Ge r -> Just (MO_S_Lt r)
-       MO_F_Eq r -> Just (MO_F_Ne r)
-       MO_F_Ne r -> Just (MO_F_Eq r)
-       MO_F_Ge r -> Just (MO_F_Le r)
-       MO_F_Le r -> Just (MO_F_Ge r)   
-       MO_F_Gt r -> Just (MO_F_Lt r)   
-       MO_F_Lt r -> Just (MO_F_Gt r)   
-       _other    -> Nothing
-
--- ----------------------------------------------------------------------------
--- machOpResultType
-
-{- |
-Returns the MachRep of the result of a MachOp.
--}
-machOpResultType :: MachOp -> [CmmType] -> CmmType
-machOpResultType mop tys =
-  case mop of
-    MO_Add {}          -> ty1  -- Preserve GC-ptr-hood
-    MO_Sub {}          -> ty1  -- of first arg
-    MO_Mul    r                -> cmmBits r
-    MO_S_MulMayOflo r  -> cmmBits r
-    MO_S_Quot r                -> cmmBits r
-    MO_S_Rem  r                -> cmmBits r
-    MO_S_Neg  r                -> cmmBits r
-    MO_U_MulMayOflo r  -> cmmBits r
-    MO_U_Quot r                -> cmmBits r
-    MO_U_Rem  r                -> cmmBits r
-
-    MO_Eq {}           -> comparisonResultRep
-    MO_Ne {}           -> comparisonResultRep
-    MO_S_Ge {}         -> comparisonResultRep
-    MO_S_Le {}         -> comparisonResultRep
-    MO_S_Gt {}         -> comparisonResultRep
-    MO_S_Lt {}         -> comparisonResultRep
-
-    MO_U_Ge {}         -> comparisonResultRep
-    MO_U_Le {}         -> comparisonResultRep
-    MO_U_Gt {}         -> comparisonResultRep
-    MO_U_Lt {}         -> comparisonResultRep
-
-    MO_F_Add r         -> cmmFloat r
-    MO_F_Sub r         -> cmmFloat r
-    MO_F_Mul r         -> cmmFloat r
-    MO_F_Quot r                -> cmmFloat r
-    MO_F_Neg r         -> cmmFloat r
-    MO_F_Eq  {}                -> comparisonResultRep
-    MO_F_Ne  {}                -> comparisonResultRep
-    MO_F_Ge  {}                -> comparisonResultRep
-    MO_F_Le  {}                -> comparisonResultRep
-    MO_F_Gt  {}                -> comparisonResultRep
-    MO_F_Lt  {}                -> comparisonResultRep
-
-    MO_And {}          -> ty1  -- Used for pointer masking
-    MO_Or {}           -> ty1
-    MO_Xor {}          -> ty1
-    MO_Not   r         -> cmmBits r
-    MO_Shl   r         -> cmmBits r
-    MO_U_Shr r         -> cmmBits r
-    MO_S_Shr r         -> cmmBits r
-
-    MO_SS_Conv _ to    -> cmmBits to
-    MO_UU_Conv _ to    -> cmmBits to
-    MO_FS_Conv _ to    -> cmmBits to
-    MO_SF_Conv _ to    -> cmmFloat to
-    MO_FF_Conv _ to    -> cmmFloat to
-  where
-    (ty1:_) = tys
-
-comparisonResultRep :: CmmType
-comparisonResultRep = bWord  -- is it?
-
-
--- -----------------------------------------------------------------------------
--- machOpArgReps
-
--- | This function is used for debugging only: we can check whether an
--- application of a MachOp is "type-correct" by checking that the MachReps of
--- its arguments are the same as the MachOp expects.  This is used when 
--- linting a CmmExpr.
-
-machOpArgReps :: MachOp -> [Width]
-machOpArgReps op = 
-  case op of
-    MO_Add    r                -> [r,r]
-    MO_Sub    r                -> [r,r]
-    MO_Eq     r                -> [r,r]
-    MO_Ne     r                -> [r,r]
-    MO_Mul    r                -> [r,r]
-    MO_S_MulMayOflo r  -> [r,r]
-    MO_S_Quot r                -> [r,r]
-    MO_S_Rem  r                -> [r,r]
-    MO_S_Neg  r                -> [r]
-    MO_U_MulMayOflo r  -> [r,r]
-    MO_U_Quot r                -> [r,r]
-    MO_U_Rem  r                -> [r,r]
-
-    MO_S_Ge r          -> [r,r]
-    MO_S_Le r          -> [r,r]
-    MO_S_Gt r          -> [r,r]
-    MO_S_Lt r          -> [r,r]
-
-    MO_U_Ge r          -> [r,r]
-    MO_U_Le r          -> [r,r]
-    MO_U_Gt r          -> [r,r]
-    MO_U_Lt r          -> [r,r]
-
-    MO_F_Add r         -> [r,r]
-    MO_F_Sub r         -> [r,r]
-    MO_F_Mul r         -> [r,r]
-    MO_F_Quot r                -> [r,r]
-    MO_F_Neg r         -> [r]
-    MO_F_Eq  r         -> [r,r]
-    MO_F_Ne  r         -> [r,r]
-    MO_F_Ge  r         -> [r,r]
-    MO_F_Le  r         -> [r,r]
-    MO_F_Gt  r         -> [r,r]
-    MO_F_Lt  r         -> [r,r]
-
-    MO_And   r         -> [r,r]
-    MO_Or    r         -> [r,r]
-    MO_Xor   r         -> [r,r]
-    MO_Not   r         -> [r]
-    MO_Shl   r         -> [r,wordWidth]
-    MO_U_Shr r         -> [r,wordWidth]
-    MO_S_Shr r         -> [r,wordWidth]
-
-    MO_SS_Conv from _  -> [from]
-    MO_UU_Conv from _   -> [from]
-    MO_SF_Conv from _  -> [from]
-    MO_FS_Conv from _  -> [from]
-    MO_FF_Conv from _  -> [from]
-
-
--------------------------------------------------------------------------
-{-     Note [Signed vs unsigned]
-       ~~~~~~~~~~~~~~~~~~~~~~~~~
-Should a CmmType include a signed vs. unsigned distinction?
-
-This is very much like a "hint" in C-- terminology: it isn't necessary
-in order to generate correct code, but it might be useful in that the
-compiler can generate better code if it has access to higher-level
-hints about data.  This is important at call boundaries, because the
-definition of a function is not visible at all of its call sites, so
-the compiler cannot infer the hints.
-
-Here in Cmm, we're taking a slightly different approach.  We include
-the int vs. float hint in the MachRep, because (a) the majority of
-platforms have a strong distinction between float and int registers,
-and (b) we don't want to do any heavyweight hint-inference in the
-native code backend in order to get good code.  We're treating the
-hint more like a type: our Cmm is always completely consistent with
-respect to hints.  All coercions between float and int are explicit.
-
-What about the signed vs. unsigned hint?  This information might be
-useful if we want to keep sub-word-sized values in word-size
-registers, which we must do if we only have word-sized registers.
-
-On such a system, there are two straightforward conventions for
-representing sub-word-sized values:
-
-(a) Leave the upper bits undefined.  Comparison operations must
-    sign- or zero-extend both operands before comparing them,
-    depending on whether the comparison is signed or unsigned.
-
-(b) Always keep the values sign- or zero-extended as appropriate.
-    Arithmetic operations must narrow the result to the appropriate
-    size.
-
-A clever compiler might not use either (a) or (b) exclusively, instead
-it would attempt to minimize the coercions by analysis: the same kind
-of analysis that propagates hints around.  In Cmm we don't want to
-have to do this, so we plump for having richer types and keeping the
-type information consistent.
-
-If signed/unsigned hints are missing from MachRep, then the only
-choice we have is (a), because we don't know whether the result of an
-operation should be sign- or zero-extended.
-
-Many architectures have extending load operations, which work well
-with (b).  To make use of them with (a), you need to know whether the
-value is going to be sign- or zero-extended by an enclosing comparison
-(for example), which involves knowing above the context.  This is
-doable but more complex.
-
-Further complicating the issue is foreign calls: a foreign calling
-convention can specify that signed 8-bit quantities are passed as
-sign-extended 32 bit quantities, for example (this is the case on the
-PowerPC).  So we *do* need sign information on foreign call arguments.
-
-Pros for adding signed vs. unsigned to MachRep:
-
-  - It would let us use convention (b) above, and get easier
-    code generation for extending loads.
-
-  - Less information required on foreign calls.
-  
-  - MachOp type would be simpler
-
-Cons:
-
-  - More complexity
-
-  - What is the MachRep for a VanillaReg?  Currently it is
-    always wordRep, but now we have to decide whether it is
-    signed or unsigned.  The same VanillaReg can thus have
-    different MachReps in different parts of the program.
-
-  - Extra coercions cluttering up expressions.
-
-Currently for GHC, the foreign call point is moot, because we do our
-own promotion of sub-word-sized values to word-sized values.  The Int8
-type is represnted by an Int# which is kept sign-extended at all times
-(this is slightly naughty, because we're making assumptions about the
-C calling convention rather early on in the compiler).  However, given
-this, the cons outweigh the pros.
-
--}
-
index 2549453..a606da2 100644 (file)
@@ -2,12 +2,11 @@ module CmmInfo (
   emptyContInfoTable,
   cmmToRawCmm,
   mkInfoTable,
-  mkBareInfoTable
 ) where
 
 #include "HsVersions.h"
 
-import Cmm
+import OldCmm
 import CmmUtils
 
 import CLabel
@@ -18,7 +17,6 @@ import CgInfoTbls
 import CgCallConv
 import CgUtils
 import SMRep
-import ZipCfgCmmRep
 
 import Constants
 import Panic
@@ -29,10 +27,9 @@ import UniqSupply
 import Data.Bits
 
 -- When we split at proc points, we need an empty info table.
-emptyContInfoTable :: CmmInfo
-emptyContInfoTable =
-  CmmInfo Nothing Nothing (CmmInfoTable False (ProfilingInfo zero zero) rET_SMALL
-                                              (ContInfo [] NoC_SRT))
+emptyContInfoTable :: CmmInfoTable
+emptyContInfoTable = CmmInfoTable False (ProfilingInfo zero zero) rET_SMALL
+                                  (ContInfo [] NoC_SRT)
     where zero = CmmInt 0 wordWidth
 
 cmmToRawCmm :: [Cmm] -> IO [RawCmm]
@@ -78,10 +75,10 @@ cmmToRawCmm cmm = do
 
 mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
 mkInfoTable _    (CmmData sec dat) = [CmmData sec dat]
-mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) =
+mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label blocks) =
     case info of
       -- Code without an info table.  Easy.
-      CmmNonInfoTable -> [CmmProc [] entry_label arguments blocks]
+      CmmNonInfoTable -> [CmmProc [] entry_label blocks]
 
       CmmInfoTable _ (ProfilingInfo ty_prof cl_prof) type_tag type_info ->
           let info_label = entryLblToInfoLbl entry_label
@@ -91,7 +88,7 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) =
           -- A function entry point.
           FunInfo (ptrs, nptrs) srt fun_arity pap_bitmap slow_entry ->
               mkInfoTableAndCode info_label std_info fun_extra_bits entry_label
-                                 arguments blocks
+                                 blocks
             where
               fun_type = argDescrType pap_bitmap
               fun_extra_bits =
@@ -110,7 +107,7 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) =
           -- A constructor.
           ConstrInfo (ptrs, nptrs) con_tag descr ->
               mkInfoTableAndCode info_label std_info [con_name] entry_label
-                                 arguments blocks
+                                 blocks
               where
                 std_info = mkStdInfoTable ty_prof' cl_prof' type_tag con_tag layout
                 con_name = makeRelativeRefTo info_label descr
@@ -118,7 +115,7 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) =
           -- A thunk.
           ThunkInfo (ptrs, nptrs) srt ->
               mkInfoTableAndCode info_label std_info srt_label entry_label
-                                 arguments blocks
+                                 blocks
               where
                 std_info = mkStdInfoTable ty_prof' cl_prof' type_tag srt_bitmap layout
                 (srt_label, srt_bitmap) = mkSRTLit info_label srt
@@ -127,7 +124,7 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) =
           -- A selector thunk.
           ThunkSelectorInfo offset _srt ->
               mkInfoTableAndCode info_label std_info [{- no SRT -}] entry_label
-                                 arguments blocks
+                                 blocks
               where
                 std_info = mkStdInfoTable ty_prof' cl_prof' type_tag 0 (mkWordCLit offset)
 
@@ -135,7 +132,7 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) =
           ContInfo stack_layout srt ->
               liveness_data ++
               mkInfoTableAndCode info_label std_info srt_label entry_label
-                                 arguments blocks
+                                 blocks
               where
                 std_info = mkStdInfoTable ty_prof' cl_prof' maybe_big_type_tag srt_bitmap
                                           (makeRelativeRefTo info_label liveness_lit)
@@ -146,30 +143,18 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) =
                                      else type_tag
                 (srt_label, srt_bitmap) = mkSRTLit info_label srt
 
--- Generate a bare info table, not attached to any procedure.
-mkBareInfoTable :: CLabel -> Unique -> CmmInfoTable -> [CmmTopZ]
-mkBareInfoTable lbl uniq info =
-  case mkInfoTable uniq (CmmProc (CmmInfo Nothing Nothing info) lbl [] (ListGraph [])) of
-    [CmmProc d _ _ _] ->
-      ASSERT (tablesNextToCode)
-      [CmmData Data (d ++ [CmmDataLabel (entryLblToInfoLbl lbl)])]
-    [CmmData d s]     -> [CmmData d s]
-    _ -> panic "mkBareInfoTable expected to produce only data"
-
-
 -- Handle the differences between tables-next-to-code
 -- and not tables-next-to-code
 mkInfoTableAndCode :: CLabel
                    -> [CmmLit]
                    -> [CmmLit]
                    -> CLabel
-                   -> CmmFormals
                    -> ListGraph CmmStmt
                    -> [RawCmmTop]
-mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
+mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl blocks
   | tablesNextToCode   -- Reverse the extra_bits; and emit the top-level proc
   = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info))
-             entry_lbl args blocks]
+             entry_lbl blocks]
 
   | ListGraph [] <- blocks -- No code; only the info table is significant
   =            -- Use a zero place-holder in place of the 
@@ -178,7 +163,7 @@ mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
 
   | otherwise  -- Separately emit info table (with the function entry 
   =            -- point as first entry) and the entry code 
-    [CmmProc [] entry_lbl args blocks,
+    [CmmProc [] entry_lbl blocks,
      mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)]
 
 mkSRTLit :: CLabel
index 50e9aea..0a19290 100644 (file)
@@ -23,7 +23,7 @@ module CmmLex (
    CmmToken(..), cmmlex,
   ) where
 
-import Cmm
+import OldCmm
 import Lexer
 
 import SrcLoc
index 2fc4a74..95b1eef 100644 (file)
@@ -17,10 +17,10 @@ module CmmLint (
   ) where
 
 import BlockId
-import Cmm
+import OldCmm
 import CLabel
 import Outputable
-import PprCmm
+import OldPprCmm()
 import Constants
 import FastString
 
@@ -48,9 +48,9 @@ runCmmLint l p =
        Right _  -> Nothing
 
 lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
-lintCmmTop (CmmProc _ lbl (ListGraph blocks))
+lintCmmTop (CmmProc _ lbl (ListGraph blocks))
   = addLintInfo (text "in proc " <> pprCLabel lbl) $
-        let labels = foldl (\s b -> extendBlockSet s (blockId b)) emptyBlockSet blocks
+        let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks
        in  mapM_ (lintCmmBlock labels) blocks
 
 lintCmmTop (CmmData {})
@@ -142,7 +142,7 @@ lintCmmStmt labels = lint
           lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . hintlessCmm) args
           lint (CmmReturn ress) = mapM_ (lintCmmExpr . hintlessCmm) ress
           lint (CmmBranch id)    = checkTarget id
-          checkTarget id = if elemBlockSet id labels then return ()
+          checkTarget id = if setMember id labels then return ()
                            else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
 
 lintTarget :: CmmCallTarget -> CmmLint ()
@@ -180,14 +180,14 @@ addLintInfo info thing = CmmLint $
 cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
 cmmLintMachOpErr expr argsRep opExpectsRep
      = cmmLintErr (text "in MachOp application: " $$ 
-                                       nest 2 (pprExpr expr) $$
+                                       nest 2 (ppr expr) $$
                                        (text "op is expecting: " <+> ppr opExpectsRep) $$
                                        (text "arguments provide: " <+> ppr argsRep))
 
 cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a
 cmmLintAssignErr stmt e_ty r_ty
   = cmmLintErr (text "in assignment: " $$ 
-               nest 2 (vcat [pprStmt stmt, 
+               nest 2 (vcat [ppr stmt, 
                              text "Reg ty:" <+> ppr r_ty,
                              text "Rhs ty:" <+> ppr e_ty]))
                         
@@ -196,4 +196,4 @@ cmmLintAssignErr stmt e_ty r_ty
 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
 cmmLintDubiousWordOffset expr
    = cmmLintErr (text "offset is not a multiple of words: " $$
-                       nest 2 (pprExpr expr))
+                       nest 2 (ppr expr))
index ed65977..78867b0 100644 (file)
@@ -1,18 +1,24 @@
-module CmmLive (
-        CmmLive,
-        BlockEntryLiveness,
-        cmmLiveness,
-        cmmFormalsToLiveLocals,
-  ) where
+{-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 
-#include "HsVersions.h"
+module CmmLive
+    ( CmmLive
+    , cmmLiveness
+    , liveLattice
+    , noLiveOnEntry, xferLive
+    )
+where
 
 import BlockId
 import Cmm
-import Dataflow
+import CmmExpr
+import Control.Monad
+import OptimizationFuel
+import PprCmmExpr ()
 
+import Compiler.Hoopl
 import Maybes
-import Panic
+import Outputable
 import UniqSet
 
 -----------------------------------------------------------------------------
@@ -20,193 +26,50 @@ import UniqSet
 -----------------------------------------------------------------------------
 
 -- | The variables live on entry to a block
-type CmmLive = UniqSet LocalReg
+type CmmLive = RegSet
+
+-- | The dataflow lattice
+liveLattice :: DataflowLattice CmmLive
+liveLattice = DataflowLattice "live LocalReg's" emptyRegSet add
+    where add _ (OldFact old) (NewFact new) = case unionUniqSets old new of
+            join -> (changeIf $ sizeUniqSet join > sizeUniqSet old, join)
 
 -- | A mapping from block labels to the variables live on entry
 type BlockEntryLiveness = BlockEnv CmmLive
 
--- | A mapping from block labels to the blocks that target it
-type BlockSources = BlockEnv (UniqSet BlockId)
-
--- | A mapping from block labels to the statements in the block
-type BlockStmts = BlockEnv [CmmStmt]
-
------------------------------------------------------------------------------
--- | Calculated liveness info for a list of 'CmmBasicBlock'
------------------------------------------------------------------------------
-cmmLiveness :: [CmmBasicBlock] -> BlockEntryLiveness
-cmmLiveness blocks =
-    fixedpoint (cmmBlockDependants sources)
-               (cmmBlockUpdate blocks')
-               (map blockId blocks)
-               (mkBlockEnv [(blockId b, emptyUniqSet) | b <- blocks])
-    where
-      sources :: BlockSources
-      sources = cmmBlockSources blocks
-
-      blocks' :: BlockStmts
-      blocks' = mkBlockEnv $ map block_name blocks
-
-      block_name :: CmmBasicBlock -> (BlockId, [CmmStmt])
-      block_name b = (blockId b, blockStmts b)
-
-{-
--- For debugging, annotate each block with a comment indicating
--- the calculated live variables
-cmmLivenessComment ::
-    BlockEnv (UniqSet LocalReg) -> CmmBasicBlock -> CmmBasicBlock
-cmmLivenessComment live (BasicBlock ident stmts) =
-    BasicBlock ident stmts' where
-        stmts' = (CmmComment $ mkFastString $ showSDoc $ ppr $ live'):stmts
-        live' = map CmmLocal $ uniqSetToList $ lookupWithDefaultUFM live emptyUniqSet ident
--}
-
-
------------------------------------------------------------------------------
--- | Calculates a table of where one can lookup the blocks that might
--- need updating after a given block is updated in the liveness analysis
------------------------------------------------------------------------------
-cmmBlockSources :: [CmmBasicBlock] -> BlockSources
-cmmBlockSources blocks = foldr aux emptyBlockEnv blocks
-    where
-      aux :: CmmBasicBlock
-          -> BlockSources
-          -> BlockSources
-      aux block sourcesUFM =
-          foldUniqSet (add_source_edges $ blockId block)
-                      sourcesUFM
-                      (branch_targets $ blockStmts block)
-
-      add_source_edges :: BlockId -> BlockId
-                       -> BlockSources
-                       -> BlockSources
-      add_source_edges source target ufm =
-          addToBEnv_Acc (flip addOneToUniqSet) unitUniqSet ufm target source
-
-      branch_targets :: [CmmStmt] -> UniqSet BlockId
-      branch_targets stmts =
-          mkUniqSet $ concatMap target stmts where
-              target (CmmBranch ident) = [ident]
-              target (CmmCondBranch _ ident) = [ident]
-              target (CmmSwitch _ blocks) = mapMaybe id blocks
-              target _ = []
-
------------------------------------------------------------------------------
--- | Given the table calculated by 'cmmBlockSources', list all blocks
--- that depend on the result of a particular block.
---
--- Used by the call to 'fixedpoint'.
------------------------------------------------------------------------------
-cmmBlockDependants :: BlockSources -> BlockId -> [BlockId]
-cmmBlockDependants sources ident =
-    uniqSetToList $ lookupWithDefaultBEnv sources emptyUniqSet ident
-
------------------------------------------------------------------------------
--- | Given the table of type 'BlockStmts' and a block that was updated,
--- calculate an updated BlockEntryLiveness
 -----------------------------------------------------------------------------
-cmmBlockUpdate ::
-    BlockStmts
-    -> BlockId
-    -> Maybe BlockId
-    -> BlockEntryLiveness
-    -> Maybe BlockEntryLiveness
-cmmBlockUpdate blocks node _ state =
-    if (sizeUniqSet old_live) == (sizeUniqSet new_live)
-      then Nothing
-      else Just $ extendBlockEnv state node new_live
-    where
-      new_live, old_live :: CmmLive
-      new_live = cmmStmtListLive state block_stmts
-      old_live = lookupWithDefaultBEnv state missing_live node
-
-      block_stmts :: [CmmStmt]
-      block_stmts = lookupWithDefaultBEnv blocks missing_block node
-
-      missing_live = panic "unknown block id during liveness analysis"
-      missing_block = panic "unknown block id during liveness analysis"
-
+-- | Calculated liveness info for a CmmGraph
 -----------------------------------------------------------------------------
--- Section: 
------------------------------------------------------------------------------
------------------------------------------------------------------------------
--- CmmBlockLive, cmmStmtListLive and helpers
------------------------------------------------------------------------------
-
--- Calculate the live registers for a local block (list of statements)
-
-cmmStmtListLive :: BlockEntryLiveness -> [CmmStmt] -> CmmLive
-cmmStmtListLive other_live stmts =
-    foldr ((.) . (cmmStmtLive other_live)) id stmts emptyUniqSet
-
------------------------------------------------------------------------------
--- This code is written in the style of a state monad,
--- but since Control.Monad.State is not in the core
--- we can't use it in GHC, so we'll fake one here.
--- We don't need a return value so well leave it out.
--- Thus 'bind' reduces to function composition.
-
-type CmmLivenessTransformer = CmmLive -> CmmLive
-
--- Helpers for the "Monad"
-addLive, addKilled :: CmmLive -> CmmLivenessTransformer
-addLive new_live live = live `unionUniqSets` new_live
-addKilled new_killed live = live `minusUniqSet` new_killed
-
---------------------------------
--- Liveness of a CmmStmt
---------------------------------
-cmmFormalsToLiveLocals :: HintedCmmFormals -> [LocalReg]
-cmmFormalsToLiveLocals formals = map hintlessCmm formals
-
-cmmStmtLive :: BlockEntryLiveness -> CmmStmt -> CmmLivenessTransformer
-cmmStmtLive _ (CmmNop) = id
-cmmStmtLive _ (CmmComment _) = id
-cmmStmtLive _ (CmmAssign reg expr) =
-    cmmExprLive expr . reg_liveness where
-        reg_liveness =
-            case reg of
-              (CmmLocal reg') -> addKilled $ unitUniqSet reg'
-              (CmmGlobal _) -> id
-cmmStmtLive _ (CmmStore expr1 expr2) =
-    cmmExprLive expr2 . cmmExprLive expr1
-cmmStmtLive _ (CmmCall target results arguments _ _) =
-    target_liveness .
-    foldr ((.) . cmmExprLive) id (map hintlessCmm arguments) .
-    addKilled (mkUniqSet $ cmmFormalsToLiveLocals results) where
-        target_liveness =
-            case target of
-              (CmmCallee target _) -> cmmExprLive target
-              (CmmPrim _) -> id
-cmmStmtLive other_live (CmmBranch target) =
-    addLive (lookupWithDefaultBEnv other_live emptyUniqSet target)
-cmmStmtLive other_live (CmmCondBranch expr target) =
-    cmmExprLive expr .
-    addLive (lookupWithDefaultBEnv other_live emptyUniqSet target)
-cmmStmtLive other_live (CmmSwitch expr targets) =
-    cmmExprLive expr .
-    (foldr ((.) . (addLive .
-                   lookupWithDefaultBEnv other_live emptyUniqSet))
-           id
-           (mapCatMaybes id targets))
-cmmStmtLive _ (CmmJump expr params) =
-    const (cmmExprLive expr $ foldr ((.) . cmmExprLive) id (map hintlessCmm params) $ emptyUniqSet)
-cmmStmtLive _ (CmmReturn params) =
-    const (foldr ((.) . cmmExprLive) id (map hintlessCmm params) $ emptyUniqSet)
-
---------------------------------
--- Liveness of a CmmExpr
---------------------------------
-cmmExprLive :: CmmExpr -> CmmLivenessTransformer
-cmmExprLive expr = addLive (mkUniqSet $ expr_liveness expr) where
-    expr_liveness :: CmmExpr -> [LocalReg]
-    expr_liveness (CmmLit _) = []
-    expr_liveness (CmmLoad expr _) = expr_liveness expr
-    expr_liveness (CmmReg reg) = reg_liveness reg
-    expr_liveness (CmmMachOp _ exprs) = concatMap expr_liveness exprs
-    expr_liveness (CmmRegOff reg _) = reg_liveness reg
-    expr_liveness (CmmStackSlot _ _) = panic "cmmExprLive CmmStackSlot"
 
-    reg_liveness :: CmmReg -> [LocalReg]
-    reg_liveness (CmmLocal reg) = [reg]
-    reg_liveness (CmmGlobal _) = []
+cmmLiveness :: CmmGraph -> FuelUniqSM BlockEntryLiveness
+cmmLiveness graph =
+  liftM check $ liftM snd $ dataflowPassBwd graph [] $ analBwd liveLattice xferLive
+  where entry = g_entry graph
+        check facts = noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts
+
+gen_kill :: (DefinerOfLocalRegs a, UserOfLocalRegs a) => a -> CmmLive -> CmmLive
+gen_kill a = gen a . kill a
+
+-- | On entry to the procedure, there had better not be any LocalReg's live-in.
+noLiveOnEntry :: BlockId -> CmmLive -> a -> a
+noLiveOnEntry bid in_fact x =
+  if isEmptyUniqSet in_fact then x
+  else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)
+
+-- | The transfer equations use the traditional 'gen' and 'kill'
+-- notations, which should be familiar from the dragon book.
+gen  :: UserOfLocalRegs    a => a -> RegSet -> RegSet
+gen  a live = foldRegsUsed    extendRegSet      live a
+kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
+kill a live = foldRegsDefd delOneFromUniqSet live a
+
+xferLive :: BwdTransfer CmmNode CmmLive
+xferLive = mkBTransfer3 fst mid lst
+  where fst _ f = f
+        mid :: CmmNode O O -> CmmLive -> CmmLive
+        mid n f = gen_kill n $ case n of CmmUnsafeForeignCall {} -> emptyRegSet
+                                         _                       -> f
+        lst :: CmmNode O C -> FactBase CmmLive -> CmmLive
+        lst n f = gen_kill n $ case n of CmmCall {}            -> emptyRegSet
+                                         CmmForeignCall {}     -> emptyRegSet
+                                         _                     -> joinOutFacts liveLattice n f
diff --git a/compiler/cmm/CmmLiveZ.hs b/compiler/cmm/CmmLiveZ.hs
deleted file mode 100644 (file)
index ea9b2e5..0000000
+++ /dev/null
@@ -1,84 +0,0 @@
-
-module CmmLiveZ
-    ( CmmLive
-    , cmmLivenessZ
-    , liveLattice
-    , middleLiveness, noLiveOnEntry
-    ) 
-where
-
-import BlockId
-import CmmExpr
-import CmmTx
-import DFMonad
-import Control.Monad
-import PprCmm()
-import PprCmmZ()
-import ZipCfg
-import ZipDataflow
-import ZipCfgCmmRep
-
-import Maybes
-import Outputable
-import UniqSet
-
------------------------------------------------------------------------------
--- Calculating what variables are live on entry to a basic block
------------------------------------------------------------------------------
-
--- | The variables live on entry to a block
-type CmmLive = RegSet
-
--- | The dataflow lattice
-liveLattice :: DataflowLattice CmmLive
-liveLattice = DataflowLattice "live LocalReg's" emptyUniqSet add False
-    where add new old =
-            let join = unionUniqSets new old in
-            (if sizeUniqSet join > sizeUniqSet old then aTx else noTx) join
-
--- | A mapping from block labels to the variables live on entry
-type BlockEntryLiveness = BlockEnv CmmLive
-
------------------------------------------------------------------------------
--- | Calculated liveness info for a CmmGraph
------------------------------------------------------------------------------
-cmmLivenessZ :: CmmGraph -> FuelMonad BlockEntryLiveness
-cmmLivenessZ g@(LGraph entry _) =
-  liftM (check . zdfFpFacts) (res :: FuelMonad (CmmBackwardFixedPoint CmmLive))
-  where res = zdfSolveFrom emptyBlockEnv "liveness analysis" liveLattice transfers
-                           emptyUniqSet (graphOfLGraph g)
-        transfers = BackwardTransfers (flip const) mid last
-        mid  m = gen_kill m . midLive  m
-        last l = gen_kill l . lastLive l 
-        check facts   =
-          noLiveOnEntry entry (expectJust "check" $ lookupBlockEnv facts entry) facts
-
-gen_kill :: (DefinerOfLocalRegs a, UserOfLocalRegs a) => a -> CmmLive -> CmmLive
-gen_kill a = gen a . kill a
-
-middleLiveness :: Middle -> CmmLive -> CmmLive
-middleLiveness = gen_kill
-
--- | On entry to the procedure, there had better not be any LocalReg's live-in.
-noLiveOnEntry :: BlockId -> CmmLive -> a -> a
-noLiveOnEntry bid in_fact x =
-  if isEmptyUniqSet in_fact then x
-  else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)
-
--- | The transfer equations use the traditional 'gen' and 'kill'
--- notations, which should be familiar from the dragon book.
-gen  :: UserOfLocalRegs    a => a -> RegSet -> RegSet
-gen  a live = foldRegsUsed    extendRegSet      live a
-kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
-kill a live = foldRegsDefd delOneFromUniqSet live a
-
-midLive :: Middle -> CmmLive -> CmmLive
-midLive (MidForeignCall {}) _ = emptyUniqSet
-midLive _                live = live
-
-lastLive :: Last -> (BlockId -> CmmLive) -> CmmLive
-lastLive l env = last l
-  where last (LastBranch id)        = env id
-        last (LastCall _ _  _ _ _)  = emptyUniqSet
-        last (LastCondBranch _ t f) = unionUniqSets (env t) (env f)
-        last (LastSwitch _ tbl)     = unionManyUniqSets $ map env (catMaybes tbl)
diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs
new file mode 100644 (file)
index 0000000..5e1ac16
--- /dev/null
@@ -0,0 +1,465 @@
+
+module CmmMachOp
+    ( MachOp(..)
+    , pprMachOp, isCommutableMachOp, isAssociativeMachOp
+    , isComparisonMachOp, machOpResultType
+    , machOpArgReps, maybeInvertComparison
+
+    -- MachOp builders
+    , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
+    , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem
+    , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe
+    , mo_wordULe, mo_wordUGt, mo_wordULt
+    , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr
+    , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
+    , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord
+    , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32
+
+    -- CallishMachOp
+    , CallishMachOp(..)
+    , pprCallishMachOp
+   )
+where
+
+#include "HsVersions.h"
+
+import CmmType
+import Outputable
+
+-----------------------------------------------------------------------------
+--              MachOp
+-----------------------------------------------------------------------------
+
+{-
+Implementation notes:
+
+It might suffice to keep just a width, without distinguishing between
+floating and integer types.  However, keeping the distinction will
+help the native code generator to assign registers more easily.
+-}
+
+
+{- |
+Machine-level primops; ones which we can reasonably delegate to the
+native code generators to handle.  Basically contains C's primops
+and no others.
+
+Nomenclature: all ops indicate width and signedness, where
+appropriate.  Widths: 8\/16\/32\/64 means the given size, obviously.
+Nat means the operation works on STG word sized objects.
+Signedness: S means signed, U means unsigned.  For operations where
+signedness is irrelevant or makes no difference (for example
+integer add), the signedness component is omitted.
+
+An exception: NatP is a ptr-typed native word.  From the point of
+view of the native code generators this distinction is irrelevant,
+but the C code generator sometimes needs this info to emit the
+right casts.
+-}
+
+data MachOp
+  -- Integer operations (insensitive to signed/unsigned)
+  = MO_Add Width
+  | MO_Sub Width
+  | MO_Eq  Width
+  | MO_Ne  Width
+  | MO_Mul Width                -- low word of multiply
+
+  -- Signed multiply/divide
+  | MO_S_MulMayOflo Width       -- nonzero if signed multiply overflows
+  | MO_S_Quot Width             -- signed / (same semantics as IntQuotOp)
+  | MO_S_Rem  Width             -- signed % (same semantics as IntRemOp)
+  | MO_S_Neg  Width             -- unary -
+
+  -- Unsigned multiply/divide
+  | MO_U_MulMayOflo Width       -- nonzero if unsigned multiply overflows
+  | MO_U_Quot Width             -- unsigned / (same semantics as WordQuotOp)
+  | MO_U_Rem  Width             -- unsigned % (same semantics as WordRemOp)
+
+  -- Signed comparisons
+  | MO_S_Ge Width
+  | MO_S_Le Width
+  | MO_S_Gt Width
+  | MO_S_Lt Width
+
+  -- Unsigned comparisons
+  | MO_U_Ge Width
+  | MO_U_Le Width
+  | MO_U_Gt Width
+  | MO_U_Lt Width
+
+  -- Floating point arithmetic
+  | MO_F_Add  Width
+  | MO_F_Sub  Width
+  | MO_F_Neg  Width             -- unary -
+  | MO_F_Mul  Width
+  | MO_F_Quot Width
+
+  -- Floating point comparison
+  | MO_F_Eq Width
+  | MO_F_Ne Width
+  | MO_F_Ge Width
+  | MO_F_Le Width
+  | MO_F_Gt Width
+  | MO_F_Lt Width
+
+  -- Bitwise operations.  Not all of these may be supported
+  -- at all sizes, and only integral Widths are valid.
+  | MO_And   Width
+  | MO_Or    Width
+  | MO_Xor   Width
+  | MO_Not   Width
+  | MO_Shl   Width
+  | MO_U_Shr Width      -- unsigned shift right
+  | MO_S_Shr Width      -- signed shift right
+
+  -- Conversions.  Some of these will be NOPs.
+  -- Floating-point conversions use the signed variant.
+  | MO_SF_Conv Width Width      -- Signed int -> Float
+  | MO_FS_Conv Width Width      -- Float -> Signed int
+  | MO_SS_Conv Width Width      -- Signed int -> Signed int
+  | MO_UU_Conv Width Width      -- unsigned int -> unsigned int
+  | MO_FF_Conv Width Width      -- Float -> Float
+  deriving (Eq, Show)
+
+pprMachOp :: MachOp -> SDoc
+pprMachOp mo = text (show mo)
+
+
+
+-- -----------------------------------------------------------------------------
+-- Some common MachReps
+
+-- A 'wordRep' is a machine word on the target architecture
+-- Specifically, it is the size of an Int#, Word#, Addr#
+-- and the unit of allocation on the stack and the heap
+-- Any pointer is also guaranteed to be a wordRep.
+
+mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
+    , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem
+    , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe
+    , mo_wordULe, mo_wordUGt, mo_wordULt
+    , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr
+    , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
+    , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord
+    , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32
+    :: MachOp
+
+mo_wordAdd      = MO_Add wordWidth
+mo_wordSub      = MO_Sub wordWidth
+mo_wordEq       = MO_Eq  wordWidth
+mo_wordNe       = MO_Ne  wordWidth
+mo_wordMul      = MO_Mul wordWidth
+mo_wordSQuot    = MO_S_Quot wordWidth
+mo_wordSRem     = MO_S_Rem wordWidth
+mo_wordSNeg     = MO_S_Neg wordWidth
+mo_wordUQuot    = MO_U_Quot wordWidth
+mo_wordURem     = MO_U_Rem wordWidth
+
+mo_wordSGe      = MO_S_Ge  wordWidth
+mo_wordSLe      = MO_S_Le  wordWidth
+mo_wordSGt      = MO_S_Gt  wordWidth
+mo_wordSLt      = MO_S_Lt  wordWidth
+
+mo_wordUGe      = MO_U_Ge  wordWidth
+mo_wordULe      = MO_U_Le  wordWidth
+mo_wordUGt      = MO_U_Gt  wordWidth
+mo_wordULt      = MO_U_Lt  wordWidth
+
+mo_wordAnd      = MO_And wordWidth
+mo_wordOr       = MO_Or  wordWidth
+mo_wordXor      = MO_Xor wordWidth
+mo_wordNot      = MO_Not wordWidth
+mo_wordShl      = MO_Shl wordWidth
+mo_wordSShr     = MO_S_Shr wordWidth
+mo_wordUShr     = MO_U_Shr wordWidth
+
+mo_u_8To32      = MO_UU_Conv W8 W32
+mo_s_8To32      = MO_SS_Conv W8 W32
+mo_u_16To32     = MO_UU_Conv W16 W32
+mo_s_16To32     = MO_SS_Conv W16 W32
+
+mo_u_8ToWord    = MO_UU_Conv W8  wordWidth
+mo_s_8ToWord    = MO_SS_Conv W8  wordWidth
+mo_u_16ToWord   = MO_UU_Conv W16 wordWidth
+mo_s_16ToWord   = MO_SS_Conv W16 wordWidth
+mo_s_32ToWord   = MO_SS_Conv W32 wordWidth
+mo_u_32ToWord   = MO_UU_Conv W32 wordWidth
+
+mo_WordTo8      = MO_UU_Conv wordWidth W8
+mo_WordTo16     = MO_UU_Conv wordWidth W16
+mo_WordTo32     = MO_UU_Conv wordWidth W32
+
+mo_32To8        = MO_UU_Conv W32 W8
+mo_32To16       = MO_UU_Conv W32 W16
+
+
+-- ----------------------------------------------------------------------------
+-- isCommutableMachOp
+
+{- |
+Returns 'True' if the MachOp has commutable arguments.  This is used
+in the platform-independent Cmm optimisations.
+
+If in doubt, return 'False'.  This generates worse code on the
+native routes, but is otherwise harmless.
+-}
+isCommutableMachOp :: MachOp -> Bool
+isCommutableMachOp mop =
+  case mop of
+        MO_Add _                -> True
+        MO_Eq _                 -> True
+        MO_Ne _                 -> True
+        MO_Mul _                -> True
+        MO_S_MulMayOflo _       -> True
+        MO_U_MulMayOflo _       -> True
+        MO_And _                -> True
+        MO_Or _                 -> True
+        MO_Xor _                -> True
+        _other                  -> False
+
+-- ----------------------------------------------------------------------------
+-- isAssociativeMachOp
+
+{- |
+Returns 'True' if the MachOp is associative (i.e. @(x+y)+z == x+(y+z)@)
+This is used in the platform-independent Cmm optimisations.
+
+If in doubt, return 'False'.  This generates worse code on the
+native routes, but is otherwise harmless.
+-}
+isAssociativeMachOp :: MachOp -> Bool
+isAssociativeMachOp mop =
+  case mop of
+        MO_Add {} -> True       -- NB: does not include
+        MO_Mul {} -> True --     floatint point!
+        MO_And {} -> True
+        MO_Or  {} -> True
+        MO_Xor {} -> True
+        _other    -> False
+
+-- ----------------------------------------------------------------------------
+-- isComparisonMachOp
+
+{- |
+Returns 'True' if the MachOp is a comparison.
+
+If in doubt, return False.  This generates worse code on the
+native routes, but is otherwise harmless.
+-}
+isComparisonMachOp :: MachOp -> Bool
+isComparisonMachOp mop =
+  case mop of
+    MO_Eq   _  -> True
+    MO_Ne   _  -> True
+    MO_S_Ge _  -> True
+    MO_S_Le _  -> True
+    MO_S_Gt _  -> True
+    MO_S_Lt _  -> True
+    MO_U_Ge _  -> True
+    MO_U_Le _  -> True
+    MO_U_Gt _  -> True
+    MO_U_Lt _  -> True
+    MO_F_Eq {} -> True
+    MO_F_Ne {} -> True
+    MO_F_Ge {} -> True
+    MO_F_Le {} -> True
+    MO_F_Gt {} -> True
+    MO_F_Lt {} -> True
+    _other     -> False
+
+-- -----------------------------------------------------------------------------
+-- Inverting conditions
+
+-- Sometimes it's useful to be able to invert the sense of a
+-- condition.  Not all conditional tests are invertible: in
+-- particular, floating point conditionals cannot be inverted, because
+-- there exist floating-point values which return False for both senses
+-- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)).
+
+maybeInvertComparison :: MachOp -> Maybe MachOp
+maybeInvertComparison op
+  = case op of  -- None of these Just cases include floating point
+        MO_Eq r   -> Just (MO_Ne r)
+        MO_Ne r   -> Just (MO_Eq r)
+        MO_U_Lt r -> Just (MO_U_Ge r)
+        MO_U_Gt r -> Just (MO_U_Le r)
+        MO_U_Le r -> Just (MO_U_Gt r)
+        MO_U_Ge r -> Just (MO_U_Lt r)
+        MO_S_Lt r -> Just (MO_S_Ge r)
+        MO_S_Gt r -> Just (MO_S_Le r)
+        MO_S_Le r -> Just (MO_S_Gt r)
+        MO_S_Ge r -> Just (MO_S_Lt r)
+        MO_F_Eq r -> Just (MO_F_Ne r)
+        MO_F_Ne r -> Just (MO_F_Eq r)
+        MO_F_Ge r -> Just (MO_F_Le r)
+        MO_F_Le r -> Just (MO_F_Ge r)
+        MO_F_Gt r -> Just (MO_F_Lt r)
+        MO_F_Lt r -> Just (MO_F_Gt r)
+        _other    -> Nothing
+
+-- ----------------------------------------------------------------------------
+-- machOpResultType
+
+{- |
+Returns the MachRep of the result of a MachOp.
+-}
+machOpResultType :: MachOp -> [CmmType] -> CmmType
+machOpResultType mop tys =
+  case mop of
+    MO_Add {}           -> ty1  -- Preserve GC-ptr-hood
+    MO_Sub {}           -> ty1  -- of first arg
+    MO_Mul    r         -> cmmBits r
+    MO_S_MulMayOflo r   -> cmmBits r
+    MO_S_Quot r         -> cmmBits r
+    MO_S_Rem  r         -> cmmBits r
+    MO_S_Neg  r         -> cmmBits r
+    MO_U_MulMayOflo r   -> cmmBits r
+    MO_U_Quot r         -> cmmBits r
+    MO_U_Rem  r         -> cmmBits r
+
+    MO_Eq {}            -> comparisonResultRep
+    MO_Ne {}            -> comparisonResultRep
+    MO_S_Ge {}          -> comparisonResultRep
+    MO_S_Le {}          -> comparisonResultRep
+    MO_S_Gt {}          -> comparisonResultRep
+    MO_S_Lt {}          -> comparisonResultRep
+
+    MO_U_Ge {}          -> comparisonResultRep
+    MO_U_Le {}          -> comparisonResultRep
+    MO_U_Gt {}          -> comparisonResultRep
+    MO_U_Lt {}          -> comparisonResultRep
+
+    MO_F_Add r          -> cmmFloat r
+    MO_F_Sub r          -> cmmFloat r
+    MO_F_Mul r          -> cmmFloat r
+    MO_F_Quot r         -> cmmFloat r
+    MO_F_Neg r          -> cmmFloat r
+    MO_F_Eq  {}         -> comparisonResultRep
+    MO_F_Ne  {}         -> comparisonResultRep
+    MO_F_Ge  {}         -> comparisonResultRep
+    MO_F_Le  {}         -> comparisonResultRep
+    MO_F_Gt  {}         -> comparisonResultRep
+    MO_F_Lt  {}         -> comparisonResultRep
+
+    MO_And {}           -> ty1  -- Used for pointer masking
+    MO_Or {}            -> ty1
+    MO_Xor {}           -> ty1
+    MO_Not   r          -> cmmBits r
+    MO_Shl   r          -> cmmBits r
+    MO_U_Shr r          -> cmmBits r
+    MO_S_Shr r          -> cmmBits r
+
+    MO_SS_Conv _ to     -> cmmBits to
+    MO_UU_Conv _ to     -> cmmBits to
+    MO_FS_Conv _ to     -> cmmBits to
+    MO_SF_Conv _ to     -> cmmFloat to
+    MO_FF_Conv _ to     -> cmmFloat to
+  where
+    (ty1:_) = tys
+
+comparisonResultRep :: CmmType
+comparisonResultRep = bWord  -- is it?
+
+
+-- -----------------------------------------------------------------------------
+-- machOpArgReps
+
+-- | This function is used for debugging only: we can check whether an
+-- application of a MachOp is "type-correct" by checking that the MachReps of
+-- its arguments are the same as the MachOp expects.  This is used when
+-- linting a CmmExpr.
+
+machOpArgReps :: MachOp -> [Width]
+machOpArgReps op =
+  case op of
+    MO_Add    r         -> [r,r]
+    MO_Sub    r         -> [r,r]
+    MO_Eq     r         -> [r,r]
+    MO_Ne     r         -> [r,r]
+    MO_Mul    r         -> [r,r]
+    MO_S_MulMayOflo r   -> [r,r]
+    MO_S_Quot r         -> [r,r]
+    MO_S_Rem  r         -> [r,r]
+    MO_S_Neg  r         -> [r]
+    MO_U_MulMayOflo r   -> [r,r]
+    MO_U_Quot r         -> [r,r]
+    MO_U_Rem  r         -> [r,r]
+
+    MO_S_Ge r           -> [r,r]
+    MO_S_Le r           -> [r,r]
+    MO_S_Gt r           -> [r,r]
+    MO_S_Lt r           -> [r,r]
+
+    MO_U_Ge r           -> [r,r]
+    MO_U_Le r           -> [r,r]
+    MO_U_Gt r           -> [r,r]
+    MO_U_Lt r           -> [r,r]
+
+    MO_F_Add r          -> [r,r]
+    MO_F_Sub r          -> [r,r]
+    MO_F_Mul r          -> [r,r]
+    MO_F_Quot r         -> [r,r]
+    MO_F_Neg r          -> [r]
+    MO_F_Eq  r          -> [r,r]
+    MO_F_Ne  r          -> [r,r]
+    MO_F_Ge  r          -> [r,r]
+    MO_F_Le  r          -> [r,r]
+    MO_F_Gt  r          -> [r,r]
+    MO_F_Lt  r          -> [r,r]
+
+    MO_And   r          -> [r,r]
+    MO_Or    r          -> [r,r]
+    MO_Xor   r          -> [r,r]
+    MO_Not   r          -> [r]
+    MO_Shl   r          -> [r,wordWidth]
+    MO_U_Shr r          -> [r,wordWidth]
+    MO_S_Shr r          -> [r,wordWidth]
+
+    MO_SS_Conv from _   -> [from]
+    MO_UU_Conv from _   -> [from]
+    MO_SF_Conv from _   -> [from]
+    MO_FS_Conv from _   -> [from]
+    MO_FF_Conv from _   -> [from]
+
+-----------------------------------------------------------------------------
+-- CallishMachOp
+-----------------------------------------------------------------------------
+
+-- CallishMachOps tend to be implemented by foreign calls in some backends,
+-- so we separate them out.  In Cmm, these can only occur in a
+-- statement position, in contrast to an ordinary MachOp which can occur
+-- anywhere in an expression.
+data CallishMachOp
+  = MO_F64_Pwr
+  | MO_F64_Sin
+  | MO_F64_Cos
+  | MO_F64_Tan
+  | MO_F64_Sinh
+  | MO_F64_Cosh
+  | MO_F64_Tanh
+  | MO_F64_Asin
+  | MO_F64_Acos
+  | MO_F64_Atan
+  | MO_F64_Log
+  | MO_F64_Exp
+  | MO_F64_Sqrt
+  | MO_F32_Pwr
+  | MO_F32_Sin
+  | MO_F32_Cos
+  | MO_F32_Tan
+  | MO_F32_Sinh
+  | MO_F32_Cosh
+  | MO_F32_Tanh
+  | MO_F32_Asin
+  | MO_F32_Acos
+  | MO_F32_Atan
+  | MO_F32_Log
+  | MO_F32_Exp
+  | MO_F32_Sqrt
+  | MO_WriteBarrier
+  | MO_Touch         -- Keep variables live (when using interior pointers)
+  deriving (Eq, Show)
+
+pprCallishMachOp :: CallishMachOp -> SDoc
+pprCallishMachOp mo = text (show mo)
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
new file mode 100644 (file)
index 0000000..12d534e
--- /dev/null
@@ -0,0 +1,303 @@
+-- CmmNode type for representation using Hoopl graphs.
+{-# LANGUAGE GADTs #-}
+module CmmNode
+  ( CmmNode(..)
+  , UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..)
+  , mapExp, mapExpDeep, foldExp, foldExpDeep
+  )
+where
+
+import CmmExpr
+import CmmDecl
+import FastString
+import ForeignCall
+import SMRep
+
+import Compiler.Hoopl
+import Data.Maybe
+import Prelude hiding (succ)
+
+
+------------------------
+-- CmmNode
+
+data CmmNode e x where
+  CmmEntry :: Label -> CmmNode C O
+  CmmComment :: FastString -> CmmNode O O
+  CmmAssign :: CmmReg -> CmmExpr -> CmmNode O O  -- Assign to register
+  CmmStore :: CmmExpr -> CmmExpr -> CmmNode O O  -- Assign to memory location.  Size is
+                                                 -- given by cmmExprType of the rhs.
+  CmmUnsafeForeignCall ::         -- An unsafe foreign call; see Note [Foreign calls]
+      ForeignTarget ->            -- call target
+      CmmFormals ->               -- zero or more results
+      CmmActuals ->               -- zero or more arguments
+      CmmNode O O
+  CmmBranch :: Label -> CmmNode O C  -- Goto another block in the same procedure
+  CmmCondBranch :: {                 -- conditional branch
+      cml_pred :: CmmExpr,
+      cml_true, cml_false :: Label
+  } -> CmmNode O C
+  CmmSwitch :: CmmExpr -> [Maybe Label] -> CmmNode O C -- Table branch
+      -- The scrutinee is zero-based;
+      --      zero -> first block
+      --      one  -> second block etc
+      -- Undefined outside range, and when there's a Nothing
+  CmmCall :: {                -- A call (native or safe foreign)
+      cml_target :: CmmExpr,  -- never a CmmPrim to a CallishMachOp!
+
+      cml_cont :: Maybe Label,
+          -- Label of continuation (Nothing for return or tail call)
+
+      cml_args :: ByteOff,
+          -- Byte offset, from the *old* end of the Area associated with
+          -- the Label (if cml_cont = Nothing, then Old area), of
+          -- youngest outgoing arg.  Set the stack pointer to this before
+          -- transferring control.
+          -- (NB: an update frame might also have been stored in the Old
+          --      area, but it'll be in an older part than the args.)
+
+      cml_ret_args :: ByteOff,
+          -- For calls *only*, the byte offset for youngest returned value
+          -- This is really needed at the *return* point rather than here
+          -- at the call, but in practice it's convenient to record it here.
+
+      cml_ret_off :: ByteOff
+        -- For calls *only*, the byte offset of the base of the frame that
+        -- must be described by the info table for the return point.
+        -- The older words are an update frames, which have their own
+        -- info-table and layout information
+
+        -- From a liveness point of view, the stack words older than
+        -- cml_ret_off are treated as live, even if the sequel of
+        -- the call goes into a loop.
+  } -> CmmNode O C
+  CmmForeignCall :: {           -- A safe foreign call; see Note [Foreign calls]
+      tgt   :: ForeignTarget,   -- call target and convention
+      res   :: CmmFormals,      -- zero or more results
+      args  :: CmmActuals,      -- zero or more arguments
+      succ  :: Label,           -- Label of continuation
+      updfr :: UpdFrameOffset,  -- where the update frame is (for building infotable)
+      intrbl:: Bool             -- whether or not the call is interruptible
+  } -> CmmNode O C
+
+{- Note [Foreign calls]
+~~~~~~~~~~~~~~~~~~~~~~~
+A MidForeign call is used for *unsafe* foreign calls;
+a LastForeign call is used for *safe* foreign calls.
+Unsafe ones are easy: think of them as a "fat machine instruction".
+
+Safe ones are trickier.  A safe foreign call 
+     r = f(x)
+ultimately expands to
+     push "return address"     -- Never used to return to; 
+                               -- just points an info table
+     save registers into TSO
+     call suspendThread
+     r = f(x)                  -- Make the call
+     call resumeThread
+     restore registers
+     pop "return address"
+We cannot "lower" a safe foreign call to this sequence of Cmms, because
+after we've saved Sp all the Cmm optimiser's assumptions are broken.
+Furthermore, currently the smart Cmm constructors know the calling
+conventions for Haskell, the garbage collector, etc, and "lower" them
+so that a LastCall passes no parameters or results.  But the smart 
+constructors do *not* (currently) know the foreign call conventions.
+
+Note that a safe foreign call needs an info table.
+-}
+
+---------------------------------------------
+-- Eq instance of CmmNode
+-- It is a shame GHC cannot infer it by itself :(
+
+instance Eq (CmmNode e x) where
+  (CmmEntry a)                 == (CmmEntry a')                   = a==a'
+  (CmmComment a)               == (CmmComment a')                 = a==a'
+  (CmmAssign a b)              == (CmmAssign a' b')               = a==a' && b==b'
+  (CmmStore a b)               == (CmmStore a' b')                = a==a' && b==b'
+  (CmmUnsafeForeignCall a b c) == (CmmUnsafeForeignCall a' b' c') = a==a' && b==b' && c==c'
+  (CmmBranch a)                == (CmmBranch a')                  = a==a'
+  (CmmCondBranch a b c)        == (CmmCondBranch a' b' c')        = a==a' && b==b' && c==c'
+  (CmmSwitch a b)              == (CmmSwitch a' b')               = a==a' && b==b'
+  (CmmCall a b c d e)          == (CmmCall a' b' c' d' e')        = a==a' && b==b' && c==c' && d==d' && e==e'
+  (CmmForeignCall a b c d e f) == (CmmForeignCall a' b' c' d' e' f') = a==a' && b==b' && c==c' && d==d' && e==e' && f==f'
+  _                            == _                               = False
+
+----------------------------------------------
+-- Hoopl instances of CmmNode
+
+instance NonLocal CmmNode where
+  entryLabel (CmmEntry l) = l
+  -- entryLabel _ = error "CmmNode.entryLabel"
+
+  successors (CmmBranch l) = [l]
+  successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
+  successors (CmmSwitch _ ls) = catMaybes ls
+  successors (CmmCall {cml_cont=l}) = maybeToList l
+  successors (CmmForeignCall {succ=l}) = [l]
+  -- successors _ = error "CmmNode.successors"
+
+
+instance HooplNode CmmNode where
+  mkBranchNode label = CmmBranch label
+  mkLabelNode label  = CmmEntry label
+
+--------------------------------------------------
+-- Various helper types
+
+type UpdFrameOffset = ByteOff
+
+data Convention
+  = NativeDirectCall -- Native C-- call skipping the node (closure) argument
+  | NativeNodeCall   -- Native C-- call including the node argument
+  | NativeReturn     -- Native C-- return
+  | Slow             -- Slow entry points: all args pushed on the stack
+  | GC               -- Entry to the garbage collector: uses the node reg!
+  | PrimOpCall       -- Calling prim ops
+  | PrimOpReturn     -- Returning from prim ops
+  | Foreign          -- Foreign call/return
+        ForeignConvention
+  | Private
+        -- Used for control transfers within a (pre-CPS) procedure All
+        -- jump sites known, never pushed on the stack (hence no SRT)
+        -- You can choose whatever calling convention you please
+        -- (provided you make sure all the call sites agree)!
+        -- This data type eventually to be extended to record the convention.
+  deriving( Eq )
+
+data ForeignConvention
+  = ForeignConvention
+        CCallConv               -- Which foreign-call convention
+        [ForeignHint]           -- Extra info about the args
+        [ForeignHint]           -- Extra info about the result
+  deriving Eq
+
+data ForeignTarget        -- The target of a foreign call
+  = ForeignTarget                -- A foreign procedure
+        CmmExpr                  -- Its address
+        ForeignConvention        -- Its calling convention
+  | PrimTarget            -- A possibly-side-effecting machine operation
+        CallishMachOp            -- Which one
+  deriving Eq
+
+--------------------------------------------------
+-- Instances of register and slot users / definers
+
+instance UserOfLocalRegs (CmmNode e x) where
+  foldRegsUsed f z n = case n of
+    CmmAssign _ expr -> fold f z expr
+    CmmStore addr rval -> fold f (fold f z addr) rval
+    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
+    CmmCondBranch expr _ _ -> fold f z expr
+    CmmSwitch expr _ -> fold f z expr
+    CmmCall {cml_target=tgt} -> fold f z tgt
+    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
+    _ -> z
+    where fold :: forall a b.
+                       UserOfLocalRegs a =>
+                       (b -> LocalReg -> b) -> b -> a -> b
+          fold f z n = foldRegsUsed f z n
+
+instance UserOfLocalRegs ForeignTarget where
+  foldRegsUsed _f z (PrimTarget _)      = z
+  foldRegsUsed f  z (ForeignTarget e _) = foldRegsUsed f z e
+
+instance DefinerOfLocalRegs (CmmNode e x) where
+  foldRegsDefd f z n = case n of
+    CmmAssign lhs _ -> fold f z lhs
+    CmmUnsafeForeignCall _ fs _ -> fold f z fs
+    CmmForeignCall {res=res} -> fold f z res
+    _ -> z
+    where fold :: forall a b.
+                   DefinerOfLocalRegs a =>
+                   (b -> LocalReg -> b) -> b -> a -> b
+          fold f z n = foldRegsDefd f z n
+
+
+instance UserOfSlots (CmmNode e x) where
+  foldSlotsUsed f z n = case n of
+    CmmAssign _ expr -> fold f z expr
+    CmmStore addr rval -> fold f (fold f z addr) rval
+    CmmUnsafeForeignCall _ _ args -> fold f z args
+    CmmCondBranch expr _ _ -> fold f z expr
+    CmmSwitch expr _ -> fold f z expr
+    CmmCall {cml_target=tgt} -> fold f z tgt
+    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
+    _ -> z
+    where fold :: forall a b.
+                       UserOfSlots a =>
+                       (b -> SubArea -> b) -> b -> a -> b
+          fold f z n = foldSlotsUsed f z n
+
+instance UserOfSlots ForeignTarget where
+  foldSlotsUsed  f z (ForeignTarget e _) = foldSlotsUsed f z e
+  foldSlotsUsed _f z (PrimTarget _)      = z
+
+instance DefinerOfSlots (CmmNode e x) where
+  foldSlotsDefd f z n = case n of
+    CmmStore (CmmStackSlot a i) expr -> f z (a, i, widthInBytes $ typeWidth $ cmmExprType expr)
+    CmmForeignCall {res=res} -> fold f z $ map foreign_call_slot res
+    _ -> z
+    where
+          fold :: forall a b.
+                  DefinerOfSlots a =>
+                  (b -> SubArea -> b) -> b -> a -> b
+          fold f z n = foldSlotsDefd f z n
+          foreign_call_slot r = case widthInBytes $ typeWidth $ localRegType r of w -> (RegSlot r, w, w)
+
+-----------------------------------
+-- mapping Expr in CmmNode
+
+mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget 
+mapForeignTarget exp   (ForeignTarget e c) = ForeignTarget (exp e) c
+mapForeignTarget _   m@(PrimTarget _)      = m
+
+-- Take a transformer on expressions and apply it recursively.
+wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
+wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map (wrapRecExp f) es)
+wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)
+wrapRecExp f e                    = f e
+
+mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
+mapExp _ f@(CmmEntry _)                          = f
+mapExp _ m@(CmmComment _)                        = m
+mapExp f   (CmmAssign r e)                       = CmmAssign r (f e)
+mapExp f   (CmmStore addr e)                     = CmmStore (f addr) (f e)
+mapExp f   (CmmUnsafeForeignCall tgt fs as)      = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
+mapExp _ l@(CmmBranch _)                         = l
+mapExp f   (CmmCondBranch e ti fi)               = CmmCondBranch (f e) ti fi
+mapExp f   (CmmSwitch e tbl)                     = CmmSwitch (f e) tbl
+mapExp f   (CmmCall tgt mb_id o i s)             = CmmCall (f tgt) mb_id o i s
+mapExp f   (CmmForeignCall tgt fs as succ updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ updfr intrbl
+
+mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
+mapExpDeep f = mapExp $ wrapRecExp f
+
+-----------------------------------
+-- folding Expr in CmmNode
+
+foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z 
+foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
+foldExpForeignTarget _   (PrimTarget _)      z = z
+
+-- Take a folder on expressions and apply it recursively.
+wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
+wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
+wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
+wrapRecExpf f e                  z = f e z
+
+foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
+foldExp _ (CmmEntry {}) z                         = z
+foldExp _ (CmmComment {}) z                       = z
+foldExp f (CmmAssign _ e) z                       = f e z
+foldExp f (CmmStore addr e) z                     = f addr $ f e z
+foldExp f (CmmUnsafeForeignCall t _ as) z         = foldr f (foldExpForeignTarget f t z) as
+foldExp _ (CmmBranch _) z                         = z
+foldExp f (CmmCondBranch e _ _) z                 = f e z
+foldExp f (CmmSwitch e _) z                       = f e z
+foldExp f (CmmCall {cml_target=tgt}) z            = f tgt z
+foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args
+
+foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
+foldExpDeep f = foldExp $ wrapRecExpf f
index fa25e24..53281b0 100644 (file)
@@ -21,8 +21,7 @@ module CmmOpt (
 
 #include "HsVersions.h"
 
-import Cmm
-import CmmExpr
+import OldCmm
 import CmmUtils
 import CLabel
 import StaticFlags
@@ -532,12 +531,12 @@ exactLog2 x_
 -}
 
 cmmLoopifyForC :: RawCmmTop -> RawCmmTop
-cmmLoopifyForC p@(CmmProc info entry_lbl []
+cmmLoopifyForC p@(CmmProc info entry_lbl
                  (ListGraph blocks@(BasicBlock top_id _ : _)))
   | null info = p  -- only if there's an info table, ignore case alts
   | otherwise =  
 --  pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $
-  CmmProc info entry_lbl [] (ListGraph blocks')
+  CmmProc info entry_lbl (ListGraph blocks')
   where blocks' = [ BasicBlock id (map do_stmt stmts)
                  | BasicBlock id stmts <- blocks ]
 
index 51f29a8..8c2498e 100644 (file)
@@ -37,8 +37,8 @@ import CgClosure
 import CostCentre
 
 import BlockId
-import Cmm
-import PprCmm
+import OldCmm
+import OldPprCmm()
 import CmmUtils
 import CmmLex
 import CLabel
index de8cfa3..d0d54d9 100644 (file)
-module CmmProcPoint (
-  calculateProcPoints
-  ) where
+{-# LANGUAGE GADTs, DisambiguateRecordFields #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 
-#include "HsVersions.h"
+module CmmProcPoint
+    ( ProcPointSet, Status(..)
+    , callProcPoints, minimalProcPointSet
+    , addProcPointProtocols, splitAtProcPoints, procPointAnalysis
+    )
+where
 
-import BlockId
-import CmmBrokenBlock
-import Dataflow
+import Prelude hiding (last, unzip, succ, zip)
 
+import BlockId
+import CLabel
+import Cmm
+import CmmDecl
+import CmmExpr
+import CmmContFlowOpt
+import CmmInfo
+import CmmLive
+import Constants
+import Data.List (sortBy)
+import Maybes
+import MkGraph
+import Control.Monad
+import OptimizationFuel
+import Outputable
 import UniqSet
-import Panic
-
--- Determine the proc points for a set of basic blocks.
---
--- A proc point is any basic block that must start a new function.
--- The entry block of the original function is a proc point.
--- The continuation of a function call is also a proc point.
--- The third kind of proc point arises when there is a joint point
--- in the control flow.  Suppose we have code like the following:
---
---   if (...) { ...; call foo(); ...}
---   else { ...; call bar(); ...}
---   x = y;
---
--- That last statement "x = y" must be a proc point because
--- it can be reached by blocks owned by different proc points
--- (the two branches of the conditional).
---
--- We calculate these proc points by starting with the minimal set
--- and finding blocks that are reachable from more proc points than
--- one of their parents.  (This ensures we don't choose a block
--- simply beause it is reachable from another block that is reachable
--- from multiple proc points.)  These new blocks are added to the
--- set of proc points and the process is repeated until there
--- are no more proc points to be found.
-
-calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
-calculateProcPoints blocks =
-    calculateProcPoints' init_proc_points blocks
-    where
-      init_proc_points = mkUniqSet $
-                         map brokenBlockId $
-                         filter always_proc_point blocks
-      always_proc_point BrokenBlock {
-                              brokenBlockEntry = FunctionEntry _ _ _ } = True
-      always_proc_point BrokenBlock {
-                              brokenBlockEntry = ContinuationEntry _ _ _ } = True
-      always_proc_point _ = False
-
-calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId
-calculateProcPoints' old_proc_points blocks =
-    if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points
-      then old_proc_points
-      else calculateProcPoints' new_proc_points blocks
-    where
-      blocks_ufm :: BlockEnv BrokenBlock
-      blocks_ufm = blocksToBlockEnv blocks
-
-      owners = calculateOwnership blocks_ufm old_proc_points blocks
-      new_proc_points =
-          unionManyUniqSets
-            (old_proc_points:
-             map (calculateNewProcPoints owners) blocks)
-
-calculateNewProcPoints :: BlockEnv (UniqSet BlockId)
-                       -> BrokenBlock
-                       -> UniqSet BlockId
-calculateNewProcPoints  owners block =
-    unionManyUniqSets (map (maybe_proc_point parent_id) child_ids)
-    where
-      parent_id = brokenBlockId block
-      child_ids = brokenBlockTargets block
-      maybe_proc_point parent_id child_id =
-          if needs_proc_point
-            then unitUniqSet child_id
-            else emptyUniqSet
-          where
-            parent_owners = lookupWithDefaultBEnv owners emptyUniqSet parent_id
-            child_owners = lookupWithDefaultBEnv owners emptyUniqSet child_id
-            needs_proc_point =
-                -- only if parent isn't dead
-                (not $ isEmptyUniqSet parent_owners) &&
-                -- and only if child has more owners than parent
-                (not $ isEmptyUniqSet $
-                     child_owners `minusUniqSet` parent_owners)
-
-calculateOwnership :: BlockEnv BrokenBlock
-                   -> UniqSet BlockId
-                   -> [BrokenBlock]
-                   -> BlockEnv (UniqSet BlockId)
-calculateOwnership blocks_ufm proc_points blocks =
-    fixedpoint dependants update (map brokenBlockId blocks) emptyBlockEnv
-    where
-      dependants :: BlockId -> [BlockId]
-      dependants ident =
-          brokenBlockTargets $ lookupWithDefaultBEnv
-                                 blocks_ufm unknown_block ident
-
-      update :: BlockId
-             -> Maybe BlockId
-             -> BlockEnv (UniqSet BlockId)
-             -> Maybe (BlockEnv (UniqSet BlockId))
-      update ident cause owners =
-          case (cause, ident `elementOfUniqSet` proc_points) of
-            (Nothing, True) ->
-                Just $ extendBlockEnv owners ident (unitUniqSet ident)
-            (Nothing, False) -> Nothing
-            (Just _,      True) -> Nothing
-            (Just cause', False) ->
-                if (sizeUniqSet old) == (sizeUniqSet new)
-                   then Nothing
-                   else Just $ extendBlockEnv owners ident new
-                where
-                  old = lookupWithDefaultBEnv owners emptyUniqSet ident
-                  new = old `unionUniqSets`
-                        lookupWithDefaultBEnv owners emptyUniqSet cause'
-
-      unknown_block = panic "unknown BlockId in calculateOwnership"
+import UniqSupply
+
+import Compiler.Hoopl
+
+import qualified Data.Map as Map
+
+-- Compute a minimal set of proc points for a control-flow graph.
+
+-- Determine a protocol for each proc point (which live variables will
+-- be passed as arguments and which will be on the stack). 
+
+{-
+A proc point is a basic block that, after CPS transformation, will
+start a new function.  The entry block of the original function is a
+proc point, as is the continuation of each function call.
+A third kind of proc point arises if we want to avoid copying code.
+Suppose we have code like the following:
+
+  f() {
+    if (...) { ..1..; call foo(); ..2..}
+    else     { ..3..; call bar(); ..4..}
+    x = y + z;
+    return x;
+  }
+
+The statement 'x = y + z' can be reached from two different proc
+points: the continuations of foo() and bar().  We would prefer not to
+put a copy in each continuation; instead we would like 'x = y + z' to
+be the start of a new procedure to which the continuations can jump:
+
+  f_cps () {
+    if (...) { ..1..; push k_foo; jump foo_cps(); }
+    else     { ..3..; push k_bar; jump bar_cps(); }
+  }
+  k_foo() { ..2..; jump k_join(y, z); }
+  k_bar() { ..4..; jump k_join(y, z); }
+  k_join(y, z) { x = y + z; return x; }
+
+You might think then that a criterion to make a node a proc point is
+that it is directly reached by two distinct proc points.  (Note
+[Direct reachability].)  But this criterion is a bit too simple; for
+example, 'return x' is also reached by two proc points, yet there is
+no point in pulling it out of k_join.  A good criterion would be to
+say that a node should be made a proc point if it is reached by a set
+of proc points that is different than its immediate dominator.  NR
+believes this criterion can be shown to produce a minimum set of proc
+points, and given a dominator tree, the proc points can be chosen in
+time linear in the number of blocks.  Lacking a dominator analysis,
+however, we turn instead to an iterative solution, starting with no
+proc points and adding them according to these rules:
+
+  1. The entry block is a proc point.
+  2. The continuation of a call is a proc point.
+  3. A node is a proc point if it is directly reached by more proc
+     points than one of its predecessors.
+
+Because we don't understand the problem very well, we apply rule 3 at
+most once per iteration, then recompute the reachability information.
+(See Note [No simple dataflow].)  The choice of the new proc point is
+arbitrary, and I don't know if the choice affects the final solution,
+so I don't know if the number of proc points chosen is the
+minimum---but the set will be minimal.
+-}
+
+type ProcPointSet = BlockSet
+
+data Status
+  = ReachedBy ProcPointSet  -- set of proc points that directly reach the block
+  | ProcPoint               -- this block is itself a proc point
+
+instance Outputable Status where
+  ppr (ReachedBy ps)
+      | setNull ps = text "<not-reached>"
+      | otherwise = text "reached by" <+>
+                    (hsep $ punctuate comma $ map ppr $ setElems ps)
+  ppr ProcPoint = text "<procpt>"
+
+lattice :: DataflowLattice Status
+lattice = DataflowLattice "direct proc-point reachability" unreached add_to
+    where unreached = ReachedBy setEmpty
+          add_to _ (OldFact ProcPoint) _ = (NoChange, ProcPoint)
+          add_to _ _ (NewFact ProcPoint) = (SomeChange, ProcPoint) -- because of previous case
+          add_to _ (OldFact (ReachedBy p)) (NewFact (ReachedBy p')) =
+              let union = setUnion p' p
+              in  if setSize union > setSize p then (SomeChange, ReachedBy union)
+                                               else (NoChange, ReachedBy p)
+--------------------------------------------------
+-- transfer equations
+
+forward :: FwdTransfer CmmNode Status
+forward = mkFTransfer3 first middle ((mkFactBase lattice . ) . last)
+    where first :: CmmNode C O -> Status -> Status
+          first (CmmEntry id) ProcPoint = ReachedBy $ setSingleton id
+          first  _ x = x
+
+          middle _ x = x
+
+          last :: CmmNode O C -> Status -> [(Label, Status)]
+          last (CmmCall {cml_cont = Just k}) _ = [(k, ProcPoint)]
+          last (CmmForeignCall {succ = k})   _ = [(k, ProcPoint)]
+          last l x = map (\id -> (id, x)) (successors l)
+
+-- It is worth distinguishing two sets of proc points:
+-- those that are induced by calls in the original graph
+-- and those that are introduced because they're reachable from multiple proc points.
+callProcPoints      :: CmmGraph -> ProcPointSet
+callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g
+  where add :: CmmBlock -> BlockSet -> BlockSet
+        add b set = case lastNode b of
+                      CmmCall {cml_cont = Just k} -> setInsert k set
+                      CmmForeignCall {succ=k}     -> setInsert k set
+                      _ -> set
+
+minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelUniqSM ProcPointSet
+-- Given the set of successors of calls (which must be proc-points)
+-- figure out the minimal set of necessary proc-points
+minimalProcPointSet callProcPoints g = extendPPSet g (postorderDfs g) callProcPoints
+
+procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelUniqSM (BlockEnv Status)
+-- Once you know what the proc-points are, figure out
+-- what proc-points each block is reachable from
+procPointAnalysis procPoints g =
+  liftM snd $ dataflowPassFwd g initProcPoints $ analFwd lattice forward
+  where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints]
+
+extendPPSet :: CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet
+extendPPSet g blocks procPoints =
+    do env <- procPointAnalysis procPoints g
+       let add block pps = let id = entryLabel block
+                           in  case mapLookup id env of
+                                 Just ProcPoint -> setInsert id pps
+                                 _ -> pps
+           procPoints' = foldGraphBlocks add setEmpty g
+           newPoints = mapMaybe ppSuccessor blocks
+           newPoint  = listToMaybe newPoints
+           ppSuccessor b =
+               let nreached id = case mapLookup id env `orElse`
+                                       pprPanic "no ppt" (ppr id <+> ppr b) of
+                                   ProcPoint -> 1
+                                   ReachedBy ps -> setSize ps
+                   block_procpoints = nreached (entryLabel b)
+                   -- | Looking for a successor of b that is reached by
+                   -- more proc points than b and is not already a proc
+                   -- point.  If found, it can become a proc point.
+                   newId succ_id = not (setMember succ_id procPoints') &&
+                                   nreached succ_id > block_procpoints
+               in  listToMaybe $ filter newId $ successors b
+{-
+       case newPoints of
+           []  -> return procPoints'
+           pps -> extendPPSet g blocks
+                    (foldl extendBlockSet procPoints' pps)
+-}
+       case newPoint of Just id ->
+                          if setMember id procPoints' then panic "added old proc pt"
+                          else extendPPSet g blocks (setInsert id procPoints')
+                        Nothing -> return procPoints'
+
+
+------------------------------------------------------------------------
+--                    Computing Proc-Point Protocols                  --
+------------------------------------------------------------------------
+
+{-
+
+There is one major trick, discovered by Michael Adams, which is that
+we want to choose protocols in a way that enables us to optimize away
+some continuations.  The optimization is very much like branch-chain
+elimination, except that it involves passing results as well as
+control.  The idea is that if a call's continuation k does nothing but
+CopyIn its results and then goto proc point P, the call's continuation
+may be changed to P, *provided* P's protocol is identical to the
+protocol for the CopyIn.  We choose protocols to make this so.
+
+Here's an explanatory example; we begin with the source code (lines
+separate basic blocks):
+
+  ..1..;
+  x, y = g();
+  goto P;
+  -------
+  P: ..2..;
+
+Zipperization converts this code as follows:
+
+  ..1..;
+  call g() returns to k;
+  -------
+  k: CopyIn(x, y);
+     goto P;
+  -------
+  P: ..2..;
+
+What we'd like to do is assign P the same CopyIn protocol as k, so we
+can eliminate k:
+
+  ..1..;
+  call g() returns to P;
+  -------
+  P: CopyIn(x, y); ..2..;
+
+Of course, P may be the target of more than one continuation, and
+different continuations may have different protocols.  Michael Adams
+implemented a voting mechanism, but he thinks a simple greedy
+algorithm would be just as good, so that's what we do.
+
+-}
+
+data Protocol = Protocol Convention CmmFormals Area
+  deriving Eq
+instance Outputable Protocol where
+  ppr (Protocol c fs a) = text "Protocol" <+> ppr c <+> ppr fs <+> ppr a
+
+-- | Function 'optimize_calls' chooses protocols only for those proc
+-- points that are relevant to the optimization explained above.
+-- The others are assigned by 'add_unassigned', which is not yet clever.
+
+addProcPointProtocols :: ProcPointSet -> ProcPointSet -> CmmGraph -> FuelUniqSM CmmGraph
+addProcPointProtocols callPPs procPoints g =
+  do liveness <- cmmLiveness g
+     (protos, g') <- optimize_calls liveness g
+     blocks'' <- add_CopyOuts protos procPoints g'
+     return $ ofBlockMap (g_entry g) blocks''
+    where optimize_calls liveness g =  -- see Note [Separate Adams optimization]
+            do let (protos, blocks') =
+                       foldGraphBlocks maybe_add_call (mapEmpty, mapEmpty) g
+                   protos' = add_unassigned liveness procPoints protos
+               let g' = ofBlockMap (g_entry g) (add_CopyIns callPPs protos' blocks')
+               return (protos', removeUnreachableBlocks g')
+          maybe_add_call :: CmmBlock -> (BlockEnv Protocol, BlockEnv CmmBlock)
+                         -> (BlockEnv Protocol, BlockEnv CmmBlock)
+          -- ^ If the block is a call whose continuation goes to a proc point
+          -- whose protocol either matches the continuation's or is not yet set,
+          -- redirect the call (cf 'newblock') and set the protocol if necessary
+          maybe_add_call block (protos, blocks) =
+              case lastNode block of
+                CmmCall tgt (Just k) args res s
+                    | Just proto <- mapLookup k protos,
+                      Just pee   <- branchesToProcPoint k
+                    -> let newblock = replaceLastNode block (CmmCall tgt (Just pee)
+                                                                     args res s)
+                           changed_blocks   = insertBlock newblock blocks
+                           unchanged_blocks = insertBlock block    blocks
+                       in case mapLookup pee protos of
+                            Nothing -> (mapInsert pee proto protos, changed_blocks)
+                            Just proto' ->
+                              if proto == proto' then (protos, changed_blocks)
+                              else (protos, unchanged_blocks)
+                _ -> (protos, insertBlock block blocks)
+
+          branchesToProcPoint :: BlockId -> Maybe BlockId
+          -- ^ Tells whether the named block is just a branch to a proc point
+          branchesToProcPoint id =
+              let block = mapLookup id (toBlockMap g) `orElse`
+                                    panic "branch out of graph"
+              in case blockToNodeList block of
+-- MS: There is an ugly bug in ghc-6.10, which rejects following valid code.
+-- After trying several tricks, the NOINLINE on getItOut worked. Uffff.
+#if __GLASGOW_HASKELL__ >= 612
+                   (_, [], JustC (CmmBranch pee)) | setMember pee procPoints -> Just pee
+                   _                                                         -> Nothing
+#else
+                   (_, [], exit) | CmmBranch pee <- getItOut exit
+                                 , setMember pee procPoints      -> Just pee
+                   _                                             -> Nothing
+              where {-# NOINLINE getItOut #-}
+                    getItOut :: MaybeC C a -> a
+                    getItOut (JustC a) = a
+#endif
+
+-- | For now, following a suggestion by Ben Lippmeier, we pass all
+-- live variables as arguments, hoping that a clever register
+-- allocator might help.
+
+add_unassigned :: BlockEnv CmmLive -> ProcPointSet -> BlockEnv Protocol ->
+                  BlockEnv Protocol
+add_unassigned = pass_live_vars_as_args
+
+pass_live_vars_as_args :: BlockEnv CmmLive -> ProcPointSet ->
+                          BlockEnv Protocol -> BlockEnv Protocol
+pass_live_vars_as_args _liveness procPoints protos = protos'
+  where protos' = setFold addLiveVars protos procPoints
+        addLiveVars :: BlockId -> BlockEnv Protocol -> BlockEnv Protocol
+        addLiveVars id protos =
+            case mapLookup id protos of
+              Just _  -> protos
+              Nothing -> let live = emptyRegSet
+                                    --lookupBlockEnv _liveness id `orElse`
+                                    --panic ("no liveness at block " ++ show id)
+                             formals = uniqSetToList live
+                             prot = Protocol Private formals $ CallArea $ Young id
+                         in  mapInsert id prot protos
+
+
+-- | Add copy-in instructions to each proc point that did not arise from a call
+-- instruction. (Proc-points that arise from calls already have their copy-in instructions.)
+
+add_CopyIns :: ProcPointSet -> BlockEnv Protocol -> BlockEnv CmmBlock -> BlockEnv CmmBlock
+add_CopyIns callPPs protos blocks = mapFold maybe_insert_CopyIns mapEmpty blocks
+    where maybe_insert_CopyIns block blocks
+             | not $ setMember bid callPPs
+             , Just (Protocol c fs _area) <- mapLookup bid protos
+             = let nodes     = copyInSlot c fs
+                   (h, m, l) = blockToNodeList block
+               in insertBlock (blockOfNodeList (h, nodes ++ m, l)) blocks
+             | otherwise = insertBlock block blocks
+           where bid = entryLabel block
+
+
+-- | Add a CopyOut node before each procpoint.
+-- If the predecessor is a call, then the copy outs should already be done by the callee.
+-- Note: If we need to add copy-out instructions, they may require stack space,
+-- so we accumulate a map from the successors to the necessary stack space,
+-- then update the successors after we have finished inserting the copy-outs.
+
+add_CopyOuts :: BlockEnv Protocol -> ProcPointSet -> CmmGraph ->
+                FuelUniqSM (BlockEnv CmmBlock)
+add_CopyOuts protos procPoints g = foldGraphBlocks mb_copy_out (return mapEmpty) g
+    where mb_copy_out :: CmmBlock -> FuelUniqSM (BlockEnv CmmBlock) ->
+                                     FuelUniqSM (BlockEnv CmmBlock)
+          mb_copy_out b z | entryLabel b == g_entry g = skip b z
+          mb_copy_out b z =
+            case lastNode b of
+              CmmCall {}        -> skip b z -- copy out done by callee
+              CmmForeignCall {} -> skip b z -- copy out done by callee
+              _ -> copy_out b z
+          copy_out b z = foldr trySucc init (successors b) >>= finish
+            where init = (\bmap -> (b, bmap)) `liftM` z
+                  trySucc succId z =
+                    if setMember succId procPoints then
+                      case mapLookup succId protos of
+                        Nothing -> z
+                        Just (Protocol c fs _area) -> insert z succId $ copyOutSlot c fs
+                    else z
+                  insert z succId m =
+                    do (b, bmap) <- z
+                       (b, bs)   <- insertBetween b m succId
+                       -- pprTrace "insert for succ" (ppr succId <> ppr m) $ do
+                       return $ (b, foldl (flip insertBlock) bmap bs)
+                  finish (b, bmap) = return $ insertBlock b bmap
+          skip b bs = insertBlock b `liftM` bs
+
+-- At this point, we have found a set of procpoints, each of which should be
+-- the entry point of a procedure.
+-- Now, we create the procedure for each proc point,
+-- which requires that we:
+-- 1. build a map from proc points to the blocks reachable from the proc point
+-- 2. turn each branch to a proc point into a jump
+-- 3. turn calls and returns into jumps
+-- 4. build info tables for the procedures -- and update the info table for
+--    the SRTs in the entry procedure as well.
+-- Input invariant: A block should only be reachable from a single ProcPoint.
+splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
+                     CmmTop -> FuelUniqSM [CmmTop]
+splitAtProcPoints entry_label callPPs procPoints procMap
+                  (CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info})
+                           top_l g@(CmmGraph {g_entry=entry})) =
+  do -- Build a map from procpoints to the blocks they reach
+     let addBlock b graphEnv =
+           case mapLookup bid procMap of
+             Just ProcPoint -> add graphEnv bid bid b
+             Just (ReachedBy set) ->
+               case setElems set of
+                 []   -> graphEnv
+                 [id] -> add graphEnv id bid b 
+                 _    -> panic "Each block should be reachable from only one ProcPoint"
+             Nothing -> pprPanic "block not reached by a proc point?" (ppr bid)
+           where bid = entryLabel b
+         add graphEnv procId bid b = mapInsert procId graph' graphEnv
+               where graph  = mapLookup procId graphEnv `orElse` mapEmpty
+                     graph' = mapInsert bid b graph
+     graphEnv <- return $ foldGraphBlocks addBlock emptyBlockMap g
+     -- Build a map from proc point BlockId to labels for their new procedures
+     -- Due to common blockification, we may overestimate the set of procpoints.
+     let add_label map pp = return $ Map.insert pp lbl map
+           where lbl = if pp == entry then entry_label else blockLbl pp
+     procLabels <- foldM add_label Map.empty
+                         (filter (flip mapMember (toBlockMap g)) (setElems procPoints))
+     -- For each procpoint, we need to know the SP offset on entry.
+     -- If the procpoint is:
+     --  - continuation of a call, the SP offset is in the call
+     --  - otherwise, 0 (and left out of the spEntryMap)
+     let add_sp_off :: CmmBlock -> BlockEnv CmmStackInfo -> BlockEnv CmmStackInfo
+         add_sp_off b env =
+           case lastNode b of
+             CmmCall {cml_cont = Just succ, cml_ret_args = off, cml_ret_off = updfr_off} ->
+               mapInsert succ (StackInfo { arg_space = off, updfr_space = Just updfr_off}) env
+             CmmForeignCall {succ = succ, updfr = updfr_off} ->
+               mapInsert succ (StackInfo { arg_space = wORD_SIZE, updfr_space = Just updfr_off}) env
+             _ -> env
+         spEntryMap = foldGraphBlocks add_sp_off (mapInsert entry stack_info emptyBlockMap) g
+         getStackInfo id = mapLookup id spEntryMap `orElse` StackInfo {arg_space = 0, updfr_space = Nothing}
+     -- In each new graph, add blocks jumping off to the new procedures,
+     -- and replace branches to procpoints with branches to the jump-off blocks
+     let add_jump_block (env, bs) (pp, l) =
+           do bid <- liftM mkBlockId getUniqueM
+              let b = blockOfNodeList (JustC (CmmEntry bid), [], JustC jump)
+                  StackInfo {arg_space = argSpace, updfr_space = off} = getStackInfo pp
+                  jump = CmmCall (CmmLit (CmmLabel l')) Nothing argSpace 0
+                                 (off `orElse` 0) -- Jump's shouldn't need the offset...
+                  l' = if setMember pp callPPs then entryLblToInfoLbl l else l
+              return (mapInsert pp bid env, b : bs)
+         add_jumps (newGraphEnv) (ppId, blockEnv) =
+           do let needed_jumps = -- find which procpoints we currently branch to
+                    mapFold add_if_branch_to_pp [] blockEnv
+                  add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
+                  add_if_branch_to_pp block rst =
+                    case lastNode block of
+                      CmmBranch id          -> add_if_pp id rst
+                      CmmCondBranch _ ti fi -> add_if_pp ti (add_if_pp fi rst)
+                      CmmSwitch _ tbl       -> foldr add_if_pp rst (catMaybes tbl)
+                      _                     -> rst
+                  add_if_pp id rst = case Map.lookup id procLabels of
+                                       Just x -> (id, x) : rst
+                                       Nothing -> rst
+              (jumpEnv, jumpBlocks) <-
+                 foldM add_jump_block (mapEmpty, []) needed_jumps
+                  -- update the entry block
+              let b = expectJust "block in env" $ mapLookup ppId blockEnv
+                  off = getStackInfo ppId
+                  blockEnv' = mapInsert ppId b blockEnv
+                  -- replace branches to procpoints with branches to jumps
+                  blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'
+                  -- add the jump blocks to the graph
+                  blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks
+              let g' = (off, ofBlockMap ppId blockEnv''')
+              -- pprTrace "g' pre jumps" (ppr g') $ do
+              return (mapInsert ppId g' newGraphEnv)
+     graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv
+     let to_proc (bid, (stack_info, g)) | setMember bid callPPs =
+           if bid == entry then
+             CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info})
+                     top_l (replacePPIds g)
+           else
+             CmmProc (TopInfo {info_tbl=emptyContInfoTable, stack_info=stack_info})
+                     lbl (replacePPIds g)
+           where lbl = expectJust "pp label" $ Map.lookup bid procLabels
+         to_proc (bid, (stack_info, g)) =
+           CmmProc (TopInfo {info_tbl=CmmNonInfoTable, stack_info=stack_info})
+                   lbl (replacePPIds g)
+             where lbl = expectJust "pp label" $ Map.lookup bid procLabels
+         -- References to procpoint IDs can now be replaced with the infotable's label
+         replacePPIds g = mapGraphNodes (id, mapExp repl, mapExp repl) g
+           where repl e@(CmmLit (CmmBlock bid)) =
+                   case Map.lookup bid procLabels of
+                     Just l  -> CmmLit (CmmLabel (entryLblToInfoLbl l))
+                     Nothing -> e
+                 repl e = e
+     -- The C back end expects to see return continuations before the call sites.
+     -- Here, we sort them in reverse order -- it gets reversed later.
+     let (_, block_order) = foldl add_block_num (0::Int, emptyBlockMap) (postorderDfs g)
+         add_block_num (i, map) block = (i+1, mapInsert (entryLabel block) i map)
+         sort_fn (bid, _) (bid', _) =
+           compare (expectJust "block_order" $ mapLookup bid  block_order)
+                   (expectJust "block_order" $ mapLookup bid' block_order)
+     procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv
+     return -- pprTrace "procLabels" (ppr procLabels)
+            -- pprTrace "splitting graphs" (ppr procs)
+            procs
+splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t]
+
+----------------------------------------------------------------
+
+{-
+Note [Direct reachability]
+
+Block B is directly reachable from proc point P iff control can flow
+from P to B without passing through an intervening proc point.
+-}
+
+----------------------------------------------------------------
+
+{-
+Note [No simple dataflow]
+
+Sadly, it seems impossible to compute the proc points using a single
+dataflow pass.  One might attempt to use this simple lattice:
+
+  data Location = Unknown
+                | InProc BlockId -- node is in procedure headed by the named proc point
+                | ProcPoint      -- node is itself a proc point   
+
+At a join, a node in two different blocks becomes a proc point.  
+The difficulty is that the change of information during iterative
+computation may promote a node prematurely.  Here's a program that
+illustrates the difficulty:
+
+  f () {
+  entry:
+    ....
+  L1:
+    if (...) { ... }
+    else { ... }
+
+  L2: if (...) { g(); goto L1; }
+      return x + y;
+  }
+
+The only proc-point needed (besides the entry) is L1.  But in an
+iterative analysis, consider what happens to L2.  On the first pass
+through, it rises from Unknown to 'InProc entry', but when L1 is
+promoted to a proc point (because it's the successor of g()), L1's
+successors will be promoted to 'InProc L1'.  The problem hits when the
+new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'.
+The join operation makes it a proc point when in fact it needn't be,
+because its immediate dominator L1 is already a proc point and there
+are no other proc points that directly reach L2.
+-}
+
+
+
+{- Note [Separate Adams optimization]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It may be worthwhile to attempt the Adams optimization by rewriting
+the graph before the assignment of proc-point protocols.  Here are a
+couple of rules:
+                                                                  
+  g() returns to k;                    g() returns to L;          
+  k: CopyIn c ress; goto L:             
+   ...                        ==>        ...                       
+  L: // no CopyIn node here            L: CopyIn c ress; 
+
+                                                                  
+And when c == c' and ress == ress', this also:
+
+  g() returns to k;                    g() returns to L;          
+  k: CopyIn c ress; goto L:             
+   ...                        ==>        ...                       
+  L: CopyIn c' ress'                   L: CopyIn c' ress' ; 
+
+In both cases the goal is to eliminate k.
+-}
diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs
deleted file mode 100644 (file)
index c972ad5..0000000
+++ /dev/null
@@ -1,554 +0,0 @@
-module CmmProcPointZ
-    ( ProcPointSet, Status(..)
-    , callProcPoints, minimalProcPointSet
-    , addProcPointProtocols, splitAtProcPoints, procPointAnalysis
-    )
-where
-
-import Prelude hiding (zip, unzip, last)
-
-import BlockId
-import CLabel
-import Cmm hiding (blockId)
-import CmmContFlowOpt
-import CmmInfo
-import CmmLiveZ
-import CmmTx
-import DFMonad
-import Data.List (sortBy)
-import Maybes
-import MkZipCfg
-import MkZipCfgCmm hiding (CmmBlock, CmmGraph, CmmTopZ)
-import Control.Monad
-import Outputable
-import UniqSet
-import UniqSupply
-import ZipCfg
-import ZipCfgCmmRep
-import ZipDataflow
-
-import qualified Data.Map as Map
-
--- Compute a minimal set of proc points for a control-flow graph.
-
--- Determine a protocol for each proc point (which live variables will
--- be passed as arguments and which will be on the stack). 
-
-{-
-A proc point is a basic block that, after CPS transformation, will
-start a new function.  The entry block of the original function is a
-proc point, as is the continuation of each function call.
-A third kind of proc point arises if we want to avoid copying code.
-Suppose we have code like the following:
-
-  f() {
-    if (...) { ..1..; call foo(); ..2..}
-    else     { ..3..; call bar(); ..4..}
-    x = y + z;
-    return x;
-  }
-
-The statement 'x = y + z' can be reached from two different proc
-points: the continuations of foo() and bar().  We would prefer not to
-put a copy in each continuation; instead we would like 'x = y + z' to
-be the start of a new procedure to which the continuations can jump:
-
-  f_cps () {
-    if (...) { ..1..; push k_foo; jump foo_cps(); }
-    else     { ..3..; push k_bar; jump bar_cps(); }
-  }
-  k_foo() { ..2..; jump k_join(y, z); }
-  k_bar() { ..4..; jump k_join(y, z); }
-  k_join(y, z) { x = y + z; return x; }
-
-You might think then that a criterion to make a node a proc point is
-that it is directly reached by two distinct proc points.  (Note
-[Direct reachability].)  But this criterion is a bit too simple; for
-example, 'return x' is also reached by two proc points, yet there is
-no point in pulling it out of k_join.  A good criterion would be to
-say that a node should be made a proc point if it is reached by a set
-of proc points that is different than its immediate dominator.  NR
-believes this criterion can be shown to produce a minimum set of proc
-points, and given a dominator tree, the proc points can be chosen in
-time linear in the number of blocks.  Lacking a dominator analysis,
-however, we turn instead to an iterative solution, starting with no
-proc points and adding them according to these rules:
-
-  1. The entry block is a proc point.
-  2. The continuation of a call is a proc point.
-  3. A node is a proc point if it is directly reached by more proc
-     points than one of its predecessors.
-
-Because we don't understand the problem very well, we apply rule 3 at
-most once per iteration, then recompute the reachability information.
-(See Note [No simple dataflow].)  The choice of the new proc point is
-arbitrary, and I don't know if the choice affects the final solution,
-so I don't know if the number of proc points chosen is the
-minimum---but the set will be minimal.
--}
-
-type ProcPointSet = BlockSet
-
-data Status
-  = ReachedBy ProcPointSet  -- set of proc points that directly reach the block
-  | ProcPoint               -- this block is itself a proc point
-
-instance Outputable Status where
-  ppr (ReachedBy ps)
-      | isEmptyBlockSet ps = text "<not-reached>"
-      | otherwise = text "reached by" <+>
-                    (hsep $ punctuate comma $ map ppr $ blockSetToList ps)
-  ppr ProcPoint = text "<procpt>"
-
-
-lattice :: DataflowLattice Status
-lattice = DataflowLattice "direct proc-point reachability" unreached add_to False
-    where unreached = ReachedBy emptyBlockSet
-          add_to _ ProcPoint = noTx ProcPoint
-          add_to ProcPoint _ = aTx ProcPoint -- aTx because of previous case again
-          add_to (ReachedBy p) (ReachedBy p') =
-              let union = unionBlockSets p p'
-              in  if sizeBlockSet union > sizeBlockSet p' then
-                      aTx (ReachedBy union)
-                  else
-                      noTx (ReachedBy p')
---------------------------------------------------
--- transfer equations
-
-forward :: ForwardTransfers Middle Last Status
-forward = ForwardTransfers first middle last exit
-    where first id ProcPoint = ReachedBy $ unitBlockSet id
-          first  _ x = x
-          middle _ x = x
-          last (LastCall _ (Just id) _ _ _) _ = LastOutFacts [(id, ProcPoint)]
-          last l x = LastOutFacts $ map (\id -> (id, x)) (succs l)
-          exit x   = x
-                
--- It is worth distinguishing two sets of proc points:
--- those that are induced by calls in the original graph
--- and those that are introduced because they're reachable from multiple proc points.
-callProcPoints      :: CmmGraph -> ProcPointSet
-callProcPoints g = fold_blocks add (unitBlockSet (lg_entry g)) g
-  where add b set = case last $ unzip b of
-                      LastOther (LastCall _ (Just k) _ _ _) -> extendBlockSet set k
-                      _ -> set
-
-minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelMonad ProcPointSet
--- Given the set of successors of calls (which must be proc-points)
--- figure ou the minimal set of necessary proc-points
-minimalProcPointSet callProcPoints g = extendPPSet g (postorder_dfs g) callProcPoints
-
-type PPFix = FuelMonad (ForwardFixedPoint Middle Last Status ())
-
-procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelMonad (BlockEnv Status)
--- Once you know what the proc-points are, figure out
--- what proc-points each block is reachable from
-procPointAnalysis procPoints g =
-  let addPP env id = extendBlockEnv env id ProcPoint
-      initProcPoints = foldl addPP emptyBlockEnv (blockSetToList procPoints)
-  in liftM zdfFpFacts $
-        (zdfSolveFrom initProcPoints "proc-point reachability" lattice
-                              forward (fact_bot lattice) $ graphOfLGraph g :: PPFix)
-
-extendPPSet :: CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelMonad ProcPointSet
-extendPPSet g blocks procPoints =
-    do env <- procPointAnalysis procPoints g
-       let add block pps = let id = blockId block
-                           in  case lookupBlockEnv env id of
-                                 Just ProcPoint -> extendBlockSet pps id
-                                 _ -> pps
-           procPoints' = fold_blocks add emptyBlockSet g
-           newPoints = mapMaybe ppSuccessor blocks
-           newPoint  = listToMaybe newPoints 
-           ppSuccessor b@(Block bid _) =
-               let nreached id = case lookupBlockEnv env id `orElse`
-                                       pprPanic "no ppt" (ppr id <+> ppr b) of
-                                   ProcPoint -> 1
-                                   ReachedBy ps -> sizeBlockSet ps
-                   block_procpoints = nreached bid
-                   -- | Looking for a successor of b that is reached by
-                   -- more proc points than b and is not already a proc
-                   -- point.  If found, it can become a proc point.
-                   newId succ_id = not (elemBlockSet succ_id procPoints') &&
-                                   nreached succ_id > block_procpoints
-               in  listToMaybe $ filter newId $ succs b
-{-
-       case newPoints of
-           []  -> return procPoints'
-           pps -> extendPPSet g blocks
-                    (foldl extendBlockSet procPoints' pps)
--}
-       case newPoint of Just id ->
-                          if elemBlockSet id procPoints' then panic "added old proc pt"
-                          else extendPPSet g blocks (extendBlockSet procPoints' id)
-                        Nothing -> return procPoints'
-
-
-------------------------------------------------------------------------
---                    Computing Proc-Point Protocols                  --
-------------------------------------------------------------------------
-
-{-
-
-There is one major trick, discovered by Michael Adams, which is that
-we want to choose protocols in a way that enables us to optimize away
-some continuations.  The optimization is very much like branch-chain
-elimination, except that it involves passing results as well as
-control.  The idea is that if a call's continuation k does nothing but
-CopyIn its results and then goto proc point P, the call's continuation
-may be changed to P, *provided* P's protocol is identical to the
-protocol for the CopyIn.  We choose protocols to make this so.
-
-Here's an explanatory example; we begin with the source code (lines
-separate basic blocks):
-
-  ..1..;
-  x, y = g();
-  goto P;
-  -------
-  P: ..2..;
-
-Zipperization converts this code as follows:
-
-  ..1..;
-  call g() returns to k;
-  -------
-  k: CopyIn(x, y);
-     goto P;
-  -------
-  P: ..2..;
-
-What we'd like to do is assign P the same CopyIn protocol as k, so we
-can eliminate k:
-
-  ..1..;
-  call g() returns to P;
-  -------
-  P: CopyIn(x, y); ..2..;
-
-Of course, P may be the target of more than one continuation, and
-different continuations may have different protocols.  Michael Adams
-implemented a voting mechanism, but he thinks a simple greedy
-algorithm would be just as good, so that's what we do.
-
--}
-
-data Protocol = Protocol Convention CmmFormals Area
-  deriving Eq
-instance Outputable Protocol where
-  ppr (Protocol c fs a) = text "Protocol" <+> ppr c <+> ppr fs <+> ppr a
-
--- | Function 'optimize_calls' chooses protocols only for those proc
--- points that are relevant to the optimization explained above.
--- The others are assigned by 'add_unassigned', which is not yet clever.
-
-addProcPointProtocols :: ProcPointSet -> ProcPointSet -> CmmGraph -> FuelMonad CmmGraph
-addProcPointProtocols callPPs procPoints g =
-  do liveness <- cmmLivenessZ g
-     (protos, g') <- optimize_calls liveness g
-     blocks'' <- add_CopyOuts protos procPoints g'
-     return $ LGraph (lg_entry g) blocks''
-    where optimize_calls liveness g =  -- see Note [Separate Adams optimization]
-            do let (protos, blocks') =
-                       fold_blocks maybe_add_call (init_protocols, emptyBlockEnv) g
-                   protos' = add_unassigned liveness procPoints protos
-               blocks <- add_CopyIns callPPs protos' blocks'
-               let g' = LGraph (lg_entry g) (mkBlockEnv (map withKey (concat blocks)))
-                   withKey b@(Block bid _) = (bid, b)
-               return (protos', runTx removeUnreachableBlocksZ g')
-          maybe_add_call :: CmmBlock -> (BlockEnv Protocol, BlockEnv CmmBlock)
-                         -> (BlockEnv Protocol, BlockEnv CmmBlock)
-          -- ^ If the block is a call whose continuation goes to a proc point
-          -- whose protocol either matches the continuation's or is not yet set,
-          -- redirect the call (cf 'newblock') and set the protocol if necessary
-          maybe_add_call block (protos, blocks) =
-              case goto_end $ unzip block of
-                (h, LastOther (LastCall tgt (Just k) args res s))
-                    | Just proto <- lookupBlockEnv protos k,
-                      Just pee   <- branchesToProcPoint k
-                    -> let newblock = zipht h (tailOfLast (LastCall tgt (Just pee)
-                                                                    args res s))
-                           changed_blocks   = insertBlock newblock blocks
-                           unchanged_blocks = insertBlock block    blocks
-                       in case lookupBlockEnv protos pee of
-                            Nothing -> (extendBlockEnv protos pee proto,changed_blocks)
-                            Just proto' ->
-                              if proto == proto' then (protos, changed_blocks)
-                              else (protos, unchanged_blocks)
-                _ -> (protos, insertBlock block blocks)
-
-          branchesToProcPoint :: BlockId -> Maybe BlockId
-          -- ^ Tells whether the named block is just a branch to a proc point
-          branchesToProcPoint id =
-              let (Block _ t) = lookupBlockEnv (lg_blocks g) id `orElse`
-                                    panic "branch out of graph"
-              in case t of
-                   ZLast (LastOther (LastBranch pee))
-                       | elemBlockSet pee procPoints -> Just pee
-                   _ -> Nothing
-          init_protocols = fold_blocks maybe_add_proto emptyBlockEnv g
-          maybe_add_proto :: CmmBlock -> BlockEnv Protocol -> BlockEnv Protocol
-          --maybe_add_proto (Block id (ZTail (CopyIn c _ fs _srt) _)) env =
-          --    extendBlockEnv env id (Protocol c fs $ toArea id fs)
-          maybe_add_proto _ env = env
-          -- JD: Is this proto stuff even necessary, now that we have
-          -- common blockification?
-
--- | For now, following a suggestion by Ben Lippmeier, we pass all
--- live variables as arguments, hoping that a clever register
--- allocator might help.
-
-add_unassigned :: BlockEnv CmmLive -> ProcPointSet -> BlockEnv Protocol ->
-                  BlockEnv Protocol
-add_unassigned = pass_live_vars_as_args
-
-pass_live_vars_as_args :: BlockEnv CmmLive -> ProcPointSet ->
-                          BlockEnv Protocol -> BlockEnv Protocol
-pass_live_vars_as_args _liveness procPoints protos = protos'
-  where protos' = foldBlockSet addLiveVars protos procPoints
-        addLiveVars :: BlockId -> BlockEnv Protocol -> BlockEnv Protocol
-        addLiveVars id protos =
-            case lookupBlockEnv protos id of
-              Just _  -> protos
-              Nothing -> let live = emptyRegSet
-                                    --lookupBlockEnv _liveness id `orElse`
-                                    --panic ("no liveness at block " ++ show id)
-                             formals = uniqSetToList live
-                             prot = Protocol Private formals $ CallArea $ Young id
-                         in  extendBlockEnv protos id prot
-
-
--- | Add copy-in instructions to each proc point that did not arise from a call
--- instruction. (Proc-points that arise from calls already have their copy-in instructions.)
-
-add_CopyIns :: ProcPointSet -> BlockEnv Protocol -> BlockEnv CmmBlock ->
-               FuelMonad [[CmmBlock]]
-add_CopyIns callPPs protos blocks =
-  liftUniq $ mapM maybe_insert_CopyIns (blockEnvToList blocks)
-    where maybe_insert_CopyIns (_, b@(Block id t))
-           | not $ elemBlockSet id callPPs
-           = case lookupBlockEnv protos id of
-               Just (Protocol c fs _area) ->
-                 do LGraph _ blocks <-
-                      lgraphOfAGraph (mkLabel id <*> copyInSlot c fs <*> mkZTail t)
-                    return (map snd $ blockEnvToList blocks)
-               Nothing -> return [b]
-           | otherwise = return [b]
-
--- | Add a CopyOut node before each procpoint.
--- If the predecessor is a call, then the copy outs should already be done by the callee.
--- Note: If we need to add copy-out instructions, they may require stack space,
--- so we accumulate a map from the successors to the necessary stack space,
--- then update the successors after we have finished inserting the copy-outs.
-
-add_CopyOuts :: BlockEnv Protocol -> ProcPointSet -> CmmGraph ->
-                FuelMonad (BlockEnv CmmBlock)
-add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv) g
-    where mb_copy_out :: CmmBlock -> FuelMonad (BlockEnv CmmBlock) ->
-                                     FuelMonad (BlockEnv CmmBlock)
-          mb_copy_out b@(Block bid _) z | bid == lg_entry g = skip b z 
-          mb_copy_out b z =
-            case last $ unzip b of
-              LastOther (LastCall _ _ _ _ _) -> skip b z -- copy out done by callee
-              _ -> copy_out b z
-          copy_out b z = fold_succs trySucc b init >>= finish
-            where init = z >>= (\bmap -> return (b, bmap))
-                  trySucc succId z =
-                    if elemBlockSet succId procPoints then
-                      case lookupBlockEnv protos succId of
-                        Nothing -> z
-                        Just (Protocol c fs _area) -> insert z succId $ copyOutSlot c fs
-                    else z
-                  insert z succId m =
-                    do (b, bmap) <- z
-                       (b, bs)   <- insertBetween b m succId
-                       -- pprTrace "insert for succ" (ppr succId <> ppr m) $ do
-                       return $ (b, foldl (flip insertBlock) bmap bs)
-                  finish (b@(Block bid _), bmap) =
-                    return $ (extendBlockEnv bmap bid b)
-          skip b@(Block bid _) bs =
-            bs >>= (\bmap -> return (extendBlockEnv bmap bid b))
-
--- At this point, we have found a set of procpoints, each of which should be
--- the entry point of a procedure.
--- Now, we create the procedure for each proc point,
--- which requires that we:
--- 1. build a map from proc points to the blocks reachable from the proc point
--- 2. turn each branch to a proc point into a jump
--- 3. turn calls and returns into jumps
--- 4. build info tables for the procedures -- and update the info table for
---    the SRTs in the entry procedure as well.
--- Input invariant: A block should only be reachable from a single ProcPoint.
-splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
-                     CmmTopZ -> FuelMonad [CmmTopZ]
-splitAtProcPoints entry_label callPPs procPoints procMap
-                  (CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args
-                           (stackInfo, g@(LGraph entry blocks))) =
-  do -- Build a map from procpoints to the blocks they reach
-     let addBlock b@(Block bid _) graphEnv =
-           case lookupBlockEnv procMap bid of
-             Just ProcPoint -> add graphEnv bid bid b
-             Just (ReachedBy set) ->
-               case blockSetToList set of
-                 []   -> graphEnv
-                 [id] -> add graphEnv id bid b 
-                 _    -> panic "Each block should be reachable from only one ProcPoint"
-             Nothing -> pprPanic "block not reached by a proc point?" (ppr bid)
-         add graphEnv procId bid b = extendBlockEnv graphEnv procId graph'
-               where graph  = lookupBlockEnv graphEnv procId `orElse` emptyBlockEnv
-                     graph' = extendBlockEnv graph bid b
-     graphEnv <- return $ fold_blocks addBlock emptyBlockEnv g
-     -- Build a map from proc point BlockId to labels for their new procedures
-     -- Due to common blockification, we may overestimate the set of procpoints.
-     let add_label map pp = return $ Map.insert pp lbl map
-           where lbl = if pp == entry then entry_label else blockLbl pp
-     procLabels <- foldM add_label Map.empty
-                         (filter (elemBlockEnv blocks) (blockSetToList procPoints))
-     -- For each procpoint, we need to know the SP offset on entry.
-     -- If the procpoint is:
-     --  - continuation of a call, the SP offset is in the call
-     --  - otherwise, 0 -- no overflow for passing those variables
-     let add_sp_off b env =
-           case last (unzip b) of
-             LastOther (LastCall {cml_cont = Just succ, cml_ret_args = off,
-                                  cml_ret_off = updfr_off}) ->
-               extendBlockEnv env succ (off, updfr_off)
-             _ -> env
-         spEntryMap = fold_blocks add_sp_off (mkBlockEnv [(entry, stackInfo)]) g
-         getStackInfo id = lookupBlockEnv spEntryMap id `orElse` (0, Nothing)
-     -- In each new graph, add blocks jumping off to the new procedures,
-     -- and replace branches to procpoints with branches to the jump-off blocks
-     let add_jump_block (env, bs) (pp, l) =
-           do bid <- liftM mkBlockId getUniqueM
-              let b = Block bid (ZLast (LastOther jump))
-                  (argSpace, _) = getStackInfo pp
-                  jump = LastCall (CmmLit (CmmLabel l')) Nothing argSpace 0 Nothing
-                  l' = if elemBlockSet pp callPPs then entryLblToInfoLbl l else l
-              return (extendBlockEnv env pp bid, b : bs)
-         add_jumps (newGraphEnv) (ppId, blockEnv) =
-           do let needed_jumps = -- find which procpoints we currently branch to
-                    foldBlockEnv' add_if_branch_to_pp [] blockEnv
-                  add_if_branch_to_pp block rst =
-                    case last (unzip block) of
-                      LastOther (LastBranch id) -> add_if_pp id rst
-                      LastOther (LastCondBranch _ ti fi) ->
-                        add_if_pp ti (add_if_pp fi rst)
-                      LastOther (LastSwitch _ tbl) -> foldr add_if_pp rst (catMaybes tbl)
-                      _ -> rst
-                  add_if_pp id rst = case Map.lookup id procLabels of
-                                       Just x -> (id, x) : rst
-                                       Nothing -> rst
-              (jumpEnv, jumpBlocks) <-
-                 foldM add_jump_block (emptyBlockEnv, []) needed_jumps
-                  -- update the entry block
-              let b = expectJust "block in env" $ lookupBlockEnv blockEnv ppId
-                  off = getStackInfo ppId
-                  blockEnv' = extendBlockEnv blockEnv ppId b
-                  -- replace branches to procpoints with branches to jumps
-                  LGraph _ blockEnv'' = replaceBranches jumpEnv $ LGraph ppId blockEnv'
-                  -- add the jump blocks to the graph
-                  blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks
-              let g' = (off, LGraph ppId blockEnv''')
-              -- pprTrace "g' pre jumps" (ppr g') $ do
-              return (extendBlockEnv newGraphEnv ppId g')
-     graphEnv <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv
-     let to_proc (bid, g) |&