diff --git a/language-cil.cabal b/language-cil.cabal --- a/language-cil.cabal +++ b/language-cil.cabal @@ -1,5 +1,5 @@ name: language-cil -version: 0.2.2 +version: 0.3.1 homepage: https://github.com/tomlokhorst/language-cil synopsis: Manipulating Common Intermediate Language AST description: Language-Cil is a Haskell library for manipulating CIL @@ -27,7 +27,7 @@ library hs-source-dirs: src build-depends: base > 3 && < 5, - bool-extras >= 0.3.0 && < 0.4 + bool-extras >= 0.4.0 && < 0.5 exposed-modules: Language.Cil Language.Cil.Analysis Language.Cil.Build diff --git a/src/Language/Cil/Analysis.hs b/src/Language/Cil/Analysis.hs --- a/src/Language/Cil/Analysis.hs +++ b/src/Language/Cil/Analysis.hs @@ -3,28 +3,28 @@ -- module Language.Cil.Analysis ( - instructions + opcodes ) where import Language.Cil.Syntax class Ast a where - -- A concatenated list of all instructions. - instructions :: a -> [Instr] + -- A concatenated list of all opcodes. + opcodes :: a -> [OpCode] instance Ast Assembly where - instructions (Assembly _ _ td) = concatMap instructions td + opcodes (Assembly _ _ td) = concatMap opcodes td instance Ast TypeDef where - instructions (Class _ _ _ _ cd) = concatMap instructions cd - instructions (GenericClass _ _ _ cd) = concatMap instructions cd + opcodes (Class _ _ _ _ cd) = concatMap opcodes cd + opcodes (GenericClass _ _ _ cd) = concatMap opcodes cd instance Ast ClassDecl where - instructions (FieldDef _) = [] - instructions (MethodDef md) = instructions md - instructions (TypeDef td) = instructions td + opcodes (FieldDef _) = [] + opcodes (MethodDef md) = opcodes md + opcodes (TypeDef td) = opcodes td instance Ast MethodDef where - instructions (Constructor _ _ _ md) = [ i | Instr i <- md ] - instructions (Method _ _ _ _ md) = [ i | Instr i <- md ] + opcodes (Constructor _ _ _ md) = [ o | OpCode o <- md ] + opcodes (Method _ _ _ _ md) = [ o | OpCode o <- md ] diff --git a/src/Language/Cil/Build.hs b/src/Language/Cil/Build.hs --- a/src/Language/Cil/Build.hs +++ b/src/Language/Cil/Build.hs @@ -12,7 +12,7 @@ , localsInit , maxStack - -- * mdecl functions + -- * OpCode functions , add , add_ovf , add_ovf_un @@ -29,6 +29,7 @@ , brtrue , call , callvirt + , castclass , ceq , cgt , ckfinite @@ -39,6 +40,8 @@ , isinst , ldarg , ldargN + , ldarga + , ldargaN , ldc_i4 , ldc_i8 , ldc_r4 @@ -60,6 +63,7 @@ , ldfld , ldflda , ldftn + , ldftn_instance , ldind_i , ldind_i1 , ldind_i2 @@ -80,6 +84,7 @@ , ldsfld , ldsflda , ldstr + , ldtoken , mul , mul_ovf , mul_ovf_un @@ -119,12 +124,14 @@ , sub , sub_ovf , sub_ovf_un + , switch , tail , tailcall , throw , unaligned , unalignedPtr , unbox + , unbox_any , volatile , volatilePtr , xor @@ -166,384 +173,405 @@ maxStack x = Directive (MaxStack x) --- mdecl functions +-- OpCode functions add :: MethodDecl -add = mdecl $ Add +add = OpCode $ Add add_ovf :: MethodDecl -add_ovf = mdecl $ Add_ovf +add_ovf = OpCode $ Add_ovf add_ovf_un :: MethodDecl -add_ovf_un = mdecl $ Add_ovf_un +add_ovf_un = OpCode $ Add_ovf_un and :: MethodDecl -and = mdecl $ And +and = OpCode $ And beq :: Label -> MethodDecl -beq = mdecl . Beq +beq = OpCode . Beq bge :: Label -> MethodDecl -bge = mdecl . Bge +bge = OpCode . Bge bgt :: Label -> MethodDecl -bgt = mdecl . Bgt +bgt = OpCode . Bgt ble :: Label -> MethodDecl -ble = mdecl . Ble +ble = OpCode . Ble blt :: Label -> MethodDecl -blt = mdecl . Blt +blt = OpCode . Blt box :: PrimitiveType -> MethodDecl -box = mdecl . Box +box = OpCode . Box unbox :: PrimitiveType -> MethodDecl -unbox = mdecl . Unbox +unbox = OpCode . Unbox +unbox_any :: PrimitiveType -> MethodDecl +unbox_any = OpCode . Unbox_any + br :: Label -> MethodDecl -br = mdecl . Br +br = OpCode . Br break :: MethodDecl -break = mdecl $ Break +break = OpCode $ Break brfalse :: Label -> MethodDecl -brfalse = mdecl . Brfalse +brfalse = OpCode . Brfalse brtrue :: Label -> MethodDecl -brtrue = mdecl . Brtrue +brtrue = OpCode . Brtrue call :: [CallConv] -> PrimitiveType -> AssemblyName -> TypeName -> MethodName -> [PrimitiveType] -> MethodDecl -call ccs p l t m ps = mdecl $ Call ccs p l t m ps +call ccs p l t m ps = OpCode $ Call ccs p l t m ps callvirt :: PrimitiveType -> AssemblyName -> TypeName -> MethodName -> [PrimitiveType] -> MethodDecl -callvirt p l t m ps = mdecl $ CallVirt p l t m ps +callvirt p l t m ps = OpCode $ CallVirt p l t m ps +castclass :: PrimitiveType -> MethodDecl +castclass = OpCode . Castclass + ceq, cgt, clt :: MethodDecl -ceq = mdecl $ Ceq -cgt = mdecl $ Cgt -clt = mdecl $ Clt +ceq = OpCode $ Ceq +cgt = OpCode $ Cgt +clt = OpCode $ Clt ckfinite :: MethodDecl -ckfinite = mdecl $ Ckfinite +ckfinite = OpCode $ Ckfinite dup :: MethodDecl -dup = mdecl $ Dup +dup = OpCode $ Dup div :: MethodDecl -div = mdecl $ Div +div = OpCode $ Div div_un :: MethodDecl -div_un = mdecl $ Div_un +div_un = OpCode $ Div_un isinst :: TypeName -> MethodDecl -isinst = mdecl . Isinst +isinst = OpCode . Isinst ldarg :: Offset -> MethodDecl -ldarg 0 = mdecl $ Ldarg_0 -ldarg 1 = mdecl $ Ldarg_1 -ldarg 2 = mdecl $ Ldarg_2 -ldarg 3 = mdecl $ Ldarg_3 -ldarg x = mdecl $ Ldarg x +ldarg 0 = OpCode $ Ldarg_0 +ldarg 1 = OpCode $ Ldarg_1 +ldarg 2 = OpCode $ Ldarg_2 +ldarg 3 = OpCode $ Ldarg_3 +ldarg x = OpCode $ Ldarg x ldargN :: DottedName -> MethodDecl -ldargN = mdecl . LdargN +ldargN = OpCode . LdargN +ldarga :: Offset -> MethodDecl +ldarga = OpCode . Ldarga + +ldargaN :: DottedName -> MethodDecl +ldargaN = OpCode . LdargaN + ldc_i4 :: Integer -> MethodDecl -ldc_i4 (-1) = mdecl $ Ldc_i4_m1 -ldc_i4 0 = mdecl $ Ldc_i4_0 -ldc_i4 1 = mdecl $ Ldc_i4_1 -ldc_i4 2 = mdecl $ Ldc_i4_2 -ldc_i4 3 = mdecl $ Ldc_i4_3 -ldc_i4 4 = mdecl $ Ldc_i4_4 -ldc_i4 5 = mdecl $ Ldc_i4_5 -ldc_i4 6 = mdecl $ Ldc_i4_6 -ldc_i4 7 = mdecl $ Ldc_i4_7 -ldc_i4 8 = mdecl $ Ldc_i4_8 -ldc_i4 x = mdecl $ if -127 <= x && x <= 128 +ldc_i4 (-1) = OpCode $ Ldc_i4_m1 +ldc_i4 0 = OpCode $ Ldc_i4_0 +ldc_i4 1 = OpCode $ Ldc_i4_1 +ldc_i4 2 = OpCode $ Ldc_i4_2 +ldc_i4 3 = OpCode $ Ldc_i4_3 +ldc_i4 4 = OpCode $ Ldc_i4_4 +ldc_i4 5 = OpCode $ Ldc_i4_5 +ldc_i4 6 = OpCode $ Ldc_i4_6 +ldc_i4 7 = OpCode $ Ldc_i4_7 +ldc_i4 8 = OpCode $ Ldc_i4_8 +ldc_i4 x = OpCode $ if -127 <= x && x <= 128 then Ldc_i4_s (fromInteger x) else Ldc_i4 x ldc_i8 :: Integer -> MethodDecl -ldc_i8 = mdecl . Ldc_i8 +ldc_i8 = OpCode . Ldc_i8 ldc_r4 :: Float -> MethodDecl -ldc_r4 = mdecl . Ldc_r4 +ldc_r4 = OpCode . Ldc_r4 ldc_r8 :: Double -> MethodDecl -ldc_r8 = mdecl . Ldc_r8 +ldc_r8 = OpCode . Ldc_r8 ldchar :: Char -> MethodDecl ldchar c = ldc_i4 (toInteger $ ord c) ldelem_i :: MethodDecl -ldelem_i = mdecl $ Ldelem_i +ldelem_i = OpCode $ Ldelem_i ldelem_i1 :: MethodDecl -ldelem_i1 = mdecl $ Ldelem_i1 +ldelem_i1 = OpCode $ Ldelem_i1 ldelem_i2 :: MethodDecl -ldelem_i2 = mdecl $ Ldelem_i2 +ldelem_i2 = OpCode $ Ldelem_i2 ldelem_i4 :: MethodDecl -ldelem_i4 = mdecl $ Ldelem_i4 +ldelem_i4 = OpCode $ Ldelem_i4 ldelem_i8 :: MethodDecl -ldelem_i8 = mdecl $ Ldelem_i8 +ldelem_i8 = OpCode $ Ldelem_i8 ldelem_u1 :: MethodDecl -ldelem_u1 = mdecl $ Ldelem_u1 +ldelem_u1 = OpCode $ Ldelem_u1 ldelem_u2 :: MethodDecl -ldelem_u2 = mdecl $ Ldelem_u2 +ldelem_u2 = OpCode $ Ldelem_u2 ldelem_u4 :: MethodDecl -ldelem_u4 = mdecl $ Ldelem_u4 +ldelem_u4 = OpCode $ Ldelem_u4 ldelem_u8 :: MethodDecl -ldelem_u8 = mdecl $ Ldelem_u8 +ldelem_u8 = OpCode $ Ldelem_u8 ldelem_r4 :: MethodDecl -ldelem_r4 = mdecl $ Ldelem_r4 +ldelem_r4 = OpCode $ Ldelem_r4 ldelem_r8 :: MethodDecl -ldelem_r8 = mdecl $ Ldelem_r8 +ldelem_r8 = OpCode $ Ldelem_r8 ldelem_ref :: MethodDecl -ldelem_ref = mdecl $ Ldelem_ref +ldelem_ref = OpCode $ Ldelem_ref ldelema :: MethodDecl -ldelema = mdecl $ Ldelema +ldelema = OpCode $ Ldelema ldfld :: PrimitiveType -> AssemblyName -> TypeName -> FieldName -> MethodDecl -ldfld p a t f = mdecl $ Ldfld p a t f +ldfld p a t f = OpCode $ Ldfld p a t f ldflda :: PrimitiveType -> AssemblyName -> TypeName -> FieldName -> MethodDecl -ldflda p a t f = mdecl $ Ldflda p a t f +ldflda p a t f = OpCode $ Ldflda p a t f +ldftn_ :: [CallConv] -> PrimitiveType -> AssemblyName -> TypeName -> MethodName -> [PrimitiveType] -> MethodDecl +ldftn_ cc p a t m ps = OpCode $ Ldftn cc p a t m ps + ldftn :: PrimitiveType -> AssemblyName -> TypeName -> MethodName -> [PrimitiveType] -> MethodDecl -ldftn p a t m ps = mdecl $ Ldftn p a t m ps +ldftn = ldftn_ [] +ldftn_instance :: PrimitiveType -> AssemblyName -> TypeName -> MethodName -> [PrimitiveType] -> MethodDecl +ldftn_instance = ldftn_ [CcInstance] + ldind_i :: MethodDecl -ldind_i = mdecl $ Ldind_i +ldind_i = OpCode $ Ldind_i ldind_i1 :: MethodDecl -ldind_i1 = mdecl $ Ldind_i1 +ldind_i1 = OpCode $ Ldind_i1 ldind_i2 :: MethodDecl -ldind_i2 = mdecl $ Ldind_i2 +ldind_i2 = OpCode $ Ldind_i2 ldind_i4 :: MethodDecl -ldind_i4 = mdecl $ Ldind_i4 +ldind_i4 = OpCode $ Ldind_i4 ldind_i8 :: MethodDecl -ldind_i8 = mdecl $ Ldind_i8 +ldind_i8 = OpCode $ Ldind_i8 ldind_r4 :: MethodDecl -ldind_r4 = mdecl $ Ldind_r4 +ldind_r4 = OpCode $ Ldind_r4 ldind_r8 :: MethodDecl -ldind_r8 = mdecl $ Ldind_r8 +ldind_r8 = OpCode $ Ldind_r8 ldind_ref :: MethodDecl -ldind_ref = mdecl $ Ldind_ref +ldind_ref = OpCode $ Ldind_ref ldind_u1 :: MethodDecl -ldind_u1 = mdecl $ Ldind_u1 +ldind_u1 = OpCode $ Ldind_u1 ldind_u2 :: MethodDecl -ldind_u2 = mdecl $ Ldind_u2 +ldind_u2 = OpCode $ Ldind_u2 ldind_u4 :: MethodDecl -ldind_u4 = mdecl $ Ldind_u4 +ldind_u4 = OpCode $ Ldind_u4 ldlen :: MethodDecl -ldlen = mdecl $ Ldlen +ldlen = OpCode $ Ldlen ldloc :: Offset -> MethodDecl -ldloc 0 = mdecl $ Ldloc_0 -ldloc 1 = mdecl $ Ldloc_1 -ldloc 2 = mdecl $ Ldloc_2 -ldloc 3 = mdecl $ Ldloc_3 -ldloc x = mdecl $ Ldloc x +ldloc 0 = OpCode $ Ldloc_0 +ldloc 1 = OpCode $ Ldloc_1 +ldloc 2 = OpCode $ Ldloc_2 +ldloc 3 = OpCode $ Ldloc_3 +ldloc x = OpCode $ Ldloc x ldlocN :: LocalName -> MethodDecl -ldlocN nm = mdecl $ LdlocN nm +ldlocN nm = OpCode $ LdlocN nm ldloca :: Offset -> MethodDecl -ldloca = mdecl . Ldloca +ldloca = OpCode . Ldloca ldlocaN :: LocalName -> MethodDecl -ldlocaN nm = mdecl $ LdlocaN nm +ldlocaN nm = OpCode $ LdlocaN nm ldnull :: MethodDecl -ldnull = mdecl $ Ldnull +ldnull = OpCode $ Ldnull ldsfld :: PrimitiveType -> AssemblyName -> TypeName -> FieldName -> MethodDecl -ldsfld p a t f = mdecl $ Ldsfld p a t f +ldsfld p a t f = OpCode $ Ldsfld p a t f ldsflda :: PrimitiveType -> AssemblyName -> TypeName -> FieldName -> MethodDecl -ldsflda p a t f = mdecl $ Ldsflda p a t f +ldsflda p a t f = OpCode $ Ldsflda p a t f ldstr :: String -> MethodDecl -ldstr = mdecl . Ldstr +ldstr = OpCode . Ldstr +ldtoken :: PrimitiveType -> MethodDecl +ldtoken = OpCode . Ldtoken + mul :: MethodDecl -mul = mdecl $ Mul +mul = OpCode $ Mul mul_ovf :: MethodDecl -mul_ovf = mdecl $ Mul_ovf +mul_ovf = OpCode $ Mul_ovf mul_ovf_un :: MethodDecl -mul_ovf_un = mdecl $ Mul_ovf_un +mul_ovf_un = OpCode $ Mul_ovf_un neg :: MethodDecl -neg = mdecl $ Neg +neg = OpCode $ Neg newarr :: PrimitiveType -> MethodDecl -newarr t = mdecl $ Newarr t +newarr t = OpCode $ Newarr t -- | Creates a new object. -- Note that this function assumes the constructor returns Void. -- If this is not the case, call the Newobj constructor manually. newobj :: AssemblyName -> TypeName -> [PrimitiveType] -> MethodDecl -newobj a t ps = mdecl $ Newobj Void a t ps +newobj a t ps = OpCode $ Newobj Void a t ps nop :: MethodDecl -nop = mdecl $ Nop +nop = OpCode $ Nop not :: MethodDecl -not = mdecl $ Not +not = OpCode $ Not or :: MethodDecl -or = mdecl $ Or +or = OpCode $ Or pop :: MethodDecl -pop = mdecl $ Pop +pop = OpCode $ Pop rem :: MethodDecl -rem = mdecl $ Rem +rem = OpCode $ Rem rem_un :: MethodDecl -rem_un = mdecl $ Rem_un +rem_un = OpCode $ Rem_un ret :: MethodDecl -ret = mdecl $ Ret +ret = OpCode $ Ret shl :: MethodDecl -shl = mdecl $ Shl +shl = OpCode $ Shl shr :: MethodDecl -shr = mdecl $ Shr +shr = OpCode $ Shr shr_un :: MethodDecl -shr_un = mdecl $ Shr_un +shr_un = OpCode $ Shr_un stelem_i :: MethodDecl -stelem_i = mdecl $ Stelem_i +stelem_i = OpCode $ Stelem_i stelem_i1 :: MethodDecl -stelem_i1 = mdecl $ Stelem_i1 +stelem_i1 = OpCode $ Stelem_i1 stelem_i2 :: MethodDecl -stelem_i2 = mdecl $ Stelem_i2 +stelem_i2 = OpCode $ Stelem_i2 stelem_i4 :: MethodDecl -stelem_i4 = mdecl $ Stelem_i4 +stelem_i4 = OpCode $ Stelem_i4 stelem_i8 :: MethodDecl -stelem_i8 = mdecl $ Stelem_i8 +stelem_i8 = OpCode $ Stelem_i8 stelem_r4 :: MethodDecl -stelem_r4 = mdecl $ Stelem_r4 +stelem_r4 = OpCode $ Stelem_r4 stelem_r8 :: MethodDecl -stelem_r8 = mdecl $ Stelem_r8 +stelem_r8 = OpCode $ Stelem_r8 stelem_ref :: MethodDecl -stelem_ref = mdecl $ Stelem_ref +stelem_ref = OpCode $ Stelem_ref stfld :: PrimitiveType -> AssemblyName -> TypeName -> FieldName -> MethodDecl -stfld p a t f = mdecl $ Stfld p a t f +stfld p a t f = OpCode $ Stfld p a t f stind_i :: MethodDecl -stind_i = mdecl $ Stind_i +stind_i = OpCode $ Stind_i stind_i1 :: MethodDecl -stind_i1 = mdecl $ Stind_i1 +stind_i1 = OpCode $ Stind_i1 stind_i2 :: MethodDecl -stind_i2 = mdecl $ Stind_i2 +stind_i2 = OpCode $ Stind_i2 stind_i4 :: MethodDecl -stind_i4 = mdecl $ Stind_i4 +stind_i4 = OpCode $ Stind_i4 stind_i8 :: MethodDecl -stind_i8 = mdecl $ Stind_i8 +stind_i8 = OpCode $ Stind_i8 stind_r4 :: MethodDecl -stind_r4 = mdecl $ Stind_r4 +stind_r4 = OpCode $ Stind_r4 stind_r8 :: MethodDecl -stind_r8 = mdecl $ Stind_r8 +stind_r8 = OpCode $ Stind_r8 stind_ref :: MethodDecl -stind_ref = mdecl $ Stind_ref +stind_ref = OpCode $ Stind_ref stloc :: Offset -> MethodDecl -stloc 0 = mdecl $ Stloc_0 -stloc 1 = mdecl $ Stloc_1 -stloc 2 = mdecl $ Stloc_2 -stloc 3 = mdecl $ Stloc_3 -stloc x = mdecl $ Stloc x +stloc 0 = OpCode $ Stloc_0 +stloc 1 = OpCode $ Stloc_1 +stloc 2 = OpCode $ Stloc_2 +stloc 3 = OpCode $ Stloc_3 +stloc x = OpCode $ Stloc x stlocN :: LocalName -> MethodDecl -stlocN nm = mdecl $ StlocN nm +stlocN nm = OpCode $ StlocN nm stsfld :: PrimitiveType -> AssemblyName -> TypeName -> FieldName -> MethodDecl -stsfld p a t f = mdecl $ Stsfld p a t f +stsfld p a t f = OpCode $ Stsfld p a t f sub :: MethodDecl -sub = mdecl $ Sub +sub = OpCode $ Sub sub_ovf :: MethodDecl -sub_ovf = mdecl $ Sub_ovf +sub_ovf = OpCode $ Sub_ovf sub_ovf_un :: MethodDecl -sub_ovf_un = mdecl $ Sub_ovf_un +sub_ovf_un = OpCode $ Sub_ovf_un +switch :: [Label] -> MethodDecl +switch = OpCode . Switch + tail :: MethodDecl -tail = mdecl $ Tail +tail = OpCode $ Tail tailcall :: MethodDecl -> MethodDecl -tailcall (Instr (OpCode oc)) = Instr (OpCode (Tailcall oc)) -tailcall _ = error $ "Language.Cil.Build.tailcall: Can't tailcall supplied argument" +tailcall (OpCode oc) = OpCode (Tailcall oc) +tailcall _ = error $ "Language.Cil.Build.tailcall: Can't tailcall supplied argument" throw :: MethodDecl -throw = mdecl $ Throw +throw = OpCode $ Throw unaligned :: Alignment -> MethodDecl -unaligned a = mdecl $ Unaligned a +unaligned a = OpCode $ Unaligned a unalignedPtr :: Alignment -> MethodDecl -> MethodDecl -unalignedPtr a (Instr (OpCode oc)) | supportsUnaligned oc = mdecl $ UnalignedPtr a oc -unalignedPtr _ _ = error $ "Language.Cil.Build.unalignedPtr: Supplied argument doesn't require alignment" +unalignedPtr a (OpCode oc) | supportsUnaligned oc = OpCode $ UnalignedPtr a oc +unalignedPtr _ _ = error $ "Language.Cil.Build.unalignedPtr: Supplied argument doesn't require alignment" volatile :: MethodDecl -volatile = mdecl $ Volatile +volatile = OpCode $ Volatile volatilePtr :: MethodDecl -> MethodDecl -volatilePtr (Instr (OpCode oc)) | supportsVolatile oc = mdecl $ VolatilePtr oc -volatilePtr _ = error $ "Language.Cil.Build.volatilePtr: Supplied argument cannot be marked volatile" +volatilePtr (OpCode oc) | supportsVolatile oc = OpCode $ VolatilePtr oc +volatilePtr _ = error $ "Language.Cil.Build.volatilePtr: Supplied argument cannot be marked volatile" xor :: MethodDecl -xor = mdecl $ Xor +xor = OpCode $ Xor -- Helper functions -mdecl :: OpCode -> MethodDecl -mdecl i = Instr $ OpCode i - supportsUnaligned :: OpCode -> Bool supportsUnaligned (VolatilePtr oc) = supportsPrefix oc supportsUnaligned oc = supportsPrefix oc @@ -585,12 +613,9 @@ -- Convenient AST functions --- | Relabel a labelled mdecl with a new label. -label :: Label -> MethodDecl -> MethodDecl -label l (Instr (LabOpCode _ oc)) = Instr $ LabOpCode l oc -label l (Instr (OpCode oc)) = Instr $ LabOpCode l oc -label _ _ = error $ "Language.Cil.Build.label: " - ++ "Can't label non-Instrs." +-- | Relabel a labelled MethodDecl with a new label. +label :: Label -> MethodDecl +label l = Label l comment :: String -> MethodDecl comment s = Comment s diff --git a/src/Language/Cil/Pretty.hs b/src/Language/Cil/Pretty.hs --- a/src/Language/Cil/Pretty.hs +++ b/src/Language/Cil/Pretty.hs @@ -99,16 +99,19 @@ pr (FaPublic) = ("public" ++) pr (FaPrivate) = ("private" ++) pr (FaAssembly) = ("assembly" ++) + pr (FaInitOnly) = ("initonly" ++) instance Pretty MethodDef where pr (Constructor mas t ps ms) = ident . (".method " ++) - . prList mas . pr t . sp . (".ctor(" ++) + . prList mas . pr t . sp . (ctorName ++) . foldr (.) id (intersperse (", " ++) (map pr ps)) . (") cil managed\n" ++) . ident . ("{\n" ++) . foldr (\m s -> pr m . s) id ms . ident . ("}\n" ++) + where ctorName = if static then ".cctor(" else ".ctor(" + static = MaStatic `elem` mas pr (Method mas t n ps ms) = ident . (".method " ++) . prList mas @@ -138,13 +141,10 @@ instance Pretty MethodDecl where pr (Directive d) = pr d - pr (Instr i) = pr i + pr (Label l) = ident . (l ++) . (":" ++) . nl + pr (OpCode oc) = ident . ident . pr oc . nl pr (Comment s) = ident . ident . ("// " ++) . (s ++) . nl -instance Pretty Instr where - pr (OpCode oc) = ident . ident . pr oc . nl - pr (LabOpCode l oc) = ident . (l ++) . (":" ++) . nl - . ident . ident . pr oc . nl instance Pretty Directive where pr (EntryPoint) = ident . ident . (".entrypoint" ++) . nl @@ -179,6 +179,7 @@ . prCall a c m ps pr (CallVirt t a c m ps) = ("callvirt instance " ++) . prsp t . sp . prCall a c m ps + pr (Castclass t) = ("castclass " ++) . pr t pr (Ceq) = ("ceq" ++) pr (Cgt) = ("cgt" ++) pr (Ckfinite) = ("ckfinite" ++) @@ -193,6 +194,8 @@ pr (Ldarg_2) = ("ldarg.2 " ++) pr (Ldarg_3) = ("ldarg.3 " ++) pr (LdargN nm) = ("ldarg " ++) . prName nm + pr (Ldarga x) = ("ldarga " ++) . shows x + pr (LdargaN nm) = ("ldarga " ++) . prName nm pr (Ldc_i4 x) = ("ldc.i4 " ++) . shows x pr (Ldc_i4_0) = ("ldc.i4.0 " ++) pr (Ldc_i4_1) = ("ldc.i4.1 " ++) @@ -220,7 +223,7 @@ pr (Ldelem_ref) = ("ldelem.ref " ++) pr (Ldfld t a c f) = ("ldfld " ++) . pr t . sp . prFld a c f pr (Ldflda t a c f) = ("ldflda " ++) . pr t . sp . prFld a c f - pr (Ldftn t a c m ps) = ("ldftn " ++) . pr t . sp . prCall a c m ps + pr (Ldftn cc t a c m ps) = ("ldftn " ++) . prList cc . pr t . sp . prCall a c m ps pr (Ldind_i) = ("ldind.i " ++) pr (Ldind_i1) = ("ldind.i1 " ++) pr (Ldind_i2) = ("ldind.i2 " ++) @@ -245,6 +248,7 @@ 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 + pr (Ldtoken t) = ("ldtoken " ++) . prTypeToken t pr (Mul) = ("mul" ++) pr (Mul_ovf) = ("mul.ovf" ++) pr (Mul_ovf_un) = ("mul.ovf.un" ++) @@ -287,12 +291,14 @@ pr (Sub) = ("sub" ++) pr (Sub_ovf) = ("sub.ovf" ++) pr (Sub_ovf_un) = ("sub.ovf.un" ++) + pr (Switch labels) = (("switch (" ++ intercalate ", " labels ++ ")") ++) pr (Tail) = ("tail." ++) pr (Tailcall opcode) = ("tail. " ++) . pr opcode pr (Throw) = ("throw" ++) pr (Unaligned a) = ("unaligned. " ++) . pr a pr (UnalignedPtr a opcode) = ("unaligned. " ++) . pr a . sp . pr opcode pr (Unbox t) = ("unbox " ++) . pr t + pr (Unbox_any t) = ("unbox.any " ++) . pr t pr (Volatile) = ("volatile." ++) pr (VolatilePtr opcode) = ("volatile. " ++) . pr opcode pr (Xor) = ("xor" ++) @@ -330,9 +336,20 @@ . 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 +prTypeToken t = pr t + prAssembly :: DottedName -> ShowS prAssembly a = bool (("[" ++) . prName a . ("]" ++)) id (a == "") +prGenericTypeName :: TypeName -> [a] -> (a -> ShowS) -> ShowS +prGenericTypeName n args prArg = + prName n + . ("`" ++) . shows (length args) + . ("<" ++) . foldr (.) id (intersperse ("," ++) (map prArg args)) . (">" ++) + instance Pretty PrimitiveType where pr Void = ("void" ++) pr Bool = ("bool" ++) @@ -341,16 +358,17 @@ pr Int32 = ("int32" ++) pr Int64 = ("int64" ++) pr Float32 = ("float32" ++) - pr Double64 = ("double64" ++) + pr Double64 = ("float64" ++) pr IntPtr = ("native int" ++) pr String = ("string" ++) pr Object = ("object" ++) pr (ValueType a c) = ("valuetype " ++) . prAssembly a . prName c pr (ReferenceType a c) = ("class " ++ ) . prAssembly a . prName c - pr (GenericReferenceType a c gs) = prAssembly a . prName c . ("`" ++) . shows (length gs) - . ("<" ++) . foldr (.) id (intersperse ("," ++) (map ((("!" ++) .) . prName) gs)) . (">" ++) + 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 (ByRef pt) = pr pt . ("&" ++) + pr (Array et) = pr et . ("[]" ++) instance Pretty Alignment where pr ByteAligned = ("1" ++) diff --git a/src/Language/Cil/Syntax.hs b/src/Language/Cil/Syntax.hs --- a/src/Language/Cil/Syntax.hs +++ b/src/Language/Cil/Syntax.hs @@ -30,7 +30,6 @@ , Parameter (..) , ParamAttr (..) , MethodDecl (..) - , Instr (..) , Directive (..) , Local (..) , Label @@ -124,6 +123,7 @@ | FaPublic | FaPrivate | FaAssembly + | FaInitOnly deriving Show -- | Primitive types in CIL. @@ -142,9 +142,11 @@ | ValueType AssemblyName TypeName | ReferenceType AssemblyName TypeName | GenericReferenceType AssemblyName TypeName [GenParamName] + | GenericReferenceTypeInstance AssemblyName TypeName [PrimitiveType] | ByRef PrimitiveType | GenericType Offset - deriving Show + | Array PrimitiveType + deriving (Eq, Ord, Show) -- | A specification of pointer alignment. data Alignment @@ -167,7 +169,7 @@ | MaAssembly | MaVirtual | MaHidebysig - deriving Show + deriving (Show, Eq) -- | A formal parameter to a method. data Parameter @@ -184,8 +186,9 @@ -- | Method declarations, i.e. the body of a method. data MethodDecl = Directive Directive - | Instr Instr - | Comment String + | Label Label + | OpCode OpCode + | Comment String deriving Show -- | Directive meta data for method definitions. @@ -200,13 +203,6 @@ = Local PrimitiveType LocalName deriving Show --- | Single instruction in method definition. --- Either an OpCode or a labelled OpCode. -data Instr - = LabOpCode Label OpCode - | OpCode OpCode - deriving Show - -- | CIL OpCodes inside a method definition. -- See -- for a more complete list with documentation. @@ -240,6 +236,7 @@ , methodName :: MethodName -- ^ Name of the method. , paramTypes :: [PrimitiveType] -- ^ Types of the formal parameters of the method. } -- ^ Pops /n/ values, calls specified virtual method, pushes return value. (where /n/ is the number of formal parameters of the method). + | Castclass PrimitiveType -- ^ Pops 1 value, attempts to cast it to the specified type. If this succeeds, pushes the cast value. Otherwise throws an InvalidCastException. | Ceq -- ^ Pops 2 values, if they are equal, pushes 1 to stack; otherwise, pushes 0. | 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. @@ -254,6 +251,8 @@ | Ldarg_2 -- ^ Loads 2th argument to current method onto stack. | Ldarg_3 -- ^ Loads 3th argument to current method onto stack. | LdargN DottedName -- ^ Loads named argument to current method onto stack. + | Ldarga Offset -- ^ Loads address of the /n/-th argument to current method onto stack. + | LdargaN DottedName -- ^ Loads address of the named argument to current method onto stack. | Ldc_i4 Integer -- ^ Loads the supplied 32-bit integer onto the stack. | Ldc_i4_0 -- ^ Loads the value 0 onto the stack. | Ldc_i4_1 -- ^ Loads the value 1 onto the stack. @@ -295,7 +294,8 @@ , fieldName :: FieldName -- ^ Name of the field. } -- ^ Pops object reference, find address of specified field on the object, pushes address to the stack. | Ldftn - { returnType :: PrimitiveType -- ^ Return type of the method. + { callConv :: [CallConv] -- ^ Method is associated with class or instance. + , returnType :: PrimitiveType -- ^ Return type of the method. , assemblyName :: AssemblyName -- ^ Name of the assembly where the method resides. , typeName :: TypeName -- ^ Name of the type of which the method is a member. , methodName :: MethodName -- ^ Name of the method. @@ -335,6 +335,7 @@ , fieldName :: FieldName -- ^ Name of the field. } -- ^ 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. | 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. @@ -393,12 +394,14 @@ | Sub -- ^ Pops 2 values, subtracts second value from the first value, pushes result. | Sub_ovf -- ^ Pops 2 values, subtracts second value from the first value with a signed overflow check, pushes result. | Sub_ovf_un -- ^ Pops 2 values, subtracts second value from the first value with an unsigned overflow check, pushes result. + | Switch [Label] -- ^ Pops an unsigned integer value and transfers control to label with matching index. | Tail -- ^ Performs subsequent call as a tail call, by replacing current stack frame with callee stack frame. | Tailcall OpCode -- ^ Performs provided call as a tail call, by replacing current stack frame with callee stack frame. | Throw -- ^ Pops an object reference from the stack and throws it as an exception. | Unaligned Alignment -- ^ Performs subsequent load or store operation under a weaker-than-usual alignment precondition. | UnalignedPtr Alignment OpCode -- ^ Performs provided load or store operation under a weaker-than-usual alignment precondition. | Unbox PrimitiveType -- ^ Pops 1 value, unboxes object reference, pushes value type. + | Unbox_any PrimitiveType -- ^ Pops 1 value, unboxes and loads value, equivalent to unbox followed by ldobj | Volatile -- ^ Marks subsequent pointer reference as volatile, i.e. the value it points at can be modified from another thread. | VolatilePtr OpCode -- ^ Marks provided pointer reference as volatile, i.e. the value it points at can be modified from another thread. | Xor -- ^ Pops 2 values, do bitwise XOR between the values, pushes result.