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, 273 insertions, 0 deletions

diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs
new file mode 100644
index 0000000000..4b0db35bd8
--- /dev/null
+++ b/compiler/cmm/OldPprCmm.hs
@@ -0,0 +1,273 @@
+----------------------------------------------------------------------------
+--
+-- Pretty-printing of old-style Cmm as (a superset of) C--
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+--
+-- This is where we walk over Cmm emitting an external representation,
+-- suitable for parsing, in a syntax strongly reminiscent of C--. This
+-- is the "External Core" for the Cmm layer.
+--
+-- As such, this should be a well-defined syntax: we want it to look nice.
+-- Thus, we try wherever possible to use syntax defined in [1],
+-- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
+-- slightly, in some cases. For one, we use I8 .. I64 for types, rather
+-- than C--'s bits8 .. bits64.
+--
+-- We try to ensure that all information available in the abstract
+-- syntax is reproduced, or reproducible, in the concrete syntax.
+-- Data that is not in printed out can be reconstructed according to
+-- conventions used in the pretty printer. There are at least two such
+-- cases:
+--      1) if a value has wordRep type, the type is not appended in the
+--      output.
+--      2) MachOps that operate over wordRep type are printed in a
+--      C-style, rather than as their internal MachRep name.
+--
+-- These conventions produce much more readable Cmm output.
+--
+-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
+--
+
+module OldPprCmm
+    ( pprStmt
+    , module PprCmmDecl
+    , module PprCmmExpr
+    )
+where
+
+import BlockId
+import CLabel
+import CmmUtils
+import OldCmm
+import PprCmmDecl
+import PprCmmExpr
+
+
+import BasicTypes
+import ForeignCall
+import Outputable
+import FastString
+
+import Data.List
+
+-----------------------------------------------------------------------------
+
+instance (Outputable instr) => Outputable (ListGraph instr) where
+    ppr (ListGraph blocks) = vcat (map ppr blocks)
+
+instance (Outputable instr) => Outputable (GenBasicBlock instr) where
+    ppr b = pprBBlock b
+
+instance Outputable CmmStmt where
+    ppr s = pprStmt s
+
+instance Outputable CmmInfo where
+    ppr e = pprInfo e
+
+
+-- --------------------------------------------------------------------------
+instance Outputable CmmSafety where
+  ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
+  ppr CmmInterruptible = ptext (sLit "_interruptible_call_")
+  ppr (CmmSafe srt) = ppr srt
+
+-- --------------------------------------------------------------------------
+-- Info tables. The current pretty printer needs refinement
+-- but will work for now.
+--
+-- For ideas on how to refine it, they used to be printed in the
+-- style of C--'s 'stackdata' declaration, just inside the proc body,
+-- and were labelled with the procedure name ++ "_info".
+pprInfo :: CmmInfo -> SDoc
+pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) =
+    vcat [{-ptext (sLit "gc_target: ") <>
+                maybe (ptext (sLit "<none>")) ppr gc_target,-}
+          ptext (sLit "update_frame: ") <>
+                maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame]
+pprInfo (CmmInfo _gc_target update_frame info_table@(CmmInfoTable _ _ _ _)) =
+    vcat [{-ptext (sLit "gc_target: ") <>
+                maybe (ptext (sLit "<none>")) ppr gc_target,-}
+          ptext (sLit "update_frame: ") <>
+                maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame,
+          ppr info_table]
+
+
+-- --------------------------------------------------------------------------
+-- Basic blocks look like assembly blocks.
+--      lbl: stmt ; stmt ; ..
+pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
+pprBBlock (BasicBlock ident stmts) =
+    hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
+
+-- --------------------------------------------------------------------------
+-- Statements. C-- usually, exceptions to this should be obvious.
+--
+pprStmt :: CmmStmt -> SDoc
+pprStmt stmt = case stmt of
+
+    -- ;
+    CmmNop -> semi
+
+    --  // text
+    CmmComment s -> text "//" <+> ftext s
+
+    -- reg = expr;
+    CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
+
+    -- rep[lv] = expr;
+    CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
+        where
+          rep = ppr ( cmmExprType expr )
+
+    -- call "ccall" foo(x, y)[r1, r2];
+    -- ToDo ppr volatile
+    CmmCall (CmmCallee fn cconv) results args safety ret ->
+        sep  [ pp_lhs <+> pp_conv
+             , nest 2 (pprExpr9 fn <>
+                       parens (commafy (map ppr_ar args)))
+               <> brackets (ppr safety)
+             , case ret of CmmMayReturn -> empty
+                           CmmNeverReturns -> ptext $ sLit (" never returns")
+             ] <> semi
+        where
+          pp_lhs | null results = empty
+                 | otherwise    = commafy (map ppr_ar results) <+> equals
+                -- Don't print the hints on a native C-- call
+          ppr_ar (CmmHinted ar k) = case cconv of
+                            CmmCallConv -> ppr ar
+                            _           -> ppr (ar,k)
+          pp_conv = case cconv of
+                      CmmCallConv -> empty
+                      _           -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv)
+
+    -- Call a CallishMachOp, like sin or cos that might be implemented as a library call.
+    CmmCall (CmmPrim op) results args safety ret ->
+        pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
+                        results args safety ret)
+        where
+          -- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we
+          --       use one to get the label printed.
+          lbl = CmmLabel (mkForeignLabel
+                                (mkFastString (show op))
+                                Nothing ForeignLabelInThisPackage IsFunction)
+
+    CmmBranch ident          -> genBranch ident
+    CmmCondBranch expr ident -> genCondBranch expr ident
+    CmmJump expr params      -> genJump expr params
+    CmmReturn params         -> genReturn params
+    CmmSwitch arg ids        -> genSwitch arg ids
+
+-- Just look like a tuple, since it was a tuple before
+-- ... is that a good idea? --Isaac Dupree
+instance (Outputable a) => Outputable (CmmHinted a) where
+  ppr (CmmHinted a k) = ppr (a, k)
+
+pprUpdateFrame :: UpdateFrame -> SDoc
+pprUpdateFrame (UpdateFrame expr args) =
+    hcat [ ptext (sLit "jump")
+         , space
+         , if isTrivialCmmExpr expr
+                then pprExpr expr
+                else case expr of
+                    CmmLoad (CmmReg _) _ -> pprExpr expr
+                    _ -> parens (pprExpr expr)
+         , space
+         , parens  ( commafy $ map ppr args ) ]
+
+
+-- --------------------------------------------------------------------------
+-- goto local label. [1], section 6.6
+--
+--     goto lbl;
+--
+genBranch :: BlockId -> SDoc
+genBranch ident =
+    ptext (sLit "goto") <+> ppr ident <> semi
+
+-- --------------------------------------------------------------------------
+-- Conditional. [1], section 6.4
+--
+--     if (expr) { goto lbl; }
+--
+genCondBranch :: CmmExpr -> BlockId -> SDoc
+genCondBranch expr ident =
+    hsep [ ptext (sLit "if")
+         , parens(ppr expr)
+         , ptext (sLit "goto")
+         , ppr ident <> semi ]
+
+-- --------------------------------------------------------------------------
+-- A tail call. [1], Section 6.9
+--
+--     jump foo(a, b, c);
+--
+genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc
+genJump expr args =
+    hcat [ ptext (sLit "jump")
+         , space
+         , if isTrivialCmmExpr expr
+                then pprExpr expr
+                else case expr of
+                    CmmLoad (CmmReg _) _ -> pprExpr expr
+                    _ -> parens (pprExpr expr)
+         , space
+         , parens  ( commafy $ map ppr args )
+         , semi ]
+
+
+-- --------------------------------------------------------------------------
+-- Return from a function. [1], Section 6.8.2 of version 1.128
+--
+--     return (a, b, c);
+--
+genReturn :: [CmmHinted CmmExpr] -> SDoc
+genReturn args =
+    hcat [ ptext (sLit "return")
+         , space
+         , parens  ( commafy $ map ppr args )
+         , semi ]
+
+-- --------------------------------------------------------------------------
+-- Tabled jump to local label
+--
+-- The syntax is from [1], section 6.5
+--
+--      switch [0 .. n] (expr) { case ... ; }
+--
+genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
+genSwitch expr maybe_ids
+
+    = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
+
+      in hang (hcat [ ptext (sLit "switch [0 .. ")
+                    , int (length maybe_ids - 1)
+                    , ptext (sLit "] ")
+                    , if isTrivialCmmExpr expr
+                        then pprExpr expr
+                        else parens (pprExpr expr)
+                    , ptext (sLit " {")
+                    ])
+            4 (vcat ( map caseify pairs )) $$ rbrace
+
+    where
+      snds a b = (snd a) == (snd b)
+
+      caseify :: [(Int,Maybe BlockId)] -> SDoc
+      caseify ixs@((_,Nothing):_)
+        = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
+                <> ptext (sLit " */")
+      caseify as
+        = let (is,ids) = unzip as
+          in hsep [ ptext (sLit "case")
+                  , hcat (punctuate comma (map int is))
+                  , ptext (sLit ": goto")
+                  , ppr (head [ id | Just id <- ids]) <> semi ]
+
+-----------------------------------------------------------------------------
+
+commafy :: [SDoc] -> SDoc
+commafy xs = fsep $ punctuate comma xs