diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2008, Tom Lokhorst + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/language-cil.cabal b/language-cil.cabal new file mode 100644 --- /dev/null +++ b/language-cil.cabal @@ -0,0 +1,35 @@ +name: language-cil +version: 0.2.0 +synopsis: Manipulating Common Intermediate Language AST +description: Language-Cil is a Haskell library for manipulating CIL + abstract syntax and generating .il files. + . + Common Intermediate Language (CIL), formerly known as + Microsoft Intermediate Language (MSIL), is the lowest + level language that runs on Microsoft .NET and Mono. + . + Read more on Wikipedia: + + . + This library is still under development, it only supports + a small subset of the full CIL. +license: BSD3 +license-file: LICENSE +author: Jeroen Leeuwestein, + Tom Lokhorst +maintainer: Tom Lokhorst +stability: Experimental +category: Language, .NET +build-type: Simple +cabal-version: >= 1.6 + +library + hs-source-dirs: src + build-depends: base > 3 && < 5, + bool-extras >= 0.3.0 && < 0.4 + exposed-modules: Language.Cil + Language.Cil.Analysis + Language.Cil.Build + Language.Cil.Pretty + Language.Cil.Syntax + diff --git a/src/Language/Cil.hs b/src/Language/Cil.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cil.hs @@ -0,0 +1,24 @@ +-- | +-- A simple abstraction over the Common Intermediate Language (also known as +-- MSIL - Microsoft Intermediate Language). +-- Currently, it only exposes a small subset of CIL. +-- + +module Language.Cil + ( module Language.Cil.Analysis + , module Language.Cil.Build + , module Language.Cil.Pretty + , module Language.Cil.Syntax + , writeAssembly + ) where + +import Control.Monad (liftM) + +import Language.Cil.Analysis +import Language.Cil.Build +import Language.Cil.Pretty +import Language.Cil.Syntax + +writeAssembly :: FilePath -> Assembly -> IO () +writeAssembly fp a = writeFile fp (pr a "") + diff --git a/src/Language/Cil/Analysis.hs b/src/Language/Cil/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cil/Analysis.hs @@ -0,0 +1,30 @@ +-- | +-- Analysis functions over the Cil AST. +-- + +module Language.Cil.Analysis ( + instructions + ) where + +import Language.Cil.Syntax + +class Ast a where + -- A concatenated list of all instructions. + instructions :: a -> [Instr] + +instance Ast Assembly where + instructions (Assembly _ _ td) = concatMap instructions td + +instance Ast TypeDef where + instructions (Class _ _ _ _ cd) = concatMap instructions cd + instructions (GenericClass _ _ _ cd) = concatMap instructions cd + +instance Ast ClassDecl where + instructions (FieldDef _) = [] + instructions (MethodDef md) = instructions md + instructions (TypeDef td) = instructions td + +instance Ast MethodDef where + instructions (Constructor _ _ _ md) = [ i | Instr i <- md ] + instructions (Method _ _ _ _ md) = [ i | Instr i <- md ] + diff --git a/src/Language/Cil/Build.hs b/src/Language/Cil/Build.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cil/Build.hs @@ -0,0 +1,409 @@ +-- | +-- Combinators for building abstract syntax. +-- + +module Language.Cil.Build ( + + -- * Assembly ref functions + assemblyRef + + -- * Directive functions + , entryPoint + , localsInit + , maxStack + + -- * mdecl functions + , add + , beq + , bge + , bgt + , ble + , blt + , box + , br + , brfalse + , brtrue + , call + , callvirt + , ceq + , cge + , cgt + , cle + , clt + , dup + , isinst + , ldarg + , ldargN + , ldc_i4 + , ldc_i8 + , ldc_r4 + , ldc_r8 + , ldchar + , ldfld + , ldflda + , ldftn + , ldind_i + , ldind_i1 + , ldind_i2 + , ldind_i4 + , ldind_i8 + , ldind_r4 + , ldind_r8 + , ldind_ref + , ldind_u1 + , ldind_u2 + , ldind_u4 + , ldloc + , ldlocN + , ldloca + , ldlocaN + , ldsfld + , ldsflda + , ldstr + , mul + , neg + , newobj + , nop + , pop + , rem + , ret + , stfld + , stind_i + , stind_i1 + , stind_i2 + , stind_i4 + , stind_i8 + , stind_r4 + , stind_r8 + , stind_ref + , stloc + , stlocN + , stsfld + , sub + , tail + , tailcall + , unbox + + -- * Convenient AST functions + , label + , comment + , extends + , noExtends + , noImplements + , classDef + , defaultCtor + , extendsCtor + , simpleAssembly + , mscorlibRef + ) where + +-- If someone uses the `rem' or `tail' opcode, they can deal with the ambiguous +-- occurence themselves! +import Prelude hiding (rem, tail) +import Data.Char (ord) + +import Language.Cil.Syntax + +-- AssemblyRef functions + +assemblyRef :: AssemblyName -> Version -> PublicKeyToken -> AssemblyRef +assemblyRef = AssemblyRef + +-- Directive functions + +entryPoint :: MethodDecl +entryPoint = Directive EntryPoint + +localsInit :: [Local] -> MethodDecl +localsInit ls = Directive (LocalsInit ls) + +maxStack :: Int -> MethodDecl +maxStack x = Directive (MaxStack x) + + +-- mdecl functions + +add :: MethodDecl +add = mdecl $ Add + +beq :: Label -> MethodDecl +beq = mdecl . Beq + +bge :: Label -> MethodDecl +bge = mdecl . Bge + +bgt :: Label -> MethodDecl +bgt = mdecl . Bgt + +ble :: Label -> MethodDecl +ble = mdecl . Ble + +blt :: Label -> MethodDecl +blt = mdecl . Blt + +box :: PrimitiveType -> MethodDecl +box = mdecl . Box + +unbox :: PrimitiveType -> MethodDecl +unbox = mdecl . Unbox + +br :: Label -> MethodDecl +br = mdecl . Br + +brfalse :: Label -> MethodDecl +brfalse = mdecl . Brfalse + +brtrue :: Label -> MethodDecl +brtrue = mdecl . Brtrue + +call :: [CallConv] -> PrimitiveType -> AssemblyName -> TypeName -> MethodName -> [PrimitiveType] -> MethodDecl +call ccs p l t m ps = mdecl $ 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 + +ceq, cge, cgt, cle, clt :: MethodDecl +ceq = mdecl $ Ceq +cge = mdecl $ Cge +cgt = mdecl $ Cgt +cle = mdecl $ Cle +clt = mdecl $ Clt + +dup :: MethodDecl +dup = mdecl $ Dup + +isinst :: TypeName -> MethodDecl +isinst = mdecl . 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 + +ldargN :: DottedName -> MethodDecl +ldargN = mdecl . LdargN + +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 + then Ldc_i4_s (fromInteger x) + else Ldc_i4 x + +ldc_i8 :: Integer -> MethodDecl +ldc_i8 = mdecl . Ldc_i8 + +ldc_r4 :: Float -> MethodDecl +ldc_r4 = mdecl . Ldc_r4 + +ldc_r8 :: Double -> MethodDecl +ldc_r8 = mdecl . Ldc_r8 + +ldchar :: Char -> MethodDecl +ldchar c = ldc_i4 (toInteger $ ord c) + +ldfld :: PrimitiveType -> AssemblyName -> TypeName -> FieldName -> MethodDecl +ldfld p a t f = mdecl $ Ldfld p a t f + +ldflda :: PrimitiveType -> AssemblyName -> TypeName -> FieldName -> MethodDecl +ldflda p a t f = mdecl $ Ldflda p a t f + +ldftn :: PrimitiveType -> AssemblyName -> TypeName -> MethodName -> [PrimitiveType] -> MethodDecl +ldftn p a t m ps = mdecl $ Ldftn p a t m ps + +ldind_i :: MethodDecl +ldind_i = mdecl $ Ldind_i + +ldind_i1 :: MethodDecl +ldind_i1 = mdecl $ Ldind_i1 + +ldind_i2 :: MethodDecl +ldind_i2 = mdecl $ Ldind_i2 + +ldind_i4 :: MethodDecl +ldind_i4 = mdecl $ Ldind_i4 + +ldind_i8 :: MethodDecl +ldind_i8 = mdecl $ Ldind_i8 + +ldind_r4 :: MethodDecl +ldind_r4 = mdecl $ Ldind_r4 + +ldind_r8 :: MethodDecl +ldind_r8 = mdecl $ Ldind_r8 + +ldind_ref :: MethodDecl +ldind_ref = mdecl $ Ldind_ref + +ldind_u1 :: MethodDecl +ldind_u1 = mdecl $ Ldind_u1 + +ldind_u2 :: MethodDecl +ldind_u2 = mdecl $ Ldind_u2 + +ldind_u4 :: MethodDecl +ldind_u4 = mdecl $ Ldind_u4 + +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 + +ldlocN :: LocalName -> MethodDecl +ldlocN nm = mdecl $ LdlocN nm + +ldloca :: Offset -> MethodDecl +ldloca = mdecl . Ldloca + +ldlocaN :: LocalName -> MethodDecl +ldlocaN nm = mdecl $ LdlocaN nm + +ldsfld :: PrimitiveType -> AssemblyName -> TypeName -> FieldName -> MethodDecl +ldsfld p a t f = mdecl $ Ldsfld p a t f + +ldsflda :: PrimitiveType -> AssemblyName -> TypeName -> FieldName -> MethodDecl +ldsflda p a t f = mdecl $ Ldsflda p a t f + +ldstr :: String -> MethodDecl +ldstr = mdecl . Ldstr + +mul :: MethodDecl +mul = mdecl $ Mul + +neg :: MethodDecl +neg = mdecl $ Neg + +-- | 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 + +nop :: MethodDecl +nop = mdecl $ Nop + +pop :: MethodDecl +pop = mdecl $ Pop + +rem :: MethodDecl +rem = mdecl $ Rem + +ret :: MethodDecl +ret = mdecl $ Ret + +stfld :: PrimitiveType -> AssemblyName -> TypeName -> FieldName -> MethodDecl +stfld p a t f = mdecl $ Stfld p a t f + +stind_i :: MethodDecl +stind_i = mdecl $ Stind_i + +stind_i1 :: MethodDecl +stind_i1 = mdecl $ Stind_i1 + +stind_i2 :: MethodDecl +stind_i2 = mdecl $ Stind_i2 + +stind_i4 :: MethodDecl +stind_i4 = mdecl $ Stind_i4 + +stind_i8 :: MethodDecl +stind_i8 = mdecl $ Stind_i8 + +stind_r4 :: MethodDecl +stind_r4 = mdecl $ Stind_r4 + +stind_r8 :: MethodDecl +stind_r8 = mdecl $ Stind_r8 + +stind_ref :: MethodDecl +stind_ref = mdecl $ 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 + +stlocN :: LocalName -> MethodDecl +stlocN nm = mdecl $ StlocN nm + +stsfld :: PrimitiveType -> AssemblyName -> TypeName -> FieldName -> MethodDecl +stsfld p a t f = mdecl $ Stsfld p a t f + +sub :: MethodDecl +sub = mdecl $ Sub + +tail :: MethodDecl +tail = mdecl $ Tail + +tailcall :: MethodDecl -> MethodDecl +tailcall (Instr (OpCode oc)) = Instr (OpCode (Tailcall oc)) +tailcall _ = error $ "Language.Cil.Build.tailcall: Can't tailcall supplied argument" + + +-- Helper functions + +mdecl :: OpCode -> MethodDecl +mdecl i = Instr $ OpCode i + +-- 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." + +comment :: String -> MethodDecl +comment s = Comment s + +extends :: TypeName -> Maybe TypeSpec +extends nm = Just (TypeSpec nm) + +noExtends :: Maybe TypeSpec +noExtends = Nothing + +noImplements :: [TypeSpec] +noImplements = [] + +classDef :: [ClassAttr] -> TypeName -> Maybe TypeSpec -> [TypeSpec] -> [FieldDef] -> [MethodDef]-> [TypeDef] -> TypeDef +classDef cas n et its fs ms ts = Class cas n et its (map FieldDef fs ++ map MethodDef ms ++ map TypeDef ts) + +defaultCtor :: [Parameter] -> MethodDef +defaultCtor = extendsCtor "" "object" + +extendsCtor :: AssemblyName -> TypeName -> [Parameter] -> MethodDef +extendsCtor a c ps = Constructor [MaPublic] Void ps + $ ldarg 0 + : map ldarg [1 .. length ps] + ++ + [ call [CcInstance] Void a c ".ctor" (map (\(Param _ t _) -> t) ps) + , ret + ] + +-- | Create a simple Assembly with one method containing the provided MethodDecls. +simpleAssembly :: [MethodDecl] -> Assembly +simpleAssembly ocs = Assembly [mscorlibRef] "DefaultAssemblyName" + [ Class [CaPublic] "DefaultClassName" Nothing [] + [ MethodDef + $ Method [MaStatic, MaPublic] Void "DefaultMethodName" [] (entryPoint : ocs) + ] + ] + +mscorlibRef :: AssemblyRef +mscorlibRef = AssemblyRef "mscorlib" (2, 0, 0 ,0) "B7 7A 5C 56 19 34 E0 89" + diff --git a/src/Language/Cil/Pretty.hs b/src/Language/Cil/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cil/Pretty.hs @@ -0,0 +1,325 @@ +-- | +-- Pretty-printer for the abstract syntax. +-- Currenty uses ShowS, maybe should use some PP combinator library? +-- + +module Language.Cil.Pretty ( + Pretty (pr) + ) where + +import Language.Cil.Syntax + +import Data.Bool.Extras (bool) +import Data.List (intersperse, intercalate) + +{- Alternative to deriving Show + +instance Show Assembly where + show a = pr a "" +-} + +class Pretty a where + -- | Serializes a Cil data structure to a String. + pr :: a -> ShowS + +-- | Serializes a DottedName, escaping some weird names (such as \'add\' +-- or ''). +prName :: DottedName -> ShowS +prName "" = error "Language.Cil.Pretty.prName: Name cannot be empty" +prName n = if n `elem` keywords -- || '<' `elem` n -- temp disabled, fix later: stfld class Lazy::func + then (escape n ++) + else (n ++) + where + escape s = intercalate "/" (map (\s' -> "'" ++ s' ++ "'") (filter (/=[]) (split '/' s))) + +split :: Eq a => a -> [a] -> [[a]] +split x xs = f xs [] + where + f [] zs = [zs] + f (y:ys) zs = if x == y + then zs:f ys [] + else f ys (zs++[y]) + +instance Pretty Assembly where + pr (Assembly as n ts) = + foldr (\a s -> pr a . s) id as + . (".assembly " ++) . prName n . (" {}\n" ++) + . foldr (\t s -> pr t . nl . s) id ts + +instance Pretty AssemblyRef where + pr (AssemblyRef n (x0, x1, x2, x3) t) = + (".assembly extern " ++) . (n ++) . nl + . ("{" ++) . nl + . ident . (".ver " ++) . shows x0 . (":" ++) . shows x1 . (":" ++) . shows x2 . (":" ++) . shows x3 . nl + . ident . (".publickeytoken = (" ++) . (t ++) . (")" ++) . nl + . ("}" ++) . nl + +instance Pretty TypeDef where + pr (Class cas n et its ds) = + (".class " ++) + . prList cas . prName n + . maybe id (\e -> sp . ("extends " ++) . pr e) et + . bool (sp . ("implements " ++) . foldr (.) id (map pr its)) id (null its) + . ("\n{\n" ++) + . foldr (\d s -> pr d . s) id ds + . ("}\n" ++) + pr (GenericClass cas n ps ds) = + (".class " ++) . prList cas . prName n + . ("`" ++) . shows (length ps) . ("<" ++) + . foldr (.) id (intersperse (", " ++) (map pr ps)) + . (">\n{\n" ++) + . foldr (\d s -> pr d . s) id ds + . ("}\n" ++) + +instance Pretty GenParam where + pr (GenParam n) = prName n + +instance Pretty ClassAttr where + pr CaPrivate = ("private" ++) + pr CaPublic = ("public" ++) + pr CaNestedPublic = ("nested public" ++) + pr CaNestedPrivate = ("nested private" ++) + +instance Pretty ClassDecl where + pr (FieldDef fd) = pr fd + pr (MethodDef md) = pr md + pr (TypeDef td) = pr td + +instance Pretty TypeSpec where + pr (TypeSpec nm) = prName nm + +instance Pretty FieldDef where + pr (Field fas t n) = + ident . (".field " ++) + . prList fas + . pr t . sp . prName n . nl + +instance Pretty FieldAttr where + pr (FaStatic) = ("static" ++) + pr (FaPublic) = ("public" ++) + pr (FaPrivate) = ("private" ++) + pr (FaAssembly) = ("assembly" ++) + +instance Pretty MethodDef where + pr (Constructor mas t ps ms) = + ident . (".method " ++) + . prList mas . pr t . sp . (".ctor(" ++) + . foldr (.) id (intersperse (", " ++) (map pr ps)) + . (") cil managed\n" ++) + . ident . ("{\n" ++) + . foldr (\m s -> pr m . s) id ms + . ident . ("}\n" ++) + pr (Method mas t n ps ms) = + ident . (".method " ++) + . prList mas + . pr t . sp . prName n . ("(" ++) + . foldr (.) id (intersperse (", " ++) (map pr ps)) + . (") cil managed\n" ++) + . ident . ("{\n" ++) + . foldr (\m s -> pr m . s) id ms + . ident . ("}\n" ++) + +instance Pretty MethAttr where + pr (MaStatic) = ("static" ++) + pr (MaPublic) = ("public" ++) + pr (MaPrivate) = ("private" ++) + pr (MaAssembly) = ("assembly" ++) + pr (MaVirtual) = ("virtual" ++) + pr (MaHidebysig) = ("hidebysig" ++) + +instance Pretty Parameter where + pr (Param mps t n) = maybe id (\p -> ("[" ++) . pr p . ("] " ++)) mps + . pr t . sp . prName n + +instance Pretty ParamAttr where + pr (PaIn) = ("in" ++) + pr (PaOut) = ("out" ++) + pr (PaOpt) = ("opt" ++) + +instance Pretty MethodDecl where + pr (Directive d) = pr d + pr (Instr i) = pr i + 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 + pr (LocalsInit ls) = + let bigident = ident . ident . ident . ident + in + ident . ident . (".locals init (" ++) + . bool nl id (null ls) + . foldr (.) id (intersperse (",\n" ++) (map (\l -> bigident . pr l) ls)) + . (")\n" ++) + pr (MaxStack x) = ident . ident . (".maxstack " ++) . shows x . nl + +instance Pretty Local where + pr (Local t n) = pr t . sp . prName n + +instance Pretty OpCode where + pr (Add) = ("add" ++) + pr (And) = ("and" ++) + pr (Beq l) = ("beq " ++) . (l ++) + pr (Bge l) = ("bge " ++) . (l ++) + pr (Bgt l) = ("bgt " ++) . (l ++) + pr (Ble l) = ("ble " ++) . (l ++) + pr (Blt l) = ("blt " ++) . (l ++) + pr (Box t) = ("box " ++) . pr t + pr (Br l) = ("br " ++) . (l ++) + pr (Brfalse l) = ("brfalse " ++) . (l ++) + pr (Brtrue l) = ("brtrue " ++) . (l ++) + pr (Call ccs t a c m ps) = ("call " ++) . prList ccs . pr t . sp + . prCall a c m ps + pr (CallVirt t a c m ps) = ("callvirt instance " ++) . prsp t . sp + . prCall a c m ps + pr (Ceq) = ("ceq" ++) + pr (Cge) = ("cge" ++) + pr (Cgt) = ("cgt" ++) + pr (Cle) = ("cle" ++) + pr (Clt) = ("clt" ++) + pr (Dup) = ("dup" ++) + pr (Isinst nm) = ("isinst " ++) . prName nm + pr (Ldarg x) = ("ldarg " ++) . shows x + pr (Ldarg_0) = ("ldarg.0 " ++) + pr (Ldarg_1) = ("ldarg.1 " ++) + pr (Ldarg_2) = ("ldarg.2 " ++) + pr (Ldarg_3) = ("ldarg.3 " ++) + pr (LdargN nm) = ("ldarg " ++) . prName nm + pr (Ldc_i4 x) = ("ldc.i4 " ++) . shows x + pr (Ldc_i4_0) = ("ldc.i4.0 " ++) + pr (Ldc_i4_1) = ("ldc.i4.1 " ++) + pr (Ldc_i4_2) = ("ldc.i4.2 " ++) + pr (Ldc_i4_3) = ("ldc.i4.3 " ++) + pr (Ldc_i4_4) = ("ldc.i4.4 " ++) + pr (Ldc_i4_5) = ("ldc.i4.5 " ++) + pr (Ldc_i4_6) = ("ldc.i4.6 " ++) + pr (Ldc_i4_7) = ("ldc.i4.7 " ++) + pr (Ldc_i4_8) = ("ldc.i4.8 " ++) + pr (Ldc_i4_m1) = ("ldc.i4.m1 " ++) + pr (Ldc_i4_s x) = ("ldc.i4.s " ++) . shows x + 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 (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 (Ldind_i) = ("ldind.i " ++) + pr (Ldind_i1) = ("ldind.i1 " ++) + pr (Ldind_i2) = ("ldind.i2 " ++) + pr (Ldind_i4) = ("ldind.i4 " ++) + pr (Ldind_i8) = ("ldind.i8 " ++) + pr (Ldind_r4) = ("ldind.r4 " ++) + pr (Ldind_r8) = ("ldind.r8 " ++) + pr (Ldind_ref) = ("ldind.ref " ++) + pr (Ldind_u1) = ("ldind.u1 " ++) + pr (Ldind_u2) = ("ldind.u2 " ++) + pr (Ldind_u4) = ("ldind.u4 " ++) + pr (Ldloc x) = ("ldloc " ++) . shows x + pr (Ldloc_0) = ("ldloc.0 " ++) + pr (Ldloc_1) = ("ldloc.1 " ++) + pr (Ldloc_2) = ("ldloc.2 " ++) + pr (Ldloc_3) = ("ldloc.3 " ++) + pr (LdlocN nm) = ("ldloc " ++) . prName nm + pr (Ldloca x) = ("ldloca " ++) . shows x + pr (LdlocaN nm) = ("ldloca " ++) . prName nm + 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 (Mul) = ("mul" ++) + pr (Neg) = ("neg" ++) + pr (Newobj t a c ps) = ("newobj instance " ++) . pr t . sp + . prNewobj a c ps + pr (Nop) = ("nop" ++) + pr (Pop) = ("pop" ++) + pr (Rem) = ("rem" ++) + pr (Ret) = ("ret" ++) + pr (Stfld t a c f) = ("stfld " ++) . pr t . sp . prFld a c f + pr (Stind_i) = ("stind.i " ++) + pr (Stind_i1) = ("stind.i1 " ++) + pr (Stind_i2) = ("stind.i2 " ++) + pr (Stind_i4) = ("stind.i4 " ++) + pr (Stind_i8) = ("stind.i8 " ++) + pr (Stind_r4) = ("stind.r4 " ++) + pr (Stind_r8) = ("stind.r8 " ++) + pr (Stind_ref) = ("stind.ref " ++) + pr (Stloc x) = ("stloc " ++) . shows x + pr (Stloc_0) = ("stloc.0 " ++) + pr (Stloc_1) = ("stloc.1 " ++) + pr (Stloc_2) = ("stloc.2 " ++) + pr (Stloc_3) = ("stloc.3 " ++) + pr (StlocN nm) = ("stloc " ++) . prName nm + pr (Stsfld t a c f) = ("stsfld " ++) . pr t . sp . prFld a c f + pr (Sub) = ("sub" ++) + pr (Tail) = ("tail." ++) + pr (Tailcall opcode) = ("tail. " ++) . pr opcode + pr (Unbox t) = ("unbox " ++) . pr t + +instance Pretty CallConv where + pr (CcInstance) = ("instance" ++) + +prList :: (Pretty a) => [a] -> ShowS +prList = foldr (\x s -> pr x . sp . s) id + +prFld :: DottedName -> DottedName -> DottedName -> ShowS +prFld a c f = + prAssembly a + . (if c /= "" + then prName c . ("::" ++) + else id) + . prName f + +prNewobj :: DottedName -> DottedName -> [PrimitiveType] -> ShowS +prNewobj a c ps = + prAssembly a + . (if c /= "" + then prName c . ("::" ++) + else id) + . (".ctor(" ++) + . foldr (.) id (intersperse (", " ++) (map pr ps)) + . (")" ++) + +prCall :: DottedName -> DottedName -> DottedName -> [PrimitiveType] -> ShowS +prCall a c m ps = + prAssembly a + . bool (prName c . ("::" ++)) id (c == "") + . prName m + . ("(" ++) + . foldr (.) id (intersperse (", " ++) (map pr ps)) + . (")" ++) + +prAssembly :: DottedName -> ShowS +prAssembly a = bool (("[" ++) . prName a . ("]" ++)) id (a == "") + +instance Pretty PrimitiveType where + pr Void = ("void" ++) + pr Bool = ("bool" ++) + pr Char = ("char" ++) + pr Byte = ("uint8" ++) + pr Int32 = ("int32" ++) + pr Int64 = ("int64" ++) + pr Float32 = ("float32" ++) + pr Double64 = ("double64" ++) + 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 (GenericType x) = ("!" ++) . shows x + pr (ByRef pt) = pr pt . ("&" ++) + +-- Helper functions, to pretty print +prsp :: (Pretty a) => a -> ShowS +prsp x = let s = pr x "" + in bool (pr x . sp) id (s == "") + +ident, sp, nl :: ShowS +ident = (" " ++) +sp = (" " ++) +nl = ('\n' :) + diff --git a/src/Language/Cil/Syntax.hs b/src/Language/Cil/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cil/Syntax.hs @@ -0,0 +1,359 @@ +-- | +-- Abstract Syntax Tree for the Common Intermediate Language. +-- Note; currently this is just a subset of CIL. +-- + +module Language.Cil.Syntax ( + keywords + , DottedName + , AssemblyName + , TypeName + , GenParamName + , MethodName + , FieldName + , ParamName + , LocalName + , Version + , PublicKeyToken + , Offset + , Assembly (..) + , AssemblyRef (..) + , TypeDef (..) + , GenParam (..) + , ClassAttr (..) + , ClassDecl (..) + , TypeSpec (..) + , FieldDef (..) + , FieldAttr (..) + , MethodDef (..) + , MethAttr (..) + , Parameter (..) + , ParamAttr (..) + , MethodDecl (..) + , Instr (..) + , Directive (..) + , Local (..) + , Label + , OpCode (..) + , PrimitiveType (..) + , CallConv (..) + ) where + +keywords :: [String] +keywords = ["add", "mul", "or", "pop", "sub", "value"] + +-- | A name in the CIL world. +-- These need to confirm to certain restrictions, altough these aren't +-- currently checked. +type DottedName = String + +type AssemblyName = DottedName +type TypeName = DottedName +type GenParamName = DottedName +type MethodName = DottedName +type FieldName = DottedName +type ParamName = DottedName +type LocalName = DottedName + +-- | An offset, e.g. for local variables or arguments +type Offset = Int + +-- | A Label in CIL. +type Label = String + +-- | A Version number in CIL +type Version = (Int, Int, Int, Int) + +-- | A public key token +type PublicKeyToken = String + +-- | The top level Assembly. +-- This is the root of a CIL program. +data Assembly + = Assembly [AssemblyRef] AssemblyName [TypeDef] + deriving Show + +-- | Assembly reference. +data AssemblyRef + = AssemblyRef AssemblyName Version PublicKeyToken + deriving Show + +-- | A Type definition in CIL, either a class or a value type. +data TypeDef + = Class [ClassAttr] TypeName (Maybe TypeSpec) [TypeSpec] [ClassDecl] + | GenericClass [ClassAttr] TypeName [GenParam] [ClassDecl] + deriving Show + +-- | A parameter to a generic class. +-- Not fully implemented yet, constraints aren't supported. +data GenParam + = GenParam -- constraintFlags :: [ConstraintFlag] + -- constraints :: [DottedName] + {- paramName -} GenParamName + deriving Show + +-- | Attribures to class definitions. +data ClassAttr + = CaPrivate + | CaPublic + | CaNestedPublic + | CaNestedPrivate + deriving Show + +-- | Class declarations, i.e. the body of a class. +data ClassDecl + = FieldDef FieldDef + | MethodDef MethodDef + | TypeDef TypeDef + deriving Show + +-- | Type specification. +data TypeSpec + = TypeSpec TypeName + deriving Show + +-- | Field definition. +data FieldDef + = Field [FieldAttr] PrimitiveType FieldName + deriving Show + +-- | Attributes to field definitions. +data FieldAttr + = FaStatic + | FaPublic + | FaPrivate + | FaAssembly + deriving Show + +-- | Primitive types in CIL. +data PrimitiveType + = Void + | Bool + | Char + | Byte + | Int32 + | Int64 + | Float32 + | Double64 + | IntPtr + | String + | Object + | ValueType AssemblyName TypeName + | ReferenceType AssemblyName TypeName + | GenericReferenceType AssemblyName TypeName [GenParamName] + | ByRef PrimitiveType + | GenericType Offset + deriving Show + +-- | A Method definition in CIL. +data MethodDef + = Constructor [MethAttr] PrimitiveType [Parameter] [MethodDecl] + | Method [MethAttr] PrimitiveType MethodName [Parameter] [MethodDecl] + deriving Show + +-- | Attributes to method definitions. +data MethAttr + = MaStatic + | MaPublic + | MaPrivate + | MaAssembly + | MaVirtual + | MaHidebysig + deriving Show + +-- | A formal parameter to a method. +data Parameter + = Param (Maybe ParamAttr) PrimitiveType ParamName + deriving Show + +-- | Attributes to parameter definitions. +data ParamAttr + = PaIn + | PaOut + | PaOpt + deriving Show + +-- | Method declarations, i.e. the body of a method. +data MethodDecl + = Directive Directive + | Instr Instr + | Comment String + deriving Show + +-- | Directive meta data for method definitions. +data Directive + = EntryPoint + | LocalsInit [Local] + | MaxStack Int + deriving Show + +-- | Local variables used inside a method definition. +data Local + = 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. +data OpCode + = Add -- ^ Pops 2 values, adds the values, pushes result. + | And -- ^ Pops 2 values, do bitwise AND between the values, pushes result. + | Beq Label -- ^ Pops 2 values, if first value is equal to second value, jump to specified label. + | Bge Label -- ^ Pops 2 values, if first value is greater or equal to second value, jump to specified label. + | Bgt Label -- ^ Pops 2 values, if first value is greater than second value, jump to specified label. + | Ble Label -- ^ Pops 2 values, if first value is lesser or equal to second value, jump to specified label. + | Blt Label -- ^ Pops 2 values, if first value is lesser or equal to second value, jump to specified label. + | Box PrimitiveType -- ^ Pops 1 value, boxes value type, pushes object reference. + | Br Label -- ^ Unconditionally jump to specified label. + | 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. + | Call + { 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. + , paramTypes :: [PrimitiveType] -- ^ Types of the formal parameters of the method. + } -- ^ Pops /n/ values, calls specified method, pushes return value. (where /n/ is the number of formal parameters of the method). + | CallVirt + { 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. + , 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). + | Ceq -- ^ Pops 2 values, if they are equal, pushes 1 to stack; otherwise, pushes 0. + | Cge -- ^ Pops 2 values and compares them. + | Cgt -- ^ Pops 2 values and compares them. + | Cle -- ^ Pops 2 values and compares them. + | Clt -- ^ Pops 2 values and compares them. + | Dup -- ^ Pops 1 value, copies it, pushes the same value twise. + | Isinst TypeName -- ^ Tests if an object reference is an instance of class, returning either a null reference or an instance of that class or interface. + | Ldarg Offset -- ^ Loads /n/-th argument to current method onto stack. + | Ldarg_0 -- ^ Loads 0th argument to current method onto stack. + | Ldarg_1 -- ^ Loads 1th argument to current method onto stack. + | 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. + | 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. + | Ldc_i4_2 -- ^ Loads the value 2 onto the stack. + | Ldc_i4_3 -- ^ Loads the value 3 onto the stack. + | Ldc_i4_4 -- ^ Loads the value 4 onto the stack. + | Ldc_i4_5 -- ^ Loads the value 5 onto the stack. + | Ldc_i4_6 -- ^ Loads the value 6 onto the stack. + | Ldc_i4_7 -- ^ Loads the value 7 onto the stack. + | Ldc_i4_8 -- ^ Loads the value 8 onto the stack. + | Ldc_i4_m1 -- ^ Loads the value -1 onto the stack. + | Ldc_i4_s Int -- ^ Loads the supplied 8-bit integer onto the stack as 32-bit integer (short form). + | Ldc_i8 Integer -- ^ Loads the supplied 64-bit integer onto the stack. + | Ldc_r4 Float -- ^ Loads the supplied 32-bit float onto the stack. + | Ldc_r8 Double -- ^ Loads the supplied 64-bit double onto the stack. + | Ldfld + { fieldType :: PrimitiveType -- ^ Type of the field. + , assemblyName :: AssemblyName -- ^ Name of the assembly where the field resides. + , typeName :: TypeName -- ^ Name of the type of which the field is a member. + , fieldName :: FieldName -- ^ Name of the field. + } -- ^ Pops object reference, find value of specified field on object, pushes value to the stack. + | Ldflda + { fieldType :: PrimitiveType -- ^ Type of the field. + , assemblyName :: AssemblyName -- ^ Name of the assembly where the field resides. + , typeName :: TypeName -- ^ Name of the type of which the field is a member. + , 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. + , 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. + , paramTypes :: [PrimitiveType] -- ^ Types of the formal parameters of the method. + } -- ^ Pops object reference, finds address of specified method, pushes address as native int to the stack. + | Ldind_i -- ^ Pops an address, pushes the native integer stored at the address. + | Ldind_i1 -- ^ Pops an address, pushes the 8-bit integer stored at the address as a 32-bit integer. + | Ldind_i2 -- ^ Pops an address, pushes the 16-bit integer stored at the address as a 32-bit integer. + | Ldind_i4 -- ^ Pops an address, pushes the 32-bit integer stored at the address. + | Ldind_i8 -- ^ Pops an address, pushes the 64-bit integer stored at the address as a 64-bit integer. + | Ldind_r4 -- ^ Pops an address, pushes the 32-bit float stored at the address. + | Ldind_r8 -- ^ Pops an address, pushes the 64-bit double stored at the address. + | Ldind_ref -- ^ Pops an address, pushes the object reference specified at the address. + | Ldind_u1 -- ^ Pops an address, pushes the 8-bit unsigned integer stored at the address as a 32-bit integer. + | Ldind_u2 -- ^ Pops an address, pushes the 16-bit unsigned integer stored at the address as a 32-bit integer. + | Ldind_u4 -- ^ Pops an address, pushes the 32-bit unsigned integer stored at the address as a 32-bit integer. + | Ldloc Offset -- ^ Pushes value of local variable, specified by index, to the stack. + | Ldloc_0 -- ^ Pushes 0th local variable to the stack. + | Ldloc_1 -- ^ Pushes 1th local variable to the stack. + | Ldloc_2 -- ^ Pushes 2th local variable to the stack. + | Ldloc_3 -- ^ Pushes 3th local variable to the stack. + | LdlocN DottedName -- ^ Pushes value of local variable, specified by name, to the stack. + | Ldloca Offset -- ^ Pushes address of local variable, specified by index, to the stack. + | LdlocaN DottedName -- ^ Pushes address of local variable, specified by name, to the stack. + | Ldsfld + { fieldType :: PrimitiveType -- ^ Type of the field. + , assemblyName :: AssemblyName -- ^ Name of the assembly where the field resides. + , typeName :: TypeName -- ^ Name of the type of which the field is a member. + , fieldName :: FieldName -- ^ Name of the field. + } -- ^ Pops type reference, find value of specified field on the type, pushes value to the stack. + | Ldsflda + { fieldType :: PrimitiveType -- ^ Type of the field. + , assemblyName :: AssemblyName -- ^ Name of the assembly where the field resides. + , typeName :: TypeName -- ^ Name of the type of which the field is a member. + , 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. + | Mul -- ^ Pops 2 values, multiplies the values, pushes result. + | Neg -- ^ Pops 1 value, negates the value, pushes the value. + | Newobj + { returnType :: PrimitiveType -- ^ Return type of the constructor (almost alway Void). + , assemblyName :: AssemblyName -- ^ Name of the assembly where the constructor resides. + , typeName :: TypeName -- ^ Name of the type of which the constructor is a member. + , paramTypes :: [PrimitiveType] -- ^ Types of the formal paramters of the constructor. + } -- ^ Creates a new object or instance of a value type. Pops /n/ values, calls the specified constructor, pushes a new object reference onto the stack (where /n/ is the number of formal parameters of the constructor). + | Nop -- ^ No operation is performed. + | Pop -- ^ Pops the top of the stack. + | Rem -- ^ Pops 2 values, devides the first value by the second value, pushes the remainder. + | Ret -- ^ Returns from the current method. Pushes top of the stack to the top of the callers stack (if stack is not empty). + | Stfld + { fieldType :: PrimitiveType -- ^ Type of the field. + , assemblyName :: AssemblyName -- ^ Name of the assembly where the field resides. + , typeName :: TypeName -- ^ Name of the type of which the field is a member. + , fieldName :: FieldName -- ^ Name of the field. + } -- ^ Replaces the value stored in the field of an object reference or pointer with a new value. + | Stind_i -- ^ Pops an address and a native integer, stores the integer at the address. + | Stind_i1 -- ^ Pops an address and a 8-bit integer, stores the integer at the address. + | Stind_i2 -- ^ Pops an address and a 16-bit integer, stores the integer at the address. + | Stind_i4 -- ^ Pops an address and a 32-bit integer, stores the integer at the address. + | Stind_i8 -- ^ Pops an address and a 64-bit integer, stores the integer at the address. + | Stind_r4 -- ^ Pops an address and a 32-bit float, stores the float at the address. + | Stind_r8 -- ^ Pops an address and a 64-bit double, stores the double at the address. + | Stind_ref -- ^ Pops an address and an object reference, stores the object reference at the address. + | Stloc Offset -- ^ Pops 1 value, stores it in the local variable specified by index. + | Stloc_0 -- ^ Pops 1 value, stores it in the 0th local variable. + | Stloc_1 -- ^ Pops 1 value, stores it in the 1th local variable. + | 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. + | Stsfld + { fieldType :: PrimitiveType -- ^ Type of the field. + , assemblyName :: AssemblyName -- ^ Name of the assembly where the field resides. + , typeName :: TypeName -- ^ Name of the type of which the field is a member. + , fieldName :: FieldName -- ^ Name of the field. + } -- ^ Replaces the value stored in the static field of a type with a new value. + | Sub -- ^ Pops 2 values, substracts second value from the first value, pushes result. + | 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. + | Unbox PrimitiveType -- ^ Pops 1 value, unboxes object reference, pushes value type. + deriving Show + +-- | Calling convention for method calls. +data CallConv + = CcInstance + deriving Show +