{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}

-- | Formats on this architecture
--      A Format is a combination of width and class
--
--      TODO:   Signed vs unsigned?
--
--      TODO:   This module is currently shared by all architectures because
--              NCGMonad need to know about it to make a VReg. It would be better
--              to have architecture specific formats, and do the overloading
--              properly. eg SPARC doesn't care about FF80.
--
module GHC.CmmToAsm.Format (
    Format(.., IntegerFormat),
    ScalarFormat(..),
    intFormat,
    floatFormat,
    isIntFormat,
    isIntScalarFormat,
    intScalarFormat,
    isFloatFormat,
    vecFormat,
    isVecFormat,
    cmmTypeFormat,
    formatToWidth,
    scalarWidth,
    formatInBytes,
    isFloatScalarFormat,
    isFloatOrFloatVecFormat,
    floatScalarFormat,
    scalarFormatFormat,
    VirtualRegWithFormat(..),
    RegWithFormat(..),
    takeVirtualRegs,
    takeRealRegs,
)

where

import GHC.Prelude

import GHC.Cmm
import GHC.Platform.Reg ( Reg(..), RealReg, VirtualReg )
import GHC.Types.Unique ( Uniquable(..) )
import GHC.Types.Unique.Set
import GHC.Utils.Outputable
import GHC.Utils.Panic

{- Note [GHC's data format representations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC has severals types that represent various aspects of data format.
These include:

 * 'CmmType.CmmType': The data classification used throughout the C--
   pipeline. This is a pair of a CmmCat and a Width.

 * 'CmmType.CmmCat': What the bits in a C-- value mean (e.g. a pointer, integer, or floating-point value)

 * 'CmmType.Width': The width of a C-- value.

 * 'CmmType.Length': The width (measured in number of scalars) of a vector value.

 * 'Format.Format': The data format representation used by much of the backend.

 * 'Format.ScalarFormat': The format of a 'Format.VecFormat'\'s scalar.

 * 'RegClass.RegClass': Whether a register is an integer or a floating point/vector register.
-}

-- It looks very like the old MachRep, but it's now of purely local
-- significance, here in the native code generator.  You can change it
-- without global consequences.
--
-- A major use is as an opcode qualifier; thus the opcode
--      mov.l a b
-- might be encoded
--      MOV II32 a b
-- where the Format field encodes the ".l" part.

-- ToDo: it's not clear to me that we need separate signed-vs-unsigned formats
--        here.  I've removed them from the x86 version, we'll see what happens --SDM

-- ToDo: quite a few occurrences of Format could usefully be replaced by Width

data Format
        = II8
        | II16
        | II32
        | II64
        | FF32
        | FF64
        | VecFormat !Length       -- ^ number of elements (always at least 2)
                    !ScalarFormat -- ^ format of each element
        deriving (Show, Eq, Ord)

pattern IntegerFormat :: Format
pattern IntegerFormat <- ( isIntegerFormat -> True )
{-# COMPLETE IntegerFormat, FF32, FF64, VecFormat #-}

isIntegerFormat :: Format -> Bool
isIntegerFormat = \case
  II8  -> True
  II16 -> True
  II32 -> True
  II64 -> True
  _    -> False


instance Outputable Format where
  ppr fmt = text (show fmt)

data ScalarFormat
  = FmtInt8
  | FmtInt16
  | FmtInt32
  | FmtInt64
  | FmtFloat
  | FmtDouble
  deriving (Show, Eq, Ord)

scalarFormatFormat :: ScalarFormat -> Format
scalarFormatFormat = \case
  FmtInt8 -> II8
  FmtInt16 -> II16
  FmtInt32 -> II32
  FmtInt64 -> II64
  FmtFloat -> FF32
  FmtDouble -> FF64

isFloatScalarFormat :: ScalarFormat -> Bool
isFloatScalarFormat = \case
  FmtFloat -> True
  FmtDouble -> True
  _ -> False

isFloatOrFloatVecFormat :: Format -> Bool
isFloatOrFloatVecFormat = \case
  VecFormat _ sFmt -> isFloatScalarFormat sFmt
  fmt -> isFloatFormat fmt

floatScalarFormat :: Width -> ScalarFormat
floatScalarFormat W32 = FmtFloat
floatScalarFormat W64 = FmtDouble
floatScalarFormat w = pprPanic "floatScalarFormat" (ppr w)

isIntScalarFormat :: ScalarFormat -> Bool
isIntScalarFormat = not . isFloatScalarFormat

intScalarFormat :: Width -> ScalarFormat
intScalarFormat = \case
  W8  -> FmtInt8
  W16 -> FmtInt16
  W32 -> FmtInt32
  W64 -> FmtInt64
  w   -> pprPanic "intScalarFormat" (ppr w)

-- | Get the integer format of this width.
intFormat :: Width -> Format
intFormat width
 = case width of
        W8      -> II8
        W16     -> II16
        W32     -> II32
        W64     -> II64
        other   -> sorry $ "The native code generator cannot " ++
            "produce code for Format.intFormat " ++ show other
            ++ "\n\tConsider using the llvm backend with -fllvm"

-- | Check if a format represent an integer value.
isIntFormat :: Format -> Bool
isIntFormat format =
  case format of
    II8  -> True
    II16 -> True
    II32 -> True
    II64 -> True
    _    -> False

-- | Get the float format of this width.
floatFormat :: Width -> Format
floatFormat width
 = case width of
        W32     -> FF32
        W64     -> FF64
        other   -> pprPanic "Format.floatFormat" (ppr other)

-- | Check if a format represents a floating point value.
isFloatFormat :: Format -> Bool
isFloatFormat format
 = case format of
        FF32    -> True
        FF64    -> True
        _       -> False

vecFormat :: CmmType -> Format
vecFormat ty =
  let l      = vecLength ty
      elemTy = vecElemType ty
   in if isFloatType elemTy
      then case typeWidth elemTy of
             W32 -> VecFormat l FmtFloat
             W64 -> VecFormat l FmtDouble
             _   -> pprPanic "Incorrect vector element width" (ppr elemTy)
      else case typeWidth elemTy of
             W8  -> VecFormat l FmtInt8
             W16 -> VecFormat l FmtInt16
             W32 -> VecFormat l FmtInt32
             W64 -> VecFormat l FmtInt64
             _   -> pprPanic "Incorrect vector element width" (ppr elemTy)

-- | Check if a format represents a vector
isVecFormat :: Format -> Bool
isVecFormat (VecFormat {}) = True
isVecFormat _              = False


-- | Convert a Cmm type to a Format.
cmmTypeFormat :: CmmType -> Format
cmmTypeFormat ty
        | isFloatType ty        = floatFormat (typeWidth ty)
        | isVecType ty          = vecFormat ty
        | otherwise             = intFormat (typeWidth ty)


-- | Get the Width of a Format.
formatToWidth :: Format -> Width
formatToWidth format
 = case format of
        II8  -> W8
        II16 -> W16
        II32 -> W32
        II64 -> W64
        FF32 -> W32
        FF64 -> W64
        VecFormat l s ->
          widthFromBytes (l * widthInBytes (scalarWidth s))

scalarWidth :: ScalarFormat -> Width
scalarWidth = \case
  FmtInt8   -> W8
  FmtInt16  -> W16
  FmtInt32  -> W32
  FmtInt64  -> W64
  FmtFloat  -> W32
  FmtDouble -> W64

formatInBytes :: Format -> Int
formatInBytes = widthInBytes . formatToWidth

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

-- | A typed virtual register: a virtual register, together with the specific
-- format we are using it at.
data VirtualRegWithFormat
    = VirtualRegWithFormat
    { virtualRegWithFormat_reg :: {-# UNPACK #-} !VirtualReg
    , virtualRegWithFormat_format :: !Format
    }

-- | A typed register: a register, together with the specific format we
-- are using it at.
data RegWithFormat
    = RegWithFormat
    { regWithFormat_reg :: {-# UNPACK #-} !Reg
    , regWithFormat_format :: !Format
    }

instance Show RegWithFormat where
  show (RegWithFormat reg fmt) = show reg ++ "::" ++ show fmt

instance Uniquable RegWithFormat where
  getUnique = getUnique . regWithFormat_reg

instance Outputable VirtualRegWithFormat where
  ppr (VirtualRegWithFormat reg fmt) = ppr reg <+> dcolon <+> ppr fmt

instance Outputable RegWithFormat where
  ppr (RegWithFormat reg fmt) = ppr reg <+> dcolon <+> ppr fmt

-- | Take all the virtual registers from this set.
takeVirtualRegs :: UniqSet RegWithFormat -> UniqSet VirtualReg
takeVirtualRegs = mapMaybeUniqSet_sameUnique $
  \ case { RegWithFormat { regWithFormat_reg = RegVirtual vr } -> Just vr; _ -> Nothing }
  -- See Note [Unique Determinism and code generation]

-- | Take all the real registers from this set.
takeRealRegs :: UniqSet RegWithFormat -> UniqSet RealReg
takeRealRegs = mapMaybeUniqSet_sameUnique $
  \ case { RegWithFormat { regWithFormat_reg = RegReal rr } -> Just rr; _ -> Nothing }
  -- See Note [Unique Determinism and code generation]