Merge in new code generator branch.

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.

9 files changed, 64 insertions, 71 deletions

diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
index 556f91c228..1eaf00f3a2 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
@@ -12,7 +12,7 @@ import RegAlloc.Liveness
 import Instruction
 import Reg
 
-import Cmm
+import OldCmm
 import Bag
 import Digraph
 import UniqFM
@@ -67,11 +67,11 @@ slurpJoinMovs
 slurpJoinMovs live
 	= slurpCmm emptyBag live
  where	
-  	slurpCmm   rs  CmmData{}		= rs
-	slurpCmm   rs (CmmProc _ _ _ sccs) 	= foldl' slurpBlock rs (flattenSCCs sccs)
-        slurpBlock rs (BasicBlock _ instrs)	= foldl' slurpLI    rs instrs
+  	slurpCmm   rs  CmmData{}		    = rs
+	slurpCmm   rs (CmmProc _ _ sccs) 	= foldl' slurpBlock rs (flattenSCCs sccs)
+	slurpBlock rs (BasicBlock _ instrs)	= foldl' slurpLI    rs instrs
                 
-        slurpLI    rs (LiveInstr _	Nothing) = rs
+	slurpLI    rs (LiveInstr _	Nothing)    = rs
 	slurpLI    rs (LiveInstr instr (Just live))
 	 	| Just (r1, r2)	<- takeRegRegMoveInstr instr
 		, elementOfUniqSet r1 $ liveDieRead live
diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
index 7e744e6337..4eabb3b0b4 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
@@ -12,7 +12,7 @@ where
 import RegAlloc.Liveness
 import Instruction
 import Reg
-import Cmm	hiding (RegSet)
+import OldCmm hiding (RegSet)
 import BlockId
 
 import State
@@ -89,12 +89,12 @@ regSpill_top regSlotMap cmm
 	CmmData{}				
 	 -> return cmm
 
-	CmmProc info label params sccs
+	CmmProc info label sccs
 	 |  LiveInfo static firstId mLiveVRegsOnEntry liveSlotsOnEntry <- info
 	 -> do	
 		-- We should only passed Cmms with the liveness maps filled in,  but we'll
 		-- create empty ones if they're not there just in case.
-		let liveVRegsOnEntry	= fromMaybe emptyBlockEnv mLiveVRegsOnEntry
+		let liveVRegsOnEntry	= fromMaybe mapEmpty mLiveVRegsOnEntry
 		
 		-- The liveVRegsOnEntry contains the set of vregs that are live on entry to
 		-- each basic block. If we spill one of those vregs we remove it from that
@@ -103,7 +103,7 @@ regSpill_top regSlotMap cmm
 		-- reload instructions after we've done a successful allocation.
 		let liveSlotsOnEntry' :: Map BlockId (Set Int)
 		    liveSlotsOnEntry'
-			= foldBlockEnv patchLiveSlot liveSlotsOnEntry liveVRegsOnEntry
+			= mapFoldWithKey patchLiveSlot liveSlotsOnEntry liveVRegsOnEntry
 
 		let info'
 			= LiveInfo static firstId
@@ -113,7 +113,7 @@ regSpill_top regSlotMap cmm
 		-- Apply the spiller to all the basic blocks in the CmmProc.
 		sccs'		<- mapM (mapSCCM (regSpill_block regSlotMap)) sccs
 
-		return	$ CmmProc info' label params sccs'
+		return	$ CmmProc info' label sccs'
 
  where	-- | Given a BlockId and the set of registers live in it, 
 	--   if registers in this block are being spilled to stack slots, 
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
index ef4f0887d9..38c33b708a 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
@@ -33,7 +33,7 @@ import Instruction
 import Reg
 
 import BlockId
-import Cmm
+import OldCmm
 import UniqSet
 import UniqFM
 import Unique
@@ -47,7 +47,6 @@ import Data.Set			(Set)
 import qualified Data.Map	as Map
 import qualified Data.Set	as Set
 
-
 --
 type Slot = Int
 
@@ -291,10 +290,10 @@ cleanTopBackward cmm
 	CmmData{}
 	 -> return cmm
 	
-	CmmProc info label params sccs
+	CmmProc info label sccs
 	 | LiveInfo _ _ _ liveSlotsOnEntry <- info
 	 -> do	sccs'	<- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs
-		return	$ CmmProc info label params sccs' 
+		return	$ CmmProc info label sccs' 
 
 
 cleanBlockBackward 
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
index 0dc25f58d2..330a410312 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
@@ -24,7 +24,7 @@ import Reg
 import GraphBase
 
 import BlockId
-import Cmm
+import OldCmm
 import UniqFM
 import UniqSet
 import Digraph		(flattenSCCs)
@@ -71,7 +71,7 @@ slurpSpillCostInfo cmm
 	= execState (countCmm cmm) zeroSpillCostInfo
  where
 	countCmm CmmData{}		= return ()
-	countCmm (CmmProc info _ _ sccs)
+	countCmm (CmmProc info _ sccs)
 		= mapM_ (countBlock info)
 		$ flattenSCCs sccs
 
@@ -79,7 +79,7 @@ slurpSpillCostInfo cmm
 	--	the info table from the CmmProc
  	countBlock info (BasicBlock blockId instrs)
 		| LiveInfo _ _ (Just blockLive) _ <- info
-		, Just rsLiveEntry  <- lookupBlockEnv blockLive blockId
+		, Just rsLiveEntry  <- mapLookup blockId blockLive
 		, rsLiveEntry_virt  <- takeVirtuals rsLiveEntry
 		= countLIs rsLiveEntry_virt instrs
 
diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
index 51554d6953..5ff7bff91a 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
@@ -27,7 +27,8 @@ import RegClass
 import Reg
 import TargetReg
 
-import Cmm
+import OldCmm
+import OldPprCmm()
 import Outputable
 import UniqFM
 import UniqSet
diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
index a9367f9f01..903082fc26 100644
--- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
@@ -23,7 +23,7 @@ import Instruction
 import Reg
 
 import BlockId
-import Cmm	hiding (RegSet)
+import OldCmm  hiding (RegSet)
 import Digraph
 import Outputable
 import Unique
@@ -86,7 +86,7 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests)
 
 	-- adjust the current assignment to remove any vregs that are not live
 	-- on entry to the destination block.
-	let Just live_set 	= lookupBlockEnv block_live dest
+	let Just live_set 	= mapLookup dest block_live
 	let still_live uniq _ 	= uniq `elemUniqSet_Directly` live_set
 	let adjusted_assig	= filterUFM_Directly still_live assig
 
@@ -96,7 +96,7 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests)
 			, not (elemUniqSet_Directly reg live_set)
 			, r 	     <- regsOfLoc loc ]
 
-	case lookupBlockEnv block_assig dest of
+	case mapLookup dest block_assig of
 	 Nothing 
 	  -> joinToTargets_first 
 	  		block_live new_blocks block_id instr dest dests
@@ -118,8 +118,7 @@ joinToTargets_first block_live new_blocks block_id instr dest dests
 	let freeregs' 	= foldr releaseReg freeregs to_free 
 	
 	-- remember the current assignment on entry to this block.
-	setBlockAssigR (extendBlockEnv block_assig dest 
-				(freeregs', src_assig))
+	setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig)
 
 	joinToTargets' block_live new_blocks block_id instr dests
 
@@ -173,7 +172,7 @@ joinToTargets_again
 		--	A the end of the current block we will jump to the fixup one, 
 		--	then that will jump to our original destination.
 		fixup_block_id <- getUniqueR
-		let block = BasicBlock (BlockId fixup_block_id) 
+		let block = BasicBlock (mkBlockId fixup_block_id) 
 				$ fixUpInstrs ++ mkJumpInstr dest
 		
 {-		pprTrace
@@ -190,7 +189,7 @@ joinToTargets_again
 		 --	fixup block instead.
 		 _	-> let	instr'	=  patchJumpInstr instr 
 		 				(\bid -> if bid == dest 
-								then BlockId fixup_block_id 
+								then mkBlockId fixup_block_id 
 								else dest)
 						
 		 	   in	joinToTargets' block_live (block : new_blocks) block_id instr' dests
diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
index de771523b9..5fab944e09 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -102,7 +102,7 @@ import Instruction
 import Reg
 
 import BlockId
-import Cmm hiding (RegSet)
+import OldCmm hiding (RegSet)
 
 import Digraph
 import Unique
@@ -132,11 +132,11 @@ regAlloc (CmmData sec d)
 		( CmmData sec d
 		, Nothing )
 	
-regAlloc (CmmProc (LiveInfo info _ _ _) lbl params [])
-	= return ( CmmProc info lbl params (ListGraph [])
+regAlloc (CmmProc (LiveInfo info _ _ _) lbl [])
+	= return ( CmmProc info lbl (ListGraph [])
 		 , Nothing )
 	
-regAlloc (CmmProc static lbl params sccs)
+regAlloc (CmmProc static lbl sccs)
 	| LiveInfo info (Just first_id) (Just block_live) _	<- static
 	= do	
  		-- do register allocation on each component.
@@ -148,11 +148,11 @@ regAlloc (CmmProc static lbl params sccs)
 		let ((first':_), rest')
 				= partition ((== first_id) . blockId) final_blocks
 
-		return	( CmmProc info lbl params (ListGraph (first' : rest'))
+		return	( CmmProc info lbl (ListGraph (first' : rest'))
 			, Just stats)
 	
 -- bogus. to make non-exhaustive match warning go away.
-regAlloc (CmmProc _ _ _ _)
+regAlloc (CmmProc _ _ _)
 	= panic "RegAllocLinear.regAlloc: no match"
 
 
@@ -228,7 +228,7 @@ process first_id block_live (b@(BasicBlock id _) : blocks)
  = do 	
 	block_assig <- getBlockAssigR
 
-    	if isJust (lookupBlockEnv block_assig id) 
+    	if isJust (mapLookup id block_assig) 
              || id == first_id
          then do 
 		b'  <- processBlock block_live b
@@ -259,7 +259,7 @@ processBlock block_live (BasicBlock id instrs)
 initBlock :: BlockId -> RegM ()
 initBlock id
  = do	block_assig	<- getBlockAssigR
-  	case lookupBlockEnv block_assig id of
+  	case mapLookup id block_assig of
 	        -- no prior info about this block: assume everything is
 	        -- free and the assignment is empty.
 	 	Nothing
diff --git a/compiler/nativeGen/RegAlloc/Linear/Stats.hs b/compiler/nativeGen/RegAlloc/Linear/Stats.hs
index 137168e942..c80f77f893 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Stats.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Stats.hs
@@ -10,7 +10,7 @@ import RegAlloc.Linear.Base
 import RegAlloc.Liveness
 import Instruction
 
-import Cmm		(GenBasicBlock(..))
+import OldCmm  (GenBasicBlock(..))
 
 import UniqFM
 import Outputable
diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index 903fa4c577..a2030fafa9 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -35,8 +35,8 @@ import Reg
 import Instruction
 
 import BlockId
-import Cmm hiding (RegSet)
-import PprCmm()
+import OldCmm hiding (RegSet)
+import OldPprCmm()
 
 import Digraph
 import Outputable
@@ -64,9 +64,6 @@ emptyRegMap = emptyUFM
 
 type BlockMap a = BlockEnv a
 
-emptyBlockMap :: BlockEnv a
-emptyBlockMap = emptyBlockEnv
-
 
 -- | A top level thing which carries liveness information.
 type LiveCmmTop instr
@@ -243,9 +240,9 @@ mapBlockTopM
 mapBlockTopM _ cmm@(CmmData{})
 	= return cmm
 
-mapBlockTopM f (CmmProc header label params sccs)
+mapBlockTopM f (CmmProc header label sccs)
  = do	sccs'	<- mapM (mapSCCM f) sccs
- 	return	$ CmmProc header label params sccs'
+ 	return	$ CmmProc header label sccs'
 
 mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b)
 mapSCCM	f (AcyclicSCC x)	
@@ -275,9 +272,9 @@ mapGenBlockTopM
 mapGenBlockTopM _ cmm@(CmmData{})
 	= return cmm
 
-mapGenBlockTopM f (CmmProc header label params (ListGraph blocks))
+mapGenBlockTopM f (CmmProc header label (ListGraph blocks))
  = do	blocks'	<- mapM f blocks
- 	return	$ CmmProc header label params (ListGraph blocks')
+ 	return	$ CmmProc header label (ListGraph blocks')
 
 
 -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.
@@ -293,7 +290,7 @@ slurpConflicts live
 	= slurpCmm (emptyBag, emptyBag) live
 
  where	slurpCmm   rs  CmmData{}		= rs
- 	slurpCmm   rs (CmmProc info _ _ sccs)
+ 	slurpCmm   rs (CmmProc info _ sccs)
 		= foldl' (slurpSCC info) rs sccs
 
 	slurpSCC  info rs (AcyclicSCC b)	
@@ -304,7 +301,7 @@ slurpConflicts live
 
 	slurpBlock info rs (BasicBlock blockId instrs)	
 		| LiveInfo _ _ (Just blockLive)	_ <- info
-		, Just rsLiveEntry		  <- lookupBlockEnv blockLive blockId
+		, Just rsLiveEntry		  <- mapLookup blockId blockLive
 		, (conflicts, moves)		  <- slurpLIs rsLiveEntry rs instrs
 		= (consBag rsLiveEntry conflicts, moves)
 
@@ -372,7 +369,7 @@ slurpReloadCoalesce live
                  -> GenCmmTop t t1 [SCC (LiveBasicBlock instr)]
                  -> Bag (Reg, Reg)
         slurpCmm cs CmmData{}	= cs
- 	slurpCmm cs (CmmProc _ _ _ sccs)
+ 	slurpCmm cs (CmmProc _ _ sccs)
 		= slurpComp cs (flattenSCCs sccs)
 
         slurpComp :: Bag (Reg, Reg)
@@ -469,8 +466,7 @@ stripLive live
 	= stripCmm live
 
  where	stripCmm (CmmData sec ds)	= CmmData sec ds
-
- 	stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label params sccs)
+ 	stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs)
 	 = let	final_blocks	= flattenSCCs sccs
 		
 		-- make sure the block that was first in the input list
@@ -479,17 +475,17 @@ stripLive live
 		((first':_), rest')
 				= partition ((== first_id) . blockId) final_blocks
 
-	   in	CmmProc info label params
+	   in	CmmProc info label 
                           (ListGraph $ map stripLiveBlock $ first' : rest')
 
 	-- procs used for stg_split_markers don't contain any blocks, and have no first_id.
-	stripCmm (CmmProc (LiveInfo info Nothing _ _) label params [])
-	 =	CmmProc info label params (ListGraph [])
+	stripCmm (CmmProc (LiveInfo info Nothing _ _) label [])
+	 =	CmmProc info label (ListGraph [])
 
 	-- If the proc has blocks but we don't know what the first one was, then we're dead.
 	stripCmm proc
 		 = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc)
-			
+
 
 -- | Strip away liveness information from a basic block,
 --	and make real spill instructions out of SPILL, RELOAD pseudos along the way.
@@ -554,14 +550,14 @@ patchEraseLive patchF cmm
  where
 	patchCmm cmm@CmmData{}	= cmm
 
-	patchCmm (CmmProc info label params sccs)
+	patchCmm (CmmProc info label sccs)
 	 | LiveInfo static id (Just blockMap) mLiveSlots <- info
 	 = let 	
 	 	patchRegSet set	= mkUniqSet $ map patchF $ uniqSetToList set
-		blockMap'	= mapBlockEnv patchRegSet blockMap
+		blockMap'	= mapMap patchRegSet blockMap
 
 		info'		= LiveInfo static id (Just blockMap') mLiveSlots
-	   in	CmmProc info' label params $ map patchSCC sccs
+	   in	CmmProc info' label $ map patchSCC sccs
 
 	 | otherwise
 	 = panic "RegAlloc.Liveness.patchEraseLive: no blockMap"
@@ -630,19 +626,17 @@ natCmmTopToLive
 natCmmTopToLive (CmmData i d)
 	= CmmData i d
 
-natCmmTopToLive (CmmProc info lbl params (ListGraph []))
-	= CmmProc (LiveInfo info Nothing Nothing Map.empty)
-		  lbl params []
+natCmmTopToLive (CmmProc info lbl (ListGraph []))
+	= CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl []
 
-natCmmTopToLive (CmmProc info lbl params (ListGraph blocks@(first : _)))
+natCmmTopToLive (CmmProc info lbl (ListGraph blocks@(first : _)))
  = let	first_id	= blockId first
 	sccs		= sccBlocks blocks
 	sccsLive	= map (fmap (\(BasicBlock l instrs) -> 
 					BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs)))
 			$ sccs
 				
-   in	CmmProc (LiveInfo info (Just first_id) Nothing Map.empty)
-		lbl params sccsLive
+   in	CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl sccsLive
 
 
 sccBlocks 
@@ -670,18 +664,18 @@ regLiveness
 regLiveness (CmmData i d)
 	= returnUs $ CmmData i d
 
-regLiveness (CmmProc info lbl params [])
+regLiveness (CmmProc info lbl [])
 	| LiveInfo static mFirst _ _	<- info
 	= returnUs $ CmmProc
-			(LiveInfo static mFirst (Just emptyBlockEnv) Map.empty)
-			lbl params []
+			(LiveInfo static mFirst (Just mapEmpty) Map.empty)
+			lbl []
 
-regLiveness (CmmProc info lbl params sccs)
+regLiveness (CmmProc info lbl sccs)
 	| LiveInfo static mFirst _ liveSlotsOnEntry	<- info
 	= let	(ann_sccs, block_live)	= computeLiveness sccs
 
    	  in	returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry)
-			   lbl params ann_sccs
+			   lbl ann_sccs
 
 
 -- -----------------------------------------------------------------------------
@@ -730,7 +724,7 @@ reverseBlocksInTops :: LiveCmmTop instr -> LiveCmmTop instr
 reverseBlocksInTops top
  = case top of
 	CmmData{}			-> top
-	CmmProc info lbl params sccs	-> CmmProc info lbl params (reverse sccs)
+	CmmProc info lbl sccs	-> CmmProc info lbl (reverse sccs)
 
 	
 -- | Computing liveness
@@ -803,8 +797,8 @@ livenessSCCs blockmap done
                 -- BlockMaps for equality.
 	    equalBlockMaps a b
 	        = a' == b'
-	      where a' = map f $ blockEnvToList a
-	            b' = map f $ blockEnvToList b
+	      where a' = map f $ mapToList a
+	            b' = map f $ mapToList b
 	            f (key,elt) = (key, uniqSetToList elt)
 
 
@@ -821,7 +815,7 @@ livenessBlock blockmap (BasicBlock block_id instrs)
  = let
  	(regsLiveOnEntry, instrs1)
  		= livenessBack emptyUniqSet blockmap [] (reverse instrs)
- 	blockmap'	= extendBlockEnv blockmap block_id regsLiveOnEntry
+ 	blockmap'	= mapInsert block_id regsLiveOnEntry blockmap
 
 	instrs2		= livenessForward regsLiveOnEntry instrs1
 
@@ -928,7 +922,7 @@ liveness1 liveregs blockmap (LiveInstr instr _)
 	    not_a_branch = null targets
 
 	    targetLiveRegs target
-                  = case lookupBlockEnv blockmap target of
+                  = case mapLookup target blockmap of
                                 Just ra -> ra
                                 Nothing -> emptyRegMap