Add new mem{cpy,set,move} cmm prim ops.

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

diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index d3ec27f..ae8ef40 100644 (file)
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -15,6 +15,7 @@
 
 module PPC.CodeGen ( 
        cmmTopCodeGen, 
 
 module PPC.CodeGen ( 
        cmmTopCodeGen, 

+       generateJumpTableForInstr,

        InstrBlock 
 ) 
 
        InstrBlock 
 ) 
 

@@ -22,7 +23,7 @@ where
 
 #include "HsVersions.h"
 #include "nativeGen/NCG.h"
 
 #include "HsVersions.h"
 #include "nativeGen/NCG.h"

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

 
 -- NCG stuff:
 import PPC.Instr
 
 -- NCG stuff:
 import PPC.Instr

@@ -35,12 +36,13 @@ import PIC
 import Size
 import RegClass
 import Reg
 import Size
 import RegClass
 import Reg

+import TargetReg

 import Platform
 
 -- Our intermediate code:
 import BlockId
 import PprCmm          ( pprExpr )
 import Platform
 
 -- Our intermediate code:
 import BlockId
 import PprCmm          ( pprExpr )

-import Cmm
+import OldCmm

 import CLabel
 
 -- The rest:
 import CLabel
 
 -- The rest:

@@ -48,6 +50,7 @@ import StaticFlags    ( opt_PIC )
 import OrdList
 import qualified Outputable as O
 import Outputable
 import OrdList
 import qualified Outputable as O
 import Outputable

+import Unique

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

@@ -73,10 +76,10 @@ cmmTopCodeGen
        -> RawCmmTop 
        -> NatM [NatCmmTop Instr]
 
        -> RawCmmTop 
        -> NatM [NatCmmTop Instr]
 

-cmmTopCodeGen dflags (CmmProc info lab params (ListGraph blocks)) = do
+cmmTopCodeGen dflags (CmmProc info lab (ListGraph blocks)) = do

   (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
   picBaseMb <- getPicBaseMaybeNat
   (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)

       tops = proc : concat statics
       os   = platformOS $ targetPlatform dflags
   case picBaseMb of
       tops = proc : concat statics
       os   = platformOS $ targetPlatform dflags
   case picBaseMb of

@@ -176,15 +179,15 @@ swizzleRegisterRep (Any _ codefn)     size = Any   size codefn
 getRegisterReg :: CmmReg -> Reg
 
 getRegisterReg (CmmLocal (LocalReg u pk))
 getRegisterReg :: CmmReg -> Reg
 
 getRegisterReg (CmmLocal (LocalReg u pk))

-  = mkVReg u (cmmTypeSize pk)
+  = RegVirtual $ mkVirtualReg u (cmmTypeSize pk)

 
 getRegisterReg (CmmGlobal mid)
 
 getRegisterReg (CmmGlobal mid)

-  = case get_GlobalReg_reg_or_addr mid of
-       Left reg@(RegReal _) -> reg
-       _other -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
-          -- By this stage, the only MagicIds remaining should be the
-          -- ones which map to a real machine register on this
-          -- platform.  Hence ...
+  = case globalRegMaybe mid of
+        Just reg -> reg
+        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
+        -- By this stage, the only MagicIds remaining should be the
+        -- ones which map to a real machine register on this
+        -- platform.  Hence ...

 
 
 {-
 
 
 {-

@@ -220,8 +223,8 @@ is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000
 -- | 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)

 
 
 
 
 
 

@@ -305,7 +308,7 @@ assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock
 assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do
    ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
    let 
 assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do
    ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
    let 

-         r_dst_lo = mkVReg u_dst II32
+         r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32

          r_dst_hi = getHiVRegFromLo r_dst_lo
          r_src_hi = getHiVRegFromLo r_src_lo
          mov_lo = MR r_dst_lo r_src_lo
          r_dst_hi = getHiVRegFromLo r_dst_lo
          r_src_hi = getHiVRegFromLo r_src_lo
          mov_lo = MR r_dst_lo r_src_lo

@@ -329,7 +332,7 @@ iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do
                          rlo
 
 iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty
                          rlo
 
 iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty

-   = return (ChildCode64 nilOL (mkVReg vu II32))
+   = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))

 
 iselExpr64 (CmmLit (CmmInt i _)) = do
   (rlo,rhi) <- getNewRegPairNat II32
 
 iselExpr64 (CmmLit (CmmInt i _)) = do
   (rlo,rhi) <- getNewRegPairNat II32

@@ -376,6 +379,11 @@ iselExpr64 expr
 
 getRegister :: CmmExpr -> NatM Register
 
 
 getRegister :: CmmExpr -> NatM Register
 

+getRegister (CmmReg (CmmGlobal PicBaseReg))
+  = do
+      reg <- getPicBaseNat archWordSize
+      return (Fixed archWordSize reg nilOL)
+

 getRegister (CmmReg reg) 
   = return (Fixed (cmmTypeSize (cmmRegType reg)) 
                  (getRegisterReg reg) nilOL)
 getRegister (CmmReg reg) 
   = return (Fixed (cmmTypeSize (cmmRegType reg)) 
                  (getRegisterReg reg) nilOL)

@@ -413,7 +421,7 @@ getRegister (CmmLoad mem pk)
   | not (isWord64 pk)
   = do
         Amode addr addr_code <- getAmode mem
   | not (isWord64 pk)
   = do
         Amode addr addr_code <- getAmode mem

-        let code dst = ASSERT((regClass dst == RcDouble) == isFloatType pk)
+        let code dst = ASSERT((targetClassOfReg dst == RcDouble) == isFloatType pk)

                        addr_code `snocOL` LD size dst addr
         return (Any size code)
           where size = cmmTypeSize pk
                        addr_code `snocOL` LD size dst addr
         return (Any size code)
           where size = cmmTypeSize pk

@@ -791,7 +799,7 @@ genJump (CmmLit (CmmLabel lbl))
 genJump tree
   = do
         (target,code) <- getSomeReg tree
 genJump tree
   = do
         (target,code) <- getSomeReg tree

-        return (code `snocOL` MTCTR target `snocOL` BCTR [])
+        return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing)

 
 
 -- -----------------------------------------------------------------------------
 
 
 -- -----------------------------------------------------------------------------

@@ -902,7 +910,7 @@ genCCall target dest_regs argsAndHints
         (labelOrExpr, reduceToFF32) <- case target of
             CmmCallee (CmmLit (CmmLabel lbl)) conv -> return (Left lbl, False)
             CmmCallee expr conv -> return  (Right expr, False)
         (labelOrExpr, reduceToFF32) <- case target of
             CmmCallee (CmmLit (CmmLabel lbl)) conv -> return (Left lbl, False)
             CmmCallee expr conv -> return  (Right expr, False)

-            CmmPrim mop -> outOfLineFloatOp mop
+            CmmPrim mop -> outOfLineMachOp mop

                                                         
         let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode
             codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32
                                                         
         let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode
             codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32

@@ -929,7 +937,17 @@ genCCall target dest_regs argsAndHints
         initialStackOffset = 8
         stackDelta finalStack = roundTo 16 finalStack
 #endif
         initialStackOffset = 8
         stackDelta finalStack = roundTo 16 finalStack
 #endif

-       args = map hintlessCmm argsAndHints
+        -- need to remove alignment information
+        argsAndHints' | (CmmPrim mop) <- target,
+                        (mop == MO_Memcpy ||
+                         mop == MO_Memset ||
+                         mop == MO_Memmove)
+                      -> init argsAndHints
+
+                      | otherwise
+                      -> argsAndHints
+
+       args = map hintlessCmm argsAndHints'

        argReps = map cmmExprType args
 
        roundTo a x | x `mod` a == 0 = x
        argReps = map cmmExprType args
 
        roundTo a x | x `mod` a == 0 = x

@@ -1054,11 +1072,11 @@ genCCall target dest_regs argsAndHints
                     where rep = cmmRegType (CmmLocal dest)
                           r_dest = getRegisterReg (CmmLocal dest)
                           
                     where rep = cmmRegType (CmmLocal dest)
                           r_dest = getRegisterReg (CmmLocal dest)
                           

-        outOfLineFloatOp mop =
+        outOfLineMachOp mop =

             do
                 dflags <- getDynFlagsNat
                 mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $
             do
                 dflags <- getDynFlagsNat
                 mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $

-                              mkForeignLabel functionName Nothing True IsFunction
+                              mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction

                 let mopLabelOrExpr = case mopExpr of
                         CmmLit (CmmLabel lbl) -> Left lbl
                         _ -> Right mopExpr
                 let mopLabelOrExpr = case mopExpr of
                         CmmLit (CmmLabel lbl) -> Left lbl
                         _ -> Right mopExpr

@@ -1098,6 +1116,11 @@ genCCall target dest_regs argsAndHints
                     MO_F64_Cosh  -> (fsLit "cosh", False)
                     MO_F64_Tanh  -> (fsLit "tanh", False)
                     MO_F64_Pwr   -> (fsLit "pow", False)
                     MO_F64_Cosh  -> (fsLit "cosh", False)
                     MO_F64_Tanh  -> (fsLit "tanh", False)
                     MO_F64_Pwr   -> (fsLit "pow", False)

+
+                    MO_Memcpy    -> (fsLit "memcpy", False)
+                    MO_Memset    -> (fsLit "memset", False)
+                    MO_Memmove   -> (fsLit "memmove", False)
+

                     other -> pprPanic "genCCall(ppc): unknown callish op"
                                     (pprCallishMachOp other)
 
                     other -> pprPanic "genCCall(ppc): unknown callish op"
                                     (pprCallishMachOp other)
 

@@ -1119,22 +1142,12 @@ genSwitch expr ids
         dflags <- getDynFlagsNat
         dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
         (tableReg,t_code) <- getSomeReg $ dynRef
         dflags <- getDynFlagsNat
         dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
         (tableReg,t_code) <- getSomeReg $ dynRef

-        let
-            jumpTable = map jumpTableEntryRel ids
-            
-            jumpTableEntryRel Nothing
-                = CmmStaticLit (CmmInt 0 wordWidth)
-            jumpTableEntryRel (Just (BlockId id))
-                = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
-                where blockLabel = mkAsmTempLabel id
-
-            code = e_code `appOL` t_code `appOL` toOL [
-                            LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
+        let code = e_code `appOL` t_code `appOL` toOL [

                             SLW tmp reg (RIImm (ImmInt 2)),
                             LD II32 tmp (AddrRegReg tableReg tmp),
                             ADD tmp tmp (RIReg tableReg),
                             MTCTR tmp,
                             SLW tmp reg (RIImm (ImmInt 2)),
                             LD II32 tmp (AddrRegReg tableReg tmp),
                             ADD tmp tmp (RIReg tableReg),
                             MTCTR tmp,

-                            BCTR [ id | Just id <- ids ]
+                            BCTR ids (Just lbl)

                     ]
         return code
   | otherwise
                     ]
         return code
   | otherwise

@@ -1142,19 +1155,27 @@ genSwitch expr ids
         (reg,e_code) <- getSomeReg expr
         tmp <- getNewRegNat II32
         lbl <- getNewLabelNat
         (reg,e_code) <- getSomeReg expr
         tmp <- getNewRegNat II32
         lbl <- getNewLabelNat

-        let
-            jumpTable = map jumpTableEntry ids
-        
-            code = e_code `appOL` toOL [
-                            LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
+        let code = e_code `appOL` toOL [

                             SLW tmp reg (RIImm (ImmInt 2)),
                             ADDIS tmp tmp (HA (ImmCLbl lbl)),
                             LD II32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
                             MTCTR tmp,
                             SLW tmp reg (RIImm (ImmInt 2)),
                             ADDIS tmp tmp (HA (ImmCLbl lbl)),
                             LD II32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
                             MTCTR tmp,

-                            BCTR [ id | Just id <- ids ]
+                            BCTR ids (Just lbl)

                     ]
         return code
 
                     ]
         return code
 

+generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr)
+generateJumpTableForInstr (BCTR ids (Just lbl)) =
+    let jumpTable
+            | opt_PIC   = map jumpTableEntryRel ids
+            | otherwise = map jumpTableEntry ids
+                where jumpTableEntryRel Nothing
+                        = CmmStaticLit (CmmInt 0 wordWidth)
+                      jumpTableEntryRel (Just blockid)
+                        = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
+                            where blockLabel = mkAsmTempLabel (getUnique blockid)
+    in Just (CmmData ReadOnlyData (CmmDataLabel lbl : jumpTable))
+generateJumpTableForInstr _ = Nothing

 
 -- -----------------------------------------------------------------------------
 -- 'condIntReg' and 'condFltReg': condition codes into registers
 
 -- -----------------------------------------------------------------------------
 -- 'condIntReg' and 'condFltReg': condition codes into registers