hLLVM (empty) → 0.5.0.0
raw patch · 54 files changed
+12493/−0 lines, 54 filesdep +arraydep +basedep +bytestringsetup-changed
Dependencies added: array, base, bytestring, cmdargs, containers, data-dword, directory, filepath, hooplext, mtl, parsec, pretty, template-haskell, transformers
Files
- CHANGES +6/−0
- LICENSE +24/−0
- README.md +38/−0
- Setup.hs +4/−0
- TODO +3/−0
- hLLVM.cabal +135/−0
- src/Llvm/Data/Ast.hs +357/−0
- src/Llvm/Data/Conversion.hs +11/−0
- src/Llvm/Data/Conversion/AstIrConversion.hs +1492/−0
- src/Llvm/Data/Conversion/AstScanner.hs +14/−0
- src/Llvm/Data/Conversion/AstSimplification.hs +750/−0
- src/Llvm/Data/Conversion/IrAstConversion.hs +1171/−0
- src/Llvm/Data/Conversion/LabelMapM.hs +77/−0
- src/Llvm/Data/Conversion/TypeConversion.hs +350/−0
- src/Llvm/Data/CoreIr.hs +782/−0
- src/Llvm/Data/Ir.hs +162/−0
- src/Llvm/Data/IrType.hs +1069/−0
- src/Llvm/Data/Shared.hs +21/−0
- src/Llvm/Data/Shared/AtomicEntity.hs +324/−0
- src/Llvm/Data/Shared/DataLayout.hs +86/−0
- src/Llvm/Data/Shared/SimpleConst.hs +42/−0
- src/Llvm/Data/Shared/Util.hs +74/−0
- src/Llvm/Data/Type.hs +54/−0
- src/Llvm/Pass/Dominator.hs +130/−0
- src/Llvm/Pass/Liveness.hs +122/−0
- src/Llvm/Pass/Mem2Reg.hs +129/−0
- src/Llvm/Pass/NormalGraph.hs +17/−0
- src/Llvm/Pass/Optimizer.hs +36/−0
- src/Llvm/Pass/PassManager.hs +25/−0
- src/Llvm/Pass/PassTester.hs +28/−0
- src/Llvm/Pass/PhiFixUp.hs +93/−0
- src/Llvm/Pass/Rewriter.hs +245/−0
- src/Llvm/Pass/Uda.hs +166/−0
- src/Llvm/Query/Conversion.hs +59/−0
- src/Llvm/Query/IrCxt.hs +50/−0
- src/Llvm/Query/Qerror.hs +23/−0
- src/Llvm/Query/TypeConstValue.hs +364/−0
- src/Llvm/Query/TypeDef.hs +13/−0
- src/Llvm/Syntax/Parser/Basic.hs +491/−0
- src/Llvm/Syntax/Parser/Block.hs +26/−0
- src/Llvm/Syntax/Parser/Const.hs +230/−0
- src/Llvm/Syntax/Parser/DataLayout.hs +93/−0
- src/Llvm/Syntax/Parser/Instruction.hs +109/−0
- src/Llvm/Syntax/Parser/Module.hs +224/−0
- src/Llvm/Syntax/Parser/Rhs.hs +326/−0
- src/Llvm/Syntax/Parser/Type.hs +153/−0
- src/Llvm/Syntax/Printer/Common.hs +23/−0
- src/Llvm/Syntax/Printer/IrPrint.hs +1041/−0
- src/Llvm/Syntax/Printer/LlvmPrint.hs +592/−0
- src/Llvm/Syntax/Printer/SharedEntityPrint.hs +396/−0
- src/Llvm/Util/Mapping.hs +8/−0
- src/Llvm/Util/Monadic.hs +13/−0
- src/LlvmTest.hs +168/−0
- src/ParserTester.hs +54/−0
+ CHANGES view
@@ -0,0 +1,6 @@+0.5 +- support LLVM 3.5 syntax+- renamed to hLLVM+0.1+- support LLVM 3.1 syntax+- Hoopl based implementation :mem2reg, dce, dominator
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2011-2015 Ning Wang (email@ningwang.org)+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * 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.+ * Neither the name of the Ning Wang nor the+ names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 NING WANG 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.
+ README.md view
@@ -0,0 +1,38 @@+hLLVM -- A Haskell Library for analyzing and transforming LLVM assembly codes+++Goal: +==========================================+- Provide functionalities for performaning analysis and transformation of LLVM codes in pure Haskell++++Build:+==============+From hLLVM toplevel directory++ cabal configure++ cabal build++The test driver 'llvm-test' is generated at dist/build/llvm-test++Test:+==============+## test LLVM assembly parser+dist/build/llvm-test/llvm-test parse -i test/test1.ll -o out.ll++## test mem2reg pass+dist/build/llvm-test/llvm-test pass -s=mem2reg -f=10000 -i test/test1.ll -o out.ll+++## test dce pass+dist/build/llvm-test/llvm-test pass -s=dce -f=10000 -i test/test1.ll -o out.ll+++## test mem2reg and dce passes+dist/build/llvm-test/llvm-test pass -s=mem2reg -s=dce -f=1000 -i test/test1.ll -o out.ll+++## run tests in batch (llvm-test needs to be available in the executable search paths)+test/runLlvmTest.sh [parse|ast2ir|ir2ast] <directory of llvm-3.5 test cases>
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple+main = defaultMain++
+ TODO view
@@ -0,0 +1,3 @@+- hoopl will remove all unresearchable code, however, blockaddress might refer to some removed code labels. We need to write a pass to update all blockaddress that still refer to removed code labels to undef++- constant folding
+ hLLVM.cabal view
@@ -0,0 +1,135 @@+name: hLLVM+version: 0.5.0.0+license: BSD3+license-file: LICENSE+author: Ning Wang <email@ningwang.org>+maintainer: Ning Wang <email@ningwang.org>+build-Type: Simple+cabal-Version: >= 1.10+stability: 0.5+synopsis: A library for processing LLVM assembly codes+category: Compilers/Interpreters+description: A pure Haskell library for analyzing and transforming LLVM assembly codes. + It includes:+ 1) a parser to parse LLVM code in its text form+ 2) an internal IR that can be feed into Hoopl+ 3) a set of utility functions to convert LLVM AST to and from the internal IR + 4) a set of utility functions to query the IR++extra-source-files: README.md, LICENSE, CHANGES, TODO++source-repository head+ type: git+ location: https://github.com/mlite/hLLVM.git++++flag debug {+ description: Enable debug support+ default: False+}++flag testcoverage {+ description: Enable test coverage report+ default: False+}++library {+ default-language: Haskell2010+ build-depends: base >= 3 && < 5,+ containers,+ array,+ bytestring,+ mtl,+ filepath,+ directory,+ hooplext == 3.10.0.2,+ parsec >=3.1.2 && <3.2,+ cmdargs >=0.10 && <0.11,+ transformers >= 0.3.0.0,+ pretty >= 1.1.1.1,+ data-dword == 0.3,+ template-haskell >= 2.9.0.0+ hs-source-dirs: src+ exposed-modules: Llvm.Data.Ast,+ Llvm.Data.Type,+ Llvm.Data.CoreIr,+ Llvm.Data.Ir,+ Llvm.Data.IrType,+ Llvm.Data.Shared,+ Llvm.Data.Shared.AtomicEntity,+ Llvm.Data.Shared.SimpleConst,+ Llvm.Data.Shared.DataLayout,+ Llvm.Data.Shared.Util,+ Llvm.Data.Conversion,+ Llvm.Data.Conversion.AstSimplification,+ Llvm.Data.Conversion.AstIrConversion,+ Llvm.Data.Conversion.AstScanner,+ Llvm.Data.Conversion.IrAstConversion,+ Llvm.Data.Conversion.TypeConversion,+ Llvm.Data.Conversion.LabelMapM,+ Llvm.Util.Mapping,+ Llvm.Util.Monadic,+ Llvm.Query.TypeConstValue,+ Llvm.Query.Qerror,+ Llvm.Query.Conversion,+ Llvm.Query.IrCxt,+ Llvm.Query.TypeDef,+ Llvm.Syntax.Printer.Common,+ Llvm.Syntax.Printer.SharedEntityPrint,+ Llvm.Syntax.Printer.IrPrint,+ Llvm.Syntax.Printer.LlvmPrint,+ Llvm.Syntax.Parser.Basic,+ Llvm.Syntax.Parser.Block,+ Llvm.Syntax.Parser.Const,+ Llvm.Syntax.Parser.DataLayout,+ Llvm.Syntax.Parser.Instruction,+ Llvm.Syntax.Parser.Module,+ Llvm.Syntax.Parser.Rhs,+ Llvm.Syntax.Parser.Type,+ Llvm.Pass.Dominator,+ Llvm.Pass.Liveness,+ Llvm.Pass.Mem2Reg,+ Llvm.Pass.NormalGraph,+ Llvm.Pass.Optimizer,+ Llvm.Pass.PassManager,+ Llvm.Pass.PhiFixUp,+ Llvm.Pass.Rewriter,+ Llvm.Pass.Uda,+ Llvm.Pass.PassTester,+ ParserTester+ if flag(debug) {+ if !os(windows) {+ cc-options: -DDEBUG+ } else {+ cc-options: -DNDEBUG+ }+ } + if flag(testcoverage) {+ ghc-options: + }+ other-extensions: CPP+}++executable llvm-test+ default-language: Haskell2010+ main-is: LlvmTest.hs+ hs-source-dirs: src+ build-depends: base >= 3 && < 5,+ containers,+ array,+ bytestring,+ mtl,+ filepath,+ directory,+ template-haskell >= 2.9.0.0,+ hooplext == 3.10.0.2,+ parsec >=3.1.2 && <3.2,+ cmdargs >=0.10 && <0.11,+ transformers >= 0.3.0.0,+ pretty >= 1.1.1.1,+ data-dword == 0.3+ if flag(testcoverage) {+ ghc-options:+ }+
+ src/Llvm/Data/Ast.hs view
@@ -0,0 +1,357 @@+{-# LANGUAGE GADTs #-}+module Llvm.Data.Ast+ ( module Llvm.Data.Ast+ , module Llvm.Data.Shared+ , module Llvm.Data.Type+ ) where++import Llvm.Data.Shared+import Llvm.Data.Type+import qualified Data.Map as M+import Data.Word (Word32)+++-- | quotation does not change a label value+-- | it's still unclear when a quoted verion is used+-- | we keep the original format to make llvm-as happy+data LabelId = LabelString String -- Lstring+ | LabelDqString String -- Lstring -- a string enclosed by double quotes+ | LabelNumber Word32 -- Int+ | LabelDqNumber Word32 -- Int -- a number enclosed by double quotes+ deriving (Eq,Ord,Show)++data BlockLabel = ExplicitBlockLabel LabelId+ | ImplicitBlockLabel (String, Int, Int)+ deriving (Eq, Ord, Show)++data PercentLabel = PercentLabel LabelId deriving (Eq, Ord, Show)+data TargetLabel = TargetLabel PercentLabel deriving (Eq,Ord,Show)++data IbinOp = Add | Sub | Mul | Udiv+ | Sdiv | Urem | Srem+ | Shl | Lshr | Ashr | And | Or | Xor+ deriving (Eq,Ord,Show)++ibinOpMap :: M.Map IbinOp String+ibinOpMap = M.fromList [(Add, "add"), (Sub, "sub"), (Mul, "mul")+ ,(Udiv, "udiv"), (Sdiv, "sdiv")+ ,(Urem, "urem"), (Srem, "srem")+ ,(Shl, "shl"), (Lshr, "lshr"), (Ashr, "ashr")+ ,(And, "and"), (Or, "or"), (Xor, "xor")+ ]++data FbinOp = Fadd | Fsub | Fmul | Fdiv | Frem+ deriving (Eq,Ord,Show)++fbinOpMap :: M.Map FbinOp String+fbinOpMap = M.fromList [(Fadd, "fadd"), (Fsub, "fsub"), (Fmul, "fmul"), (Fdiv, "fdiv"), (Frem, "frem")]++data TrapFlag = Nuw | Nsw | Exact deriving (Eq,Ord,Show)++trapFlagMap :: M.Map TrapFlag String+trapFlagMap = M.fromList [(Nuw, "nuw"), (Nsw, "nsw"), (Exact, "exact")]++-- | Binary Operations <http://llvm.org/releases/3.0/docs/LangRef.html#binaryops>+data IbinExpr v = IbinExpr IbinOp [TrapFlag] Type v v deriving (Eq,Ord,Show)+data FbinExpr v = FbinExpr FbinOp FastMathFlags Type v v deriving (Eq,Ord,Show)+data BinExpr v = Ie (IbinExpr v)+ | Fe (FbinExpr v)+ deriving (Eq, Ord, Show)+data GetElementPtr v = GetElementPtr (IsOrIsNot InBounds) (Pointer (Typed v)) [Typed v] deriving (Eq,Ord,Show)+data Select v = Select (Typed v) (Typed v) (Typed v) deriving (Eq,Ord,Show)+data Icmp v = Icmp IcmpOp Type v v deriving (Eq,Ord,Show)+data Fcmp v = Fcmp FcmpOp Type v v deriving (Eq,Ord,Show)+++-- | Vector Operations <http://llvm.org/releases/3.0/docs/LangRef.html#vectorops>+data ExtractElement v = ExtractElement (Typed v) (Typed v) deriving (Eq,Ord,Show)+data InsertElement v = InsertElement (Typed v) (Typed v) (Typed v) deriving (Eq,Ord,Show)+data ShuffleVector v = ShuffleVector (Typed v) (Typed v) (Typed v) deriving (Eq,Ord,Show)++-- | Aggregate Operations <http://llvm.org/releases/3.0/docs/LangRef.html#aggregateops>+data ExtractValue v = ExtractValue (Typed v) [Word32] deriving (Eq,Ord,Show)+data InsertValue v = InsertValue (Typed v) (Typed v) [Word32] deriving (Eq,Ord,Show)++-- | Conversion Operations <http://llvm.org/releases/3.0/docs/LangRef.html#convertops>+data Conversion v = Conversion ConvertOp (Typed v) Type deriving (Eq,Ord,Show)++data ConvertOp = Trunc | Zext | Sext | FpTrunc | FpExt | FpToUi+ | FpToSi | UiToFp | SiToFp | PtrToInt | IntToPtr+ | Bitcast | AddrSpaceCast+ deriving (Eq,Ord,Show)++convertOpMap :: M.Map ConvertOp String+convertOpMap = M.fromList [(Trunc, "trunc"), (Zext, "zext"), (Sext, "sext")+ ,(FpTrunc, "fptrunc"), (FpExt, "fpext"), (FpToUi, "fptoui")+ ,(FpToSi, "fptosi"), (UiToFp, "uitofp"), (SiToFp, "sitofp")+ ,(PtrToInt, "ptrtoint"), (IntToPtr, "inttoptr"), (Bitcast, "bitcast")+ ,(AddrSpaceCast, "addrspacecast")]++-- | Complex Constants <http://llvm.org/releases/3.0/docs/LangRef.html#complexconstants>+data ComplexConstant = Cstruct Packing [TypedConstOrNull]+ | Carray [TypedConstOrNull]+ | Cvector [TypedConstOrNull]+ deriving (Eq,Ord,Show)++-- | Constants <http://llvm.org/releases/3.5.0/docs/LangRef.html#constant-expressions>+data Const = C_simple SimpleConstant+ | C_complex ComplexConstant+ | C_localId LocalId+ | C_labelId LabelId+ -- | Addresses of Basic Block <http://llvm.org/releases/3.0/docs/LangRef.html#blockaddress>+ | C_blockAddress GlobalId PercentLabel+ | C_binexp (BinExpr Const)+ | C_conv (Conversion Const)+ | C_gep (GetElementPtr Const)+ | C_select (Select Const)+ | C_icmp (Icmp Const)+ | C_fcmp (Fcmp Const)+ | C_shufflevector (ShuffleVector Const)+ | C_extractvalue (ExtractValue Const)+ | C_insertvalue (InsertValue Const)+ | C_extractelement (ExtractElement Const)+ | C_insertelement (InsertElement Const)+ | C_null+ deriving (Eq,Ord,Show)++data Prefix = Prefix (TypedConstOrNull) deriving (Eq, Ord, Show)+data Prologue = Prologue (TypedConstOrNull) deriving (Eq, Ord, Show)++data MdVar = MdVar String deriving (Eq,Ord,Show)+data MdNode = MdNode String deriving (Eq,Ord,Show)+data MetaConst = McStruct [MetaKindedConst]+ | McString DqString+ | McMn MdNode+ | McMv MdVar+ | McRef LocalId+ | McSimple Const+ deriving (Eq,Ord,Show)++data MetaKindedConst = MetaKindedConst MetaKind MetaConst+ | UnmetaKindedNull+ deriving (Eq, Ord, Show)++data GetResult = GetResult (Typed Value) String deriving (Eq, Ord, Show)+++data Expr = EgEp (GetElementPtr Value)+ | EiC (Icmp Value)+ | EfC (Fcmp Value)+ | Eb (BinExpr Value)+ | Ec (Conversion Value)+ | Es (Select Value)+ deriving (Eq,Ord,Show)++-- | Memory Access and Addressing Operations <http://llvm.org/releases/3.5.0/docs/LangRef.html#memory-access-and-addressing-operations>+data MemOp = Alloca (IsOrIsNot InAllocaAttr) Type (Maybe (Typed Value)) (Maybe Alignment)+ | Load (IsOrIsNot Volatile) (Pointer (Typed Value)) (Maybe Alignment) (Maybe Nontemporal) (Maybe InvariantLoad) (Maybe Nonnull)+ | LoadAtomic Atomicity (IsOrIsNot Volatile) (Pointer (Typed Value)) (Maybe Alignment)+ | Store (IsOrIsNot Volatile) (Typed Value) (Pointer (Typed Value)) (Maybe Alignment) (Maybe Nontemporal)+ | StoreAtomic Atomicity (IsOrIsNot Volatile) (Typed Value) (Pointer (Typed Value)) (Maybe Alignment)+ | Fence (IsOrIsNot SingleThread) AtomicMemoryOrdering+ | CmpXchg (IsOrIsNot Weak) (IsOrIsNot Volatile) (Pointer (Typed Value)) (Typed Value) (Typed Value)+ (IsOrIsNot SingleThread) AtomicMemoryOrdering AtomicMemoryOrdering+ | AtomicRmw (IsOrIsNot Volatile) AtomicOp (Pointer (Typed Value)) (Typed Value)+ (IsOrIsNot SingleThread) AtomicMemoryOrdering deriving (Eq,Ord,Show)++data Pointer v = Pointer v deriving (Eq, Ord, Show)++instance Functor Pointer where+ fmap f (Pointer x) = Pointer (f x)++data FunName = FunNameGlobal GlobalOrLocalId+ | FunNameString String+ deriving (Eq,Ord,Show)++data CallSite = CsFun (Maybe CallConv) [ParamAttr] Type FunName [ActualParam] [FunAttr]+ | CsAsm Type (Maybe SideEffect) (Maybe AlignStack) AsmDialect DqString DqString [ActualParam] [FunAttr]+ | CsConversion [ParamAttr] Type (Conversion Const) [ActualParam] [FunAttr]+ deriving (Eq,Ord,Show)++data Clause = Catch (Typed Value)+ | Filter TypedConstOrNull+ | Cco (Conversion Value)+ deriving (Eq,Ord,Show)++data TypedConstOrNull = TypedConst (Typed Const)+ | UntypedNull+ deriving (Eq, Ord, Show)++data PersFn = PersFnId GlobalOrLocalId+ | PersFnCast (Conversion GlobalOrLocalId)+ | PersFnUndef+ | PersFnNull+ | PersFnConst Const+ deriving (Eq, Ord, Show)+++data Rhs = RmO MemOp+ | Re Expr+ | Call TailCall CallSite+ | ReE (ExtractElement Value)+ | RiE (InsertElement Value)+ | RsV (ShuffleVector Value)+ | ReV (ExtractValue Value)+ | RiV (InsertValue Value)+ | RvA VaArg+ | RlP LandingPad+ deriving (Eq,Ord,Show)++data VaArg = VaArg (Typed Value) Type deriving (Eq, Ord, Show)++data LandingPad = LandingPad Type Type PersFn (Maybe Cleanup) [Clause] deriving (Eq, Ord, Show)++data Dbg = Dbg MdVar MetaConst deriving (Eq,Show)++data PhiInst = PhiInst (Maybe LocalId) Type+ [(Value, PercentLabel)] deriving (Eq,Show)++data PhiInstWithDbg = PhiInstWithDbg PhiInst [Dbg]+ deriving (Eq, Show)++data ComputingInst = ComputingInst (Maybe LocalId) Rhs+ deriving (Eq,Show)+ +data ComputingInstWithDbg = ComputingInstWithDbg ComputingInst [Dbg]+ | ComputingInstWithComment String+ deriving (Eq,Show)++-- | Terminator Instructions <http://llvm.org/releases/3.0/docs/LangRef.html#terminators>+data TerminatorInst =+ -- | <http://llvm.org/releases/3.0/docs/LangRef.html#i_ret>+ RetVoid+ | Return [(Typed Value)]+ -- | <http://llvm.org/releases/3.0/docs/LangRef.html#i_br>+ | Br TargetLabel+ -- | <http://llvm.org/releases/3.0/docs/LangRef.html#i_br>+ | Cbr Value TargetLabel TargetLabel+ -- | <http://llvm.org/releases/3.0/docs/LangRef.html#i_switch>+ | Switch (Typed Value) TargetLabel [((Typed Value), TargetLabel)]+ -- | <http://llvm.org/releases/3.0/docs/LangRef.html#i_indirectbr>+ | IndirectBr (Typed Value) [TargetLabel]+ -- | <http://llvm.org/releases/3.0/docs/LangRef.html#i_invoke>+ | Invoke (Maybe LocalId) CallSite TargetLabel TargetLabel+ -- | <http://llvm.org/releases/3.0/docs/LangRef.html#i_unwind>+ | Unwind+ -- | <http://llvm.org/releases/3.0/docs/LangRef.html#i_resume>+ | Resume (Typed Value)+ -- | <http://llvm.org/releases/3.0/docs/LangRef.html#i_unreachable>+ | Unreachable+ deriving (Eq,Show)++data TerminatorInstWithDbg = TerminatorInstWithDbg TerminatorInst [Dbg]+ deriving (Eq,Show)++data ActualParam = ActualParamData Type [ParamAttr] (Maybe Alignment) Value [ParamAttr]+ | ActualParamMeta MetaKindedConst+ deriving (Eq,Ord,Show)++data Value = Val_local LocalId+ | Val_const Const+ deriving (Eq,Ord,Show)+ +data Typed v = Typed Type v deriving (Eq, Ord, Show)++data Aliasee = AtV (Typed Value)+ | Ac (Conversion Const)+ | AgEp (GetElementPtr Const)+ deriving (Eq,Show)++data FunctionPrototype = FunctionPrototype+ (Maybe Linkage)+ (Maybe Visibility)+ (Maybe DllStorageClass)+ (Maybe CallConv)+ [ParamAttr]+ Type+ GlobalId+ FormalParamList+ (Maybe AddrNaming)+ [FunAttr]+ (Maybe Section)+ (Maybe Comdat)+ (Maybe Alignment)+ (Maybe Gc)+ (Maybe Prefix)+ (Maybe Prologue)+ deriving (Eq,Ord,Show)+++data Toplevel = ToplevelTriple TlTriple+ | ToplevelDataLayout TlDataLayout+ | ToplevelAlias TlAlias+ | ToplevelDbgInit TlDbgInit+ | ToplevelStandaloneMd TlStandaloneMd+ | ToplevelNamedMd TlNamedMd+ | ToplevelDeclare TlDeclare+ | ToplevelDefine TlDefine+ | ToplevelGlobal TlGlobal+ | ToplevelTypeDef TlTypeDef+ | ToplevelDepLibs TlDepLibs+ | ToplevelUnamedType TlUnamedType+ | ToplevelModuleAsm TlModuleAsm+ | ToplevelAttribute TlAttribute+ | ToplevelComdat TlComdat+ deriving (Eq,Show)+++data TlTriple = TlTriple TargetTriple deriving (Eq, Show)++data TlDataLayout = TlDataLayout DataLayout deriving (Eq, Show)++data TlAlias = TlAlias GlobalId (Maybe Visibility) (Maybe DllStorageClass) (Maybe ThreadLocalStorage)+ AddrNaming (Maybe Linkage) Aliasee deriving (Eq, Show)++data TlDbgInit = TlDbgInit String Word32 deriving (Eq, Show)++data TlStandaloneMd = TlStandaloneMd String MetaKindedConst deriving (Eq, Show)++data TlNamedMd = TlNamedMd MdVar [MdNode] deriving (Eq, Show)++data TlDeclare = TlDeclare FunctionPrototype deriving (Eq, Show)++data TlDefine = TlDefine FunctionPrototype [Block] deriving (Eq, Show)++data TlGlobal = TlGlobal (Maybe GlobalId)+ (Maybe Linkage)+ (Maybe Visibility)+ (Maybe DllStorageClass)+ (Maybe ThreadLocalStorage)+ AddrNaming+ (Maybe AddrSpace)+ (IsOrIsNot ExternallyInitialized)+ GlobalType+ Type+ (Maybe Const)+ (Maybe Section)+ (Maybe Comdat)+ (Maybe Alignment)+ deriving (Eq, Show)++data TlTypeDef = TlTypeDef LocalId Type deriving (Eq, Show)++data TlDepLibs = TlDepLibs [DqString] deriving (Eq, Show)++data TlUnamedType = TlUnamedType Word32 Type deriving (Eq, Show)++data TlModuleAsm = TlModuleAsm DqString deriving (Eq, Show)++data TlAttribute = TlAttribute Word32 [FunAttr] deriving (Eq, Show)++data TlComdat = TlComdat DollarId SelectionKind deriving (Eq, Show)++data Block = Block BlockLabel [PhiInstWithDbg] [ComputingInstWithDbg] TerminatorInstWithDbg deriving (Eq,Show)++blockLabel :: Block -> BlockLabel+blockLabel (Block v _ _ _) = v++data Module = Module [Toplevel] deriving (Eq,Show)+++dataLayoutOfModule :: Module -> DataLayoutInfo+dataLayoutOfModule (Module tl) = let [ToplevelDataLayout (TlDataLayout dl)] =+ filter (\x -> case x of+ ToplevelDataLayout _ -> True+ _ -> False+ ) tl+ in getDataLayoutInfo dl
+ src/Llvm/Data/Conversion.hs view
@@ -0,0 +1,11 @@+module Llvm.Data.Conversion+ (module Llvm.Data.Conversion.AstSimplification+ ,module Llvm.Data.Conversion.AstIrConversion+ ,module Llvm.Data.Conversion.IrAstConversion+ ,module Llvm.Data.Conversion.LabelMapM+ ) where++import Llvm.Data.Conversion.AstSimplification+import Llvm.Data.Conversion.AstIrConversion+import Llvm.Data.Conversion.IrAstConversion+import Llvm.Data.Conversion.LabelMapM (IdLabelMap(..),a2h,invertMap)
+ src/Llvm/Data/Conversion/AstIrConversion.hs view
@@ -0,0 +1,1492 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Llvm.Data.Conversion.AstIrConversion(astToIr) where++#define FLC (I.FileLoc $(I.srcLoc))++import qualified Compiler.Hoopl as H+import qualified Control.Monad as Md+import qualified Data.Map as M+import qualified Llvm.Data.Ast as A+import qualified Llvm.Data.Ir as I+import Llvm.Data.Conversion.LabelMapM+import Llvm.Util.Monadic (maybeM, pairM)+import Llvm.Data.Conversion.TypeConversion+import Llvm.Data.Conversion.AstScanner (typeDefOfModule)+import Data.Maybe (fromJust)++type MM = LabelMapM H.SimpleUniqueMonad++{- Ast to Ir conversion -}+-- the real differences between Ast and Ir+-- 1. Ir uses Unique values as labels while Ast can use any strings as labels+-- 2. All unreachable code are removed in Ir++isTvector :: MP -> A.Type -> Bool+isTvector mp t = let (ta::I.Utype) = tconvert mp t+ in case ta of+ (I.UtypeVectorI _) -> True+ (I.UtypeVectorF _) -> True+ (I.UtypeVectorP _) -> True+ _ -> False++getElemPtrIsTvector :: MP -> A.GetElementPtr v -> Bool+getElemPtrIsTvector mp (A.GetElementPtr n (A.Pointer (A.Typed t _)) l) = isTvector mp t++conversionIsTvector :: MP -> A.Conversion v -> Bool+conversionIsTvector mp (A.Conversion _ _ dt) = isTvector mp dt++convert_LabelId :: A.LabelId -> MM H.Label +convert_LabelId = labelFor+++convert_PercentLabel :: A.PercentLabel -> MM H.Label +convert_PercentLabel (A.PercentLabel l) = convert_LabelId l++convert_TargetLabel :: A.TargetLabel -> MM H.Label +convert_TargetLabel (A.TargetLabel tl) = convert_PercentLabel tl ++convert_BlockLabel :: A.BlockLabel -> MM H.Label+convert_BlockLabel (A.ImplicitBlockLabel p) = error $ "ImplicitBlockLabel @" ++ show p ++ " should be normalized away in AstSimplification, and should not be leaked to Ast2Ir."+convert_BlockLabel (A.ExplicitBlockLabel b) = convert_LabelId b +++convert_ComplexConstant :: A.ComplexConstant -> (MM I.Const)+convert_ComplexConstant (A.Cstruct b fs) = Md.liftM (I.C_struct b) (mapM convert_TypedConstOrNUll fs)+convert_ComplexConstant (A.Cvector fs) = Md.liftM I.C_vector (mapM convert_TypedConstOrNUll fs)+convert_ComplexConstant (A.Carray fs) = Md.liftM I.C_array (mapM convert_TypedConstOrNUll fs)+++data Binexp s v where {+ Add :: (Maybe I.NoWrap) -> I.Type s I.I -> v -> v -> Binexp s v;+ Sub :: (Maybe I.NoWrap) -> I.Type s I.I -> v -> v -> Binexp s v;+ Mul :: (Maybe I.NoWrap) -> I.Type s I.I -> v -> v -> Binexp s v;+ Udiv :: (Maybe I.Exact) -> I.Type s I.I -> v -> v -> Binexp s v;+ Sdiv :: (Maybe I.Exact) -> I.Type s I.I -> v -> v -> Binexp s v;+ Urem :: I.Type s I.I -> v -> v -> Binexp s v;+ Srem :: I.Type s I.I -> v -> v -> Binexp s v;+ Shl :: (Maybe I.NoWrap) -> I.Type s I.I -> v -> v -> Binexp s v;+ Lshr :: (Maybe I.Exact) -> I.Type s I.I -> v -> v -> Binexp s v;+ Ashr :: (Maybe I.Exact) -> I.Type s I.I -> v -> v -> Binexp s v;+ And :: I.Type s I.I -> v -> v -> Binexp s v;+ Or :: I.Type s I.I -> v -> v -> Binexp s v;+ Xor :: I.Type s I.I -> v -> v -> Binexp s v;+ } deriving (Eq, Ord, Show)++data FBinexp s v where {+ Fadd :: I.FastMathFlags -> I.Type s I.F -> v -> v -> FBinexp s v;+ Fsub :: I.FastMathFlags -> I.Type s I.F -> v -> v -> FBinexp s v;+ Fmul :: I.FastMathFlags -> I.Type s I.F -> v -> v -> FBinexp s v;+ Fdiv :: I.FastMathFlags -> I.Type s I.F -> v -> v -> FBinexp s v;+ Frem :: I.FastMathFlags -> I.Type s I.F -> v -> v -> FBinexp s v;+ } deriving (Eq, Ord, Show)++++convert_to_Binexp :: (u -> MM v) -> A.IbinExpr u -> MM (Binexp I.ScalarB v)+convert_to_Binexp cvt (A.IbinExpr op cs t u1 u2) = + do { mp <- typeDefs+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; let ta::I.Type I.ScalarB I.I = I.dcast FLC $ ((tconvert mp t)::I.Utype)+ ; return (convert_IbinOp op cs ta u1a u2a)+ }+ where convert_IbinOp :: A.IbinOp -> [A.TrapFlag] -> I.Type I.ScalarB I.I -> v -> v -> Binexp I.ScalarB v+ convert_IbinOp op cs = case op of+ A.Add -> Add (getnowrap cs)+ A.Sub -> Sub (getnowrap cs)+ A.Mul -> Mul (getnowrap cs)+ A.Udiv -> Udiv (getexact cs)+ A.Sdiv -> Sdiv (getexact cs)+ A.Shl -> Shl (getnowrap cs)+ A.Lshr -> Lshr (getexact cs)+ A.Ashr -> Ashr (getexact cs)+ A.Urem -> Urem+ A.Srem -> Srem+ A.And -> And+ A.Or -> Or+ A.Xor -> Xor++convert_to_Binexp_V :: (u -> MM v) -> A.IbinExpr u -> MM (Binexp I.VectorB v)+convert_to_Binexp_V cvt (A.IbinExpr op cs t u1 u2) = + do { mp <- typeDefs+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; let ta::I.Type I.VectorB I.I = I.dcast FLC $ ((tconvert mp t)::I.Utype)+ ; return (convert_IbinOp op cs ta u1a u2a)+ }+ where convert_IbinOp :: A.IbinOp -> [A.TrapFlag] -> I.Type I.VectorB I.I -> v -> v -> Binexp I.VectorB v+ convert_IbinOp op cs = case op of+ A.Add -> Add (getnowrap cs)+ A.Sub -> Sub (getnowrap cs)+ A.Mul -> Mul (getnowrap cs)+ A.Udiv -> Udiv (getexact cs)+ A.Sdiv -> Sdiv (getexact cs)+ A.Shl -> Shl (getnowrap cs)+ A.Lshr -> Lshr (getexact cs)+ A.Ashr -> Ashr (getexact cs)+ A.Urem -> Urem+ A.Srem -> Srem+ A.And -> And+ A.Or -> Or+ A.Xor -> Xor+++getnowrap :: [A.TrapFlag] -> Maybe I.NoWrap+getnowrap x = case x of+ [A.Nsw] -> Just I.Nsw+ [A.Nuw] -> Just I.Nuw+ [A.Nsw,A.Nuw] -> Just I.Nsuw+ [A.Nuw,A.Nsw] -> Just I.Nsuw+ [] -> Nothing+ _ -> error ("irrefutable error1 " ++ show x)++getexact :: [A.TrapFlag] -> Maybe I.Exact+getexact x = case x of+ [A.Exact] -> Just I.Exact+ [] -> Nothing+ _ -> error "irrefutable error2"+++convert_to_FBinexp :: (u -> MM v) -> A.FbinExpr u -> (MM (FBinexp I.ScalarB v))+convert_to_FBinexp cvt (A.FbinExpr op cs t u1 u2) = + do { mp <- typeDefs+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; let ta::I.Type I.ScalarB I.F = I.dcast FLC $ ((tconvert mp t)::I.Utype)+ ; return ((convertFop op) cs ta u1a u2a)+ }+ where+ convertFop o = case o of+ A.Fadd -> Fadd+ A.Fsub -> Fsub+ A.Fmul -> Fmul+ A.Fdiv -> Fdiv+ A.Frem -> Frem+++convert_to_FBinexp_V :: (u -> MM v) -> A.FbinExpr u -> (MM (FBinexp I.VectorB v))+convert_to_FBinexp_V cvt (A.FbinExpr op cs t u1 u2) = + do { mp <- typeDefs+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; let ta::I.Type I.VectorB I.F = I.dcast FLC $ ((tconvert mp t)::I.Utype)+ ; return ((convertFop op) cs ta u1a u2a)+ }+ where+ convertFop o = case o of+ A.Fadd -> Fadd+ A.Fsub -> Fsub+ A.Fmul -> Fmul+ A.Fdiv -> Fdiv+ A.Frem -> Frem+++convert_to_Conversion :: (u -> MM v) -> A.Conversion u -> (MM (I.Conversion I.ScalarB v))+convert_to_Conversion cvt (A.Conversion op (A.Typed t u) dt) = + do { mp <- typeDefs+ ; u1 <- cvt u + ; let (t1::I.Utype) = tconvert mp t+ (dt1::I.Utype) = tconvert mp dt+ newOp = case op of+ A.Trunc -> let (t2::I.Type I.ScalarB I.I) = I.dcast FLC t1+ (dt2::I.Type I.ScalarB I.I) = I.dcast FLC dt1+ in I.Trunc (I.T t2 u1) dt2+ A.Zext -> let (t2::I.Type I.ScalarB I.I) = I.dcast FLC t1+ (dt2::I.Type I.ScalarB I.I) = I.dcast FLC dt1+ in I.Zext (I.T t2 u1) dt2 + A.Sext -> let (t2::I.Type I.ScalarB I.I) = I.dcast FLC t1+ (dt2::I.Type I.ScalarB I.I) = I.dcast FLC dt1+ in I.Sext (I.T t2 u1) dt2 + A.FpTrunc -> let (t2::I.Type I.ScalarB I.F) = I.dcast FLC t1+ (dt2::I.Type I.ScalarB I.F) = I.dcast FLC dt1+ in I.FpTrunc (I.T t2 u1) dt2 + A.FpExt -> let (t2::I.Type I.ScalarB I.F) = I.dcast FLC t1+ (dt2::I.Type I.ScalarB I.F) = I.dcast FLC dt1+ in I.FpExt (I.T t2 u1) dt2 + A.FpToUi -> let (t2::I.Type I.ScalarB I.F) = I.dcast FLC t1+ (dt2::I.Type I.ScalarB I.I) = I.dcast FLC dt1+ in I.FpToUi (I.T t2 u1) dt2 + A.FpToSi -> let (t2::I.Type I.ScalarB I.F) = I.dcast FLC t1+ (dt2::I.Type I.ScalarB I.I) = I.dcast FLC dt1+ in I.FpToSi (I.T t2 u1) dt2 + A.UiToFp -> let (t2::I.Type I.ScalarB I.I) = I.dcast FLC t1+ (dt2::I.Type I.ScalarB I.F) = I.dcast FLC dt1+ in I.UiToFp (I.T t2 u1) dt2 + A.SiToFp -> let (t2::I.Type I.ScalarB I.I) = I.dcast FLC t1+ (dt2::I.Type I.ScalarB I.F) = I.dcast FLC dt1+ in I.SiToFp (I.T t2 u1) dt2 + A.PtrToInt -> let (t2::I.Type I.ScalarB I.P) = I.dcast FLC t1+ (dt2::I.Type I.ScalarB I.I) = I.dcast FLC dt1+ in I.PtrToInt (I.T t2 u1) dt2 + A.IntToPtr -> let (t2::I.Type I.ScalarB I.I) = I.dcast FLC t1+ (dt2::I.Type I.ScalarB I.P) = I.dcast FLC dt1+ in I.IntToPtr (I.T t2 u1) dt2 + A.Bitcast -> let (t2::I.Dtype) = I.dcast FLC t1+ (dt2::I.Dtype) = I.dcast FLC dt1+ in I.Bitcast (I.T t2 u1) dt2 + A.AddrSpaceCast -> let (t2::I.Type I.ScalarB I.P) = I.dcast FLC t1+ (dt2::I.Type I.ScalarB I.P) = I.dcast FLC dt1+ in I.AddrSpaceCast (I.T t2 u1) dt2 + ; return newOp+ }++convert_to_Conversion_V :: (u -> MM v) -> A.Conversion u -> (MM (I.Conversion I.VectorB v))+convert_to_Conversion_V cvt (A.Conversion op (A.Typed t u) dt) = + do { mp <- typeDefs+ ; u1 <- cvt u + ; let (t1::I.Utype) = tconvert mp t+ (dt1::I.Utype) = tconvert mp dt+ newOp = case op of+ A.Trunc -> let (t2::I.Type I.VectorB I.I) = I.dcast FLC t1+ (dt2::I.Type I.VectorB I.I) = I.dcast FLC dt1+ in I.Trunc (I.T t2 u1) dt2+ A.Zext -> let (t2::I.Type I.VectorB I.I) = I.dcast FLC t1+ (dt2::I.Type I.VectorB I.I) = I.dcast FLC dt1+ in I.Zext (I.T t2 u1) dt2 + A.Sext -> let (t2::I.Type I.VectorB I.I) = I.dcast FLC t1+ (dt2::I.Type I.VectorB I.I) = I.dcast FLC dt1+ in I.Sext (I.T t2 u1) dt2 + A.FpTrunc -> let (t2::I.Type I.VectorB I.F) = I.dcast FLC t1+ (dt2::I.Type I.VectorB I.F) = I.dcast FLC dt1+ in I.FpTrunc (I.T t2 u1) dt2 + A.FpExt -> let (t2::I.Type I.VectorB I.F) = I.dcast FLC t1+ (dt2::I.Type I.VectorB I.F) = I.dcast FLC dt1+ in I.FpExt (I.T t2 u1) dt2 + A.FpToUi -> let (t2::I.Type I.VectorB I.F) = I.dcast FLC t1+ (dt2::I.Type I.VectorB I.I) = I.dcast FLC dt1+ in I.FpToUi (I.T t2 u1) dt2 + A.FpToSi -> let (t2::I.Type I.VectorB I.F) = I.dcast FLC t1+ (dt2::I.Type I.VectorB I.I) = I.dcast FLC dt1+ in I.FpToSi (I.T t2 u1) dt2 + A.UiToFp -> let (t2::I.Type I.VectorB I.I) = I.dcast FLC t1+ (dt2::I.Type I.VectorB I.F) = I.dcast FLC dt1+ in I.UiToFp (I.T t2 u1) dt2 + A.SiToFp -> let (t2::I.Type I.VectorB I.I) = I.dcast FLC t1+ (dt2::I.Type I.VectorB I.F) = I.dcast FLC dt1+ in I.SiToFp (I.T t2 u1) dt2 + A.PtrToInt -> let (t2::I.Type I.VectorB I.P) = I.dcast FLC t1+ (dt2::I.Type I.VectorB I.I) = I.dcast FLC dt1+ in I.PtrToInt (I.T t2 u1) dt2 + A.IntToPtr -> let (t2::I.Type I.VectorB I.I) = I.dcast FLC t1+ (dt2::I.Type I.VectorB I.P) = I.dcast FLC dt1+ in I.IntToPtr (I.T t2 u1) dt2 + A.Bitcast -> let (t2::I.Dtype) = I.dcast FLC t1+ (dt2::I.Dtype) = I.dcast FLC dt1+ in I.Bitcast (I.T t2 u1) dt2 + A.AddrSpaceCast -> let (t2::I.Type I.VectorB I.P) = I.dcast FLC t1+ (dt2::I.Type I.VectorB I.P) = I.dcast FLC dt1+ in I.AddrSpaceCast (I.T t2 u1) dt2 + ; return newOp+ }+++convert_to_GetElementPtr :: (u -> MM v) -> A.GetElementPtr u -> (MM (I.GetElementPtr I.ScalarB v))+convert_to_GetElementPtr cvt (A.GetElementPtr b (A.Pointer (A.Typed t u)) us) = + do { mp <- typeDefs+ ; ua <- cvt u+ ; let (ta::I.Type I.ScalarB I.P) = I.dcast FLC ((tconvert mp t)::I.Utype)+ ; usa <- mapM convert_Tv_Tint us+ ; return $ I.GetElementPtr b (I.T ta ua) usa+ }+ where+ convert_Tv_Tint (A.Typed t v) = do { mp <- typeDefs+ ; va <- cvt v+ ; let (ta::I.Type I.ScalarB I.I) = I.dcast FLC ((tconvert mp t)::I.Utype)+ ; return $ I.T ta va+ }+++convert_to_GetElementPtr_V :: (u -> MM v) -> A.GetElementPtr u -> (MM (I.GetElementPtr I.VectorB v))+convert_to_GetElementPtr_V cvt (A.GetElementPtr b (A.Pointer (A.Typed t u)) us) = + do { mp <- typeDefs+ ; ua <- cvt u+ ; let (ta::I.Type I.VectorB I.P) = I.dcast FLC ((tconvert mp t)::I.Utype)+ ; usa <- mapM (convert_Tv_Tint) us+ ; return $ I.GetElementPtr b (I.T ta ua) usa+ }+ where+ convert_Tv_Tint (A.Typed te v) = do { mp <- typeDefs+ ; va <- cvt v+ ; let (ta::I.Utype) = tconvert mp te+ ; return $ I.T (I.dcast FLC ta) va+ }+++cast_to_EitherScalarOrVectorI :: I.FileLoc -> I.T I.Utype v -> + Either (I.T (I.Type I.ScalarB I.I) v) (I.T (I.Type I.VectorB I.I) v)+cast_to_EitherScalarOrVectorI flc (I.T t v) = case t of+ I.UtypeScalarI e -> Left $ I.T e v+ I.UtypeVectorI e -> Right $ I.T e v+ _ -> error "$$$$"+ + +convert_to_Select_I :: (u -> MM v) -> A.Select u -> (MM (I.Select I.ScalarB I.I v))+convert_to_Select_I cvt (A.Select (A.Typed t1 u1) (A.Typed t2 u2) (A.Typed t3 u3)) = + do { mp <- typeDefs+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; u3a <- cvt u3+ ; let (t1a::I.Type I.ScalarB I.I) = I.dcast FLC ((tconvert mp t1)::I.Utype)+ (t2a::I.Type I.ScalarB I.I) = I.dcast FLC ((tconvert mp t2)::I.Utype)+ (t3a::I.Type I.ScalarB I.I) = I.dcast FLC ((tconvert mp t3)::I.Utype)+ ; return $ I.Select (Left (I.T t1a u1a)) (I.T t2a u2a) (I.T t3a u3a)+ }++convert_to_Select_VI :: (u -> MM v) -> A.Select u -> (MM (I.Select I.VectorB I.I v))+convert_to_Select_VI cvt (A.Select (A.Typed t1 u1) (A.Typed t2 u2) (A.Typed t3 u3)) = + do { mp <- typeDefs+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; u3a <- cvt u3+ ; let t1a = cast_to_EitherScalarOrVectorI FLC (I.T ((tconvert mp t1)::I.Utype) u1a)+ (t2a::I.Type I.VectorB I.I) = I.dcast FLC ((tconvert mp t2)::I.Utype)+ (t3a::I.Type I.VectorB I.I) = I.dcast FLC ((tconvert mp t3)::I.Utype)+ ; return $ I.Select t1a (I.T t2a u2a) (I.T t3a u3a)+ }++convert_to_Select_F :: (u -> MM v) -> A.Select u -> (MM (I.Select I.ScalarB I.F v))+convert_to_Select_F cvt (A.Select (A.Typed t1 u1) (A.Typed t2 u2) (A.Typed t3 u3)) = + do { mp <- typeDefs+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; u3a <- cvt u3+ ; let (t1a::I.Type I.ScalarB I.I) = I.dcast FLC ((tconvert mp t1)::I.Utype)+ (t2a::I.Type I.ScalarB I.F) = I.dcast FLC ((tconvert mp t2)::I.Utype)+ (t3a::I.Type I.ScalarB I.F) = I.dcast FLC ((tconvert mp t3)::I.Utype)+ ; return $ I.Select (Left (I.T t1a u1a)) (I.T t2a u2a) (I.T t3a u3a)+ }++convert_to_Select_VF :: (u -> MM v) -> A.Select u -> (MM (I.Select I.VectorB I.F v))+convert_to_Select_VF cvt (A.Select (A.Typed t1 u1) (A.Typed t2 u2) (A.Typed t3 u3)) = + do { mp <- typeDefs+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; u3a <- cvt u3+ ; let t1a = cast_to_EitherScalarOrVectorI FLC (I.T ((tconvert mp t1)::I.Utype) u1a)+ (t2a::I.Type I.VectorB I.F) = I.dcast FLC ((tconvert mp t2)::I.Utype)+ (t3a::I.Type I.VectorB I.F) = I.dcast FLC ((tconvert mp t3)::I.Utype)+ ; return $ I.Select t1a (I.T t2a u2a) (I.T t3a u3a)+ }++convert_to_Select_P :: (u -> MM v) -> A.Select u -> (MM (I.Select I.ScalarB I.P v))+convert_to_Select_P cvt (A.Select (A.Typed t1 u1) (A.Typed t2 u2) (A.Typed t3 u3)) = + do { mp <- typeDefs+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; u3a <- cvt u3+ ; let (t1a::I.Type I.ScalarB I.I) = I.dcast FLC ((tconvert mp t1)::I.Utype)+ (t2a::I.Type I.ScalarB I.P) = I.dcast FLC ((tconvert mp t2)::I.Utype)+ (t3a::I.Type I.ScalarB I.P) = I.dcast FLC ((tconvert mp t3)::I.Utype)+ ; return $ I.Select (Left (I.T t1a u1a)) (I.T t2a u2a) (I.T t3a u3a)+ }+++convert_to_Select_VP :: (u -> MM v) -> A.Select u -> (MM (I.Select I.VectorB I.P v))+convert_to_Select_VP cvt (A.Select (A.Typed t1 u1) (A.Typed t2 u2) (A.Typed t3 u3)) = + do { mp <- typeDefs+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; u3a <- cvt u3+ ; let t1a = cast_to_EitherScalarOrVectorI FLC (I.T ((tconvert mp t1)::I.Utype) u1a)+ (t2a::I.Type I.VectorB I.P) = I.dcast FLC ((tconvert mp t2)::I.Utype)+ (t3a::I.Type I.VectorB I.P) = I.dcast FLC ((tconvert mp t3)::I.Utype)+ ; return $ I.Select t1a (I.T t2a u2a) (I.T t3a u3a)+ }+++convert_to_Select_Record :: (u -> MM v) -> A.Select u -> (MM (I.Select I.FirstClassB I.D v))+convert_to_Select_Record cvt (A.Select (A.Typed t1 u1) (A.Typed t2 u2) (A.Typed t3 u3)) = + do { mp <- typeDefs+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; u3a <- cvt u3+ ; let (t1a::I.Type I.ScalarB I.I) = I.dcast FLC ((tconvert mp t1)::I.Utype)+ (t2a::I.Type I.FirstClassB I.D) = I.squeeze FLC (I.dcast FLC ((tconvert mp t2)::I.Utype))+ (t3a::I.Type I.FirstClassB I.D) = I.squeeze FLC (I.dcast FLC ((tconvert mp t3)::I.Utype))+ ; return $ I.Select (Left (I.T t1a u1a)) (I.T t2a u2a) (I.T t3a u3a)+ }+++convert_to_Icmp :: (u -> MM v) -> A.Icmp u -> MM (I.Icmp I.ScalarB v)+convert_to_Icmp cvt (A.Icmp op t u1 u2) = + do { mp <- typeDefs+ ; let (t1::I.IntOrPtrType I.ScalarB) = I.dcast FLC ((tconvert mp t)::I.Utype)+ ; u1a <- cvt u1 + ; u2a <- cvt u2+ ; return (I.Icmp op t1 u1a u2a)+ }++convert_to_Icmp_V :: (u -> MM v) -> A.Icmp u -> MM (I.Icmp I.VectorB v)+convert_to_Icmp_V cvt (A.Icmp op t u1 u2) = + do { mp <- typeDefs+ ; let (t1::I.IntOrPtrType I.VectorB) = I.dcast FLC ((tconvert mp t)::I.Utype)+ ; u1a <- cvt u1 + ; u2a <- cvt u2+ ; return (I.Icmp op t1 u1a u2a)+ }++convert_to_Fcmp :: (u -> MM v) -> A.Fcmp u -> MM (I.Fcmp I.ScalarB v)+convert_to_Fcmp cvt (A.Fcmp op t u1 u2) = + do { mp <- typeDefs+ ; let (t1::I.Type I.ScalarB I.F) = I.dcast FLC ((tconvert mp t)::I.Utype)+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; return (I.Fcmp op t1 u1a u2a)+ }++convert_to_Fcmp_V :: (u -> MM v) -> A.Fcmp u -> MM (I.Fcmp I.VectorB v)+convert_to_Fcmp_V cvt (A.Fcmp op t u1 u2) = + do { mp <- typeDefs+ ; let (t1::I.Type I.VectorB I.F) = I.dcast FLC ((tconvert mp t)::I.Utype)+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; return (I.Fcmp op t1 u1a u2a)+ }++convert_to_ShuffleVector_I :: (u -> MM v) -> A.ShuffleVector u -> MM (I.ShuffleVector I.I v)+convert_to_ShuffleVector_I cvt (A.ShuffleVector (A.Typed t1 u1) (A.Typed t2 u2) (A.Typed t3 u3)) =+ do { mp <- typeDefs+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; u3a <- cvt u3+ ; let (t1a::I.Type I.VectorB I.I) = I.dcast FLC ((tconvert mp t1)::I.Utype)+ (t2a::I.Type I.VectorB I.I) = I.dcast FLC ((tconvert mp t2)::I.Utype)+ (t3a::I.Type I.VectorB I.I) = I.dcast FLC ((tconvert mp t3)::I.Utype)+ ; return (I.ShuffleVector (I.T t1a u1a) (I.T t2a u2a) (I.T t3a u3a))+ }++convert_to_ShuffleVector_F :: (u -> MM v) -> A.ShuffleVector u -> MM (I.ShuffleVector I.F v)+convert_to_ShuffleVector_F cvt (A.ShuffleVector (A.Typed t1 u1) (A.Typed t2 u2) (A.Typed t3 u3)) =+ do { mp <- typeDefs+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; u3a <- cvt u3+ ; let (t1a::I.Type I.VectorB I.F) = I.dcast FLC ((tconvert mp t1)::I.Utype)+ (t2a::I.Type I.VectorB I.F) = I.dcast FLC ((tconvert mp t2)::I.Utype)+ (t3a::I.Type I.VectorB I.I) = I.dcast FLC ((tconvert mp t3)::I.Utype)+ ; return (I.ShuffleVector (I.T t1a u1a) (I.T t2a u2a) (I.T t3a u3a))+ }++convert_to_ShuffleVector_P :: (u -> MM v) -> A.ShuffleVector u -> MM (I.ShuffleVector I.P v)+convert_to_ShuffleVector_P cvt (A.ShuffleVector (A.Typed t1 u1) (A.Typed t2 u2) (A.Typed t3 u3)) =+ do { mp <- typeDefs+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; u3a <- cvt u3+ ; let (t1a::I.Type I.VectorB I.P) = I.dcast FLC ((tconvert mp t1)::I.Utype)+ (t2a::I.Type I.VectorB I.P) = I.dcast FLC ((tconvert mp t2)::I.Utype)+ (t3a::I.Type I.VectorB I.I) = I.dcast FLC ((tconvert mp t3)::I.Utype)+ ; return (I.ShuffleVector (I.T t1a u1a) (I.T t2a u2a) (I.T t3a u3a))+ }++convert_to_ExtractValue :: (u -> MM v) -> A.ExtractValue u -> MM (I.ExtractValue v)+convert_to_ExtractValue cvt (A.ExtractValue (A.Typed t u) s) = + do { mp <- typeDefs+ ; let (ta::I.Type I.RecordB I.D) = I.dcast FLC ((tconvert mp t)::I.Utype)+ ; ua <- cvt u + ; return (I.ExtractValue (I.T ta ua) s)+ }++convert_to_InsertValue :: (u -> MM v) -> A.InsertValue u -> MM (I.InsertValue v)+convert_to_InsertValue cvt (A.InsertValue (A.Typed t1 u1) (A.Typed t2 u2) s) = + do { mp <- typeDefs+ ; let (t1a::I.Type I.RecordB I.D) = I.dcast FLC ((tconvert mp t1)::I.Utype)+ (t2a::I.Dtype) = I.dcast FLC ((tconvert mp t2)::I.Utype)+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; return $ I.InsertValue (I.T t1a u1a) (I.T t2a u2a) s+ }++convert_to_ExtractElement_I :: (u -> MM v) -> A.ExtractElement u -> MM (I.ExtractElement I.I v)+convert_to_ExtractElement_I cvt (A.ExtractElement (A.Typed t1 u1) (A.Typed t2 u2)) = + do { mp <- typeDefs+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; let (t1a::I.Type I.VectorB I.I) = I.dcast FLC $ ((tconvert mp t1)::I.Utype)+ (t2a::I.Type I.ScalarB I.I) = I.dcast FLC $ ((tconvert mp t2)::I.Utype)+ ; return $ I.ExtractElement (I.T t1a u1a) (I.T t2a u2a)+ }++convert_to_ExtractElement_F :: (u -> MM v) -> A.ExtractElement u -> MM (I.ExtractElement I.F v)+convert_to_ExtractElement_F cvt (A.ExtractElement (A.Typed t1 u1) (A.Typed t2 u2)) = + do { mp <- typeDefs+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; let (t1a::I.Type I.VectorB I.F) = I.dcast FLC $ ((tconvert mp t1)::I.Utype)+ (t2a::I.Type I.ScalarB I.I) = I.dcast FLC $ ((tconvert mp t2)::I.Utype)+ ; return $ I.ExtractElement (I.T t1a u1a) (I.T t2a u2a)+ }++convert_to_ExtractElement_P :: (u -> MM v) -> A.ExtractElement u -> MM (I.ExtractElement I.P v)+convert_to_ExtractElement_P cvt (A.ExtractElement (A.Typed t1 u1) (A.Typed t2 u2)) = + do { mp <- typeDefs+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; let (t1a::I.Type I.VectorB I.P) = I.dcast FLC $ ((tconvert mp t1)::I.Utype)+ (t2a::I.Type I.ScalarB I.I) = I.dcast FLC $ ((tconvert mp t2)::I.Utype)+ ; return $ I.ExtractElement (I.T t1a u1a) (I.T t2a u2a)+ }++convert_to_InsertElement_I :: (u -> MM v) -> A.InsertElement u -> MM (I.InsertElement I.I v)+convert_to_InsertElement_I cvt (A.InsertElement (A.Typed t1 u1) (A.Typed t2 u2) (A.Typed t3 u3)) = + do { mp <- typeDefs+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; u3a <- cvt u3+ ; let (t1a::I.Type I.VectorB I.I) = I.dcast FLC $ ((tconvert mp t1)::I.Utype)+ (t2a::I.Type I.ScalarB I.I) = I.dcast FLC $ ((tconvert mp t2)::I.Utype)+ (t3a::I.Type I.ScalarB I.I) = I.dcast FLC $ ((tconvert mp t3)::I.Utype)+ ; return $ I.InsertElement (I.T t1a u1a) (I.T t2a u2a) (I.T t3a u3a)+ }++convert_to_InsertElement_F :: (u -> MM v) -> A.InsertElement u -> MM (I.InsertElement I.F v)+convert_to_InsertElement_F cvt (A.InsertElement (A.Typed t1 u1) (A.Typed t2 u2) (A.Typed t3 u3)) = + do { mp <- typeDefs+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; u3a <- cvt u3+ ; let (t1a::I.Type I.VectorB I.F) = I.dcast FLC $ ((tconvert mp t1)::I.Utype)+ (t2a::I.Type I.ScalarB I.F) = I.dcast FLC $ ((tconvert mp t2)::I.Utype)+ (t3a::I.Type I.ScalarB I.I) = I.dcast FLC $ ((tconvert mp t3)::I.Utype)+ ; return $ I.InsertElement (I.T t1a u1a) (I.T t2a u2a) (I.T t3a u3a)+ }++convert_to_InsertElement_P :: (u -> MM v) -> A.InsertElement u -> MM (I.InsertElement I.P v)+convert_to_InsertElement_P cvt (A.InsertElement (A.Typed t1 u1) (A.Typed t2 u2) (A.Typed t3 u3)) = + do { mp <- typeDefs+ ; u1a <- cvt u1+ ; u2a <- cvt u2+ ; u3a <- cvt u3+ ; let (t1a::I.Type I.VectorB I.P) = I.dcast FLC $ ((tconvert mp t1)::I.Utype)+ (t2a::I.Type I.ScalarB I.P) = I.dcast FLC $ ((tconvert mp t2)::I.Utype)+ (t3a::I.Type I.ScalarB I.I) = I.dcast FLC $ ((tconvert mp t3)::I.Utype)+ ; return $ I.InsertElement (I.T t1a u1a) (I.T t2a u2a) (I.T t3a u3a)+ }+++convert_SimpleConst :: A.SimpleConstant -> I.Const+convert_SimpleConst x = case x of+ A.CpInt s -> I.C_int s+ A.CpUhexInt s -> I.C_uhex_int s+ A.CpShexInt s -> I.C_shex_int s+ A.CpFloat s -> I.C_float s+ A.CpNull -> I.C_null+ A.CpUndef -> I.C_undef+ A.CpTrue -> I.C_true+ A.CpFalse -> I.C_false+ A.CpZeroInitializer -> I.C_zeroinitializer+ A.CpGlobalAddr s -> I.C_globalAddr s+ A.CpStr s -> I.C_str s+ A.CpBconst s -> convert_Bconst s+ +convert_Bconst :: A.BinaryConstant -> I.Const +convert_Bconst x = case x of+ A.BconstUint8 s -> I.C_u8 s+ A.BconstUint16 s -> I.C_u16 s+ A.BconstUint32 s -> I.C_u32 s+ A.BconstUint64 s -> I.C_u64 s+ A.BconstUint96 s -> I.C_u96 s+ A.BconstUint128 s -> I.C_u128 s+ A.BconstInt8 s -> I.C_s8 s+ A.BconstInt16 s -> I.C_s16 s+ A.BconstInt32 s -> I.C_s32 s+ A.BconstInt64 s -> I.C_s64 s+ A.BconstInt96 s -> I.C_s96 s+ A.BconstInt128 s -> I.C_s128 s++convert_Const :: A.Const -> MM I.Const+convert_Const x = + let cvt = convert_Const+ in case x of+ A.C_simple a -> return $ convert_SimpleConst a+ A.C_complex a -> convert_ComplexConstant a+ A.C_localId a -> return $ I.C_localId a+ A.C_labelId a -> Md.liftM I.C_labelId (convert_LabelId a)+ A.C_blockAddress g a -> do { a' <- convert_PercentLabel a+ ; return $ I.C_block g a'+ }+ A.C_binexp (A.Ie a@(A.IbinExpr _ _ t _ _)) -> + do { mp <- typeDefs+ ; if isTvector mp t then+ do { x <- convert_to_Binexp_V cvt a + ; let y = case x of+ Add n ta v1a v2a -> I.C_add_V n ta v1a v2a+ Sub n ta v1a v2a -> I.C_sub_V n ta v1a v2a+ Mul n ta v1a v2a -> I.C_mul_V n ta v1a v2a+ Udiv n ta v1a v2a -> I.C_udiv_V n ta v1a v2a+ Sdiv n ta v1a v2a -> I.C_sdiv_V n ta v1a v2a+ Urem ta v1a v2a -> I.C_urem_V ta v1a v2a+ Srem ta v1a v2a -> I.C_srem_V ta v1a v2a+ Shl n ta v1a v2a -> I.C_shl_V n ta v1a v2a+ Lshr n ta v1a v2a -> I.C_lshr_V n ta v1a v2a+ Ashr n ta v1a v2a -> I.C_ashr_V n ta v1a v2a+ And ta v1a v2a -> I.C_and_V ta v1a v2a+ Or ta v1a v2a -> I.C_or_V ta v1a v2a+ Xor ta v1a v2a -> I.C_xor_V ta v1a v2a+ ; return y + }+ else+ do { x <- convert_to_Binexp cvt a + ; let y = case x of+ Add n ta v1a v2a -> I.C_add n ta v1a v2a+ Sub n ta v1a v2a -> I.C_sub n ta v1a v2a+ Mul n ta v1a v2a -> I.C_mul n ta v1a v2a+ Udiv n ta v1a v2a -> I.C_udiv n ta v1a v2a+ Sdiv n ta v1a v2a -> I.C_sdiv n ta v1a v2a+ Urem ta v1a v2a -> I.C_urem ta v1a v2a+ Srem ta v1a v2a -> I.C_srem ta v1a v2a+ Shl n ta v1a v2a -> I.C_shl n ta v1a v2a+ Lshr n ta v1a v2a -> I.C_lshr n ta v1a v2a+ Ashr n ta v1a v2a -> I.C_ashr n ta v1a v2a+ And ta v1a v2a -> I.C_and ta v1a v2a+ Or ta v1a v2a -> I.C_or ta v1a v2a+ Xor ta v1a v2a -> I.C_xor ta v1a v2a+ ; return y + }+ }+ A.C_binexp (A.Fe a@(A.FbinExpr _ _ t _ _)) -> + do { mp <- typeDefs+ ; if isTvector mp t then+ do { x <- convert_to_FBinexp_V cvt a+ ; let y = case x of+ Fadd n ta v1a v2a -> I.C_fadd_V n ta v1a v2a+ Fsub n ta v1a v2a -> I.C_fsub_V n ta v1a v2a+ Fmul n ta v1a v2a -> I.C_fmul_V n ta v1a v2a+ Fdiv n ta v1a v2a -> I.C_fdiv_V n ta v1a v2a+ Frem n ta v1a v2a -> I.C_frem_V n ta v1a v2a+ ; return y + }+ else+ do { x <- convert_to_FBinexp cvt a+ ; let y = case x of+ Fadd n ta v1a v2a -> I.C_fadd n ta v1a v2a+ Fsub n ta v1a v2a -> I.C_fsub n ta v1a v2a+ Fmul n ta v1a v2a -> I.C_fmul n ta v1a v2a+ Fdiv n ta v1a v2a -> I.C_fdiv n ta v1a v2a+ Frem n ta v1a v2a -> I.C_frem n ta v1a v2a+ ; return y + }+ }+ A.C_conv a ->+ do { mp <- typeDefs+ ; if conversionIsTvector mp a then+ do { x <- convert_to_Conversion_V cvt a+ ; let y = case x of+ I.Trunc tv dt -> I.C_trunc_V tv dt+ I.Zext tv dt -> I.C_zext_V tv dt+ I.Sext tv dt -> I.C_sext_V tv dt+ I.FpTrunc tv dt -> I.C_fptrunc_V tv dt+ I.FpExt tv dt -> I.C_fpext_V tv dt+ I.FpToUi tv dt -> I.C_fptoui_V tv dt+ I.FpToSi tv dt -> I.C_fptosi_V tv dt+ I.UiToFp tv dt -> I.C_uitofp_V tv dt+ I.SiToFp tv dt -> I.C_sitofp_V tv dt+ I.PtrToInt tv dt -> I.C_ptrtoint_V tv dt+ I.IntToPtr tv dt -> I.C_inttoptr_V tv dt+ I.Bitcast tv dt -> I.C_bitcast tv dt+ I.AddrSpaceCast tv dt -> I.C_addrspacecast_V tv dt + ; return y+ }+ else+ do { x <- convert_to_Conversion cvt a+ ; let y = case x of+ I.Trunc tv dt -> I.C_trunc tv dt+ I.Zext tv dt -> I.C_zext tv dt+ I.Sext tv dt -> I.C_sext tv dt+ I.FpTrunc tv dt -> I.C_fptrunc tv dt+ I.FpExt tv dt -> I.C_fpext tv dt+ I.FpToUi tv dt -> I.C_fptoui tv dt+ I.FpToSi tv dt -> I.C_fptosi tv dt+ I.UiToFp tv dt -> I.C_uitofp tv dt+ I.SiToFp tv dt -> I.C_sitofp tv dt+ I.PtrToInt tv dt -> I.C_ptrtoint tv dt+ I.IntToPtr tv dt -> I.C_inttoptr tv dt+ I.Bitcast tv dt -> I.C_bitcast tv dt+ I.AddrSpaceCast tv dt -> I.C_addrspacecast tv dt + ; return y+ }+ }+ A.C_gep a -> + do { mp <- typeDefs+ ; if getElemPtrIsTvector mp a then + do { (I.GetElementPtr b t idx) <- convert_to_GetElementPtr_V convert_Const a+ ; return $ I.C_getelementptr_V b t idx+ }+ else + do { (I.GetElementPtr b t idx) <- convert_to_GetElementPtr convert_Const a+ ; return $ I.C_getelementptr b t idx+ }+ }+ A.C_select a@(A.Select _ (A.Typed t _) _) -> + do { mp <- typeDefs+ ; case matchType mp t of+ Tk_VectorI -> Md.liftM I.C_select_VI (convert_to_Select_VI cvt a)+ Tk_ScalarI -> Md.liftM I.C_select_I (convert_to_Select_I cvt a)+ Tk_VectorF -> Md.liftM I.C_select_VF (convert_to_Select_VF cvt a)+ Tk_ScalarF -> Md.liftM I.C_select_F (convert_to_Select_F cvt a)+ Tk_VectorP -> Md.liftM I.C_select_VP (convert_to_Select_VP cvt a)+ Tk_ScalarP -> Md.liftM I.C_select_P (convert_to_Select_P cvt a)+ Tk_RecordD -> do { (I.Select (Left cnd) t f) <- convert_to_Select_Record cvt a + ; return $ I.C_select_First cnd t f+ }+ }+ A.C_icmp a@(A.Icmp _ t _ _) -> + do { mp <- typeDefs+ ; if isTvector mp t then Md.liftM I.C_icmp_V (convert_to_Icmp_V cvt a)+ else Md.liftM I.C_icmp (convert_to_Icmp cvt a)+ }+ A.C_fcmp a@(A.Fcmp _ t _ _) -> + do { mp <- typeDefs+ ; if isTvector mp t then Md.liftM I.C_fcmp_V (convert_to_Fcmp_V cvt a)+ else Md.liftM I.C_fcmp (convert_to_Fcmp cvt a)+ }+ A.C_shufflevector a@(A.ShuffleVector (A.Typed t _) _ _) -> + do { mp <- typeDefs+ ; case matchType mp t of+ Tk_VectorI -> Md.liftM I.C_shufflevector_I (convert_to_ShuffleVector_I cvt a)+ Tk_VectorF -> Md.liftM I.C_shufflevector_F (convert_to_ShuffleVector_F cvt a)+ Tk_VectorP -> Md.liftM I.C_shufflevector_P (convert_to_ShuffleVector_P cvt a)+ }+ A.C_extractvalue a -> Md.liftM I.C_extractvalue (convert_to_ExtractValue cvt a)+ A.C_insertvalue a -> Md.liftM I.C_insertvalue (convert_to_InsertValue cvt a)+ A.C_extractelement a@(A.ExtractElement (A.Typed t _) _) -> + do { mp <- typeDefs+ ; case matchType mp t of+ Tk_VectorI -> Md.liftM I.C_extractelement_I (convert_to_ExtractElement_I cvt a)+ Tk_VectorF -> Md.liftM I.C_extractelement_F (convert_to_ExtractElement_F cvt a)+ Tk_VectorP -> Md.liftM I.C_extractelement_P (convert_to_ExtractElement_P cvt a)+ }+ A.C_insertelement a@(A.InsertElement (A.Typed t _) _ _) -> + do { mp <- typeDefs+ ; case matchType mp t of+ Tk_VectorI -> Md.liftM I.C_insertelement_I (convert_to_InsertElement_I cvt a)+ Tk_VectorF -> Md.liftM I.C_insertelement_F (convert_to_InsertElement_F cvt a)+ Tk_VectorP -> Md.liftM I.C_insertelement_P (convert_to_InsertElement_P cvt a)+ }+ +convert_MdVar :: A.MdVar -> (MM I.MdVar)+convert_MdVar (A.MdVar s) = return $ I.MdVar s++convert_MdNode :: A.MdNode -> (MM I.MdNode)+convert_MdNode (A.MdNode s) = return $ I.MdNode s++convert_MetaConst :: A.MetaConst -> (MM I.MetaConst)+convert_MetaConst (A.McStruct c) = Md.liftM I.McStruct (mapM convert_MetaKindedConst c)+convert_MetaConst (A.McString s) = return $ I.McString s+convert_MetaConst (A.McMn n) = Md.liftM I.McMn (convert_MdNode n)+convert_MetaConst (A.McMv n) = Md.liftM I.McMv (convert_MdVar n)+convert_MetaConst (A.McRef i) = return $ I.McRef i+convert_MetaConst (A.McSimple sc) = Md.liftM I.McSimple (convert_Const sc)++convert_MetaKindedConst :: A.MetaKindedConst -> MM I.MetaKindedConst+convert_MetaKindedConst x = + do { mp <- typeDefs+ ; case x of+ (A.MetaKindedConst mk mc) -> Md.liftM (I.MetaKindedConst (tconvert mp mk)) (convert_MetaConst mc)+ A.UnmetaKindedNull -> return I.UnmetaKindedNull+ }++++convert_FunName :: A.FunName -> (MM I.FunName)+convert_FunName (A.FunNameGlobal g) = return $ I.FunNameGlobal g+convert_FunName (A.FunNameString s) = return $ I.FunNameString s++convert_Value :: A.Value -> (MM I.Value)+convert_Value (A.Val_local a) = return $ I.Val_ssa a+convert_Value (A.Val_const a) = Md.liftM I.Val_const (convert_Const a)++convert_to_CallSite :: A.CallSite -> MM (Bool, I.CallSite)+convert_to_CallSite x = case x of+ (A.CsFun cc pa t fn aps fa) ->+ do { mp <- typeDefs+ ; let ert = A.splitCallReturnType t+ erta = eitherRet mp ert+ ; fna <- convert_FunName fn+ ; apsa <- mapM convert_ActualParam aps+ ; return (fst ert == A.Tvoid, I.CsFun cc pa erta fna apsa fa)+ }+ (A.CsAsm t dia b1 b2 qs1 qs2 as fa) ->+ do { mp <- typeDefs+ ; let ert = A.splitCallReturnType t+ erta = eitherRet mp ert+ ; asa <- mapM convert_ActualParam as+ ; return (fst ert == A.Tvoid, I.CsAsm erta dia b1 b2 qs1 qs2 asa fa)+ }+ (A.CsConversion pa t cv as fa) ->+ do { mp <- typeDefs+ ; let ert = A.splitCallReturnType t+ erta = eitherRet mp ert+ ; asa <- mapM convert_ActualParam as+ ; if isTvector mp t then + do { cva <- convert_to_Conversion_V convert_Const cv+ ; return (fst ert == A.Tvoid, I.CsConversionV pa erta cva asa fa)+ }+ else+ do { cva <- convert_to_Conversion convert_Const cv+ ; return (fst ert == A.Tvoid, I.CsConversion pa erta cva asa fa)+ }+ }+ where eitherRet :: MP -> (A.Type, Maybe (A.Type, A.AddrSpace)) -> I.CallSiteType+ eitherRet mp (rt, ft) = case ft of+ Just (fta,as) -> I.CallSiteFun (I.dcast FLC ((tconvert mp fta)::I.Utype)) (tconvert mp as)+ Nothing -> I.CallSiteRet $ I.dcast FLC ((tconvert mp rt)::I.Utype)++convert_Clause :: A.Clause -> MM I.Clause+convert_Clause x = case x of + (A.Catch (A.Typed t v)) -> do { mp <- typeDefs+ ; let (ti::I.Dtype) = I.dcast FLC ((tconvert mp t)::I.Utype)+ ; vi <- convert_Value v+ ; return $ I.Catch (I.T ti vi)+ }+ (A.Filter tc) -> Md.liftM I.Filter (convert_TypedConstOrNUll tc)+ (A.Cco tc) -> + do { mp <- typeDefs+ ; if conversionIsTvector mp tc then Md.liftM I.CcoV (convert_to_Conversion_V convert_Value tc)+ else Md.liftM I.CcoS (convert_to_Conversion convert_Value tc)+ }+++convert_GlobalOrLocalId :: A.GlobalOrLocalId -> (MM I.GlobalOrLocalId)+convert_GlobalOrLocalId = return++convert_PersFn :: A.PersFn -> MM I.PersFn+convert_PersFn (A.PersFnId s) = return $ I.PersFnId s+convert_PersFn (A.PersFnCast c) = + do { mp <- typeDefs+ ; if conversionIsTvector mp c then Md.liftM I.PersFnCastV (convert_to_Conversion_V convert_GlobalOrLocalId c)+ else Md.liftM I.PersFnCastS (convert_to_Conversion convert_GlobalOrLocalId c)+ }+convert_PersFn (A.PersFnUndef) = return $ I.PersFnUndef+convert_PersFn (A.PersFnNull) = return $ I.PersFnNull+convert_PersFn (A.PersFnConst c) = Md.liftM I.PersFnConst (convert_Const c)+++convert_Expr_CInst :: (Maybe A.LocalId, A.Expr) -> (MM I.CInst)+convert_Expr_CInst (Just lhs, A.EgEp c) = + do { mp <- typeDefs+ ; if getElemPtrIsTvector mp c then + do { (I.GetElementPtr b t idx) <- convert_to_GetElementPtr_V convert_Value c+ ; return $ I.I_getelementptr_V b t idx lhs+ }+ else + do { (I.GetElementPtr b t idx) <- convert_to_GetElementPtr convert_Value c+ ; return $ I.I_getelementptr b t idx lhs+ }+ }+convert_Expr_CInst (Just lhs, A.EiC a@(A.Icmp _ t _ _)) = + do { mp <- typeDefs+ ; if isTvector mp t then + do { (I.Icmp op ta v1a v2a) <- convert_to_Icmp_V convert_Value a+ ; return $ I.I_icmp_V op ta v1a v2a lhs+ }+ else + do { (I.Icmp op ta v1a v2a) <- convert_to_Icmp convert_Value a+ ; return $ I.I_icmp op ta v1a v2a lhs+ }+ }+convert_Expr_CInst (Just lhs, A.EfC a@(A.Fcmp _ t _ _)) = + do { mp <- typeDefs+ ; if isTvector mp t then + do { (I.Fcmp op ta v1a v2a) <- convert_to_Fcmp_V convert_Value a+ ; return $ I.I_fcmp_V op ta v1a v2a lhs+ }+ else + do { (I.Fcmp op ta v1a v2a) <- convert_to_Fcmp convert_Value a+ ; return $ I.I_fcmp op ta v1a v2a lhs+ }+ }+convert_Expr_CInst (Just lhs, A.Eb (A.Ie a@(A.IbinExpr _ _ t _ _))) = + do { mp <- typeDefs+ ; if not $ isTvector mp t then + do { x <- convert_to_Binexp convert_Value a + ; let y = case x of+ Add n ta v1a v2a -> I.I_add n ta v1a v2a lhs+ Sub n ta v1a v2a -> I.I_sub n ta v1a v2a lhs + Mul n ta v1a v2a -> I.I_mul n ta v1a v2a lhs+ Udiv n ta v1a v2a -> I.I_udiv n ta v1a v2a lhs+ Sdiv n ta v1a v2a -> I.I_sdiv n ta v1a v2a lhs+ Urem ta v1a v2a -> I.I_urem ta v1a v2a lhs+ Srem ta v1a v2a -> I.I_srem ta v1a v2a lhs+ Shl n ta v1a v2a -> I.I_shl n ta v1a v2a lhs+ Lshr n ta v1a v2a -> I.I_lshr n ta v1a v2a lhs+ Ashr n ta v1a v2a -> I.I_ashr n ta v1a v2a lhs+ And ta v1a v2a -> I.I_and ta v1a v2a lhs+ Or ta v1a v2a -> I.I_or ta v1a v2a lhs+ Xor ta v1a v2a -> I.I_xor ta v1a v2a lhs+ ; return y + }+ else + do { x <- convert_to_Binexp_V convert_Value a + ; let y = case x of+ Add n ta v1a v2a -> I.I_add_V n ta v1a v2a lhs+ Sub n ta v1a v2a -> I.I_sub_V n ta v1a v2a lhs+ Mul n ta v1a v2a -> I.I_mul_V n ta v1a v2a lhs+ Udiv n ta v1a v2a -> I.I_udiv_V n ta v1a v2a lhs+ Sdiv n ta v1a v2a -> I.I_sdiv_V n ta v1a v2a lhs+ Urem ta v1a v2a -> I.I_urem_V ta v1a v2a lhs+ Srem ta v1a v2a -> I.I_srem_V ta v1a v2a lhs+ Shl n ta v1a v2a -> I.I_shl_V n ta v1a v2a lhs+ Lshr n ta v1a v2a -> I.I_lshr_V n ta v1a v2a lhs+ Ashr n ta v1a v2a -> I.I_ashr_V n ta v1a v2a lhs+ And ta v1a v2a -> I.I_and_V ta v1a v2a lhs+ Or ta v1a v2a -> I.I_or_V ta v1a v2a lhs+ Xor ta v1a v2a -> I.I_xor_V ta v1a v2a lhs+ ; return y + }+ }+convert_Expr_CInst (Just lhs, A.Eb (A.Fe a@(A.FbinExpr _ _ t _ _))) = + do { mp <- typeDefs+ ; if not $ isTvector mp t then + do { x <- convert_to_FBinexp convert_Value a+ ; let y = case x of+ Fadd n ta v1a v2a -> I.I_fadd n ta v1a v2a lhs+ Fsub n ta v1a v2a -> I.I_fsub n ta v1a v2a lhs+ Fmul n ta v1a v2a -> I.I_fmul n ta v1a v2a lhs+ Fdiv n ta v1a v2a -> I.I_fdiv n ta v1a v2a lhs+ Frem n ta v1a v2a -> I.I_frem n ta v1a v2a lhs+ ; return y + }+ else+ do { x <- convert_to_FBinexp_V convert_Value a+ ; let y = case x of+ Fadd n ta v1a v2a -> I.I_fadd_V n ta v1a v2a lhs+ Fsub n ta v1a v2a -> I.I_fsub_V n ta v1a v2a lhs+ Fmul n ta v1a v2a -> I.I_fmul_V n ta v1a v2a lhs+ Fdiv n ta v1a v2a -> I.I_fdiv_V n ta v1a v2a lhs+ Frem n ta v1a v2a -> I.I_frem_V n ta v1a v2a lhs+ ; return y+ }+ }+convert_Expr_CInst (Just lhs, A.Ec a) = + do { mp <- typeDefs+ ; if not $ conversionIsTvector mp a then + do { x <- convert_to_Conversion convert_Value a+ ; let y = case x of+ I.Trunc tv dt -> I.I_trunc tv dt lhs+ I.Zext tv dt -> I.I_zext tv dt lhs+ I.Sext tv dt -> I.I_sext tv dt lhs+ I.FpTrunc tv dt -> I.I_fptrunc tv dt lhs+ I.FpExt tv dt -> I.I_fpext tv dt lhs+ I.FpToUi tv dt -> I.I_fptoui tv dt lhs+ I.FpToSi tv dt -> I.I_fptosi tv dt lhs+ I.UiToFp tv dt -> I.I_uitofp tv dt lhs+ I.SiToFp tv dt -> I.I_sitofp tv dt lhs+ I.PtrToInt tv dt -> I.I_ptrtoint tv dt lhs+ I.IntToPtr tv dt -> I.I_inttoptr tv dt lhs+ I.Bitcast tv@(I.T st v) dt -> case (st, dt) of+ (I.DtypeScalarP sta, I.DtypeScalarP dta) -> I.I_bitcast (I.T sta v) dta lhs+ (_,_) -> I.I_bitcast_D tv dt lhs+ I.AddrSpaceCast tv dt -> I.I_addrspacecast tv dt lhs+ ; return y + }+ else + do { x <- convert_to_Conversion_V convert_Value a+ ; let y = case x of+ I.Trunc tv dt -> I.I_trunc_V tv dt lhs+ I.Zext tv dt -> I.I_zext_V tv dt lhs+ I.Sext tv dt -> I.I_sext_V tv dt lhs+ I.FpTrunc tv dt -> I.I_fptrunc_V tv dt lhs+ I.FpExt tv dt -> I.I_fpext_V tv dt lhs+ I.FpToUi tv dt -> I.I_fptoui_V tv dt lhs+ I.FpToSi tv dt -> I.I_fptosi_V tv dt lhs+ I.UiToFp tv dt -> I.I_uitofp_V tv dt lhs+ I.SiToFp tv dt -> I.I_sitofp_V tv dt lhs+ I.PtrToInt tv dt -> I.I_ptrtoint_V tv dt lhs+ I.IntToPtr tv dt -> I.I_inttoptr_V tv dt lhs+ I.Bitcast tv@(I.T st v) dt -> case (st, dt) of+ (I.DtypeScalarP sta, I.DtypeScalarP dta) -> I.I_bitcast (I.T sta v) dta lhs+ (_,_) -> I.I_bitcast_D tv dt lhs+ I.AddrSpaceCast tv dt -> I.I_addrspacecast_V tv dt lhs+ ; return y+ }+ }+convert_Expr_CInst (Just lhs, A.Es a@(A.Select _ (A.Typed t _) _)) = + do { mp <- typeDefs+ ; case matchType mp t of+ Tk_ScalarI -> do { (I.Select (Left cnd) t f) <- convert_to_Select_I convert_Value a+ ; return $ I.I_select_I cnd t f lhs+ }+ Tk_ScalarF -> do { (I.Select (Left cnd) t f) <- convert_to_Select_F convert_Value a+ ; return $ I.I_select_F cnd t f lhs+ }+ Tk_ScalarP -> do { (I.Select (Left cnd) t f) <- convert_to_Select_P convert_Value a+ ; return $ I.I_select_P cnd t f lhs+ }+ Tk_RecordD -> do { (I.Select (Left cnd) t f) <- convert_to_Select_Record convert_Value a+ ; return $ I.I_select_First cnd t f lhs+ }+ Tk_VectorI -> do { (I.Select cnd t f) <- convert_to_Select_VI convert_Value a+ ; return $ I.I_select_VI cnd t f lhs+ }+ Tk_VectorF -> do { (I.Select cnd t f) <- convert_to_Select_VF convert_Value a+ ; return $ I.I_select_VF cnd t f lhs+ }+ Tk_VectorP -> do { (I.Select cnd t f) <- convert_to_Select_VP convert_Value a+ ; return $ I.I_select_VP cnd t f lhs+ }+ }+++convert_MemOp :: (Maybe A.LocalId, A.MemOp) -> (MM I.CInst)+convert_MemOp (mlhs, c) = case (mlhs, c) of+ (Just lhs, A.Alloca mar t mtv ma) -> + do { mp <- typeDefs+ ; ti <- convert_Type_Dtype FLC t+ ; mtvi <- maybeM (convert_to_TypedValue_SI FLC) mtv+ ; return (I.I_alloca mar ti mtvi ma lhs)+ }+ (Just lhs, A.Load atom (A.Pointer tv) aa nonterm inv nonul) -> + do { tvi <- convert_to_TypedAddrValue FLC tv+ ; return (I.I_load atom tvi aa nonterm inv nonul lhs)+ }+ (Just lhs, A.LoadAtomic at v (A.Pointer tv) aa) -> + do { tvi <- convert_to_TypedAddrValue FLC tv+ ; return (I.I_loadatomic at v tvi aa lhs)+ }+ (Nothing, A.Store atom tv1 (A.Pointer tv2) aa nt) -> + do { tv1a <- convert_to_DtypedValue tv1+ ; tv2a <- convert_to_TypedAddrValue FLC tv2+ ; return $ I.I_store atom tv1a tv2a aa nt+ }+ (Nothing, A.StoreAtomic atom v tv1 (A.Pointer tv2) aa) -> + do { tv1a <- convert_to_DtypedValue tv1+ ; tv2a <- convert_to_TypedAddrValue FLC tv2+ ; return $ I.I_storeatomic atom v tv1a tv2a aa+ }+ (Nothing, A.Fence b fo) -> return $ I.I_fence b fo+ (Just lhs, A.CmpXchg wk b1 (A.Pointer tv1) tv2@(A.Typed t2 _) tv3 b2 mf ff) -> + do { mp <- typeDefs+ ; tv1a <- convert_to_TypedAddrValue FLC tv1+ ; case matchType mp t2 of+ Tk_ScalarI -> do { tv2a <- convert_to_TypedValue_SI FLC tv2+ ; tv3a <- convert_to_TypedValue_SI FLC tv3+ ; return $ I.I_cmpxchg_I wk b1 tv1a tv2a tv3a b2 mf ff lhs+ }+ Tk_ScalarF -> do { tv2a <- convert_to_TypedValue_SF FLC tv2+ ; tv3a <- convert_to_TypedValue_SF FLC tv3+ ; return $ I.I_cmpxchg_F wk b1 tv1a tv2a tv3a b2 mf ff lhs+ }+ Tk_ScalarP -> do { tv2a <- convert_to_TypedValue_SP FLC tv2+ ; tv3a <- convert_to_TypedValue_SP FLC tv3+ ; return $ I.I_cmpxchg_P wk b1 tv1a tv2a tv3a b2 mf ff lhs+ }+ }+ (Just lhs, A.AtomicRmw b1 op (A.Pointer tv1) tv2 b2 mf) -> + do { tv1a <- convert_to_TypedAddrValue FLC tv1+ ; tv2a <- convert_to_TypedValue_SI FLC tv2+ ; return $ I.I_atomicrmw b1 op tv1a tv2a b2 mf lhs+ }+ (_,_) -> error $ "AstIrConversion:irrefutable lhs:" ++ show mlhs ++ " rhs:" ++ show c++convert_to_DtypedValue :: A.Typed A.Value -> MM (I.T I.Dtype I.Value)+convert_to_DtypedValue (A.Typed t v) = do { mp <- typeDefs+ ; let (ti::I.Dtype) = I.dcast FLC ((tconvert mp t)::I.Utype)+ ; vi <- convert_Value v + ; return $ I.T ti vi+ }+ +convert_to_DtypedConst :: A.Typed A.Const -> MM (I.T I.Dtype I.Const)+convert_to_DtypedConst (A.Typed t v) = do { mp <- typeDefs+ ; let (ti::I.Dtype) = I.dcast FLC ((tconvert mp t)::I.Utype)+ ; vi <- convert_Const v + ; return $ I.T ti vi+ }+++convert_to_TypedValue_SI :: I.FileLoc -> A.Typed A.Value -> MM (I.T (I.Type I.ScalarB I.I) I.Value)+convert_to_TypedValue_SI lc (A.Typed t v) = do { mp <- typeDefs+ ; let (ti::I.Type I.ScalarB I.I) = I.dcast lc ((tconvert mp t)::I.Utype)+ ; vi <- convert_Value v+ ; return $ I.T ti vi+ }++convert_to_TypedValue_SF :: I.FileLoc -> A.Typed A.Value -> MM (I.T (I.Type I.ScalarB I.F) I.Value)+convert_to_TypedValue_SF lc (A.Typed t v) = do { mp <- typeDefs+ ; let (ti::I.Type I.ScalarB I.F) = I.dcast lc ((tconvert mp t)::I.Utype)+ ; vi <- convert_Value v+ ; return $ I.T ti vi+ }++convert_to_TypedValue_SP :: I.FileLoc -> A.Typed A.Value -> MM (I.T (I.Type I.ScalarB I.P) I.Value)+convert_to_TypedValue_SP lc (A.Typed t v) = do { mp <- typeDefs+ ; let (ti::I.Type I.ScalarB I.P) = I.dcast lc ((tconvert mp t)::I.Utype)+ ; vi <- convert_Value v+ ; return $ I.T ti vi+ }++convert_to_TypedAddrValue :: I.FileLoc -> A.Typed A.Value -> MM (I.T (I.Type I.ScalarB I.P) I.Value)+convert_to_TypedAddrValue lc (A.Typed t v) = do { mp <- typeDefs+ ; let (ti::I.Type I.ScalarB I.P) = I.dcast lc ((tconvert mp t)::I.Utype)+ ; vi <- convert_Value v+ ; return $ I.T ti vi+ }++convert_Type_Dtype :: I.FileLoc -> A.Type -> MM I.Dtype+convert_Type_Dtype lc t = do { mp <- typeDefs+ ; return $ I.dcast lc ((tconvert mp t)::I.Utype)+ }+++convert_Rhs :: (Maybe A.LocalId, A.Rhs) -> MM I.CInst+convert_Rhs (mlhs, A.RmO c) = convert_MemOp (mlhs, c)+convert_Rhs (mlhs, A.Re e) = convert_Expr_CInst (mlhs, e)+convert_Rhs (lhs, A.Call b cs) = + do { (isvoid,csi) <- convert_to_CallSite cs+ ; case csi of + I.CsFun _ _ _ (I.FunNameGlobal (I.GolG (I.GlobalIdAlphaNum "llvm.dbg.declare"))) paramList _ -> return $ I.I_llvm_dbg_declare paramList+ I.CsFun _ _ _ (I.FunNameGlobal (I.GolG (I.GlobalIdAlphaNum "llvm.dbg.value"))) paramList _ -> return $ I.I_llvm_dbg_value paramList+ I.CsFun Nothing [] _ (I.FunNameGlobal (I.GolG (I.GlobalIdAlphaNum "llvm.va_start"))) + [I.ActualParamData t1 [] Nothing v []] [] | isvoid -> return $ I.I_va_start (I.T (I.dcast FLC t1) v)+ I.CsFun Nothing [] _ (I.FunNameGlobal (I.GolG (I.GlobalIdAlphaNum "llvm.va_end")))+ [I.ActualParamData t1 [] Nothing v []] [] | isvoid -> return $ I.I_va_end (I.T (I.dcast FLC t1) v)+ I.CsFun Nothing [] _ (I.FunNameGlobal (I.GolG (I.GlobalIdAlphaNum nm)))+ [I.ActualParamData t1 [] Nothing v1 [] -- dest+ ,I.ActualParamData t2 [] Nothing v2 [] -- src+ ,I.ActualParamData t3 [] Nothing v3 [] -- len+ ,I.ActualParamData t4 [] Nothing v4 [] -- align+ ,I.ActualParamData t5 [] Nothing v5 [] -- volatile + ] [] | isvoid && (nm == "llvm.memcpy.p0i8.p0i8.i32" || nm == "llvm.memcpy.p0i8.p0i8.i64") + -> let mod = case nm of+ "llvm.memcpy.p0i8.p0i8.i32" -> I.MemLenI32+ "llvm.memcpy.p0i8.p0i8.i64" -> I.MemLenI64 + in return $ I.I_llvm_memcpy mod+ (I.T (I.dcast FLC t1) v1)+ (I.T (I.dcast FLC t2) v2)+ (I.T (I.dcast FLC t3) v3)+ (I.T (I.dcast FLC t4) v4)+ (I.T (I.dcast FLC t5) v5)+ {-+ I.CsFun Nothing [] _ (I.FunNameGlobal (I.GolG (I.GlobalIdAlphaNum "_dts_dbaseOf"))) + [I.ActualParamData t1 [] Nothing v []] [] -> return $ I.I_dbaseOf (I.T (I.dcast FLC t1) v) (fromJust lhs)+ I.CsFun Nothing [] _ (I.FunNameGlobal (I.GolG (I.GlobalIdAlphaNum "_dts_dsizeOf"))) + [I.ActualParamData t1 [] Nothing v []] [] -> return $ I.I_dsizeOf (I.T (I.dcast FLC t1) v) (fromJust lhs)+ I.CsFun Nothing [] _ (I.FunNameGlobal (I.GolG (I.GlobalIdAlphaNum "_dts_inspect_va_start_offset"))) + [] _ -> return $ I.I_inspect_va_start_offset (fromJust lhs)+ I.CsFun Nothing [] _ (I.FunNameGlobal (I.GolG (I.GlobalIdAlphaNum "_dts_inspect_va_start_mbase"))) + [] _ -> return $ I.I_inspect_va_start_mbase (fromJust lhs)+ I.CsFun Nothing [] _ (I.FunNameGlobal (I.GolG (I.GlobalIdAlphaNum "_dts_inspect_va_start_msize"))) + [] _ -> return $ I.I_inspect_va_start_msize (fromJust lhs) + -}+ I.CsFun cc pa cstype fn ap fa -> return $ I.I_call_fun b cc pa cstype fn ap fa lhs+ _ -> return $ I.I_call_other b csi lhs+ }+convert_Rhs (Just lhs, A.RvA (A.VaArg tv t)) = + do { tvi <- convert_to_DtypedValue tv+ ; ti <- convert_Type_Dtype FLC t+ ; return $ I.I_va_arg tvi ti lhs+ }+convert_Rhs (Just lhs, A.RlP (A.LandingPad t1 t2 pf b cs)) = + do { pfi <- convert_PersFn pf+ ; csi <- mapM convert_Clause cs+ ; t1i <- convert_Type_Dtype FLC t1+ ; t2i <- convert_Type_Dtype FLC t2+ ; return $ I.I_landingpad t1i t2i pfi b csi lhs+ }+convert_Rhs (Just lhs, A.ReE a@(A.ExtractElement (A.Typed t1 _) _)) = + do { mp <- typeDefs+ ; case matchType mp t1 of+ Tk_VectorI -> do { (I.ExtractElement vec idx) <- convert_to_ExtractElement_I convert_Value a+ ; return $ I.I_extractelement_I vec idx lhs+ }+ Tk_VectorF -> do { (I.ExtractElement vec idx) <- convert_to_ExtractElement_F convert_Value a+ ; return $ I.I_extractelement_F vec idx lhs+ }+ Tk_VectorP -> do { (I.ExtractElement vec idx) <- convert_to_ExtractElement_P convert_Value a+ ; return $ I.I_extractelement_P vec idx lhs+ }+ }+convert_Rhs (Just lhs, A.RiE a@(A.InsertElement (A.Typed t1 _) _ _)) = + do { mp <- typeDefs+ ; case matchType mp t1 of+ Tk_VectorI -> do { (I.InsertElement vec val idx) <- convert_to_InsertElement_I convert_Value a+ ; return $ I.I_insertelement_I vec val idx lhs+ }+ Tk_VectorF -> do { (I.InsertElement vec val idx) <- convert_to_InsertElement_F convert_Value a+ ; return $ I.I_insertelement_F vec val idx lhs+ }+ Tk_VectorP -> do { (I.InsertElement vec val idx) <- convert_to_InsertElement_P convert_Value a+ ; return $ I.I_insertelement_P vec val idx lhs+ }+ }+convert_Rhs (Just lhs, A.RsV a@(A.ShuffleVector (A.Typed t _) _ _)) = + do { mp <- typeDefs+ ; case matchType mp t of+ Tk_VectorI -> do { (I.ShuffleVector tv1a tv2a tv3a) <- convert_to_ShuffleVector_I convert_Value a+ ; return $ I.I_shufflevector_I tv1a tv2a tv3a lhs+ }+ Tk_VectorF -> do { (I.ShuffleVector tv1a tv2a tv3a) <- convert_to_ShuffleVector_F convert_Value a+ ; return $ I.I_shufflevector_F tv1a tv2a tv3a lhs+ }+ Tk_VectorP -> do { (I.ShuffleVector tv1a tv2a tv3a) <- convert_to_ShuffleVector_P convert_Value a+ ; return $ I.I_shufflevector_P tv1a tv2a tv3a lhs+ }+ }+convert_Rhs (Just lhs, A.ReV a) = + do { (I.ExtractValue blocka idxa) <- convert_to_ExtractValue convert_Value a+ ; return $ I.I_extractvalue blocka idxa lhs+ }+convert_Rhs (Just lhs, A.RiV a) = + do { (I.InsertValue blocka va idxa) <- convert_to_InsertValue convert_Value a+ ; return $ I.I_insertvalue blocka va idxa lhs+ }+convert_Rhs (lhs,rhs) = error $ "AstIrConversion:irrefutable error lhs:" ++ show lhs ++ " rhs:" ++ show rhs+++convert_ActualParam :: A.ActualParam -> MM I.ActualParam+convert_ActualParam x = case x of+ (A.ActualParamData t pa1 ma v pa2) ->+ do { mp <- typeDefs+ ; let (ta::I.Utype) = tconvert mp t+ ; va <- convert_Value v+ ; case ta of+ I.UtypeLabelX lbl -> return $ I.ActualParamLabel lbl pa1 ma va pa2+ _ -> return $ I.ActualParamData (I.dcast FLC ta) pa1 ma va pa2+ }+ (A.ActualParamMeta mc) -> Md.liftM I.ActualParamMeta (convert_MetaKindedConst mc)++convert_Aliasee :: A.Aliasee -> (MM I.Aliasee)+convert_Aliasee (A.AtV (A.Typed t v)) = do { mp <- typeDefs+ ; va <- convert_Value v+ ; let (ta::I.Dtype) = I.dcast FLC ((tconvert mp t)::I.Utype)+ ; return $ I.AtV (I.T ta va)+ }+convert_Aliasee (A.Ac c@(A.Conversion _ _ dt)) = + do { mp <- typeDefs+ ; if isTvector mp dt then Md.liftM I.AcV (convert_to_Conversion_V convert_Const c)+ else Md.liftM I.Ac (convert_to_Conversion convert_Const c)+ }+convert_Aliasee (A.AgEp a) = + do { mp <- typeDefs+ ; if getElemPtrIsTvector mp a then Md.liftM I.AgepV (convert_to_GetElementPtr_V convert_Const a)+ else Md.liftM I.Agep (convert_to_GetElementPtr convert_Const a)+ }++convert_Prefix :: A.Prefix -> (MM I.Prefix)+convert_Prefix (A.Prefix n) = Md.liftM I.Prefix (convert_TypedConstOrNUll n)++convert_Prologue :: A.Prologue -> (MM I.Prologue)+convert_Prologue (A.Prologue n) = Md.liftM I.Prologue (convert_TypedConstOrNUll n)++convert_TypedConstOrNUll :: A.TypedConstOrNull -> MM I.TypedConstOrNull+convert_TypedConstOrNUll x = case x of+ A.TypedConst (A.Typed t v) -> do { mp <- typeDefs+ ; vi <- convert_Const v+ ; let (ti::I.Dtype) = I.dcast FLC ((tconvert mp t)::I.Utype)+ ; return (I.TypedConst (I.T ti vi))+ }+ A.UntypedNull -> return I.UntypedNull++convert_FunctionPrototype :: A.FunctionPrototype -> (MM I.FunctionPrototype)+convert_FunctionPrototype (A.FunctionPrototype f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f10a f11 f12 f13 f14) =+ do { mp <- typeDefs+ ; let (f5a::I.Rtype) = I.dcast FLC ((tconvert mp f5)::I.Utype)+ ; f13a <- maybeM convert_Prefix f13+ ; f14a <- maybeM convert_Prologue f14+ ; return $ I.FunctionPrototype f0 f1 f2 f3 f4 f5a f6 (tconvert mp f7) f8 f9 f10 f10a f11 f12 f13a f14a+ }++convert_PhiInst :: A.PhiInst -> MM I.PhiInst+convert_PhiInst phi@(A.PhiInst mg t branches) = + do { mp <- typeDefs+ ; branchesa <- mapM (pairM convert_Value convert_PercentLabel) branches + ; let (ta::I.Utype) = tconvert mp t+ ; let (tab::I.Ftype) = case ta of + I.UtypeRecordD e -> I.dcast FLC (I.squeeze FLC e)+ _ -> I.dcast FLC ta + ; case mg of + Just lhs -> return $ I.PhiInst lhs tab (fmap (\x -> (fst x, snd x)) branchesa)+ Nothing -> I.errorLoc FLC $ "unused phi" ++ show phi+ }++convert_CInst :: A.ComputingInst -> (MM I.CInst)+convert_CInst (A.ComputingInst mg rhs) = convert_Rhs (mg, rhs) ++convert_TerminatorInst :: A.TerminatorInst -> (MM I.TerminatorInst)+convert_TerminatorInst (A.RetVoid) = return I.RetVoid+convert_TerminatorInst (A.Return tvs) = Md.liftM I.Return (mapM convert_to_DtypedValue tvs)+convert_TerminatorInst (A.Br t) = Md.liftM I.Br (convert_TargetLabel t)+convert_TerminatorInst (A.Cbr cnd t f) = Md.liftM3 I.Cbr (convert_Value cnd) (convert_TargetLabel t) (convert_TargetLabel f)+convert_TerminatorInst (A.IndirectBr cnd bs) = + Md.liftM2 I.IndirectBr (convert_to_TypedAddrValue FLC cnd) (mapM convert_TargetLabel bs)+convert_TerminatorInst (A.Switch cnd d cases) = + Md.liftM3 I.Switch (convert_to_TypedValue_SI FLC cnd) + (convert_TargetLabel d) (mapM (pairM (convert_to_TypedValue_SI FLC) convert_TargetLabel) cases)+convert_TerminatorInst (A.Invoke mg cs t f) = + do { (isvoid, csa) <- convert_to_CallSite cs+ ; ta <- convert_TargetLabel t+ ; fa <- convert_TargetLabel f+ ; if isvoid then return $ I.InvokeCmd csa ta fa+ else return $ I.Invoke csa ta fa mg+ }+convert_TerminatorInst (A.Resume tv) = Md.liftM I.Resume (convert_to_DtypedValue tv)+convert_TerminatorInst A.Unreachable = return I.Unreachable+convert_TerminatorInst A.Unwind = return I.Unwind++convert_Dbg :: A.Dbg -> (MM I.Dbg)+convert_Dbg (A.Dbg mv mc) = Md.liftM2 I.Dbg (convert_MdVar mv) (convert_MetaConst mc)++convert_PhiInstWithDbg :: A.PhiInstWithDbg -> (MM I.PhiInstWithDbg)+convert_PhiInstWithDbg (A.PhiInstWithDbg ins dbgs) = Md.liftM2 I.PhiInstWithDbg (convert_PhiInst ins) (mapM convert_Dbg dbgs)++convert_CInstWithDbg :: A.ComputingInstWithDbg -> (MM I.CInstWithDbg)+convert_CInstWithDbg (A.ComputingInstWithDbg ins dbgs) = Md.liftM2 I.CInstWithDbg (convert_CInst ins) (mapM convert_Dbg dbgs)+ +convert_TerminatorInstWithDbg :: A.TerminatorInstWithDbg -> (MM I.TerminatorInstWithDbg)+convert_TerminatorInstWithDbg (A.TerminatorInstWithDbg term dbgs) = + Md.liftM2 I.TerminatorInstWithDbg (convert_TerminatorInst term) (mapM convert_Dbg dbgs)+++toSingleNodeGraph :: A.Block -> MM (H.Graph (I.Node a) H.C H.C)+-- toSingleNodeGraph b | trace ("toSingleNodeGraph " ++ toLlvm b) False = undefined+toSingleNodeGraph (A.Block f phi ms l) =+ do { f' <- toFirst f+ ; phi' <- mapM toPhi phi+ ; ms' <- mapM toMid ms+ ; l' <- toLast l+ ; return $ H.mkFirst f' H.<*> H.mkMiddles phi' H.<*> H.mkMiddles ms' H.<*> H.mkLast l'+ }++toFirst :: A.BlockLabel -> MM (I.Node a H.C H.O)+toFirst x = Md.liftM I.Nlabel (convert_BlockLabel x)++toPhi :: A.PhiInstWithDbg -> MM (I.Node a H.O H.O)+toPhi phi = Md.liftM I.Pinst (convert_PhiInstWithDbg phi)++toMid :: A.ComputingInstWithDbg -> MM (I.Node a H.O H.O)+toMid inst = Md.liftM I.Cinst (convert_CInstWithDbg inst)++toLast :: A.TerminatorInstWithDbg -> MM (I.Node a H.O H.C)+toLast inst = Md.liftM I.Tinst (convert_TerminatorInstWithDbg inst)++-- | the head must be the entry block+getEntryAndAlist :: [A.Block] -> MM (H.Label, [A.LabelId])+getEntryAndAlist [] = error "Parsed procedures should not be empty"+getEntryAndAlist bs =+ do { l <- convert_BlockLabel $ A.blockLabel $ head bs+ ; let ord = map (\b -> case A.blockLabel b of+ A.ImplicitBlockLabel p -> error $ "irrefutable implicitblock " + ++ show p ++ " should be normalized in AstSimplify" + A.ExplicitBlockLabel x -> x + ) bs+ ; return (l, ord)+ }++toGraph :: [A.Block] -> MM (H.Graph (I.Node a) H.C H.C)+toGraph bs =+ {-+ It's more likely that only reachable blocks are pulled out and used to create+ a graph, the unreachable blocks are left.+ -}+ do { g <- foldl (Md.liftM2 (H.|*><*|)) (return H.emptyClosedGraph) (map toSingleNodeGraph bs)+ ; getBody g+ }++getBody :: forall n. H.Graph n H.C H.C -> MM (H.Graph n H.C H.C)+getBody graph = LabelMapM f+ where f m = return (m, graph)+++blockToGraph :: A.FunctionPrototype -> [A.Block] -> MM (H.Label, H.Graph (I.Node a) H.C H.C)+blockToGraph fn blocks =+ do { (entry, labels) <- getEntryAndAlist blocks+ ; body <- toGraph blocks + ; return (entry, body)+ }+ +convert_TlTriple :: A.TlTriple -> (MM I.TlTriple)+convert_TlTriple (A.TlTriple x) = return (I.TlTriple x)+ +convert_TlDataLayout :: A.TlDataLayout -> (MM I.TlDataLayout)+convert_TlDataLayout (A.TlDataLayout x) = return (I.TlDataLayout x)+++convert_TlAlias :: A.TlAlias -> (MM I.TlAlias)+convert_TlAlias (A.TlAlias g v dll tlm na l a) = convert_Aliasee a >>= return . (I.TlAlias g v dll tlm na l)++convert_TlDbgInit :: A.TlDbgInit -> (MM I.TlDbgInit)+convert_TlDbgInit (A.TlDbgInit s i) = return (I.TlDbgInit s i)+ +convert_TlStandaloneMd :: A.TlStandaloneMd -> (MM I.TlStandaloneMd)+convert_TlStandaloneMd (A.TlStandaloneMd s tv) = convert_MetaKindedConst tv >>= return . (I.TlStandaloneMd s)+ + +convert_TlNamedMd :: A.TlNamedMd -> (MM I.TlNamedMd)+convert_TlNamedMd (A.TlNamedMd m ns) = do { ma <- convert_MdVar m+ ; nsa <- mapM convert_MdNode ns+ ; return $ I.TlNamedMd ma nsa+ }+ +convert_TlDeclare :: A.TlDeclare -> (MM I.TlDeclare)+convert_TlDeclare (A.TlDeclare f) = convert_FunctionPrototype f >>= return . I.TlDeclare+ +convert_TlDefine :: A.TlDefine -> (MM (I.TlDefine a))+convert_TlDefine (A.TlDefine f b) = do { fa <- convert_FunctionPrototype f+ ; (e, g) <- blockToGraph f b+ ; return $ I.TlDefine fa e g+ }++convert_TlGlobal :: A.TlGlobal -> (MM I.TlGlobal)+convert_TlGlobal (A.TlGlobal a1 a2 a3 a4 a5 a6 a7 a8 a8a a9 a10 a11 a12 a13) =+ do { mp <- typeDefs+ ; let (a9a::I.Utype) = tconvert mp a9+ ; a10a <- maybeM convert_Const a10+ ; case a9a of + I.UtypeOpaqueD _ -> return $ I.TlGlobalOpaque a1 a2 a3 a4 a5 a6 (fmap (tconvert mp) a7) + a8 a8a (I.dcast FLC a9a) a10a a11 a12 a13+ _ -> return $ I.TlGlobalDtype a1 a2 a3 a4 a5 a6 (fmap (tconvert mp) a7) + a8 a8a (I.dcast FLC a9a) a10a a11 a12 a13+ }+ +convert_TlTypeDef :: A.TlTypeDef -> (MM I.TlTypeDef)+convert_TlTypeDef (A.TlTypeDef lid t) = + do { mp <- typeDefs+ ; let (ta::I.Utype) = tconvert mp t+ ; case ta of+ I.UtypeFunX _ -> return (I.TlFunTypeDef lid (I.dcast FLC ta))+ I.UtypeOpaqueD _-> return (I.TlOpqTypeDef lid (I.dcast FLC ta))+ _ -> return (I.TlDatTypeDef lid (I.dcast FLC ((tconvert mp t)::I.Utype)))+ }+ +convert_TlDepLibs :: A.TlDepLibs -> (MM I.TlDepLibs)+convert_TlDepLibs (A.TlDepLibs s) = return (I.TlDepLibs s)+ +convert_TlUnamedType :: A.TlUnamedType -> (MM I.TlUnamedType)+convert_TlUnamedType (A.TlUnamedType i t) = do { mp <- typeDefs+ ; let (ta::I.Dtype) = I.dcast FLC ((tconvert mp t)::I.Utype)+ ; return (I.TlUnamedType i ta)+ }+ +convert_TlModuleAsm :: A.TlModuleAsm -> (MM I.TlModuleAsm)+convert_TlModuleAsm (A.TlModuleAsm s) = return (I.TlModuleAsm s)++convert_TlAttribute :: A.TlAttribute -> (MM I.TlAttribute)+convert_TlAttribute (A.TlAttribute n l) = return (I.TlAttribute n l)+ +convert_TlComdat :: A.TlComdat -> (MM I.TlComdat)+convert_TlComdat (A.TlComdat l s) = return (I.TlComdat l s)+ ++toplevel2Ir :: A.Toplevel -> MM (I.Toplevel a)+toplevel2Ir (A.ToplevelTriple q) = Md.liftM I.ToplevelTriple (convert_TlTriple q)+toplevel2Ir (A.ToplevelDataLayout q) = Md.liftM I.ToplevelDataLayout (convert_TlDataLayout q)+toplevel2Ir (A.ToplevelAlias q) = Md.liftM I.ToplevelAlias (convert_TlAlias q)+toplevel2Ir (A.ToplevelDbgInit s) = Md.liftM I.ToplevelDbgInit (convert_TlDbgInit s)+toplevel2Ir (A.ToplevelStandaloneMd s) = Md.liftM I.ToplevelStandaloneMd (convert_TlStandaloneMd s)+toplevel2Ir (A.ToplevelNamedMd m) = Md.liftM I.ToplevelNamedMd (convert_TlNamedMd m)+toplevel2Ir (A.ToplevelDeclare f) = Md.liftM I.ToplevelDeclare (convert_TlDeclare f)+toplevel2Ir (A.ToplevelDefine f) = Md.liftM I.ToplevelDefine (convert_TlDefine f)+toplevel2Ir (A.ToplevelGlobal g) = Md.liftM I.ToplevelGlobal (convert_TlGlobal g)+toplevel2Ir (A.ToplevelTypeDef t) = Md.liftM I.ToplevelTypeDef (convert_TlTypeDef t)+toplevel2Ir (A.ToplevelDepLibs qs) = Md.liftM I.ToplevelDepLibs (convert_TlDepLibs qs)+toplevel2Ir (A.ToplevelUnamedType i) = Md.liftM I.ToplevelUnamedType (convert_TlUnamedType i)+toplevel2Ir (A.ToplevelModuleAsm q) = Md.liftM I.ToplevelModuleAsm (convert_TlModuleAsm q)+toplevel2Ir (A.ToplevelAttribute n) = Md.liftM I.ToplevelAttribute (convert_TlAttribute n)+toplevel2Ir (A.ToplevelComdat l) = Md.liftM I.ToplevelComdat (convert_TlComdat l)++astToIr :: A.Module -> H.SimpleUniqueMonad (IdLabelMap, I.Module a)+astToIr m@(A.Module ts) = let td = M.fromList $ typeDefOfModule m+ in runLabelMapM (emptyIdLabelMap td) $ Md.liftM I.Module (mapM toplevel2Ir ts)
+ src/Llvm/Data/Conversion/AstScanner.hs view
@@ -0,0 +1,14 @@+module Llvm.Data.Conversion.AstScanner where++import Llvm.Data.Ast++typeDefOfModule :: Module -> [(LocalId, Type)]+typeDefOfModule (Module tl) = + let tl0 = filter (\x -> case x of+ ToplevelTypeDef _ -> True+ _ -> False+ ) tl+ in fmap (\(ToplevelTypeDef (TlTypeDef lid ty)) -> (lid,ty)) tl0+ + +
+ src/Llvm/Data/Conversion/AstSimplification.hs view
@@ -0,0 +1,750 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+module Llvm.Data.Conversion.AstSimplification (simplify) where++import Llvm.Data.Ast+import qualified Data.Map as M+import qualified Data.Set as St+import qualified Control.Monad.State as S+import qualified Control.Monad.Reader as R+import Data.Maybe+import Llvm.Util.Monadic (maybeM)+import Debug.Trace+import Data.Word (Word32)++{-+ Assign explicit names to all implicit variables + Assign explicit labels to all implicit labels+-}+data MyState = MyState { _cnt :: Word32 -- Integer+ , _renaming :: String+ , _implicitLabelNums :: St.Set Word32 -- Integer+ , _explicitLabelNums :: St.Set Word32 -- Integer+ , _explicitLabelDqNums :: St.Set Word32 -- Integer + } + +type MS = S.State MyState++data LabelNumbers = LabelNumbers { implicitNumbers :: St.Set Word32 -- Integer+ , explicitNumbers :: St.Set Word32 -- Integer+ , explicitDqNumbers :: St.Set Word32 -- Integer+ } deriving (Eq, Ord, Show)+ +idPrefix :: String+idPrefix = "_hsllvm_implicit_ID"++implicitLbPrefix :: String+implicitLbPrefix = "_hsllvm_implicit_L"++explicitLbPrefix :: String+explicitLbPrefix = "_hsllvm_explicit_L"++------------------------------------------------------------------------+-- iteration 1+------------------------------------------------------------------------+iter1 :: [Toplevel] -> ([Toplevel], M.Map GlobalId LabelNumbers)+iter1 l = let (l1, m1) = unzip $ fmap rnToplevel1 l+ in (l1, foldl M.union M.empty m1)++rnToplevel1 :: Toplevel -> (Toplevel, M.Map GlobalId LabelNumbers)+rnToplevel1 (ToplevelDefine (TlDefine fp bs)) = + let ((fp2, bs2), mys) = S.runState (do { fpa <- rnDefFunctionPrototype fp+ ; bsa <- S.mapM rnBlock bs+ ; return (fpa, bsa)+ }+ ) (MyState 0 (show fp) St.empty St.empty St.empty)+ labelNumbers = LabelNumbers (_implicitLabelNums mys) (_explicitLabelNums mys) (_explicitLabelDqNums mys)+ in ((ToplevelDefine (TlDefine fp2 bs2)), M.insert (getGlobalId fp) labelNumbers M.empty)+rnToplevel1 x = (x, M.empty)+++getGlobalId :: FunctionPrototype -> GlobalId+getGlobalId (FunctionPrototype _ _ _ _ _ _ fhName _ _ _ _ _ _ _ _ _) = fhName ++rnDefFunctionPrototype :: FunctionPrototype -> MS FunctionPrototype+rnDefFunctionPrototype fpt@(FunctionPrototype v0 v1 v2 v3 v4 v5 v6 fhParams v8 v9 v10 v11 v12 v13 fhPrefix fhPrologue) = + do { fp' <- rnDefFormalParamList fhParams+ ; prefix' <- rnPrefix fhPrefix+ ; prologue' <- rnPrologue fhPrologue + ; return $ FunctionPrototype v0 v1 v2 v3 v4 v5 v6 fp' v8 v9 v10 v11 v12 v13 prefix' prologue'+ }+ + + +rnDefFormalParamList :: FormalParamList -> MS FormalParamList +rnDefFormalParamList (FormalParamList fps b fa) = do { fps' <- mapM rnDefFormalParam fps+ ; return $ FormalParamList fps' b fa+ }+ +rnDefFormalParam :: FormalParam -> MS FormalParam+rnDefFormalParam x = case x of+ (FormalParamData t pas1 align pid pas2) -> + do { pid' <- rnDefFparam pid+ ; return $ FormalParamData (normalType t) pas1 align pid' pas2+ }+ (FormalParamMeta e pid) -> + do { pid1 <- rnDefFparam pid+ ; e1 <- rnMetaKind e+ ; return $ FormalParamMeta e1 pid1+ }++rnDefFparam :: Fparam -> MS Fparam +rnDefFparam (FimplicitParam) =+ do { x <- getNext+ ; S.liftM FexplicitParam (rnDefLocalId (LocalIdNum x))+ }+rnDefFparam (FexplicitParam x) = S.liftM FexplicitParam (rnDefLocalId x)+ +rnLabelId :: LabelId -> MS LabelId+rnLabelId x = return x++++getNext :: MS Word32 -- Integer+getNext = do { MyState{..} <- S.get+ ; S.modify (\s@MyState {..} -> s { _cnt = _cnt + 1})+ ; return _cnt+ }++getFp :: MS String+getFp = do { MyState{..} <- S.get+ ; return _renaming+ }++rnDefLabel :: BlockLabel -> MS BlockLabel+rnDefLabel bl = case bl of+ ImplicitBlockLabel _ -> do { i <- getNext+ ; S.modify (\s@MyState{..} -> s { _implicitLabelNums = St.insert i _implicitLabelNums })+ ; ia <- return $ LabelString (implicitLbPrefix ++ show i)+ ; return $ ExplicitBlockLabel ia+ }+ ExplicitBlockLabel i -> S.liftM ExplicitBlockLabel (recordLabelNumber i)+ where + recordLabelNumber :: LabelId -> MS LabelId+ recordLabelNumber (LabelNumber i) = S.modify (\s@MyState {..} -> s { _explicitLabelNums = St.insert i _explicitLabelNums }) >> return (LabelString (explicitLbPrefix ++ show i))+ recordLabelNumber x@(LabelDqNumber i) = S.modify (\s@MyState {..} -> s { _explicitLabelDqNums = St.insert i _explicitLabelDqNums }) >> return x+ recordLabelNumber x = return x++rnBlock :: Block -> MS Block+rnBlock (Block lbl phi comp term) = do { lbl' <- rnDefLabel lbl+ ; phi' <- mapM rnPhiInstWithDbg phi+ ; comp' <- mapM rnComputingInstWithDbg comp+ ; term' <- rnTerminatorInstWithDbg term+ ; return (Block lbl' phi' comp' term')+ }+++rnDefLocalId :: LocalId -> MS LocalId+#ifdef DEBUG+rnDefLocalId l | trace ("rnDefLocalId " ++ (show l)) False = undefined+#endif+rnDefLocalId (LocalIdNum i) = S.liftM (LocalIdAlphaNum) (return (idPrefix ++ show i))+rnDefLocalId x = return x+++rnLocalId :: LocalId -> MS LocalId+rnLocalId (LocalIdNum i) = S.liftM (LocalIdAlphaNum) (return (idPrefix ++ show i))+rnLocalId x = return x +++rnLhs :: LocalId -> MS LocalId+rnLhs localId = checkImpCount localId >> rnDefLocalId localId++rnPhiInstWithDbg :: PhiInstWithDbg -> MS PhiInstWithDbg+rnPhiInstWithDbg (PhiInstWithDbg ins dbgs) = S.liftM (\x -> PhiInstWithDbg x dbgs) (rnPhi ins)++rnPhi :: PhiInst -> MS PhiInst+rnPhi (PhiInst lhs t ins) = do { lhs' <- maybeM rnLhs lhs+ ; lhs'' <- getLhs True lhs'+ ; ins' <- S.mapM g ins+ ; return $ PhiInst lhs'' t ins'+ }+ where g (v, p) = do { v' <- rnValue v+ ; p' <- rnPercentLabel p+ ; return (v', p')+ }+++rnComputingInstWithDbg :: ComputingInstWithDbg -> MS ComputingInstWithDbg+rnComputingInstWithDbg (ComputingInstWithDbg c l) = S.liftM (\x -> ComputingInstWithDbg x l) + (rnComputingInst c)++rnComputingInst :: ComputingInst -> MS ComputingInst+#ifdef DEBUG+rnComputingInst x | trace ("rnComputingInst " ++ show (x)) False = undefined+#endif+rnComputingInst (ComputingInst lhs rhs) = do { lhs' <- maybeM rnLhs lhs+ ; (b, rhs') <- rnRhs rhs+ ; lhs'' <- getLhs b lhs'+ ; return (ComputingInst lhs'' rhs')+ }++getLhs :: Bool -> Maybe LocalId -> MS (Maybe LocalId)+getLhs False x = return x+getLhs True (Just x) = return $ Just x+getLhs True Nothing = do { m <- getNext+ ; m' <- rnLocalId (LocalIdNum m)+ ; return $ Just m'+ }++rnGlobalOrLocalId :: GlobalOrLocalId -> MS GlobalOrLocalId+rnGlobalOrLocalId (GolL l) = S.liftM GolL (rnLocalId l)+rnGlobalOrLocalId x = return x++rnValue :: Value -> MS Value+rnValue (Val_local x) = S.liftM Val_local (rnLocalId x)+rnValue (Val_const x) = S.liftM Val_const (rnConst x)++rnTypedValue :: Typed Value -> MS (Typed Value)+rnTypedValue (Typed t v) = S.liftM (Typed $ normalType t) (rnValue v)++normalType :: Type -> Type+normalType (Tpointer et as) = Tpointer (normalType et) (normAddrSpace as) +normalType (Tstruct pk l) = Tstruct pk (fmap normalType l)+normalType (Tarray n e) = Tarray n (normalType e)+normalType x = x+ +normAddrSpace :: AddrSpace -> AddrSpace +normAddrSpace (AddrSpace 0) = AddrSpaceUnspecified+normAddrSpace x = x++checkImpCount :: LocalId -> MS ()+checkImpCount x@(LocalIdNum i) = + do { m <- getNext+ ; if (i == m) then return ()+ else do { y <- getFp+ ; error ("AstSimplify:expect " ++ (show m) ++ " and but found " ++ (show x) ++ " in " ++ y)+ }+ }+checkImpCount _ = return () + +rnRhs :: Rhs -> MS (Bool, Rhs)+rnRhs lhs = case lhs of+ RmO x -> S.liftM (\(b,x) -> (b, RmO x)) (rnMemOp x)+ Re x -> S.liftM (\x -> (True, Re x)) (rnExpr x)+ Call b cs -> S.liftM (\(bb, x) -> (bb, Call b x)) (rnCallSite cs)+ ReE e -> S.liftM (\x -> (True, ReE x)) (rnExtractElem rnTypedValue e)+ RiE e -> S.liftM (\x -> (True, RiE x)) (rnInsertElem rnTypedValue e)+ RsV e -> S.liftM (\x -> (True, RsV x)) (rnShuffleVector rnTypedValue e)+ ReV e -> S.liftM (\x -> (True, ReV x)) (rnExtractValue rnTypedValue e)+ RiV e -> S.liftM (\x -> (True, RiV x)) (rnInsertValue rnTypedValue e)+ RvA (VaArg tv t) -> S.liftM (\x -> (True, RvA $ VaArg x t)) (rnTypedValue tv)+ RlP (LandingPad rt ft ix cl c) -> return (True, lhs)+ +rnMemOp :: MemOp -> MS (Bool, MemOp)+rnMemOp (Alloca m t tv a) = do { tv' <- maybeM rnTypedValue tv+ ; return (True, Alloca m t tv' a)+ }+rnMemOp (Load a tp ma nt inv nl) = S.liftM (\x -> (True, Load a x ma nt inv nl)) (rnPointer rnTypedValue tp)+rnMemOp (LoadAtomic at a tp ma) = S.liftM (\x -> (True, LoadAtomic at a x ma)) (rnPointer rnTypedValue tp)+rnMemOp (Store a tv tp ma nt) = S.liftM2 (\x y -> (False, Store a x y ma nt))+ (rnTypedValue tv) (rnPointer rnTypedValue tp)+rnMemOp (StoreAtomic at a tv tp ma) = S.liftM2 (\x y -> (False, StoreAtomic at a x y ma))+ (rnTypedValue tv) (rnPointer rnTypedValue tp)+rnMemOp (Fence b f) = return (False, Fence b f)+rnMemOp (CmpXchg wk b1 tp tv1 tv2 b2 mf ff) = + S.liftM3 (\x y z -> (True, CmpXchg wk b1 x y z b2 mf ff))+ (rnPointer rnTypedValue tp)+ (rnTypedValue tv1)+ (rnTypedValue tv2)+rnMemOp (AtomicRmw b1 ao tp tv b2 mf) = + S.liftM2 (\x y -> (True, AtomicRmw b1 ao x y b2 mf))+ (rnPointer rnTypedValue tp)+ (rnTypedValue tv)++rnPointer :: (a -> MS a) -> Pointer a -> MS (Pointer a)+rnPointer f (Pointer v) = S.liftM Pointer (f v) ++rnExpr :: Expr -> MS Expr+rnExpr (EgEp e) = S.liftM EgEp (rnGetElemPtr rnTypedValue e)+rnExpr (EiC e) = S.liftM EiC (rnIcmp rnValue e)+rnExpr (EfC e) = S.liftM EfC (rnFcmp rnValue e)+rnExpr (Eb e) = S.liftM Eb (rnBinExpr rnValue e)+rnExpr (Ec e) = S.liftM Ec (rnConversion rnTypedValue e)+rnExpr (Es e) = S.liftM Es (rnSelect rnTypedValue e)+++rnGetElemPtr :: (Typed v -> MS (Typed v)) -> GetElementPtr v -> MS (GetElementPtr v)+rnGetElemPtr fv (GetElementPtr b v vs) = do { v' <- rnPointer fv v+ ; vs' <- mapM fv vs+ ; return $ GetElementPtr b v' vs'+ }+++rnIcmp :: (a -> MS a) -> Icmp a -> MS (Icmp a)+rnIcmp f (Icmp o t v1 v2) = S.liftM2 (Icmp o t) (f v1) (f v2)++rnFcmp :: (a -> MS a) -> Fcmp a -> MS (Fcmp a)+rnFcmp f (Fcmp o t v1 v2) = S.liftM2 (Fcmp o t) (f v1) (f v2)++rnIbinExpr :: (a -> MS a) -> IbinExpr a -> MS (IbinExpr a)+rnIbinExpr f (IbinExpr o tf t v1 v2) = S.liftM2 (IbinExpr o tf t) (f v1) (f v2)++rnFbinExpr :: (a -> MS a) -> FbinExpr a -> MS (FbinExpr a)+rnFbinExpr f (FbinExpr o tf t v1 v2) = S.liftM2 (FbinExpr o tf t) (f v1) (f v2)++rnBinExpr :: (a -> MS a) -> BinExpr a -> MS (BinExpr a)+rnBinExpr f (Ie x) = S.liftM Ie (rnIbinExpr f x)+rnBinExpr f (Fe x) = S.liftM Fe (rnFbinExpr f x)++rnConversion :: (Typed a -> MS (Typed a)) -> Conversion a -> MS (Conversion a)+rnConversion f (Conversion o v t) = S.liftM (\x -> Conversion o x t) (f v)++rnSelect :: (Typed a -> MS (Typed a)) -> Select a -> MS (Select a)+rnSelect f (Select v1 v2 v3) = S.liftM3 Select (f v1) (f v2) (f v3)+++rnFunName :: FunName -> MS FunName+rnFunName (FunNameGlobal g) = S.liftM FunNameGlobal (rnGlobalOrLocalId g)+rnFunName x = return x+ ++rnCallSite :: CallSite -> MS (Bool, CallSite)+rnCallSite (CsFun c pa t fn aps fas) = + do { fna <- rnFunName fn+ ; x <- mapM rnActualParam aps+ ; let (rt, _) = splitCallReturnType t+ ; return (not (rt == Tvoid), CsFun c pa t fna x fas)+ }+rnCallSite (CsAsm t dia b1 b2 qs1 qs2 aps fas) = + do { apsa <- mapM rnActualParam aps+ ; let (rt, _) = splitCallReturnType t+ ; return (not (rt == Tvoid), CsAsm t dia b1 b2 qs1 qs2 apsa fas)+ }+rnCallSite (CsConversion pas t c aps fas) = + do { apsa <- mapM rnActualParam aps+ ; let (rt, _) = splitCallReturnType t+ ; return (not (rt == Tvoid), CsConversion pas t c apsa fas)+ }++rnActualParam :: ActualParam -> MS ActualParam+rnActualParam (ActualParamData t ps ma v pa) = S.liftM (\x -> ActualParamData t ps ma x pa) (rnValue v)+rnActualParam (ActualParamMeta mc) = S.liftM ActualParamMeta (rnMetaKindedConst mc)+ ++rnExtractElem :: (Typed a -> MS (Typed a)) -> ExtractElement a -> MS (ExtractElement a)+rnExtractElem f (ExtractElement v1 v2) = S.liftM2 ExtractElement (f v1) (f v2)++rnInsertElem :: (Typed a -> MS (Typed a)) -> InsertElement a -> MS (InsertElement a)+rnInsertElem f (InsertElement v1 v2 v3) = S.liftM3 InsertElement (f v1) (f v2) (f v3)++rnShuffleVector :: (Typed a -> MS (Typed a)) -> ShuffleVector a -> MS (ShuffleVector a)+rnShuffleVector f (ShuffleVector v1 v2 v3) = S.liftM3 ShuffleVector (f v1) (f v2) (f v3)+++rnExtractValue :: (Typed a -> MS (Typed a)) -> ExtractValue a -> MS (ExtractValue a)+rnExtractValue f (ExtractValue v s) = S.liftM (\x -> ExtractValue x s) (f v)+++rnInsertValue :: (Typed a -> MS (Typed a)) -> InsertValue a -> MS (InsertValue a)+rnInsertValue f (InsertValue v1 v2 s) = S.liftM2 (\x y -> InsertValue x y s)+ (f v1) (f v2)+ + +rnTerminatorInstWithDbg :: TerminatorInstWithDbg -> MS TerminatorInstWithDbg+rnTerminatorInstWithDbg (TerminatorInstWithDbg t ds) = S.liftM (\x -> TerminatorInstWithDbg x ds) (rnTerminatorInst t)+++rnTerminatorInst :: TerminatorInst -> MS TerminatorInst+rnTerminatorInst (Return ls) = S.liftM Return (mapM rnTypedValue ls)+rnTerminatorInst (Br l) = S.liftM Br (rnTargetLabel l)+rnTerminatorInst (Cbr v tl fl) = S.liftM3 Cbr (rnValue v) (rnTargetLabel tl) (rnTargetLabel fl)+rnTerminatorInst (Switch t d cases) = S.liftM3 Switch (rnTypedValue t) (rnTargetLabel d) + (mapM (\(x,y) -> S.liftM2 (,)+ (rnTypedValue x)+ (rnTargetLabel y)) cases)++rnTerminatorInst (IndirectBr tv ls) = S.liftM2 IndirectBr+ (rnTypedValue tv) (mapM rnTargetLabel ls)+ +rnTerminatorInst (Invoke lhsOpt callSite tl fl) = do { lhsOpt' <- (maybeM rnLhs lhsOpt)+ ; (b, cs) <- (rnCallSite callSite)+ ; lhsOpt'' <- getLhs b lhsOpt'+ ; tl' <- (rnTargetLabel tl)+ ; fl' <- (rnTargetLabel fl)+ ; return $ Invoke lhsOpt'' cs tl' fl'+ }+rnTerminatorInst (Resume tv) = S.liftM Resume (rnTypedValue tv) +rnTerminatorInst x = return x+++rnPercentLabel :: PercentLabel -> MS PercentLabel+rnPercentLabel (PercentLabel x) = S.liftM PercentLabel (rnLabelId x)++rnTargetLabel :: TargetLabel -> MS TargetLabel+rnTargetLabel (TargetLabel x) = S.liftM TargetLabel (rnPercentLabel x)+++rnMetaConst :: MetaConst -> MS MetaConst+rnMetaConst (McRef l) = S.liftM McRef (rnLocalId l)+rnMetaConst (McStruct c) = S.liftM McStruct (S.mapM (mapMetaKindedConst rnMetaConst) c)+rnMetaConst mc@(McSimple sc) = return mc+rnMetaConst x = return x+ +rnMetaKind :: MetaKind -> MS MetaKind +rnMetaKind mk = return mk++rnMetaKind2 :: MetaKind -> RD MetaKind+rnMetaKind2 mk = return mk++rnMetaKindedConst :: MetaKindedConst -> MS MetaKindedConst+rnMetaKindedConst x = case x of+ (MetaKindedConst mk mc) -> S.liftM (MetaKindedConst mk) (rnMetaConst mc)+ UnmetaKindedNull -> return UnmetaKindedNull++mapMetaKindedConst :: Monad m => (MetaConst -> m MetaConst) -> MetaKindedConst -> m MetaKindedConst+mapMetaKindedConst f x = case x of+ (MetaKindedConst mk mc) -> S.liftM (MetaKindedConst mk) (f mc)+ UnmetaKindedNull -> return UnmetaKindedNull++rnConst :: Const -> MS Const+rnConst (C_complex x) = S.liftM C_complex (rnComplexConstant x)+rnConst (C_localId x) = S.liftM C_localId (rnLocalId x)+rnConst (C_labelId l) = S.liftM C_labelId (rnLabelId l)+rnConst (C_blockAddress g l) = S.liftM (C_blockAddress g) (rnPercentLabel l)+rnConst (C_binexp bexpr) = S.liftM C_binexp (rnBinExpr rnConst bexpr)+rnConst (C_conv convert) = S.liftM C_conv (rnConversion rnTypedConst convert)+rnConst (C_gep getelm) = S.liftM C_gep (rnGetElemPtr rnTypedConst getelm)+rnConst (C_select select) = S.liftM C_select (rnSelect rnTypedConst select)+rnConst (C_icmp icmp) = S.liftM C_icmp (rnIcmp rnConst icmp)+rnConst (C_fcmp fcmp) = S.liftM C_fcmp (rnFcmp rnConst fcmp)+rnConst (C_shufflevector shuffle) = S.liftM C_shufflevector (rnShuffleVector rnTypedConst shuffle)+rnConst (C_extractvalue extract) = S.liftM C_extractvalue (rnExtractValue rnTypedConst extract)+rnConst (C_insertvalue insert) = S.liftM C_insertvalue (rnInsertValue rnTypedConst insert)+rnConst (C_extractelement extract) = S.liftM C_extractelement (rnExtractElem rnTypedConst extract)+rnConst (C_insertelement insert) = S.liftM C_insertelement (rnInsertElem rnTypedConst insert)+rnConst x = return x++rnComplexConstant :: ComplexConstant -> MS ComplexConstant+rnComplexConstant (Cstruct b l) = S.liftM (Cstruct b) (S.mapM (mapTypedConstOrNull rnTypedConst) l)+rnComplexConstant (Carray l) = S.liftM Carray (S.mapM (mapTypedConstOrNull rnTypedConst) l)+rnComplexConstant (Cvector l) = S.liftM Cvector (S.mapM (mapTypedConstOrNull rnTypedConst) l)++rnTypedConst :: Typed Const -> MS (Typed Const) +rnTypedConst (Typed t c) = S.liftM (Typed t) (rnConst c)++rnPrefix :: Maybe Prefix -> MS (Maybe Prefix)+rnPrefix (Just (Prefix n)) = S.liftM (Just . Prefix) (mapTypedConstOrNull rnTypedConst n)+rnPrefix _ = return Nothing++rnPrologue :: Maybe Prologue -> MS (Maybe Prologue)+rnPrologue (Just (Prologue n)) = S.liftM (Just . Prologue) (mapTypedConstOrNull rnTypedConst n)+rnPrologue _ = return Nothing++++------------------------------------------------------------------------+-- iteration 2+------------------------------------------------------------------------+type RD a = R.Reader (GlobalId, (M.Map GlobalId LabelNumbers)) a++iter2 :: M.Map GlobalId LabelNumbers -> [Toplevel] -> [Toplevel]+#ifdef DEBUG+iter2 m tl | trace ("iter2 " ++ show m) False = undefined+#endif+iter2 m tl = fmap (rnToplevel2 m) tl+ +rnToplevel2 :: M.Map GlobalId LabelNumbers -> Toplevel -> Toplevel+rnToplevel2 m (ToplevelGlobal (TlGlobal v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 const v12 v13 v14)) = + R.runReader (do { x <- maybe (return Nothing) (\x -> R.liftM Just (rnConst2 x)) const+ ; return (ToplevelGlobal (TlGlobal v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 const v12 v13 v14))+ }) (GlobalIdNum 0, m)+rnToplevel2 m (ToplevelDefine (TlDefine fp@(FunctionPrototype _ _ _ _ _ _ fhName _ _ _ _ _ _ _ _ _) bs)) = + let (fp2, bs2) = R.runReader (do { fp' <- rnDefFunctionPrototype2 fp+ ; bs' <- S.mapM rnBlock2 bs+ ; return (fp', bs')+ }) (fhName, m) -- + in (ToplevelDefine (TlDefine fp2 bs2))+rnToplevel2 _ x = x+++rnBlock2 :: Block -> RD Block+rnBlock2 (Block lbl phi comp term) = do { phi' <- mapM rnPhiInstWithDbg2 phi+ ; comp' <- mapM rnComputingInstWithDbg2 comp+ ; term' <- rnTerminatorInstWithDbg2 term+ ; return (Block lbl phi' comp' term')+ }+++rnPhiInstWithDbg2 :: PhiInstWithDbg -> RD PhiInstWithDbg+rnPhiInstWithDbg2 (PhiInstWithDbg ins dbgs) = S.liftM (\x -> PhiInstWithDbg x dbgs) (rnPhi2 ins)++rnPhi2 :: PhiInst -> RD PhiInst+rnPhi2 (PhiInst lhs t ins) = do { ins' <- S.mapM g ins+ ; return $ PhiInst lhs t ins'+ }+ where g (v, p) = do { v' <- rnValue2 v+ ; p' <- rnMyPercentLabel2 p+ ; return (v', p')+ }++rnComputingInstWithDbg2 :: ComputingInstWithDbg -> RD ComputingInstWithDbg+rnComputingInstWithDbg2 (ComputingInstWithDbg c l) = + R.liftM (\x -> ComputingInstWithDbg x l) (rnComputingInst2 c)++rnComputingInst2 :: ComputingInst -> RD ComputingInst+#ifdef DEBUG+rnComputingInst2 x | trace ("rnComputingInst2 " ++ show (x)) False = undefined+#endif+rnComputingInst2 (ComputingInst lhs rhs) = do { rhsa <- rnRhs2 rhs+ ; return (ComputingInst lhs rhsa)+ }+++rnRhs2 :: Rhs -> RD Rhs+rnRhs2 lhs = case lhs of+ RmO x -> S.liftM RmO (rnMemOp2 x)+ Re x -> S.liftM Re (rnExpr2 x)+ Call b cs -> S.liftM (Call b) (rnCallSite2 cs)+ ReE e -> S.liftM ReE (rnExtractElem2 rnTypedValue2 e)+ RiE e -> S.liftM RiE (rnInsertElem2 rnTypedValue2 e)+ RsV e -> S.liftM RsV (rnShuffleVector2 rnTypedValue2 e)+ ReV e -> S.liftM ReV (rnExtractValue2 rnTypedValue2 e)+ RiV e -> S.liftM RiV (rnInsertValue2 rnTypedValue2 e)+ RvA (VaArg tv t) -> S.liftM (\x -> RvA $ VaArg x t) (rnTypedValue2 tv)+ RlP (LandingPad rt ft ix cl c) -> return lhs+++rnMemOp2 :: MemOp -> RD MemOp+rnMemOp2 (Alloca m t tv a) = do { tv' <- maybeM rnTypedValue2 tv+ ; return (Alloca m t tv' a)+ }+rnMemOp2 (Load a tp ma nt inv nl) = S.liftM (\x -> (Load a x ma nt inv nl)) (rnPointer2 rnTypedValue2 tp)+rnMemOp2 (LoadAtomic at a tp ma) = S.liftM (\x -> (LoadAtomic at a x ma)) (rnPointer2 rnTypedValue2 tp)+rnMemOp2 (Store a tv tp ma nt) = S.liftM2 (\x y -> (Store a x y ma nt))+ (rnTypedValue2 tv) (rnPointer2 rnTypedValue2 tp)+rnMemOp2 (StoreAtomic at a tv tp ma) = S.liftM2 (\x y -> (StoreAtomic at a x y ma))+ (rnTypedValue2 tv) (rnPointer2 rnTypedValue2 tp)+rnMemOp2 (Fence b f) = return (Fence b f)+rnMemOp2 (CmpXchg wk b1 tp tv1 tv2 b2 mf ff) = + S.liftM3 (\x y z -> CmpXchg wk b1 x y z b2 mf ff)+ (rnPointer2 rnTypedValue2 tp)+ (rnTypedValue2 tv1)+ (rnTypedValue2 tv2)+rnMemOp2 (AtomicRmw b1 ao tp tv b2 mf) = + S.liftM2 (\x y -> AtomicRmw b1 ao x y b2 mf)+ (rnPointer2 rnTypedValue2 tp)+ (rnTypedValue2 tv)++rnCallSite2 :: CallSite -> RD CallSite+rnCallSite2 (CsFun c pa t fn aps fas) = + do { x <- mapM rnActualParam2 aps+ ; return (CsFun c pa t fn x fas)+ }+rnCallSite2 (CsAsm t dia b1 b2 qs1 qs2 aps fas) = + do { apsa <- mapM rnActualParam2 aps+ ; return (CsAsm t dia b1 b2 qs1 qs2 apsa fas)+ }+rnCallSite2 (CsConversion pas t c aps fas) = + do { apsa <- mapM rnActualParam2 aps+ ; return (CsConversion pas t c apsa fas)+ }+ +rnActualParam2 :: ActualParam -> RD ActualParam+rnActualParam2 (ActualParamData t ps ma v pa) = S.liftM (\x -> ActualParamData t ps ma x pa) (rnValue2 v)+rnActualParam2 (ActualParamMeta mc) = S.liftM ActualParamMeta (rnMetaKindedConst2 mc)+ + ++rnTerminatorInstWithDbg2 :: TerminatorInstWithDbg -> RD TerminatorInstWithDbg+rnTerminatorInstWithDbg2 (TerminatorInstWithDbg t ds) = + S.liftM (\x -> TerminatorInstWithDbg x ds) (rnTerminatorInst2 t)+ + +rnTerminatorInst2 :: TerminatorInst -> RD TerminatorInst+rnTerminatorInst2 x = case x of+ Return ls -> S.liftM Return (mapM rnTypedValue2 ls)+ Br l -> S.liftM Br (rnTargetLabel2 l)+ Cbr v tl fl -> S.liftM3 Cbr (rnValue2 v) (rnTargetLabel2 tl) (rnTargetLabel2 fl)+ Switch t d cases -> S.liftM3 Switch (rnTypedValue2 t) (rnTargetLabel2 d) + (mapM (\(x,y) -> S.liftM2 (,)+ (rnTypedValue2 x)+ (rnTargetLabel2 y)) cases)+ IndirectBr tv ls -> S.liftM2 IndirectBr+ (rnTypedValue2 tv) (mapM rnTargetLabel2 ls)+ Invoke lhsOpt callSite tl fl -> do { cs <- (rnCallSite2 callSite)+ ; tla <- (rnTargetLabel2 tl)+ ; fla <- (rnTargetLabel2 fl)+ ; return $ Invoke lhsOpt cs tla fla+ }+ Resume tv -> S.liftM Resume (rnTypedValue2 tv)+ _ -> return x ++rnTargetLabel2 :: TargetLabel -> RD TargetLabel+rnTargetLabel2 (TargetLabel x) = S.liftM TargetLabel (rnMyPercentLabel2 x)++rnDefFunctionPrototype2 :: FunctionPrototype -> RD FunctionPrototype+rnDefFunctionPrototype2 fpt = return fpt+++rnConst2 :: Const -> RD Const+rnConst2 (C_complex x) = S.liftM C_complex (rnComplexConstant2 x)+rnConst2 (C_localId x) = S.liftM C_localId (rnLocalId2 x)+rnConst2 (C_labelId l) = do { rd <- R.ask+ ; S.liftM C_labelId (rnLabelId2 (fst rd) l)+ }+rnConst2 (C_blockAddress g l) = S.liftM (C_blockAddress g) (rnPercentLabel2 g l)+rnConst2 (C_binexp bexpr) = S.liftM C_binexp (rnBinExpr2 rnConst2 bexpr)+rnConst2 (C_conv convert) = S.liftM C_conv (rnConversion2 rnTypedConst2 convert)+rnConst2 (C_gep getelm) = S.liftM C_gep (rnGetElemPtr2 rnTypedConst2 getelm)+rnConst2 (C_select select) = S.liftM C_select (rnSelect2 rnTypedConst2 select)+rnConst2 (C_icmp icmp) = S.liftM C_icmp (rnIcmp2 rnConst2 icmp)+rnConst2 (C_fcmp fcmp) = S.liftM C_fcmp (rnFcmp2 rnConst2 fcmp)+rnConst2 (C_shufflevector shuffle) = S.liftM C_shufflevector (rnShuffleVector2 rnTypedConst2 shuffle)+rnConst2 (C_extractvalue extract) = S.liftM C_extractvalue (rnExtractValue2 rnTypedConst2 extract)+rnConst2 (C_insertvalue insert) = S.liftM C_insertvalue (rnInsertValue2 rnTypedConst2 insert)+rnConst2 (C_extractelement extract) = S.liftM C_extractelement (rnExtractElem2 rnTypedConst2 extract)+rnConst2 (C_insertelement insert) = S.liftM C_insertelement (rnInsertElem2 rnTypedConst2 insert)+rnConst2 x = return x++++rnComplexConstant2 :: ComplexConstant -> RD ComplexConstant+rnComplexConstant2 (Cstruct b l) = S.liftM (Cstruct b) (S.mapM (mapTypedConstOrNull rnTypedConst2) l)+rnComplexConstant2 (Carray l) = S.liftM Carray (S.mapM (mapTypedConstOrNull rnTypedConst2) l)+rnComplexConstant2 (Cvector l) = S.liftM Cvector (S.mapM (mapTypedConstOrNull rnTypedConst2) l)+ +rnTypedConst2 :: Typed Const -> RD (Typed Const) +rnTypedConst2 (Typed t c) = S.liftM (Typed t) (rnConst2 c)++mapTypedConstOrNull :: Monad m => (Typed Const -> m (Typed Const)) -> TypedConstOrNull -> m TypedConstOrNull+mapTypedConstOrNull f (TypedConst tc) = S.liftM TypedConst (f tc)+mapTypedConstOrNull f UntypedNull = return UntypedNull++rnMetaConst2 :: MetaConst -> RD MetaConst+rnMetaConst2 (McRef l) = R.liftM McRef (rnLocalId2 l)+rnMetaConst2 (McStruct l) = R.liftM McStruct (S.mapM (mapMetaKindedConst rnMetaConst2) l) -- Const (rnConst2 c)+rnMetaConst2 (McSimple sc) = return $ McSimple sc+rnMetaConst2 x = return x++rnMetaKindedConst2 :: MetaKindedConst -> RD MetaKindedConst+rnMetaKindedConst2 x = case x of+ (MetaKindedConst mk mc) -> R.liftM (MetaKindedConst mk) (rnMetaConst2 mc)+ UnmetaKindedNull -> return UnmetaKindedNull ++rnPercentLabel2 :: GlobalId -> PercentLabel -> RD PercentLabel+rnPercentLabel2 g (PercentLabel x) = R.liftM PercentLabel (rnLabelId2 g x)++rnMyPercentLabel2 :: PercentLabel -> RD PercentLabel +rnMyPercentLabel2 x = do { r <- R.ask+ ; rnPercentLabel2 (fst r) x+ }++rnLabelId2 :: GlobalId -> LabelId -> RD LabelId+rnLabelId2 g l = case l of+ LabelNumber i -> do { b <- isImplicitNum g i+ ; if b then return $ LabelString (implicitLbPrefix ++ show i)+ else do { c <- isExplicitNum g i+ ; if c then return $ LabelString (explicitLbPrefix ++ show i)+ else do { d <- isExplicitDqNum g i + ; if d then return $ LabelDqNumber i+ else error ("what happend??? " ++ show l)+ }+ }+ }+ LabelDqNumber i -> do { b <- isExplicitDqNum g i+ ; if b then return l+ else do { c <- isExplicitNum g i + ; if c then return $ LabelString (explicitLbPrefix ++ show i)+ else do { x <- R.ask+ ; error ("what happend??? " ++ show l ++ " " ++ show x)+ }+ }+ }+ _ -> return l++isImplicitNum :: GlobalId -> Word32 {-Integer-} -> RD Bool+isImplicitNum g i = do { (_,r) <- R.ask+ ; case M.lookup g r of+ Nothing -> return False+ Just st -> return $ St.member i (implicitNumbers st) + }+ +isExplicitNum :: GlobalId -> Word32 {-Integer-} -> RD Bool+isExplicitNum g i = do { (_,r) <- R.ask+ ; case M.lookup g r of+ Nothing -> return False+ Just st -> return $ St.member i (explicitNumbers st) + }++isExplicitDqNum :: GlobalId -> Word32 {-Integer-} -> RD Bool+isExplicitDqNum g i = do { (_,r) <- R.ask+ ; case M.lookup g r of+ Nothing -> return False+ Just st -> return $ St.member i (explicitDqNumbers st) + }++rnPointer2 :: (a -> RD a) -> Pointer a -> RD (Pointer a)+rnPointer2 f (Pointer v) = S.liftM Pointer (f v)++rnExpr2 :: Expr -> RD Expr+rnExpr2 (EgEp e) = S.liftM EgEp (rnGetElemPtr2 rnTypedValue2 e)+rnExpr2 (EiC e) = S.liftM EiC (rnIcmp2 rnValue2 e)+rnExpr2 (EfC e) = S.liftM EfC (rnFcmp2 rnValue2 e)+rnExpr2 (Eb e) = S.liftM Eb (rnBinExpr2 rnValue2 e)+rnExpr2 (Ec e) = S.liftM Ec (rnConversion2 rnTypedValue2 e)+rnExpr2 (Es e) = S.liftM Es (rnSelect2 rnTypedValue2 e)+++rnGetElemPtr2 :: (Typed v -> RD (Typed v)) -> GetElementPtr v -> RD (GetElementPtr v)+rnGetElemPtr2 fv (GetElementPtr b v vs) = do { v' <- rnPointer2 fv v+ ; vs' <- mapM fv vs+ ; return $ GetElementPtr b v' vs'+ }++rnIcmp2 :: (a -> RD a) -> Icmp a -> RD (Icmp a)+rnIcmp2 f (Icmp o t v1 v2) = S.liftM2 (Icmp o t) (f v1) (f v2)++rnFcmp2 :: (a -> RD a) -> Fcmp a -> RD (Fcmp a)+rnFcmp2 f (Fcmp o t v1 v2) = S.liftM2 (Fcmp o t) (f v1) (f v2)++rnIbinExpr2 :: (a -> RD a) -> IbinExpr a -> RD (IbinExpr a)+rnIbinExpr2 f (IbinExpr o tf t v1 v2) = S.liftM2 (IbinExpr o tf t) (f v1) (f v2)++rnFbinExpr2 :: (a -> RD a) -> FbinExpr a -> RD (FbinExpr a)+rnFbinExpr2 f (FbinExpr o tf t v1 v2) = S.liftM2 (FbinExpr o tf t) (f v1) (f v2)++rnBinExpr2 :: (a -> RD a) -> BinExpr a -> RD (BinExpr a)+rnBinExpr2 f (Ie x) = S.liftM Ie (rnIbinExpr2 f x)+rnBinExpr2 f (Fe x) = S.liftM Fe (rnFbinExpr2 f x)++rnConversion2 :: (Typed a -> RD (Typed a)) -> Conversion a -> RD (Conversion a)+rnConversion2 f (Conversion o v t) = S.liftM (\x -> Conversion o x t) (f v)++rnSelect2 :: (Typed a -> RD (Typed a)) -> Select a -> RD (Select a)+rnSelect2 f (Select v1 v2 v3) = S.liftM3 Select (f v1) (f v2) (f v3)++rnValue2 :: Value -> RD Value+rnValue2 (Val_local x) = S.liftM Val_local (rnLocalId2 x)+rnValue2 (Val_const x) = S.liftM Val_const (rnConst2 x)+++rnTypedValue2 :: Typed Value -> RD (Typed Value)+rnTypedValue2 (Typed t v) = S.liftM (Typed t) (rnValue2 v)++rnLocalId2 :: LocalId -> RD LocalId+rnLocalId2 x = return x;++rnExtractElem2 :: (Typed a -> RD (Typed a)) -> ExtractElement a -> RD (ExtractElement a)+rnExtractElem2 f (ExtractElement v1 v2) = S.liftM2 ExtractElement (f v1) (f v2)++rnInsertElem2 :: (Typed a -> RD (Typed a)) -> InsertElement a -> RD (InsertElement a)+rnInsertElem2 f (InsertElement v1 v2 v3) = S.liftM3 InsertElement (f v1) (f v2) (f v3)++rnShuffleVector2 :: (Typed a -> RD (Typed a)) -> ShuffleVector a -> RD (ShuffleVector a)+rnShuffleVector2 f (ShuffleVector v1 v2 v3) = S.liftM3 ShuffleVector (f v1) (f v2) (f v3)+++rnExtractValue2 :: (Typed a -> RD (Typed a)) -> ExtractValue a -> RD (ExtractValue a)+rnExtractValue2 f (ExtractValue v s) = S.liftM (\x -> ExtractValue x s) (f v)+++rnInsertValue2 :: (Typed a -> RD (Typed a)) -> InsertValue a -> RD (InsertValue a)+rnInsertValue2 f (InsertValue v1 v2 s) = S.liftM2 (\x y -> InsertValue x y s)+ (f v1) (f v2)+++simplify :: Module -> Module+simplify (Module ml) = let (sl, ml1) = iter1 ml+ in Module (iter2 ml1 sl)
+ src/Llvm/Data/Conversion/IrAstConversion.hs view
@@ -0,0 +1,1171 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Llvm.Data.Conversion.IrAstConversion(irToAst) where++#define FLC (I.FileLoc $(I.srcLoc))++import qualified Compiler.Hoopl as H+import qualified Control.Monad as Md+import qualified Data.Map as M+import qualified Llvm.Data.Ast as A+import qualified Llvm.Data.Ir as I+import Llvm.Util.Monadic (maybeM, pairM)+import Llvm.Data.Conversion.TypeConversion+import Control.Monad.Reader++class Conversion l1 l2 | l1 -> l2 where+ convert :: l1 -> l2++type Rm = Reader (M.Map H.Label A.LabelId)++instance Conversion a (Rm b) => Conversion (Maybe a) (Rm (Maybe b)) where+ convert (Just x) = Md.liftM Just (convert x)+ convert Nothing = return Nothing++instance (Conversion a (Rm c), Conversion b (Rm c)) => Conversion (Either a b) (Rm c) where+ convert (Left x) = (convert x)+ convert (Right x) = (convert x)++{- Ir to Ast conversion -} +instance Conversion H.Label (Rm A.LabelId) where+ convert l = do { r <- ask+ ; case M.lookup l r of + Just l0 -> return l0+ Nothing -> return $ A.LabelDqString $ "_hoopl_label_" ++ show l + }++convert_to_PercentLabel :: H.Label -> Rm A.PercentLabel+convert_to_PercentLabel l = Md.liftM A.PercentLabel (convert l)++convert_to_TargetLabel :: H.Label -> Rm A.TargetLabel+convert_to_TargetLabel l = Md.liftM (A.TargetLabel . A.PercentLabel) (convert l)++convert_to_BlockLabel :: H.Label -> Rm A.BlockLabel+convert_to_BlockLabel l = Md.liftM A.ExplicitBlockLabel (convert l)+ +cnowrap :: Maybe I.NoWrap -> [A.TrapFlag]+cnowrap = maybe [] (\x -> case x of+ I.Nsw -> [A.Nsw]+ I.Nuw -> [A.Nuw]+ I.Nsuw -> [A.Nsw, A.Nuw]+ )+cexact :: Maybe a -> [A.TrapFlag] +cexact = maybe [] (\_ -> [A.Exact])+++instance Conversion v1 (Rm v2) => Conversion (I.Conversion I.ScalarB v1) (Rm (A.Conversion v2)) where+ convert x = let (op, t1, u, dt1) = case x of+ I.Trunc (I.T t0 u0) dt0 -> (A.Trunc, tconvert () t0, u0, tconvert () dt0) + I.Zext (I.T t0 u0) dt0 -> (A.Zext, tconvert () t0, u0, tconvert () dt0)+ I.Sext (I.T t0 u0) dt0 -> (A.Sext, tconvert () t0, u0, tconvert () dt0)+ I.FpTrunc (I.T t0 u0) dt0 -> (A.FpTrunc, tconvert () t0, u0, tconvert () dt0)+ I.FpExt (I.T t0 u0) dt0 -> (A.FpExt, tconvert () t0, u0, tconvert () dt0)+ I.FpToUi (I.T t0 u0) dt0 -> (A.FpToUi, tconvert () t0, u0, tconvert () dt0)+ I.FpToSi (I.T t0 u0) dt0 -> (A.FpToSi, tconvert () t0, u0, tconvert () dt0)+ I.UiToFp (I.T t0 u0) dt0 -> (A.UiToFp, tconvert () t0, u0, tconvert () dt0)+ I.SiToFp (I.T t0 u0) dt0 -> (A.SiToFp, tconvert () t0, u0, tconvert () dt0)+ I.PtrToInt (I.T t0 u0) dt0 -> (A.PtrToInt, tconvert () t0, u0, tconvert () dt0)+ I.IntToPtr (I.T t0 u0) dt0 -> (A.IntToPtr, tconvert () t0, u0, tconvert () dt0)+ I.Bitcast (I.T t0 u0) dt0 -> (A.Bitcast, tconvert () t0, u0, tconvert () dt0)+ I.AddrSpaceCast (I.T t0 u0) dt0 -> (A.AddrSpaceCast, tconvert () t0, u0, tconvert () dt0)+ in do { u1 <- convert u+ ; return $ A.Conversion op (A.Typed t1 u1) dt1+ }++instance Conversion v1 (Rm v2) => Conversion (I.Conversion I.VectorB v1) (Rm (A.Conversion v2)) where+ convert x = let (op, t1, u, dt1) = case x of+ I.Trunc (I.T t0 u0) dt0 -> (A.Trunc, tconvert () t0, u0, tconvert () dt0) + I.Zext (I.T t0 u0) dt0 -> (A.Zext, tconvert () t0, u0, tconvert () dt0)+ I.Sext (I.T t0 u0) dt0 -> (A.Sext, tconvert () t0, u0, tconvert () dt0)+ I.FpTrunc (I.T t0 u0) dt0 -> (A.FpTrunc, tconvert () t0, u0, tconvert () dt0)+ I.FpExt (I.T t0 u0) dt0 -> (A.FpExt, tconvert () t0, u0, tconvert () dt0)+ I.FpToUi (I.T t0 u0) dt0 -> (A.FpToUi, tconvert () t0, u0, tconvert () dt0)+ I.FpToSi (I.T t0 u0) dt0 -> (A.FpToSi, tconvert () t0, u0, tconvert () dt0)+ I.UiToFp (I.T t0 u0) dt0 -> (A.UiToFp, tconvert () t0, u0, tconvert () dt0)+ I.SiToFp (I.T t0 u0) dt0 -> (A.SiToFp, tconvert () t0, u0, tconvert () dt0)+ I.PtrToInt (I.T t0 u0) dt0 -> (A.PtrToInt, tconvert () t0, u0, tconvert () dt0)+ I.IntToPtr (I.T t0 u0) dt0 -> (A.IntToPtr, tconvert () t0, u0, tconvert () dt0)+ I.Bitcast (I.T t0 u0) dt0 -> (A.Bitcast, tconvert () t0, u0, tconvert () dt0)+ I.AddrSpaceCast (I.T t0 u0) dt0 -> (A.AddrSpaceCast, tconvert () t0, u0, tconvert () dt0)+ in do { u1 <- convert u+ ; return $ A.Conversion op (A.Typed t1 u1) dt1+ }+ +mkConversion :: (A.ConvertOp, A.Type, I.Const, A.Type) -> Rm A.Const+mkConversion (op, t1, u, dt1) = do { u1 <- convert u+ ; return $ A.C_conv $ A.Conversion op (A.Typed t1 u1) dt1 + }++instance (Conversion v1 (Rm v2)) => Conversion (I.GetElementPtr I.ScalarB v1) (Rm (A.GetElementPtr v2)) where+ convert (I.GetElementPtr b u us) = do { ua <- convert u+ ; usa <- mapM convert us+ ; return $ A.GetElementPtr b (A.Pointer ua) usa+ }+ +instance (Conversion v1 (Rm v2)) => Conversion (I.GetElementPtr I.VectorB v1) (Rm (A.GetElementPtr v2)) where+ convert (I.GetElementPtr b u us) = do { ua <- convert u+ ; usa <- mapM convert us+ ; return $ A.GetElementPtr b (A.Pointer ua) usa+ } ++instance Conversion v1 (Rm v2) => Conversion (I.T I.ScalarType v1) (Rm (A.Typed v2)) where+ convert (I.T t v) = Md.liftM (A.Typed $ tconvert () t) (convert v)++instance Conversion v1 (Rm v2) => Conversion (I.T I.Dtype v1) (Rm (A.Typed v2)) where+ convert (I.T t v) = Md.liftM (A.Typed $ tconvert () t) (convert v)++instance Conversion v1 (Rm v2) => Conversion (I.T (I.Type I.ScalarB I.I) v1) (Rm (A.Typed v2)) where+ convert (I.T t v) = Md.liftM (A.Typed $ tconvert () t) (convert v)++instance Conversion v1 (Rm v2) => Conversion (I.T (I.Type I.ScalarB I.F) v1) (Rm (A.Typed v2)) where+ convert (I.T t v) = Md.liftM (A.Typed $ tconvert () t) (convert v)++instance Conversion v1 (Rm v2) => Conversion (I.T (I.Type I.ScalarB I.P) v1) (Rm (A.Typed v2)) where+ convert (I.T t v) = Md.liftM (A.Typed $ tconvert () t) (convert v)++instance Conversion v1 (Rm v2) => Conversion (I.T (I.Type I.VectorB I.I) v1) (Rm (A.Typed v2)) where+ convert (I.T t v) = Md.liftM (A.Typed $ tconvert () t) (convert v)++instance Conversion v1 (Rm v2) => Conversion (I.T (I.Type I.VectorB I.F) v1) (Rm (A.Typed v2)) where+ convert (I.T t v) = Md.liftM (A.Typed $ tconvert () t) (convert v)++instance Conversion v1 (Rm v2) => Conversion (I.T (I.Type I.VectorB I.P) v1) (Rm (A.Typed v2)) where+ convert (I.T t v) = Md.liftM (A.Typed $ tconvert () t) (convert v)++instance Conversion v1 (Rm v2) => Conversion (I.T (I.Type I.RecordB I.D) v1) (Rm (A.Typed v2)) where+ convert (I.T t v) = Md.liftM (A.Typed $ tconvert () t) (convert v)++instance Conversion v1 (Rm v2) => Conversion (I.T (I.Type I.CodeFunB I.X) v1) (Rm (A.Typed v2)) where+ convert (I.T t v) = Md.liftM (A.Typed $ tconvert () t) (convert v)++instance Conversion v1 (Rm v2) => Conversion (I.T (I.Type I.CodeLabelB I.X) v1) (Rm (A.Typed v2)) where+ convert (I.T t v) = Md.liftM (A.Typed $ tconvert () t) (convert v)++instance Conversion v1 (Rm v2) => Conversion (I.T (I.Type I.FirstClassB I.D) v1) (Rm (A.Typed v2)) where+ convert (I.T t v) = Md.liftM (A.Typed $ tconvert () t) (convert v)++instance (Conversion v1 (Rm v2)) => Conversion (I.Select I.ScalarB I.I v1) (Rm (A.Select v2)) where+ convert (I.Select u1 u2 u3) = Md.liftM3 A.Select (convert u1) (convert u2) (convert u3)++instance (Conversion v1 (Rm v2)) => Conversion (I.Select I.ScalarB I.F v1) (Rm (A.Select v2)) where+ convert (I.Select u1 u2 u3) = Md.liftM3 A.Select (convert u1) (convert u2) (convert u3)++instance (Conversion v1 (Rm v2)) => Conversion (I.Select I.ScalarB I.P v1) (Rm (A.Select v2)) where+ convert (I.Select u1 u2 u3) = Md.liftM3 A.Select (convert u1) (convert u2) (convert u3)++instance (Conversion v1 (Rm v2)) => Conversion (I.Select I.VectorB I.I v1) (Rm (A.Select v2)) where+ convert (I.Select u1 u2 u3) = Md.liftM3 A.Select (convert u1) (convert u2) (convert u3)++instance (Conversion v1 (Rm v2)) => Conversion (I.Select I.VectorB I.F v1) (Rm (A.Select v2)) where+ convert (I.Select u1 u2 u3) = Md.liftM3 A.Select (convert u1) (convert u2) (convert u3)++instance (Conversion v1 (Rm v2)) => Conversion (I.Select I.VectorB I.P v1) (Rm (A.Select v2)) where+ convert (I.Select u1 u2 u3) = Md.liftM3 A.Select (convert u1) (convert u2) (convert u3)++instance Conversion v1 (Rm v2) => Conversion (I.Icmp I.ScalarB v1) (Rm (A.Icmp v2)) where+ convert (I.Icmp op t u1 u2) = Md.liftM2 (A.Icmp op (tconvert () t)) (convert u1) (convert u2)++instance Conversion v1 (Rm v2) => Conversion (I.Icmp I.VectorB v1) (Rm (A.Icmp v2)) where+ convert (I.Icmp op t u1 u2) = Md.liftM2 (A.Icmp op (tconvert () t)) (convert u1) (convert u2)++instance Conversion v1 (Rm v2) => Conversion (I.Fcmp I.ScalarB v1) (Rm (A.Fcmp v2)) where+ convert (I.Fcmp op t u1 u2) = Md.liftM2 (A.Fcmp op (tconvert () t)) (convert u1) (convert u2)++instance Conversion v1 (Rm v2) => Conversion (I.Fcmp I.VectorB v1) (Rm (A.Fcmp v2)) where+ convert (I.Fcmp op t u1 u2) = Md.liftM2 (A.Fcmp op (tconvert () t)) (convert u1) (convert u2)++instance Conversion v1 (Rm v2) => Conversion (I.ShuffleVector I.I v1) (Rm (A.ShuffleVector v2)) where+ convert (I.ShuffleVector u1 u2 u3) = Md.liftM3 A.ShuffleVector (convert u1) (convert u2) (convert u3)++instance Conversion v1 (Rm v2) => Conversion (I.ShuffleVector I.F v1) (Rm (A.ShuffleVector v2)) where+ convert (I.ShuffleVector u1 u2 u3) = Md.liftM3 A.ShuffleVector (convert u1) (convert u2) (convert u3)++instance Conversion v1 (Rm v2) => Conversion (I.ShuffleVector I.P v1) (Rm (A.ShuffleVector v2)) where+ convert (I.ShuffleVector u1 u2 u3) = Md.liftM3 A.ShuffleVector (convert u1) (convert u2) (convert u3)++instance Conversion v1 (Rm v2) => Conversion (I.ExtractValue v1) (Rm (A.ExtractValue v2)) where+ convert (I.ExtractValue u s) = convert u >>= \u' -> return $ A.ExtractValue u' s++instance Conversion v1 (Rm v2) => Conversion (I.InsertValue v1) (Rm (A.InsertValue v2)) where+ convert (I.InsertValue u1 u2 s) = do { u1' <- convert u1+ ; u2' <- convert u2+ ; return $ A.InsertValue u1' u2' s+ }++instance Conversion v1 (Rm v2) => Conversion (I.ExtractElement I.I v1) (Rm (A.ExtractElement v2)) where+ convert (I.ExtractElement u1 u2) = Md.liftM2 A.ExtractElement (convert u1) (convert u2)++instance Conversion v1 (Rm v2) => Conversion (I.ExtractElement I.F v1) (Rm (A.ExtractElement v2)) where+ convert (I.ExtractElement u1 u2) = Md.liftM2 A.ExtractElement (convert u1) (convert u2)++instance Conversion v1 (Rm v2) => Conversion (I.ExtractElement I.P v1) (Rm (A.ExtractElement v2)) where+ convert (I.ExtractElement u1 u2) = Md.liftM2 A.ExtractElement (convert u1) (convert u2)+++instance Conversion v1 (Rm v2) => Conversion (I.InsertElement I.I v1) (Rm (A.InsertElement v2)) where+ convert (I.InsertElement u1 u2 u3) = Md.liftM3 A.InsertElement (convert u1) (convert u2) (convert u3)++instance Conversion v1 (Rm v2) => Conversion (I.InsertElement I.F v1) (Rm (A.InsertElement v2)) where+ convert (I.InsertElement u1 u2 u3) = Md.liftM3 A.InsertElement (convert u1) (convert u2) (convert u3)++instance Conversion v1 (Rm v2) => Conversion (I.InsertElement I.P v1) (Rm (A.InsertElement v2)) where+ convert (I.InsertElement u1 u2 u3) = Md.liftM3 A.InsertElement (convert u1) (convert u2) (convert u3)++++++instance Conversion I.Const (Rm A.Const) where+ convert x = case x of+ I.C_int s -> return $ A.C_simple $ A.CpInt s + I.C_uhex_int s -> return $ A.C_simple $ A.CpUhexInt s+ I.C_shex_int s -> return $ A.C_simple $ A.CpShexInt s + I.C_float s -> return $ A.C_simple $ A.CpFloat s+ I.C_null -> return $ A.C_simple $ A.CpNull+ I.C_undef -> return $ A.C_simple $ A.CpUndef+ I.C_true -> return $ A.C_simple $ A.CpTrue+ I.C_false -> return $ A.C_simple $ A.CpFalse+ I.C_zeroinitializer -> return $ A.C_simple $ A.CpZeroInitializer+ I.C_globalAddr s -> return $ A.C_simple $ A.CpGlobalAddr s+ I.C_str s -> return $ A.C_simple $ A.CpStr s+ I.C_u8 s -> return $ A.C_simple $ A.CpBconst $ A.BconstUint8 s+ I.C_u16 s -> return $ A.C_simple $ A.CpBconst $ A.BconstUint16 s+ I.C_u32 s -> return $ A.C_simple $ A.CpBconst $ A.BconstUint32 s + I.C_u64 s -> return $ A.C_simple $ A.CpBconst $ A.BconstUint64 s+ I.C_u96 s -> return $ A.C_simple $ A.CpBconst $ A.BconstUint96 s + I.C_u128 s -> return $ A.C_simple $ A.CpBconst $ A.BconstUint128 s + I.C_s8 s -> return $ A.C_simple $ A.CpBconst $ A.BconstInt8 s + I.C_s16 s -> return $ A.C_simple $ A.CpBconst $ A.BconstInt16 s+ I.C_s32 s -> return $ A.C_simple $ A.CpBconst $ A.BconstInt32 s + I.C_s64 s -> return $ A.C_simple $ A.CpBconst $ A.BconstInt64 s + I.C_s96 s -> return $ A.C_simple $ A.CpBconst $ A.BconstInt96 s + I.C_s128 s -> return $ A.C_simple $ A.CpBconst $ A.BconstInt128 s +++ (I.C_struct b fs) -> Md.liftM (A.C_complex . (A.Cstruct b)) (mapM convert fs)+ (I.C_vector fs) -> Md.liftM (A.C_complex . A.Cvector) (mapM convert fs)+ (I.C_array fs) -> Md.liftM (A.C_complex . A.Carray) (mapM convert fs)+ (I.C_vectorN n fs) -> do { v <- convert fs+ ; return (A.C_complex $ A.Cvector $ (fmap (\_ -> v) [1..n]))+ }+ (I.C_arrayN n fs) -> do { v <- convert fs+ ; return (A.C_complex $ A.Carray $ (fmap (\_ -> v) [1..n]))+ }+ I.C_localId a -> return $ A.C_localId a+ I.C_labelId a -> Md.liftM A.C_labelId (convert a)+ I.C_block g a -> do { a' <- convert_to_PercentLabel a+ ; return $ A.C_blockAddress g a'+ }+ I.C_add nw t u1 u2 -> Md.liftM (A.C_binexp . A.Ie) + (Md.liftM2 (A.IbinExpr A.Add (cnowrap nw) (tconvert () t)) (convert u1) (convert u2))+ I.C_sub nw t u1 u2 -> Md.liftM (A.C_binexp . A.Ie)+ (Md.liftM2 (A.IbinExpr A.Sub (cnowrap nw) (tconvert () t)) (convert u1) (convert u2))+ I.C_mul nw t u1 u2 -> Md.liftM (A.C_binexp . A.Ie)+ (Md.liftM2 (A.IbinExpr A.Mul (cnowrap nw) (tconvert () t)) (convert u1) (convert u2))+ I.C_udiv nw t u1 u2 -> Md.liftM (A.C_binexp . A.Ie)+ (Md.liftM2 (A.IbinExpr A.Udiv (cexact nw) (tconvert () t)) (convert u1) (convert u2))+ I.C_sdiv nw t u1 u2 -> Md.liftM (A.C_binexp . A.Ie)+ (Md.liftM2 (A.IbinExpr A.Sdiv (cexact nw) (tconvert () t)) (convert u1) (convert u2))+ I.C_urem t u1 u2 -> Md.liftM (A.C_binexp . A.Ie)+ (Md.liftM2 (A.IbinExpr A.Urem [] (tconvert () t)) (convert u1) (convert u2))+ I.C_srem t u1 u2 -> Md.liftM (A.C_binexp . A.Ie)+ (Md.liftM2 (A.IbinExpr A.Srem [] (tconvert () t)) (convert u1) (convert u2))+ I.C_shl nw t u1 u2 -> Md.liftM (A.C_binexp . A.Ie)+ (Md.liftM2 (A.IbinExpr A.Shl (cnowrap nw) (tconvert () t)) (convert u1) (convert u2))+ I.C_lshr nw t u1 u2 -> Md.liftM (A.C_binexp . A.Ie)+ (Md.liftM2 (A.IbinExpr A.Lshr (cexact nw) (tconvert () t)) (convert u1) (convert u2))+ I.C_ashr nw t u1 u2 -> Md.liftM (A.C_binexp . A.Ie)+ (Md.liftM2 (A.IbinExpr A.Ashr (cexact nw) (tconvert () t)) (convert u1) (convert u2))+ I.C_and t u1 u2 -> Md.liftM (A.C_binexp . A.Ie)+ (Md.liftM2 (A.IbinExpr A.And [] (tconvert () t)) (convert u1) (convert u2))+ I.C_or t u1 u2 -> Md.liftM (A.C_binexp . A.Ie)+ (Md.liftM2 (A.IbinExpr A.Or [] (tconvert () t)) (convert u1) (convert u2))+ I.C_xor t u1 u2 -> Md.liftM (A.C_binexp . A.Ie)+ (Md.liftM2 (A.IbinExpr A.Xor [] (tconvert () t)) (convert u1) (convert u2))+++ I.C_add_V nw t u1 u2 -> Md.liftM (A.C_binexp . A.Ie) (Md.liftM2 (A.IbinExpr A.Add (cnowrap nw) (tconvert () t)) (convert u1) (convert u2))+ I.C_sub_V nw t u1 u2 -> Md.liftM (A.C_binexp . A.Ie) (Md.liftM2 (A.IbinExpr A.Sub (cnowrap nw) (tconvert () t)) (convert u1) (convert u2))+ I.C_mul_V nw t u1 u2 -> Md.liftM (A.C_binexp . A.Ie) (Md.liftM2 (A.IbinExpr A.Mul (cnowrap nw) (tconvert () t)) (convert u1) (convert u2))+ I.C_udiv_V nw t u1 u2 -> Md.liftM (A.C_binexp . A.Ie) $ Md.liftM2 (A.IbinExpr A.Udiv (cexact nw) (tconvert () t)) (convert u1) (convert u2)+ I.C_sdiv_V nw t u1 u2 -> Md.liftM (A.C_binexp . A.Ie) $ Md.liftM2 (A.IbinExpr A.Sdiv (cexact nw) (tconvert () t)) (convert u1) (convert u2)+ I.C_urem_V t u1 u2 -> Md.liftM (A.C_binexp . A.Ie) $ Md.liftM2 (A.IbinExpr A.Urem [] (tconvert () t)) (convert u1) (convert u2)+ I.C_srem_V t u1 u2 -> Md.liftM (A.C_binexp . A.Ie) $ Md.liftM2 (A.IbinExpr A.Srem [] (tconvert () t)) (convert u1) (convert u2)+ I.C_shl_V nw t u1 u2 -> Md.liftM (A.C_binexp . A.Ie) $ Md.liftM2 (A.IbinExpr A.Shl (cnowrap nw) (tconvert () t)) (convert u1) (convert u2)+ I.C_lshr_V nw t u1 u2 -> Md.liftM (A.C_binexp . A.Ie) $ Md.liftM2 (A.IbinExpr A.Lshr (cexact nw) (tconvert () t)) (convert u1) (convert u2)+ I.C_ashr_V nw t u1 u2 -> Md.liftM (A.C_binexp . A.Ie) $ Md.liftM2 (A.IbinExpr A.Ashr (cexact nw) (tconvert () t)) (convert u1) (convert u2)+ I.C_and_V t u1 u2 -> Md.liftM (A.C_binexp . A.Ie) $ Md.liftM2 (A.IbinExpr A.And [] (tconvert () t)) (convert u1) (convert u2)+ I.C_or_V t u1 u2 -> Md.liftM (A.C_binexp . A.Ie) $ Md.liftM2 (A.IbinExpr A.Or [] (tconvert () t)) (convert u1) (convert u2)+ I.C_xor_V t u1 u2 -> Md.liftM (A.C_binexp . A.Ie) $ Md.liftM2 (A.IbinExpr A.Xor [] (tconvert () t)) (convert u1) (convert u2)++ I.C_fadd fg t u1 u2 -> Md.liftM (A.C_binexp . A.Fe) $ Md.liftM2 (A.FbinExpr A.Fadd fg (tconvert () t)) (convert u1) (convert u2)+ I.C_fsub fg t u1 u2 -> Md.liftM (A.C_binexp . A.Fe) $ Md.liftM2 (A.FbinExpr A.Fsub fg (tconvert () t)) (convert u1) (convert u2)+ I.C_fmul fg t u1 u2 -> Md.liftM (A.C_binexp . A.Fe) $ Md.liftM2 (A.FbinExpr A.Fmul fg (tconvert () t)) (convert u1) (convert u2)+ I.C_fdiv fg t u1 u2 -> Md.liftM (A.C_binexp . A.Fe) $ Md.liftM2 (A.FbinExpr A.Fdiv fg (tconvert () t)) (convert u1) (convert u2)+ I.C_frem fg t u1 u2 -> Md.liftM (A.C_binexp . A.Fe) $ Md.liftM2 (A.FbinExpr A.Frem fg (tconvert () t)) (convert u1) (convert u2)++ I.C_fadd_V fg t u1 u2 -> Md.liftM (A.C_binexp . A.Fe) $ Md.liftM2 (A.FbinExpr A.Fadd fg (tconvert () t)) (convert u1) (convert u2)+ I.C_fsub_V fg t u1 u2 -> Md.liftM (A.C_binexp . A.Fe) $ Md.liftM2 (A.FbinExpr A.Fsub fg (tconvert () t)) (convert u1) (convert u2)+ I.C_fmul_V fg t u1 u2 -> Md.liftM (A.C_binexp . A.Fe) $ Md.liftM2 (A.FbinExpr A.Fmul fg (tconvert () t)) (convert u1) (convert u2)+ I.C_fdiv_V fg t u1 u2 -> Md.liftM (A.C_binexp . A.Fe) $ Md.liftM2 (A.FbinExpr A.Fdiv fg (tconvert () t)) (convert u1) (convert u2)+ I.C_frem_V fg t u1 u2 -> Md.liftM (A.C_binexp . A.Fe) $ Md.liftM2 (A.FbinExpr A.Frem fg (tconvert () t)) (convert u1) (convert u2)++ I.C_trunc (I.T t0 u0) dt0 -> mkConversion (A.Trunc, tconvert () t0, u0, tconvert () dt0) + I.C_zext (I.T t0 u0) dt0 -> mkConversion (A.Zext, tconvert () t0, u0, tconvert () dt0)+ I.C_sext (I.T t0 u0) dt0 -> mkConversion (A.Sext, tconvert () t0, u0, tconvert () dt0)+ I.C_fptrunc (I.T t0 u0) dt0 -> mkConversion (A.FpTrunc, tconvert () t0, u0, tconvert () dt0)+ I.C_fpext (I.T t0 u0) dt0 -> mkConversion (A.FpExt, tconvert () t0, u0, tconvert () dt0)+ I.C_fptoui (I.T t0 u0) dt0 -> mkConversion (A.FpToUi, tconvert () t0, u0, tconvert () dt0)+ I.C_fptosi (I.T t0 u0) dt0 -> mkConversion (A.FpToSi, tconvert () t0, u0, tconvert () dt0)+ I.C_uitofp (I.T t0 u0) dt0 -> mkConversion (A.UiToFp, tconvert () t0, u0, tconvert () dt0)+ I.C_sitofp (I.T t0 u0) dt0 -> mkConversion (A.SiToFp, tconvert () t0, u0, tconvert () dt0)+ I.C_ptrtoint (I.T t0 u0) dt0 -> mkConversion (A.PtrToInt, tconvert () t0, u0, tconvert () dt0)+ I.C_inttoptr (I.T t0 u0) dt0 -> mkConversion (A.IntToPtr, tconvert () t0, u0, tconvert () dt0)+ I.C_addrspacecast (I.T t0 u0) dt0 -> mkConversion (A.AddrSpaceCast, tconvert () t0, u0, tconvert () dt0)++ I.C_bitcast (I.T t0 u0) dt0 -> mkConversion (A.Bitcast, tconvert () t0, u0, tconvert () dt0)+ + I.C_trunc_V (I.T t0 u0) dt0 -> mkConversion (A.Trunc, tconvert () t0, u0, tconvert () dt0) + I.C_zext_V (I.T t0 u0) dt0 -> mkConversion (A.Zext, tconvert () t0, u0, tconvert () dt0)+ I.C_sext_V (I.T t0 u0) dt0 -> mkConversion (A.Sext, tconvert () t0, u0, tconvert () dt0)+ I.C_fptrunc_V (I.T t0 u0) dt0 -> mkConversion (A.FpTrunc, tconvert () t0, u0, tconvert () dt0)+ I.C_fpext_V (I.T t0 u0) dt0 -> mkConversion (A.FpExt, tconvert () t0, u0, tconvert () dt0)+ I.C_fptoui_V (I.T t0 u0) dt0 -> mkConversion (A.FpToUi, tconvert () t0, u0, tconvert () dt0)+ I.C_fptosi_V (I.T t0 u0) dt0 -> mkConversion (A.FpToSi, tconvert () t0, u0, tconvert () dt0)+ I.C_uitofp_V (I.T t0 u0) dt0 -> mkConversion (A.UiToFp, tconvert () t0, u0, tconvert () dt0)+ I.C_sitofp_V (I.T t0 u0) dt0 -> mkConversion (A.SiToFp, tconvert () t0, u0, tconvert () dt0)+ I.C_ptrtoint_V (I.T t0 u0) dt0 -> mkConversion (A.PtrToInt, tconvert () t0, u0, tconvert () dt0)+ I.C_inttoptr_V (I.T t0 u0) dt0 -> mkConversion (A.IntToPtr, tconvert () t0, u0, tconvert () dt0)+ I.C_addrspacecast_V (I.T t0 u0) dt0 -> mkConversion (A.AddrSpaceCast, tconvert () t0, u0, tconvert () dt0)++ I.C_getelementptr b u us -> do { ua <- convert u+ ; usa <- mapM convert us+ ; return $ A.C_gep $ A.GetElementPtr b (A.Pointer ua) usa+ }++ I.C_getelementptr_V b u us -> do { ua <- convert u+ ; usa <- mapM convert us+ ; return $ A.C_gep $ A.GetElementPtr b (A.Pointer ua) usa+ }+ I.C_select_I a -> Md.liftM A.C_select (convert a)+ I.C_select_F a -> Md.liftM A.C_select (convert a)+ I.C_select_P a -> Md.liftM A.C_select (convert a)+ I.C_select_First cnd t f -> do { cnda <- convert cnd + ; ta <- convert t+ ; fa <- convert f+ ; return $ A.C_select (A.Select cnda ta fa)+ }+ I.C_select_VI a -> Md.liftM A.C_select (convert a)+ I.C_select_VF a -> Md.liftM A.C_select (convert a)+ I.C_select_VP a -> Md.liftM A.C_select (convert a)+ I.C_icmp a -> Md.liftM A.C_icmp (convert a)+ I.C_icmp_V a -> Md.liftM A.C_icmp (convert a)+ I.C_fcmp a -> Md.liftM A.C_fcmp (convert a)+ I.C_fcmp_V a -> Md.liftM A.C_fcmp (convert a)+ I.C_shufflevector_I a -> Md.liftM A.C_shufflevector (convert a)+ I.C_shufflevector_F a -> Md.liftM A.C_shufflevector (convert a)+ I.C_shufflevector_P a -> Md.liftM A.C_shufflevector (convert a)+ I.C_extractvalue a -> Md.liftM A.C_extractvalue (convert a)+ I.C_insertvalue a -> Md.liftM A.C_insertvalue (convert a)+ I.C_extractelement_I a -> Md.liftM A.C_extractelement (convert a)+ I.C_extractelement_F a -> Md.liftM A.C_extractelement (convert a)+ I.C_extractelement_P a -> Md.liftM A.C_extractelement (convert a) + I.C_insertelement_I a -> Md.liftM A.C_insertelement (convert a)+ I.C_insertelement_F a -> Md.liftM A.C_insertelement (convert a)+ I.C_insertelement_P a -> Md.liftM A.C_insertelement (convert a)+++instance Conversion I.MdVar (Rm A.MdVar) where+ convert (I.MdVar s) = return $ A.MdVar s++instance Conversion I.MdNode (Rm A.MdNode) where+ convert (I.MdNode s) = return $ A.MdNode s++instance Conversion I.MetaConst (Rm A.MetaConst) where+ convert (I.McStruct c) = mapM convert c >>= return . A.McStruct+ convert (I.McString s) = return $ A.McString s+ convert (I.McMn n) = convert n >>= return . A.McMn+ convert (I.McMv n) = convert n >>= return . A.McMv+ convert (I.McRef i) = return $ A.McRef i+ convert (I.McSimple sc) = Md.liftM A.McSimple (convert sc)++instance Conversion I.MetaKindedConst (Rm A.MetaKindedConst) where+ convert x = case x of+ (I.MetaKindedConst mk mc) -> Md.liftM (A.MetaKindedConst (tconvert () mk)) (convert mc)+ I.UnmetaKindedNull -> return A.UnmetaKindedNull++instance Conversion I.FunName (Rm A.FunName) where+ convert (I.FunNameGlobal g) = return $ A.FunNameGlobal g+ convert (I.FunNameString s) = return $ A.FunNameString s++instance Conversion I.Value (Rm A.Value) where+ convert (I.Val_ssa a) = return $ A.Val_local a+ convert (I.Val_const a) = Md.liftM A.Val_const (convert a)++instance Conversion I.CallSiteType (Rm A.Type) where+ convert t = case t of+ I.CallSiteRet x -> return $ tconvert () x+ I.CallSiteFun ft as -> return $ tconvert () (I.Tpointer (I.ucast ft) as)+ +instance Conversion I.CallSite (Rm A.CallSite) where+ convert (I.CsFun cc pa t fn aps fa) = do { fna <- convert fn+ ; apsa <- mapM convert aps+ ; ta <- convert t+ ; return $ A.CsFun cc pa ta fna apsa fa+ }+ convert (I.CsAsm t dia b1 b2 qs1 qs2 as fa) = do { asa <- mapM convert as+ ; ta <- convert t+ ; return $ A.CsAsm ta dia b1 b2 qs1 qs2 asa fa+ }+ convert (I.CsConversion pa t cv as fa) = do { cva <- convert cv+ ; asa <- mapM convert as+ ; ta <- convert t+ ; return $ A.CsConversion pa ta cva asa fa+ }+ convert (I.CsConversionV pa t cv as fa) = do { cva <- convert cv+ ; asa <- mapM convert as+ ; ta <- convert t+ ; return $ A.CsConversion pa ta cva asa fa+ }+++instance Conversion I.Clause (Rm A.Clause) where+ convert (I.Catch tv) = convert tv >>= \tv' -> return $ A.Catch tv'+ convert (I.Filter tc) = convert tc >>= \tc' -> return $ A.Filter tc'+ convert (I.CcoS tc) = convert tc >>= return . A.Cco+ convert (I.CcoV tc) = convert tc >>= return . A.Cco ++instance Conversion I.GlobalOrLocalId (Rm A.GlobalOrLocalId) where+ convert g = return g++instance Conversion I.PersFn (Rm A.PersFn) where+ convert (I.PersFnId s) = return $ A.PersFnId $ s+ convert (I.PersFnCastS c) = convert c >>= return . A.PersFnCast+ convert (I.PersFnCastV c) = convert c >>= return . A.PersFnCast + convert (I.PersFnUndef) = return $ A.PersFnUndef+ convert (I.PersFnNull) = return $ A.PersFnNull+ convert (I.PersFnConst c) = Md.liftM A.PersFnConst (convert c)+++instance Conversion I.CInst (Rm A.ComputingInst) where+ convert cinst = case cinst of + I.I_alloca mar t mtv ma lhs -> do { mtva <- maybeM convert mtv + ; return $ A.ComputingInst (Just lhs) $ A.RmO $ A.Alloca mar (tconvert () t) mtva ma+ }+ I.I_load atom tv aa nonterm invr nonull lhs -> do { tva <- convert tv + ; return $ A.ComputingInst (Just lhs) $ A.RmO $ A.Load atom (A.Pointer tva) aa nonterm invr nonull+ }+ I.I_loadatomic atom v tv aa lhs -> do { tva <- convert tv + ; return $ A.ComputingInst (Just lhs) $ A.RmO $ A.LoadAtomic atom v (A.Pointer tva) aa+ }+ I.I_store atom tv1 tv2 aa nonterm -> do { tv1a <- convert tv1+ ; tv2a <- convert tv2+ ; return $ A.ComputingInst Nothing (A.RmO $ A.Store atom tv1a (A.Pointer tv2a) aa nonterm)+ }+ I.I_storeatomic atom v tv1 tv2 aa -> do { tv1a <- convert tv1+ ; tv2a <- convert tv2+ ; return $ A.ComputingInst Nothing (A.RmO $ A.StoreAtomic atom v tv1a (A.Pointer tv2a) aa)+ }+ I.I_cmpxchg_I wk b1 tv1 tv2 tv3 b2 sord ford lhs-> do { tv1a <- convert tv1+ ; tv2a <- convert tv2+ ; tv3a <- convert tv3+ ; return $ A.ComputingInst (Just lhs) (A.RmO $ A.CmpXchg wk b1 (A.Pointer tv1a) tv2a tv3a b2 sord ford)+ }+ I.I_cmpxchg_F wk b1 tv1 tv2 tv3 b2 sord ford lhs->+ do { tv1a <- convert tv1+ ; tv2a <- convert tv2+ ; tv3a <- convert tv3+ ; return $ A.ComputingInst (Just lhs) (A.RmO $ A.CmpXchg wk b1 (A.Pointer tv1a) tv2a tv3a b2 sord ford)+ } + I.I_cmpxchg_P wk b1 tv1 tv2 tv3 b2 sord ford lhs->+ do { tv1a <- convert tv1+ ; tv2a <- convert tv2+ ; tv3a <- convert tv3+ ; return $ A.ComputingInst (Just lhs) (A.RmO $ A.CmpXchg wk b1 (A.Pointer tv1a) tv2a tv3a b2 sord ford)+ } + I.I_atomicrmw b1 op tv1 tv2 b2 mf lhs-> + do { tv1a <- convert tv1+ ; tv2a <- convert tv2+ ; return $ A.ComputingInst (Just lhs) (A.RmO $ A.AtomicRmw b1 op (A.Pointer tv1a) tv2a b2 mf)+ }+ I.I_fence b fo -> return $ A.ComputingInst Nothing $ A.RmO $ A.Fence b fo + I.I_va_arg tv t lhs-> + do { tv1 <- convert tv+ ; return $ A.ComputingInst (Just lhs) $ A.RvA $ A.VaArg tv1 (tconvert () t)+ }+ I.I_va_start (I.T t v) -> + do { let t1 = tconvert () t+ ; va <- convert v+ ; return $ A.ComputingInst Nothing $ A.Call A.TcNon $ A.CsFun Nothing [] A.Tvoid (A.FunNameGlobal $ A.GolG $ A.GlobalIdAlphaNum "llvm.va_start") + [A.ActualParamData t1 [] Nothing va []] []+ } + I.I_va_end (I.T t v) -> + do { let t1 = tconvert () t+ ; va <- convert v + ; return $ A.ComputingInst Nothing $ A.Call A.TcNon $ A.CsFun Nothing [] A.Tvoid (A.FunNameGlobal $ A.GolG $ A.GlobalIdAlphaNum "llvm.va_end") + [A.ActualParamData t1 [] Nothing va []] []+ } + I.I_landingpad t1 t2 pf b cs lhs-> + do { pfa <- convert pf+ ; csa <- mapM convert cs+ ; return $ A.ComputingInst (Just lhs) (A.RlP $ A.LandingPad (tconvert () t1) (tconvert () t2) pfa b csa)+ }+ I.I_extractelement_I tv1 tv2 lhs-> + do { tv1a <- convert tv1+ ; tv2a <- convert tv2+ ; return $ A.ComputingInst (Just lhs) (A.ReE $ A.ExtractElement tv1a tv2a)+ }+ I.I_extractelement_F tv1 tv2 lhs-> + do { tv1a <- convert tv1+ ; tv2a <- convert tv2+ ; return $ A.ComputingInst (Just lhs) (A.ReE $ A.ExtractElement tv1a tv2a)+ }+ I.I_extractelement_P tv1 tv2 lhs-> + do { tv1a <- convert tv1+ ; tv2a <- convert tv2+ ; return $ A.ComputingInst (Just lhs) (A.ReE $ A.ExtractElement tv1a tv2a)+ } + I.I_extractvalue tv1 idx lhs-> + do { tv1a <- convert tv1+ ; return $ A.ComputingInst (Just lhs) (A.ReV $ A.ExtractValue tv1a idx)+ }+ I.I_getelementptr b ptr idx lhs-> + do { ptra <- convert ptr+ ; idxa <- mapM convert idx+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.EgEp $ A.GetElementPtr b (A.Pointer ptra) idxa) + }+ I.I_getelementptr_V b ptr idx lhs ->+ do { ptra <- convert ptr+ ; idxa <- mapM convert idx+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.EgEp $ A.GetElementPtr b (A.Pointer ptra) idxa) + } + I.I_icmp op t v1 v2 lhs-> + do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.EiC $ A.Icmp op (tconvert () t) v1a v2a)+ }+ I.I_icmp_V op t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.EiC $ A.Icmp op (tconvert () t) v1a v2a)+ } + I.I_fcmp op t v1 v2 lhs-> + do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.EfC $ A.Fcmp op (tconvert () t) v1a v2a)+ }+ I.I_fcmp_V op t v1 v2 lhs-> + do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.EfC $ A.Fcmp op (tconvert () t) v1a v2a)+ }+ I.I_add n t v1 v2 lhs-> + do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Add (cnowrap n) (tconvert () t) v1a v2a)+ }+ I.I_sub n t v1 v2 lhs -> + do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Sub (cnowrap n) (tconvert () t) v1a v2a)+ }+ I.I_mul n t v1 v2 lhs -> + do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Mul (cnowrap n) (tconvert () t) v1a v2a)+ }+ I.I_udiv n t v1 v2 lhs-> + do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Udiv (cexact n) (tconvert () t) v1a v2a)+ }+ I.I_sdiv n t v1 v2 lhs-> + do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Sdiv (cexact n) (tconvert () t) v1a v2a)+ }+ I.I_urem t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Urem [] (tconvert () t) v1a v2a)+ }+ I.I_srem t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Srem [] (tconvert () t) v1a v2a)+ }+ I.I_shl n t v1 v2 lhs-> + do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Shl (cnowrap n) (tconvert () t) v1a v2a)+ }+ I.I_lshr n t v1 v2 lhs-> + do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Lshr (cexact n) (tconvert () t) v1a v2a)+ }+ I.I_ashr n t v1 v2 lhs-> + do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Ashr (cexact n) (tconvert () t) v1a v2a)+ }+ I.I_and t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2 + ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.And [] (tconvert () t) v1a v2a)+ }+ I.I_or t v1 v2 lhs-> + do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Or [] (tconvert () t) v1a v2a)+ }+ I.I_xor t v1 v2 lhs-> + do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Xor [] (tconvert () t) v1a v2a)+ }+ I.I_add_V n t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Add (cnowrap n) (tconvert () t) v1a v2a)+ }+ I.I_sub_V n t v1 v2 lhs-> + do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Sub (cnowrap n) (tconvert () t) v1a v2a)+ }+ I.I_mul_V n t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Mul (cnowrap n) (tconvert () t) v1a v2a)+ }+ I.I_udiv_V n t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Udiv (cexact n) (tconvert () t) v1a v2a)+ }+ I.I_sdiv_V n t v1 v2 lhs-> + do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Sdiv (cexact n) (tconvert () t) v1a v2a)+ }+ I.I_urem_V t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Urem [] (tconvert () t) v1a v2a)+ }+ I.I_srem_V t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Srem [] (tconvert () t) v1a v2a)+ }+ I.I_shl_V n t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Shl (cnowrap n) (tconvert () t) v1a v2a)+ }+ I.I_lshr_V n t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Lshr (cexact n) (tconvert () t) v1a v2a)+ }+ I.I_ashr_V n t v1 v2 lhs-> + do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Ashr (cexact n) (tconvert () t) v1a v2a)+ }+ I.I_and_V t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.And [] (tconvert () t) v1a v2a)+ }+ I.I_or_V t v1 v2 lhs-> + do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Or [] (tconvert () t) v1a v2a)+ }+ I.I_xor_V t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Ie $ A.IbinExpr A.Xor [] (tconvert () t) v1a v2a)+ } + I.I_fadd n t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Fe $ A.FbinExpr A.Fadd n (tconvert () t) v1a v2a)+ }+ I.I_fsub n t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Fe $ A.FbinExpr A.Fadd n (tconvert () t) v1a v2a)+ }+ I.I_fmul n t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Fe $ A.FbinExpr A.Fadd n (tconvert () t) v1a v2a)+ }+ I.I_fdiv n t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Fe $ A.FbinExpr A.Fadd n (tconvert () t) v1a v2a)+ }+ I.I_frem n t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Fe $ A.FbinExpr A.Fadd n (tconvert () t) v1a v2a)+ }+ I.I_fadd_V n t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Fe $ A.FbinExpr A.Fadd n (tconvert () t) v1a v2a)+ }+ I.I_fsub_V n t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Fe $ A.FbinExpr A.Fadd n (tconvert () t) v1a v2a)+ }+ I.I_fmul_V n t v1 v2 lhs-> + do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Fe $ A.FbinExpr A.Fadd n (tconvert () t) v1a v2a)+ }+ I.I_fdiv_V n t v1 v2 lhs-> + do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Fe $ A.FbinExpr A.Fadd n (tconvert () t) v1a v2a)+ }+ I.I_frem_V n t v1 v2 lhs->+ do { v1a <- convert v1+ ; v2a <- convert v2+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Eb $ A.Fe $ A.FbinExpr A.Fadd n (tconvert () t) v1a v2a)+ }+ I.I_trunc tv dt lhs->+ do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.Trunc tva (tconvert () dt)) + }+ I.I_zext tv dt lhs->+ do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.Zext tva (tconvert () dt)) + } + I.I_sext tv dt lhs->+ do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.Sext tva (tconvert () dt)) + } + I.I_fptrunc tv dt lhs->+ do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.FpTrunc tva (tconvert () dt)) + } + I.I_fpext tv dt lhs-> + do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.FpExt tva (tconvert () dt)) + } + I.I_fptoui tv dt lhs-> + do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.FpToUi tva (tconvert () dt)) + } + I.I_fptosi tv dt lhs-> + do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.FpToSi tva (tconvert () dt)) + } + I.I_uitofp tv dt lhs-> + do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.UiToFp tva (tconvert () dt)) + } + I.I_sitofp tv dt lhs-> + do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.SiToFp tva (tconvert () dt)) + } + I.I_ptrtoint tv dt lhs ->+ do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.PtrToInt tva (tconvert () dt)) + } + I.I_inttoptr tv dt lhs -> + do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.IntToPtr tva (tconvert () dt)) + } + I.I_bitcast tv dt lhs -> + do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.Bitcast tva (tconvert () dt)) + } + I.I_bitcast_D tv dt lhs -> + do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.Bitcast tva (tconvert () dt)) + } + I.I_addrspacecast tv dt lhs-> + do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.AddrSpaceCast tva (tconvert () dt)) + } + I.I_trunc_V tv dt lhs->+ do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.Trunc tva (tconvert () dt)) + }+ I.I_zext_V tv dt lhs-> + do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.Zext tva (tconvert () dt)) + } + I.I_sext_V tv dt lhs->+ do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.Sext tva (tconvert () dt)) + } + I.I_fptrunc_V tv dt lhs-> + do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.FpTrunc tva (tconvert () dt)) + } + I.I_fpext_V tv dt lhs-> + do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.FpExt tva (tconvert () dt)) + } + I.I_fptoui_V tv dt lhs-> + do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.FpToUi tva (tconvert () dt)) + } + I.I_fptosi_V tv dt lhs-> + do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.FpToSi tva (tconvert () dt)) + } + I.I_uitofp_V tv dt lhs->+ do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.UiToFp tva (tconvert () dt)) + } + I.I_sitofp_V tv dt lhs->+ do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.SiToFp tva (tconvert () dt)) + } + I.I_ptrtoint_V tv dt lhs-> + do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.PtrToInt tva (tconvert () dt)) + } + I.I_inttoptr_V tv dt lhs->+ do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.IntToPtr tva (tconvert () dt)) + } + I.I_addrspacecast_V tv dt lhs-> + do { tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Ec $ A.Conversion A.AddrSpaceCast tva (tconvert () dt)) + } + I.I_select_I cnd t f lhs->+ do { cnda <- convert cnd+ ; ta <- convert t+ ; fa <- convert f+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Es $ A.Select cnda ta fa) + }+ I.I_select_F cnd t f lhs->+ do { cnda <- convert cnd+ ; ta <- convert t+ ; fa <- convert f+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Es $ A.Select cnda ta fa) + }+ I.I_select_P cnd t f lhs->+ do { cnda <- convert cnd+ ; ta <- convert t+ ; fa <- convert f+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Es $ A.Select cnda ta fa) + }+ I.I_select_First cnd t f lhs->+ do { cnda <- convert cnd+ ; ta <- convert t+ ; fa <- convert f+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Es $ A.Select cnda ta fa) + }+ I.I_select_VI cnd t f lhs-> + do { cnda <- convert cnd+ ; ta <- convert t+ ; fa <- convert f+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Es $ A.Select cnda ta fa) + }+ I.I_select_VF cnd t f lhs-> + do { cnda <- convert cnd+ ; ta <- convert t+ ; fa <- convert f+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Es $ A.Select cnda ta fa) + }+ I.I_select_VP cnd t f lhs-> + do { cnda <- convert cnd+ ; ta <- convert t+ ; fa <- convert f+ ; return $ A.ComputingInst (Just lhs) (A.Re $ A.Es $ A.Select cnda ta fa) + }+ I.I_insertelement_I vtv tv idx lhs-> + do { vtva <- convert vtv+ ; tva <- convert tv+ ; idxa <- convert idx+ ; return $ A.ComputingInst (Just lhs) (A.RiE $ A.InsertElement vtva tva idxa) + }+ I.I_insertelement_F vtv tv idx lhs-> + do { vtva <- convert vtv+ ; tva <- convert tv+ ; idxa <- convert idx+ ; return $ A.ComputingInst (Just lhs) (A.RiE $ A.InsertElement vtva tva idxa) + }+ I.I_insertelement_P vtv tv idx lhs-> + do { vtva <- convert vtv+ ; tva <- convert tv+ ; idxa <- convert idx+ ; return $ A.ComputingInst (Just lhs) (A.RiE $ A.InsertElement vtva tva idxa) + }+ I.I_shufflevector_I tv1 tv2 tv3 lhs->+ do { tv1a <- convert tv1+ ; tv2a <- convert tv2+ ; tv3a <- convert tv3+ ; return $ A.ComputingInst (Just lhs) (A.RsV $ A.ShuffleVector tv1a tv2a tv3a) + }+ I.I_shufflevector_F tv1 tv2 tv3 lhs->+ do { tv1a <- convert tv1+ ; tv2a <- convert tv2+ ; tv3a <- convert tv3+ ; return $ A.ComputingInst (Just lhs) (A.RsV $ A.ShuffleVector tv1a tv2a tv3a) + }+ I.I_shufflevector_P tv1 tv2 tv3 lhs-> + do { tv1a <- convert tv1+ ; tv2a <- convert tv2+ ; tv3a <- convert tv3+ ; return $ A.ComputingInst (Just lhs) (A.RsV $ A.ShuffleVector tv1a tv2a tv3a) + }+ I.I_insertvalue vtv tv idx lhs-> + do { vtva <- convert vtv+ ; tva <- convert tv+ ; return $ A.ComputingInst (Just lhs) $ A.RiV $ A.InsertValue vtva tva idx + }+ I.I_call_fun tc cc pa cstype fn ap fna lhs-> + do { csa <- convert (I.CsFun cc pa cstype fn ap fna)+ ; return $ A.ComputingInst lhs $ A.Call tc csa + }+ I.I_call_other tc cs lhs->+ do { csa <- convert cs+ ; return $ A.ComputingInst lhs $ A.Call tc csa + }+ I.I_llvm_dbg_declare ap ->+ do { apa <- mapM convert ap+ ; return $ A.ComputingInst Nothing $ A.Call A.TcNon $ A.CsFun Nothing [] A.Tvoid (A.FunNameGlobal $ A.GolG $ A.GlobalIdAlphaNum "llvm.dbg.declare")+ apa []+ }+ I.I_llvm_dbg_value ap ->+ do { apa <- mapM convert ap+ ; return $ A.ComputingInst Nothing $ A.Call A.TcNon $ A.CsFun Nothing [] A.Tvoid (A.FunNameGlobal $ A.GolG $ A.GlobalIdAlphaNum "llvm.dbg.value")+ apa []+ } + I.I_llvm_memcpy memLen tv1 tv2 tv3 tv4 tv5 -> + do { (A.Typed t1 v1) <- convert tv1+ ; (A.Typed t2 v2) <- convert tv2+ ; (A.Typed t3 v3) <- convert tv3+ ; (A.Typed t4 v4) <- convert tv4+ ; (A.Typed t5 v5) <- convert tv5+ ; let nm = case memLen of+ I.MemLenI32 -> "llvm.memcpy.p0i8.p0i8.i32"+ I.MemLenI64 -> "llvm.memcpy.p0i8.p0i8.i64"+ ; return $ A.ComputingInst Nothing $ A.Call A.TcNon $ A.CsFun Nothing [] A.Tvoid (A.FunNameGlobal $ A.GolG $ A.GlobalIdAlphaNum nm) + [A.ActualParamData t1 [] Nothing v1 []+ ,A.ActualParamData t2 [] Nothing v2 []+ ,A.ActualParamData t3 [] Nothing v3 []+ ,A.ActualParamData t4 [] Nothing v4 []+ ,A.ActualParamData t5 [] Nothing v5 []+ ] []+ } + +instance Conversion I.ActualParam (Rm A.ActualParam) where+ convert x = case x of+ (I.ActualParamData t pa1 ma v pa2) -> do { va <- convert v + ; return $ A.ActualParamData (tconvert () t) pa1 ma va pa2+ }+ (I.ActualParamLabel t pa1 ma v pa2) -> do { va <- convert v + ; return $ A.ActualParamData (tconvert () t) pa1 ma va pa2+ }+ (I.ActualParamMeta mc) -> Md.liftM (A.ActualParamMeta) (convert mc)++instance Conversion I.Aliasee (Rm A.Aliasee) where+ convert (I.AtV tv) = Md.liftM A.AtV (convert tv)+ convert (I.Ac a) = Md.liftM A.Ac (convert a)+ convert (I.AcV a) = Md.liftM A.Ac (convert a) + convert (I.Agep a) = Md.liftM A.AgEp (convert a)+ convert (I.AgepV a) = Md.liftM A.AgEp (convert a) ++instance Conversion I.Prefix (Rm A.Prefix) where+ convert (I.Prefix n) = Md.liftM A.Prefix (convert n)++instance Conversion I.Prologue (Rm A.Prologue) where+ convert (I.Prologue n) = Md.liftM A.Prologue (convert n)++instance Conversion I.TypedConstOrNull (Rm A.TypedConstOrNull) where+ convert x = case x of+ I.TypedConst tv -> Md.liftM A.TypedConst (convert tv)+ I.UntypedNull -> return A.UntypedNull++instance Conversion I.FunctionPrototype (Rm A.FunctionPrototype) where+ convert (I.FunctionPrototype f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f10a f11 f12 f13 f14) =+ do { f13' <- convert f13+ ; f14' <- convert f14+ ; return $ A.FunctionPrototype f0 f1 f2 f3 f4 (tconvert () f5) + f6 (tconvert () f7) f8 f9 f10 f10a f11 f12 f13' f14'+ }+++instance Conversion I.PhiInst (Rm A.PhiInst) where+ convert (I.PhiInst mg t branches) = + Md.liftM (A.PhiInst (Just mg) (tconvert () t)) + (mapM (pairM convert convert_to_PercentLabel) branches)+++instance Conversion I.TerminatorInst (Rm A.TerminatorInst) where+ convert (I.RetVoid) = return A.RetVoid+ convert (I.Return tvs) = Md.liftM A.Return (mapM convert tvs)+ convert (I.Br t) = Md.liftM A.Br (convert_to_TargetLabel t)+ convert (I.Cbr cnd t f) = Md.liftM3 A.Cbr (convert cnd) (convert_to_TargetLabel t) (convert_to_TargetLabel f)+ convert (I.IndirectBr cnd bs) = Md.liftM2 A.IndirectBr (convert cnd) (mapM convert_to_TargetLabel bs)+ convert (I.Switch cnd d cases) = Md.liftM3 A.Switch (convert cnd) (convert_to_TargetLabel d) + (mapM (pairM convert convert_to_TargetLabel) cases)+ convert (I.Invoke cs t f mg) = Md.liftM3 (A.Invoke mg) (convert cs) (convert_to_TargetLabel t) (convert_to_TargetLabel f)+ convert (I.InvokeCmd cs t f) = Md.liftM3 (A.Invoke Nothing) (convert cs) (convert_to_TargetLabel t) (convert_to_TargetLabel f)+ convert (I.Resume tv) = Md.liftM A.Resume (convert tv)+ convert I.Unreachable = return A.Unreachable+ convert I.Unwind = return A.Unwind++instance Conversion I.Dbg (Rm A.Dbg) where+ convert (I.Dbg mv mc) = Md.liftM2 A.Dbg (convert mv) (convert mc)++instance Conversion I.PhiInstWithDbg (Rm A.PhiInstWithDbg) where+ convert (I.PhiInstWithDbg ins dbgs) = Md.liftM2 A.PhiInstWithDbg (convert ins) (mapM convert dbgs)++instance Conversion I.CInstWithDbg (Rm A.ComputingInstWithDbg) where+ convert (I.CInstWithDbg ins dbgs) = Md.liftM2 A.ComputingInstWithDbg (convert ins) (mapM convert dbgs)++instance Conversion I.TerminatorInstWithDbg (Rm A.TerminatorInstWithDbg) where+ convert (I.TerminatorInstWithDbg term dbgs) = Md.liftM2 A.TerminatorInstWithDbg (convert term) (mapM convert dbgs)+ + + +instance Conversion I.TlTriple (Rm A.TlTriple) where+ convert (I.TlTriple x) = return (A.TlTriple x)++instance Conversion I.TlDataLayout (Rm A.TlDataLayout) where+ convert (I.TlDataLayout x) = return (A.TlDataLayout x)++instance Conversion I.TlAlias (Rm A.TlAlias) where + convert (I.TlAlias g v dll tlm na l a) = convert a >>= return . (A.TlAlias g v dll tlm na l)++instance Conversion I.TlDbgInit (Rm A.TlDbgInit) where+ convert (I.TlDbgInit s i) = return (A.TlDbgInit s i)+ +instance Conversion I.TlStandaloneMd (Rm A.TlStandaloneMd) where + convert (I.TlStandaloneMd s tv) = convert tv >>= return . (A.TlStandaloneMd s)++instance Conversion I.TlNamedMd (Rm A.TlNamedMd) where + convert (I.TlNamedMd m ns) = do { m' <- convert m+ ; ns' <- mapM convert ns+ ; return $ A.TlNamedMd m' ns'+ }+ +instance Conversion I.TlDeclare (Rm A.TlDeclare) where + convert (I.TlDeclare f) = convert f >>= return . A.TlDeclare+ +instance Conversion (I.TlDefine a) (Rm A.TlDefine) where+ convert (I.TlDefine f elbl g) = + do { (bl, bm) <- graphToBlocks g+ ; f' <- convert f+ ; elbla <- convert elbl+ ; let entryblk = case M.lookup elbla bm of+ Just x -> x+ Nothing -> error $ "irrefutable: entry block " ++ show elbl ++ " does not exist."+ ; let bs'' = entryblk:(filter (\x -> x /= entryblk) bl) + ; return $ A.TlDefine f' bs''+ } -- TODO: this method will NOT emit the new nodes generated by hoopl passes, it should be fixed ASAP.++ +instance Conversion I.TlGlobal (Rm A.TlGlobal) where+ convert x = case x of+ (I.TlGlobalDtype a1 a2 a3 a4 a5 a6 a7 a8 a8a a9 a10 a11 a12 a13) ->+ do { a10a <- maybeM convert a10+ ; return $ A.TlGlobal a1 a2 a3 a4 a5 a6 (fmap (tconvert ()) a7) + a8 a8a (tconvert () a9) a10a a11 a12 a13+ }+ (I.TlGlobalOpaque a1 a2 a3 a4 a5 a6 a7 a8 a8a a9 a10 a11 a12 a13) ->+ do { a10a <- maybeM convert a10+ ; return $ A.TlGlobal a1 a2 a3 a4 a5 a6 (fmap (tconvert ()) a7) + a8 a8a (tconvert () a9) a10a a11 a12 a13+ }+ +instance Conversion I.TlTypeDef (Rm A.TlTypeDef) where + convert x = case x of+ (I.TlFunTypeDef lid t) -> return (A.TlTypeDef lid (tconvert () t))+ (I.TlDatTypeDef lid t) -> return (A.TlTypeDef lid (tconvert () t))+ (I.TlOpqTypeDef lid t) -> return (A.TlTypeDef lid (tconvert () t))++instance Conversion I.TlDepLibs (Rm A.TlDepLibs) where + convert (I.TlDepLibs s) = return (A.TlDepLibs s)+ +instance Conversion I.TlUnamedType (Rm A.TlUnamedType) where + convert (I.TlUnamedType i t) = return (A.TlUnamedType i (tconvert () t))+ +instance Conversion I.TlModuleAsm (Rm A.TlModuleAsm) where + convert (I.TlModuleAsm s) = return (A.TlModuleAsm s)++instance Conversion I.TlAttribute (Rm A.TlAttribute) where+ convert (I.TlAttribute n l) = return (A.TlAttribute n l)+ +instance Conversion I.TlComdat (Rm A.TlComdat) where + convert (I.TlComdat l s) = return (A.TlComdat l s)++ +type Pblock = (A.BlockLabel, [A.PhiInstWithDbg], [A.ComputingInstWithDbg])++getLabelId :: A.BlockLabel -> A.LabelId+getLabelId (A.ImplicitBlockLabel _) = error "ImplicitBlockLabel should be normalized"+getLabelId (A.ExplicitBlockLabel l) = l++convertNode :: I.Node a e x -> Rm ([A.Block], M.Map A.LabelId A.Block, Maybe Pblock)+ -> Rm ([A.Block], M.Map A.LabelId A.Block, Maybe Pblock)+convertNode (I.Nlabel a) p = do { (bl, bs, Nothing) <- p+ ; a' <- convert_to_BlockLabel a+ ; return (bl, bs, Just (a', [], []))+ }+convertNode (I.Pinst a) p = do { (bl, bs, Just (pb, phis, [])) <- p+ ; a' <- convert a+ ; return (bl, bs, Just (pb, a':phis, []))+ }+convertNode (I.Cinst a) p = do { (bl, bs, Just (pb, phis, cs)) <- p+ ; a' <- convert a+ ; return (bl, bs, Just (pb, phis, a':cs))+ }+convertNode (I.Comment a) p = do { (bl, bs, Just (pb, phis, cs)) <- p+ ; return (bl, bs, Just (pb, phis, (A.ComputingInstWithComment a):cs))+ }+convertNode (I.Tinst a) p = do { (bl, bs, pb) <- p+ ; a' <- convert a+ ; case pb of+ Nothing -> error "irrefutable"+ Just (l, phis, cs) ->+ let blk = A.Block l (reverse phis) (reverse cs) a'+ in return (blk:bl, M.insert (getLabelId l) blk bs, Nothing)+ }+convertNode (I.Additional _) _ = error "irrefutable:Additional node should be converted to LLVM node" + +graphToBlocks :: H.Graph (I.Node a) H.C H.C -> Rm ([A.Block], M.Map A.LabelId A.Block)+graphToBlocks g = do { (bl, bs, Nothing) <- H.foldGraphNodes convertNode g (return ([], M.empty, Nothing))+ ; return (reverse bl, bs)+ }++toplevel2Ast :: I.Toplevel a -> Rm A.Toplevel+toplevel2Ast (I.ToplevelTriple q) = Md.liftM A.ToplevelTriple (convert q)+toplevel2Ast (I.ToplevelDataLayout q) = Md.liftM A.ToplevelDataLayout (convert q)+toplevel2Ast (I.ToplevelAlias g) = Md.liftM A.ToplevelAlias (convert g)+toplevel2Ast (I.ToplevelDbgInit s) = Md.liftM A.ToplevelDbgInit (convert s)+toplevel2Ast (I.ToplevelStandaloneMd s) = Md.liftM (A.ToplevelStandaloneMd) (convert s)+toplevel2Ast (I.ToplevelNamedMd m) = Md.liftM A.ToplevelNamedMd (convert m) +toplevel2Ast (I.ToplevelDeclare f) = Md.liftM A.ToplevelDeclare (convert f)+toplevel2Ast (I.ToplevelDefine f) = Md.liftM A.ToplevelDefine (convert f)+toplevel2Ast (I.ToplevelGlobal s) = Md.liftM A.ToplevelGlobal (convert s)+toplevel2Ast (I.ToplevelTypeDef t) = Md.liftM A.ToplevelTypeDef (convert t)+toplevel2Ast (I.ToplevelDepLibs qs) = Md.liftM A.ToplevelDepLibs (convert qs)+toplevel2Ast (I.ToplevelUnamedType i) = Md.liftM A.ToplevelUnamedType (convert i)+toplevel2Ast (I.ToplevelModuleAsm q) = Md.liftM A.ToplevelModuleAsm (convert q)+toplevel2Ast (I.ToplevelComdat l) = Md.liftM A.ToplevelComdat (convert l)+toplevel2Ast (I.ToplevelAttribute n) = Md.liftM A.ToplevelAttribute (convert n)++irToAst :: M.Map H.Label A.LabelId -> I.Module a -> A.Module+irToAst iLm (I.Module ts) = runReader (Md.liftM A.Module (mapM toplevel2Ast ts)) iLm
+ src/Llvm/Data/Conversion/LabelMapM.hs view
@@ -0,0 +1,77 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE TemplateHaskell #-}++module Llvm.Data.Conversion.LabelMapM+ (IdLabelMap,labelFor,LabelMapM(..),runLabelMapM,emptyIdLabelMap+ ,typeDefs,a2h,invertMap)+ where+import qualified Compiler.Hoopl as H+import qualified Data.Map as M+import qualified Llvm.Data.Ast as A+import Control.Applicative+import Control.Monad (ap, liftM)+#ifdef DEBUG+import Debug.Trace+import Llvm.Data.AsmPrint+import Llvm.Data.AstWriter+#endif++#define FLC (I.FileLoc $(I.srcLoc))++{-+-- LabelMapM monad is a CheckingFuelMonad with a data structure IdLabelMap to track+-- the mapping between LLVM labels and Hoopl labels and the original order LLVM labels+-- the mapping will be used to convert Hoopl labels back to LLVM labels to make +-- llvm-as happy+-}++data IdLabelMap =+ IdLabelMap+ { a2h :: M.Map A.LabelId H.Label+ -- | readonly value, it should be converted to a reader monad later+ , typedefs :: M.Map A.LocalId A.Type + } deriving (Show)++data LabelMapM m a = LabelMapM { unIlM :: IdLabelMap -> m (IdLabelMap, a) }++instance Functor m => Functor (LabelMapM m) where + fmap f mla = LabelMapM $ \iLm -> let ma = unIlM mla iLm + fx = \(im, a) -> (im, f a) + in fmap fx ma + +instance (Functor m, Applicative m, Monad m, H.UniqueMonad m) => Applicative (LabelMapM m) where + pure = return+ (<*>) = ap + +-- | we need to get a fresh Hoopl label for each LLVM label, so we use Hoopl Unique Monad+instance (Applicative m, H.UniqueMonad m) => Monad (LabelMapM m) where+ return x = LabelMapM $ \iLm -> return (iLm, x)+ iLmM >>= k = LabelMapM $ \iLm -> unIlM iLmM iLm >>= \(iLm1, x) -> unIlM (k x) iLm1+++labelFor :: H.UniqueMonad m => A.LabelId -> LabelMapM m H.Label+labelFor al = LabelMapM $ \iLm -> case M.lookup al (a2h iLm) of+ Just hl -> return (iLm, hl)+ Nothing -> do { hl <- H.freshLabel+ ; let a2h' = M.insert al hl (a2h iLm)+ ; return (iLm { a2h = a2h'}, hl)+ }++typeDefs :: H.UniqueMonad m => LabelMapM m (M.Map A.LocalId A.Type)+typeDefs = LabelMapM $ \iLm -> return (iLm, typedefs iLm)++revertMap :: A.LabelId -> A.BlockLabel+revertMap (A.LabelNumber _) = error "irrefutable"+revertMap x = A.ExplicitBlockLabel x++emptyIdLabelMap td = IdLabelMap { a2h = M.empty, typedefs = td}++runLabelMapM :: H.UniqueMonad m => IdLabelMap -> LabelMapM m a -> m (IdLabelMap, a)+runLabelMapM iLm (LabelMapM f) = f iLm++invertMap :: (Ord k, Ord v) => M.Map k v -> M.Map v k+invertMap m = foldl (\p (k,v) -> if M.member v p then+ error $ "irrefutable error in invertMap, the values are not unique"+ else + M.insert v k p+ ) M.empty (M.toList m)
+ src/Llvm/Data/Conversion/TypeConversion.hs view
@@ -0,0 +1,350 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Llvm.Data.Conversion.TypeConversion where++import qualified Llvm.Data.Type as A+import qualified Llvm.Data.IrType as I+import qualified Data.Map as M+import Data.Either ++#define FLC (I.FileLoc $(I.srcLoc))++type MP = M.Map A.LocalId A.Type++class TypeConversion mp l1 l2 where+ tconvert :: mp -> l1 -> l2+ +{-Ast Type to Ir type conversion -}++instance TypeConversion () I.Dtype A.Type where+ tconvert _ t = case t of+ I.DtypeScalarI x -> tconvert () x+ I.DtypeScalarF x -> tconvert () x+ I.DtypeScalarP x -> tconvert () x+ I.DtypeVectorI x -> tconvert () x+ I.DtypeVectorF x -> tconvert () x+ I.DtypeVectorP x -> tconvert () x+ I.DtypeRecordD x -> tconvert () x+ I.DtypeFirstClassD x -> tconvert () x++instance TypeConversion () I.ScalarType A.Type where+ tconvert _ t = case t of+ I.ScalarTypeI x -> tconvert () x+ I.ScalarTypeF x -> tconvert () x+ I.ScalarTypeP x -> tconvert () x++instance TypeConversion () (I.IntOrPtrType I.ScalarB) A.Type where+ tconvert _ t = case t of+ I.IntOrPtrTypeI x -> tconvert () x+ I.IntOrPtrTypeP x -> tconvert () x++instance TypeConversion () (I.IntOrPtrType I.VectorB) A.Type where+ tconvert _ t = case t of+ I.IntOrPtrTypeI x -> tconvert () x+ I.IntOrPtrTypeP x -> tconvert () x++instance TypeConversion () (Either I.Rtype (I.Type I.CodeFunB I.X)) A.Type where+ tconvert _ (Left e) = tconvert () e+ tconvert _ (Right e) = tconvert () (I.Tpointer (I.ucast e) 0)++instance TypeConversion () I.FormalParam A.FormalParam where+ tconvert _ (I.FormalParamData dt pa1 ma fp pa2) = A.FormalParamData (tconvert () dt) pa1 ma fp pa2+ tconvert _ (I.FormalParamMeta mk fp) = A.FormalParamMeta (tconvert () mk) fp++instance TypeConversion () I.FormalParamList A.FormalParamList where+ tconvert _ (I.FormalParamList l ma fas) = A.FormalParamList (fmap (tconvert ()) l) ma fas++instance TypeConversion MP A.FormalParam I.FormalParam where+ tconvert mp (A.FormalParamData dt pa1 ma fp pa2) = + I.FormalParamData (I.dcast FLC ((tconvert mp dt)::I.Utype)) pa1 ma fp pa2+ tconvert mp (A.FormalParamMeta mk fp) = I.FormalParamMeta (tconvert mp mk) fp++instance TypeConversion MP A.FormalParamList I.FormalParamList where+ tconvert mp (A.FormalParamList l ma fas) = I.FormalParamList (fmap (tconvert mp) l) ma fas++instance TypeConversion () I.Rtype A.Type where + tconvert _ t = case t of+ I.RtypeScalarI x -> tconvert () x+ I.RtypeScalarF x -> tconvert () x + I.RtypeScalarP x -> tconvert () x + I.RtypeVectorI x -> tconvert () x+ I.RtypeVectorF x -> tconvert () x+ I.RtypeVectorP x -> tconvert () x+ I.RtypeRecordD x -> tconvert () x+ I.RtypeFirstClassD x -> tconvert () x + I.RtypeVoidU _ -> A.Tvoid + +instance TypeConversion () I.Etype A.Type where+ tconvert _ t = case t of+ I.EtypeScalarI x -> tconvert () x + I.EtypeScalarF x -> tconvert () x + I.EtypeScalarP x -> tconvert () x + I.EtypeVectorI x -> tconvert () x+ I.EtypeVectorF x -> tconvert () x + I.EtypeVectorP x -> tconvert () x + I.EtypeRecordD x -> tconvert () x+ I.EtypeOpaqueD x -> tconvert () x+ I.EtypeFunX x -> tconvert () x+ +instance TypeConversion () I.Ftype A.Type where+ tconvert _ t = case t of+ I.FtypeScalarI x -> tconvert () x+ I.FtypeScalarF x -> tconvert () x + I.FtypeScalarP x -> tconvert () x + I.FtypeVectorI x -> tconvert () x+ I.FtypeVectorF x -> tconvert () x + I.FtypeVectorP x -> tconvert () x + I.FtypeFirstClassD x -> tconvert () x+++instance TypeConversion MP A.TypeParamList I.TypeParamList where+ tconvert mp (A.TypeParamList l ma) = + let (l1::[I.Utype]) = fmap (tconvert mp) l+ in I.TypeParamList (fmap (I.dcast FLC) l1) ma++instance TypeConversion () I.TypeParamList A.TypeParamList where+ tconvert _ (I.TypeParamList l ma) = A.TypeParamList (fmap (tconvert ()) l) ma++instance TypeConversion MP A.Type I.Utype where+ tconvert _ (A.Tprimitive et) = case et of + A.TpI n -> I.UtypeScalarI $ I.TpI n+ A.TpF n -> I.UtypeScalarF $ I.TpF n+ A.TpV n -> I.UtypeScalarI $ I.TpV n+ A.TpHalf -> I.UtypeScalarF $ I.TpHalf + A.TpFloat -> I.UtypeScalarF $ I.TpFloat+ A.TpDouble -> I.UtypeScalarF $ I.TpDouble+ A.TpFp128 -> I.UtypeScalarF $ I.TpFp128 + A.TpX86Fp80 -> I.UtypeScalarF $ I.TpX86Fp80+ A.TpPpcFp128 -> I.UtypeScalarF $ I.TpPpcFp128+ A.TpX86Mmx -> I.UtypeScalarI $ I.TpX86Mmx+ A.TpLabel -> I.UtypeLabelX $ I.TpLabel+ tconvert _ A.Tvoid = I.ucast I.Tvoid+ tconvert mp (A.Tarray n et) = + let (eta::I.Utype) = tconvert mp et+ in case eta of+ I.UtypeOpaqueD _ -> I.UtypeOpaqueD $ I.Topaque_array n (I.dcast FLC eta)+ _ -> I.UtypeRecordD $ I.Tarray n (I.dcast FLC eta)+ tconvert mp (A.Tvector n et) = case matchType mp et of+ Tk_ScalarI -> let et1 = I.dcast FLC $ ((tconvert mp et)::I.Utype)+ in I.UtypeVectorI $ I.TvectorI n et1+ Tk_ScalarF -> let et1 = I.dcast FLC $ ((tconvert mp et)::I.Utype)+ in I.UtypeVectorF $ I.TvectorF n et1+ Tk_ScalarP -> let et1 = I.dcast FLC $ ((tconvert mp et)::I.Utype)+ in I.UtypeVectorP $ I.TvectorP n et1+ _ -> I.errorLoc FLC "$$$$$$$$$"+ tconvert mp (A.Tstruct pk dts) = + let (dts0::[I.Utype]) = fmap (tconvert mp) dts+ dts1 = fmap (\e -> case e of+ I.UtypeOpaqueD ea -> Right ea+ _ -> Left ((I.dcast FLC e)::I.Dtype)+ ) dts0+ in if any isRight dts1 then I.UtypeOpaqueD (I.Topaque_struct pk dts1)+ else I.UtypeRecordD (I.Tstruct pk $ lefts dts1)+ tconvert mp (A.Tpointer et as) = let n1 = case as of+ A.AddrSpace n -> n+ A.AddrSpaceUnspecified -> 0 + et1 = I.dcast FLC ((tconvert mp et)::I.Utype) + in I.UtypeScalarP $ I.Tpointer et1 n1+ tconvert mp A.Topaque = I.ucast $ I.Topaque+ tconvert mp tn@(A.Tname s) = case getTk mp (castTnameToLocalId tn) of + Tk_ScalarI -> I.ucast $ I.TnameScalarI s+ Tk_ScalarF -> I.ucast $ I.TnameScalarF s+ Tk_ScalarP -> I.ucast $ I.TnameScalarP s + Tk_VectorI -> I.ucast $ I.TnameVectorI s+ Tk_VectorF -> I.ucast $ I.TnameVectorF s+ Tk_VectorP -> I.ucast $ I.TnameVectorP s+ Tk_RecordD -> I.ucast $ I.TnameRecordD s+ Tk_CodeFunX -> I.ucast $ I.TnameCodeFunX s+ Tk_Opaque -> I.ucast $ I.TnameOpaqueD s+ tconvert mp tn@(A.TquoteName s) = case getTk mp (castTnameToLocalId tn) of + Tk_ScalarI -> I.ucast $ I.TquoteNameScalarI s+ Tk_ScalarF -> I.ucast $ I.TquoteNameScalarF s + Tk_ScalarP -> I.ucast $ I.TquoteNameScalarP s + Tk_VectorI -> I.ucast $ I.TquoteNameVectorI s+ Tk_VectorF -> I.ucast $ I.TquoteNameVectorF s + Tk_VectorP -> I.ucast $ I.TquoteNameVectorP s + Tk_RecordD -> I.ucast $ I.TquoteNameRecordD s+ Tk_CodeFunX -> I.ucast $ I.TquoteNameCodeFunX s+ Tk_Opaque -> I.ucast $ I.TquoteNameOpaqueD s + tconvert mp tn@(A.Tno s) = case getTk mp (castTnameToLocalId tn) of + Tk_ScalarI -> I.ucast $ I.TnoScalarI s+ Tk_ScalarF -> I.ucast $ I.TnoScalarF s + Tk_ScalarP -> I.ucast $ I.TnoScalarP s + Tk_VectorI -> I.ucast $ I.TnoVectorI s+ Tk_VectorF -> I.ucast $ I.TnoVectorF s+ Tk_VectorP -> I.ucast $ I.TnoVectorP s+ Tk_RecordD -> I.ucast $ I.TnoRecordD s+ Tk_CodeFunX -> I.ucast $ I.TnoCodeFunX s+ Tk_Opaque -> I.ucast $ I.TnoOpaqueD s+ tconvert mp (A.Tfunction rt tp fa) = + let rt1 = I.dcast FLC ((tconvert mp rt)::I.Utype)+ in I.UtypeFunX (I.Tfunction rt1 (tconvert mp tp) fa)+ + +instance TypeConversion MP A.AddrSpace I.AddrSpace where + tconvert _ (A.AddrSpace n) = n+ tconvert _ (A.AddrSpaceUnspecified) = 0++instance TypeConversion () I.AddrSpace A.AddrSpace where + tconvert _ 0 = A.AddrSpaceUnspecified+ tconvert _ n = A.AddrSpace n+ +instance TypeConversion MP A.MetaKind I.MetaKind where+ tconvert mp x = case x of+ A.Mtype e -> I.Mtype (tconvert mp e)+ A.Mmetadata -> I.Mmetadata++ +instance TypeConversion () I.MetaKind A.MetaKind where+ tconvert _ x = case x of+ I.Mtype e -> A.Mtype (tconvert () e)+ I.Mmetadata -> A.Mmetadata+++instance TypeConversion () (I.Type s r) A.Type where -- Primitive where+ tconvert _ t = case t of+ I.TpI n -> A.Tprimitive $ A.TpI n+ I.TpF n -> A.Tprimitive $ A.TpF n+ I.TpV n -> A.Tprimitive $ A.TpV n+ I.TpHalf -> A.Tprimitive $ A.TpHalf + I.TpFloat -> A.Tprimitive $ A.TpFloat+ I.TpDouble -> A.Tprimitive $ A.TpDouble+ I.TpFp128 -> A.Tprimitive $ A.TpFp128 + I.TpX86Fp80 -> A.Tprimitive $ A.TpX86Fp80+ I.TpPpcFp128 -> A.Tprimitive $ A.TpPpcFp128+ I.TpX86Mmx -> A.Tprimitive $ A.TpX86Mmx+ I.Tpointer el 0 -> A.Tpointer (tconvert () el) A.AddrSpaceUnspecified+ I.Tpointer el as -> A.Tpointer (tconvert () el) (A.AddrSpace as)+ + I.Tarray n dt -> A.Tarray n (tconvert () dt)+ I.Tstruct p dts -> A.Tstruct p (fmap (tconvert ()) dts)+ + I.Tfirst_class_array n dt -> A.Tarray n (tconvert () dt)+ I.Tfirst_class_struct p dts -> A.Tstruct p (fmap (tconvert ()) dts)+ + I.Tfirst_class_no n -> A.Tno n+ I.Tfirst_class_name s -> A.Tname s+ I.Tfirst_class_quoteName s -> A.TquoteName s++ I.Topaque_struct p dts -> A.Tstruct p (fmap (either (tconvert()) (tconvert ())) dts)+ I.Topaque_array n dt -> A.Tarray n (tconvert () dt)+ + I.TvectorI n dt -> A.Tvector n (tconvert () dt)+ I.TvectorF n dt -> A.Tvector n (tconvert () dt) + I.TvectorP n dt -> A.Tvector n (tconvert () dt) + I.Tvoid -> A.Tvoid+ + I.TnoScalarI n -> A.Tno n+ I.TnameScalarI s -> A.Tname s+ I.TquoteNameScalarI s -> A.TquoteName s+ + I.TnoScalarF n -> A.Tno n+ I.TnameScalarF s -> A.Tname s+ I.TquoteNameScalarF s -> A.TquoteName s++ I.TnoScalarP n -> A.Tno n+ I.TnameScalarP s -> A.Tname s+ I.TquoteNameScalarP s -> A.TquoteName s++ I.TnoVectorI n -> A.Tno n+ I.TnameVectorI s -> A.Tname s+ I.TquoteNameVectorI s -> A.TquoteName s+ + I.TnoVectorF n -> A.Tno n+ I.TnameVectorF s -> A.Tname s+ I.TquoteNameVectorF s -> A.TquoteName s++ I.TnoVectorP n -> A.Tno n+ I.TnameVectorP s -> A.Tname s+ I.TquoteNameVectorP s -> A.TquoteName s++ I.TnoRecordD n -> A.Tno n+ I.TnameRecordD s -> A.Tname s+ I.TquoteNameRecordD s -> A.TquoteName s+ + I.TnoCodeFunX n -> A.Tno n+ I.TnameCodeFunX s -> A.Tname s+ I.TquoteNameCodeFunX s -> A.TquoteName s++ I.TnoOpaqueD n -> A.Tno n+ I.TnameOpaqueD s -> A.Tname s+ I.TquoteNameOpaqueD s -> A.TquoteName s++ I.Tfunction rt tp fa -> A.Tfunction (tconvert () rt) (tconvert () tp) fa+ I.TpNull -> A.Tprimitive A.TpNull+ I.TpLabel -> A.Tprimitive A.TpLabel+ I.Topaque -> A.Topaque++instance TypeConversion () I.Utype A.Type where+ tconvert _ t = case t of+ I.UtypeScalarI x -> tconvert () x+ I.UtypeScalarF x -> tconvert () x+ I.UtypeScalarP x -> tconvert () x+ I.UtypeVectorI x -> tconvert () x+ I.UtypeVectorF x -> tconvert () x+ I.UtypeVectorP x -> tconvert () x+ I.UtypeRecordD x -> tconvert () x+ I.UtypeFunX x -> tconvert () x+ I.UtypeLabelX x -> tconvert () x+ I.UtypeOpaqueD x -> tconvert () x+ I.UtypeVoidU x -> tconvert () x++data Tk = Tk_ScalarI+ | Tk_ScalarP+ | Tk_ScalarF+ | Tk_VectorI+ | Tk_VectorF + | Tk_VectorP + | Tk_RecordD+ | Tk_CodeFunX+ | Tk_CodeLabelX+ | Tk_Opaque+ + +getTk :: MP -> A.LocalId -> Tk+getTk mp lid = case M.lookup lid mp of + Nothing -> error $ "undefined " ++ show lid+ Just e -> matchType mp e++matchType :: MP -> A.Type -> Tk+matchType mp t = case t of+ A.Tprimitive e -> case e of+ A.TpI _ -> Tk_ScalarI+ A.TpF _ -> Tk_ScalarF+ A.TpV _ -> Tk_ScalarI+ A.TpHalf -> Tk_ScalarF+ A.TpFloat -> Tk_ScalarF+ A.TpDouble -> Tk_ScalarF+ A.TpFp128 -> Tk_ScalarF+ A.TpX86Fp80 -> Tk_ScalarF+ A.TpPpcFp128 -> Tk_ScalarF+ A.TpX86Mmx -> Tk_ScalarI+ A.TpLabel -> Tk_CodeLabelX+ A.TpNull -> I.errorLoc FLC "TpNull"+ A.Tarray _ _ -> Tk_RecordD+ A.Tstruct _ _ -> Tk_RecordD+ A.Tpointer _ _ -> Tk_ScalarP+ A.Tfunction _ _ _ -> Tk_CodeFunX+ A.Tvector _ e -> let ek = matchType mp e+ in case ek of+ Tk_ScalarI -> Tk_VectorI+ Tk_ScalarF -> Tk_VectorF+ Tk_ScalarP -> Tk_VectorP+ _ -> error $ "RRRRRRR"+ A.Tname _ -> getTk mp (castTnameToLocalId t)+ A.TquoteName _ -> getTk mp (castTnameToLocalId t)+ A.Tno _ -> getTk mp (castTnameToLocalId t)+ A.Topaque -> Tk_Opaque+ _ -> I.errorLoc FLC (show t)+++castTnameToLocalId :: A.Type -> A.LocalId +castTnameToLocalId x = case x of+ A.Tname s -> A.LocalIdAlphaNum s+ A.TquoteName s -> A.LocalIdDqString s+ A.Tno s -> A.LocalIdNum s
+ src/Llvm/Data/CoreIr.hs view
@@ -0,0 +1,782 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Llvm.Data.CoreIr+ ( module Llvm.Data.CoreIr+ , module Llvm.Data.Shared+ , module Llvm.Data.IrType+ , module Data.Word+ , Label+ ) where+import Llvm.Data.Shared+import Llvm.Data.IrType+import Compiler.Hoopl (Label)+import Data.Int+import Data.Word (Word8, Word16, Word32, Word64)+import Data.DoubleWord++data NoWrap =+ -- | No Signed Wrap+ Nsw+ -- | No Unsigned Wrap+ | Nuw+ -- | No Signed and Unsigned Wrap+ | Nsuw deriving (Eq,Ord,Show)++data Exact = Exact deriving (Eq,Ord,Show)++data Conversion s v where {+ Trunc :: T (Type s I) v -> Type s I -> Conversion s v;+ Zext :: T (Type s I) v -> Type s I -> Conversion s v;+ Sext :: T (Type s I) v -> Type s I -> Conversion s v;+ FpTrunc :: T (Type s F) v -> Type s F -> Conversion s v;+ FpExt :: T (Type s F) v -> Type s F -> Conversion s v;+ FpToUi :: T (Type s F) v -> Type s I -> Conversion s v;+ FpToSi :: T (Type s F) v -> Type s I -> Conversion s v;+ UiToFp :: T (Type s I) v -> Type s F -> Conversion s v;+ SiToFp :: T (Type s I) v -> Type s F -> Conversion s v;+ PtrToInt :: T (Type s P) v -> Type s I -> Conversion s v;+ IntToPtr :: T (Type s I) v -> Type s P -> Conversion s v;+ Bitcast :: T Dtype v -> Dtype -> Conversion s v;+ AddrSpaceCast :: T (Type s P) v -> Type s P -> Conversion s v;+ } deriving (Eq, Ord, Show)++data GetElementPtr s v = GetElementPtr (IsOrIsNot InBounds) (T (Type s P) v) [T (Type s I) v]+ deriving (Eq,Ord,Show)++data Select s r v = Select (Either (T (Type ScalarB I) v) (T (Type s I) v)) (T (Type s r) v) (T (Type s r) v)+ deriving (Eq,Ord,Show)++data Icmp s v = Icmp IcmpOp (IntOrPtrType s) v v deriving (Eq,Ord,Show)++data Fcmp s v = Fcmp FcmpOp (Type s F) v v deriving (Eq,Ord,Show)++{- vector operations -}+data ShuffleVector r v = ShuffleVector (T (Type VectorB r) v) (T (Type VectorB r) v) (T (Type VectorB I) v)+ deriving (Eq,Ord,Show)++data ExtractElement r v = ExtractElement (T (Type VectorB r) v) (T (Type ScalarB I) v)+ deriving (Eq,Ord,Show)++data InsertElement r v = InsertElement (T (Type VectorB r) v) (T (Type ScalarB r) v) (T (Type ScalarB I) v)+ deriving (Eq,Ord,Show)++{- aggregate operations -}+data ExtractValue v = ExtractValue (T (Type RecordB D) v) [Word32] deriving (Eq,Ord,Show)++data InsertValue v = InsertValue (T (Type RecordB D) v) (T Dtype v) [Word32] deriving (Eq,Ord,Show)++data Const where {+ C_u8 :: Word8 -> Const;+ C_u16 :: Word16 -> Const;+ C_u32 :: Word32 -> Const;+ C_u64 :: Word64 -> Const;+ C_u96 :: Word96 -> Const;+ C_u128 :: Word128 -> Const;+ C_s8 :: Int8 -> Const;+ C_s16 :: Int16 -> Const;+ C_s32 :: Int32 -> Const;+ C_s64 :: Int64 -> Const;+ C_s96 :: Int96 -> Const;+ C_s128 :: Int128 -> Const;+ C_int :: String -> Const;+ C_uhex_int :: String -> Const;+ C_shex_int :: String -> Const;+ C_float :: String -> Const;+ C_null :: Const;+ C_undef :: Const;+ C_true :: Const;+ C_false :: Const;+ C_zeroinitializer :: Const;+ C_globalAddr :: GlobalId -> Const;+ C_str :: String -> Const;+ C_struct :: Packing -> [TypedConstOrNull] -> Const;+ C_vector :: [TypedConstOrNull] -> Const;+ C_vectorN :: Word32 -> TypedConstOrNull -> Const;+ C_array :: [TypedConstOrNull] -> Const;+ C_arrayN :: Word32 -> TypedConstOrNull -> Const;+ C_localId :: LocalId -> Const;+ C_labelId :: Label -> Const;+ C_block :: GlobalId -> Label -> Const;++ C_add :: Maybe NoWrap -> Type ScalarB I -> Const -> Const -> Const;+ C_sub :: Maybe NoWrap -> Type ScalarB I -> Const -> Const -> Const;+ C_mul :: Maybe NoWrap -> Type ScalarB I -> Const -> Const -> Const;+ C_udiv :: Maybe Exact -> Type ScalarB I -> Const -> Const -> Const;+ C_sdiv :: Maybe Exact -> Type ScalarB I -> Const -> Const -> Const;+ C_urem :: Type ScalarB I -> Const -> Const -> Const;+ C_srem :: Type ScalarB I -> Const -> Const -> Const;+ C_shl :: Maybe NoWrap -> Type ScalarB I -> Const -> Const -> Const;+ C_lshr :: Maybe Exact -> Type ScalarB I -> Const -> Const -> Const;+ C_ashr :: Maybe Exact -> Type ScalarB I -> Const -> Const -> Const;+ C_and :: Type ScalarB I -> Const -> Const -> Const;+ C_or :: Type ScalarB I -> Const -> Const -> Const;+ C_xor :: Type ScalarB I -> Const -> Const -> Const;++ C_add_V :: Maybe NoWrap -> Type VectorB I -> Const -> Const -> Const;+ C_sub_V :: Maybe NoWrap -> Type VectorB I -> Const -> Const -> Const;+ C_mul_V :: Maybe NoWrap -> Type VectorB I -> Const -> Const -> Const;+ C_udiv_V :: Maybe Exact -> Type VectorB I -> Const -> Const -> Const;+ C_sdiv_V :: Maybe Exact -> Type VectorB I -> Const -> Const -> Const;+ C_urem_V :: Type VectorB I -> Const -> Const -> Const;+ C_srem_V :: Type VectorB I -> Const -> Const -> Const;+ C_shl_V :: Maybe NoWrap -> Type VectorB I -> Const -> Const -> Const;+ C_lshr_V :: Maybe Exact -> Type VectorB I -> Const -> Const -> Const;+ C_ashr_V :: Maybe Exact -> Type VectorB I -> Const -> Const -> Const;+ C_and_V :: Type VectorB I -> Const -> Const -> Const;+ C_or_V :: Type VectorB I -> Const -> Const -> Const;+ C_xor_V :: Type VectorB I -> Const -> Const -> Const;++ C_fadd :: FastMathFlags -> Type ScalarB F -> Const -> Const -> Const;+ C_fsub :: FastMathFlags -> Type ScalarB F -> Const -> Const -> Const;+ C_fmul :: FastMathFlags -> Type ScalarB F -> Const -> Const -> Const;+ C_fdiv :: FastMathFlags -> Type ScalarB F -> Const -> Const -> Const;+ C_frem :: FastMathFlags -> Type ScalarB F -> Const -> Const -> Const;++ C_fadd_V :: FastMathFlags -> Type VectorB F -> Const -> Const -> Const;+ C_fsub_V :: FastMathFlags -> Type VectorB F -> Const -> Const -> Const;+ C_fmul_V :: FastMathFlags -> Type VectorB F -> Const -> Const -> Const;+ C_fdiv_V :: FastMathFlags -> Type VectorB F -> Const -> Const -> Const;+ C_frem_V :: FastMathFlags -> Type VectorB F -> Const -> Const -> Const;++ C_trunc :: T (Type ScalarB I) Const -> Type ScalarB I -> Const;+ C_zext :: T (Type ScalarB I) Const -> Type ScalarB I -> Const;+ C_sext :: T (Type ScalarB I) Const -> Type ScalarB I -> Const;+ C_fptrunc :: T (Type ScalarB F) Const -> Type ScalarB F -> Const;+ C_fpext :: T (Type ScalarB F) Const -> Type ScalarB F -> Const;+ C_fptoui :: T (Type ScalarB F) Const -> Type ScalarB I -> Const;+ C_fptosi :: T (Type ScalarB F) Const -> Type ScalarB I -> Const;+ C_uitofp :: T (Type ScalarB I) Const -> Type ScalarB F -> Const;+ C_sitofp :: T (Type ScalarB I) Const -> Type ScalarB F -> Const;+ C_ptrtoint :: T (Type ScalarB P) Const -> Type ScalarB I -> Const;+ C_inttoptr :: T (Type ScalarB I) Const -> Type ScalarB P -> Const;+ C_bitcast :: T Dtype Const -> Dtype -> Const;+ C_addrspacecast :: T (Type ScalarB P) Const -> Type ScalarB P -> Const;++ C_trunc_V :: T (Type VectorB I) Const -> Type VectorB I -> Const;+ C_zext_V :: T (Type VectorB I) Const -> Type VectorB I -> Const;+ C_sext_V :: T (Type VectorB I) Const -> Type VectorB I -> Const;+ C_fptrunc_V :: T (Type VectorB F) Const -> Type VectorB F -> Const;+ C_fpext_V :: T (Type VectorB F) Const -> Type VectorB F -> Const;+ C_fptoui_V :: T (Type VectorB F) Const -> Type VectorB I -> Const;+ C_fptosi_V :: T (Type VectorB F) Const -> Type VectorB I -> Const;+ C_uitofp_V :: T (Type VectorB I) Const -> Type VectorB F -> Const;+ C_sitofp_V :: T (Type VectorB I) Const -> Type VectorB F -> Const;+ C_ptrtoint_V :: T (Type VectorB P) Const -> Type VectorB I -> Const;+ C_inttoptr_V :: T (Type VectorB I) Const -> Type VectorB P -> Const;+ C_addrspacecast_V :: T (Type VectorB P) Const -> Type VectorB P -> Const;++ C_getelementptr :: IsOrIsNot InBounds -> T (Type ScalarB P) Const -> [T (Type ScalarB I) Const] -> Const;+ C_getelementptr_V :: IsOrIsNot InBounds -> T (Type VectorB P) Const -> [T (Type VectorB I) Const] -> Const;++ C_select_I :: Select ScalarB I Const -> Const;+ C_select_F :: Select ScalarB F Const -> Const;+ C_select_P :: Select ScalarB P Const -> Const;++ C_select_First :: T (Type ScalarB I) Const -> T (Type FirstClassB D) Const -> T (Type FirstClassB D) Const -> Const;++ C_select_VI :: Select VectorB I Const -> Const;+ C_select_VF :: Select VectorB F Const -> Const;+ C_select_VP :: Select VectorB P Const -> Const;++ C_icmp :: Icmp ScalarB Const -> Const;+ C_icmp_V :: Icmp VectorB Const -> Const;++ C_fcmp :: Fcmp ScalarB Const -> Const;+ C_fcmp_V :: Fcmp VectorB Const -> Const;++ C_shufflevector_I :: ShuffleVector I Const -> Const;+ C_shufflevector_F :: ShuffleVector F Const -> Const;+ C_shufflevector_P :: ShuffleVector P Const -> Const;++ C_extractelement_I :: ExtractElement I Const -> Const;+ C_extractelement_F :: ExtractElement F Const -> Const;+ C_extractelement_P :: ExtractElement P Const -> Const;++ C_insertelement_I :: InsertElement I Const -> Const;+ C_insertelement_F :: InsertElement F Const -> Const;+ C_insertelement_P :: InsertElement P Const -> Const;++ C_extractvalue :: ExtractValue Const -> Const;+ C_insertvalue :: InsertValue Const -> Const;+ } deriving (Eq, Ord, Show)++data MdVar = MdVar String deriving (Eq,Ord,Show)+data MdNode = MdNode String deriving (Eq,Ord,Show)+data MetaConst = McStruct [MetaKindedConst]+ | McString DqString+ | McMn MdNode+ | McMv MdVar+ | McRef LocalId+ | McSimple Const+ deriving (Eq,Ord,Show)++data MetaKindedConst = MetaKindedConst MetaKind MetaConst+ | UnmetaKindedNull+ deriving (Eq, Ord, Show)++data FunName = FunNameGlobal GlobalOrLocalId+ | FunNameString String+ deriving (Eq,Ord,Show)++data CallSiteType = CallSiteRet Rtype+ | CallSiteFun (Type CodeFunB X) AddrSpace+ deriving (Eq, Ord, Show)++data CallSite = CsFun (Maybe CallConv) [ParamAttr] CallSiteType FunName [ActualParam] [FunAttr]+ | CsAsm CallSiteType (Maybe SideEffect) (Maybe AlignStack) AsmDialect DqString DqString [ActualParam] [FunAttr]+ | CsConversion [ParamAttr] CallSiteType (Conversion ScalarB Const) [ActualParam] [FunAttr]+ | CsConversionV [ParamAttr] CallSiteType (Conversion VectorB Const) [ActualParam] [FunAttr]+ deriving (Eq,Ord,Show)++data Clause = Catch (T Dtype Value)+ | Filter TypedConstOrNull+ | CcoS (Conversion ScalarB Value)+ | CcoV (Conversion VectorB Value)+ deriving (Eq,Ord,Show)++data PersFn = PersFnId GlobalOrLocalId+ | PersFnCastS (Conversion ScalarB GlobalOrLocalId)+ | PersFnCastV (Conversion VectorB GlobalOrLocalId)+ | PersFnUndef+ | PersFnNull+ | PersFnConst Const+ deriving (Eq, Ord, Show)++data Dbg = Dbg MdVar MetaConst deriving (Eq, Ord, Show)++data PhiInst = PhiInst LocalId Ftype [(Value, Label)] deriving (Eq, Ord, Show)++data PhiInstWithDbg = PhiInstWithDbg PhiInst [Dbg] deriving (Eq, Ord, Show)++i_alloca :: FileLoc -> CInst+i_alloca loc = I_alloca { result = errorLoc loc "please assign a new variable name"+ , inAllocaAttr = IsNot InAllocaAttr+ , dtype = errorLoc loc "please specify the allocated date type"+ , size = Nothing+ , alignment = Nothing+ }++i_getelementptr :: FileLoc -> CInst+i_getelementptr loc = I_getelementptr { result = errorLoc loc "please assign a new variable name"+ , inBounds = IsNot InBounds+ , pointer = errorLoc loc "please assign a pointer"+ , indices = []+ }+++i_store :: FileLoc -> CInst+i_store loc = I_store { volatile = IsNot Volatile+ , storedvalue = errorLoc loc "please specified the stored value"+ , pointer = errorLoc loc " please assign a pointer"+ , alignment = Nothing+ , nontemporal = Nothing+ }++data CInst where {+ I_alloca :: { inAllocaAttr :: IsOrIsNot InAllocaAttr+ , dtype :: Dtype+ , size :: Maybe (T (Type ScalarB I) Value)+ , alignment :: Maybe Alignment+ , result :: LocalId+ } -> CInst;++ I_load :: { volatile :: IsOrIsNot Volatile+ , pointer :: T (Type ScalarB P) Value+ , alignment :: Maybe Alignment+ , temporal :: Maybe Nontemporal+ , invariantLoad :: Maybe InvariantLoad+ , nonull :: Maybe Nonnull+ , result :: LocalId+ } -> CInst;++ I_loadatomic :: { atomicity :: Atomicity+ , volatile :: IsOrIsNot Volatile+ , pointer :: T (Type ScalarB P) Value+ , alignment :: Maybe Alignment+ , result :: LocalId+ } -> CInst;++ I_store :: { volatile :: IsOrIsNot Volatile+ , storedvalue :: T Dtype Value+ , pointer :: T (Type ScalarB P) Value+ , alignment :: Maybe Alignment+ , nontemporal :: Maybe Nontemporal + } -> CInst;++ I_storeatomic :: { atomicity :: Atomicity+ , volatile :: IsOrIsNot Volatile+ , storedvalue :: T Dtype Value+ , pointer :: T (Type ScalarB P) Value+ , alignment :: Maybe Alignment + } -> CInst;++ I_fence :: { singleThread :: IsOrIsNot SingleThread+ , ordering :: AtomicMemoryOrdering } -> CInst;++ I_cmpxchg_I :: { weak :: IsOrIsNot Weak+ , volatile :: IsOrIsNot Volatile+ , pointer :: T (Type ScalarB P) Value+ , cmpi :: T (Type ScalarB I) Value+ , newi :: T (Type ScalarB I) Value+ , singlethread :: IsOrIsNot SingleThread+ , success_ordering :: AtomicMemoryOrdering+ , failure_ordering :: AtomicMemoryOrdering+ , result :: LocalId } -> CInst;++ I_cmpxchg_F :: { weak :: IsOrIsNot Weak+ , volatile :: IsOrIsNot Volatile+ , pointer :: T (Type ScalarB P) Value+ , cmpf :: T (Type ScalarB F) Value+ , newf :: T (Type ScalarB F) Value+ , singlethread :: IsOrIsNot SingleThread+ , success_ordering :: AtomicMemoryOrdering+ , failure_ordering :: AtomicMemoryOrdering+ , result :: LocalId } -> CInst;++ I_cmpxchg_P :: { weak :: IsOrIsNot Weak+ , volatile :: IsOrIsNot Volatile+ , pointer :: T (Type ScalarB P) Value+ , cmpp :: T (Type ScalarB P) Value+ , newp :: T (Type ScalarB P) Value+ , singlethread :: IsOrIsNot SingleThread+ , success_ordering :: AtomicMemoryOrdering+ , failure_ordering :: AtomicMemoryOrdering+ , result :: LocalId } -> CInst;++ I_atomicrmw :: { volatile :: IsOrIsNot Volatile+ , atomicOp :: AtomicOp+ , pointer :: T (Type ScalarB P) Value+ , val :: T (Type ScalarB I) Value+ , singlethread :: IsOrIsNot SingleThread+ , ordering :: AtomicMemoryOrdering+ , result :: LocalId } -> CInst;++ I_call_fun :: { tailCall :: TailCall+ , callConv :: Maybe CallConv+ , paramAttrs :: [ParamAttr]+ , callSiteType :: CallSiteType+ , calleeName :: FunName+ , actualParams :: [ActualParam]+ , funAttrs :: [FunAttr]+ , callReturn :: Maybe LocalId } -> CInst;++ I_call_other :: { tailCall :: TailCall+ , callSite :: CallSite+ , callReturn :: Maybe LocalId } -> CInst;++ I_extractelement_I :: { vectorI :: T (Type VectorB I) Value+ , index :: T (Type ScalarB I) Value+ , result :: LocalId } -> CInst;++ I_extractelement_F :: { vectorF :: T (Type VectorB F) Value+ , index :: T (Type ScalarB I) Value+ , result :: LocalId } -> CInst;++ I_extractelement_P :: { vectorP :: T (Type VectorB P) Value+ , index :: T (Type ScalarB I) Value+ , result :: LocalId } -> CInst;++ I_insertelement_I :: { vectorI :: T (Type VectorB I) Value+ , elementI :: T (Type ScalarB I) Value+ , index :: T (Type ScalarB I) Value+ , result :: LocalId } -> CInst;++ I_insertelement_F :: { vectorF :: T (Type VectorB F) Value+ , elementF :: T (Type ScalarB F) Value+ , index :: T (Type ScalarB I) Value+ , result :: LocalId+ } -> CInst;++ I_insertelement_P :: { vectorP :: T (Type VectorB P) Value+ , elementP :: T (Type ScalarB P) Value+ , index :: T (Type ScalarB I) Value+ , result :: LocalId+ } -> CInst;++ I_shufflevector_I :: { vector1I :: T (Type VectorB I) Value+ , vector2I :: T (Type VectorB I) Value+ , vectorIdx :: T (Type VectorB I) Value+ , result :: LocalId+ } -> CInst;++ I_shufflevector_F :: { vector1F :: T (Type VectorB F) Value+ , vector2F :: T (Type VectorB F) Value+ , vectorIdx :: T (Type VectorB I) Value+ , result :: LocalId+ } -> CInst;++ I_shufflevector_P :: { vector1P :: T (Type VectorB P) Value+ , vector2P :: T (Type VectorB P) Value+ , vectorIdx :: T (Type VectorB I) Value+ , result :: LocalId+ } -> CInst;++ I_extractvalue :: T (Type RecordB D) Value -> [Word32] -> LocalId -> CInst;+ I_insertvalue :: T (Type RecordB D) Value -> T Dtype Value -> [Word32] -> LocalId -> CInst;++ I_va_arg :: { dv :: T Dtype Value + , typeD :: Dtype + , result :: LocalId + } -> CInst;+ + I_va_start :: { pointer :: T (Type ScalarB P) Value } -> CInst;+ I_va_end :: { pointer :: T (Type ScalarB P) Value } -> CInst;++ I_landingpad :: Dtype -> Dtype -> PersFn -> Maybe Cleanup -> [Clause] -> LocalId -> CInst;++ I_getelementptr :: { inBounds :: IsOrIsNot InBounds+ , pointer :: T (Type ScalarB P) Value+ , indices :: [T (Type ScalarB I) Value]+ , result :: LocalId + } -> CInst;++ I_getelementptr_V :: { inBounds :: IsOrIsNot InBounds+ , vpointer :: T (Type VectorB P) Value+ , vindices :: [T (Type VectorB I) Value]+ , result :: LocalId + } -> CInst;++ {- Scalar Integer cmp -}+ I_icmp :: { icmpOp :: IcmpOp+ , icmpType :: IntOrPtrType ScalarB+ , operand1 :: Value+ , operand2 :: Value+ , result :: LocalId+ } -> CInst;++ {- Vector Integer cmp -}+ I_icmp_V :: { icmpOp :: IcmpOp+ , icmpTypeV :: IntOrPtrType VectorB+ , operand1 :: Value+ , operand2 :: Value+ , result :: LocalId+ } -> CInst;++ {- Scalar Float cmp -}+ I_fcmp :: { fcmpOp :: FcmpOp+ , fcmpTypeF :: Type ScalarB F+ , operand1 :: Value+ , operand2 :: Value+ , result :: LocalId+ } -> CInst;++ I_fcmp_V :: { fcmpOp :: FcmpOp + , fcmpTypeVF :: Type VectorB F + , operand1 :: Value + , operand2 :: Value + , result :: LocalId + } -> CInst;++ {-- int bin exp --}+ I_add :: { flagI :: Maybe NoWrap+ , typeI :: Type ScalarB I+ , operand1 :: Value+ , operand2 :: Value+ , result :: LocalId + } -> CInst;++ I_sub :: { flagI :: Maybe NoWrap+ , typeI :: Type ScalarB I+ , operand1 :: Value+ , operand2 :: Value+ , result :: LocalId+ } -> CInst;++ I_mul :: { flagI :: Maybe NoWrap+ , typeI :: Type ScalarB I+ , operand1 :: Value+ , operand2 :: Value+ , result :: LocalId + } -> CInst;++ I_udiv :: { flagE :: Maybe Exact+ , typeI :: Type ScalarB I+ , operand1 :: Value+ , operand2 :: Value+ , result :: LocalId + } -> CInst;++ I_sdiv :: { flagE :: Maybe Exact+ , typeI :: Type ScalarB I+ , operand1 :: Value+ , operand2 :: Value+ , result :: LocalId + } -> CInst;++ I_urem :: { typeI :: Type ScalarB I+ , operand1 :: Value+ , operand2 :: Value+ , result :: LocalId + } -> CInst;++ I_srem :: { typeI :: Type ScalarB I+ , operand1 :: Value+ , operand2 :: Value+ , result :: LocalId + } -> CInst;++ I_shl :: { flagW :: Maybe NoWrap+ , typeI :: Type ScalarB I+ , operand1 :: Value+ , operand2 :: Value+ , result :: LocalId + } -> CInst;++ I_lshr :: { flagE :: Maybe Exact+ , typeI :: Type ScalarB I+ , operand1 :: Value+ , operand2 :: Value+ , result :: LocalId + } -> CInst;++ I_ashr :: { flagE :: Maybe Exact+ , typeI :: Type ScalarB I+ , operand1 :: Value+ , operand2 :: Value+ , result :: LocalId + } -> CInst;++ I_and :: { typeI :: Type ScalarB I+ , operand1 :: Value+ , operand2 :: Value+ , result :: LocalId + } -> CInst;++ I_or :: { typeI :: Type ScalarB I+ , operand1 :: Value+ , operand2 :: Value+ , result :: LocalId + } -> CInst;++ I_xor :: { typeI :: Type ScalarB I+ , operand1 :: Value+ , operand2 :: Value+ , result :: LocalId + } -> CInst;++ {-- int bin vector exp --}+ I_add_V :: (Maybe NoWrap) -> Type VectorB I -> Value -> Value -> LocalId -> CInst;+ I_sub_V :: (Maybe NoWrap) -> Type VectorB I -> Value -> Value -> LocalId -> CInst;+ I_mul_V :: (Maybe NoWrap) -> Type VectorB I -> Value -> Value -> LocalId -> CInst;+ I_udiv_V :: (Maybe Exact) -> Type VectorB I -> Value -> Value -> LocalId -> CInst;+ I_sdiv_V :: (Maybe Exact) -> Type VectorB I -> Value -> Value -> LocalId -> CInst;+ I_urem_V :: Type VectorB I -> Value -> Value -> LocalId -> CInst;+ I_srem_V :: Type VectorB I -> Value -> Value -> LocalId -> CInst;+ I_shl_V :: (Maybe NoWrap) -> Type VectorB I -> Value -> Value -> LocalId -> CInst;+ I_lshr_V :: (Maybe Exact) -> Type VectorB I -> Value -> Value -> LocalId -> CInst;+ I_ashr_V :: (Maybe Exact) -> Type VectorB I -> Value -> Value -> LocalId -> CInst;+ I_and_V :: Type VectorB I -> Value -> Value -> LocalId -> CInst;+ I_or_V :: Type VectorB I -> Value -> Value -> LocalId -> CInst;+ I_xor_V :: Type VectorB I -> Value -> Value -> LocalId -> CInst;++ {- float bin exp -}+ I_fadd :: FastMathFlags -> Type ScalarB F -> Value -> Value -> LocalId -> CInst;+ I_fsub :: FastMathFlags -> Type ScalarB F -> Value -> Value -> LocalId -> CInst;+ I_fmul :: FastMathFlags -> Type ScalarB F -> Value -> Value -> LocalId -> CInst;+ I_fdiv :: FastMathFlags -> Type ScalarB F -> Value -> Value -> LocalId -> CInst;+ I_frem :: FastMathFlags -> Type ScalarB F -> Value -> Value -> LocalId -> CInst;++ {- float bin exp -}+ I_fadd_V :: FastMathFlags -> Type VectorB F -> Value -> Value -> LocalId -> CInst;+ I_fsub_V :: FastMathFlags -> Type VectorB F -> Value -> Value -> LocalId -> CInst;+ I_fmul_V :: FastMathFlags -> Type VectorB F -> Value -> Value -> LocalId -> CInst;+ I_fdiv_V :: FastMathFlags -> Type VectorB F -> Value -> Value -> LocalId -> CInst;+ I_frem_V :: FastMathFlags -> Type VectorB F -> Value -> Value -> LocalId -> CInst;++ {-- Scalar conversion --}+ I_trunc :: { srcI :: T (Type ScalarB I) Value+ , toI :: Type ScalarB I+ , result :: LocalId } -> CInst;++ I_zext :: { srcI :: T (Type ScalarB I) Value+ , toI :: Type ScalarB I+ , result :: LocalId } -> CInst;++ I_sext :: { srcI :: T (Type ScalarB I) Value+ , toI :: Type ScalarB I+ , result :: LocalId } -> CInst;++ I_fptrunc :: { srcF :: T (Type ScalarB F) Value+ , toF :: Type ScalarB F+ , result :: LocalId } -> CInst;++ I_fpext :: { srcF :: T (Type ScalarB F) Value+ , toF :: Type ScalarB F+ , result :: LocalId } -> CInst;++ I_fptoui :: { srcF :: T (Type ScalarB F) Value+ , toI :: Type ScalarB I+ , result :: LocalId } -> CInst;++ I_fptosi :: { srcF ::T (Type ScalarB F) Value+ , toI :: Type ScalarB I+ , result :: LocalId } -> CInst;++ I_uitofp :: { srcI :: T (Type ScalarB I) Value+ , toF :: Type ScalarB F+ , result :: LocalId } -> CInst;++ I_sitofp :: { srcI :: T (Type ScalarB I) Value+ , toF :: Type ScalarB F+ , result :: LocalId } -> CInst;++ I_ptrtoint :: { srcP :: T (Type ScalarB P) Value+ , toI :: Type ScalarB I+ , result :: LocalId } -> CInst;++ I_inttoptr :: { srcI :: T (Type ScalarB I) Value+ , toP :: Type ScalarB P+ , result :: LocalId } -> CInst;++ I_addrspacecast :: T (Type ScalarB P) Value -> Type ScalarB P -> LocalId -> CInst;+++ I_bitcast :: { srcP :: T (Type ScalarB P) Value+ , toP :: Type ScalarB P+ , result :: LocalId } -> CInst;++ I_bitcast_D :: { srcD :: T Dtype Value+ , toD :: Dtype+ , result :: LocalId } -> CInst;++ {-- Vector conversion --}+ I_trunc_V :: T (Type VectorB I) Value -> Type VectorB I -> LocalId -> CInst;+ I_zext_V :: T (Type VectorB I) Value -> Type VectorB I -> LocalId -> CInst;+ I_sext_V :: T (Type VectorB I) Value -> Type VectorB I -> LocalId -> CInst;+ I_fptrunc_V :: T (Type VectorB F) Value -> Type VectorB F -> LocalId -> CInst;+ I_fpext_V :: T (Type VectorB F) Value -> Type VectorB F -> LocalId -> CInst;+ I_fptoui_V :: T (Type VectorB F) Value -> Type VectorB I -> LocalId -> CInst;+ I_fptosi_V :: T (Type VectorB F) Value -> Type VectorB I -> LocalId -> CInst;+ I_uitofp_V :: T (Type VectorB I) Value -> Type VectorB F -> LocalId -> CInst;+ I_sitofp_V :: T (Type VectorB I) Value -> Type VectorB F -> LocalId -> CInst;++ I_ptrtoint_V :: { srcVP :: T (Type VectorB P) Value+ , toVI :: Type VectorB I+ , result :: LocalId } -> CInst;++ I_inttoptr_V :: { srcVI :: T (Type VectorB I) Value+ , toVP :: Type VectorB P+ , result :: LocalId } -> CInst;++ I_addrspacecast_V :: { srcVP :: T (Type VectorB P) Value+ , toVP :: Type VectorB P+ , result :: LocalId } -> CInst;++ I_select_I :: T (Type ScalarB I) Value -> T (Type ScalarB I) Value -> T (Type ScalarB I) Value -> LocalId -> CInst;+ I_select_F :: T (Type ScalarB I) Value -> T (Type ScalarB F) Value -> T (Type ScalarB F) Value -> LocalId -> CInst;+ I_select_P :: T (Type ScalarB I) Value -> T (Type ScalarB P) Value -> T (Type ScalarB P) Value -> LocalId -> CInst;++ I_select_VI :: Either (T (Type ScalarB I) Value) (T (Type VectorB I) Value)+ -> T (Type VectorB I) Value -> T (Type VectorB I) Value -> LocalId -> CInst;+ I_select_VF :: Either (T (Type ScalarB I) Value) (T (Type VectorB I) Value)+ -> T (Type VectorB F) Value -> T (Type VectorB F) Value -> LocalId -> CInst;++ I_select_VP :: { condV :: Either (T (Type ScalarB I) Value) (T (Type VectorB I) Value)+ , trueVP :: T (Type VectorB P) Value+ , falseVP :: T (Type VectorB P) Value+ , result :: LocalId } -> CInst;++ I_select_First :: { cond :: T (Type ScalarB I) Value+ , trueFirst :: T (Type FirstClassB D) Value+ , falseFirst :: T (Type FirstClassB D) Value+ , result :: LocalId } -> CInst;++ {-- llvm intrinsic function calls --}+ I_llvm_memcpy:: { memlen :: MemLen+ , dest :: T (Type ScalarB P) Value+ , src :: T (Type ScalarB P) Value+ , len :: T (Type ScalarB I) Value+ , align :: T (Type ScalarB I) Value+ , isvolatile :: T (Type ScalarB I) Value+ } -> CInst;+ + I_llvm_dbg_declare :: [ActualParam] -> CInst;+ I_llvm_dbg_value :: [ActualParam] -> CInst;+ } deriving (Eq, Ord, Show)++data MemLen = MemLenI32+ | MemLenI64 deriving (Eq, Ord, Show)++{- -}+data CInstWithDbg = CInstWithDbg CInst [Dbg] deriving (Eq, Ord, Show)++data TerminatorInst = Unreachable+ | RetVoid+ | Return [T Dtype Value]+ | Br Label+ | Cbr Value Label Label+ | IndirectBr (T (Type ScalarB P) Value) [Label]+ | Switch (T (Type ScalarB I) Value) Label [((T (Type ScalarB I) Value), Label)]+ | Invoke CallSite Label Label (Maybe LocalId)+ | InvokeCmd CallSite Label Label+ | Resume (T Dtype Value)+ | Unwind+ deriving (Eq, Ord, Show)++data TerminatorInstWithDbg = TerminatorInstWithDbg TerminatorInst [Dbg] deriving (Eq, Ord, Show)++data ActualParam = ActualParamData Dtype [ParamAttr] (Maybe Alignment) Value [ParamAttr]+ | ActualParamLabel (Type CodeLabelB X) [ParamAttr] (Maybe Alignment) Value [ParamAttr]+ | ActualParamMeta MetaKindedConst+ deriving (Eq,Ord,Show)++data Value = Val_ssa LocalId+ | Val_const Const+ deriving (Eq,Ord,Show)++data T t v = T t v deriving (Eq, Ord, Show)++data Aliasee = AtV (T Dtype Value)+ | Ac (Conversion ScalarB Const)+ | AcV (Conversion VectorB Const)+ | Agep (GetElementPtr ScalarB Const)+ | AgepV (GetElementPtr VectorB Const)+ deriving (Eq, Ord, Show)++data FunctionPrototype = FunctionPrototype { fp_linkage :: Maybe Linkage+ , fp_visibility :: Maybe Visibility+ , fp_dllstorage :: Maybe DllStorageClass+ , fp_call_conv :: Maybe CallConv+ , fp_param_attrs :: [ParamAttr]+ , fp_ret_type :: Rtype+ , fp_fun_name :: GlobalId+ , fp_param_list :: FormalParamList+ , fp_addr_naming :: Maybe AddrNaming+ , fp_fun_attrs :: [FunAttr]+ , fp_section :: Maybe Section+ , fp_comdat :: Maybe Comdat+ , fp_alignment :: Maybe Alignment+ , fp_gc :: Maybe Gc+ , fp_prefix :: Maybe Prefix+ , fp_prologue :: Maybe Prologue+ } deriving (Eq,Ord,Show)++data Prefix = Prefix TypedConstOrNull deriving (Eq, Ord, Show)+data Prologue = Prologue TypedConstOrNull deriving (Eq, Ord, Show)++data TypedConstOrNull = TypedConst (T Dtype Const)+ | UntypedNull deriving (Eq, Ord, Show)+++instance Ucast Const Const where+ ucast = id++instance Ucast Const Value where+ ucast = Val_const++instance Ucast Value Value where+ ucast = id++instance Dcast Value Value where+ dcast _ = id++instance Dcast Value Const where+ dcast lc x = case x of+ Val_const v -> v+ _ -> dcastError lc "Const" x++instance (Ucast t s, Ucast u v) => Ucast (T t u) (T s v) where+ ucast (T t u) = T (ucast t) (ucast u)++instance (Dcast s t, Dcast v u) => Dcast (T s v) (T t u) where+ dcast lc (T s v) = T (dcast lc s) (dcast lc v)
+ src/Llvm/Data/Ir.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE GADTs #-}+module Llvm.Data.Ir+ (module Llvm.Data.Ir+ , module Llvm.Data.CoreIr+ , module Data.Word+ )+ where+import Llvm.Data.CoreIr+import qualified Llvm.Data.CoreIr as Ci+import qualified Compiler.Hoopl as H+import qualified Data.Set as S+import Data.Word (Word32)++{- An intermediate representation that is suitable for Hoopl -}++data Toplevel a = ToplevelTriple TlTriple+ | ToplevelDataLayout TlDataLayout+ | ToplevelAlias TlAlias+ | ToplevelDbgInit TlDbgInit+ | ToplevelStandaloneMd TlStandaloneMd+ | ToplevelNamedMd TlNamedMd+ | ToplevelDeclare TlDeclare+ | ToplevelDefine (TlDefine a)+ | ToplevelGlobal TlGlobal+ | ToplevelTypeDef TlTypeDef+ | ToplevelDepLibs TlDepLibs+ | ToplevelUnamedType TlUnamedType+ | ToplevelModuleAsm TlModuleAsm+ | ToplevelAttribute TlAttribute+ | ToplevelComdat TlComdat++data TlTriple = TlTriple Ci.TargetTriple deriving (Eq)++data TlDataLayout = TlDataLayout Ci.DataLayout deriving (Eq)++data TlAlias = TlAlias { tla_lhs :: Ci.GlobalId+ , tla_visibility :: Maybe Ci.Visibility+ , tla_dllstorage :: Maybe Ci.DllStorageClass+ , tla_tls :: Maybe Ci.ThreadLocalStorage+ , tla_addrnaming :: AddrNaming+ , tla_linkage :: Maybe Ci.Linkage+ , tla_aliasee :: Ci.Aliasee+ } deriving (Eq, Ord, Show)++data TlDbgInit = TlDbgInit String Word32 deriving (Eq, Ord, Show)++data TlStandaloneMd = TlStandaloneMd String MetaKindedConst deriving (Eq, Ord, Show)++data TlNamedMd = TlNamedMd Ci.MdVar [Ci.MdNode] deriving (Eq, Ord, Show)++data TlDeclare = TlDeclare Ci.FunctionPrototype deriving (Eq)++type NOOP = ()++data TlDefine a = TlDefine Ci.FunctionPrototype H.Label (H.Graph (Node a) H.C H.C) ++data TlGlobal = TlGlobalDtype { tlg_lhs :: (Maybe Ci.GlobalId)+ , tlg_linkage :: (Maybe Ci.Linkage)+ , tlg_visibility :: (Maybe Ci.Visibility)+ , tlg_dllstorage :: (Maybe Ci.DllStorageClass)+ , tlg_tls :: (Maybe Ci.ThreadLocalStorage)+ , tlg_addrnaming :: AddrNaming+ , tlg_addrspace :: (Maybe Ci.AddrSpace)+ , tlg_externallyInitialized :: (IsOrIsNot Ci.ExternallyInitialized)+ , tlg_globalType :: Ci.GlobalType+ , tlg_dtype :: Ci.Dtype+ , tlg_const :: (Maybe Ci.Const)+ , tlg_section :: (Maybe Ci.Section)+ , tlg_comdat :: (Maybe Ci.Comdat)+ , tlg_alignment :: (Maybe Ci.Alignment)+ }+ | TlGlobalOpaque { tlg_lhs :: (Maybe Ci.GlobalId)+ , tlg_linkage :: (Maybe Ci.Linkage)+ , tlg_visiblity :: (Maybe Ci.Visibility)+ , tlg_dllstorage :: (Maybe Ci.DllStorageClass)+ , tlg_tls :: (Maybe Ci.ThreadLocalStorage)+ , tlg_addrnaming :: AddrNaming+ , tlg_addrspace :: (Maybe Ci.AddrSpace)+ , tlg_externallyInitialized :: (IsOrIsNot Ci.ExternallyInitialized)+ , tlg_globalType :: Ci.GlobalType+ , tlg_otype :: (Ci.Type Ci.OpaqueB D)+ , tlg_const :: (Maybe Ci.Const)+ , tlg_section :: (Maybe Ci.Section)+ , tlg_comdat :: (Maybe Ci.Comdat)+ , tlg_alignment :: (Maybe Ci.Alignment)+ } deriving (Eq, Ord, Show)++data TlTypeDef = TlDatTypeDef Ci.LocalId Ci.Dtype+ | TlOpqTypeDef Ci.LocalId (Ci.Type OpaqueB D)+ | TlFunTypeDef Ci.LocalId (Ci.Type CodeFunB X) deriving (Eq, Ord, Show)++data TlDepLibs = TlDepLibs [Ci.DqString] deriving (Eq, Ord, Show)++data TlUnamedType = TlUnamedType Word32 Ci.Dtype deriving (Eq, Ord, Show)++data TlModuleAsm = TlModuleAsm Ci.DqString deriving (Eq, Ord, Show)++data TlAttribute = TlAttribute Word32 [FunAttr] deriving (Eq, Ord, Show)++data TlComdat = TlComdat Ci.DollarId Ci.SelectionKind deriving (Eq, Ord, Show)++data Module a = Module [Toplevel a] ++-- each instruction represents a node+data Node a e x where+ Nlabel :: H.Label -> Node a H.C H.O+ Pinst :: Ci.PhiInstWithDbg -> Node a H.O H.O+ Cinst :: Ci.CInstWithDbg -> Node a H.O H.O+ Comment :: String -> Node a H.O H.O+ Tinst :: Ci.TerminatorInstWithDbg -> Node a H.O H.C+ Additional :: a -> Node a H.O H.O++instance Show a => Show (Node a e x) where+ show x = case x of+ Nlabel v -> "Nlabel: Node C O:" ++ show v+ Pinst v -> "Pinst : Node O O:" ++ show v+ Cinst v -> "Cinst : Node O O:" ++ show v+ Tinst v -> "Tinst : Node O C:" ++ show v+ Comment s -> "Comment : Node O O:" ++ s+ Additional a -> "Additional : Node O O:" ++ show a++instance Eq a => Eq (Node a e x) where+ (==) x1 x2 = case (x1, x2) of+ (Nlabel l1, Nlabel l2) -> l1 == l2+ (Pinst v1, Pinst v2) -> v1 == v2+ (Cinst v1, Cinst v2) -> v1 == v2+ (Tinst v1, Tinst v2) -> v1 == v2+ (Comment v1, Comment v2) -> v1 == v2+ (Additional a1, Additional a2) -> a1 == a2+ (_, _) -> False++instance (Show a, Ord a) => Ord (Node a e x) where+ compare x1 x2 = case (x1, x2) of+ (Nlabel l1, Nlabel l2) -> compare l1 l2+ (Pinst v1, Pinst v2) -> compare v1 v2+ (Cinst v1, Cinst v2) -> compare v1 v2+ (Tinst v1, Tinst v2) -> compare v1 v2+ (Comment v1, Comment v2) -> compare v1 v2+ (Additional v1, Additional v2) -> compare v1 v2+ (_, _) -> compare (show x1) (show x2)++instance H.NonLocal (Node a) where+ entryLabel (Nlabel l) = l+ successors (Tinst (Ci.TerminatorInstWithDbg inst _)) = suc inst+ where+ suc (Ci.Unreachable) = []+ suc (Ci.Return _) = []+ suc (Ci.RetVoid) = []+ suc (Ci.Br l) = [l]+ suc (Ci.Cbr _ l1 l2) = [l1, l2]+ suc (Ci.IndirectBr _ ls) = ls+ suc (Ci.Switch _ d ls) = (d):(map snd ls)+ suc (Ci.Invoke _ l1 l2 _) = [l1, l2]+ suc (Ci.InvokeCmd _ l1 l2) = [l1, l2]+ suc (Ci.Resume _) = error "what is resume"+ suc (Ci.Unwind) = error "what is unwind"++globalIdOfModule :: (Module a) -> S.Set (Ci.Dtype, Ci.GlobalId) -- this should be a map, globalid might have an opaque type+globalIdOfModule (Module tl) = foldl (\a b -> S.union a (globalIdOf b)) S.empty tl+ where globalIdOf (ToplevelGlobal (TlGlobalDtype lhs _ _ _ _ _ _ _ _ t _ _ _ _)) =+ maybe S.empty (\x -> S.singleton (t, x)) lhs+ globalIdOf _ = S.empty
+ src/Llvm/Data/IrType.hs view
@@ -0,0 +1,1069 @@+{-# OPTIONS_GHC -cpp -fwarn-incomplete-patterns #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+module Llvm.Data.IrType+ (module Llvm.Data.Shared.AtomicEntity+ ,module Llvm.Data.IrType+ ,module Llvm.Data.Shared.Util+ ,module Data.Word+ )+ where++import Llvm.Data.Shared.AtomicEntity+import Llvm.Data.Shared.Util+import Data.Word (Word32)++#define FLC (FileLoc $(srcLoc))++data ScalarB -- Scalar Storage Block+data VectorB -- Vector Storage Block+data FirstClassB -- First Class Storage Block+data RecordB -- Record (struct and array) Storage Block+data CodeFunB -- Code Fun Storage Block+data CodeLabelB -- Code Label Storage Block+data OpaqueB -- Opaque Storage Block+data NoB -- No Storage Block++data I -- Integer representation+data F -- Float representation+data P -- Pointer representation+data D -- Data (I,F,P) representation+data U -- Unknown representation+data X -- Executable representation++data Type sto rep where {+ TpI :: Word32 -> Type ScalarB I;+ TpF :: Word32 -> Type ScalarB F;+ TpV :: Word32 -> Type ScalarB I;+ TpHalf :: Type ScalarB F;+ TpFloat :: Type ScalarB F;+ TpDouble :: Type ScalarB F;+ TpFp128 :: Type ScalarB F;+ TpX86Fp80 :: Type ScalarB F;+ TpPpcFp128 :: Type ScalarB F;+ TpX86Mmx :: Type ScalarB I;+ TvectorI :: Word32 -> Type ScalarB I -> Type VectorB I;+ TvectorF :: Word32 -> Type ScalarB F -> Type VectorB F;+ TvectorP :: Word32 -> Type ScalarB P -> Type VectorB P;+ TpNull :: Type ScalarB I;+ TpLabel :: Type CodeLabelB X;+ Tvoid :: Type NoB U;+ Topaque :: Type OpaqueB D;+ + {- first class aggregate types -}+ Tfirst_class_array :: Word32 -> ScalarType -> Type FirstClassB D;+ Tfirst_class_struct :: Packing -> [ScalarType] -> Type FirstClassB D;+ Tfirst_class_name :: String -> Type FirstClassB D;+ Tfirst_class_quoteName :: String -> Type FirstClassB D;+ Tfirst_class_no :: Word32 -> Type FirstClassB D;+ + Tarray :: Word32 -> Dtype -> Type RecordB D;+ Tstruct :: Packing -> [Dtype] -> Type RecordB D;+ + Topaque_struct :: Packing -> [Either Dtype (Type OpaqueB D)] -> Type OpaqueB D;+ Topaque_array :: Word32 -> Type OpaqueB D -> Type OpaqueB D;+ + Tpointer :: Etype -> AddrSpace -> Type ScalarB P;+ Tfunction :: Rtype -> TypeParamList -> [FunAttr] -> Type CodeFunB X;+ {- reference types -}++ {- referee is Scalar -}+ TnameScalarI :: String -> Type ScalarB I;+ TquoteNameScalarI :: String -> Type ScalarB I;+ TnoScalarI :: Word32 -> Type ScalarB I;++ TnameScalarF :: String -> Type ScalarB F;+ TquoteNameScalarF :: String -> Type ScalarB F;+ TnoScalarF :: Word32 -> Type ScalarB F;++ TnameScalarP :: String -> Type ScalarB P;+ TquoteNameScalarP :: String -> Type ScalarB P;+ TnoScalarP :: Word32 -> Type ScalarB P;++ {- referee is Vector -}+ TnameVectorI :: String -> Type VectorB I;+ TquoteNameVectorI :: String -> Type VectorB I;+ TnoVectorI :: Word32 -> Type VectorB I;++ TnameVectorF :: String -> Type VectorB F;+ TquoteNameVectorF :: String -> Type VectorB F;+ TnoVectorF :: Word32 -> Type VectorB F;++ TnameVectorP :: String -> Type VectorB P;+ TquoteNameVectorP :: String -> Type VectorB P;+ TnoVectorP :: Word32 -> Type VectorB P;++ {- referee is Large Block -}+ TnameRecordD :: String -> Type RecordB D;+ TquoteNameRecordD :: String -> Type RecordB D;+ TnoRecordD :: Word32 -> Type RecordB D;++ {- referee is Code Fun Block -}+ TnameCodeFunX :: String -> Type CodeFunB X;+ TquoteNameCodeFunX :: String -> Type CodeFunB X;+ TnoCodeFunX :: Word32 -> Type CodeFunB X;+ + {- referee is Opaque -}+ TnameOpaqueD :: String -> Type OpaqueB D;+ TquoteNameOpaqueD :: String -> Type OpaqueB D;+ TnoOpaqueD :: Word32 -> Type OpaqueB D;+ }+++instance Show (Type s r) where+ show x = case x of+ TpI n -> "TpI " ++ show n+ TpF n -> "TpF " ++ show n+ TpV n -> "TpV " ++ show n+ Tvoid -> "Tvoid"+ TpHalf -> "TpHalf"+ TpFloat -> "TpFloat"+ TpDouble -> "TpDouble"+ TpFp128 -> "TpFp128"+ TpX86Fp80 -> "TpX86Fp80"+ TpPpcFp128 -> "TpPpcFp128"+ TpX86Mmx -> "TpX86Mmx"+ TpNull -> "TpNull"+ TpLabel -> "TpLabel"+ Topaque -> "Topaque"+ Tarray n d -> "Tarray " ++ show n ++ " " ++ show d++ TvectorI n d -> "TvectorI " ++ show n ++ " " ++ show d+ TvectorF n d -> "TvectorF " ++ show n ++ " " ++ show d+ TvectorP n d -> "TvectorP " ++ show n ++ " " ++ show d++ Tstruct p ds -> "Tstruct " ++ show p ++ " " ++ show ds+ Tpointer e as -> "Tpointer " ++ show e ++ " " ++ show as+ Tfunction rt tp fa -> "Tfunction " ++ show rt ++ " " ++ show tp ++ " " ++ show fa+ {- Scalar -}+ TnameScalarI s -> "TnameScalarI " ++ show s+ TquoteNameScalarI s -> "TquoteNameScalarI " ++ show s+ TnoScalarI n -> "TnoScalarI " ++ show n++ TnameScalarF s -> "TnameScalarF " ++ show s+ TquoteNameScalarF s -> "TquoteNameScalarF " ++ show s+ TnoScalarF n -> "TnoScalarF " ++ show n++ TnameScalarP s -> "TnameScalarP " ++ show s+ TquoteNameScalarP s -> "TquoteNameScalarP " ++ show s+ TnoScalarP n -> "TnoScalarP " ++ show n++ {- Vector -}+ TnameVectorI s -> "TnameVectorI " ++ show s+ TquoteNameVectorI s -> "TquoteNameVectorI " ++ show s+ TnoVectorI n -> "TnoVectorI " ++ show n++ TnameVectorF s -> "TnameVectorF " ++ show s+ TquoteNameVectorF s -> "TquoteNameVectorF " ++ show s+ TnoVectorF n -> "TnoVectorF " ++ show n++ TnameVectorP s -> "TnameVectorP " ++ show s+ TquoteNameVectorP s -> "TquoteNameVectorP " ++ show s+ TnoVectorP n -> "TnoVectorP " ++ show n++ {- Large -}+ TnameRecordD s -> "TnameRecordD " ++ show s+ TquoteNameRecordD s -> "TquoteNameRecordD " ++ show s+ TnoRecordD n -> "TnoRecordD " ++ show n++ {- Code -}+ TnameCodeFunX s -> "TnameCodeFunX " ++ show s+ TquoteNameCodeFunX s -> "TquoteNameCodeFunX " ++ show s+ TnoCodeFunX n -> "TnoCodeFunX " ++ show n++ {- Opaque -}+ TnameOpaqueD s -> "TnameOpaqueD " ++ show s+ TquoteNameOpaqueD s -> "TquoteNameOpaqueD " ++ show s+ TnoOpaqueD n -> "TnoOpaqueD " ++ show n+ + Topaque_struct pk l -> "Topaque_struct " ++ show pk ++ " " ++ show l+ Topaque_array n e -> "Topaque_array " ++ show n ++ " " ++ show e + + Tfirst_class_array n e -> "Tfirst_class_array " ++ show n ++ " " ++ show e+ Tfirst_class_struct pk l -> "Tfirst_class_struct " ++ show pk ++ " " ++ show l+ Tfirst_class_name s -> "Tfirst_class_name " ++ show s+ Tfirst_class_quoteName s -> "Tfirst_class_quoteName " ++ show s+ Tfirst_class_no s -> "Tfirst_class_no " ++ show s++instance Mingle (Type s r) where+ mingle x = case x of+ TpI n -> "i" ++ show n+ TpF n -> "f" ++ show n+ TpV n -> "vi" ++ show n+ Tvoid -> "void"+ TpHalf -> "half"+ TpFloat -> "float"+ TpDouble -> "double"+ TpFp128 -> "fp128"+ TpX86Fp80 -> "x86fp80"+ TpPpcFp128 -> "ppcfp128"+ TpX86Mmx -> "x86mmx"+ TpNull -> "null"+ TpLabel -> "label"+ Topaque -> "opaque"+ Tarray n d -> "a_" ++ show n ++ "_" ++ mingle d++ TvectorI n d -> "vi_" ++ show n ++ "_" ++ mingle d+ TvectorF n d -> "vf_" ++ show n ++ "_" ++ mingle d+ TvectorP n d -> "vp_" ++ show n ++ "_" ++ mingle d++ Tstruct p ds -> "s_" ++ show p ++ "_" ++ mingle ds+ Tpointer e as -> "ptr_" ++ mingle e ++ "_" ++ show as+ Tfunction rt tp fa -> "fun_" ++ mingle rt ++ " " ++ mingle tp ++ " " ++ show fa+ {- Scalar -}+ TnameScalarI s -> show s+ TquoteNameScalarI s -> show s+ TnoScalarI n -> show n++ TnameScalarF s -> show s+ TquoteNameScalarF s -> show s+ TnoScalarF n -> show n++ TnameScalarP s -> show s+ TquoteNameScalarP s -> show s+ TnoScalarP n -> show n++ {- Vector -}+ TnameVectorI s -> show s+ TquoteNameVectorI s -> show s+ TnoVectorI n -> show n++ TnameVectorF s -> show s+ TquoteNameVectorF s -> show s+ TnoVectorF n -> show n++ TnameVectorP s -> show s+ TquoteNameVectorP s -> show s+ TnoVectorP n -> show n++ {- Large -}+ TnameRecordD s -> show s+ TquoteNameRecordD s -> show s+ TnoRecordD n -> show n++ {- Code -}+ TnameCodeFunX s -> show s+ TquoteNameCodeFunX s -> show s+ TnoCodeFunX n -> show n++ {- Opaque -}+ TnameOpaqueD s -> show s+ TquoteNameOpaqueD s -> show s+ TnoOpaqueD n -> show n+ + Topaque_struct pk l -> "os_" ++ show pk ++ "_" ++ show l+ Topaque_array n e -> "oa_" ++ show n ++ "_" ++ show e + + Tfirst_class_array n e -> "1ca_" ++ show n ++ " " ++ show e+ Tfirst_class_struct pk l -> "1cs_" ++ show pk ++ " " ++ show l+ Tfirst_class_name s -> show s+ Tfirst_class_quoteName s -> show s+ Tfirst_class_no s -> show s++instance Eq (Type s r) where+ (==) x1 x2 = case (x1, x2) of+ (TpI n, TpI n1) -> n == n1+ (TpF n, TpF n1) -> n == n1+ (TpV n, TpV n1) -> n == n1+ (Tvoid, Tvoid) -> True+ (TpHalf, TpHalf) -> True+ (TpFloat, TpFloat) -> True+ (TpDouble, TpDouble) -> True+ (TpFp128, TpFp128) -> True+ (TpX86Fp80, TpX86Fp80) -> True+ (TpPpcFp128, TpPpcFp128) -> True+ (TpX86Mmx, TpX86Mmx) -> True+ (TpNull, TpNull) -> error "Eq: comparing TpNull"+ (TpLabel, TpLabel) -> error "Eq: comparing TpLabel"+ (Topaque, Topaque) -> error "Eq: comparing Topaque"+++ (TvectorI n d, TvectorI n1 d1) -> eq2 (n,n1) (d,d1)+ (TvectorF n d, TvectorF n1 d1) -> eq2 (n,n1) (d,d1)+ (TvectorP n d, TvectorP n1 d1) -> eq2 (n,n1) (d,d1)++ (Tarray n d, Tarray n1 d1) -> eq2 (n,n1) (d,d1)+ (Tstruct p ds, Tstruct p1 ds1) -> eq2 (p,p1) (ds,ds1)+ + (Tfirst_class_array n d, Tfirst_class_array n1 d1) -> eq2 (n,n1) (d,d1)+ (Tfirst_class_struct p ds, Tfirst_class_struct p1 ds1) -> eq2 (p,p1) (ds,ds1)+ (Tfirst_class_name s, Tfirst_class_name s1) -> s == s1+ (Tfirst_class_quoteName s, Tfirst_class_quoteName s1) -> s == s1 + (Tfirst_class_no s, Tfirst_class_no s1) -> s == s1 + + + (Tpointer e as, Tpointer e1 as1) -> eq2 (e,e1) (as,as1)+ (Tfunction rt tp fa, Tfunction rt1 tp1 fa1) -> eq3 (rt,rt1) (tp,tp1) (fa,fa1)++ {- Scalar -}+ (TnameScalarI s, TnameScalarI s1) -> s == s1+ (TquoteNameScalarI s, TquoteNameScalarI s1) -> s == s1+ (TnoScalarI n, TnoScalarI n1) -> n == n1++ (TnameScalarF s, TnameScalarF s1) -> s == s1+ (TquoteNameScalarF s, TquoteNameScalarF s1) -> s == s1+ (TnoScalarF n, TnoScalarF n1) -> n == n1++ (TnameScalarP s, TnameScalarP s1) -> s == s1+ (TquoteNameScalarP s, TquoteNameScalarP s1) -> s == s1+ (TnoScalarP n, TnoScalarP n1) -> n == n1++ {- Vector -}+ (TnameVectorI s, TnameVectorI s1) -> s == s1+ (TquoteNameVectorI s, TquoteNameVectorI s1) -> s == s1+ (TnoVectorI n, TnoVectorI n1) -> n == n1++ (TnameVectorF s, TnameVectorF s1) -> s == s1+ (TquoteNameVectorF s, TquoteNameVectorF s1) -> s == s1+ (TnoVectorF n, TnoVectorF n1) -> n == n1++ (TnameVectorP s, TnameVectorP s1) -> s == s1+ (TquoteNameVectorP s, TquoteNameVectorP s1) -> s == s1+ (TnoVectorP n, TnoVectorP n1) -> n == n1++ {- Record -}+ (TnameRecordD s, TnameRecordD s1) -> s == s1+ (TquoteNameRecordD s, TquoteNameRecordD s1) -> s == s1+ (TnoRecordD n, TnoRecordD n1) -> n == n1++ {- Fun Code -}+ (TnameCodeFunX s, TnameCodeFunX s1) -> s == s1+ (TquoteNameCodeFunX s, TquoteNameCodeFunX s1) -> s == s1+ (TnoCodeFunX n, TnoCodeFunX n1) -> n == n1++ {- Opaque -}+ (TnameOpaqueD _, TnameOpaqueD _) -> errorLoc FLC "comparing opaque types"+ (TquoteNameOpaqueD _, TquoteNameOpaqueD _) -> errorLoc FLC "comparing opaque types"+ (TnoOpaqueD _, TnoOpaqueD _) -> errorLoc FLC "comparing opaque types"+ (Topaque_struct _ _, Topaque_struct _ _) -> errorLoc FLC "comparing opaque types"+ (Topaque_array _ _, Topaque_array _ _) -> errorLoc FLC "comparing opaque types"++ (_,_) -> False++++instance Ord (Type s r) where+ compare x1 x2 = case (x1, x2) of+ (TpI n, TpI n1) -> compare n n1+ (TpF n, TpF n1) -> compare n n1+ (TpV n, TpV n1) -> compare n n1+ (Tvoid, Tvoid) -> EQ+ (TpHalf, TpHalf) -> EQ+ (TpFloat, TpFloat) -> EQ+ (TpDouble, TpDouble) -> EQ+ (TpFp128, TpFp128) -> EQ+ (TpX86Fp80, TpX86Fp80) -> EQ+ (TpPpcFp128, TpPpcFp128) -> EQ+ (TpX86Mmx, TpX86Mmx) -> EQ+ (TpNull, TpNull) -> error "Ord: comparing TpNull"+ (TpLabel, TpLabel) -> error "Ord: comparing TpLabel"+ (Topaque, Topaque) -> error "Ord: comparing Topaque"+++ (TvectorI n d, TvectorI n1 d1) -> compare2 (n,n1) (d,d1)+ (TvectorF n d, TvectorF n1 d1) -> compare2 (n,n1) (d,d1)+ (TvectorP n d, TvectorP n1 d1) -> compare2 (n,n1) (d,d1)++ (Tarray n d, Tarray n1 d1) -> compare2 (n,n1) (d,d1)+ (Tstruct p ds, Tstruct p1 ds1) -> compare2 (p,p1) (ds,ds1)+ + (Tfirst_class_array n d, Tfirst_class_array n1 d1) -> compare2 (n,n1) (d,d1)+ (Tfirst_class_struct p ds, Tfirst_class_struct p1 ds1) -> compare2 (p,p1) (ds,ds1)+ (Tfirst_class_name s, Tfirst_class_name s1) -> compare s s1+ (Tfirst_class_quoteName s, Tfirst_class_quoteName s1) -> compare s s1 + (Tfirst_class_no s, Tfirst_class_no s1) -> compare s s1+++ (Tpointer e as, Tpointer e1 as1) -> compare2 (e,e1) (as,as1)+ (Tfunction rt tp fa, Tfunction rt1 tp1 fa1) -> compare3 (rt,rt1) (tp,tp1) (fa,fa1)++ {- Scalar -}+ (TnameScalarI s, TnameScalarI s1) -> compare s s1+ (TquoteNameScalarI s, TquoteNameScalarI s1) -> compare s s1+ (TnoScalarI n, TnoScalarI n1) -> compare n n1++ (TnameScalarF s, TnameScalarF s1) -> compare s s1+ (TquoteNameScalarF s, TquoteNameScalarF s1) -> compare s s1+ (TnoScalarF n, TnoScalarF n1) -> compare n n1++ (TnameScalarP s, TnameScalarP s1) -> compare s s1+ (TquoteNameScalarP s, TquoteNameScalarP s1) -> compare s s1+ (TnoScalarP n, TnoScalarP n1) -> compare n n1++ {- Vector -}+ (TnameVectorI s, TnameVectorI s1) -> compare s s1+ (TquoteNameVectorI s, TquoteNameVectorI s1) -> compare s s1+ (TnoVectorI n, TnoVectorI n1) -> compare n n1++ (TnameVectorF s, TnameVectorF s1) -> compare s s1+ (TquoteNameVectorF s, TquoteNameVectorF s1) -> compare s s1+ (TnoVectorF n, TnoVectorF n1) -> compare n n1++ (TnameVectorP s, TnameVectorP s1) -> compare s s1+ (TquoteNameVectorP s, TquoteNameVectorP s1) -> compare s s1+ (TnoVectorP n, TnoVectorP n1) -> compare n n1++ {- Large -}+ (TnameRecordD s, TnameRecordD s1) -> compare s s1+ (TquoteNameRecordD s, TquoteNameRecordD s1) -> compare s s1+ (TnoRecordD n, TnoRecordD n1) -> compare n n1++ {- Code -}+ (TnameCodeFunX s, TnameCodeFunX s1) -> compare s s1+ (TquoteNameCodeFunX s, TquoteNameCodeFunX s1) -> compare s s1+ (TnoCodeFunX n, TnoCodeFunX n1) -> compare n n1++ {- Opaque -}+ (TnameOpaqueD _, TnameOpaqueD _) -> errorLoc FLC "comparing opaque types"+ (TquoteNameOpaqueD _, TquoteNameOpaqueD _) -> errorLoc FLC "comparing opaque types"+ (TnoOpaqueD _, TnoOpaqueD _) -> errorLoc FLC "comparing opaque types"+ (Topaque_struct _ _, Topaque_struct _ _) -> errorLoc FLC "comparing opaque types"+ (Topaque_array _ _, Topaque_array _ _) -> errorLoc FLC "comparing opaque types" ++ (_,_) -> compare (show x1) (show x2)++data FormalParam = FormalParamData Dtype [ParamAttr] (Maybe Alignment) Fparam [ParamAttr]+ | FormalParamMeta MetaKind Fparam+ deriving (Eq,Ord,Show)++data FormalParamList = FormalParamList [FormalParam] (Maybe VarArgParam) [FunAttr]+ deriving (Eq,Ord,Show)++data TypeParamList = TypeParamList [Dtype] (Maybe VarArgParam) deriving (Eq,Ord,Show)++instance Mingle TypeParamList where+ mingle (TypeParamList l va) = "(" ++ mingle l ++ show va ++ ")"++type AddrSpace = Word32++data MetaKind = Mtype Utype+ | Mmetadata+ deriving (Eq, Ord,Show)+++{- short hand notations -}+uc :: Ucast a b => a -> b+uc x = ucast x++dc :: Dcast a b => FileLoc -> String -> a -> b+dc lc s x = dcast lc x++data Utype = UtypeScalarI (Type ScalarB I)+ | UtypeScalarF (Type ScalarB F)+ | UtypeScalarP (Type ScalarB P)+ | UtypeVectorI (Type VectorB I)+ | UtypeVectorF (Type VectorB F)+ | UtypeVectorP (Type VectorB P)+ | UtypeFirstClassD (Type FirstClassB D)+ | UtypeRecordD (Type RecordB D)+ | UtypeOpaqueD (Type OpaqueB D)+ | UtypeVoidU (Type NoB U)+ | UtypeFunX (Type CodeFunB X)+ | UtypeLabelX (Type CodeLabelB X)+ deriving (Eq,Ord,Show)++data Etype = EtypeScalarI (Type ScalarB I)+ | EtypeScalarF (Type ScalarB F)+ | EtypeScalarP (Type ScalarB P)+ | EtypeVectorI (Type VectorB I)+ | EtypeVectorF (Type VectorB F)+ | EtypeVectorP (Type VectorB P)+ | EtypeFirstClassD (Type FirstClassB D) + | EtypeRecordD (Type RecordB D)+ | EtypeOpaqueD (Type OpaqueB D)+ | EtypeFunX (Type CodeFunB X)+ deriving (Eq, Ord, Show)++{- this will be replicated in multiple nodes to reduce the depth of AST, a lower depth AST is+ more friendly for manual AST construction+-}+data Rtype = RtypeScalarI (Type ScalarB I)+ | RtypeScalarF (Type ScalarB F)+ | RtypeScalarP (Type ScalarB P)+ | RtypeVectorI (Type VectorB I)+ | RtypeVectorF (Type VectorB F)+ | RtypeVectorP (Type VectorB P)+ | RtypeFirstClassD (Type FirstClassB D)+ | RtypeRecordD (Type RecordB D)+ | RtypeVoidU (Type NoB U)+ deriving (Eq, Ord, Show)++data Dtype = DtypeScalarI (Type ScalarB I)+ | DtypeScalarF (Type ScalarB F)+ | DtypeScalarP (Type ScalarB P)+ | DtypeVectorI (Type VectorB I)+ | DtypeVectorF (Type VectorB F)+ | DtypeVectorP (Type VectorB P)+ | DtypeFirstClassD (Type FirstClassB D)+ | DtypeRecordD (Type RecordB D)+ deriving (Eq, Ord, Show)++{- First class type -}+data Ftype = FtypeScalarI (Type ScalarB I)+ | FtypeScalarF (Type ScalarB F)+ | FtypeScalarP (Type ScalarB P)+ | FtypeVectorI (Type VectorB I)+ | FtypeVectorF (Type VectorB F)+ | FtypeVectorP (Type VectorB P)+ | FtypeFirstClassD (Type FirstClassB D)+ deriving (Eq, Ord, Show)+++data ScalarType = ScalarTypeI (Type ScalarB I)+ | ScalarTypeF (Type ScalarB F)+ | ScalarTypeP (Type ScalarB P)+ deriving (Eq, Ord, Show)+ +data IntOrPtrType s = IntOrPtrTypeI (Type s I) + | IntOrPtrTypeP (Type s P)+ deriving (Eq, Ord, Show)++{- Type s r, which represents all types, ucast to Utype -}+instance Ucast (Type s r) (Type s r) where+ ucast = id+ +instance Ucast (Type s r) Utype where+ ucast x = case x of+ TpI _ -> UtypeScalarI x+ TpF _ -> UtypeScalarF x+ TpV _ -> UtypeScalarI x+ Tvoid -> UtypeVoidU x+ TpHalf -> UtypeScalarF x+ TpFloat -> UtypeScalarF x+ TpDouble -> UtypeScalarF x+ TpFp128 -> UtypeScalarF x+ TpX86Fp80 -> UtypeScalarF x+ TpPpcFp128 -> UtypeScalarF x+ TpX86Mmx -> UtypeScalarI x+ TpNull -> UtypeScalarI x+ TpLabel -> UtypeLabelX x+ Topaque -> UtypeOpaqueD x++ TvectorI _ _ -> UtypeVectorI x+ TvectorF _ _ -> UtypeVectorF x+ TvectorP _ _ -> UtypeVectorP x+ + Tfirst_class_array _ _ -> UtypeFirstClassD x+ Tfirst_class_struct _ _ -> UtypeFirstClassD x+ Tfirst_class_name _ -> UtypeFirstClassD x+ Tfirst_class_quoteName _ -> UtypeFirstClassD x + Tfirst_class_no _ -> UtypeFirstClassD x + + Tarray _ _ -> UtypeRecordD x+ Tstruct _ _ -> UtypeRecordD x+ + Topaque_struct _ _ -> UtypeOpaqueD x+ Topaque_array _ _ -> UtypeOpaqueD x + + Tpointer _ _ -> UtypeScalarP x+ Tfunction _ _ _ -> UtypeFunX x++ {- Scalar -}+ TnameScalarI _ -> UtypeScalarI x+ TquoteNameScalarI _ -> UtypeScalarI x+ TnoScalarI _ -> UtypeScalarI x++ TnameScalarF _ -> UtypeScalarF x+ TquoteNameScalarF _ -> UtypeScalarF x+ TnoScalarF _ -> UtypeScalarF x++ TnameScalarP _ -> UtypeScalarP x+ TquoteNameScalarP _ -> UtypeScalarP x+ TnoScalarP _ -> UtypeScalarP x++ {- Vector -}+ TnameVectorI _ -> UtypeVectorI x+ TquoteNameVectorI _ -> UtypeVectorI x+ TnoVectorI _ -> UtypeVectorI x++ TnameVectorF _ -> UtypeVectorF x+ TquoteNameVectorF _ -> UtypeVectorF x+ TnoVectorF _ -> UtypeVectorF x++ TnameVectorP _ -> UtypeVectorP x+ TquoteNameVectorP _ -> UtypeVectorP x+ TnoVectorP _ -> UtypeVectorP x++ {- Large -}+ TnameRecordD _ -> UtypeRecordD x+ TquoteNameRecordD _ -> UtypeRecordD x+ TnoRecordD _ -> UtypeRecordD x++ {- Code -}+ TnameCodeFunX _ -> UtypeFunX x+ TquoteNameCodeFunX _ -> UtypeFunX x+ TnoCodeFunX _ -> UtypeFunX x++ {- Opaque -}+ TnameOpaqueD _ -> UtypeOpaqueD x+ TquoteNameOpaqueD _ -> UtypeOpaqueD x+ TnoOpaqueD _ -> UtypeOpaqueD x++instance Dcast Utype (Type ScalarB I) where+ dcast lc e = case e of+ UtypeScalarI x -> x+ _ -> dcastError lc "Type ScalarB I" e++instance Dcast Utype (Type ScalarB F) where+ dcast lc e = case e of+ UtypeScalarF x -> x+ _ -> dcastError lc "Type ScalarB F" e++instance Dcast Utype (Type ScalarB P) where+ dcast lc e = case e of+ UtypeScalarP x -> x+ _ -> dcastError lc "Type ScalarB P" e++instance Dcast Utype (Type VectorB I) where+ dcast lc e = case e of+ UtypeVectorI x -> x+ _ -> dcastError lc "Type VectorB I" e++instance Dcast Utype (Type VectorB F) where+ dcast lc e = case e of+ UtypeVectorF x -> x+ _ -> dcastError lc "Type VectorB F" e++instance Dcast Utype (Type VectorB P) where+ dcast lc e = case e of+ UtypeVectorP x -> x+ _ -> dcastError lc "Type VectorB P" e++instance Dcast Utype (Type FirstClassB D) where+ dcast lc e = case e of+ UtypeFirstClassD x -> x+ _ -> dcastError lc "Type FirstClassB D" e++instance Dcast Utype (Type RecordB D) where+ dcast lc e = case e of+ UtypeRecordD x -> x+ _ -> dcastError lc "Type RecordB D" e+++instance Dcast Utype (Type CodeFunB X) where+ dcast lc e = case e of+ UtypeFunX x -> x+ _ -> dcastError lc "Type CodeFunB X" e++instance Dcast Utype (Type CodeLabelB X) where+ dcast lc e = case e of+ UtypeLabelX x -> x+ _ -> dcastError lc "Type CodeLabelB X" e+++instance Dcast Utype (Type OpaqueB D) where+ dcast lc e = case e of+ UtypeOpaqueD x -> x+ _ -> dcastError lc "Type OpaqueB D" e+++{- Etype's dcast, ucast, dcast -}+instance Dcast Utype Etype where+ dcast lc x = case x of+ UtypeScalarI e -> EtypeScalarI e+ UtypeScalarF e -> EtypeScalarF e+ UtypeScalarP e -> EtypeScalarP e+ UtypeVectorI e -> EtypeVectorI e+ UtypeVectorF e -> EtypeVectorF e+ UtypeVectorP e -> EtypeVectorP e+ UtypeFirstClassD e -> EtypeFirstClassD e + UtypeRecordD e -> EtypeRecordD e+ UtypeOpaqueD e -> EtypeOpaqueD e+ UtypeFunX e -> EtypeFunX e+ _ -> dcastError lc "Etype" x++instance Ucast Etype Utype where+ ucast x = case x of+ EtypeScalarI e -> UtypeScalarI e+ EtypeScalarF e -> UtypeScalarF e+ EtypeScalarP e -> UtypeScalarP e+ EtypeVectorI e -> UtypeVectorI e+ EtypeVectorF e -> UtypeVectorF e+ EtypeVectorP e -> UtypeVectorP e+ EtypeFirstClassD e -> UtypeFirstClassD e+ EtypeRecordD e -> UtypeRecordD e+ EtypeOpaqueD e -> UtypeOpaqueD e+ EtypeFunX e -> UtypeFunX e++instance Dcast Etype Dtype where+ dcast lc x = case x of+ EtypeScalarI e -> DtypeScalarI e+ EtypeScalarF e -> DtypeScalarF e+ EtypeScalarP e -> DtypeScalarP e+ EtypeVectorI e -> DtypeVectorI e+ EtypeVectorF e -> DtypeVectorF e+ EtypeVectorP e -> DtypeVectorP e+ EtypeFirstClassD e -> DtypeFirstClassD e+ EtypeRecordD e -> DtypeRecordD e+ _ -> dcastError lc "Dtype" x++instance Dcast (Type s r) Etype where+ dcast lc x = let (x1::Utype) = ucast x+ in dcast lc x1++instance Ucast (Type x I) Etype where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Ucast (Type x F) Etype where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Ucast (Type x P) Etype where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Ucast (Type FirstClassB x) Etype where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Ucast (Type RecordB D) Etype where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Ucast (Type CodeFunB X) Etype where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1+++{- Rtype's dcast, ucast, dcast -}+instance Dcast Utype Rtype where+ dcast lc x = case x of+ UtypeScalarI e -> RtypeScalarI e+ UtypeScalarF e -> RtypeScalarF e+ UtypeScalarP e -> RtypeScalarP e+ UtypeVectorI e -> RtypeVectorI e+ UtypeVectorF e -> RtypeVectorF e+ UtypeVectorP e -> RtypeVectorP e+ UtypeRecordD e -> RtypeRecordD e+ UtypeVoidU e -> RtypeVoidU e+ _ -> dcastError lc "Rtype" x++instance Ucast Rtype Utype where+ ucast x = case x of+ RtypeScalarI e -> UtypeScalarI e+ RtypeScalarF e -> UtypeScalarF e+ RtypeScalarP e -> UtypeScalarP e+ RtypeVectorI e -> UtypeVectorI e+ RtypeVectorF e -> UtypeVectorF e+ RtypeVectorP e -> UtypeVectorP e+ RtypeRecordD e -> UtypeRecordD e+ RtypeFirstClassD e -> UtypeFirstClassD e+ RtypeVoidU e -> UtypeVoidU e++instance Dcast Rtype Dtype where+ dcast lc x = case x of+ RtypeScalarI e -> DtypeScalarI e+ RtypeScalarF e -> DtypeScalarF e+ RtypeScalarP e -> DtypeScalarP e+ RtypeVectorI e -> DtypeVectorI e+ RtypeVectorF e -> DtypeVectorF e+ RtypeVectorP e -> DtypeVectorP e+ RtypeRecordD e -> DtypeRecordD e+ _ -> dcastError lc "Rtype" x++instance Dcast (Type s r) Rtype where+ dcast lc x = let (x1::Utype) = ucast x+ in dcast lc x1++instance Ucast (Type x I) Rtype where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Ucast (Type x F) Rtype where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Ucast (Type x P) Rtype where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Ucast (Type FirstClassB D) Rtype where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Ucast (Type RecordB D) Rtype where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Ucast (Type NoB U) Rtype where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++{- Dtype's dcast, ucast, dcast -}+instance Dcast Utype Dtype where+ dcast lc x = case x of+ UtypeScalarI e -> DtypeScalarI e+ UtypeScalarF e -> DtypeScalarF e+ UtypeScalarP e -> DtypeScalarP e+ UtypeVectorI e -> DtypeVectorI e+ UtypeVectorF e -> DtypeVectorF e+ UtypeVectorP e -> DtypeVectorP e+ UtypeFirstClassD e -> DtypeFirstClassD e + UtypeRecordD e -> DtypeRecordD e+ _ -> dcastError lc "Dtype" x++instance Ucast Dtype Utype where+ ucast x = case x of+ DtypeScalarI e -> UtypeScalarI e+ DtypeScalarF e -> UtypeScalarF e+ DtypeScalarP e -> UtypeScalarP e+ DtypeVectorI e -> UtypeVectorI e+ DtypeVectorF e -> UtypeVectorF e+ DtypeVectorP e -> UtypeVectorP e+ DtypeFirstClassD e -> UtypeFirstClassD e + DtypeRecordD e -> UtypeRecordD e++instance Ucast Dtype Etype where+ ucast x = case x of+ DtypeScalarI e -> EtypeScalarI e+ DtypeScalarF e -> EtypeScalarF e+ DtypeScalarP e -> EtypeScalarP e+ DtypeVectorI e -> EtypeVectorI e+ DtypeVectorF e -> EtypeVectorF e+ DtypeVectorP e -> EtypeVectorP e+ DtypeFirstClassD e -> EtypeFirstClassD e + DtypeRecordD e -> EtypeRecordD e++instance Dcast (Type s r) Dtype where+ dcast lc x = let (x1::Utype) = ucast x+ in dcast lc x1++instance Ucast (Type x I) Dtype where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Ucast (Type x F) Dtype where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Ucast (Type x P) Dtype where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Ucast (Type RecordB D) Dtype where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Dcast Dtype (Type ScalarB P) where+ dcast lc x = case x of+ DtypeScalarP e -> e+ _ -> dcastError lc "Type ScalarB P" x++instance Dcast Dtype (Type ScalarB I) where+ dcast lc x = case x of+ DtypeScalarI e -> e+ _ -> dcastError lc "Type ScalarB I" x++{- Ftype's dcast, ucast, dcast -}+instance Dcast Utype Ftype where+ dcast lc x = case x of+ UtypeScalarI e -> FtypeScalarI e+ UtypeScalarF e -> FtypeScalarF e+ UtypeScalarP e -> FtypeScalarP e+ UtypeVectorI e -> FtypeVectorI e+ UtypeVectorF e -> FtypeVectorF e+ UtypeVectorP e -> FtypeVectorP e+ UtypeFirstClassD e -> FtypeFirstClassD e+ _ -> dcastError lc "Ftype" x++instance Ucast Ftype Utype where+ ucast x = case x of+ FtypeScalarI e -> UtypeScalarI e+ FtypeScalarF e -> UtypeScalarF e+ FtypeScalarP e -> UtypeScalarP e+ FtypeVectorI e -> UtypeVectorI e+ FtypeVectorF e -> UtypeVectorF e+ FtypeVectorP e -> UtypeVectorP e+ FtypeFirstClassD e -> UtypeFirstClassD e ++instance Dcast (Type s r) Ftype where+ dcast lc x = let (x1::Utype) = ucast x+ in dcast lc x1++instance Ucast (Type x I) Ftype where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Ucast (Type x F) Ftype where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Ucast (Type x P) Ftype where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1+++{- ScalarType's dcast, ucast, dcast -}+instance Dcast Utype ScalarType where+ dcast lc x = case x of+ UtypeScalarI e -> ScalarTypeI e+ UtypeScalarF e -> ScalarTypeF e+ UtypeScalarP e -> ScalarTypeP e+ _ -> dcastError lc "ScalarType" x++instance Ucast ScalarType Utype where+ ucast x = case x of+ ScalarTypeI e -> UtypeScalarI e+ ScalarTypeF e -> UtypeScalarF e+ ScalarTypeP e -> UtypeScalarP e++instance Dcast Dtype ScalarType where+ dcast lc x = case x of+ DtypeScalarI e -> ScalarTypeI e+ DtypeScalarF e -> ScalarTypeF e+ DtypeScalarP e -> ScalarTypeP e+ _ -> dcastError lc "ScalarType" x++instance Ucast ScalarType Dtype where+ ucast x = case x of+ ScalarTypeI e -> DtypeScalarI e+ ScalarTypeF e -> DtypeScalarF e+ ScalarTypeP e -> DtypeScalarP e++instance Dcast (Type s r) ScalarType where+ dcast lc x = let (x1::Utype) = ucast x+ in dcast lc x1++instance Ucast (Type x I) ScalarType where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Ucast (Type x F) ScalarType where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Ucast (Type x P) ScalarType where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1+++{- IntOrPtrType's dcast, ucast, dcast -}+instance Dcast Utype (IntOrPtrType ScalarB) where+ dcast lc x = case x of+ UtypeScalarI e -> IntOrPtrTypeI e+ UtypeScalarP e -> IntOrPtrTypeP e+ _ -> dcastError lc "IntOrPtrType ScalarB" x++instance Dcast Utype (IntOrPtrType VectorB) where+ dcast lc x = case x of+ UtypeVectorI e -> IntOrPtrTypeI e+ UtypeVectorP e -> IntOrPtrTypeP e+ _ -> dcastError lc "IntOrPtrType VectorB" x++instance Ucast (IntOrPtrType ScalarB) Utype where+ ucast x = case x of+ IntOrPtrTypeI e -> UtypeScalarI e+ IntOrPtrTypeP e -> UtypeScalarP e++instance Ucast (IntOrPtrType VectorB) Utype where+ ucast x = case x of+ IntOrPtrTypeI e -> UtypeVectorI e+ IntOrPtrTypeP e -> UtypeVectorP e+++instance Dcast (Type s r) (IntOrPtrType ScalarB) where+ dcast lc x = let (x1::Utype) = ucast x+ in dcast lc x1++instance Dcast (Type s r) (IntOrPtrType VectorB) where+ dcast lc x = let (x1::Utype) = ucast x+ in dcast lc x1++instance Ucast (Type ScalarB I) (IntOrPtrType ScalarB) where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Ucast (Type ScalarB P) (IntOrPtrType ScalarB) where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Ucast (Type VectorB I) (IntOrPtrType VectorB) where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1++instance Ucast (Type VectorB P) (IntOrPtrType VectorB) where+ ucast x = let (x1::Utype) = ucast x+ in dcast (FileLoc "irrefutable") x1+++squeeze :: FileLoc -> Type RecordB D -> Type FirstClassB D+squeeze loc x = case x of+ Tstruct pk dl -> Tfirst_class_struct pk (fmap (dcast loc) dl)+ Tarray n el -> Tfirst_class_array n (dcast loc el)+ TnameRecordD e -> Tfirst_class_name e+ TquoteNameRecordD e -> Tfirst_class_quoteName e+ TnoRecordD e -> Tfirst_class_no e+ + +void :: Type NoB U+void = Tvoid++i1 :: Type ScalarB I+i1 = TpI 1++i8 :: Type ScalarB I+i8 = TpI 8++i16 :: Type ScalarB I+i16 = TpI 16++i32 :: Type ScalarB I+i32 = TpI 32++i64 :: Type ScalarB I+i64 = TpI 64++i128 :: Type ScalarB I+i128 = TpI 128++ptr0 :: Type s r -> Type ScalarB P+ptr0 t = Tpointer (dcast FLC t) 0++half :: Type ScalarB F+half = TpHalf++float :: Type ScalarB F+float = TpFloat++double :: Type ScalarB F+double = TpDouble++fp128 :: Type ScalarB F+fp128 = TpFp128++x86_fp80 :: Type ScalarB F+x86_fp80 = TpX86Fp80+++instance Mingle Dtype where+ mingle t = let (t0::Utype) = ucast t + in mingle t0+ +instance Mingle Rtype where+ mingle t = let (t0::Utype) = ucast t + in mingle t0+ +instance Mingle Etype where+ mingle t = let (t0::Utype) = ucast t + in mingle t0++instance Mingle Utype where + mingle t = case t of+ UtypeScalarI e -> mingle e+ UtypeScalarF e -> mingle e+ UtypeScalarP e -> mingle e+ UtypeVectorI e -> mingle e+ UtypeVectorF e -> mingle e+ UtypeVectorP e -> mingle e+ UtypeFirstClassD e -> mingle e+ UtypeRecordD e -> mingle e+ UtypeOpaqueD e -> mingle e+ UtypeVoidU e -> mingle e+ UtypeFunX e -> mingle e+ UtypeLabelX e -> mingle e
@@ -0,0 +1,21 @@+module Llvm.Data.Shared + (module Llvm.Data.Shared.AtomicEntity+ ,module Llvm.Data.Shared.SimpleConst+ ,module Llvm.Data.Shared.DataLayout+ ,module Llvm.Data.Shared.Util+ )+ where++import Llvm.Data.Shared.AtomicEntity+import Llvm.Data.Shared.SimpleConst+-- import Llvm.Data.Shared.Type+import Llvm.Data.Shared.DataLayout+import Llvm.Data.Shared.Util++++{-+data Typed v where+ TypedData :: Type -> v -> Typed v + UntypedNull :: Typed v -- Const+-}
@@ -0,0 +1,324 @@+module Llvm.Data.Shared.AtomicEntity where+import qualified Data.Map as M+import Data.Word(Word32)++-- | Double Quoted String+data DqString = DqString String deriving (Eq, Ord, Show)++data IcmpOp = IcmpEq | IcmpNe | IcmpUgt | IcmpUge | IcmpUlt + | IcmpUle | IcmpSgt | IcmpSge | IcmpSlt | IcmpSle+ deriving (Eq,Ord,Show)++icmpOpMap :: M.Map IcmpOp String+icmpOpMap = M.fromList [(IcmpEq, "eq"), (IcmpNe, "ne")+ ,(IcmpUgt, "ugt"),(IcmpUge, "uge")+ ,(IcmpUlt, "ult"),(IcmpUle, "ule")+ ,(IcmpSgt, "sgt"), (IcmpSge, "sge")+ ,(IcmpSlt, "slt"),(IcmpSle, "sle")+ ]++data FcmpOp = FcmpTrue | FcmpFalse+ | FcmpOeq | FcmpOgt | FcmpOge+ | FcmpOlt | FcmpOle | FcmpOne | FcmpOrd+ | FcmpUeq | FcmpUgt | FcmpUge | FcmpUlt+ | FcmpUle | FcmpUne | FcmpUno+ deriving (Eq,Ord,Show)++fcmpOpMap :: M.Map FcmpOp String+fcmpOpMap = M.fromList [(FcmpTrue, "true"), (FcmpFalse, "false")+ ,(FcmpOeq, "oeq"), (FcmpOgt, "ogt"), (FcmpOge, "oge")+ ,(FcmpOlt, "olt"), (FcmpOle, "ole"), (FcmpOne, "one"), (FcmpOrd, "ord")+ ,(FcmpUeq, "ueq"), (FcmpUgt, "ugt"), (FcmpUge, "uge")+ ,(FcmpUlt, "ult"), (FcmpUle, "ule"), (FcmpUne, "une"), (FcmpUno, "uno") + ]++-- | Linkage Types <http://llvm.org/releases/3.5.0/docs/LangRef.html#linkage-types>+data Linkage = LinkagePrivate+ | LinkageInternal + | LinkageAvailableExternally+ | LinkageLinkonce+ | LinkageCommon+ | LinkageWeak+ | LinkageAppending+ | LinkageExternWeak+ | LinkageLinkonceOdr+ | LinkageWeakOdr+ | LinkageExternal+ deriving (Eq,Ord,Show)++-- | Calling Conventions <http://llvm.org/releases/3.5.0/docs/LangRef.html#calling-conventions>+data CallConv = Ccc + | CcFast + | CcCold + | CcGhc+ | CcHiPe+ | Cc String+ | CcWebkit_Js+ | CcAnyReg+ | CcPreserveMost+ | CcPreserveAll+ | CcFirstTarget+ | CcX86_StdCall+ | CcX86_FastCall+ | CcArm_Apcs+ | CcArm_Aapcs+ | CcArm_Aapcs_Vfp+ | CcMsp430_Intr+ | CcX86_ThisCall+ | CcPtx_Kernel+ | CcPtx_Device+ | CcSpir_Func+ | CcSpir_Kernel+ | CcIntel_Ocl_Bi+ | CcX86_64_SysV+ | CcX86_64_Win64+ | CcX86_VectorCall+ deriving (Eq,Ord,Show)++-- | Visibility Styles <http://llvm.org/releases/3.5.0/docs/LangRef.html#visibility-styles>+data Visibility = VisDefault | VisHidden | VisProtected+ deriving (Eq,Ord,Show)++-- | DLL Storage Classes <http://llvm.org/releases/3.5.0/docs/LangRef.html#dll-storage-classes> +data DllStorageClass = DscImport+ | DscExport deriving (Eq, Ord, Show)+ +-- | Thread Local Storage Models <http://llvm.org/releases/3.5.0/docs/LangRef.html#thread-local-storage-models>+data ThreadLocalStorage = TlsLocalDynamic+ | TlsInitialExec+ | TlsLocalExec+ | TlsNone+ deriving (Eq, Ord, Show)++-- | Parameter Attributes <http://llvm.org/releases/3.5.0/docs/LangRef.html#parameter-attributes>+data ParamAttr = PaZeroExt + | PaSignExt+ | PaInReg + | PaByVal + | PaInAlloca+ | PaSRet+ | PaNoAlias + | PaNoCapture+ | PaNest + | PaReturned+ | PaNonNull+ | PaDereferenceable Word32 -- Integer+ | PaReadOnly+ | PaReadNone+ | PaAlign Word32 -- Integer+ deriving (Eq,Ord,Show)++-- | Function Attributes <http://llvm.org/releases/3.5.0/docs/LangRef.html#function-attributes>+data FunAttr = FaAlignStack Word32 -- Integer+ | FaAlwaysInline+ | FaBuiltin+ | FaCold+ | FaInlineHint+ | FaJumpTable+ | FaMinSize+ | FaNaked+ | FaNoBuiltin+ | FaNoDuplicate+ | FaNoImplicitFloat+ | FaNoInline+ | FaNonLazyBind+ | FaNoRedZone+ | FaNoReturn+ | FaNoUnwind+ | FaOptNone+ | FaOptSize+ | FaReadNone+ | FaReadOnly+ | FaReturnsTwice+ | FaSanitizeAddress+ | FaSanitizeMemory+ | FaSanitizeThread+ | FaSsp+ | FaSspReq+ | FaSspStrong+ | FaUwTable+ | FaPair DqString (Maybe DqString)+ | FaAlign Word32 -- Integer+ | FaGroup Word32 -- Integer+ deriving (Eq,Ord,Show)+++data SelectionKind = Any+ | ExactMatch+ | Largest+ | NoDuplicates+ | SameSize+ deriving (Eq, Ord, Show)++selectionKindMap :: M.Map SelectionKind String+selectionKindMap = M.fromList [(Any, "any"), (ExactMatch, "exactmatch"), (Largest, "largest"), (NoDuplicates, "noduplicates"), (SameSize, "samesize")]++data Section = Section DqString deriving (Eq,Ord,Show)++data Alignment = Alignment Word32 deriving (Eq,Ord,Show)+type MaybeAlignment = Maybe Alignment++data Gc = Gc DqString deriving (Eq,Ord,Show)+data GlobalType = GlobalType String deriving (Eq,Ord,Show)++data AddrNaming = UnnamedAddr+ | NamedAddr deriving (Eq, Ord, Show)+++data GlobalOrLocalId = GolG GlobalId+ | GolL LocalId+ deriving (Eq,Ord,Show)++data LocalId = LocalIdNum Word32 -- Integer+ | LocalIdAlphaNum String+ | LocalIdDqString String+ deriving (Eq,Ord,Show)+++data DollarId = DollarIdNum Word32 + | DollarIdAlphaNum String+ | DollarIdDqString String+ deriving (Eq, Ord, Show) ++data Comdat = Comdat (Maybe DollarId) deriving (Eq, Ord, Show)++data GlobalId = GlobalIdNum Word32+ | GlobalIdAlphaNum String+ | GlobalIdDqString String+ deriving (Eq,Ord,Show)+ +-- | Atomic Memory Ordering Constraints <http://llvm.org/releases/3.5.0/docs/LangRef.html#atomic-memory-ordering-constraints>+data AtomicMemoryOrdering = AmoAcquire | AmoRelease | AmoAcqRel + | AmoSeqCst | AmoUnordered | AmoMonotonic+ deriving (Eq,Ord,Show)++atomicMemoryOrderingMap :: M.Map AtomicMemoryOrdering String +atomicMemoryOrderingMap = M.fromList [(AmoAcquire, "acquire"), (AmoRelease, "release")+ ,(AmoAcqRel, "acq_rel"), (AmoSeqCst, "seq_cst")+ ,(AmoUnordered, "unordered"), (AmoMonotonic, "monotonic")+ ] ++-- | atomicrmw operation <http://llvm.org/releases/3.5.0/docs/LangRef.html#id175>+data AtomicOp = AoXchg | AoAdd | AoSub | AoAnd | AoNand + | AoOr | AoXor + | AoMax | AoMin | AoUmax | AoUmin+ deriving (Eq,Ord,Show)+ +atomicOpMap :: M.Map AtomicOp String +atomicOpMap = M.fromList [(AoXchg, "xchg"), (AoAdd, "add"), (AoSub, "sub")+ ,(AoAnd, "and"), (AoNand, "nand")+ ,(AoOr, "or"), (AoXor, "xor")+ ,(AoMax, "max"), (AoMin, "min"), (AoUmax, "umax"), (AoUmin, "umin")]+ + +{- syntatical representation: c"...." -} +{-- data Cstring = Cstring String deriving (Eq,Ord,Show) -}++ +data Atomicity = Atomicity (IsOrIsNot SingleThread) AtomicMemoryOrdering+ deriving (Eq, Ord, Show)+ +data Nontemporal = Nontemporal Word32 deriving (Eq, Ord, Show)+type MaybeNontemporal = Maybe Nontemporal+ +data InvariantLoad = InvariantLoad Word32 deriving (Eq, Ord, Show)+ +data Nonnull = Nonnull Word32 deriving (Eq, Ord, Show)+ +data Volatile = Volatile deriving (Eq, Ord, Show)++data SingleThread = SingleThread deriving (Eq, Ord, Show)++data InAllocaAttr = InAllocaAttr deriving (Eq, Ord, Show)+ +data TailCall = TcNon+ | TcTailCall+ | TcMustTailCall deriving (Eq, Ord, Show)++data Weak = Weak deriving (Eq, Ord, Show)+++data IsOrIsNot a = Is a+ | IsNot a+ deriving (Eq, Ord, Show)+ +data InBounds = InBounds deriving (Eq, Ord, Show)++{- short hand notations -}+isInBounds :: IsOrIsNot InBounds+isInBounds = Is InBounds++isNotInBounds :: IsOrIsNot InBounds+isNotInBounds = IsNot InBounds++data FastMathFlag = Fmfnnan+ | Fmfninf+ | Fmfnsz+ | Fmfarcp+ | Fmffast+ deriving (Eq, Ord, Show)+ +fastMathFlagMap :: M.Map FastMathFlag String+fastMathFlagMap = M.fromList [(Fmfnnan, "nnan"), (Fmfninf, "ninf"), (Fmfnsz, "nsz"), (Fmfarcp, "arcp"), (Fmffast, "fast")]++data FastMathFlags = FastMathFlags [FastMathFlag] deriving (Eq, Ord, Show)++data ExternallyInitialized = ExternallyInitialized deriving (Eq, Ord, Show)++data AsmDialect = AsmDialectAtt+ | AsmDialectIntel+ deriving (Eq, Ord, Show)++data SideEffect = SideEffect deriving (Eq, Ord, Show)+data AlignStack = AlignStack deriving (Eq, Ord, Show)++data Cleanup = Cleanup deriving (Eq, Ord, Show)+++data Arch = Arch_i386+ | Arch_i686+ | Arch_x86+ | Arch_x86_64+ | Arch_PowerPc+ | Arch_PowerPc64+ | Arch_Arm String+ | Arch_ThumbV7+ | Arch_Itanium+ | Arch_Mips String+ | Arch_String String+ deriving (Eq, Ord, Show)+ +data Vendor = Vendor_Pc + | Vendor_Apple+ | Vendor_Unknown+ | Vendor_String String+ deriving (Eq, Ord, Show)+ +data Os = Os_Linux + | Os_Windows+ | Os_Win32+ | Os_FreeBsd String+ | Os_Darwin String+ | Os_Macosx String+ | Os_Ios String+ | Os_Mingw32+ | Os_Unknown+ | Os_String String+ deriving (Eq, Ord, Show)+ +data OsEnv = OsEnv_Gnu + | OsEnv_String String+ deriving (Eq, Ord, Show)++data TargetTriple = TargetTriple Arch (Maybe Vendor) (Maybe Os) (Maybe OsEnv) deriving (Eq, Ord, Show)+++data Fparam = FimplicitParam+ | FexplicitParam LocalId+ deriving (Eq,Ord,Show)++data Packing = Packed + | Unpacked+ deriving (Eq, Ord, Show)++data VarArgParam = VarArgParam deriving (Eq, Ord, Show)
@@ -0,0 +1,86 @@+module Llvm.Data.Shared.DataLayout where++import qualified Data.Map as M+import Data.Word++data Endianness = LittleEndian+ | BigEndian deriving (Eq, Ord, Show)++data LayoutAddrSpace = LayoutAddrSpace Word32+ | LayoutAddrSpaceUnspecified deriving (Eq, Ord, Show)+ +data StackAlign = StackAlign AlignInBit+ | StackAlignUnspecified deriving (Eq, Ord, Show)++data SizeInBit = SizeInBit Word32 deriving (Eq, Ord, Show)+data AlignInBit = AlignInBit Word32 deriving (Eq, Ord, Show)++data AbiAlign = AbiAlign AlignInBit deriving (Eq, Ord, Show)++data PrefAlign = PrefAlign AlignInBit deriving (Eq, Ord, Show)++data Mangling = ManglingE+ | ManglingM+ | ManglingO+ | ManglingW deriving (Eq, Ord, Show)+ +data LayoutSpec = DlE Endianness+ | DlS StackAlign+ | DlLittleS (Maybe Word32) (Maybe Word32) (Maybe Word32)+ | DlP LayoutAddrSpace SizeInBit AbiAlign (Maybe PrefAlign)+ | DlI SizeInBit AbiAlign (Maybe PrefAlign)+ | DlF SizeInBit AbiAlign (Maybe PrefAlign)+ | DlV SizeInBit AbiAlign (Maybe PrefAlign) + | DlA (Maybe SizeInBit) AbiAlign (Maybe PrefAlign)+ | DlM Mangling+ | DlN [SizeInBit] deriving (Eq, Ord, Show)+ +data DataLayout = DataLayout [LayoutSpec] deriving (Eq, Ord, Show)+++data DataLayoutInfo = DataLayoutInfo + { endianess :: Endianness+ , stackAlign :: StackAlign+ , pointers :: M.Map LayoutAddrSpace (SizeInBit, AbiAlign, Maybe PrefAlign)+ , ints :: M.Map SizeInBit (AbiAlign, Maybe PrefAlign) + , floats :: M.Map SizeInBit (AbiAlign, Maybe PrefAlign) + , vectors :: M.Map SizeInBit (AbiAlign, Maybe PrefAlign)+ , aggregates :: M.Map (Maybe SizeInBit) (AbiAlign, Maybe PrefAlign)+ , nativeInt :: [SizeInBit]+ , mangling :: Maybe Mangling+ } deriving (Eq, Ord, Show)+ + +data AlignType = AlignAbi | AlignPref deriving (Eq, Ord, Show)++selectAlignment :: AlignType -> AbiAlign -> Maybe PrefAlign -> AlignInBit+selectAlignment at (AbiAlign aba) pa = case at of+ AlignAbi -> aba+ AlignPref -> maybe aba (\(PrefAlign n) -> n) pa+ ++emptyDataLayoutInfo :: DataLayoutInfo+emptyDataLayoutInfo = DataLayoutInfo { endianess = LittleEndian+ , stackAlign = StackAlignUnspecified+ , pointers = M.empty -- (LayoutAddrSpaceUnspecified, SizeInBit 0, AbiAlign 0, Nothing)+ , ints = M.empty+ , floats = M.empty+ , vectors = M.empty+ , aggregates = M.empty+ , nativeInt = []+ , mangling = Nothing+ }+ +getDataLayoutInfo :: DataLayout -> DataLayoutInfo +getDataLayoutInfo (DataLayout ls) = foldl (\p v -> case v of+ DlE x -> p { endianess = x}+ DlS x -> p { stackAlign = x}+ DlP la s aa pa -> p { pointers = M.insert la (s, aa, pa) (pointers p) }+ DlI s aa pa -> p { ints = M.insert s (aa, pa) (ints p) }+ DlF s aa pa -> p { floats = M.insert s (aa, pa) (floats p) }+ DlV s aa pa -> p { vectors = M.insert s (aa, pa) (vectors p) }+ DlA s aa pa -> p { aggregates = M.insert s (aa, pa) (aggregates p) }+ DlN l -> p { nativeInt = l }+ DlM m -> p { mangling = Just m }+ _ -> error $ "unexpected case " ++ show v+ ) emptyDataLayoutInfo ls
@@ -0,0 +1,42 @@+module Llvm.Data.Shared.SimpleConst + (module Llvm.Data.Shared.SimpleConst+ ,module Llvm.Data.Shared.AtomicEntity+ )+ where++import Llvm.Data.Shared.AtomicEntity (GlobalId)+import Data.Int+import Data.Word+import Data.DoubleWord++-- | Simple Constants <http://llvm.org/releases/3.0/docs/LangRef.html#simpleconstants> +data SimpleConstant = CpInt String+ | CpUhexInt String+ | CpShexInt String+ | CpFloat String+ -- | null pointer constant+ | CpNull+ | CpUndef+ -- | true::i1 + | CpTrue+ -- | false::i1+ | CpFalse+ | CpZeroInitializer+ | CpGlobalAddr GlobalId+ | CpStr String+ | CpBconst BinaryConstant+ deriving (Eq, Ord, Show)++data BinaryConstant = BconstUint8 Word8+ | BconstUint16 Word16+ | BconstUint32 Word32+ | BconstUint64 Word64+ | BconstUint96 Word96+ | BconstUint128 Word128+ | BconstInt8 Int8+ | BconstInt16 Int16+ | BconstInt32 Int32+ | BconstInt64 Int64+ | BconstInt96 Int96+ | BconstInt128 Int128+ deriving (Eq, Ord, Show)
@@ -0,0 +1,74 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+module Llvm.Data.Shared.Util where++import Language.Haskell.TH++eq2 :: (Eq a, Eq b) => (a,a) -> (b,b) -> Bool+eq2 (a1,a2) (b1,b2) = a1==a2 && b1==b2++eq3 :: (Eq a, Eq b, Eq c) => (a,a) -> (b,b) -> (c,c) -> Bool+eq3 (a1,a2) (b1,b2) (c1,c2) = eq2 (a1,a2) (b1,b2) && c1 == c2++eq4 :: (Eq a, Eq b, Eq c, Eq d) => (a,a) -> (b,b) -> (c,c) -> (d,d) -> Bool+eq4 (a1,a2) (b1,b2) (c1,c2) (d1, d2) = eq3 (a1,a2) (b1,b2) (c1, c2) && d1 == d2++eq5 :: (Eq a, Eq b, Eq c, Eq d, Eq e) => (a,a) -> (b,b) -> (c,c) -> (d,d) -> (e,e) -> Bool+eq5 (a1,a2) (b1,b2) (c1,c2) (d1, d2) (e1, e2) = eq4 (a1,a2) (b1,b2) (c1,c2) (d1,d2) && e1 == e2+++compare2 :: (Ord a, Ord b) => (a,a) -> (b, b) -> Ordering +compare2 (a1,a2) (b1, b2) = let v = compare a1 a2+ in if v == EQ then compare b1 b2+ else v++compare3 :: (Ord a, Ord b, Ord c) => (a,a) -> (b,b) -> (c,c) -> Ordering+compare3 (a1,a2) (b1,b2) (c1,c2) = let v = compare2 (a1,a2) (b1,b2)+ in if v == EQ then compare c1 c2+ else v++compare4 :: (Ord a, Ord b, Ord c, Ord d) => (a,a) -> (b,b) -> (c,c) -> (d,d) -> Ordering+compare4 (a1,a2) (b1,b2) (c1,c2) (d1,d2) = let v = compare3 (a1,a2) (b1,b2) (c1,c2)+ in if v == EQ then compare d1 d2+ else v++compare5 :: (Ord a, Ord b, Ord c, Ord d, Ord e) => (a,a) -> (b,b) -> (c,c) -> (d,d) -> (e,e) -> Ordering+compare5 (a1,a2) (b1,b2) (c1,c2) (d1, d2) (e1, e2) = let v = compare4 (a1,a2) (b1,b2) (c1,c2) (d1,d2)+ in if v == EQ then compare e1 e2+ else v++newtype FileLoc = FileLoc String deriving (Eq, Ord, Show)++castError :: Show a => FileLoc -> String -> a -> b+castError (FileLoc loc) s x = error $ (loc ++ "irrefutable error, casting " ++ show x ++ " to " ++ s)++dcastError :: Show a => FileLoc -> String -> a -> b+dcastError = castError+++srcLoc :: ExpQ+srcLoc = do { (Loc f p m s e) <- location+ ; stringE (p ++ ":" ++ m ++ "@" ++ show s)+ } + +errorLoc :: FileLoc -> String -> a+errorLoc (FileLoc lc) s = error (lc ++ ":" ++ s)++{- up casting -}+class Ucast l1 l2 where+ ucast :: l1 -> l2++{- down casting -}+class Dcast l1 l2 where+ dcast :: FileLoc -> l1 -> l2+ +{- horizontal casting -}+class Hcast l1 l2 where + hcast :: FileLoc -> l1 -> l2+ + +class Mingle a where + mingle :: a -> String+ +instance Mingle a => Mingle ([a]) where + mingle l = foldl (\p e -> p ++ (mingle e)) "" l
+ src/Llvm/Data/Type.hs view
@@ -0,0 +1,54 @@+module Llvm.Data.Type + (module Llvm.Data.Type+ ,module Llvm.Data.Shared.AtomicEntity + )+ where++import Llvm.Data.Shared.AtomicEntity hiding (AddrSpace(..))+import Data.Word (Word32)++data TypePrimitive = TpI Word32+ | TpF Word32 + | TpV Word32 + | TpHalf | TpFloat | TpDouble | TpFp128 | TpX86Fp80 | TpPpcFp128 + | TpX86Mmx + | TpNull+ | TpLabel+ deriving (Eq,Ord,Show)+++splitCallReturnType :: Type -> (Type, Maybe (Type, AddrSpace))+splitCallReturnType (Tpointer f@(Tfunction rt _ _) as) = (rt, Just (f, as))+splitCallReturnType x = (x, Nothing)++data Type = Tprimitive TypePrimitive+ | Topaque + | Tname String+ | TquoteName String+ | Tno Word32+ | Tarray Word32 Type+ | Tvector Word32 Type+ | Tstruct Packing [Type]+ | Tpointer Type AddrSpace+ | Tfunction Type TypeParamList [FunAttr]+ | Tvoid+ -- | deref a type will strip off Tpointer, this is a syntatical+ -- | representation that should be evaluated later.+ -- | Tderef Type + deriving (Eq,Ord,Show)+++data MetaKind = Mtype Type+ | Mmetadata+ deriving (Eq, Ord, Show)+ +data FormalParam = FormalParamData Type [ParamAttr] (Maybe Alignment) Fparam [ParamAttr]+ | FormalParamMeta MetaKind Fparam+ deriving (Eq,Ord,Show)++data FormalParamList = FormalParamList [FormalParam] (Maybe VarArgParam) [FunAttr] deriving (Eq,Ord,Show)++data TypeParamList = TypeParamList [Type] (Maybe VarArgParam) deriving (Eq,Ord,Show)++data AddrSpace = AddrSpace Word32 + | AddrSpaceUnspecified deriving (Eq,Ord,Show)
+ src/Llvm/Pass/Dominator.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Safe #-}++module Llvm.Pass.Dominator+ ( Doms, DPath(..), domPath, domEntry, domLattice, extendDom+ , DominatorNode(..), DominatorTree(..), tree+ , immediateDominators+ , domPass+ )+ where++import Data.Maybe++import Compiler.Hoopl+++type Doms = WithBot DPath+-- ^ List of labels, extended with a standard bottom element++-- | The fact that goes into the entry of a dominator analysis: the first node+-- is dominated only by the entry point, which is represented by the empty list+-- of labels.+domEntry :: Doms+domEntry = PElem (DPath [])++newtype DPath = DPath [Label]+ -- ^ represents part of the domination relation: each label+ -- in a list is dominated by all its successors. This is a newtype only so+ -- we can give it a fancy Show instance.++instance Show DPath where+ show (DPath ls) = concat (foldr (\l path -> show l : " -> " : path) ["entry"] ls)++domPath :: Doms -> [Label]+domPath Bot = [] -- lies: an unreachable node appears to be dominated by the entry+domPath (PElem (DPath ls)) = ls++extendDom :: Label -> DPath -> DPath+extendDom l (DPath ls) = DPath (l:ls)++domLattice :: DataflowLattice Doms+domLattice = addPoints "dominators" extend++extend :: JoinFun DPath+extend _ (OldFact (DPath l)) (NewFact (DPath l')) =+ (changeIf (l `lengthDiffers` j), DPath j)+ where j = lcs l l'+ lcs :: [Label] -> [Label] -> [Label] -- longest common suffix+ lcs l l' | length l > length l' = lcs (drop (length l - length l') l) l'+ | length l < length l' = lcs l' l+ | otherwise = dropUnlike l l' l+ dropUnlike [] [] maybe_like = maybe_like+ dropUnlike (x:xs) (y:ys) maybe_like =+ dropUnlike xs ys (if x == y then maybe_like else xs)+ dropUnlike _ _ _ = error "this can't happen"++ lengthDiffers [] [] = False+ lengthDiffers (_:xs) (_:ys) = lengthDiffers xs ys+ lengthDiffers [] (_:_) = True+ lengthDiffers (_:_) [] = True++++-- | Dominator pass+domPass :: (NonLocal n, Monad m) => FwdPass m n Doms+domPass = FwdPass domLattice (mkFTransfer3 first (const id) distributeFact) noFwdRewrite+ where first n = fmap (extendDom $ entryLabel n)++----------------------------------------------------------------++data DominatorNode = Entry | Labelled Label+data DominatorTree = Dominates DominatorNode [DominatorTree]+-- ^ This data structure is a *rose tree* in which each node may have+-- arbitrarily many children. Each node dominates all its descendants.++-- | Map from a FactBase for dominator lists into a+-- dominator tree. +tree :: [(Label, Doms)] -> DominatorTree+tree facts = Dominates Entry $ merge $ map reverse $ map mkList facts+ -- This code has been lightly tested. The key insight is this: to+ -- find lists that all have the same head, convert from a list of+ -- lists to a finite map, in 'children'. Then, to convert from the+ -- finite map to list of dominator trees, use the invariant that+ -- each key dominates all the lists of values.+ where merge lists = mapTree $ children $ filter (not . null) lists+ children = foldl addList noFacts+ addList :: FactBase [[Label]] -> [Label] -> FactBase [[Label]]+ addList map (x:xs) = mapInsert x (xs:existing) map+ where existing = fromMaybe [] $ lookupFact x map+ addList _ [] = error "this can't happen"+ mapTree :: FactBase [[Label]] -> [DominatorTree]+ mapTree map = [Dominates (Labelled x) (merge lists) |+ (x, lists) <- mapToList map]+ mkList (l, doms) = l : domPath doms+++instance Show DominatorTree where+ show = tree2dot++-- | Given a dominator tree, produce a string representation, in the+-- input language of dot, that will enable dot to produce a+-- visualization of the tree. For more info about dot see+-- http://www.graphviz.org.++tree2dot :: DominatorTree -> String+tree2dot t = concat $ "digraph {\n" : dot t ["}\n"]+ where+ dot :: DominatorTree -> [String] -> [String]+ dot (Dominates root trees) = + (dotnode root :) . outedges trees . flip (foldl subtree) trees+ where outedges [] = id+ outedges (Dominates n _ : ts) =+ \s -> " " : show root : " -> " : show n : "\n" : outedges ts s+ dotnode Entry = " entryNode [shape=plaintext, label=\"entry\"]\n"+ dotnode (Labelled l) = " " ++ show l ++ "\n"+ subtree = flip dot++instance Show DominatorNode where+ show Entry = "entryNode"+ show (Labelled l) = show l++----------------------------------------------------------------++-- | Takes FactBase from dominator analysis and returns a map from each +-- label to its immediate dominator, if any+immediateDominators :: FactBase Doms -> LabelMap Label+immediateDominators = mapFoldWithKey add mapEmpty+ where add l (PElem (DPath (idom:_))) = mapInsert l idom + add _ _ = id+
+ src/Llvm/Pass/Liveness.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE ScopedTypeVariables, GADTs #-}++module Llvm.Pass.Liveness (dce) where+import Data.Maybe+import qualified Data.Set as Ds+import qualified Data.List as L++import qualified Compiler.Hoopl as H+import Llvm.Data.Ir+import Llvm.Pass.Uda+import Llvm.Syntax.Printer.IrPrint++type Live = Ds.Set LocalId+liveLattice :: H.DataflowLattice Live+liveLattice = H.DataflowLattice+ { H.fact_name = "Live variables"+ , H.fact_bot = Ds.empty+ , H.fact_join = add+ }+ where add _ (H.OldFact old) (H.NewFact new) = (ch, j)+ where+ j = new `Ds.union` old+ ch= H.changeIf (Ds.size j > Ds.size old)++liveness :: H.BwdTransfer (Node a) Live+liveness = H.mkBTransfer live+ where+ live = undefined+ {-+ live :: Node e x -> H.Fact x Live -> Live+ live (Nlabel _) f = f+ live (Pinst n) f = f `Ds.union` (filterOutGlobalId $ u1ofPinstWithDbg n) `Ds.difference` (filterOutGlobalId $ d1ofPinstWithDbg n)+ -- | FIXME+ -- | this is a very simplistic implementation and it does not consider function calls might have side effects.+ -- | we need to distinguish the uses of a possible side effect computation from the uses of a pure computation.+ live (Cinst n) f = f `Ds.union` (filterOutGlobalId $ u1ofComputingInstWithDbg n) `Ds.difference` (filterOutGlobalId $ d1ofComputingInstWithDbg n)+ live x@(Tinst n) f = let bs = H.successors x+ f' = foldl (\p -> \l -> p `Ds.union` (fact f l)) Ds.empty bs+ in f' `Ds.union` (filterOutGlobalId $ u1ofTerminatorInstWithDbg n) `Ds.difference` (filterOutGlobalId $ d1ofTerminatorInstWithDbg n)+-- fact :: FactBase (Ds.Set LocalId) -> Label -> Live+ fact f l = fromMaybe Ds.empty $ H.lookupFact l f+-}++deadAsstElim :: forall a. forall m. H.FuelMonad m => H.BwdRewrite m (Node a) Live+deadAsstElim = H.mkBRewrite d+ where+ d :: Node a e x -> H.Fact x Live -> m (Maybe (H.Graph (Node a) e x))+ d (Cinst n) live = dead n live+ d _ _ = return Nothing+++dead :: forall a.forall m. H.FuelMonad m => CInstWithDbg -> H.Fact H.O Live -> m (Maybe (H.Graph (Node a) H.O H.O))+dead (CInstWithDbg ci _) live = deadCi ci live+++deadCi :: forall a.forall m. H.FuelMonad m => CInst -> H.Fact H.O Live -> m (Maybe (H.Graph (Node a) H.O H.O))+deadCi = undefined+{-+deadCi (ComputingInst Nothing (RmO m)) live = deadRmo m live+deadCi (ComputingInst Nothing (Call _ cs)) live = deadCallSite cs live+deadCi (ComputingInst _ (LandingPad _ _ _ _ _)) _ = return Nothing+deadCi (ComputingInst lhsOpt _) live = case lhsOpt of+ Just (GolL x) | not (x `Ds.member` live) -> return $ Just H.emptyGraph+ _ -> return Nothing+++deadRmo :: forall m. H.FuelMonad m => MemOp -> H.Fact H.O Live -> m (Maybe (H.Graph Node H.O H.O))+deadRmo inst live = case inst of+ (Store _ _ (TypedData _ (Pointer v)) _ _) -> case localIdOfValue v of+ Just x | not (x `Ds.member` live) -> return $ Just H.emptyGraph+ _ -> return Nothing+ (StoreAtomic _ _ _ (TypedData _ (Pointer v)) _) -> case localIdOfValue v of+ Just x | not (x `Ds.member` live) -> return $ Just H.emptyGraph+ _ -> return Nothing+ _ -> return Nothing+ where localIdOfValue (VgOl (GolL x)) = Just x+ localIdOfValue _ = Nothing+-}++isDeclare :: FunName -> Bool+isDeclare (FunNameGlobal (GolG gl)) | (render $ printIr gl) == "@llvm.dbg.declare" = True+isDeclare _ = False+++isDeadAP :: H.Fact H.O Live -> ActualParam -> Bool+isDeadAP = undefined+{-+isDeadAP live ap = let u = filterOutGlobalId $ u1 $ uDofActualParam ap+ dif = u `Ds.intersection` live+ in dif == Ds.empty+-}++deadCallSite :: forall a.forall m. H.FuelMonad m => CallSite -> H.Fact H.O Live -> m (Maybe (H.Graph (Node a) H.O H.O))+deadCallSite (CsFun _ _ _ fn ap _) live | isDeclare fn =+ if L.all (isDeadAP live) ap then return $ Just H.emptyGraph+ else return Nothing+deadCallSite _ _ = return Nothing++++filterOutGlobalId :: Ds.Set GlobalOrLocalId -> Ds.Set LocalId+filterOutGlobalId s = Ds.foldl (\a b -> case b of+ GolL l -> Ds.insert l a+ _ -> a) Ds.empty s++++++dcePass :: forall a. forall m. H.FuelMonad m => H.BwdPass m (Node a) Live+dcePass = H.BwdPass { H.bp_lattice = liveLattice+ , H.bp_transfer = liveness+ , H.bp_rewrite = deadAsstElim+ }++dce :: (H.CheckpointMonad m, H.FuelMonad m) => Ds.Set (Dtype, GlobalId) -> Label -> H.Graph (Node a) H.C H.C -> m (H.Graph (Node a) H.C H.C)+dce _ entry graph =+ do { (graph', _, _) <- H.analyzeAndRewriteBwd bwd (H.JustC [entry]) graph+ H.mapEmpty+ ; return graph'+ }+ where bwd = dcePass
+ src/Llvm/Pass/Mem2Reg.hs view
@@ -0,0 +1,129 @@+{-# OPTIONS_GHC -cpp #-}+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+module Llvm.Pass.Mem2Reg (mem2reg) where++import Compiler.Hoopl+import Llvm.Data.Ir+import qualified Data.Map as Dm+import qualified Data.Set as Ds+import Control.Monad+import Llvm.Pass.Rewriter (rwNode,nodeToGraph)+import Prelude hiding(lookup)+#ifdef DEBUG+import Debug.Trace+#endif+++-- | TODO: describe in details what this pass is doing+type Mem2RegFact = Dm.Map LValue (WithTop Value)++data LValue = Mem LocalId+ | Ref LocalId+ deriving (Eq, Show, Ord)++mem2RegLattice :: DataflowLattice Mem2RegFact+mem2RegLattice = DataflowLattice { fact_name = "Mem 2 Reg"+ , fact_bot = Dm.empty+ , fact_join = joinMaps (extendJoinDomain factAdd)+ }+ where+ factAdd _ (OldFact old) (NewFact new)+ = if new == old then (NoChange, PElem new)+ else (SomeChange, Top)++isReg :: FwdTransfer (Node a) Mem2RegFact+isReg = mkFTransfer ft++ft :: (Node a) e x -> Mem2RegFact -> Fact x Mem2RegFact+ft (Nlabel _) f = f+ft (Pinst _) f = f+ft (Cinst cinst) f = cinstft cinst f+ft n@(Tinst tinst) f = tinstft n tinst f+ ++tinstft :: (Node a) O C -> TerminatorInstWithDbg -> Mem2RegFact -> Fact C Mem2RegFact+tinstft n t@(TerminatorInstWithDbg term _) f = + let targets = successors n -- targetOf term+ in case targets of+ [] -> mapEmpty+ l -> mkFactBase mem2RegLattice+ (map (\x -> (x, f)) l)++cinstft :: CInstWithDbg -> Mem2RegFact -> Fact O Mem2RegFact+cinstft = undefined++{-+cinstft (ComputingInstWithDbg (ComputingInst lhs rhs) _) f = cinstft' lhs rhs f+++cinstft' :: Maybe GlobalOrLocalId -> Rhs -> Mem2RegFact -> Fact O Mem2RegFact+cinstft' lhs (RmO m) f = memOp lhs m f+cinstft' lhs (Re (Ev tv)) f = maybe f (\a -> let TypedData _ v = tv in+ case a of+ GolG _ -> f+ GolL s -> Dm.insert (Ref $ localIdToLstring s) (PElem v) f) lhs+cinstft' _ (Re _) f = f+cinstft' _ _ f = f+++memOp :: Maybe GlobalOrLocalId -> MemOp -> Mem2RegFact -> Fact O Mem2RegFact+memOp (Just (GolL lhs)) (Allocate _ _ Nothing _) f = insert (Mem $ localIdToLstring lhs) Top f+memOp _ (Store _ (TypedData _ v1) (TypedData _ (Pointer (VgOl (GolL ptr)))) _ _) f =+ let x = Mem $ localIdToLstring ptr+ in if (x `Dm.member` f) then insert x (PElem v1) f+ else f+memOp _ (StoreAtomic _ _ (TypedData _ v1) (TypedData _ (Pointer (VgOl (GolL ptr)))) _) f =+ let x = Mem $ localIdToLstring ptr+ in if (x `Dm.member` f) then insert x (PElem v1) f+ else f+memOp _ _ f = f+-}++insert :: Ord k => k -> v -> Dm.Map k v -> Dm.Map k v+#ifdef DEBUG+insert x v1 f | trace ("insert " ++ (show x) ++ "->" ++ (show v1)) False = undefined+#endif+insert x v1 f = Dm.insert x v1 f++badAss :: Monad m => (Value -> Maybe Value) -> Node a e x -> m (Maybe (Node a e x))+badAss f node = return (rwNode f node)+++mem2Reg :: forall a.forall m . FuelMonad m => FwdRewrite m (Node a) Mem2RegFact+mem2Reg = mkFRewrite cp+ where+ -- each node is rewritten to a one node graph.+ cp :: FuelMonad m => Node a e x -> Mem2RegFact -> m (Maybe (Graph (Node a) e x))+ cp node f = do { x <- badAss (lookup f) node+ ; return $ liftM {-Maybe-} nodeToGraph x+ }++ lookup :: Mem2RegFact -> Value -> Maybe Value+ lookup f x = do { x' <- case x of+ Val_ssa s -> Just $ Ref s+ -- Deref (Pointer (VgOl (GolL s))) -> Just $ Mem $ localIdToLstring s+ _ -> Nothing+ ; case Dm.lookup x' f of+ Just (PElem v) -> Just v+ _ -> Nothing+ }+++++mem2RegPass :: forall a. forall m. FuelMonad m => FwdPass m (Node a) Mem2RegFact+mem2RegPass = FwdPass { fp_lattice = mem2RegLattice+ , fp_transfer = isReg+ , fp_rewrite = mem2Reg+ }+++mem2reg :: (CheckpointMonad m, FuelMonad m) => Ds.Set (Dtype, GlobalId) -> Label -> Graph (Node a) C C -> m (Graph (Node a) C C)+mem2reg _ entry graph =+ do { (graph', _, _) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph+ (mapSingleton entry (Dm.empty)) -- initFact gs))+ ; return graph'+ }+ where fwd = mem2RegPass -- debugFwdJoins trace (const True) mem2RegPas
+ src/Llvm/Pass/NormalGraph.hs view
@@ -0,0 +1,17 @@+module Llvm.Pass.NormalGraph where+import Compiler.Hoopl (Graph,C,analyzeAndRewriteFwd,MaybeC(..),mapInsert,mapEmpty,LabelMap,CheckpointMonad, FuelMonad) +import Llvm.Data.Ir+import Llvm.Pass.PhiFixUp+import Llvm.Pass.Dominator++idom :: (CheckpointMonad m, FuelMonad m) => Label -> Graph (Node a) C C -> m (LabelMap Label)+idom entry g = do { (_,fact,_) <- analyzeAndRewriteFwd domPass (JustC [entry]) g+ (mapInsert entry domEntry mapEmpty)+ ; return $ immediateDominators fact+ }++fixUpPhi :: (CheckpointMonad m, FuelMonad m) => () -> Label -> Graph (Node a) C C -> m (Graph (Node a) C C)+fixUpPhi _ entry g = do { labelMap <- idom entry g+ ; g' <- phiFixUp labelMap entry g+ ; return g'+ }
+ src/Llvm/Pass/Optimizer.hs view
@@ -0,0 +1,36 @@+module Llvm.Pass.Optimizer where++import Llvm.Data.Ir+import qualified Compiler.Hoopl as H +import qualified Data.Set as Ds++type Optimization m a u = a -> H.Label -> H.Graph (Node u) H.C H.C -> m (H.Graph (Node u) H.C H.C)+ +opt :: (H.CheckpointMonad m, H.FuelMonad m) => a -> Optimization m a u -> (Toplevel u) -> m (Toplevel u)+opt _ _ (ToplevelTriple s) = return $ ToplevelTriple s+opt _ _ (ToplevelDataLayout s) = return $ ToplevelDataLayout s+opt _ _ (ToplevelAlias s) = return $ ToplevelAlias s+opt _ _ (ToplevelDbgInit s) = return $ ToplevelDbgInit s+opt _ _ (ToplevelStandaloneMd s) = return $ ToplevelStandaloneMd s+opt _ _ (ToplevelNamedMd v) = return $ ToplevelNamedMd v+opt _ _ (ToplevelDeclare fn) = return $ ToplevelDeclare fn+opt gs f (ToplevelDefine (TlDefine fn entry graph)) = do { graph' <- f gs entry graph+ ; return $ ToplevelDefine $ TlDefine fn entry graph'+ }+opt _ _ (ToplevelGlobal s) = return $ ToplevelGlobal s+opt _ _ (ToplevelTypeDef a) = return $ ToplevelTypeDef a+opt _ _ (ToplevelDepLibs qs) = return $ ToplevelDepLibs qs+opt _ _ (ToplevelUnamedType i) = return $ ToplevelUnamedType i+opt _ _ (ToplevelModuleAsm s) = return $ ToplevelModuleAsm s+opt _ _ (ToplevelComdat s) = return $ ToplevelComdat s+opt _ _ (ToplevelAttribute s) = return $ ToplevelAttribute s+++optModule :: (H.CheckpointMonad m, H.FuelMonad m) => Optimization m (Ds.Set (Dtype, GlobalId)) u -> Module u -> m (Module u)+optModule f (Module l) = + let gs = globalIdOfModule (Module l)+ in mapM (opt gs f) l >>= return . Module++optModule1 :: (H.CheckpointMonad m, H.FuelMonad m) => a -> Optimization m a u -> Module u -> m (Module u)+optModule1 a f (Module l) = + mapM (opt a f) l >>= return . Module
+ src/Llvm/Pass/PassManager.hs view
@@ -0,0 +1,25 @@+module Llvm.Pass.PassManager where++import Llvm.Data.Ir+import Llvm.Pass.Mem2Reg+-- import Llvm.Pass.PrepareRw+import Llvm.Pass.Liveness+import qualified Data.Set as Ds+import Llvm.Pass.Optimizer+import Compiler.Hoopl++data Step = Mem2Reg | Dce + | PrepareRw+ deriving (Show,Eq)++toPass :: (CheckpointMonad m, FuelMonad m) => Step -> Optimization m (Ds.Set (Dtype, GlobalId)) a+toPass Mem2Reg = mem2reg+toPass Dce = dce++applyPasses1 :: (CheckpointMonad m, FuelMonad m) => [Optimization m (Ds.Set (Dtype, GlobalId)) a] -> Module a -> m (Module a)+applyPasses1 steps m = foldl (\p e -> p >>= optModule e) (return m) steps+++applySteps :: (CheckpointMonad m, FuelMonad m) => [Step] -> Module a -> m (Module a)+applySteps steps m = let passes = map toPass steps+ in applyPasses1 passes m
+ src/Llvm/Pass/PassTester.hs view
@@ -0,0 +1,28 @@+module Llvm.Pass.PassTester where++import Llvm.Data.Ir+import Llvm.Query.IrCxt+import qualified Compiler.Hoopl as H +import qualified Data.Set as Ds++type Optimization m a u x = IrCxt -> a -> H.Label -> H.Graph (Node u) H.C H.C -> m (H.Graph (Node u) H.C H.C, x)+ +opt :: (H.CheckpointMonad m, H.FuelMonad m) => IrCxt -> a -> Optimization m a u x -> Toplevel u -> m [(Toplevel u, (FunctionPrototype, x))]+opt dl gs f (ToplevelDefine (TlDefine fn entry graph)) = do { (graph', x) <- f dl gs entry graph+ ; return [(ToplevelDefine $ TlDefine fn entry graph', (fn, x))]+ }+opt _ _ _ _ = return []+++optModule :: (H.CheckpointMonad m, H.FuelMonad m) => Optimization m (Ds.Set (Dtype, GlobalId)) u x -> Module u -> m (Module u, [(FunctionPrototype, x)])+optModule f (Module l) = + let gs = globalIdOfModule (Module l)+ dl = irCxtOfModule (Module l)+ in mapM (opt dl gs f) l >>= \x -> let (lx, ly) = unzip $ concat x+ in return (Module lx, ly)++{-+optModule1 :: (H.CheckpointMonad m, H.FuelMonad m) => a -> Optimization m a x -> Module -> m Module+optModule1 a f (Module l) = + mapM (opt a f) l >>= return . Module+-}
+ src/Llvm/Pass/PhiFixUp.hs view
@@ -0,0 +1,93 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}++module Llvm.Pass.PhiFixUp (phiFixUp) where++import Compiler.Hoopl+import Llvm.Data.Ir+import Control.Monad (liftM)++import Llvm.Pass.Rewriter+#ifdef DEBUG+import Debug.Trace+#endif ++-- | this pass fix up Phi instructions that have the parameters from unreachable code+type LiveLabel = LabelMap Label -- all the searchable labels+lattice :: LiveLabel -> DataflowLattice LiveLabel+lattice live = DataflowLattice { fact_name = "Live Label"+ , fact_bot = live+ , fact_join = add+ }+ where add _ (OldFact old) (NewFact new) = (ch, j)+ where + j = new `mapUnion` old+ ch= changeIf (mapSize j > mapSize old)+++fwdTransfer :: FwdTransfer (Node a) LiveLabel+fwdTransfer = mkFTransfer live+ where+ live :: Node a e x -> LiveLabel -> Fact x LiveLabel+ live (Nlabel _) f = f+ live (Pinst _) f = f + live (Cinst _) f = f + live t@(Tinst n) f = tinstft t n f+ tinstft :: Node a O C -> TerminatorInstWithDbg -> LiveLabel -> Fact C LiveLabel+ tinstft n (TerminatorInstWithDbg term _) f = + let targets = successors n -- targetOf term+ in case targets of+ [] -> mapEmpty+ l -> mkFactBase (lattice f) (map (\x -> (x, f)) l)+ ++fwdRewrite :: forall a.forall m. FuelMonad m => FwdRewrite m (Node a) LiveLabel+fwdRewrite = mkFRewrite d+ where+ d :: Node a e x -> LiveLabel -> m (Maybe (Graph (Node a) e x))+ d (Pinst n) f = removePhi n f + d _ _ = return Nothing+++removePhi :: forall a. forall m. FuelMonad m => PhiInstWithDbg -> Fact O LiveLabel -> m (Maybe (Graph (Node a) O O))+#ifdef DEBUG+removePhi x live | trace ("removePhi is called over " ++ show x) False = undefined+removePhi x live | trace ("removePhi is called with " ++ show live) False = undefined+removePhi x live | trace ("removePhi is called with " ++ show live) False = undefined+#endif+removePhi (PhiInstWithDbg (PhiInst lhs t ins) dbgs) live = + if liveOperands == ins then+ return $ Nothing+ else if liveOperands == [] then+ return $ Just emptyGraph+ else + return $ Just $ nodeToGraph (Pinst $ PhiInstWithDbg (PhiInst lhs t liveOperands) dbgs)+ where +#ifdef DEBUG+ isAlive x s | trace ("isAlive is called with " ++ show x ++ " " ++ show s) False = undefined+ isAlive x s | trace ("isAlive result is " ++ show (hooplLabelOf x `mapMember` s)) False = undefined+#endif + isAlive x s = x `mapMember` s+ liveOperands = foldl (\p -> \x@(_, li) -> + if isAlive li live then x:p else p) [] (reverse ins)+++fwdPass :: forall a.forall m. FuelMonad m => LiveLabel -> FwdPass m (Node a) LiveLabel+fwdPass f = FwdPass { fp_lattice = lattice f+ , fp_transfer = fwdTransfer+ , fp_rewrite = fwdRewrite+ }++phiFixUp :: (CheckpointMonad m, FuelMonad m) => LabelMap Label -> Label -> Graph (Node a) C C -> m (Graph (Node a) C C)+#ifdef DEBUG+phiFixUp idom entry graph | trace ("phiFixUp with idom " ++ show idom) False = undefined+phiFixUp idom entry graph | trace ("phiFixUp with entry " ++ show entry) False = undefined+#endif+phiFixUp idom entry graph = + let idom0 = mapInsert entry entry idom+ fwd = fwdPass idom0+ in do { (graph0, _, _) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph+ (mapInsert entry idom0 mapEmpty)+ ; return graph0+ }
+ src/Llvm/Pass/Rewriter.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE GADTs #-}+module Llvm.Pass.Rewriter where++import Control.Monad+import Data.Maybe+import Prelude hiding (succ)++import qualified Compiler.Hoopl as H++import Llvm.Data.Ir+import Llvm.Query.TypeConstValue+import Llvm.Util.Monadic (maybeM)+import Debug.Trace++type MaybeChange a = a -> Maybe a++{-+f2t :: (a -> Maybe a) -> (Typed a, Typed a) -> Maybe (Typed a, Typed a) +f2t f ((TypedData t1 a1), (TypedData t2 a2)) = case (f a1, f a2) of+ (Nothing, Nothing) -> Nothing+ (a1', a2') -> Just (TypedData t1 $ fromMaybe a1 a1', TypedData t2 $ fromMaybe a2 a2')+++f2 :: (a -> Maybe a) -> (a, a) -> Maybe (a, a) +f2 f (a1, a2) = case (f a1, f a2) of+ (Nothing, Nothing) -> Nothing+ (a1', a2') -> Just (fromMaybe a1 a1', fromMaybe a2 a2')+++f3 :: (a -> Maybe a) -> (Typed a, Typed a, Typed a) -> Maybe (Typed a, Typed a, Typed a) +f3 f (TypedData t1 a1, TypedData t2 a2, TypedData t3 a3) = case (f a1, f a2, f a3) of+ (Nothing, Nothing, Nothing) -> Nothing+ (a1', a2', a3') -> Just (TypedData t1 $ fromMaybe a1 a1'+ , TypedData t2 $ fromMaybe a2 a2'+ , TypedData t3 $ fromMaybe a3 a3')+++fs :: Eq a => (a -> Maybe a) -> [Typed a] -> Maybe [Typed a]+fs f ls = let ls' = map (\(TypedData t x) -> TypedData t (fromMaybe x (f x))) ls+ in if ls == ls' then Nothing else Just ls'+++rwIbinExpr :: MaybeChange a -> MaybeChange (IbinExpr a)+rwIbinExpr f e = let (v1, v2) = operandOfIbinExpr e+ t = typeOfIbinExpr e+ in do { (v1', v2') <- f2 f (v1, v2)+ ; return $ newBinExpr t v1' v2'+ }+ where newBinExpr t v1 v2 = + case e of + Add nw _ _ _ -> Add nw t v1 v2+ Sub nw _ _ _ -> Sub nw t v1 v2+ Mul nw _ _ _ -> Mul nw t v1 v2+ Udiv nw _ _ _ -> Udiv nw t v1 v2+ Sdiv nw _ _ _ -> Sdiv nw t v1 v2+ Urem _ _ _ -> Urem t v1 v2+ Srem _ _ _ -> Srem t v1 v2+ Shl nw _ _ _ -> Shl nw t v1 v2+ Lshr nw _ _ _ -> Lshr nw t v1 v2+ Ashr nw _ _ _ -> Ashr nw t v1 v2+ And _ _ _ -> And t v1 v2+ Or _ _ _ -> Or t v1 v2+ Xor _ _ _ -> Xor t v1 v2+ ++rwFbinExpr :: MaybeChange a -> MaybeChange (FbinExpr a)+rwFbinExpr f e = let (v1, v2) = operandOfFbinExpr e+ t = typeOfFbinExpr e+ in do { (v1', v2') <- f2 f (v1, v2)+ ; return $ newBinExpr t v1' v2'+ }+ where newBinExpr t v1 v2 = + case e of + Fadd fg _ _ _ -> Fadd fg t v1 v2+ Fsub fg _ _ _ -> Fsub fg t v1 v2+ Fmul fg _ _ _ -> Fmul fg t v1 v2+ Fdiv fg _ _ _ -> Fdiv fg t v1 v2+ Frem fg _ _ _ -> Frem fg t v1 v2++rwBinExpr :: MaybeChange a -> MaybeChange (BinExpr a)+rwBinExpr f (Ie e) = liftM Ie (rwIbinExpr f e)+rwBinExpr f (Fe e) = liftM Fe (rwFbinExpr f e)+++rwConversion :: MaybeChange a -> MaybeChange (Conversion a)+rwConversion f (Conversion co (TypedData ts v) t) = + do { v1 <- f v+ ; return $ Conversion co (TypedData ts v1) t+ }++rwGetElemPtr :: Eq a => MaybeChange a -> MaybeChange (GetElemPtr a)+rwGetElemPtr f (GetElemPtr b (TypedData ts (Pointer v)) indices) = + do { v1 <- f v+ -- ; indices1 <- fs f indices + ; return $ GetElemPtr b (TypedData ts (Pointer v1)) indices+ }++rwSelect :: MaybeChange a -> MaybeChange (Select a)+rwSelect f (Select tv1 tv2 tv3) = do { (tv1', tv2', tv3') <- f3 f (tv1, tv2, tv3)+ ; return $ Select tv1' tv2' tv3'+ }++rwIcmp :: MaybeChange a -> MaybeChange (Icmp a)+rwIcmp f (Icmp op t v1 v2) = do { (v1', v2') <- f2 f (v1, v2)+ ; return $ Icmp op t v1' v2'+ }+rwFcmp :: MaybeChange a -> MaybeChange (Fcmp a)+rwFcmp f (Fcmp op t v1 v2) = do { (v1', v2') <- f2 f (v1, v2)+ ; return $ Fcmp op t v1' v2'+ }++tv2v :: MaybeChange Value -> MaybeChange (Typed Value)+tv2v f (TypedData t x) = liftM (TypedData t) (f x)++tp2p :: MaybeChange Value -> MaybeChange (Typed (Pointer Value))+tp2p f x | trace ("tp2p " ++ (show x)) False = undefined+tp2p f (TypedData t (Pointer x)) = liftM (\p -> TypedData t (Pointer p)) (f x)+++rwExpr :: MaybeChange Value -> MaybeChange Expr+rwExpr f (EgEp gep) = rwGetElemPtr f gep >>= return . EgEp+rwExpr f (EiC a) = rwIcmp f a >>= return . EiC+rwExpr f (EfC a) = rwFcmp f a >>= return . EfC+rwExpr f (Eb a) = rwBinExpr f a >>= return . Eb+rwExpr f (Ec a) = rwConversion f a >>= return . Ec+rwExpr f (Es a) = rwSelect f a >>= return . Es+rwExpr f (Ev x) = (tv2v f x) >>= return . Ev+ ++rwMemOp :: MaybeChange Value -> MaybeChange Rhs +rwMemOp f x | trace ("rwMemOp " ++ (show x)) False = undefined+rwMemOp f (RmO (Allocate m t ms ma)) = do { ms' <- maybeM (tv2v f) ms+ ; return $ RmO $ Allocate m t ms' ma+ }+rwMemOp f (RmO (Load x ptr a1 a2 a3 a4)) = + do { tp <- (tp2p f) ptr+ ; traceM $ "tp:" ++ show tp+ ; return $ RmO (Load x tp a1 a2 a3 a4)+ }+ {-+rwMemOp f (RmO (LoadAtomic _ _ (TypedData (Tpointer t _) ptr) _)) = do { tv <- (tv2v f) (TypedData t (Deref ptr))+ ; return $ Re $ Ev tv+ }+ -}+-- rwMemOp f (RmO (Free tv)) = (tv2v f) tv >>= return . RmO . Free +rwMemOp f (RmO (Store a tv1 tv2 ma nt)) = do { tv1' <- (tv2v f) tv1+ ; return $ RmO $ Store a tv1' tv2 ma nt+ }+rwMemOp f (RmO (StoreAtomic at a tv1 tv2 ma)) = do { tv1' <- (tv2v f) tv1+ ; return $ RmO $ StoreAtomic at a tv1' tv2 ma+ } +rwMemOp f (RmO (CmpXchg wk b ptr v1 v2 b2 fe ff)) = do { (v1', v2') <- f2 (tv2v f) (v1, v2)+ ; return $ RmO $ CmpXchg wk b ptr v1' v2' b2 fe ff+ }+rwMemOp f (RmO (AtomicRmw b ao ptr v1 b2 fe)) = do { v1' <- (tv2v f) v1+ ; return $ RmO $ AtomicRmw b ao ptr v1' b2 fe+ }+rwMemOp _ _ = error "impossible case" ++rwShuffleVector :: MaybeChange a -> MaybeChange (ShuffleVector a)+rwShuffleVector f (ShuffleVector tv1 tv2 tv3) = + do { (tv1', tv2', tv3') <- f3 f (tv1, tv2, tv3)+ ; return $ ShuffleVector tv1' tv2' tv3'+ }+ +rwExtractValue :: MaybeChange a -> MaybeChange (ExtractValue a)+rwExtractValue f (ExtractValue (TypedData t v) s) = + f v >>= \v1 -> return $ ExtractValue (TypedData t v1) s++rwInsertValue :: MaybeChange a -> MaybeChange (InsertValue a)+rwInsertValue f (InsertValue tv1 tv2 s) = do { (tv1', tv2') <- f2t f (tv1, tv2)+ ; return $ InsertValue tv1' tv2' s+ }+ +rwExtractElem :: MaybeChange a -> MaybeChange (ExtractElem a)+rwExtractElem f (ExtractElem tv1 tv2) = do { (tv1', tv2') <- f2t f (tv1, tv2)+ ; return $ ExtractElem tv1' tv2'+ }++rwInsertElem :: MaybeChange a -> MaybeChange (InsertElem a)+rwInsertElem f (InsertElem tv1 tv2 tv3) = do { (tv1', tv2', tv3') <- f3 f (tv1, tv2, tv3)+ ; return $ InsertElem tv1' tv2' tv3'+ }+rwRhs :: MaybeChange Value -> MaybeChange Rhs+rwRhs f (RmO a) = rwMemOp f (RmO a) +rwRhs _ (Call _ _) = Nothing+rwRhs f (Re a) = rwExpr f a >>= return . Re+rwRhs f (ReE a) = rwExtractElem f a >>= return . ReE+rwRhs f (RiE a) = rwInsertElem f a >>= return . RiE+rwRhs f (RsV a) = rwShuffleVector f a >>= return . RsV+rwRhs f (ReV a) = rwExtractValue f a >>= return . ReV+rwRhs f (RiV a) = rwInsertValue f a >>= return . RiV+rwRhs f (VaArg tv t) = (tv2v f) tv >>= \tv' -> return $ VaArg tv' t+rwRhs _ (LandingPad _ _ _ _ _) = Nothing+++rwComputingInst :: MaybeChange Value -> MaybeChange ComputingInst+rwComputingInst f (ComputingInst lhs rhs) = rwRhs f rhs >>= return . (ComputingInst lhs)++rwComputingInstWithDbg :: MaybeChange Value -> MaybeChange ComputingInstWithDbg+rwComputingInstWithDbg f (ComputingInstWithDbg cinst dbgs) = + rwComputingInst f cinst >>= \cinst' -> return $ ComputingInstWithDbg cinst' dbgs+ +rwCinst :: MaybeChange Value -> MaybeChange (Node e x)+rwCinst f (Cinst c) = rwComputingInstWithDbg f c >>= return . Cinst+rwCinst _ _ = Nothing+++rwTerminatorInst :: MaybeChange Value -> MaybeChange TerminatorInst+rwTerminatorInst f (Return ls) = do { ls' <- fs f ls+ ; return $ Return ls'+ }+rwTerminatorInst f (Cbr v tl fl) = do { v' <- f v+ ; return $ Cbr v' tl fl+ }+rwTerminatorInst _ _ = Nothing +-- rwTerminatorInst f e = error ("unhandled case " ++ (show e))+ ++rwTerminatorInstWithDbg :: MaybeChange Value -> MaybeChange TerminatorInstWithDbg+rwTerminatorInstWithDbg f (TerminatorInstWithDbg cinst dbgs) = + rwTerminatorInst f cinst >>= \cinst' -> return $ TerminatorInstWithDbg cinst' dbgs+ +rwTinst :: MaybeChange Value -> MaybeChange (Node e x)+rwTinst f (Tinst c) = rwTerminatorInstWithDbg f c >>= return . Tinst+rwTinst _ _ = Nothing+-}++rwNode :: MaybeChange Value -> MaybeChange (Node a e x)+rwNode = undefined++{-+rwNode f n@(Cinst _) = rwCinst f n+rwNode f n@(Tinst _) = rwTinst f n+rwNode _ _ = Nothing+-}++nodeToGraph :: Node a e x -> H.Graph (Node a) e x+nodeToGraph n@(Nlabel _) = H.mkFirst n+nodeToGraph n@(Pinst _) = H.mkMiddle n+nodeToGraph n@(Cinst _) = H.mkMiddle n+nodeToGraph n@(Tinst _) = H.mkLast n++
+ src/Llvm/Pass/Uda.hs view
@@ -0,0 +1,166 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++#define FLC (FileLoc $(srcLoc))+{-+ This module compute the use, def, and Addr of CoreIr+-}+module Llvm.Pass.Uda where+import Llvm.Data.CoreIr+import qualified Data.Set as Ds+import Data.Monoid+import Prelude (Show, Eq, Ord, fst, (.), ($), map, maybe, Maybe, (++), show, Bool(False), undefined, foldl,error+ ,fmap)+#ifdef DEBUG+import Debug.Trace+#endif++import Llvm.Query.TypeConstValue+import Llvm.Query.IrCxt+import qualified Llvm.Query.TypeConstValue as Tc++class Uda a where+ use :: a -> Ds.Set GlobalOrLocalId+ def :: a -> Ds.Set LocalId -- defined ssa variables+ + storeTo :: a -> Ds.Set Value+ storeTo _ = Ds.empty+ + loadFrom :: a -> Ds.Set Value+ loadFrom _ = Ds.empty + +instance Uda Const where+ use c = case c of+ C_globalAddr i -> Ds.insert (GolG i) Ds.empty+ _ -> Ds.empty+ def _ = Ds.empty++instance Uda v => Uda (GetElementPtr s v) where+ use (GetElementPtr _ (T _ ptr) indices) = use ptr `Ds.union` (foldl (\p e -> Ds.union p (use e)) Ds.empty indices)+ def _ = Ds.empty+ +instance Uda v => Uda (Maybe v) where + use x = maybe Ds.empty use x+ def x = maybe Ds.empty def x+ storeTo x = maybe Ds.empty storeTo x+ +instance Uda v => Uda (T t v) where + use (T _ x) = use x+ def (T _ x) = def x+ storeTo (T _ x) = storeTo x+ +instance Uda LocalId where+ use x = Ds.insert (GolL x) Ds.empty+ def x = Ds.insert x Ds.empty+ storeTo x = Ds.insert (Val_ssa x) Ds.empty+ +instance Uda Value where+ use x = case x of+ Val_ssa l -> Ds.insert (GolL l) Ds.empty+ Val_const c -> use c+ def _ = error $ "cannot happen"+ storeTo x = Ds.insert x Ds.empty+ +instance Uda ActualParam where+ use ap = case ap of+ ActualParamData _ _ _ v _ -> use v+ ActualParamLabel _ _ _ v _ -> use v+ ActualParamMeta _ -> Ds.empty+ def _ = errorLoc FLC $ "cannot happen"+ storeTo _ = errorLoc FLC $ "cannot happen"+ loadFrom _ = errorLoc FLC $ "cannot happen"+ + +instance Uda x => Uda [x] where + use l = Ds.unions (fmap use l)+ def l = Ds.unions (fmap def l)+ storeTo l = Ds.unions (fmap storeTo l)+ loadFrom l = Ds.unions (fmap loadFrom l)++instance Uda CallSite where+ use x = case x of+ CsFun _ _ _ _ l _ -> use l+ CsAsm _ _ _ _ _ _ l _ -> use l+ CsConversion _ _ _ l _ -> use l++instance Uda CInst where + use ci = case ci of+ I_alloca{..} -> use size+ I_load{..} -> use pointer+ I_loadatomic{..} -> use pointer+ I_store{..} -> Ds.union (use storedvalue) (use pointer)+ I_storeatomic{..} -> Ds.union (use storedvalue) (use pointer)+ I_fence{..} -> Ds.empty+ I_cmpxchg_I{..} -> Ds.unions [use pointer,use cmpi,use newi]+ I_cmpxchg_F{..} -> Ds.unions [use pointer,use cmpf,use newf]+ I_cmpxchg_P{..} -> Ds.unions [use pointer,use cmpp,use newp]+ I_atomicrmw{..} -> Ds.unions [use pointer,use val]+ I_call_fun{..} -> use actualParams+ I_call_other{..} -> use callSite+ I_extractelement_I{..} -> Ds.unions [use vectorI, use index]+ I_extractelement_F{..} -> Ds.unions [use vectorF, use index]+ I_extractelement_P{..} -> Ds.unions [use vectorP, use index]+ I_bitcast{..} -> use srcP+ I_ptrtoint{..} -> use srcP+ I_inttoptr{..} -> use srcI+ I_add{..} -> use operand1 `mappend` use operand2+ I_getelementptr{..} -> use pointer `mappend` (foldl (\p e -> p `mappend` (use e)) Ds.empty indices)+ I_getelementptr_V{..} -> use vpointer `mappend` (foldl (\p e -> p `mappend` (use e)) Ds.empty vindices)+ I_llvm_dbg_declare{..} -> Ds.empty+ I_icmp{..} -> use operand1 `mappend` use operand2+ I_icmp_V{..} -> use operand1 `mappend` use operand2+ I_va_end{..} -> use pointer+ I_va_start{..} -> use pointer+ I_va_arg tv _ _ -> use tv+ _ -> errorLoc FLC $ "unsupported " ++ show ci+ def ci = case ci of+ I_alloca{..} -> def result+ I_load{..} -> def result+ I_store{..} -> Ds.empty+ I_bitcast{..} -> def result+ I_ptrtoint{..} -> def result+ I_inttoptr{..} -> def result+ I_add{..} -> def result+ I_sub{..} -> def result+ I_mul{..} -> def result+ I_udiv{..} -> def result+ I_sdiv{..} -> def result+ I_urem{..} -> def result+ I_srem{..} -> def result+ I_shl{..} -> def result+ I_lshr{..} -> def result+ I_ashr{..} -> def result + I_and{..} -> def result + I_or{..} -> def result + I_xor{..} -> def result + I_getelementptr{..} -> def result+ I_llvm_dbg_declare{..} -> Ds.empty+ I_icmp{..} -> def result+ I_icmp_V{..} -> def result+ I_trunc{..} -> def result+ I_sext{..} -> def result+ I_va_start{..} -> Ds.empty+ I_va_arg{..} -> def result+ I_va_end{..} -> Ds.empty+ _ -> errorLoc FLC $ "unsupported " ++ show ci + storeTo ci = case ci of+ I_store{..} -> storeTo pointer+ I_va_start tv -> storeTo tv+ _ -> Ds.empty+ loadFrom ci = case ci of+ I_load{..} -> let T _ v = pointer+ in Ds.insert v Ds.empty+ _ -> Ds.empty+++instance Uda CInstWithDbg where + use (CInstWithDbg ci _) = use ci+ def (CInstWithDbg ci _) = def ci+ storeTo (CInstWithDbg ci _) = storeTo ci+ loadFrom (CInstWithDbg ci _) = loadFrom ci+ + +
+ src/Llvm/Query/Conversion.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+module Llvm.Query.Conversion where+import Llvm.Data.CoreIr+import Llvm.Query.Qerror+import Llvm.Data.IrType+import Debug.Trace++strToApInt :: String -> Integer+-- strToApInt s | trace ("parsing " ++ show s ++ " as int") False = undefined+strToApInt s = case ((reads s)::[(Integer,String)]) of+ [(n,"")] -> n+ _ -> error $ "is not integer " ++ s++castTypedValueToTypedConst :: Show t => T t Value -> T t Const+castTypedValueToTypedConst (T t (Val_const c)) = T t c+castTypedValueToTypedConst x = error $ "is not const " ++ show x++castTypedConstToTypedValue :: T t Const -> T t Value +castTypedConstToTypedValue (T t c) = T t (Val_const c) +++zExtTo32or64 :: MonadError Qerror m => Integer -> m Integer+zExtTo32or64 n = return n -- FIXME n should be less then or equal to uint64_t++castToStructType :: MonadError Qerror m => Type x r -> m (Packing, [Dtype])+castToStructType (Tstruct p ts) = return (p, ts)+castToStructType x = throwError (QerrWithInfo $ (show x) ++ " is not a struct type")++getUniqueInteger :: Show t => T t Const -> Integer+getUniqueInteger (T _ (C_int s)) = strToApInt s+getUniqueInteger (T _ (C_u8 s)) = fromIntegral s+getUniqueInteger (T _ (C_u16 s)) = fromIntegral s+getUniqueInteger (T _ (C_u32 s)) = fromIntegral s+getUniqueInteger (T _ (C_s8 s)) = fromIntegral s+getUniqueInteger (T _ (C_s16 s)) = fromIntegral s+getUniqueInteger (T _ (C_s32 s)) = fromIntegral s+getUniqueInteger x = error $ "is not integer " ++ show x+++type ExponentType = Int +data FloatingSemantics = FloatingSemantics { maxExponent :: ExponentType + , minExponent :: ExponentType+ , precision :: Integer+ } deriving (Eq, Ord, Show)++ieeeHalf = FloatingSemantics 15 (-14) 11+ieeeSingle = FloatingSemantics 127 (-126) 24+ieeeDouble = FloatingSemantics 1023 (-1022) 53+ieeeQuad = FloatingSemantics 16383 (-16382) 113+x87DoubleExtended = FloatingSemantics 16383 (-16382) 64+pPcDoubleDouble = FloatingSemantics 1023 (-1022+53) (53+53)+bogus = FloatingSemantics 0 0 0++data InMemRep = InMemRep (Type ScalarB I) SimpleConstant deriving (Eq, Ord, Show)+{-+castPointerToValue :: Typed Pointer -> Typed Value+castPointerToValue (Typed (Tpointer _) (Pointer v)) = Ec (Conversion +-}
+ src/Llvm/Query/IrCxt.hs view
@@ -0,0 +1,50 @@+module Llvm.Query.IrCxt where+import qualified Llvm.Data.CoreIr as Ci+import qualified Data.Map as M+import Llvm.Data.Ir++data TypeEnv = TypeEnv { dataLayout :: Ci.DataLayoutInfo+ , targetTriple :: Ci.TargetTriple+ , typedefs :: M.Map Ci.LocalId Ci.Dtype+ } deriving (Eq, Ord, Show)++data FunCxt = FunCxt { funName :: String + , funParameters :: M.Map Ci.LocalId Ci.Dtype+ } deriving (Eq, Ord, Show)++data GlobalCxt = GlobalCxt { typeEnv :: TypeEnv+ , globals :: M.Map (Maybe Ci.GlobalId) (TlGlobal, Ci.Dtype)+ } deriving (Eq, Ord, Show)+ +data IrCxt = IrCxt { globalCxt :: GlobalCxt+ , funCxt :: FunCxt+ } deriving (Eq, Ord, Show)++irCxtOfModule :: Module a -> IrCxt+irCxtOfModule (Module tl) = + let [ToplevelDataLayout (TlDataLayout dl)] = filter (\x -> case x of+ ToplevelDataLayout _ -> True+ _ -> False+ ) tl+ [ToplevelTriple (TlTriple tt)] = filter (\x -> case x of+ ToplevelTriple _ -> True+ _ -> False+ ) tl+ tdefs = fmap (\(ToplevelTypeDef (TlDatTypeDef lhs def)) -> (lhs, def)) $ filter (\x -> case x of+ ToplevelTypeDef _ -> True+ _ -> False+ ) tl+ glbs = fmap (\(ToplevelGlobal g@(TlGlobalDtype lhs _ _ _ _ _ _ _ _ t _ _ _ _)) -> (lhs, (g,t))) $ filter (\x -> case x of+ ToplevelGlobal _ -> True+ _ -> False+ ) tl+ in IrCxt { globalCxt = GlobalCxt { typeEnv = TypeEnv { dataLayout = getDataLayoutInfo dl+ , targetTriple = tt+ , typedefs = M.fromList tdefs+ }+ , globals = M.fromList glbs+ }+ , funCxt = FunCxt { funName = ""+ , funParameters = M.empty+ }+ }
+ src/Llvm/Query/Qerror.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE FlexibleContexts #-}+module Llvm.Query.Qerror + (module Llvm.Query.Qerror+ ,module Control.Monad.Error+ ) where+import Control.Monad.Error++data Qerror = QerrIsNotInteger String+ | QerrIsNotConst String+ | QerrWithoutInfo+ | QerrWithInfo String+ deriving (Eq, Ord, Show)++instance Error Qerror where+ noMsg = QerrWithoutInfo+ strMsg s = QerrWithInfo s+ +{- +suppressQerror :: MonadError Qerror m => m a -> a +suppressQerror ma = case catchError ma (\err -> strMsg err) of+ (Right a) -> a+ (Left e) -> error $ show e +-}
+ src/Llvm/Query/TypeConstValue.hs view
@@ -0,0 +1,364 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+module Llvm.Query.TypeConstValue where++#define FLC (FileLoc $(srcLoc))+++import Llvm.Data.Shared+import Llvm.Data.IrType+import qualified Data.Map as M+import qualified Data.Bits as B+import Llvm.Data.CoreIr+import Llvm.Query.IrCxt +import Llvm.Query.Conversion+import Debug.Trace+import Llvm.Query.TypeDef+import Data.Word++eightBits :: Word32+eightBits = 8++data SizeInByte = SizeInByte Word32 deriving (Eq, Ord, Show)+data OffsetInByte = OffsetInByte Word32 deriving (Eq, Ord, Show)+data AlignInByte = AlignInByte Word32 deriving (Eq, Ord, Show)++fromSizeInBit :: SizeInBit -> SizeInByte+fromSizeInBit (SizeInBit n) = SizeInByte (n `div` eightBits)++toSizeInBit :: SizeInByte -> SizeInBit+toSizeInBit (SizeInByte n) = SizeInBit (n * eightBits)++fromAlignInBit :: AlignInBit -> AlignInByte+fromAlignInBit (AlignInBit n) = AlignInByte (n `div` eightBits)+++getTypeAlignment :: TypeEnv -> Dtype -> AlignType -> AlignInByte+getTypeAlignment te@TypeEnv{..} t at = case t of+ DtypeScalarI st -> fromAlignInBit $ getTpAlignment dataLayout st+ DtypeScalarF st -> fromAlignInBit $ getTpAlignment dataLayout st + DtypeRecordD st -> case st of+ Tarray i et -> getTypeAlignment te et at+ Tstruct p tys -> case (p, at) of+ (Packed, AlignAbi) -> AlignInByte 1+ _ -> let aa = case M.lookup (Just $ SizeInBit 0) (aggregates dataLayout) of+ Just (aa, pa) -> selectAlignment at aa pa+ Nothing -> errorX+ sl = getStructLayout te (p,tys)+ in (max (fromAlignInBit aa) (structAlignment sl))+ DtypeScalarP st -> case st of + Tpointer t a -> case (uncurry lookupOr) (ta $ Just a) (pointers dataLayout) of+ Just (s, aa, pa) -> (fromAlignInBit $ selectAlignment at aa pa)+ Nothing -> errorX+ where+ errorX :: a+ errorX = error $ "getTypedAlignment:unsupported " ++ show t+ getTpAlignment :: DataLayoutInfo -> Type ScalarB x -> AlignInBit+ getTpAlignment dl tp = case tp of+ TpI n -> case M.lookup (SizeInBit n) (ints dl) of+ Just (aa, pa) -> selectAlignment at aa pa+ Nothing -> AlignInBit n+ TpF n -> case M.lookup (SizeInBit n) (floats dl) of+ Just (aa, pa) -> selectAlignment at aa pa+ Nothing -> AlignInBit n+ TpV n -> case M.lookup (SizeInBit n) (vectors dl) of+ Just (aa, pa) -> selectAlignment at aa pa+ Nothing ->AlignInBit n+ TpHalf -> AlignInBit 16 + TpFloat -> let b = getTypeSizeInBits te (ucast tp)+ in case M.lookup b (floats dl) of+ Just (aa, pa) -> selectAlignment at aa pa+ Nothing -> AlignInBit 32+ TpDouble -> let b = getTypeSizeInBits te (ucast tp)+ in case M.lookup b (floats dl) of+ Just (aa, pa) -> selectAlignment at aa pa+ Nothing -> AlignInBit 64+ TpFp128 -> let b = getTypeSizeInBits te (ucast tp)+ in case M.lookup b (floats dl) of+ Just (aa, pa) -> selectAlignment at aa pa+ Nothing -> errorX+ TpX86Fp80 -> let b = getTypeSizeInBits te (ucast tp)+ in case M.lookup b (floats dl) of+ Just (aa, pa) -> selectAlignment at aa pa+ Nothing -> errorX+ TpPpcFp128 -> let b = getTypeSizeInBits te (ucast tp)+ in case M.lookup b (floats dl) of+ Just (aa, pa) -> selectAlignment at aa pa+ Nothing -> errorX+ TpX86Mmx -> errorX++ta :: Maybe AddrSpace -> (LayoutAddrSpace, LayoutAddrSpace)+ta x = case x of+ Just n | n == 0 -> (LayoutAddrSpaceUnspecified, LayoutAddrSpace n)+ Just n -> (LayoutAddrSpace n, LayoutAddrSpace n) + Nothing -> (LayoutAddrSpaceUnspecified, LayoutAddrSpace 0)+++getCallFrameTypeAlignment :: TypeEnv -> Dtype -> AlignInByte+getCallFrameTypeAlignment te@TypeEnv{..} ty = case stackAlign dataLayout of+ StackAlign n -> fromAlignInBit n+ StackAlignUnspecified -> getTypeAlignment te ty AlignAbi++lookupOr :: Ord a => a -> a -> M.Map a r -> Maybe r+lookupOr a1 a2 m = maybe (M.lookup a2 m) Just (M.lookup a1 m)++getTypeSizeInBits :: TypeEnv -> Dtype -> SizeInBit+getTypeSizeInBits te@TypeEnv{..} dt = case dt of+ (DtypeRecordD t) -> case t of+ Tarray i et -> let SizeInBit n = getTypeAllocSizeInBits te et+ in SizeInBit (i * n)+ Tstruct pk ts -> let sl = getStructLayout te (pk, ts)+ in toSizeInBit $ structSize sl+ TnameRecordD n -> case getTypeByTname n typedefs of+ Just d -> getTypeSizeInBits te d+ Nothing -> errorLoc FLC ("undefined " ++ show n)+ _ -> errorLoc FLC (show t)+ (DtypeScalarP (Tpointer t a)) -> case (uncurry lookupOr) (ta $ Just a) (pointers dataLayout) of+ Just (n, _, _) -> n+ Nothing -> error $ "getTypeSizeInBits:unsupported type " ++ show t+ (DtypeScalarI t) -> case t of + TpI n -> SizeInBit n+ TpV n -> SizeInBit n+ (DtypeScalarF t) -> case t of + TpF n -> SizeInBit n+ TpHalf -> SizeInBit 16+ TpFloat -> SizeInBit 32+ TpDouble -> SizeInBit 64+ TpFp128 -> SizeInBit 128+ TpX86Fp80 -> SizeInBit 80+ TpPpcFp128 -> SizeInBit 128+ _ -> errorLoc FLC (show dt)+ ++getTypeStoreSize :: TypeEnv -> Dtype -> SizeInByte+getTypeStoreSize te ty = let (SizeInBit tyBits) = getTypeSizeInBits te ty+ in fromSizeInBit (SizeInBit (tyBits + 7))++getTypeStoreSizeInBits :: TypeEnv -> Dtype -> SizeInBit+getTypeStoreSizeInBits te ty = toSizeInBit (getTypeStoreSize te ty)++getTypeAllocSize :: TypeEnv -> Dtype -> SizeInByte+getTypeAllocSize te ty = roundUpAlignment (getTypeStoreSize te ty) (getTypeAlignment te ty AlignAbi)++getTypeAllocSizeInBits :: TypeEnv -> Dtype -> SizeInBit+getTypeAllocSizeInBits te ty = toSizeInBit (getTypeAllocSize te ty)++data StructLayout = StructLayout { structSize :: SizeInByte+ , structAlignment :: AlignInByte+ , numElements :: Integer+ , memberOffsets :: [OffsetInByte]+ } deriving (Eq, Ord, Show)++roundUpAlignment :: SizeInByte -> AlignInByte -> SizeInByte+roundUpAlignment (SizeInByte val) (AlignInByte align) = SizeInByte $ (val + (align -1)) B..&. (B.complement (align - 1))++getStructLayout :: TypeEnv -> (Packing, [Dtype]) -> StructLayout+getStructLayout te@TypeEnv{..} (pk, tys) = + let (totalSize@(SizeInByte totalSizeByte), offsets, alignment@(AlignInByte alignmentByte)) =+ foldl (\(curSize@(SizeInByte curSizeByte), offsets, AlignInByte structAlignment0) ty ->+ let tyAlign@(AlignInByte tyAlignByte) = case pk of+ Packed -> AlignInByte 1+ Unpacked -> getTypeAlignment te ty AlignAbi+ (SizeInByte nextOffsetByte) = if curSizeByte B..&. (tyAlignByte - 1) /= 0 then roundUpAlignment curSize tyAlign+ else curSize+ (SizeInByte tySize) = getTypeAllocSize te ty+ in (SizeInByte $ nextOffsetByte + tySize, (OffsetInByte nextOffsetByte):offsets, AlignInByte $ max tyAlignByte structAlignment0)+ ) (SizeInByte 0, [], AlignInByte 1) tys+ in StructLayout { structSize = if (totalSizeByte B..&. (alignmentByte - 1)) /= 0 then roundUpAlignment totalSize alignment+ else totalSize+ , structAlignment = alignment+ , numElements = toInteger $ length tys+ , memberOffsets = reverse offsets+ }++getPointerSizeInBits :: DataLayoutInfo -> Maybe AddrSpace -> SizeInBit+getPointerSizeInBits dl mas = case (uncurry lookupOr) (ta mas) (pointers dl) of+ Just (s, aa, pa) -> s+ Nothing -> error $ "getPointerSizeInBits:unsupported " ++ show dl++getPointerSize :: DataLayoutInfo -> Maybe AddrSpace -> SizeInByte+getPointerSize dl mas = fromSizeInBit (getPointerSizeInBits dl mas)++getPointerAlignment :: DataLayoutInfo -> Maybe AddrSpace -> AlignType -> AlignInByte+getPointerAlignment dl mas at = case (uncurry lookupOr) (ta mas) (pointers dl) of+ Just (s, aa, pa) -> fromAlignInBit $ selectAlignment at aa pa+ Nothing -> error $ "getPointerAlignment:unsupported " ++ show dl++++getScalarTypeSizeInBits :: DataLayoutInfo -> ScalarType -> SizeInBit+getScalarTypeSizeInBits dl x = + SizeInBit (case x of+ ScalarTypeI e -> case e of+ (TpI n) -> n+ (TpV n) -> n+ TpX86Mmx -> 64+ ScalarTypeF e -> case e of+ (TpF n) -> n+ TpHalf -> 16+ TpFloat -> 32+ TpDouble -> 64+ TpFp128 -> 128+ TpX86Fp80 -> 80+ TpPpcFp128 -> 128+ ScalarTypeP _ -> 32+ )+++getGetElemtPtrIndexedType :: TypeEnv -> Dtype -> [T (Type ScalarB I) Value] -> Dtype+getGetElemtPtrIndexedType te x is | trace ("getGetElemtPtrIndexedType : type:" ++ show x ++ ", " ++ show is) False = undefined+getGetElemtPtrIndexedType te x is = case is of + hd:tl -> case x of+ DtypeScalarP (Tpointer et _) -> if tl == [] then dcast FLC et+ else getGetElemtPtrIndexedType te (dcast FLC et) tl+ DtypeRecordD (TnameRecordD _) -> getGetElemtPtrIndexedType te (getTypeDef te x) is+ DtypeRecordD (TquoteNameRecordD _) -> getGetElemtPtrIndexedType te (getTypeDef te x) is + DtypeRecordD (TnoRecordD _) -> getGetElemtPtrIndexedType te (getTypeDef te x) is+ _ -> let ct = getTypeAtIndex te x (castTypedValueToTypedConst hd)+ in if tl == [] then ct+ else getGetElemtPtrIndexedType te ct tl++getTypeAtIndex :: Show t => TypeEnv -> Dtype -> T t Const -> Dtype+getTypeAtIndex _ x@(DtypeScalarP (Tpointer _ _)) _ = error $ "does not expect a pointer type: " ++ show x+getTypeAtIndex te t idx = + case (getTypeDef te t) of+ DtypeRecordD (Tstruct _ ts) -> let (ii::Word32) = fromIntegral $ getUniqueInteger idx+ in if ii < fromIntegral (length ts) then ts !! (fromIntegral ii)+ else error ("Invalid structure index! " ++ show ii)+ DtypeRecordD (Tarray n et) -> et + x -> error $ "Invalid indexing of " ++ show x++getTypeDef :: TypeEnv -> Dtype -> Dtype+getTypeDef TypeEnv{..} t = case t of+ DtypeRecordD (TnameRecordD n) -> maybe (error $ show t ++ " is not defined.") id (getTypeByTname n typedefs)+ DtypeRecordD (TquoteNameRecordD n) -> maybe (error $ show t ++ " is not defined.") id (getTypeByTquoteName n typedefs)+ DtypeRecordD (TnoRecordD n) -> maybe (error $ show t ++ " is not defined.") id (getTypeByTno n typedefs)+ DtypeRecordD _ -> t+ DtypeScalarI _ -> t+ DtypeScalarP _ -> t + DtypeScalarF _ -> t+ DtypeVectorI _ -> t+ DtypeVectorP _ -> t+ DtypeVectorF _ -> t+ DtypeFirstClassD _ -> t+++getElementType :: TypeEnv -> Dtype -> Dtype+getElementType te t = case getTypeDef te t of+ DtypeRecordD (Tarray _ t1) -> t1+ DtypeScalarP (Tpointer t1 _) -> dcast FLC t1+ _ -> error $ (show t) ++ " has not element type"++{-+getScalarType :: TypeEnv -> Dtype -> Dtype+getScalarType te (DtypeAgg (Tvector _ t)) = t+getScalarType te x = x+-}++castIsValid :: DataLayoutInfo -> Conversion ScalarB v -> Bool -- ConvertOp -> Dtype -> Dtype -> Bool+-- castIsValid op src dest | vsize src == vsize dest = case op of+castIsValid dl op = True + {-case op of + Trunc (T src _) dest -> getScalarTypeSizeInBits dl src > getScalarTypeSizeInBits dl+ Zext (T src _) dest -> getScalarTypeSizeInBits dl src < getScalarTypeSizeInBits dl+ Sext (T src _) dest -> getScalarTypeSizeInBits dl src < getScalarTypeSizeInBits dl+ FpTrunc (T src _) dest -> getScalarTypeSizeInBits dl src > getScalarTypeSizeInBits dl dest+ FpExt (T src _) dest -> getScalarTypeSizeInBits dl src < getScalarTypeSizeInBits dl dest+ UiToFp (T src _) dest -> vsize src == vsize dest && vmap isInt src && vmap isFp dest+ SiToFp (T src _) dest -> vsize src == vsize dest && vmap isInt src && vmap isFp dest+ FpToUi (T src _) dest -> vsize src == vsize dest && vmap isFp src && vmap isInt dest+ FpToSi (T src _) dest -> vsize src == vsize dest && vmap isFp src && vmap isInt dest+ PtrToInt (T src _) dest -> vsize src == vsize dest && vmap isInt src && vmap isPtr dest+ IntToPtr (T src _) dest -> vsize src == vsize dest && vmap isPtr src && vmap isInt dest+ Bitcast (T src _) dest -> vsize src == vsize dest && (vmap isPtr src && vmap isPtr dest && vmap addrSpace src == vmap addrSpace dest) {- ptr to ptr -}+ || (vmap (not . isPtr) src) && (vmap (getScalarTypeSizeInBits dl) src == vmap (getScalarTypeSizeInBits dl) dest) {- non ptr to ptr -}+ AddrSpaceCast (T src _) dest -> vsize src == vsize dest && vmap isPtr src && vmap isPtr dest && vmap addrSpace src == vmap addrSpace dest+ where isValid f s d = vmap f s && vmap f d+-}+++castable :: Show v => DataLayoutInfo -> Conversion ScalarB v -> Conversion ScalarB v+castable dl op = if castIsValid dl op then op+ else error $ "Invalid cast:" ++ show op ++++getConstArray :: Dtype -> [T Dtype Const] -> T Dtype Const+getConstArray t@(DtypeRecordD (Tarray n el)) [] = T t (C_array $ fmap (\x -> TypedConst $ T el C_zeroinitializer) [1..n])+getConstArray t@(DtypeRecordD (Tarray n el)) l = if or $ fmap (\(T vt _) -> vt /= el) l then error "type mismatch"+ else T t (C_array (fmap TypedConst l))+getConstArray t _ = error "type mismatch"+++getTypedConst :: TypeEnv -> (Type ScalarB x -> Const) -> Dtype -> T Dtype Const+getTypedConst te f t = case (getTypeDef te t) of+ (DtypeRecordD (Tarray n et)) -> let ev = getTypedConst te f et+ in T t (C_arrayN n $ TypedConst ev)+ (DtypeRecordD (Tstruct pk ts)) -> let evs = fmap (getTypedConst te f) ts+ in T t (C_struct pk (fmap TypedConst evs))++getNullValue :: Type ScalarB x -> Const+getNullValue t = case t of+-- TpVoid -> error $ show t ++ " has no null const value"+-- TpNull -> error $ show t ++ " has no null const value"+-- TpLabel -> error $ show t ++ " has no null const value"+ _ -> C_zeroinitializer++getUndefValue :: Type ScalarB x -> Const+getUndefValue t = case t of+-- TpVoid -> error $ show t ++ " has no undef const value"+-- TpNull -> error $ show t ++ " has no undef const value"+-- TpLabel -> error $ show t ++ " has no undef const value"+ _ -> C_undef++getPointerCast :: Show v => DataLayoutInfo -> T (Type ScalarB P) v -> Type ScalarB I -> Conversion ScalarB v+getPointerCast dl (T ts v) td = castable dl (PtrToInt (T ts v) td)++getBitCast :: Show v => DataLayoutInfo -> T Dtype v -> Dtype -> Conversion ScalarB v+getBitCast dl (T t c) dt = castable dl (Bitcast (T t c) dt)++getGetElementPtr :: T (Type ScalarB P) Const -> [T (Type ScalarB I) Const] -> IsOrIsNot InBounds -> GetElementPtr ScalarB Const+getGetElementPtr (T t cv) indices isB = GetElementPtr isB (T t cv) indices+++getIntStoreTypeForPointer :: DataLayoutInfo -> Dtype+getIntStoreTypeForPointer dl = let (SizeInBit sizeInBits) = getPointerSizeInBits dl Nothing+ in DtypeScalarI $ TpI sizeInBits++typeOfCallSite :: IrCxt -> CallSite -> Maybe Rtype+typeOfCallSite = error "typeOfCallSite is not defined yet"++typeOfExtractElem = undefined+typeOfInsertElem _ = Nothing+typeOfShuffleVector = undefined+typeOfExtractValue = undefined+typeOfInsertValue _ = Nothing++{-+castTcToTv :: T t Const -> T t Value+castTcToTv (T t c) = (T t (Val_const c))+-}+++class TypeOf a t | a -> t where + typeof :: TypeEnv -> a -> t+ + +instance TypeOf CInst Dtype where+ typeof te x = case x of+ I_getelementptr{..} -> let (T bt _) = pointer+ et = getGetElemtPtrIndexedType te (ucast bt) indices+ in (ucast $ Tpointer (ucast et) 0)+ I_add{..} -> ucast typeI+ I_bitcast{..} -> ucast toP+ I_ptrtoint{..} -> ucast toI+ I_inttoptr{..} -> ucast toP+ I_load{..} -> let (T (Tpointer et _) _) = pointer+ in dcast FLC et+ I_llvm_dbg_declare{..} -> error $ show x ++ " has no type"+ _ -> errorLoc FLC $ "unsupported " ++ show x
+ src/Llvm/Query/TypeDef.hs view
@@ -0,0 +1,13 @@+module Llvm.Query.TypeDef where++import Llvm.Data.Ir+import qualified Data.Map as M+ +getTypeByTname :: String -> M.Map LocalId Dtype -> Maybe Dtype+getTypeByTname tn mp = M.lookup (LocalIdAlphaNum tn) mp++getTypeByTquoteName :: String -> M.Map LocalId Dtype -> Maybe Dtype+getTypeByTquoteName tn mp = M.lookup (LocalIdDqString tn) mp++getTypeByTno :: Word32 -> M.Map LocalId Dtype -> Maybe Dtype+getTypeByTno n mp = M.lookup (LocalIdNum n) mp
+ src/Llvm/Syntax/Parser/Basic.hs view
@@ -0,0 +1,491 @@+module Llvm.Syntax.Parser.Basic+ ( module Text.Parsec+ , module Llvm.Syntax.Parser.Basic+ , module Control.Monad+ , module Text.Parsec.Perm+ )+ where++import Text.Parsec +import Control.Monad+import Llvm.Data.Ast+import qualified Text.Parsec.Token as T+import Text.Parsec.Language+import Text.Parsec.Perm+import Data.Char+import Data.Functor.Identity (Identity)+import qualified Data.Map as M+import Data.Word (Word32)++-- dummy state+-- data DummyState = DummyState++type DummyState = ()++type P a = Parsec String DummyState a++initState :: DummyState+initState = () -- DummyState ++lexer :: T.GenTokenParser String u Data.Functor.Identity.Identity+lexer = T.makeTokenParser + (emptyDef + { T.commentLine = ";"+ , T.reservedNames = + [ "begin", "end", "true", "false", "declare", "define", "global", "constant"+ , "dllimport", "dllexport"+ , "extern_weak", "external", "thread_local", "zeroinitializer", "undef", "null", "to", "tail"+ , "target", "triple", "deplibs", "datalayout", "volatile", "nuw", "nsw", "exact", "inbounds", "align"+ , "addrspace", "section", "alias", "module", "asm", "sideeffect", "gc", "ccc", "cc", "fastcc"+ , "coldcc", "x86_stdcallcc", "x86_fastcallcc", "x86_thiscallcc", "arm_apcscc", "arm_aapcscc", "arm_aapcs_vfpcc"+ , "msp430_intrcc", "cc", "c", "signext", "zeroext", "inreg", "sret", "nounwind", "noreturn", "noalias"+ , "nocapture", "byval", "nest", "type", "opaque", "eq", "ne", "slt", "sgt"+ , "sle", "sge", "ult", "ugt", "ule", "uge", "oeq", "one", "olt", "ogt", "ole", "oge", "ord", "uno", "ueq"+ , "une", "x", "blockaddress"+ , "add", "fadd", "sub", "fsub", "mul", "fmul", "udiv", "sdiv", "fdiv", "urem", "srem", "frem"+ , "shl", "lshr", "ashr", "and", "or", "xor", "icmp", "fcmp", "phi", "call", "trunc"+ , "zext", "sext", "fptrunc", "fpext", "uitofp", "sitofp", "fptoui", "fptosi", "inttoptr", "ptrtoint"+ , "bitcast", "addrspacecast", "select", "va_arg", "ret", "br", "switch", "indirectbr"+ , "invoke", "unwind", "unreachable"+ , "alloca", "malloc", "load", "store", "getelementptr", "extractelement", "insertelement", "shufflevector"+ , "getresult", "extractvalue", "insertvalue", "free", "address_safety", "nonlazybind", "landingpad", "cleanup"+ , "catch", "filter", "personality", "half", "unnamed_addr", "singlethread", "acquire"+ , "release", "acq_rel", "seq_cst", "unordered", "monotonic", "atomic"+ , "atomicrmw", "xchg", "nand", "max", "min", "umax", "umin", "x86_mmx"+ , "call", "tail", "musttail"+ -- Linkage Types + , "private", "internal", "available_externally", "linkonce", "weak", "common", "appending", "extern_weak"+ , "linkonce_odr", "weak_odr", "external"+ -- Calling Conventions+ , "ccc", "fastcc", "coldcc", "cc", "webkit_jscc", "anyregcc", "preserve_mostcc", "preserve_allcc"+ , "spir_kernel", "spir_func", "intel_ocl_bicc", "x86_stdcallcc", "x86_fastcallcc", "x86_thiscallcc"+ , "arm_apcscc", "arm_aapcscc", "arm_aapcs_vfpcc", "msp430_intrcc", "ptx_kernel", "ptx_device"+ , "x86_64_win64cc", "x86_64_sysvcc"+ -- Visibility Styles + , "default", "hidden", "protected"+ -- Parameter Attributes + , "zeroext", "signext", "inreg", "byval", "inalloca", "sret", "noalias", "nocapture", "nest", "returned"+ , "nonnull", "dereferenceable"+ -- Function Attributes+ , "alignstack", "alwaysinline", "builtin", "cold", "inlinehint", "jumptable", "minsize", "naked", "nobuiltin"+ , "noduplicate", "noimplicitfloat", "noinline", "nonlazybind", "noredzone", "noreturn", "nounwind", "optnone"+ , "optsize", "readnone", "readonly", "returns_twice", "sanitize_address", "sanitize_memory", "sanitize_thread"+ , "ssp", "sspreq", "sspstrong", "uwtable"+ -- Fast math flags+ , "nnan", "ninf", "nsz", "arcp", "fast"+ , "inteldialect"+ , "<<label>>"+ ]+ })+ ++integer :: P Integer+integer = T.integer lexer++unsignedInt :: P Word32+unsignedInt = liftM fromIntegral integer++decimal :: P Integer+decimal = lexeme (T.decimal lexer)+++reserved :: String -> P ()+reserved = T.reserved lexer+++symbol :: String -> P String+symbol = T.symbol lexer+++lexeme :: P a -> P a+lexeme = T.lexeme lexer+++intStrToken :: P String+intStrToken = lexeme numericLit <?> "intStringToken"+++whiteSpace :: P ()+whiteSpace = T.whiteSpace lexer++ignore :: P a -> P ()+ignore p = do { _ <- p ; return () }++chartok :: Char -> P Char+chartok = lexeme . char++complete :: P a -> P a+complete p = do { whiteSpace; x <- p; eof; return x }++-------------------------------------------------------------------------------+comma :: P String+comma = T.comma lexer++colon :: P String+colon = T.colon lexer++braces :: P a -> P a+braces = T.braces lexer ++brackets :: P a -> P a+brackets = T.brackets lexer ++parens :: P a -> P a+parens = T.parens lexer++angles :: P a -> P a+angles = T.angles lexer++anglebraces :: P a -> P a+anglebraces p = between (symbol "<{") (symbol "}>") p+++-------------------------------------------------------------------+idChar :: Char -> Bool+idChar c = isAlphaNum c || c == '$' || c == '.' || c == '_' || c == '-' ++startChar :: Char -> Bool+startChar c = isAlpha c || c == '$' || c == '.' || c == '_' || c == '-'++pAlphaNum :: P String+pAlphaNum = do { h <- satisfy startChar+ ; l <- many (satisfy idChar)+ ; return (h:l)+ }++pLocalId :: P LocalId+pLocalId = do { x <- lexeme (char '%' >> choice [ liftM LocalIdNum unsignedInt -- decimal+ , try $ liftM (LocalIdAlphaNum) pAlphaNum+ , try $ liftM (LocalIdAlphaNum) (lexeme (between (char '"') (char '"') pAlphaNum))+ , liftM (LocalIdDqString) pQuoteStr+ ])+ ; return x+ }++pGlobalId :: P GlobalId+pGlobalId = lexeme (char '@' >> choice [ liftM GlobalIdNum unsignedInt -- decimal+ , try $ liftM (GlobalIdAlphaNum) pAlphaNum -- (many1 (satisfy idChar))+ , try $ liftM GlobalIdAlphaNum (lexeme (between (char '"') (char '"') pAlphaNum))+ , liftM GlobalIdDqString pQuoteStr+ ])++pDollarId :: P DollarId+pDollarId = lexeme (char '$' >> choice [ liftM DollarIdNum unsignedInt -- decimal+ , try $ liftM (DollarIdAlphaNum) pId + , try $ liftM DollarIdAlphaNum (lexeme (between (char '"') (char '"') pId))+ , liftM (DollarIdDqString) pQuoteStr+ ])+++pMdVar :: P MdVar+pMdVar = lexeme $ do { ignore (char '!')+ ; n <- choice [ liftM (\x -> [x]) (satisfy isAlpha)+ , char '\\' >> numericLit ]+ ; l <- many (satisfy idChar)+ ; return $ MdVar (n++l)+ }++pId :: P String+pId = do { n <- (satisfy isAlpha)+ ; l <- many (satisfy idChar)+ ; return $ n:l+ }+ +pGlobalOrLocalId :: P GlobalOrLocalId+pGlobalOrLocalId = do { x <- choice [liftM GolL pLocalId+ , liftM GolG pGlobalId ]+ ; return x+ }+++numericLit :: P String+numericLit = many1 (satisfy isNumber)++pQuoteStr :: P String+pQuoteStr = lexeme ((char '"' >> (manyTill anyChar (char '"'))))++readInteger :: String -> Either String Integer +readInteger x = case reads x :: [(Integer, String)] of+ [(i,s)] | s == "" -> Right i+ [] -> Left x + _ -> Left x+ +pLabelId :: P LabelId+pLabelId = choice [ do { s <- (many1 (satisfy lblChar))+ ; case readInteger s of+ Right x -> return $ LabelNumber $ fromIntegral x+ Left x -> return $ LabelString x+ }+ , do { s <- pQuoteStr+ ; case readInteger s of+ Right x -> return $ LabelDqNumber $ fromIntegral x+ Left x -> return $ LabelDqString x+ }+ ]+ where+ lblChar c = isAlphaNum c || c == '.' || c == '_' || c == '-' + + +pLabelNumber :: P LabelId+pLabelNumber = do { x <- many1 (satisfy isDigit)+ ; let i = read x:: Word32 -- Int + ; return $ LabelNumber i+ }+ +pAddrNaming :: P AddrNaming+pAddrNaming = option NamedAddr (reserved "unnamed_addr" >> return UnnamedAddr)+ +pPercentLabel :: P PercentLabel+pPercentLabel = lexeme (char '%' >> liftM PercentLabel pLabelId)++pTargetLabel :: P TargetLabel+pTargetLabel = reserved "label" >> liftM TargetLabel pPercentLabel++pExplicitBlockLabel :: P BlockLabel+pExplicitBlockLabel = lexeme (do { x <- pLabelId + ; _ <- char ':'+ ; return $ ExplicitBlockLabel x+ })+ +pImplicitBlockLabel :: P BlockLabel +pImplicitBlockLabel = do { pos <- getPosition+ ; return $ ImplicitBlockLabel (sourceName pos, sourceLine pos, sourceColumn pos)+ }+ ++pBlockLabel :: P BlockLabel +pBlockLabel = choice [ try pExplicitBlockLabel+ , pImplicitBlockLabel ]++pParamAttr :: P ParamAttr+pParamAttr = choice [ reserved "zeroext" >> return PaZeroExt+ , reserved "signext" >> return PaSignExt+ , reserved "inreg" >> return PaInReg+ , reserved "byval" >> return PaByVal+ , reserved "inalloca" >> return PaInAlloca+ , reserved "sret" >> return PaSRet+ , reserved "noalias" >> return PaNoAlias+ , reserved "nocapture" >> return PaNoCapture+ , reserved "nest" >> return PaNest+ , reserved "returned" >> return PaReturned+ , reserved "nonnull" >> return PaNonNull+ , reserved "dereferenceable" >> liftM PaDereferenceable (parens unsignedInt) -- decimal)+ , reserved "readonly" >> return PaReadOnly+ , reserved "readnone" >> return PaReadNone+ , reserved "align" >> liftM PaAlign unsignedInt -- decimal+ ]++pConvertOp :: P ConvertOp+pConvertOp = choice $ fmap (\(x,y) -> reserved y >> return x) $ M.toList convertOpMap++pCallConv :: P CallConv+pCallConv = choice [ try (reserved "ccc") >> return Ccc+ , try (string "cc" >> liftM Cc intStrToken)+ , reserved "cc" >> liftM Cc intStrToken+ , reserved "fastcc" >> return CcFast+ , reserved "coldcc" >> return CcCold+ , reserved "webkit_jscc" >> return CcWebkit_Js+ , reserved "anyregcc" >> return CcAnyReg+ , reserved "preserve_mostcc" >> return CcPreserveMost+ , reserved "preserve_allcc" >> return CcPreserveAll+ , reserved "spir_kernel" >> return CcSpir_Kernel+ , reserved "spir_func" >> return CcSpir_Func+ , reserved "intel_ocl_bicc" >> return CcIntel_Ocl_Bi+ , reserved "x86_stdcallcc" >> return CcX86_StdCall+ , reserved "x86_fastcallcc" >> return CcX86_FastCall+ , reserved "x86_thiscallcc" >> return CcX86_ThisCall+ , reserved "arm_apcscc" >> return CcArm_Apcs+ , reserved "arm_aapcscc" >> return CcArm_Aapcs+ , reserved "arm_aapcs_vfpcc" >> return CcArm_Aapcs_Vfp+ , reserved "msp430_intrcc" >> return CcMsp430_Intr+ , reserved "ptx_kernel" >> return CcPtx_Kernel+ , reserved "ptx_device" >> return CcPtx_Device+ , reserved "x86_64_win64cc" >> return CcX86_64_Win64+ , reserved "x86_64_sysvcc" >> return CcX86_64_SysV+ ]+++pVisibility :: P Visibility+pVisibility = (reserved "default" >> return VisDefault)+ <|> (reserved "hidden" >> return VisHidden)+ <|> (reserved "protected" >> return VisProtected)+++pLinkage :: P Linkage+pLinkage = choice [ reserved "linker_private_weak_def_auto" >> return LinkagePrivate+ , reserved "linker_private_weak" >> return LinkagePrivate+ , reserved "private" >> return LinkagePrivate+ , reserved "linker_private" >> return LinkagePrivate+ , reserved "internal" >> return LinkageInternal+ , reserved "external" >> return LinkageExternal+ , reserved "available_externally" >> return LinkageAvailableExternally+ , reserved "linkonce" >> return LinkageLinkonce+ , reserved "weak" >> return LinkageWeak+ , reserved "common" >> return LinkageCommon+ , reserved "appending" >> return LinkageAppending+ , reserved "extern_weak" >> return LinkageExternWeak+ , reserved "linkonce_odr" >> return LinkageLinkonceOdr+ , reserved "weak_odr" >> return LinkageWeakOdr+ ]+++opt :: P a -> P (Maybe a)+opt p = option Nothing (liftM Just (try p))+++optCommaSep :: P a -> P (Maybe a)+optCommaSep p = opt (try (comma >> p))++++pIbinaryOperator :: P IbinOp+pIbinaryOperator = choice $ fmap (\(x,y) -> reserved y >> return x) $ M.toList ibinOpMap++pFbinaryOperator :: P FbinOp+pFbinaryOperator = choice $ fmap (\(x,y) -> reserved y >> return x) $ M.toList fbinOpMap++pIcmpOp :: P IcmpOp+pIcmpOp = choice $ fmap (\(x,y) -> reserved y >> return x) $ M.toList icmpOpMap++pFcmpOp :: P FcmpOp+pFcmpOp = choice $ fmap (\(x,y) -> reserved y >> return x) $ M.toList fcmpOpMap+++pAliasLinkage :: P Linkage+pAliasLinkage = choice [ reserved "private" >> return LinkagePrivate+ , reserved "internal" >> return LinkageInternal+ , reserved "available_externally" >> return LinkageAvailableExternally+ , reserved "linkonce" >> return LinkageLinkonce+ , reserved "weak" >> return LinkageWeak+ , reserved "common" >> return LinkageCommon+ , reserved "appending" >> return LinkageAppending+ , reserved "extern_weak" >> return LinkageExternWeak+ , reserved "linkonce_odr" >> return LinkageLinkonceOdr+ , reserved "weak_odr" >> return LinkageWeakOdr+ , reserved "external" >> return LinkageExternal+ ]++pDllStorageClass :: P DllStorageClass+pDllStorageClass = choice [ reserved "dllimport" >> return DscImport+ , reserved "dllexport" >> return DscExport+ ] +pThreadLocalStorageClass :: P ThreadLocalStorage +pThreadLocalStorageClass = reserved "thread_local" >> option TlsNone (parens (choice [ reserved "localdynamic" >> return TlsLocalDynamic+ , reserved "initialexec" >> return TlsInitialExec+ , reserved "localexec" >> return TlsLocalExec+ ]+ ))++pTailCall :: P TailCall+pTailCall = choice [ reserved "tail" >> return TcTailCall+ , reserved "musttail" >> return TcMustTailCall+ ]+pFunAttr :: P FunAttr+pFunAttr = choice [ reserved "alignstack" >> liftM FaAlignStack (parens unsignedInt) -- decimal)+ , reserved "alwaysinline" >> return FaAlwaysInline+ , reserved "builtin" >> return FaBuiltin+ , reserved "cold" >> return FaCold+ , reserved "inlinehint" >> return FaInlineHint+ , reserved "jumptable" >> return FaJumpTable+ , reserved "minsize" >> return FaMinSize+ , reserved "naked" >> return FaNaked+ , reserved "nobuiltin" >> return FaNoBuiltin+ , reserved "noduplicate" >> return FaNoDuplicate+ , reserved "noimplicitfloat" >> return FaNoImplicitFloat+ , reserved "noinline" >> return FaNoInline+ , reserved "nonlazybind" >> return FaNonLazyBind+ , reserved "noredzone" >> return FaNoRedZone+ , reserved "noreturn" >> return FaNoReturn+ , reserved "nounwind" >> return FaNoUnwind+ , reserved "optnone" >> return FaOptNone+ , reserved "optsize" >> return FaOptSize+ , reserved "readnone" >> return FaReadNone+ , reserved "readonly" >> return FaReadOnly+ , reserved "returns_twice" >> return FaReturnsTwice+ , reserved "sanitize_address" >> return FaSanitizeAddress+ , reserved "sanitize_memory" >> return FaSanitizeMemory+ , reserved "sanitize_thread" >> return FaSanitizeThread+ , reserved "ssp" >> return FaSsp+ , reserved "sspreq" >> return FaSspReq+ , reserved "sspstrong" >> return FaSspStrong+ , reserved "uwtable" >> return FaUwTable+ , reserved "align" >> liftM FaAlign unsignedInt -- integer+ , liftM DqString pQuoteStr >>= \s1 -> opt (symbol "=" >> liftM DqString pQuoteStr) >>= \s2 -> return (FaPair s1 s2)+ ]++pCarry :: P TrapFlag+pCarry = choice $ fmap (\(x,y) -> reserved y >> return x) $ M.toList trapFlagMap+++pAlign :: P Alignment+pAlign = reserved "align" >> liftM Alignment unsignedInt -- decimal++pComdat :: P Comdat+pComdat = reserved "comdat" >> liftM Comdat (opt pDollarId)++pNontemporal :: P Nontemporal+pNontemporal = char '!' >> reserved "nontemporal" >> char '!' >> liftM Nontemporal unsignedInt -- decimal ++pInvariantLoad :: P InvariantLoad+pInvariantLoad = char '!' >> reserved "invariant.load" >> char '!' >> liftM InvariantLoad unsignedInt -- decimal++pNonnull :: P Nonnull+pNonnull = char '!' >> reserved "nonnull" >> char '!' >> liftM Nonnull unsignedInt -- decimal++pSection :: P Section+pSection = reserved "section" >> liftM (Section . DqString) pQuoteStr++pSelectionKind :: P SelectionKind+pSelectionKind = choice $ fmap (\(x, y) -> reserved y >> return x) $ M.toList selectionKindMap ++pAddrSpace :: P AddrSpace+pAddrSpace = reserved "addrspace" >> liftM (AddrSpace . fromIntegral) (parens decimal)+ +pGlobalType :: P GlobalType +pGlobalType = choice [ reserved "constant" >> return (GlobalType "constant")+ , reserved "global" >> return (GlobalType "global")+ ]++pFenceOrder :: P AtomicMemoryOrdering+pFenceOrder = choice $ fmap (\(x,y) -> reserved y >> return x) $ M.toList atomicMemoryOrderingMap++pAtomicOp :: P AtomicOp+pAtomicOp = choice $ fmap (\(x,y) -> reserved y >> return x) $ M.toList atomicOpMap++pFunAttrCollection :: P [FunAttr] -- Collection +pFunAttrCollection = many $ choice [ char '#' >> liftM FaGroup unsignedInt -- decimal+ , pFunAttr+ ]++pTuple2 :: P a -> P b -> P (a, b)+pTuple2 p1 p2 = do { a1 <- p1+ ; ignore comma+ ; a2 <- p2+ ; return (a1, a2)+ }++pTriple3 :: P a -> P b -> P c -> P (a, b, c)+pTriple3 p1 p2 p3 = do { a1 <- p1+ ; ignore comma+ ; a2 <- p2+ ; ignore comma+ ; a3 <- p3+ ; return (a1, a2, a3)+ }+++pTuple :: P a -> P (a, a)+pTuple p = pTuple2 p p++pTriple :: P a -> P (a, a, a)+pTriple p = pTriple3 p p p++uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 f (a1, b1, c1) = f a1 b1 c1+ + +pFastMathFlag :: P FastMathFlag+pFastMathFlag = choice $ fmap (\(x,y) -> reserved y >> return x) $ M.toList fastMathFlagMap+ +pFastMathFlags :: P FastMathFlags +pFastMathFlags = liftM FastMathFlags (many pFastMathFlag)
+ src/Llvm/Syntax/Parser/Block.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS_GHC -Wall #-}+module Llvm.Syntax.Parser.Block where+import Llvm.Data.Ast+import Llvm.Syntax.Parser.Basic+import Llvm.Syntax.Parser.Instruction++-------------------------------------------------------------------------------+pBlocks :: P [Block]+pBlocks = try (many block)+ where+ block :: P Block+ block = do { n <- pBlockLabel+ ; restInsts (Block n) [] []+ }++restInsts :: ([PhiInstWithDbg] -> [ComputingInstWithDbg] -> TerminatorInstWithDbg -> Block) -> + [PhiInstWithDbg] -> [ComputingInstWithDbg] -> P Block +restInsts bf phis insts = do { instOrTerm <- pInstructionWithDbg+ ; case instOrTerm of+ InstructionWithDbg (Phi inst) dbgs ->+ restInsts bf ((PhiInstWithDbg inst dbgs):phis) insts+ InstructionWithDbg (Comp inst) dbgs -> + restInsts bf phis ((ComputingInstWithDbg inst dbgs):insts)+ InstructionWithDbg (Term x) dbgs -> + return $ bf (reverse phis) (reverse insts) (TerminatorInstWithDbg x dbgs)+ }
+ src/Llvm/Syntax/Parser/Const.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE GADTs #-}+module Llvm.Syntax.Parser.Const where+import Llvm.Data.Ast+import Llvm.Syntax.Parser.Basic+import Llvm.Syntax.Parser.Type+++pConst :: P Const+pConst = choice [ liftM C_simple pSimpleConstant+ , liftM C_complex pComplexConstant+ , pBlockAddr+ , liftM C_binexp pConstBinaryOperation+ , liftM C_icmp pConstIcmp+ , liftM C_fcmp pConstFcmp+ , liftM C_extractelement pConstExtractElement+ , liftM C_insertelement pConstInsertElement+ , liftM C_shufflevector pConstShuffleVector+ , liftM C_extractvalue pConstExtractValue+ , liftM C_insertvalue pConstInsertValue+ , liftM C_select pConstSelect+ , liftM C_gep pConstGetElemPtr+ , liftM C_conv pConstConversion+ ]+ +pTypedConst :: P (TypedConstOrNull)+pTypedConst = do { t <- pType+ ; case t of + (Tprimitive TpNull) -> return UntypedNull+ _ -> liftM (TypedConst . Typed t) pConst + }++pSimpleConstant :: P SimpleConstant+pSimpleConstant = choice [ pIntOrFloat + , (reserved "undef" >> return CpUndef) + , (reserved "null" >> return CpNull) + , (reserved "false" >> return CpFalse) + , (reserved "true" >> return CpTrue) + , (reserved "zeroinitializer" >> return CpZeroInitializer)+ , liftM CpGlobalAddr pGlobalId+ , (char 'c' >> liftM CpStr pQuoteStr)+ ]+++signedIntStr :: P String+signedIntStr = do { sign <- option "" (string "-" <|> string "+")+ ; n <- numericLit+ ; return (sign ++ n)+ }++pIntOrFloat :: P SimpleConstant+pIntOrFloat = lexeme (choice [try k, try u, try s, intOrFloat])+ where+ k = do { hd <- string "0x"+ ; t <- option "" (choice [ string "K", string "M", string "H", string "L"])+ ; cs <- many1 hexDigit+ ; return $ CpFloat (hd ++ t ++ cs)+ }+ u = do { ignore (string "u0x")+ ; cs <- many1 hexDigit+ ; return $ CpUhexInt cs+ }+ s = do { ignore (string "s0x")+ ; cs <- many1 hexDigit+ ; return $ CpShexInt cs+ }+ intOrFloat = do { i <- signedIntStr+ ; option (CpInt i) + (do { ignore (char '.')+ ; ne <- option "" (do { n <- numericLit+ ; e <- option "" (do { e <- (string "E" <|> string "e")+ ; x <- signedIntStr+ ; return (e ++ x)+ })+ ; return (n ++ e)+ })+ ; return $ CpFloat (i ++ "." ++ ne)+ })+ }+++pComplexConstant :: P ComplexConstant+pComplexConstant = choice [ pConstStruct+ , (try pConstVector)+ , pPackedStructConst+ , pConstArray+ ]++pConstStruct :: P ComplexConstant+pConstStruct = liftM (Cstruct Unpacked) (braces (sepBy pTypedConst comma))++++pPackedStructConst :: P ComplexConstant+pPackedStructConst = liftM (Cstruct Packed) (anglebraces (sepBy pTypedConst comma))+ +pConstVector :: P ComplexConstant+pConstVector = liftM Cvector (angles (sepBy pTypedConst comma))+ +pConstArray :: P ComplexConstant+pConstArray = liftM Carray (brackets (sepBy pTypedConst comma))+++pBlockAddr :: P Const+pBlockAddr = reserved "blockaddress" >> parens (pTuple2 pGlobalId pPercentLabel) + >>= return . (uncurry C_blockAddress)+ +pConstIbinaryOperation :: P (IbinExpr Const)+pConstIbinaryOperation = do { op <- pIbinaryOperator+ ; l <- many pCarry+ ; (tc1, tc2) <- parens (pTuple pTypedConst)+ ; return $ IbinExpr op l (getType tc1 tc2) (getConst tc1) (getConst tc2)+ }+ ++pConstFbinaryOperation :: P (FbinExpr Const)+pConstFbinaryOperation = do { op <- pFbinaryOperator+ ; l <- pFastMathFlags+ ; (tc1, tc2) <- parens (pTuple pTypedConst)+ ; return $ FbinExpr op l (getType tc1 tc2) (getConst tc1) (getConst tc2)+ }+ +pConstBinaryOperation :: P (BinExpr Const) +pConstBinaryOperation = choice [liftM Ie pConstIbinaryOperation, liftM Fe pConstFbinaryOperation]++ +getType :: TypedConstOrNull -> TypedConstOrNull -> Type+getType (TypedConst (Typed t1 _)) (TypedConst (Typed t2 _)) = if t1 == t2 then t1 + else error "t1 != t2"+getType UntypedNull (TypedConst (Typed t2 _)) = t2+getType (TypedConst (Typed t1 _)) UntypedNull = t1+getType UntypedNull UntypedNull = error "unexpected case"++getConst :: TypedConstOrNull -> Const+getConst UntypedNull = C_simple CpNull+getConst (TypedConst (Typed _ c)) = c+ +pConstIcmp :: P (Icmp Const) +pConstIcmp = do { reserved "icmp"+ ; op <- pIcmpOp+ ; (tc1, tc2) <- parens (pTuple pTypedConst)+ ; return (Icmp op (getType tc1 tc2) (getConst tc1) (getConst tc2))+ }+ +pConstFcmp :: P (Fcmp Const)+pConstFcmp = do { reserved "fcmp"+ ; op <- pFcmpOp+ ; (tc1, tc2) <- parens (pTuple pTypedConst)+ ; return $ Fcmp op (getType tc1 tc2) (getConst tc1) (getConst tc2)+ }+ + +extractTypedConst :: TypedConstOrNull -> Typed Const +extractTypedConst (TypedConst x) = x+extractTypedConst _ = error " error rorooror"++pConstExtractElement :: P (ExtractElement Const)+pConstExtractElement = reserved "extractelement" >> parens (pTuple pTypedConst) >>= \(x,y) -> return $ ExtractElement (extractTypedConst x) (extractTypedConst y)+ +pConstInsertElement :: P (InsertElement Const)+pConstInsertElement = do { reserved "insertelement"+ ; (tc1, tc2, idx) <- parens (pTriple3 pTypedConst pTypedConst pConst)+ ; return $ InsertElement (extractTypedConst tc1) (extractTypedConst tc2) (Typed (Tprimitive $ TpI 32) idx)+ }++pConstShuffleVector :: P (ShuffleVector Const)+pConstShuffleVector = reserved "shufflevector" >> parens (pTriple pTypedConst) >>= \(x,y,z) -> return $ ShuffleVector (extractTypedConst x) (extractTypedConst y) (extractTypedConst z)+ +pConstExtractValue :: P (ExtractValue Const)+pConstExtractValue = reserved "extractvalue" >> parens (pTuple2 pTypedConst (sepBy unsignedInt comma)) >>= \(x, y) -> return $ ExtractValue (extractTypedConst x) y + +pConstInsertValue :: P (InsertValue Const)+pConstInsertValue = reserved "insertvalue" >> parens (pTriple3 pTypedConst pTypedConst (sepBy unsignedInt comma)) >>= \(x,y,z) -> return $ InsertValue (extractTypedConst x) (extractTypedConst y) z+ + +pConstSelect :: P (Select Const)+pConstSelect = reserved "select" >> parens (pTriple pTypedConst) >>= \(x,y,z) -> return $ Select (extractTypedConst x) (extractTypedConst y) (extractTypedConst z)+ +pConstConversion :: P (Conversion Const)+pConstConversion = do { op <- pConvertOp+ ; ignore $ chartok '('+ ; tc <- pTypedConst+ ; reserved "to"+ ; t <- pType+ ; ignore $ chartok ')'+ ; return $ Conversion op (extractTypedConst tc) t+ }+ + +pConstGetElemPtr :: P (GetElementPtr Const)+pConstGetElemPtr = do { reserved "getelementptr"+ ; ib <- option (IsNot InBounds) (reserved "inbounds" >> return (Is InBounds))+ ; ignore (chartok '(')+ ; (Typed t c) <- liftM extractTypedConst pTypedConst+ ; idx <- option [] (do { ignore comma+ ; idx <- sepBy pTypedConst comma + ; return $ fmap extractTypedConst idx+ })+ ; ignore (chartok ')')+ ; return $ GetElementPtr ib (Pointer (Typed t c)) idx+ }+ +{-+pTypedConst1 :: P MetaConst -- (TypedConstOrNull)+pTypedConst1 = do { t <- pType+ ; case t of+ (Tprimitive TpNull) -> return UntypedNull+ _ -> (choice [pConst, liftM CmL pLocalId] >>= return . (TypedConst . Typed t))+ }+++pMetaStruct :: P MetaConst -- [MetaConst] -- Const+pMetaStruct = liftM McStruct (braces (sepBy pTypedConst1 comma))+-}++pMetaKindedConst :: P (MetaKindedConst)+pMetaKindedConst = choice [ reserved "null" >> return UnmetaKindedNull+ , liftM2 MetaKindedConst pMetaKind pMetaConst+ ]+++pMetaConst :: P MetaConst+pMetaConst = choice[ char '!' >> choice [ liftM McStruct (braces (sepBy pMetaKindedConst comma))+ , liftM (McString . DqString) pQuoteStr+ , liftM (McMn . MdNode) intStrToken+ ]+ , liftM McSimple pConst+ , liftM McRef pLocalId + ]+ +
+ src/Llvm/Syntax/Parser/DataLayout.hs view
@@ -0,0 +1,93 @@+module Llvm.Syntax.Parser.DataLayout where++import Llvm.Syntax.Parser.Basic+import Llvm.Data.Shared.DataLayout+import Llvm.Data.Shared.AtomicEntity (TargetTriple(..), Arch(..), Vendor(..), Os(..), OsEnv(..))+++pLayoutSpec :: P LayoutSpec+pLayoutSpec = choice [ char 'e' >> return (DlE LittleEndian)+ , char 'E' >> return (DlE BigEndian)+ , try (char 's' >> do { n <- option Nothing (liftM Just unsignedInt)+ ; aa <- option Nothing (colon >> liftM Just unsignedInt)+ ; pa <- option Nothing (colon >> liftM Just unsignedInt)+ ; return (DlLittleS n aa pa)+ })+ , char 'p' >> do { as <- option (LayoutAddrSpaceUnspecified) (liftM LayoutAddrSpace unsignedInt)+ ; s <- colon >> liftM SizeInBit unsignedInt+ ; aa <- colon >> liftM (AbiAlign . AlignInBit) unsignedInt+ ; pa <- prefAlign+ ; return (DlP as s aa pa) + }+ , dlIVF+ , char 'a' >> do { s <- opt (liftM SizeInBit unsignedInt)+ ; aa <- colon >> liftM (AbiAlign . AlignInBit) unsignedInt+ ; pa <- prefAlign+ ; return (DlA s aa pa)+ }+ , char 'm' >> colon >> liftM DlM (choice [ char 'e' >> return ManglingE+ , char 'm' >> return ManglingM+ , char 'o' >> return ManglingO+ , char 'w' >> return ManglingW+ ])+ , char 'n' >> do { ls <- sepBy1 unsignedInt colon+ ; return (DlN (fmap SizeInBit ls))+ }+ , try (symbol "S0" >> return (DlS StackAlignUnspecified))+ , char 'S' >> liftM ((DlS . StackAlign . AlignInBit)) unsignedInt+ ]+ where prefAlign = option Nothing (colon >> liftM (Just . PrefAlign . AlignInBit) unsignedInt)+ dlIVF = do { df <- choice [ char 'i' >> return DlI+ , char 'v' >> return DlV+ , char 'f' >> return DlF+ ]+ ; s <- liftM SizeInBit unsignedInt+ ; abi <- colon >> liftM (AbiAlign . AlignInBit) unsignedInt+ ; pa <- prefAlign+ ; return (df s abi pa)+ }+ +pDataLayout :: P DataLayout+pDataLayout = liftM DataLayout (sepBy pLayoutSpec (char '-'))+++pTargetTriple :: P TargetTriple+pTargetTriple = + do { arch <- choice [ reserved "i386" >> return Arch_i386+ , reserved "i686" >> return Arch_i686+ , reserved "x86" >> return Arch_x86+ , reserved "x86_64" >> return Arch_x86_64+ , reserved "powerpc" >> return Arch_PowerPc+ , reserved "powerpc64" >> return Arch_PowerPc64+ , reserved "arm" >> liftM Arch_Arm pAnyString+ , reserved "thumbv7" >> return Arch_ThumbV7+ , reserved "mips" >> liftM Arch_Mips pAnyString+ , reserved "itanium" >> return Arch_Itanium + , liftM Arch_String pAnyString+ ]+ ; vendor <- option Nothing (char '-' >> liftM Just+ (choice [ reserved "pc" >> return Vendor_Pc+ , reserved "apple" >> return Vendor_Apple+ , reserved "unknown" >> return Vendor_Unknown+ , liftM Vendor_String pAnyString+ ]))+ ; os <- option Nothing (char '-' >> liftM Just+ (choice [ reserved "linux" >> return Os_Linux+ , reserved "windows" >> return Os_Windows+ , reserved "win32" >> return Os_Win32+ , reserved "mingw32" >> return Os_Mingw32+ , reserved "unknown" >> return Os_Unknown+ , reserved "darwin" >> liftM Os_Darwin pAnyString+ , string "freebsd" >> liftM Os_FreeBsd pAnyString+ , string "macosx" >> liftM Os_Macosx pAnyString+ , string "ios" >> liftM Os_Ios pAnyString+ , liftM Os_String pAnyString+ ]))+ ; env <- option Nothing (char '-' >> liftM Just (choice [ reserved "gnu" >> return OsEnv_Gnu+ , liftM OsEnv_String pAnyString+ ]))+ ; return $ TargetTriple arch vendor os env+ }+ where + pAnyString :: P String+ pAnyString = (manyTill anyChar (lookAhead $ choice [char '"', char '-']))
+ src/Llvm/Syntax/Parser/Instruction.hs view
@@ -0,0 +1,109 @@+{-# OPTIONS_GHC -Wall #-}+module Llvm.Syntax.Parser.Instruction where+import Llvm.Data.Ast+import Llvm.Syntax.Parser.Basic+import Llvm.Syntax.Parser.Const+import Llvm.Syntax.Parser.Type+import Llvm.Syntax.Parser.Rhs++pTerminatorInst :: P TerminatorInst+pTerminatorInst = choice [ pRet+ , pBr+ , pSwitch+ , reserved "indirectbr" >> liftM (uncurry IndirectBr)+ (pTuple2 pTypedValue (brackets (sepBy pTargetLabel comma)))+ , reserved "unreachable" >> return Unreachable+ , reserved "resume" >> liftM Resume pTypedValue+ ]+ <?> "control instruction"++pRet :: P TerminatorInst+pRet = do { reserved "ret"+ ; t <- pType+ ; case t of+ Tvoid -> return RetVoid+ _ -> do { v <- pValue+ ; option (Return $ [Typed t v])+ (do { ls <- many (try (comma >> pTypedValue))+ ; return (Return ((Typed t v):ls))+ }+ )+ }+ }++++pSwitch :: P TerminatorInst+pSwitch = do { reserved "switch"+ ; (tv,l) <- tvl+ ; arms <- brackets (many tvl)+ ; return $ Switch tv l arms+ }+ where+ tvl = pTuple2 pTypedValue pTargetLabel+++pBr :: P TerminatorInst+pBr = reserved "br" >> choice [ reserved "label" >> liftM (Br . TargetLabel) pPercentLabel+ , reserved "i1" >> liftM (uncurry3 Cbr) (pTriple3 pValue pTargetLabel pTargetLabel)+ ]+++data Instruction = Comp ComputingInst+ | Term TerminatorInst+ | Phi PhiInst++data InstructionWithDbg = InstructionWithDbg Instruction [Dbg]++pInstruction :: P Instruction+pInstruction = do { lhs <- opt (do { x <- pLocalId+ ; ignore (chartok '=')+ ; return x+ })+ ; choice [ try $ liftM Term $ pInvoke lhs+ , liftM Comp $ pComputingInst lhs+ , liftM Term pTerminatorInst+ , liftM Phi $ pPhiInst lhs+ ]+ }++pDbg :: P Dbg+pDbg = do { x <- pMdVar+ ; mc <- pMetaConst+ ; return $ Dbg x mc+ }++pInstructionWithDbg :: P InstructionWithDbg+pInstructionWithDbg = do { ins <- pInstruction+ ; l <- many (comma >> pDbg)+ ; return $ InstructionWithDbg ins l+ }++++pComputingInst :: Maybe LocalId -> P ComputingInst+pComputingInst lhs = do { rhs <- pRhs+ ; return $ ComputingInst lhs rhs+ }+++pInvoke :: Maybe LocalId -> P TerminatorInst+pInvoke lhs = do { reserved "invoke"+ ; callSite <- pCallSite+ ; reserved "to"+ ; toLbl <- pTargetLabel+ ; reserved "unwind"+ ; unwindLbl <- pTargetLabel+ ; return $ Invoke lhs callSite toLbl unwindLbl+ }+++pPhiInst :: Maybe LocalId -> P PhiInst+pPhiInst lhsOpt = do { reserved "phi"+ ; t <- pType+ ; one <- pair+ ; ls <- many (try (comma >> pair))+ ; return $ PhiInst lhsOpt t (one:ls)+ }+ where pair = brackets (pTuple2 pValue pPercentLabel)+
+ src/Llvm/Syntax/Parser/Module.hs view
@@ -0,0 +1,224 @@+module Llvm.Syntax.Parser.Module where+import Llvm.Data.Ast+import Llvm.Syntax.Parser.Basic+import Llvm.Syntax.Parser.Type+import Llvm.Syntax.Parser.Block+import Llvm.Syntax.Parser.Const+import Llvm.Syntax.Parser.Rhs+import Llvm.Syntax.Parser.DataLayout+++pModule :: P Module+pModule = do { l <- many toplevel+ ; eof + ; return $ Module l+ }++toplevel :: P Toplevel+toplevel = choice [ try pNamedGlobal + , try pToplevelTypeDef+ , try pToplevelTarget+ , try pToplevelDepLibs+ , try pToplevelDeclare+ , try pToplevelDefine+ , pToplevelModuleAsm+ , pToplevelAttributeGroup+ , pToplevelComdat+ , pStandaloneMd+ ]+++-- GlobalVar '=' OptionalVisibility ALIAS ...+-- GlobalVar '=' OptionalLinkage OptionalVisibility ... -> global variable+pNamedGlobal :: P Toplevel+pNamedGlobal = do { lhsOpt <- opt (pGlobalId >>= \x->chartok '=' >> return x)+ ; linkOpt <- opt pLinkage -- (choice [try pExternalLinkage, pLinkage])+ ; vis <- opt pVisibility+ ; dllStorage <- opt pDllStorageClass+ ; tlm <- opt pThreadLocalStorageClass+ ; na <- option NamedAddr (reserved "unnamed_addr" >> return UnnamedAddr)+ ; hasAlias <- option False (reserved "alias" >> return True)+ ; case (lhsOpt, linkOpt, hasAlias) of+ (Just lhs, Nothing, True) -> pAlias lhs vis dllStorage tlm na+ (_, _, False) -> pGlobal lhsOpt linkOpt vis dllStorage tlm na+ }++-- ParseAlias:+-- ::= GlobalVar '=' OptionalVisibility 'alias' OptionalLinkage Aliasee+-- Aliasee+-- ::= TypeAndValue+-- ::= 'bitcast' '(' TypeAndValue 'to' Type ')'+-- ::= 'getelementptr' 'inbounds'? '(' ... ')'+--+-- Everything through visibility has already been parsed.+--+pAlias :: GlobalId -> Maybe Visibility -> Maybe DllStorageClass -> Maybe ThreadLocalStorage -> AddrNaming -> P Toplevel+pAlias lhs vis dll tlm na = do { link <- option Nothing (liftM Just pAliasLinkage)+ ; aliasee <- pAliasee+ ; return $ ToplevelAlias (TlAlias lhs vis dll tlm na link aliasee)+ }+ where pAliasee = + choice [ liftM AtV pTypedValue+ , liftM Ac pConstConversion+ , liftM AgEp pConstGetElemPtr+ ]+++-- ParseGlobal+-- ::= GlobalVar '=' OptionalLinkage OptionalVisibility OptionalThreadLocal+-- OptionalAddrSpace GlobalType Type Const+-- ::= OptionalLinkage OptionalVisibility OptionalThreadLocal+-- OptionalAddrSpace GlobalType Type Const+--+-- Everything through visibility has been parsed already.+--+pGlobal :: Maybe GlobalId -> Maybe Linkage -> Maybe Visibility -> Maybe DllStorageClass -> Maybe ThreadLocalStorage -> AddrNaming -> P Toplevel+pGlobal lhs link vis dll tls na = + do { addrOpt <- opt pAddrSpace+ ; exti <- option (IsNot ExternallyInitialized) (reserved "externally_initialized" >> return (Is ExternallyInitialized))+ ; globalOpt <- pGlobalType+ ; t <- pType+ ; c <- if (hasInit link) then liftM Just pConst+ else return Nothing+ ; (s,cd,a) <- permute ((,,) <$?> (Nothing, try (comma >> liftM Just pSection))+ <|?> (Nothing, try (comma >> liftM Just pComdat))+ <|?> (Nothing, try (comma >> liftM Just pAlign))+ )+ ; return $ ToplevelGlobal (TlGlobal lhs link vis dll tls na addrOpt exti+ globalOpt t c s cd a)+ }+ where hasInit x = case x of + Just(LinkageExternWeak) -> False+ Just(LinkageExternal) -> False+ -- Just(DllImport) -> False+ Just(_) -> True+ Nothing -> True++data LocalIdOrQuoteStr = L LocalId | Q DqString deriving (Eq,Show)++pLhsType :: P LocalIdOrQuoteStr +pLhsType = do { lhs <- choice [ liftM L pLocalId+ , liftM (Q . DqString) pQuoteStr+ ] + ; ignore (chartok '=')+ ; reserved "type" + ; return lhs+ }+ +pToplevelTypeDef :: P Toplevel +pToplevelTypeDef = do { lhsOpt <- opt pLhsType+ ; case lhsOpt of+ Nothing -> liftM (ToplevelUnamedType . (TlUnamedType 1)) pType+ Just (L x) -> liftM (ToplevelTypeDef . (TlTypeDef x)) pType+ Just (Q _) -> error "irrefutable"+ }++pToplevelTarget :: P Toplevel+pToplevelTarget = do { reserved "target"+ ; choice [ do { reserved "triple" + ; ignore $ chartok '=' + ; tt <- lexeme (between (char '"') (char '"') pTargetTriple)+ ; return $ ToplevelTriple (TlTriple tt)+ }+ , do { reserved "datalayout" + ; ignore $ chartok '='+ ; ls <- lexeme (between (char '"') (char '"') pDataLayout) + ; return $ ToplevelDataLayout (TlDataLayout ls) + }+ ]+ }++pToplevelDepLibs :: P Toplevel+pToplevelDepLibs = do { reserved "deplibs"+ ; ignore (chartok '=')+ ; l <- brackets (sepBy pQuoteStr comma)+ ; return $ ToplevelDepLibs (TlDepLibs (fmap DqString l))+ }++ +pFunctionPrototype :: P FunctionPrototype+pFunctionPrototype = do { lopt <- opt pLinkage+ ; vopt <- opt pVisibility+ ; dllopt <- opt pDllStorageClass+ ; copt <- opt pCallConv+ ; as <- many pParamAttr+ ; ret <- pType+ ; name <- pGlobalId+ ; params <- pFormalParamList+ ; unnamed <- opt (reserved "unnamed_addr" >> return UnnamedAddr)+ ; attrs <- pFunAttrCollection+ ; sopt <- opt pSection+ ; cdopt <- opt pComdat+ ; aopt <- opt pAlign+ ; gopt <- opt (liftM (Gc . DqString) (reserved "gc" >> pQuoteStr))+ ; prefixOpt <- opt pPrefix+ ; prologueOpt <- opt pPrologue+ ; return (FunctionPrototype lopt vopt dllopt copt + as ret name params unnamed attrs sopt cdopt aopt gopt + prefixOpt prologueOpt)+ }+ +pPrefix :: P Prefix +pPrefix = reserved "prefix" >> liftM Prefix pTypedConst++pPrologue :: P Prologue+pPrologue = reserved "prologue" >> liftM Prologue pTypedConst++pToplevelDefine :: P Toplevel+pToplevelDefine = do { reserved "define"+ ; fh <- pFunctionPrototype+ ; bs <- braces pBlocks+ ; return $ ToplevelDefine (TlDefine fh bs)+ }+ +pToplevelAttributeGroup :: P Toplevel +pToplevelAttributeGroup = do { reserved "attributes" + ; ignore (char '#')+ ; n <- unsignedInt -- decimal+ ; ignore (chartok '=')+ ; l <- braces $ many pFunAttr+ ; return $ ToplevelAttribute (TlAttribute n l)+ }+ +pToplevelDeclare :: P Toplevel +pToplevelDeclare = liftM ToplevelDeclare + (reserved "declare" >> liftM TlDeclare pFunctionPrototype)++pToplevelModuleAsm :: P Toplevel+pToplevelModuleAsm = do { reserved "module"+ ; reserved "asm"+ ; s <- pQuoteStr+ ; return $ ToplevelModuleAsm (TlModuleAsm (DqString s))+ }+ ++pToplevelComdat :: P Toplevel+pToplevelComdat = do { l <- pDollarId+ ; ignore (chartok '=')+ ; reserved "comdat"+ ; s <- pSelectionKind+ ; return $ ToplevelComdat (TlComdat l s)+ }++pMdNode :: P MdNode+pMdNode = (char '!' >> liftM MdNode intStrToken)++pStandaloneMd :: P Toplevel+pStandaloneMd = do { ignore (char '!')+ ; choice [ do { n <- intStrToken+ ; ignore (chartok '=')+ ; choice [ do { t <- pMetaKindedConst -- Tmetadata+ ; return (ToplevelStandaloneMd (TlStandaloneMd n t))+ }+ ]+ }+ , do { i <- lexeme pId+ ; ignore (chartok '=')+ ; ignore (lexeme (string "!{"))+ ; l <- sepBy pMdNode comma + ; ignore (chartok '}')+ ; return $ ToplevelNamedMd (TlNamedMd (MdVar i) l)+ }+ ]+ }+
+ src/Llvm/Syntax/Parser/Rhs.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE GADTs #-}+module Llvm.Syntax.Parser.Rhs where+import Llvm.Data.Ast+import Llvm.Syntax.Parser.Basic+import Llvm.Syntax.Parser.Type+import Llvm.Syntax.Parser.Const+++pTmetadata :: P MetaConst+pTmetadata = do { reserved "metadata" + ; mc <- pMetaConst+ ; return mc+ }++pTypedValue :: P (Typed Value)+pTypedValue = liftM2 Typed pType pValue++pValue :: P Value+pValue = choice [ (liftM Val_const pConst)+ , (liftM Val_local pLocalId) + ]+++pTypedPointer :: P (Pointer (Typed Value))+pTypedPointer = do { t <- pType+ ; v <- pValue+ ; return (Pointer (Typed t v))+ }+ +pAllocate :: P MemOp+pAllocate = do { reserved "alloca"+ ; ina <- option (IsNot InAllocaAttr) (reserved "inalloca" >> return (Is InAllocaAttr))+ ; t <- pType + ; n <- opt (comma >> pTypedValue)+ ; a <- opt (comma >> pAlign)+ ; return $ Alloca ina t n a+ }++pLoad :: P MemOp+pLoad = do { reserved "load"+ ; at <- option False (reserved "atomic" >> return True)+ ; b <- option (IsNot Volatile) (reserved "volatile" >> return (Is Volatile))+ ; tv <- pTypedPointer+ ; if at then+ do { st <- option (IsNot SingleThread) (reserved "singlethread" >> return (Is SingleThread))+ ; ord <- pFenceOrder+ ; a <- optCommaSep pAlign+ ; return $ LoadAtomic (Atomicity st ord) b tv a+ }+ else+ do { a <- optCommaSep pAlign+ ; nt <- optCommaSep pNontemporal+ ; inv <- optCommaSep pInvariantLoad+ ; nn <- optCommaSep pNonnull+ ; return $ Load b tv a nt inv nn+ }+ }+ +pStore :: P MemOp+pStore = do { reserved "store"+ ; at <- option False (reserved "atomic" >> return True)+ ; b <- option (IsNot Volatile) (reserved "volatile" >> return (Is Volatile))+ ; tv <- pTypedValue+ ; ignore comma+ ; ptr <- pTypedPointer+ ; if at then + do { st <- option (IsNot SingleThread) (reserved "singlethread" >> return (Is SingleThread))+ ; ord <- pFenceOrder+ ; a <- optCommaSep pAlign+ ; return $ StoreAtomic (Atomicity st ord) b tv ptr a + }+ else+ do { a <- optCommaSep pAlign+ ; nt <- optCommaSep pNontemporal+ ; return $ Store b tv ptr a nt+ }+ }+ + +pFence :: P MemOp+pFence = do { reserved "fence"+ ; st <- option (IsNot SingleThread) (reserved "singlethread" >> return (Is SingleThread))+ ; ordering <- pFenceOrder+ ; return $ Fence st ordering+ }+ +pCmpXchg :: P MemOp+pCmpXchg = do { reserved "cmpxchg"+ ; wk <- option (IsNot Weak) (reserved "weak" >> return (Is Weak))+ ; v <- option (IsNot Volatile) (reserved "volatile" >> return (Is Volatile))+ ; p <- pTypedPointer+ ; ignore comma+ ; (c, n) <- pTuple pTypedValue+ ; st <- option (IsNot SingleThread) (reserved "singlethread" >> return (Is SingleThread))+ ; sord <- pFenceOrder+ ; ford <- pFenceOrder+ ; return $ CmpXchg wk v p c n st sord ford+ }+ +pAtomicRmw :: P MemOp+pAtomicRmw = do { reserved "atomicrmw"+ ; v <- option (IsNot Volatile) (reserved "volatile" >> return (Is Volatile))+ ; op <- pAtomicOp+ ; p <- pTypedPointer+ ; ignore comma+ ; vl <- pTypedValue+ ; st <- option (IsNot SingleThread) (reserved "singlethread" >> return (Is SingleThread))+ ; ord <- pFenceOrder+ ; return $ AtomicRmw v op p vl st ord+ } ++ + ++pMemOp :: P MemOp+pMemOp = choice [ pAllocate+ , pLoad+ , pStore+ , pFence+ , pCmpXchg+ , pAtomicRmw+ ]+++pExpr :: P Expr +pExpr = choice [ liftM Eb pBinaryOperation+ , liftM EiC pIcmp+ , liftM EfC pFcmp + , liftM Es pSelect+ , liftM Ec pConversion+ , liftM EgEp pGetElemPtr+ ]++pIbinaryOperation :: P (IbinExpr Value)+pIbinaryOperation = do { op <- pIbinaryOperator+ ; l <- many pCarry+ ; t <- pType+ ; (v1, v2) <- pTuple pValue+ ; return $ IbinExpr op l t v1 v2+ }++pFbinaryOperation :: P (FbinExpr Value)+pFbinaryOperation = do { op <- pFbinaryOperator+ ; l <- pFastMathFlags + ; t <- pType+ ; (v1, v2) <- pTuple pValue+ ; return $ FbinExpr op l t v1 v2+ }+ +pBinaryOperation :: P (BinExpr Value) +pBinaryOperation = choice [ liftM Ie pIbinaryOperation, liftM Fe pFbinaryOperation]++ +pIcmp :: P (Icmp Value)+pIcmp = do { reserved "icmp"+ ; op <- pIcmpOp+ ; t <- pType+ ; (v1, v2) <- pTuple pValue+ ; return (Icmp op t v1 v2)+ }++pFcmp :: P (Fcmp Value)+pFcmp = do { reserved "fcmp"+ ; op <- pFcmpOp+ ; t <- pType+ ; (v1, v2) <- pTuple pValue+ ; return $ Fcmp op t v1 v2+ }+ + ++ +pSelect :: P (Select Value)+pSelect = do { reserved "select"+ ; t <- pSelTy+ ; v <- pValue+ ; ignore comma+ ; (tv2, tv3) <- pTuple pTypedValue+ ; return $ Select (Typed t v) tv2 tv3+ }++pConversion :: P (Conversion Value)+pConversion = do { op <- pConvertOp+ ; tv <- pTypedValue+ ; reserved "to"+ ; t <- pType+ ; return $ Conversion op tv t+ }++pGetElemPtr :: P (GetElementPtr Value)+pGetElemPtr = do { reserved "getelementptr"+ ; ib <- option (IsNot InBounds) (reserved "inbounds" >> return (Is InBounds))+ ; tc1 <- pTypedPointer -- AddrValue+ ; idx <- many (try (comma >> pTypedValue))+ ; return $ GetElementPtr ib tc1 idx+ }++pExtractElement :: P (ExtractElement Value)+pExtractElement = reserved "extractelement" >> pTuple pTypedValue >>= return . (uncurry ExtractElement)++pInsertElement :: P (InsertElement Value)+pInsertElement = reserved "insertelement" >> pTriple pTypedValue >>= return . (uncurry3 InsertElement)++pShuffleVector :: P (ShuffleVector Value)+pShuffleVector = reserved "shufflevector" >> pTriple pTypedValue >>= return . (uncurry3 ShuffleVector)+ +pExtractValue :: P (ExtractValue Value)+pExtractValue = do { reserved "extractvalue"+ ; tc1 <- pTypedValue+ ; ls <- many (try (comma >> unsignedInt))+ ; return $ ExtractValue tc1 ls+ }++pInsertValue :: P (InsertValue Value)+pInsertValue = do { reserved "insertvalue"+ ; (tv1, tv2) <- pTuple pTypedValue+ ; ls <- many (try (comma >> unsignedInt))+ ; return $ InsertValue tv1 tv2 ls+ }+ + +pVaArg :: P Rhs+pVaArg = reserved "va_arg" >> pTuple2 pTypedValue pType >>= return . (RvA . uncurry VaArg)+ + +pCallFun :: P CallSite+pCallFun = do { cc <- opt pCallConv+ ; atts0 <- many pParamAttr+ ; t <- pType+ ; i <- choice [ liftM FunNameString (choice [symbol "null", symbol "undef"])+ , liftM FunNameGlobal pGlobalOrLocalId+ ]+ ; params <- parens (sepBy pActualParam comma)+ ; atts1 <- pFunAttrCollection+ ; return (CsFun cc atts0 t i params atts1)+ }++pCallAsm :: P CallSite+pCallAsm = do { t <- pType+ ; reserved "asm"+ ; se <- opt (reserved "sideeffect" >> return SideEffect)+ ; as <- opt (reserved "alignstack" >> return AlignStack)+ ; dialect <- option AsmDialectAtt (reserved "inteldialect" >> return AsmDialectIntel)+ ; (s1, s2) <- pTuple pQuoteStr+ ; params <- parens (sepBy pActualParam comma)+ ; atts1 <- pFunAttrCollection+ ; return (CsAsm t se as dialect (DqString s1) (DqString s2) params atts1)+ }++pCallConversion :: P (CallSite)+pCallConversion = do { a <- many pParamAttr+ ; t <- pType+ ; convert <- pConstConversion+ ; params <- parens (sepBy pActualParam comma)+ ; atts1 <- pFunAttrCollection+ ; return (CsConversion a t convert params atts1)+ }++pCallSite :: P CallSite+pCallSite = choice [ try pCallFun+ , try pCallAsm+ , pCallConversion+ ]+ +pCall :: P Rhs+pCall = do { tl <- option TcNon pTailCall + ; reserved "call"+ ; liftM (Call tl) pCallSite+ }++pActualParam :: P ActualParam+pActualParam = choice [do { t <- pType+ ; atts0 <- many pParamAttr+ ; a <- opt pAlign+ ; v <- pValue+ ; atts1 <- many pParamAttr+ ; return $ ActualParamData t atts0 a v atts1+ }+ ,liftM ActualParamMeta pMetaKindedConst+ ]+ +pRhs :: P Rhs+pRhs = choice [ liftM Re pExpr+ , liftM RmO pMemOp+ , liftM ReE pExtractElement+ , liftM RiE pInsertElement+ , liftM RsV pShuffleVector+ , liftM ReV pExtractValue+ , liftM RiV pInsertValue+ , pVaArg+ , pCall+ , pLandingPad+ ]+ + +++pPersFn :: P PersFn+pPersFn = choice [ liftM PersFnId pGlobalOrLocalId+ , do { op <- pConvertOp+ ; ignore (chartok '(')+ ; ot <- pType+ ; ix <- pGlobalOrLocalId+ ; reserved "to"+ ; dt <- pType+ ; ignore (chartok ')')+ ; return $ PersFnCast (Conversion op (Typed ot ix) dt)+ }+ , reserved "undef" >> return PersFnUndef+ , reserved "null" >> return PersFnNull+ , liftM PersFnConst pConst+ ]+ +pLandingPad :: P Rhs+pLandingPad = do { reserved "landingpad"+ ; rt <- pType+ ; reserved "personality"+ ; ft <- pType+ ; ix <- pPersFn+ ; cl <- option Nothing (reserved "cleanup" >> return (Just Cleanup))+ ; c <- many pClause+ ; return $ RlP $ LandingPad rt ft ix cl c+ }+ where pClause = choice [ reserved "catch" >> liftM Catch pTypedValue+ , reserved "filter" >> liftM Filter pTypedConst+ ]
+ src/Llvm/Syntax/Parser/Type.hs view
@@ -0,0 +1,153 @@+module Llvm.Syntax.Parser.Type where+import Llvm.Data.Ast+import Llvm.Syntax.Parser.Basic+++pType :: P Type+pType =+ do { t <- choice [ try (liftM Tprimitive pPrimType)+ , pTypeName+ --, upref+ , array+ , try pstruct+ , vector+ , struct+ , pOther + ]+ ; post t+ }+ where+-- upref = chartok '\\' >> liftM TupRef decimal+ array = brackets (avbody Tarray)+ vector = angles (avbody Tvector)+ avbody f = do { n <- lexeme unsignedInt -- decimal+ ; ignore $ chartok 'x'+ ; t <- pType+ ; return (f n t)+ }+ struct = liftM (Tstruct Unpacked) (braces (sepBy pType comma))+ pstruct = do { ignore $ symbol "<{"+ ; v <- sepBy pType comma+ ; ignore $ symbol "}>"+ ; return (Tstruct Packed v)+ }+ pOther = choice [ reserved "opaque" >> return Topaque+ , reserved "void" >> return Tvoid+ ]+++castTypeToMetaKind :: Type -> MetaKind+castTypeToMetaKind t = Mtype t +++pMetaKind :: P MetaKind+pMetaKind = choice [ try (liftM castTypeToMetaKind pType)+ , reserved "metadata" >> return Mmetadata+ ]++pTypeName :: P Type+pTypeName = do { x <- pLocalId + ; case x of + LocalIdNum n -> return $ Tno n+ LocalIdAlphaNum s -> return $ Tname s+ LocalIdDqString s -> return $ TquoteName s+ }+++pStar :: P AddrSpace+pStar = option AddrSpaceUnspecified pAddrSpace >>= \x -> chartok '*' >> return x++post :: Type -> P Type+post t = do { pt <- option t (pStar >>= \x -> post (Tpointer t x))+ ; option pt $ do { fp <- pTypeParamList+ ; fattrs <- many pFunAttr+ ; post (Tfunction pt fp fattrs)+ }+ }++pTypeI :: P TypePrimitive+pTypeI = (char 'i' >> liftM TpI unsignedInt)++pTypeF :: P TypePrimitive+pTypeF = (char 'f' >> liftM TpF unsignedInt)++pTypeV :: P TypePrimitive+pTypeV = (char 'v' >> liftM TpV unsignedInt)+++pPrimType :: P TypePrimitive+pPrimType = choice [ try pTypeI+ , reserved "half" >> return TpHalf+ , reserved "float" >> return TpFloat+ , reserved "fp128" >> return TpFp128+ , pTypeF+ , reserved "label" >> return TpLabel+ , reserved "double" >> return TpDouble+ , reserved "x86_fp80" >> return TpX86Fp80+ , reserved "x86_mmx" >> return TpX86Mmx+ , reserved "ppc_fp128" >> return TpPpcFp128+ , pTypeV+ , reserved "null" >> return TpNull+ ]+ + +pTypeParamList :: P TypeParamList+pTypeParamList = do { ignore $ chartok '('+ ; (l, f) <- args []+ ; return $ TypeParamList l f+ }+ where+ args :: [Type] -> P ([Type], Maybe VarArgParam)+ args l = choice [ do { p <- pType+ ; let l' = p:l+ ; choice [ comma >> args l'+ , chartok ')' >> return (reverse l', Nothing)+ ]+ }+ , symbol "..." >> chartok ')' >> return (reverse l, Just VarArgParam)+ , chartok ')' >> return (reverse l, Nothing)+ ]+ ++pFormalParamList :: P FormalParamList+pFormalParamList = do { ignore $ chartok '('+ ; (l, f) <- args []+ ; funAttrs <- many pFunAttr+ ; return $ FormalParamList l f funAttrs+ }+ where+ args :: [FormalParam] -> P ([FormalParam], Maybe VarArgParam)+ args l = choice [ do { p <- param+ ; let l' = p:l+ ; choice [ comma >> args l'+ , chartok ')' >> return (reverse l', Nothing)+ ]+ }+ , symbol "..." >> chartok ')' >> return (reverse l, Just VarArgParam)+ , chartok ')' >> return (reverse l, Nothing)+ ]+ where+ param = choice [do { at <- pType+ ; ar1 <- many pParamAttr+ ; an <- opt pAlign+ ; lv <- opt pLocalId+ ; let lv' = maybe FimplicitParam FexplicitParam lv + ; ar2 <- many pParamAttr+ ; return $ FormalParamData at ar1 an lv' ar2+ }+ , do { mt <- pMetaKind+ ; lv <- opt pLocalId+ ; let lv1 = maybe FimplicitParam FexplicitParam lv+ ; return $ FormalParamMeta mt lv1+ }+ ]++pSelTy :: P Type+pSelTy = choice [ reserved "i1" >> return (Tprimitive $ TpI 1)+ , angles $ do { n <- unsignedInt -- decimal+ ; ignore $ chartok 'x'+ ; reserved "i1"+ ; return $ Tvector n (Tprimitive $ TpI 1)+ }+ , pTypeName+ ]
+ src/Llvm/Syntax/Printer/Common.hs view
@@ -0,0 +1,23 @@+module Llvm.Syntax.Printer.Common + (module Llvm.Syntax.Printer.Common+ ,module Text.PrettyPrint+ )+ where++import Text.PrettyPrint+import Data.Monoid (mempty)+import qualified Data.Map as M(Map, foldWithKey) +++angleBrackets :: Doc -> Doc +angleBrackets x = char '<' <> x <> char '>'++commaSepList :: [Doc] -> Doc+commaSepList l = hsep $ punctuate comma l++commaSepNonEmpty :: [Doc] -> Doc+commaSepNonEmpty l = commaSepList (filter (not . isEmpty) l)++sepMaybe :: (a -> Doc) -> (Doc -> Doc) -> Maybe a -> Doc+sepMaybe f _ (Nothing) = empty+sepMaybe f sep (Just x) = sep $ f x
+ src/Llvm/Syntax/Printer/IrPrint.hs view
@@ -0,0 +1,1041 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+module Llvm.Syntax.Printer.IrPrint + (module Llvm.Syntax.Printer.IrPrint+ ,module Llvm.Syntax.Printer.Common+ ) where++import Llvm.Data.Ir+import Llvm.Query.IrCxt++import Llvm.Syntax.Printer.Common+import Llvm.Syntax.Printer.SharedEntityPrint (integral)+import qualified Llvm.Syntax.Printer.SharedEntityPrint as P+import qualified Compiler.Hoopl as H+import qualified Data.Map as M (Map, toList)+import qualified Data.Set as S (Set, toList)++class IrPrint a where+ printIr :: a -> Doc+ +instance IrPrint v => IrPrint (H.LabelMap v) where+ printIr lm = let ls = H.mapToList lm+ in vcat $ fmap (\(k,v) -> printIr k <+> text "::=>" <+> printIr v) ls+ +instance (IrPrint t1, IrPrint t2) => IrPrint (t1, t2) where+ printIr (v1, v2) = parens (printIr v1 <> comma <+> printIr v2)+ +instance IrPrint x => IrPrint [x] where + printIr l = vcat $ fmap printIr l+ +instance (IrPrint k, IrPrint v) => IrPrint (M.Map k v) where+ printIr mp = let l = M.toList mp+ in printIr l+ +instance IrPrint v => IrPrint (S.Set v) where+ printIr s = let l = S.toList s+ in printIr l+ +instance IrPrint () where + printIr _ = text "()"+ +commaSepMaybe :: IrPrint a => Maybe a -> Doc+commaSepMaybe = maybe empty ((comma <+>) . printIr)++optSepToLlvm :: IrPrint a => Maybe a -> Doc -> Doc+optSepToLlvm (Nothing) _ = empty+optSepToLlvm (Just x) sep = printIr x <+> sep++instance IrPrint a => IrPrint (Maybe a) where+ printIr (Just x) = printIr x+ printIr Nothing = empty+ ++instance IrPrint TlTriple where + printIr (TlTriple s) = hsep [text "target", text "triple", equals, printIr s]++instance IrPrint TlDataLayout where+ printIr (TlDataLayout s) = hsep [text "target", text "datalayout", equals, printIr s]++instance IrPrint TlAlias where+ printIr (TlAlias lhs vis dll tlm na link aliasee) = + hsep [printIr lhs, equals, printIr vis, printIr dll, printIr tlm, printIr na, text "alias", printIr link, printIr aliasee]++instance IrPrint TlDbgInit where+ printIr (TlDbgInit s i) = hsep [text "dbginit", text s, integral i]++instance IrPrint TlStandaloneMd where+ printIr (TlStandaloneMd s t) = char '!'<>(text s) <+> equals <+> printIr t++instance IrPrint TlNamedMd where + printIr (TlNamedMd mv nds) = printIr mv <+> equals <+> char '!'<>(braces (hsep $ punctuate comma $ fmap printIr nds))++instance IrPrint TlDeclare where+ printIr (TlDeclare fproto) = text "declare" <+> printIr fproto+ +instance IrPrint a => IrPrint (TlDefine a) where + printIr (TlDefine fproto entry graph) = text "define" <+> printIr fproto $$+ text "; the entry label is" <+> + printIr entry $$+ printIr graph++instance IrPrint TlGlobal where + printIr x = case x of+ (TlGlobalDtype lhs linkage vis dll tlm un addrspace externali gty ty c section comdat align) ->+ hsep [optSepToLlvm lhs equals, printIr linkage, printIr vis, printIr dll, printIr tlm, printIr un, optSepToLlvm addrspace empty+ , printIr externali, printIr gty, printIr ty, printIr c, commaSepNonEmpty [printIr section, printIr comdat, printIr align]]+ (TlGlobalOpaque lhs linkage vis dll tlm un addrspace externali gty ty c section comdat align) ->+ hsep [optSepToLlvm lhs equals, printIr linkage, printIr vis, printIr dll, printIr tlm, printIr un, optSepToLlvm addrspace empty+ , printIr externali, printIr gty, printIr ty, printIr c, commaSepNonEmpty [printIr section, printIr comdat, printIr align]] ++instance IrPrint TlTypeDef where + printIr x = case x of+ (TlDatTypeDef n t) -> hsep [printIr n, equals, text "data type", printIr t]+ (TlOpqTypeDef n t) -> hsep [printIr n, equals, text "opaque type", printIr t] + (TlFunTypeDef n t) -> hsep [printIr n, equals, text "function type", printIr t] ++instance IrPrint TlDepLibs where+ printIr (TlDepLibs l) = hsep [text "deplibs", equals, brackets (hsep $ punctuate comma $ fmap printIr l)]++instance IrPrint TlUnamedType where+ printIr (TlUnamedType x t) = text "type" <+> printIr t <+> text("; " ++ (show x))++instance IrPrint TlModuleAsm where+ printIr (TlModuleAsm qs) = hsep [text "module", text "asm", printIr qs]+ +instance IrPrint TlAttribute where+ printIr (TlAttribute n l) = hsep [text "attributes", char '#' <> (integral n), braces (hsep $ fmap printIr l)]++instance IrPrint TlComdat where+ printIr (TlComdat l s) = hsep [printIr l, equals, printIr s]+ +instance IrPrint a => IrPrint (Toplevel a) where + printIr (ToplevelTriple x) = printIr x+ printIr (ToplevelDataLayout x) = printIr x+ printIr (ToplevelAlias x) = printIr x+ printIr (ToplevelDbgInit x) = printIr x+ printIr (ToplevelStandaloneMd x) = printIr x+ printIr (ToplevelNamedMd x) = printIr x+ printIr (ToplevelDeclare x) = printIr x+ printIr (ToplevelDefine x) = printIr x+ printIr (ToplevelGlobal x) = printIr x+ printIr (ToplevelTypeDef x) = printIr x+ printIr (ToplevelDepLibs x) = printIr x+ printIr (ToplevelUnamedType x) = printIr x+ printIr (ToplevelModuleAsm x) = printIr x+ printIr (ToplevelAttribute x) = printIr x+ printIr (ToplevelComdat x) = printIr x++instance IrPrint TypeEnv where+ printIr (TypeEnv dl tt td) = text "datalayout:" <+> printIr dl+ $+$ text "triple:" <+> printIr tt+ $+$ text "typedefs:" <+> printIr td+ +instance IrPrint GlobalCxt where+ printIr (GlobalCxt te gl) = text "typeEnv:" <+> printIr te+ $+$ text "globals:" <+> printIr gl+ +instance IrPrint FunCxt where+ printIr (FunCxt fn p) = text "funName:" <+> text fn+ $+$ text "funParameters:" <+> printIr p+ +instance IrPrint IrCxt where+ printIr (IrCxt g l) = text "globalCxt:" <+> printIr g+ $+$ text "funCxt:" <+> printIr l++instance IrPrint a => IrPrint (Module a) where + printIr (Module tops) = fcat $ fmap printIr tops+++instance IrPrint a => IrPrint (Node a e x) where+ printIr (Nlabel lbl) = printIr lbl+ printIr (Pinst i) = printIr i+ printIr (Cinst c) = printIr c+ printIr (Tinst t) = printIr t+ printIr (Comment s) = text s+ printIr (Additional a) = printIr a+ +instance IrPrint a => IrPrint (H.Graph (Node a) H.C H.C) where+ printIr g = braces (H.foldGraphNodes (\n -> \s -> s $$ (printIr n)) g empty)++instance IrPrint Label where+ printIr l = text (show l) ++instance IrPrint Exact where+ printIr Exact = text "exact"++instance IrPrint NoWrap where+ printIr Nsw = text "nsw"+ printIr Nuw = text "nuw"+ printIr Nsuw = text "nsw nuw"++printX :: (String, Doc, T Utype Const, T Utype Const) -> Doc+printX (op, cs, s1, s2) = text op <+> cs <+> parens (printIr s1 <> comma <+> printIr s2)++printF :: (String, Doc, T Utype Const, T Utype Const) -> Doc +printF (op, cs, s1, s2) = text op <+> cs <+> parens (printIr s1 <> comma <+> printIr s2)++printConversion :: IrPrint x => Conversion s x -> (Doc -> Doc) -> Doc+printConversion x p = case x of+ Trunc fv dt -> text "trunc" <+> p (printIr fv <+> text "to" <+> printIr dt)+ Zext fv dt -> text "zext" <+> p (printIr fv <+> text "to" <+> printIr dt)+ Sext fv dt -> text "sext" <+> p (printIr fv <+> text "to" <+> printIr dt)+ FpTrunc fv dt -> text "fptrunc" <+> p (printIr fv <+> text "to" <+> printIr dt)+ FpExt fv dt -> text "fpext" <+> p (printIr fv <+> text "to" <+> printIr dt)+ FpToUi fv dt -> text "fptoui" <+> p (printIr fv <+> text "to" <+> printIr dt)+ FpToSi fv dt -> text "fptosi" <+> p (printIr fv <+> text "to" <+> printIr dt)+ UiToFp fv dt -> text "uitofp" <+> p (printIr fv <+> text "to" <+> printIr dt)+ SiToFp fv dt -> text "sitofp" <+> p (printIr fv <+> text "to" <+> printIr dt)+ PtrToInt fv dt -> text "ptrtoint" <+> p (printIr fv <+> text "to" <+> printIr dt)+ IntToPtr fv dt -> text "inttoptr" <+> p (printIr fv <+> text "to" <+> printIr dt)+ Bitcast fv dt -> text "bitcast" <+> p (printIr fv <+> text "to" <+> printIr dt)+ AddrSpaceCast fv dt -> text "addrspacecast" <+> p (printIr fv <+> text "to" <+> printIr dt)++instance IrPrint (Conversion s Const) where+ printIr x = printConversion x parens++instance IrPrint (GetElementPtr s Const) where+ printIr (GetElementPtr b base indices) = + hsep [text "getelementptr", printIr b, parens (commaSepList ((printIr base):fmap printIr indices))]+ +instance IrPrint (Select s r Const) where+ printIr (Select cnd tc1 tc2) = text "select" <+> (parens (commaSepList [printIr cnd, printIr tc1, printIr tc2]))++instance (IrPrint a, IrPrint b) => IrPrint (Either a b) where+ printIr (Left a) = printIr a+ printIr (Right b) = printIr b++instance IrPrint (Icmp ScalarB Const) where+ printIr (Icmp op t c1 c2) = + text "icmp" <+> printIr op <+> parens (commaSepList [printIr (T t c1), printIr (T t c2)])++instance IrPrint (Icmp VectorB Const) where+ printIr (Icmp op t c1 c2) = + text "icmp" <+> printIr op <+> parens (commaSepList [printIr (T t c1), printIr (T t c2)])++instance IrPrint (Fcmp s Const) where+ printIr (Fcmp op t c1 c2) = + text "fcmp" <+> printIr op <+> parens (commaSepList [printIr (T t c1), printIr (T t c2)])+ +instance IrPrint (ShuffleVector r Const) where+ printIr (ShuffleVector tc1 tc2 mask) = + text "shufflevector" <+> parens (commaSepList [printIr tc1, printIr tc2, printIr mask])++instance IrPrint (ExtractValue Const) where+ printIr (ExtractValue tc indices) = + hsep [text "extractvalue", parens (commaSepList ((printIr tc:(fmap integral indices))))]+ +instance IrPrint (InsertValue Const) where+ printIr (InsertValue vect tc indices) = + hsep [text "insertvalue", parens (commaSepList ((printIr vect:printIr tc:(fmap integral indices))))]+ +instance IrPrint (ExtractElement r Const) where+ printIr (ExtractElement tc index) = + hsep [text "extractelement", parens (printIr tc <> comma <+> printIr index)]+ +instance IrPrint (InsertElement r Const) where+ printIr (InsertElement tc1 tc2 index) = + hsep [text "insertelement", parens (printIr tc1 <> comma <+> printIr tc2 <> comma <+> printIr index)]+ +instance IrPrint Const where+ printIr cst = case cst of+ C_u8 v -> integral v+ C_u16 v -> integral v+ C_u32 v -> integral v+ C_u64 v -> integral v+ C_u96 v -> integral v+ C_u128 v -> integral v+ C_s8 v -> integral v+ C_s16 v -> integral v+ C_s32 v -> integral v+ C_s64 v -> integral v+ C_s96 v -> integral v+ C_s128 v -> integral v+ C_int i -> text i+ C_uhex_int i -> text "u0x" <> (text i)+ C_shex_int i -> text "s0x" <> (text i)+ C_float s -> text s+ C_null -> text "null"+ C_undef -> text "undef"+ C_true -> text "true"+ C_false -> text "false"+ C_zeroinitializer -> text "zeroinitializer"+ C_globalAddr g -> printIr g+ C_str s -> char 'c'<> (doubleQuotes $ text s)++ (C_struct b ts) -> let v = (braces (commaSepList $ fmap printIr ts))+ in case b of + Packed -> angleBrackets v+ Unpacked -> v+ (C_vector ts) -> angleBrackets (commaSepList $ fmap printIr ts)+ (C_array ts) -> brackets (commaSepList $ fmap printIr ts)+ C_vectorN n e -> angleBrackets (commaSepList $ fmap (\x -> printIr e) [1..n])+ C_arrayN n e -> brackets (commaSepList $ fmap (\x -> printIr e) [1..n]) + C_localId l -> printIr l+ C_labelId l -> printIr l+ C_block g a -> text "blockaddress" <+> parens (printIr g <> comma <+> printIr a)+ + C_add x t v1 v2 -> printX ("add", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_sub x t v1 v2 -> printX ("sub", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_mul x t v1 v2 -> printX ("mul", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_udiv x t v1 v2 -> printX ("udiv", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_sdiv x t v1 v2 -> printX ("sdiv", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_urem t v1 v2 -> printX ("urem", empty, T (ucast t) v1, T (ucast t) v2)+ C_srem t v1 v2 -> printX ("srem", empty, T (ucast t) v1, T (ucast t) v2)+ C_shl x t v1 v2 -> printX ("shl", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_lshr x t v1 v2 -> printX ("lshr", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_ashr x t v1 v2 -> printX ("ashr", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_and t v1 v2 -> printX ("and", empty, T (ucast t) v1, T (ucast t) v2)+ C_or t v1 v2 -> printX ("or", empty, T (ucast t) v1, T (ucast t) v2)+ C_xor t v1 v2 -> printX ("xor", empty, T (ucast t) v1, T (ucast t) v2)++ C_add_V x t v1 v2 -> printX ("add", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_sub_V x t v1 v2 -> printX ("sub", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_mul_V x t v1 v2 -> printX ("mul", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_udiv_V x t v1 v2 -> printX ("udiv", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_sdiv_V x t v1 v2 -> printX ("sdiv", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_urem_V t v1 v2 -> printX ("urem", empty, T (ucast t) v1, T (ucast t) v2)+ C_srem_V t v1 v2 -> printX ("srem", empty, T (ucast t) v1, T (ucast t) v2)+ C_shl_V x t v1 v2 -> printX ("shl", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_lshr_V x t v1 v2 -> printX ("lshr", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_ashr_V x t v1 v2 -> printX ("ashr", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_and_V t v1 v2 -> printX ("and", empty, T (ucast t) v1, T (ucast t) v2)+ C_or_V t v1 v2 -> printX ("or", empty, T (ucast t) v1, T (ucast t) v2)+ C_xor_V t v1 v2 -> printX ("xor", empty, T (ucast t) v1, T (ucast t) v2)++ C_fadd x t v1 v2 -> printF ("fadd", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_fsub x t v1 v2 -> printF ("fsub", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_fmul x t v1 v2 -> printF ("fmul", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_fdiv x t v1 v2 -> printF ("fdiv", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_frem x t v1 v2 -> printF ("frem", printIr x, T (ucast t) v1, T (ucast t) v2)++ C_fadd_V x t v1 v2 -> printF ("fadd", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_fsub_V x t v1 v2 -> printF ("fsub", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_fmul_V x t v1 v2 -> printF ("fmul", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_fdiv_V x t v1 v2 -> printF ("fdiv", printIr x, T (ucast t) v1, T (ucast t) v2)+ C_frem_V x t v1 v2 -> printF ("frem", printIr x, T (ucast t) v1, T (ucast t) v2)++ {- conversion -}+ C_trunc fv dt -> text "trunc" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_zext fv dt -> text "zext" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_sext fv dt -> text "sext" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_fptrunc fv dt -> text "fptrunc" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_fpext fv dt -> text "fpext" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_fptoui fv dt -> text "fptoui" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_fptosi fv dt -> text "fptosi" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_uitofp fv dt -> text "uitofp" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_sitofp fv dt -> text "sitofp" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_ptrtoint fv dt -> text "ptrtoint" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_inttoptr fv dt -> text "inttoptr" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_addrspacecast fv dt -> text "addrspacecast" <+> parens (printIr fv <+> text "to" <+> printIr dt)++ C_bitcast fv dt -> text "bitcast" <+> parens (printIr fv <+> text "to" <+> printIr dt)++ C_trunc_V fv dt -> text "trunc" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_zext_V fv dt -> text "zext" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_sext_V fv dt -> text "sext" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_fptrunc_V fv dt -> text "fptrunc" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_fpext_V fv dt -> text "fpext" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_fptoui_V fv dt -> text "fptoui" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_fptosi_V fv dt -> text "fptosi" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_uitofp_V fv dt -> text "uitofp" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_sitofp_V fv dt -> text "sitofp" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_ptrtoint_V fv dt -> text "ptrtoint" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_inttoptr_V fv dt -> text "inttoptr" <+> parens (printIr fv <+> text "to" <+> printIr dt)+ C_addrspacecast_V fv dt -> text "addrspacecast" <+> parens (printIr fv <+> text "to" <+> printIr dt)++ C_getelementptr b base indices ->+ hsep [text "getelementptr", printIr b, parens (commaSepList ((printIr base):fmap printIr indices))]+ + C_getelementptr_V b base indices ->+ hsep [text "getelementptr", printIr b, parens (commaSepList ((printIr base):fmap printIr indices))]++ C_select_I a -> printIr a+ C_select_F a -> printIr a + C_select_P a -> printIr a + C_select_First cnd t f -> hsep [text "select", printIr cnd, printIr t, printIr f]+ C_select_VI a -> printIr a + C_select_VF a -> printIr a + C_select_VP a -> printIr a + C_icmp a -> printIr a+ C_icmp_V a -> printIr a + C_fcmp a -> printIr a + C_fcmp_V a -> printIr a+ C_shufflevector_I a -> printIr a+ C_shufflevector_F a -> printIr a + C_shufflevector_P a -> printIr a + C_extractelement_I a -> printIr a+ C_extractelement_F a -> printIr a + C_extractelement_P a -> printIr a + C_insertelement_I a -> printIr a+ C_insertelement_F a -> printIr a + C_insertelement_P a -> printIr a + C_extractvalue a -> printIr a+ C_insertvalue a -> printIr a ++instance IrPrint MdVar where + printIr (MdVar s) = char '!' <> (text s)+ +instance IrPrint MdNode where+ printIr (MdNode s) = char '!' <> (text s)+ +instance IrPrint MetaConst where+ printIr (McStruct c) = char '!' <> braces (commaSepList (fmap printIr c))+ printIr (McString s) = char '!' <> (printIr s)+ printIr (McMn n) = printIr n+ printIr (McMv v) = printIr v+ printIr (McRef s) = text $ show s+ printIr (McSimple sc) = printIr sc++instance IrPrint (GetElementPtr s Value) where+ printIr (GetElementPtr ib tv tcs) = + hsep [text "getelementptr", printIr ib, printIr tv, (commaSepList $ fmap printIr tcs)]++instance IrPrint (Icmp ScalarB Value) where + printIr (Icmp op t v1 v2) = hsep [text "icmp", printIr op, printIr t, printIr v1 <> comma, printIr v2]+ +instance IrPrint (Icmp VectorB Value) where + printIr (Icmp op t v1 v2) = hsep [text "icmp", printIr op, printIr t, printIr v1 <> comma, printIr v2]++instance IrPrint (Fcmp s Value) where + printIr (Fcmp op t v1 v2) = hsep [text "fcmp", printIr op, printIr t, printIr v1 <> comma, printIr v2]+ +instance IrPrint (Conversion s Value) where + printIr x = printConversion x id+ +instance IrPrint (Select s r Value) where + printIr (Select c t f) = text "select" <+> (commaSepList [printIr c, printIr t, printIr f])++instance IrPrint Value where+ printIr (Val_ssa i) = printIr i+ printIr (Val_const c) = printIr c++ +instance IrPrint TypedConstOrNull where + printIr (TypedConst tc) = printIr tc+ printIr UntypedNull = text "null"+++instance (IrPrint t, IrPrint x) => IrPrint (T t x) where+ printIr (T t v) = printIr t <+> printIr v+ +instance IrPrint FunName where+ printIr (FunNameGlobal s) = printIr s+ printIr (FunNameString s) = text s+ ++instance IrPrint CallSiteType where+ printIr (CallSiteRet e) = printIr e+ printIr (CallSiteFun e as) = printIr (Tpointer (ucast e) as) ++ +instance IrPrint CallSite where+ printIr (CsFun cc ra rt ident params fa) = + hsep [printIr cc, hsep $ fmap printIr ra, printIr rt, printIr ident, parens (commaSepList $ fmap printIr params), hsep $ fmap printIr fa]+ printIr (CsAsm t se as dia s1 s2 params fa) = + hsep [printIr t, text "asm", printIr se, printIr as, printIr dia, printIr s1 <> comma+ , printIr s2, parens (commaSepList $ fmap printIr params), hsep $ fmap printIr fa]+ printIr (CsConversion ra t convert params fa) = + hsep [hsep $ fmap printIr ra, printIr t, printIr convert, parens (hsep $ fmap printIr params), hsep $ fmap printIr fa]+ printIr (CsConversionV ra t convert params fa) = + hsep [hsep $ fmap printIr ra, printIr t, printIr convert, parens (hsep $ fmap printIr params), hsep $ fmap printIr fa]+++instance IrPrint Clause where+ printIr (Catch tv) = text "catch" <+> printIr tv+ printIr (Filter tc) = text "filter" <+> printIr tc+ printIr (CcoS c) = printIr c+ printIr (CcoV c) = printIr c ++instance IrPrint (Conversion s GlobalOrLocalId) where+ printIr x = printConversion x parens+ +instance IrPrint PersFn where+ printIr (PersFnId g) = printIr g+ printIr (PersFnCastS c) = printIr c+ printIr (PersFnCastV c) = printIr c + printIr PersFnUndef = text "undef" + printIr PersFnNull = text "null"+ printIr (PersFnConst c) = printIr c+++instance IrPrint (ExtractElement r Value) where+ printIr (ExtractElement tv1 tv2) = hsep [text "extractelement", printIr tv1 <> comma, printIr tv2]+ +instance IrPrint (InsertElement r Value) where + printIr (InsertElement vect tv idx) = + hsep [text "insertelement", printIr vect <> comma, printIr tv <> comma, printIr idx]+ +instance IrPrint (ShuffleVector r Value) where + printIr (ShuffleVector vect1 vect2 mask) = + hsep [text "shufflevector", printIr vect1 <> comma, printIr vect2 <> comma, printIr mask]+ +instance IrPrint (ExtractValue Value) where + printIr (ExtractValue tv idxs) = + hsep [text "extractvalue", printIr tv <> comma, (commaSepList $ fmap integral idxs)]+ +instance IrPrint (InsertValue Value) where + printIr (InsertValue vect tv idx) = text "insertvalue" <+> hsep (punctuate comma ((printIr vect):(printIr tv):(fmap integral idx)))++instance IrPrint ActualParam where+ printIr x = case x of+ (ActualParamData t att1 align v att2) ->+ hsep [printIr t, hsep $ fmap printIr att1, printIr align, printIr v, hsep $ fmap printIr att2]+ (ActualParamMeta mc) -> printIr mc+ ++instance IrPrint Dbg where+ printIr (Dbg mv meta) = printIr mv <+> printIr meta+++instance IrPrint PhiInst where+ printIr (PhiInst lhs t pairs) = printIr lhs <+> equals <+> text "phi" + <+> printIr t <+> (commaSepList $ fmap tvToLLvm pairs)+ where tvToLLvm (h1,h2) = brackets (printIr h1 <+> comma <+> printIr h2)++instance IrPrint CInst where+ printIr x = case x of+ (I_alloca ma t s a lhs) -> + hsep [printIr lhs, equals, text "alloca", printIr ma, printIr t, commaSepMaybe s, commaSepMaybe a]+ (I_load v ptr align nonterm invar nonull lhs) ->+ hsep [printIr lhs, equals, text "load", printIr v, printIr ptr+ , commaSepNonEmpty [printIr align, printIr nonterm, printIr invar, printIr nonull]]+ (I_loadatomic (Atomicity st ord) v ptr align lhs) ->+ hsep [printIr lhs, equals, text "load atomic", printIr v, printIr ptr, printIr st, printIr ord, commaSepMaybe align]+ (I_store b v addr align nonterm) ->+ hsep [text "store", printIr b, printIr v <> comma, printIr addr, commaSepMaybe align, commaSepMaybe nonterm]+ (I_storeatomic (Atomicity st ord) b v ptr align) ->+ hsep [text "store atomic", printIr b, printIr v <> comma, printIr ptr, printIr st, printIr ord <> commaSepMaybe align]+ (I_fence b order) -> hsep [text "fence", printIr b, printIr order]+ (I_cmpxchg_I wk v p c n st sord ford lhs) ->+ hsep [printIr lhs, equals, text "cmpxchg", printIr wk, printIr v, printIr p <> comma+ , printIr c <> comma, printIr n, printIr st, printIr sord, printIr ford]+ (I_cmpxchg_F wk v p c n st sord ford lhs) ->+ hsep [printIr lhs, equals, text "cmpxchg", printIr wk, printIr v, printIr p <> comma+ , printIr c <> comma, printIr n, printIr st, printIr sord, printIr ford]+ (I_cmpxchg_P wk v p c n st sord ford lhs) ->+ hsep [printIr lhs, equals, text "cmpxchg", printIr wk, printIr v, printIr p <> comma+ , printIr c <> comma, printIr n, printIr st, printIr sord, printIr ford]+ + (I_atomicrmw v op p vl st ord lhs) ->+ hsep [printIr lhs, equals, text "atomicrmw", printIr v, printIr op, printIr p <> comma, printIr vl, printIr st, printIr ord]+ + (I_call_fun tc cc pa cstype callee actparams fna lhs) -> hsep [optSepToLlvm lhs equals, printIr tc, + printIr (CsFun cc pa cstype callee actparams fna)]+ (I_call_other tc cs lhs) -> hsep [optSepToLlvm lhs equals, printIr tc, printIr cs] + + (I_extractelement_I tv idx lhs) -> hsep [printIr lhs, equals, text "extractelement_i", printIr tv, printIr idx]+ (I_extractelement_F tv idx lhs) -> hsep [printIr lhs, equals, text "extractelement_f", printIr tv, printIr idx]+ (I_extractelement_P tv idx lhs) -> hsep [printIr lhs, equals, text "extractelement_p", printIr tv, printIr idx]+ + (I_insertelement_I tv v idx lhs) -> hsep [printIr lhs, equals, text "insertelement_i", printIr tv, printIr v, printIr idx]+ (I_insertelement_F tv v idx lhs) -> hsep [printIr lhs, equals, text "insertelement_f", printIr tv, printIr v, printIr idx]+ (I_insertelement_P tv v idx lhs) -> hsep [printIr lhs, equals, text "insertelement_p", printIr tv, printIr v, printIr idx]+ + (I_shufflevector_I v1 v2 v3 lhs) -> hsep [printIr lhs, equals, text "shufflevector_i", printIr v1, printIr v2, printIr v3]+ (I_shufflevector_F v1 v2 v3 lhs) -> hsep [printIr lhs, equals, text "shufflevector_f", printIr v1, printIr v2, printIr v3]+ (I_shufflevector_P v1 v2 v3 lhs) -> hsep [printIr lhs, equals, text "shufflevector_p", printIr v1, printIr v2, printIr v3]+ + (I_extractvalue v idx lhs) -> hsep ([printIr lhs, equals, text "extractvalue", printIr v] ++ fmap integral idx)+ (I_insertvalue vv v idx lhs) -> hsep ([printIr lhs, equals, text "insertvalue", printIr vv, printIr v] ++ fmap integral idx)+ + I_va_arg dv t lhs -> hsep [printIr lhs, equals, text "va_arg", printIr dv, printIr t]+ I_va_start tv -> text "call" <+> text "void" <+> text "@llvm.va_start" <+> parens(printIr tv)+ I_va_end tv -> text "call" <+> text "void" <+> text "@llvm.va_end" <+> parens(printIr tv)+ + I_landingpad rt pt tgl b clauses lhs -> + hsep ([printIr lhs, equals, text "landingpad", printIr rt, text "personality", printIr pt, printIr tgl, printIr b] ++ fmap printIr clauses)+ + I_getelementptr b base indices lhs -> hsep [printIr lhs, equals, text "getelementptr", printIr b, parens (commaSepList ((printIr base):fmap printIr indices))]+ I_getelementptr_V b base indices lhs -> hsep [printIr lhs, equals, text "getelementptr_v", printIr b, parens (commaSepList ((printIr base):fmap printIr indices))]+ + (I_icmp op t v1 v2 lhs) -> hsep [printIr lhs, equals, text "icmp", printIr op, printIr t, printIr v1, printIr v2]+ (I_icmp_V op t v1 v2 lhs) -> hsep [printIr lhs, equals, text "icmp_v", printIr op, printIr t, printIr v1, printIr v2]+ + (I_fcmp op t v1 v2 lhs) -> hsep [printIr lhs, equals, text "fcmp", printIr op, printIr t, printIr v1, printIr v2]+ (I_fcmp_V op t v1 v2 lhs) -> hsep [printIr lhs, equals, text "fcmp_v", printIr op, printIr t, printIr v1, printIr v2]+ + (I_add n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "add", printIr n, printIr t, printIr v1, printIr v2]+ (I_sub n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "sub", printIr n, printIr t, printIr v1, printIr v2] + (I_mul n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "mul", printIr n, printIr t, printIr v1, printIr v2] + (I_udiv n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "udiv", printIr n, printIr t, printIr v1, printIr v2] + (I_sdiv n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "sdiv", printIr n, printIr t, printIr v1, printIr v2] + (I_urem t v1 v2 lhs) -> hsep [printIr lhs, equals, text "urem", printIr t, printIr v1, printIr v2] + (I_srem t v1 v2 lhs) -> hsep [printIr lhs, equals, text "sdiv", printIr t, printIr v1, printIr v2] + (I_shl n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "shl", printIr n, printIr t, printIr v1, printIr v2]+ (I_lshr n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "lshr", printIr n, printIr t, printIr v1, printIr v2] + (I_ashr n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "ashr", printIr n, printIr t, printIr v1, printIr v2] + (I_and t v1 v2 lhs) -> hsep [printIr lhs, equals, text "and", printIr t, printIr v1, printIr v2]+ (I_or t v1 v2 lhs) -> hsep [printIr lhs, equals, text "or", printIr t, printIr v1, printIr v2]+ (I_xor t v1 v2 lhs) -> hsep [printIr lhs, equals, text "xor", printIr t, printIr v1, printIr v2]+ + (I_add_V n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "add_v", printIr n, printIr t, printIr v1, printIr v2]+ (I_sub_V n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "sub_v", printIr n, printIr t, printIr v1, printIr v2] + (I_mul_V n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "mul_v", printIr n, printIr t, printIr v1, printIr v2] + (I_udiv_V n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "udiv_v", printIr n, printIr t, printIr v1, printIr v2] + (I_sdiv_V n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "sdiv_v", printIr n, printIr t, printIr v1, printIr v2] + (I_urem_V t v1 v2 lhs) -> hsep [printIr lhs, equals, text "urem_v", printIr t, printIr v1, printIr v2] + (I_srem_V t v1 v2 lhs) -> hsep [printIr lhs, equals, text "sdiv_v", printIr t, printIr v1, printIr v2] + (I_shl_V n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "shl_v", printIr n, printIr t, printIr v1, printIr v2]+ (I_lshr_V n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "lshr_v", printIr n, printIr t, printIr v1, printIr v2] + (I_ashr_V n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "ashr_v", printIr n, printIr t, printIr v1, printIr v2] + (I_and_V t v1 v2 lhs) -> hsep [printIr lhs, equals, text "and_v", printIr t, printIr v1, printIr v2]+ (I_or_V t v1 v2 lhs) -> hsep [printIr lhs, equals, text "or_v", printIr t, printIr v1, printIr v2]+ (I_xor_V t v1 v2 lhs) -> hsep [printIr lhs, equals, text "xor_v", printIr t, printIr v1, printIr v2]+ + + (I_fadd n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "fadd", printIr n, printIr t, printIr v1, printIr v2]+ (I_fsub n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "fsub", printIr n, printIr t, printIr v1, printIr v2] + (I_fmul n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "fmul", printIr n, printIr t, printIr v1, printIr v2] + (I_fdiv n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "fdiv", printIr n, printIr t, printIr v1, printIr v2] + (I_frem n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "frem", printIr n, printIr t, printIr v1, printIr v2]+ + (I_fadd_V n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "fadd_v", printIr n, printIr t, printIr v1, printIr v2]+ (I_fsub_V n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "fsub_v", printIr n, printIr t, printIr v1, printIr v2] + (I_fmul_V n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "fmul_v", printIr n, printIr t, printIr v1, printIr v2] + (I_fdiv_V n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "fdiv_v", printIr n, printIr t, printIr v1, printIr v2] + (I_frem_V n t v1 v2 lhs) -> hsep [printIr lhs, equals, text "frem_v", printIr n, printIr t, printIr v1, printIr v2]+ + (I_trunc tv dt lhs) -> hsep [printIr lhs, equals, text "trunc", printIr tv, text "to", printIr dt]+ (I_zext tv dt lhs) -> hsep [printIr lhs, equals, text "zext", printIr tv, text "to", printIr dt]+ (I_sext tv dt lhs) -> hsep [printIr lhs, equals, text "sext", printIr tv, text "to", printIr dt]+ (I_fptrunc tv dt lhs) -> hsep [printIr lhs, equals, text "fptrunc", printIr tv, text "to", printIr dt]+ (I_fpext tv dt lhs) -> hsep [printIr lhs, equals, text "fpext", printIr tv, text "to", printIr dt]+ (I_fptoui tv dt lhs) -> hsep [printIr lhs, equals, text "fptoui", printIr tv, text "to", printIr dt]+ (I_fptosi tv dt lhs) -> hsep [printIr lhs, equals, text "fptosi", printIr tv, text "to", printIr dt]+ (I_uitofp tv dt lhs) -> hsep [printIr lhs, equals, text "uitofp", printIr tv, text "to", printIr dt]+ (I_sitofp tv dt lhs) -> hsep [printIr lhs, equals, text "sitofp", printIr tv, text "to", printIr dt]+ (I_ptrtoint tv dt lhs) -> hsep [printIr lhs, equals, text "ptrtoint", printIr tv, text "to", printIr dt]+ (I_inttoptr tv dt lhs) -> hsep [printIr lhs, equals, text "inttoptr", printIr tv, text "to", printIr dt]+ (I_addrspacecast tv dt lhs) -> hsep [printIr lhs, equals, text "addrspacecast", printIr tv, text "to", printIr dt] + + (I_bitcast tv dt lhs) -> hsep [printIr lhs, equals, text "bitcast", printIr tv, text "to", printIr dt]+ (I_bitcast_D tv dt lhs) -> hsep [printIr lhs, equals, text "bitcast_D", printIr tv, text "to", printIr dt]++ (I_trunc_V tv dt lhs) -> hsep [printIr lhs, equals, text "trunc_v", printIr tv, text "to", printIr dt]+ (I_zext_V tv dt lhs) -> hsep [printIr lhs, equals, text "zext_v", printIr tv, text "to", printIr dt]+ (I_sext_V tv dt lhs) -> hsep [printIr lhs, equals, text "sext_v", printIr tv, text "to", printIr dt]+ (I_fptrunc_V tv dt lhs) -> hsep [printIr lhs, equals, text "fptrunc_v", printIr tv, text "to", printIr dt]+ (I_fpext_V tv dt lhs) -> hsep [printIr lhs, equals, text "fpext_v", printIr tv, text "to", printIr dt]+ (I_fptoui_V tv dt lhs) -> hsep [printIr lhs, equals, text "fptoui_v", printIr tv, text "to", printIr dt]+ (I_fptosi_V tv dt lhs) -> hsep [printIr lhs, equals, text "fptosi_v", printIr tv, text "to", printIr dt]+ (I_uitofp_V tv dt lhs) -> hsep [printIr lhs, equals, text "uitofp_v", printIr tv, text "to", printIr dt]+ (I_sitofp_V tv dt lhs) -> hsep [printIr lhs, equals, text "sitofp_v", printIr tv, text "to", printIr dt]+ (I_ptrtoint_V tv dt lhs) -> hsep [printIr lhs, equals, text "ptrtoint_v", printIr tv, text "to", printIr dt]+ (I_inttoptr_V tv dt lhs) -> hsep [printIr lhs, equals, text "inttoptr_v", printIr tv, text "to", printIr dt]+ (I_addrspacecast_V tv dt lhs) -> hsep [printIr lhs, equals, text "addrspacecast_v", printIr tv, text "to", printIr dt] + + (I_select_I cnd t f lhs) -> hsep [printIr lhs, equals, text "select", printIr cnd, printIr t, printIr f]+ (I_select_F cnd t f lhs) -> hsep [printIr lhs, equals, text "select", printIr cnd, printIr t, printIr f] + (I_select_P cnd t f lhs) -> hsep [printIr lhs, equals, text "select", printIr cnd, printIr t, printIr f] + + (I_select_First cnd t f lhs) -> hsep [printIr lhs, equals, text "select", printIr cnd, printIr t, printIr f] + + (I_select_VI cnd t f lhs) -> hsep [printIr lhs, equals, text "select", printIr cnd, printIr t, printIr f]+ (I_select_VF cnd t f lhs) -> hsep [printIr lhs, equals, text "select", printIr cnd, printIr t, printIr f] + (I_select_VP cnd t f lhs) -> hsep [printIr lhs, equals, text "select", printIr cnd, printIr t, printIr f]+ + I_llvm_memcpy mod tv1 tv2 tv3 tv4 tv5 -> text "I_llvm_memcpy" <+> printIr mod <+> parens (hsep [printIr tv1, printIr tv2, printIr tv3, printIr tv4, printIr tv5]) + I_llvm_dbg_declare aps -> text "I_llvm_dbg_declare" <> parens (hsep (fmap printIr aps))+ I_llvm_dbg_value aps -> text "I_llvm_dbg_value" <> parens (hsep (fmap printIr aps)) + {-+ I_dbaseOf tv lhs -> hsep [printIr lhs, equals, text "dbaseOf", printIr tv]+ I_dsizeOf tv lhs -> hsep [printIr lhs, equals, text "dsizeOf", printIr tv]+ I_inspect_va_start_offset lhs -> hsep [printIr lhs, equals, text "inspect_va_start_offset"]+ I_inspect_va_start_mbase lhs -> hsep [printIr lhs, equals, text "inspect_va_start_mbase"] + I_inspect_va_start_msize lhs -> hsep [printIr lhs, equals, text "inspect_va_start_msize"]+ -}+ +instance IrPrint MemLen where + printIr m = case m of+ MemLenI32 -> text "i32"+ MemLenI64 -> text "i64"++instance IrPrint TerminatorInst where+ printIr RetVoid = text "ret" <+> text "void"+ printIr (Return x) = text "ret" <+> (commaSepList $ fmap printIr x)+ printIr (Br a) = text "br" <+> printIr a+ printIr (Cbr v t f) = text "br i1" <+> (commaSepList [printIr v, printIr t, printIr f])+ printIr (IndirectBr v l) = hsep [text "indirectbr", printIr v <> comma, brackets (commaSepList $ fmap printIr l)]+ printIr (Switch v d tbl) = + hsep [text "switch", printIr v <> comma, printIr d, brackets (hsep $ fmap (\(p1,p2) -> printIr p1 <> comma <+> printIr p2) tbl)]+ printIr (Invoke callSite toL unwindL lhs) = + hsep [optSepToLlvm lhs equals, text "invoke", printIr callSite, text "to", printIr toL, text "unwind", printIr unwindL]+ printIr (InvokeCmd callSite toL unwindL) = + hsep [text "invoke", printIr callSite, text "to", printIr toL, text "unwind", printIr unwindL]+ printIr Unreachable = text "unreachable"+ printIr (Resume a) = text "resume" <+> printIr a+ printIr Unwind = text "unwind"+ ++instance IrPrint PhiInstWithDbg where+ printIr (PhiInstWithDbg ins dbgs) = commaSepList ((printIr ins):fmap printIr dbgs)++instance IrPrint TerminatorInstWithDbg where+ printIr (TerminatorInstWithDbg ins dbgs) = commaSepList ((printIr ins):fmap printIr dbgs)++instance IrPrint CInstWithDbg where+ printIr (CInstWithDbg ins dbgs) = commaSepList ((printIr ins):fmap printIr dbgs)+++instance IrPrint Aliasee where+ printIr (AtV tv ) = printIr tv+ printIr (Ac c) = printIr c+ printIr (AcV c) = printIr c + printIr (Agep a) = printIr a+ printIr (AgepV a) = printIr a + ++instance IrPrint FunctionPrototype where+ printIr (FunctionPrototype fhLinkage fhVisibility fhDllStorageClass fhCCoonc fhAttr fhRetType fhName fhParams + fhd fhAttr1 fhSection fhCmd fhAlign fhGc fhPrefix fhPrologue) = + hsep [printIr fhLinkage, printIr fhVisibility, printIr fhDllStorageClass, printIr fhCCoonc, hsep $ fmap printIr fhAttr+ , printIr fhRetType, printIr fhName, printIr fhParams, printIr fhd, hsep $ fmap printIr fhAttr1+ , printIr fhSection, printIr fhCmd, printIr fhAlign, printIr fhGc, printIr fhPrefix, printIr fhPrologue]+++instance IrPrint MetaKind where+ printIr a = case a of+ Mtype t -> printIr t+ Mmetadata -> text "metadata"++instance IrPrint MetaKindedConst where+ printIr x = case x of+ (MetaKindedConst mk mc) -> printIr mk <+> printIr mc+ UnmetaKindedNull -> text "null" ++instance IrPrint (Type s x) where+ printIr a = case a of + TpI i -> text "i" <> integral i+ TpF f -> text "f" <> integral f+ TpV v -> text "v" <> integral v+ TpHalf -> text "half"+ TpFloat -> text "float"+ TpDouble -> text "double"+ TpFp128 -> text "fp128"+ TpX86Fp80 -> text "x86_fp80"+ TpPpcFp128 -> text "ppc_fp128"+ TpX86Mmx -> text "x86_mmx"+ TpLabel -> text "label"+ Tvoid -> text "void"+ Topaque -> text "opaque"+ TpNull -> text "null"+ + TnameScalarI s -> char '%' <> text s+ TquoteNameScalarI s -> char '%'<> (doubleQuotes $ text s)+ TnoScalarI i -> char '%'<> integral i+ + TnameScalarF s -> char '%' <> text s+ TquoteNameScalarF s -> char '%'<> (doubleQuotes $ text s)+ TnoScalarF i -> char '%'<> integral i++ TnameScalarP s -> char '%' <> text s+ TquoteNameScalarP s -> char '%'<> (doubleQuotes $ text s)+ TnoScalarP i -> char '%'<> integral i++ TnameVectorI s -> char '%' <> text s+ TquoteNameVectorI s -> char '%'<> (doubleQuotes $ text s)+ TnoVectorI i -> char '%'<> integral i++ TnameVectorF s -> char '%' <> text s+ TquoteNameVectorF s -> char '%'<> (doubleQuotes $ text s)+ TnoVectorF i -> char '%'<> integral i++ TnameVectorP s -> char '%' <> text s+ TquoteNameVectorP s -> char '%'<> (doubleQuotes $ text s)+ TnoVectorP i -> char '%'<> integral i++ TnameRecordD s -> char '%' <> text s+ TquoteNameRecordD s -> char '%'<> (doubleQuotes $ text s)+ TnoRecordD i -> char '%'<> integral i++ TnameCodeFunX s -> char '%' <> text s+ TquoteNameCodeFunX s -> char '%'<> (doubleQuotes $ text s)+ TnoCodeFunX i -> char '%'<> integral i++ Tarray i t -> brackets (integral i <+> char 'x' <+> printIr t)+ TvectorI i t -> char '<' <> integral i <+> char 'x' <+> printIr t <> char '>'+ TvectorF i t -> char '<' <> integral i <+> char 'x' <+> printIr t <> char '>' + TvectorP i t -> char '<' <> integral i <+> char 'x' <+> printIr t <> char '>' + Tstruct b ts -> let (start, end) = case b of + Packed -> (char '<', char '>')+ Unpacked -> (empty, empty)+ in start <+> braces (hsep $ punctuate comma $ fmap printIr ts) <+> end+ Tpointer t addr -> printIr t <+> integral addr <+> text "*"+ Tfunction t fp atts -> printIr t <+> printIr fp <+> (hsep $ punctuate comma $ fmap printIr atts)++instance IrPrint FormalParam where+ printIr x = case x of+ (FormalParamData t att1 align id att2) ->+ (printIr t) <+> (hsep $ fmap printIr att1) <> (maybe empty ((comma <+>) . printIr) align)+ <+> (printIr id) <+> (hsep $ fmap printIr att2)+ (FormalParamMeta e lv) -> printIr e <+> printIr lv++instance IrPrint FormalParamList where+ printIr (FormalParamList params var atts) =+ parens (commaSepNonEmpty ((fmap printIr params) ++ [maybe empty printIr var])) <+> (hsep $ fmap printIr atts)++instance IrPrint TypeParamList where+ printIr (TypeParamList params b) = parens (commaSepNonEmpty ((fmap printIr params) ++ [maybe empty printIr b]))++++instance IrPrint Utype where+ printIr x = case x of+ UtypeScalarI e -> printIr e+ UtypeScalarF e -> printIr e + UtypeScalarP e -> printIr e + UtypeVectorI e -> printIr e+ UtypeVectorF e -> printIr e + UtypeVectorP e -> printIr e+ UtypeFirstClassD e -> printIr e+ UtypeRecordD e -> printIr e+ UtypeOpaqueD e -> printIr e+ UtypeVoidU e -> printIr e+ UtypeFunX e -> printIr e+++instance IrPrint Etype where+ printIr x = case x of+ EtypeScalarI e -> printIr e+ EtypeScalarF e -> printIr e + EtypeScalarP e -> printIr e + EtypeVectorI e -> printIr e+ EtypeVectorF e -> printIr e + EtypeVectorP e -> printIr e + EtypeFirstClassD e -> printIr e+ EtypeRecordD e -> printIr e+ EtypeOpaqueD e -> printIr e+ EtypeFunX e -> printIr e++instance IrPrint Ftype where+ printIr x = case x of+ FtypeScalarI e -> printIr e+ FtypeScalarF e -> printIr e + FtypeScalarP e -> printIr e + FtypeVectorI e -> printIr e+ FtypeVectorF e -> printIr e + FtypeVectorP e -> printIr e+ FtypeFirstClassD e -> printIr e+++instance IrPrint Dtype where+ printIr x = case x of+ DtypeScalarI e -> printIr e+ DtypeScalarF e -> printIr e + DtypeScalarP e -> printIr e+ DtypeVectorI e -> printIr e+ DtypeVectorF e -> printIr e + DtypeVectorP e -> printIr e + DtypeFirstClassD e -> printIr e+ DtypeRecordD e -> printIr e++instance IrPrint Rtype where+ printIr x = case x of+ RtypeScalarI e -> printIr e+ RtypeScalarF e -> printIr e + RtypeScalarP e -> printIr e + RtypeVectorI e -> printIr e+ RtypeVectorF e -> printIr e + RtypeVectorP e -> printIr e+ RtypeFirstClassD e -> printIr e+ RtypeRecordD e -> printIr e+ RtypeVoidU e -> printIr e++instance IrPrint ScalarType where+ printIr x = case x of+ ScalarTypeI e -> printIr e+ ScalarTypeF e -> printIr e + ScalarTypeP e -> printIr e ++instance IrPrint (IntOrPtrType ScalarB) where+ printIr x = case x of+ IntOrPtrTypeI e -> printIr e+ IntOrPtrTypeP e -> printIr e ++instance IrPrint (IntOrPtrType VectorB) where+ printIr x = case x of+ IntOrPtrTypeI e -> printIr e+ IntOrPtrTypeP e -> printIr e ++instance IrPrint Prefix where+ printIr (Prefix n) = text "prefix" <+> printIr n+ +instance IrPrint Prologue where + printIr (Prologue n) = text "prologue" <+> printIr n+++instance IrPrint IcmpOp where+ printIr = P.print ++instance IrPrint FcmpOp where+ printIr = P.print++instance IrPrint Linkage where+ printIr = P.print++instance IrPrint CallConv where+ printIr = P.print++instance IrPrint Visibility where+ printIr = P.print++instance IrPrint DllStorageClass where+ printIr = P.print+ +instance IrPrint ThreadLocalStorage where + printIr = P.print++instance IrPrint ParamAttr where+ printIr = P.print++instance IrPrint FunAttr where+ printIr = P.print+ +instance IrPrint SelectionKind where + printIr = P.print+ +instance IrPrint AddrNaming where+ printIr = P.print++instance IrPrint DqString where+ printIr = P.print+++instance IrPrint Section where+ printIr = P.print++instance IrPrint Alignment where+ printIr = P.print++instance IrPrint Gc where+ printIr = P.print++instance IrPrint GlobalType where+ printIr = P.print++instance IrPrint GlobalOrLocalId where+ printIr = P.print+ +instance IrPrint LocalId where+ printIr = P.print+ +instance IrPrint GlobalId where+ printIr = P.print++instance IrPrint BinaryConstant where+ printIr = P.print+ +instance IrPrint AtomicMemoryOrdering where+ printIr = P.print++instance IrPrint AtomicOp where+ printIr = P.print+ +instance IrPrint Integer where+ printIr = integer++instance IrPrint AddrSpace where+ printIr = integral++instance IrPrint Fparam where+ printIr = P.print+ +instance IrPrint InAllocaAttr where+ printIr = P.print+ +instance IrPrint Volatile where+ printIr = P.print++instance IrPrint Weak where+ printIr = P.print+ +instance IrPrint SingleThread where+ printIr = P.print++instance IrPrint InBounds where+ printIr = P.print+ +instance (P.Print a, IrPrint a) => IrPrint (IsOrIsNot a) where+ printIr = P.print++instance IrPrint Nontemporal where + printIr = P.print+ +instance IrPrint InvariantLoad where+ printIr = P.print+ +instance IrPrint Nonnull where+ printIr = P.print+ + +instance IrPrint TailCall where+ printIr = P.print++instance IrPrint DollarId where+ printIr = P.print+++instance IrPrint Comdat where+ printIr = P.print++instance IrPrint FastMathFlag where + printIr = P.print+ +instance IrPrint FastMathFlags where + printIr = P.print+ +instance IrPrint ExternallyInitialized where + printIr = P.print+ + +instance IrPrint AsmDialect where + printIr = P.print++instance IrPrint Endianness where+ printIr = P.print+ +instance IrPrint LayoutAddrSpace where + printIr = P.print+ +instance IrPrint SizeInBit where + printIr = P.print+ +instance IrPrint AlignInBit where + printIr = P.print+ +instance IrPrint StackAlign where + printIr = P.print+ +instance IrPrint Mangling where+ printIr = P.print+ +instance IrPrint AbiAlign where + printIr = P.print++instance IrPrint PrefAlign where+ printIr = P.print+ +instance IrPrint LayoutSpec where + printIr = P.print+ +instance IrPrint DataLayout where+ printIr = P.print+ +instance IrPrint SideEffect where + printIr = P.print+ +instance IrPrint AlignStack where + printIr = P.print++instance IrPrint Cleanup where+ printIr = P.print++instance IrPrint TargetTriple where+ printIr = P.print+ +instance IrPrint DataLayoutInfo where + printIr = P.print+ +instance IrPrint VarArgParam where + printIr = P.print
+ src/Llvm/Syntax/Printer/LlvmPrint.hs view
@@ -0,0 +1,592 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+module Llvm.Syntax.Printer.LlvmPrint+ (module Llvm.Syntax.Printer.LlvmPrint+ ,module Llvm.Syntax.Printer.Common+ ) where++import Llvm.Syntax.Printer.Common+import Llvm.Data.Ast+import qualified Llvm.Syntax.Printer.SharedEntityPrint as P+import Llvm.Syntax.Printer.SharedEntityPrint (integral)+import Llvm.Util.Mapping (getValOrImplError)++class AsmPrint a where+ toLlvm :: a -> Doc++commaSepMaybe :: AsmPrint a => Maybe a -> Doc+commaSepMaybe = maybe empty ((comma<+>) . toLlvm)++maybeSepByEquals :: AsmPrint a => Maybe a -> Doc+maybeSepByEquals = maybe empty ((<+>equals).toLlvm)++instance AsmPrint a => AsmPrint (Maybe a) where+ toLlvm (Just x) = toLlvm x+ toLlvm Nothing = empty++instance AsmPrint LabelId where+ toLlvm (LabelString s) = text s+ toLlvm (LabelNumber n) = integral n+ toLlvm (LabelDqNumber n) = doubleQuotes $ integral n+ toLlvm (LabelDqString s) = doubleQuotes $ text s++instance AsmPrint PercentLabel where+ toLlvm (PercentLabel li) = char '%' <> (toLlvm li)+ +instance AsmPrint TargetLabel where+ toLlvm (TargetLabel x) = text "label" <+> toLlvm x+ +instance AsmPrint BlockLabel where+ toLlvm (ImplicitBlockLabel (f, l, c)) = + text ";<label>:? ;" <+> parens ((text f) <> comma <+> (integer $ toInteger l) <> comma <+> (integer $ toInteger c))+ toLlvm (ExplicitBlockLabel l) = toLlvm l <> char ':'++instance AsmPrint ComplexConstant where+ toLlvm (Cstruct b ts) = + let (start, end) = case b of + Packed -> (char '<', char '>') + Unpacked -> (empty, empty)+ in start <> braces (commaSepList $ fmap toLlvm ts) <> end+ toLlvm (Cvector ts) = char '<' <+> (commaSepList $ fmap toLlvm ts) <+> char '>'+ toLlvm (Carray ts) = brackets $ commaSepList $ fmap toLlvm ts++instance AsmPrint IbinOp where+ toLlvm x = text $ getValOrImplError (ibinOpMap, "ibinOpMap") x ++instance AsmPrint FbinOp where+ toLlvm x = text $ getValOrImplError (fbinOpMap, "fbinOpMap") x++instance AsmPrint (BinExpr Const) where+ toLlvm (Ie v) = toLlvm v+ toLlvm (Fe v) = toLlvm v++instance AsmPrint (BinExpr Value) where+ toLlvm (Ie v) = toLlvm v+ toLlvm (Fe v) = toLlvm v++instance AsmPrint (IbinExpr Const) where+ toLlvm (IbinExpr op cs t c1 c2) = + toLlvm op <+> (hsep $ fmap toLlvm cs) <+> parens (toLlvm (Typed t c1) <> comma <+> toLlvm (Typed t c2))+ +instance AsmPrint (FbinExpr Const) where+ toLlvm (FbinExpr op cs t c1 c2) = + toLlvm op <+> toLlvm cs <+> parens (toLlvm (Typed t c1) <> comma <+> toLlvm (Typed t c2))++instance AsmPrint (Conversion Const) where+ toLlvm (Conversion op tc t) = toLlvm op <+> parens (toLlvm tc <+> text "to" <+> toLlvm t)++instance AsmPrint (GetElementPtr Const) where+ toLlvm (GetElementPtr b base indices) = + text "getelementptr" <+> toLlvm b <+> parens (commaSepList ((toLlvm base):fmap toLlvm indices))++instance AsmPrint (Select Const) where+ toLlvm (Select cnd tc1 tc2) = + text "select" <+> parens (commaSepList [toLlvm cnd, toLlvm tc1, toLlvm tc2])++instance AsmPrint (Icmp Const) where+ toLlvm (Icmp op t c1 c2) = + text "icmp" <+> toLlvm op <+> parens (toLlvm (Typed t c1) <> comma <+> toLlvm (Typed t c2))++instance AsmPrint (Fcmp Const) where+ toLlvm (Fcmp op t c1 c2) = + text "fcmp" <+> toLlvm op <+> parens (toLlvm (Typed t c1) <> comma <+> toLlvm (Typed t c2))++instance AsmPrint (ShuffleVector Const) where+ toLlvm (ShuffleVector tc1 tc2 mask) = + text "shufflevector" <+> parens (commaSepList [toLlvm tc1, toLlvm tc2, toLlvm mask])++instance AsmPrint (ExtractValue Const) where+ toLlvm (ExtractValue tc indices) = + text "extractvalue" <+> parens (commaSepList ((toLlvm tc):fmap integral indices))+ +instance AsmPrint (InsertValue Const) where+ toLlvm (InsertValue vect tc indices) = + text "insertvalue" <+> parens (commaSepList ((toLlvm vect):(toLlvm tc):fmap integral indices)) + +instance AsmPrint (ExtractElement Const) where+ toLlvm (ExtractElement tc index) = + text "extractelement" <+> parens (toLlvm tc <> comma <+> toLlvm index)++instance AsmPrint (InsertElement Const) where + toLlvm (InsertElement tc1 tc2 index) = + text "insertelement" <+> parens (commaSepList [toLlvm tc1, toLlvm tc2, toLlvm index])++instance AsmPrint TrapFlag where+ toLlvm Nuw = text "nuw"+ toLlvm Nsw = text "nsw"+ toLlvm Exact = text "exact"+ +instance AsmPrint Const where+ toLlvm x = case x of+ C_simple c -> toLlvm c+ C_complex a -> toLlvm a+ C_labelId l -> toLlvm l+ C_blockAddress g a -> text "blockaddress" <+> parens (toLlvm g <> comma <+> toLlvm a)+ C_binexp a -> toLlvm a+ C_conv a -> toLlvm a + C_gep a -> toLlvm a+ C_select a -> toLlvm a+ C_icmp a -> toLlvm a+ C_fcmp a -> toLlvm a + C_shufflevector a -> toLlvm a+ C_extractvalue a -> toLlvm a+ C_insertvalue a -> toLlvm a+ C_extractelement a -> toLlvm a+ C_insertelement a -> toLlvm a+ C_localId v -> toLlvm v++instance AsmPrint MdVar where + toLlvm (MdVar s) = char '!'<> (text s)+ +instance AsmPrint MdNode where+ toLlvm (MdNode s) = char '!' <> (text s)+ +instance AsmPrint MetaConst where+ toLlvm (McStruct c) = char '!' <> braces (commaSepList (fmap toLlvm c))+ toLlvm (McString s) = char '!' <> (toLlvm s)+ toLlvm (McMn n) = toLlvm n+ toLlvm (McMv v) = toLlvm v+ toLlvm (McRef s) = toLlvm s+ toLlvm (McSimple sc) = toLlvm sc++instance AsmPrint MetaKindedConst where+ toLlvm x = case x of+ (MetaKindedConst mk mc) -> toLlvm mk <+> toLlvm mc+ UnmetaKindedNull -> text "null"++instance AsmPrint (GetElementPtr Value) where+ toLlvm (GetElementPtr ib tv tcs) = + text "getelementptr" <+> toLlvm ib <+> (commaSepList ((toLlvm tv):fmap toLlvm tcs))++instance AsmPrint (IbinExpr Value) where+ toLlvm (IbinExpr op cs t v1 v2) = hsep ((toLlvm op):(fmap toLlvm cs)++[toLlvm t, toLlvm v1 <> comma, toLlvm v2])++instance AsmPrint (FbinExpr Value) where+ toLlvm (FbinExpr op cs t v1 v2) = hsep [toLlvm op, toLlvm cs, toLlvm t, toLlvm v1 <> comma, toLlvm v2]++instance AsmPrint (Icmp Value) where + toLlvm (Icmp op t v1 v2) = hsep [text "icmp", toLlvm op, toLlvm t, toLlvm v1 <> comma, toLlvm v2]+ +instance AsmPrint (Fcmp Value) where + toLlvm (Fcmp op t v1 v2) = hsep [text "fcmp", toLlvm op, toLlvm t, toLlvm v1 <> comma, toLlvm v2]+ +instance AsmPrint (Conversion Value) where+ toLlvm (Conversion op tv t) = hsep [toLlvm op, toLlvm tv, text "to", toLlvm t]+ +instance AsmPrint (Select Value) where+ toLlvm (Select c t f) = hsep [text "select", toLlvm c <> comma, toLlvm t <> comma, toLlvm f]++instance AsmPrint Expr where+ toLlvm (EgEp a) = toLlvm a+ toLlvm (EiC a) = toLlvm a+ toLlvm (EfC a) = toLlvm a+ toLlvm (Eb a) = toLlvm a+ toLlvm (Ec a) = toLlvm a+ toLlvm (Es a) = toLlvm a++instance AsmPrint MemOp where + toLlvm (Alloca ma t s a) = hsep [text "alloca", toLlvm ma, hcat [toLlvm t, commaSepMaybe s, commaSepMaybe a]]+ toLlvm (Load b ptr align noterm inv nonul) = + hsep [text "load", toLlvm b, hcat [toLlvm ptr, commaSepMaybe align, commaSepMaybe noterm, commaSepMaybe inv, commaSepMaybe nonul]]+ toLlvm (LoadAtomic (Atomicity st ord) b ptr align) = + hsep [text "load", text "atomic", toLlvm b, toLlvm ptr, toLlvm st, toLlvm ord] <> (commaSepMaybe align)+ toLlvm (Store b v addr align noterm) = + hsep [text "store", toLlvm b, toLlvm v <> comma, toLlvm addr <> (commaSepMaybe align) <> (commaSepMaybe noterm)]+ toLlvm (StoreAtomic (Atomicity st ord) b v ptr align) = + hsep [text "store", text "atomic", toLlvm b, toLlvm v <> comma, toLlvm ptr, toLlvm st, toLlvm ord] <> (commaSepMaybe align)+ toLlvm (Fence b order) = hsep [text "fence", toLlvm b, toLlvm order]+ toLlvm (CmpXchg wk v p c n st sord ford) = + hsep [text "cmpxchg", toLlvm wk, toLlvm v, toLlvm p <> comma, toLlvm c <> comma, toLlvm n, toLlvm st, toLlvm sord, toLlvm ford]+ toLlvm (AtomicRmw v op p vl st ord) = + hsep [text "atomicrmw", toLlvm v, toLlvm op, toLlvm p <> comma, toLlvm vl, toLlvm st, toLlvm ord]++instance AsmPrint Value where+ toLlvm (Val_local i) = toLlvm i+ toLlvm (Val_const c) = toLlvm c++instance AsmPrint v => AsmPrint (Typed v) where+ toLlvm (Typed t v) = toLlvm t <+> toLlvm v++instance AsmPrint a => AsmPrint (Pointer a) where+ toLlvm (Pointer i) = toLlvm i++instance AsmPrint FunName where+ toLlvm (FunNameGlobal s) = toLlvm s+ toLlvm (FunNameString s) = text s+ +instance AsmPrint CallSite where+ toLlvm (CsFun cc ra rt ident params fa) = + hsep [toLlvm cc, hsep $ fmap toLlvm ra, toLlvm rt, toLlvm ident, parens (commaSepList $ fmap toLlvm params), hsep $ fmap toLlvm fa]+ toLlvm (CsAsm t se as dia s1 s2 params fa) = + hsep [toLlvm t, text "asm", toLlvm se, toLlvm as, toLlvm dia, toLlvm s1 <> comma, toLlvm s2, parens (commaSepList $ fmap toLlvm params), hsep $ fmap toLlvm fa]+ toLlvm (CsConversion ra t convert params fa) = + hsep [hsep $ fmap toLlvm ra, toLlvm t, toLlvm convert, parens (commaSepList $ fmap toLlvm params), hsep $ fmap toLlvm fa]++instance AsmPrint Clause where+ toLlvm (Catch tv) = text "catch" <+> toLlvm tv+ toLlvm (Filter tc) = text "filter" <+> toLlvm tc+ toLlvm (Cco c) = toLlvm c++instance AsmPrint (Conversion GlobalOrLocalId) where+ toLlvm (Conversion op (Typed t g) dt) = toLlvm op <+> parens (hsep [toLlvm t, toLlvm g, text "to", toLlvm dt])+ +instance AsmPrint PersFn where+ toLlvm (PersFnId g) = toLlvm g+ toLlvm (PersFnCast c) = toLlvm c+ toLlvm PersFnUndef = text "undef"+ toLlvm PersFnNull = text "null"+ toLlvm (PersFnConst c) = toLlvm c++instance AsmPrint (ExtractElement Value) where+ toLlvm (ExtractElement tv1 tv2) = + text "extractelement" <+> (commaSepList [toLlvm tv1, toLlvm tv2])+ +instance AsmPrint (InsertElement Value) where + toLlvm (InsertElement vect tv idx) = + text "insertelement" <+> (commaSepList [toLlvm vect, toLlvm tv, toLlvm idx])+ +instance AsmPrint (ShuffleVector Value) where + toLlvm (ShuffleVector vect1 vect2 mask) = + text "shufflevector" <+> (commaSepList [toLlvm vect1, toLlvm vect2, toLlvm mask])+ +instance AsmPrint (ExtractValue Value) where + toLlvm (ExtractValue tv idxs) = text "extractvalue" <+> (commaSepList ((toLlvm tv):(fmap integral idxs)))+ +instance AsmPrint (InsertValue Value) where + toLlvm (InsertValue vect tv idxs) = + text "insertvalue" <+> (commaSepList ((toLlvm vect):(toLlvm tv):(fmap integral idxs)))+++instance AsmPrint Rhs where+ toLlvm (RmO a) = toLlvm a+ toLlvm (Re a) = toLlvm a+ toLlvm (Call tailc callSite) = hsep [toLlvm tailc, text "call", toLlvm callSite]+ toLlvm (ReE a) = toLlvm a+ toLlvm (RiE a) = toLlvm a+ toLlvm (RsV a) = toLlvm a+ toLlvm (ReV a) = toLlvm a+ toLlvm (RiV a) = toLlvm a+ toLlvm (RvA (VaArg tv t)) = hsep [text "va_arg", toLlvm tv <> comma, toLlvm t]+ toLlvm (RlP (LandingPad rt pt tgl b clause)) = + hsep ([text "landingpad", toLlvm rt, text "personality", toLlvm pt, toLlvm tgl, toLlvm b] ++ (fmap toLlvm clause))++instance AsmPrint ActualParam where+ toLlvm x = case x of+ (ActualParamData t att1 align v att2) ->+ hsep [toLlvm t, hsep $ fmap toLlvm att1, toLlvm align, toLlvm v, hsep $ fmap toLlvm att2]+ (ActualParamMeta mc) -> toLlvm mc++instance AsmPrint Dbg where+ toLlvm (Dbg mv meta) = toLlvm mv <+> toLlvm meta++instance AsmPrint PhiInst where+ toLlvm (PhiInst lhs t pairs) = hsep [maybe empty ((<+> equals) . toLlvm) lhs, text "phi", toLlvm t, commaSepList $ fmap tvToLLvm pairs]+ where tvToLLvm (h1,h2) = brackets (toLlvm h1 <> comma <+> toLlvm h2)++instance AsmPrint ComputingInst where+ toLlvm (ComputingInst lhs rhs) = maybe empty ((<+> equals) . toLlvm) lhs <+> toLlvm rhs++instance AsmPrint TerminatorInst where+ toLlvm RetVoid = text "ret" <+> text "void"+ toLlvm (Return x) = text "ret" <+> (commaSepList $ fmap toLlvm x)+ toLlvm (Br a) = text "br" <+> toLlvm a+ toLlvm (Cbr v t f) = hsep [text "br", text "i1", toLlvm v <> comma, toLlvm t <> comma, toLlvm f]+ toLlvm (IndirectBr v l) = hsep [text "indirectbr", toLlvm v <> comma, brackets (commaSepList $ fmap toLlvm l)]+ toLlvm (Switch v d tbl) = + hsep [text "switch", toLlvm v <> comma, toLlvm d, brackets (hsep $ fmap (\(p1,p2) -> toLlvm p1 <> comma <+> toLlvm p2) tbl)]+ toLlvm (Invoke lhs callSite toL unwindL) = + hsep [maybe empty ((<+> equals) . toLlvm) lhs, text "invoke", toLlvm callSite, text "to", toLlvm toL, text "unwind", toLlvm unwindL]+ toLlvm Unreachable = text "unreachable"+ toLlvm (Resume a) = text "resume" <+> toLlvm a+ +instance AsmPrint PhiInstWithDbg where+ toLlvm (PhiInstWithDbg ins dbgs) = commaSepList ((toLlvm ins):fmap toLlvm dbgs)++instance AsmPrint TerminatorInstWithDbg where+ toLlvm (TerminatorInstWithDbg ins dbgs) = commaSepList ((toLlvm ins):fmap toLlvm dbgs)++instance AsmPrint ComputingInstWithDbg where+ toLlvm ci = case ci of+ ComputingInstWithDbg ins dbgs -> commaSepList ((toLlvm ins):fmap toLlvm dbgs)+ ComputingInstWithComment s -> char ';' <+> text s ++instance AsmPrint Aliasee where+ toLlvm (AtV tv ) = toLlvm tv+ toLlvm (Ac c) = toLlvm c+ toLlvm (AgEp a) = toLlvm a++instance AsmPrint FunctionPrototype where+ toLlvm (FunctionPrototype fhLinkage fhVisibility fhDllStorageClass fhCCoonc fhAttr fhRetType fhName fhParams fnd + fhAttr1 fhSection fhcmd fhAlign fhGc fhPrefix fhPrologue) = + hsep [toLlvm fhLinkage, toLlvm fhVisibility, toLlvm fhDllStorageClass, toLlvm fhCCoonc, hsep $ fmap toLlvm fhAttr + , toLlvm fhRetType, toLlvm fhName, toLlvm fhParams, toLlvm fnd, hsep $ fmap toLlvm fhAttr1+ , toLlvm fhSection, toLlvm fhcmd, toLlvm fhAlign, toLlvm fhGc, toLlvm fhPrefix, toLlvm fhPrologue]++instance AsmPrint Block where+ toLlvm (Block lbl phis ins end) = toLlvm lbl $$+ (nest 2 + ((vcat $ fmap toLlvm phis) $$+ (vcat $ fmap toLlvm ins) $$+ toLlvm end))++instance AsmPrint Toplevel where + toLlvm (ToplevelTriple (TlTriple s)) = hsep [text "target", text "triple", equals, toLlvm s]+ toLlvm (ToplevelDataLayout (TlDataLayout s)) = hsep [text "target", text "datalayout", equals, toLlvm s]+ toLlvm (ToplevelAlias (TlAlias lhs vis dll tlm naddr link aliasee)) = + hsep [toLlvm lhs, equals, toLlvm vis, toLlvm dll, toLlvm tlm, toLlvm naddr, text "alias", toLlvm link, toLlvm aliasee]+ toLlvm (ToplevelDbgInit (TlDbgInit s i)) = error "DbgInit is not implemented"+ toLlvm (ToplevelStandaloneMd smd) = toLlvm smd+ toLlvm (ToplevelNamedMd (TlNamedMd mv nds)) = toLlvm mv <+> equals <+> char '!'<>(braces (commaSepList $ fmap toLlvm nds))+ toLlvm (ToplevelDeclare (TlDeclare fproto)) = text "declare" <+> toLlvm fproto+ toLlvm (ToplevelDefine (TlDefine fproto blocks)) = text "define" <+> toLlvm fproto <+> text "{" $$+ (fcat $ fmap toLlvm blocks) $$ text "}"+ toLlvm (ToplevelGlobal (TlGlobal lhs linkage vis dllStor threadLoc un addrspace externali gty ty const0 + section comdat align)) = + hsep [maybeSepByEquals lhs, toLlvm linkage, toLlvm vis, toLlvm dllStor, toLlvm threadLoc, toLlvm un+ , toLlvm addrspace, toLlvm externali, toLlvm gty, toLlvm ty, toLlvm const0]+ <> (hcat [commaSepMaybe section, commaSepMaybe comdat, commaSepMaybe align])++ toLlvm (ToplevelTypeDef (TlTypeDef n t)) = toLlvm n <+> equals <+> text "type" <+> toLlvm t+ toLlvm (ToplevelDepLibs (TlDepLibs l)) = text "deplibs" <+> equals <+> brackets (commaSepList $ fmap toLlvm l)+ toLlvm (ToplevelUnamedType (TlUnamedType x t)) = text "type" <+> toLlvm t <+> text "; " <+> (integral x)+ toLlvm (ToplevelModuleAsm (TlModuleAsm qs)) = text "module asm" <+> toLlvm qs+ toLlvm (ToplevelAttribute (TlAttribute n l)) = + hsep [text "attributes", char '#' <> (integral n), equals, braces (hsep $ fmap toLlvm l)]+ toLlvm (ToplevelComdat (TlComdat l c)) = + hsep [toLlvm l, equals, text "comdat", toLlvm c]++instance AsmPrint TlStandaloneMd where+ toLlvm (TlStandaloneMd lhs rhs) = char '!' <> (text lhs) <+> equals <+> toLlvm rhs++instance AsmPrint FormalParam where+ toLlvm x = case x of+ (FormalParamData t att1 align id att2) ->+ (toLlvm t) <+> (hsep $ fmap toLlvm att1) + <> (maybe empty ((comma <+>) . toLlvm) align) <+> (toLlvm id) <+> (hsep $ fmap toLlvm att2)+ (FormalParamMeta e lv) -> toLlvm e <+> toLlvm lv++instance AsmPrint FormalParamList where+ toLlvm (FormalParamList params var atts) =+ parens (commaSepNonEmpty ((fmap toLlvm params) ++ [maybe empty toLlvm var])) <+> (hsep $ fmap toLlvm atts)++instance AsmPrint TypeParamList where+ toLlvm (TypeParamList params b) = parens (commaSepNonEmpty ((fmap toLlvm params) ++ [maybe empty toLlvm b]))++instance AsmPrint TypePrimitive where+ toLlvm a = case a of + TpI i -> text "i" <> integral i+ TpF f -> text "f" <> integral f+ TpV v -> text "v" <> integral v+ TpHalf -> text "half"+ TpFloat -> text "float"+ TpDouble -> text "double"+ TpFp128 -> text "fp128"+ TpX86Fp80 -> text "x86_fp80"+ TpPpcFp128 -> text "ppc_fp128"+ TpX86Mmx -> text "x86_mmx"+ TpLabel -> text "label" + TpNull -> text "null"++instance AsmPrint MetaKind where+ toLlvm a = case a of+ Mtype e -> toLlvm e+ Mmetadata -> text "metadata"++instance AsmPrint Type where+ toLlvm a = case a of + Tprimitive tp -> toLlvm tp+ Tvoid -> text "void"+ Topaque -> text "opaque"+ Tname s -> char '%' <> text s + TquoteName s -> char '%'<> (doubleQuotes $ text s)+ Tno i -> char '%'<> integral i+ Tarray i t -> brackets (integral i <+> char 'x' <+> toLlvm t)+ Tvector i t -> char '<' <> integral i <+> char 'x' <+> toLlvm t <> char '>'+ Tstruct b ts -> let (start, end) = case b of + Packed -> (char '<', char '>')+ Unpacked -> (empty, empty)+ in start <> braces (hsep $ punctuate comma $ fmap toLlvm ts) <> end+ Tpointer t addr -> toLlvm t <+> toLlvm addr <> text "*"+ Tfunction t fp atts -> toLlvm t <+> toLlvm fp <+> (hsep $ punctuate comma $ fmap toLlvm atts)++instance AsmPrint AddrSpace where+ toLlvm (AddrSpace n) = text "addrspace" <+> (parens $ integral n)+ toLlvm AddrSpaceUnspecified = empty++instance AsmPrint ConvertOp where+ toLlvm x = text $ getValOrImplError (convertOpMap, "convertOpMap") x++instance AsmPrint TypedConstOrNull where + toLlvm (TypedConst tc) = toLlvm tc+ toLlvm UntypedNull = text "null"++instance AsmPrint Module where + toLlvm (Module tops) = vcat $ fmap toLlvm tops++instance AsmPrint Prefix where+ toLlvm (Prefix n) = text "prefix" <+> toLlvm n+ +instance AsmPrint Prologue where + toLlvm (Prologue n) = text "prologue" <+> toLlvm n++instance AsmPrint IcmpOp where+ toLlvm = P.print ++instance AsmPrint FcmpOp where+ toLlvm = P.print++instance AsmPrint Linkage where+ toLlvm = P.print++instance AsmPrint CallConv where+ toLlvm = P.print++instance AsmPrint Visibility where+ toLlvm = P.print++instance AsmPrint DllStorageClass where+ toLlvm = P.print+ +instance AsmPrint ThreadLocalStorage where + toLlvm = P.print++instance AsmPrint ParamAttr where+ toLlvm = P.print++instance AsmPrint FunAttr where+ toLlvm = P.print+ +instance AsmPrint SelectionKind where + toLlvm = P.print+ +instance AsmPrint AddrNaming where+ toLlvm = P.print++instance AsmPrint DqString where+ toLlvm = P.print++instance AsmPrint Section where+ toLlvm = P.print++instance AsmPrint Alignment where+ toLlvm = P.print++instance AsmPrint Gc where+ toLlvm = P.print++instance AsmPrint GlobalType where+ toLlvm = P.print++instance AsmPrint GlobalOrLocalId where+ toLlvm = P.print+ +instance AsmPrint LocalId where+ toLlvm = P.print+ +instance AsmPrint GlobalId where+ toLlvm = P.print++instance AsmPrint SimpleConstant where+ toLlvm = P.print+ +instance AsmPrint AtomicMemoryOrdering where+ toLlvm = P.print++instance AsmPrint AtomicOp where+ toLlvm = P.print+ +instance AsmPrint Fparam where+ toLlvm = P.print+ +instance AsmPrint VarArgParam where+ toLlvm = P.print++instance AsmPrint InAllocaAttr where+ toLlvm = P.print+ +instance AsmPrint Volatile where+ toLlvm = P.print++instance AsmPrint Weak where+ toLlvm = P.print+ +instance AsmPrint SingleThread where+ toLlvm = P.print++instance AsmPrint InBounds where+ toLlvm = P.print+ +instance (P.Print a, AsmPrint a) => AsmPrint (IsOrIsNot a) where+ toLlvm = P.print++instance AsmPrint Nontemporal where + toLlvm = P.print+ +instance AsmPrint InvariantLoad where+ toLlvm = P.print+ +instance AsmPrint Nonnull where+ toLlvm = P.print++instance AsmPrint TailCall where+ toLlvm = P.print++instance AsmPrint DollarId where+ toLlvm = P.print++instance AsmPrint Comdat where+ toLlvm = P.print++instance AsmPrint FastMathFlag where + toLlvm = P.print+ +instance AsmPrint FastMathFlags where + toLlvm = P.print+ +instance AsmPrint ExternallyInitialized where + toLlvm = P.print+ +instance AsmPrint AsmDialect where + toLlvm = P.print++instance AsmPrint Endianness where+ toLlvm = P.print+ +instance AsmPrint LayoutAddrSpace where + toLlvm = P.print+ +instance AsmPrint SizeInBit where + toLlvm = P.print+ +instance AsmPrint AlignInBit where + toLlvm = P.print+ +instance AsmPrint StackAlign where + toLlvm = P.print+ +instance AsmPrint Mangling where+ toLlvm = P.print+ +instance AsmPrint AbiAlign where + toLlvm = P.print++instance AsmPrint PrefAlign where+ toLlvm = P.print+ +instance AsmPrint LayoutSpec where + toLlvm = P.print+ +instance AsmPrint DataLayout where+ toLlvm = P.print+ +instance AsmPrint SideEffect where + toLlvm = P.print+ +instance AsmPrint AlignStack where + toLlvm = P.print+ +instance AsmPrint Cleanup where + toLlvm = P.print++instance AsmPrint TargetTriple where+ toLlvm = P.print
@@ -0,0 +1,396 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE GADTs #-}+module Llvm.Syntax.Printer.SharedEntityPrint where+import Prelude (($),fmap, Maybe(..),maybe, (.),null,(++),error, show,fromIntegral,String,Integral)++import Llvm.Syntax.Printer.Common +import Llvm.Data.Shared+import Llvm.Util.Mapping (getValOrImplError)+import qualified Data.Map as M++class Print a where+ print :: a -> Doc++instance Print Endianness where+ print LittleEndian = char 'e'+ print BigEndian = char 'E'+ +instance Print LayoutAddrSpace where + print (LayoutAddrSpace n) = integral n+ print (LayoutAddrSpaceUnspecified) = empty+ +instance Print SizeInBit where + print (SizeInBit n) = integral n+ +instance Print AlignInBit where + print (AlignInBit n) = integral n+ +instance Print StackAlign where + print (StackAlign n) = print n+ print StackAlignUnspecified = char '0'+ +instance Print Mangling where+ print x = case x of+ ManglingE -> char 'e'+ ManglingM -> char 'm'+ ManglingO -> char 'o'+ ManglingW -> char 'w'+ +instance Print AbiAlign where + print (AbiAlign n) = print n++instance Print PrefAlign where+ print (PrefAlign n) = print n+ ++integral :: Integral a => a -> Doc+integral = integer . fromIntegral++instance Print LayoutSpec where + print ls = case ls of+ DlE x -> print x+ DlS x -> char 'S' <> (print x)+ DlLittleS s1 s2 s3 -> char 's' <> (maybe empty integral s1) + <> sepMaybe integral colonSep s2+ <> sepMaybe integral colonSep s3+ DlP as s a n -> char 'p' <> (print as) + <> colonSep (print s) + <> colonSep (print a) + <> sepMaybe print colonSep n+ DlI s a n -> char 'i' <> (print s)+ <> colonSep (print a)+ <> sepMaybe print colonSep n+ DlF s a n -> char 'f' <> (print s)+ <> colonSep (print a)+ <> sepMaybe print colonSep n+ DlV s a n -> char 'v' <> (print s)+ <> colonSep (print a)+ <> sepMaybe print colonSep n+ DlA s a n -> char 'a' <> (maybe empty print s)+ <> colonSep (print a)+ <> sepMaybe print colonSep n+ DlM m -> char 'm' <> colonSep (print m)+ DlN l -> char 'n' <> (hcat $ punctuate (char ':') $ fmap print l)+ where + colonSep = (char ':' <>)+ +instance Print DataLayout where+ print (DataLayout l) = doubleQuotes (hcat $ punctuate (char '-') $ fmap print l)+ +instance Print IcmpOp where+ print x = text $ getValOrImplError (icmpOpMap, "icmpOpMap") x++instance Print FcmpOp where+ print x = text $ getValOrImplError (fcmpOpMap, "fcmpOpMap") x++{-+instance Print ConvertOp where+ print x = text $ getValOrImplError (convertOpMap, "convertOpMap") x+-}++instance Print Linkage where+ print LinkagePrivate = text "private"+ print LinkageInternal = text "internal"+ print LinkageAvailableExternally = text "available_externally"+ print LinkageExternal = text "external"+ print LinkageLinkonce = text "linkonce"+ print LinkageWeak = text "weak"+ print LinkageCommon = text "common"+ print LinkageAppending = text "appending"+ print LinkageExternWeak = text "extern_weak"+ print LinkageLinkonceOdr = text "linkonce_odr"+ print LinkageWeakOdr = text "weak_odr"+ +instance Print CallConv where+ print Ccc = text "ccc"+ print CcFast = text "fastcc"+ print CcCold = text "coldcc"+ print CcWebkit_Js = text "webkit_jscc"+ print CcAnyReg = text "anyregcc"+ print CcPreserveMost = text "preserve_mostcc"+ print CcPreserveAll = text "preserve_allcc"+ print (Cc s) = text "cc" <> text s+ print CcSpir_Kernel = text "spir_kernel"+ print CcSpir_Func = text "spir_func"+ print CcIntel_Ocl_Bi = text "intel_ocl_bicc"+ print CcX86_StdCall = text "x86_stdcallcc"+ print CcX86_FastCall = text "x86_fastcallcc"+ print CcX86_ThisCall = text "x86_thiscallcc"+ print CcArm_Apcs = text "arm_apcscc"+ print CcArm_Aapcs = text "arm_aapcscc"+ print CcArm_Aapcs_Vfp = text "arm_aapcs_vfpcc"+ print CcMsp430_Intr = text "msp430_intrcc"+ print CcPtx_Kernel = text "ptx_kernel"+ print CcPtx_Device = text "ptx_device"+ print CcX86_64_Win64 = text "x86_64_win64cc"+ print CcX86_64_SysV = text "x86_64_sysvcc"++instance Print Visibility where+ print VisDefault = text "default"+ print VisHidden = text "hidden"+ print VisProtected = text "protected"+++instance Print DllStorageClass where+ print DscImport = text "dllimport"+ print DscExport = text "dllexport"+ +instance Print ThreadLocalStorage where + print x = let d = case x of + TlsLocalDynamic -> text "localdynamic"+ TlsInitialExec -> text "initialexec"+ TlsLocalExec -> text "localexec"+ TlsNone -> empty+ in if isEmpty d then text "thread_local"+ else text "thread_local" <+> parens d ++instance Print ParamAttr where+ print PaZeroExt = text "zeroext"+ print PaSignExt = text "signext"+ print PaInReg = text "inreg"+ print PaByVal = text "byval"+ print PaInAlloca = text "inalloca"+ print PaSRet = text "sret"+ print PaNoAlias = text "noalias"+ print PaNoCapture = text "nocapture"+ print PaNest = text "nest"+ print PaReturned = text "returned"+ print PaNonNull = text "nonnull"+ print (PaDereferenceable n) = (text "dereferenceable") <> (parens $ integral n)+ print PaReadOnly = text "readonly"+ print PaReadNone = text "readnone"+ print (PaAlign n) = text "align" <+> integral n+++instance Print FunAttr where+ print (FaAlignStack n) = (text "alignstack") <> (parens $ integral n)+ print FaAlwaysInline = text "alwaysinline"+ print FaBuiltin = text "builtin"+ print FaCold = text "cold"+ print FaInlineHint = text "inlinehint"+ print FaJumpTable = text "jumptable"+ print FaMinSize = text "minsize"+ print FaNaked = text "naked"+ print FaNoBuiltin = text "nobuiltin"+ print FaNoDuplicate = text "noduplicate"+ print FaNoImplicitFloat = text "noimplicitfloat"+ print FaNoInline = text "noinline"+ print FaNonLazyBind = text "nonlazybind"+ print FaNoRedZone = text "noredzone"+ print FaNoReturn = text "noreturn"+ print FaNoUnwind = text "nounwind"+ print FaOptNone = text "optnone"+ print FaOptSize = text "optsize"+ print FaReadNone = text "readnone"+ print FaReadOnly = text "readonly"+ print FaReturnsTwice = text "returns_twice"+ print FaSanitizeAddress = text "sanitize_address"+ print FaSanitizeMemory = text "sanitize_memory"+ print FaSanitizeThread = text "sanitize_thread"+ print FaSsp = text "ssp"+ print FaSspReq = text "sspreq"+ print FaSspStrong = text "sspstrong"+ print FaUwTable = text "uwtable"+ print (FaPair s1 s2) = print s1 <> (maybe empty ((equals<>) . print) s2)+ print (FaAlign n) = text "align" <+> integral n+ print (FaGroup n) = char '#'<> (integral n)+ +instance Print SelectionKind where + print x = text $ getValOrImplError (selectionKindMap, "selectionKindMap") x+ +instance Print AddrNaming where+ print UnnamedAddr = text "unnamed_addr"+ print NamedAddr = empty++instance Print DqString where+ print (DqString x) = doubleQuotes $ text x++instance Print Section where+ print (Section s) = text "section" <+> (print s)++instance Print Alignment where+ print (Alignment s) = text "align" <+> (integral s)++instance Print Gc where+ print (Gc s) = text "gc" <+> (print s)++instance Print GlobalType where+ print (GlobalType s) = text s+++instance Print GlobalOrLocalId where+ print (GolG g) = print g+ print (GolL l) = print l+ +instance Print LocalId where+ print (LocalIdNum s) = char '%'<>(integral s)+ print (LocalIdAlphaNum s) = char '%' <> text s+ print (LocalIdDqString s) = char '%' <> (doubleQuotes $ text s)+ +instance Print GlobalId where+ print (GlobalIdNum s) = char '@'<>(integral s)+ print (GlobalIdAlphaNum s) = char '@'<> text s+ print (GlobalIdDqString s) = char '@'<> (doubleQuotes $ text s)++instance Print SimpleConstant where+ print x = case x of+ CpInt i -> text i+ CpUhexInt i -> text "u0x" <> (text i)+ CpShexInt i -> text "s0x" <> (text i)+ CpFloat s -> text s+ CpNull -> text "null"+ CpUndef -> text "undef"+ CpTrue -> text "true"+ CpFalse -> text "false"+ CpZeroInitializer -> text "zeroinitializer"+ CpGlobalAddr g -> print g+ CpStr s -> char 'c'<> (doubleQuotes $ text s)+ CpBconst bc -> print bc+ +instance Print BinaryConstant where+ print x = case x of+ BconstUint8 v -> integral v+ BconstUint16 v -> integral v+ BconstUint32 v -> integral v+ BconstUint64 v -> integral v+ BconstUint96 v -> integral v+ BconstUint128 v -> integral v+ BconstInt8 v -> integral v+ BconstInt16 v -> integral v+ BconstInt32 v -> integral v+ BconstInt64 v -> integral v+ BconstInt96 v -> integral v+ BconstInt128 v -> integral v++instance Print AtomicMemoryOrdering where+ print x = text $ getValOrImplError (atomicMemoryOrderingMap, "atomicMemoryOrderingMap") x++instance Print AtomicOp where+ print x = text $ getValOrImplError (atomicOpMap, "atomicOpMap") x+ +instance Print Fparam where+ print (FimplicitParam) = text "; implicit param\n"+ print (FexplicitParam x) = print x+ +instance Print InAllocaAttr where+ print s = case s of+ InAllocaAttr -> text "inalloca"+ + +instance Print Volatile where+ print Volatile = text "volatile"++instance Print Weak where+ print Weak = text "weak"+ +instance Print SingleThread where+ print SingleThread = text "singlethread"++instance Print InBounds where+ print InBounds = text "inbounds"+ +instance Print a => Print (IsOrIsNot a) where+ print s = case s of+ Is x -> print x+ IsNot _ -> empty++instance Print Nontemporal where + print (Nontemporal i) = char '!'<>(text "nontemporal") <+> char '!'<>(integral i)+ +instance Print InvariantLoad where+ print (InvariantLoad i) = char '!'<>(text "invariant.load") <+> char '!'<>(integral i)+ +instance Print Nonnull where+ print (Nonnull i) = char '!'<>(text "nonnull") <+> char '!'<>(integral i)+ + +instance Print TailCall where+ print x = case x of+ TcNon -> empty+ TcTailCall -> text "tail"+ TcMustTailCall -> text "musttail"+ +instance Print DollarId where+ print (DollarIdNum n) = char '$' <> (integral n)+ print (DollarIdAlphaNum s) = char '$' <> (text s)+ print (DollarIdDqString s) = char '$' <> (doubleQuotes $ text s)+ + +instance Print Comdat where+ print (Comdat l) = text "comdat" <+> (maybe empty print l)+ +instance Print FastMathFlag where+ print x = text $ getValOrImplError (fastMathFlagMap, "fastMathFlagMap") x + +instance Print FastMathFlags where + print (FastMathFlags l) = hsep $ fmap print l+ +instance Print ExternallyInitialized where + print ExternallyInitialized = text "externally_initialized"+ + +instance Print AsmDialect where + print x = case x of+ AsmDialectAtt -> empty+ AsmDialectIntel -> text "inteldialect"+ + +instance Print SideEffect where+ print SideEffect = text "sideeffect"+ +instance Print AlignStack where + print AlignStack = text "alignstack"+ +instance Print VarArgParam where+ print VarArgParam = text "..."+ +instance Print Cleanup where+ print Cleanup = text "cleanup"++instance Print Arch where+ print arch = case arch of+ Arch_i386 -> text "i386"+ Arch_i686 -> text "i686"+ Arch_x86 -> text "x86"+ Arch_x86_64 -> text "x86_64"+ Arch_PowerPc -> text "powerpc"+ Arch_PowerPc64 -> text "powerpc64"+ Arch_Arm s -> text "arm" <> text s+ Arch_ThumbV7 -> text "thumbv7"+ Arch_Itanium -> text "itanium"+ Arch_Mips s -> text "mips" <> text s+ Arch_String s -> text s+ +instance Print Vendor where+ print v = case v of+ Vendor_Pc -> text "pc"+ Vendor_Apple -> text "apple"+ Vendor_Unknown -> text "unknown"+ Vendor_String s -> text s+ +instance Print Os where + print v = case v of+ Os_Linux -> text "linux"+ Os_Windows -> text "windows"+ Os_Win32 -> text "win32"+ Os_Darwin s -> text "darwin" <> text s+ Os_FreeBsd s -> text "freebsd" <> text s+ Os_Macosx s -> text "macosx" <> text s+ Os_Ios s -> text "ios" <> text s+ Os_Mingw32 -> text "mingw32"+ Os_Unknown -> text "unknown"+ Os_String s -> text s+ +instance Print OsEnv where + print v = case v of+ OsEnv_Gnu -> text "gnu"+ OsEnv_String s -> text s++instance Print TargetTriple where+ print (TargetTriple arch ven os env) = + doubleQuotes (hcat $ punctuate (char '-') + ([print arch] ++ mb ven ++ mb os ++ mb env))+ where mb v = maybe [] (\x -> [print x]) v++instance Print DataLayoutInfo where+ print (DataLayoutInfo e sa ptrs is fs as ni ml _) = text "datalayout"
+ src/Llvm/Util/Mapping.hs view
@@ -0,0 +1,8 @@+module Llvm.Util.Mapping where++import qualified Data.Map as M++getValOrImplError :: (Show a, Ord a) => (M.Map a k, String) -> a -> k+getValOrImplError (mp, mn) x = case M.lookup x mp of+ Just s -> s+ Nothing -> error $ "implementation error: " ++ show x ++ " is not added to " ++ mn
+ src/Llvm/Util/Monadic.hs view
@@ -0,0 +1,13 @@+module Llvm.Util.Monadic where+import Control.Monad ()++maybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)+maybeM f a = case a of+ Just a' -> f a' >>= return . Just+ Nothing -> return Nothing++pairM :: Monad m => (v -> m v1) -> (l -> m l1) -> (v, l) -> m (v1, l1)+pairM c1 c2 (v, l) = do { v' <- c1 v+ ; l' <- c2 l+ ; return $ (v', l')+ }
+ src/LlvmTest.hs view
@@ -0,0 +1,168 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE DeriveDataTypeable #-}+import System.IO+import System.Console.CmdArgs+import ParserTester+import Llvm.Pass.Optimizer ()+import qualified Llvm.Pass.Mem2Reg as M2R ()+import qualified Llvm.Pass.Liveness as L ()+import qualified Llvm.Data.Ir as I+import Llvm.Query.IrCxt+import Llvm.Pass.PassManager+import qualified Compiler.Hoopl as H+import qualified Llvm.Data.Conversion as Cv+import qualified Llvm.Pass.NormalGraph as N+import qualified Llvm.Pass.Optimizer as O+import qualified Llvm.Pass.PassTester as T+import qualified Llvm.Syntax.Printer.IrPrint as P+import qualified Data.Map as M+import qualified Data.Set as S++toStep "mem2reg" = Just Mem2Reg+toStep "dce" = Just Dce+toStep _ = Nothing+++extractSteps :: [String] -> [Step]+extractSteps l = map (\x -> case toStep x of+ Just s -> s+ Nothing -> error (x ++ " is not step")+ ) l++data Sample = Dummy { input :: FilePath, output :: Maybe String }+ | Parser { input :: FilePath, output :: Maybe String, showAst :: Bool }+ | Ast2Ir { input :: FilePath, output :: Maybe String }+ | Ir2Ast { input :: FilePath, output :: Maybe String }+ | Pass { input :: FilePath, output :: Maybe String, step :: [String], fuel :: Int }+ | PhiFixUp { input :: FilePath, output :: Maybe String, fuel :: Int }+ | AstCanonic { input :: FilePath, output :: Maybe String }+ deriving (Show, Data, Typeable, Eq)++outFlags x = x &= help "Output file, stdout is used if it's not specified" &= typFile++dummy = Dummy { input = def &= typ "<INPUT>"+ , output = outFlags Nothing+ } &= help "Test LLVM Parser"++parser = Parser { input = def &= typ "<INPUT>"+ , output = outFlags Nothing+ , showAst = False+ } &= help "Test LLVM Parser"++ast2ir = Ast2Ir { input = def &= typ "<INPUT>"+ , output = outFlags Nothing+ } &= help "Test Ast to Ir conversion"++ir2ast = Ir2Ast { input = def &= typ "<INPUT>"+ , output = outFlags Nothing+ } &= help "Test Ir to Ast conversion"++astcanonic = AstCanonic { input = def &= typ "<INPUT>"+ , output = outFlags Nothing+ } &= help "Test Ir to Ast conversion"++pass = Pass { input = def &= typ "<INPUT>"+ , output = outFlags Nothing+ , fuel = H.infiniteFuel &= typ "FUEL" &= help "The fuel used to run the pass"+ , step = def &= typ "STEP" &= help "Supported steps : mem2reg, dce. Multiple passes are supported by specifying multiple --step s, e.g., --step=mem2reg --step=dce"+ } &= help "Test Optimization pass"++phifixup = PhiFixUp { input = def &= typ "<INPUT>"+ , output = outFlags Nothing+ , fuel = H.infiniteFuel &= typ "FUEL" &= help "The fuel used to run the pass"+ } &= help "Test PhiFixUp pass"++mode = cmdArgsMode $ modes [dummy, parser, ast2ir, ir2ast, pass, astcanonic, phifixup] &= help "Test sub components"+ &= program "Test" &= summary "Test driver v1.0"++main :: IO ()+main = do { sel <- cmdArgsRun mode+#ifdef DEBUG+ ; putStr $ show sel+#endif+ ; case sel of+ Parser ix ox sh -> do { inh <- openFile ix ReadMode+ ; m <- testParser ix inh+ ; if sh then+ do { swth <- openFileOrStdout (fmap (\x -> x ++ ".show") ox) + ; writeOutShow m swth+ ; closeFileOrStdout ox swth+ }+ else + do { outh <- openFileOrStdout ox + ; writeOutLlvm m outh+ ; closeFileOrStdout ox outh+ }+ ; hClose inh+ }+ AstCanonic ix ox -> do { inh <- openFile ix ReadMode+ ; outh <- openFileOrStdout ox+ ; ast <- testParser ix inh+ ; let ast' = Cv.simplify ast+ ; writeOutLlvm ast' outh+ ; hClose inh+ ; closeFileOrStdout ox outh+ }++ Ast2Ir ix ox -> do { inh <- openFile ix ReadMode+ ; outh <- openFileOrStdout ox+ ; ast <- testParser ix inh+ ; let ast' = Cv.simplify ast+ ; let (m, ir) = H.runSimpleUniqueMonad ((Cv.astToIr ast')::H.SimpleUniqueMonad (Cv.IdLabelMap, I.Module ()))+ ; writeOutIr ir outh+ ; hClose inh+ ; closeFileOrStdout ox outh+ }+ Ir2Ast ix ox -> do { inh <- openFile ix ReadMode+ ; outh <- openFileOrStdout ox+ ; ast <- testParser ix inh+ ; let ast' = Cv.simplify ast+ ; let (m, ir) = testAst2Ir ast'+ ast'' = testIr2Ast m ir+ ; writeOutLlvm ast'' outh+ ; hClose inh+ ; closeFileOrStdout ox outh+ }+ PhiFixUp ix ox f -> do { inh <- openFile ix ReadMode+ ; outh <- openFileOrStdout ox+ ; ast <- testParser ix inh+ ; let ast1 = Cv.simplify ast+ ; let (m, ir) = testAst2Ir ast1+ ; let ir1 = H.runSimpleUniqueMonad $ H.runWithFuel f + ((O.optModule1 () N.fixUpPhi ir):: H.SimpleFuelMonad (I.Module ()))+ ; let ast2 = testIr2Ast m ir1+ ; writeOutLlvm ast2 outh+ ; hClose inh+ ; closeFileOrStdout ox outh+ }+ Pass ix ox passes f -> do { inh <- openFile ix ReadMode+ ; outh <- openFileOrStdout ox+ ; ast <- testParser ix inh+ ; let ast1 = Cv.simplify ast+ ; let (m, ir) = testAst2Ir ast1+ ; let applySteps' = applySteps (extractSteps passes) ir+ ; let ir1 = H.runSimpleUniqueMonad $ H.runWithFuel f + (applySteps' :: H.SimpleFuelMonad (I.Module ()))+ ; let ir2 = H.runSimpleUniqueMonad $ H.runWithFuel f + ((O.optModule1 () N.fixUpPhi ir1) :: H.SimpleFuelMonad (I.Module ()))+ ; let ast2 = testIr2Ast m ir2+ ; writeOutLlvm ast2 outh+ ; hClose inh+ ; closeFileOrStdout ox outh+ }+ _ -> error $ "unexpected option " ++ show sel+ }+ where+ testAst2Ir e = H.runSimpleUniqueMonad $ Cv.astToIr e+ testIr2Ast m e = Cv.irToAst (Cv.invertMap (Cv.a2h m)) e++++openFileOrStdout :: Maybe FilePath -> IO Handle+openFileOrStdout Nothing = return stdout+openFileOrStdout (Just x) = openFile x WriteMode+++closeFileOrStdout :: Maybe FilePath -> Handle -> IO ()+closeFileOrStdout Nothing h = hFlush h+closeFileOrStdout (Just _) h = hClose h
+ src/ParserTester.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE DeriveDataTypeable #-}+module ParserTester (testParser, writeOutLlvm, writeOutIr, writeOutShow) where+import System.IO+import Llvm.Syntax.Parser.Basic+import Llvm.Syntax.Parser.Module+import Llvm.Data.Ast+import Llvm.Syntax.Printer.LlvmPrint+import Llvm.Syntax.Printer.IrPrint+import Data.List+import Llvm.Data.Conversion++displayError f s = + let sLine = sourceLine $ errorPos s+ in do + { hPutStrLn stderr (hackFile sLine (sourceColumn $ errorPos s) f) + ; hPutStrLn stderr (show (sourceColumn $ errorPos s))+ ; hPutStrLn stderr (show s)+ ; error ""+ }+ where + hackFile :: Int -> Int -> [Char] -> [Char] + hackFile sLine sCol l = let (_,ls) = mapAccumL f (0,0) l+ in ls+ where+ printx lx c x fx fc = if (lx < sLine) then ((fx lx,c), x)+ else if (lx == sLine) then+ if (c < sCol) + then ((lx, c+1), '^')+ else if (c == sCol) + then ((lx, c+1), '\n')+ else ((lx, c), x) + else + ((lx,c), fc x) + f :: (Int,Int)-> Char -> ((Int,Int), Char)+ f (lx,c) '\n' = printx lx c '\n' (+1) id+ f (lx,c) x = printx lx c x id (\_ -> '_')+ ++testParser :: FilePath -> Handle -> IO Module+testParser fileName inh = do { inpStr <- hGetContents inh+ ; case runParser (complete pModule) initState fileName inpStr of+ Left s -> displayError inpStr s+ Right e -> return e+ }+ + +writeOutLlvm :: AsmPrint a => a -> Handle -> IO ()+writeOutLlvm m outh = hPutStr outh (render $ toLlvm m)++writeOutShow :: Show a => a -> Handle -> IO ()+writeOutShow m outh = hPutStr outh (show m)++writeOutIr :: IrPrint a => a -> Handle -> IO ()+writeOutIr m outh = hPutStr outh (render $ printIr m)