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