cmmTopCodeGen no longer takes DynFlags as an argument

[ghc-hetmet.git] / compiler / nativeGen / SPARC / CodeGen.hs

diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index 550a1a3..a4dbbe8 100644 (file)
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -8,6 +8,7 @@
 
 module SPARC.CodeGen ( 
        cmmTopCodeGen, 
 
 module SPARC.CodeGen ( 
        cmmTopCodeGen, 

+       generateJumpTableForInstr,

        InstrBlock 
 ) 
 
        InstrBlock 
 ) 
 

@@ -15,15 +16,17 @@ where
 
 #include "HsVersions.h"
 #include "nativeGen/NCG.h"
 
 #include "HsVersions.h"
 #include "nativeGen/NCG.h"

-#include "MachDeps.h"
+#include "../includes/MachDeps.h"

 
 -- NCG stuff:
 
 -- NCG stuff:

+import SPARC.CodeGen.Sanity

 import SPARC.CodeGen.Amode
 import SPARC.CodeGen.CondCode
 import SPARC.CodeGen.Gen64
 import SPARC.CodeGen.Gen32
 import SPARC.CodeGen.CCall
 import SPARC.CodeGen.Base
 import SPARC.CodeGen.Amode
 import SPARC.CodeGen.CondCode
 import SPARC.CodeGen.Gen64
 import SPARC.CodeGen.Gen32
 import SPARC.CodeGen.CCall
 import SPARC.CodeGen.Base

+import SPARC.Ppr       ()

 import SPARC.Instr
 import SPARC.Imm
 import SPARC.AddrMode
 import SPARC.Instr
 import SPARC.Imm
 import SPARC.AddrMode

@@ -34,69 +37,70 @@ import NCGMonad
 
 -- Our intermediate code:
 import BlockId
 
 -- Our intermediate code:
 import BlockId

-import Cmm
+import OldCmm

 import CLabel
 
 -- The rest:
 import StaticFlags     ( opt_PIC )
 import OrdList
 import CLabel
 
 -- The rest:
 import StaticFlags     ( opt_PIC )
 import OrdList

-import qualified Outputable as O

 import Outputable
 import Outputable

+import Unique

 
 import Control.Monad   ( mapAndUnzipM )
 
 import Control.Monad   ( mapAndUnzipM )

-import DynFlags

 
 -- | Top level code generation
 cmmTopCodeGen 
 
 -- | Top level code generation
 cmmTopCodeGen 

-       :: DynFlags
-       -> RawCmmTop 
+       :: RawCmmTop 

        -> NatM [NatCmmTop Instr]
 
        -> NatM [NatCmmTop Instr]
 

-cmmTopCodeGen _
-       (CmmProc info lab params (ListGraph blocks)) 
+cmmTopCodeGen
+       (CmmProc info lab (ListGraph blocks)) 

  = do  
        (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
 
  = do  
        (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
 

---     picBaseMb       <- getPicBaseMaybeNat
-       let proc        = CmmProc info lab params (ListGraph $ concat nat_blocks)
+       let proc        = CmmProc info lab (ListGraph $ concat nat_blocks)

        let tops        = proc : concat statics
 
        let tops        = proc : concat statics
 

---     case picBaseMb of
---      Just picBase -> initializePicBase picBase tops
---      Nothing -> return tops
-  

        return tops
   
        return tops
   

-  
-cmmTopCodeGen _ (CmmData sec dat) = do
+cmmTopCodeGen (CmmData sec dat) = do

   return [CmmData sec dat]  -- no translation, we just use CmmStatic
 
 
   return [CmmData sec dat]  -- no translation, we just use CmmStatic
 
 

-
+-- | Do code generation on a single block of CMM code.
+--     code generation may introduce new basic block boundaries, which
+--     are indicated by the NEWBLOCK instruction.  We must split up the
+--     instruction stream into basic blocks again.  Also, we extract
+--     LDATAs here too.

 basicBlockCodeGen 
        :: CmmBasicBlock
        -> NatM ( [NatBasicBlock Instr]
                , [NatCmmTop Instr])
 
 basicBlockCodeGen 
        :: CmmBasicBlock
        -> NatM ( [NatBasicBlock Instr]
                , [NatCmmTop Instr])
 

-basicBlockCodeGen (BasicBlock id stmts) = do
+basicBlockCodeGen cmm@(BasicBlock id stmts) = do

   instrs <- stmtsToInstrs stmts
   instrs <- stmtsToInstrs stmts

-  -- code generation may introduce new basic block boundaries, which
-  -- are indicated by the NEWBLOCK instruction.  We must split up the
-  -- instruction stream into basic blocks again.  Also, we extract
-  -- LDATAs here too.

   let
   let

-       (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
+       (top,other_blocks,statics) 
+               = foldrOL mkBlocks ([],[],[]) instrs

        
        mkBlocks (NEWBLOCK id) (instrs,blocks,statics) 
          = ([], BasicBlock id instrs : blocks, statics)
        
        mkBlocks (NEWBLOCK id) (instrs,blocks,statics) 
          = ([], BasicBlock id instrs : blocks, statics)

+

        mkBlocks (LDATA sec dat) (instrs,blocks,statics) 
          = (instrs, blocks, CmmData sec dat:statics)
        mkBlocks (LDATA sec dat) (instrs,blocks,statics) 
          = (instrs, blocks, CmmData sec dat:statics)

+

        mkBlocks instr (instrs,blocks,statics)
          = (instr:instrs, blocks, statics)
        mkBlocks instr (instrs,blocks,statics)
          = (instr:instrs, blocks, statics)

-  -- in
-  return (BasicBlock id top : other_blocks, statics)

 
 

+       -- do intra-block sanity checking
+       blocksChecked
+               = map (checkBlock cmm)
+               $ BasicBlock id top : other_blocks
+
+  return (blocksChecked, statics)

 
 

+
+-- | Convert some Cmm statements to SPARC instructions.

 stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock
 stmtsToInstrs stmts
    = do instrss <- mapM stmtToInstrs stmts
 stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock
 stmtsToInstrs stmts
    = do instrss <- mapM stmtToInstrs stmts

@@ -157,8 +161,8 @@ temporary, then do the other computation, and then use the temporary:
 -- | Convert a BlockId to some CmmStatic data
 jumpTableEntry :: Maybe BlockId -> CmmStatic
 jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth)
 -- | Convert a BlockId to some CmmStatic data
 jumpTableEntry :: Maybe BlockId -> CmmStatic
 jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth)

-jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel)
-    where blockLabel = mkAsmTempLabel id
+jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
+    where blockLabel = mkAsmTempLabel (getUnique blockid)

 
 
 
 
 
 

@@ -294,15 +298,11 @@ genSwitch expr ids
                dst             <- getNewRegNat II32
 
                label           <- getNewLabelNat
                dst             <- getNewRegNat II32
 
                label           <- getNewLabelNat

-               let jumpTable   = map jumpTableEntry ids

 
                return $ e_code `appOL`
                 toOL   
 
                return $ e_code `appOL`
                 toOL   

-                       -- the jump table
-                       [ LDATA ReadOnlyData (CmmDataLabel label : jumpTable)
-
-                       -- load base of jump table
-                       , SETHI (HI (ImmCLbl label)) base_reg
+                       [ -- load base of jump table
+                         SETHI (HI (ImmCLbl label)) base_reg

                        , OR    False base_reg (RIImm $ LO $ ImmCLbl label) base_reg
                        
                        -- the addrs in the table are 32 bits wide..
                        , OR    False base_reg (RIImm $ LO $ ImmCLbl label) base_reg
                        
                        -- the addrs in the table are 32 bits wide..

@@ -310,6 +310,11 @@ genSwitch expr ids
 
                        -- load and jump to the destination
                        , LD      II32 (AddrRegReg base_reg offset_reg) dst
 
                        -- load and jump to the destination
                        , LD      II32 (AddrRegReg base_reg offset_reg) dst

-                       , JMP_TBL (AddrRegImm dst (ImmInt 0)) [i | Just i <- ids]
+                       , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label

                        , NOP ]
 
                        , NOP ]
 

+generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr)
+generateJumpTableForInstr (JMP_TBL _ ids label) =
+       let jumpTable = map jumpTableEntry ids
+       in Just (CmmData ReadOnlyData (CmmDataLabel label : jumpTable))
+generateJumpTableForInstr _ = Nothing