ghc/compiler/absCSyn/AbsCUtils.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
   3 %
   4 \section[AbsCUtils]{Help functions for Abstract~C datatype}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module AbsCUtils (
  10         nonemptyAbsC,
  11         mkAbstractCs, mkAbsCStmts,
  12         mkAlgAltsCSwitch,
  13         magicIdPrimRep,
  14         getAmodeRep, amodeCanSurviveGC,
  15         mixedTypeLocn, mixedPtrLocn,
  16         flattenAbsC,
  17         mkAbsCStmtList
  18
  19         -- printing/forcing stuff comes from PprAbsC
  20     ) where
  21
  22 IMP_Ubiq(){-uitous-}
  23
  24 import AbsCSyn
  25
  26 import CLabel           ( mkReturnPtLabel )
  27 import Digraph          ( stronglyConnComp )
  28 import HeapOffs         ( possiblyEqualHeapOffset )
  29 import Id               ( fIRST_TAG, ConTag(..) )
  30 import Literal          ( literalPrimRep, Literal(..) )
  31 import PrimRep          ( getPrimRepSize, PrimRep(..) )
  32 import Unique           ( Unique{-instance Eq-} )
  33 import UniqSupply       ( getUnique, getUniques, splitUniqSupply )
  34 import Util             ( panic )
  35
  36 infixr 9 `thenFlt`
  37 \end{code}
  38
  39 Check if there is any real code in some Abstract~C.  If so, return it
  40 (@Just ...@); otherwise, return @Nothing@.  Don't be too strict!
  41
  42 It returns the "reduced" code in the Just part so that the work of
  43 discarding AbsCNops isn't lost, and so that if the caller uses
  44 the reduced version there's less danger of a big tree of AbsCNops getting
  45 materialised and causing a space leak.
  46
  47 \begin{code}
  48 nonemptyAbsC :: AbstractC -> Maybe AbstractC
  49 nonemptyAbsC  AbsCNop           = Nothing
  50 nonemptyAbsC (AbsCStmts s1 s2)  = case (nonemptyAbsC s1) of
  51                                     Nothing -> nonemptyAbsC s2
  52                                     Just x  -> Just (AbsCStmts x s2)
  53 nonemptyAbsC s@(CSimultaneous c) = case (nonemptyAbsC c) of
  54                                     Nothing -> Nothing
  55                                     Just x  -> Just s
  56 nonemptyAbsC other              = Just other
  57 \end{code}
  58
  59 \begin{code}
  60 mkAbstractCs :: [AbstractC] -> AbstractC
  61 mkAbstractCs [] = AbsCNop
  62 mkAbstractCs cs = foldr1 mkAbsCStmts cs
  63
  64 -- for fiddling around w/ killing off AbsCNops ... (ToDo)
  65 mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
  66 mkAbsCStmts = AbsCStmts
  67
  68 {- Discarded SLPJ June 95; it calls nonemptyAbsC too much!
  69   = case (case (nonemptyAbsC abc2) of
  70             Nothing -> AbsCNop
  71             Just d2 -> d2)      of { abc2b ->
  72
  73     case (nonemptyAbsC abc1) of {
  74       Nothing -> abc2b;
  75       Just d1 -> AbsCStmts d1 abc2b
  76     } }
  77 -}
  78 \end{code}
  79
  80 Get the sho' 'nuff statements out of an @AbstractC@.
  81 \begin{code}
  82 mkAbsCStmtList :: AbstractC -> [AbstractC]
  83
  84 mkAbsCStmtList absC = mkAbsCStmtList' absC []
  85
  86 -- Optimised a la foldr/build!
  87
  88 mkAbsCStmtList'  AbsCNop r = r
  89
  90 mkAbsCStmtList' (AbsCStmts s1 s2) r
  91   = mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
  92
  93 mkAbsCStmtList' s@(CSimultaneous c) r
  94   = if null (mkAbsCStmtList c) then r else s : r
  95
  96 mkAbsCStmtList' other r = other : r
  97 \end{code}
  98
  99 \begin{code}
 100 mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC
 101
 102 mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
 103  = CSwitch scrutinee (adjust tagged_alts) deflt_absc
 104  where
 105    -- Adjust the tags in the switch to start at zero.
 106    -- This is the convention used by primitive ops which return algebraic
 107    -- data types.  Why?  Because for two-constructor types, zero is faster
 108    -- to create and distinguish from 1 than are 1 and 2.
 109
 110    -- We also need to convert to Literals to keep the CSwitch happy
 111    adjust tagged_alts
 112      = [ (MachInt (toInteger (tag - fIRST_TAG)) False{-unsigned-}, abs_c)
 113        | (tag, abs_c) <- tagged_alts ]
 114 \end{code}
 115
 116 %************************************************************************
 117 %*                                                                      *
 118 \subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds}
 119 %*                                                                      *
 120 %************************************************************************
 121
 122 \begin{code}
 123 magicIdPrimRep BaseReg              = PtrRep
 124 magicIdPrimRep StkOReg              = PtrRep
 125 magicIdPrimRep (VanillaReg kind _) = kind
 126 magicIdPrimRep (FloatReg _)         = FloatRep
 127 magicIdPrimRep (DoubleReg _)        = DoubleRep
 128 magicIdPrimRep TagReg               = IntRep
 129 magicIdPrimRep RetReg               = RetRep
 130 magicIdPrimRep SpA                  = PtrRep
 131 magicIdPrimRep SuA                  = PtrRep
 132 magicIdPrimRep SpB                  = PtrRep
 133 magicIdPrimRep SuB                  = PtrRep
 134 magicIdPrimRep Hp                   = PtrRep
 135 magicIdPrimRep HpLim                = PtrRep
 136 magicIdPrimRep LivenessReg          = IntRep
 137 magicIdPrimRep StdUpdRetVecReg      = PtrRep
 138 magicIdPrimRep StkStubReg           = PtrRep
 139 magicIdPrimRep CurCostCentre        = CostCentreRep
 140 magicIdPrimRep VoidReg              = VoidRep
 141 \end{code}
 142
 143 %************************************************************************
 144 %*                                                                      *
 145 \subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
 146 %*                                                                      *
 147 %************************************************************************
 148
 149 See also the return conventions for unboxed things; currently living
 150 in @CgCon@ (next to the constructor return conventions).
 151
 152 ToDo: tiny tweaking may be in order
 153 \begin{code}
 154 getAmodeRep :: CAddrMode -> PrimRep
 155
 156 getAmodeRep (CVal _ kind)                   = kind
 157 getAmodeRep (CAddr _)                       = PtrRep
 158 getAmodeRep (CReg magic_id)                 = magicIdPrimRep magic_id
 159 getAmodeRep (CTemp uniq kind)               = kind
 160 getAmodeRep (CLbl label kind)               = kind
 161 getAmodeRep (CUnVecLbl _ _)                 = PtrRep
 162 getAmodeRep (CCharLike _)                   = PtrRep
 163 getAmodeRep (CIntLike _)                    = PtrRep
 164 getAmodeRep (CString _)             = PtrRep
 165 getAmodeRep (CLit lit)                      = literalPrimRep lit
 166 getAmodeRep (CLitLit _ kind)                = kind
 167 getAmodeRep (COffset _)             = IntRep
 168 getAmodeRep (CCode abs_C)                   = CodePtrRep
 169 getAmodeRep (CLabelledCode label abs_C)    = CodePtrRep
 170 getAmodeRep (CTableEntry _ _ kind)          = kind
 171 getAmodeRep (CMacroExpr kind _ _)           = kind
 172 #ifdef DEBUG
 173 getAmodeRep (CJoinPoint _ _)                = panic "getAmodeRep:CJoinPoint"
 174 getAmodeRep (CCostCentre _ _)               = panic "getAmodeRep:CCostCentre"
 175 #endif
 176 \end{code}
 177
 178 @amodeCanSurviveGC@ tells, well, whether or not the amode is invariant
 179 across a garbage collection.  Used only for PrimOp arguments (not that
 180 it matters).
 181
 182 \begin{code}
 183 amodeCanSurviveGC :: CAddrMode -> Bool
 184
 185 amodeCanSurviveGC (CTableEntry base offset _)
 186   = amodeCanSurviveGC base && amodeCanSurviveGC offset
 187     -- "Fixed table, so it's OK" (JSM); code is slightly paranoid
 188
 189 amodeCanSurviveGC (CLbl _ _)            = True
 190 amodeCanSurviveGC (CUnVecLbl _ _)       = True
 191 amodeCanSurviveGC (CCharLike arg)       = amodeCanSurviveGC arg
 192 amodeCanSurviveGC (CIntLike arg)        = amodeCanSurviveGC arg
 193 amodeCanSurviveGC (CString _)           = True
 194 amodeCanSurviveGC (CLit _)              = True
 195 amodeCanSurviveGC (CLitLit _ _)         = True
 196 amodeCanSurviveGC (COffset _)           = True
 197 amodeCanSurviveGC (CMacroExpr _ _ args) = all amodeCanSurviveGC args
 198
 199 amodeCanSurviveGC _ = False
 200     -- there are some amodes that "cannot occur" as args
 201     -- to a PrimOp, but it is safe to return False (rather than panic)
 202 \end{code}
 203
 204 @mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
 205 location; that is, one which can contain values of various types.
 206
 207 \begin{code}
 208 mixedTypeLocn :: CAddrMode -> Bool
 209
 210 mixedTypeLocn (CVal (NodeRel _)   _)    = True
 211 mixedTypeLocn (CVal (SpBRel _ _)  _)    = True
 212 mixedTypeLocn (CVal (HpRel _ _)   _)    = True
 213 mixedTypeLocn other                     = False -- All the rest
 214 \end{code}
 215
 216 @mixedPtrLocn@ tells whether an amode identifies a
 217 location which can contain values of various pointer types.
 218
 219 \begin{code}
 220 mixedPtrLocn :: CAddrMode -> Bool
 221
 222 mixedPtrLocn (CVal (SpARel _ _)  _)     = True
 223 mixedPtrLocn other                      = False -- All the rest
 224 \end{code}
 225
 226 %************************************************************************
 227 %*                                                                      *
 228 \subsection[AbsCUtils-flattening]{Flatten Abstract~C}
 229 %*                                                                      *
 230 %************************************************************************
 231
 232 The following bits take ``raw'' Abstract~C, which may have all sorts of
 233 nesting, and flattens it into one long @AbsCStmtList@.  Mainly,
 234 @CClosureInfos@ and code for switches are pulled out to the top level.
 235
 236 The various functions herein tend to produce
 237 \begin{enumerate}
 238 \item
 239 A {\em flattened} \tr{<something>} of interest for ``here'', and
 240 \item
 241 Some {\em unflattened} Abstract~C statements to be carried up to the
 242 top-level.  The only real reason (now) that it is unflattened is
 243 because it means the recursive flattening can be done in just one
 244 place rather than having to remember lots of places.
 245 \end{enumerate}
 246
 247 Care is taken to reduce the occurrence of forward references, while still
 248 keeping laziness a much as possible.  Essentially, this means that:
 249 \begin{itemize}
 250 \item
 251 {\em All} the top-level C statements resulting from flattening a
 252 particular AbsC statement (whether the latter is nested or not) appear
 253 before {\em any} of the code for a subsequent AbsC statement;
 254 \item
 255 but stuff nested within any AbsC statement comes
 256 out before the code for the statement itself.
 257 \end{itemize}
 258
 259 The ``stuff to be carried up'' always includes a label: a
 260 @CStaticClosure@, @CClosureUpdInfo@, @CRetUnVector@, @CFlatRetVector@, or
 261 @CCodeBlock@.  The latter turns into a C function, and is never
 262 actually produced by the code generator.  Rather it always starts life
 263 as a @CLabelledCode@ addressing mode; when such an addr mode is
 264 flattened, the ``tops'' stuff is a @CCodeBlock@.
 265
 266 \begin{code}
 267 flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
 268
 269 flattenAbsC us abs_C
 270   = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
 271     here `mkAbsCStmts` tops }
 272 \end{code}
 273
 274 %************************************************************************
 275 %*                                                                      *
 276 \subsubsection{Flattening monadery}
 277 %*                                                                      *
 278 %************************************************************************
 279
 280 The flattener is monadised.  It's just a @UniqueSupply@, along with a
 281 ``come-back-to-here'' label to pin on heap and stack checks.
 282
 283 \begin{code}
 284 type FlatM result
 285      = CLabel
 286     -> UniqSupply
 287     -> result
 288
 289 initFlt :: UniqSupply -> FlatM a -> a
 290
 291 initFlt init_us m = m (panic "initFlt:CLabel") init_us
 292
 293 {-# INLINE thenFlt #-}
 294 {-# INLINE returnFlt #-}
 295
 296 thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
 297
 298 thenFlt expr cont label us
 299   = case (splitUniqSupply us)   of { (s1, s2) ->
 300     case (expr label s1)        of { result ->
 301     cont result label s2 }}
 302
 303 returnFlt :: a -> FlatM a
 304 returnFlt result label us = result
 305
 306 mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
 307
 308 mapFlt f []     = returnFlt []
 309 mapFlt f (x:xs)
 310   = f x         `thenFlt` \ r  ->
 311     mapFlt f xs `thenFlt` \ rs ->
 312     returnFlt (r:rs)
 313
 314 mapAndUnzipFlt  :: (a -> FlatM (b,c))   -> [a] -> FlatM ([b],[c])
 315
 316 mapAndUnzipFlt f [] = returnFlt ([],[])
 317 mapAndUnzipFlt f (x:xs)
 318   = f x                 `thenFlt` \ (r1,  r2)  ->
 319     mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) ->
 320     returnFlt (r1:rs1, r2:rs2)
 321
 322 getUniqFlt :: FlatM Unique
 323 getUniqFlt label us = getUnique us
 324
 325 getUniqsFlt :: Int -> FlatM [Unique]
 326 getUniqsFlt i label us = getUniques i us
 327
 328 setLabelFlt :: CLabel -> FlatM a -> FlatM a
 329 setLabelFlt new_label cont label us = cont new_label us
 330
 331 getLabelFlt :: FlatM CLabel
 332 getLabelFlt label us = label
 333 \end{code}
 334
 335 %************************************************************************
 336 %*                                                                      *
 337 \subsubsection{Flattening the top level}
 338 %*                                                                      *
 339 %************************************************************************
 340
 341 \begin{code}
 342 flatAbsC :: AbstractC
 343          -> FlatM (AbstractC,           -- Stuff to put inline          [Both are fully
 344                    AbstractC)           -- Stuff to put at top level     flattened]
 345
 346 flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
 347
 348 flatAbsC (AbsCStmts s1 s2)
 349   = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) ->
 350     flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) ->
 351     returnFlt (mkAbsCStmts inline_s1 inline_s2,
 352                mkAbsCStmts top_s1    top_s2)
 353
 354 flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast upd descr liveness)
 355   = flatAbsC slow               `thenFlt` \ (slow_heres, slow_tops) ->
 356     flat_maybe maybe_fast       `thenFlt` \ (fast_heres, fast_tops) ->
 357     flatAmode upd               `thenFlt` \ (upd_lbl,    upd_tops) ->
 358     returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops, upd_tops,
 359        CClosureInfoAndCode cl_info slow_heres fast_heres upd_lbl descr liveness]
 360     )
 361   where
 362     flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
 363     flat_maybe Nothing      = returnFlt (Nothing, AbsCNop)
 364     flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
 365                               returnFlt (Just heres, tops)
 366
 367 flatAbsC (CCodeBlock label abs_C)
 368   = flatAbsC abs_C          `thenFlt` \ (absC_heres, absC_tops) ->
 369     returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock label absC_heres)
 370
 371 flatAbsC (CClosureUpdInfo info) = flatAbsC info
 372
 373 flatAbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
 374   = flatAmodes (cost_centre:amodes)     `thenFlt` \ (new_cc:new_amodes, tops) ->
 375     returnFlt (AbsCNop, tops `mkAbsCStmts`
 376                         CStaticClosure closure_lbl closure_info new_cc new_amodes)
 377
 378 flatAbsC (CRetVector tbl_label stuff deflt)
 379   = do_deflt deflt                              `thenFlt` \ (deflt_amode, deflt_tops) ->
 380     mapAndUnzipFlt (do_alt deflt_amode) stuff   `thenFlt` \ (alt_amodes, alt_tops) ->
 381     returnFlt (AbsCNop, mkAbstractCs [deflt_tops,
 382                                       mkAbstractCs alt_tops,
 383                                       CFlatRetVector tbl_label alt_amodes])
 384
 385   where
 386     do_deflt deflt = case nonemptyAbsC deflt of
 387                         Nothing     -> returnFlt (bogus_default_label, AbsCNop)
 388                         Just deflt' -> flatAmode (CCode deflt)  -- Deals correctly with the
 389                                                                 -- CJump (CLabelledCode ...) case
 390
 391     do_alt deflt_amode Nothing    = returnFlt (deflt_amode, AbsCNop)
 392     do_alt deflt_amode (Just alt) = flatAmode alt
 393
 394     bogus_default_label = panic "flatAbsC: CRetVector: default needed and not available"
 395
 396
 397 flatAbsC (CRetUnVector label amode)
 398   = flatAmode amode     `thenFlt` \ (new_amode, tops) ->
 399     returnFlt (AbsCNop, tops `mkAbsCStmts` CRetUnVector label new_amode)
 400
 401 flatAbsC (CFlatRetVector label amodes)
 402   = flatAmodes amodes   `thenFlt` \ (new_amodes, tops) ->
 403     returnFlt (AbsCNop, tops `mkAbsCStmts` CFlatRetVector label new_amodes)
 404
 405 flatAbsC cc@(CCostCentreDecl _ _)  -- at top, already flat
 406   = returnFlt (AbsCNop, cc)
 407
 408 -- now the real stmts:
 409
 410 flatAbsC (CAssign dest source)
 411   = flatAmode dest    `thenFlt` \ (dest_amode, dest_tops) ->
 412     flatAmode source  `thenFlt` \ (src_amode,  src_tops)  ->
 413     returnFlt ( CAssign dest_amode src_amode, mkAbsCStmts dest_tops src_tops )
 414
 415 -- special case: jump to some anonymous code
 416 flatAbsC (CJump (CCode abs_C)) = flatAbsC abs_C
 417
 418 flatAbsC (CJump target)
 419   = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
 420     returnFlt ( CJump targ_amode, targ_tops )
 421
 422 flatAbsC (CFallThrough target)
 423   = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
 424     returnFlt ( CFallThrough targ_amode, targ_tops )
 425
 426 flatAbsC (CReturn target return_info)
 427   = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
 428     returnFlt ( CReturn targ_amode return_info, targ_tops )
 429
 430 flatAbsC (CSwitch discrim alts deflt)
 431   = flatAmode discrim            `thenFlt` \ (discrim_amode, discrim_tops) ->
 432     mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
 433     flatAbsC deflt               `thenFlt` \ (flat_def_alt, def_tops) ->
 434     returnFlt (
 435       CSwitch discrim_amode flat_alts flat_def_alt,
 436       mkAbstractCs (discrim_tops : def_tops : flat_alts_tops)
 437     )
 438   where
 439     flat_alt (tag, absC)
 440       = flatAbsC absC   `thenFlt` \ (alt_heres, alt_tops) ->
 441         returnFlt ( (tag, alt_heres), alt_tops )
 442
 443 flatAbsC stmt@(CInitHdr a b cc u)
 444   = flatAmode cc        `thenFlt` \ (new_cc, tops) ->
 445     returnFlt (CInitHdr a b new_cc u, tops)
 446
 447 flatAbsC stmt@(COpStmt results op args liveness_mask vol_regs)
 448   = flatAmodes results          `thenFlt` \ (results_here, tops1) ->
 449     flatAmodes args             `thenFlt` \ (args_here,    tops2) ->
 450     returnFlt (COpStmt results_here op args_here liveness_mask vol_regs,
 451                 mkAbsCStmts tops1 tops2)
 452
 453 flatAbsC stmt@(CSimultaneous abs_c)
 454   = flatAbsC abs_c              `thenFlt` \ (stmts_here, tops) ->
 455     doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
 456     returnFlt (new_stmts_here, tops)
 457
 458 flatAbsC stmt@(CMacroStmt macro amodes)
 459   = flatAmodes amodes           `thenFlt` \ (amodes_here, tops) ->
 460     returnFlt (CMacroStmt macro amodes_here, tops)
 461
 462 flatAbsC stmt@(CCallProfCtrMacro str amodes)
 463   = flatAmodes amodes           `thenFlt` \ (amodes_here, tops) ->
 464     returnFlt (CCallProfCtrMacro str amodes_here, tops)
 465
 466 flatAbsC stmt@(CCallProfCCMacro str amodes)
 467   = flatAmodes amodes           `thenFlt` \ (amodes_here, tops) ->
 468     returnFlt (CCallProfCCMacro str amodes_here, tops)
 469
 470 flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
 471 \end{code}
 472
 473 %************************************************************************
 474 %*                                                                      *
 475 \subsection[flat-amodes]{Flattening addressing modes}
 476 %*                                                                      *
 477 %************************************************************************
 478
 479 \begin{code}
 480 flatAmode :: CAddrMode -> FlatM (CAddrMode, AbstractC)
 481
 482 -- easy ones first
 483 flatAmode amode@(CVal _ _)      = returnFlt (amode, AbsCNop)
 484
 485 flatAmode amode@(CAddr _)       = returnFlt (amode, AbsCNop)
 486 flatAmode amode@(CReg _)        = returnFlt (amode, AbsCNop)
 487 flatAmode amode@(CTemp _ _)     = returnFlt (amode, AbsCNop)
 488 flatAmode amode@(CLbl _ _)      = returnFlt (amode, AbsCNop)
 489 flatAmode amode@(CUnVecLbl _ _) = returnFlt (amode, AbsCNop)
 490 flatAmode amode@(CString _)     = returnFlt (amode, AbsCNop)
 491 flatAmode amode@(CLit _)        = returnFlt (amode, AbsCNop)
 492 flatAmode amode@(CLitLit _ _)   = returnFlt (amode, AbsCNop)
 493 flatAmode amode@(COffset _)     = returnFlt (amode, AbsCNop)
 494
 495 -- CIntLike must be a literal -- no flattening
 496 flatAmode amode@(CIntLike int)  = returnFlt(amode, AbsCNop)
 497
 498 -- CCharLike may be arbitrary value -- have to flatten
 499 flatAmode amode@(CCharLike char)
 500   = flatAmode char      `thenFlt` \ (flat_char, tops) ->
 501     returnFlt(CCharLike flat_char, tops)
 502
 503 flatAmode (CJoinPoint _ _) = panic "flatAmode:CJoinPoint"
 504
 505 flatAmode (CLabelledCode label abs_C)
 506   -- Push the code (with this label) to the top level
 507   = flatAbsC abs_C      `thenFlt` \ (body_code, tops) ->
 508     returnFlt (CLbl label CodePtrRep,
 509                tops `mkAbsCStmts` CCodeBlock label body_code)
 510
 511 flatAmode (CCode abs_C)
 512   = case mkAbsCStmtList abs_C of
 513       [CJump amode] -> flatAmode amode  -- Elide redundant labels
 514       _ ->
 515         -- de-anonymous-ise the code and push it (labelled) to the top level
 516         getUniqFlt              `thenFlt` \ new_uniq ->
 517         case (mkReturnPtLabel new_uniq)    of { return_pt_label ->
 518         flatAbsC abs_C  `thenFlt` \ (body_code, tops) ->
 519         returnFlt (
 520             CLbl return_pt_label CodePtrRep,
 521             tops `mkAbsCStmts` CCodeBlock return_pt_label body_code
 522             -- DO NOT TOUCH the stuff sent to the top...
 523         ) }
 524
 525 flatAmode (CTableEntry base index kind)
 526   = flatAmode base      `thenFlt` \ (base_amode, base_tops) ->
 527     flatAmode index     `thenFlt` \ (ix_amode,  ix_tops)  ->
 528     returnFlt ( CTableEntry base_amode ix_amode kind, mkAbsCStmts base_tops ix_tops )
 529
 530 flatAmode (CMacroExpr pk macro amodes)
 531   = flatAmodes amodes           `thenFlt` \ (amodes_here, tops) ->
 532     returnFlt ( CMacroExpr pk macro amodes_here, tops )
 533
 534 flatAmode amode@(CCostCentre _ _) = returnFlt (amode, AbsCNop)
 535 \end{code}
 536
 537 And a convenient way to do a whole bunch of 'em.
 538 \begin{code}
 539 flatAmodes :: [CAddrMode] -> FlatM ([CAddrMode], AbstractC)
 540
 541 flatAmodes [] = returnFlt ([], AbsCNop)
 542
 543 flatAmodes amodes
 544   = mapAndUnzipFlt flatAmode amodes `thenFlt` \ (amodes_here, tops) ->
 545     returnFlt (amodes_here, mkAbstractCs tops)
 546 \end{code}
 547
 548 %************************************************************************
 549 %*                                                                      *
 550 \subsection[flat-simultaneous]{Doing things simultaneously}
 551 %*                                                                      *
 552 %************************************************************************
 553
 554 \begin{code}
 555 doSimultaneously :: AbstractC -> FlatM AbstractC
 556 \end{code}
 557
 558 Generate code to perform the @CAssign@s and @COpStmt@s in the
 559 input simultaneously, using temporary variables when necessary.
 560
 561 We use the strongly-connected component algorithm, in which
 562         * the vertices are the statements
 563         * an edge goes from s1 to s2 iff
 564                 s1 assigns to something s2 uses
 565           that is, if s1 should *follow* s2 in the final order
 566
 567 ADR Comment
 568
 569 Wow - fancy stuff.  But are we ever going to do anything other than
 570 assignments in parallel?  If not, wouldn't it be simpler to generate
 571 the following:
 572
 573  x1, x2, x3 = e1, e2, e3
 574
 575     |
 576     |
 577     V
 578  { int t1 = e1;
 579    int t2 = e2;
 580    int t3 = e3;
 581    x1 = t1;
 582    x2 = t2;
 583    x3 = t3;
 584  }
 585
 586 and leave it to the C compiler to figure out whether it needs al
 587 those variables.
 588
 589 (Likewise, why not let the C compiler delete silly code like
 590
 591     x = x
 592
 593 for us?)
 594
 595 tnemmoC RDA
 596
 597 \begin{code}
 598 type CVertex = (Int, AbstractC)  -- Give each vertex a unique number,
 599                                  -- for fast comparison
 600
 601 type CEdge = (CVertex, CVertex)
 602
 603 doSimultaneously abs_c
 604   = let
 605         enlisted = en_list abs_c
 606     in
 607     case enlisted of -- it's often just one stmt
 608       []  -> returnFlt AbsCNop
 609       [x] -> returnFlt x
 610       _   -> doSimultaneously1 (zip [(1::Int)..] enlisted)
 611
 612 -- en_list puts all the assignments in a list, filtering out Nops and
 613 -- assignments which do nothing
 614 en_list AbsCNop                               = []
 615 en_list (AbsCStmts a1 a2)                     = en_list a1 ++ en_list a2
 616 en_list (CAssign am1 am2) | sameAmode am1 am2 = []
 617 en_list other                                 = [other]
 618
 619 sameAmode :: CAddrMode -> CAddrMode -> Bool
 620 -- ToDo: Move this function, or make CAddrMode an instance of Eq
 621 -- At the moment we put in just enough to catch the cases we want:
 622 --      the second (destination) argument is always a CVal.
 623 sameAmode (CReg r1)                  (CReg r2)               = r1 == r2
 624 sameAmode (CVal (SpARel r1 v1) _) (CVal (SpARel r2 v2) _) = r1 == r2 && v1 == v2
 625 sameAmode (CVal (SpBRel r1 v1) _) (CVal (SpBRel r2 v2) _) = r1 == r2 && v1 == v2
 626 sameAmode other1                     other2                  = False
 627
 628 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
 629 doSimultaneously1 vertices
 630   = let
 631         edges :: [CEdge]
 632         edges = concat (map edges_from vertices)
 633
 634         edges_from :: CVertex -> [CEdge]
 635         edges_from v1 = [(v1,v2) | v2 <- vertices, v1 `should_follow` v2]
 636
 637         should_follow :: CVertex -> CVertex -> Bool
 638         (n1, CAssign dest1 _) `should_follow` (n2, CAssign _ src2)
 639           = dest1 `conflictsWith` src2
 640         (n1, COpStmt dests1 _ _ _ _) `should_follow` (n2, CAssign _ src2)
 641           = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
 642         (n1, CAssign dest1 _)`should_follow` (n2, COpStmt _ _ srcs2 _ _)
 643           = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
 644         (n1, COpStmt dests1 _ _ _ _) `should_follow` (n2, COpStmt _ _ srcs2 _ _)
 645           = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
 646
 647 --      (_, COpStmt _ _ _ _ _) `should_follow` (_, CCallProfCtrMacro _ _) = False
 648 --      (_, CCallProfCtrMacro _ _) `should_follow` (_, COpStmt _ _ _ _ _) = False
 649
 650         eq_vertex :: CVertex -> CVertex -> Bool
 651         (n1, _) `eq_vertex` (n2, _) = n1 == n2
 652
 653         components = stronglyConnComp eq_vertex edges vertices
 654
 655         -- do_components deal with one strongly-connected component
 656         do_component :: [CVertex] -> FlatM AbstractC
 657
 658         -- A singleton?  Then just do it.
 659         do_component [(n,abs_c)] = returnFlt abs_c
 660
 661         -- Two or more?  Then go via temporaries.
 662         do_component ((n,first_stmt):rest)
 663           = doSimultaneously1 rest      `thenFlt` \ abs_cs ->
 664             go_via_temps first_stmt     `thenFlt` \ (to_temps, from_temps) ->
 665             returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
 666
 667         go_via_temps (CAssign dest src)
 668           = getUniqFlt                  `thenFlt` \ uniq ->
 669             let
 670                 the_temp = CTemp uniq (getAmodeRep dest)
 671             in
 672             returnFlt (CAssign the_temp src, CAssign dest the_temp)
 673
 674         go_via_temps (COpStmt dests op srcs liveness_mask vol_regs)
 675           = getUniqsFlt (length dests)  `thenFlt` \ uniqs ->
 676             let
 677                 the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
 678             in
 679             returnFlt (COpStmt the_temps op srcs liveness_mask vol_regs,
 680                        mkAbstractCs (zipWith CAssign dests the_temps))
 681     in
 682     mapFlt do_component components `thenFlt` \ abs_cs ->
 683     returnFlt (mkAbstractCs abs_cs)
 684 \end{code}
 685
 686
 687 @conflictsWith@ tells whether an assignment to its first argument will
 688 screw up an access to its second.
 689
 690 \begin{code}
 691 conflictsWith :: CAddrMode -> CAddrMode -> Bool
 692 (CReg reg1)        `conflictsWith` (CReg reg2)          = reg1 == reg2
 693 (CReg reg)         `conflictsWith` (CVal reg_rel _)     = reg `regConflictsWithRR` reg_rel
 694 (CReg reg)         `conflictsWith` (CAddr reg_rel)      = reg `regConflictsWithRR` reg_rel
 695 (CTemp u1 _)       `conflictsWith` (CTemp u2 _)         = u1 == u2
 696 (CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
 697   = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
 698
 699 other1            `conflictsWith` other2                = False
 700 -- CAddr and literals are impossible on the LHS of an assignment
 701
 702 regConflictsWithRR :: MagicId -> RegRelative -> Bool
 703
 704 regConflictsWithRR (VanillaReg k ILIT(1)) (NodeRel _)   = True
 705
 706 regConflictsWithRR SpA  (SpARel _ _)    = True
 707 regConflictsWithRR SpB  (SpBRel _ _)    = True
 708 regConflictsWithRR Hp   (HpRel _ _)     = True
 709 regConflictsWithRR _    _               = False
 710
 711 rrConflictsWithRR :: Int -> Int                 -- Sizes of two things
 712                   -> RegRelative -> RegRelative -- The two amodes
 713                   -> Bool
 714
 715 rrConflictsWithRR s1 s2 rr1 rr2 = rr rr1 rr2
 716   where
 717     rr (SpARel p1 o1)    (SpARel p2 o2)
 718         | s1 == 0 || s2 == 0 = False    -- No conflict if either is size zero
 719         | s1 == 1 && s2 == 1 = b1 == b2
 720         | otherwise          = (b1+s1) >= b2  &&
 721                                (b2+s2) >= b1
 722         where
 723           b1 = p1-o1
 724           b2 = p2-o2
 725
 726     rr (SpBRel p1 o1)    (SpBRel p2 o2)
 727         | s1 == 0 || s2 == 0 = False    -- No conflict if either is size zero
 728         | s1 == 1 && s2 == 1 = b1 == b2
 729         | otherwise          = (b1+s1) >= b2  &&
 730                                (b2+s2) >= b1
 731         where
 732           b1 = p1-o1
 733           b2 = p2-o2
 734
 735     rr (NodeRel o1)      (NodeRel o2)
 736         | s1 == 0 || s2 == 0 = False    -- No conflict if either is size zero
 737         | s1 == 1 && s2 == 1 = o1 `possiblyEqualHeapOffset` o2
 738         | otherwise          = True             -- Give up
 739
 740     rr (HpRel _ _)       (HpRel _ _)    = True  -- Give up
 741
 742     rr other1            other2         = False
 743 \end{code}