    {-# OPTIONS -Wall -fno-warn-name-shadowing #-}

    -- This is the module to import to be able to build C-- programs.
    -- It should not be necessary to import MkZipCfg or ZipCfgCmmRep.
    -- If you find it necessary to import these other modules, please
    -- complain to Norman Ramsey.

    module MkZipCfgCmm
      ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkSafeCall, mkUnsafeCall, mkFinalCall
             , mkJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch, mkReturn
             , mkReturnSimple, mkComment, copyInOflow, copyInSlot, copyOutOflow, copyOutSlot
             , mkEntry, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
      , (<*>), catAGraphs, mkLabel, mkBranch
      , emptyAGraph, withFreshLabel, withUnique, outOfLine
      , lgraphOfAGraph, graphOfAGraph, labelAGraph
      , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, CmmStackInfo
      , Middle, Last, Convention(..), ForeignConvention(..), MidCallTarget(..), Transfer(..)
      , stackStubExpr, pprAGraph
      )
    where

    #include "HsVersions.h"

    import BlockId
    import CmmExpr
    import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
               , CmmActuals, CmmFormals
               )
    import CmmCallConv (assignArgumentsPos, ParamLocation(..))
    import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ)
      -- to make this module more self-contained, the above definitions are
      -- duplicated below
    import PprCmm()

    import FastString
    import ForeignCall
    import MkZipCfg
    import Panic
    import SMRep (ByteOff)
    import StaticFlags
    import ZipCfg

    type CmmGraph  = LGraph Middle Last
    type CmmAGraph = AGraph Middle Last
    type CmmBlock  = Block  Middle Last
    type CmmStackInfo            = (ByteOff, Maybe ByteOff)
      -- probably want a record; (SP offset on entry, update frame space)
    type CmmZ                    = GenCmm    CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
    type CmmTopZ                 = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph)

    data Transfer = Call | Jump | Ret deriving Eq

    ---------- No-ops
    mkNop        :: CmmAGraph
    mkComment    :: FastString -> CmmAGraph

    ---------- Assignment and store
    mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
    mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph

    ---------- Calls
    mkCall       :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals ->
                      UpdFrameOffset -> CmmAGraph
    mkCmmCall    :: CmmExpr ->              CmmFormals -> CmmActuals ->
                      UpdFrameOffset -> CmmAGraph
      -- Native C-- calling convention
    mkSafeCall    :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> CmmAGraph
    mkUnsafeCall  :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
    mkFinalCall   :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph
      -- Never returns; like exit() or barf()

    ---------- Control transfer
    mkJump       	::               CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
    mkJumpGC       	::               CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
    mkForeignJump   :: Convention -> CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
    mkCbranch    	:: CmmExpr -> BlockId -> BlockId          -> CmmAGraph
    mkSwitch     	:: CmmExpr -> [Maybe BlockId]             -> CmmAGraph
    mkReturn     	:: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
    mkReturnSimple  :: CmmActuals -> UpdFrameOffset -> CmmAGraph

    mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
    mkCmmIfThen     :: CmmExpr -> CmmAGraph -> CmmAGraph
    mkCmmWhileDo    :: CmmExpr -> CmmAGraph -> CmmAGraph

    -- Not to be forgotten, but exported by MkZipCfg:
    -- mkBranch   	  :: BlockId -> CmmAGraph
    -- mkLabel    	  :: BlockId -> Maybe Int -> CmmAGraph
    -- outOfLine  	  :: CmmAGraph -> CmmAGraph
    -- withUnique 	  :: (Unique -> CmmAGraph) -> CmmAGraph
    -- withFreshLabel :: String -> (BlockId -> CmmAGraph) -> CmmAGraph

    --------------------------------------------------------------------------

    mkCmmWhileDo    e = mkWhileDo (mkCbranch e)
    mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)

    mkCmmIfThen e tbranch
      = withFreshLabel "end of if"     $ \endif ->
        withFreshLabel "start of then" $ \tid ->
        mkCbranch e tid endif <*>
        mkLabel tid   <*> tbranch <*> mkBranch endif <*>
        mkLabel endif

    -- ================ IMPLEMENTATION ================--

    mkNop                     = emptyAGraph
    mkComment fs              = mkMiddle $ MidComment fs
    mkStore  l r              = mkMiddle $ MidStore  l r

    -- NEED A COMPILER-DEBUGGING FLAG HERE
    -- Sanity check: any value assigned to a pointer must be non-zero.
    -- If it's 0, cause a crash immediately.
    mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r
      where assign l r = mkMiddle (MidAssign l r)
            check (CmmGlobal _) = mkNop
            check l@(CmmLocal reg) = -- if a ptr arg is NULL, cause a crash!
              if isGcPtrType ty then
                mkCmmIfThen (CmmMachOp (MO_Eq w) [r, stackStubExpr w])
                            (assign l (CmmLoad (CmmLit (CmmInt 0 w)) ty))
              else mkNop
                where ty = localRegType reg
                      w  = typeWidth ty
                      r  = CmmReg l

    -- Why are we inserting extra blocks that simply branch to the successors?
    -- Because in addition to the branch instruction, @mkBranch@ will insert
    -- a necessary adjustment to the stack pointer.
    mkCbranch pred ifso ifnot = mkLast (LastCondBranch pred ifso ifnot)
    mkSwitch e tbl            = mkLast $ LastSwitch e tbl

    mkSafeCall   t fs as upd =
      withFreshLabel "safe call" $ \k ->
        mkMiddle $ MidForeignCall (Safe k upd) t fs as
    mkUnsafeCall t fs as = mkMiddle $ MidForeignCall Unsafe t fs as

    -- For debugging purposes, we can stub out dead stack slots:
    stackStubExpr :: Width -> CmmExpr
    stackStubExpr w = CmmLit (CmmInt 0 w)

    -- When we copy in parameters, we usually want to put overflow
    -- parameters on the stack, but sometimes we want to pass
    -- the variables in their spill slots.
    -- Therefore, for copying arguments and results, we provide different
    -- functions to pass the arguments in an overflow area and to pass them in spill slots.
    copyInOflow  :: Convention -> Area -> CmmFormals -> (Int, CmmAGraph)
    copyInSlot   :: Convention -> CmmFormals -> CmmAGraph
    copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset ->
                                  (Int, [Middle])
    copyOutSlot  :: Convention -> [LocalReg] -> [Middle]
      -- why a list of middles here instead of an AGraph?

    copyInOflow      = copyIn oneCopyOflowI
    copyInSlot c f = snd $ copyIn oneCopySlotI c (panic "no area for copying to slots") f

    type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, CmmAGraph) ->
                              (ByteOff, CmmAGraph)
    type CopyIn  = SlotCopier -> Convention -> Area -> CmmFormals -> (ByteOff, CmmAGraph)

    -- Return the number of bytes used for copying arguments, as well as the
    -- instructions to copy the arguments.
    copyIn :: CopyIn
    copyIn oflow conv area formals =
      foldr ci (init_offset, mkNop) args'
      where ci (reg, RegisterParam r) (n, ms) =
              (n, mkAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) <*> ms)
            ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
            init_offset = widthInBytes wordWidth -- infotable
            args  = assignArgumentsPos conv localRegType formals
            args' = foldl adjust [] args
              where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
                    adjust rst x@(_, RegisterParam _) = x : rst

    -- Copy-in one arg, using overflow space if needed.
    oneCopyOflowI, oneCopySlotI :: SlotCopier
    oneCopyOflowI area (reg, off) (n, ms) =
      (max n off, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) <*> ms)
      where ty = localRegType reg

    -- Copy-in one arg, using spill slots if needed -- used for calling conventions at
    -- a procpoint that is not a return point. The offset is irrelevant here...
    oneCopySlotI _ (reg, _) (n, ms) =
      (n, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) <*> ms)
      where ty = localRegType reg
            w  = widthInBytes (typeWidth ty)

    -- Factoring out the common parts of the copyout functions yielded something
    -- more complicated:

    -- The argument layout function ignores the pointer to the info table, so we slot that
    -- in here. When copying-out to a young area, we set the info table for return
    -- and adjust the offsets of the other parameters.
    -- If this is a call instruction, we adjust the offsets of the other parameters.
    copyOutOflow conv transfer area@(CallArea a) actuals updfr_off =
      foldr co (init_offset, []) args'
      where co (v, RegisterParam r) (n, ms) = (n, MidAssign (CmmGlobal r) v : ms)
            co (v, StackParam off)  (n, ms) =
              (max n off, MidStore (CmmStackSlot area off) v : ms)
            (setRA, init_offset) =
              case a of Young id@(BlockId _) -> -- set RA if making a call
                          if transfer == Call then
                            ([(CmmLit (CmmBlock id), StackParam init_offset)],
                             widthInBytes wordWidth)
                          else ([], 0)
                        Old -> ([], updfr_off)
            args = assignArgumentsPos conv cmmExprType actuals
            args' = foldl adjust setRA args
              where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
                    adjust rst x@(_, RegisterParam _) = x : rst
    copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"

    -- Args passed only in registers and stack slots; no overflow space.
    -- No return address may apply!
    copyOutSlot conv actuals = foldr co [] args
      where co (v, RegisterParam r) ms = MidAssign (CmmGlobal r) (toExp v) : ms
            co (v, StackParam off)  ms =
              MidStore (CmmStackSlot (RegSlot v) off) (toExp v) : ms
            toExp r = CmmReg (CmmLocal r)
            args = assignArgumentsPos conv localRegType actuals

    -- oneCopySlotO _ (reg, _) (n, ms) =
    --   (n, MidStore (CmmStackSlot (RegSlot reg) w) reg : ms)
    --   where w = widthInBytes (typeWidth (localRegType reg))

    mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph)
    mkEntry _ conv formals = copyInOflow conv (CallArea Old) formals

    lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
                    (ByteOff -> Last) -> CmmAGraph
    lastWithArgs transfer area conv actuals updfr_off last =
      let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in
      mkMiddles copies <*> mkLast (last outArgs)

    -- The area created for the jump and return arguments is the same area as the
    -- procedure entry.
    old :: Area
    old = CallArea Old
    toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> Last
    toCall e cont updfr_off res_space arg_space =
      LastCall e cont arg_space res_space (Just updfr_off)
    mkJump e actuals updfr_off =
      lastWithArgs Jump old NativeNodeCall actuals updfr_off $ toCall e Nothing updfr_off 0
    mkJumpGC e actuals updfr_off =
      lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0
    mkForeignJump conv e actuals updfr_off =
      lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off 0
    mkReturn e actuals updfr_off =
      lastWithArgs Ret  old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
        -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
    mkReturnSimple actuals updfr_off =
      lastWithArgs Ret  old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
        where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord

    mkFinalCall f _ actuals updfr_off =
      lastWithArgs Call old NativeDirectCall actuals updfr_off $ toCall f Nothing updfr_off 0

    mkCmmCall f results actuals = mkCall f (NativeDirectCall, NativeReturn) results actuals

    -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
    mkCall f (callConv, retConv) results actuals updfr_off =
      withFreshLabel "call successor" $ \k ->
        let area = CallArea $ Young k
            (off, copyin) = copyInOflow retConv area results
            copyout = lastWithArgs Call area callConv actuals updfr_off
                                   (toCall f (Just k) updfr_off off)
        in (copyout <*> mkLabel k <*> copyin)