compiler/cmm/MkGraph.hs

   1 {-# LANGUAGE GADTs #-}
   2 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
   3 -- ToDo: remove
   4 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
   5
   6 -- Module for building CmmAGraphs.
   7
   8 -- As the CmmAGraph is a wrapper over Graph CmmNode O x, it is different
   9 -- from Hoopl's AGraph. The current clients expect functions with the
  10 -- same names Hoopl uses, so this module cannot be in the same namespace
  11 -- as Compiler.Hoopl.
  12
  13 module MkGraph
  14   ( CmmAGraph
  15   , emptyAGraph, (<*>), catAGraphs, outOfLine
  16   , mkLabel, mkMiddle, mkLast
  17   , withFreshLabel, withUnique, lgraphOfAGraph, labelAGraph
  18
  19   , stackStubExpr
  20   , mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkSafeCall, mkUnsafeCall, mkFinalCall
  21          , mkJump, mkDirectJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch
  22          , mkReturn, mkReturnSimple, mkComment, mkCallEntry
  23          , mkBranch, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
  24          , copyInOflow, copyInSlot, copyOutOflow, copyOutSlot
  25   -- Reexport of needed Cmm stuff
  26   , Convention(..), ForeignConvention(..), ForeignTarget(..)
  27   , CmmStackInfo(..), CmmTopInfo(..), CmmGraph, GenCmmGraph(..)
  28   , Cmm, CmmTop
  29   )
  30 where
  31
  32 import BlockId
  33 import Cmm
  34 import CmmDecl
  35 import CmmExpr
  36 import CmmCallConv (assignArgumentsPos, ParamLocation(..))
  37
  38 import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..))
  39 import qualified Compiler.Hoopl as H
  40 import Compiler.Hoopl.GHC (uniqueToLbl)
  41 import FastString
  42 import ForeignCall
  43 import Outputable
  44 import Prelude hiding (succ)
  45 import SMRep (ByteOff)
  46 import StaticFlags
  47 import Unique
  48 import UniqSupply
  49
  50 #include "HsVersions.h"
  51
  52 {-
  53 A 'CmmAGraph' is an abstract version of a 'Graph CmmNode O x' from module
  54 'Cmm'.  The difference is that the 'CmmAGraph' can be eigher open of closed at
  55 exit and it can supply fresh Labels and Uniques.
  56
  57 It also supports a splicing operation <*>, which is different from the Hoopl's
  58 <*>, because it splices two CmmAGraphs. Specifically, it can splice Graph
  59 O C and Graph O x. In this case, the open beginning of the second graph is
  60 thrown away.  In the debug mode this sequence is checked to be empty or
  61 containing a branch (see note [Branch follows branch]).
  62
  63 When an CmmAGraph open at exit is being converted to a CmmGraph, the output
  64 exit sequence is considered unreachable. If the graph consist of one block
  65 only, if it not the case and we crash. Otherwise we just throw the exit
  66 sequence away (and in debug mode we test that it really was unreachable).
  67 -}
  68
  69 {-
  70 Node [Branch follows branch]
  71 ============================
  72 Why do we say it's ok for a Branch to follow a Branch?
  73 Because the standard constructor mkLabel has fall-through
  74 semantics. So if you do a mkLabel, you finish the current block,
  75 giving it a label, and start a new one that branches to that label.
  76 Emitting a Branch at this point is fine:
  77        goto L1; L2: ...stuff...
  78 -}
  79
  80 data CmmGraphOC = Opened (Graph CmmNode O O)
  81                 | Closed (Graph CmmNode O C)
  82 type CmmAGraph = UniqSM CmmGraphOC     -- Graph open at entry
  83
  84 {-
  85 MS: I began with
  86   newtype CmmAGraph = forall x. AG (UniqSM (Graph CmmNode O x))
  87 but that does not work well, because we cannot take the graph
  88 out of the monad -- we do not know the type of what we would take
  89 out and pattern matching does not help, as we cannot pattern match
  90 on a graph inside the monad.
  91 -}
  92
  93 data Transfer = Call | Jump | Ret deriving Eq
  94
  95 ---------- AGraph manipulation
  96
  97 emptyAGraph    :: CmmAGraph
  98 (<*>)          :: CmmAGraph -> CmmAGraph -> CmmAGraph
  99 catAGraphs     :: [CmmAGraph] -> CmmAGraph
 100
 101 mkLabel        :: BlockId     -> CmmAGraph  -- created a sequence "goto id; id:" as an AGraph
 102 mkMiddle       :: CmmNode O O -> CmmAGraph  -- creates an open AGraph from a given node
 103 mkLast         :: CmmNode O C -> CmmAGraph  -- created a closed AGraph from a given node
 104
 105 withFreshLabel :: String -> (BlockId -> CmmAGraph) -> CmmAGraph
 106 withUnique     :: (Unique -> CmmAGraph) -> CmmAGraph
 107
 108 lgraphOfAGraph :: CmmAGraph -> UniqSM CmmGraph
 109   -- ^ allocate a fresh label for the entry point
 110 labelAGraph    :: BlockId -> CmmAGraph -> UniqSM CmmGraph
 111   -- ^ use the given BlockId as the label of the entry point
 112
 113 ---------- No-ops
 114 mkNop        :: CmmAGraph
 115 mkComment    :: FastString -> CmmAGraph
 116
 117 ---------- Assignment and store
 118 mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
 119 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
 120
 121 ---------- Calls
 122 mkCall       :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals ->
 123                   UpdFrameOffset -> CmmAGraph
 124 mkCmmCall    :: CmmExpr ->              CmmFormals -> CmmActuals ->
 125                   UpdFrameOffset -> CmmAGraph
 126   -- Native C-- calling convention
 127 mkSafeCall    :: ForeignTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> Bool -> CmmAGraph
 128 mkUnsafeCall  :: ForeignTarget -> CmmFormals -> CmmActuals -> CmmAGraph
 129 mkFinalCall   :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph
 130   -- Never returns; like exit() or barf()
 131
 132 ---------- Control transfer
 133 mkJump          ::               CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
 134 mkDirectJump    ::               CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
 135 mkJumpGC        ::               CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
 136 mkForeignJump   :: Convention -> CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
 137 mkCbranch       :: CmmExpr -> BlockId -> BlockId          -> CmmAGraph
 138 mkSwitch        :: CmmExpr -> [Maybe BlockId]             -> CmmAGraph
 139 mkReturn        :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
 140 mkReturnSimple  :: CmmActuals -> UpdFrameOffset -> CmmAGraph
 141
 142 mkBranch        :: BlockId -> CmmAGraph
 143 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
 144 mkCmmIfThen     :: CmmExpr -> CmmAGraph -> CmmAGraph
 145 mkCmmWhileDo    :: CmmExpr -> CmmAGraph -> CmmAGraph
 146
 147 outOfLine       :: CmmAGraph -> CmmAGraph
 148 -- ^ The argument is an CmmAGraph that must have an
 149 -- empty entry sequence and be closed at the end.
 150 -- The result is a new CmmAGraph that is open at the
 151 -- end and goes directly from entry to exit, with the
 152 -- original graph sitting to the side out-of-line.
 153 --
 154 -- Example:  mkMiddle (x = 3)
 155 --           <*> outOfLine (mkLabel L <*> ...stuff...)
 156 --           <*> mkMiddle (y = x)
 157 -- Control will flow directly from x=3 to y=x;
 158 -- the block starting with L is "on the side".
 159 --
 160 -- N.B. algebraically forall g g' : g <*> outOfLine g' == outOfLine g' <*> g
 161
 162 --------------------------------------------------------------------------
 163
 164 -- ================ IMPLEMENTATION ================--
 165
 166 --------------------------------------------------
 167 -- Raw CmmAGraph handling
 168
 169 emptyAGraph = return $ Opened emptyGraph
 170 ag <*> ah = do g <- ag
 171                h <- ah
 172                return (case (g, h) of
 173                  (Opened g, Opened h) -> Opened $ g H.<*> h
 174                  (Opened g, Closed h) -> Closed $ g H.<*> h
 175                  (Closed g, Opened GNil) -> Closed g
 176                  (Closed g, Opened (GUnit e)) -> note_unreachable e $ Closed g
 177                  (Closed g, Opened (GMany (JustO e) b x)) -> note_unreachable e $ Opened $ g H.|*><*| GMany NothingO b x
 178                  (Closed g, Closed (GMany (JustO e) b x)) -> note_unreachable e $ Closed $ g H.|*><*| GMany NothingO b x
 179                  :: CmmGraphOC)
 180 catAGraphs = foldl (<*>) emptyAGraph
 181
 182 outOfLine ag = withFreshLabel "outOfLine" $ \l ->
 183                do g <- ag
 184                   return (case g of
 185                     Closed (GMany (JustO e) b _) -> note_unreachable e $ Opened $
 186                                                       GMany (JustO $ BLast $ CmmBranch l) b (JustO $ BFirst $ CmmEntry l)
 187                     _                            -> panic "outOfLine"
 188                     :: CmmGraphOC)
 189
 190 note_unreachable :: Block CmmNode O x -> a -> a
 191 note_unreachable block graph =
 192   ASSERT (block_is_empty_or_label)  -- Note [Branch follows branch]
 193   graph
 194   where block_is_empty_or_label :: Bool
 195         block_is_empty_or_label = case blockToNodeList block of
 196                                     (NothingC, [], NothingC)            -> True
 197                                     (NothingC, [], JustC (CmmBranch _)) -> True
 198                                     _                                   -> False
 199
 200 mkLabel bid = return $ Opened $ H.mkLast (CmmBranch bid) |*><*| H.mkFirst (CmmEntry bid)
 201 mkMiddle middle = return $ Opened $ H.mkMiddle middle
 202 mkLast last = return $ Closed $ H.mkLast last
 203
 204 withUnique f = getUniqueM >>= f
 205 withFreshLabel _name f = getUniqueM >>= f . uniqueToLbl . intToUnique . getKey
 206
 207 lgraphOfAGraph g = do u <- getUniqueM
 208                       labelAGraph (mkBlockId u) g
 209
 210 labelAGraph lbl ag = do g <- ag
 211                         return $ CmmGraph {g_entry=lbl, g_graph=H.mkFirst (CmmEntry lbl) H.<*> closed g}
 212   where closed :: CmmGraphOC -> Graph CmmNode O C
 213         closed (Closed g) = g
 214         closed (Opened g@(GMany entry body (JustO exit))) =
 215           ASSERT (entryLabel exit `notElem` map entryLabel (postorder_dfs g))
 216           GMany entry body NothingO
 217         closed (Opened _) = panic "labelAGraph"
 218
 219 --------------------------------------------------
 220 -- CmmAGraph constructions
 221
 222 mkNop                     = emptyAGraph
 223 mkComment fs              = mkMiddle $ CmmComment fs
 224 mkStore  l r              = mkMiddle $ CmmStore  l r
 225
 226 -- NEED A COMPILER-DEBUGGING FLAG HERE
 227 -- Sanity check: any value assigned to a pointer must be non-zero.
 228 -- If it's 0, cause a crash immediately.
 229 mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r
 230   where assign l r = mkMiddle (CmmAssign l r)
 231         check (CmmGlobal _) = mkNop
 232         check l@(CmmLocal reg) = -- if a ptr arg is NULL, cause a crash!
 233           if isGcPtrType ty then
 234             mkCmmIfThen (CmmMachOp (MO_Eq w) [r, stackStubExpr w])
 235                         (assign l (CmmLoad (CmmLit (CmmInt 0 w)) ty))
 236           else mkNop
 237             where ty = localRegType reg
 238                   w  = typeWidth ty
 239                   r  = CmmReg l
 240
 241
 242 -- Why are we inserting extra blocks that simply branch to the successors?
 243 -- Because in addition to the branch instruction, @mkBranch@ will insert
 244 -- a necessary adjustment to the stack pointer.
 245 mkCbranch pred ifso ifnot = mkLast (CmmCondBranch pred ifso ifnot)
 246 mkSwitch e tbl            = mkLast $ CmmSwitch e tbl
 247
 248 mkSafeCall   t fs as upd i = withFreshLabel "safe call" $ body
 249   where
 250     body k =
 251      (    mkStore (CmmStackSlot (CallArea (Young k)) (widthInBytes wordWidth))
 252                   (CmmLit (CmmBlock k))
 253       <*> mkLast (CmmForeignCall {tgt=t, res=fs, args=as, succ=k, updfr=upd, intrbl=i})
 254       <*> mkLabel k)
 255 mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as
 256
 257 mkBranch bid = mkLast (CmmBranch bid)
 258
 259 mkCmmIfThenElse e tbranch fbranch =
 260   withFreshLabel "end of if"     $ \endif ->
 261   withFreshLabel "start of then" $ \tid ->
 262   withFreshLabel "start of else" $ \fid ->
 263     mkCbranch e tid fid <*>
 264     mkLabel tid <*> tbranch <*> mkBranch endif <*>
 265     mkLabel fid <*> fbranch <*> mkLabel endif
 266
 267 mkCmmIfThen e tbranch
 268   = withFreshLabel "end of if"     $ \endif ->
 269     withFreshLabel "start of then" $ \tid ->
 270       mkCbranch e tid endif <*>
 271       mkLabel tid <*> tbranch <*> mkLabel endif
 272
 273 mkCmmWhileDo e body =
 274   withFreshLabel "loop test" $ \test ->
 275   withFreshLabel "loop head" $ \head ->
 276   withFreshLabel "end while" $ \endwhile ->
 277     -- Forrest Baskett's while-loop layout
 278     mkBranch test <*> mkLabel head <*> body
 279                   <*> mkLabel test <*> mkCbranch e head endwhile
 280                   <*> mkLabel endwhile
 281
 282 -- For debugging purposes, we can stub out dead stack slots:
 283 stackStubExpr :: Width -> CmmExpr
 284 stackStubExpr w = CmmLit (CmmInt 0 w)
 285
 286 -- When we copy in parameters, we usually want to put overflow
 287 -- parameters on the stack, but sometimes we want to pass
 288 -- the variables in their spill slots.
 289 -- Therefore, for copying arguments and results, we provide different
 290 -- functions to pass the arguments in an overflow area and to pass them in spill slots.
 291 copyInOflow  :: Convention -> Area -> CmmFormals -> (Int, CmmAGraph)
 292 copyInSlot   :: Convention -> CmmFormals -> [CmmNode O O]
 293 copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset ->
 294                               (Int, CmmAGraph)
 295 copyOutSlot  :: Convention -> [LocalReg] -> [CmmNode O O]
 296
 297 copyInOflow conv area formals = (offset, catAGraphs $ map mkMiddle nodes)
 298   where (offset, nodes) = copyIn oneCopyOflowI conv area formals
 299 copyInSlot c f = snd $ copyIn oneCopySlotI c (panic "no area for copying to slots") f
 300
 301 type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) ->
 302                           (ByteOff, [CmmNode O O])
 303 type CopyIn  = SlotCopier -> Convention -> Area -> CmmFormals -> (ByteOff, [CmmNode O O])
 304
 305 -- Return the number of bytes used for copying arguments, as well as the
 306 -- instructions to copy the arguments.
 307 copyIn :: CopyIn
 308 copyIn oflow conv area formals =
 309   foldr ci (init_offset, []) args'
 310   where ci (reg, RegisterParam r) (n, ms) =
 311           (n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms)
 312         ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
 313         init_offset = widthInBytes wordWidth -- infotable
 314         args  = assignArgumentsPos conv localRegType formals
 315         args' = foldl adjust [] args
 316           where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
 317                 adjust rst x@(_, RegisterParam _) = x : rst
 318
 319 -- Copy-in one arg, using overflow space if needed.
 320 oneCopyOflowI, oneCopySlotI :: SlotCopier
 321 oneCopyOflowI area (reg, off) (n, ms) =
 322   (max n off, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) : ms)
 323   where ty = localRegType reg
 324
 325 -- Copy-in one arg, using spill slots if needed -- used for calling conventions at
 326 -- a procpoint that is not a return point. The offset is irrelevant here...
 327 oneCopySlotI _ (reg, _) (n, ms) =
 328   (n, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) : ms)
 329   where ty = localRegType reg
 330         w  = widthInBytes (typeWidth ty)
 331
 332
 333 -- Factoring out the common parts of the copyout functions yielded something
 334 -- more complicated:
 335
 336 -- The argument layout function ignores the pointer to the info table, so we slot that
 337 -- in here. When copying-out to a young area, we set the info table for return
 338 -- and adjust the offsets of the other parameters.
 339 -- If this is a call instruction, we adjust the offsets of the other parameters.
 340 copyOutOflow conv transfer area@(CallArea a) actuals updfr_off =
 341   foldr co (init_offset, emptyAGraph) args'
 342   where co (v, RegisterParam r) (n, ms) = (n, mkAssign (CmmGlobal r) v <*> ms)
 343         co (v, StackParam off)  (n, ms) =
 344           (max n off, mkStore (CmmStackSlot area off) v <*> ms)
 345         (setRA, init_offset) =
 346           case a of Young id -> id `seq` -- set RA if making a call
 347                       if transfer == Call then
 348                         ([(CmmLit (CmmBlock id), StackParam init_offset)],
 349                          widthInBytes wordWidth)
 350                       else ([], 0)
 351                     Old -> ([], updfr_off)
 352         args = assignArgumentsPos conv cmmExprType actuals
 353         args' = foldl adjust setRA args
 354           where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
 355                 adjust rst x@(_, RegisterParam _) = x : rst
 356 copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"
 357
 358 -- Args passed only in registers and stack slots; no overflow space.
 359 -- No return address may apply!
 360 copyOutSlot conv actuals = foldr co [] args
 361   where co (v, RegisterParam r) ms = CmmAssign (CmmGlobal r) (toExp v) : ms
 362         co (v, StackParam off)  ms = CmmStore  (CmmStackSlot (RegSlot v) off) (toExp v) : ms
 363         toExp r = CmmReg (CmmLocal r)
 364         args = assignArgumentsPos conv localRegType actuals
 365
 366 mkCallEntry :: Convention -> CmmFormals -> (Int, CmmAGraph)
 367 mkCallEntry conv formals = copyInOflow conv (CallArea Old) formals
 368
 369 lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
 370                 (ByteOff -> CmmAGraph) -> CmmAGraph
 371 lastWithArgs transfer area conv actuals updfr_off last =
 372   let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in
 373   copies <*> last outArgs
 374
 375 -- The area created for the jump and return arguments is the same area as the
 376 -- procedure entry.
 377 old :: Area
 378 old = CallArea Old
 379 toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> CmmAGraph
 380 toCall e cont updfr_off res_space arg_space =
 381   mkLast $ CmmCall e cont arg_space res_space updfr_off
 382 mkJump e actuals updfr_off =
 383   lastWithArgs Jump old NativeNodeCall actuals updfr_off $ toCall e Nothing updfr_off 0
 384 mkDirectJump e actuals updfr_off =
 385   lastWithArgs Jump old NativeDirectCall actuals updfr_off $ toCall e Nothing updfr_off 0
 386 mkJumpGC e actuals updfr_off =
 387   lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0
 388 mkForeignJump conv e actuals updfr_off =
 389   lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off 0
 390 mkReturn e actuals updfr_off =
 391   lastWithArgs Ret  old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
 392     -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
 393 mkReturnSimple actuals updfr_off =
 394   lastWithArgs Ret  old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
 395     where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
 396
 397 mkFinalCall f _ actuals updfr_off =
 398   lastWithArgs Call old NativeDirectCall actuals updfr_off $ toCall f Nothing updfr_off 0
 399
 400 mkCmmCall f results actuals = mkCall f (NativeDirectCall, NativeReturn) results actuals
 401
 402 -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
 403 mkCall f (callConv, retConv) results actuals updfr_off =
 404   withFreshLabel "call successor" $ \k ->
 405     let area = CallArea $ Young k
 406         (off, copyin) = copyInOflow retConv area results
 407         copyout = lastWithArgs Call area callConv actuals updfr_off
 408                                (toCall f (Just k) updfr_off off)
 409     in (copyout <*> mkLabel k <*> copyin)