Add opcodes required for supporting value type arrays

language-cil.cabal

@@ -1,5 +1,5 @@
 name:                language-cil
-version:             0.4.0
+version:             0.4.1
 homepage:            https://github.com/tomlokhorst/language-cil
 synopsis:            Manipulating Common Intermediate Language AST
 description:         Language-Cil is a Haskell library for manipulating CIL
@@ -33,4 +33,3 @@ library
                      Language.Cil.Build
                      Language.Cil.Pretty
                      Language.Cil.Syntax
-

src/Language/Cil/Build.hs

@@ -29,11 +29,25 @@ module Language.Cil.Build (
   , brtrue
   , call
   , callvirt
+  , callMethod
+  , callvirtMethod
   , castclass
   , ceq
   , cgt
   , ckfinite
-  , clt 
+  , clt
+
+  , conv_i1
+  , conv_i2
+  , conv_i4
+  , conv_i8
+  , conv_u1
+  , conv_u2
+  , conv_u4
+  , conv_u8
+  , conv_r4
+  , conv_r8
+
   , dup
   , div
   , div_un
@@ -85,6 +99,7 @@ module Language.Cil.Build (
   , ldsflda
   , ldstr
   , ldtoken
+  , ldobj
   , mul
   , mul_ovf
   , mul_ovf_un
@@ -120,6 +135,7 @@ module Language.Cil.Build (
   , stind_ref
   , stloc
   , stlocN
+  , stobj
   , stsfld
   , sub
   , sub_ovf
@@ -226,6 +242,12 @@ brtrue = OpCode . Brtrue
 call :: [CallConv] -> PrimitiveType -> AssemblyName -> TypeName -> MethodName -> [PrimitiveType] -> MethodDecl
 call ccs p l t m ps = OpCode $ Call ccs p l t m ps
 
+callMethod :: MethodRef -> MethodDecl
+callMethod = OpCode . CallMethod
+
+callvirtMethod :: MethodRef -> MethodDecl
+callvirtMethod = OpCode . CallVirtMethod
+
 callvirt :: PrimitiveType -> AssemblyName -> TypeName -> MethodName -> [PrimitiveType] -> MethodDecl
 callvirt p l t m ps = OpCode $ CallVirt p l t m ps
 
@@ -237,6 +259,18 @@ ceq = OpCode $ Ceq
 cgt = OpCode $ Cgt
 clt = OpCode $ Clt
 
+conv_i1, conv_i2, conv_i4, conv_i8, conv_u1, conv_u2, conv_u4, conv_u8, conv_r4, conv_r8 :: MethodDecl
+conv_i1 = OpCode Conv_i1
+conv_i2 = OpCode Conv_i2
+conv_i4 = OpCode Conv_i4
+conv_i8 = OpCode Conv_i8
+conv_u1 = OpCode Conv_u1
+conv_u2 = OpCode Conv_u2
+conv_u4 = OpCode Conv_u4
+conv_u8 = OpCode Conv_u8
+conv_r4 = OpCode Conv_r4
+conv_r8 = OpCode Conv_r8
+
 ckfinite :: MethodDecl
 ckfinite = OpCode $ Ckfinite
 
@@ -331,8 +365,8 @@ ldelem_r8 = OpCode $ Ldelem_r8
 ldelem_ref :: MethodDecl
 ldelem_ref = OpCode $ Ldelem_ref
 
-ldelema :: MethodDecl
-ldelema = OpCode $ Ldelema
+ldelema :: PrimitiveType -> MethodDecl
+ldelema = OpCode . Ldelema
 
 ldfld :: PrimitiveType -> AssemblyName -> TypeName -> FieldName -> MethodDecl
 ldfld p a t f = OpCode $ Ldfld p a t f
@@ -404,6 +438,9 @@ ldlocaN nm = OpCode $ LdlocaN nm
 ldnull :: MethodDecl
 ldnull = OpCode $ Ldnull
 
+ldobj :: PrimitiveType -> MethodDecl
+ldobj = OpCode . Ldobj
+
 ldsfld :: PrimitiveType -> AssemblyName -> TypeName -> FieldName -> MethodDecl
 ldsfld p a t f = OpCode $ Ldsfld p a t f
 
@@ -528,6 +565,9 @@ stloc x = OpCode $ Stloc x
 stlocN :: LocalName -> MethodDecl
 stlocN nm = OpCode $ StlocN nm
 
+stobj :: PrimitiveType -> MethodDecl
+stobj = OpCode . Stobj
+
 stsfld :: PrimitiveType -> AssemblyName -> TypeName -> FieldName -> MethodDecl
 stsfld p a t f = OpCode $ Stsfld p a t f
 
@@ -602,9 +642,9 @@ supportsPrefix Stind_r8  = True
 supportsPrefix Stind_ref = True
 supportsPrefix (Ldfld _ _ _ _) = True
 supportsPrefix (Stfld _ _ _ _) = True
+supportsPrefix (Ldobj _) = True
+supportsPrefix (Stobj _) = True
 -- there are several cases for not-yet-supported opcodes
--- supportsPrefix (Ldobj ...)
--- supportsPrefix (Stobj ...)
 -- supportsPrefix (Initblk ...)
 -- supportsPrefix (Cpblk ...)
 supportsPrefix _         = False

src/Language/Cil/Pretty.hs

@@ -79,6 +79,8 @@ instance Pretty ClassAttr where
   pr CaPublic        = ("public" ++)
   pr CaNestedPublic  = ("nested public" ++)
   pr CaNestedPrivate = ("nested private" ++)
+  pr CaBeforeFieldInit = ("beforefieldinit" ++)
+  pr CaSealed        = ("sealed" ++)
 
 instance Pretty ClassDecl where
   pr (FieldDef fd)  = pr fd
@@ -179,11 +181,23 @@ instance Pretty OpCode where
                                . prCall a c m ps
   pr (CallVirt t a c m ps) = ("callvirt instance " ++) . prsp t . sp
                                . prCall a c m ps
+  pr (CallMethod m)        = ("call " ++) . prMethodRef m
+  pr (CallVirtMethod m)    = ("callvirt " ++) . prMethodRef m
   pr (Castclass t)         = ("castclass " ++) . pr t
   pr (Ceq)                 = ("ceq" ++)
   pr (Cgt)                 = ("cgt" ++)
   pr (Ckfinite)            = ("ckfinite" ++)
   pr (Clt)                 = ("clt" ++)
+  pr (Conv_i1)             = ("conv.i1" ++)
+  pr (Conv_i2)             = ("conv.i2" ++)
+  pr (Conv_i4)             = ("conv.i4" ++)
+  pr (Conv_i8)             = ("conv.i8" ++)
+  pr (Conv_u1)             = ("conv.u1" ++)
+  pr (Conv_u2)             = ("conv.u2" ++)
+  pr (Conv_u4)             = ("conv.u4" ++)
+  pr (Conv_u8)             = ("conv.u8" ++)
+  pr (Conv_r4)             = ("conv.r4" ++)
+  pr (Conv_r8)             = ("conv.r8" ++)
   pr (Div)                 = ("div" ++)
   pr (Div_un)              = ("div.un" ++)
   pr (Dup)                 = ("dup" ++)
@@ -211,6 +225,7 @@ instance Pretty OpCode where
   pr (Ldc_i8 x)            = ("ldc.i8 " ++) . shows x
   pr (Ldc_r4 x)            = ("ldc.r4 " ++) . shows x
   pr (Ldc_r8 x)            = ("ldc.r8 " ++) . shows x
+  pr (Ldelema t)           = ("ldelema " ++) . pr t
   pr (Ldelem_i)            = ("ldelem.i " ++)
   pr (Ldelem_i1)           = ("ldelem.i1 " ++)
   pr (Ldelem_i2)           = ("ldelem.i2 " ++)
@@ -245,6 +260,7 @@ instance Pretty OpCode where
   pr (Ldloca x)            = ("ldloca " ++) . shows x
   pr (LdlocaN nm)          = ("ldloca " ++) . prName nm
   pr (Ldnull)              = ("ldnull " ++)
+  pr (Ldobj t)             = ("ldobj " ++) . pr t
   pr (Ldsfld t a c f)      = ("ldsfld " ++) . pr t . sp . prFld a c f
   pr (Ldsflda t a c f)     = ("ldsflda " ++) . pr t . sp . prFld a c f
   pr (Ldstr s)             = ("ldstr " ++) . shows s
@@ -287,6 +303,7 @@ instance Pretty OpCode where
   pr (Stloc_2)             = ("stloc.2 " ++)
   pr (Stloc_3)             = ("stloc.3 " ++)
   pr (StlocN nm)           = ("stloc " ++) . prName nm
+  pr (Stobj t)             = ("stobj " ++) . pr t
   pr (Stsfld t a c f)      = ("stsfld " ++) . pr t . sp . prFld a c f
   pr (Sub)                 = ("sub" ++)
   pr (Sub_ovf)             = ("sub.ovf" ++)
@@ -336,6 +353,15 @@ prCall a c m ps =
   . foldr (.) id (intersperse (", " ++) (map pr ps))
   . (")" ++)
 
+prMethodRef :: MethodRef -> ShowS
+prMethodRef (GenericMethodInstance ccs declTy n tyArgs ps retTy) =
+    prList ccs
+  . pr retTy . sp
+  . pr declTy . ("::" ++) . prName n . prGenericArgs pr tyArgs
+  . ("(" ++)
+  . foldr (.) id (intersperse (", " ++) (map pr ps))
+  . (")" ++)
+
 prTypeToken :: PrimitiveType -> ShowS
 prTypeToken (ValueType a c)     = prAssembly a . prName c
 prTypeToken (ReferenceType a c) = prAssembly a . prName c
@@ -344,11 +370,14 @@ prTypeToken t = pr t
 prAssembly :: DottedName -> ShowS
 prAssembly a = bool (("[" ++) . prName a . ("]" ++)) id (a == "")
 
+prGenericArgs :: (a -> ShowS) -> [a] -> ShowS
+prGenericArgs prArg args = ("<" ++) . foldr (.) id (intersperse ("," ++) (map prArg args)) . (">" ++)
+
 prGenericTypeName :: TypeName -> [a] -> (a -> ShowS) -> ShowS
 prGenericTypeName n args prArg =
     prName n
   . ("`" ++) . shows (length args)
-  . ("<" ++) . foldr (.) id (intersperse ("," ++) (map prArg args)) . (">" ++)
+  . prGenericArgs prArg args
 
 instance Pretty PrimitiveType where
   pr Void                = ("void" ++) 
@@ -367,6 +396,7 @@ instance Pretty PrimitiveType where
   pr (GenericReferenceType a c gs)         = prAssembly a . prGenericTypeName c gs ((("!" ++) .) . prName)
   pr (GenericReferenceTypeInstance a c ts) = ("class " ++) . prAssembly a . prGenericTypeName c ts pr
   pr (GenericType x)     = ("!" ++) . shows x
+  pr (GenericMethodTypeParameter x) = ("!!" ++) . shows x
   pr (ByRef pt)          = pr pt . ("&" ++)
   pr (Array et)          = pr et . ("[]" ++)
 

src/Language/Cil/Syntax.hs

@@ -26,6 +26,7 @@ module Language.Cil.Syntax (
   , FieldDef      (..)
   , FieldAttr     (..)
   , MethodDef     (..)
+  , MethodRef     (..)
   , MethAttr      (..)
   , Parameter     (..)
   , ParamAttr     (..)
@@ -76,7 +77,7 @@ data Assembly
 -- | Assembly reference.
 data AssemblyRef
   = AssemblyRef AssemblyName Version PublicKeyToken
-  deriving Show
+  deriving (Eq, Ord, Show)
 
 -- | A Type definition in CIL, either a class or a value type.
 data TypeDef
@@ -98,6 +99,8 @@ data ClassAttr
   | CaPublic
   | CaNestedPublic
   | CaNestedPrivate
+  | CaBeforeFieldInit
+  | CaSealed
   deriving Show
 
 -- | Class declarations, i.e. the body of a class.
@@ -145,6 +148,7 @@ data PrimitiveType
   | GenericReferenceTypeInstance AssemblyName TypeName [PrimitiveType]
   | ByRef PrimitiveType
   | GenericType Offset
+  | GenericMethodTypeParameter Offset
   | Array PrimitiveType
   deriving (Eq, Ord, Show)
 
@@ -203,6 +207,11 @@ data Local
   = Local PrimitiveType LocalName
   deriving Show
 
+-- | Method references for use with CallMethod.
+data MethodRef
+  = GenericMethodInstance [CallConv] PrimitiveType MethodName [PrimitiveType] [PrimitiveType] PrimitiveType -- ^ Calling convention, declaring type, method name, type arguments, parameter types, return type
+  deriving Show
+
 -- | CIL OpCodes inside a method definition.
 -- See <http://msdn.microsoft.com/en-us/library/system.reflection.emit.opcodes_fields.aspx>
 -- for a more complete list with documentation.
@@ -221,6 +230,8 @@ data OpCode
   | Break              -- ^ Inform a debugger that a breakpoint has been reached.
   | Brfalse Label      -- ^ Pops 1 value, if value is false, null reference or zero, jump to specified label.
   | Brtrue Label       -- ^ Pops 1 value, if value is true, not null or non-zero, jump to specified label.
+  | CallMethod MethodRef -- ^ Pops /n/ values, calls specified method, pushes return value. (where /n/ is the number of formal parameters of the method).
+  | CallVirtMethod MethodRef  -- ^ Pops /n/ values, calls specified virtual method, pushes return value. (where /n/ is the number of formal parameters of the method).
   | Call
       { callConv     :: [CallConv]      -- ^ Method is associated with class or instance.
       , returnType   :: PrimitiveType   -- ^ Return type of the method.
@@ -241,6 +252,16 @@ data OpCode
   | Cgt                -- ^ Pops 2 values and compares them.
   | Ckfinite           -- ^ Pops a float or double. Throws an ArithmeticException if the popped value is NaN or +/- infinity. Pushes the popped value.
   | Clt                -- ^ Pops 2 values and compares them.
+  | Conv_i1            -- ^ Convert to int8, pushing I on stack.
+  | Conv_i2            -- ^ Convert to int16, pushing I on stack.
+  | Conv_i4            -- ^ Convert to int32, pushing I on stack.
+  | Conv_i8            -- ^ Convert to int64, pushing I on stack.
+  | Conv_u1            -- ^ Convert to uint8, pushing U on stack.
+  | Conv_u2            -- ^ Convert to uint16, pushing U on stack.
+  | Conv_u4            -- ^ Convert to uint32, pushing U on stack.
+  | Conv_u8            -- ^ Convert to uint64, pushing U on stack.
+  | Conv_r4            -- ^ Convert to float32, pushing F on stack.
+  | Conv_r8            -- ^ Convert to float64, pushing F on stack.
   | Dup                -- ^ Pops 1 value, copies it, pushes the same value twise.
   | Div                -- ^ Pops 2 values, divides the first by the second, pushes the result.
   | Div_un             -- ^ Pops 2 integers, divides the first by the second when consider as unsigned integers, pushes the result.
@@ -280,7 +301,7 @@ data OpCode
   | Ldelem_r4          -- ^ Pops an array reference and an index. Pushes the float in the specified slot of the array.
   | Ldelem_r8          -- ^ Pops an array reference and an index. Pushes the double in the specified slot of the array.
   | Ldelem_ref         -- ^ Pops an array reference and an index. Pushes the object reference in the specified slot of the array.
-  | Ldelema            -- ^ Pops an array reference and an index. Pushes the address of the specified slot of the array.
+  | Ldelema PrimitiveType -- ^ Pops an array reference and an index. Pushes the address of the specified slot of the array.
   | Ldfld
       { fieldType    :: PrimitiveType  -- ^ Type of the field.
       , assemblyName :: AssemblyName   -- ^ Name of the assembly where the field resides.
@@ -336,6 +357,7 @@ data OpCode
       } -- ^ Pops type reference, find address of specified field on the type, pushes address to the stack.
   | Ldstr String       -- ^ Pushes an object reference to the specified string constant.
   | Ldtoken PrimitiveType -- ^ Pushes the RuntimeTypeHandle of the specified type.
+  | Ldobj PrimitiveType -- ^ Copies the value type object pointed to by an address to the top of the evaluation stack.
   | Mul                -- ^ Pops 2 values, multiplies the values, pushes result.
   | Mul_ovf            -- ^ Pops 2 values, multiplies the values with a signed overflow check, pushes result.
   | Mul_ovf_un         -- ^ Pops 2 values, multiplies the values with an unsigned overflow check, pushes result.
@@ -385,6 +407,7 @@ data OpCode
   | Stloc_2            -- ^ Pops 1 value, stores it in the 2th local variable.
   | Stloc_3            -- ^ Pops 1 value, stores it in the 3th local variable.
   | StlocN DottedName  -- ^ Pops 1 value, stores it in the local variable specified by name.
+  | Stobj PrimitiveType -- ^ Copies a value of a specified type from the evaluation stack into a supplied memory address.
   | Stsfld
       { fieldType    :: PrimitiveType  -- ^ Type of the field.
       , assemblyName :: AssemblyName   -- ^ Name of the assembly where the field resides.

stack.yaml

@@ -0,0 +1,5 @@
+resolver: lts-7.0
+packages:
+  - location: .
+extra-deps:
+  - bool-extras-0.4.0