{-# 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)