ghc/compiler/absCSyn/AbsCUtils.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[AbsCUtils]{Help functions for Abstract~C datatype}
   5
   6 \begin{code}
   7 module AbsCUtils (
   8         nonemptyAbsC,
   9         mkAbstractCs, mkAbsCStmts,
  10         mkAlgAltsCSwitch,
  11         magicIdPrimRep,
  12         getAmodeRep,
  13         mixedTypeLocn, mixedPtrLocn,
  14         flattenAbsC,
  15         mkAbsCStmtList
  16
  17         -- printing/forcing stuff comes from PprAbsC
  18     ) where
  19
  20 #include "HsVersions.h"
  21
  22 import AbsCSyn
  23 import Digraph          ( stronglyConnComp, SCC(..) )
  24 import DataCon          ( fIRST_TAG, ConTag )
  25 import Literal          ( literalPrimRep, mkMachWord )
  26 import PrimRep          ( getPrimRepSize, PrimRep(..) )
  27 import Unique           ( Unique{-instance Eq-} )
  28 import UniqSupply       ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
  29                           UniqSupply )
  30 import CmdLineOpts      ( opt_EmitCExternDecls )
  31 import PrimOp           ( PrimOp(..), CCall(..), isDynamicTarget )
  32 import Panic            ( panic )
  33 import FastTypes
  34
  35 import Maybe            ( isJust )
  36
  37 infixr 9 `thenFlt`
  38 \end{code}
  39
  40 Check if there is any real code in some Abstract~C.  If so, return it
  41 (@Just ...@); otherwise, return @Nothing@.  Don't be too strict!
  42
  43 It returns the "reduced" code in the Just part so that the work of
  44 discarding AbsCNops isn't lost, and so that if the caller uses
  45 the reduced version there's less danger of a big tree of AbsCNops getting
  46 materialised and causing a space leak.
  47
  48 \begin{code}
  49 nonemptyAbsC :: AbstractC -> Maybe AbstractC
  50 nonemptyAbsC  AbsCNop           = Nothing
  51 nonemptyAbsC (AbsCStmts s1 s2)  = case (nonemptyAbsC s1) of
  52                                     Nothing -> nonemptyAbsC s2
  53                                     Just x  -> Just (AbsCStmts x s2)
  54 nonemptyAbsC s@(CSimultaneous c) = case (nonemptyAbsC c) of
  55                                     Nothing -> Nothing
  56                                     Just x  -> Just s
  57 nonemptyAbsC other              = Just other
  58 \end{code}
  59
  60 \begin{code}
  61 mkAbstractCs :: [AbstractC] -> AbstractC
  62 mkAbstractCs [] = AbsCNop
  63 mkAbstractCs cs = foldr1 mkAbsCStmts cs
  64
  65 -- for fiddling around w/ killing off AbsCNops ... (ToDo)
  66 mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
  67 mkAbsCStmts AbsCNop c = c
  68 mkAbsCStmts c AbsCNop = c
  69 mkAbsCStmts c1 c2     = c1 `AbsCStmts` c2
  70
  71 {- Discarded SLPJ June 95; it calls nonemptyAbsC too much!
  72   = case (case (nonemptyAbsC abc2) of
  73             Nothing -> AbsCNop
  74             Just d2 -> d2)      of { abc2b ->
  75
  76     case (nonemptyAbsC abc1) of {
  77       Nothing -> abc2b;
  78       Just d1 -> AbsCStmts d1 abc2b
  79     } }
  80 -}
  81 \end{code}
  82
  83 Get the sho' 'nuff statements out of an @AbstractC@.
  84 \begin{code}
  85 mkAbsCStmtList :: AbstractC -> [AbstractC]
  86
  87 mkAbsCStmtList absC = mkAbsCStmtList' absC []
  88
  89 -- Optimised a la foldr/build!
  90
  91 mkAbsCStmtList'  AbsCNop r = r
  92
  93 mkAbsCStmtList' (AbsCStmts s1 s2) r
  94   = mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
  95
  96 mkAbsCStmtList' s@(CSimultaneous c) r
  97   = if null (mkAbsCStmtList c) then r else s : r
  98
  99 mkAbsCStmtList' other r = other : r
 100 \end{code}
 101
 102 \begin{code}
 103 mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC
 104
 105 mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
 106  | isJust (nonemptyAbsC deflt_absc)
 107         = CSwitch scrutinee (adjust tagged_alts) deflt_absc
 108  | otherwise
 109         = CSwitch scrutinee (adjust rest) first_alt
 110  where
 111    -- it's ok to convert one of the alts into a default if we don't already have
 112    -- one, because this is an algebraic case and we're guaranteed that the tag
 113    -- will match one of the branches.
 114    ((tag,first_alt):rest) = tagged_alts
 115
 116    -- Adjust the tags in the switch to start at zero.
 117    -- This is the convention used by primitive ops which return algebraic
 118    -- data types.  Why?  Because for two-constructor types, zero is faster
 119    -- to create and distinguish from 1 than are 1 and 2.
 120
 121    -- We also need to convert to Literals to keep the CSwitch happy
 122    adjust tagged_alts
 123      = [ (mkMachWord (toInteger (tag - fIRST_TAG)), abs_c)
 124        | (tag, abs_c) <- tagged_alts ]
 125 \end{code}
 126
 127 %************************************************************************
 128 %*                                                                      *
 129 \subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds}
 130 %*                                                                      *
 131 %************************************************************************
 132
 133 \begin{code}
 134 magicIdPrimRep BaseReg              = PtrRep
 135 magicIdPrimRep (VanillaReg kind _) = kind
 136 magicIdPrimRep (FloatReg _)         = FloatRep
 137 magicIdPrimRep (DoubleReg _)        = DoubleRep
 138 magicIdPrimRep (LongReg kind _)     = kind
 139 magicIdPrimRep Sp                   = PtrRep
 140 magicIdPrimRep Su                   = PtrRep
 141 magicIdPrimRep SpLim                = PtrRep
 142 magicIdPrimRep Hp                   = PtrRep
 143 magicIdPrimRep HpLim                = PtrRep
 144 magicIdPrimRep CurCostCentre        = CostCentreRep
 145 magicIdPrimRep VoidReg              = VoidRep
 146 magicIdPrimRep CurrentTSO           = ThreadIdRep
 147 magicIdPrimRep CurrentNursery       = PtrRep
 148 \end{code}
 149
 150 %************************************************************************
 151 %*                                                                      *
 152 \subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
 153 %*                                                                      *
 154 %************************************************************************
 155
 156 See also the return conventions for unboxed things; currently living
 157 in @CgCon@ (next to the constructor return conventions).
 158
 159 ToDo: tiny tweaking may be in order
 160 \begin{code}
 161 getAmodeRep :: CAddrMode -> PrimRep
 162
 163 getAmodeRep (CVal _ kind)                   = kind
 164 getAmodeRep (CAddr _)                       = PtrRep
 165 getAmodeRep (CReg magic_id)                 = magicIdPrimRep magic_id
 166 getAmodeRep (CTemp uniq kind)               = kind
 167 getAmodeRep (CLbl _ kind)                   = kind
 168 getAmodeRep (CCharLike _)                   = PtrRep
 169 getAmodeRep (CIntLike _)                    = PtrRep
 170 getAmodeRep (CLit lit)                      = literalPrimRep lit
 171 getAmodeRep (CMacroExpr kind _ _)           = kind
 172 getAmodeRep (CJoinPoint _)                  = panic "getAmodeRep:CJoinPoint"
 173 \end{code}
 174
 175 @mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
 176 location; that is, one which can contain values of various types.
 177
 178 \begin{code}
 179 mixedTypeLocn :: CAddrMode -> Bool
 180
 181 mixedTypeLocn (CVal (NodeRel _) _)      = True
 182 mixedTypeLocn (CVal (SpRel _)   _)      = True
 183 mixedTypeLocn (CVal (HpRel _)   _)      = True
 184 mixedTypeLocn other                     = False -- All the rest
 185 \end{code}
 186
 187 @mixedPtrLocn@ tells whether an amode identifies a
 188 location which can contain values of various pointer types.
 189
 190 \begin{code}
 191 mixedPtrLocn :: CAddrMode -> Bool
 192
 193 mixedPtrLocn (CVal (SpRel _)  _)        = True
 194 mixedPtrLocn other                      = False -- All the rest
 195 \end{code}
 196
 197 %************************************************************************
 198 %*                                                                      *
 199 \subsection[AbsCUtils-flattening]{Flatten Abstract~C}
 200 %*                                                                      *
 201 %************************************************************************
 202
 203 The following bits take ``raw'' Abstract~C, which may have all sorts of
 204 nesting, and flattens it into one long @AbsCStmtList@.  Mainly,
 205 @CClosureInfos@ and code for switches are pulled out to the top level.
 206
 207 The various functions herein tend to produce
 208 \begin{enumerate}
 209 \item
 210 A {\em flattened} \tr{<something>} of interest for ``here'', and
 211 \item
 212 Some {\em unflattened} Abstract~C statements to be carried up to the
 213 top-level.  The only real reason (now) that it is unflattened is
 214 because it means the recursive flattening can be done in just one
 215 place rather than having to remember lots of places.
 216 \end{enumerate}
 217
 218 Care is taken to reduce the occurrence of forward references, while still
 219 keeping laziness a much as possible.  Essentially, this means that:
 220 \begin{itemize}
 221 \item
 222 {\em All} the top-level C statements resulting from flattening a
 223 particular AbsC statement (whether the latter is nested or not) appear
 224 before {\em any} of the code for a subsequent AbsC statement;
 225 \item
 226 but stuff nested within any AbsC statement comes
 227 out before the code for the statement itself.
 228 \end{itemize}
 229
 230 The ``stuff to be carried up'' always includes a label: a
 231 @CStaticClosure@, @CRetDirect@, @CFlatRetVector@, or
 232 @CCodeBlock@.  The latter turns into a C function, and is never
 233 actually produced by the code generator.  Rather it always starts life
 234 as a @CCodeBlock@ addressing mode; when such an addr mode is
 235 flattened, the ``tops'' stuff is a @CCodeBlock@.
 236
 237 \begin{code}
 238 flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
 239
 240 flattenAbsC us abs_C
 241   = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
 242     here `mkAbsCStmts` tops }
 243 \end{code}
 244
 245 %************************************************************************
 246 %*                                                                      *
 247 \subsubsection{Flattening monadery}
 248 %*                                                                      *
 249 %************************************************************************
 250
 251 The flattener is monadised.  It's just a @UniqueSupply@.
 252
 253 \begin{code}
 254 type FlatM result =  UniqSupply -> result
 255
 256 initFlt :: UniqSupply -> FlatM a -> a
 257
 258 initFlt init_us m = m init_us
 259
 260 {-# INLINE thenFlt #-}
 261 {-# INLINE returnFlt #-}
 262
 263 thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
 264
 265 thenFlt expr cont us
 266   = case (splitUniqSupply us)   of { (s1, s2) ->
 267     case (expr s1)              of { result ->
 268     cont result s2 }}
 269
 270 returnFlt :: a -> FlatM a
 271 returnFlt result us = result
 272
 273 mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
 274
 275 mapFlt f []     = returnFlt []
 276 mapFlt f (x:xs)
 277   = f x         `thenFlt` \ r  ->
 278     mapFlt f xs `thenFlt` \ rs ->
 279     returnFlt (r:rs)
 280
 281 mapAndUnzipFlt  :: (a -> FlatM (b,c))   -> [a] -> FlatM ([b],[c])
 282
 283 mapAndUnzipFlt f [] = returnFlt ([],[])
 284 mapAndUnzipFlt f (x:xs)
 285   = f x                 `thenFlt` \ (r1,  r2)  ->
 286     mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) ->
 287     returnFlt (r1:rs1, r2:rs2)
 288
 289 getUniqFlt :: FlatM Unique
 290 getUniqFlt us = uniqFromSupply us
 291
 292 getUniqsFlt :: Int -> FlatM [Unique]
 293 getUniqsFlt i us = uniqsFromSupply i us
 294 \end{code}
 295
 296 %************************************************************************
 297 %*                                                                      *
 298 \subsubsection{Flattening the top level}
 299 %*                                                                      *
 300 %************************************************************************
 301
 302 \begin{code}
 303 flatAbsC :: AbstractC
 304          -> FlatM (AbstractC,   -- Stuff to put inline          [Both are fully
 305                    AbstractC)   -- Stuff to put at top level     flattened]
 306
 307 flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
 308
 309 flatAbsC (AbsCStmts s1 s2)
 310   = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) ->
 311     flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) ->
 312     returnFlt (mkAbsCStmts inline_s1 inline_s2,
 313                mkAbsCStmts top_s1    top_s2)
 314
 315 flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast descr)
 316   = flatAbsC slow               `thenFlt` \ (slow_heres, slow_tops) ->
 317     flat_maybe maybe_fast       `thenFlt` \ (fast_heres, fast_tops) ->
 318     returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops,
 319        CClosureInfoAndCode cl_info slow_heres fast_heres descr]
 320     )
 321
 322 flatAbsC (CCodeBlock lbl abs_C)
 323   = flatAbsC abs_C          `thenFlt` \ (absC_heres, absC_tops) ->
 324     returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock lbl absC_heres)
 325
 326 flatAbsC (CRetDirect uniq slow_code srt liveness)
 327   = flatAbsC slow_code          `thenFlt` \ (heres, tops) ->
 328     returnFlt (AbsCNop,
 329                 mkAbstractCs [ tops, CRetDirect uniq heres srt liveness ])
 330
 331 flatAbsC (CSwitch discrim alts deflt)
 332   = mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
 333     flatAbsC deflt               `thenFlt` \ (flat_def_alt, def_tops) ->
 334     returnFlt (
 335       CSwitch discrim flat_alts flat_def_alt,
 336       mkAbstractCs (def_tops : flat_alts_tops)
 337     )
 338   where
 339     flat_alt (tag, absC)
 340       = flatAbsC absC   `thenFlt` \ (alt_heres, alt_tops) ->
 341         returnFlt ( (tag, alt_heres), alt_tops )
 342
 343 flatAbsC stmt@(COpStmt results (CCallOp ccall@(CCall target is_asm _ _)) args vol_regs)
 344   | isCandidate
 345   = returnFlt (stmt, tdef)
 346   | otherwise
 347   = returnFlt (stmt, AbsCNop)
 348   where
 349     isCandidate = is_dynamic || opt_EmitCExternDecls && not is_asm
 350     is_dynamic  = isDynamicTarget target
 351
 352     tdef = CCallTypedef is_dynamic ccall results args
 353
 354 flatAbsC stmt@(CSimultaneous abs_c)
 355   = flatAbsC abs_c              `thenFlt` \ (stmts_here, tops) ->
 356     doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
 357     returnFlt (new_stmts_here, tops)
 358
 359 flatAbsC stmt@(CCheck macro amodes code)
 360   = flatAbsC code               `thenFlt` \ (code_here, code_tops) ->
 361     returnFlt (CCheck macro amodes code_here, code_tops)
 362
 363 -- the TICKY_CTR macro always needs to be hoisted out to the top level.
 364 -- This is a HACK.
 365 flatAbsC stmt@(CCallProfCtrMacro str amodes)
 366   | str == SLIT("TICK_CTR")     = returnFlt (AbsCNop, stmt)
 367   | otherwise                   = returnFlt (stmt, AbsCNop)
 368
 369 -- Some statements need no flattening at all:
 370 flatAbsC stmt@(CMacroStmt macro amodes)         = returnFlt (stmt, AbsCNop)
 371 flatAbsC stmt@(CCallProfCCMacro str amodes)     = returnFlt (stmt, AbsCNop)
 372 flatAbsC stmt@(CAssign dest source)             = returnFlt (stmt, AbsCNop)
 373 flatAbsC stmt@(CJump target)                    = returnFlt (stmt, AbsCNop)
 374 flatAbsC stmt@(CFallThrough target)             = returnFlt (stmt, AbsCNop)
 375 flatAbsC stmt@(CReturn target return_info)      = returnFlt (stmt, AbsCNop)
 376 flatAbsC stmt@(CInitHdr a b cc)                 = returnFlt (stmt, AbsCNop)
 377 flatAbsC stmt@(COpStmt results op args vol_regs)= returnFlt (stmt, AbsCNop)
 378
 379 -- Some statements only make sense at the top level, so we always float
 380 -- them.  This probably isn't necessary.
 381 flatAbsC stmt@(CStaticClosure _ _ _ _)          = returnFlt (AbsCNop, stmt)
 382 flatAbsC stmt@(CClosureTbl _)                   = returnFlt (AbsCNop, stmt)
 383 flatAbsC stmt@(CSRT _ _)                        = returnFlt (AbsCNop, stmt)
 384 flatAbsC stmt@(CBitmap _ _)                     = returnFlt (AbsCNop, stmt)
 385 flatAbsC stmt@(CCostCentreDecl _ _)             = returnFlt (AbsCNop, stmt)
 386 flatAbsC stmt@(CCostCentreStackDecl _)          = returnFlt (AbsCNop, stmt)
 387 flatAbsC stmt@(CSplitMarker)                    = returnFlt (AbsCNop, stmt)
 388 flatAbsC stmt@(CRetVector _ _ _ _)              = returnFlt (AbsCNop, stmt)
 389 flatAbsC stmt@(CModuleInitBlock _ _)            = returnFlt (AbsCNop, stmt)
 390 \end{code}
 391
 392 \begin{code}
 393 flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
 394 flat_maybe Nothing      = returnFlt (Nothing, AbsCNop)
 395 flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
 396                           returnFlt (Just heres, tops)
 397 \end{code}
 398
 399 %************************************************************************
 400 %*                                                                      *
 401 \subsection[flat-simultaneous]{Doing things simultaneously}
 402 %*                                                                      *
 403 %************************************************************************
 404
 405 \begin{code}
 406 doSimultaneously :: AbstractC -> FlatM AbstractC
 407 \end{code}
 408
 409 Generate code to perform the @CAssign@s and @COpStmt@s in the
 410 input simultaneously, using temporary variables when necessary.
 411
 412 We use the strongly-connected component algorithm, in which
 413         * the vertices are the statements
 414         * an edge goes from s1 to s2 iff
 415                 s1 assigns to something s2 uses
 416           that is, if s1 should *follow* s2 in the final order
 417
 418 \begin{code}
 419 type CVertex = (Int, AbstractC)  -- Give each vertex a unique number,
 420                                  -- for fast comparison
 421
 422 type CEdge = (CVertex, CVertex)
 423
 424 doSimultaneously abs_c
 425   = let
 426         enlisted = en_list abs_c
 427     in
 428     case enlisted of -- it's often just one stmt
 429       []  -> returnFlt AbsCNop
 430       [x] -> returnFlt x
 431       _   -> doSimultaneously1 (zip [(1::Int)..] enlisted)
 432
 433 -- en_list puts all the assignments in a list, filtering out Nops and
 434 -- assignments which do nothing
 435 en_list AbsCNop                               = []
 436 en_list (AbsCStmts a1 a2)                     = en_list a1 ++ en_list a2
 437 en_list (CAssign am1 am2) | sameAmode am1 am2 = []
 438 en_list other                                 = [other]
 439
 440 sameAmode :: CAddrMode -> CAddrMode -> Bool
 441 -- ToDo: Move this function, or make CAddrMode an instance of Eq
 442 -- At the moment we put in just enough to catch the cases we want:
 443 --      the second (destination) argument is always a CVal.
 444 sameAmode (CReg r1)                  (CReg r2)               = r1 == r2
 445 sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _)            = r1 ==# r2
 446 sameAmode other1                     other2                  = False
 447
 448 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
 449 doSimultaneously1 vertices
 450   = let
 451         edges = [ (vertex, key1, edges_from stmt1)
 452                 | vertex@(key1, stmt1) <- vertices
 453                 ]
 454         edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
 455                                     stmt1 `should_follow` stmt2
 456                            ]
 457         components = stronglyConnComp edges
 458
 459         -- do_components deal with one strongly-connected component
 460                 -- Not cyclic, or singleton?  Just do it
 461         do_component (AcyclicSCC (n,abs_c))  = returnFlt abs_c
 462         do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c
 463
 464                 -- Cyclic?  Then go via temporaries.  Pick one to
 465                 -- break the loop and try again with the rest.
 466         do_component (CyclicSCC ((n,first_stmt) : rest))
 467           = doSimultaneously1 rest      `thenFlt` \ abs_cs ->
 468             go_via_temps first_stmt     `thenFlt` \ (to_temps, from_temps) ->
 469             returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
 470
 471         go_via_temps (CAssign dest src)
 472           = getUniqFlt                  `thenFlt` \ uniq ->
 473             let
 474                 the_temp = CTemp uniq (getAmodeRep dest)
 475             in
 476             returnFlt (CAssign the_temp src, CAssign dest the_temp)
 477
 478         go_via_temps (COpStmt dests op srcs vol_regs)
 479           = getUniqsFlt (length dests)  `thenFlt` \ uniqs ->
 480             let
 481                 the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
 482             in
 483             returnFlt (COpStmt the_temps op srcs vol_regs,
 484                        mkAbstractCs (zipWith CAssign dests the_temps))
 485     in
 486     mapFlt do_component components `thenFlt` \ abs_cs ->
 487     returnFlt (mkAbstractCs abs_cs)
 488
 489   where
 490     should_follow :: AbstractC -> AbstractC -> Bool
 491     (CAssign dest1 _) `should_follow` (CAssign _ src2)
 492       = dest1 `conflictsWith` src2
 493     (COpStmt dests1 _ _ _) `should_follow` (CAssign _ src2)
 494       = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
 495     (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _)
 496       = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
 497     (COpStmt dests1 _ _ _) `should_follow` (COpStmt _ _ srcs2 _)
 498       = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
 499
 500 --    (COpStmt _ _ _ _ _) `should_follow` (CCallProfCtrMacro _ _) = False
 501 --    (CCallProfCtrMacro _ _) `should_follow` (COpStmt _ _ _ _ _) = False
 502
 503
 504 \end{code}
 505
 506
 507 @conflictsWith@ tells whether an assignment to its first argument will
 508 screw up an access to its second.
 509
 510 \begin{code}
 511 conflictsWith :: CAddrMode -> CAddrMode -> Bool
 512 (CReg reg1)        `conflictsWith` (CReg reg2)          = reg1 == reg2
 513 (CReg reg)         `conflictsWith` (CVal reg_rel _)     = reg `regConflictsWithRR` reg_rel
 514 (CReg reg)         `conflictsWith` (CAddr reg_rel)      = reg `regConflictsWithRR` reg_rel
 515 (CTemp u1 _)       `conflictsWith` (CTemp u2 _)         = u1 == u2
 516 (CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
 517   = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
 518
 519 other1            `conflictsWith` other2                = False
 520 -- CAddr and literals are impossible on the LHS of an assignment
 521
 522 regConflictsWithRR :: MagicId -> RegRelative -> Bool
 523
 524 regConflictsWithRR (VanillaReg k n) (NodeRel _) | n ==# (_ILIT 1)    = True
 525 regConflictsWithRR Sp   (SpRel _)       = True
 526 regConflictsWithRR Hp   (HpRel _)       = True
 527 regConflictsWithRR _    _               = False
 528
 529 rrConflictsWithRR :: Int -> Int                 -- Sizes of two things
 530                   -> RegRelative -> RegRelative -- The two amodes
 531                   -> Bool
 532
 533 rrConflictsWithRR s1b s2b rr1 rr2 = rr rr1 rr2
 534   where
 535     s1 = iUnbox s1b
 536     s2 = iUnbox s2b
 537
 538     rr (SpRel o1)    (SpRel o2)
 539         | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
 540         | s1 ==# (_ILIT 1)  && s2 ==# (_ILIT 1) = o1 ==# o2
 541         | otherwise          = (o1 +# s1) >=# o2  &&
 542                                (o2 +# s2) >=# o1
 543
 544     rr (NodeRel o1)      (NodeRel o2)
 545         | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
 546         | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2
 547         | otherwise          = True             -- Give up
 548
 549     rr (HpRel _)         (HpRel _)    = True    -- Give up (ToDo)
 550
 551     rr other1            other2       = False
 552 \end{code}