├── .github └── workflows │ └── haskell.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── examples ├── .gitignore ├── Factorial.hs ├── Makefile └── test.c ├── llvm-pretty.cabal ├── src └── Text │ ├── LLVM.hs │ └── LLVM │ ├── AST.hs │ ├── DebugUtils.hs │ ├── Labels.hs │ ├── Labels │ └── TH.hs │ ├── Lens.hs │ ├── PP.hs │ ├── Parser.hs │ ├── Triple.hs │ ├── Triple │ ├── AST.hs │ ├── Parse.hs │ ├── Parse │ │ ├── ARM.hs │ │ └── LookupTable.hs │ └── Print.hs │ └── Util.hs └── test ├── Main.hs ├── Output.hs ├── TQQDefs.hs └── Triple.hs /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: 4 | push: 5 | branches: [ master ] 6 | pull_request: 7 | branches: [ master ] 8 | 9 | jobs: 10 | build: 11 | strategy: 12 | matrix: 13 | os: ["ubuntu-24.04"] 14 | ghc: ["9.6.7", "9.8.4", "9.10.1"] 15 | cabal: ["3.14.2.0"] 16 | fail-fast: false 17 | name: ${{ matrix.os }} - GHC ${{ matrix.ghc }} - Cabal ${{ matrix.cabal }} 18 | uses: GaloisInc/.github/.github/workflows/haskell-ci.yml@v1 19 | with: 20 | cabal: ${{ matrix.cabal }} 21 | ghc: ${{ matrix.ghc }} 22 | os: ${{ matrix.os }} 23 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | .cabal-sandbox/ 3 | cabal.sandbox.config 4 | .stack-work/ 5 | .ghc.environment.* 6 | /dist-newstyle 7 | .boring 8 | _darcs/ 9 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for llvm-pretty 2 | 3 | ## pending 4 | 5 | * Add a `FunctionPointerAlign` constructor to `LayoutSpec`. 6 | 7 | ## 0.13.0.0 (March 2025) 8 | 9 | * Changed some of the signatures of helper functions in the AST to make them more 10 | flexible by using `Type' ident` rather than `Type` in their signatures (the 11 | latter fixes `ident` to be `Ident`). Changed functions: `isAlias`, 12 | `isPrimTypeOf`, `isVector`, `isVectorOf`, `isArray`, and `isPointer`. 13 | 14 | ## 0.12.1.0 (August 2024) 15 | 16 | * Fix for printing NaN and infinite floating point values. 17 | 18 | * Add support for more AtomicRWOps. 19 | 20 | ## 0.12.0.0 (January 2024) 21 | 22 | * Add preliminary support for LLVM versions up through 17. 23 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2010, Trevor Elliott 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Trevor Elliott nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # `llvm-pretty` 2 | 3 | A pretty printing library that was inspired by the LLVM binding by Lennart 4 | Augustsson. The library provides a monadic interface to a pretty printer, that 5 | allows functions to be defined and called, generating the corresponding LLVM 6 | assembly when run. 7 | 8 | ## LLVM language feature support 9 | 10 | Currently, `llvm-pretty` supports LLVM versions up through 17. As a result of 11 | the broad version coverage, the `llvm-pretty` AST is a superset of all versions 12 | of the LLVM AST. This means that the manner in which certain information is 13 | presented in the `llvm-pretty` AST (e.g., during pretty printing) will be 14 | different depending on the LLVM version used to originate the information. 15 | Conversely, it is possible to construct an `llvm-pretty` AST that cannot be 16 | represented in a specific (or any) LLVM version. 17 | 18 | `llvm-pretty` strives to support a reasonable variety of [LLVM language 19 | features](https://llvm.org/docs/LangRef.html), but there are places where our 20 | coverage of the LLVM language is incomplete. If you need a LLVM feature that is 21 | not currently supported by `llvm-pretty`, please [file an 22 | issue](https://github.com/GaloisInc/llvm-pretty/issues/new). 23 | 24 | ## `llvm-pretty` versus `llvm-pretty-bc-parser` 25 | 26 | `llvm-pretty` supports almost everything that one would want to do with LLVM 27 | ASTs. One notable exception is parsing: `llvm-pretty` deliberately does not 28 | support parsing an LLVM module AST from a bitcode file. This functionality is 29 | factored out into a separate 30 | [`llvm-pretty-bc-parser`](https://github.com/GaloisInc/llvm-pretty-bc-parser) 31 | library. `llvm-pretty-bc-parser` generally tries to stay in sync with all of 32 | the LLVM language features that `llvm-pretty` supports, but it may be the case 33 | that some valid `llvm-pretty` ASTs cannot be parsed by `llvm-pretty-bc-parser`. 34 | If you encounter an occurrence of this issue, please [file an 35 | issue](https://github.com/GaloisInc/llvm-pretty-bc-parser/issues/new) at the 36 | `llvm-pretty-bc-parser` issue tracker. 37 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.ll 3 | *.bc 4 | -------------------------------------------------------------------------------- /examples/Factorial.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE DoRec #-} 3 | 4 | module Factorial where 5 | 6 | import Text.LLVM 7 | import Text.LLVM.AST 8 | 9 | factorial :: Module 10 | factorial = snd $ runLLVM $ do 11 | define emptyFunAttrs (iT 32) "factorial" (iT 32) $ \ x -> do 12 | "entry" 13 | jump "test" 14 | 15 | rec "test" 16 | i <- phi (iT 32) [x `from` "entry", i' `from` "incr"] 17 | acc <- phi (iT 32) [int 1 `from` "entry", acc' `from` "incr"] 18 | 19 | b <- icmp Iule i (int 1) 20 | br b "exit" "incr" 21 | 22 | "incr" 23 | acc' <- mul acc i 24 | i' <- sub i (int 1) 25 | jump "test" 26 | 27 | "exit" 28 | ret acc 29 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | 2 | GHC = ghc 3 | 4 | all: 5 | 6 | %.bc: %.ll 7 | llvm-as -o $@ $< 8 | 9 | %.s: %.bc 10 | llc -o $@ $< 11 | 12 | all: factorial 13 | factorial: factorial.o test.o 14 | $(CC) -o $@ $^ 15 | 16 | factorial.ll: Factorial.hs 17 | $(GHC) -i../src Factorial.hs -e "ppModule factorial" > $@ 18 | 19 | clean: clean-factorial 20 | clean-factorial: 21 | $(RM) factorial factorial.ll factorial.o test.o 22 | 23 | -------------------------------------------------------------------------------- /examples/test.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | extern int factorial(int); 4 | 5 | int main() { 6 | printf("factorial(%d) = %d\n", 5, factorial(5)); 7 | 8 | return 0; 9 | } 10 | -------------------------------------------------------------------------------- /llvm-pretty.cabal: -------------------------------------------------------------------------------- 1 | Cabal-version: 2.2 2 | Name: llvm-pretty 3 | Version: 0.13.0.0.99 4 | License: BSD-3-Clause 5 | License-file: LICENSE 6 | Author: Trevor Elliott 7 | Maintainer: rscott@galois.com, kquick@galois.com 8 | Category: Text 9 | Build-type: Simple 10 | Synopsis: A pretty printing library inspired by the llvm binding. 11 | Description: 12 | A pretty printing library that was inspired by the LLVM binding by Lennart 13 | Augustsson. The library provides a monadic interface to a pretty printer, 14 | that allows functions to be defined and called, generating the corresponding 15 | LLVM assembly when run. 16 | tested-with: GHC==9.10.1, GHC==9.8.4, GHC==9.6.6 17 | extra-doc-files: CHANGELOG.md, README.md 18 | 19 | 20 | source-repository head 21 | type: git 22 | location: http://github.com/GaloisInc/llvm-pretty 23 | 24 | common common 25 | Default-language: Haskell2010 26 | Ghc-options: 27 | -Wall 28 | 29 | Library 30 | Import: common 31 | 32 | Hs-source-dirs: src 33 | Exposed-modules: Text.LLVM 34 | Text.LLVM.AST 35 | Text.LLVM.Labels 36 | Text.LLVM.Labels.TH 37 | Text.LLVM.Lens 38 | Text.LLVM.Parser 39 | Text.LLVM.PP 40 | Text.LLVM.DebugUtils 41 | Text.LLVM.Triple 42 | Text.LLVM.Triple.AST 43 | Text.LLVM.Triple.Parse 44 | Text.LLVM.Triple.Print 45 | Other-modules: Text.LLVM.Triple.Parse.ARM 46 | Text.LLVM.Triple.Parse.LookupTable 47 | Text.LLVM.Util 48 | 49 | Build-depends: base >= 4.11 && < 5, 50 | containers >= 0.4, 51 | parsec >= 3, 52 | pretty >= 1.0.1, 53 | monadLib >= 3.6.1, 54 | microlens >= 0.4, 55 | microlens-th >= 0.4, 56 | syb >= 0.7, 57 | template-haskell >= 2.7, 58 | th-abstraction >= 0.3.1 && <0.8 59 | 60 | Test-suite llvm-pretty-test 61 | Import: common 62 | Type: exitcode-stdio-1.0 63 | Main-is: Main.hs 64 | Other-modules: 65 | Output 66 | Triple 67 | TQQDefs 68 | Hs-source-dirs: test 69 | Ghc-options: 70 | -threaded 71 | Build-depends: 72 | llvm-pretty, 73 | base, 74 | pretty, 75 | tasty, 76 | tasty-hunit, 77 | template-haskell, 78 | text 79 | -------------------------------------------------------------------------------- /src/Text/LLVM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE RecursiveDo #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FunctionalDependencies #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE TypeSynonymInstances #-} 9 | module Text.LLVM ( 10 | -- * LLVM Monad 11 | LLVM() 12 | , runLLVM 13 | , emitTypeDecl 14 | , emitGlobal 15 | , emitDeclare 16 | , emitDefine 17 | 18 | -- * Alias Introduction 19 | , alias 20 | 21 | -- * Function Definition 22 | , freshSymbol 23 | , (:>)(..) 24 | , define, defineFresh, DefineArgs() 25 | , define' 26 | , declare 27 | , global 28 | , FunAttrs(..), emptyFunAttrs 29 | -- * Types 30 | , iT, ptrT, voidT, arrayT 31 | , (=:), (-:) 32 | 33 | -- * Values 34 | , IsValue(..) 35 | , int 36 | , integer 37 | , struct 38 | , array 39 | , string 40 | 41 | -- * Basic Blocks 42 | , BB() 43 | , freshLabel 44 | , label 45 | , comment 46 | , assign 47 | 48 | -- * Terminator Instructions 49 | , ret 50 | , retVoid 51 | , jump 52 | , br 53 | , unreachable 54 | , unwind 55 | 56 | -- * Binary Operations 57 | , add, fadd 58 | , sub, fsub 59 | , mul, fmul 60 | , udiv, sdiv, fdiv 61 | , urem, srem, frem 62 | 63 | -- * Bitwise Binary Operations 64 | , shl 65 | , lshr, ashr 66 | , band, bor, bxor 67 | 68 | -- * Conversion Operations 69 | , trunc 70 | , zext 71 | , sext 72 | , fptrunc 73 | , fpext 74 | , fptoui, fptosi 75 | , uitofp, sitofp 76 | , ptrtoint, inttoptr 77 | , bitcast 78 | 79 | -- * Aggregate Operations 80 | , extractValue 81 | , insertValue 82 | 83 | -- * Memory Access and Addressing Operations 84 | , alloca 85 | , load 86 | , store 87 | , getelementptr 88 | , nullPtr 89 | 90 | -- * Other Operations 91 | , icmp 92 | , fcmp 93 | , phi, PhiArg, from 94 | , select 95 | , call, call_ 96 | , invoke 97 | , switch 98 | , shuffleVector 99 | 100 | -- * Re-exported 101 | , module Text.LLVM.AST 102 | ) where 103 | 104 | import Text.LLVM.AST 105 | 106 | import Control.Monad.Fix (MonadFix) 107 | import Data.Char (ord) 108 | import Data.Int (Int8,Int16,Int32,Int64) 109 | import Data.Word (Word32, Word64) 110 | import Data.Maybe (maybeToList) 111 | import Data.String (IsString(..)) 112 | import MonadLib hiding (jump,Label) 113 | import qualified Data.Foldable as F 114 | import qualified Data.Sequence as Seq 115 | import qualified Data.Map.Strict as Map 116 | 117 | 118 | -- Fresh Names ----------------------------------------------------------------- 119 | 120 | type Names = Map.Map String Int 121 | 122 | -- | Avoid generating the provided name. When the name already exists, return 123 | -- Nothing. 124 | avoid :: String -> Names -> Maybe Names 125 | avoid name ns = 126 | case Map.lookup name ns of 127 | Nothing -> Just (Map.insert name 0 ns) 128 | Just _ -> Nothing 129 | 130 | nextName :: String -> Names -> (String,Names) 131 | nextName pfx ns = 132 | case Map.lookup pfx ns of 133 | Nothing -> (fmt (0 :: Int), Map.insert pfx 1 ns) 134 | Just ix -> (fmt ix, Map.insert pfx (ix+1) ns) 135 | where 136 | fmt i = showString pfx (shows i "") 137 | 138 | 139 | -- LLVM Monad ------------------------------------------------------------------ 140 | 141 | newtype LLVM a = LLVM 142 | { unLLVM :: WriterT Module (StateT Names Id) a 143 | } deriving (Functor,Applicative,Monad,MonadFix) 144 | 145 | freshNameLLVM :: String -> LLVM String 146 | freshNameLLVM pfx = LLVM $ do 147 | ns <- get 148 | let (n,ns') = nextName pfx ns 149 | set ns' 150 | return n 151 | 152 | runLLVM :: LLVM a -> (a,Module) 153 | runLLVM = fst . runId . runStateT Map.empty . runWriterT . unLLVM 154 | 155 | emitTypeDecl :: TypeDecl -> LLVM () 156 | emitTypeDecl td = LLVM (put emptyModule { modTypes = [td] }) 157 | 158 | emitGlobal :: Global -> LLVM (Typed Value) 159 | emitGlobal g = 160 | do LLVM (put emptyModule { modGlobals = [g] }) 161 | return (ptrT (globalType g) -: globalSym g) 162 | 163 | emitDefine :: Define -> LLVM (Typed Value) 164 | emitDefine d = 165 | do LLVM (put emptyModule { modDefines = [d] }) 166 | return (defFunType d -: defName d) 167 | 168 | emitDeclare :: Declare -> LLVM (Typed Value) 169 | emitDeclare d = 170 | do LLVM (put emptyModule { modDeclares = [d] }) 171 | return (decFunType d -: decName d) 172 | 173 | alias :: Ident -> Type -> LLVM () 174 | alias i ty = emitTypeDecl (TypeDecl i ty) 175 | 176 | freshSymbol :: LLVM Symbol 177 | freshSymbol = Symbol `fmap` freshNameLLVM "f" 178 | 179 | -- | Emit a declaration. 180 | declare :: Type -> Symbol -> [Type] -> Bool -> LLVM (Typed Value) 181 | declare rty sym tys va = emitDeclare Declare 182 | { decLinkage = Nothing 183 | , decVisibility = Nothing 184 | , decRetType = rty 185 | , decName = sym 186 | , decArgs = tys 187 | , decVarArgs = va 188 | , decAttrs = [] 189 | , decComdat = Nothing 190 | } 191 | 192 | -- | Emit a global declaration. 193 | global :: GlobalAttrs -> Symbol -> Type -> Maybe Value -> LLVM (Typed Value) 194 | global attrs sym ty mbVal = emitGlobal Global 195 | { globalSym = sym 196 | , globalType = ty 197 | , globalValue = toValue `fmap` mbVal 198 | , globalAttrs = attrs 199 | , globalAlign = Nothing 200 | , globalMetadata = Map.empty 201 | } 202 | 203 | -- | Output a somewhat clunky representation for a string global, that deals 204 | -- well with escaping in the haskell-source string. 205 | string :: Symbol -> String -> LLVM (Typed Value) 206 | string sym str = 207 | global emptyGlobalAttrs { gaConstant = True } sym (typedType val) 208 | (Just (typedValue val)) 209 | where 210 | bytes = [ int (fromIntegral (ord c)) | c <- str ] 211 | val = array (iT 8) bytes 212 | 213 | 214 | -- Function Definition --------------------------------------------------------- 215 | 216 | data FunAttrs = FunAttrs 217 | { funLinkage :: Maybe Linkage 218 | , funVisibility :: Maybe Visibility 219 | , funGC :: Maybe GC 220 | } deriving (Show) 221 | 222 | emptyFunAttrs :: FunAttrs 223 | emptyFunAttrs = FunAttrs 224 | { funLinkage = Nothing 225 | , funVisibility = Nothing 226 | , funGC = Nothing 227 | } 228 | 229 | 230 | -- XXX Do not export 231 | freshArg :: Type -> LLVM (Typed Ident) 232 | freshArg ty = (Typed ty . Ident) `fmap` freshNameLLVM "a" 233 | 234 | infixr 0 :> 235 | data a :> b = a :> b 236 | deriving Show 237 | 238 | -- | Types that can be used to define the body of a function. 239 | class DefineArgs a k | a -> k where 240 | defineBody :: [Typed Ident] -> a -> k -> LLVM ([Typed Ident], [BasicBlock]) 241 | 242 | instance DefineArgs () (BB ()) where 243 | defineBody tys () body = return $ runBB $ do 244 | body 245 | return (reverse tys) 246 | 247 | instance DefineArgs as k => DefineArgs (Type :> as) (Typed Value -> k) where 248 | defineBody args (ty :> as) f = do 249 | arg <- freshArg ty 250 | defineBody (arg:args) as (f (toValue `fmap` arg)) 251 | 252 | -- helper instances for DefineArgs 253 | 254 | instance DefineArgs Type (Typed Value -> BB ()) where 255 | defineBody tys ty body = defineBody tys (ty :> ()) body 256 | 257 | instance DefineArgs (Type,Type) (Typed Value -> Typed Value -> BB ()) where 258 | defineBody tys (a,b) body = defineBody tys (a :> b :> ()) body 259 | 260 | instance DefineArgs (Type,Type,Type) 261 | (Typed Value -> Typed Value -> Typed Value -> BB ()) where 262 | defineBody tys (a,b,c) body = defineBody tys (a :> b :> c :> ()) body 263 | 264 | -- | Define a function. 265 | define :: DefineArgs sig k => FunAttrs -> Type -> Symbol -> sig -> k 266 | -> LLVM (Typed Value) 267 | define attrs rty fun sig k = do 268 | (args,body) <- defineBody [] sig k 269 | emitDefine Define 270 | { defLinkage = funLinkage attrs 271 | , defVisibility = funVisibility attrs 272 | , defName = fun 273 | , defRetType = rty 274 | , defArgs = args 275 | , defVarArgs = False 276 | , defAttrs = [] 277 | , defSection = Nothing 278 | , defGC = funGC attrs 279 | , defBody = body 280 | , defMetadata = Map.empty 281 | , defComdat = Nothing 282 | } 283 | 284 | -- | A combination of define and @freshSymbol@. 285 | defineFresh :: DefineArgs sig k => FunAttrs -> Type -> sig -> k 286 | -> LLVM (Typed Value) 287 | defineFresh attrs rty args body = do 288 | sym <- freshSymbol 289 | define attrs rty sym args body 290 | 291 | -- | Function definition when the argument list isn't statically known. This is 292 | -- useful when generating code. 293 | define' :: FunAttrs -> Type -> Symbol -> [Type] -> Bool 294 | -> ([Typed Value] -> BB ()) 295 | -> LLVM (Typed Value) 296 | define' attrs rty sym sig va k = do 297 | args <- mapM freshArg sig 298 | emitDefine Define 299 | { defLinkage = funLinkage attrs 300 | , defVisibility = funVisibility attrs 301 | , defName = sym 302 | , defRetType = rty 303 | , defArgs = args 304 | , defVarArgs = va 305 | , defAttrs = [] 306 | , defSection = Nothing 307 | , defGC = funGC attrs 308 | , defBody = snd (runBB (k (map (fmap toValue) args))) 309 | , defMetadata = Map.empty 310 | , defComdat = Nothing 311 | } 312 | 313 | -- Basic Block Monad ----------------------------------------------------------- 314 | 315 | newtype BB a = BB 316 | { unBB :: WriterT [BasicBlock] (StateT RW Id) a 317 | } deriving (Functor,Applicative,Monad,MonadFix) 318 | 319 | avoidName :: String -> BB () 320 | avoidName name = BB $ do 321 | rw <- get 322 | case avoid name (rwNames rw) of 323 | Just ns' -> set rw { rwNames = ns' } 324 | Nothing -> error ("avoidName: " ++ name ++ " already registered") 325 | 326 | freshNameBB :: String -> BB String 327 | freshNameBB pfx = BB $ do 328 | rw <- get 329 | let (n,ns') = nextName pfx (rwNames rw) 330 | set rw { rwNames = ns' } 331 | return n 332 | 333 | runBB :: BB a -> (a,[BasicBlock]) 334 | runBB m = 335 | case runId (runStateT emptyRW (runWriterT (unBB body))) of 336 | ((a,bbs),_rw) -> (a,bbs) 337 | where 338 | -- make sure that the last block is terminated 339 | body = do 340 | res <- m 341 | terminateBasicBlock 342 | return res 343 | 344 | data RW = RW 345 | { rwNames :: Names 346 | , rwLabel :: Maybe BlockLabel 347 | , rwStmts :: Seq.Seq Stmt 348 | } deriving Show 349 | 350 | emptyRW :: RW 351 | emptyRW = RW 352 | { rwNames = Map.empty 353 | , rwLabel = Nothing 354 | , rwStmts = Seq.empty 355 | } 356 | 357 | rwBasicBlock :: RW -> (RW,Maybe BasicBlock) 358 | rwBasicBlock rw 359 | | Seq.null (rwStmts rw) = (rw,Nothing) 360 | | otherwise = 361 | let rw' = rw { rwLabel = Nothing, rwStmts = Seq.empty } 362 | bb = BasicBlock (rwLabel rw) (F.toList (rwStmts rw)) 363 | in (rw',Just bb) 364 | 365 | emitStmt :: Stmt -> BB () 366 | emitStmt stmt = do 367 | BB $ do 368 | rw <- get 369 | set $! rw { rwStmts = rwStmts rw Seq.|> stmt } 370 | when (isTerminator (stmtInstr stmt)) terminateBasicBlock 371 | 372 | effect :: Instr -> BB () 373 | effect i = emitStmt (Effect i []) 374 | 375 | observe :: Type -> Instr -> BB (Typed Value) 376 | observe ty i = do 377 | name <- freshNameBB "r" 378 | let res = Ident name 379 | emitStmt (Result res i []) 380 | return (Typed ty (ValIdent res)) 381 | 382 | 383 | -- Basic Blocks ---------------------------------------------------------------- 384 | 385 | freshLabel :: BB Ident 386 | freshLabel = Ident `fmap` freshNameBB "L" 387 | 388 | -- | Force termination of the current basic block, and start a new one with the 389 | -- given label. If the previous block had no instructions defined, it will just 390 | -- be thrown away. 391 | label :: Ident -> BB () 392 | label l = do 393 | terminateBasicBlock 394 | BB $ do 395 | rw <- get 396 | set $! rw { rwLabel = Just (Named l) } 397 | 398 | instance IsString (BB a) where 399 | fromString l = do 400 | label (fromString l) 401 | return (error ("Label ``" ++ l ++ "'' has no value")) 402 | 403 | terminateBasicBlock :: BB () 404 | terminateBasicBlock = BB $ do 405 | rw <- get 406 | let (rw',bb) = rwBasicBlock rw 407 | put (maybeToList bb) 408 | set rw' 409 | 410 | 411 | -- Type Helpers ---------------------------------------------------------------- 412 | 413 | iT :: Word32 -> Type 414 | iT = PrimType . Integer 415 | 416 | ptrT :: Type -> Type 417 | ptrT = PtrTo 418 | 419 | voidT :: Type 420 | voidT = PrimType Void 421 | 422 | arrayT :: Word64 -> Type -> Type 423 | arrayT = Array 424 | 425 | 426 | -- Value Helpers --------------------------------------------------------------- 427 | 428 | class IsValue a where 429 | toValue :: a -> Value 430 | 431 | instance IsValue Value where 432 | toValue = id 433 | 434 | instance IsValue a => IsValue (Typed a) where 435 | toValue = toValue . typedValue 436 | 437 | instance IsValue Bool where 438 | toValue = ValBool 439 | 440 | instance IsValue Integer where 441 | toValue = ValInteger 442 | 443 | instance IsValue Int where 444 | toValue = ValInteger . toInteger 445 | 446 | instance IsValue Int8 where 447 | toValue = ValInteger . toInteger 448 | 449 | instance IsValue Int16 where 450 | toValue = ValInteger . toInteger 451 | 452 | instance IsValue Int32 where 453 | toValue = ValInteger . toInteger 454 | 455 | instance IsValue Int64 where 456 | toValue = ValInteger . toInteger 457 | 458 | instance IsValue Float where 459 | toValue = ValFloat 460 | 461 | instance IsValue Double where 462 | toValue = ValDouble 463 | 464 | instance IsValue Ident where 465 | toValue = ValIdent 466 | 467 | instance IsValue Symbol where 468 | toValue = ValSymbol 469 | 470 | (-:) :: IsValue a => Type -> a -> Typed Value 471 | ty -: a = ty =: toValue a 472 | 473 | (=:) :: Type -> a -> Typed a 474 | ty =: a = Typed 475 | { typedType = ty 476 | , typedValue = a 477 | } 478 | 479 | int :: Int -> Value 480 | int = toValue 481 | 482 | integer :: Integer -> Value 483 | integer = toValue 484 | 485 | struct :: Bool -> [Typed Value] -> Typed Value 486 | struct packed tvs 487 | | packed = PackedStruct (map typedType tvs) =: ValPackedStruct tvs 488 | | otherwise = Struct (map typedType tvs) =: ValStruct tvs 489 | 490 | array :: Type -> [Value] -> Typed Value 491 | array ty vs = Typed (Array (fromIntegral (length vs)) ty) (ValArray ty vs) 492 | 493 | 494 | -- Instructions ---------------------------------------------------------------- 495 | 496 | comment :: String -> BB () 497 | comment str = effect (Comment str) 498 | 499 | -- | Emit an assignment that uses the given identifier to name the result of the 500 | -- BB operation. 501 | -- 502 | -- WARNING: this can throw errors. 503 | assign :: IsValue a => Ident -> BB (Typed a) -> BB (Typed Value) 504 | assign r@(Ident name) body = do 505 | avoidName name 506 | tv <- body 507 | rw <- BB get 508 | case Seq.viewr (rwStmts rw) of 509 | 510 | stmts Seq.:> Result _ i m -> 511 | do BB (set rw { rwStmts = stmts Seq.|> Result r i m }) 512 | return (const (ValIdent r) `fmap` tv) 513 | 514 | _ -> error "assign: invalid argument" 515 | 516 | -- | Emit the ``ret'' instruction and terminate the current basic block. 517 | ret :: IsValue a => Typed a -> BB () 518 | ret tv = effect (Ret (toValue `fmap` tv)) 519 | 520 | -- | Emit ``ret void'' and terminate the current basic block. 521 | retVoid :: BB () 522 | retVoid = effect RetVoid 523 | 524 | jump :: Ident -> BB () 525 | jump l = effect (Jump (Named l)) 526 | 527 | br :: IsValue a => Typed a -> Ident -> Ident -> BB () 528 | br c t f = effect (Br (toValue `fmap` c) (Named t) (Named f)) 529 | 530 | unreachable :: BB () 531 | unreachable = effect Unreachable 532 | 533 | unwind :: BB () 534 | unwind = effect Unwind 535 | 536 | binop :: (IsValue a, IsValue b) 537 | => (Typed Value -> Value -> Instr) -> Typed a -> b -> BB (Typed Value) 538 | binop k l r = observe (typedType l) (k (toValue `fmap` l) (toValue r)) 539 | 540 | add :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value) 541 | add = binop (Arith (Add False False)) 542 | 543 | fadd :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value) 544 | fadd = binop (Arith FAdd) 545 | 546 | sub :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value) 547 | sub = binop (Arith (Sub False False)) 548 | 549 | fsub :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value) 550 | fsub = binop (Arith FSub) 551 | 552 | mul :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value) 553 | mul = binop (Arith (Mul False False)) 554 | 555 | fmul :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value) 556 | fmul = binop (Arith FMul) 557 | 558 | udiv :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value) 559 | udiv = binop (Arith (UDiv False)) 560 | 561 | sdiv :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value) 562 | sdiv = binop (Arith (SDiv False)) 563 | 564 | fdiv :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value) 565 | fdiv = binop (Arith FDiv) 566 | 567 | urem :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value) 568 | urem = binop (Arith URem) 569 | 570 | srem :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value) 571 | srem = binop (Arith SRem) 572 | 573 | frem :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value) 574 | frem = binop (Arith FRem) 575 | 576 | shl :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value) 577 | shl = binop (Bit (Shl False False)) 578 | 579 | lshr :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value) 580 | lshr = binop (Bit (Lshr False)) 581 | 582 | ashr :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value) 583 | ashr = binop (Bit (Ashr False)) 584 | 585 | band :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value) 586 | band = binop (Bit And) 587 | 588 | bor :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value) 589 | bor = binop (Bit Or) 590 | 591 | bxor :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value) 592 | bxor = binop (Bit Xor) 593 | 594 | -- | Returns the value stored in the member field of an aggregate value. 595 | extractValue :: IsValue a => Typed a -> Int32 -> BB (Typed Value) 596 | extractValue ta i = 597 | let etp = case typedType ta of 598 | Struct fl -> fl !! fromIntegral i 599 | Array _l etp' -> etp' 600 | _ -> error "extractValue not given a struct or array." 601 | in observe etp (ExtractValue (toValue `fmap` ta) [i]) 602 | 603 | -- | Inserts a value into the member field of an aggregate value, and returns 604 | -- the new value. 605 | insertValue :: (IsValue a, IsValue b) 606 | => Typed a -> Typed b -> Int32 -> BB (Typed Value) 607 | insertValue ta tv i = 608 | observe (typedType ta) 609 | (InsertValue (toValue `fmap` ta) (toValue `fmap` tv) [i]) 610 | 611 | shuffleVector :: (IsValue a, IsValue b, IsValue c) 612 | => Typed a -> b -> c -> BB (Typed Value) 613 | shuffleVector vec1 vec2 mask = 614 | case typedType vec1 of 615 | Vector n _ -> observe (typedType vec1) 616 | $ ShuffleVector (toValue `fmap` vec1) (toValue vec2) 617 | $ Typed (Vector n (PrimType (Integer 32))) (toValue mask) 618 | _ -> error "shuffleVector not given a vector" 619 | 620 | alloca :: Type -> Maybe (Typed Value) -> Maybe Int -> BB (Typed Value) 621 | alloca ty mb align = observe (PtrTo ty) (Alloca ty es align) 622 | where 623 | es = fmap toValue `fmap` mb 624 | 625 | load :: IsValue a => Type -> Typed a -> Maybe Align -> BB (Typed Value) 626 | load ty ptr ma = observe ty (Load ty (toValue `fmap` ptr) Nothing ma) 627 | 628 | store :: (IsValue a, IsValue b) => a -> Typed b -> Maybe Align -> BB () 629 | store a ptr ma = 630 | case typedType ptr of 631 | PtrTo ty -> effect (Store (ty -: a) (toValue `fmap` ptr) Nothing ma) 632 | _ -> error "store not given a pointer" 633 | 634 | nullPtr :: Type -> Typed Value 635 | nullPtr ty = ptrT ty =: ValNull 636 | 637 | convop :: IsValue a 638 | => (Typed Value -> Type -> Instr) -> Typed a -> Type -> BB (Typed Value) 639 | convop k a ty = observe ty (k (toValue `fmap` a) ty) 640 | 641 | trunc :: IsValue a => Typed a -> Type -> BB (Typed Value) 642 | trunc = convop (Conv Trunc) 643 | 644 | zext :: IsValue a => Typed a -> Type -> BB (Typed Value) 645 | zext = convop (Conv ZExt) 646 | 647 | sext :: IsValue a => Typed a -> Type -> BB (Typed Value) 648 | sext = convop (Conv SExt) 649 | 650 | fptrunc :: IsValue a => Typed a -> Type -> BB (Typed Value) 651 | fptrunc = convop (Conv FpTrunc) 652 | 653 | fpext :: IsValue a => Typed a -> Type -> BB (Typed Value) 654 | fpext = convop (Conv FpExt) 655 | 656 | fptoui :: IsValue a => Typed a -> Type -> BB (Typed Value) 657 | fptoui = convop (Conv FpToUi) 658 | 659 | fptosi :: IsValue a => Typed a -> Type -> BB (Typed Value) 660 | fptosi = convop (Conv FpToSi) 661 | 662 | uitofp :: IsValue a => Typed a -> Type -> BB (Typed Value) 663 | uitofp = convop (Conv UiToFp) 664 | 665 | sitofp :: IsValue a => Typed a -> Type -> BB (Typed Value) 666 | sitofp = convop (Conv SiToFp) 667 | 668 | ptrtoint :: IsValue a => Typed a -> Type -> BB (Typed Value) 669 | ptrtoint = convop (Conv PtrToInt) 670 | 671 | inttoptr :: IsValue a => Typed a -> Type -> BB (Typed Value) 672 | inttoptr = convop (Conv IntToPtr) 673 | 674 | bitcast :: IsValue a => Typed a -> Type -> BB (Typed Value) 675 | bitcast = convop (Conv BitCast) 676 | 677 | icmp :: (IsValue a, IsValue b) => ICmpOp -> Typed a -> b -> BB (Typed Value) 678 | icmp op l r = observe (iT 1) (ICmp op (toValue `fmap` l) (toValue r)) 679 | 680 | fcmp :: (IsValue a, IsValue b) => FCmpOp -> Typed a -> b -> BB (Typed Value) 681 | fcmp op l r = observe (iT 1) (FCmp op (toValue `fmap` l) (toValue r)) 682 | 683 | data PhiArg = PhiArg Value BlockLabel 684 | 685 | from :: IsValue a => a -> BlockLabel -> PhiArg 686 | from a = PhiArg (toValue a) 687 | 688 | phi :: Type -> [PhiArg] -> BB (Typed Value) 689 | phi ty vs = observe ty (Phi ty [ (v,l) | PhiArg v l <- vs ]) 690 | 691 | select :: (IsValue a, IsValue b, IsValue c) 692 | => Typed a -> Typed b -> Typed c -> BB (Typed Value) 693 | select c t f = observe (typedType t) 694 | $ Select (toValue `fmap` c) (toValue `fmap` t) (toValue f) 695 | 696 | getelementptr :: IsValue a 697 | => Type -> Typed a -> [Typed Value] -> BB (Typed Value) 698 | getelementptr ty ptr ixs = observe ty (GEP False ty (toValue `fmap` ptr) ixs) 699 | 700 | -- | Emit a call instruction, and generate a new variable for its result. 701 | call :: IsValue a => Typed a -> [Typed Value] -> BB (Typed Value) 702 | call sym vs = case typedType sym of 703 | PtrTo ty@(FunTy rty _ _) -> observe rty (Call False ty (toValue sym) vs) 704 | _ -> error "invalid function type given to call" 705 | 706 | -- | Emit a call instruction, but don't generate a new variable for its result. 707 | call_ :: IsValue a => Typed a -> [Typed Value] -> BB () 708 | call_ sym vs = effect (Call False (typedType sym) (toValue sym) vs) 709 | 710 | -- | Emit an invoke instruction, and generate a new variable for its result. 711 | invoke :: IsValue a => 712 | Type -> a -> [Typed Value] -> Ident -> Ident -> BB (Typed Value) 713 | invoke rty sym vs to uw = observe rty 714 | $ Invoke rty (toValue sym) vs (Named to) (Named uw) 715 | 716 | -- | Emit a call instruction, but don't generate a new variable for its result. 717 | switch :: IsValue a => Typed a -> Ident -> [(Integer, Ident)] -> BB () 718 | switch idx def dests = effect (Switch (toValue `fmap` idx) (Named def) 719 | (map (\(n, l) -> (n, Named l)) dests)) 720 | -------------------------------------------------------------------------------- /src/Text/LLVM/DebugUtils.hs: -------------------------------------------------------------------------------- 1 | {-# Language TransformListComp, MonadComprehensions #-} 2 | {- | 3 | Module : Text.LLVM.DebugUtils 4 | Description : This module interprets the DWARF information associated 5 | with a function's argument and return types in order to 6 | interpret field name references. 7 | License : BSD3 8 | Stability : provisional 9 | Maintainer : emertens@galois.com 10 | -} 11 | module Text.LLVM.DebugUtils 12 | ( -- * Definition type analyzer 13 | Info(..), StructFieldInfo(..), BitfieldInfo(..), UnionFieldInfo(..) 14 | , computeFunctionTypes, valMdToInfo 15 | , localVariableNameDeclarations 16 | 17 | -- * Metadata lookup 18 | , mkMdMap 19 | 20 | -- * Type structure dereference 21 | , derefInfo 22 | , fieldIndexByPosition 23 | , fieldIndexByName 24 | 25 | -- * Info hueristics 26 | , guessAliasInfo 27 | , guessTypeInfo 28 | 29 | -- * Function arguments 30 | , debugInfoArgNames 31 | 32 | -- * Line numbers of definitions 33 | , debugInfoGlobalLines 34 | , debugInfoDefineLines 35 | ) where 36 | 37 | import Control.Applicative ((<|>)) 38 | import Control.Monad ((<=<)) 39 | import Data.Bits (Bits(..)) 40 | import Data.IntMap (IntMap) 41 | import qualified Data.IntMap as IntMap 42 | import Data.List (elemIndex, tails, stripPrefix) 43 | import Data.Map (Map) 44 | import qualified Data.Map as Map 45 | import Data.Maybe (fromMaybe, listToMaybe, maybeToList, mapMaybe) 46 | import Data.Word (Word16, Word64) 47 | import Text.LLVM.AST 48 | 49 | dbgKind :: String 50 | dbgKind = "dbg" 51 | 52 | llvmDbgCuKey :: String 53 | llvmDbgCuKey = "llvm.dbg.cu" 54 | 55 | dwarfPointer, dwarfStruct, dwarfTypedef, dwarfUnion, dwarfBasetype, 56 | dwarfConst, dwarfArray :: Word16 57 | dwarfPointer = 0x0f 58 | dwarfStruct = 0x13 59 | dwarfTypedef = 0x16 60 | dwarfArray = 0x01 61 | dwarfUnion = 0x17 62 | dwarfBasetype = 0x24 63 | dwarfConst = 0x26 64 | 65 | type MdMap = IntMap ValMd 66 | 67 | data Info 68 | = Pointer Info 69 | | Structure (Maybe String) [StructFieldInfo] 70 | | Union (Maybe String) [UnionFieldInfo] 71 | | Typedef String Info 72 | | ArrInfo Info 73 | | BaseType String DIBasicType 74 | | Unknown 75 | deriving Show 76 | 77 | -- | Record debug information about a field in a struct type. 78 | data StructFieldInfo = StructFieldInfo 79 | { sfiName :: String 80 | -- ^ The field name. 81 | , sfiOffset :: Word64 82 | -- ^ The field's offset (in bits) from the start of the struct. 83 | , sfiBitfield :: Maybe BitfieldInfo 84 | -- ^ If this field resides within a bitfield, this is 85 | -- @'Just' bitfieldInfo@. Otherwise, this is 'Nothing'. 86 | , sfiInfo :: Info 87 | -- ^ The debug 'Info' associated with the field's type. 88 | } deriving Show 89 | 90 | -- | Record debug information about a field within a bitfield. For example, 91 | -- the following C struct: 92 | -- 93 | -- @ 94 | -- struct s { 95 | -- int32_t w; 96 | -- uint8_t x1:1; 97 | -- uint8_t x2:2; 98 | -- uint8_t y:1; 99 | -- int32_t z; 100 | -- }; 101 | -- @ 102 | -- 103 | -- Corresponds to the following 'Info': 104 | -- 105 | -- @ 106 | -- 'Structure' 107 | -- [ 'StructFieldInfo' { 'sfiName' = \"w\" 108 | -- , 'sfiOffset' = 0 109 | -- , 'sfiBitfield' = Nothing 110 | -- , 'sfiInfo' = 'BaseType' \"int32_t\" 111 | -- } 112 | -- , 'StructFieldInfo' { 'sfiName' = \"x1\" 113 | -- , 'sfiOffset' = 32 114 | -- , 'sfiBitfield' = Just ('BitfieldInfo' { 'biFieldSize' = 1 115 | -- , 'biBitfieldOffset' = 32 116 | -- }) 117 | -- , 'sfiInfo' = 'BaseType' \"uint8_t\" 118 | -- } 119 | -- , 'StructFieldInfo' { 'sfiName' = \"x2\" 120 | -- , 'sfiOffset' = 33 121 | -- , 'sfiBitfield' = Just ('BitfieldInfo' { 'biFieldSize' = 2 122 | -- , 'biBitfieldOffset' = 32 123 | -- }) 124 | -- , 'sfiInfo' = BaseType \"uint8_t\" 125 | -- } 126 | -- , 'StructFieldInfo' { 'sfiName' = \"y\" 127 | -- , 'sfiOffset' = 35 128 | -- , 'sfiBitfield' = Just ('BitfieldInfo' { 'biFieldSize' = 1 129 | -- , 'biBitfieldOffset' = 32 130 | -- }) 131 | -- , 'sfiInfo' = 'BaseType' \"uint8_t\" 132 | -- } 133 | -- , 'StructFieldInfo' { 'sfiName' = \"z\" 134 | -- , 'sfiOffset' = 64 135 | -- , 'sfiBitfield' = Nothing 136 | -- , 'sfiInfo' = BaseType \"int32_t\" 137 | -- } 138 | -- ] 139 | -- @ 140 | -- 141 | -- Notice that only @x1@, @x2@, and @y@ have 'BitfieldInfo's, as they are the 142 | -- only fields that were declared with bitfield syntax. 143 | data BitfieldInfo = BitfieldInfo 144 | { biFieldSize :: Word64 145 | -- ^ The field's size (in bits) within the bitfield. This should not be 146 | -- confused with the size of the field's declared type. For example, the 147 | -- 'biFieldSize' of the @x1@ field is @1@, despite the fact that its 148 | -- declared type, @uint8_t@, is otherwise 8 bits in size. 149 | , biBitfieldOffset :: Word64 150 | -- ^ The bitfield's offset (in bits) from the start of the struct. Note 151 | -- that for a given field within a bitfield, its 'sfiOffset' is equal to 152 | -- the 'biBitfieldOffset' plus the 'biFieldSize'. 153 | } deriving Show 154 | 155 | -- | Record debug information about a field in a union type. 156 | data UnionFieldInfo = UnionFieldInfo 157 | { ufiName :: String 158 | -- ^ The field name. 159 | , ufiInfo :: Info 160 | -- ^ The debug 'Info' associated with the field's type. 161 | } deriving Show 162 | 163 | -- | Compute an 'IntMap' of the unnamed metadata in a module 164 | mkMdMap :: Module -> IntMap ValMd 165 | mkMdMap m = IntMap.fromList [ (umIndex md, umValues md) | md <- modUnnamedMd m ] 166 | 167 | ------------------------------------------------------------------------ 168 | 169 | getDebugInfo :: MdMap -> ValMd -> Maybe DebugInfo 170 | getDebugInfo mdMap (ValMdRef i) = getDebugInfo mdMap =<< IntMap.lookup i mdMap 171 | getDebugInfo _ (ValMdDebugInfo di) = Just di 172 | getDebugInfo _ _ = Nothing 173 | 174 | getInteger :: MdMap -> ValMd -> Maybe Integer 175 | getInteger mdMap (ValMdRef i) = getInteger mdMap =<< IntMap.lookup i mdMap 176 | getInteger _ (ValMdValue (Typed _ (ValInteger i))) = Just i 177 | getInteger _ _ = Nothing 178 | 179 | getList :: MdMap -> ValMd -> Maybe [Maybe ValMd] 180 | getList mdMap (ValMdRef i) = getList mdMap =<< IntMap.lookup i mdMap 181 | getList _ (ValMdNode di) = Just di 182 | getList _ _ = Nothing 183 | 184 | ------------------------------------------------------------------------ 185 | 186 | valMdToInfo :: MdMap -> ValMd -> Info 187 | valMdToInfo mdMap val = 188 | maybe Unknown (debugInfoToInfo mdMap) (getDebugInfo mdMap val) 189 | 190 | 191 | valMdToInfo' :: MdMap -> Maybe ValMd -> Info 192 | valMdToInfo' = maybe Unknown . valMdToInfo 193 | 194 | 195 | debugInfoToInfo :: MdMap -> DebugInfo -> Info 196 | debugInfoToInfo mdMap (DebugInfoDerivedType dt) 197 | | didtTag dt == dwarfPointer = Pointer (valMdToInfo' mdMap (didtBaseType dt)) 198 | | didtTag dt == dwarfTypedef = case didtName dt of 199 | Nothing -> valMdToInfo' mdMap (didtBaseType dt) 200 | Just nm -> Typedef nm (valMdToInfo' mdMap (didtBaseType dt)) 201 | | didtTag dt == dwarfConst = valMdToInfo' mdMap (didtBaseType dt) 202 | debugInfoToInfo _ (DebugInfoBasicType bt) 203 | | dibtTag bt == dwarfBasetype = BaseType (dibtName bt) bt 204 | debugInfoToInfo mdMap (DebugInfoCompositeType ct) 205 | | dictTag ct == dwarfStruct = maybe Unknown (Structure (dictName ct)) (getStructFields mdMap ct) 206 | | dictTag ct == dwarfUnion = maybe Unknown (Union (dictName ct)) (getUnionFields mdMap ct) 207 | | dictTag ct == dwarfArray = ArrInfo (valMdToInfo' mdMap (dictBaseType ct)) 208 | debugInfoToInfo _ _ = Unknown 209 | 210 | 211 | getFieldDIs :: MdMap -> DICompositeType -> Maybe [DebugInfo] 212 | getFieldDIs mdMap = 213 | traverse (getDebugInfo mdMap) <=< sequence <=< getList mdMap <=< dictElements 214 | 215 | getStructFields :: MdMap -> DICompositeType -> Maybe [StructFieldInfo] 216 | getStructFields mdMap = traverse (debugInfoToStructField mdMap) <=< getFieldDIs mdMap 217 | 218 | debugInfoToStructField :: MdMap -> DebugInfo -> Maybe StructFieldInfo 219 | debugInfoToStructField mdMap di = 220 | do DebugInfoDerivedType dt <- Just di 221 | fieldName <- didtName dt 222 | -- We check if a struct field resides within a bitfield by checking its 223 | -- `flags` field sets `BitField`, which has a numeric value of 19. 224 | -- (https://github.com/llvm/llvm-project/blob/1bebc31c617d1a0773f1d561f02dd17c5e83b23b/llvm/include/llvm/IR/DebugInfoFlags.def#L51) 225 | -- 226 | -- If so, the `size` field records the size in bits, and the `extraData` 227 | -- field records the offset of the overall bitfield from the start of the 228 | -- struct. 229 | -- (https://github.com/llvm/llvm-project/blob/ee7652569854af567ba83e5255d70e80cc8619a1/llvm/lib/CodeGen/AsmPrinter/CodeViewDebug.cpp#L2489-L2508) 230 | let bitfield | testBit (didtFlags dt) 19 231 | , Just extraData <- didtExtraData dt 232 | , Just bitfieldOffset <- getInteger mdMap extraData 233 | = Just $ BitfieldInfo { biFieldSize = didtSize dt 234 | , biBitfieldOffset = fromInteger bitfieldOffset 235 | } 236 | | otherwise 237 | = Nothing 238 | Just (StructFieldInfo { sfiName = fieldName 239 | , sfiOffset = didtOffset dt 240 | , sfiBitfield = bitfield 241 | , sfiInfo = valMdToInfo' mdMap (didtBaseType dt) 242 | }) 243 | 244 | 245 | getUnionFields :: MdMap -> DICompositeType -> Maybe [UnionFieldInfo] 246 | getUnionFields mdMap = traverse (debugInfoToUnionField mdMap) <=< getFieldDIs mdMap 247 | 248 | 249 | debugInfoToUnionField :: MdMap -> DebugInfo -> Maybe UnionFieldInfo 250 | debugInfoToUnionField mdMap di = 251 | do DebugInfoDerivedType dt <- Just di 252 | fieldName <- didtName dt 253 | Just (UnionFieldInfo { ufiName = fieldName 254 | , ufiInfo = valMdToInfo' mdMap (didtBaseType dt) 255 | }) 256 | 257 | 258 | 259 | -- | Compute the structures of a function's return and argument types 260 | -- using DWARF information metadata of the LLVM module. Different 261 | -- versions of LLVM make this information available via different 262 | -- paths. This function attempts to support the variations. 263 | computeFunctionTypes :: 264 | Module {- ^ module to search -} -> 265 | Symbol {- ^ function symbol -} -> 266 | Maybe [Maybe Info] {- ^ return and argument type information -} 267 | computeFunctionTypes m sym = 268 | [ fmap (valMdToInfo mdMap) <$> types 269 | | let mdMap = mkMdMap m 270 | , sp <- findSubprogramViaDefine mdMap m sym 271 | <|> findSubprogramViaCu mdMap m sym 272 | , DebugInfoSubroutineType st <- getDebugInfo mdMap =<< dispType sp 273 | , types <- getList mdMap =<< distTypeArray st 274 | ] 275 | 276 | 277 | -- | This method of computing argument type information works on at least LLVM 3.8 278 | findSubprogramViaDefine :: 279 | IntMap ValMd {- ^ unnamed metadata -} -> 280 | Module {- ^ module to search -} -> 281 | Symbol {- ^ function symbol to find -} -> 282 | Maybe DISubprogram {- ^ debug information related to function symbol -} 283 | findSubprogramViaDefine mdMap m sym = 284 | [ sp 285 | | def <- modDefines m 286 | , defName def == sym 287 | , then listToMaybe ----- commits to a choice ----- 288 | , dbgMd <- Map.lookup dbgKind (defMetadata def) 289 | , DebugInfoSubprogram sp <- getDebugInfo mdMap dbgMd 290 | ] 291 | 292 | 293 | -- | This method of computing function debugging information works on LLVM 3.7 294 | findSubprogramViaCu :: 295 | MdMap {- ^ map of unnamed metadata -} -> 296 | Module {- ^ module to search -} -> 297 | Symbol {- ^ function symbol to search for -} -> 298 | Maybe DISubprogram {- ^ debugging information for given symbol -} 299 | findSubprogramViaCu mdMap m (Symbol sym) = listToMaybe 300 | [ sp 301 | | md <- modNamedMd m 302 | , nmName md == llvmDbgCuKey 303 | , ref <- nmValues md 304 | , DebugInfoCompileUnit cu <- maybeToList $ getDebugInfo mdMap $ ValMdRef ref 305 | , Just entry <- fromMaybe [] $ getList mdMap =<< dicuSubprograms cu 306 | , DebugInfoSubprogram sp <- maybeToList $ getDebugInfo mdMap entry 307 | , dispName sp == Just sym 308 | ] 309 | 310 | 311 | ------------------------------------------------------------------------ 312 | 313 | -- | If the argument describes a pointer, return the information for the 314 | -- type that it points do. If the argument describes an array, return 315 | -- information about the element type. 316 | derefInfo :: 317 | Info {- ^ pointer type information -} -> 318 | Info {- ^ type information of pointer's base type -} 319 | derefInfo (Pointer x) = x 320 | derefInfo (ArrInfo x) = x 321 | derefInfo _ = Unknown 322 | 323 | -- | If the argument describes a composite type, returns the type of the 324 | -- field by zero-based index into the list of fields. 325 | fieldIndexByPosition :: 326 | Int {- ^ zero-based field index -} -> 327 | Info {- ^ composite type information -} -> 328 | Info {- ^ type information for specified field -} 329 | fieldIndexByPosition i info = 330 | case info of 331 | Typedef _ info' -> fieldIndexByPosition i info' 332 | Structure _ xs -> go [ x | StructFieldInfo{sfiInfo = x} <- xs ] 333 | Union _ xs -> go [ x | UnionFieldInfo{ufiInfo = x} <- xs ] 334 | _ -> Unknown 335 | where 336 | go xs = case drop i xs of 337 | [] -> Unknown 338 | x:_ -> x 339 | 340 | -- | If the argument describes a composite type, return the first, zero-based 341 | -- index of the field in that type that matches the given name. 342 | fieldIndexByName :: 343 | String {- ^ field name -} -> 344 | Info {- ^ composite type info -} -> 345 | Maybe Int {- ^ zero-based index of field matching the name -} 346 | fieldIndexByName n info = 347 | case info of 348 | Typedef _ info' -> fieldIndexByName n info' 349 | Structure _ xs -> go [ x | StructFieldInfo{sfiName = x} <- xs ] 350 | Union _ xs -> go [ x | UnionFieldInfo{ufiName = x} <- xs ] 351 | _ -> Nothing 352 | where 353 | go = elemIndex n 354 | 355 | ------------------------------------------------------------------------ 356 | 357 | localVariableNameDeclarations :: 358 | IntMap ValMd {- ^ unnamed metadata -} -> 359 | Define {- ^ function definition -} -> 360 | Map Ident Ident {- ^ raw name, actual name -} 361 | localVariableNameDeclarations mdMap def = 362 | case defBody def of 363 | blk1 : _ -> foldr aux Map.empty (tails (bbStmts blk1)) 364 | _ -> Map.empty 365 | where 366 | 367 | aux :: [Stmt] -> Map Ident Ident -> Map Ident Ident 368 | aux ( Effect (Store src dst _ _) _ 369 | : Effect (Call _ _ (ValSymbol (Symbol what)) [var,md,_]) _ 370 | : _) sofar 371 | | what == "llvm.dbg.declare" 372 | , Just dstIdent <- extractIdent dst 373 | , Just srcIdent <- extractIdent src 374 | , Just varIdent <- extractIdent var 375 | , dstIdent == varIdent 376 | , Just name <- extractLvName md 377 | = Map.insert name srcIdent sofar 378 | 379 | aux ( Effect (Call _ _ (ValSymbol (Symbol what)) [var,_,md,_]) _ 380 | : _) sofar 381 | | what == "llvm.dbg.value" 382 | , Just key <- extractIdent var 383 | , Just name <- extractLvName md 384 | = Map.insert name key sofar 385 | 386 | aux _ sofar = sofar 387 | 388 | extractIdent :: Typed Value -> Maybe Ident 389 | extractIdent (Typed _ (ValIdent i)) = Just i 390 | extractIdent _ = Nothing 391 | 392 | extractLvName :: Typed Value -> Maybe Ident 393 | extractLvName mdArg = 394 | do ValMd md <- Just (typedValue mdArg) 395 | DebugInfoLocalVariable dilv <- getDebugInfo mdMap md 396 | Ident <$> dilvName dilv 397 | 398 | ------------------------------------------------------------------------ 399 | 400 | -- | Search the metadata for debug info corresponding 401 | -- to a given type alias. This is considered a heuristic 402 | -- because there's no direct mapping between type aliases 403 | -- and debug info. The debug information must be search 404 | -- for a textual match. 405 | -- 406 | -- Compared to @guessTypeInfo@, this function first tries 407 | -- to strip the \"struct.\" and \"union.\" prefixes that are 408 | -- commonly added by clang before searching for the type information. 409 | guessAliasInfo :: 410 | IntMap ValMd {- ^ unnamed metadata -} -> 411 | Ident {- ^ alias -} -> 412 | Info 413 | guessAliasInfo mdMap (Ident name) 414 | | Just pfx <- stripPrefix "struct." name = guessTypeInfo mdMap pfx 415 | | Just pfx <- stripPrefix "union." name = guessTypeInfo mdMap pfx 416 | | otherwise = guessTypeInfo mdMap name 417 | 418 | -- | Search the metadata for debug info corresponding 419 | -- to a given type alias. This is considered a heuristic 420 | -- because there's no direct mapping between type aliases 421 | -- and debug info. The debug information must be search 422 | -- for a textual match. 423 | guessTypeInfo :: 424 | IntMap ValMd {- ^ unnamed metadata -} -> 425 | String {- ^ struct alias -} -> 426 | Info 427 | guessTypeInfo mdMap name = 428 | case mapMaybe (go <=< getDebugInfo mdMap) (IntMap.elems mdMap) of 429 | [] -> Unknown 430 | x:_ -> x 431 | 432 | where 433 | go di | DebugInfoDerivedType didt <- di 434 | , Just name == didtName didt 435 | = Just (debugInfoToInfo mdMap di) 436 | 437 | go di | DebugInfoCompositeType dict <- di 438 | , Just name == dictName dict 439 | = Just (debugInfoToInfo mdMap di) 440 | 441 | go _ = Nothing 442 | 443 | ------------------------------------------------------------------------ 444 | 445 | -- | Find source-level names of function arguments 446 | debugInfoArgNames :: Module -> Define -> IntMap String 447 | debugInfoArgNames m d = 448 | case Map.lookup dbgKind $ defMetadata d of 449 | Just (ValMdRef s) -> scopeArgs s 450 | _ -> IntMap.empty 451 | where 452 | scopeArgs :: Int -> IntMap String 453 | scopeArgs s = IntMap.fromList . mapMaybe go $ modUnnamedMd m 454 | where 455 | go :: UnnamedMd -> Maybe (Int, String) 456 | go 457 | ( UnnamedMd 458 | { umValues = 459 | ValMdDebugInfo 460 | ( DebugInfoLocalVariable 461 | DILocalVariable 462 | { dilvScope = Just (ValMdRef s'), 463 | dilvArg = a, 464 | dilvName = Just n 465 | } 466 | ) 467 | }) = 468 | if s == s' 469 | then Just (fromIntegral a - 1, n) 470 | else Nothing 471 | go _ = Nothing 472 | 473 | ------------------------------------------------------------------------ 474 | 475 | -- | Map global variable names to the line on which the global is defined 476 | debugInfoGlobalLines :: Module -> Map String Int 477 | debugInfoGlobalLines = Map.fromList . mapMaybe go . modUnnamedMd 478 | where 479 | go :: UnnamedMd -> Maybe (String, Int) 480 | go (UnnamedMd 481 | { umValues = ValMdDebugInfo 482 | (DebugInfoGlobalVariable DIGlobalVariable 483 | { digvName = Just n 484 | , digvLine = l 485 | } 486 | ) 487 | }) = Just (n, (fromIntegral l)) 488 | go _ = Nothing 489 | 490 | -- | Map function names to the line on which the function is defined 491 | debugInfoDefineLines :: Module -> Map String Int 492 | debugInfoDefineLines = Map.fromList . mapMaybe go . modUnnamedMd 493 | where 494 | go :: UnnamedMd -> Maybe (String, Int) 495 | go (UnnamedMd 496 | { umValues = ValMdDebugInfo 497 | (DebugInfoSubprogram DISubprogram 498 | { dispName = Just n 499 | , dispIsDefinition = True 500 | , dispLine = l 501 | } 502 | ) 503 | }) = Just (n, (fromIntegral l)) 504 | go _ = Nothing 505 | -------------------------------------------------------------------------------- /src/Text/LLVM/Labels.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE EmptyCase, TypeOperators, FlexibleContexts #-} 3 | module Text.LLVM.Labels where 4 | 5 | import Text.LLVM.AST 6 | import Text.LLVM.Labels.TH 7 | 8 | class Functor f => HasLabel f where 9 | -- | Given a function for resolving labels, where the presence of a symbol 10 | -- denotes a label in a different function, rename all labels in a function. 11 | relabel :: Applicative m => (Maybe Symbol -> a -> m b) -> f a -> m (f b) 12 | 13 | instance HasLabel Instr' where 14 | relabel _ RetVoid = pure RetVoid 15 | relabel _ Unreachable = pure Unreachable 16 | relabel _ Unwind = pure Unwind 17 | relabel _ (Comment str) = pure (Comment str) 18 | relabel f (Ret tv) = Ret <$> traverse (relabel f) tv 19 | relabel f (Arith op l r) = Arith op 20 | <$> traverse (relabel f) l 21 | <*> relabel f r 22 | relabel f (UnaryArith op a) = UnaryArith op 23 | <$> traverse (relabel f) a 24 | relabel f (Bit op l r) = Bit op 25 | <$> traverse (relabel f) l 26 | <*> relabel f r 27 | relabel f (Conv op l r) = Conv op <$> traverse (relabel f) l <*> pure r 28 | relabel f (Call t r n as) = Call t r 29 | <$> relabel f n 30 | <*> traverse (traverse (relabel f)) as 31 | relabel f (CallBr r n as u es) = CallBr r 32 | <$> relabel f n 33 | <*> traverse (traverse (relabel f)) as 34 | <*> f Nothing u 35 | <*> traverse (f Nothing) es 36 | relabel f (Alloca t n a) = Alloca t 37 | <$> traverse (traverse (relabel f)) n 38 | <*> pure a 39 | relabel f (Load t a mo ma) = Load t 40 | <$> traverse (relabel f) a 41 | <*> pure mo 42 | <*> pure ma 43 | relabel f (Store d v mo ma) = Store 44 | <$> traverse (relabel f) d 45 | <*> traverse (relabel f) v 46 | <*> pure mo 47 | <*> pure ma 48 | relabel _ (Fence s o) = pure (Fence s o) 49 | relabel f (CmpXchg w v p a n s o o') 50 | = CmpXchg w v 51 | <$> traverse (relabel f) p 52 | <*> traverse (relabel f) a 53 | <*> traverse (relabel f) n 54 | <*> pure s 55 | <*> pure o 56 | <*> pure o' 57 | relabel f (AtomicRW v op p a s o) 58 | = AtomicRW v op 59 | <$> traverse (relabel f) p 60 | <*> traverse (relabel f) a 61 | <*> pure s 62 | <*> pure o 63 | relabel f (ICmp op l r) = ICmp op 64 | <$> traverse (relabel f) l 65 | <*> relabel f r 66 | relabel f (FCmp op l r) = FCmp op 67 | <$> traverse (relabel f) l 68 | <*> relabel f r 69 | relabel f (GEP ib t a is) = GEP ib t 70 | <$> traverse (relabel f) a 71 | <*> traverse (traverse (relabel f)) is 72 | relabel f (Select c l r) = Select 73 | <$> traverse (relabel f) c 74 | <*> traverse (relabel f) l <*> relabel f r 75 | relabel f (ExtractValue a is) = ExtractValue 76 | <$> traverse (relabel f) a 77 | <*> pure is 78 | relabel f (InsertValue a i is) = InsertValue 79 | <$> traverse (relabel f) a 80 | <*> traverse (relabel f) i 81 | <*> pure is 82 | relabel f (ShuffleVector a b m) = ShuffleVector 83 | <$> traverse (relabel f) a 84 | <*> relabel f b 85 | <*> traverse (relabel f) m 86 | relabel f (Jump lab) = Jump <$> f Nothing lab 87 | relabel f (Br c l r) = Br 88 | <$> traverse (relabel f) c 89 | <*> f Nothing l 90 | <*> f Nothing r 91 | relabel f (Invoke r s as u e) = Invoke r 92 | <$> relabel f s 93 | <*> traverse (traverse (relabel f)) as 94 | <*> f Nothing u 95 | <*> f Nothing e 96 | relabel f (VaArg al t) = VaArg 97 | <$> traverse (relabel f) al 98 | <*> pure t 99 | relabel f (ExtractElt v i) = ExtractElt 100 | <$> traverse (relabel f) v 101 | <*> relabel f i 102 | relabel f (InsertElt v e i) = InsertElt 103 | <$> traverse (relabel f) v 104 | <*> traverse (relabel f) e 105 | <*> relabel f i 106 | relabel f (IndirectBr d ls) = IndirectBr 107 | <$> traverse (relabel f) d 108 | <*> traverse (f Nothing) ls 109 | relabel f (Switch c d ls) = 110 | let step (n,i) = (\l -> (n,l)) <$> f Nothing i 111 | in Switch <$> traverse (relabel f) c <*> f Nothing d <*> traverse step ls 112 | relabel f (Phi t ls) = 113 | let step (a,l) = (,) <$> relabel f a <*> f Nothing l 114 | in Phi t <$> traverse step ls 115 | 116 | relabel f (LandingPad ty fn c cs) = LandingPad ty 117 | <$> traverse (traverse (relabel f)) fn 118 | <*> pure c 119 | <*> traverse (relabel f) cs 120 | 121 | relabel f (Resume tv) = Resume <$> traverse (relabel f) tv 122 | relabel f (Freeze tv) = Freeze <$> traverse (relabel f) tv 123 | 124 | instance HasLabel Stmt' where relabel = $(generateRelabel 'relabel ''Stmt') 125 | instance HasLabel Clause' where relabel = $(generateRelabel 'relabel ''Clause') 126 | instance HasLabel Value' where relabel = $(generateRelabel 'relabel ''Value') 127 | instance HasLabel ValMd' where relabel = $(generateRelabel 'relabel ''ValMd') 128 | instance HasLabel DILabel' where relabel = $(generateRelabel 'relabel ''DILabel') 129 | instance HasLabel DebugLoc' where relabel = $(generateRelabel 'relabel ''DebugLoc') 130 | instance HasLabel DebugInfo' where relabel = $(generateRelabel 'relabel ''DebugInfo') 131 | instance HasLabel DIDerivedType' where relabel = $(generateRelabel 'relabel ''DIDerivedType') 132 | instance HasLabel DISubroutineType' where relabel = $(generateRelabel 'relabel ''DISubroutineType') 133 | instance HasLabel DISubrange' where relabel = $(generateRelabel 'relabel ''DISubrange') 134 | instance HasLabel DIGlobalVariable' where relabel = $(generateRelabel 'relabel ''DIGlobalVariable') 135 | instance HasLabel DIGlobalVariableExpression' where relabel = $(generateRelabel 'relabel ''DIGlobalVariableExpression') 136 | instance HasLabel DILocalVariable' where relabel = $(generateRelabel 'relabel ''DILocalVariable') 137 | instance HasLabel DISubprogram' where relabel = $(generateRelabel 'relabel ''DISubprogram') 138 | instance HasLabel DICompositeType' where relabel = $(generateRelabel 'relabel ''DICompositeType') 139 | instance HasLabel DILexicalBlock' where relabel = $(generateRelabel 'relabel ''DILexicalBlock') 140 | instance HasLabel DICompileUnit' where relabel = $(generateRelabel 'relabel ''DICompileUnit') 141 | instance HasLabel DILexicalBlockFile' where relabel = $(generateRelabel 'relabel ''DILexicalBlockFile') 142 | instance HasLabel DINameSpace' where relabel = $(generateRelabel 'relabel ''DINameSpace') 143 | instance HasLabel DITemplateTypeParameter' where relabel = $(generateRelabel 'relabel ''DITemplateTypeParameter') 144 | instance HasLabel DITemplateValueParameter' where relabel = $(generateRelabel 'relabel ''DITemplateValueParameter') 145 | instance HasLabel DIImportedEntity' where relabel = $(generateRelabel 'relabel ''DIImportedEntity') 146 | instance HasLabel DIArgList' where relabel = $(generateRelabel 'relabel ''DIArgList') 147 | 148 | -- | Clever instance that actually uses the block name 149 | instance HasLabel ConstExpr' where 150 | relabel f (ConstBlockAddr t@(Typed { typedValue = ValSymbol s }) l) = 151 | ConstBlockAddr <$> traverse (relabel f) t <*> f (Just s) l 152 | relabel f x = $(generateRelabel 'relabel ''ConstExpr') f x 153 | -------------------------------------------------------------------------------- /src/Text/LLVM/Labels/TH.hs: -------------------------------------------------------------------------------- 1 | {-# Language TemplateHaskell #-} 2 | module Text.LLVM.Labels.TH (generateRelabel) where 3 | 4 | import Control.Monad (zipWithM) 5 | import Language.Haskell.TH 6 | import Language.Haskell.TH.Datatype 7 | 8 | generateRelabel :: Name -> Name -> ExpQ 9 | generateRelabel relabel dataCon = 10 | do di <- reifyDatatype dataCon 11 | generateRelabelData di (varE relabel) 12 | 13 | generateRelabelData :: DatatypeInfo -> ExpQ -> ExpQ 14 | generateRelabelData di relabelE = 15 | [| \f x -> $(caseE [| x |] (mkMatch [| f |] <$> cons)) |] 16 | where 17 | mkMatch = generateRelabelCon lastArg relabelE 18 | lastArg = tvName (last (datatypeVars di)) 19 | cons = datatypeCons di 20 | 21 | -- | Generates the case arm for the given constructor that 22 | -- relabels values using this constructor given a relabeling 23 | -- function. 24 | generateRelabelCon :: 25 | Name {- ^ last type parameter -} -> 26 | ExpQ {- ^ recusive relabel expression -} -> 27 | ExpQ {- ^ function expression -} -> 28 | ConstructorInfo {- ^ current constructor -} -> 29 | MatchQ {- ^ match arm for this constructor -} 30 | generateRelabelCon lastArg relabelE fE ci = 31 | do names <- nameThings "x" (constructorFields ci) 32 | match 33 | (conP cn (map (varP . fst) names)) 34 | (normalB (bodyExp cn (map gen names))) 35 | [] 36 | where 37 | cn = constructorName ci 38 | 39 | -- Give a field name and type returns: 40 | -- Left for a pure field 41 | -- Right for a field using the Applicative instance 42 | gen :: (Name, Type) -> Either ExpQ ExpQ 43 | gen (n,t) = 44 | let nE = varE n in 45 | case generateRelabelField lastArg fE relabelE t of 46 | Just f -> Right [| $f $nE |] 47 | Nothing -> Left nE 48 | 49 | -- | Given a constructor and a list of pure and updated fields, 50 | -- build syntax that rebuilds the expression. 51 | bodyExp :: 52 | Name {- ^ constructor -} -> 53 | [Either ExpQ ExpQ] {- ^ list of pure and applicative fields -} -> 54 | ExpQ {- ^ applicative result -} 55 | bodyExp conname fields = liftAE conLike updates 56 | where 57 | updates = [r | Right r <- fields] 58 | 59 | -- Builds a value suitable to be the argument to liftAE that can 60 | -- combine all of the updated field values 61 | conLike = 62 | do names <- map fst <$> nameThings "y" updates 63 | lamE 64 | (map varP names) 65 | (appsE (conE conname : replaceRights (map varE names) fields)) 66 | 67 | -- | Replaces all of the 'Right' values in the given list with elements 68 | -- from the first list. The number of replacements must exactly match 69 | -- the number of 'Right' values. 70 | replaceRights :: 71 | [a] {- ^ replacements -} -> 72 | [Either a b] {- ^ source list -} -> 73 | [a] {- ^ replaced list -} 74 | replaceRights xs (Left y : ys) = y : replaceRights xs ys 75 | replaceRights (x:xs) (Right _ : ys) = x : replaceRights xs ys 76 | replaceRights [] [] = [] 77 | replaceRights _ _ = error "Text.LLVM.Labels.TH.replaceRights: PANIC" 78 | 79 | -- | Generate the applicative update value for a field if it 80 | -- has an appropriate type otherwise return nothing if it 81 | -- should be left unchagned. 82 | generateRelabelField :: 83 | Name {- ^ last type parameter -} -> 84 | ExpQ {- ^ function expression -} -> 85 | ExpQ {- ^ relabel expression -} -> 86 | Type {- ^ field type -} -> 87 | Maybe ExpQ {- ^ applicative update function -} 88 | generateRelabelField lastArg fE relabelE t = 89 | case typeDepth t of 90 | (n, VarT tn) | tn == lastArg -> Just (exprs !! n) 91 | _ -> Nothing 92 | where 93 | exprs = [| $fE Nothing |] : iterate traverseE [| $relabelE $fE |] 94 | 95 | -- | Figure out the depth of the outer type applications and 96 | -- return the type at the bottom of the stack 97 | typeDepth :: 98 | Type {- ^ target type -} -> 99 | (Int, Type) {- ^ number of type applications and right-most type -} 100 | typeDepth = go 0 101 | where 102 | go i (AppT _ x) = go (i+1) x 103 | go i t = (i, t) 104 | 105 | -- | Associate each element in a list of things with a unique name 106 | -- derived from a given name stem. 107 | nameThings :: 108 | String {- ^ base name -} -> 109 | [a] {- ^ things to name -} -> 110 | Q [(Name, a)] {- ^ things paired with unique names -} 111 | nameThings base xs = zipWithM nameThing [0 :: Int ..] xs 112 | where 113 | nameThing i x = do n <- newName (base ++ show i); return (n,x) 114 | 115 | -- | Apply 'traverse' to an expression 116 | traverseE :: 117 | ExpQ {- ^ f -} -> 118 | ExpQ {- ^ traverse f -} 119 | traverseE e = [| traverse $e |] 120 | 121 | -- Applies a pure value to zero or more applicative things to be combined 122 | -- with (<$>) and (<*>) 123 | liftAE :: ExpQ -> [ExpQ] -> ExpQ 124 | liftAE c [] = [| pure $c |] 125 | liftAE c (x:xs) = foldl (\f e -> [| $f <*> $e |]) [| $c <$> $x |] xs 126 | -------------------------------------------------------------------------------- /src/Text/LLVM/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Text.LLVM.Lens where 3 | 4 | import Text.LLVM 5 | import Lens.Micro.TH 6 | import Lens.Micro 7 | import Language.Haskell.TH.Syntax (mkName, nameBase) 8 | 9 | concat <$> mapM (makeLensesWith (lensRules & lensField .~ (\_ _ n -> [TopName $ mkName $ nameBase n ++ "Lens"]))) 10 | [ ''Module 11 | , ''LayoutSpec 12 | , ''TypeDecl 13 | , ''GlobalAlias 14 | , ''ConstExpr' 15 | , ''Type' 16 | , ''Mangling 17 | , ''NamedMd 18 | , ''Value' 19 | , ''BlockLabel 20 | , ''UnnamedMd 21 | , ''Typed 22 | , ''Global 23 | , ''Declare 24 | , ''Clause' 25 | , ''FunAttr 26 | , ''GlobalAttrs 27 | , ''BasicBlock' 28 | , ''Stmt' 29 | , ''Linkage 30 | , ''DebugLoc' 31 | , ''DebugInfo' 32 | , ''DIFile 33 | , ''DISubrange' 34 | , ''DIBasicType 35 | , ''DIExpression 36 | , ''DISubprogram' 37 | , ''DISubroutineType' 38 | , ''DILocalVariable' 39 | , ''DIGlobalVariableExpression' 40 | , ''DIGlobalVariable' 41 | , ''DICompileUnit' 42 | , ''DICompositeType' 43 | , ''DIDerivedType' 44 | , ''DILexicalBlock' 45 | , ''DILexicalBlockFile' 46 | , ''DIArgList' 47 | , ''Instr' 48 | , ''ValMd' 49 | , ''ConvOp 50 | , ''BitOp 51 | , ''ArithOp 52 | , ''FCmpOp 53 | , ''ICmpOp 54 | , ''GC 55 | , ''Define 56 | , ''PrimType 57 | ] 58 | -------------------------------------------------------------------------------- /src/Text/LLVM/PP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE ImplicitParams #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE Rank2Types #-} 6 | 7 | -- | 8 | -- Module : Text.LLVM.PP 9 | -- Copyright : Trevor Elliott 2011-2016 10 | -- License : BSD3 11 | -- 12 | -- Maintainer : awesomelyawesome@gmail.com 13 | -- Stability : experimental 14 | -- Portability : unknown 15 | -- 16 | -- This is the pretty-printer for llvm assembly versions 3.6 and lower. 17 | -- 18 | module Text.LLVM.PP where 19 | 20 | import Text.LLVM.AST 21 | import Text.LLVM.Triple.AST (TargetTriple) 22 | import Text.LLVM.Triple.Print (printTriple) 23 | 24 | import Control.Applicative ((<|>)) 25 | import Data.Bits ( shiftR, (.&.) ) 26 | import Data.Char (isAlphaNum,isAscii,isDigit,isPrint,ord,toUpper) 27 | import Data.List (intersperse) 28 | import qualified Data.Map as Map 29 | import Data.Maybe (catMaybes,fromMaybe,isJust) 30 | import GHC.Float (castDoubleToWord64, castFloatToWord32) 31 | import Numeric (showHex) 32 | import Text.PrettyPrint.HughesPJ 33 | import Data.Int 34 | import Prelude hiding ((<>)) 35 | 36 | 37 | -- Pretty-printer Config ------------------------------------------------------- 38 | 39 | 40 | -- | The value used to specify the LLVM major version. The LLVM text format 41 | -- (i.e. assembly code) changes with different versions of LLVM, so this value is 42 | -- used to select the version the output should be generated for. 43 | -- 44 | -- At the current time, changes primarily occur when the LLVM major version 45 | -- changes, and this is expected to be the case going forward, so it is 46 | -- sufficient to reference the LLVM version by the single major version number. 47 | -- There is one exception and one possible future exception to this approach: 48 | -- 49 | -- 1. During LLVM v3, there were changes in 3.5, 3.6, 3.7, and 3.8. There are 50 | -- explicit @ppLLVMnn@ function entry points for those versions, but in the 51 | -- event that a numerical value is needed, we note the serendipitous fact 52 | -- that prior to LLVM 4, there are exactly 4 versions we need to 53 | -- differentiate and can therefore assign the values of 0, 1, 2, and 3 to 54 | -- those versions (and we have no intention of supporting any other pre-4.0 55 | -- versions at this point). 56 | -- 57 | -- 2. If at some future date, there are text format changes associated with a 58 | -- minor version, then the LLVM version designation here will need to be 59 | -- enhanced and made more sophisticated. At the present time, the likelihood 60 | -- of that is small enough that the current simple implementation is a 61 | -- benefit over a more complex mechanism that might not be needed. 62 | -- 63 | type LLVMVer = Int 64 | 65 | -- | Helpers for specifying the LLVM versions prior to v4 66 | llvmV3_5, llvmV3_6, llvmV3_7, llvmV3_8 :: LLVMVer 67 | llvmV3_5 = 0 68 | llvmV3_6 = 1 69 | llvmV3_7 = 2 70 | llvmV3_8 = 3 71 | 72 | -- | This value should be updated when support is added for new LLVM versions; 73 | -- this is used for defaulting and otherwise reporting the maximum LLVM version 74 | -- known to be supported. 75 | llvmVlatest :: LLVMVer 76 | llvmVlatest = 17 77 | 78 | 79 | -- | The differences between various versions of the llvm textual AST. 80 | newtype Config = Config { cfgVer :: LLVMVer } 81 | 82 | withConfig :: Config -> ((?config :: Config) => a) -> a 83 | withConfig cfg body = let ?config = cfg in body 84 | 85 | 86 | ppLLVM :: LLVMVer -> ((?config :: Config) => a) -> a 87 | ppLLVM llvmver = withConfig Config { cfgVer = llvmver } 88 | 89 | ppLLVM35, ppLLVM36, ppLLVM37, ppLLVM38 :: ((?config :: Config) => a) -> a 90 | 91 | ppLLVM35 = withConfig Config { cfgVer = llvmV3_5 } 92 | ppLLVM36 = withConfig Config { cfgVer = llvmV3_6 } 93 | ppLLVM37 = withConfig Config { cfgVer = llvmV3_7 } 94 | ppLLVM38 = withConfig Config { cfgVer = llvmV3_8 } 95 | 96 | llvmVer :: (?config :: Config) => LLVMVer 97 | llvmVer = cfgVer ?config 98 | 99 | llvmVerToString :: LLVMVer -> String 100 | llvmVerToString 0 = "3.5" 101 | llvmVerToString 1 = "3.6" 102 | llvmVerToString 2 = "3.7" 103 | llvmVerToString 3 = "3.8" 104 | llvmVerToString n 105 | | n >= 4 = show n 106 | | otherwise = error $ "Invalid LLVMVer: " ++ show n 107 | 108 | -- | This is a helper function for when a list of parameters is gated by a 109 | -- condition (usually the llvmVer value). 110 | when' :: Monoid a => Bool -> a -> a 111 | when' c l = if c then l else mempty 112 | 113 | 114 | -- | This type encapsulates the ability to convert an object into Doc 115 | -- format. Using this abstraction allows for a consolidated representation of the 116 | -- declaration. Most pretty-printing for LLVM elements will have a @'Fmt' a@ 117 | -- function signature for that element. 118 | type Fmt a = (?config :: Config) => a -> Doc 119 | 120 | 121 | -- | The LLVMPretty class has instances for most AST elements. It allows the 122 | -- conversion of an AST element (and its sub-elements) into a Doc assembly format 123 | -- by simply using the 'llvmPP' method rather than needing to explicitly invoke 124 | -- the specific pretty-printing function for that element. 125 | class LLVMPretty a where llvmPP :: Fmt a 126 | 127 | instance LLVMPretty Module where llvmPP = ppModule 128 | instance LLVMPretty Symbol where llvmPP = ppSymbol 129 | instance LLVMPretty Ident where llvmPP = ppIdent 130 | 131 | 132 | -- Modules --------------------------------------------------------------------- 133 | 134 | ppModule :: Fmt Module 135 | ppModule m = foldr ($+$) empty 136 | $ ppSourceName (modSourceName m) 137 | : ppTargetTriple (modTriple m) 138 | : ppDataLayout (modDataLayout m) 139 | : ppInlineAsm (modInlineAsm m) 140 | : concat [ map ppTypeDecl (modTypes m) 141 | , map ppGlobal (modGlobals m) 142 | , map ppGlobalAlias (modAliases m) 143 | , map ppDeclare (modDeclares m) 144 | , map ppDefine (modDefines m) 145 | , map ppNamedMd (modNamedMd m) 146 | , map ppUnnamedMd (modUnnamedMd m) 147 | , map ppComdat (Map.toList (modComdat m)) 148 | ] 149 | 150 | 151 | -- Source filename ------------------------------------------------------------- 152 | 153 | ppSourceName :: Fmt (Maybe String) 154 | ppSourceName Nothing = empty 155 | ppSourceName (Just sn) = "source_filename" <+> char '=' <+> doubleQuotes (text sn) 156 | 157 | -- Metadata -------------------------------------------------------------------- 158 | 159 | ppNamedMd :: Fmt NamedMd 160 | ppNamedMd nm = 161 | sep [ ppMetadata (text (nmName nm)) <+> char '=' 162 | , ppMetadata (braces (commas (map (ppMetadata . int) (nmValues nm)))) ] 163 | 164 | ppUnnamedMd :: Fmt UnnamedMd 165 | ppUnnamedMd um = 166 | sep [ ppMetadata (int (umIndex um)) <+> char '=' 167 | , distinct <+> ppValMd (umValues um) ] 168 | where 169 | distinct | umDistinct um = "distinct" 170 | | otherwise = empty 171 | 172 | 173 | -- Aliases --------------------------------------------------------------------- 174 | 175 | ppGlobalAlias :: Fmt GlobalAlias 176 | ppGlobalAlias g = ppSymbol (aliasName g) 177 | <+> char '=' 178 | <+> ppMaybe ppLinkage (aliasLinkage g) 179 | <+> ppMaybe ppVisibility (aliasVisibility g) 180 | <+> body 181 | where 182 | val = aliasTarget g 183 | body = case val of 184 | ValSymbol _sym -> ppType (aliasType g) <+> ppValue val 185 | _ -> ppValue val 186 | 187 | 188 | -- Target triple --------------------------------------------------------------- 189 | 190 | -- | Pretty print a 'TargetTriple' 191 | ppTargetTriple :: Fmt TargetTriple 192 | ppTargetTriple triple = "target" <+> "triple" <+> char '=' 193 | <+> doubleQuotes (text (printTriple triple)) 194 | 195 | -- Data Layout ----------------------------------------------------------------- 196 | 197 | -- | Pretty print a data layout specification. 198 | ppDataLayout :: Fmt DataLayout 199 | ppDataLayout [] = empty 200 | ppDataLayout ls = "target" <+> "datalayout" <+> char '=' 201 | <+> doubleQuotes (hcat (intersperse (char '-') (map ppLayoutSpec ls))) 202 | 203 | -- | Pretty print a single layout specification. 204 | ppLayoutSpec :: Fmt LayoutSpec 205 | ppLayoutSpec ls = 206 | case ls of 207 | BigEndian -> char 'E' 208 | LittleEndian -> char 'e' 209 | PointerSize 0 sz abi pref -> char 'p' <> char ':' <> ppLayoutBody sz abi pref 210 | PointerSize n sz abi pref -> char 'p' <> int n <> char ':' 211 | <> ppLayoutBody sz abi pref 212 | IntegerSize sz abi pref -> char 'i' <> ppLayoutBody sz abi pref 213 | VectorSize sz abi pref -> char 'v' <> ppLayoutBody sz abi pref 214 | FloatSize sz abi pref -> char 'f' <> ppLayoutBody sz abi pref 215 | StackObjSize sz abi pref -> char 's' <> ppLayoutBody sz abi pref 216 | AggregateSize sz abi pref -> char 'a' <> ppLayoutBody sz abi pref 217 | NativeIntSize szs -> 218 | char 'n' <> hcat (punctuate (char ':') (map int szs)) 219 | FunctionPointerAlign ty abi -> 220 | char 'F' <> ppFunctionPointerAlignType ty <> int abi 221 | StackAlign a -> char 'S' <> int a 222 | Mangling m -> char 'm' <> char ':' <> ppMangling m 223 | 224 | -- | Pretty-print the common case for data layout specifications. 225 | ppLayoutBody :: Int -> Int -> Fmt (Maybe Int) 226 | ppLayoutBody size abi mb = int size <> char ':' <> int abi <> pref 227 | where 228 | pref = case mb of 229 | Nothing -> empty 230 | Just p -> char ':' <> int p 231 | 232 | ppFunctionPointerAlignType :: Fmt FunctionPointerAlignType 233 | ppFunctionPointerAlignType ty = 234 | case ty of 235 | IndependentOfFunctionAlign -> char 'i' 236 | MultipleOfFunctionAlign -> char 'n' 237 | 238 | ppMangling :: Fmt Mangling 239 | ppMangling ElfMangling = char 'e' 240 | ppMangling MipsMangling = char 'm' 241 | ppMangling MachOMangling = char 'o' 242 | ppMangling WindowsCoffMangling = char 'w' 243 | 244 | 245 | -- Inline Assembly ------------------------------------------------------------- 246 | 247 | -- | Pretty-print the inline assembly block. 248 | ppInlineAsm :: Fmt InlineAsm 249 | ppInlineAsm = foldr ($+$) empty . map ppLine 250 | where 251 | ppLine l = "module asm" <+> doubleQuotes (text l) 252 | 253 | 254 | -- Identifiers ----------------------------------------------------------------- 255 | 256 | ppIdent :: Fmt Ident 257 | ppIdent (Ident n) 258 | | validIdentifier n = char '%' <> text n 259 | | otherwise = char '%' <> ppStringLiteral n 260 | 261 | -- | According to the LLVM Language Reference Manual, the regular 262 | -- expression for LLVM identifiers is "[-a-zA-Z$._][-a-zA-Z$._0-9]". 263 | -- Identifiers may also be strings of one or more decimal digits. 264 | validIdentifier :: String -> Bool 265 | validIdentifier [] = False 266 | validIdentifier s@(c0 : cs) 267 | | isDigit c0 = all isDigit cs 268 | | otherwise = all isIdentChar s 269 | where 270 | isIdentChar :: Char -> Bool 271 | isIdentChar c = isAlphaNum c || c `elem` ("-$._" :: [Char]) 272 | 273 | 274 | -- Symbols --------------------------------------------------------------------- 275 | 276 | ppSymbol :: Fmt Symbol 277 | ppSymbol (Symbol n) 278 | | validIdentifier n = char '@' <> text n 279 | | otherwise = char '@' <> ppStringLiteral n 280 | 281 | 282 | -- Types ----------------------------------------------------------------------- 283 | 284 | ppPrimType :: Fmt PrimType 285 | ppPrimType Label = "label" 286 | ppPrimType Void = "void" 287 | ppPrimType (Integer i) = char 'i' <> integer (toInteger i) 288 | ppPrimType (FloatType ft) = ppFloatType ft 289 | ppPrimType X86mmx = "x86mmx" 290 | ppPrimType Metadata = "metadata" 291 | 292 | ppFloatType :: Fmt FloatType 293 | ppFloatType Half = "half" 294 | ppFloatType Float = "float" 295 | ppFloatType Double = "double" 296 | ppFloatType Fp128 = "fp128" 297 | ppFloatType X86_fp80 = "x86_fp80" 298 | ppFloatType PPC_fp128 = "ppc_fp128" 299 | 300 | ppType :: Fmt Type 301 | ppType (PrimType pt) = ppPrimType pt 302 | ppType (Alias i) = ppIdent i 303 | ppType (Array len ty) = brackets (integral len <+> char 'x' <+> ppType ty) 304 | ppType (PtrTo ty) = ppType ty <> char '*' 305 | ppType PtrOpaque = "ptr" 306 | ppType (Struct ts) = structBraces (commas (map ppType ts)) 307 | ppType (PackedStruct ts) = angles (structBraces (commas (map ppType ts))) 308 | ppType (FunTy r as va) = ppType r <> ppArgList va (map ppType as) 309 | ppType (Vector len pt) = angles (integral len <+> char 'x' <+> ppType pt) 310 | ppType Opaque = "opaque" 311 | 312 | ppTypeDecl :: Fmt TypeDecl 313 | ppTypeDecl td = ppIdent (typeName td) <+> char '=' 314 | <+> "type" <+> ppType (typeValue td) 315 | 316 | 317 | -- Declarations ---------------------------------------------------------------- 318 | 319 | ppGlobal :: Fmt Global 320 | ppGlobal g = ppSymbol (globalSym g) <+> char '=' 321 | <+> ppGlobalAttrs (isJust $ globalValue g) (globalAttrs g) 322 | <+> ppType (globalType g) <+> ppMaybe ppValue (globalValue g) 323 | <> ppAlign (globalAlign g) 324 | <> ppAttachedMetadata (Map.toList (globalMetadata g)) 325 | 326 | -- | Pretty-print Global Attributes (usually associated with a global variable 327 | -- declaration). The first argument to ppGlobalAttrs indicates whether there is a 328 | -- value associated with this global declaration: a global declaration with a 329 | -- value should not be identified as \"external\" and \"default\" visibility, 330 | -- whereas one without a value may have those attributes. 331 | 332 | ppGlobalAttrs :: Bool -> Fmt GlobalAttrs 333 | ppGlobalAttrs hasValue ga 334 | -- LLVM 3.8 does not emit or parse linkage information w/ hidden visibility 335 | | Just HiddenVisibility <- gaVisibility ga = 336 | ppVisibility HiddenVisibility <+> constant 337 | | Just External <- gaLinkage ga 338 | , Just DefaultVisibility <- gaVisibility ga 339 | , hasValue = 340 | -- Just show the value, no "external" or "default". This is based on 341 | -- empirical testing as described in the comment above (testing the 342 | -- following 6 configurations: 343 | -- * uninitialized scalar 344 | -- * uninitialized structure 345 | -- * initialized scalar 346 | -- * initialized structure 347 | -- * external scalar 348 | -- * external structure 349 | constant 350 | | otherwise = 351 | ppMaybe ppLinkage (gaLinkage ga) <+> ppMaybe ppVisibility (gaVisibility ga) <+> constant 352 | where 353 | constant | gaConstant ga = "constant" 354 | | otherwise = "global" 355 | 356 | ppDeclare :: Fmt Declare 357 | ppDeclare d = "declare" 358 | <+> ppMaybe ppLinkage (decLinkage d) 359 | <+> ppMaybe ppVisibility (decVisibility d) 360 | <+> ppType (decRetType d) 361 | <+> ppSymbol (decName d) 362 | <> ppArgList (decVarArgs d) (map ppType (decArgs d)) 363 | <+> hsep (ppFunAttr <$> decAttrs d) 364 | <> maybe empty ((char ' ' <>) . ppComdatName) (decComdat d) 365 | 366 | ppComdatName :: Fmt String 367 | ppComdatName s = "comdat" <> parens (char '$' <> text s) 368 | 369 | ppComdat :: Fmt (String,SelectionKind) 370 | ppComdat (n,k) = ppComdatName n <+> char '=' <+> text "comdat" <+> ppSelectionKind k 371 | 372 | ppSelectionKind :: Fmt SelectionKind 373 | ppSelectionKind k = 374 | case k of 375 | ComdatAny -> "any" 376 | ComdatExactMatch -> "exactmatch" 377 | ComdatLargest -> "largest" 378 | ComdatNoDuplicates -> "noduplicates" 379 | ComdatSameSize -> "samesize" 380 | 381 | ppDefine :: Fmt Define 382 | ppDefine d = "define" 383 | <+> ppMaybe ppLinkage (defLinkage d) 384 | <+> ppMaybe ppVisibility (defVisibility d) 385 | <+> ppType (defRetType d) 386 | <+> ppSymbol (defName d) 387 | <> ppArgList (defVarArgs d) (map (ppTyped ppIdent) (defArgs d)) 388 | <+> hsep (ppFunAttr <$> defAttrs d) 389 | <+> ppMaybe (\s -> "section" <+> doubleQuotes (text s)) (defSection d) 390 | <+> ppMaybe (\gc -> "gc" <+> ppGC gc) (defGC d) 391 | <+> ppMds (defMetadata d) 392 | <+> char '{' 393 | $+$ vcat (map ppBasicBlock (defBody d)) 394 | $+$ char '}' 395 | where 396 | ppMds mdm = 397 | case Map.toList mdm of 398 | [] -> empty 399 | mds -> hsep [ "!" <> text k <+> ppValMd md | (k, md) <- mds ] 400 | 401 | -- FunAttr --------------------------------------------------------------------- 402 | 403 | ppFunAttr :: Fmt FunAttr 404 | ppFunAttr a = 405 | case a of 406 | AlignStack w -> text "alignstack" <> parens (int w) 407 | Alwaysinline -> text "alwaysinline" 408 | Builtin -> text "builtin" 409 | Cold -> text "cold" 410 | Inlinehint -> text "inlinehint" 411 | Jumptable -> text "jumptable" 412 | Minsize -> text "minsize" 413 | Naked -> text "naked" 414 | Nobuiltin -> text "nobuiltin" 415 | Noduplicate -> text "noduplicate" 416 | Noimplicitfloat -> text "noimplicitfloat" 417 | Noinline -> text "noinline" 418 | Nonlazybind -> text "nonlazybind" 419 | Noredzone -> text "noredzone" 420 | Noreturn -> text "noreturn" 421 | Nounwind -> text "nounwind" 422 | Optnone -> text "optnone" 423 | Optsize -> text "optsize" 424 | Readnone -> text "readnone" 425 | Readonly -> text "readonly" 426 | ReturnsTwice -> text "returns_twice" 427 | SanitizeAddress -> text "sanitize_address" 428 | SanitizeMemory -> text "sanitize_memory" 429 | SanitizeThread -> text "sanitize_thread" 430 | SSP -> text "ssp" 431 | SSPreq -> text "sspreq" 432 | SSPstrong -> text "sspstrong" 433 | UWTable -> text "uwtable" 434 | 435 | -- Basic Blocks ---------------------------------------------------------------- 436 | 437 | ppLabelDef :: Fmt BlockLabel 438 | ppLabelDef (Named (Ident l)) = text l <> char ':' 439 | ppLabelDef (Anon i) = char ';' <+> "