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)
data Safety = Safe | Unsafe deriving(Eq,Ord,Show)
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)
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
| CConst {
primRequires :: Requires,
primConst :: !PackedString
}
| Func {
primRequires :: Requires,
funcName :: !PackedString,
primArgTypes :: [ExtType],
primRetType :: ExtType,
primRetArgs :: [ExtType],
primSafety :: Safety
}
| IFunc {
primRequires :: Requires,
primArgTypes :: [ExtType],
primRetType :: ExtType
}
| AddrOf {
primRequires :: Requires,
primConst :: !PackedString
}
| Peek { primArgTy :: Op.Ty }
| Poke { primArgTy :: Op.Ty }
| PrimTypeInfo {
primArgTy :: Op.Ty,
primRetTy :: Op.Ty,
primTypeInfo :: !PrimTypeInfo
}
| PrimString !PackedString
| 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)
data PrimTypeInfo = PrimSizeOf | PrimMaxBound | PrimMinBound | PrimAlignmentOf | PrimUMaxBound
deriving(Typeable, Eq, Ord, Show)
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
primIsCheap :: Prim -> Bool
primIsCheap AddrOf {} = True
primIsCheap CConst {} = True
primIsCheap PrimString {} = True
primIsCheap PrimTypeInfo {} = True
primIsCheap Op { primCOp = op } = Op.isCheap op
primIsCheap _ = False
primIsConstant :: Prim -> Bool
primIsConstant CConst {} = True
primIsConstant AddrOf {} = True
primIsConstant PrimString {} = True
primIsConstant PrimTypeInfo {} = True
primIsConstant Op { primCOp = op } = Op.isEagerSafe op
primIsConstant _ = False
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 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"
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"