-----------------------------------------------------------------------------
--
-- Cmm data types
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

module Cmm ( 
        GenCmm(..), Cmm, RawCmm,
        GenCmmTop(..), CmmTop, RawCmmTop,
        ListGraph(..),
        cmmMapGraph, cmmTopMapGraph,
        cmmMapGraphM, cmmTopMapGraphM,
        CmmInfo(..), UpdateFrame(..),
        CmmInfoTable(..), HasStaticClosure, ClosureTypeInfo(..), ConstrDescription,
        ProfilingInfo(..), ClosureTypeTag,
        GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
        CmmReturnInfo(..),
        CmmStmt(..), CmmActual, CmmActuals, CmmFormal, CmmFormals, 
        HintedCmmFormal, HintedCmmFormals, HintedCmmActual, HintedCmmActuals,
        CmmSafety(..),
        CmmCallTarget(..), CallishMachOp(..), pprCallishMachOp,
        ForeignHint(..), CmmHinted(..),
        CmmStatic(..), Section(..),
        module CmmExpr,
  ) where

#include "HsVersions.h"

import BlockId
import CmmExpr
import CLabel
import ForeignCall
import SMRep

import ClosureInfo
import Outputable
import FastString

import Data.Word


-- A [[BlockId]] is a local label.
-- Local labels must be unique within an entire compilation unit, not
-- just a single top-level item, because local labels map one-to-one
-- with assembly-language labels.

-----------------------------------------------------------------------------
--  Cmm, CmmTop, CmmBasicBlock
-----------------------------------------------------------------------------

-- A file is a list of top-level chunks.  These may be arbitrarily
-- re-orderd during code generation.

-- GenCmm is abstracted over
--   d, the type of static data elements in CmmData
--   h, the static info preceding the code of a CmmProc
--   g, the control-flow graph of a CmmProc
--
-- We expect there to be two main instances of this type:
--   (a) C--, i.e. populated with various C-- constructs
--       (Cmm and RawCmm below)
--   (b) Native code, populated with data/instructions
--
-- A second family of instances based on ZipCfg is work in progress.
--
newtype GenCmm d h g = Cmm [GenCmmTop d h g]

-- | A top-level chunk, abstracted over the type of the contents of
-- the basic blocks (Cmm or instructions are the likely instantiations).
data GenCmmTop d h g
  = CmmProc	-- A procedure
     h	               -- Extra header such as the info table
     CLabel            -- Used to generate both info & entry labels
     CmmFormals		     -- Argument locals live on entry (C-- procedure params)
                       -- XXX Odd that there are no kinds, but there you are ---NR
     g                 -- Control-flow graph for the procedure's code

  | CmmData 	-- Static data
	Section 
	[d]

-- | A control-flow graph represented as a list of extended basic blocks.
newtype ListGraph i = ListGraph [GenBasicBlock i] 
   -- ^ Code, may be empty.  The first block is the entry point.  The
   -- order is otherwise initially unimportant, but at some point the
   -- code gen will fix the order.

   -- BlockIds must be unique across an entire compilation unit, since
   -- they are translated to assembly-language labels, which scope
   -- across a whole compilation unit.

-- | Cmm with the info table as a data type
type Cmm    = GenCmm    CmmStatic CmmInfo (ListGraph CmmStmt)
type CmmTop = GenCmmTop CmmStatic CmmInfo (ListGraph CmmStmt)

-- | Cmm with the info tables converted to a list of 'CmmStatic'
type RawCmm    = GenCmm    CmmStatic [CmmStatic] (ListGraph CmmStmt)
type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] (ListGraph CmmStmt)


-- A basic block containing a single label, at the beginning.
-- The list of basic blocks in a top-level code block may be re-ordered.
-- Fall-through is not allowed: there must be an explicit jump at the
-- end of each basic block, but the code generator might rearrange basic
-- blocks in order to turn some jumps into fallthroughs.

data GenBasicBlock i = BasicBlock BlockId [i]
type CmmBasicBlock   = GenBasicBlock CmmStmt

instance UserOfLocalRegs i => UserOfLocalRegs (GenBasicBlock i) where
    foldRegsUsed f set (BasicBlock _ l) = foldRegsUsed f set l

blockId :: GenBasicBlock i -> BlockId
-- The branch block id is that of the first block in 
-- the branch, which is that branch's entry point
blockId (BasicBlock blk_id _ ) = blk_id

blockStmts :: GenBasicBlock i -> [i]
blockStmts (BasicBlock _ stmts) = stmts


mapBlockStmts :: (i -> i') -> GenBasicBlock i -> GenBasicBlock i'
mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs)
----------------------------------------------------------------
--   graph maps
----------------------------------------------------------------

cmmMapGraph    :: (g -> g') -> GenCmm    d h g -> GenCmm    d h g'
cmmTopMapGraph :: (g -> g') -> GenCmmTop d h g -> GenCmmTop d h g'

cmmMapGraphM    :: Monad m => (String -> g -> m g') -> GenCmm    d h g -> m (GenCmm    d h g')
cmmTopMapGraphM :: Monad m => (String -> g -> m g') -> GenCmmTop d h g -> m (GenCmmTop d h g')

cmmMapGraph f (Cmm tops) = Cmm $ map (cmmTopMapGraph f) tops
cmmTopMapGraph f (CmmProc h l args g) = CmmProc h l args (f g)
cmmTopMapGraph _ (CmmData s ds)             = CmmData s ds

cmmMapGraphM f (Cmm tops) = mapM (cmmTopMapGraphM f) tops >>= return . Cmm
cmmTopMapGraphM f (CmmProc h l args g) =
  f (showSDoc $ ppr l) g >>= return . CmmProc h l args
cmmTopMapGraphM _ (CmmData s ds)       = return $ CmmData s ds

-----------------------------------------------------------------------------
--     Info Tables
-----------------------------------------------------------------------------

data CmmInfo
  = CmmInfo
      (Maybe BlockId)     -- GC target. Nothing <=> CPS won't do stack check
                          -- JD: NOT USED BY NEW CODE GEN
      (Maybe UpdateFrame) -- Update frame
      CmmInfoTable        -- Info table

-- Info table as a haskell data type
data CmmInfoTable
  = CmmInfoTable
      HasStaticClosure
      ProfilingInfo
      ClosureTypeTag -- Int
      ClosureTypeInfo
  | CmmNonInfoTable   -- Procedure doesn't need an info table

type HasStaticClosure = Bool

-- TODO: The GC target shouldn't really be part of CmmInfo
-- as it doesn't appear in the resulting info table.
-- It should be factored out.

data ClosureTypeInfo
  = ConstrInfo ClosureLayout ConstrTag ConstrDescription
  | FunInfo    ClosureLayout C_SRT FunArity ArgDescr SlowEntry
  | ThunkInfo  ClosureLayout C_SRT
  | ThunkSelectorInfo SelectorOffset C_SRT
  | ContInfo
      [Maybe LocalReg]  -- Stack layout: Just x, an item x
                        --               Nothing: a 1-word gap
			-- Start of list is the *young* end
      C_SRT

data CmmReturnInfo = CmmMayReturn
                   | CmmNeverReturns
    deriving ( Eq )

-- TODO: These types may need refinement
data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc
type ClosureTypeTag = StgHalfWord
type ClosureLayout = (StgHalfWord, StgHalfWord) -- ptrs, nptrs
type ConstrTag = StgHalfWord
type ConstrDescription = CmmLit
type FunArity = StgHalfWord
type SlowEntry = CmmLit
  -- We would like this to be a CLabel but
  -- for now the parser sets this to zero on an INFO_TABLE_FUN.
type SelectorOffset = StgWord

-- | A frame that is to be pushed before entry to the function.
-- Used to handle 'update' frames.
data UpdateFrame =
    UpdateFrame
      CmmExpr    -- Frame header.  Behaves like the target of a 'jump'.
      [CmmExpr]  -- Frame remainder.  Behaves like the arguments of a 'jump'.

-----------------------------------------------------------------------------
--		CmmStmt
-- A "statement".  Note that all branches are explicit: there are no
-- control transfers to computed addresses, except when transfering
-- control to a new function.
-----------------------------------------------------------------------------

data CmmStmt	-- Old-style
  = CmmNop
  | CmmComment FastString

  | CmmAssign CmmReg CmmExpr	 -- Assign to register

  | CmmStore CmmExpr CmmExpr     -- Assign to memory location.  Size is
                                 -- given by cmmExprType of the rhs.

  | CmmCall	 		 -- A call (forign, native or primitive), with 
     CmmCallTarget
     HintedCmmFormals		 -- zero or more results
     HintedCmmActuals		 -- zero or more arguments
     CmmSafety			 -- whether to build a continuation
     CmmReturnInfo

  | CmmBranch BlockId             -- branch to another BB in this fn

  | CmmCondBranch CmmExpr BlockId -- conditional branch

  | CmmSwitch CmmExpr [Maybe BlockId]   -- Table branch
	-- The scrutinee is zero-based; 
	--	zero -> first block
	--	one  -> second block etc
	-- Undefined outside range, and when there's a Nothing

  | CmmJump CmmExpr      -- Jump to another C-- function,
      HintedCmmActuals         -- with these parameters.  (parameters never used)

  | CmmReturn            -- Return from a native C-- function,
      HintedCmmActuals         -- with these return values. (parameters never used)

type CmmActual = CmmExpr
type CmmFormal = LocalReg
type CmmActuals = [CmmActual]
type CmmFormals = [CmmFormal]

data CmmHinted a = CmmHinted { hintlessCmm :: a, cmmHint :: ForeignHint }
	   	 deriving( Eq )

type HintedCmmActuals = [HintedCmmActual]
type HintedCmmFormals = [HintedCmmFormal]
type HintedCmmFormal  = CmmHinted CmmFormal
type HintedCmmActual  = CmmHinted CmmActual

data CmmSafety      = CmmUnsafe | CmmSafe C_SRT

-- | enable us to fold used registers over 'CmmActuals' and 'CmmFormals'
instance UserOfLocalRegs CmmStmt where
  foldRegsUsed f (set::b) s = stmt s set
    where 
      stmt :: CmmStmt -> b -> b
      stmt (CmmNop)                  = id
      stmt (CmmComment {})           = id
      stmt (CmmAssign _ e)           = gen e
      stmt (CmmStore e1 e2)          = gen e1 . gen e2
      stmt (CmmCall target _ es _ _) = gen target . gen es
      stmt (CmmBranch _)             = id
      stmt (CmmCondBranch e _)       = gen e
      stmt (CmmSwitch e _)           = gen e
      stmt (CmmJump e es)            = gen e . gen es
      stmt (CmmReturn es)            = gen es

      gen :: UserOfLocalRegs a => a -> b -> b
      gen a set = foldRegsUsed f set a

instance UserOfLocalRegs CmmCallTarget where
    foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e
    foldRegsUsed _ set (CmmPrim {})    = set

instance UserOfSlots CmmCallTarget where
    foldSlotsUsed f set (CmmCallee e _) = foldSlotsUsed f set e
    foldSlotsUsed _ set (CmmPrim {})    = set

instance UserOfLocalRegs a => UserOfLocalRegs (CmmHinted a) where
  foldRegsUsed f set a = foldRegsUsed f set (hintlessCmm a)

instance UserOfSlots a => UserOfSlots (CmmHinted a) where
  foldSlotsUsed f set a = foldSlotsUsed f set (hintlessCmm a)

instance DefinerOfLocalRegs a => DefinerOfLocalRegs (CmmHinted a) where
  foldRegsDefd f set a = foldRegsDefd f set (hintlessCmm a)

{-
Discussion
~~~~~~~~~~

One possible problem with the above type is that the only way to do a
non-local conditional jump is to encode it as a branch to a block that
contains a single jump.  This leads to inefficient code in the back end.

[N.B. This problem will go away when we make the transition to the
'zipper' form of control-flow graph, in which both targets of a
conditional jump are explicit. ---NR]

One possible way to fix this would be:

data CmmStat = 
  ...
  | CmmJump CmmBranchDest
  | CmmCondJump CmmExpr CmmBranchDest
  ...

data CmmBranchDest
  = Local BlockId
  | NonLocal CmmExpr [LocalReg]

In favour:

+ one fewer constructors in CmmStmt
+ allows both cond branch and switch to jump to non-local destinations

Against:

- not strictly necessary: can already encode as branch+jump
- not always possible to implement any better in the back end
- could do the optimisation in the back end (but then plat-specific?)
- C-- doesn't have it
- back-end optimisation might be more general (jump shortcutting)

So we'll stick with the way it is, and add the optimisation to the NCG.
-}

-----------------------------------------------------------------------------
--		CmmCallTarget
--
-- The target of a CmmCall.
-----------------------------------------------------------------------------

data CmmCallTarget
  = CmmCallee		-- Call a function (foreign or native)
	CmmExpr 		-- literal label <=> static call
				-- other expression <=> dynamic call
	CCallConv		-- The calling convention

  | CmmPrim		-- Call a "primitive" (eg. sin, cos)
	CallishMachOp		-- These might be implemented as inline
				-- code by the backend.
  deriving Eq


data ForeignHint
  = NoHint | AddrHint | SignedHint
  deriving( Eq )
	-- Used to give extra per-argument or per-result
	-- information needed by foreign calling conventions


-- CallishMachOps tend to be implemented by foreign calls in some backends,
-- so we separate them out.  In Cmm, these can only occur in a
-- statement position, in contrast to an ordinary MachOp which can occur
-- anywhere in an expression.
data CallishMachOp
  = MO_F64_Pwr
  | MO_F64_Sin
  | MO_F64_Cos
  | MO_F64_Tan
  | MO_F64_Sinh
  | MO_F64_Cosh
  | MO_F64_Tanh
  | MO_F64_Asin
  | MO_F64_Acos
  | MO_F64_Atan
  | MO_F64_Log
  | MO_F64_Exp
  | MO_F64_Sqrt
  | MO_F32_Pwr
  | MO_F32_Sin
  | MO_F32_Cos
  | MO_F32_Tan
  | MO_F32_Sinh
  | MO_F32_Cosh
  | MO_F32_Tanh
  | MO_F32_Asin
  | MO_F32_Acos
  | MO_F32_Atan
  | MO_F32_Log
  | MO_F32_Exp
  | MO_F32_Sqrt
  | MO_WriteBarrier
  | MO_Touch         -- Keep variables live (when using interior pointers)
  deriving (Eq, Show)

pprCallishMachOp :: CallishMachOp -> SDoc
pprCallishMachOp mo = text (show mo)
  
-----------------------------------------------------------------------------
--		Static Data
-----------------------------------------------------------------------------

data Section
  = Text
  | Data
  | ReadOnlyData
  | RelocatableReadOnlyData
  | UninitialisedData
  | ReadOnlyData16	-- .rodata.cst16 on x86_64, 16-byte aligned
  | OtherSection String

data CmmStatic
  = CmmStaticLit CmmLit	
	-- a literal value, size given by cmmLitRep of the literal.
  | CmmUninitialised Int
	-- uninitialised data, N bytes long
  | CmmAlign Int
	-- align to next N-byte boundary (N must be a power of 2).
  | CmmDataLabel CLabel
	-- label the current position in this section.
  | CmmString [Word8]
	-- string of 8-bit values only, not zero terminated.