diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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] diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple +main = defaultMain + + diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -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 diff --git a/hLLVM.cabal b/hLLVM.cabal new file mode 100644 --- /dev/null +++ b/hLLVM.cabal @@ -0,0 +1,135 @@ +name: hLLVM +version: 0.5.0.0 +license: BSD3 +license-file: LICENSE +author: Ning Wang +maintainer: Ning Wang +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: + } + diff --git a/src/Llvm/Data/Ast.hs b/src/Llvm/Data/Ast.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Data/Ast.hs @@ -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 +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 +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 +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 +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 +data ComplexConstant = Cstruct Packing [TypedConstOrNull] + | Carray [TypedConstOrNull] + | Cvector [TypedConstOrNull] + deriving (Eq,Ord,Show) + +-- | Constants +data Const = C_simple SimpleConstant + | C_complex ComplexConstant + | C_localId LocalId + | C_labelId LabelId + -- | Addresses of Basic Block + | 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 +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 +data TerminatorInst = + -- | + RetVoid + | Return [(Typed Value)] + -- | + | Br TargetLabel + -- | + | Cbr Value TargetLabel TargetLabel + -- | + | Switch (Typed Value) TargetLabel [((Typed Value), TargetLabel)] + -- | + | IndirectBr (Typed Value) [TargetLabel] + -- | + | Invoke (Maybe LocalId) CallSite TargetLabel TargetLabel + -- | + | Unwind + -- | + | Resume (Typed Value) + -- | + | 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 diff --git a/src/Llvm/Data/Conversion.hs b/src/Llvm/Data/Conversion.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Data/Conversion.hs @@ -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) diff --git a/src/Llvm/Data/Conversion/AstIrConversion.hs b/src/Llvm/Data/Conversion/AstIrConversion.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Data/Conversion/AstIrConversion.hs @@ -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) diff --git a/src/Llvm/Data/Conversion/AstScanner.hs b/src/Llvm/Data/Conversion/AstScanner.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Data/Conversion/AstScanner.hs @@ -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 + + + diff --git a/src/Llvm/Data/Conversion/AstSimplification.hs b/src/Llvm/Data/Conversion/AstSimplification.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Data/Conversion/AstSimplification.hs @@ -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) diff --git a/src/Llvm/Data/Conversion/IrAstConversion.hs b/src/Llvm/Data/Conversion/IrAstConversion.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Data/Conversion/IrAstConversion.hs @@ -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 diff --git a/src/Llvm/Data/Conversion/LabelMapM.hs b/src/Llvm/Data/Conversion/LabelMapM.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Data/Conversion/LabelMapM.hs @@ -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) diff --git a/src/Llvm/Data/Conversion/TypeConversion.hs b/src/Llvm/Data/Conversion/TypeConversion.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Data/Conversion/TypeConversion.hs @@ -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 diff --git a/src/Llvm/Data/CoreIr.hs b/src/Llvm/Data/CoreIr.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Data/CoreIr.hs @@ -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) diff --git a/src/Llvm/Data/Ir.hs b/src/Llvm/Data/Ir.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Data/Ir.hs @@ -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 diff --git a/src/Llvm/Data/IrType.hs b/src/Llvm/Data/IrType.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Data/IrType.hs @@ -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 diff --git a/src/Llvm/Data/Shared.hs b/src/Llvm/Data/Shared.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Data/Shared.hs @@ -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 +-} diff --git a/src/Llvm/Data/Shared/AtomicEntity.hs b/src/Llvm/Data/Shared/AtomicEntity.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Data/Shared/AtomicEntity.hs @@ -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 +data Linkage = LinkagePrivate + | LinkageInternal + | LinkageAvailableExternally + | LinkageLinkonce + | LinkageCommon + | LinkageWeak + | LinkageAppending + | LinkageExternWeak + | LinkageLinkonceOdr + | LinkageWeakOdr + | LinkageExternal + deriving (Eq,Ord,Show) + +-- | 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 +data Visibility = VisDefault | VisHidden | VisProtected + deriving (Eq,Ord,Show) + +-- | DLL Storage Classes +data DllStorageClass = DscImport + | DscExport deriving (Eq, Ord, Show) + +-- | Thread Local Storage Models +data ThreadLocalStorage = TlsLocalDynamic + | TlsInitialExec + | TlsLocalExec + | TlsNone + deriving (Eq, Ord, Show) + +-- | 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 +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 +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 +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) diff --git a/src/Llvm/Data/Shared/DataLayout.hs b/src/Llvm/Data/Shared/DataLayout.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Data/Shared/DataLayout.hs @@ -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 diff --git a/src/Llvm/Data/Shared/SimpleConst.hs b/src/Llvm/Data/Shared/SimpleConst.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Data/Shared/SimpleConst.hs @@ -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 +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) diff --git a/src/Llvm/Data/Shared/Util.hs b/src/Llvm/Data/Shared/Util.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Data/Shared/Util.hs @@ -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 diff --git a/src/Llvm/Data/Type.hs b/src/Llvm/Data/Type.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Data/Type.hs @@ -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) diff --git a/src/Llvm/Pass/Dominator.hs b/src/Llvm/Pass/Dominator.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Pass/Dominator.hs @@ -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 + diff --git a/src/Llvm/Pass/Liveness.hs b/src/Llvm/Pass/Liveness.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Pass/Liveness.hs @@ -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 diff --git a/src/Llvm/Pass/Mem2Reg.hs b/src/Llvm/Pass/Mem2Reg.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Pass/Mem2Reg.hs @@ -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 diff --git a/src/Llvm/Pass/NormalGraph.hs b/src/Llvm/Pass/NormalGraph.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Pass/NormalGraph.hs @@ -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' + } diff --git a/src/Llvm/Pass/Optimizer.hs b/src/Llvm/Pass/Optimizer.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Pass/Optimizer.hs @@ -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 diff --git a/src/Llvm/Pass/PassManager.hs b/src/Llvm/Pass/PassManager.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Pass/PassManager.hs @@ -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 diff --git a/src/Llvm/Pass/PassTester.hs b/src/Llvm/Pass/PassTester.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Pass/PassTester.hs @@ -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 +-} diff --git a/src/Llvm/Pass/PhiFixUp.hs b/src/Llvm/Pass/PhiFixUp.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Pass/PhiFixUp.hs @@ -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 + } diff --git a/src/Llvm/Pass/Rewriter.hs b/src/Llvm/Pass/Rewriter.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Pass/Rewriter.hs @@ -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 + + diff --git a/src/Llvm/Pass/Uda.hs b/src/Llvm/Pass/Uda.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Pass/Uda.hs @@ -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 + + + diff --git a/src/Llvm/Query/Conversion.hs b/src/Llvm/Query/Conversion.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Query/Conversion.hs @@ -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 +-} diff --git a/src/Llvm/Query/IrCxt.hs b/src/Llvm/Query/IrCxt.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Query/IrCxt.hs @@ -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 + } + } diff --git a/src/Llvm/Query/Qerror.hs b/src/Llvm/Query/Qerror.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Query/Qerror.hs @@ -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 +-} diff --git a/src/Llvm/Query/TypeConstValue.hs b/src/Llvm/Query/TypeConstValue.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Query/TypeConstValue.hs @@ -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 diff --git a/src/Llvm/Query/TypeDef.hs b/src/Llvm/Query/TypeDef.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Query/TypeDef.hs @@ -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 diff --git a/src/Llvm/Syntax/Parser/Basic.hs b/src/Llvm/Syntax/Parser/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Llvm/Syntax/Parser/Basic.hs @@ -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" + , "<