X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmExpr.hs;h=8a5bab1f6cc75d91aac2b281634b337359fd9853;hp=5893843a208fbd976576b2beea6974ea136a902b;hb=edc0bafd3fcd01b85a2e8894e5dfe149eb0e0857;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69

diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs
index 5893843..8a5bab1 100644
--- a/compiler/cmm/CmmExpr.hs
+++ b/compiler/cmm/CmmExpr.hs
@@ -1,15 +1,16 @@
 
 module CmmExpr
     ( CmmType	-- Abstract 
- 	  , b8, b16, b32, b64, f32, f64, bWord, bHalfWord, gcWord
- 	  , cInt, cLong
- 	  , cmmBits, cmmFloat
- 	  , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood
- 	  , isFloatType, isGcPtrType, isWord32, isWord64, isFloat64, isFloat32
+    , b8, b16, b32, b64, f32, f64, bWord, bHalfWord, gcWord
+    , cInt, cLong
+    , cmmBits, cmmFloat
+    , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood
+    , isFloatType, isGcPtrType, isWord32, isWord64, isFloat64, isFloat32
  
     , Width(..)
- 	  , widthInBits, widthInBytes, widthInLog
- 	  , wordWidth, halfWordWidth, cIntWidth, cLongWidth
+    , widthInBits, widthInBytes, widthInLog, widthFromBytes
+    , wordWidth, halfWordWidth, cIntWidth, cLongWidth
+    , narrowU, narrowS
  
     , CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
     , CmmReg(..), cmmRegType
@@ -21,7 +22,8 @@ module CmmExpr
     , DefinerOfSlots, UserOfSlots, foldSlotsDefd, foldSlotsUsed
     , RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
             , plusRegSet, minusRegSet, timesRegSet
-    , Area(..), AreaId(..), SubArea, StackSlotMap, getSlot
+    , regUsedIn
+    , Area(..), AreaId(..), SubArea, SubAreaSet, AreaMap, isStackSlotOf
  
    -- MachOp
     , MachOp(..) 
@@ -47,14 +49,14 @@ import BlockId
 import CLabel
 import Constants
 import FastString
-import FiniteMap
-import Maybes
-import Monad
 import Outputable
-import Panic
 import Unique
 import UniqSet
 
+import Data.Word
+import Data.Int
+import Data.Map (Map)
+
 -----------------------------------------------------------------------------
 --		CmmExpr
 -- An expression.  Expressions have no side effects.
@@ -94,11 +96,32 @@ data Area
   deriving (Eq, Ord)
 
 data AreaId
-  = Old -- entry parameters, jumps, and returns share one call area at old end of stack
+  = Old            -- See Note [Old Area]
   | Young BlockId
   deriving (Eq, Ord)
 
-type SubArea = (Area, Int, Int) -- area, offset, width
+{- Note [Old Area] 
+~~~~~~~~~~~~~~~~~~
+There is a single call area 'Old', allocated at the extreme old
+end of the stack frame (ie just younger than the return address)
+which holds:
+  * incoming (overflow) parameters, 
+  * outgoing (overflow) parameter to tail calls,
+  * outgoing (overflow) result values 
+  * the update frame (if any)
+
+Its size is the max of all these requirements.  On entry, the stack
+pointer will point to the youngest incoming parameter, which is not
+necessarily at the young end of the Old area.
+
+End of note -}
+
+type SubArea    = (Area, Int, Int) -- area, offset, width
+type SubAreaSet = Map Area [SubArea]
+
+type AreaMap    = Map Area Int
+     -- Byte offset of the oldest byte of the Area, 
+     -- relative to the oldest byte of the Old Area
 
 data CmmLit
   = CmmInt Integer  Width
@@ -119,6 +142,8 @@ data CmmLit
         -- It is also used inside the NCG during when generating
         -- position-independent code. 
   | CmmLabelDiffOff CLabel CLabel Int   -- label1 - label2 + offset
+  | CmmBlock BlockId			-- Code label
+  | CmmHighStackMark -- stands for the max stack space used during a procedure
   deriving Eq
 
 cmmExprType :: CmmExpr -> CmmType
@@ -135,6 +160,8 @@ cmmLitType (CmmFloat _ width)   = cmmFloat width
 cmmLitType (CmmLabel lbl) 	= cmmLabelType lbl
 cmmLitType (CmmLabelOff lbl _)  = cmmLabelType lbl
 cmmLitType (CmmLabelDiffOff {}) = bWord
+cmmLitType (CmmBlock _) 	= bWord
+cmmLitType (CmmHighStackMark)   = bWord
 
 cmmLabelType :: CLabel -> CmmType
 cmmLabelType lbl | isGcPtrLabel lbl = gcWord
@@ -244,28 +271,33 @@ instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where
   foldRegsDefd _ set [] = set
   foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs
 
+instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where
+  foldRegsDefd _ set Nothing  = set
+  foldRegsDefd f set (Just x) = foldRegsDefd f set x
+
+-----------------------------------------------------------------------------
+-- Another reg utility
+
+regUsedIn :: CmmReg -> CmmExpr -> Bool
+_   `regUsedIn` CmmLit _ 	 = False
+reg `regUsedIn` CmmLoad e  _ 	 = reg `regUsedIn` e
+reg `regUsedIn` CmmReg reg' 	 = reg == reg'
+reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
+reg `regUsedIn` CmmMachOp _ es   = any (reg `regUsedIn`) es
+_   `regUsedIn` CmmStackSlot _ _ = False
 
 -----------------------------------------------------------------------------
 --    Stack slots
 -----------------------------------------------------------------------------
 
-mkVarSlot :: LocalReg -> CmmExpr
-mkVarSlot r = CmmStackSlot (RegSlot r) 0
-
--- Usually, we either want to lookup a variable's spill slot in an environment
--- or else allocate it and add it to the environment.
--- For a variable, we just need a single area of the appropriate size.
-type StackSlotMap = FiniteMap LocalReg CmmExpr
-getSlot :: StackSlotMap -> LocalReg -> (StackSlotMap, CmmExpr)
-getSlot map r = case lookupFM map r of
-                  Just s  -> (map, s)
-                  Nothing -> (addToFM map r s, s) where s = mkVarSlot r
+isStackSlotOf :: CmmExpr -> LocalReg -> Bool
+isStackSlotOf (CmmStackSlot (RegSlot r) _) r' = r == r'
+isStackSlotOf _ _ = False
 
 -----------------------------------------------------------------------------
 --    Stack slot use information for expressions and other types [_$_]
 -----------------------------------------------------------------------------
 
-
 -- Fold over the area, the offset into the area, and the width of the subarea.
 class UserOfSlots a where
   foldSlotsUsed :: (b -> SubArea -> b) -> b -> a -> b
@@ -377,6 +409,7 @@ instance Ord GlobalReg where
    compare CurrentTSO CurrentTSO = EQ
    compare CurrentNursery CurrentNursery = EQ
    compare HpAlloc HpAlloc = EQ
+   compare EagerBlackholeInfo EagerBlackholeInfo = EQ
    compare GCEnter1 GCEnter1 = EQ
    compare GCFun GCFun = EQ
    compare BaseReg BaseReg = EQ
@@ -409,6 +442,8 @@ instance Ord GlobalReg where
    compare _ GCFun = GT
    compare BaseReg _ = LT
    compare _ BaseReg = GT
+   compare EagerBlackholeInfo _ = LT
+   compare _ EagerBlackholeInfo = GT
 
 -- convenient aliases
 spReg, hpReg, spLimReg, nodeReg :: CmmReg
@@ -605,6 +640,15 @@ widthInBytes W64  = 8
 widthInBytes W128 = 16
 widthInBytes W80  = 10
 
+widthFromBytes :: Int -> Width
+widthFromBytes 1  = W8
+widthFromBytes 2  = W16
+widthFromBytes 4  = W32
+widthFromBytes 8  = W64
+widthFromBytes 16 = W128
+widthFromBytes 10 = W80
+widthFromBytes n  = pprPanic "no width for given number of bytes" (ppr n)
+
 -- log_2 of the width in bytes, useful for generating shifts.
 widthInLog :: Width -> Int
 widthInLog W8   = 0
@@ -614,6 +658,21 @@ widthInLog W64  = 3
 widthInLog W128 = 4
 widthInLog W80  = panic "widthInLog: F80"
 
+-- widening / narrowing
+
+narrowU :: Width -> Integer -> Integer
+narrowU W8  x = fromIntegral (fromIntegral x :: Word8)
+narrowU W16 x = fromIntegral (fromIntegral x :: Word16)
+narrowU W32 x = fromIntegral (fromIntegral x :: Word32)
+narrowU W64 x = fromIntegral (fromIntegral x :: Word64)
+narrowU _ _ = panic "narrowTo"
+
+narrowS :: Width -> Integer -> Integer
+narrowS W8  x = fromIntegral (fromIntegral x :: Int8)
+narrowS W16 x = fromIntegral (fromIntegral x :: Int16)
+narrowS W32 x = fromIntegral (fromIntegral x :: Int32)
+narrowS W64 x = fromIntegral (fromIntegral x :: Int64)
+narrowS _ _ = panic "narrowTo"
 
 -----------------------------------------------------------------------------
 --    		MachOp