Merging in the new codegen branch

[ghc-hetmet.git] / compiler / nativeGen / AsmCodeGen.lhs

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 507d96b..29f4be4 100644 (file)
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -36,7 +36,6 @@ import qualified GraphColor   as Color
 import Cmm
 import CmmOpt          ( cmmMiniInline, cmmMachOpFold )
 import PprCmm
-import MachOp
 import CLabel
 import State
 
@@ -129,7 +128,7 @@ nativeCodeGen dflags h us cmms
        let split_cmms  = concat $ map add_split cmms
 
        (imports, prof)
-               <- cmmNativeGens dflags h us split_cmms [] []
+               <- cmmNativeGens dflags h us split_cmms [] [] 0
 
        let (native, colorStats, linearStats)
                = unzip3 prof
@@ -179,13 +178,13 @@ nativeCodeGen dflags h us cmms
 
 -- | Do native code generation on all these cmms.
 --
-cmmNativeGens dflags h us [] impAcc profAcc
+cmmNativeGens dflags h us [] impAcc profAcc count
        = return (reverse impAcc, reverse profAcc)
 
-cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc
+cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count
  = do
        (us', native, imports, colorStats, linearStats)
-               <- cmmNativeGen dflags us cmm
+               <- cmmNativeGen dflags us cmm count
 
        Pretty.printDoc Pretty.LeftMode h
                $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map pprNatCmmTop native
@@ -196,13 +195,18 @@ cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc
                        then native
                        else []
 
+       let count'      = count + 1;
+
+
        -- force evaulation all this stuff to avoid space leaks
        seqString (showSDoc $ vcat $ map ppr imports) `seq` return ()
        lsPprNative     `seq` return ()
+       count'          `seq` return ()
 
        cmmNativeGens dflags h us' cmms
                        (imports : impAcc)
                        ((lsPprNative, colorStats, linearStats) : profAcc)
+                       count'
 
  where seqString []            = ()
        seqString (x:xs)        = x `seq` seqString xs `seq` ()
@@ -215,13 +219,14 @@ cmmNativeGen
        :: DynFlags
        -> UniqSupply
        -> RawCmmTop                            -- ^ the cmm to generate code for
+       -> Int                                  -- ^ sequence number of this top thing
        -> IO   ( UniqSupply
                , [NatCmmTop]                   -- native code
                , [CLabel]                      -- things imported by this cmm
                , Maybe [Color.RegAllocStats]   -- stats for the coloring register allocator
                , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators
 
-cmmNativeGen dflags us cmm
+cmmNativeGen dflags us cmm count
  = do
 
        -- rewrite assignments to global regs
@@ -288,7 +293,8 @@ cmmNativeGen dflags us cmm
                dumpIfSet_dyn dflags
                        Opt_D_dump_asm_regalloc_stages "Build/spill stages"
                        (vcat   $ map (\(stage, stats)
-                                       -> text " Stage " <> int stage
+                                       -> text "# --------------------------"
+                                       $$ text "#  cmm " <> int count <> text " Stage " <> int stage
                                        $$ ppr stats)
                                $ zip [0..] regAllocStats)
 
@@ -356,10 +362,7 @@ cmmNativeGen dflags us cmm
 x86fp_kludge :: NatCmmTop -> NatCmmTop
 x86fp_kludge top@(CmmData _ _) = top
 x86fp_kludge top@(CmmProc info lbl params (ListGraph code)) = 
-       CmmProc info lbl params (ListGraph $ map bb_i386_insert_ffrees code)
-       where
-               bb_i386_insert_ffrees (BasicBlock id instrs) =
-                       BasicBlock id (i386_insert_ffrees instrs)
+       CmmProc info lbl params (ListGraph $ i386_insert_ffrees code)
 #endif
 
 
@@ -449,7 +452,7 @@ sequenceBlocks (entry:blocks) =
   -- the first block is the entry point ==> it must remain at the start.
 
 sccBlocks :: [NatBasicBlock] -> [SCC (NatBasicBlock,Unique,[Unique])]
-sccBlocks blocks = stronglyConnCompR (map mkNode blocks)
+sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
 
 getOutEdges :: [Instr] -> [Unique]
 getOutEdges instrs = case jumpDests (last instrs) [] of
@@ -712,9 +715,9 @@ cmmStmtConFold stmt
                                e' <- cmmExprConFold CallReference e
                                return $ CmmCallee e' conv
                              other -> return other
-                 args' <- mapM (\(arg, hint) -> do
+                 args' <- mapM (\(CmmHinted arg hint) -> do
                                   arg' <- cmmExprConFold DataReference arg
-                                  return (arg', hint)) args
+                                  return (CmmHinted arg' hint)) args
                 return $ CmmCall target' regs args' srt returns
 
         CmmCondBranch test dest
@@ -755,23 +758,27 @@ cmmExprConFold referenceKind expr
            -> do
                 dflags <- getDynFlagsCmmOpt
                 dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
-                 return $ cmmMachOpFold (MO_Add wordRep) [
+                 return $ cmmMachOpFold (MO_Add wordWidth) [
                      dynRef,
-                     (CmmLit $ CmmInt (fromIntegral off) wordRep)
+                     (CmmLit $ CmmInt (fromIntegral off) wordWidth)
                    ]
 
 #if powerpc_TARGET_ARCH
            -- On powerpc (non-PIC), it's easier to jump directly to a label than
            -- to use the register table, so we replace these registers
            -- with the corresponding labels:
+        CmmReg (CmmGlobal EagerBlackholeInfo)
+          | not opt_PIC
+          -> cmmExprConFold referenceKind $
+             CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_EAGER_BLACKHOLE_INFO"))) 
         CmmReg (CmmGlobal GCEnter1)
           | not opt_PIC
           -> cmmExprConFold referenceKind $
-             CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1"))) 
+             CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_gc_enter_1"))) 
         CmmReg (CmmGlobal GCFun)
           | not opt_PIC
           -> cmmExprConFold referenceKind $
-             CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
+             CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_gc_fun")))
 #endif
 
         CmmReg (CmmGlobal mid)
@@ -787,7 +794,7 @@ cmmExprConFold referenceKind expr
                     -> case mid of 
                           BaseReg -> cmmExprConFold DataReference baseRegAddr
                           other   -> cmmExprConFold DataReference
-                                        (CmmLoad baseRegAddr (globalRegRep mid))
+                                        (CmmLoad baseRegAddr (globalRegType mid))
           -- eliminate zero offsets
        CmmRegOff reg 0
           -> cmmExprConFold referenceKind (CmmReg reg)
@@ -799,10 +806,10 @@ cmmExprConFold referenceKind expr
            -> case get_GlobalReg_reg_or_addr mid of
                 Left  realreg -> return expr
                 Right baseRegAddr
-                   -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordRep) [
+                   -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordWidth) [
                                         CmmReg (CmmGlobal mid),
                                         CmmLit (CmmInt (fromIntegral offset)
-                                                       wordRep)])
+                                                       wordWidth)])
         other
            -> return other