-- | -- Module : Mu.AST -- Copyright : Author 2011-2012 -- License : BSD3 -- -- Maintainer : email@something.com -- Stability : experimental -- Portability : unknown -- -- Description -- {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NoImplicitPrelude #-} module Mu.AST ( HasName (..) , Name (..) , SignatureName (..) , TypedefName (..) , FunctionName (..) , FunctionVerName (..) , ConstantName (..) , GlobalCellName (..) , BasicBlockName (..) , InstructionName (..) , ExposeName (..) , CookieName (..) , VarName (..) , Version (..) , Bundle (..) , Definition (..) , ConstConstructor (..) , CallConvention (..) , Type (..) , ExceptionClause (..) , WPExceptionClause (..) , KeepAliveClause (..) , DestinationClause (..) , Flag (..) , BinaryOp (..) , CompareOp (..) , ConvertOp (..) , AtomicRMWOp (..) , MemoryOrder (..) , Expression (..) , CurStackClause (..) , NewStackClause (..) , Assigned (..) , BasicBlock (..) , versionedName , dot , (%) , CommInst (..) ) where import Prelude hiding (EQ) import Data.Monoid ((<>)) import Data.Binary (Binary) import Data.ByteString.Char8 (ByteString) import Data.String (IsString, fromString) import GHC.Generics (Generic) import Text.Printf (printf) import Data.List (intersperse, concat, map) import Mu.AST.CommInst -------------------------------------------------- * Named things -- For internal use only, hence the underscore_naming. type Underlying_Name_Type = String -- | A universal class for the various things that newtype off 'Name'. class HasName a where nameOf :: a -> Underlying_Name_Type nameOf = nameOf . toName toName :: a -> Name newtype Name = Name Underlying_Name_Type deriving (IsString, Eq, Ord, Generic) instance Binary Name instance Show Name where show (Name n) = n instance HasName Name where nameOf (Name n) = n toName = id -- A little bit disgusting, but it gives us type safety where previously we had -- none. newtype SignatureName = SignatureName Name deriving (HasName, Eq, Ord, Show, IsString, Generic) newtype TypedefName = TypedefName Name deriving (HasName, Eq, Ord, Show, IsString, Generic) newtype FunctionName = FunctionName Name deriving (HasName, Eq, Ord, Show, IsString, Generic) newtype FunctionVerName = FunctionVerName Name deriving (HasName, Eq, Ord, Show, IsString, Generic) newtype ConstantName = ConstantName Name deriving (HasName, Eq, Ord, Show, IsString, Generic) newtype GlobalCellName = GlobalCellName Name deriving (HasName, Eq, Ord, Show, IsString, Generic) newtype BasicBlockName = BasicBlockName Name deriving (HasName, Eq, Ord, Show, IsString, Generic) newtype InstructionName = InstructionName Name deriving (HasName, Eq, Ord, Show, IsString, Generic) newtype ExposeName = ExposeName Name deriving (HasName, Eq, Ord, Show, IsString, Generic) newtype CookieName = CookieName Name deriving (HasName, Eq, Ord, Show, IsString, Generic) newtype VarName = VarName Name deriving (HasName, Eq, Ord, Show, IsString, Generic) instance Binary SignatureName instance Binary TypedefName instance Binary FunctionName instance Binary FunctionVerName instance Binary ConstantName instance Binary GlobalCellName instance Binary BasicBlockName instance Binary InstructionName instance Binary ExposeName instance Binary CookieName instance Binary VarName newtype Version = Version Underlying_Name_Type deriving (Generic) instance Binary Version instance Show Version where show (Version vn) = vn versionedName :: FunctionName -> Version -> FunctionVerName versionedName fn (Version vn) = FunctionVerName $ Name $ nameOf fn <> "." <> vn -- | Create a new name for a Mu thing inside some other scope. dot :: (HasName a, IsString b) => a -> Underlying_Name_Type -> b dot a sub = fromString $ nameOf a <> "." <> sub -- | Infix version of 'dot'. -- -- Possibly a bad idea to use. (%) :: (HasName a, IsString b) => a -> Underlying_Name_Type -> b (%) = dot -------------------------------------------------- * Intermediate Representation -- $ir -- See -- | A representation of Mu Bundles. newtype Bundle = Bundle { unBundle :: [Definition] } deriving (Monoid, Generic) instance Binary Bundle data Definition = TypeDefinition TypedefName Type | SignatureDefinition SignatureName [TypedefName] [TypedefName] | FunctionDefinition FunctionName Version SignatureName BasicBlock [BasicBlock] | Constant ConstantName TypedefName ConstConstructor | GlobalCell GlobalCellName TypedefName | ExposedFunction ExposeName FunctionName CallConvention CookieName deriving (Generic) instance Binary Definition instance HasName Definition where nameOf defn = case defn of TypeDefinition name _ -> nameOf name SignatureDefinition name _ _ -> nameOf name FunctionDefinition name _ _ _ _ -> nameOf name Constant name _ _ -> nameOf name GlobalCell name _ -> nameOf name ExposedFunction name _ _ _ -> nameOf name toName = Name . nameOf data ConstConstructor = IntCtor Integer | FloatCtor Float | DoubleCtor Double | ListCtor [ConstantName] | NullCtor | ExternCtor ByteString deriving (Generic) instance Binary ConstConstructor -- | Represent the Mu Calling convention data CallConvention = MuCallConvention -- ^ Mu represents the default calling convention, CCall | ForeignCallConvention String -- ^ Extra conventions can be invoked using the foreign Convention deriving (Eq, Show, Generic) instance Binary CallConvention -- | Represent the Mu IR native types. data Type = MuInt { intLen :: Int} -- ^ Integers of variable sizes (1, 8, 16, 32 & 64 bits) | MuFloat -- ^ IEEE single length floating point | MuDouble -- ^ IEEE double length floating point | Ref { refType :: TypedefName} -- ^ A reference to a Mu TypedefName | IRef { irefType :: TypedefName} -- ^ An internal refernce to a Mu TypedefName | WeakRef { weakRefType :: TypedefName} -- ^ A weak refernce to a Mu TypedefName | UPtr { uptrType :: TypedefName} -- ^ A pointer to a Mu TypedefName | Struct { structTypes :: [TypedefName]} -- ^ A struct of multiple Mu Types | Array { arrayType :: TypedefName , arrayLen :: Int} -- ^ An array of a set number of Mu Types | Hybrid { hybridTypes :: [TypedefName] , hybridType :: TypedefName} -- ^ A hybrid with a set 'header' of Mu types, then a variable -- number of A single Mu TypedefName | Void | ThreadRef | StackRef | FrameCursorRef | TagRef64 | Vector { vectorType :: TypedefName , vectorLen :: Int} -- ^ Vector of multiple Mu types | FuncRef { funcRefSig :: SignatureName} -- ^ Function ref to a function signature | UFuncPtr { ufuncPtrSig :: SignatureName} -- ^ Function pointer to a function signature deriving (Eq, Ord, Generic) instance Binary Type -- | Represents an Exception Clause which are appended to certain instructions data ExceptionClause = ExceptionClause { exceptionNor :: DestinationClause -- ^ The destination to go to if normal execution happens , exceptionExc :: DestinationClause -- ^ The exceptional destination } deriving (Eq, Show, Generic) instance Binary ExceptionClause -- | WP Exceptions are used for Watch Points newtype WPExceptionClause = WPExceptionClause { wpExceptionDest :: DestinationClause } deriving (Eq, Show, Generic) instance Binary WPExceptionClause -- | Keep Alive clause used to keep certain variables alive outside their scope newtype KeepAliveClause = KeepAlive { keepAliveVars :: [VarName] } deriving (Eq, Show, Generic) instance Binary KeepAliveClause -- | Destination clause, the call to move to a basic block e.g. %cont(%a) data DestinationClause = DestinationClause { destClauseDestination :: BasicBlockName , destClauseArgList :: [VarName] } deriving (Eq, Show, Generic) instance Binary DestinationClause -- | Flags for Common Instructions and CCall, pp $ Flag "DEFAULT" == "#DEFAULT" newtype Flag = Flag { flagValue :: String } deriving (Generic) instance Binary Flag -- | Binary Ops as defined by the Mu Spec -- | Binary Ops all use the same arguments, so these flags represent precisely which binary operation to display data BinaryOp = Add | Sub | Mul | SDiv | SRem | UDiv | URem | Shl | LShr | AShr | And | Or | Xor | FAdd | FSub | FMul | FDiv | FRem deriving (Eq, Ord, Show, Generic) instance Binary BinaryOp instance Enum BinaryOp where fromEnum op = case op of Add -> 0x01 Sub -> 0x02 Mul -> 0x03 SDiv -> 0x04 SRem -> 0x05 UDiv -> 0x06 URem -> 0x07 Shl -> 0x08 LShr -> 0x09 AShr -> 0x0a And -> 0x0b Or -> 0x0c Xor -> 0x0d FAdd -> 0xb0 FSub -> 0xb1 FMul -> 0xb2 FDiv -> 0xb3 FRem -> 0xb4 toEnum val = case val of 0x01 -> And 0x02 -> Sub 0x03 -> Mul 0x04 -> SDiv 0x05 -> SRem 0x06 -> UDiv 0x07 -> URem 0x08 -> Shl 0x09 -> LShr 0x0a -> AShr 0x0b -> And 0x0c -> Or 0x0d -> Xor 0xb0 -> FAdd 0xb1 -> FSub 0xb2 -> FMul 0xb3 -> FDiv 0xb4 -> FRem _ -> error $ (show val) ++ " is not a valid BinaryOp" -- | Compare Ops as defined by the Mu Spec -- | See Binary Ops for more detail data CompareOp = EQ | NE | SGE | SLE | SGT | SLT | UGE | UGT | ULE | ULT | FFALSE | FTRUE | FOEQ | FOGT | FOGE | FOLT | FOLE | FONE | FORD | FUEQ | FUGT | FUGE | FULT | FULE | FUNE | FUNO deriving (Eq, Ord, Show, Generic) instance Binary CompareOp instance Enum CompareOp where fromEnum op = case op of EQ -> 0x20 NE -> 0x21 SGE -> 0x22 SGT -> 0x23 SLE -> 0x24 SLT -> 0x25 UGE -> 0x26 UGT -> 0x27 ULE -> 0x28 ULT -> 0x29 FFALSE -> 0xC0 FTRUE -> 0xC1 FUNO -> 0xC2 FUEQ -> 0xC3 FUNE -> 0xC4 FUGT -> 0xC5 FUGE -> 0xC6 FULT -> 0xC7 FULE -> 0xC8 FORD -> 0xC9 FOEQ -> 0xCA FONE -> 0xCB FOGT -> 0xCC FOGE -> 0xCD FOLT -> 0xCE FOLE -> 0xCF toEnum val = case val of 0x20 -> EQ 0x21 -> NE 0x22 -> SGE 0x23 -> SGT 0x24 -> SLE 0x25 -> SLT 0x26 -> UGE 0x27 -> UGT 0x28 -> ULE 0x29 -> ULT 0xC0 -> FFALSE 0xC1 -> FTRUE 0xC2 -> FUNO 0xC3 -> FUEQ 0xC4 -> FUNE 0xC5 -> FUGT 0xC6 -> FUGE 0xC7 -> FULT 0xC8 -> FULE 0xC9 -> FORD 0xCA -> FOEQ 0xCB -> FONE 0xCC -> FOGT 0xCD -> FOGE 0xCE -> FOLT 0xCF -> FOLE _ -> error $ (show val) ++ " is not a valid CompareOp" -- | Convert Ops as defined by the Mu Spec -- | See Binary Ops for more detail data ConvertOp = TRUNC | ZEXT | SEXT | FPTRUNC | FPEXT | FPTOUI | FPTOSI | UITOFP | SITOFP | BITCAST | REFCAST | PTRCAST deriving (Eq, Ord, Show, Generic) instance Binary ConvertOp instance Enum ConvertOp where fromEnum op = case op of TRUNC -> 0x30 ZEXT -> 0x31 SEXT -> 0x32 FPTRUNC -> 0x33 FPEXT -> 0x34 FPTOUI -> 0x35 FPTOSI -> 0x36 UITOFP -> 0x37 SITOFP -> 0x38 BITCAST -> 0x39 REFCAST -> 0x3A PTRCAST -> 0x3B toEnum val = case val of 0x30 -> TRUNC 0x31 -> ZEXT 0x32 -> SEXT 0x33 -> FPTRUNC 0x34 -> FPEXT 0x35 -> FPTOUI 0x36 -> FPTOSI 0x37 -> UITOFP 0x38 -> SITOFP 0x39 -> BITCAST 0x3a -> REFCAST 0x3b -> PTRCAST _ -> error $ (show val) ++ " is not a valid ConvertOp" -- | Atomic RMW Ops as defined by the mu spec -- | See Binary Ops for more detail data AtomicRMWOp = XCHG | ADD | SUB | AND | NAND | OR | XOR | MAX | MIN | UMAX | UMIN deriving (Eq, Ord, Enum, Show, Generic) instance Binary AtomicRMWOp -- | Memory Orders ad defined by the Mu Spec data MemoryOrder = NOT_ATOMIC | RELAXED | CONSUME | ACQUIRE | RELEASE | ACQ_REL | SEQ_CST deriving (Eq, Ord, Enum, Show, Generic) instance Binary MemoryOrder -- | Expressions define all the operations which can be performed on Mu Data. This includes terminal instructions. data Expression = BinaryOperation { -- | The operation to be performed (Add, sub ...) binOp :: BinaryOp -- | The type of both parameters (they must be the same type) , binType :: TypedefName -- | The first parameter , binV1 :: VarName -- | The second parameter , binV2 :: VarName -- | The optional exception clause , execClause :: Maybe ExceptionClause} | CompareOperation { -- | The compare operation, {EQ, SLE ... } cmpOp :: CompareOp -- | Type of both operands , cmpType :: TypedefName -- | first parameter , cmpV1 :: VarName -- | second parameter , cmpV2 :: VarName} | ConvertOperation { -- | Operation to be performed {TRUNC, SEXT ...} convOp :: ConvertOp -- | The source type, the type to be converted from , convTypeSrc :: TypedefName -- | The destination type, the type to be converted to , convTypeDest :: TypedefName -- | Variable to be converted , convV :: VarName} | AtomicRMWOperation { -- | Bool indicates if Loc is a pointer aRMWIsPtr :: Bool -- | The memory order for the operation , aRMWMemOrd :: MemoryOrder -- | The operation to be performed , aRMWOp :: AtomicRMWOp -- | The type of loc , aRMWType :: TypedefName -- | The memory location/address to access. , aRMWLoc :: VarName -- | The literal to be used , aRMWOpnd :: VarName -- | The optional Exception clause , aRMWExecClause :: Maybe ExceptionClause} | CmpXchg { -- | Bool indicating if loc is a pointer cmpXchgIsPtr :: Bool -- | Bool indicating if operation is weak , cmpXchgIsWeak :: Bool -- | Memory order for operation success , cmpXchgMemOrdSucc :: MemoryOrder -- | Memory order for operation failure , cmpXchgMemOrdFail :: MemoryOrder -- | The type of the operation. Must be EQ comparable , cmpXchgType :: TypedefName -- | variable of IRef or UPtr. The memory loc/addr to access , cmpXchgLoc :: VarName -- | Strong Variant represents expected value in memory , cmpXchgExpect :: VarName -- | Strong Variant represents Desired value in memory , cmpXchgDesired :: VarName -- | Optional exception clause , cmpXchgExecClause :: Maybe ExceptionClause} | Fence { -- | Memory order for fence operation fenceMemOrd :: MemoryOrder} | New { -- | Type to allocate from heap newType :: TypedefName -- | exception clause if operation fails , newExecClause :: Maybe ExceptionClause} | NewHybrid { -- | Hybrid type to alloate from heap newHybridType :: TypedefName -- | Length of hybrid type (must be int) , newHybridLenType :: TypedefName -- | Length of hybrid , newHybridLen :: VarName -- | Exception clause if operation fails , newHybridExecClause :: Maybe ExceptionClause} | Alloca { -- | Type to allocate allocaType :: TypedefName -- | Exception clause if operation fails , allocaExecClause :: Maybe ExceptionClause} | AllocaHybrid { -- | Hybrid Type to allocate allocaHybridType :: TypedefName -- | Length of hybrid type (must be int) , allocaHybridLenType :: TypedefName -- | Length of hybrid , allocaHybridLen :: VarName -- | Exception clause if operation fails , allocaHybridExecClause :: Maybe ExceptionClause} | Return { -- | Values to return (if any) returnValues :: [VarName]} | Throw { -- | exceptional variable tor throw throwException :: VarName} | Call { -- | Signature of Mu Function to call callSignature :: SignatureName -- | Variable of type funcref<@sig> , callCallee :: VarName -- | Arguments to pass to function , callArgList :: [VarName] -- | optional exception clause , callExceptionClause :: Maybe ExceptionClause -- | Optional keep alive clause , callKeepAliveClause :: Maybe KeepAliveClause} | CCall { -- | Calling convention to follow (Mu or Other) ccallCallConv :: CallConvention -- | type of callee (ufuncptr<@sig>) , ccallType :: TypedefName -- | Signature of callee , ccallSig :: SignatureName -- | address of function to call. (.const @callee = ufuncptr<@sig> 0xdeadbeef) , ccallCallee :: VarName -- | Arguments to pass to function , ccallArgList :: [VarName] -- | optional exception clause , ccallExceptionClause :: Maybe ExceptionClause -- | optional keep alive clause , ccallKeepAliveClause :: Maybe KeepAliveClause} | TailCall { -- | signature of function to call tailCallSignature :: SignatureName -- | function to call , tailCallCallee :: VarName -- | arguments to pass , tailCallArgList :: [VarName]} | Branch1 { -- | BasicBlock to branch to branch1Destination :: DestinationClause} | Branch2 { -- | Variable of type int<1>, condition on which to branch branch2Cond :: VarName -- | Branch if condition is true , branch2BranchTrue :: DestinationClause -- | Branch if condition is false , branch2BranchFalse :: DestinationClause} | WatchPoint { -- | name of watchpoint watchpointname :: VarName -- | id of watchpoint , watchpointId :: Int -- | The types of the return values , watchpointTypes :: [TypedefName] -- | destination before watchpoint is enabled , watchpointdis :: DestinationClause -- | destination after watchpoint is enabled , watchpointena :: DestinationClause -- | optional exception clause for after watchpoint is enabled , watchpointWpExec :: Maybe WPExceptionClause -- | optional keep alive clause for after watchpoint is enabled , watchpointKeepAlive :: Maybe KeepAliveClause} | Trap { -- | name of trap trapName :: VarName -- | the types of the values to return , trapTypes :: [TypedefName] -- | optional exception clause , trapExceptionClause :: Maybe ExceptionClause -- | optinoal keep alive clause , trapKeepAlive :: Maybe KeepAliveClause} | WPBranch { -- | watchpoint id wpBranchId :: Int -- | destination to jump to if watchpoint is enabled , wpBranchDis :: DestinationClause -- | destination to jump to if watchpoint is disabled , wpBranchEna :: DestinationClause} | Switch { -- | type of value to switch on switchType :: TypedefName -- | value to switch on , switchOpnd :: VarName -- | default destination (if all others fail) , switchDefault :: DestinationClause -- | list of (condition, destination) pairs , switchBlocks :: [(VarName, DestinationClause)]} | SwapStack { -- | variable of type stackref (stack to swap to) swapStackSwapee :: VarName -- | cur stack clause to use , swapStackCurStackClause :: CurStackClause -- | new stack clause to use , swapStackNewStackClause :: NewStackClause -- | optional exception clause , swapStackExecClause :: Maybe ExceptionClause -- | optional keep alive clause , swapStackKeepAliveClause :: Maybe KeepAliveClause} | NewThread { -- | variable of type stackref (stack to bind thread to) newThreadStack :: VarName -- | new stack clause to use , newThreadStackClause :: NewStackClause -- | optional exception clause to use , newThreadExceptionClause :: Maybe ExceptionClause} | Comminst { -- | operation code of the common instruction comminstInst :: CommInst -- | optional flags to pass , comminstFlags :: [Flag] -- | types (if any) of the arguments to pass to comminst , comminstTypes :: [TypedefName] -- | signatures (if any) to pass to the comminst , comminstSigs :: [SignatureName] -- | arguments (if any) to pass to the comminst , comminstArgs :: [VarName] -- | optional exception clause , comminstExecClause :: Maybe ExceptionClause -- | optional keep alive clause , comminstKeepAliveClause :: Maybe KeepAliveClause} | Load { -- | Bool indicating if Loc is a poiner loadIsPtr :: Bool -- | Optional Memory order (default NOT_ATOMIC) , loadMemOrd :: Maybe MemoryOrder -- | The referant type of loc , loadType :: TypedefName -- | Variable of type IRef or UPtr (the mem location to load from) , loadLoc :: VarName -- | Exception clause if operation fails , loadExecClause :: Maybe ExceptionClause} | Store { -- | Bool indicating if loc is a pointer storeIsPtr :: Bool -- | Memory order for operation , storeMemOrd :: Maybe MemoryOrder -- | Type of loc , storeType :: TypedefName -- | variable of IRef or UPtr. Mem loc/addr to store into , storeLoc :: VarName -- | The new value to store , storeNewVal :: VarName -- | Optional exception clause , storeExecClause :: Maybe ExceptionClause} | ExtractValue { structExtractType :: TypedefName , structExtractIndex :: Int , structExtractStruct :: VarName} | InsertValue { structInsertType :: TypedefName , structInsertIndex :: Int , structInsertStruct :: VarName , structInsertNewVal :: VarName} | ExtractElement { arrExtractType :: TypedefName , arrExtractIndexType :: TypedefName , arrExtractOpnd :: VarName , arrExtractIndex :: VarName} | InsertElement { arrInsertType :: TypedefName , arrInsertIndexType :: TypedefName , arrInsertOpnd :: VarName , arrInsertIndex :: VarName , arrInsertNewVal :: VarName} | ShuffleVector { arrShuffleVType :: TypedefName , arrShuffleMaskType :: TypedefName , arrShuffleV1 :: VarName , arrShuffleV2 :: VarName , arrShuffleMask :: VarName} | GetIRef { getIRefType :: TypedefName , getIRefOpnd :: VarName} | GetFieldIRef { getFieldIRefPtr :: Bool , getFieldIRefTypeOpnd :: TypedefName , getFieldIRefIndex :: Int , getFieldIRefOpnd :: VarName} | GetElemIRef { getElemIRefPtr :: Bool , getElemIRefTypeOpnd :: TypedefName , getElemIRefTypeIndex :: TypedefName , getElemIRefOpnd :: VarName , getElemIRefIndex :: VarName} | ShiftIRef { shiftIRefPtr :: Bool , shiftIRefTypeOpnd :: TypedefName , shiftIRefTypeIndex :: TypedefName , shiftIRefOpnd :: VarName , shiftIRefOffset :: VarName} | GetVarPartIRef { getVarPartIRefPtr :: Bool , getVarPartIRefTypeOpnd :: TypedefName , getVarPartIRefOpnd :: VarName} deriving (Generic) instance Binary Expression data CurStackClause = RetWith { retWithTypes :: [TypedefName]} | KillOld deriving (Generic) instance Binary CurStackClause data NewStackClause = PassValues { newStackTypes :: [TypedefName] , newStackValues :: [VarName]} | ThrowExc { throwExecExceptionClause :: VarName} deriving (Generic) instance Binary NewStackClause data Assigned a = (:=) { assignVarss :: [VarName] , assignExpr :: a } deriving (Generic) instance Binary a => Binary (Assigned a) data BasicBlock = BasicBlock { basicBlockName :: BasicBlockName , basicBlockParams :: [(VarName, TypedefName)] , basicBlockExcParam :: Maybe VarName , basicBlockInstructions :: [Assigned Expression] , basicBlockTerminst :: Expression } deriving (Generic) instance Binary BasicBlock