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