diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/cmm/CmmExpr.hs | 147 |
1 files changed, 70 insertions, 77 deletions
diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index e57c6eca4c..186b6bfdc2 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -1,18 +1,11 @@ -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module CmmExpr ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr , CmmReg(..), cmmRegType , CmmLit(..), cmmLitType , LocalReg(..), localRegType , GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg - , VGcPtr(..), vgcFlag -- Temporary! + , VGcPtr(..), vgcFlag -- Temporary! , DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed , RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet @@ -36,7 +29,7 @@ import Data.Set (Set) import qualified Data.Set as Set ----------------------------------------------------------------------------- --- CmmExpr +-- CmmExpr -- An expression. Expressions have no side effects. ----------------------------------------------------------------------------- @@ -48,19 +41,19 @@ data CmmExpr | CmmStackSlot Area {-# UNPACK #-} !Int -- addressing expression of a stack slot | CmmRegOff !CmmReg Int - -- CmmRegOff reg i - -- ** is shorthand only, meaning ** - -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)] - -- where rep = typeWidth (cmmRegType reg) - -instance Eq CmmExpr where -- Equality ignores the types - CmmLit l1 == CmmLit l2 = l1==l2 - CmmLoad e1 _ == CmmLoad e2 _ = e1==e2 - CmmReg r1 == CmmReg r2 = r1==r2 - CmmRegOff r1 i1 == CmmRegOff r2 i2 = r1==r2 && i1==i2 - CmmMachOp op1 es1 == CmmMachOp op2 es2 = op1==op2 && es1==es2 + -- CmmRegOff reg i + -- ** is shorthand only, meaning ** + -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)] + -- where rep = typeWidth (cmmRegType reg) + +instance Eq CmmExpr where -- Equality ignores the types + CmmLit l1 == CmmLit l2 = l1==l2 + CmmLoad e1 _ == CmmLoad e2 _ = e1==e2 + CmmReg r1 == CmmReg r2 = r1==r2 + CmmRegOff r1 i1 == CmmRegOff r2 i2 = r1==r2 && i1==i2 + CmmMachOp op1 es1 == CmmMachOp op2 es2 = op1==op2 && es1==es2 CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2 - _e1 == _e2 = False + _e1 == _e2 = False data CmmReg = CmmLocal {-# UNPACK #-} !LocalReg @@ -75,14 +68,14 @@ data Area -- See Note [Continuation BlockId] in CmmNode. deriving (Eq, Ord) -{- Note [Old Area] +{- 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, + * incoming (overflow) parameters, * outgoing (overflow) parameter to tail calls, - * outgoing (overflow) result values + * outgoing (overflow) result values * the update frame (if any) Its size is the max of all these requirements. On entry, the stack @@ -93,22 +86,22 @@ End of note -} data CmmLit = CmmInt !Integer Width - -- Interpretation: the 2's complement representation of the value - -- is truncated to the specified size. This is easier than trying - -- to keep the value within range, because we don't know whether - -- it will be used as a signed or unsigned value (the CmmType doesn't - -- distinguish between signed & unsigned). + -- Interpretation: the 2's complement representation of the value + -- is truncated to the specified size. This is easier than trying + -- to keep the value within range, because we don't know whether + -- it will be used as a signed or unsigned value (the CmmType doesn't + -- distinguish between signed & unsigned). | CmmFloat Rational Width - | CmmLabel CLabel -- Address of label - | CmmLabelOff CLabel Int -- Address of label + byte offset - + | CmmLabel CLabel -- Address of label + | CmmLabelOff CLabel Int -- Address of label + byte offset + -- Due to limitations in the C backend, the following -- MUST ONLY be used inside the info table indicated by label2 -- (label2 must be the info label), and label1 must be an -- SRT, a slow entrypoint or a large bitmap (see the Mangler) -- Don't use it at all unless tablesNextToCode. -- It is also used inside the NCG during when generating - -- position-independent code. + -- position-independent code. | CmmLabelDiffOff CLabel CLabel Int -- label1 - label2 + offset | CmmBlock {-# UNPACK #-} !BlockId -- Code label @@ -119,9 +112,9 @@ data CmmLit deriving Eq cmmExprType :: CmmExpr -> CmmType -cmmExprType (CmmLit lit) = cmmLitType lit -cmmExprType (CmmLoad _ rep) = rep -cmmExprType (CmmReg reg) = cmmRegType reg +cmmExprType (CmmLit lit) = cmmLitType lit +cmmExprType (CmmLoad _ rep) = rep +cmmExprType (CmmReg reg) = cmmRegType reg cmmExprType (CmmMachOp op args) = machOpResultType op (map cmmExprType args) cmmExprType (CmmRegOff reg _) = cmmRegType reg cmmExprType (CmmStackSlot _ _) = bWord -- an address @@ -131,15 +124,15 @@ cmmExprType (CmmStackSlot _ _) = bWord -- an address cmmLitType :: CmmLit -> CmmType cmmLitType (CmmInt _ width) = cmmBits width cmmLitType (CmmFloat _ width) = cmmFloat width -cmmLitType (CmmLabel lbl) = cmmLabelType lbl +cmmLitType (CmmLabel lbl) = cmmLabelType lbl cmmLitType (CmmLabelOff lbl _) = cmmLabelType lbl cmmLitType (CmmLabelDiffOff {}) = bWord -cmmLitType (CmmBlock _) = bWord +cmmLitType (CmmBlock _) = bWord cmmLitType (CmmHighStackMark) = bWord cmmLabelType :: CLabel -> CmmType cmmLabelType lbl | isGcPtrLabel lbl = gcWord - | otherwise = bWord + | otherwise = bWord cmmExprWidth :: CmmExpr -> Width cmmExprWidth e = typeWidth (cmmExprType e) @@ -153,7 +146,7 @@ maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op maybeInvertCmmExpr _ = Nothing ----------------------------------------------------------------------------- --- Local registers +-- Local registers ----------------------------------------------------------------------------- data LocalReg @@ -172,14 +165,14 @@ instance Uniquable LocalReg where getUnique (LocalReg uniq _) = uniq cmmRegType :: CmmReg -> CmmType -cmmRegType (CmmLocal reg) = localRegType reg -cmmRegType (CmmGlobal reg) = globalRegType reg +cmmRegType (CmmLocal reg) = localRegType reg +cmmRegType (CmmGlobal reg) = globalRegType reg localRegType :: LocalReg -> CmmType localRegType (LocalReg _ rep) = rep ----------------------------------------------------------------------------- --- Register-use information for expressions and other types +-- Register-use information for expressions and other types ----------------------------------------------------------------------------- -- | Sets of local registers @@ -270,58 +263,58 @@ instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where -- Another reg utility regUsedIn :: CmmReg -> CmmExpr -> Bool -_ `regUsedIn` CmmLit _ = False -reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e -reg `regUsedIn` CmmReg reg' = reg == reg' +_ `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 ----------------------------------------------------------------------------- --- Global STG registers +-- Global STG registers ----------------------------------------------------------------------------- data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show ) - -- TEMPORARY!!! + -- TEMPORARY!!! ----------------------------------------------------------------------------- --- Global STG registers +-- Global STG registers ----------------------------------------------------------------------------- vgcFlag :: CmmType -> VGcPtr vgcFlag ty | isGcPtrType ty = VGcPtr - | otherwise = VNonGcPtr + | otherwise = VNonGcPtr data GlobalReg -- Argument and return registers - = VanillaReg -- pointers, unboxed ints and chars - {-# UNPACK #-} !Int -- its number - VGcPtr + = VanillaReg -- pointers, unboxed ints and chars + {-# UNPACK #-} !Int -- its number + VGcPtr - | FloatReg -- single-precision floating-point registers - {-# UNPACK #-} !Int -- its number + | FloatReg -- single-precision floating-point registers + {-# UNPACK #-} !Int -- its number - | DoubleReg -- double-precision floating-point registers - {-# UNPACK #-} !Int -- its number + | DoubleReg -- double-precision floating-point registers + {-# UNPACK #-} !Int -- its number - | LongReg -- long int registers (64-bit, really) - {-# UNPACK #-} !Int -- its number + | LongReg -- long int registers (64-bit, really) + {-# UNPACK #-} !Int -- its number -- STG registers - | Sp -- Stack ptr; points to last occupied stack location. - | SpLim -- Stack limit - | Hp -- Heap ptr; points to last occupied heap location. - | HpLim -- Heap limit register + | Sp -- Stack ptr; points to last occupied stack location. + | SpLim -- Stack limit + | Hp -- Heap ptr; points to last occupied heap location. + | HpLim -- Heap limit register | CCCS -- Current cost-centre stack | CurrentTSO -- pointer to current thread's TSO - | CurrentNursery -- pointer to allocation area - | HpAlloc -- allocation count for heap check failure + | CurrentNursery -- pointer to allocation area + | HpAlloc -- allocation count for heap check failure - -- We keep the address of some commonly-called - -- functions in the register table, to keep code - -- size down: + -- We keep the address of some commonly-called + -- functions in the register table, to keep code + -- size down: | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info - | GCEnter1 -- stg_gc_enter_1 - | GCFun -- stg_gc_fun + | GCEnter1 -- stg_gc_enter_1 + | GCFun -- stg_gc_fun -- Base offset for the register table, used for accessing registers -- which do not have real registers assigned to them. This register @@ -337,7 +330,7 @@ data GlobalReg deriving( Show ) instance Eq GlobalReg where - VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes + VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes FloatReg i == FloatReg j = i==j DoubleReg i == DoubleReg j = i==j LongReg i == LongReg j = i==j @@ -422,9 +415,9 @@ node = VanillaReg 1 VGcPtr globalRegType :: GlobalReg -> CmmType globalRegType (VanillaReg _ VGcPtr) = gcWord globalRegType (VanillaReg _ VNonGcPtr) = bWord -globalRegType (FloatReg _) = cmmFloat W32 -globalRegType (DoubleReg _) = cmmFloat W64 -globalRegType (LongReg _) = cmmBits W64 -globalRegType Hp = gcWord -- The initialiser for all - -- dynamically allocated closures -globalRegType _ = bWord +globalRegType (FloatReg _) = cmmFloat W32 +globalRegType (DoubleReg _) = cmmFloat W64 +globalRegType (LongReg _) = cmmBits W64 +globalRegType Hp = gcWord -- The initialiser for all + -- dynamically allocated closures +globalRegType _ = bWord |