Prims.hs

{- Generated by DrIFT (Automatic class derivations for Haskell) -}
{-# LINE 1 "src/C/Prims.hs" #-}
{-# LANGUAGE OverloadedStrings #-}
module C.Prims where

import Data.Binary
import Data.Monoid(Monoid(..))
import Data.Typeable
import qualified Data.Set as Set

import Doc.DocLike
import Doc.PPrint
import PackedString
import StringTable.Atom
import qualified Cmm.Op as Op

import GHC.Exts

data CallConv = CCall | StdCall | CApi | Primitive | DotNet
    deriving(Eq,Ord,Show)
    {-! derive: Binary !-}

data Safety = Safe | Unsafe deriving(Eq,Ord,Show)
    {-! derive: Binary !-}

newtype ExtType = ExtType PackedString
    deriving(Binary,IsString,Eq,Ord)

instance Show ExtType where
    show (ExtType p) = unpackPS p

instance Show Requires where
    show (Requires s) = show (Set.toList s)

newtype Requires = Requires (Set.Set (CallConv,PackedString))
    deriving(Eq,Ord,Monoid,Binary)

data DotNetPrim = DotNetField | DotNetCtor | DotNetMethod
    deriving(Typeable, Eq, Ord, Show)
    {-! derive: Binary !-}

primReqs p = f p where
    f CConst {} = primRequires p
    f Func {} = primRequires p
    f IFunc {} = primRequires p
    f AddrOf {} = primRequires p
    f _ = mempty

data Prim =
    PrimPrim Atom -- Special primitive implemented in the compiler somehow.
    | CConst {
        primRequires :: Requires,
        primConst :: !PackedString
        }  -- C code which evaluates to a constant
    | Func {
        primRequires :: Requires,
        funcName :: !PackedString,
        primArgTypes :: [ExtType],
        primRetType :: ExtType,
	primRetArgs :: [ExtType],
        primSafety  :: Safety
        }   -- function call with C calling convention
    | IFunc {
        primRequires :: Requires,
        primArgTypes :: [ExtType],
        primRetType :: ExtType
        } -- indirect function call with C calling convention
    | AddrOf {
        primRequires :: Requires,
        primConst :: !PackedString -- address of linker name
        }
    | Peek { primArgTy :: Op.Ty }  -- read value from memory
    | Poke { primArgTy :: Op.Ty }  -- write value to memory
    | PrimTypeInfo {
        primArgTy :: Op.Ty,
        primRetTy :: Op.Ty,
        primTypeInfo :: !PrimTypeInfo
        }
    | PrimString !PackedString  -- address of a raw string. encoded in utf8.
    | PrimDotNet {
        primStatic :: !Bool,
        primDotNet :: !DotNetPrim,
        primIOLike :: !Bool,
        primAssembly :: !PackedString,
        primDotNetName :: !PackedString
        }
    | Op {
        primCOp :: Op.Op Op.Ty,
        primRetTy :: Op.Ty
        }
    deriving(Typeable, Eq, Ord, Show)
    {-! derive: Binary !-}

data PrimTypeInfo = PrimSizeOf | PrimMaxBound | PrimMinBound | PrimAlignmentOf | PrimUMaxBound
    deriving(Typeable, Eq, Ord, Show)
    {-! derive: Binary !-}

primStaticTypeInfo :: Op.Ty -> PrimTypeInfo -> Maybe Integer
primStaticTypeInfo (Op.TyBits (Op.Bits b) _) w = Just ans where
    bits = toInteger b
    ans = case w of
        PrimSizeOf -> bits `div` 8
        PrimAlignmentOf ->  bits `div` 8
        PrimMinBound -> negate $ 2^(bits - 1)
        PrimMaxBound -> 2^(bits - 1) - 1
        PrimUMaxBound -> 2^bits - 1
primStaticTypeInfo _ _ = Nothing

-- | These primitives may safely be duplicated without affecting performance or
-- correctness too adversly. either because they are cheap to begin with, or
-- will be recombined in a later pass.

primIsCheap :: Prim -> Bool
primIsCheap AddrOf {} = True
primIsCheap CConst {} = True
primIsCheap PrimString {} = True
primIsCheap PrimTypeInfo {} = True
primIsCheap Op { primCOp = op } = Op.isCheap op
primIsCheap _ = False

-- | whether a primitive represents a constant expression (assuming all its arguments are constant)
-- TODO needs grin support
primIsConstant :: Prim -> Bool
primIsConstant CConst {} = True
primIsConstant AddrOf {} = True
primIsConstant PrimString {} = True
primIsConstant PrimTypeInfo {} = True
primIsConstant Op { primCOp = op } = Op.isEagerSafe op
primIsConstant _ = False

-- | whether a primitive can be eagarly evaluated.
-- TODO needs grin support
primEagerSafe :: Prim -> Bool
primEagerSafe CConst {} = True
primEagerSafe PrimString {} = True
primEagerSafe AddrOf {} = True
primEagerSafe PrimTypeInfo {} = True
primEagerSafe Op { primCOp = op } = Op.isEagerSafe op
primEagerSafe _ = False

primPrim s = PrimPrim $ toAtom s

instance DocLike d => PPrint d ExtType where
    pprint t = tshow t
--instance DocLike d => PPrint d PackedString where
--    pprint t = text $ unpackPS t

instance DocLike d => PPrint d Prim where
    pprint (PrimPrim t) = text (fromAtom t)
    pprint (CConst _ s) = parens (text $ unpackPS s)
    pprint Func { .. } = parens (tshow primRetType) <> text (unpackPS funcName) <> tupled (map pprint primArgTypes)
    pprint IFunc { .. } = parens (tshow primRetType) <> parens (char '*') <> tupled (map pprint primArgTypes)
    pprint (AddrOf _ s) = char '&' <> text (unpackPS s)
    pprint (PrimString s) = tshow s <> char '#'
    pprint (Peek t) = char '*' <> tshow t
    pprint (Poke t) = char '=' <> tshow t
    pprint Op { primCOp = Op.BinOp bo ta tb, primRetTy = rt } | rt == ta && rt == tb = parens (pprint rt) <> tshow bo
    pprint Op { primCOp = Op.UnOp bo ta, primRetTy = rt } | rt == ta = parens (pprint rt) <> tshow bo
    pprint Op { primCOp = op, primRetTy = rt } = parens (pprint rt) <> pprint op
    pprint PrimDotNet { primDotNet = dn,  primDotNetName = nn} = parens (text (unpackPS nn))
    pprint PrimTypeInfo { primArgTy = at, primTypeInfo = PrimSizeOf } = text "sizeof" <> parens (tshow at)
    pprint PrimTypeInfo { primArgTy = at, primTypeInfo = PrimAlignmentOf } = text "alignmentof" <> parens (tshow at)
    pprint PrimTypeInfo { primArgTy = at, primTypeInfo = PrimMaxBound } = text "max" <> parens (tshow at)
    pprint PrimTypeInfo { primArgTy = at, primTypeInfo = PrimUMaxBound } = text "umax" <> parens (tshow at)
    pprint PrimTypeInfo { primArgTy = at, primTypeInfo = PrimMinBound } = text "min" <> parens (tshow at)

instance DocLike d => PPrint d Op.Ty where
    pprintAssoc _ n p = text (showsPrec n p "")
instance (DocLike d,Show v) => PPrint d (Op.Op v) where
    pprintAssoc _ n p = text (showsPrec n p "")

parseDotNetFFI :: Monad m => String -> m Prim
parseDotNetFFI s = ans where
    init = PrimDotNet { primIOLike = False, primStatic = False, primDotNet = DotNetField, primAssembly = packString "", primDotNetName = packString "" }
    ans = case words s of
        ("static":rs) -> f rs init { primStatic = True }
        rs -> f rs init
    f ("field":rs) dn = g dn { primDotNet = DotNetField } rs
    f ("ctor":rs) dn = g dn { primDotNet = DotNetCtor } rs
    f ("method":rs) dn = g dn { primDotNet = DotNetMethod } rs
    f _ _ = fail "invalid .NET ffi specification"
    g dn ['[':rs] | (as,']':nm) <- span (/= ']') rs = return dn { primAssembly = packString as, primDotNetName = packString nm }
    g dn [n] = return dn { primDotNetName = packString n }
    g _ _ = fail "invalid .NET ffi specification"
{-* Generated by DrIFT : Look, but Don't Touch. *-}
instance Data.Binary.Binary CallConv where
    put CCall = do
	    Data.Binary.putWord8 0
    put StdCall = do
	    Data.Binary.putWord8 1
    put CApi = do
	    Data.Binary.putWord8 2
    put Primitive = do
	    Data.Binary.putWord8 3
    put DotNet = do
	    Data.Binary.putWord8 4
    get = do
	    h <- Data.Binary.getWord8
	    case h of
	      0 -> do
		    return CCall
	      1 -> do
		    return StdCall
	      2 -> do
		    return CApi
	      3 -> do
		    return Primitive
	      4 -> do
		    return DotNet
	      _ -> fail "invalid binary data found"

instance Data.Binary.Binary Safety where
    put Safe = do
	    Data.Binary.putWord8 0
    put Unsafe = do
	    Data.Binary.putWord8 1
    get = do
	    h <- Data.Binary.getWord8
	    case h of
	      0 -> do
		    return Safe
	      1 -> do
		    return Unsafe
	      _ -> fail "invalid binary data found"

instance Data.Binary.Binary DotNetPrim where
    put DotNetField = do
	    Data.Binary.putWord8 0
    put DotNetCtor = do
	    Data.Binary.putWord8 1
    put DotNetMethod = do
	    Data.Binary.putWord8 2
    get = do
	    h <- Data.Binary.getWord8
	    case h of
	      0 -> do
		    return DotNetField
	      1 -> do
		    return DotNetCtor
	      2 -> do
		    return DotNetMethod
	      _ -> fail "invalid binary data found"

instance Data.Binary.Binary Prim where
    put (PrimPrim aa) = do
	    Data.Binary.putWord8 0
	    Data.Binary.put aa
    put (CConst ab ac) = do
	    Data.Binary.putWord8 1
	    Data.Binary.put ab
	    Data.Binary.put ac
    put (Func ad ae af ag ah ai) = do
	    Data.Binary.putWord8 2
	    Data.Binary.put ad
	    Data.Binary.put ae
	    Data.Binary.put af
	    Data.Binary.put ag
	    Data.Binary.put ah
	    Data.Binary.put ai
    put (IFunc aj ak al) = do
	    Data.Binary.putWord8 3
	    Data.Binary.put aj
	    Data.Binary.put ak
	    Data.Binary.put al
    put (AddrOf am an) = do
	    Data.Binary.putWord8 4
	    Data.Binary.put am
	    Data.Binary.put an
    put (Peek ao) = do
	    Data.Binary.putWord8 5
	    Data.Binary.put ao
    put (Poke ap) = do
	    Data.Binary.putWord8 6
	    Data.Binary.put ap
    put (PrimTypeInfo aq ar as) = do
	    Data.Binary.putWord8 7
	    Data.Binary.put aq
	    Data.Binary.put ar
	    Data.Binary.put as
    put (PrimString at) = do
	    Data.Binary.putWord8 8
	    Data.Binary.put at
    put (PrimDotNet au av aw ax ay) = do
	    Data.Binary.putWord8 9
	    Data.Binary.put au
	    Data.Binary.put av
	    Data.Binary.put aw
	    Data.Binary.put ax
	    Data.Binary.put ay
    put (Op az aA) = do
	    Data.Binary.putWord8 10
	    Data.Binary.put az
	    Data.Binary.put aA
    get = do
	    h <- Data.Binary.getWord8
	    case h of
	      0 -> do
		    aa <- Data.Binary.get
		    return (PrimPrim aa)
	      1 -> do
		    ab <- Data.Binary.get
		    ac <- Data.Binary.get
		    return (CConst ab ac)
	      2 -> do
		    ad <- Data.Binary.get
		    ae <- Data.Binary.get
		    af <- Data.Binary.get
		    ag <- Data.Binary.get
		    ah <- Data.Binary.get
		    ai <- Data.Binary.get
		    return (Func ad ae af ag ah ai)
	      3 -> do
		    aj <- Data.Binary.get
		    ak <- Data.Binary.get
		    al <- Data.Binary.get
		    return (IFunc aj ak al)
	      4 -> do
		    am <- Data.Binary.get
		    an <- Data.Binary.get
		    return (AddrOf am an)
	      5 -> do
		    ao <- Data.Binary.get
		    return (Peek ao)
	      6 -> do
		    ap <- Data.Binary.get
		    return (Poke ap)
	      7 -> do
		    aq <- Data.Binary.get
		    ar <- Data.Binary.get
		    as <- Data.Binary.get
		    return (PrimTypeInfo aq ar as)
	      8 -> do
		    at <- Data.Binary.get
		    return (PrimString at)
	      9 -> do
		    au <- Data.Binary.get
		    av <- Data.Binary.get
		    aw <- Data.Binary.get
		    ax <- Data.Binary.get
		    ay <- Data.Binary.get
		    return (PrimDotNet au av aw ax ay)
	      10 -> do
		    az <- Data.Binary.get
		    aA <- Data.Binary.get
		    return (Op az aA)
	      _ -> fail "invalid binary data found"

instance Data.Binary.Binary PrimTypeInfo where
    put PrimSizeOf = do
	    Data.Binary.putWord8 0
    put PrimMaxBound = do
	    Data.Binary.putWord8 1
    put PrimMinBound = do
	    Data.Binary.putWord8 2
    put PrimAlignmentOf = do
	    Data.Binary.putWord8 3
    put PrimUMaxBound = do
	    Data.Binary.putWord8 4
    get = do
	    h <- Data.Binary.getWord8
	    case h of
	      0 -> do
		    return PrimSizeOf
	      1 -> do
		    return PrimMaxBound
	      2 -> do
		    return PrimMinBound
	      3 -> do
		    return PrimAlignmentOf
	      4 -> do
		    return PrimUMaxBound
	      _ -> fail "invalid binary data found"

--  Imported from other files :-