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