compiler/cmm/CmmNode.hs

   1 -- CmmNode type for representation using Hoopl graphs.
   2 {-# LANGUAGE GADTs #-}
   3
   4 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
   5 #if __GLASGOW_HASKELL__ >= 701
   6 -- GHC 7.0.1 improved incomplete pattern warnings with GADTs
   7 {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
   8 #endif
   9
  10 module CmmNode
  11   ( CmmNode(..)
  12   , UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..)
  13   , mapExp, mapExpDeep, foldExp, foldExpDeep
  14   )
  15 where
  16
  17 import CmmExpr
  18 import CmmDecl
  19 import FastString
  20 import ForeignCall
  21 import SMRep
  22
  23 import Compiler.Hoopl
  24 import Data.Maybe
  25 import Prelude hiding (succ)
  26
  27
  28 ------------------------
  29 -- CmmNode
  30
  31 data CmmNode e x where
  32   CmmEntry :: Label -> CmmNode C O
  33   CmmComment :: FastString -> CmmNode O O
  34   CmmAssign :: CmmReg -> CmmExpr -> CmmNode O O  -- Assign to register
  35   CmmStore :: CmmExpr -> CmmExpr -> CmmNode O O  -- Assign to memory location.  Size is
  36                                                  -- given by cmmExprType of the rhs.
  37   CmmUnsafeForeignCall ::         -- An unsafe foreign call; see Note [Foreign calls]
  38       ForeignTarget ->            -- call target
  39       CmmFormals ->               -- zero or more results
  40       CmmActuals ->               -- zero or more arguments
  41       CmmNode O O
  42   CmmBranch :: Label -> CmmNode O C  -- Goto another block in the same procedure
  43   CmmCondBranch :: {                 -- conditional branch
  44       cml_pred :: CmmExpr,
  45       cml_true, cml_false :: Label
  46   } -> CmmNode O C
  47   CmmSwitch :: CmmExpr -> [Maybe Label] -> CmmNode O C -- Table branch
  48       -- The scrutinee is zero-based;
  49       --      zero -> first block
  50       --      one  -> second block etc
  51       -- Undefined outside range, and when there's a Nothing
  52   CmmCall :: {                -- A call (native or safe foreign)
  53       cml_target :: CmmExpr,  -- never a CmmPrim to a CallishMachOp!
  54
  55       cml_cont :: Maybe Label,
  56           -- Label of continuation (Nothing for return or tail call)
  57
  58       cml_args :: ByteOff,
  59           -- Byte offset, from the *old* end of the Area associated with
  60           -- the Label (if cml_cont = Nothing, then Old area), of
  61           -- youngest outgoing arg.  Set the stack pointer to this before
  62           -- transferring control.
  63           -- (NB: an update frame might also have been stored in the Old
  64           --      area, but it'll be in an older part than the args.)
  65
  66       cml_ret_args :: ByteOff,
  67           -- For calls *only*, the byte offset for youngest returned value
  68           -- This is really needed at the *return* point rather than here
  69           -- at the call, but in practice it's convenient to record it here.
  70
  71       cml_ret_off :: ByteOff
  72         -- For calls *only*, the byte offset of the base of the frame that
  73         -- must be described by the info table for the return point.
  74         -- The older words are an update frames, which have their own
  75         -- info-table and layout information
  76
  77         -- From a liveness point of view, the stack words older than
  78         -- cml_ret_off are treated as live, even if the sequel of
  79         -- the call goes into a loop.
  80   } -> CmmNode O C
  81   CmmForeignCall :: {           -- A safe foreign call; see Note [Foreign calls]
  82       tgt   :: ForeignTarget,   -- call target and convention
  83       res   :: CmmFormals,      -- zero or more results
  84       args  :: CmmActuals,      -- zero or more arguments
  85       succ  :: Label,           -- Label of continuation
  86       updfr :: UpdFrameOffset,  -- where the update frame is (for building infotable)
  87       intrbl:: Bool             -- whether or not the call is interruptible
  88   } -> CmmNode O C
  89
  90 {- Note [Foreign calls]
  91 ~~~~~~~~~~~~~~~~~~~~~~~
  92 A MidForeign call is used for *unsafe* foreign calls;
  93 a LastForeign call is used for *safe* foreign calls.
  94 Unsafe ones are easy: think of them as a "fat machine instruction".
  95 In particular, they do *not* kill all live registers (there was a bit
  96 of code in GHC that conservatively assumed otherwise.)
  97
  98 Safe ones are trickier.  A safe foreign call
  99      r = f(x)
 100 ultimately expands to
 101      push "return address"      -- Never used to return to;
 102                                 -- just points an info table
 103      save registers into TSO
 104      call suspendThread
 105      r = f(x)                   -- Make the call
 106      call resumeThread
 107      restore registers
 108      pop "return address"
 109 We cannot "lower" a safe foreign call to this sequence of Cmms, because
 110 after we've saved Sp all the Cmm optimiser's assumptions are broken.
 111 Furthermore, currently the smart Cmm constructors know the calling
 112 conventions for Haskell, the garbage collector, etc, and "lower" them
 113 so that a LastCall passes no parameters or results.  But the smart
 114 constructors do *not* (currently) know the foreign call conventions.
 115
 116 Note that a safe foreign call needs an info table.
 117 -}
 118
 119 ---------------------------------------------
 120 -- Eq instance of CmmNode
 121 -- It is a shame GHC cannot infer it by itself :(
 122
 123 instance Eq (CmmNode e x) where
 124   (CmmEntry a)                 == (CmmEntry a')                   = a==a'
 125   (CmmComment a)               == (CmmComment a')                 = a==a'
 126   (CmmAssign a b)              == (CmmAssign a' b')               = a==a' && b==b'
 127   (CmmStore a b)               == (CmmStore a' b')                = a==a' && b==b'
 128   (CmmUnsafeForeignCall a b c) == (CmmUnsafeForeignCall a' b' c') = a==a' && b==b' && c==c'
 129   (CmmBranch a)                == (CmmBranch a')                  = a==a'
 130   (CmmCondBranch a b c)        == (CmmCondBranch a' b' c')        = a==a' && b==b' && c==c'
 131   (CmmSwitch a b)              == (CmmSwitch a' b')               = a==a' && b==b'
 132   (CmmCall a b c d e)          == (CmmCall a' b' c' d' e')        = a==a' && b==b' && c==c' && d==d' && e==e'
 133   (CmmForeignCall a b c d e f) == (CmmForeignCall a' b' c' d' e' f') = a==a' && b==b' && c==c' && d==d' && e==e' && f==f'
 134   _                            == _                               = False
 135
 136 ----------------------------------------------
 137 -- Hoopl instances of CmmNode
 138
 139 instance NonLocal CmmNode where
 140   entryLabel (CmmEntry l) = l
 141
 142   successors (CmmBranch l) = [l]
 143   successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
 144   successors (CmmSwitch _ ls) = catMaybes ls
 145   successors (CmmCall {cml_cont=l}) = maybeToList l
 146   successors (CmmForeignCall {succ=l}) = [l]
 147
 148
 149 instance HooplNode CmmNode where
 150   mkBranchNode label = CmmBranch label
 151   mkLabelNode label  = CmmEntry label
 152
 153 --------------------------------------------------
 154 -- Various helper types
 155
 156 type UpdFrameOffset = ByteOff
 157
 158 data Convention
 159   = NativeDirectCall -- Native C-- call skipping the node (closure) argument
 160   | NativeNodeCall   -- Native C-- call including the node argument
 161   | NativeReturn     -- Native C-- return
 162   | Slow             -- Slow entry points: all args pushed on the stack
 163   | GC               -- Entry to the garbage collector: uses the node reg!
 164   | PrimOpCall       -- Calling prim ops
 165   | PrimOpReturn     -- Returning from prim ops
 166   | Foreign          -- Foreign call/return
 167         ForeignConvention
 168   | Private
 169         -- Used for control transfers within a (pre-CPS) procedure All
 170         -- jump sites known, never pushed on the stack (hence no SRT)
 171         -- You can choose whatever calling convention you please
 172         -- (provided you make sure all the call sites agree)!
 173         -- This data type eventually to be extended to record the convention.
 174   deriving( Eq )
 175
 176 data ForeignConvention
 177   = ForeignConvention
 178         CCallConv               -- Which foreign-call convention
 179         [ForeignHint]           -- Extra info about the args
 180         [ForeignHint]           -- Extra info about the result
 181   deriving Eq
 182
 183 data ForeignTarget        -- The target of a foreign call
 184   = ForeignTarget                -- A foreign procedure
 185         CmmExpr                  -- Its address
 186         ForeignConvention        -- Its calling convention
 187   | PrimTarget            -- A possibly-side-effecting machine operation
 188         CallishMachOp            -- Which one
 189   deriving Eq
 190
 191 --------------------------------------------------
 192 -- Instances of register and slot users / definers
 193
 194 instance UserOfLocalRegs (CmmNode e x) where
 195   foldRegsUsed f z n = case n of
 196     CmmAssign _ expr -> fold f z expr
 197     CmmStore addr rval -> fold f (fold f z addr) rval
 198     CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
 199     CmmCondBranch expr _ _ -> fold f z expr
 200     CmmSwitch expr _ -> fold f z expr
 201     CmmCall {cml_target=tgt} -> fold f z tgt
 202     CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
 203     _ -> z
 204     where fold :: forall a b.
 205                        UserOfLocalRegs a =>
 206                        (b -> LocalReg -> b) -> b -> a -> b
 207           fold f z n = foldRegsUsed f z n
 208
 209 instance UserOfLocalRegs ForeignTarget where
 210   foldRegsUsed _f z (PrimTarget _)      = z
 211   foldRegsUsed f  z (ForeignTarget e _) = foldRegsUsed f z e
 212
 213 instance DefinerOfLocalRegs (CmmNode e x) where
 214   foldRegsDefd f z n = case n of
 215     CmmAssign lhs _ -> fold f z lhs
 216     CmmUnsafeForeignCall _ fs _ -> fold f z fs
 217     CmmForeignCall {res=res} -> fold f z res
 218     _ -> z
 219     where fold :: forall a b.
 220                    DefinerOfLocalRegs a =>
 221                    (b -> LocalReg -> b) -> b -> a -> b
 222           fold f z n = foldRegsDefd f z n
 223
 224
 225 instance UserOfSlots (CmmNode e x) where
 226   foldSlotsUsed f z n = case n of
 227     CmmAssign _ expr -> fold f z expr
 228     CmmStore addr rval -> fold f (fold f z addr) rval
 229     CmmUnsafeForeignCall _ _ args -> fold f z args
 230     CmmCondBranch expr _ _ -> fold f z expr
 231     CmmSwitch expr _ -> fold f z expr
 232     CmmCall {cml_target=tgt} -> fold f z tgt
 233     CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
 234     _ -> z
 235     where fold :: forall a b.
 236                        UserOfSlots a =>
 237                        (b -> SubArea -> b) -> b -> a -> b
 238           fold f z n = foldSlotsUsed f z n
 239
 240 instance UserOfSlots ForeignTarget where
 241   foldSlotsUsed  f z (ForeignTarget e _) = foldSlotsUsed f z e
 242   foldSlotsUsed _f z (PrimTarget _)      = z
 243
 244 instance DefinerOfSlots (CmmNode e x) where
 245   foldSlotsDefd f z n = case n of
 246     CmmStore (CmmStackSlot a i) expr -> f z (a, i, widthInBytes $ typeWidth $ cmmExprType expr)
 247     CmmForeignCall {res=res} -> fold f z $ map foreign_call_slot res
 248     _ -> z
 249     where
 250           fold :: forall a b.
 251                   DefinerOfSlots a =>
 252                   (b -> SubArea -> b) -> b -> a -> b
 253           fold f z n = foldSlotsDefd f z n
 254           foreign_call_slot r = case widthInBytes $ typeWidth $ localRegType r of w -> (RegSlot r, w, w)
 255
 256 -----------------------------------
 257 -- mapping Expr in CmmNode
 258
 259 mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
 260 mapForeignTarget exp   (ForeignTarget e c) = ForeignTarget (exp e) c
 261 mapForeignTarget _   m@(PrimTarget _)      = m
 262
 263 -- Take a transformer on expressions and apply it recursively.
 264 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
 265 wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map (wrapRecExp f) es)
 266 wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)
 267 wrapRecExp f e                    = f e
 268
 269 mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
 270 mapExp _ f@(CmmEntry _)                          = f
 271 mapExp _ m@(CmmComment _)                        = m
 272 mapExp f   (CmmAssign r e)                       = CmmAssign r (f e)
 273 mapExp f   (CmmStore addr e)                     = CmmStore (f addr) (f e)
 274 mapExp f   (CmmUnsafeForeignCall tgt fs as)      = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
 275 mapExp _ l@(CmmBranch _)                         = l
 276 mapExp f   (CmmCondBranch e ti fi)               = CmmCondBranch (f e) ti fi
 277 mapExp f   (CmmSwitch e tbl)                     = CmmSwitch (f e) tbl
 278 mapExp f   (CmmCall tgt mb_id o i s)             = CmmCall (f tgt) mb_id o i s
 279 mapExp f   (CmmForeignCall tgt fs as succ updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ updfr intrbl
 280
 281 mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
 282 mapExpDeep f = mapExp $ wrapRecExp f
 283
 284 -----------------------------------
 285 -- folding Expr in CmmNode
 286
 287 foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
 288 foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
 289 foldExpForeignTarget _   (PrimTarget _)      z = z
 290
 291 -- Take a folder on expressions and apply it recursively.
 292 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
 293 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
 294 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
 295 wrapRecExpf f e                  z = f e z
 296
 297 foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
 298 foldExp _ (CmmEntry {}) z                         = z
 299 foldExp _ (CmmComment {}) z                       = z
 300 foldExp f (CmmAssign _ e) z                       = f e z
 301 foldExp f (CmmStore addr e) z                     = f addr $ f e z
 302 foldExp f (CmmUnsafeForeignCall t _ as) z         = foldr f (foldExpForeignTarget f t z) as
 303 foldExp _ (CmmBranch _) z                         = z
 304 foldExp f (CmmCondBranch e _ _) z                 = f e z
 305 foldExp f (CmmSwitch e _) z                       = f e z
 306 foldExp f (CmmCall {cml_target=tgt}) z            = f tgt z
 307 foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args
 308
 309 foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
 310 foldExpDeep f = foldExp $ wrapRecExpf f