Merge in new code generator branch.

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

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index d73cb89..7a38540 100644 (file)
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -7,13 +7,6 @@
 -- -----------------------------------------------------------------------------
 
 \begin{code}
 -- -----------------------------------------------------------------------------
 
 \begin{code}

-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-

 module AsmCodeGen ( nativeCodeGen ) where
 
 #include "HsVersions.h"
 module AsmCodeGen ( nativeCodeGen ) where
 
 #include "HsVersions.h"

@@ -29,12 +22,12 @@ import Alpha.Instr
 #elif i386_TARGET_ARCH || x86_64_TARGET_ARCH
 import X86.CodeGen
 import X86.Regs
 #elif i386_TARGET_ARCH || x86_64_TARGET_ARCH
 import X86.CodeGen
 import X86.Regs

-import X86.RegInfo

 import X86.Instr
 import X86.Ppr
 
 #elif sparc_TARGET_ARCH
 import SPARC.CodeGen
 import X86.Instr
 import X86.Ppr
 
 #elif sparc_TARGET_ARCH
 import SPARC.CodeGen

+import SPARC.CodeGen.Expand

 import SPARC.Regs
 import SPARC.Instr
 import SPARC.Ppr
 import SPARC.Regs
 import SPARC.Instr
 import SPARC.Ppr

@@ -59,37 +52,29 @@ import qualified RegAlloc.Linear.Main               as Linear
 import qualified GraphColor                    as Color
 import qualified RegAlloc.Graph.Main           as Color
 import qualified RegAlloc.Graph.Stats          as Color
 import qualified GraphColor                    as Color
 import qualified RegAlloc.Graph.Main           as Color
 import qualified RegAlloc.Graph.Stats          as Color

-import qualified RegAlloc.Graph.Coalesce       as Color

 import qualified RegAlloc.Graph.TrivColorable  as Color
 
 import qualified RegAlloc.Graph.TrivColorable  as Color
 

-import qualified SPARC.CodeGen.Expand          as SPARC
-

 import TargetReg
 import Platform
 import Instruction
 import PIC
 import Reg
 import TargetReg
 import Platform
 import Instruction
 import PIC
 import Reg

-import RegClass

 import NCGMonad
 
 import BlockId
 import CgUtils         ( fixStgRegisters )
 import NCGMonad
 
 import BlockId
 import CgUtils         ( fixStgRegisters )

-import Cmm
+import OldCmm

 import CmmOpt          ( cmmMiniInline, cmmMachOpFold )
 import CmmOpt          ( cmmMiniInline, cmmMachOpFold )

-import PprCmm
+import OldPprCmm

 import CLabel
 import CLabel

-import State

 
 import UniqFM
 import Unique          ( Unique, getUnique )
 import UniqSupply
 import DynFlags
 
 import UniqFM
 import Unique          ( Unique, getUnique )
 import UniqSupply
 import DynFlags

-#if powerpc_TARGET_ARCH
-import StaticFlags     ( opt_Static, opt_PIC )
-#endif
+import StaticFlags

 import Util
 import Util

-import Config           ( cProjectVersion )
-import Module
+import Config

 
 import Digraph
 import qualified Pretty
 
 import Digraph
 import qualified Pretty

@@ -98,18 +83,16 @@ import Outputable
 import FastString
 import UniqSet
 import ErrUtils
 import FastString
 import UniqSet
 import ErrUtils

+import Module

 
 -- DEBUGGING ONLY
 --import OrdList
 
 import Data.List
 
 -- DEBUGGING ONLY
 --import OrdList
 
 import Data.List

-import Data.Int
-import Data.Word
-import Data.Bits

 import Data.Maybe
 import Data.Maybe

-import GHC.Exts

 import Control.Monad
 import System.IO
 import Control.Monad
 import System.IO

+import Distribution.System

 
 {-
 The native-code generator has machine-independent and
 
 {-
 The native-code generator has machine-independent and

@@ -222,12 +205,26 @@ nativeCodeGen dflags h us cmms
                | dopt Opt_SplitObjs dflags = split_marker : tops
                | otherwise                 = tops
 
                | dopt Opt_SplitObjs dflags = split_marker : tops
                | otherwise                 = tops
 

-       split_marker = CmmProc [] mkSplitMarkerLabel [] (ListGraph [])
+       split_marker = CmmProc [] mkSplitMarkerLabel (ListGraph [])

 
 
 -- | Do native code generation on all these cmms.
 --
 
 
 -- | Do native code generation on all these cmms.
 --

-cmmNativeGens dflags h us [] impAcc profAcc count
+cmmNativeGens :: DynFlags
+              -> BufHandle
+              -> UniqSupply
+              -> [RawCmmTop]
+              -> [[CLabel]]
+              -> [ ([NatCmmTop Instr],
+                   Maybe [Color.RegAllocStats Instr],
+                   Maybe [Linear.RegAllocStats]) ]
+              -> Int
+              -> IO ( [[CLabel]],
+                      [([NatCmmTop Instr],
+                      Maybe [Color.RegAllocStats Instr],
+                      Maybe [Linear.RegAllocStats])] )
+
+cmmNativeGens _ _ _ [] impAcc profAcc _

        = return (reverse impAcc, reverse profAcc)
 
 cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count
        = return (reverse impAcc, reverse profAcc)
 
 cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count

@@ -304,7 +301,9 @@ cmmNativeGen dflags us cmm count
        -- tag instructions with register liveness information
        let (withLiveness, usLive) =
                {-# SCC "regLiveness" #-}
        -- tag instructions with register liveness information
        let (withLiveness, usLive) =
                {-# SCC "regLiveness" #-}

-               initUs usGen $ mapUs regLiveness native
+               initUs usGen 
+                       $ mapUs regLiveness 
+                       $ map natCmmTopToLive native

 
        dumpIfSet_dyn dflags
                Opt_D_dump_asm_liveness "Liveness annotations added"
 
        dumpIfSet_dyn dflags
                Opt_D_dump_asm_liveness "Liveness annotations added"

@@ -402,7 +401,7 @@ cmmNativeGen dflags us cmm count
 #if sparc_TARGET_ARCH
        let expanded = 
                {-# SCC "sparc_expand" #-}
 #if sparc_TARGET_ARCH
        let expanded = 
                {-# SCC "sparc_expand" #-}

-               map SPARC.expandTop kludged
+               map expandTop kludged

 
        dumpIfSet_dyn dflags
                Opt_D_dump_asm_expanded "Synthetic instructions expanded"
 
        dumpIfSet_dyn dflags
                Opt_D_dump_asm_expanded "Synthetic instructions expanded"

@@ -422,8 +421,8 @@ cmmNativeGen dflags us cmm count
 #if i386_TARGET_ARCH
 x86fp_kludge :: NatCmmTop Instr -> NatCmmTop Instr
 x86fp_kludge top@(CmmData _ _) = top
 #if i386_TARGET_ARCH
 x86fp_kludge :: NatCmmTop Instr -> NatCmmTop Instr
 x86fp_kludge top@(CmmData _ _) = top

-x86fp_kludge top@(CmmProc info lbl params (ListGraph code)) = 
-       CmmProc info lbl params (ListGraph $ i386_insert_ffrees code)
+x86fp_kludge (CmmProc info lbl (ListGraph code)) = 
+       CmmProc info lbl (ListGraph $ i386_insert_ffrees code)

 #endif
 
 
 #endif
 
 

@@ -499,8 +498,8 @@ sequenceTop
        -> NatCmmTop Instr
 
 sequenceTop top@(CmmData _ _) = top
        -> NatCmmTop Instr
 
 sequenceTop top@(CmmData _ _) = top

-sequenceTop (CmmProc info lbl params (ListGraph blocks)) = 
-  CmmProc info lbl params (ListGraph $ makeFarBranches $ sequenceBlocks blocks)
+sequenceTop (CmmProc info lbl (ListGraph blocks)) = 
+  CmmProc info lbl (ListGraph $ makeFarBranches $ sequenceBlocks blocks)

 
 -- The algorithm is very simple (and stupid): we make a graph out of
 -- the blocks where there is an edge from one block to another iff the
 
 -- The algorithm is very simple (and stupid): we make a graph out of
 -- the blocks where there is an edge from one block to another iff the

@@ -510,7 +509,7 @@ sequenceTop (CmmProc info lbl params (ListGraph blocks)) =
 -- destination of the out edge to the front of the list, and continue.
 
 -- FYI, the classic layout for basic blocks uses postorder DFS; this
 -- destination of the out edge to the front of the list, and continue.
 
 -- FYI, the classic layout for basic blocks uses postorder DFS; this

--- algorithm is implemented in cmm/ZipCfg.hs (NR 6 Sep 2007).
+-- algorithm is implemented in Hoopl.

 
 sequenceBlocks 
        :: Instruction instr
 
 sequenceBlocks 
        :: Instruction instr

@@ -543,8 +542,12 @@ getOutEdges instrs
                [one] -> [getUnique one]
                _many -> []
 
                [one] -> [getUnique one]
                _many -> []
 

+mkNode :: (Instruction t)
+       => GenBasicBlock t
+       -> (GenBasicBlock t, Unique, [Unique])

 mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
 
 mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
 

+seqBlocks :: (Eq t) => [(GenBasicBlock t1, t, [t])] -> [GenBasicBlock t1]

 seqBlocks [] = []
 seqBlocks ((block,_,[]) : rest)
   = block : seqBlocks rest
 seqBlocks [] = []
 seqBlocks ((block,_,[]) : rest)
   = block : seqBlocks rest

@@ -557,7 +560,8 @@ seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
          -- fallthroughs within a loop.
 seqBlocks _ = panic "AsmCodegen:seqBlocks"
 
          -- fallthroughs within a loop.
 seqBlocks _ = panic "AsmCodegen:seqBlocks"
 

-reorder id accum [] = (False, reverse accum)
+reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)])
+reorder  _ accum [] = (False, reverse accum)

 reorder id accum (b@(block,id',out) : rest)
   | id == id'  = (True, (block,id,out) : reverse accum ++ rest)
   | otherwise  = reorder id (b:accum) rest
 reorder id accum (b@(block,id',out) : rest)
   | id == id'  = (True, (block,id,out) : reverse accum ++ rest)
   | otherwise  = reorder id (b:accum) rest

@@ -584,14 +588,14 @@ makeFarBranches blocks
         handleBlock addr (BasicBlock id instrs)
                 = BasicBlock id (zipWith makeFar [addr..] instrs)
         
         handleBlock addr (BasicBlock id instrs)
                 = BasicBlock id (zipWith makeFar [addr..] instrs)
         

-        makeFar addr (BCC ALWAYS tgt) = BCC ALWAYS tgt
+        makeFar _ (BCC ALWAYS tgt) = BCC ALWAYS tgt

         makeFar addr (BCC cond tgt)
             | abs (addr - targetAddr) >= nearLimit
             = BCCFAR cond tgt
             | otherwise
             = BCC cond tgt
             where Just targetAddr = lookupUFM blockAddressMap tgt
         makeFar addr (BCC cond tgt)
             | abs (addr - targetAddr) >= nearLimit
             = BCCFAR cond tgt
             | otherwise
             = BCC cond tgt
             where Just targetAddr = lookupUFM blockAddressMap tgt

-        makeFar addr other            = other
+        makeFar _ other            = other

         
         nearLimit = 7000 -- 8192 instructions are allowed; let's keep some
                          -- distance, as we have a few pseudo-insns that are
         
         nearLimit = 7000 -- 8192 instructions are allowed; let's keep some
                          -- distance, as we have a few pseudo-insns that are

@@ -619,11 +623,13 @@ shortcutBranches dflags tops
     (tops', mappings) = mapAndUnzip build_mapping tops
     mapping = foldr plusUFM emptyUFM mappings
 
     (tops', mappings) = mapAndUnzip build_mapping tops
     mapping = foldr plusUFM emptyUFM mappings
 

+build_mapping :: GenCmmTop d t (ListGraph Instr)
+              -> (GenCmmTop d t (ListGraph Instr), UniqFM JumpDest)

 build_mapping top@(CmmData _ _) = (top, emptyUFM)
 build_mapping top@(CmmData _ _) = (top, emptyUFM)

-build_mapping (CmmProc info lbl params (ListGraph []))
-  = (CmmProc info lbl params (ListGraph []), emptyUFM)
-build_mapping (CmmProc info lbl params (ListGraph (head:blocks)))
-  = (CmmProc info lbl params (ListGraph (head:others)), mapping)
+build_mapping (CmmProc info lbl (ListGraph []))
+  = (CmmProc info lbl (ListGraph []), emptyUFM)
+build_mapping (CmmProc info lbl (ListGraph (head:blocks)))
+  = (CmmProc info lbl (ListGraph (head:others)), mapping)

         -- drop the shorted blocks, but don't ever drop the first one,
         -- because it is pointed to by a global label.
   where
         -- drop the shorted blocks, but don't ever drop the first one,
         -- because it is pointed to by a global label.
   where

@@ -633,11 +639,11 @@ build_mapping (CmmProc info lbl params (ListGraph (head:blocks)))
     (_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks
     split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
         | Just (DestBlockId dest) <- canShortcut insn,
     (_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks
     split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
         | Just (DestBlockId dest) <- canShortcut insn,

-          (elemBlockSet dest s) || dest == id -- loop checks
+          (setMember dest s) || dest == id -- loop checks

         = (s, shortcut_blocks, b : others)
     split (s, shortcut_blocks, others) (BasicBlock id [insn])
         | Just dest <- canShortcut insn
         = (s, shortcut_blocks, b : others)
     split (s, shortcut_blocks, others) (BasicBlock id [insn])
         | Just dest <- canShortcut insn

-        = (extendBlockSet s id, (id,dest) : shortcut_blocks, others)
+        = (setInsert id s, (id,dest) : shortcut_blocks, others)

     split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
 
 
     split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
 
 

@@ -645,12 +651,15 @@ build_mapping (CmmProc info lbl params (ListGraph (head:blocks)))
     mapping = foldl add emptyUFM shortcut_blocks
     add ufm (id,dest) = addToUFM ufm id dest
     
     mapping = foldl add emptyUFM shortcut_blocks
     add ufm (id,dest) = addToUFM ufm id dest
     

+apply_mapping :: UniqFM JumpDest
+              -> GenCmmTop CmmStatic h (ListGraph Instr)
+              -> GenCmmTop CmmStatic h (ListGraph Instr)

 apply_mapping ufm (CmmData sec statics) 
   = CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
   -- we need to get the jump tables, so apply the mapping to the entries
   -- of a CmmData too.
 apply_mapping ufm (CmmData sec statics) 
   = CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
   -- we need to get the jump tables, so apply the mapping to the entries
   -- of a CmmData too.

-apply_mapping ufm (CmmProc info lbl params (ListGraph blocks))
-  = CmmProc info lbl params (ListGraph $ map short_bb blocks)
+apply_mapping ufm (CmmProc info lbl (ListGraph blocks))
+  = CmmProc info lbl (ListGraph $ map short_bb blocks)

   where
     short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
     short_insn i = shortcutJump (lookupUFM ufm) i
   where
     short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
     short_insn i = shortcutJump (lookupUFM ufm) i

@@ -695,7 +704,6 @@ genMachCode dflags cmm_top
           else pprPanic "genMachCode: nonzero final delta" (int final_delta)
     }
 
           else pprPanic "genMachCode: nonzero final delta" (int final_delta)
     }
 

-

 -- -----------------------------------------------------------------------------
 -- Generic Cmm optimiser
 
 -- -----------------------------------------------------------------------------
 -- Generic Cmm optimiser
 

@@ -721,9 +729,9 @@ Ideas for other things we could do (ToDo):
 
 cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
 cmmToCmm _ top@(CmmData _ _) = (top, [])
 
 cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
 cmmToCmm _ top@(CmmData _ _) = (top, [])

-cmmToCmm dflags (CmmProc info lbl params (ListGraph blocks)) = runCmmOpt dflags $ do
+cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do

   blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
   blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)

-  return $ CmmProc info lbl params (ListGraph blocks')
+  return $ CmmProc info lbl (ListGraph blocks')

 
 newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
 
 
 newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
 

@@ -737,7 +745,7 @@ instance Monad CmmOptM where
                       CmmOptM g' -> g' (imports', dflags)
 
 addImportCmmOpt :: CLabel -> CmmOptM ()
                       CmmOptM g' -> g' (imports', dflags)
 
 addImportCmmOpt :: CLabel -> CmmOptM ()

-addImportCmmOpt lbl = CmmOptM $ \(imports, dflags) -> (# (), lbl:imports #)
+addImportCmmOpt lbl = CmmOptM $ \(imports, _dflags) -> (# (), lbl:imports #)

 
 getDynFlagsCmmOpt :: CmmOptM DynFlags
 getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
 
 getDynFlagsCmmOpt :: CmmOptM DynFlags
 getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)

@@ -751,6 +759,7 @@ cmmBlockConFold (BasicBlock id stmts) = do
   stmts' <- mapM cmmStmtConFold stmts
   return $ BasicBlock id stmts'
 
   stmts' <- mapM cmmStmtConFold stmts
   return $ BasicBlock id stmts'
 

+cmmStmtConFold :: CmmStmt -> CmmOptM CmmStmt

 cmmStmtConFold stmt
    = case stmt of
         CmmAssign reg src
 cmmStmtConFold stmt
    = case stmt of
         CmmAssign reg src

@@ -786,8 +795,8 @@ cmmStmtConFold stmt
                     CmmComment (mkFastString ("deleted: " ++ 
                                        showSDoc (pprStmt stmt)))
 
                     CmmComment (mkFastString ("deleted: " ++ 
                                        showSDoc (pprStmt stmt)))
 

-                  CmmLit (CmmInt n _) -> CmmBranch dest
-                  other -> CmmCondBranch test' dest
+                  CmmLit (CmmInt _ _) -> CmmBranch dest
+                  _other -> CmmCondBranch test' dest

 
        CmmSwitch expr ids
           -> do expr' <- cmmExprConFold DataReference expr
 
        CmmSwitch expr ids
           -> do expr' <- cmmExprConFold DataReference expr

@@ -797,6 +806,7 @@ cmmStmtConFold stmt
            -> return other
 
 
            -> return other
 
 

+cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr

 cmmExprConFold referenceKind expr
    = case expr of
         CmmLoad addr rep
 cmmExprConFold referenceKind expr
    = case expr of
         CmmLoad addr rep

@@ -822,23 +832,21 @@ cmmExprConFold referenceKind expr
                      (CmmLit $ CmmInt (fromIntegral off) wordWidth)
                    ]
 
                      (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:
+        -- 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)
         CmmReg (CmmGlobal EagerBlackholeInfo)

-          | not opt_PIC
+          | cTargetArch == PPC && not opt_PIC

           -> cmmExprConFold referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
         CmmReg (CmmGlobal GCEnter1)
           -> cmmExprConFold referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
         CmmReg (CmmGlobal GCEnter1)

-          | not opt_PIC
+          | cTargetArch == PPC && not opt_PIC

           -> cmmExprConFold referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) 
         CmmReg (CmmGlobal GCFun)
           -> cmmExprConFold referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) 
         CmmReg (CmmGlobal GCFun)

-          | not opt_PIC
+          | cTargetArch == PPC && not opt_PIC

           -> cmmExprConFold referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))
           -> cmmExprConFold referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))

-#endif

 
         other
            -> return other
 
         other
            -> return other