Cmm back end upgrades

[ghc-hetmet.git] / compiler / cmm / Cmm.hs

diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index 24542e1..2d13c45 100644 (file)
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -1,7 +1,3 @@
-{-# OPTIONS -fno-warn-name-shadowing -w #-}
--- We'd like to use -fno-warn-orphans rather than -w, but old compilers
--- don't understand it so building stage1 fails.
-
 -----------------------------------------------------------------------------
 --
 -- Cmm data types
@@ -20,26 +16,19 @@ module Cmm (
         CmmInfoTable(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag,
         GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
         CmmReturnInfo(..),
-       CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals,
+       CmmStmt(..), CmmActual, CmmActuals, CmmFormal, CmmFormals, CmmKind,
+        CmmFormalsWithoutKinds, CmmFormalWithoutKind,
+        CmmKinded(..),
         CmmSafety(..),
        CmmCallTarget(..),
        CmmStatic(..), Section(..),
-       CmmExpr(..), cmmExprRep, maybeInvertCmmExpr,
-       CmmReg(..), cmmRegRep,
-       CmmLit(..), cmmLitRep,
-       LocalReg(..), localRegRep, localRegGCFollow, Kind(..),
-        BlockId(..), freshBlockId,
+        module CmmExpr,
+
+        BlockId(..), mkBlockId,
         BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv,
         BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet,
-       GlobalReg(..), globalRegRep,
-
-       node, nodeReg, spReg, hpReg, spLimReg
   ) where
 
--- ^ In order not to do violence to the import structure of the rest
--- of the compiler, module Cmm re-exports a number of identifiers
--- defined in 'CmmExpr'
-
 #include "HsVersions.h"
 
 import CmmExpr
@@ -53,10 +42,10 @@ import FastString
 
 import Data.Word
 
-import ZipCfg (        BlockId(..), freshBlockId
-              , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv
-              , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet
-              )
+import StackSlot (     BlockId(..), mkBlockId
+                 , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv
+                 , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet
+                 )
 
 -- A [[BlockId]] is a local label.
 -- Local labels must be unique within an entire compilation unit, not
@@ -90,7 +79,8 @@ data GenCmmTop d h g
   = CmmProc    -- A procedure
      h                -- Extra header such as the info table
      CLabel            -- Used to generate both info & entry labels
-     CmmFormals        -- Argument locals live on entry (C-- procedure params)
+     CmmFormalsWithoutKinds -- Argument locals live on entry (C-- procedure params)
+                       -- XXX Odd that there are no kinds, but there you are ---NR
      g                 -- Control-flow graph for the procedure's code
 
   | CmmData    -- Static data
@@ -229,7 +219,7 @@ data CmmStmt
 
   | CmmCall                     -- A call (forign, native or primitive), with 
      CmmCallTarget
-     CmmHintFormals             -- zero or more results
+     CmmFormals                 -- zero or more results
      CmmActuals                         -- zero or more arguments
      CmmSafety                  -- whether to build a continuation
      CmmReturnInfo
@@ -250,16 +240,21 @@ data CmmStmt
   | CmmReturn            -- Return from a native C-- function,
       CmmActuals         -- with these return values.
 
-type CmmActual      = CmmExpr
-type CmmActuals     = [(CmmActual,MachHint)]
-type CmmFormal      = LocalReg
-type CmmHintFormals = [(CmmFormal,MachHint)]
-type CmmFormals     = [CmmFormal]
+type CmmKind   = MachHint
+data CmmKinded a = CmmKinded { kindlessCmm :: a, cmmKind :: CmmKind }
+                         deriving (Eq)
+type CmmActual = CmmKinded CmmExpr
+type CmmFormal = CmmKinded LocalReg
+type CmmActuals = [CmmActual]
+type CmmFormals = [CmmFormal]
+type CmmFormalWithoutKind   = LocalReg
+type CmmFormalsWithoutKinds = [CmmFormalWithoutKind]
+
 data CmmSafety      = CmmUnsafe | CmmSafe C_SRT
 
--- | enable us to fold used registers over 'CmmActuals' and 'CmmHintFormals'
-instance UserOfLocalRegs a => UserOfLocalRegs (a, MachHint) where
-  foldRegsUsed f set (a, _) = foldRegsUsed f set a
+-- | enable us to fold used registers over 'CmmActuals' and 'CmmFormals'
+instance UserOfLocalRegs a => UserOfLocalRegs (CmmKinded a) where
+  foldRegsUsed f set (CmmKinded a _) = foldRegsUsed f set a
 
 instance UserOfLocalRegs CmmStmt where
   foldRegsUsed f set s = stmt s set
@@ -279,6 +274,15 @@ instance UserOfLocalRegs CmmCallTarget where
     foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e
     foldRegsUsed _ set (CmmPrim {})    = set
 
+instance DefinerOfLocalRegs a => DefinerOfLocalRegs (CmmKinded a) where
+  foldRegsDefd f z (CmmKinded x _) = foldRegsDefd f z x
+
+
+--just look like a tuple, since it was a tuple before
+-- ... is that a good idea? --Isaac Dupree
+instance (Outputable a) => Outputable (CmmKinded a) where
+  ppr (CmmKinded a k) = ppr (a, k)
+
 {-
 Discussion
 ~~~~~~~~~~
@@ -334,6 +338,7 @@ data CmmCallTarget
   | CmmPrim            -- Call a "primitive" (eg. sin, cos)
        CallishMachOp           -- These might be implemented as inline
                                -- code by the backend.
+  deriving Eq
 
 -----------------------------------------------------------------------------
 --             Static Data