Remove duplicate functions in StgCmmUtils, use functions from CgUtils
[ghc.git] / compiler / codeGen / CgUtils.hs
index 1f0b825..0ff9bd8 100644 (file)
@@ -1,3 +1,5 @@
+{-# LANGUAGE GADTs #-}
+
 -----------------------------------------------------------------------------
 --
 -- Code generator utilities; mostly monadic
@@ -6,12 +8,21 @@
 --
 -----------------------------------------------------------------------------
 
-module CgUtils ( fixStgRegisters ) where
+module CgUtils (
+        fixStgRegisters,
+        baseRegOffset,
+        get_Regtable_addr_from_offset,
+        regTableOffset,
+        get_GlobalReg_addr,
+  ) where
 
-#include "HsVersions.h"
+import GhcPrelude
 
 import CodeGen.Platform
-import OldCmm
+import Cmm
+import Hoopl.Block
+import Hoopl.Graph
+import CmmUtils
 import CLabel
 import DynFlags
 import Outputable
@@ -36,10 +47,37 @@ baseRegOffset dflags (FloatReg  1)       = oFFSET_StgRegTable_rF1 dflags
 baseRegOffset dflags (FloatReg  2)       = oFFSET_StgRegTable_rF2 dflags
 baseRegOffset dflags (FloatReg  3)       = oFFSET_StgRegTable_rF3 dflags
 baseRegOffset dflags (FloatReg  4)       = oFFSET_StgRegTable_rF4 dflags
-baseRegOffset _      (FloatReg  n)       = panic ("Registers above F4 are not supported (tried to use F" ++ show n ++ ")")
+baseRegOffset dflags (FloatReg  5)       = oFFSET_StgRegTable_rF5 dflags
+baseRegOffset dflags (FloatReg  6)       = oFFSET_StgRegTable_rF6 dflags
+baseRegOffset _      (FloatReg  n)       = panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")")
 baseRegOffset dflags (DoubleReg 1)       = oFFSET_StgRegTable_rD1 dflags
 baseRegOffset dflags (DoubleReg 2)       = oFFSET_StgRegTable_rD2 dflags
-baseRegOffset _      (DoubleReg n)       = panic ("Registers above D2 are not supported (tried to use D" ++ show n ++ ")")
+baseRegOffset dflags (DoubleReg 3)       = oFFSET_StgRegTable_rD3 dflags
+baseRegOffset dflags (DoubleReg 4)       = oFFSET_StgRegTable_rD4 dflags
+baseRegOffset dflags (DoubleReg 5)       = oFFSET_StgRegTable_rD5 dflags
+baseRegOffset dflags (DoubleReg 6)       = oFFSET_StgRegTable_rD6 dflags
+baseRegOffset _      (DoubleReg n)       = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")")
+baseRegOffset dflags (XmmReg 1)          = oFFSET_StgRegTable_rXMM1 dflags
+baseRegOffset dflags (XmmReg 2)          = oFFSET_StgRegTable_rXMM2 dflags
+baseRegOffset dflags (XmmReg 3)          = oFFSET_StgRegTable_rXMM3 dflags
+baseRegOffset dflags (XmmReg 4)          = oFFSET_StgRegTable_rXMM4 dflags
+baseRegOffset dflags (XmmReg 5)          = oFFSET_StgRegTable_rXMM5 dflags
+baseRegOffset dflags (XmmReg 6)          = oFFSET_StgRegTable_rXMM6 dflags
+baseRegOffset _      (XmmReg n)          = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")")
+baseRegOffset dflags (YmmReg 1)          = oFFSET_StgRegTable_rYMM1 dflags
+baseRegOffset dflags (YmmReg 2)          = oFFSET_StgRegTable_rYMM2 dflags
+baseRegOffset dflags (YmmReg 3)          = oFFSET_StgRegTable_rYMM3 dflags
+baseRegOffset dflags (YmmReg 4)          = oFFSET_StgRegTable_rYMM4 dflags
+baseRegOffset dflags (YmmReg 5)          = oFFSET_StgRegTable_rYMM5 dflags
+baseRegOffset dflags (YmmReg 6)          = oFFSET_StgRegTable_rYMM6 dflags
+baseRegOffset _      (YmmReg n)          = panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")")
+baseRegOffset dflags (ZmmReg 1)          = oFFSET_StgRegTable_rZMM1 dflags
+baseRegOffset dflags (ZmmReg 2)          = oFFSET_StgRegTable_rZMM2 dflags
+baseRegOffset dflags (ZmmReg 3)          = oFFSET_StgRegTable_rZMM3 dflags
+baseRegOffset dflags (ZmmReg 4)          = oFFSET_StgRegTable_rZMM4 dflags
+baseRegOffset dflags (ZmmReg 5)          = oFFSET_StgRegTable_rZMM5 dflags
+baseRegOffset dflags (ZmmReg 6)          = oFFSET_StgRegTable_rZMM6 dflags
+baseRegOffset _      (ZmmReg n)          = panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")")
 baseRegOffset dflags Sp                  = oFFSET_StgRegTable_rSp dflags
 baseRegOffset dflags SpLim               = oFFSET_StgRegTable_rSpLim dflags
 baseRegOffset dflags (LongReg 1)         = oFFSET_StgRegTable_rL1 dflags
@@ -53,8 +91,10 @@ baseRegOffset dflags HpAlloc             = oFFSET_StgRegTable_rHpAlloc dflags
 baseRegOffset dflags EagerBlackholeInfo  = oFFSET_stgEagerBlackholeInfo dflags
 baseRegOffset dflags GCEnter1            = oFFSET_stgGCEnter1 dflags
 baseRegOffset dflags GCFun               = oFFSET_stgGCFun dflags
-baseRegOffset _      BaseReg             = panic "baseRegOffset:BaseReg"
-baseRegOffset _      PicBaseReg          = panic "baseRegOffset:PicBaseReg"
+baseRegOffset _      BaseReg             = panic "CgUtils.baseRegOffset:BaseReg"
+baseRegOffset _      PicBaseReg          = panic "CgUtils.baseRegOffset:PicBaseReg"
+baseRegOffset _      MachSp              = panic "CgUtils.baseRegOffset:MachSp"
+baseRegOffset _      UnwindReturnReg     = panic "CgUtils.baseRegOffset:UnwindReturnReg"
 
 
 -- -----------------------------------------------------------------------------
@@ -70,8 +110,7 @@ baseRegOffset _      PicBaseReg          = panic "baseRegOffset:PicBaseReg"
 get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr
 get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0
 get_GlobalReg_addr dflags mid
-    = get_Regtable_addr_from_offset dflags
-                                    (globalRegType dflags mid) (baseRegOffset dflags mid)
+    = get_Regtable_addr_from_offset dflags (baseRegOffset dflags mid)
 
 -- Calculate a literal representing an offset into the register table.
 -- Used when we don't have an actual BaseReg to offset from.
@@ -79,10 +118,10 @@ regTableOffset :: DynFlags -> Int -> CmmExpr
 regTableOffset dflags n =
   CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))
 
-get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr
-get_Regtable_addr_from_offset dflags offset =
+get_Regtable_addr_from_offset :: DynFlags -> Int -> CmmExpr
+get_Regtable_addr_from_offset dflags offset =
     if haveRegBase (targetPlatform dflags)
-    then CmmRegOff (CmmGlobal BaseReg) offset
+    then CmmRegOff baseReg offset
     else regTableOffset dflags offset
 
 -- | Fixup global registers so that they assign to locations within the
@@ -90,59 +129,34 @@ get_Regtable_addr_from_offset dflags _ offset =
 fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl
 fixStgRegisters _ top@(CmmData _ _) = top
 
-fixStgRegisters dflags (CmmProc info lbl (ListGraph blocks)) =
-  let blocks' = map (fixStgRegBlock dflags) blocks
-  in CmmProc info lbl $ ListGraph blocks'
-
-fixStgRegBlock :: DynFlags -> CmmBasicBlock -> CmmBasicBlock
-fixStgRegBlock dflags (BasicBlock id stmts) =
-  let stmts' = map (fixStgRegStmt dflags) stmts
-  in BasicBlock id stmts'
-
-fixStgRegStmt :: DynFlags -> CmmStmt -> CmmStmt
-fixStgRegStmt dflags stmt
-  = case stmt of
-        CmmAssign (CmmGlobal reg) src ->
-            let src' = fixStgRegExpr dflags src
-                baseAddr = get_GlobalReg_addr dflags reg
-            in case reg `elem` activeStgRegs platform of
-                True  -> CmmAssign (CmmGlobal reg) src'
-                False -> CmmStore baseAddr src'
-
-        CmmAssign reg src ->
-            let src' = fixStgRegExpr dflags src
-            in CmmAssign reg src'
-
-        CmmStore addr src -> CmmStore (fixStgRegExpr dflags addr) (fixStgRegExpr dflags src)
-
-        CmmCall target regs args returns ->
-            let target' = case target of
-                    CmmCallee e conv -> CmmCallee (fixStgRegExpr dflags e) conv
-                    CmmPrim op mStmts ->
-                        CmmPrim op (fmap (map (fixStgRegStmt dflags)) mStmts)
-                args' = map (\(CmmHinted arg hint) ->
-                                (CmmHinted (fixStgRegExpr dflags arg) hint)) args
-            in CmmCall target' regs args' returns
-
-        CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr dflags test) dest
-
-        CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr dflags expr) ids
-
-        CmmJump addr live -> CmmJump (fixStgRegExpr dflags addr) live
-
-        -- CmmNop, CmmComment, CmmBranch, CmmReturn
-        _other -> stmt
-    where platform = targetPlatform dflags
-
-
-fixStgRegExpr :: DynFlags -> CmmExpr -> CmmExpr
-fixStgRegExpr dflags expr
-  = case expr of
-        CmmLoad addr ty -> CmmLoad (fixStgRegExpr dflags addr) ty
-
-        CmmMachOp mop args -> CmmMachOp mop args'
-            where args' = map (fixStgRegExpr dflags) args
-
+fixStgRegisters dflags (CmmProc info lbl live graph) =
+  let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock dflags)) graph
+  in CmmProc info lbl live graph'
+
+fixStgRegBlock :: DynFlags -> Block CmmNode e x -> Block CmmNode e x
+fixStgRegBlock dflags block = mapBlock (fixStgRegStmt dflags) block
+
+fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x
+fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt
+  where
+    platform = targetPlatform dflags
+
+    fixAssign stmt =
+      case stmt of
+        CmmAssign (CmmGlobal reg) src
+          -- MachSp isn't an STG register; it's merely here for tracking unwind
+          -- information
+          | reg == MachSp -> stmt
+          | otherwise ->
+            let baseAddr = get_GlobalReg_addr dflags reg
+            in case reg `elem` activeStgRegs (targetPlatform dflags) of
+                True  -> CmmAssign (CmmGlobal reg) src
+                False -> CmmStore baseAddr src
+        other_stmt -> other_stmt
+
+    fixExpr expr = case expr of
+        -- MachSp isn't an STG; it's merely here for tracking unwind information
+        CmmReg (CmmGlobal MachSp) -> expr
         CmmReg (CmmGlobal reg) ->
             -- Replace register leaves with appropriate StixTrees for
             -- the given target.  MagicIds which map to a reg on this
@@ -155,9 +169,8 @@ fixStgRegExpr dflags expr
                 False ->
                     let baseAddr = get_GlobalReg_addr dflags reg
                     in case reg of
-                        BaseReg -> fixStgRegExpr dflags baseAddr
-                        _other  -> fixStgRegExpr dflags
-                                    (CmmLoad baseAddr (globalRegType dflags reg))
+                        BaseReg -> baseAddr
+                        _other  -> CmmLoad baseAddr (globalRegType dflags reg)
 
         CmmRegOff (CmmGlobal reg) offset ->
             -- RegOf leaves are just a shorthand form. If the reg maps
@@ -165,12 +178,9 @@ fixStgRegExpr dflags expr
             -- expand it and defer to the above code.
             case reg `elem` activeStgRegs platform of
                 True  -> expr
-                False -> fixStgRegExpr dflags (CmmMachOp (MO_Add (wordWidth dflags)) [
-                                    CmmReg (CmmGlobal reg),
+                False -> CmmMachOp (MO_Add (wordWidth dflags)) [
+                                    fixExpr (CmmReg (CmmGlobal reg)),
                                     CmmLit (CmmInt (fromIntegral offset)
-                                                (wordWidth dflags))])
-
-        -- CmmLit, CmmReg (CmmLocal), CmmStackSlot
-        _other -> expr
-    where platform = targetPlatform dflags
+                                                   (wordWidth dflags))]
 
+        other_expr -> other_expr