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 copyOutSlot  :: Convention -> [LocalReg] -> [CmmNode O O]
 294
 295 copyInOflow conv area formals = (offset, catAGraphs $ map mkMiddle nodes)
 296   where (offset, nodes) = copyIn oneCopyOflowI conv area formals
 297 copyInSlot c f = snd $ copyIn oneCopySlotI c (panic "no area for copying to slots") f
 298
 299 type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) ->
 300                           (ByteOff, [CmmNode O O])
 301 type CopyIn  = SlotCopier -> Convention -> Area -> CmmFormals -> (ByteOff, [CmmNode O O])
 302
 303 -- Return the number of bytes used for copying arguments, as well as the
 304 -- instructions to copy the arguments.
 305 copyIn :: CopyIn
 306 copyIn oflow conv area formals =
 307   foldr ci (init_offset, []) args'
 308   where ci (reg, RegisterParam r) (n, ms) =
 309           (n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms)
 310         ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
 311         init_offset = widthInBytes wordWidth -- infotable
 312         args  = assignArgumentsPos conv localRegType formals
 313         args' = foldl adjust [] args
 314           where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
 315                 adjust rst x@(_, RegisterParam _) = x : rst
 316
 317 -- Copy-in one arg, using overflow space if needed.
 318 oneCopyOflowI, oneCopySlotI :: SlotCopier
 319 oneCopyOflowI area (reg, off) (n, ms) =
 320   (max n off, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) : ms)
 321   where ty = localRegType reg
 322
 323 -- Copy-in one arg, using spill slots if needed -- used for calling conventions at
 324 -- a procpoint that is not a return point. The offset is irrelevant here...
 325 oneCopySlotI _ (reg, _) (n, ms) =
 326   (n, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) : ms)
 327   where ty = localRegType reg
 328         w  = widthInBytes (typeWidth ty)
 329
 330
 331 -- Factoring out the common parts of the copyout functions yielded something
 332 -- more complicated:
 333
 334 copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset ->
 335                               (Int, CmmAGraph)
 336 -- Generate code to move the actual parameters into the locations
 337 -- required by the calling convention.  This includes a store for the return address.
 338 --
 339 -- The argument layout function ignores the pointer to the info table, so we slot that
 340 -- in here. When copying-out to a young area, we set the info table for return
 341 -- and adjust the offsets of the other parameters.
 342 -- If this is a call instruction, we adjust the offsets of the other parameters.
 343 copyOutOflow conv transfer area@(CallArea a) actuals updfr_off
 344   = foldr co (init_offset, emptyAGraph) args'
 345   where
 346     co (v, RegisterParam r) (n, ms) = (n, mkAssign (CmmGlobal r) v <*> ms)
 347     co (v, StackParam off)  (n, ms) = (max n off, mkStore (CmmStackSlot area off) v <*> ms)
 348
 349     (setRA, init_offset) =
 350       case a of Young id -> id `seq` -- Generate a store instruction for
 351                                      -- the return address if making a call
 352                   if transfer == Call then
 353                     ([(CmmLit (CmmBlock id), StackParam init_offset)],
 354                      widthInBytes wordWidth)
 355                   else ([], 0)
 356                 Old -> ([], updfr_off)
 357
 358     args :: [(CmmExpr, ParamLocation ByteOff)]   -- The argument and where to put it
 359     args = assignArgumentsPos conv cmmExprType actuals
 360
 361     args' = foldl adjust setRA args
 362       where adjust rst   (v, StackParam off)  = (v, StackParam (off + init_offset)) : rst
 363             adjust rst x@(_, RegisterParam _) = x : rst
 364
 365 copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"
 366
 367 -- Args passed only in registers and stack slots; no overflow space.
 368 -- No return address may apply!
 369 copyOutSlot conv actuals = foldr co [] args
 370   where co (v, RegisterParam r) ms = CmmAssign (CmmGlobal r) (toExp v) : ms
 371         co (v, StackParam off)  ms = CmmStore  (CmmStackSlot (RegSlot v) off) (toExp v) : ms
 372         toExp r = CmmReg (CmmLocal r)
 373         args = assignArgumentsPos conv localRegType actuals
 374
 375 mkCallEntry :: Convention -> CmmFormals -> (Int, CmmAGraph)
 376 mkCallEntry conv formals = copyInOflow conv (CallArea Old) formals
 377
 378 lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
 379                 (ByteOff -> CmmAGraph) -> CmmAGraph
 380 lastWithArgs transfer area conv actuals updfr_off last =
 381   let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in
 382   copies <*> last outArgs
 383
 384 -- The area created for the jump and return arguments is the same area as the
 385 -- procedure entry.
 386 old :: Area
 387 old = CallArea Old
 388 toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> CmmAGraph
 389 toCall e cont updfr_off res_space arg_space =
 390   mkLast $ CmmCall e cont arg_space res_space updfr_off
 391 mkJump e actuals updfr_off =
 392   lastWithArgs Jump old NativeNodeCall actuals updfr_off $ toCall e Nothing updfr_off 0
 393 mkDirectJump e actuals updfr_off =
 394   lastWithArgs Jump old NativeDirectCall actuals updfr_off $ toCall e Nothing updfr_off 0
 395 mkJumpGC e actuals updfr_off =
 396   lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0
 397 mkForeignJump conv e actuals updfr_off =
 398   lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off 0
 399 mkReturn e actuals updfr_off =
 400   lastWithArgs Ret  old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
 401     -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
 402 mkReturnSimple actuals updfr_off =
 403   lastWithArgs Ret  old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
 404     where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
 405
 406 mkFinalCall f _ actuals updfr_off =
 407   lastWithArgs Call old NativeDirectCall actuals updfr_off $ toCall f Nothing updfr_off 0
 408
 409 mkCmmCall f results actuals = mkCall f (NativeDirectCall, NativeReturn) results actuals
 410
 411 -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
 412 mkCall f (callConv, retConv) results actuals updfr_off =
 413   withFreshLabel "call successor" $ \k ->
 414     let area = CallArea $ Young k
 415         (off, copyin) = copyInOflow retConv area results
 416         copyout = lastWithArgs Call area callConv actuals updfr_off
 417                                (toCall f (Just k) updfr_off off)
 418     in (copyout <*> mkLabel k <*> copyin)