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