compiler/cmm/CmmNode.hs

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