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