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