ghc/compiler/absCSyn/AbsCFuns.lhs

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