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