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.

1 files changed, 0 insertions, 248 deletions

diff --git a/compiler/cmm/StackPlacements.hs b/compiler/cmm/StackPlacements.hs
deleted file mode 100644
index 5cac288573..0000000000
--- a/compiler/cmm/StackPlacements.hs
+++ /dev/null
@@ -1,248 +0,0 @@
-
-module StackPlacements
-  ( SlotSet, allStackSlots  -- the infinite set of stack slots
-  , SlotClass(..), slotClassBits, stackSlot32, stackSlot64, stackSlot128
-  , allSlotClasses
-  , getStackSlot, extendSlotSet, deleteFromSlotSet, elemSlotSet, chooseSlot
-  , StackPlacement(..)
-  )
-where
-
-import Maybes
-import Outputable
-import Unique
-
-import Prelude hiding (pi)
-import Data.List
-
-{- 
-
-The goal here is to provide placements on the stack that will allow,
-for example, two 32-bit words to spill to a slot previously used by a
-64-bit floating-point value.  I use a simple buddy-system allocator
-that splits large slots in half as needed; this will work fine until
-the day when somebody wants to spill an 80-bit Intel floating-point
-register into the Intel standard 96-bit stack slot.
-
--}
-
-data SlotClass = SlotClass32 | SlotClass64 | SlotClass128
-  deriving (Eq)
-
-instance Uniquable SlotClass where
-    getUnique = getUnique . slotClassBits
-
-instance Outputable SlotClass where
-    ppr cls = text "class of" <+> int (slotClassBits cls) <> text "-bit stack slots"
-
-slotClassBits :: SlotClass -> Int
-slotClassBits SlotClass32 = 32
-slotClassBits SlotClass64 = 64
-slotClassBits SlotClass128 = 128
-
-data StackPlacement = FullSlot SlotClass Int
-               | YoungHalf StackPlacement
-               | OldHalf StackPlacement
-  deriving (Eq)
-
-data OneSize = OneSize { full_slots :: [StackPlacement], fragments :: [StackPlacement] }
-  -- ^ Always used for slots that have been previously used
-
-data SlotSet = SlotSet { s32, s64, s128 :: OneSize, next_unused :: Int }
-
-allStackSlots :: SlotSet
-allStackSlots = SlotSet empty empty empty 0
-    where empty = OneSize [] []
-
-
-psize :: StackPlacement -> Int
-psize (FullSlot cls _) = slotClassBits cls
-psize (YoungHalf p) = psize p `div` 2
-psize (OldHalf   p) = psize p `div` 2
-
-
-
-
--- | Get a slot no matter what
-get32, get64, get128 :: SlotSet -> (StackPlacement, SlotSet)
-
--- | Get a previously used slot if one exists
-getu32, getu64, getu128 :: SlotSet -> Maybe (StackPlacement, SlotSet)
-
--- | Only supported slot classes
-
-stackSlot32, stackSlot64, stackSlot128 :: SlotClass
-stackSlot32  = SlotClass32
-stackSlot64  = SlotClass64
-stackSlot128 = SlotClass128
-
-allSlotClasses :: [SlotClass]
-allSlotClasses = [stackSlot32, stackSlot64, stackSlot128]
-
--- | Get a fresh slot, never before used
-getFull :: SlotClass -> SlotSet -> (StackPlacement, SlotSet)
-
-infixr 4 |||
-
-(|||) :: (SlotSet -> Maybe (StackPlacement, SlotSet)) ->
-         (SlotSet ->       (StackPlacement, SlotSet)) ->
-         (SlotSet ->       (StackPlacement, SlotSet))
-      
-f1 ||| f2 = \slots -> f1 slots `orElse`   f2 slots
-
-getFull cls slots = (FullSlot cls n, slots { next_unused = n + 1 })
-    where n = next_unused slots
-
-get32  = getu32  ||| (fmap split64  . getu64)  ||| getFull stackSlot32
-get64  = getu64  ||| (fmap split128 . getu128) ||| getFull stackSlot64
-get128 = getu128 ||| getFull stackSlot128
-
-type SizeGetter = SlotSet -> OneSize
-type SizeSetter = OneSize -> SlotSet -> SlotSet
-
-upd32, upd64, upd128 :: SizeSetter
-upd32  this_size slots = slots { s32  = this_size }
-upd64  this_size slots = slots { s64  = this_size }
-upd128 this_size slots = slots { s128 = this_size }
-
-with_size :: Int -> (SizeGetter -> SizeSetter -> a) -> a
-with_size  32 = with_32
-with_size  64 = with_64
-with_size 128 = with_128
-with_size _   = panic "non-standard slot size -- error in size computation?"
-
-with_32, with_64, with_128 :: (SizeGetter -> SizeSetter -> a) -> a
-with_32  f = f s32  upd32
-with_64  f = f s64  upd64
-with_128 f = f s128 upd128
-
-getu32  = with_32  getUsed
-getu64  = with_64  getUsed
-getu128 = with_128 getUsed
-
-getUsed :: SizeGetter -> SizeSetter -> SlotSet -> Maybe (StackPlacement, SlotSet)
-getUsed get set slots = 
-    let this_size = get slots in
-    case full_slots this_size of
-      p : ps -> Just (p, set (this_size { full_slots = ps }) slots)
-      [] -> case fragments this_size of
-              p : ps -> Just (p, set (this_size { fragments = ps }) slots)
-              [] -> Nothing
-
--- | When splitting, allocate the old half first in case it makes the
--- stack smaller at a call site.
-split64, split128 :: (StackPlacement, SlotSet) -> (StackPlacement, SlotSet)
-split64  (p, slots) = (OldHalf p, slots { s32 = cons_frag (YoungHalf p) (s32 slots) })
-split128 (p, slots) = (OldHalf p, slots { s64 = cons_frag (YoungHalf p) (s64 slots) })
-
-cons_frag :: StackPlacement -> OneSize -> OneSize
-cons_frag p this_size = this_size { fragments = p : fragments this_size }
-
-
-----------------------------
-instance Outputable StackPlacement where
-  ppr (FullSlot cls n) = int (slotClassBits cls) <> text "-bit slot " <> int n
-  ppr (YoungHalf p) = text "young half of" <+> ppr p
-  ppr (OldHalf   p) = text "old half of"   <+> ppr p
-
-instance Outputable SlotSet where
-  ppr slots = fsep $ punctuate comma
-              (pprSlots (s32 slots) ++ pprSlots (s64 slots) ++ pprSlots (s128 slots) ++
-               [text "and slots numbered" <+> int (next_unused slots)
-                         <+> text "and up"])
-   where pprSlots (OneSize w fs) = map ppr w ++ map ppr fs
-
-{-
-instance ColorSet SlotSet SlotClass StackPlacement where
-  emptyColorSet = panic "The set of stack slots is never empty"
-  deleteFromColorSet = deleteFromSlotSet
-  extendColorSet slots (cls, p@(FullSlot {})) =
-      with_size (slotClassBits cls) add_full p (pi slots)
-  extendColorSet slots (cls, p) = with_size (slotClassBits cls) add_frag p (pi slots)
-  chooseColor        = chooseSlot
--}
-
-deleteFromSlotSet :: StackPlacement -> SlotSet -> SlotSet
-deleteFromSlotSet p@(FullSlot {}) slots = with_size (psize p) remove_full p (pi slots)
-deleteFromSlotSet p               slots = with_size (psize p) remove_frag p (pi slots)
-
-extendSlotSet :: SlotSet -> StackPlacement -> SlotSet
-extendSlotSet slots p@(FullSlot {}) = with_size (psize p) add_full p (pi slots)
-extendSlotSet slots p               = with_size (psize p) add_frag p (pi slots)
-
-elemSlotSet :: StackPlacement -> SlotSet -> Bool
-elemSlotSet p@(FullSlot {}) slots = with_size (psize p) elem_full p slots
-elemSlotSet p               slots = with_size (psize p) elem_frag p slots
-
-remove_full, remove_frag, add_full, add_frag
-    :: SizeGetter -> SizeSetter -> StackPlacement -> SlotSet -> SlotSet
-
-remove_full get set p slots = set p' slots
-    where this_size = get slots
-          p' = this_size { full_slots = delete p $ full_slots this_size }
-
-remove_frag get set p slots = set p' slots
-    where this_size = get slots
-          p' = this_size { full_slots = delete p $ full_slots this_size }
-
-add_full get set p slots = set p' slots
-    where this_size = get slots
-          p' = this_size { full_slots = add p $ full_slots this_size }
-
-add_frag get set p slots = set p' slots
-    where this_size = get slots
-          p' = this_size { full_slots = add p $ full_slots this_size }
-
-add :: Eq a => a -> [a] -> [a]
-add x xs = if notElem x xs then x : xs else xs
-
-elem_full, elem_frag :: SizeGetter -> SizeSetter -> StackPlacement -> SlotSet -> Bool
-elem_full get _set p slots = elem p (full_slots $ get slots)
-elem_frag get _set p slots = elem p (fragments  $ get slots)
-
-
-
-
-getStackSlot :: SlotClass -> SlotSet -> (StackPlacement, SlotSet)
-getStackSlot cls slots =
-  case cls of
-    SlotClass32  -> get32  (pi slots)
-    SlotClass64  -> get64  (pi slots)
-    SlotClass128 -> get128 (pi slots)
- 
-
-chooseSlot :: SlotClass -> [StackPlacement] -> SlotSet -> Maybe (StackPlacement, SlotSet)
-chooseSlot cls prefs slots =
-  case filter (flip elemSlotSet slots) prefs of
-    placement : _ -> Just (placement, deleteFromSlotSet placement (pi slots))
-    [] -> Just (getStackSlot cls slots)
-
-check_invariant :: Bool
-check_invariant = True
-
-pi :: SlotSet -> SlotSet
-pi = if check_invariant then panic_on_invariant_violation else id
-
-panic_on_invariant_violation :: SlotSet -> SlotSet
-panic_on_invariant_violation slots =
-    check 32 (s32 slots) $ check 64 (s64 slots) $ check 128 (s128 slots) $ slots
-  where n = next_unused slots
-        check bits this_size = (check_full bits $ full_slots this_size) .
-                               (check_frag bits $ fragments  this_size)
-        check_full _ [] = id
-        check_full bits (FullSlot cls k : ps) =
-            if slotClassBits cls /= bits then panic "slot in bin of wrong size"
-            else if k >= n then panic "slot number is unreasonably fresh"
-                 else check_full bits ps
-        check_full _ _ = panic "a fragment is in a bin reserved for full slots"
-        check_frag _ [] = id
-        check_frag _ (FullSlot {} : _) =
-            panic "a full slot is in a bin reserved for fragments"
-        check_frag bits (p : ps) =
-            if bits /= psize p then panic "slot in bin of wrong size"
-            else if pnumber p >= n then panic "slot number is unreasonably fresh"
-                 else check_frag bits ps
-        pnumber (FullSlot _ k) = k
-        pnumber (YoungHalf p) = pnumber p
-        pnumber (OldHalf p)   = pnumber p
-