Reorganisation of the source tree

Most of the other users of the fptools build system have migrated to
Cabal, and with the move to darcs we can now flatten the source tree
without losing history, so here goes.

The main change is that the ghc/ subdir is gone, and most of what it
contained is now at the top level.  The build system now makes no
pretense at being multi-project, it is just the GHC build system.

No doubt this will break many things, and there will be a period of
instability while we fix the dependencies.  A straightforward build
should work, but I haven't yet fixed binary/source distributions.
Changes to the Building Guide will follow, too.

1 files changed, 462 insertions, 0 deletions

diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
new file mode 100644
index 0000000000..6e8367d662
--- /dev/null
+++ b/compiler/cmm/PprCmm.hs
@@ -0,0 +1,462 @@
+----------------------------------------------------------------------------
+--
+-- Pretty-printing of Cmm as (a superset of) C--
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+--
+-- 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 PprCmm ( 	
+	writeCmms, pprCmms, pprCmm, pprStmt, pprExpr
+  ) where
+
+#include "HsVersions.h"
+
+import Cmm
+import CmmUtils     ( isTrivialCmmExpr )
+import MachOp       ( MachOp(..), pprMachOp, MachRep(..), wordRep )
+import CLabel       ( pprCLabel, mkForeignLabel, entryLblToInfoLbl )
+
+import ForeignCall  ( CCallConv(..) )
+import Unique       ( getUnique )
+import Outputable
+import FastString   ( mkFastString )
+
+import Data.List    ( intersperse, groupBy )
+import IO           ( Handle )
+import Maybe	    ( isJust )
+import Data.Char    ( chr )
+
+pprCmms :: [Cmm] -> SDoc
+pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
+        where
+          separator = space $$ ptext SLIT("-------------------") $$ space
+
+writeCmms :: Handle -> [Cmm] -> IO ()
+writeCmms handle cmms = printForC handle (pprCmms cmms)
+
+-----------------------------------------------------------------------------
+
+instance Outputable Cmm where
+    ppr c = pprCmm c
+
+instance Outputable CmmTop where
+    ppr t = pprTop t
+
+instance Outputable CmmBasicBlock where
+    ppr b = pprBBlock b
+
+instance Outputable CmmStmt where
+    ppr s = pprStmt s
+
+instance Outputable CmmExpr where
+    ppr e = pprExpr e
+
+instance Outputable CmmReg where
+    ppr e = pprReg e
+
+instance Outputable GlobalReg where
+    ppr e = pprGlobalReg e
+
+-----------------------------------------------------------------------------
+
+pprCmm :: Cmm -> SDoc
+pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
+
+-- --------------------------------------------------------------------------
+-- Top level `procedure' blocks. The info tables, if not null, are
+-- printed in the style of C--'s 'stackdata' declaration, just inside
+-- the proc body, and are labelled with the procedure name ++ "_info".
+--
+pprTop :: CmmTop -> SDoc
+pprTop (CmmProc info lbl params blocks )
+
+  = vcat [ pprCLabel lbl <> parens (commafy $ map pprLocalReg params) <+> lbrace
+         , nest 8 $ pprInfo info lbl
+         , nest 4 $ vcat (map ppr blocks)
+         , rbrace ]
+
+  where
+    pprInfo [] _  = empty
+    pprInfo i label = 
+        (hang (pprCLabel (entryLblToInfoLbl label) <+> lbrace )
+            4 $ vcat (map pprStatic i))
+        $$ rbrace
+
+-- --------------------------------------------------------------------------
+-- We follow [1], 4.5
+--
+--      section "data" { ... }
+--
+pprTop (CmmData section ds) = 
+    (hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic ds)))
+    $$ rbrace
+
+
+-- --------------------------------------------------------------------------
+-- Basic blocks look like assembly blocks.
+--      lbl: stmt ; stmt ; .. 
+pprBBlock :: CmmBasicBlock -> SDoc
+pprBBlock (BasicBlock ident stmts) =
+    hang (pprBlockId 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 ( cmmExprRep expr )
+
+    -- call "ccall" foo(x, y)[r1, r2];
+    -- ToDo ppr volatile
+    CmmCall (CmmForeignCall fn cconv) results args _volatile ->
+        hcat [ ptext SLIT("call"), space, 
+               doubleQuotes(ppr cconv), space,
+               target fn, parens  ( commafy $ map ppr args ),
+               (if null results
+                    then empty
+                    else brackets( commafy $ map ppr results)), semi ]
+        where
+            target (CmmLit lit) = pprLit lit
+            target fn'          = parens (ppr fn')
+
+    CmmCall (CmmPrim op) results args volatile ->
+        pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
+                        results args volatile)
+        where
+          lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
+
+    CmmBranch ident          -> genBranch ident
+    CmmCondBranch expr ident -> genCondBranch expr ident
+    CmmJump expr params      -> genJump expr params
+    CmmSwitch arg ids        -> genSwitch arg ids
+
+-- --------------------------------------------------------------------------
+-- goto local label. [1], section 6.6
+--
+--     goto lbl;
+--
+genBranch :: BlockId -> SDoc
+genBranch ident = 
+    ptext SLIT("goto") <+> pprBlockId 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")
+         , pprBlockId ident <> semi ]
+
+-- --------------------------------------------------------------------------
+-- A tail call. [1], Section 6.9
+--
+--     jump foo(a, b, c);
+--
+genJump :: CmmExpr -> [LocalReg] -> SDoc
+genJump expr actuals = 
+
+    hcat [ ptext SLIT("jump")
+         , space
+         , if isTrivialCmmExpr expr
+                then pprExpr expr
+                else case expr of
+                    CmmLoad (CmmReg _) _ -> pprExpr expr 
+                    _ -> parens (pprExpr expr)
+         , pprActuals actuals
+         , semi ]
+
+  where
+    pprActuals [] = empty
+    pprActuals as = parens ( commafy $ map pprLocalReg as ) 
+
+-- --------------------------------------------------------------------------
+-- 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@((i,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")
+                  , pprBlockId (head [ id | Just id <- ids]) <> semi ]
+
+-- --------------------------------------------------------------------------
+-- Expressions
+--
+
+pprExpr :: CmmExpr -> SDoc
+pprExpr e 
+    = case e of
+        CmmRegOff reg i -> 
+		pprExpr (CmmMachOp (MO_Add rep)
+			   [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
+		where rep = cmmRegRep reg	
+	CmmLit lit -> pprLit lit
+	_other     -> pprExpr1 e
+
+-- Here's the precedence table from CmmParse.y:
+-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
+-- %left '|'
+-- %left '^'
+-- %left '&'
+-- %left '>>' '<<'
+-- %left '-' '+'
+-- %left '/' '*' '%'
+-- %right '~'
+
+-- We just cope with the common operators for now, the rest will get
+-- a default conservative behaviour.
+
+-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
+pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
+   = pprExpr7 x <+> doc <+> pprExpr7 y
+pprExpr1 e = pprExpr7 e
+
+infixMachOp1 (MO_Eq     _) = Just (ptext SLIT("=="))
+infixMachOp1 (MO_Ne     _) = Just (ptext SLIT("!="))
+infixMachOp1 (MO_Shl    _) = Just (ptext SLIT("<<"))
+infixMachOp1 (MO_U_Shr  _) = Just (ptext SLIT(">>"))
+infixMachOp1 (MO_U_Ge   _) = Just (ptext SLIT(">="))
+infixMachOp1 (MO_U_Le   _) = Just (ptext SLIT("<="))
+infixMachOp1 (MO_U_Gt   _) = Just (char '>')
+infixMachOp1 (MO_U_Lt   _) = Just (char '<')
+infixMachOp1 _             = Nothing
+
+-- %left '-' '+'
+pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
+   = pprExpr7 x <+> doc <+> pprExpr8 y
+pprExpr7 e = pprExpr8 e
+
+infixMachOp7 (MO_Add _)  = Just (char '+')
+infixMachOp7 (MO_Sub _)  = Just (char '-')
+infixMachOp7 _           = Nothing
+
+-- %left '/' '*' '%'
+pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
+   = pprExpr8 x <+> doc <+> pprExpr9 y
+pprExpr8 e = pprExpr9 e
+
+infixMachOp8 (MO_U_Quot _) = Just (char '/')
+infixMachOp8 (MO_Mul _)    = Just (char '*')
+infixMachOp8 (MO_U_Rem _)  = Just (char '%')
+infixMachOp8 _             = Nothing
+
+pprExpr9 :: CmmExpr -> SDoc
+pprExpr9 e = 
+   case e of
+        CmmLit    lit       -> pprLit1 lit
+        CmmLoad   expr rep  -> ppr rep <> brackets( ppr expr )
+        CmmReg    reg       -> ppr reg
+        CmmRegOff reg off   -> parens (ppr reg <+> char '+' <+> int off)
+	CmmMachOp mop args  -> genMachOp mop args
+
+genMachOp :: MachOp -> [CmmExpr] -> SDoc
+genMachOp mop args
+   | Just doc <- infixMachOp mop = case args of
+        -- dyadic
+        [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
+
+        -- unary
+        [x]   -> doc <> pprExpr9 x
+
+        _     -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
+                          (pprMachOp mop <+>
+                            parens (hcat $ punctuate comma (map pprExpr args)))
+                          empty
+
+   | isJust (infixMachOp1 mop)
+   || isJust (infixMachOp7 mop)
+   || isJust (infixMachOp8 mop)	 = parens (pprExpr (CmmMachOp mop args))
+
+   | otherwise = char '%' <> pprMachOp mop <> parens (commafy (map pprExpr args))
+
+--
+-- Unsigned ops on the word size of the machine get nice symbols.
+-- All else get dumped in their ugly format.
+--
+infixMachOp :: MachOp -> Maybe SDoc
+infixMachOp mop
+	= case mop of
+            MO_And    _ -> Just $ char '&'
+            MO_Or     _ -> Just $ char '|'
+            MO_Xor    _ -> Just $ char '^'
+            MO_Not    _ -> Just $ char '~'
+            MO_S_Neg  _ -> Just $ char '-' -- there is no unsigned neg :)
+            _ -> Nothing
+
+-- --------------------------------------------------------------------------
+-- Literals.
+--  To minimise line noise we adopt the convention that if the literal
+--  has the natural machine word size, we do not append the type
+--
+pprLit :: CmmLit -> SDoc
+pprLit lit = case lit of
+    CmmInt i rep ->
+        hcat [ (if i < 0 then parens else id)(integer i)
+             , (if rep == wordRep 
+                    then empty 
+                    else space <> dcolon <+> ppr rep) ]
+
+    CmmFloat f rep     -> hsep [ rational f, dcolon, ppr rep ]
+    CmmLabel clbl      -> pprCLabel clbl
+    CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
+    CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'  
+                                  <> pprCLabel clbl2 <> ppr_offset i
+
+pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
+pprLit1 lit                      = pprLit lit
+
+ppr_offset :: Int -> SDoc
+ppr_offset i
+    | i==0      = empty
+    | i>=0      = char '+' <> int i
+    | otherwise = char '-' <> int (-i)
+
+-- --------------------------------------------------------------------------
+-- Static data.
+--      Strings are printed as C strings, and we print them as I8[],
+--      following C--
+--
+pprStatic :: CmmStatic -> SDoc
+pprStatic s = case s of
+    CmmStaticLit lit   -> nest 4 $ ptext SLIT("const") <+> pprLit lit <> semi
+    CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
+    CmmAlign i         -> nest 4 $ text "align" <+> int i
+    CmmDataLabel clbl  -> pprCLabel clbl <> colon
+    CmmString s'       -> nest 4 $ text "I8[]" <+> 
+			   doubleQuotes (text (map (chr.fromIntegral) s'))
+
+-- --------------------------------------------------------------------------
+-- Registers, whether local (temps) or global
+--
+pprReg :: CmmReg -> SDoc
+pprReg r 
+    = case r of
+        CmmLocal  local  -> pprLocalReg local
+        CmmGlobal global -> pprGlobalReg global
+
+--
+-- We only print the type of the local reg if it isn't wordRep
+--
+pprLocalReg :: LocalReg -> SDoc
+pprLocalReg (LocalReg uniq rep) 
+    = hcat [ char '_', ppr uniq, 
+            (if rep == wordRep 
+                then empty else dcolon <> ppr rep) ]
+
+-- needs to be kept in syn with Cmm.hs.GlobalReg
+--
+pprGlobalReg :: GlobalReg -> SDoc
+pprGlobalReg gr 
+    = case gr of
+        VanillaReg n   -> char 'R' <> int n
+        FloatReg   n   -> char 'F' <> int n
+        DoubleReg  n   -> char 'D' <> int n
+        LongReg    n   -> char 'L' <> int n
+        Sp             -> ptext SLIT("Sp")
+        SpLim          -> ptext SLIT("SpLim")
+        Hp             -> ptext SLIT("Hp")
+        HpLim          -> ptext SLIT("HpLim")
+        CurrentTSO     -> ptext SLIT("CurrentTSO")
+        CurrentNursery -> ptext SLIT("CurrentNursery")
+        HpAlloc        -> ptext SLIT("HpAlloc")
+        GCEnter1       -> ptext SLIT("stg_gc_enter_1")
+        GCFun          -> ptext SLIT("stg_gc_fun")
+        BaseReg        -> ptext SLIT("BaseReg")
+        PicBaseReg     -> ptext SLIT("PicBaseReg")
+
+-- --------------------------------------------------------------------------
+-- data sections
+--
+pprSection :: Section -> SDoc
+pprSection s = case s of
+    Text              -> section <+> doubleQuotes (ptext SLIT("text"))
+    Data              -> section <+> doubleQuotes (ptext SLIT("data"))
+    ReadOnlyData      -> section <+> doubleQuotes (ptext SLIT("readonly"))
+    RelocatableReadOnlyData
+                      -> section <+> doubleQuotes (ptext SLIT("relreadonly"))
+    UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))
+    OtherSection s'   -> section <+> doubleQuotes (text s')
+ where
+    section = ptext SLIT("section")
+       
+-- --------------------------------------------------------------------------
+-- Basic block ids
+--
+pprBlockId :: BlockId -> SDoc
+pprBlockId b = ppr $ getUnique b
+
+-----------------------------------------------------------------------------
+
+commafy :: [SDoc] -> SDoc
+commafy xs = hsep $ punctuate comma xs
+