CmmNode.hs 23.5 KB
Newer Older
1 2
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExplicitForAll #-}
3
{-# LANGUAGE FlexibleContexts #-}
4
{-# LANGUAGE FlexibleInstances #-}
5
{-# LANGUAGE GADTs #-}
6
{-# LANGUAGE MultiParamTypeClasses #-}
Gabor Greif's avatar
Gabor Greif committed
7
{-# LANGUAGE StandaloneDeriving #-}
8
{-# LANGUAGE UndecidableInstances #-}
Simon Marlow's avatar
Simon Marlow committed
9

10 11
-- CmmNode type for representation using Hoopl graphs.

12
module CmmNode (
Peter Wortmann's avatar
Peter Wortmann committed
13
     CmmNode(..), CmmFormal, CmmActual, CmmTickish,
14 15
     UpdFrameOffset, Convention(..),
     ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
16
     CmmReturnInfo(..),
17
     mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
Simon Marlow's avatar
Simon Marlow committed
18
     mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors
19
  ) where
20

21
import CodeGen.Platform
22
import CmmExpr
23
import DynFlags
24 25 26
import FastString
import ForeignCall
import SMRep
Peter Wortmann's avatar
Peter Wortmann committed
27
import CoreSyn (Tickish)
28 29 30

import Compiler.Hoopl
import Data.Maybe
31
import Data.List (tails)
32 33 34 35 36 37
import Prelude hiding (succ)


------------------------
-- CmmNode

Simon Marlow's avatar
Simon Marlow committed
38 39
#define ULabel {-# UNPACK #-} !Label

40
data CmmNode e x where
Simon Marlow's avatar
Simon Marlow committed
41
  CmmEntry :: ULabel -> CmmNode C O
Simon Peyton Jones's avatar
Simon Peyton Jones committed
42

43
  CmmComment :: FastString -> CmmNode O O
Simon Peyton Jones's avatar
Simon Peyton Jones committed
44

Peter Wortmann's avatar
Peter Wortmann committed
45 46 47 48
    -- Tick annotation, covering Cmm code in our tick scope. We only
    -- expect non-code @Tickish@ at this point (e.g. @SourceNote@).
  CmmTick :: !CmmTickish -> CmmNode O O

Simon Marlow's avatar
Simon Marlow committed
49
  CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
Simon Marlow's avatar
Simon Marlow committed
50
    -- Assign to register
Simon Peyton Jones's avatar
Simon Peyton Jones committed
51

Simon Marlow's avatar
Simon Marlow committed
52
  CmmStore :: !CmmExpr -> !CmmExpr -> CmmNode O O
Simon Marlow's avatar
Simon Marlow committed
53 54
    -- Assign to memory location.  Size is
    -- given by cmmExprType of the rhs.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
55

56 57 58 59 60 61 62
  CmmUnsafeForeignCall ::       -- An unsafe foreign call;
                                -- see Note [Foreign calls]
                                -- Like a "fat machine instruction"; can occur
                                -- in the middle of a block
      ForeignTarget ->          -- call target
      [CmmFormal] ->            -- zero or more results
      [CmmActual] ->            -- zero or more arguments
63
      CmmNode O O
64
      -- Semantics: clobbers any GlobalRegs for which callerSaves r == True
65
      -- See Note [Unsafe foreign calls clobber caller-save registers]
66
      --
Simon Marlow's avatar
Simon Marlow committed
67 68 69
      -- Invariant: the arguments and the ForeignTarget must not
      -- mention any registers for which CodeGen.Platform.callerSaves
      -- is True.  See Note [Register Parameter Passing].
Simon Peyton Jones's avatar
Simon Peyton Jones committed
70

Simon Marlow's avatar
Simon Marlow committed
71 72
  CmmBranch :: ULabel -> CmmNode O C
                                   -- Goto another block in the same procedure
Simon Peyton Jones's avatar
Simon Peyton Jones committed
73

74 75
  CmmCondBranch :: {                 -- conditional branch
      cml_pred :: CmmExpr,
Simon Marlow's avatar
Simon Marlow committed
76
      cml_true, cml_false :: ULabel
77
  } -> CmmNode O C
Simon Peyton Jones's avatar
Simon Peyton Jones committed
78

79 80 81 82 83
  CmmSwitch :: CmmExpr -> [Maybe Label] -> CmmNode O C -- Table branch
      -- The scrutinee is zero-based;
      --      zero -> first block
      --      one  -> second block etc
      -- Undefined outside range, and when there's a Nothing
Simon Peyton Jones's avatar
Simon Peyton Jones committed
84 85

  CmmCall :: {                -- A native call or tail call
86 87 88 89
      cml_target :: CmmExpr,  -- never a CmmPrim to a CallishMachOp!

      cml_cont :: Maybe Label,
          -- Label of continuation (Nothing for return or tail call)
90 91 92 93 94
          --
          -- Note [Continuation BlockId]: these BlockIds are called
          -- Continuation BlockIds, and are the only BlockIds that can
          -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or
          -- (CmmStackSlot (Young b) _).
95

96 97 98 99 100 101 102 103
      cml_args_regs :: [GlobalReg],
          -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed
          -- to the call.  This is essential information for the
          -- native code generator's register allocator; without
          -- knowing which GlobalRegs are live it has to assume that
          -- they are all live.  This list should only include
          -- GlobalRegs that are mapped to real machine registers on
          -- the target platform.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
104

105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
      cml_args :: ByteOff,
          -- Byte offset, from the *old* end of the Area associated with
          -- the Label (if cml_cont = Nothing, then Old area), of
          -- youngest outgoing arg.  Set the stack pointer to this before
          -- transferring control.
          -- (NB: an update frame might also have been stored in the Old
          --      area, but it'll be in an older part than the args.)

      cml_ret_args :: ByteOff,
          -- For calls *only*, the byte offset for youngest returned value
          -- This is really needed at the *return* point rather than here
          -- at the call, but in practice it's convenient to record it here.

      cml_ret_off :: ByteOff
        -- For calls *only*, the byte offset of the base of the frame that
        -- must be described by the info table for the return point.
        -- The older words are an update frames, which have their own
        -- info-table and layout information

        -- From a liveness point of view, the stack words older than
        -- cml_ret_off are treated as live, even if the sequel of
        -- the call goes into a loop.
  } -> CmmNode O C
Simon Peyton Jones's avatar
Simon Peyton Jones committed
128

129
  CmmForeignCall :: {           -- A safe foreign call; see Note [Foreign calls]
130
                                -- Always the last node of a block
131
      tgt   :: ForeignTarget,   -- call target and convention
132 133
      res   :: [CmmFormal],     -- zero or more results
      args  :: [CmmActual],     -- zero or more arguments; see Note [Register parameter passing]
Simon Marlow's avatar
Simon Marlow committed
134
      succ  :: ULabel,          -- Label of continuation
135 136
      ret_args :: ByteOff,      -- same as cml_ret_args
      ret_off :: ByteOff,       -- same as cml_ret_off
137 138 139 140 141
      intrbl:: Bool             -- whether or not the call is interruptible
  } -> CmmNode O C

{- Note [Foreign calls]
~~~~~~~~~~~~~~~~~~~~~~~
Simon Peyton Jones's avatar
Simon Peyton Jones committed
142 143
A CmmUnsafeForeignCall is used for *unsafe* foreign calls;
a CmmForeignCall call is used for *safe* foreign calls.
144 145 146 147 148

Unsafe ones are mostly easy: think of them as a "fat machine
instruction".  In particular, they do *not* kill all live registers,
just the registers they return to (there was a bit of code in GHC that
conservatively assumed otherwise.)  However, see [Register parameter passing].
149

150
Safe ones are trickier.  A safe foreign call
151 152
     r = f(x)
ultimately expands to
153 154
     push "return address"      -- Never used to return to;
                                -- just points an info table
155 156
     save registers into TSO
     call suspendThread
157
     r = f(x)                   -- Make the call
158 159 160 161 162 163 164
     call resumeThread
     restore registers
     pop "return address"
We cannot "lower" a safe foreign call to this sequence of Cmms, because
after we've saved Sp all the Cmm optimiser's assumptions are broken.

Note that a safe foreign call needs an info table.
165 166 167 168 169 170

So Safe Foreign Calls must remain as last nodes until the stack is
made manifest in CmmLayoutStack, where they are lowered into the above
sequence.
-}

171 172
{- Note [Unsafe foreign calls clobber caller-save registers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
173 174 175 176 177 178 179 180 181 182 183 184 185 186 187

A foreign call is defined to clobber any GlobalRegs that are mapped to
caller-saves machine registers (according to the prevailing C ABI).
StgCmmUtils.callerSaves tells you which GlobalRegs are caller-saves.

This is a design choice that makes it easier to generate code later.
We could instead choose to say that foreign calls do *not* clobber
caller-saves regs, but then we would have to figure out which regs
were live across the call later and insert some saves/restores.

Furthermore when we generate code we never have any GlobalRegs live
across a call, because they are always copied-in to LocalRegs and
copied-out again before making a call/jump.  So all we have to do is
avoid any code motion that would make a caller-saves GlobalReg live
across a foreign call during subsequent optimisations.
188 189
-}

190 191 192 193 194 195 196 197 198 199 200 201 202 203 204
{- Note [Register parameter passing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On certain architectures, some registers are utilized for parameter
passing in the C calling convention.  For example, in x86-64 Linux
convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for
argument passing.  These are registers R3-R6, which our generated
code may also be using; as a result, it's necessary to save these
values before doing a foreign call.  This is done during initial
code generation in callerSaveVolatileRegs in StgCmmUtils.hs.  However,
one result of doing this is that the contents of these registers
may mysteriously change if referenced inside the arguments.  This
is dangerous, so you'll need to disable inlining much in the same
way is done in cmm/CmmOpt.hs currently.  We should fix this!
-}

205 206
---------------------------------------------
-- Eq instance of CmmNode
Gabor Greif's avatar
Gabor Greif committed
207 208

deriving instance Eq (CmmNode e x)
209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225

----------------------------------------------
-- Hoopl instances of CmmNode

instance NonLocal CmmNode where
  entryLabel (CmmEntry l) = l

  successors (CmmBranch l) = [l]
  successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
  successors (CmmSwitch _ ls) = catMaybes ls
  successors (CmmCall {cml_cont=l}) = maybeToList l
  successors (CmmForeignCall {succ=l}) = [l]


--------------------------------------------------
-- Various helper types

226 227 228
type CmmActual = CmmExpr
type CmmFormal = LocalReg

229 230
type UpdFrameOffset = ByteOff

231 232
-- | A convention maps a list of values (function arguments or return
-- values) to registers or stack locations.
233
data Convention
234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255
  = NativeDirectCall
       -- ^ top-level Haskell functions use @NativeDirectCall@, which
       -- maps arguments to registers starting with R2, according to
       -- how many registers are available on the platform.  This
       -- convention ignores R1, because for a top-level function call
       -- the function closure is implicit, and doesn't need to be passed.
  | NativeNodeCall
       -- ^ non-top-level Haskell functions, which pass the address of
       -- the function closure in R1 (regardless of whether R1 is a
       -- real register or not), and the rest of the arguments in
       -- registers or on the stack.
  | NativeReturn
       -- ^ a native return.  The convention for returns depends on
       -- how many values are returned: for just one value returned,
       -- the appropriate register is used (R1, F1, etc.). regardless
       -- of whether it is a real register or not.  For multiple
       -- values returned, they are mapped to registers or the stack.
  | Slow
       -- ^ Slow entry points: all args pushed on the stack
  | GC
       -- ^ Entry to the garbage collector: uses the node reg!
       -- (TODO: I don't think we need this --SDM)
256 257 258 259 260 261 262
  deriving( Eq )

data ForeignConvention
  = ForeignConvention
        CCallConv               -- Which foreign-call convention
        [ForeignHint]           -- Extra info about the args
        [ForeignHint]           -- Extra info about the result
263
        CmmReturnInfo
264 265
  deriving Eq

266 267 268 269 270
data CmmReturnInfo
  = CmmMayReturn
  | CmmNeverReturns
  deriving ( Eq )

271 272 273 274 275 276 277 278
data ForeignTarget        -- The target of a foreign call
  = ForeignTarget                -- A foreign procedure
        CmmExpr                  -- Its address
        ForeignConvention        -- Its calling convention
  | PrimTarget            -- A possibly-side-effecting machine operation
        CallishMachOp            -- Which one
  deriving Eq

279 280 281 282 283 284 285 286 287 288 289
foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetHints target
  = ( res_hints ++ repeat NoHint
    , arg_hints ++ repeat NoHint )
  where
    (res_hints, arg_hints) =
       case target of
          PrimTarget op -> callishMachOpHints op
          ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) ->
             (res_hints, arg_hints)

290 291 292
--------------------------------------------------
-- Instances of register and slot users / definers

293 294
instance UserOfRegs LocalReg (CmmNode e x) where
  foldRegsUsed dflags f z n = case n of
295 296 297 298 299 300 301 302 303
    CmmAssign _ expr -> fold f z expr
    CmmStore addr rval -> fold f (fold f z addr) rval
    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
    CmmCondBranch expr _ _ -> fold f z expr
    CmmSwitch expr _ -> fold f z expr
    CmmCall {cml_target=tgt} -> fold f z tgt
    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
    _ -> z
    where fold :: forall a b.
304
                       UserOfRegs LocalReg a =>
305
                       (b -> LocalReg -> b) -> b -> a -> b
306
          fold f z n = foldRegsUsed dflags f z n
307

308 309 310 311 312 313 314 315 316 317 318 319 320 321
instance UserOfRegs GlobalReg (CmmNode e x) where
  foldRegsUsed dflags f z n = case n of
    CmmAssign _ expr -> fold f z expr
    CmmStore addr rval -> fold f (fold f z addr) rval
    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
    CmmCondBranch expr _ _ -> fold f z expr
    CmmSwitch expr _ -> fold f z expr
    CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt
    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
    _ -> z
    where fold :: forall a b.
                       UserOfRegs GlobalReg a =>
                       (b -> GlobalReg -> b) -> b -> a -> b
          fold f z n = foldRegsUsed dflags f z n
322

323 324 325 326 327 328
instance UserOfRegs r CmmExpr => UserOfRegs r ForeignTarget where
  foldRegsUsed _      _ z (PrimTarget _)      = z
  foldRegsUsed dflags f z (ForeignTarget e _) = foldRegsUsed dflags f z e

instance DefinerOfRegs LocalReg (CmmNode e x) where
  foldRegsDefd dflags f z n = case n of
329 330 331 332 333
    CmmAssign lhs _ -> fold f z lhs
    CmmUnsafeForeignCall _ fs _ -> fold f z fs
    CmmForeignCall {res=res} -> fold f z res
    _ -> z
    where fold :: forall a b.
334
                   DefinerOfRegs LocalReg a =>
335
                   (b -> LocalReg -> b) -> b -> a -> b
336 337 338 339 340 341
          fold f z n = foldRegsDefd dflags f z n

instance DefinerOfRegs GlobalReg (CmmNode e x) where
  foldRegsDefd dflags f z n = case n of
    CmmAssign lhs _ -> fold f z lhs
    CmmUnsafeForeignCall tgt _ _  -> fold f z (foreignTargetRegs tgt)
342 343 344
    CmmCall        {} -> fold f z activeRegs
    CmmForeignCall {} -> fold f z activeRegs
                      -- See Note [Safe foreign calls clobber STG registers]
345 346 347 348 349 350 351 352 353 354 355 356
    _ -> z
    where fold :: forall a b.
                   DefinerOfRegs GlobalReg a =>
                   (b -> GlobalReg -> b) -> b -> a -> b
          fold f z n = foldRegsDefd dflags f z n

          platform = targetPlatform dflags
          activeRegs = activeStgRegs platform
          activeCallerSavesRegs = filter (callerSaves platform) activeRegs

          foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = []
          foreignTargetRegs _ = activeCallerSavesRegs
357

358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425
-- Note [Safe foreign calls clobber STG registers]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- During stack layout phase every safe foreign call is expanded into a block
-- that contains unsafe foreign call (instead of safe foreign call) and ends
-- with a normal call (See Note [Foreign calls]). This means that we must
-- treat safe foreign call as if it was a normal call (because eventually it
-- will be). This is important if we try to run sinking pass before stack
-- layout phase. Consider this example of what might go wrong (this is cmm
-- code from stablename001 test). Here is code after common block elimination
-- (before stack layout):
--
--  c1q6:
--      _s1pf::P64 = R1;
--      _c1q8::I64 = performMajorGC;
--      I64[(young<c1q9> + 8)] = c1q9;
--      foreign call "ccall" arg hints:  []  result hints:  [] (_c1q8::I64)(...)
--                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
--  c1q9:
--      I64[(young<c1qb> + 8)] = c1qb;
--      R1 = _s1pc::P64;
--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
--
-- If we run sinking pass now (still before stack layout) we will get this:
--
--  c1q6:
--      I64[(young<c1q9> + 8)] = c1q9;
--      foreign call "ccall" arg hints:  []  result hints:  [] performMajorGC(...)
--                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
--  c1q9:
--      I64[(young<c1qb> + 8)] = c1qb;
--      _s1pf::P64 = R1;         <------ _s1pf sunk past safe foreign call
--      R1 = _s1pc::P64;
--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
--
-- Notice that _s1pf was sunk past a foreign call. When we run stack layout
-- safe call to performMajorGC will be turned into:
--
--  c1q6:
--      _s1pc::P64 = P64[Sp + 8];
--      I64[Sp - 8] = c1q9;
--      Sp = Sp - 8;
--      I64[I64[CurrentTSO + 24] + 16] = Sp;
--      P64[CurrentNursery + 8] = Hp + 8;
--      (_u1qI::I64) = call "ccall" arg hints:  [PtrHint,]
--                           result hints:  [PtrHint] suspendThread(BaseReg, 0);
--      call "ccall" arg hints:  []  result hints:  [] performMajorGC();
--      (_u1qJ::I64) = call "ccall" arg hints:  [PtrHint]
--                           result hints:  [PtrHint] resumeThread(_u1qI::I64);
--      BaseReg = _u1qJ::I64;
--      _u1qK::P64 = CurrentTSO;
--      _u1qL::P64 = I64[_u1qK::P64 + 24];
--      Sp = I64[_u1qL::P64 + 16];
--      SpLim = _u1qL::P64 + 192;
--      HpAlloc = 0;
--      Hp = I64[CurrentNursery + 8] - 8;
--      HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1);
--      call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8;
--  c1q9:
--      I64[(young<c1qb> + 8)] = c1qb;
--      _s1pf::P64 = R1;         <------ INCORRECT!
--      R1 = _s1pc::P64;
--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
--
-- Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that
-- call is clearly incorrect. This is what would happen if we assumed that
-- safe foreign call has the same semantics as unsafe foreign call. To prevent
-- this we need to treat safe foreign call as if was normal call.
426 427 428 429

-----------------------------------
-- mapping Expr in CmmNode

430
mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
431 432 433 434
mapForeignTarget exp   (ForeignTarget e c) = ForeignTarget (exp e) c
mapForeignTarget _   m@(PrimTarget _)      = m

wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
435 436 437
-- Take a transformer on expressions and apply it recursively.
-- (wrapRecExp f e) first recursively applies itself to sub-expressions of e
--                  then  uses f to rewrite the resulting expression
438 439 440 441 442 443 444
wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map (wrapRecExp f) es)
wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)
wrapRecExp f e                    = f e

mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExp _ f@(CmmEntry _)                          = f
mapExp _ m@(CmmComment _)                        = m
Peter Wortmann's avatar
Peter Wortmann committed
445
mapExp _ m@(CmmTick _)                           = m
446 447 448 449 450 451
mapExp f   (CmmAssign r e)                       = CmmAssign r (f e)
mapExp f   (CmmStore addr e)                     = CmmStore (f addr) (f e)
mapExp f   (CmmUnsafeForeignCall tgt fs as)      = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
mapExp _ l@(CmmBranch _)                         = l
mapExp f   (CmmCondBranch e ti fi)               = CmmCondBranch (f e) ti fi
mapExp f   (CmmSwitch e tbl)                     = CmmSwitch (f e) tbl
452
mapExp f   n@CmmCall {cml_target=tgt}            = n{cml_target = f tgt}
453
mapExp f   (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl
454 455 456 457

mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep f = mapExp $ wrapRecExp f

458 459 460 461 462 463 464 465
------------------------------------------------------------------------
-- mapping Expr in CmmNode, but not performing allocation if no changes

mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e
mapForeignTargetM _ (PrimTarget _)      = Nothing

wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)
466 467
-- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e
--                   then  gives f a chance to rewrite the resulting expression
468 469 470 471 472 473 474
wrapRecExpM f n@(CmmMachOp op es)  = maybe (f n) (f . CmmMachOp op)    (mapListM (wrapRecExpM f) es)
wrapRecExpM f n@(CmmLoad addr ty)  = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)
wrapRecExpM f e                    = f e

mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpM _ (CmmEntry _)              = Nothing
mapExpM _ (CmmComment _)            = Nothing
Peter Wortmann's avatar
Peter Wortmann committed
475
mapExpM _ (CmmTick _)               = Nothing
476 477 478 479 480
mapExpM f (CmmAssign r e)           = CmmAssign r `fmap` f e
mapExpM f (CmmStore addr e)         = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]
mapExpM _ (CmmBranch _)             = Nothing
mapExpM f (CmmCondBranch e ti fi)   = (\x -> CmmCondBranch x ti fi) `fmap` f e
mapExpM f (CmmSwitch e tbl)         = (\x -> CmmSwitch x tbl)       `fmap` f e
481
mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt
482 483 484 485
mapExpM f (CmmUnsafeForeignCall tgt fs as)
    = case mapForeignTargetM f tgt of
        Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))
        Nothing   -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as
486
mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl)
487
    = case mapForeignTargetM f tgt of
488 489
        Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl)
        Nothing   -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as
490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508

-- share as much as possible
mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]
mapListM f xs = let (b, r) = mapListT f xs
                in if b then Just r else Nothing

mapListJ :: (a -> Maybe a) -> [a] -> [a]
mapListJ f xs = snd (mapListT f xs)

mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])
mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs))
    where g (_,   y, Nothing) (True, ys)  = (True,  y:ys)
          g (_,   _, Just y)  (True, ys)  = (True,  y:ys)
          g (ys', _, Nothing) (False, _)  = (False, ys')
          g (_,   _, Just y)  (False, ys) = (True,  y:ys)

mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpDeepM f = mapExpM $ wrapRecExpM f

509 510 511
-----------------------------------
-- folding Expr in CmmNode

512
foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
513 514 515 516
foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
foldExpForeignTarget _   (PrimTarget _)      z = z

-- Take a folder on expressions and apply it recursively.
517 518
-- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad
-- itself, delegating all the other CmmExpr forms to 'f'.
519 520 521 522 523 524 525 526
wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
wrapRecExpf f e                  z = f e z

foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
foldExp _ (CmmEntry {}) z                         = z
foldExp _ (CmmComment {}) z                       = z
Peter Wortmann's avatar
Peter Wortmann committed
527
foldExp _ (CmmTick {}) z                          = z
528 529 530 531 532 533 534 535 536 537
foldExp f (CmmAssign _ e) z                       = f e z
foldExp f (CmmStore addr e) z                     = f addr $ f e z
foldExp f (CmmUnsafeForeignCall t _ as) z         = foldr f (foldExpForeignTarget f t z) as
foldExp _ (CmmBranch _) z                         = z
foldExp f (CmmCondBranch e _ _) z                 = f e z
foldExp f (CmmSwitch e _) z                       = f e z
foldExp f (CmmCall {cml_target=tgt}) z            = f tgt z
foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args

foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
Simon Marlow's avatar
Simon Marlow committed
538
foldExpDeep f = foldExp (wrapRecExpf f)
Simon Marlow's avatar
Simon Marlow committed
539

Simon Marlow's avatar
Simon Marlow committed
540 541 542 543 544 545
-- -----------------------------------------------------------------------------

mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C
mapSuccessors f (CmmBranch bid)        = CmmBranch (f bid)
mapSuccessors f (CmmCondBranch p y n)  = CmmCondBranch p (f y) (f n)
mapSuccessors f (CmmSwitch e arms)     = CmmSwitch e (map (fmap f) arms)
546
mapSuccessors _ n = n
Simon Marlow's avatar
Simon Marlow committed
547

Peter Wortmann's avatar
Peter Wortmann committed
548 549 550 551
-- -----------------------------------------------------------------------------

-- | Tickish in Cmm context (annotations only)
type CmmTickish = Tickish ()