language-cil (empty) → 0.2.0
raw patch · 8 files changed
+1213/−0 lines, 8 filesdep +basedep +bool-extrassetup-changed
Dependencies added: base, bool-extras
Files
- LICENSE +27/−0
- Setup.lhs +4/−0
- language-cil.cabal +35/−0
- src/Language/Cil.hs +24/−0
- src/Language/Cil/Analysis.hs +30/−0
- src/Language/Cil/Build.hs +409/−0
- src/Language/Cil/Pretty.hs +325/−0
- src/Language/Cil/Syntax.hs +359/−0
+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ language-cil.cabal view
@@ -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:+ <http://en.wikipedia.org/wiki/Common_Intermediate_Language>+ .+ 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 <tom@lokhorst.eu>+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+
+ src/Language/Cil.hs view
@@ -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 "")+
+ src/Language/Cil/Analysis.hs view
@@ -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 ]+
+ src/Language/Cil/Build.hs view
@@ -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"+
+ src/Language/Cil/Pretty.hs view
@@ -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 '<Thunk>').+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<!0>::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' :)+
+ src/Language/Cil/Syntax.hs view
@@ -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 <http://msdn.microsoft.com/en-us/library/system.reflection.emit.opcodes_fields.aspx>+-- 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+