Add an extension for GHC's layout-rule relaxations

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

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index d79fbb6..68982d0 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,25 +52,21 @@ 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 NCGMonad
 
 import BlockId

+import CgUtils         ( fixStgRegisters )

 import Cmm
 import CmmOpt          ( cmmMiniInline, cmmMachOpFold )
 import PprCmm
 import CLabel
 import Cmm
 import CmmOpt          ( cmmMiniInline, cmmMachOpFold )
 import PprCmm
 import CLabel

-import State

 
 import UniqFM
 import Unique          ( Unique, getUnique )
 
 import UniqFM
 import Unique          ( Unique, getUnique )

@@ -87,8 +76,9 @@ import DynFlags
 import StaticFlags     ( opt_Static, opt_PIC )
 #endif
 import Util
 import StaticFlags     ( opt_Static, opt_PIC )
 #endif
 import Util

+#if !defined(darwin_TARGET_OS)

 import Config           ( cProjectVersion )
 import Config           ( cProjectVersion )

-import Module
+#endif

 
 import Digraph
 import qualified Pretty
 
 import Digraph
 import qualified Pretty

@@ -102,11 +92,7 @@ import ErrUtils
 --import OrdList
 
 import Data.List
 --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
 

@@ -226,7 +212,21 @@ nativeCodeGen dflags h us cmms
 
 -- | 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

@@ -278,9 +278,9 @@ cmmNativeGen dflags us cmm count
  = do
 
        -- rewrite assignments to global regs
  = do
 
        -- rewrite assignments to global regs

-       let (fixed_cmm, usFix)  =
-               {-# SCC "fixAssignsTop" #-}
-               initUs us $ fixAssignsTop cmm
+       let fixed_cmm =
+               {-# SCC "fixStgRegisters" #-}
+               fixStgRegisters cmm

 
        -- cmm to cmm optimisations
        let (opt_cmm, imports) =
 
        -- cmm to cmm optimisations
        let (opt_cmm, imports) =

@@ -294,22 +294,22 @@ cmmNativeGen dflags us cmm count
        -- generate native code from cmm
        let ((native, lastMinuteImports), usGen) =
                {-# SCC "genMachCode" #-}
        -- generate native code from cmm
        let ((native, lastMinuteImports), usGen) =
                {-# SCC "genMachCode" #-}

-               initUs usFix $ genMachCode dflags opt_cmm
+               initUs us $ genMachCode dflags opt_cmm

 
        dumpIfSet_dyn dflags
                Opt_D_dump_asm_native "Native code"
                (vcat $ map (docToSDoc . pprNatCmmTop) native)
 
 
        dumpIfSet_dyn dflags
                Opt_D_dump_asm_native "Native code"
                (vcat $ map (docToSDoc . pprNatCmmTop) native)
 

-

        -- 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"
                (vcat $ map ppr withLiveness)
 
        dumpIfSet_dyn dflags
                Opt_D_dump_asm_liveness "Liveness annotations added"
                (vcat $ map ppr withLiveness)

-

                
        -- allocate registers
        (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
                
        -- allocate registers
        (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-

@@ -323,7 +323,6 @@ cmmNativeGen dflags us cmm count
                                emptyUFM
                        $ allocatableRegs
 
                                emptyUFM
                        $ allocatableRegs
 

-

                -- do the graph coloring register allocation
                let ((alloced, regAllocStats), usAlloc)
                        = {-# SCC "RegAlloc" #-}
                -- do the graph coloring register allocation
                let ((alloced, regAllocStats), usAlloc)
                        = {-# SCC "RegAlloc" #-}

@@ -404,7 +403,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"

@@ -424,7 +423,7 @@ 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)) = 
+x86fp_kludge (CmmProc info lbl params (ListGraph code)) = 

        CmmProc info lbl params (ListGraph $ i386_insert_ffrees code)
 #endif
 
        CmmProc info lbl params (ListGraph $ i386_insert_ffrees code)
 #endif
 

@@ -545,8 +544,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

@@ -559,7 +562,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

@@ -621,6 +625,8 @@ 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 (CmmProc info lbl params (ListGraph []))
   = (CmmProc info lbl params (ListGraph []), emptyUFM)
 build_mapping top@(CmmData _ _) = (top, emptyUFM)
 build_mapping (CmmProc info lbl params (ListGraph []))
   = (CmmProc info lbl params (ListGraph []), emptyUFM)

@@ -647,6 +653,9 @@ 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
 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

@@ -697,44 +706,6 @@ genMachCode dflags cmm_top
           else pprPanic "genMachCode: nonzero final delta" (int final_delta)
     }
 
           else pprPanic "genMachCode: nonzero final delta" (int final_delta)
     }
 

--- -----------------------------------------------------------------------------
--- Fixup assignments to global registers so that they assign to 
--- locations within the RegTable, if appropriate.
-
--- Note that we currently don't fixup reads here: they're done by
--- the generic optimiser below, to avoid having two separate passes
--- over the Cmm.
-
-fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop
-fixAssignsTop top@(CmmData _ _) = returnUs top
-fixAssignsTop (CmmProc info lbl params (ListGraph blocks)) =
-  mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
-  returnUs (CmmProc info lbl params (ListGraph blocks'))
-
-fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock
-fixAssignsBlock (BasicBlock id stmts) =
-  fixAssigns stmts `thenUs` \ stmts' ->
-  returnUs (BasicBlock id stmts')
-
-fixAssigns :: [CmmStmt] -> UniqSM [CmmStmt]
-fixAssigns stmts =
-  mapUs fixAssign stmts `thenUs` \ stmtss ->
-  returnUs (concat stmtss)
-
-fixAssign :: CmmStmt -> UniqSM [CmmStmt]
-fixAssign (CmmAssign (CmmGlobal reg) src)
-  | Left  realreg <- reg_or_addr
-  = returnUs [CmmAssign (CmmGlobal reg) src]
-  | Right baseRegAddr <- reg_or_addr
-  = returnUs [CmmStore baseRegAddr src]
-           -- Replace register leaves with appropriate StixTrees for
-           -- the given target. GlobalRegs which map to a reg on this
-           -- arch are left unchanged.  Assigning to BaseReg is always
-           -- illegal, so we check for that.
-  where
-       reg_or_addr = get_GlobalReg_reg_or_addr reg
-
-fixAssign other_stmt = returnUs [other_stmt]

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

@@ -745,10 +716,7 @@ Here we do:
   (a) Constant folding
   (b) Simple inlining: a temporary which is assigned to and then
       used, once, can be shorted.
   (a) Constant folding
   (b) Simple inlining: a temporary which is assigned to and then
       used, once, can be shorted.

-  (c) Replacement of references to GlobalRegs which do not have
-      machine registers by the appropriate memory load (eg.
-      Hp ==>  *(BaseReg + 34) ).
-  (d) Position independent code and dynamic linking
+  (c) Position independent code and dynamic linking

         (i)  introduce the appropriate indirections
              and position independent refs
         (ii) compile a list of imported symbols
         (i)  introduce the appropriate indirections
              and position independent refs
         (ii) compile a list of imported symbols

@@ -780,7 +748,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 #)

@@ -794,6 +762,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

@@ -829,8 +798,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

@@ -840,6 +809,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

@@ -883,42 +853,8 @@ cmmExprConFold referenceKind expr
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))
 #endif
 
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))
 #endif
 

-        CmmReg (CmmGlobal mid)
-           -- Replace register leaves with appropriate StixTrees for
-           -- the given target.  MagicIds which map to a reg on this
-           -- arch are left unchanged.  For the rest, BaseReg is taken
-           -- to mean the address of the reg table in MainCapability,
-           -- and for all others we generate an indirection to its
-           -- location in the register table.
-           -> case get_GlobalReg_reg_or_addr mid of
-                 Left  realreg -> return expr
-                 Right baseRegAddr 
-                    -> case mid of 
-                          BaseReg -> cmmExprConFold DataReference baseRegAddr
-                          other   -> cmmExprConFold DataReference
-                                        (CmmLoad baseRegAddr (globalRegType mid))
-          -- eliminate zero offsets
-       CmmRegOff reg 0
-          -> cmmExprConFold referenceKind (CmmReg reg)
-
-        CmmRegOff (CmmGlobal mid) offset
-           -- RegOf leaves are just a shorthand form. If the reg maps
-           -- to a real reg, we keep the shorthand, otherwise, we just
-           -- expand it and defer to the above code. 
-           -> case get_GlobalReg_reg_or_addr mid of
-                Left  realreg -> return expr
-                Right baseRegAddr
-                   -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordWidth) [
-                                        CmmReg (CmmGlobal mid),
-                                        CmmLit (CmmInt (fromIntegral offset)
-                                                       wordWidth)])

         other
            -> return other
 
         other
            -> return other
 

--- -----------------------------------------------------------------------------
--- Utils
-
-bind f x = x $! f
-

 \end{code}
 
 \end{code}