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