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