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
  96 Safe ones are trickier.  A safe foreign call
  97      r = f(x)
  98 ultimately expands to
  99      push "return address"      -- Never used to return to;
 100                                 -- just points an info table
 101      save registers into TSO
 102      call suspendThread
 103      r = f(x)                   -- Make the call
 104      call resumeThread
 105      restore registers
 106      pop "return address"
 107 We cannot "lower" a safe foreign call to this sequence of Cmms, because
 108 after we've saved Sp all the Cmm optimiser's assumptions are broken.
 109 Furthermore, currently the smart Cmm constructors know the calling
 110 conventions for Haskell, the garbage collector, etc, and "lower" them
 111 so that a LastCall passes no parameters or results.  But the smart
 112 constructors do *not* (currently) know the foreign call conventions.
 113
 114 Note that a safe foreign call needs an info table.
 115 -}
 116
 117 ---------------------------------------------
 118 -- Eq instance of CmmNode
 119 -- It is a shame GHC cannot infer it by itself :(
 120
 121 instance Eq (CmmNode e x) where
 122   (CmmEntry a)                 == (CmmEntry a')                   = a==a'
 123   (CmmComment a)               == (CmmComment a')                 = a==a'
 124   (CmmAssign a b)              == (CmmAssign a' b')               = a==a' && b==b'
 125   (CmmStore a b)               == (CmmStore a' b')                = a==a' && b==b'
 126   (CmmUnsafeForeignCall a b c) == (CmmUnsafeForeignCall a' b' c') = a==a' && b==b' && c==c'
 127   (CmmBranch a)                == (CmmBranch a')                  = a==a'
 128   (CmmCondBranch a b c)        == (CmmCondBranch a' b' c')        = a==a' && b==b' && c==c'
 129   (CmmSwitch a b)              == (CmmSwitch a' b')               = a==a' && b==b'
 130   (CmmCall a b c d e)          == (CmmCall a' b' c' d' e')        = a==a' && b==b' && c==c' && d==d' && e==e'
 131   (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'
 132   _                            == _                               = False
 133
 134 ----------------------------------------------
 135 -- Hoopl instances of CmmNode
 136
 137 instance NonLocal CmmNode where
 138   entryLabel (CmmEntry l) = l
 139
 140   successors (CmmBranch l) = [l]
 141   successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
 142   successors (CmmSwitch _ ls) = catMaybes ls
 143   successors (CmmCall {cml_cont=l}) = maybeToList l
 144   successors (CmmForeignCall {succ=l}) = [l]
 145
 146
 147 instance HooplNode CmmNode where
 148   mkBranchNode label = CmmBranch label
 149   mkLabelNode label  = CmmEntry label
 150
 151 --------------------------------------------------
 152 -- Various helper types
 153
 154 type UpdFrameOffset = ByteOff
 155
 156 data Convention
 157   = NativeDirectCall -- Native C-- call skipping the node (closure) argument
 158   | NativeNodeCall   -- Native C-- call including the node argument
 159   | NativeReturn     -- Native C-- return
 160   | Slow             -- Slow entry points: all args pushed on the stack
 161   | GC               -- Entry to the garbage collector: uses the node reg!
 162   | PrimOpCall       -- Calling prim ops
 163   | PrimOpReturn     -- Returning from prim ops
 164   | Foreign          -- Foreign call/return
 165         ForeignConvention
 166   | Private
 167         -- Used for control transfers within a (pre-CPS) procedure All
 168         -- jump sites known, never pushed on the stack (hence no SRT)
 169         -- You can choose whatever calling convention you please
 170         -- (provided you make sure all the call sites agree)!
 171         -- This data type eventually to be extended to record the convention.
 172   deriving( Eq )
 173
 174 data ForeignConvention
 175   = ForeignConvention
 176         CCallConv               -- Which foreign-call convention
 177         [ForeignHint]           -- Extra info about the args
 178         [ForeignHint]           -- Extra info about the result
 179   deriving Eq
 180
 181 data ForeignTarget        -- The target of a foreign call
 182   = ForeignTarget                -- A foreign procedure
 183         CmmExpr                  -- Its address
 184         ForeignConvention        -- Its calling convention
 185   | PrimTarget            -- A possibly-side-effecting machine operation
 186         CallishMachOp            -- Which one
 187   deriving Eq
 188
 189 --------------------------------------------------
 190 -- Instances of register and slot users / definers
 191
 192 instance UserOfLocalRegs (CmmNode e x) where
 193   foldRegsUsed f z n = case n of
 194     CmmAssign _ expr -> fold f z expr
 195     CmmStore addr rval -> fold f (fold f z addr) rval
 196     CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
 197     CmmCondBranch expr _ _ -> fold f z expr
 198     CmmSwitch expr _ -> fold f z expr
 199     CmmCall {cml_target=tgt} -> fold f z tgt
 200     CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
 201     _ -> z
 202     where fold :: forall a b.
 203                        UserOfLocalRegs a =>
 204                        (b -> LocalReg -> b) -> b -> a -> b
 205           fold f z n = foldRegsUsed f z n
 206
 207 instance UserOfLocalRegs ForeignTarget where
 208   foldRegsUsed _f z (PrimTarget _)      = z
 209   foldRegsUsed f  z (ForeignTarget e _) = foldRegsUsed f z e
 210
 211 instance DefinerOfLocalRegs (CmmNode e x) where
 212   foldRegsDefd f z n = case n of
 213     CmmAssign lhs _ -> fold f z lhs
 214     CmmUnsafeForeignCall _ fs _ -> fold f z fs
 215     CmmForeignCall {res=res} -> fold f z res
 216     _ -> z
 217     where fold :: forall a b.
 218                    DefinerOfLocalRegs a =>
 219                    (b -> LocalReg -> b) -> b -> a -> b
 220           fold f z n = foldRegsDefd f z n
 221
 222
 223 instance UserOfSlots (CmmNode e x) where
 224   foldSlotsUsed f z n = case n of
 225     CmmAssign _ expr -> fold f z expr
 226     CmmStore addr rval -> fold f (fold f z addr) rval
 227     CmmUnsafeForeignCall _ _ args -> fold f z args
 228     CmmCondBranch expr _ _ -> fold f z expr
 229     CmmSwitch expr _ -> fold f z expr
 230     CmmCall {cml_target=tgt} -> fold f z tgt
 231     CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
 232     _ -> z
 233     where fold :: forall a b.
 234                        UserOfSlots a =>
 235                        (b -> SubArea -> b) -> b -> a -> b
 236           fold f z n = foldSlotsUsed f z n
 237
 238 instance UserOfSlots ForeignTarget where
 239   foldSlotsUsed  f z (ForeignTarget e _) = foldSlotsUsed f z e
 240   foldSlotsUsed _f z (PrimTarget _)      = z
 241
 242 instance DefinerOfSlots (CmmNode e x) where
 243   foldSlotsDefd f z n = case n of
 244     CmmStore (CmmStackSlot a i) expr -> f z (a, i, widthInBytes $ typeWidth $ cmmExprType expr)
 245     CmmForeignCall {res=res} -> fold f z $ map foreign_call_slot res
 246     _ -> z
 247     where
 248           fold :: forall a b.
 249                   DefinerOfSlots a =>
 250                   (b -> SubArea -> b) -> b -> a -> b
 251           fold f z n = foldSlotsDefd f z n
 252           foreign_call_slot r = case widthInBytes $ typeWidth $ localRegType r of w -> (RegSlot r, w, w)
 253
 254 -----------------------------------
 255 -- mapping Expr in CmmNode
 256
 257 mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
 258 mapForeignTarget exp   (ForeignTarget e c) = ForeignTarget (exp e) c
 259 mapForeignTarget _   m@(PrimTarget _)      = m
 260
 261 -- Take a transformer on expressions and apply it recursively.
 262 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
 263 wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map (wrapRecExp f) es)
 264 wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)
 265 wrapRecExp f e                    = f e
 266
 267 mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
 268 mapExp _ f@(CmmEntry _)                          = f
 269 mapExp _ m@(CmmComment _)                        = m
 270 mapExp f   (CmmAssign r e)                       = CmmAssign r (f e)
 271 mapExp f   (CmmStore addr e)                     = CmmStore (f addr) (f e)
 272 mapExp f   (CmmUnsafeForeignCall tgt fs as)      = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
 273 mapExp _ l@(CmmBranch _)                         = l
 274 mapExp f   (CmmCondBranch e ti fi)               = CmmCondBranch (f e) ti fi
 275 mapExp f   (CmmSwitch e tbl)                     = CmmSwitch (f e) tbl
 276 mapExp f   (CmmCall tgt mb_id o i s)             = CmmCall (f tgt) mb_id o i s
 277 mapExp f   (CmmForeignCall tgt fs as succ updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ updfr intrbl
 278
 279 mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
 280 mapExpDeep f = mapExp $ wrapRecExp f
 281
 282 -----------------------------------
 283 -- folding Expr in CmmNode
 284
 285 foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
 286 foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
 287 foldExpForeignTarget _   (PrimTarget _)      z = z
 288
 289 -- Take a folder on expressions and apply it recursively.
 290 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
 291 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
 292 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
 293 wrapRecExpf f e                  z = f e z
 294
 295 foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
 296 foldExp _ (CmmEntry {}) z                         = z
 297 foldExp _ (CmmComment {}) z                       = z
 298 foldExp f (CmmAssign _ e) z                       = f e z
 299 foldExp f (CmmStore addr e) z                     = f addr $ f e z
 300 foldExp f (CmmUnsafeForeignCall t _ as) z         = foldr f (foldExpForeignTarget f t z) as
 301 foldExp _ (CmmBranch _) z                         = z
 302 foldExp f (CmmCondBranch e _ _) z                 = f e z
 303 foldExp f (CmmSwitch e _) z                       = f e z
 304 foldExp f (CmmCall {cml_target=tgt}) z            = f tgt z
 305 foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args
 306
 307 foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
 308 foldExpDeep f = foldExp $ wrapRecExpf f