{-# LANGUAGE PartialTypeSignatures , FlexibleContexts, Strict #-}
{-# OPTIONS_HADDOCK prune  #-}

{-|
Module      : L0ToNASM
Description : Lift the L0 representation of the binary to symbolized and recompilable NASM.
-}



module OutputGeneration.NASM.L0ToNASM where --  (lift_L0_to_NASM, render_NASM, __gmon_start_implementation, NASM) where


import Base
import Config

import OutputGeneration.NASM.NASM

import Data.CFG
import Data.Size
import Data.SPointer
import Data.SValue

import Binary.FunctionNames
import WithAbstractPredicates.ControlFlow
import Conventions

import Data.X86.Opcode
import Data.X86.Instruction
import Data.X86.Register

import Binary.Generic

import Data.L0
import Data.JumpTarget
import Data.Symbol
import Data.Indirection

import WithAbstractSymbolicValues.Class



import qualified Data.Map as M
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import qualified Data.Set as S
import Data.Maybe (fromJust,catMaybes,mapMaybe)
import Data.List.Extra (firstJust,replace)
import Data.List 
import Data.Word
import Data.Foldable
import Data.Char 
import Data.Bits (testBit, (.&.))
import Data.List.Split (splitOn)
import Data.ByteString.Internal (w2c)
import Data.Function (on)

import Control.Monad.State.Strict
import Data.Functor.Identity
import System.Directory (doesFileExist,createDirectoryIfMissing)
import System.Environment (getArgs)
import System.Exit (die)
import System.IO.Unsafe


import Debug.Trace

import GHC.Base hiding (Symbol)




type LiftedC bin = Lifting bin (Sstate SValue SPointer) (FInit SValue SPointer) SValue


-- | Lift an L0 representation to position-independent NASM
lift_L0_to_NASM :: BinaryClass bin => LiftedC bin -> NASM
lift_L0_to_NASM :: forall bin. BinaryClass bin => LiftedC bin -> NASM
lift_L0_to_NASM l :: LiftedC bin
l@(bin
bin,Config
_,L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue
l0) = Set String -> Set String -> [NASM_Section] -> [String] -> NASM
NASM Set String
mk_externals Set String
mk_globals [NASM_Section]
mk_sections ([String] -> NASM) -> [String] -> NASM
forall a b. (a -> b) -> a -> b
$ [String]
mk_jump_tables [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
mk_temp_storage] 
 where
  mk_externals :: Set String
mk_externals       = LiftedC bin -> Set String
forall {a} {b} {c}. BinaryClass a => (a, b, c) -> Set String
externals LiftedC bin
l
  mk_globals :: Set String
mk_globals         = bin -> Set String -> Set String
forall {a}. BinaryClass a => a -> Set String -> Set String
with_start_global bin
bin (Set String -> Set String) -> Set String -> Set String
forall a b. (a -> b) -> a -> b
$ Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
S.difference (bin -> Set String
forall {a}. BinaryClass a => a -> Set String
binary_get_global_symbols bin
bin) Set String
mk_externals
  mk_sections :: [NASM_Section]
mk_sections        = [NASM_Section]
mk_text_sections [NASM_Section] -> [NASM_Section] -> [NASM_Section]
forall a. [a] -> [a] -> [a]
++ [NASM_Section
mk_ro_data_section, NASM_Section
mk_data_section, NASM_Section
mk_bss_section, NASM_Section
mk_resolved_relocs]
  mk_text_sections :: [NASM_Section]
mk_text_sections   = (Word64 -> NASM_Section) -> [Word64] -> [NASM_Section]
forall a b. (a -> b) -> [a] -> [b]
map (LiftedC bin -> Word64 -> NASM_Section
forall bin.
BinaryClass bin =>
LiftedC bin -> Word64 -> NASM_Section
entry_to_NASM LiftedC bin
l) ([Word64] -> [NASM_Section]) -> [Word64] -> [NASM_Section]
forall a b. (a -> b) -> a -> b
$ (Int -> Word64) -> [Int] -> [Word64]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> [Word64]) -> [Int] -> [Word64]
forall a b. (a -> b) -> a -> b
$ Set Int -> [Int]
forall a. Set a -> [a]
S.toList (Set Int -> [Int]) -> Set Int -> [Int]
forall a b. (a -> b) -> a -> b
$ L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue
-> Set Int
forall pred finit v. L0 pred finit v -> Set Int
l0_get_function_entries L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue
l0

  mk_ro_data_section :: NASM_Section
mk_ro_data_section = [NASM_DataSection] -> NASM_Section
NASM_Section_Data ([NASM_DataSection] -> NASM_Section)
-> [NASM_DataSection] -> NASM_Section
forall a b. (a -> b) -> a -> b
$ LiftedC bin -> [NASM_DataSection]
forall {a}.
BinaryClass a =>
(a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> [NASM_DataSection]
ro_data_section LiftedC bin
l
  mk_data_section :: NASM_Section
mk_data_section    = [NASM_DataSection] -> NASM_Section
NASM_Section_Data ([NASM_DataSection] -> NASM_Section)
-> [NASM_DataSection] -> NASM_Section
forall a b. (a -> b) -> a -> b
$ LiftedC bin -> [NASM_DataSection]
forall {a}.
BinaryClass a =>
(a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> [NASM_DataSection]
data_section LiftedC bin
l
  mk_bss_section :: NASM_Section
mk_bss_section     = [NASM_DataSection] -> NASM_Section
NASM_Section_Data ([NASM_DataSection] -> NASM_Section)
-> [NASM_DataSection] -> NASM_Section
forall a b. (a -> b) -> a -> b
$ LiftedC bin -> [NASM_DataSection]
forall {a} {b} {c}.
BinaryClass a =>
(a, b, c) -> [NASM_DataSection]
bss_data_section LiftedC bin
l
  mk_resolved_relocs :: NASM_Section
mk_resolved_relocs = [NASM_DataSection] -> NASM_Section
NASM_Section_Data ([NASM_DataSection] -> NASM_Section)
-> [NASM_DataSection] -> NASM_Section
forall a b. (a -> b) -> a -> b
$ LiftedC bin -> [NASM_DataSection]
forall {a}.
BinaryClass a =>
(a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> [NASM_DataSection]
resolved_relocs_section LiftedC bin
l

  mk_temp_storage :: String
mk_temp_storage    = String
"section .bss\nLtemp_storage_foxdec:\nresb 8"
  mk_jump_tables :: [String]
mk_jump_tables     = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(/=) []) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ((Int, CFG, (Int, Indirections)) -> String)
-> [(Int, CFG, (Int, Indirections))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (LiftedC bin -> (Int, CFG, (Int, Indirections)) -> String
forall {bin} {a}.
(BinaryClass bin, Integral a) =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> (Int, CFG, (a, Indirections)) -> String
mk_jump_table LiftedC bin
l) ([(Int, CFG, (Int, Indirections))] -> [String])
-> [(Int, CFG, (Int, Indirections))] -> [String]
forall a b. (a -> b) -> a -> b
$ LiftedC bin -> [(Int, CFG, (Int, Indirections))]
forall {a} {b} {pred} {finit} {v}.
(a, b, L0 pred finit v) -> [(Int, CFG, (Int, Indirections))]
get_indirections_per_function LiftedC bin
l
 -- intercalate "\n" $ ["; Internally resolved relocations", "section .data"] ++ 


with_start_global :: a -> Set String -> Set String
with_start_global a
bin = 
  case a -> Word64
forall a. BinaryClass a => a -> Word64
binary_entry a
bin of
    Word64
0     -> Set String -> Set String
forall a. a -> a
id
    Word64
entry -> String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
S.insert String
"_start" 

resolved_relocs_section :: (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> [NASM_DataSection]
resolved_relocs_section l :: (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l@(a
bin,Config
_,L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue
l0) =
  case ((Int, Symbol) -> Bool) -> [(Int, Symbol)] -> [(Int, Symbol)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int, Symbol) -> Bool
forall {a}. (a, Symbol) -> Bool
is_relocation ([(Int, Symbol)] -> [(Int, Symbol)])
-> [(Int, Symbol)] -> [(Int, Symbol)]
forall a b. (a -> b) -> a -> b
$ IntMap Symbol -> [(Int, Symbol)]
forall a. IntMap a -> [(Int, a)]
IM.assocs (IntMap Symbol -> [(Int, Symbol)])
-> IntMap Symbol -> [(Int, Symbol)]
forall a b. (a -> b) -> a -> b
$ a -> IntMap Symbol
forall {a}. BinaryClass a => a -> IntMap Symbol
binary_get_symbol_table a
bin of
    [] -> []
    [(Int, Symbol)]
relocs -> ((Int, Symbol) -> NASM_DataSection)
-> [(Int, Symbol)] -> [NASM_DataSection]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Symbol) -> NASM_DataSection
forall {a}. Integral a => (a, Symbol) -> NASM_DataSection
mk_reloc [(Int, Symbol)]
relocs
 where
  is_relocation :: (a, Symbol) -> Bool
is_relocation (a
_,Relocated_ResolvedObject String
_ Word64
_) = Bool
True
  is_relocation (a, Symbol)
_ = Bool
False

  mk_reloc :: (a, Symbol) -> NASM_DataSection
mk_reloc (a
a0,Relocated_ResolvedObject String
str Word64
a1) = 
    (String, String, Word64)
-> Int
-> IntMap (Set NASM_Label)
-> [NASM_DataEntry]
-> NASM_DataSection
NASM_DataSection (String
"",String
".data",a -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a0) Int
0 (Int -> Set NASM_Label -> IntMap (Set NASM_Label)
forall a. Int -> a -> IntMap a
IM.singleton Int
0 (Set NASM_Label -> IntMap (Set NASM_Label))
-> Set NASM_Label -> IntMap (Set NASM_Label)
forall a b. (a -> b) -> a -> b
$ NASM_Label -> Set NASM_Label
forall a. a -> Set a
S.singleton (NASM_Label -> Set NASM_Label) -> NASM_Label -> Set NASM_Label
forall a b. (a -> b) -> a -> b
$ Word64 -> String -> NASM_Label
Label (a -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a0) (String -> NASM_Label) -> String -> NASM_Label
forall a b. (a -> b) -> a -> b
$ String -> String
strip_GLIBC String
str) [Word64 -> (NASM_Address, Annot) -> NASM_DataEntry
DataEntry_Pointer (a -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a0) ((a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> Word64 -> (NASM_Address, Annot)
forall bin.
BinaryClass bin =>
LiftedC bin -> Word64 -> (NASM_Address, Annot)
try_symbolize_imm (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l Word64
a1) ]

-- | Rendering NASM to a String
render_NASM :: (a, Config, L0 pred finit v) -> NASM -> String
render_NASM (a, Config, L0 pred finit v)
l (NASM Set String
exts Set String
globals [NASM_Section]
sections [String]
footer) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n\n\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [
    String
render_externals,
    String
render_globals,
    String
"default rel",
    (a, Config, L0 pred finit v) -> String
forall {a} {b} {c}. BinaryClass a => (a, b, c) -> String
mk_macros (a, Config, L0 pred finit v)
l ]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
render_sections
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
footer
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
render_annots ]
 where
  render_annots :: String
render_annots = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [
    String
"; TEMP_OBJECTs are memory locations inserted by FoxDec not present in the original binary",
    String
"; EXT_OBJECTs are external objects such as stderr and stdout",
    String
"; TERMINAL_CALLs are addresses of instructions in the original binary that always terminate and do not return",
    String
"; The remainder is a mapping from original addresses to internal labels",
    String
"%ifdef COMMENT",
    String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (NASM_Label -> String) -> [NASM_Label] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map NASM_Label -> String
forall {a}. Show a => a -> String
show_temp_object ([NASM_Label] -> [String]) -> [NASM_Label] -> [String]
forall a b. (a -> b) -> a -> b
$ Word64 -> String -> NASM_Label
Label Word64
0 String
"Ltemp_storage_foxdec" NASM_Label -> [NASM_Label] -> [NASM_Label]
forall a. a -> [a] -> [a]
: (((Int, CFG, (Int, Indirections)) -> [NASM_Label])
-> [(Int, CFG, (Int, Indirections))] -> [NASM_Label]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int, CFG, (Int, Indirections)) -> [NASM_Label]
forall {t :: * -> *} {a} {a} {b}.
(Foldable t, Integral a, Integral a) =>
(a, b, (a, t Indirection)) -> [NASM_Label]
get_temp_object ([(Int, CFG, (Int, Indirections))] -> [NASM_Label])
-> [(Int, CFG, (Int, Indirections))] -> [NASM_Label]
forall a b. (a -> b) -> a -> b
$ (a, Config, L0 pred finit v) -> [(Int, CFG, (Int, Indirections))]
forall {a} {b} {pred} {finit} {v}.
(a, b, L0 pred finit v) -> [(Int, CFG, (Int, Indirections))]
get_indirections_per_function (a, Config, L0 pred finit v)
l),
    String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Instruction -> String) -> [Instruction] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Instruction -> String
render_terminal ([Instruction] -> [String]) -> [Instruction] -> [String]
forall a b. (a -> b) -> a -> b
$ (a, Config, L0 pred finit v) -> [Instruction]
forall {a} {pred} {finit} {v}.
(BinaryClass a, Eq pred) =>
(a, Config, L0 pred finit v) -> [Instruction]
get_terminals_per_function (a, Config, L0 pred finit v)
l,
    String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
show_external_object ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (a, Config, L0 pred finit v) -> [String]
forall {a} {b} {c}. BinaryClass a => (a, b, c) -> [String]
external_objects (a, Config, L0 pred finit v)
l,
    Annot -> String
show_annots (Annot -> String) -> Annot -> String
forall a b. (a -> b) -> a -> b
$ (a, Config, L0 pred finit v) -> [NASM_Section] -> Annot
forall {a} {t :: * -> *} {b} {pred} {finit} {v}.
(BinaryClass a, Foldable t) =>
(a, b, L0 pred finit v) -> t NASM_Section -> Annot
mk_annots (a, Config, L0 pred finit v)
l [NASM_Section]
sections,
    String
"%endif" ]


  render_terminal :: Instruction -> String
render_terminal Instruction
i = String
"TERMINAL_CALL 0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall {a}. Integral a => a -> String
showHex (Instruction -> Word64
inAddress Instruction
i) 

  render_externals :: String
render_externals = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
forall a. [a] -> [a] -> [a]
(++) String
"extern ") ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Set String -> [String]
forall a. Set a -> [a]
S.toList (Set String -> [String]) -> Set String -> [String]
forall a b. (a -> b) -> a -> b
$ Set String
exts -- S.difference exts (ctxt_get_globals ctxt)
  render_sections :: [String]
render_sections  = (NASM_Section -> String) -> [NASM_Section] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map NASM_Section -> String
render_section [NASM_Section]
sections
  render_globals :: String
render_globals   = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
forall a. [a] -> [a] -> [a]
(++) String
"global ") ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Set String -> [String]
forall a. Set a -> [a]
S.toList (Set String -> [String]) -> Set String -> [String]
forall a b. (a -> b) -> a -> b
$ Set String
globals -- S.difference (ctxt_get_globals ctxt) exts

  render_section :: NASM_Section -> String
render_section (NASM_Section_Text NASM_TextSection
ts) = NASM_TextSection -> String
forall {a}. Show a => a -> String
show NASM_TextSection
ts
  render_section (NASM_Section_Data [NASM_DataSection]
ds) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n\n" ((NASM_DataSection -> String) -> [NASM_DataSection] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map NASM_DataSection -> String
forall {a}. Show a => a -> String
show [NASM_DataSection]
ds) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n"




  show_external_object :: String -> String
show_external_object String
str = String
"EXT_OBJECT " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str
  
  get_temp_object :: (a, b, (a, t Indirection)) -> [NASM_Label]
get_temp_object (a
entry,b
cfg,(a
a,t Indirection
inds)) = (Indirection -> [NASM_Label]) -> t Indirection -> [NASM_Label]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (a -> a -> Indirection -> [NASM_Label]
forall {a} {a}.
(Integral a, Integral a) =>
a -> a -> Indirection -> [NASM_Label]
get_temp_object_for_ind a
entry a
a) t Indirection
inds

  get_temp_object_for_ind :: a -> a -> Indirection -> [NASM_Label]
get_temp_object_for_ind a
entry a
a (Indirection_JumpTable (JumpTable Operand
index Int
bnd Operand
trgt IntMap Word64
tbl)) =
    [
     a -> a -> Integer -> NASM_Label
forall {a} {a} {a}.
(Integral a, Integral a, Num a, Eq a) =>
a -> a -> a -> NASM_Label
label_jump_table_temp_storage a
entry a
a Integer
0
    ,a -> a -> Integer -> NASM_Label
forall {a} {a} {a}.
(Integral a, Integral a, Num a, Eq a) =>
a -> a -> a -> NASM_Label
label_jump_table_temp_storage a
entry a
a Integer
1
    ]
  get_temp_object_for_ind a
entry a
a Indirection
_ = []

  show_temp_object :: a -> String
show_temp_object a
obj = String
"TEMP_OBJECT " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall {a}. Show a => a -> String
show a
obj







-- | get the external functions and objects 
externals :: (a, b, c) -> Set String
externals l :: (a, b, c)
l@(a
bin,b
_,c
l0) = String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
S.insert String
"exit" (Set String -> Set String) -> Set String -> Set String
forall a b. (a -> b) -> a -> b
$ [String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ([String] -> Set String) -> [String] -> Set String
forall a b. (a -> b) -> a -> b
$ (Symbol -> String) -> [Symbol] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
strip_GLIBC (String -> String) -> (Symbol -> String) -> Symbol -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> String
symbol_to_name) ([Symbol] -> [String]) -> [Symbol] -> [String]
forall a b. (a -> b) -> a -> b
$ (Symbol -> Bool) -> [Symbol] -> [Symbol]
forall a. (a -> Bool) -> [a] -> [a]
filter Symbol -> Bool
is_relocation ([Symbol] -> [Symbol]) -> [Symbol] -> [Symbol]
forall a b. (a -> b) -> a -> b
$ IntMap Symbol -> [Symbol]
forall a. IntMap a -> [a]
IM.elems (IntMap Symbol -> [Symbol]) -> IntMap Symbol -> [Symbol]
forall a b. (a -> b) -> a -> b
$ a -> IntMap Symbol
forall {a}. BinaryClass a => a -> IntMap Symbol
binary_get_symbol_table a
bin
 where
  is_relocation :: Symbol -> Bool
is_relocation (PointerToLabel String
str Bool
ex)  = Bool
ex Bool -> Bool -> Bool
&& String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
""
  is_relocation (PointerToObject String
str Bool
ex) = Bool
ex Bool -> Bool -> Bool
&& String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
""
  is_relocation (AddressOfObject String
str Bool
ex) = Bool
ex Bool -> Bool -> Bool
&& String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
""
  is_relocation (AddressOfLabel String
str Bool
ex) = Bool
ex Bool -> Bool -> Bool
&& String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
""
  is_relocation Symbol
_ = Bool
False

-- | get the external objects
external_objects :: (a, b, c) -> [String]
external_objects l :: (a, b, c)
l@(a
bin,b
_,c
l0) = (Symbol -> String) -> [Symbol] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
strip_GLIBC (String -> String) -> (Symbol -> String) -> Symbol -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> String
symbol_to_name) ([Symbol] -> [String]) -> [Symbol] -> [String]
forall a b. (a -> b) -> a -> b
$ (Symbol -> Bool) -> [Symbol] -> [Symbol]
forall a. (a -> Bool) -> [a] -> [a]
filter Symbol -> Bool
is_relocation ([Symbol] -> [Symbol]) -> [Symbol] -> [Symbol]
forall a b. (a -> b) -> a -> b
$ IntMap Symbol -> [Symbol]
forall a. IntMap a -> [a]
IM.elems (IntMap Symbol -> [Symbol]) -> IntMap Symbol -> [Symbol]
forall a b. (a -> b) -> a -> b
$ a -> IntMap Symbol
forall {a}. BinaryClass a => a -> IntMap Symbol
binary_get_symbol_table a
bin
 where
  is_relocation :: Symbol -> Bool
is_relocation (PointerToObject String
str Bool
ex) = Bool
ex Bool -> Bool -> Bool
&& String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
""
  is_relocation (AddressOfObject String
str Bool
ex) = Bool
ex Bool -> Bool -> Bool
&& String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
""
  is_relocation Symbol
_ = Bool
False





is_address_of_symbol :: Symbol -> Bool
is_address_of_symbol (AddressOfObject String
str Bool
ex) = String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
""
is_address_of_symbol (AddressOfLabel String
str Bool
ex)  = String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
""
is_address_of_symbol Symbol
_                        = Bool
False

-- | Creating labels
-- Given the entry address of the current function, the blockID of the current basic block,
-- map an address to a label.
-- First, try to see if it matches the _start symbol.
-- Then, try to map the address to a known internal synbol (unstripped binaries may have such symbols available)
-- Then, try to see if at the address a relocation is stored, and use that lavel if so.
-- Otherwise, make a new custom label.
block_label :: (a, b, c) -> p -> Word64 -> p -> NASM_Label
block_label l :: (a, b, c)
l@(a
bin,b
_,c
l0) p
entry Word64
a p
blockID = (Maybe NASM_Label
try_start_symbol Maybe NASM_Label -> Maybe NASM_Label -> Maybe NASM_Label
forall a. Eq a => Maybe a -> Maybe a -> Maybe a
`orTry` Maybe NASM_Label
try_symbol Maybe NASM_Label -> Maybe NASM_Label -> Maybe NASM_Label
forall a. Eq a => Maybe a -> Maybe a -> Maybe a
`orTry` Maybe NASM_Label
try_relocation_label) Maybe NASM_Label -> NASM_Label -> NASM_Label
forall a. Eq a => Maybe a -> a -> a
`orElse` NASM_Label
custom_label
 where
  -- Try if the address matches the entry point of the ELF
  try_start_symbol :: Maybe NASM_Label
try_start_symbol
    | a -> Word64
forall a. BinaryClass a => a -> Word64
binary_entry a
bin Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0 Bool -> Bool -> Bool
&& Word64
a Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Word64
forall a. BinaryClass a => a -> Word64
binary_entry a
bin = NASM_Label -> Maybe NASM_Label
forall a. a -> Maybe a
Just (NASM_Label -> Maybe NASM_Label) -> NASM_Label -> Maybe NASM_Label
forall a b. (a -> b) -> a -> b
$ Word64 -> String -> NASM_Label
Label Word64
a String
"_start"
    | Bool
otherwise = Maybe NASM_Label
forall a. Maybe a
Nothing
  -- Try if the address matches a known symbol
  try_symbol :: Maybe NASM_Label
try_symbol = do
    Symbol
sym  <- (Int -> IntMap Symbol -> Maybe Symbol
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
a) (IntMap Symbol -> Maybe Symbol) -> IntMap Symbol -> Maybe Symbol
forall a b. (a -> b) -> a -> b
$ (Symbol -> Bool) -> IntMap Symbol -> IntMap Symbol
forall a. (a -> Bool) -> IntMap a -> IntMap a
IM.filter Symbol -> Bool
is_address_of_symbol (IntMap Symbol -> IntMap Symbol) -> IntMap Symbol -> IntMap Symbol
forall a b. (a -> b) -> a -> b
$ a -> IntMap Symbol
forall {a}. BinaryClass a => a -> IntMap Symbol
binary_get_symbol_table a
bin)
    let name :: String
name = Symbol -> String
symbol_to_name Symbol
sym
    if {--nasm_with_safe_labels (ctxt_config ctxt) &&--} p
blockID p -> p -> Bool
forall a. Eq a => a -> a -> Bool
/= p
0 then
      NASM_Label -> Maybe NASM_Label
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (NASM_Label -> Maybe NASM_Label) -> NASM_Label -> Maybe NASM_Label
forall a b. (a -> b) -> a -> b
$ Word64 -> String -> NASM_Label
Label Word64
a (String -> NASM_Label) -> String -> NASM_Label
forall a b. (a -> b) -> a -> b
$ String
"L" String -> String -> String
forall a. [a] -> [a] -> [a]
++ p -> String
forall {a}. Integral a => a -> String
showHex p
entry String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
    else
      NASM_Label -> Maybe NASM_Label
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (NASM_Label -> Maybe NASM_Label) -> NASM_Label -> Maybe NASM_Label
forall a b. (a -> b) -> a -> b
$ Word64 -> String -> NASM_Label
Label Word64
a String
name
  -- Try to see if the address stores a relocation
  try_relocation_label :: Maybe NASM_Label
try_relocation_label = Relocation -> NASM_Label
reloc_label (Relocation -> NASM_Label) -> Maybe Relocation -> Maybe NASM_Label
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Relocation -> Bool) -> Set Relocation -> Maybe Relocation
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Word64 -> Relocation -> Bool
reloc_for Word64
a) (a -> Set Relocation
forall a. BinaryClass a => a -> Set Relocation
binary_get_relocations a
bin)

  -- Make a new label based on the entry and blockID
  custom_label :: NASM_Label
custom_label = Word64 -> String -> NASM_Label
Label Word64
a (String -> NASM_Label) -> String -> NASM_Label
forall a b. (a -> b) -> a -> b
$ String
"L" String -> String -> String
forall a. [a] -> [a] -> [a]
++ p -> String
forall {a}. Integral a => a -> String
showHex p
entry String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ p -> String
forall {a}. Show a => a -> String
show p
blockID
  -- Make a label for relocation
  reloc_label :: Relocation -> NASM_Label
reloc_label (Relocation Word64
a0 Word64
a1) = Word64 -> String -> NASM_Label
Label Word64
a (String -> NASM_Label) -> String -> NASM_Label
forall a b. (a -> b) -> a -> b
$ String
"L_reloc_0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall {a}. Integral a => a -> String
showHex Word64
a0 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall {a}. Integral a => a -> String
showHex Word64
a1


-- Make a label for the start of a section
section_label :: String -> String -> Word64 -> NASM_Label
section_label String
segment String
section Word64
addr = Word64 -> String -> NASM_Label
Label Word64
addr (String -> NASM_Label) -> String -> NASM_Label
forall a b. (a -> b) -> a -> b
$ String
"L" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
segment String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
section String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall {a}. Integral a => a -> String
showHex Word64
addr 
-- Make a label for the end of a section
end_of_section_label :: (String, String, Word64, Word64, e) -> NASM_Label
end_of_section_label (String
segment,String
section,Word64
a0,Word64
sz,e
_) = Word64 -> String -> NASM_Label
Label (Word64
a0Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+Word64
sz) (String -> NASM_Label) -> String -> NASM_Label
forall a b. (a -> b) -> a -> b
$ String
"L" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
segment String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
section String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_END"  
-- Make a macro name
macro_name :: String -> String -> Word64 -> Word64 -> NASM_Label
macro_name String
segment String
section Word64
a0 Word64
offset = String -> String -> Word64 -> Word64 -> NASM_Label
Macro String
segment String
section Word64
a0 Word64
offset
-- Make a "safe" label (no duplicates)
mk_safe_label :: String -> Word64 -> NASM_Label
mk_safe_label String
str Word64
a = Word64 -> String -> NASM_Label
Label Word64
a (String -> NASM_Label) -> String -> NASM_Label
forall a b. (a -> b) -> a -> b
$ String -> String
strip_GLIBC String
str -- ++ "_0x" ++ showHex a

-- Make a label indicating that this block is expected to terminate
terminating_label :: (a, b, c) -> p -> Instruction -> p -> NASM_Label
terminating_label (a, b, c)
l p
entry Instruction
i p
blockID =
  let Label Word64
a String
lab = (a, b, c) -> p -> Word64 -> p -> NASM_Label
forall {p} {p} {a} {b} {c}.
(Show p, Integral p, Num p, Eq p, BinaryClass a) =>
(a, b, c) -> p -> Word64 -> p -> NASM_Label
block_label (a, b, c)
l p
entry (Instruction -> Word64
inAddress Instruction
i) p
blockID in
    Word64 -> String -> NASM_Label
Label Word64
a (String -> NASM_Label) -> String -> NASM_Label
forall a b. (a -> b) -> a -> b
$ String
"FOXDEC_TERMINATING_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lab
-- Make a label indicating that this block is a DONTCARE
dontcare_label :: (a, b, c) -> p -> Word64 -> p -> NASM_Label
dontcare_label (a, b, c)
l p
entry Word64
a_end p
blockID =
  let Label Word64
a String
lab = (a, b, c) -> p -> Word64 -> p -> NASM_Label
forall {p} {p} {a} {b} {c}.
(Show p, Integral p, Num p, Eq p, BinaryClass a) =>
(a, b, c) -> p -> Word64 -> p -> NASM_Label
block_label (a, b, c)
l p
entry Word64
a_end p
blockID in
    Word64 -> String -> NASM_Label
Label Word64
a (String -> NASM_Label) -> String -> NASM_Label
forall a b. (a -> b) -> a -> b
$ String
"FOXDEC_DONTCARE_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lab
-- Make a label indicating that this instruction is halting
halting_label :: (a, b, c) -> p -> Word64 -> p -> NASM_Label
halting_label (a, b, c)
l p
entry Word64
a p
blockID =
  let Label Word64
a' String
lab = (a, b, c) -> p -> Word64 -> p -> NASM_Label
forall {p} {p} {a} {b} {c}.
(Show p, Integral p, Num p, Eq p, BinaryClass a) =>
(a, b, c) -> p -> Word64 -> p -> NASM_Label
block_label (a, b, c)
l p
entry Word64
a p
blockID in
    Word64 -> String -> NASM_Label
Label Word64
a' (String -> NASM_Label) -> String -> NASM_Label
forall a b. (a -> b) -> a -> b
$ String
lab String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_HLT"





-- | Information on sections
-- TODO: get from Binary interface
is_ro_data_section :: (String, String, c, d, e) -> Bool
is_ro_data_section (String
"",String
".rodata",c
_,d
_,e
_) = Bool
True
is_ro_data_section (String
"",String
".init_array",c
_,d
_,e
_) = Bool
True
is_ro_data_section (String
"",String
".fini_array",c
_,d
_,e
_) = Bool
True
is_ro_data_section (String
"",String
".data.rel.ro",c
_,d
_,e
_) = Bool
True
is_ro_data_section (String
"__DATA",String
"__const",c
_,d
_,e
_) = Bool
True
is_ro_data_section (String, String, c, d, e)
_ = Bool
False

is_data_section :: (String, String, c, d, e) -> Bool
is_data_section (String
"__DATA",String
"__data",c
_,d
_,e
_) = Bool
True
is_data_section (String
"",String
".data",c
_,d
_,e
_) = Bool
True
is_data_section (String, String, c, d, e)
_ = Bool
False

is_bss_data_section :: (String, String, c, d, e) -> Bool
is_bss_data_section (String
"__DATA",String
"__bss",c
_,d
_,e
_) = Bool
True
is_bss_data_section (String
"__DATA",String
"__common",c
_,d
_,e
_) = Bool
True
is_bss_data_section (String
"",String
".bss",c
_,d
_,e
_) = Bool
True
is_bss_data_section (String, String, c, d, e)
_ = Bool
False






-- | convert a given function entry to a NASM text section
entry_to_NASM :: BinaryClass bin => LiftedC bin -> Word64 -> NASM_Section
entry_to_NASM :: forall bin.
BinaryClass bin =>
LiftedC bin -> Word64 -> NASM_Section
entry_to_NASM l :: LiftedC bin
l@(bin
bin,Config
_,L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue
l0) Word64
entry = NASM_TextSection -> NASM_Section
NASM_Section_Text (NASM_TextSection -> NASM_Section)
-> NASM_TextSection -> NASM_Section
forall a b. (a -> b) -> a -> b
$ String -> [(Int, [NASM_Line])] -> IntMap IntSet -> NASM_TextSection
NASM_TextSection String
mk_header [(Int, [NASM_Line])]
mk_blocks IntMap IntSet
mk_control_flow
 where
  Label Word64
_ String
mk_header = LiftedC bin -> Integer -> Word64 -> Integer -> NASM_Label
forall {p} {p} {a} {b} {c}.
(Show p, Integral p, Num p, Eq p, BinaryClass a) =>
(a, b, c) -> p -> Word64 -> p -> NASM_Label
block_label LiftedC bin
l (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
entry) (Word64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
entry) Integer
0 -- function_name_of_entry ctxt entry
  Just CFG
cfg          = Int -> IntMap CFG -> Maybe CFG
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
entry) (L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue
-> IntMap CFG
forall pred finit v. L0 pred finit v -> IntMap CFG
l0_get_cfgs L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue
l0)
  mk_control_flow :: IntMap IntSet
mk_control_flow   = CFG -> IntMap IntSet
cfg_edges CFG
cfg
  mk_blocks :: [(Int, [NASM_Line])]
mk_blocks         = 
    let blocks :: [Int]
blocks      = IntMap [Int] -> [Int]
forall a. IntMap a -> [Int]
IM.keys (IntMap [Int] -> [Int]) -> IntMap [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ CFG -> IntMap [Int]
cfg_blocks CFG
cfg in
      LiftedC bin -> Word64 -> CFG -> [Int] -> [(Int, [NASM_Line])]
forall bin.
BinaryClass bin =>
LiftedC bin -> Word64 -> CFG -> [Int] -> [(Int, [NASM_Line])]
cfg_blocks_to_NASM LiftedC bin
l Word64
entry CFG
cfg ([Int] -> [(Int, [NASM_Line])]) -> [Int] -> [(Int, [NASM_Line])]
forall a b. (a -> b) -> a -> b
$ ((Int -> Int -> Ordering) -> [Int] -> [Int]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (CFG -> Int -> Int -> Ordering
start_address_le CFG
cfg) [Int]
blocks)

  start_address_le :: CFG -> Int -> Int -> Ordering
start_address_le CFG
cfg Int
blockID1 Int
blockID2 = 
    case (CFG -> Int -> Maybe Integer
forall {b}. Num b => CFG -> Int -> Maybe b
start_address_of_block CFG
cfg Int
blockID1, CFG -> Int -> Maybe Integer
forall {b}. Num b => CFG -> Int -> Maybe b
start_address_of_block CFG
cfg Int
blockID2) of
      (Just Integer
a1, Just Integer
a2) -> Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Integer
a1 Integer
a2
      (Just Integer
a1, Maybe Integer
_)       -> Ordering
LT
      (Maybe Integer
_, Just Integer
a2)       -> Ordering
GT
      (Maybe Integer, Maybe Integer)
_ -> Ordering
EQ


show_annots :: Annot -> String
show_annots :: Annot -> String
show_annots = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> (Annot -> [String]) -> Annot -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Word64, NASM_Label, Word64) -> String) -> Annot -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Word64, NASM_Label, Word64) -> String
forall {a} {a} {a}.
(Show a, Integral a, Integral a) =>
(a, a, a) -> String
show_entry
 where
  show_entry :: (a, a, a) -> String
show_entry (a
a,a
l,a
offset) = String
"0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall {a}. Integral a => a -> String
showHex a
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall {a}. Show a => a -> String
show a
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if a
offset a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 then String
"" else String
" + 0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall {a}. Integral a => a -> String
showHex a
offset)

mk_annots :: (a, b, L0 pred finit v) -> t NASM_Section -> Annot
mk_annots l :: (a, b, L0 pred finit v)
l@(a
bin,b
_,L0 pred finit v
l0) t NASM_Section
sections = {--map replace_macro_names $ --}Annot -> Annot
forall a. Eq a => [a] -> [a]
nub (Annot -> Annot) -> Annot -> Annot
forall a b. (a -> b) -> a -> b
$ Annot
block_mapping Annot -> Annot -> Annot
forall a. [a] -> [a] -> [a]
++ Annot
annot_from_labels
 where
  block_mapping :: Annot
block_mapping = (Int -> Annot) -> [Int] -> Annot
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> Annot
forall {c}. Num c => Int -> [(Word64, NASM_Label, c)]
mk_block_mapping_for_entry) ([Int] -> Annot) -> [Int] -> Annot
forall a b. (a -> b) -> a -> b
$ Set Int -> [Int]
forall a. Set a -> [a]
S.toList (Set Int -> [Int]) -> Set Int -> [Int]
forall a b. (a -> b) -> a -> b
$ L0 pred finit v -> Set Int
forall pred finit v. L0 pred finit v -> Set Int
l0_get_function_entries L0 pred finit v
l0
  annot_from_labels :: Annot
annot_from_labels = (NASM_Section -> Annot) -> t NASM_Section -> Annot
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NASM_Section -> Annot
get_annots_section t NASM_Section
sections

  mk_block_mapping_for_entry :: Int -> [(Word64, NASM_Label, c)]
mk_block_mapping_for_entry Int
entry = 
    let cfg :: CFG
cfg = L0 pred finit v -> IntMap CFG
forall pred finit v. L0 pred finit v -> IntMap CFG
l0_get_cfgs L0 pred finit v
l0 IntMap CFG -> Int -> CFG
forall a. IntMap a -> Int -> a
IM.! Int
entry in
      (Int -> (Word64, NASM_Label, c))
-> [Int] -> [(Word64, NASM_Label, c)]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> CFG -> Int -> (Word64, NASM_Label, c)
forall {p} {c}.
(Integral p, Num c) =>
p -> CFG -> Int -> (Word64, NASM_Label, c)
mk_block_mapping_for_block Int
entry CFG
cfg) (IntMap [Int] -> [Int]
forall a. IntMap a -> [Int]
IM.keys (IntMap [Int] -> [Int]) -> IntMap [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ CFG -> IntMap [Int]
cfg_blocks CFG
cfg)

  mk_block_mapping_for_block :: p -> CFG -> Int -> (Word64, NASM_Label, c)
mk_block_mapping_for_block p
entry CFG
cfg Int
blockID = 
    let a :: Word64
a = Instruction -> Word64
inAddress (Instruction -> Word64) -> Instruction -> Word64
forall a b. (a -> b) -> a -> b
$ [Instruction] -> Instruction
forall a. HasCallStack => [a] -> a
head ([Instruction] -> Instruction) -> [Instruction] -> Instruction
forall a b. (a -> b) -> a -> b
$ CFG -> Int -> [Instruction]
get_block_instrs CFG
cfg Int
blockID in
      (Word64
a, (a, b, L0 pred finit v) -> p -> Word64 -> Int -> NASM_Label
forall {p} {p} {a} {b} {c}.
(Show p, Integral p, Num p, Eq p, BinaryClass a) =>
(a, b, c) -> p -> Word64 -> p -> NASM_Label
block_label (a, b, L0 pred finit v)
l p
entry Word64
a Int
blockID, c
0)
  get_block_instrs :: CFG -> Int -> [Instruction]
get_block_instrs CFG
cfg Int
blockID = CFG -> IntMap [Instruction]
cfg_instrs CFG
cfg IntMap [Instruction] -> Int -> [Instruction]
forall a. IntMap a -> Int -> a
IM.! Int
blockID 


  get_annots_section :: NASM_Section -> Annot
get_annots_section (NASM_Section_Text NASM_TextSection
sec) = NASM_TextSection -> Annot
get_annots_textsection NASM_TextSection
sec
  get_annots_section (NASM_Section_Data [NASM_DataSection]
sec) = [] -- TODO?

  get_annots_textsection :: NASM_TextSection -> Annot
get_annots_textsection (NASM_TextSection String
_ [(Int, [NASM_Line])]
blocks IntMap IntSet
_) = (NASM_Line -> Annot) -> [NASM_Line] -> Annot
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NASM_Line -> Annot
get_annots_line ([NASM_Line] -> Annot) -> [NASM_Line] -> Annot
forall a b. (a -> b) -> a -> b
$ [[NASM_Line]] -> [NASM_Line]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[NASM_Line]] -> [NASM_Line]) -> [[NASM_Line]] -> [NASM_Line]
forall a b. (a -> b) -> a -> b
$ ((Int, [NASM_Line]) -> [NASM_Line])
-> [(Int, [NASM_Line])] -> [[NASM_Line]]
forall a b. (a -> b) -> [a] -> [b]
map (Int, [NASM_Line]) -> [NASM_Line]
forall a b. (a, b) -> b
snd [(Int, [NASM_Line])]
blocks

  get_annots_line :: NASM_Line -> Annot
get_annots_line (NASM_Line (NASM_Instruction Maybe Prefix
_ Maybe Opcode
_ [NASM_Operand]
_ String
_ Annot
annot)) = Annot
annot
  get_annots_line NASM_Line
_ = []



  replace_macro_names :: (Word64, NASM_Label, c) -> (Word64, NASM_Label, c)
replace_macro_names (Word64
a,NASM_Label
label,c
0) =
    case ((String, String, String, Word64, Word64) -> Bool)
-> [(String, String, String, Word64, Word64)]
-> Maybe (String, String, String, Word64, Word64)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(String
sym,String
_,String
_,Word64
_,Word64
_) -> Word64 -> String -> NASM_Label
Label Word64
a String
sym NASM_Label -> NASM_Label -> Bool
forall a. Eq a => a -> a -> Bool
== NASM_Label
label) ([(String, String, String, Word64, Word64)]
 -> Maybe (String, String, String, Word64, Word64))
-> [(String, String, String, Word64, Word64)]
-> Maybe (String, String, String, Word64, Word64)
forall a b. (a -> b) -> a -> b
$ IntMap (String, String, String, Word64, Word64)
-> [(String, String, String, Word64, Word64)]
forall a. IntMap a -> [a]
IM.elems (IntMap (String, String, String, Word64, Word64)
 -> [(String, String, String, Word64, Word64)])
-> IntMap (String, String, String, Word64, Word64)
-> [(String, String, String, Word64, Word64)]
forall a b. (a -> b) -> a -> b
$ (a, b, L0 pred finit v)
-> IntMap (String, String, String, Word64, Word64)
forall {a} {b} {c}.
BinaryClass a =>
(a, b, c) -> IntMap (String, String, String, Word64, Word64)
internal_labels_outside_of_sections (a, b, L0 pred finit v)
l of
      Just (String
sym,String
segment,String
section,Word64
a0,Word64
offset) -> String -> (Word64, NASM_Label, c)
forall a. HasCallStack => String -> a
error (String -> (Word64, NASM_Label, c))
-> String -> (Word64, NASM_Label, c)
forall a b. (a -> b) -> a -> b
$ (Word64, NASM_Label, Word64, Word64) -> String
forall {a}. Show a => a -> String
show (Word64
a,NASM_Label
label,Word64
a0,Word64
offset) -- error "TODO msut be a?"-- (a,section_label segment section a0, offset)
      Maybe (String, String, String, Word64, Word64)
Nothing -> (Word64
a,NASM_Label
label,c
0)
  replace_macro_names (Word64, NASM_Label, c)
x = (Word64, NASM_Label, c)
x
 


-- | convert a list of basic blocks to NASM instructions
-- Note that the order dictates if additional jumps need to be inserted
cfg_blocks_to_NASM :: BinaryClass bin => LiftedC bin -> Word64 -> CFG -> [Int] -> [(Int, [NASM_Line])]
cfg_blocks_to_NASM :: forall bin.
BinaryClass bin =>
LiftedC bin -> Word64 -> CFG -> [Int] -> [(Int, [NASM_Line])]
cfg_blocks_to_NASM LiftedC bin
l Word64
entry CFG
cfg []                             = []
cfg_blocks_to_NASM LiftedC bin
l Word64
entry CFG
cfg [Int
blockID0]                     = [(Int
blockID0,LiftedC bin -> Word64 -> CFG -> Int -> Maybe Int -> [NASM_Line]
forall bin.
BinaryClass bin =>
LiftedC bin -> Word64 -> CFG -> Int -> Maybe Int -> [NASM_Line]
cfg_block_to_NASM LiftedC bin
l Word64
entry CFG
cfg Int
blockID0 (Maybe Int -> [NASM_Line]) -> Maybe Int -> [NASM_Line]
forall a b. (a -> b) -> a -> b
$ Maybe Int
forall a. Maybe a
Nothing)]
cfg_blocks_to_NASM LiftedC bin
l Word64
entry CFG
cfg (Int
blockID0:blocks :: [Int]
blocks@(Int
blockID1:[Int]
_)) = (Int
blockID0,LiftedC bin -> Word64 -> CFG -> Int -> Maybe Int -> [NASM_Line]
forall bin.
BinaryClass bin =>
LiftedC bin -> Word64 -> CFG -> Int -> Maybe Int -> [NASM_Line]
cfg_block_to_NASM LiftedC bin
l Word64
entry CFG
cfg Int
blockID0 (Maybe Int -> [NASM_Line]) -> Maybe Int -> [NASM_Line]
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just Int
blockID1) (Int, [NASM_Line]) -> [(Int, [NASM_Line])] -> [(Int, [NASM_Line])]
forall a. a -> [a] -> [a]
: LiftedC bin -> Word64 -> CFG -> [Int] -> [(Int, [NASM_Line])]
forall bin.
BinaryClass bin =>
LiftedC bin -> Word64 -> CFG -> [Int] -> [(Int, [NASM_Line])]
cfg_blocks_to_NASM LiftedC bin
l Word64
entry CFG
cfg [Int]
blocks



-- | convert a single basic block to NASM instructions
-- A block is translated to a header and its instructions
cfg_block_to_NASM :: BinaryClass bin => LiftedC bin -> Word64 -> CFG -> Int -> Maybe Int -> [NASM_Line]
cfg_block_to_NASM :: forall bin.
BinaryClass bin =>
LiftedC bin -> Word64 -> CFG -> Int -> Maybe Int -> [NASM_Line]
cfg_block_to_NASM l :: LiftedC bin
l@(bin
bin,Config
_,L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue
l0) Word64
entry CFG
cfg Int
blockID Maybe Int
blockID1 = NASM_Line
block_header NASM_Line -> [NASM_Line] -> [NASM_Line]
forall a. a -> [a] -> [a]
: [NASM_Line]
mk_block
 where
  -- header
  block_header :: NASM_Line
block_header          = Int -> String -> NASM_Line
NASM_Comment Int
0 (String -> NASM_Line) -> String -> NASM_Line
forall a b. (a -> b) -> a -> b
$ String
"Entry " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall {a}. Integral a => a -> String
showHex Word64
entry String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"; block " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall {a}. Show a => a -> String
show Int
blockID String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"; address " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall {a}. Integral a => a -> String
showHex (Instruction -> Word64
inAddress (Instruction -> Word64) -> Instruction -> Word64
forall a b. (a -> b) -> a -> b
$ [Instruction] -> Instruction
forall a. HasCallStack => [a] -> a
head [Instruction]
block_instrs)
  -- instructions: the label and the body
  mk_block :: [NASM_Line]
mk_block              = [NASM_Line]
block_label' [NASM_Line] -> [NASM_Line] -> [NASM_Line]
forall a. [a] -> [a] -> [a]
++ [NASM_Line] -> [NASM_Line]
insert_nop_if_empty [NASM_Line]
block_body

  -- the label
  block_label' :: [NASM_Line]
block_label'          = [NASM_Label -> NASM_Line
NASM_Label (NASM_Label -> NASM_Line) -> NASM_Label -> NASM_Line
forall a b. (a -> b) -> a -> b
$ LiftedC bin -> Word64 -> Word64 -> Int -> NASM_Label
forall {p} {p} {a} {b} {c}.
(Show p, Integral p, Num p, Eq p, BinaryClass a) =>
(a, b, c) -> p -> Word64 -> p -> NASM_Label
block_label LiftedC bin
l Word64
entry (Instruction -> Word64
inAddress (Instruction -> Word64) -> Instruction -> Word64
forall a b. (a -> b) -> a -> b
$ [Instruction] -> Instruction
forall a. HasCallStack => [a] -> a
head [Instruction]
block_instrs) Int
blockID] 
  -- the body:
  --   in case of a block ending in a jump table, instructions are inserted at beginning and end of the block
  --   in case of a block ending in an indirection resolved to a single target, translate the last instruction accordingly
  --   in case of a block ending in an unresolved indirection resolved to a single target, translate as normal but annotate
  --   in case of no indirection, translate normally but insert an extra jump to the next block if neccessary
  block_body :: [NASM_Line]
block_body
    | [Instruction]
block_instrs [Instruction] -> [Instruction] -> Bool
forall a. Eq a => a -> a -> Bool
== [] = [Instruction] -> [NASM_Line]
mk_block_instrs [Instruction]
block_instrs [NASM_Line] -> [NASM_Line] -> [NASM_Line]
forall a. [a] -> [a] -> [a]
++ [Instruction] -> [NASM_Line]
block_end [Instruction]
block_instrs
    | Bool
otherwise =
      case Int -> IntMap Indirections -> Maybe Indirections
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ Instruction -> Word64
inAddress (Instruction -> Word64) -> Instruction -> Word64
forall a b. (a -> b) -> a -> b
$ [Instruction] -> Instruction
forall a. HasCallStack => [a] -> a
last [Instruction]
block_instrs) (IntMap Indirections -> Maybe Indirections)
-> IntMap Indirections -> Maybe Indirections
forall a b. (a -> b) -> a -> b
$ L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue
-> IntMap Indirections
forall pred finit v. L0 pred finit v -> IntMap Indirections
l0_indirections L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue
l0 of
        Maybe Indirections
Nothing -> [Instruction] -> [NASM_Line]
mk_block_instrs [Instruction]
block_instrs [NASM_Line] -> [NASM_Line] -> [NASM_Line]
forall a. [a] -> [a] -> [a]
++ [Instruction] -> [NASM_Line]
block_end [Instruction]
block_instrs
        Just Indirections
inds -> Indirections -> [NASM_Line]
block_body_with_indirection Indirections
inds

  block_body_with_indirection :: Indirections -> [NASM_Line]
block_body_with_indirection Indirections
inds =
    case (Indirection -> Bool)
-> [Indirection] -> ([Indirection], [Indirection])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Indirection -> Bool
isJumpTable ([Indirection] -> ([Indirection], [Indirection]))
-> [Indirection] -> ([Indirection], [Indirection])
forall a b. (a -> b) -> a -> b
$ Indirections -> [Indirection]
forall a. Set a -> [a]
S.toList Indirections
inds of
      ([Indirection
t],[Indirection]
_) -> Indirection -> [NASM_Line]
block_body_with_jump_table Indirection
t
      ([],[Indirection]
inds) -> if Indirection
Indirection_Unresolved Indirection -> [Indirection] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Indirection]
inds then [NASM_Line]
block_body_with_unresolved else [Indirection] -> [NASM_Line]
block_body_with_resolved [Indirection]
inds

  block_body_with_jump_table :: Indirection -> [NASM_Line]
block_body_with_jump_table (Indirection_JumpTable (tbl :: JumpTable
tbl@(JumpTable Operand
index Int
_ Operand
_ IntMap Word64
_))) =
    let ByteSize Int
si = Operand -> ByteSize
operand_size Operand
index
        reg :: Register
reg  = Register -> Int -> Register
forall {a}. (Eq a, Num a, Show a) => Register -> a -> Register
reg_of_size ([Register] -> [Instruction] -> Register
find_unused_register [Register]
register_set [Instruction]
block_instrs) Int
si
        reg' :: Register
reg' = Register -> Integer -> Register
forall {a}. (Eq a, Num a, Show a) => Register -> a -> Register
reg_of_size ([Register] -> [Instruction] -> Register
find_unused_register [ Register
r | Register
r <- [Register]
register_set, Register -> Register
real_reg Register
r Register -> Register -> Bool
forall a. Eq a => a -> a -> Bool
/= Register -> Register
real_reg Register
reg] [Instruction]
block_instrs) Integer
8 in
      JumpTable -> Register -> Register -> Instruction -> [NASM_Line]
jmp_table_init JumpTable
tbl Register
reg Register
reg' ([Instruction] -> Instruction
forall a. HasCallStack => [a] -> a
last [Instruction]
block_instrs) [NASM_Line] -> [NASM_Line] -> [NASM_Line]
forall a. [a] -> [a] -> [a]
++ [Instruction] -> [NASM_Line]
mk_block_instrs ([Instruction] -> [Instruction]
forall a. HasCallStack => [a] -> [a]
init [Instruction]
block_instrs) [NASM_Line] -> [NASM_Line] -> [NASM_Line]
forall a. [a] -> [a] -> [a]
++ JumpTable -> Register -> Register -> Instruction -> [NASM_Line]
jmp_table_end JumpTable
tbl Register
reg Register
reg' ([Instruction] -> Instruction
forall a. HasCallStack => [a] -> a
last [Instruction]
block_instrs)

  block_body_with_unresolved :: [NASM_Line]
block_body_with_unresolved = [Instruction] -> [NASM_Line]
mk_block_instrs [Instruction]
block_instrs [NASM_Line] -> [NASM_Line] -> [NASM_Line]
forall a. [a] -> [a] -> [a]
++ [NASM_Line]
unresolved_end [NASM_Line] -> [NASM_Line] -> [NASM_Line]
forall a. [a] -> [a] -> [a]
++ [Instruction] -> [NASM_Line]
block_end [Instruction]
block_instrs

  block_body_with_resolved :: [Indirection] -> [NASM_Line]
block_body_with_resolved [Indirection]
inds = 
    let trgts :: [ResolvedJumpTarget]
trgts = [ResolvedJumpTarget] -> [ResolvedJumpTarget]
forall a. Eq a => [a] -> [a]
nub ([ResolvedJumpTarget] -> [ResolvedJumpTarget])
-> [ResolvedJumpTarget] -> [ResolvedJumpTarget]
forall a b. (a -> b) -> a -> b
$ (Indirection -> ResolvedJumpTarget)
-> [Indirection] -> [ResolvedJumpTarget]
forall a b. (a -> b) -> [a] -> [b]
map Indirection -> ResolvedJumpTarget
get_resolved_target [Indirection]
inds in
      [Instruction] -> [NASM_Line]
mk_block_instrs ([Instruction] -> [Instruction]
forall a. HasCallStack => [a] -> [a]
init [Instruction]
block_instrs) [NASM_Line] -> [NASM_Line] -> [NASM_Line]
forall a. [a] -> [a] -> [a]
++ [ResolvedJumpTarget] -> Instruction -> [NASM_Line]
resolved_jump [ResolvedJumpTarget]
trgts ([Instruction] -> Instruction
forall a. HasCallStack => [a] -> a
last [Instruction]
block_instrs) [NASM_Line] -> [NASM_Line] -> [NASM_Line]
forall a. [a] -> [a] -> [a]
++ [Instruction] -> [NASM_Line]
block_end [Instruction]
block_instrs


  insert_nop_if_empty :: [NASM_Line] -> [NASM_Line]
insert_nop_if_empty [] = [NASM_Instruction -> NASM_Line
NASM_Line (NASM_Instruction -> NASM_Line) -> NASM_Instruction -> NASM_Line
forall a b. (a -> b) -> a -> b
$ Opcode -> [NASM_Operand] -> NASM_Instruction
mk_nasm_instr Opcode
NOP [] NASM_Instruction -> String -> NASM_Instruction
`withComment` String
"NOP inserted"]
  insert_nop_if_empty [NASM_Line]
b  = [NASM_Line]
b

  isJumpTable :: Indirection -> Bool
isJumpTable (Indirection_JumpTable JumpTable
_) = Bool
True
  isJumpTable Indirection
_ = Bool
False

  get_resolved_target :: Indirection -> ResolvedJumpTarget
get_resolved_target (Indirection_Resolved ResolvedJumpTarget
trgt) = ResolvedJumpTarget
trgt 


  -- make a block of regular non-control-flow instructions
  mk_block_instrs :: [Instruction] -> [NASM_Line]
mk_block_instrs [Instruction]
instrs = (Instruction -> [NASM_Line]) -> [Instruction] -> [NASM_Line]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (LiftedC bin -> Word64 -> CFG -> Int -> Instruction -> [NASM_Line]
forall {bin}.
BinaryClass bin =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> Word64 -> CFG -> Int -> Instruction -> [NASM_Line]
instr_to_NASM LiftedC bin
l Word64
entry CFG
cfg Int
blockID) ([Instruction] -> [NASM_Line]) -> [Instruction] -> [NASM_Line]
forall a b. (a -> b) -> a -> b
$ [Instruction] -> [Instruction]
filter_unnecessary_jumps [Instruction]
instrs

  -- for a normal (non-indirection) block, see if we need to insert an additional jump to the next block
  -- Necessary when that next block is not the next to be translated.
  block_end :: [Instruction] -> [NASM_Line]
block_end [Instruction]
instrs
    | [Instruction]
instrs [Instruction] -> [Instruction] -> Bool
forall a. Eq a => a -> a -> Bool
== [] = []
    | Opcode -> Bool
is_proper_block_end_instruction (Instruction -> Opcode
inOperation (Instruction -> Opcode) -> Instruction -> Opcode
forall a b. (a -> b) -> a -> b
$ [Instruction] -> Instruction
forall a. HasCallStack => [a] -> a
last [Instruction]
instrs) = []
    --  | blockID1 /= Nothing && (IM.lookup blockID (cfg_edges cfg) == Just (IS.singleton $ fromJust blockID1) = []
    | Bool
otherwise = [NASM_Line]
mk_extra_jmp


  -- A jump table is implemented (TODO more comments)
  jmp_table_init :: JumpTable -> Register -> Register -> Instruction -> [NASM_Line]
jmp_table_init t :: JumpTable
t@(JumpTable Operand
index Int
bound Operand
trgt IntMap Word64
tbl) Register
reg Register
reg' Instruction
i =
    let (NASM_Operand
trgt_str,Annot
annot) = LiftedC bin
-> Word64
-> CFG
-> Instruction
-> Bool
-> Operand
-> (NASM_Operand, Annot)
forall {bin} {t}.
(BinaryClass bin, Integral t) =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> t
-> CFG
-> Instruction
-> Bool
-> Operand
-> (NASM_Operand, Annot)
operand_to_NASM LiftedC bin
l Word64
entry CFG
cfg Instruction
empty_instr Bool
False Operand
index in
      [ Int -> String -> NASM_Line
NASM_Comment Int
2 (String -> NASM_Line) -> String -> NASM_Line
forall a b. (a -> b) -> a -> b
$ String
"Resolved indirection:"
      , Int -> String -> NASM_Line
NASM_Comment Int
2 (String -> NASM_Line) -> String -> NASM_Line
forall a b. (a -> b) -> a -> b
$ JumpTable -> String
forall {a}. Show a => a -> String
show JumpTable
t
      , NASM_Instruction -> NASM_Line
NASM_Line (NASM_Instruction -> NASM_Line) -> NASM_Instruction -> NASM_Line
forall a b. (a -> b) -> a -> b
$ Opcode -> [NASM_Operand] -> NASM_Instruction
mk_nasm_instr Opcode
MOV  [NASM_SizeDir -> NASM_Label -> NASM_Operand
label_to_mem_operand (Int
8,Bool
False) (NASM_Label -> NASM_Operand) -> NASM_Label -> NASM_Operand
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Integer -> NASM_Label
forall {a} {a} {a}.
(Integral a, Integral a, Num a, Eq a) =>
a -> a -> a -> NASM_Label
label_jump_table_temp_storage Word64
entry (Instruction -> Word64
inAddress Instruction
i) Integer
0, Register -> NASM_Operand
NASM_Operand_Reg (Register -> Register
real_reg Register
reg)]
      , NASM_Instruction -> NASM_Line
NASM_Line (NASM_Instruction -> NASM_Line) -> NASM_Instruction -> NASM_Line
forall a b. (a -> b) -> a -> b
$ Opcode -> [NASM_Operand] -> NASM_Instruction
mk_nasm_instr Opcode
MOV  [NASM_SizeDir -> NASM_Label -> NASM_Operand
label_to_mem_operand (Int
8,Bool
False) (NASM_Label -> NASM_Operand) -> NASM_Label -> NASM_Operand
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Integer -> NASM_Label
forall {a} {a} {a}.
(Integral a, Integral a, Num a, Eq a) =>
a -> a -> a -> NASM_Label
label_jump_table_temp_storage Word64
entry (Instruction -> Word64
inAddress Instruction
i) Integer
1, Register -> NASM_Operand
NASM_Operand_Reg (Register -> Register
real_reg Register
reg')]
      , NASM_Instruction -> NASM_Line
NASM_Line (NASM_Instruction -> NASM_Line) -> NASM_Instruction -> NASM_Line
forall a b. (a -> b) -> a -> b
$ Opcode -> [NASM_Operand] -> NASM_Instruction
mk_nasm_instr Opcode
MOV  [Register -> NASM_Operand
NASM_Operand_Reg Register
reg, NASM_Operand
trgt_str] NASM_Instruction -> Annot -> NASM_Instruction
`withAnnot` Annot
annot
      ]
      [NASM_Line] -> [NASM_Line] -> [NASM_Line]
forall a. [a] -> [a] -> [a]
++
      (if Register -> ByteSize
regSize Register
reg ByteSize -> ByteSize -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> ByteSize
ByteSize Int
4 then [NASM_Instruction -> NASM_Line
NASM_Line (NASM_Instruction -> NASM_Line) -> NASM_Instruction -> NASM_Line
forall a b. (a -> b) -> a -> b
$ Opcode -> [NASM_Operand] -> NASM_Instruction
mk_nasm_instr Opcode
MOVZX [Register -> NASM_Operand
NASM_Operand_Reg (Register -> NASM_Operand) -> Register -> NASM_Operand
forall a b. (a -> b) -> a -> b
$ Register -> Integer -> Register
forall {a}. (Eq a, Num a, Show a) => Register -> a -> Register
reg_of_size (Register -> Register
real_reg Register
reg) Integer
4, Register -> NASM_Operand
NASM_Operand_Reg Register
reg]] else [])
      [NASM_Line] -> [NASM_Line] -> [NASM_Line]
forall a. [a] -> [a] -> [a]
++
      [ Int -> String -> NASM_Line
NASM_Comment Int
2 (String -> NASM_Line) -> String -> NASM_Line
forall a b. (a -> b) -> a -> b
$ String
"Start of block"  ]


  jmp_table_end :: JumpTable -> Register -> Register -> Instruction -> [NASM_Line]
jmp_table_end t :: JumpTable
t@(JumpTable Operand
index Int
bound Operand
trgt IntMap Word64
tbl) Register
reg Register
reg' Instruction
last_instr =
    let (NASM_Operand
trgt_str,Annot
annot) = LiftedC bin
-> Word64
-> CFG
-> Instruction
-> Bool
-> Operand
-> (NASM_Operand, Annot)
forall {bin} {t}.
(BinaryClass bin, Integral t) =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> t
-> CFG
-> Instruction
-> Bool
-> Operand
-> (NASM_Operand, Annot)
operand_to_NASM LiftedC bin
l Word64
entry CFG
cfg Instruction
empty_instr Bool
False Operand
trgt 
        a_end :: Word64
a_end            = Instruction -> Word64
inAddress Instruction
last_instr in
      [ Int -> String -> NASM_Line
NASM_Comment Int
2 (String -> NASM_Line) -> String -> NASM_Line
forall a b. (a -> b) -> a -> b
$ String
"End of block"
      , NASM_Instruction -> NASM_Line
NASM_Line (NASM_Instruction -> NASM_Line) -> NASM_Instruction -> NASM_Line
forall a b. (a -> b) -> a -> b
$ Opcode -> [NASM_Operand] -> NASM_Instruction
mk_nasm_instr Opcode
LEA [Register -> NASM_Operand
NASM_Operand_Reg Register
reg', NASM_Label -> NASM_Operand
label_to_eff_operand (NASM_Label -> NASM_Operand) -> NASM_Label -> NASM_Operand
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> NASM_Label
forall {a} {a}. (Integral a, Integral a) => a -> a -> NASM_Label
label_jump_table_redirect_data Word64
entry Word64
a_end ]
      , NASM_Instruction -> NASM_Line
NASM_Line (NASM_Instruction -> NASM_Line) -> NASM_Instruction -> NASM_Line
forall a b. (a -> b) -> a -> b
$ Opcode -> [NASM_Operand] -> NASM_Instruction
mk_nasm_instr Opcode
LEA [Register -> NASM_Operand
NASM_Operand_Reg Register
reg', NASM_Address -> NASM_Operand
NASM_Operand_EffectiveAddress (NASM_Address -> NASM_Operand) -> NASM_Address -> NASM_Operand
forall a b. (a -> b) -> a -> b
$ NASM_Address_Computation -> NASM_Address
NASM_Addr_Compute (NASM_Address_Computation -> NASM_Address)
-> NASM_Address_Computation -> NASM_Address
forall a b. (a -> b) -> a -> b
$ NASM_Address_Computation
empty_address {nasm_base = Just reg', nasm_index = Just (reg_of_size (real_reg reg) 8), nasm_scale = 8} ]
      , NASM_Instruction -> NASM_Line
NASM_Line (NASM_Instruction -> NASM_Line) -> NASM_Instruction -> NASM_Line
forall a b. (a -> b) -> a -> b
$ Opcode -> [NASM_Operand] -> NASM_Instruction
mk_nasm_instr Opcode
MOV [NASM_Operand
trgt_str, NASM_SizeDir -> NASM_Address -> NASM_Operand
NASM_Operand_Memory (Int
8,Bool
True) (NASM_Address -> NASM_Operand) -> NASM_Address -> NASM_Operand
forall a b. (a -> b) -> a -> b
$ NASM_Address_Computation -> NASM_Address
NASM_Addr_Compute (NASM_Address_Computation -> NASM_Address)
-> NASM_Address_Computation -> NASM_Address
forall a b. (a -> b) -> a -> b
$ NASM_Address_Computation
empty_address {nasm_base = Just reg' }] NASM_Instruction -> Annot -> NASM_Instruction
`withAnnot` Annot
annot
      , NASM_Instruction -> NASM_Line
NASM_Line (NASM_Instruction -> NASM_Line) -> NASM_Instruction -> NASM_Line
forall a b. (a -> b) -> a -> b
$ Opcode -> [NASM_Operand] -> NASM_Instruction
mk_nasm_instr Opcode
MOV [Register -> NASM_Operand
NASM_Operand_Reg (Register -> Register
real_reg Register
reg), NASM_SizeDir -> NASM_Label -> NASM_Operand
label_to_mem_operand (Int
8,Bool
False) (NASM_Label -> NASM_Operand) -> NASM_Label -> NASM_Operand
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Integer -> NASM_Label
forall {a} {a} {a}.
(Integral a, Integral a, Num a, Eq a) =>
a -> a -> a -> NASM_Label
label_jump_table_temp_storage Word64
entry Word64
a_end Integer
0 ]
      , NASM_Instruction -> NASM_Line
NASM_Line (NASM_Instruction -> NASM_Line) -> NASM_Instruction -> NASM_Line
forall a b. (a -> b) -> a -> b
$ Opcode -> [NASM_Operand] -> NASM_Instruction
mk_nasm_instr Opcode
MOV [Register -> NASM_Operand
NASM_Operand_Reg (Register -> Register
real_reg Register
reg'), NASM_SizeDir -> NASM_Label -> NASM_Operand
label_to_mem_operand (Int
8,Bool
False) (NASM_Label -> NASM_Operand) -> NASM_Label -> NASM_Operand
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Integer -> NASM_Label
forall {a} {a} {a}.
(Integral a, Integral a, Num a, Eq a) =>
a -> a -> a -> NASM_Label
label_jump_table_temp_storage Word64
entry Word64
a_end Integer
1 ]
      , Int -> String -> NASM_Line
NASM_Comment Int
2 (String -> NASM_Line) -> String -> NASM_Line
forall a b. (a -> b) -> a -> b
$ String
"Executing resolved indirect jump"
      , NASM_Label -> NASM_Line
NASM_Label (NASM_Label -> NASM_Line) -> NASM_Label -> NASM_Line
forall a b. (a -> b) -> a -> b
$ LiftedC bin -> Word64 -> Word64 -> Int -> NASM_Label
forall {p} {p} {a} {b} {c}.
(Show p, Integral p, BinaryClass a, Num p, Eq p) =>
(a, b, c) -> p -> Word64 -> p -> NASM_Label
dontcare_label LiftedC bin
l Word64
entry Word64
a_end Int
blockID
      ]
      [NASM_Line] -> [NASM_Line] -> [NASM_Line]
forall a. [a] -> [a] -> [a]
++
      LiftedC bin -> Word64 -> CFG -> Int -> Instruction -> [NASM_Line]
forall {bin}.
BinaryClass bin =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> Word64 -> CFG -> Int -> Instruction -> [NASM_Line]
mk_jmp_call_instr LiftedC bin
l Word64
entry CFG
cfg Int
blockID Instruction
last_instr



  -- A resolved jump to a single known target
  resolved_jump :: [ResolvedJumpTarget] -> Instruction -> [NASM_Line]
resolved_jump [External String
f] (Instruction Word64
addr [Prefix]
pre Opcode
op Maybe Operand
Nothing [Operand]
ops Int
annot) =
    [ Int -> String -> NASM_Line
NASM_Comment Int
2 (String -> NASM_Line) -> String -> NASM_Line
forall a b. (a -> b) -> a -> b
$ String
"Resolved indirection: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Operand -> String
forall {a}. Show a => a -> String
show ([Operand] -> Operand
forall a. HasCallStack => [a] -> a
head [Operand]
ops) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" --> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f 
    , NASM_Instruction -> NASM_Line
NASM_Line (NASM_Instruction -> NASM_Line) -> NASM_Instruction -> NASM_Line
forall a b. (a -> b) -> a -> b
$ Maybe Prefix
-> Maybe Opcode
-> [NASM_Operand]
-> String
-> Annot
-> NASM_Instruction
NASM_Instruction ([Prefix] -> Maybe Prefix
forall {t :: * -> *}. Foldable t => t Prefix -> Maybe Prefix
mk_NASM_prefix [Prefix]
pre) (Opcode -> Maybe Opcode
opcode_to_NASM Opcode
op) [NASM_Address -> NASM_Operand
NASM_Operand_Address (NASM_Address -> NASM_Operand) -> NASM_Address -> NASM_Operand
forall a b. (a -> b) -> a -> b
$ Symbol -> NASM_Address
NASM_Addr_Symbol (Symbol -> NASM_Address) -> Symbol -> NASM_Address
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Symbol
PointerToLabel String
f Bool
True] String
"" []]
  resolved_jump [ImmediateAddress Word64
imm] i :: Instruction
i@(Instruction Word64
addr [Prefix]
pre Opcode
op Maybe Operand
Nothing [Operand]
ops Int
annot) = 
    [ Int -> String -> NASM_Line
NASM_Comment Int
2 (String -> NASM_Line) -> String -> NASM_Line
forall a b. (a -> b) -> a -> b
$ String
"Resolved indirection: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Operand -> String
forall {a}. Show a => a -> String
show ([Operand] -> Operand
forall a. HasCallStack => [a] -> a
head [Operand]
ops) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" --> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall {a}. Integral a => a -> String
showHex Word64
imm ]
    [NASM_Line] -> [NASM_Line] -> [NASM_Line]
forall a. [a] -> [a] -> [a]
++
    LiftedC bin -> Word64 -> CFG -> Int -> Instruction -> [NASM_Line]
forall {bin}.
BinaryClass bin =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> Word64 -> CFG -> Int -> Instruction -> [NASM_Line]
mk_jmp_call_instr LiftedC bin
l Word64
entry CFG
cfg Int
blockID Instruction
i
  resolved_jump [ResolvedJumpTarget]
trgts i :: Instruction
i@(Instruction Word64
addr [Prefix]
pre Opcode
op Maybe Operand
Nothing [Operand]
ops Int
annot) =
    [ Int -> String -> NASM_Line
NASM_Comment Int
2 (String -> NASM_Line) -> String -> NASM_Line
forall a b. (a -> b) -> a -> b
$ String
"Resolved indirection: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Operand -> String
forall {a}. Show a => a -> String
show ([Operand] -> Operand
forall a. HasCallStack => [a] -> a
head [Operand]
ops) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" --> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [ResolvedJumpTarget] -> String
forall {a}. Show a => a -> String
show [ResolvedJumpTarget]
trgts ]
    [NASM_Line] -> [NASM_Line] -> [NASM_Line]
forall a. [a] -> [a] -> [a]
++
    LiftedC bin -> Word64 -> CFG -> Int -> Instruction -> [NASM_Line]
forall {bin}.
BinaryClass bin =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> Word64 -> CFG -> Int -> Instruction -> [NASM_Line]
instr_to_NASM LiftedC bin
l Word64
entry CFG
cfg Int
blockID Instruction
i


  -- An unresolved indirection annotation
  unresolved_end :: [NASM_Line]
unresolved_end = [ Int -> String -> NASM_Line
NASM_Comment Int
2 (String -> NASM_Line) -> String -> NASM_Line
forall a b. (a -> b) -> a -> b
$ String
"Unresolved indirection" ]

  filter_unnecessary_jumps :: [Instruction] -> [Instruction]
filter_unnecessary_jumps [Instruction]
instrs
    | [Instruction]
instrs [Instruction] -> [Instruction] -> Bool
forall a. Eq a => a -> a -> Bool
== [] = []
    | Bool
otherwise    = ((Instruction -> Bool) -> [Instruction] -> [Instruction]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Instruction -> Bool) -> Instruction -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Opcode -> Bool
isJump (Opcode -> Bool) -> (Instruction -> Opcode) -> Instruction -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Instruction -> Opcode
inOperation) ([Instruction] -> [Instruction]) -> [Instruction] -> [Instruction]
forall a b. (a -> b) -> a -> b
$ [Instruction] -> [Instruction]
forall a. HasCallStack => [a] -> [a]
init [Instruction]
instrs) [Instruction] -> [Instruction] -> [Instruction]
forall a. [a] -> [a] -> [a]
++ [[Instruction] -> Instruction
forall a. HasCallStack => [a] -> a
last [Instruction]
instrs]
  is_proper_block_end_instruction :: Opcode -> Bool
is_proper_block_end_instruction Opcode
i = Opcode -> Bool
isRet Opcode
i Bool -> Bool -> Bool
|| Opcode -> Bool
isJump Opcode
i Bool -> Bool -> Bool
|| Opcode -> Bool
isHalt Opcode
i

  Just [Instruction]
block_instrs = Int -> IntMap [Instruction] -> Maybe [Instruction]
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
blockID (IntMap [Instruction] -> Maybe [Instruction])
-> IntMap [Instruction] -> Maybe [Instruction]
forall a b. (a -> b) -> a -> b
$ CFG -> IntMap [Instruction]
cfg_instrs CFG
cfg

  empty_instr :: Instruction
  empty_instr :: Instruction
empty_instr = Word64
-> [Prefix]
-> Opcode
-> Maybe Operand
-> [Operand]
-> Int
-> Instruction
Instruction Word64
0 [] Opcode
NOP Maybe Operand
forall a. Maybe a
Nothing [] Int
0

  mk_extra_jmp :: [NASM_Line]
mk_extra_jmp =
    case LiftedC bin -> Maybe Instruction -> NextRips
forall bin pred finit v.
(BinaryClass bin, Eq pred) =>
Lifting bin pred finit v -> Maybe Instruction -> NextRips
next_rips LiftedC bin
l (Instruction -> Maybe Instruction
forall a. a -> Maybe a
Just (Instruction -> Maybe Instruction)
-> Instruction -> Maybe Instruction
forall a b. (a -> b) -> a -> b
$ [Instruction] -> Instruction
forall a. HasCallStack => [a] -> a
last [Instruction]
block_instrs) of -- TODO assumes fall through is last/second
      NextRips
UnresolvedTarget -> []
      JustRips []      -> Instruction -> [NASM_Line]
mk_extra_hlt (Instruction -> [NASM_Line]) -> Instruction -> [NASM_Line]
forall a b. (a -> b) -> a -> b
$ [Instruction] -> Instruction
forall a. HasCallStack => [a] -> a
last [Instruction]
block_instrs
      JustRips [Word64
a]     -> Word64 -> [NASM_Line]
forall {a}. Integral a => a -> [NASM_Line]
mk_extra_jump_maybe Word64
a
      JustRips [Word64
_,Word64
a]   -> Word64 -> [NASM_Line]
forall {a}. Integral a => a -> [NASM_Line]
mk_extra_jump_maybe Word64
a
      NextRips
Terminal         -> Instruction -> [NASM_Line]
mk_extra_hlt (Instruction -> [NASM_Line]) -> Instruction -> [NASM_Line]
forall a b. (a -> b) -> a -> b
$ [Instruction] -> Instruction
forall a. HasCallStack => [a] -> a
last [Instruction]
block_instrs
      NextRips
x                -> [Int -> String -> NASM_Line
NASM_Comment Int
0 (String -> NASM_Line) -> String -> NASM_Line
forall a b. (a -> b) -> a -> b
$ String
"JMP ERROR CANNOT DETERMINE NEXT BLOCK" String -> String -> String
forall a. [a] -> [a] -> [a]
++ NextRips -> String
forall {a}. Show a => a -> String
show NextRips
x]

  mk_extra_hlt :: Instruction -> [NASM_Line]
mk_extra_hlt Instruction
last_instr
    | Opcode -> Bool
isCall (Instruction -> Opcode
inOperation Instruction
last_instr) =
      let a :: Word64
a = Instruction -> Word64
inAddress Instruction
last_instr Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ Instruction -> Int
inSize Instruction
last_instr) in
        if LiftedC bin -> Word64 -> Bool
forall {a} {b} {pred} {finit} {v}.
(a, b, L0 pred finit v) -> Word64 -> Bool
is_start_of_block_anywhere LiftedC bin
l Word64
a then
          []
        else  
          let label :: NASM_Label
label = LiftedC bin -> Word64 -> Word64 -> Int -> NASM_Label
forall {p} {p} {a} {b} {c}.
(Show p, Integral p, BinaryClass a, Num p, Eq p) =>
(a, b, c) -> p -> Word64 -> p -> NASM_Label
halting_label LiftedC bin
l Word64
entry Word64
a Int
blockID in
            [ 
              NASM_Label -> NASM_Line
NASM_Label NASM_Label
label,
              NASM_Instruction -> NASM_Line
NASM_Line (NASM_Instruction -> NASM_Line) -> NASM_Instruction -> NASM_Line
forall a b. (a -> b) -> a -> b
$ Opcode -> [NASM_Operand] -> NASM_Instruction
mk_nasm_instr Opcode
HLT [] NASM_Instruction -> String -> NASM_Instruction
`withComment` String
"should never be reached" NASM_Instruction -> Annot -> NASM_Instruction
`withAnnot` [(Word64
a,NASM_Label
label,Word64
0)]
            ]
    | Bool
otherwise = []

  mk_extra_jump_maybe :: a -> [NASM_Line]
mk_extra_jump_maybe a
a
    | Maybe Int
blockID1 Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Int
forall a. Maybe a
Nothing Bool -> Bool -> Bool
&& a -> Maybe a
forall a. a -> Maybe a
Just a
a Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
== CFG -> Int -> Maybe a
forall {b}. Num b => CFG -> Int -> Maybe b
start_address_of_block CFG
cfg (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Int
blockID1) = []
    | Bool
otherwise = [NASM_Instruction -> NASM_Line
NASM_Line (NASM_Instruction -> NASM_Line) -> NASM_Instruction -> NASM_Line
forall a b. (a -> b) -> a -> b
$ Opcode -> [NASM_Operand] -> NASM_Instruction
mk_nasm_instr Opcode
JMP [NASM_Address -> NASM_Operand
NASM_Operand_Address (NASM_Address -> NASM_Operand) -> NASM_Address -> NASM_Operand
forall a b. (a -> b) -> a -> b
$ (NASM_Address, Annot) -> NASM_Address
forall a b. (a, b) -> a
fst ((NASM_Address, Annot) -> NASM_Address)
-> (NASM_Address, Annot) -> NASM_Address
forall a b. (a -> b) -> a -> b
$ Maybe (NASM_Address, Annot) -> (NASM_Address, Annot)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (NASM_Address, Annot) -> (NASM_Address, Annot))
-> Maybe (NASM_Address, Annot) -> (NASM_Address, Annot)
forall a b. (a -> b) -> a -> b
$ LiftedC bin
-> Maybe (Int, CFG)
-> Bool
-> Word64
-> Maybe (NASM_Address, Annot)
forall bin.
BinaryClass bin =>
LiftedC bin
-> Maybe (Int, CFG)
-> Bool
-> Word64
-> Maybe (NASM_Address, Annot)
symbolize_immediate LiftedC bin
l ((Int, CFG) -> Maybe (Int, CFG)
forall a. a -> Maybe a
Just (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
entry,CFG
cfg)) Bool
False (Word64 -> Maybe (NASM_Address, Annot))
-> Word64 -> Maybe (NASM_Address, Annot)
forall a b. (a -> b) -> a -> b
$ a -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a] NASM_Instruction -> String -> NASM_Instruction
`withComment` String
"jump is inserted"]



start_address_of_block :: CFG -> Int -> Maybe b
start_address_of_block CFG
cfg Int
blockID = Word64 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> b) -> ([Instruction] -> Word64) -> [Instruction] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Instruction -> Word64
inAddress (Instruction -> Word64)
-> ([Instruction] -> Instruction) -> [Instruction] -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Instruction] -> Instruction
forall a. HasCallStack => [a] -> a
head ([Instruction] -> b) -> Maybe [Instruction] -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> IntMap [Instruction] -> Maybe [Instruction]
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
blockID (IntMap [Instruction] -> Maybe [Instruction])
-> IntMap [Instruction] -> Maybe [Instruction]
forall a b. (a -> b) -> a -> b
$ CFG -> IntMap [Instruction]
cfg_instrs CFG
cfg)

label_jump_table_temp_storage :: a -> a -> a -> NASM_Label
label_jump_table_temp_storage  a
entry a
a a
n = Word64 -> String -> NASM_Label
Label Word64
0 (String -> NASM_Label) -> String -> NASM_Label
forall a b. (a -> b) -> a -> b
$ String
"L_jmp_tbl_temp_storage_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall {a}. Integral a => a -> String
showHex a
entry String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall {a}. Integral a => a -> String
showHex a
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 then String
"_0" else String
"_1")
label_jump_table_redirect_data :: a -> a -> NASM_Label
label_jump_table_redirect_data a
entry a
a = Word64 -> String -> NASM_Label
Label Word64
0 (String -> NASM_Label) -> String -> NASM_Label
forall a b. (a -> b) -> a -> b
$ String
"L_jmp_tbl_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall {a}. Integral a => a -> String
showHex a
entry String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall {a}. Integral a => a -> String
showHex a
a


is_start_of_block_anywhere :: (a, b, L0 pred finit v) -> Word64 -> Bool
is_start_of_block_anywhere l :: (a, b, L0 pred finit v)
l@(a
bin,b
_,L0 pred finit v
l0) Word64
a =
  let cfgs :: [CFG]
cfgs   = IntMap CFG -> [CFG]
forall a. IntMap a -> [a]
IM.elems (IntMap CFG -> [CFG]) -> IntMap CFG -> [CFG]
forall a b. (a -> b) -> a -> b
$ L0 pred finit v -> IntMap CFG
forall pred finit v. L0 pred finit v -> IntMap CFG
l0_get_cfgs L0 pred finit v
l0
      blocks :: [[Instruction]]
blocks = (CFG -> [[Instruction]]) -> [CFG] -> [[Instruction]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (IntMap [Instruction] -> [[Instruction]]
forall a. IntMap a -> [a]
IM.elems (IntMap [Instruction] -> [[Instruction]])
-> (CFG -> IntMap [Instruction]) -> CFG -> [[Instruction]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFG -> IntMap [Instruction]
cfg_instrs) [CFG]
cfgs in
    ([Instruction] -> Bool) -> [[Instruction]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\[Instruction]
block -> Instruction -> Word64
inAddress ([Instruction] -> Instruction
forall a. HasCallStack => [a] -> a
head [Instruction]
block) Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
a) [[Instruction]]
blocks
  


-- | convert an instruction to a NASM instruction
instr_to_NASM :: (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> Word64 -> CFG -> Int -> Instruction -> [NASM_Line]
instr_to_NASM (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l Word64
entry CFG
cfg Int
blockID i :: Instruction
i@(Instruction Word64
addr [Prefix]
pre Opcode
op Maybe Operand
Nothing [Operand]
ops Int
annot)
 | Opcode
op Opcode -> Opcode -> Bool
forall a. Eq a => a -> a -> Bool
== Opcode
NOP                             = []
 | Opcode
op Opcode -> Opcode -> Bool
forall a. Eq a => a -> a -> Bool
== Opcode
ENDBR64                         = []
 | [Prefix] -> Opcode -> Bool
forall {p}. p -> Opcode -> Bool
no_ops [Prefix]
pre Opcode
op                         = [NASM_Instruction -> NASM_Line
NASM_Line (NASM_Instruction -> NASM_Line) -> NASM_Instruction -> NASM_Line
forall a b. (a -> b) -> a -> b
$ (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> Word64 -> CFG -> Instruction -> NASM_Instruction
forall {bin} {p}.
(BinaryClass bin, Integral p) =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> p -> CFG -> Instruction -> NASM_Instruction
mk_normal_instr (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l Word64
entry CFG
cfg (Instruction -> NASM_Instruction)
-> Instruction -> NASM_Instruction
forall a b. (a -> b) -> a -> b
$ Word64
-> [Prefix]
-> Opcode
-> Maybe Operand
-> [Operand]
-> Int
-> Instruction
Instruction Word64
addr [Prefix]
pre Opcode
op Maybe Operand
forall a. Maybe a
Nothing [] Int
annot]
 | Opcode -> Bool
is_cf Opcode
op                              = (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> Word64 -> CFG -> Int -> Instruction -> [NASM_Line]
forall {bin}.
BinaryClass bin =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> Word64 -> CFG -> Int -> Instruction -> [NASM_Line]
mk_jmp_call_instr (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l Word64
entry CFG
cfg Int
blockID Instruction
i
 | (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> Instruction -> [Operand] -> Bool
forall {t :: * -> *} {a} {b} {c}.
(Foldable t, BinaryClass a) =>
(a, b, c) -> Instruction -> t Operand -> Bool
some_operand_reads_GOT_entry (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l Instruction
i [Operand]
ops  = (NASM_Instruction -> NASM_Line)
-> [NASM_Instruction] -> [NASM_Line]
forall a b. (a -> b) -> [a] -> [b]
map NASM_Instruction -> NASM_Line
NASM_Line ([NASM_Instruction] -> [NASM_Line])
-> [NASM_Instruction] -> [NASM_Line]
forall a b. (a -> b) -> a -> b
$ (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> Word64 -> CFG -> Instruction -> [NASM_Instruction]
forall {a} {p}.
(BinaryClass a, Integral p) =>
(a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> p -> CFG -> Instruction -> [NASM_Instruction]
mk_GOT_entry_instr (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l Word64
entry CFG
cfg Instruction
i
 | Bool
otherwise                             = [NASM_Instruction -> NASM_Line
NASM_Line (NASM_Instruction -> NASM_Line) -> NASM_Instruction -> NASM_Line
forall a b. (a -> b) -> a -> b
$ (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> Word64 -> CFG -> Instruction -> NASM_Instruction
forall {bin} {p}.
(BinaryClass bin, Integral p) =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> p -> CFG -> Instruction -> NASM_Instruction
mk_normal_instr (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l Word64
entry CFG
cfg Instruction
i]
 where
  is_cf :: Opcode -> Bool
is_cf Opcode
op      = Opcode -> Bool
isCall Opcode
op Bool -> Bool -> Bool
|| Opcode -> Bool
isJump Opcode
op Bool -> Bool -> Bool
|| Opcode -> Bool
isCondJump Opcode
op
  no_ops :: p -> Opcode -> Bool
no_ops p
pre Opcode
op = Opcode
op Opcode -> [Opcode] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Opcode
STOSB,Opcode
STOSD,Opcode
STOSQ, Opcode
SCASB,Opcode
SCASD, Opcode
CMPSB] Bool -> Bool -> Bool
|| Opcode -> Bool
is_string_mov Opcode
op


  is_string_mov :: Opcode -> Bool
is_string_mov Opcode
op
    | Opcode
op Opcode -> [Opcode] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Opcode
MOVSB, Opcode
MOVSW, Opcode
MOVSD, Opcode
MOVSQ] =
      Bool -> Bool
not ([Operand] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Operand]
ops Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 Bool -> Bool -> Bool
&& (Operand -> ByteSize
operand_size ([Operand]
ops[Operand] -> Int -> Operand
forall a. HasCallStack => [a] -> Int -> a
!!Int
0) ByteSize -> ByteSize -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> ByteSize
ByteSize Int
16 Bool -> Bool -> Bool
|| Operand -> ByteSize
operand_size ([Operand]
ops[Operand] -> Int -> Operand
forall a. HasCallStack => [a] -> Int -> a
!!Int
1) ByteSize -> ByteSize -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> ByteSize
ByteSize Int
16))
      -- TODO
      --   REP MOVSQ QWORD PTR [RDI,8], QWORD PTR [RSI,8]
      --   MOVSD QWORD PTR [RSP+0x8],xmm0
    | Bool
otherwise = Bool
False


-- Make a normal instruction
mk_normal_instr :: (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> p -> CFG -> Instruction -> NASM_Instruction
mk_normal_instr (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l p
entry CFG
cfg i :: Instruction
i@(Instruction Word64
addr [Prefix]
pre Opcode
op Maybe Operand
Nothing [Operand]
ops Int
annot) = NASM_Instruction
mk_instr
 where
  mk_instr :: NASM_Instruction
mk_instr = Maybe Prefix
-> Maybe Opcode
-> [NASM_Operand]
-> String
-> Annot
-> NASM_Instruction
NASM_Instruction ([Prefix] -> Maybe Prefix
forall {t :: * -> *}. Foldable t => t Prefix -> Maybe Prefix
mk_NASM_prefix [Prefix]
pre) (Opcode -> Maybe Opcode
opcode_to_NASM Opcode
op) (((NASM_Operand, Annot) -> NASM_Operand)
-> [(NASM_Operand, Annot)] -> [NASM_Operand]
forall a b. (a -> b) -> [a] -> [b]
map (NASM_Operand, Annot) -> NASM_Operand
forall a b. (a, b) -> a
fst [(NASM_Operand, Annot)]
mk_ops) String
"" Annot
mk_annot
  mk_ops :: [(NASM_Operand, Annot)]
mk_ops = (Operand -> (NASM_Operand, Annot))
-> [Operand] -> [(NASM_Operand, Annot)]
forall a b. (a -> b) -> [a] -> [b]
map ((bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> p
-> CFG
-> Instruction
-> Bool
-> Operand
-> (NASM_Operand, Annot)
forall {bin} {t}.
(BinaryClass bin, Integral t) =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> t
-> CFG
-> Instruction
-> Bool
-> Operand
-> (NASM_Operand, Annot)
operand_to_NASM (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l p
entry CFG
cfg Instruction
i Bool
False) [Operand]
ops
  mk_annot :: Annot
mk_annot = [Annot] -> Annot
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Annot] -> Annot) -> [Annot] -> Annot
forall a b. (a -> b) -> a -> b
$ (Annot -> Bool) -> [Annot] -> [Annot]
forall a. (a -> Bool) -> [a] -> [a]
filter (Annot -> Annot -> Bool
forall a. Eq a => a -> a -> Bool
(/=) []) ([Annot] -> [Annot]) -> [Annot] -> [Annot]
forall a b. (a -> b) -> a -> b
$ ((NASM_Operand, Annot) -> Annot)
-> [(NASM_Operand, Annot)] -> [Annot]
forall a b. (a -> b) -> [a] -> [b]
map (NASM_Operand, Annot) -> Annot
forall a b. (a, b) -> b
snd [(NASM_Operand, Annot)]
mk_ops

-- Make a JUMP/CALL instruction
mk_jmp_call_instr :: BinaryClass bin => LiftedC bin -> Word64 -> CFG -> Int -> Instruction -> [NASM_Line]
mk_jmp_call_instr :: forall {bin}.
BinaryClass bin =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> Word64 -> CFG -> Int -> Instruction -> [NASM_Line]
mk_jmp_call_instr l :: LiftedC bin
l@(bin
bin,Config
_,L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue
l0) Word64
entry CFG
cfg Int
blockID i :: Instruction
i@(Instruction Word64
addr [Prefix]
pre Opcode
op Maybe Operand
Nothing [Operand
op1] Int
annot) =
  NASM_Line -> [NASM_Line]
add_label_if_terminating (NASM_Line -> [NASM_Line]) -> NASM_Line -> [NASM_Line]
forall a b. (a -> b) -> a -> b
$ ResolvedJumpTarget -> NASM_Line
use_jump_target (ResolvedJumpTarget -> NASM_Line)
-> ResolvedJumpTarget -> NASM_Line
forall a b. (a -> b) -> a -> b
$ bin -> Instruction -> ResolvedJumpTarget
forall bin.
BinaryClass bin =>
bin -> Instruction -> ResolvedJumpTarget
jump_target_for_instruction bin
bin Instruction
i
 where
  use_jump_target :: ResolvedJumpTarget -> NASM_Line
use_jump_target j :: ResolvedJumpTarget
j@(External String
sym)      = NASM_Instruction -> NASM_Line
NASM_Line (NASM_Instruction -> NASM_Line) -> NASM_Instruction -> NASM_Line
forall a b. (a -> b) -> a -> b
$ Maybe Prefix
-> Maybe Opcode
-> [NASM_Operand]
-> String
-> Annot
-> NASM_Instruction
NASM_Instruction Maybe Prefix
forall a. Maybe a
Nothing (Opcode -> Maybe Opcode
opcode_to_NASM Opcode
op) [NASM_Address -> NASM_Operand
NASM_Operand_Address (NASM_Address -> NASM_Operand) -> NASM_Address -> NASM_Operand
forall a b. (a -> b) -> a -> b
$ ResolvedJumpTarget -> NASM_Address
NASM_JumpTarget (ResolvedJumpTarget -> NASM_Address)
-> ResolvedJumpTarget -> NASM_Address
forall a b. (a -> b) -> a -> b
$ ResolvedJumpTarget
j] String
"" []
  use_jump_target j :: ResolvedJumpTarget
j@(ExternalDeref String
sym) = NASM_Instruction -> NASM_Line
NASM_Line (NASM_Instruction -> NASM_Line) -> NASM_Instruction -> NASM_Line
forall a b. (a -> b) -> a -> b
$ Maybe Prefix
-> Maybe Opcode
-> [NASM_Operand]
-> String
-> Annot
-> NASM_Instruction
NASM_Instruction Maybe Prefix
forall a. Maybe a
Nothing (Opcode -> Maybe Opcode
opcode_to_NASM Opcode
op) [NASM_Address -> NASM_Operand
NASM_Operand_Address (NASM_Address -> NASM_Operand) -> NASM_Address -> NASM_Operand
forall a b. (a -> b) -> a -> b
$ ResolvedJumpTarget -> NASM_Address
NASM_JumpTarget (ResolvedJumpTarget -> NASM_Address)
-> ResolvedJumpTarget -> NASM_Address
forall a b. (a -> b) -> a -> b
$ ResolvedJumpTarget
j] String
"PointerToObject" []
  use_jump_target (ImmediateAddress Word64
a') = 
        let (NASM_Operand
op1_str,Annot
annot) = LiftedC bin
-> Word64
-> CFG
-> Instruction
-> Bool
-> Operand
-> (NASM_Operand, Annot)
forall {bin} {t}.
(BinaryClass bin, Integral t) =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> t
-> CFG
-> Instruction
-> Bool
-> Operand
-> (NASM_Operand, Annot)
operand_to_NASM LiftedC bin
l Word64
entry CFG
cfg Instruction
i Bool
True (Immediate -> Operand
Op_Jmp (Immediate -> Operand) -> Immediate -> Operand
forall a b. (a -> b) -> a -> b
$ BitSize -> Word64 -> Immediate
Immediate (Int -> BitSize
BitSize Int
64) Word64
a') in
          NASM_Instruction -> NASM_Line
NASM_Line (NASM_Instruction -> NASM_Line) -> NASM_Instruction -> NASM_Line
forall a b. (a -> b) -> a -> b
$ Maybe Prefix
-> Maybe Opcode
-> [NASM_Operand]
-> String
-> Annot
-> NASM_Instruction
NASM_Instruction Maybe Prefix
forall a. Maybe a
Nothing (Opcode -> Maybe Opcode
opcode_to_NASM Opcode
op) [NASM_Operand
op1_str] String
"" Annot
annot
  use_jump_target ResolvedJumpTarget
Unresolved            =
    let (NASM_Operand
op1_str,Annot
annot) = LiftedC bin
-> Word64
-> CFG
-> Instruction
-> Bool
-> Operand
-> (NASM_Operand, Annot)
forall {bin} {t}.
(BinaryClass bin, Integral t) =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> t
-> CFG
-> Instruction
-> Bool
-> Operand
-> (NASM_Operand, Annot)
operand_to_NASM LiftedC bin
l Word64
entry CFG
cfg Instruction
i Bool
True Operand
op1 in
      NASM_Instruction -> NASM_Line
NASM_Line (NASM_Instruction -> NASM_Line) -> NASM_Instruction -> NASM_Line
forall a b. (a -> b) -> a -> b
$ Maybe Prefix
-> Maybe Opcode
-> [NASM_Operand]
-> String
-> Annot
-> NASM_Instruction
NASM_Instruction Maybe Prefix
forall a. Maybe a
Nothing (Opcode -> Maybe Opcode
opcode_to_NASM Opcode
op) [NASM_Operand
op1_str] String
"" Annot
annot


  add_label_if_terminating :: NASM_Line -> [NASM_Line]
add_label_if_terminating NASM_Line
label
    | LiftedC bin -> Instruction -> Bool
forall {bin} {pred} {finit} {v}.
(BinaryClass bin, Eq pred) =>
Lifting bin pred finit v -> Instruction -> Bool
is_terminal_call LiftedC bin
l Instruction
i = [NASM_Instruction -> NASM_Line
NASM_Line (NASM_Instruction -> NASM_Line) -> NASM_Instruction -> NASM_Line
forall a b. (a -> b) -> a -> b
$ Opcode -> [NASM_Operand] -> NASM_Instruction
mk_nasm_instr Opcode
NOP [], NASM_Label -> NASM_Line
NASM_Label (NASM_Label -> NASM_Line) -> NASM_Label -> NASM_Line
forall a b. (a -> b) -> a -> b
$ LiftedC bin -> Word64 -> Instruction -> Int -> NASM_Label
forall {p} {p} {a} {b} {c}.
(Show p, Integral p, BinaryClass a, Num p, Eq p) =>
(a, b, c) -> p -> Instruction -> p -> NASM_Label
terminating_label LiftedC bin
l Word64
entry Instruction
i Int
blockID, NASM_Line
label]
    | Bool
otherwise            = [NASM_Line
label]


is_terminal_call :: Lifting bin pred finit v -> Instruction -> Bool
is_terminal_call Lifting bin pred finit v
l Instruction
i
  | Opcode -> Bool
isCall (Instruction -> Opcode
inOperation Instruction
i) Bool -> Bool -> Bool
|| Opcode -> Bool
isJump (Instruction -> Opcode
inOperation Instruction
i) = 
    case Lifting bin pred finit v -> Instruction -> NextRips
forall bin pred finit v.
(BinaryClass bin, Eq pred) =>
Lifting bin pred finit v -> Instruction -> NextRips
resolve_call Lifting bin pred finit v
l Instruction
i of
      NextRips
Terminal    -> Bool
True
      NextRips
_           -> Bool
False
  | Bool
otherwise = Bool
False

-- Make an instruction with an operand reading a GOT entry
-- TODO MOV reg, [rip+imm] can be more efficient
mk_GOT_entry_instr :: (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> p -> CFG -> Instruction -> [NASM_Instruction]
mk_GOT_entry_instr (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l p
entry CFG
cfg i :: Instruction
i@(Instruction Word64
addr [Prefix]
pre Opcode
op Maybe Operand
Nothing [Operand]
ops Int
annot) = 
  let [Symbol
f] = [Symbol]
name_of_external_function
      r :: Register
r   = [Register] -> [Instruction] -> Register
find_unused_register [Register]
register_set [Instruction
i] in
    [ Register -> NASM_Instruction
mov_reg_to_temp Register
r
    , Register -> Symbol -> NASM_Instruction
lea_external_function Register
r Symbol
f
    , Register -> NASM_Instruction
the_actual_instr Register
r
    , Register -> NASM_Instruction
mov_temp_to_reg Register
r ]
 where
  mov_reg_to_temp :: Register -> NASM_Instruction
mov_reg_to_temp Register
r = Opcode -> [NASM_Operand] -> NASM_Instruction
mk_nasm_instr Opcode
MOV [ NASM_SizeDir -> NASM_Label -> NASM_Operand
label_to_mem_operand (Int
8,Bool
True) (NASM_Label -> NASM_Operand) -> NASM_Label -> NASM_Operand
forall a b. (a -> b) -> a -> b
$ Word64 -> String -> NASM_Label
Label Word64
0 String
"Ltemp_storage_foxdec", (NASM_Operand, Annot) -> NASM_Operand
forall a b. (a, b) -> a
fst ((NASM_Operand, Annot) -> NASM_Operand)
-> (NASM_Operand, Annot) -> NASM_Operand
forall a b. (a -> b) -> a -> b
$ (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> p
-> CFG
-> Instruction
-> Bool
-> Operand
-> (NASM_Operand, Annot)
forall {bin} {t}.
(BinaryClass bin, Integral t) =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> t
-> CFG
-> Instruction
-> Bool
-> Operand
-> (NASM_Operand, Annot)
operand_to_NASM (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l p
entry CFG
cfg Instruction
i Bool
True (Operand -> (NASM_Operand, Annot))
-> Operand -> (NASM_Operand, Annot)
forall a b. (a -> b) -> a -> b
$ Register -> Operand
Op_Reg Register
r ] NASM_Instruction -> String -> NASM_Instruction
`withComment` String
"inserted"

  lea_external_function :: Register -> Symbol -> NASM_Instruction
lea_external_function Register
r Symbol
f = Opcode -> [NASM_Operand] -> NASM_Instruction
mk_nasm_instr Opcode
LEA [ (NASM_Operand, Annot) -> NASM_Operand
forall a b. (a, b) -> a
fst ((NASM_Operand, Annot) -> NASM_Operand)
-> (NASM_Operand, Annot) -> NASM_Operand
forall a b. (a -> b) -> a -> b
$ (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> p
-> CFG
-> Instruction
-> Bool
-> Operand
-> (NASM_Operand, Annot)
forall {bin} {t}.
(BinaryClass bin, Integral t) =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> t
-> CFG
-> Instruction
-> Bool
-> Operand
-> (NASM_Operand, Annot)
operand_to_NASM (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l p
entry CFG
cfg Instruction
i Bool
True (Operand -> (NASM_Operand, Annot))
-> Operand -> (NASM_Operand, Annot)
forall a b. (a -> b) -> a -> b
$ Register -> Operand
Op_Reg Register
r,  NASM_Address -> NASM_Operand
NASM_Operand_EffectiveAddress (NASM_Address -> NASM_Operand) -> NASM_Address -> NASM_Operand
forall a b. (a -> b) -> a -> b
$ Symbol -> NASM_Address
NASM_Addr_Symbol Symbol
f ]

  the_actual_instr :: Register -> NASM_Instruction
the_actual_instr Register
r = (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> p -> CFG -> Instruction -> NASM_Instruction
forall {bin} {p}.
(BinaryClass bin, Integral p) =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> p -> CFG -> Instruction -> NASM_Instruction
mk_normal_instr (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l p
entry CFG
cfg (Word64
-> [Prefix]
-> Opcode
-> Maybe Operand
-> [Operand]
-> Int
-> Instruction
Instruction Word64
addr [Prefix]
pre Opcode
op Maybe Operand
forall a. Maybe a
Nothing (Register -> [Operand] -> [Operand]
replace_mem_op Register
r [Operand]
ops) Int
annot)

  mov_temp_to_reg :: Register -> NASM_Instruction
mov_temp_to_reg Register
r = Opcode -> [NASM_Operand] -> NASM_Instruction
mk_nasm_instr Opcode
MOV [ (NASM_Operand, Annot) -> NASM_Operand
forall a b. (a, b) -> a
fst ((NASM_Operand, Annot) -> NASM_Operand)
-> (NASM_Operand, Annot) -> NASM_Operand
forall a b. (a -> b) -> a -> b
$ (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> p
-> CFG
-> Instruction
-> Bool
-> Operand
-> (NASM_Operand, Annot)
forall {bin} {t}.
(BinaryClass bin, Integral t) =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> t
-> CFG
-> Instruction
-> Bool
-> Operand
-> (NASM_Operand, Annot)
operand_to_NASM (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l p
entry CFG
cfg Instruction
i Bool
True (Operand -> (NASM_Operand, Annot))
-> Operand -> (NASM_Operand, Annot)
forall a b. (a -> b) -> a -> b
$ Register -> Operand
Op_Reg Register
r, NASM_SizeDir -> NASM_Label -> NASM_Operand
label_to_mem_operand (Int
8,Bool
True) (NASM_Label -> NASM_Operand) -> NASM_Label -> NASM_Operand
forall a b. (a -> b) -> a -> b
$ Word64 -> String -> NASM_Label
Label Word64
0 String
"Ltemp_storage_foxdec"] NASM_Instruction -> String -> NASM_Instruction
`withComment` String
"inserted"

  replace_mem_op :: Register -> [Operand] -> [Operand]
replace_mem_op Register
r (Op_Mem BitSize
_ BitSize
_ Register
_ Register
_ Word8
_ Int
_ Maybe SReg
_: [Operand]
ops) = Register -> Operand
Op_Reg Register
r Operand -> [Operand] -> [Operand]
forall a. a -> [a] -> [a]
: [Operand]
ops
  replace_mem_op Register
r (Operand
op:[Operand]
ops)       = Operand
opOperand -> [Operand] -> [Operand]
forall a. a -> [a] -> [a]
:Register -> [Operand] -> [Operand]
replace_mem_op Register
r [Operand]
ops

  name_of_external_function :: [Symbol]
name_of_external_function = (Operand -> Maybe Symbol) -> [Operand] -> [Symbol]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> Instruction -> Operand -> Maybe Symbol
forall {a} {b} {c}.
BinaryClass a =>
(a, b, c) -> Instruction -> Operand -> Maybe Symbol
try_operand_reads_GOT_entry (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l Instruction
i) [Operand]
ops
{--
-- TODO: this is only relevant when doing non-RIP-relative binaries and translating instructions of the form:
--    MOV dst, imm
-- where imm is (maybe) an address
--mk_instr ctxt entry cfg i@(Instruction addr pre op@MOV Nothing ops@[dst,Immediate imm] annot)
--  | is_instruction_address l imm = mk_fake_lea ctxt entry cfg i
--  | otherwise = [NASM_Instruction $ concat
--      [ pre
--      , opcode_to_NASM op
--      , " "
--      ,  intercalate ", " $ map (operand_to_NASM l entry cfg i False) ops ]]

--}




some_operand_reads_GOT_entry :: (a, b, c) -> Instruction -> t Operand -> Bool
some_operand_reads_GOT_entry (a, b, c)
l Instruction
i = (Operand -> Bool) -> t Operand -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Operand
op -> (a, b, c) -> Instruction -> Operand -> Maybe Symbol
forall {a} {b} {c}.
BinaryClass a =>
(a, b, c) -> Instruction -> Operand -> Maybe Symbol
try_operand_reads_GOT_entry (a, b, c)
l Instruction
i Operand
op Maybe Symbol -> Maybe Symbol -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Symbol
forall a. Maybe a
Nothing)

try_operand_reads_GOT_entry :: (a, b, c) -> Instruction -> Operand -> Maybe Symbol
try_operand_reads_GOT_entry l :: (a, b, c)
l@(a
bin,b
_,c
l0) Instruction
i Operand
addr =
  case Instruction -> Operand -> Maybe Int
rip_relative_to_immediate Instruction
i Operand
addr of
    Maybe Int
Nothing -> Maybe Symbol
forall a. Maybe a
Nothing
    Just Int
a  -> Int -> Maybe Symbol
forall {a}. Integral a => a -> Maybe Symbol
find_relocated_function Int
a
 where
  find_relocated_function :: a -> Maybe Symbol
find_relocated_function a
a = 
    case ((Int, Symbol) -> Bool) -> [(Int, Symbol)] -> Maybe (Int, Symbol)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Int -> (Int, Symbol) -> Bool
forall {a}. Eq a => a -> (a, Symbol) -> Bool
is_relocated_function (Int -> (Int, Symbol) -> Bool) -> Int -> (Int, Symbol) -> Bool
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a) ([(Int, Symbol)] -> Maybe (Int, Symbol))
-> [(Int, Symbol)] -> Maybe (Int, Symbol)
forall a b. (a -> b) -> a -> b
$ IntMap Symbol -> [(Int, Symbol)]
forall a. IntMap a -> [(Int, a)]
IM.assocs (IntMap Symbol -> [(Int, Symbol)])
-> IntMap Symbol -> [(Int, Symbol)]
forall a b. (a -> b) -> a -> b
$ a -> IntMap Symbol
forall {a}. BinaryClass a => a -> IntMap Symbol
binary_get_symbol_table a
bin of
      Just (Int
a',sym :: Symbol
sym@(PointerToLabel String
_ Bool
_))  -> Symbol -> Maybe Symbol
forall a. a -> Maybe a
Just Symbol
sym
      --Just (a',sym@(PointerToObject _ _)) -> Just sym
      Maybe (Int, Symbol)
_ -> Maybe Symbol
forall a. Maybe a
Nothing

  is_relocated_function :: a -> (a, Symbol) -> Bool
is_relocated_function a
a (a
a',PointerToLabel  String
str Bool
_) = a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a'
  --is_relocated_function a (a',PointerToObject str _) = a == a'
  is_relocated_function a
a (a, Symbol)
_                          = Bool
False


is_instruction_address :: (bin, b, L0 pred finit v) -> Word64 -> Bool
is_instruction_address l :: (bin, b, L0 pred finit v)
l@(bin
bin,b
_,L0 pred finit v
l0) Word64
a = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
  [ bin -> Word64 -> Bool
forall bin. BinaryClass bin => bin -> Word64 -> Bool
address_has_instruction bin
bin Word64
a
  , Word64
a Word64 -> Set Word64 -> Bool
forall a. Eq a => a -> Set a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set Word64
all_instruction_addresses ]
 where
  all_instruction_addresses :: Set Word64
all_instruction_addresses = [Set Word64] -> Set Word64
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set Word64] -> Set Word64) -> [Set Word64] -> Set Word64
forall a b. (a -> b) -> a -> b
$ (CFG -> Set Word64) -> [CFG] -> [Set Word64]
forall a b. (a -> b) -> [a] -> [b]
map ([Word64] -> Set Word64
forall a. Ord a => [a] -> Set a
S.fromList ([Word64] -> Set Word64) -> (CFG -> [Word64]) -> CFG -> Set Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Instruction -> Word64) -> [Instruction] -> [Word64]
forall a b. (a -> b) -> [a] -> [b]
map Instruction -> Word64
inAddress ([Instruction] -> [Word64])
-> (CFG -> [Instruction]) -> CFG -> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Instruction]] -> [Instruction]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Instruction]] -> [Instruction])
-> (CFG -> [[Instruction]]) -> CFG -> [Instruction]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap [Instruction] -> [[Instruction]]
forall a. IntMap a -> [a]
IM.elems (IntMap [Instruction] -> [[Instruction]])
-> (CFG -> IntMap [Instruction]) -> CFG -> [[Instruction]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFG -> IntMap [Instruction]
cfg_instrs) ([CFG] -> [Set Word64]) -> [CFG] -> [Set Word64]
forall a b. (a -> b) -> a -> b
$ IntMap CFG -> [CFG]
forall a. IntMap a -> [a]
IM.elems (IntMap CFG -> [CFG]) -> IntMap CFG -> [CFG]
forall a b. (a -> b) -> a -> b
$ L0 pred finit v -> IntMap CFG
forall pred finit v. L0 pred finit v -> IntMap CFG
l0_get_cfgs L0 pred finit v
l0



-- TODO: this is only relevant when doing non-RIP-relative binaries and translating instructions of the form:
--   MOV dst, imm
-- where imm is (maybe) an address
{--
mk_fake_lea ctxt entry cfg i@(Instruction addr pre op@MOV Nothing ops@[dst@(Storage r),Immediate imm] annot) =
    let left = fromJust $ symbolize_immediate l (Just (entry,cfg)) True imm in
      [NASM_Instruction $ concat
        [ pre
        , "LEA "
        , operand_to_NASM l entry cfg i True dst
        , ", [" ++ left ++ "]"
        , " ; 0x" ++ showHex imm ++ " --> " ++ left ]]
mk_fake_lea ctxt entry cfg i@(Instruction addr pre op@MOV Nothing ops@[dst@(Memory a si),Immediate imm] annot) =
    let left = fromJust $ symbolize_immediate l (Just (entry,cfg)) True imm
        r = find_unused_register register_set [i] in
      [ NASM_Comment 2 "inserted"
      , NASM_Instruction $ concat
        [ "MOV qword [Ltemp_storage_foxdec], " 
        , operand_to_NASM l entry cfg i True $ Storage r ]
      , NASM_Instruction $ concat
        [ pre
        , "LEA "
        , operand_to_NASM l entry cfg i True $ Storage r
        , ", [" ++ l ++ "]"
        , " ; 0x" ++ showHex imm ++ " --> " ++ left ] 
      , NASM_Instruction $ concat
        [ "MOV " 
        , operand_to_NASM l entry cfg i True dst
        , ", "
        , operand_to_NASM l entry cfg i True $ Storage r ]
      , NASM_Instruction $ concat
        [ "MOV qword " 
        , operand_to_NASM l entry cfg i True $ Storage r
        , ", [Ltemp_storage_foxdec]"]
      , NASM_Comment 2 "done" ]
--}


-- | convert an operand to a NASM operand
-- Return both the translation (a String) as well as an optional annotation
operand_to_NASM :: (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> t
-> CFG
-> Instruction
-> Bool
-> Operand
-> (NASM_Operand, Annot)
operand_to_NASM (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l t
entry CFG
cfg Instruction
i Bool
is_addr (Op_Reg Register
r)               = (Register -> NASM_Operand
NASM_Operand_Reg Register
r,[])
operand_to_NASM (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l t
entry CFG
cfg Instruction
i Bool
is_addr a :: Operand
a@(Op_Mem BitSize
_ BitSize
_ Register
_ Register
_ Word8
_ Int
_ Maybe SReg
_) = (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> t -> CFG -> Instruction -> Operand -> (NASM_Operand, Annot)
forall {bin} {p}.
(BinaryClass bin, Integral p) =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> p -> CFG -> Instruction -> Operand -> (NASM_Operand, Annot)
mem_operand_to_NASM (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l t
entry CFG
cfg Instruction
i Operand
a
operand_to_NASM (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l t
entry CFG
cfg Instruction
i Bool
is_addr a :: Operand
a@(Op_Const Int
imm)         = (Immediate -> NASM_Operand
NASM_Operand_Immediate (Immediate -> NASM_Operand) -> Immediate -> NASM_Operand
forall a b. (a -> b) -> a -> b
$ BitSize -> Word64 -> Immediate
Immediate (Int -> BitSize
BitSize Int
64) (Word64 -> Immediate) -> Word64 -> Immediate
forall a b. (a -> b) -> a -> b
$ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
imm, [])
operand_to_NASM (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l t
entry CFG
cfg Instruction
i Bool
is_addr a :: Operand
a@(Op_Near Operand
op)           = (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> t
-> CFG
-> Instruction
-> Bool
-> Operand
-> (NASM_Operand, Annot)
operand_to_NASM (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l t
entry CFG
cfg Instruction
i Bool
is_addr Operand
op
operand_to_NASM (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l t
entry CFG
cfg Instruction
i Bool
is_addr a :: Operand
a@(Op_Imm Immediate
imm)           = (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> t
-> CFG
-> Instruction
-> Bool
-> Operand
-> (NASM_Operand, Annot)
operand_to_NASM (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l t
entry CFG
cfg Instruction
i Bool
is_addr (Immediate -> Operand
Op_Jmp Immediate
imm)
operand_to_NASM (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l t
entry CFG
cfg Instruction
i Bool
is_addr a :: Operand
a@(Op_Jmp Immediate
imm) 
  | Bool
is_addr   = 
    let (NASM_Address
address,Annot
annot) = (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> t -> CFG -> Instruction -> Operand -> (NASM_Address, Annot)
forall {bin} {a}.
(BinaryClass bin, Integral a) =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> a -> CFG -> Instruction -> Operand -> (NASM_Address, Annot)
symbolize_address (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l t
entry CFG
cfg Instruction
i Operand
a in
      (NASM_Address -> NASM_Operand
NASM_Operand_Address NASM_Address
address, Annot
annot)
  | Bool
otherwise = (Immediate -> NASM_Operand
NASM_Operand_Immediate Immediate
imm, [])
operand_to_NASM (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l t
entry CFG
cfg Instruction
i Bool
is_addr Operand
op = String -> (NASM_Operand, Annot)
forall a. HasCallStack => String -> a
error (String -> (NASM_Operand, Annot))
-> String -> (NASM_Operand, Annot)
forall a b. (a -> b) -> a -> b
$ Operand -> String
forall {a}. Show a => a -> String
show Operand
op

mem_operand_to_NASM :: (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> p -> CFG -> Instruction -> Operand -> (NASM_Operand, Annot)
mem_operand_to_NASM (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l p
entry CFG
cfg Instruction
i a :: Operand
a@(Op_Mem (BitSize Int
si) BitSize
_ Register
_ Register
_ Word8
_ Int
_ Maybe SReg
_) =
  let (NASM_Address
address,Annot
annot) = (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> p -> CFG -> Instruction -> Operand -> (NASM_Address, Annot)
forall {bin} {a}.
(BinaryClass bin, Integral a) =>
(bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> a -> CFG -> Instruction -> Operand -> (NASM_Address, Annot)
symbolize_address (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l p
entry CFG
cfg Instruction
i Operand
a in
    case Instruction -> Opcode
inOperation Instruction
i of
      Opcode
LEA -> (NASM_Address -> NASM_Operand
NASM_Operand_EffectiveAddress NASM_Address
address, Annot
annot)
      Opcode
_   -> (NASM_SizeDir -> NASM_Address -> NASM_Operand
NASM_Operand_Memory (Instruction -> Int -> NASM_SizeDir
size_directive_to_NASM Instruction
i (Int
si Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8)) NASM_Address
address, Annot
annot)



-- | convert the address of an operand to a NASM address
-- -- TODO remove this
address_to_NASM :: Operand -> NASM_Address_Computation
address_to_NASM (Op_Mem BitSize
_ BitSize
_ Register
reg Register
idx Word8
scale Int
displ Maybe SReg
seg) = Maybe Register
-> Maybe Register
-> Word64
-> Maybe Register
-> Maybe Word64
-> NASM_Address_Computation
NASM_Address_Computation (SReg -> Register
RegSeg (SReg -> Register) -> Maybe SReg -> Maybe Register
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SReg
seg) (Register -> Maybe Register
mk Register
idx) (Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
scale) (Register -> Maybe Register
mk Register
reg) (Int -> Maybe Word64
forall {a} {a}. (Integral a, Num a) => a -> Maybe a
mk' Int
displ)
 where
  mk :: Register -> Maybe Register
mk Register
RegNone = Maybe Register
forall a. Maybe a
Nothing 
  mk Register
r = Register -> Maybe Register
forall a. a -> Maybe a
Just Register
r

  mk' :: a -> Maybe a
mk' a
0 = Maybe a
forall a. Maybe a
Nothing
  mk' a
i = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i






-- | convert size directive of an operand to a NASM size directive
size_directive_to_NASM :: Instruction -> Int -> (Int,Bool) 
size_directive_to_NASM :: Instruction -> Int -> NASM_SizeDir
size_directive_to_NASM Instruction
_ Int
1  = (Int
1,Bool
True) -- "byte"
size_directive_to_NASM Instruction
_ Int
2  = (Int
2,Bool
True) -- "word"
size_directive_to_NASM Instruction
_ Int
4  = (Int
4,Bool
True) -- "dword"
size_directive_to_NASM Instruction
i Int
8  
  | Instruction -> Opcode
inOperation Instruction
i Opcode -> [Opcode] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Opcode
ADDSD,Opcode
SUBSD,Opcode
DIVSD,Opcode
MULSD,Opcode
COMISD,Opcode
UCOMISD,Opcode
MINSD,Opcode
MAXSD] = (Int
8,Bool
False) -- NASM does not want size directives for these instructions
  | Bool
otherwise = (Int
8,Bool
True) --  "qword"
size_directive_to_NASM Instruction
_ Int
10 = (Int
10,Bool
True) -- "tword"
size_directive_to_NASM Instruction
i Int
16
  | Instruction -> Opcode
inOperation Instruction
i Opcode -> Opcode -> Bool
forall a. Eq a => a -> a -> Bool
== Opcode
COMISD = (Int
16,Bool
False)
  | Instruction -> Opcode
inOperation Instruction
i Opcode -> Opcode -> Bool
forall a. Eq a => a -> a -> Bool
== Opcode
COMISS = (Int
16,Bool
False)
  | Bool
otherwise          = (Int
16,Bool
True) --  "oword" -- BUG in Capstone
size_directive_to_NASM Instruction
i Int
x  = String -> NASM_SizeDir
forall a. HasCallStack => String -> a
error (String -> NASM_SizeDir) -> String -> NASM_SizeDir
forall a b. (a -> b) -> a -> b
$ String
"Unknown size directive " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall {a}. Show a => a -> String
show Int
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in instruction: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Instruction -> String
forall {a}. Show a => a -> String
show Instruction
i

-- | convert opcode to a NASM opcode
opcode_to_NASM :: Opcode -> Maybe Opcode
opcode_to_NASM Opcode
MOVABS = Opcode -> Maybe Opcode
forall a. a -> Maybe a
Just Opcode
MOV
opcode_to_NASM Opcode
opcode = Opcode -> Maybe Opcode
forall a. a -> Maybe a
Just Opcode
opcode


mk_NASM_prefix :: t Prefix -> Maybe Prefix
mk_NASM_prefix t Prefix
ps
  | Prefix
PrefixRep Prefix -> t Prefix -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Prefix
ps = Prefix -> Maybe Prefix
forall a. a -> Maybe a
Just Prefix
PrefixRep
  | Prefix
PrefixRepNE Prefix -> t Prefix -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Prefix
ps = Prefix -> Maybe Prefix
forall a. a -> Maybe a
Just Prefix
PrefixRepNE
  | Prefix
PrefixLock Prefix -> t Prefix -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Prefix
ps = Prefix -> Maybe Prefix
forall a. a -> Maybe a
Just Prefix
PrefixLock
  | Bool
otherwise = Maybe Prefix
forall a. Maybe a
Nothing





----- SYMBOLIZATION -----


----- TEXT SECTIONS -----
-- | Symbolization of an address of an operand
-- Return an optional annotation as well.
symbolize_address :: (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> a -> CFG -> Instruction -> Operand -> (NASM_Address, Annot)
symbolize_address l :: (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l@(bin
bin,Config
_,L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue
l0) a
entry CFG
cfg Instruction
i Operand
a =
  case (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> Maybe (Int, CFG)
-> Bool
-> Word64
-> Maybe (NASM_Address, Annot)
forall bin.
BinaryClass bin =>
LiftedC bin
-> Maybe (Int, CFG)
-> Bool
-> Word64
-> Maybe (NASM_Address, Annot)
symbolize_immediate (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l ((Int, CFG) -> Maybe (Int, CFG)
forall a. a -> Maybe a
Just (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
entry,CFG
cfg)) (Opcode -> Bool
isCall (Opcode -> Bool) -> Opcode -> Bool
forall a b. (a -> b) -> a -> b
$ Instruction -> Opcode
inOperation Instruction
i) (Word64 -> Maybe (NASM_Address, Annot))
-> (Int -> Word64) -> Int -> Maybe (NASM_Address, Annot)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Maybe (NASM_Address, Annot))
-> Maybe Int -> Maybe (Maybe (NASM_Address, Annot))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Instruction -> Operand -> Maybe Int
rip_relative_to_immediate Instruction
i Operand
a of
    Just (Just (NASM_Address, Annot)
sym) -> (NASM_Address, Annot)
sym 
    Maybe (Maybe (NASM_Address, Annot))
_               -> (NASM_Address_Computation -> NASM_Address
NASM_Addr_Compute (NASM_Address_Computation -> NASM_Address)
-> NASM_Address_Computation -> NASM_Address
forall a b. (a -> b) -> a -> b
$ Operand -> NASM_Address_Computation
address_to_NASM Operand
a, [])
      --case try_symbolize_base_of_address ctxt i a of
      --  Just str -> error "TODO" 
      --  _        -> (NASM_Addr_Compute $ address_to_NASM i a, [])

{--
try_symbolize_base_of_address ctxt i addr = find_base addr
 where
  find_base (Op_Mem _ _ )                  = try_symbolize_base l True imm
  find_base _                                 = Nothing
--}


-- | Symbolization of an immediate value that is used as an address
symbolize_immediate :: BinaryClass bin => LiftedC bin -> Maybe (Int,CFG) -> Bool -> Word64 -> Maybe (NASM_Address,Annot)
symbolize_immediate :: forall bin.
BinaryClass bin =>
LiftedC bin
-> Maybe (Int, CFG)
-> Bool
-> Word64
-> Maybe (NASM_Address, Annot)
symbolize_immediate l :: LiftedC bin
l@(bin
bin,Config
_,L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue
l0) Maybe (Int, CFG)
entry_cfg Bool
is_call Word64
a =
  (NASM_Label -> (NASM_Address, Annot)
forall {c}.
Num c =>
NASM_Label -> (NASM_Address, [(Word64, NASM_Label, c)])
add_annot (NASM_Label -> (NASM_Address, Annot))
-> Maybe NASM_Label -> Maybe (NASM_Address, Annot)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NASM_Label
first) Maybe (NASM_Address, Annot)
-> Maybe (NASM_Address, Annot) -> Maybe (NASM_Address, Annot)
forall a. Eq a => Maybe a -> Maybe a -> Maybe a
`orTry` (NASM_Label -> (NASM_Address, Annot)
forall {c}.
Num c =>
NASM_Label -> (NASM_Address, [(Word64, NASM_Label, c)])
add_annot (NASM_Label -> (NASM_Address, Annot))
-> Maybe NASM_Label -> Maybe (NASM_Address, Annot)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NASM_Label
second) Maybe (NASM_Address, Annot)
-> Maybe (NASM_Address, Annot) -> Maybe (NASM_Address, Annot)
forall a. Eq a => Maybe a -> Maybe a -> Maybe a
`orTry` LiftedC bin -> Word64 -> Maybe (NASM_Address, Annot)
forall {a} {c} {b} {c}.
(BinaryClass a, Num c, Eq c) =>
(a, b, c)
-> Word64 -> Maybe (NASM_Address, [(Word64, NASM_Label, c)])
relocatable_symbol LiftedC bin
l Word64
a Maybe (NASM_Address, Annot)
-> Maybe (NASM_Address, Annot) -> Maybe (NASM_Address, Annot)
forall a. Eq a => Maybe a -> Maybe a -> Maybe a
`orTry` LiftedC bin -> Bool -> Word64 -> Maybe (NASM_Address, Annot)
forall bin.
BinaryClass bin =>
LiftedC bin -> Bool -> Word64 -> Maybe (NASM_Address, Annot)
try_symbolize_base LiftedC bin
l Bool
True Word64
a
 where
  (Maybe NASM_Label
first,Maybe NASM_Label
second) 
    | Bool
is_call   = (Maybe NASM_Label
find_outside_cfg,Maybe (Int, CFG) -> Maybe NASM_Label
forall {p}. Integral p => Maybe (p, CFG) -> Maybe NASM_Label
find_inside_cfg Maybe (Int, CFG)
entry_cfg)
    | Bool
otherwise = (Maybe (Int, CFG) -> Maybe NASM_Label
forall {p}. Integral p => Maybe (p, CFG) -> Maybe NASM_Label
find_inside_cfg Maybe (Int, CFG)
entry_cfg,Maybe NASM_Label
find_outside_cfg)

  -- search for a block in the current cfg that starts at @a@, and if found, make a label for it
  find_inside_cfg :: Maybe (p, CFG) -> Maybe NASM_Label
find_inside_cfg Maybe (p, CFG)
Nothing            = Maybe NASM_Label
forall a. Maybe a
Nothing 
  find_inside_cfg (Just (p
entry,CFG
cfg)) = ((LiftedC bin -> p -> Word64 -> Int -> NASM_Label
forall {p} {p} {a} {b} {c}.
(Show p, Integral p, Num p, Eq p, BinaryClass a) =>
(a, b, c) -> p -> Word64 -> p -> NASM_Label
block_label LiftedC bin
l p
entry Word64
a (Int -> NASM_Label)
-> ((Int, [Instruction]) -> Int)
-> (Int, [Instruction])
-> NASM_Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, [Instruction]) -> Int
forall a b. (a, b) -> a
fst) ((Int, [Instruction]) -> NASM_Label)
-> Maybe (Int, [Instruction]) -> Maybe NASM_Label
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Int, [Instruction]) -> Bool)
-> [(Int, [Instruction])] -> Maybe (Int, [Instruction])
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Int, [Instruction]) -> Bool
forall {a}. (a, [Instruction]) -> Bool
block_starts_at (IntMap [Instruction] -> [(Int, [Instruction])]
forall a. IntMap a -> [(Int, a)]
IM.toList (IntMap [Instruction] -> [(Int, [Instruction])])
-> IntMap [Instruction] -> [(Int, [Instruction])]
forall a b. (a -> b) -> a -> b
$ CFG -> IntMap [Instruction]
cfg_instrs CFG
cfg))
  -- search for a block outside of the current cfg
  find_outside_cfg :: Maybe NASM_Label
find_outside_cfg  = ((\Word64
a -> LiftedC bin -> Word64 -> Word64 -> Integer -> NASM_Label
forall {p} {p} {a} {b} {c}.
(Show p, Integral p, Num p, Eq p, BinaryClass a) =>
(a, b, c) -> p -> Word64 -> p -> NASM_Label
block_label LiftedC bin
l Word64
a Word64
a Integer
0) (Word64 -> NASM_Label) -> Maybe Word64 -> Maybe NASM_Label
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64 -> Bool) -> [Word64] -> Maybe Word64
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
(==) Word64
a) ((Int -> Word64) -> [Int] -> [Word64]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> [Word64]) -> [Int] -> [Word64]
forall a b. (a -> b) -> a -> b
$ Set Int -> [Int]
forall a. Set a -> [a]
S.toList (Set Int -> [Int]) -> Set Int -> [Int]
forall a b. (a -> b) -> a -> b
$ L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue
-> Set Int
forall pred finit v. L0 pred finit v -> Set Int
l0_get_function_entries L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue
l0))

  block_starts_at :: (a, [Instruction]) -> Bool
block_starts_at (a
blockId, [Instruction]
instrs) = [Instruction]
instrs [Instruction] -> [Instruction] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] Bool -> Bool -> Bool
&& Instruction -> Word64
inAddress ([Instruction] -> Instruction
forall a. HasCallStack => [a] -> a
head [Instruction]
instrs) Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
a

  add_annot :: NASM_Label -> (NASM_Address, [(Word64, NASM_Label, c)])
add_annot NASM_Label
str = (NASM_Label -> Maybe Word64 -> NASM_Address
NASM_Addr_Label NASM_Label
str Maybe Word64
forall a. Maybe a
Nothing,[(Word64
a,NASM_Label
str,c
0)])


-- | Symbolize (try to) an immediate address falling into the range of a section
try_symbolize_base :: BinaryClass bin => LiftedC bin -> Bool -> Word64 -> Maybe (NASM_Address,Annot)
try_symbolize_base :: forall bin.
BinaryClass bin =>
LiftedC bin -> Bool -> Word64 -> Maybe (NASM_Address, Annot)
try_symbolize_base l :: LiftedC bin
l@(bin
bin,Config
_,L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue
l0) Bool
not_part_of_larger_expression Word64
imm = Maybe (NASM_Address, Annot)
within_section Maybe (NASM_Address, Annot)
-> Maybe (NASM_Address, Annot) -> Maybe (NASM_Address, Annot)
forall a. Eq a => Maybe a -> Maybe a -> Maybe a
`orTry` (Word64 -> Maybe (NASM_Address, Annot)
forall {a} {a}. Integral a => a -> Maybe (NASM_Address, [a])
try_internal Word64
imm) Maybe (NASM_Address, Annot)
-> Maybe (NASM_Address, Annot) -> Maybe (NASM_Address, Annot)
forall a. Eq a => Maybe a -> Maybe a -> Maybe a
`orTry` (NASM_Label -> (NASM_Address, Annot)
forall {c}.
Num c =>
NASM_Label -> (NASM_Address, [(Word64, NASM_Label, c)])
add_annot (NASM_Label -> (NASM_Address, Annot))
-> Maybe NASM_Label -> Maybe (NASM_Address, Annot)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> Maybe NASM_Label
try_at_end_of_section Word64
imm)
 where
  within_section :: Maybe (NASM_Address, Annot)
within_section    = Word64
-> (String, String, Word64, Word64, Word64)
-> (NASM_Address, Annot)
forall {d} {e}.
Word64 -> (String, String, Word64, d, e) -> (NASM_Address, Annot)
show_section_relative Word64
imm ((String, String, Word64, Word64, Word64) -> (NASM_Address, Annot))
-> Maybe (String, String, Word64, Word64, Word64)
-> Maybe (NASM_Address, Annot)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> bin -> Word64 -> Maybe (String, String, Word64, Word64, Word64)
forall bin.
BinaryClass bin =>
bin -> Word64 -> Maybe (String, String, Word64, Word64, Word64)
find_section_for_address bin
bin Word64
imm

  show_section_relative :: Word64 -> (String, String, Word64, d, e) -> (NASM_Address, Annot)
show_section_relative Word64
a sec :: (String, String, Word64, d, e)
sec@(String
segment,String
section,Word64
a0,d
_,e
_) = (NASM_Address
label,[(Word64
a, String -> String -> Word64 -> NASM_Label
section_label String
segment String
section Word64
a0, Word64
a Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
a0)])
   where
    label :: NASM_Address
label
      | Bool
not_part_of_larger_expression = NASM_Label -> Maybe Word64 -> NASM_Address
NASM_Addr_Label (String -> String -> Word64 -> Word64 -> NASM_Label
macro_name String
segment String
section Word64
a0 (Word64
a Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
a0)) (Maybe Word64 -> NASM_Address) -> Maybe Word64 -> NASM_Address
forall a b. (a -> b) -> a -> b
$ Maybe Word64
forall a. Maybe a
Nothing
      | Bool
otherwise                     = NASM_Label -> Maybe Word64 -> NASM_Address
NASM_Addr_Label (String -> String -> Word64 -> NASM_Label
section_label String
segment String
section Word64
a0)       (Maybe Word64 -> NASM_Address) -> Maybe Word64 -> NASM_Address
forall a b. (a -> b) -> a -> b
$ Word64 -> Maybe Word64
forall a. a -> Maybe a
Just (Word64
a Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
a0)

  try_internal :: a -> Maybe (NASM_Address, [a])
try_internal a
a = (\Symbol
sym -> (Symbol -> NASM_Address
NASM_Addr_Symbol Symbol
sym,[])) (Symbol -> (NASM_Address, [a]))
-> Maybe Symbol -> Maybe (NASM_Address, [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> IntMap Symbol -> Maybe Symbol
forall a. Int -> IntMap a -> Maybe a
IM.lookup (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a) (IntMap Symbol -> Maybe Symbol) -> IntMap Symbol -> Maybe Symbol
forall a b. (a -> b) -> a -> b
$ (Symbol -> Bool) -> IntMap Symbol -> IntMap Symbol
forall a. (a -> Bool) -> IntMap a -> IntMap a
IM.filter Symbol -> Bool
is_internal_symbol (IntMap Symbol -> IntMap Symbol) -> IntMap Symbol -> IntMap Symbol
forall a b. (a -> b) -> a -> b
$ bin -> IntMap Symbol
forall {a}. BinaryClass a => a -> IntMap Symbol
binary_get_symbol_table bin
bin)

  try_at_end_of_section :: Word64 -> Maybe NASM_Label
try_at_end_of_section Word64
a = (String, String, Word64, Word64, Word64) -> NASM_Label
forall {e}. (String, String, Word64, Word64, e) -> NASM_Label
end_of_section_label ((String, String, Word64, Word64, Word64) -> NASM_Label)
-> Maybe (String, String, Word64, Word64, Word64)
-> Maybe NASM_Label
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((String, String, Word64, Word64, Word64) -> Bool)
-> [(String, String, Word64, Word64, Word64)]
-> Maybe (String, String, Word64, Word64, Word64)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Word64 -> (String, String, Word64, Word64, Word64) -> Bool
forall {a} {a} {b} {e}.
(Eq a, Num a) =>
a -> (a, b, a, a, e) -> Bool
is_end_of_section Word64
a) ([(String, String, Word64, Word64, Word64)]
 -> Maybe (String, String, Word64, Word64, Word64))
-> [(String, String, Word64, Word64, Word64)]
-> Maybe (String, String, Word64, Word64, Word64)
forall a b. (a -> b) -> a -> b
$ SectionsInfo -> [(String, String, Word64, Word64, Word64)]
si_sections (SectionsInfo -> [(String, String, Word64, Word64, Word64)])
-> SectionsInfo -> [(String, String, Word64, Word64, Word64)]
forall a b. (a -> b) -> a -> b
$ bin -> SectionsInfo
forall a. BinaryClass a => a -> SectionsInfo
binary_get_sections_info bin
bin)

  is_end_of_section :: a -> (a, b, a, a, e) -> Bool
is_end_of_section a
a (a
_,b
_,a
a0,a
sz,e
_) = a
a0 a -> a -> a
forall a. Num a => a -> a -> a
+ a
sz a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a

  add_annot :: NASM_Label -> (NASM_Address, [(Word64, NASM_Label, c)])
add_annot NASM_Label
str = (NASM_Label -> Maybe Word64 -> NASM_Address
NASM_Addr_Label NASM_Label
str Maybe Word64
forall a. Maybe a
Nothing,[(Word64
imm,NASM_Label
str,c
0)])




-- see if address matches an external symbol loaded at linking time
relocatable_symbol :: (a, b, c)
-> Word64 -> Maybe (NASM_Address, [(Word64, NASM_Label, c)])
relocatable_symbol l :: (a, b, c)
l@(a
bin,b
_,c
l0) Word64
a = (Int -> IntMap Symbol -> Maybe Symbol
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
a) (a -> IntMap Symbol
forall {a}. BinaryClass a => a -> IntMap Symbol
binary_get_symbol_table a
bin) Maybe Symbol
-> (Symbol -> Maybe (NASM_Address, [(Word64, NASM_Label, c)]))
-> Maybe (NASM_Address, [(Word64, NASM_Label, c)])
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Symbol -> Maybe (NASM_Address, [(Word64, NASM_Label, c)])
forall {c}.
Num c =>
Symbol -> Maybe (NASM_Address, [(Word64, NASM_Label, c)])
mk_symbol) Maybe (NASM_Address, [(Word64, NASM_Label, c)])
-> Maybe (NASM_Address, [(Word64, NASM_Label, c)])
-> Maybe (NASM_Address, [(Word64, NASM_Label, c)])
forall a. Eq a => Maybe a -> Maybe a -> Maybe a
`orTry` ((Relocation -> Bool) -> Set Relocation -> Maybe Relocation
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Word64 -> Relocation -> Bool
reloc_for Word64
a) (a -> Set Relocation
forall a. BinaryClass a => a -> Set Relocation
binary_get_relocations a
bin) Maybe Relocation
-> (Relocation -> Maybe (NASM_Address, [(Word64, NASM_Label, c)]))
-> Maybe (NASM_Address, [(Word64, NASM_Label, c)])
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Relocation -> Maybe (NASM_Address, [(Word64, NASM_Label, c)])
forall {c}.
Num c =>
Relocation -> Maybe (NASM_Address, [(Word64, NASM_Label, c)])
mk_reloc)
 where
  mk_symbol :: Symbol -> Maybe (NASM_Address, [(Word64, NASM_Label, c)])
mk_symbol sym :: Symbol
sym@(PointerToLabel  String
l Bool
_)             = Maybe (NASM_Address, [(Word64, NASM_Label, c)])
forall a. Maybe a
Nothing --  error $ "Reading PLT entry of address " ++ showHex a -- TODO check if this actually happens. If so, return Nothing.
  mk_symbol sym :: Symbol
sym@(PointerToObject String
o Bool
_)             = (NASM_Address, [(Word64, NASM_Label, c)])
-> Maybe (NASM_Address, [(Word64, NASM_Label, c)])
forall a. a -> Maybe a
Just (Symbol -> NASM_Address
NASM_Addr_Symbol Symbol
sym,[(Word64
a,String -> Word64 -> NASM_Label
mk_safe_label String
o Word64
a,c
0)])
  mk_symbol sym :: Symbol
sym@(AddressOfLabel  String
l Bool
_)             = (NASM_Address, [(Word64, NASM_Label, c)])
-> Maybe (NASM_Address, [(Word64, NASM_Label, c)])
forall a. a -> Maybe a
Just (Symbol -> NASM_Address
NASM_Addr_Symbol Symbol
sym,[(Word64
a,String -> Word64 -> NASM_Label
mk_safe_label String
l Word64
a,c
0)])
  mk_symbol sym :: Symbol
sym@(AddressOfObject String
o Bool
_)             = (NASM_Address, [(Word64, NASM_Label, c)])
-> Maybe (NASM_Address, [(Word64, NASM_Label, c)])
forall a. a -> Maybe a
Just (Symbol -> NASM_Address
NASM_Addr_Symbol Symbol
sym,[(Word64
a,String -> Word64 -> NASM_Label
mk_safe_label String
o Word64
a,c
0)])
  mk_symbol sym :: Symbol
sym@(Relocated_ResolvedObject String
str Word64
a1) = (NASM_Address, [(Word64, NASM_Label, c)])
-> Maybe (NASM_Address, [(Word64, NASM_Label, c)])
forall a. a -> Maybe a
Just (Symbol -> NASM_Address
NASM_Addr_Symbol Symbol
sym,[(Word64
a,String -> Word64 -> NASM_Label
mk_safe_label String
str Word64
a,c
0)])

  mk_reloc :: Relocation -> Maybe (NASM_Address, [(Word64, NASM_Label, c)])
mk_reloc (Relocation Word64
a0 Word64
a1) = 
    let label :: NASM_Label
label = (a, b, c) -> Integer -> Word64 -> Integer -> NASM_Label
forall {p} {p} {a} {b} {c}.
(Show p, Integral p, Num p, Eq p, BinaryClass a) =>
(a, b, c) -> p -> Word64 -> p -> NASM_Label
block_label (a, b, c)
l Integer
0 Word64
a0 Integer
0 in
      (NASM_Address, [(Word64, NASM_Label, c)])
-> Maybe (NASM_Address, [(Word64, NASM_Label, c)])
forall a. a -> Maybe a
Just (NASM_Label -> Maybe Word64 -> NASM_Address
NASM_Addr_Label NASM_Label
label Maybe Word64
forall a. Maybe a
Nothing, [(Word64
a,NASM_Label
label,c
0)])

reloc_for :: Word64 -> Relocation -> Bool
reloc_for Word64
a (Relocation Word64
a0 Word64
a1) = Word64
a Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
a0


rip_relative_to_immediate :: Instruction -> Operand -> Maybe Int
rip_relative_to_immediate Instruction
i (Op_Mem BitSize
_ BitSize
_ (Reg64 GPR
RIP) Register
RegNone Word8
_ Int
displ Maybe SReg
Nothing) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Instruction -> Word64
inAddress Instruction
i) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Instruction -> Int
inSize Instruction
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
displ
rip_relative_to_immediate Instruction
i (Op_Mem BitSize
_ BitSize
_ Register
RegNone Register
RegNone Word8
0 Int
displ Maybe SReg
Nothing) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
displ
rip_relative_to_immediate Instruction
i (Op_Mem BitSize
_ BitSize
_ (Reg64 GPR
RIP) Register
_ Word8
_ Int
_ Maybe SReg
_) = String -> Maybe Int
forall a. HasCallStack => String -> a
error (Instruction -> String
forall {a}. Show a => a -> String
show Instruction
i)
rip_relative_to_immediate Instruction
i (Op_Reg (Reg64 GPR
RIP)) = String -> Maybe Int
forall a. HasCallStack => String -> a
error (Instruction -> String
forall {a}. Show a => a -> String
show Instruction
i)
rip_relative_to_immediate Instruction
i (Op_Imm (Immediate BitSize
_ Word64
imm)) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
imm
rip_relative_to_immediate Instruction
i (Op_Jmp (Immediate BitSize
_ Word64
imm)) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
imm
rip_relative_to_immediate Instruction
i (Op_Const Int
c) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
c
rip_relative_to_immediate Instruction
i (Op_Near Operand
op) = Instruction -> Operand -> Maybe Int
rip_relative_to_immediate Instruction
i Operand
op
rip_relative_to_immediate Instruction
i (Op_Far Operand
op) = Instruction -> Operand -> Maybe Int
rip_relative_to_immediate Instruction
i Operand
op

rip_relative_to_immediate Instruction
i (Op_Reg Register
_) = Maybe Int
forall a. Maybe a
Nothing
rip_relative_to_immediate Instruction
i (Op_Mem BitSize
_ BitSize
_ Register
_ Register
_ Word8
_ Int
_ Maybe SReg
_) = Maybe Int
forall a. Maybe a
Nothing







----- DATA SECTIONS -----
mk_macros :: (a, b, c) -> String
mk_macros l :: (a, b, c)
l@(a
bin,b
_,c
l0) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
macros [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
""] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
internals
 where
  -- macros used to compute addresses relative to beginning of sections
  -- EXAMPLE:
  --    %define RELA_.rodata_0x11000(offset) (L_.rodata_0x11000 + offset)
  macros :: [String]
macros = ((String, String, Word64, Word64, Word64) -> String)
-> [(String, String, Word64, Word64, Word64)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String, Word64, Word64, Word64) -> String
forall {d} {e}. (String, String, Word64, d, e) -> String
mk_macro ([(String, String, Word64, Word64, Word64)] -> [String])
-> [(String, String, Word64, Word64, Word64)] -> [String]
forall a b. (a -> b) -> a -> b
$ ((String, String, Word64, Word64, Word64) -> Bool)
-> [(String, String, Word64, Word64, Word64)]
-> [(String, String, Word64, Word64, Word64)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String, String, Word64, Word64, Word64) -> Bool
forall {c} {d} {e}. (String, String, c, d, e) -> Bool
is_data_section ((String, String, Word64, Word64, Word64) -> Bool)
-> ((String, String, Word64, Word64, Word64) -> Bool)
-> (String, String, Word64, Word64, Word64)
-> Bool
forall a. (a -> Bool) -> (a -> Bool) -> a -> Bool
||| (String, String, Word64, Word64, Word64) -> Bool
forall {c} {d} {e}. (String, String, c, d, e) -> Bool
is_ro_data_section ((String, String, Word64, Word64, Word64) -> Bool)
-> ((String, String, Word64, Word64, Word64) -> Bool)
-> (String, String, Word64, Word64, Word64)
-> Bool
forall a. (a -> Bool) -> (a -> Bool) -> a -> Bool
||| (String, String, Word64, Word64, Word64) -> Bool
forall {c} {d} {e}. (String, String, c, d, e) -> Bool
is_bss_data_section) ([(String, String, Word64, Word64, Word64)]
 -> [(String, String, Word64, Word64, Word64)])
-> [(String, String, Word64, Word64, Word64)]
-> [(String, String, Word64, Word64, Word64)]
forall a b. (a -> b) -> a -> b
$ SectionsInfo -> [(String, String, Word64, Word64, Word64)]
si_sections (SectionsInfo -> [(String, String, Word64, Word64, Word64)])
-> SectionsInfo -> [(String, String, Word64, Word64, Word64)]
forall a b. (a -> b) -> a -> b
$ a -> SectionsInfo
forall a. BinaryClass a => a -> SectionsInfo
binary_get_sections_info a
bin
  -- internal symbols that are defined outside of existing sections
  -- EXAMPLE:
  --    %define __TMC_END__ RELA_.data_0x17000(0x4)
  internals :: [String]
internals = ((Int, (String, String, String, Word64, Word64)) -> [String])
-> [(Int, (String, String, String, Word64, Word64))] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int, (String, String, String, Word64, Word64)) -> [String]
forall {a}.
(a, (String, String, String, Word64, Word64)) -> [String]
mk_internal ([(Int, (String, String, String, Word64, Word64))] -> [String])
-> [(Int, (String, String, String, Word64, Word64))] -> [String]
forall a b. (a -> b) -> a -> b
$ IntMap (String, String, String, Word64, Word64)
-> [(Int, (String, String, String, Word64, Word64))]
forall a. IntMap a -> [(Int, a)]
IM.assocs (IntMap (String, String, String, Word64, Word64)
 -> [(Int, (String, String, String, Word64, Word64))])
-> IntMap (String, String, String, Word64, Word64)
-> [(Int, (String, String, String, Word64, Word64))]
forall a b. (a -> b) -> a -> b
$ (a, b, c) -> IntMap (String, String, String, Word64, Word64)
forall {a} {b} {c}.
BinaryClass a =>
(a, b, c) -> IntMap (String, String, String, Word64, Word64)
internal_labels_outside_of_sections (a, b, c)
l

  mk_internal :: (a, (String, String, String, Word64, Word64)) -> [String]
mk_internal (a
a,(String
sym,String
segment,String
section,Word64
a0,Word64
offset)) = [String
"%define " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sym String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NASM_Label -> String
forall {a}. Show a => a -> String
show (String -> String -> Word64 -> Word64 -> NASM_Label
macro_name String
segment String
section Word64
a0 Word64
offset)]

  mk_macro :: (String, String, Word64, d, e) -> String
mk_macro (String
segment,String
section,Word64
a0,d
sz,e
_) = String
"%define " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> Word64 -> String
forall {a}. Integral a => String -> String -> a -> String
show_macro_name String
segment String
section Word64
a0 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(offset) (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ NASM_Label -> String
forall {a}. Show a => a -> String
show (String -> String -> Word64 -> NASM_Label
section_label String
segment String
section Word64
a0) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" + offset)"


is_internal_symbol :: Symbol -> Bool
is_internal_symbol (AddressOfLabel String
_ Bool
False) = Bool
True
is_internal_symbol Symbol
_                        = Bool
False

internal_labels_outside_of_sections :: (a, b, c) -> IntMap (String, String, String, Word64, Word64)
internal_labels_outside_of_sections l :: (a, b, c)
l@(a
bin,b
_,c
l0) = (Int -> Symbol -> Maybe (String, String, String, Word64, Word64))
-> IntMap Symbol -> IntMap (String, String, String, Word64, Word64)
forall a b. (Int -> a -> Maybe b) -> IntMap a -> IntMap b
IM.mapMaybeWithKey Int -> Symbol -> Maybe (String, String, String, Word64, Word64)
forall {a}.
Integral a =>
a -> Symbol -> Maybe (String, String, String, Word64, Word64)
mk (IntMap Symbol -> IntMap (String, String, String, Word64, Word64))
-> IntMap Symbol -> IntMap (String, String, String, Word64, Word64)
forall a b. (a -> b) -> a -> b
$ (Int -> Symbol -> Bool) -> IntMap Symbol -> IntMap Symbol
forall a. (Int -> a -> Bool) -> IntMap a -> IntMap a
IM.filterWithKey Int -> Symbol -> Bool
forall {a} {p}. Integral a => a -> p -> Bool
is_outside_section (IntMap Symbol -> IntMap Symbol) -> IntMap Symbol -> IntMap Symbol
forall a b. (a -> b) -> a -> b
$ (Symbol -> Bool) -> IntMap Symbol -> IntMap Symbol
forall a. (a -> Bool) -> IntMap a -> IntMap a
IM.filter Symbol -> Bool
is_internal_symbol (IntMap Symbol -> IntMap Symbol) -> IntMap Symbol -> IntMap Symbol
forall a b. (a -> b) -> a -> b
$ a -> IntMap Symbol
forall {a}. BinaryClass a => a -> IntMap Symbol
binary_get_symbol_table a
bin
 where
  is_outside_section :: a -> p -> Bool
is_outside_section a
a p
_ = a -> Word64 -> Maybe (String, String, Word64, Word64, Word64)
forall bin.
BinaryClass bin =>
bin -> Word64 -> Maybe (String, String, Word64, Word64, Word64)
find_section_for_address a
bin (a -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a) Maybe (String, String, Word64, Word64, Word64)
-> Maybe (String, String, Word64, Word64, Word64) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe (String, String, Word64, Word64, Word64)
forall a. Maybe a
Nothing

  mk :: a -> Symbol -> Maybe (String, String, String, Word64, Word64)
mk a
a (AddressOfLabel String
sym Bool
False) = 
    case a -> Maybe (String, String, Word64, Word64, Word64)
forall {a}.
Integral a =>
a -> Maybe (String, String, Word64, Word64, Word64)
find_preceding_section a
a of
      Maybe (String, String, Word64, Word64, Word64)
Nothing -> Maybe (String, String, String, Word64, Word64)
forall a. Maybe a
Nothing
      Just (String
segment,String
section,Word64
a0,Word64
si,Word64
_) -> (String, String, String, Word64, Word64)
-> Maybe (String, String, String, Word64, Word64)
forall a. a -> Maybe a
Just (String
sym,String
segment,String
section,Word64
a0,a -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
a0)
    
  find_preceding_section :: a -> Maybe (String, String, Word64, Word64, Word64)
find_preceding_section a
a =
    case ((String, String, Word64, Word64, Word64)
 -> (String, String, Word64, Word64, Word64) -> Ordering)
-> [(String, String, Word64, Word64, Word64)]
-> [(String, String, Word64, Word64, Word64)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (a
-> (String, String, Word64, Word64, Word64)
-> (String, String, Word64, Word64, Word64)
-> Ordering
forall {a} {a} {a} {b} {e} {a} {b} {e}.
(Integral a, Num a, Ord a) =>
a -> (a, b, a, a, e) -> (a, b, a, a, e) -> Ordering
distance a
a) ([(String, String, Word64, Word64, Word64)]
 -> [(String, String, Word64, Word64, Word64)])
-> [(String, String, Word64, Word64, Word64)]
-> [(String, String, Word64, Word64, Word64)]
forall a b. (a -> b) -> a -> b
$ ((String, String, Word64, Word64, Word64) -> Bool)
-> [(String, String, Word64, Word64, Word64)]
-> [(String, String, Word64, Word64, Word64)]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> (String, String, Word64, Word64, Word64) -> Bool
forall {a} {a} {a} {b} {e}.
(Integral a, Num a, Ord a) =>
a -> (a, b, a, a, e) -> Bool
is_after a
a) (SectionsInfo -> [(String, String, Word64, Word64, Word64)]
si_sections (SectionsInfo -> [(String, String, Word64, Word64, Word64)])
-> SectionsInfo -> [(String, String, Word64, Word64, Word64)]
forall a b. (a -> b) -> a -> b
$ a -> SectionsInfo
forall a. BinaryClass a => a -> SectionsInfo
binary_get_sections_info a
bin) of
      []      -> Maybe (String, String, Word64, Word64, Word64)
forall a. Maybe a
Nothing
      ((String, String, Word64, Word64, Word64)
sec:[(String, String, Word64, Word64, Word64)]
_) -> (String, String, Word64, Word64, Word64)
-> Maybe (String, String, Word64, Word64, Word64)
forall a. a -> Maybe a
Just (String, String, Word64, Word64, Word64)
sec

  distance :: a -> (a, b, a, a, e) -> (a, b, a, a, e) -> Ordering
distance a
a (a
_,b
_,a
a0,a
si,e
_) (a
_,b
_,a
a0',a
si',e
_) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a a -> a -> a
forall a. Num a => a -> a -> a
- a
a0 a -> a -> a
forall a. Num a => a -> a -> a
- a
si) (a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a a -> a -> a
forall a. Num a => a -> a -> a
- a
a0' a -> a -> a
forall a. Num a => a -> a -> a
- a
si')
  is_after :: a -> (a, b, a, a, e) -> Bool
is_after a
a (a
_,b
_,a
a0,a
si,e
_) = a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
a0 a -> a -> a
forall a. Num a => a -> a -> a
+ a
si





-- TODO to Base
(|||) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
||| :: forall a. (a -> Bool) -> (a -> Bool) -> a -> Bool
(|||) a -> Bool
p a -> Bool
q a
a = a -> Bool
p a
a Bool -> Bool -> Bool
|| a -> Bool
q a
a
infixr 2 |||





ro_data_section :: (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> [NASM_DataSection]
ro_data_section (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
ctxt = (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> ((String, String, Word64, Word64, Word64) -> Bool)
-> (a -> Word64 -> Int -> Maybe [Word8])
-> [NASM_DataSection]
forall {a} {t} {t}.
(BinaryClass a, Num t, Num t) =>
(a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> ((String, String, Word64, Word64, Word64) -> Bool)
-> (a -> t -> t -> Maybe [Word8])
-> [NASM_DataSection]
generic_data_section (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
ctxt (String, String, Word64, Word64, Word64) -> Bool
forall {c} {d} {e}. (String, String, c, d, e) -> Bool
is_ro_data_section a -> Word64 -> Int -> Maybe [Word8]
forall a. BinaryClass a => a -> Word64 -> Int -> Maybe [Word8]
binary_read_ro_data
data_section :: (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> [NASM_DataSection]
data_section (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
ctxt    = (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> ((String, String, Word64, Word64, Word64) -> Bool)
-> (a -> Word64 -> Int -> Maybe [Word8])
-> [NASM_DataSection]
forall {a} {t} {t}.
(BinaryClass a, Num t, Num t) =>
(a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> ((String, String, Word64, Word64, Word64) -> Bool)
-> (a -> t -> t -> Maybe [Word8])
-> [NASM_DataSection]
generic_data_section (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
ctxt (String, String, Word64, Word64, Word64) -> Bool
forall {c} {d} {e}. (String, String, c, d, e) -> Bool
is_data_section    a -> Word64 -> Int -> Maybe [Word8]
forall a. BinaryClass a => a -> Word64 -> Int -> Maybe [Word8]
binary_read_data


generic_data_section :: (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> ((String, String, Word64, Word64, Word64) -> Bool)
-> (a -> t -> t -> Maybe [Word8])
-> [NASM_DataSection]
generic_data_section l :: (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l@(a
bin,Config
_,L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue
l0) (String, String, Word64, Word64, Word64) -> Bool
pick_section a -> t -> t -> Maybe [Word8]
read_from = 
  ((String, String, Word64, Word64, Word64) -> NASM_DataSection)
-> [(String, String, Word64, Word64, Word64)] -> [NASM_DataSection]
forall a b. (a -> b) -> [a] -> [b]
map (String, String, Word64, Word64, Word64) -> NASM_DataSection
forall {a}.
Integral a =>
(String, String, Word64, Word64, a) -> NASM_DataSection
mk_data_section ([(String, String, Word64, Word64, Word64)] -> [NASM_DataSection])
-> [(String, String, Word64, Word64, Word64)] -> [NASM_DataSection]
forall a b. (a -> b) -> a -> b
$ ((String, String, Word64, Word64, Word64) -> Bool)
-> [(String, String, Word64, Word64, Word64)]
-> [(String, String, Word64, Word64, Word64)]
forall a. (a -> Bool) -> [a] -> [a]
filter (String, String, Word64, Word64, Word64) -> Bool
pick_section ([(String, String, Word64, Word64, Word64)]
 -> [(String, String, Word64, Word64, Word64)])
-> [(String, String, Word64, Word64, Word64)]
-> [(String, String, Word64, Word64, Word64)]
forall a b. (a -> b) -> a -> b
$ SectionsInfo -> [(String, String, Word64, Word64, Word64)]
si_sections (SectionsInfo -> [(String, String, Word64, Word64, Word64)])
-> SectionsInfo -> [(String, String, Word64, Word64, Word64)]
forall a b. (a -> b) -> a -> b
$ a -> SectionsInfo
forall a. BinaryClass a => a -> SectionsInfo
binary_get_sections_info a
bin
 where
  mk_data_section :: (String, String, Word64, Word64, a) -> NASM_DataSection
mk_data_section (String
segment,String
section,Word64
a0,Word64
sz,a
align) =
    let ([NASM_DataEntry]
entries,IntMap (Set NASM_Label)
labels) = State (IntMap (Set NASM_Label)) [NASM_DataEntry]
-> IntMap (Set NASM_Label)
-> ([NASM_DataEntry], IntMap (Set NASM_Label))
forall s a. State s a -> s -> (a, s)
runState (Word64
-> String
-> String
-> Word64
-> Word64
-> State (IntMap (Set NASM_Label)) [NASM_DataEntry]
forall {m :: * -> *}.
MonadState (IntMap (Set NASM_Label)) m =>
Word64
-> String -> String -> Word64 -> Word64 -> m [NASM_DataEntry]
mk_data_entries Word64
0 String
segment String
section Word64
a0 Word64
sz) IntMap (Set NASM_Label)
forall a. IntMap a
IM.empty in
      (String, String, Word64)
-> Int
-> IntMap (Set NASM_Label)
-> [NASM_DataEntry]
-> NASM_DataSection
NASM_DataSection (String
segment,String
section,Word64
a0) (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
align) (Integer
-> NASM_Label -> IntMap (Set NASM_Label) -> IntMap (Set NASM_Label)
forall {a} {a}.
(Integral a, Ord a) =>
a -> a -> IntMap (Set a) -> IntMap (Set a)
add_label Integer
0 (String -> String -> Word64 -> NASM_Label
section_label String
segment String
section Word64
a0) IntMap (Set NASM_Label)
labels) [NASM_DataEntry]
entries


  --mk_data_section (segment,section,a0,sz,align) = intercalate "\n" $
  -- [ "section " ++ section ++ " align=" ++ show align
  -- , section_label segment section a0 ++ ":" ]
  -- ++
  -- mk_data_entries 0 segment section a0 sz
  -- ++
  -- ["\n\n"] 

  mk_data_entries :: Word64
-> String -> String -> Word64 -> Word64 -> m [NASM_DataEntry]
mk_data_entries Word64
offset String
segment String
section Word64
a0 Word64
sz 
    | Word64
offset Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
sz  = [NASM_DataEntry] -> m [NASM_DataEntry]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    | Word64
offset Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
sz = do
      (IntMap (Set NASM_Label) -> IntMap (Set NASM_Label)) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IntMap (Set NASM_Label) -> IntMap (Set NASM_Label)) -> m ())
-> (IntMap (Set NASM_Label) -> IntMap (Set NASM_Label)) -> m ()
forall a b. (a -> b) -> a -> b
$ Word64
-> NASM_Label -> IntMap (Set NASM_Label) -> IntMap (Set NASM_Label)
forall {a} {a}.
(Integral a, Ord a) =>
a -> a -> IntMap (Set a) -> IntMap (Set a)
add_label Word64
offset ((String, String, Word64, Word64, Integer) -> NASM_Label
forall {e}. (String, String, Word64, Word64, e) -> NASM_Label
end_of_section_label (String
segment,String
section,Word64
0,Word64
0,Integer
0))
      [NASM_DataEntry] -> m [NASM_DataEntry]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    | Bool
otherwise = 
      case Word64 -> Word64 -> Word64 -> [Word8]
forall {t}. Integral t => t -> t -> t -> [Word8]
takeWhileString Word64
offset Word64
a0 Word64
sz of
        []  -> Word64
-> String -> String -> Word64 -> Word64 -> m [NASM_DataEntry]
mk_data_entries_no_string Word64
offset String
segment String
section Word64
a0 Word64
sz
        [Word8]
str -> let offset' :: Word64
offset' = Word64
offset Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word8] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
str) in
                 if Word64
offset' Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
sz Bool -> Bool -> Bool
&& Word64 -> Word64 -> Word8
forall {a}. Integral a => a -> a -> Word8
read_byte Word64
offset' Word64
a0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0 then do
                   [NASM_DataEntry]
entries <- Word64
-> String -> String -> Word64 -> Word64 -> m [NASM_DataEntry]
mk_data_entries (Word64
offset' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) String
segment String
section Word64
a0 Word64
sz
                   [NASM_DataEntry] -> m [NASM_DataEntry]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([NASM_DataEntry] -> m [NASM_DataEntry])
-> [NASM_DataEntry] -> m [NASM_DataEntry]
forall a b. (a -> b) -> a -> b
$ (Word64 -> [Word8] -> NASM_DataEntry
DataEntry_String (Word64
a0 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
offset) [Word8]
str) NASM_DataEntry -> [NASM_DataEntry] -> [NASM_DataEntry]
forall a. a -> [a] -> [a]
: [NASM_DataEntry]
entries
                   -- ["db `" ++ concat str ++ "`" ++ ", 0"] ++ mk_data_entries (offset' + 1) segment section a0 sz
                 else
                   Word64
-> String -> String -> Word64 -> Word64 -> m [NASM_DataEntry]
mk_data_entries_no_string Word64
offset String
segment String
section Word64
a0 Word64
sz

  mk_data_entries_no_string :: Word64
-> String -> String -> Word64 -> Word64 -> m [NASM_DataEntry]
mk_data_entries_no_string Word64
offset String
segment String
section Word64
a0 Word64
sz =
    case Word64 -> Word64 -> Maybe Relocation
forall {a}. Integral a => a -> a -> Maybe Relocation
find_reloc Word64
offset Word64
a0 of
      Just (Relocation Word64
_ Word64
a1) -> do
        [NASM_DataEntry]
entries <- Word64
-> String -> String -> Word64 -> Word64 -> m [NASM_DataEntry]
mk_data_entries (Word64
offsetWord64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+Word64
8) String
segment String
section Word64
a0 Word64
sz
        (IntMap (Set NASM_Label) -> IntMap (Set NASM_Label)) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IntMap (Set NASM_Label) -> IntMap (Set NASM_Label)) -> m ())
-> (IntMap (Set NASM_Label) -> IntMap (Set NASM_Label)) -> m ()
forall a b. (a -> b) -> a -> b
$ Word64
-> NASM_Label -> IntMap (Set NASM_Label) -> IntMap (Set NASM_Label)
forall {a} {a}.
(Integral a, Ord a) =>
a -> a -> IntMap (Set a) -> IntMap (Set a)
add_label Word64
offset (Word64 -> NASM_Label
mk_reloc_label (Word64
a0 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
offset))
        [NASM_DataEntry] -> m [NASM_DataEntry]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([NASM_DataEntry] -> m [NASM_DataEntry])
-> [NASM_DataEntry] -> m [NASM_DataEntry]
forall a b. (a -> b) -> a -> b
$ (Word64 -> (NASM_Address, Annot) -> NASM_DataEntry
DataEntry_Pointer (Word64
a0 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
offset) ((NASM_Address, Annot) -> NASM_DataEntry)
-> (NASM_Address, Annot) -> NASM_DataEntry
forall a b. (a -> b) -> a -> b
$ (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> Word64 -> (NASM_Address, Annot)
forall bin.
BinaryClass bin =>
LiftedC bin -> Word64 -> (NASM_Address, Annot)
try_symbolize_imm (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l Word64
a1) NASM_DataEntry -> [NASM_DataEntry] -> [NASM_DataEntry]
forall a. a -> [a] -> [a]
: [NASM_DataEntry]
entries
      --  [mk_reloc_label (a0 + offset) ++ ":"] ++ ["dq " ++ try_symbolize_imm ctxt a1] ++ mk_data_entries (offset+8) segment section a0 sz
      Maybe Relocation
_ -> case Int -> IntMap Symbol -> Maybe Symbol
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ Word64
a0 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
offset) (IntMap Symbol -> Maybe Symbol) -> IntMap Symbol -> Maybe Symbol
forall a b. (a -> b) -> a -> b
$ a -> IntMap Symbol
forall {a}. BinaryClass a => a -> IntMap Symbol
binary_get_symbol_table a
bin of
             Just (PointerToLabel String
sym Bool
_) -> do
               [NASM_DataEntry]
entries <- Word64
-> String -> String -> Word64 -> Word64 -> m [NASM_DataEntry]
mk_data_entries (Word64
offsetWord64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+Word64
8) String
segment String
section Word64
a0 Word64
sz
               [NASM_DataEntry] -> m [NASM_DataEntry]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([NASM_DataEntry] -> m [NASM_DataEntry])
-> [NASM_DataEntry] -> m [NASM_DataEntry]
forall a b. (a -> b) -> a -> b
$ (Word64 -> (NASM_Address, Annot) -> NASM_DataEntry
DataEntry_Pointer (Word64
a0 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
offset) (Symbol -> NASM_Address
NASM_Addr_Symbol (String -> Bool -> Symbol
PointerToLabel String
sym Bool
False),[])) NASM_DataEntry -> [NASM_DataEntry] -> [NASM_DataEntry]
forall a. a -> [a] -> [a]
: [NASM_DataEntry]
entries
             -- Just sym -> error $ show (showHex (a0+offset),sym)
             Maybe Symbol
_ -> do
               [NASM_DataEntry]
entries <- Word64
-> String -> String -> Word64 -> Word64 -> m [NASM_DataEntry]
mk_data_entries (Word64
offsetWord64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+Word64
1) String
segment String
section Word64
a0 Word64
sz
               [NASM_DataEntry] -> m [NASM_DataEntry]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([NASM_DataEntry] -> m [NASM_DataEntry])
-> [NASM_DataEntry] -> m [NASM_DataEntry]
forall a b. (a -> b) -> a -> b
$ (Word64 -> Word8 -> NASM_DataEntry
DataEntry_Byte (Word64
a0 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
offset) (Word8 -> NASM_DataEntry) -> Word8 -> NASM_DataEntry
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Word8
forall {a}. Integral a => a -> a -> Word8
read_byte Word64
offset Word64
a0) NASM_DataEntry -> [NASM_DataEntry] -> [NASM_DataEntry]
forall a. a -> [a] -> [a]
: [NASM_DataEntry]
entries
               -- ["db 0" ++ showHex (read_byte offset a0) ++ "h"] ++ mk_data_entries (offset+1) segment section a0 sz


  mk_reloc_label :: Word64 -> NASM_Label
mk_reloc_label Word64
a0 = (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> Integer -> Word64 -> Integer -> NASM_Label
forall {p} {p} {a} {b} {c}.
(Show p, Integral p, Num p, Eq p, BinaryClass a) =>
(a, b, c) -> p -> Word64 -> p -> NASM_Label
block_label (a, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l Integer
0 Word64
a0 Integer
0

  takeWhileString :: t -> t -> t -> [Word8]
takeWhileString t
offset t
a0 t
sz
    | t -> t -> Maybe Relocation
forall {a}. Integral a => a -> a -> Maybe Relocation
find_reloc t
offset t
a0 Maybe Relocation -> Maybe Relocation -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Relocation
forall a. Maybe a
Nothing        = []
    | t
offset t -> t -> Bool
forall a. Ord a => a -> a -> Bool
>= t
sz                           = []
    | Char -> Bool
valid_char (Word8 -> Char
w2c (Word8 -> Char) -> Word8 -> Char
forall a b. (a -> b) -> a -> b
$ t -> t -> Word8
forall {a}. Integral a => a -> a -> Word8
read_byte t
offset t
a0) = (t -> t -> Word8
forall {a}. Integral a => a -> a -> Word8
read_byte t
offset t
a0) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: t -> t -> t -> [Word8]
takeWhileString (t
offsett -> t -> t
forall a. Num a => a -> a -> a
+t
1) t
a0 t
sz
    | Bool
otherwise                              = []

  valid_char :: Char -> Bool
valid_char Char
c = Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"!@#$%^&*()_-+={}[]:;|/?<>,. ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz1234567890'\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
escape_chars
  escape_chars :: String
escape_chars = String
"`\\\n\t"


  add_label :: a -> a -> IntMap (Set a) -> IntMap (Set a)
add_label a
offset a
label = (Set a -> Set a -> Set a)
-> Int -> Set a -> IntMap (Set a) -> IntMap (Set a)
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.union (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
offset) (a -> Set a
forall a. a -> Set a
S.singleton a
label)


  find_reloc :: a -> a -> Maybe Relocation
find_reloc a
offset a
a0 = (Relocation -> Bool) -> Set Relocation -> Maybe Relocation
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Word64 -> Relocation -> Bool
reloc_for (Word64 -> Relocation -> Bool) -> Word64 -> Relocation -> Bool
forall a b. (a -> b) -> a -> b
$ a -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
a0 a -> a -> a
forall a. Num a => a -> a -> a
+ a
offset)) (Set Relocation -> Maybe Relocation)
-> Set Relocation -> Maybe Relocation
forall a b. (a -> b) -> a -> b
$ a -> Set Relocation
forall a. BinaryClass a => a -> Set Relocation
binary_get_relocations a
bin
  read_byte :: a -> a -> Word8
read_byte  a
offset a
a0 = 
    case a -> t -> t -> Maybe [Word8]
read_from a
bin (a -> t
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> t) -> a -> t
forall a b. (a -> b) -> a -> b
$ a
a0 a -> a -> a
forall a. Num a => a -> a -> a
+ a
offset) t
1 of
      Just [Word8
v] -> Word8
v

try_symbolize_imm :: BinaryClass bin => LiftedC bin -> Word64 -> (NASM_Address,Annot)
try_symbolize_imm :: forall bin.
BinaryClass bin =>
LiftedC bin -> Word64 -> (NASM_Address, Annot)
try_symbolize_imm l :: LiftedC bin
l@(bin
bin,Config
_,L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue
l0) Word64
a1 = 
  case LiftedC bin
-> Maybe (Int, CFG)
-> Bool
-> Word64
-> Maybe (NASM_Address, Annot)
forall bin.
BinaryClass bin =>
LiftedC bin
-> Maybe (Int, CFG)
-> Bool
-> Word64
-> Maybe (NASM_Address, Annot)
symbolize_immediate LiftedC bin
l Maybe (Int, CFG)
forall a. Maybe a
Nothing Bool
False Word64
a1 of
    Just (NASM_Address
str,Annot
annot) -> if String
"RELA_.text" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` (NASM_Address -> String
forall {a}. Show a => a -> String
show NASM_Address
str) then String -> (NASM_Address, Annot) -> (NASM_Address, Annot)
forall a b. Show a => a -> b -> b
traceShow (String
"ERROR: UNTRANSLATED ENTRY ADDRESS " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall {a}. Integral a => a -> String
showHex Word64
a1) (NASM_Address
str,Annot
annot) else (NASM_Address
str,Annot
annot) -- show str ++ "    ; " ++ render_annot annot
    Maybe (NASM_Address, Annot)
Nothing          -> String -> (NASM_Address, Annot)
forall a. HasCallStack => String -> a
error (String -> (NASM_Address, Annot))
-> String -> (NASM_Address, Annot)
forall a b. (a -> b) -> a -> b
$ String
"ERROR: could not symbolize relocated immediate value 0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall {a}. Integral a => a -> String
showHex Word64
a1

bss_data_section :: (a, b, c) -> [NASM_DataSection]
bss_data_section l :: (a, b, c)
l@(a
bin,b
_,c
l0) = 
  ((String, String, Word64, Word64, Word64) -> NASM_DataSection)
-> [(String, String, Word64, Word64, Word64)] -> [NASM_DataSection]
forall a b. (a -> b) -> [a] -> [b]
map (String, String, Word64, Word64, Word64) -> NASM_DataSection
forall {a}.
Integral a =>
(String, String, Word64, Word64, a) -> NASM_DataSection
mk_bss_data_section ([(String, String, Word64, Word64, Word64)] -> [NASM_DataSection])
-> [(String, String, Word64, Word64, Word64)] -> [NASM_DataSection]
forall a b. (a -> b) -> a -> b
$ ((String, String, Word64, Word64, Word64) -> Bool)
-> [(String, String, Word64, Word64, Word64)]
-> [(String, String, Word64, Word64, Word64)]
forall a. (a -> Bool) -> [a] -> [a]
filter (String, String, Word64, Word64, Word64) -> Bool
forall {c} {d} {e}. (String, String, c, d, e) -> Bool
is_bss_data_section ([(String, String, Word64, Word64, Word64)]
 -> [(String, String, Word64, Word64, Word64)])
-> [(String, String, Word64, Word64, Word64)]
-> [(String, String, Word64, Word64, Word64)]
forall a b. (a -> b) -> a -> b
$ SectionsInfo -> [(String, String, Word64, Word64, Word64)]
si_sections (SectionsInfo -> [(String, String, Word64, Word64, Word64)])
-> SectionsInfo -> [(String, String, Word64, Word64, Word64)]
forall a b. (a -> b) -> a -> b
$ a -> SectionsInfo
forall a. BinaryClass a => a -> SectionsInfo
binary_get_sections_info a
bin
 where
  mk_bss_data_section :: (String, String, Word64, Word64, a) -> NASM_DataSection
mk_bss_data_section (String
segment,String
section,Word64
a0,Word64
sz,a
align) = 
    let ([NASM_DataEntry]
entries,IntMap (Set NASM_Label)
labels) = State (IntMap (Set NASM_Label)) [NASM_DataEntry]
-> IntMap (Set NASM_Label)
-> ([NASM_DataEntry], IntMap (Set NASM_Label))
forall s a. State s a -> s -> (a, s)
runState (String
-> String
-> Word64
-> Word64
-> State (IntMap (Set NASM_Label)) [NASM_DataEntry]
forall {m :: * -> *}.
MonadState (IntMap (Set NASM_Label)) m =>
String -> String -> Word64 -> Word64 -> m [NASM_DataEntry]
mk_bss String
segment String
section Word64
a0 Word64
sz) IntMap (Set NASM_Label)
forall a. IntMap a
IM.empty in
      (String, String, Word64)
-> Int
-> IntMap (Set NASM_Label)
-> [NASM_DataEntry]
-> NASM_DataSection
NASM_DataSection (String
segment,String
section,Word64
a0) (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
align) (Int
-> Set NASM_Label
-> IntMap (Set NASM_Label)
-> IntMap (Set NASM_Label)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
0 (NASM_Label -> Set NASM_Label
forall a. a -> Set a
S.singleton (NASM_Label -> Set NASM_Label) -> NASM_Label -> Set NASM_Label
forall a b. (a -> b) -> a -> b
$ String -> String -> Word64 -> NASM_Label
section_label String
segment String
section Word64
a0) IntMap (Set NASM_Label)
labels) [NASM_DataEntry]
entries
-- "section " ++ section ++ " align=" ++ show align ++ "\n" ++ section_label segment section a0 ++ ":\n" ++ mk_bss segment section a0 sz

  mk_bss :: String -> String -> Word64 -> Word64 -> m [NASM_DataEntry]
mk_bss String
segment String
section Word64
a0 Word64
sz =
    case [Word64] -> [Word64]
forall a. Ord a => [a] -> [a]
sort ([Word64] -> [Word64]) -> [Word64] -> [Word64]
forall a b. (a -> b) -> a -> b
$ (Relocation -> Word64) -> [Relocation] -> [Word64]
forall a b. (a -> b) -> [a] -> [b]
map Relocation -> Word64
get_addr ([Relocation] -> [Word64]) -> [Relocation] -> [Word64]
forall a b. (a -> b) -> a -> b
$ (Relocation -> Bool) -> [Relocation] -> [Relocation]
forall a. (a -> Bool) -> [a] -> [a]
filter (Word64 -> Word64 -> Relocation -> Bool
forall {a}. Integral a => a -> a -> Relocation -> Bool
was_relocated_and_in Word64
a0 Word64
sz) ([Relocation] -> [Relocation]) -> [Relocation] -> [Relocation]
forall a b. (a -> b) -> a -> b
$ Set Relocation -> [Relocation]
forall a. Set a -> [a]
S.toList (Set Relocation -> [Relocation]) -> Set Relocation -> [Relocation]
forall a b. (a -> b) -> a -> b
$ a -> Set Relocation
forall a. BinaryClass a => a -> Set Relocation
binary_get_relocations a
bin of
      [] -> do
        (IntMap (Set NASM_Label) -> IntMap (Set NASM_Label)) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IntMap (Set NASM_Label) -> IntMap (Set NASM_Label)) -> m ())
-> (IntMap (Set NASM_Label) -> IntMap (Set NASM_Label)) -> m ()
forall a b. (a -> b) -> a -> b
$ Word64
-> NASM_Label -> IntMap (Set NASM_Label) -> IntMap (Set NASM_Label)
forall {a} {a}.
(Integral a, Ord a) =>
a -> a -> IntMap (Set a) -> IntMap (Set a)
addlabel Word64
sz ((String, String, Word64, Word64, Integer) -> NASM_Label
forall {e}. (String, String, Word64, Word64, e) -> NASM_Label
end_of_section_label (String
segment,String
section,Word64
0,Word64
0,Integer
0))
        [NASM_DataEntry] -> m [NASM_DataEntry]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([NASM_DataEntry] -> m [NASM_DataEntry])
-> [NASM_DataEntry] -> m [NASM_DataEntry]
forall a b. (a -> b) -> a -> b
$ [Int -> NASM_DataEntry
DataEntry_BSS (Int -> NASM_DataEntry) -> Int -> NASM_DataEntry
forall a b. (a -> b) -> a -> b
$ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
sz]
      (Word64
a:[Word64]
_) -> do
        (IntMap (Set NASM_Label) -> IntMap (Set NASM_Label)) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IntMap (Set NASM_Label) -> IntMap (Set NASM_Label)) -> m ())
-> (IntMap (Set NASM_Label) -> IntMap (Set NASM_Label)) -> m ()
forall a b. (a -> b) -> a -> b
$ Word64
-> NASM_Label -> IntMap (Set NASM_Label) -> IntMap (Set NASM_Label)
forall {a} {a}.
(Integral a, Ord a) =>
a -> a -> IntMap (Set a) -> IntMap (Set a)
addlabel (Word64
a Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
a0) (Word64 -> NASM_Label
mk_reloc_label Word64
a)
        [NASM_DataEntry]
entries <- String -> String -> Word64 -> Word64 -> m [NASM_DataEntry]
mk_bss String
segment String
section (Word64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
a) (Word64
sz Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
a0 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
a)
        [NASM_DataEntry] -> m [NASM_DataEntry]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([NASM_DataEntry] -> m [NASM_DataEntry])
-> [NASM_DataEntry] -> m [NASM_DataEntry]
forall a b. (a -> b) -> a -> b
$ (Int -> NASM_DataEntry
DataEntry_BSS (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ Word64
a Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
a0)) NASM_DataEntry -> [NASM_DataEntry] -> [NASM_DataEntry]
forall a. a -> [a] -> [a]
: [NASM_DataEntry]
entries

     -- [] ->  "resb " ++ show sz ++ "\n" ++ end_of_section_label (segment,section,0,0,0) ++ ":"
     -- (a:_) -> "resb " ++ show (fromIntegral a - a0) ++ "\n" ++ mk_reloc_label a ++ ":\n" ++ mk_bss segment section (fromIntegral a) (sz + a0 - fromIntegral a)

  mk_reloc_label :: Word64 -> NASM_Label
mk_reloc_label Word64
a0 = (a, b, c) -> Integer -> Word64 -> Integer -> NASM_Label
forall {p} {p} {a} {b} {c}.
(Show p, Integral p, Num p, Eq p, BinaryClass a) =>
(a, b, c) -> p -> Word64 -> p -> NASM_Label
block_label (a, b, c)
l Integer
0 Word64
a0 Integer
0

  addlabel :: a -> a -> IntMap (Set a) -> IntMap (Set a)
addlabel a
offset a
label = (Set a -> Set a -> Set a)
-> Int -> Set a -> IntMap (Set a) -> IntMap (Set a)
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.union (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
offset) (a -> Set a
forall a. a -> Set a
S.singleton a
label)

  get_addr :: Relocation -> Word64
get_addr (Relocation Word64
a0 Word64
_) = Word64
a0
  was_relocated_and_in :: a -> a -> Relocation -> Bool
was_relocated_and_in a
a0 a
sz (Relocation Word64
a Word64
a1) = a -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a0 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
a Bool -> Bool -> Bool
&& Word64
a Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< a -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
a0 a -> a -> a
forall a. Num a => a -> a -> a
+ a
sz)-- TODO note strict inequality here



-- Get an overview of all indirections (entry,cfg,i) where entry is the entry-point of the function, cfg is the CFG of the function and i is an in instruction that performs an indirection
get_indirections_per_function :: (a, b, L0 pred finit v) -> [(Int, CFG, (Int, Indirections))]
get_indirections_per_function l :: (a, b, L0 pred finit v)
l@(a
bin,b
_,L0 pred finit v
l0) = (Int -> [(Int, CFG, (Int, Indirections))])
-> [Int] -> [(Int, CFG, (Int, Indirections))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Int -> [(Int, CFG, (Int, Indirections))]
get ([Int] -> [(Int, CFG, (Int, Indirections))])
-> [Int] -> [(Int, CFG, (Int, Indirections))]
forall a b. (a -> b) -> a -> b
$ Set Int -> [Int]
forall a. Set a -> [a]
S.toList (Set Int -> [Int]) -> Set Int -> [Int]
forall a b. (a -> b) -> a -> b
$ L0 pred finit v -> Set Int
forall pred finit v. L0 pred finit v -> Set Int
l0_get_function_entries L0 pred finit v
l0
 where
  get :: Int -> [(Int, CFG, (Int, Indirections))]
get Int
entry =
    let Just CFG
cfg = Int -> IntMap CFG -> Maybe CFG
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
entry (L0 pred finit v -> IntMap CFG
forall pred finit v. L0 pred finit v -> IntMap CFG
l0_get_cfgs L0 pred finit v
l0) in
      ((Int, Indirections) -> (Int, CFG, (Int, Indirections)))
-> [(Int, Indirections)] -> [(Int, CFG, (Int, Indirections))]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int, Indirections)
i -> (Int
entry,CFG
cfg,(Int, Indirections)
i)) ([(Int, Indirections)] -> [(Int, CFG, (Int, Indirections))])
-> [(Int, Indirections)] -> [(Int, CFG, (Int, Indirections))]
forall a b. (a -> b) -> a -> b
$ ((Int, Indirections) -> Bool)
-> [(Int, Indirections)] -> [(Int, Indirections)]
forall a. (a -> Bool) -> [a] -> [a]
filter (CFG -> (Int, Indirections) -> Bool
forall {a} {b}. Integral a => CFG -> (a, b) -> Bool
indirection_in_cfg CFG
cfg) ([(Int, Indirections)] -> [(Int, Indirections)])
-> [(Int, Indirections)] -> [(Int, Indirections)]
forall a b. (a -> b) -> a -> b
$ IntMap Indirections -> [(Int, Indirections)]
forall a. IntMap a -> [(Int, a)]
IM.assocs (IntMap Indirections -> [(Int, Indirections)])
-> IntMap Indirections -> [(Int, Indirections)]
forall a b. (a -> b) -> a -> b
$ L0 pred finit v -> IntMap Indirections
forall pred finit v. L0 pred finit v -> IntMap Indirections
l0_indirections L0 pred finit v
l0
  indirection_in_cfg :: CFG -> (a, b) -> Bool
indirection_in_cfg CFG
cfg (a
a,b
_) = ([Instruction] -> Bool) -> IntMap [Instruction] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Instruction -> Bool) -> [Instruction] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Instruction
i -> Instruction -> Word64
inAddress Instruction
i Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a)) (IntMap [Instruction] -> Bool) -> IntMap [Instruction] -> Bool
forall a b. (a -> b) -> a -> b
$ CFG -> IntMap [Instruction]
cfg_instrs CFG
cfg

get_terminals_per_function :: (a, Config, L0 pred finit v) -> [Instruction]
get_terminals_per_function l :: (a, Config, L0 pred finit v)
l@(a
bin,Config
_,L0 pred finit v
l0) = (Int -> [Instruction]) -> [Int] -> [Instruction]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Int -> [Instruction]
get ([Int] -> [Instruction]) -> [Int] -> [Instruction]
forall a b. (a -> b) -> a -> b
$ Set Int -> [Int]
forall a. Set a -> [a]
S.toList (Set Int -> [Int]) -> Set Int -> [Int]
forall a b. (a -> b) -> a -> b
$ L0 pred finit v -> Set Int
forall pred finit v. L0 pred finit v -> Set Int
l0_get_function_entries L0 pred finit v
l0
 where
  get :: Int -> [Instruction]
get Int
entry =
    let Just CFG
cfg = Int -> IntMap CFG -> Maybe CFG
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
entry (L0 pred finit v -> IntMap CFG
forall pred finit v. L0 pred finit v -> IntMap CFG
l0_get_cfgs L0 pred finit v
l0) in
      (Instruction -> Bool) -> [Instruction] -> [Instruction]
forall a. (a -> Bool) -> [a] -> [a]
filter ((a, Config, L0 pred finit v) -> Instruction -> Bool
forall {bin} {pred} {finit} {v}.
(BinaryClass bin, Eq pred) =>
Lifting bin pred finit v -> Instruction -> Bool
is_terminal_call (a, Config, L0 pred finit v)
l) ([Instruction] -> [Instruction]) -> [Instruction] -> [Instruction]
forall a b. (a -> b) -> a -> b
$ [[Instruction]] -> [Instruction]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Instruction]] -> [Instruction])
-> [[Instruction]] -> [Instruction]
forall a b. (a -> b) -> a -> b
$ IntMap [Instruction] -> [[Instruction]]
forall a. IntMap a -> [a]
IM.elems (IntMap [Instruction] -> [[Instruction]])
-> IntMap [Instruction] -> [[Instruction]]
forall a b. (a -> b) -> a -> b
$ CFG -> IntMap [Instruction]
cfg_instrs CFG
cfg


mk_jump_table :: (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> (Int, CFG, (a, Indirections)) -> String
mk_jump_table (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l (Int
entry,CFG
cfg,(a
a,Indirections
inds)) = (Indirection -> String) -> [Indirection] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Indirection -> String
mk ([Indirection] -> String) -> [Indirection] -> String
forall a b. (a -> b) -> a -> b
$ Indirections -> [Indirection]
forall a. Set a -> [a]
S.toList Indirections
inds
 where
  mk :: Indirection -> String
mk (Indirection_JumpTable (JumpTable Operand
index Int
bnd Operand
trgt IntMap Word64
tbl)) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ 
    [ String
"; JUMP TABLE: entry == " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall {a}. Integral a => a -> String
showHex Int
entry String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", instr@" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall {a}. Integral a => a -> String
showHex a
a
    , String
"section .bss"
    , NASM_Label -> String
forall {a}. Show a => a -> String
show (Int -> a -> Integer -> NASM_Label
forall {a} {a} {a}.
(Integral a, Integral a, Num a, Eq a) =>
a -> a -> a -> NASM_Label
label_jump_table_temp_storage Int
entry a
a Integer
0) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
    , String
"resb 8"
    , NASM_Label -> String
forall {a}. Show a => a -> String
show (Int -> a -> Integer -> NASM_Label
forall {a} {a} {a}.
(Integral a, Integral a, Num a, Eq a) =>
a -> a -> a -> NASM_Label
label_jump_table_temp_storage Int
entry a
a Integer
1) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
    , String
"resb 8"
    , String
"section .rodata"
    , NASM_Label -> String
forall {a}. Show a => a -> String
show (Int -> a -> NASM_Label
forall {a} {a}. (Integral a, Integral a) => a -> a -> NASM_Label
label_jump_table_redirect_data Int
entry a
a) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    ((Int, Word64) -> String) -> [(Int, Word64)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Word64) -> String
forall {a}. Show a => (a, Word64) -> String
mk_entry (((Int, Word64) -> (Int, Word64) -> Ordering)
-> [(Int, Word64)] -> [(Int, Word64)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((Int, Word64) -> Int)
-> (Int, Word64)
-> (Int, Word64)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, Word64) -> Int
forall a b. (a, b) -> a
fst) ([(Int, Word64)] -> [(Int, Word64)])
-> [(Int, Word64)] -> [(Int, Word64)]
forall a b. (a -> b) -> a -> b
$ IntMap Word64 -> [(Int, Word64)]
forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap Word64
tbl)
  mk Indirection
_ = []

  mk_entry :: (a, Word64) -> String
mk_entry (a
idx,Word64
trgt) = 
    case (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
-> Maybe (Int, CFG)
-> Bool
-> Word64
-> Maybe (NASM_Address, Annot)
forall bin.
BinaryClass bin =>
LiftedC bin
-> Maybe (Int, CFG)
-> Bool
-> Word64
-> Maybe (NASM_Address, Annot)
symbolize_immediate (bin, Config,
 L0 (Sstate SValue SPointer) (FInit SValue SPointer) SValue)
l ((Int, CFG) -> Maybe (Int, CFG)
forall a. a -> Maybe a
Just (Int
entry,CFG
cfg)) Bool
False Word64
trgt of
      Just (NASM_Address
str,Annot
annot) -> String
"dq " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NASM_Address -> String
forall {a}. Show a => a -> String
show NASM_Address
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ; index " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall {a}. Show a => a -> String
show a
idx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    ; " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Annot -> String
render_annot Annot
annot
      Maybe (NASM_Address, Annot)
Nothing          -> String
"ERROR: cannot symbolize jump target:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall {a}. Integral a => a -> String
showHex Word64
trgt





regs_of_ops :: [Operand] -> [Register]
regs_of_ops = (Operand -> [Register]) -> [Operand] -> [Register]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Operand -> [Register]
regs_of_op

regs_of_op :: Operand -> [Register]
regs_of_op (Op_Mem BitSize
_ BitSize
_ Register
reg Register
idx Word8
_ Int
_ Maybe SReg
Nothing) = [Register
reg,Register
idx]
regs_of_op (Op_Mem BitSize
_ BitSize
_ Register
reg Register
idx Word8
_ Int
_ (Just SReg
seg)) = [Register
reg,Register
idx,SReg -> Register
RegSeg SReg
seg]
regs_of_op (Op_Reg Register
r) = [Register
r]
regs_of_op (Op_Near Operand
op) = Operand -> [Register]
regs_of_op Operand
op
regs_of_op (Op_Far Operand
op) = Operand -> [Register]
regs_of_op Operand
op
regs_of_op Operand
_ = []


register_set :: [Register]
register_set = (GPR -> Register) -> [GPR] -> [Register]
forall a b. (a -> b) -> [a] -> [b]
map GPR -> Register
Reg64 [GPR
RAX,GPR
RBX,GPR
RCX,GPR
RDX,GPR
R8,GPR
R9,GPR
R10,GPR
R11,GPR
R12,GPR
R13,GPR
R14,GPR
R15]


reg_of_size :: Register -> a -> Register
reg_of_size (Reg64 GPR
r) a
8 = GPR -> Register
Reg64 GPR
r
reg_of_size (Reg64 GPR
r) a
4 = GPR -> Register
Reg32 GPR
r
reg_of_size (Reg64 GPR
r) a
2 = GPR -> Register
Reg16 GPR
r
reg_of_size (Reg64 GPR
r) a
1 = GPR -> RegHalf -> Register
Reg8 GPR
r RegHalf
HalfL


reg_of_size Register
reg a
si = String -> Register
forall a. HasCallStack => String -> a
error (String -> Register) -> String -> Register
forall a b. (a -> b) -> a -> b
$ String
"Make register " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Register -> String
forall {a}. Show a => a -> String
show Register
reg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" of size " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall {a}. Show a => a -> String
show a
si 

find_element_not_in :: [t] -> t t -> t
find_element_not_in (t
a:[t]
as) t t
x = if t
a t -> t t -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t t
x then [t] -> t t -> t
find_element_not_in [t]
as t t
x else t
a


find_unused_register :: [Register] -> [Instruction] -> Register
find_unused_register :: [Register] -> [Instruction] -> Register
find_unused_register [Register]
regs [Instruction]
instrs = 
  let used_regs :: [Register]
used_regs = (Instruction -> [Register]) -> [Instruction] -> [Register]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Register -> Register) -> [Register] -> [Register]
forall a b. (a -> b) -> [a] -> [b]
map Register -> Register
real_reg ([Register] -> [Register])
-> (Instruction -> [Register]) -> Instruction -> [Register]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Operand] -> [Register]
regs_of_ops ([Operand] -> [Register])
-> (Instruction -> [Operand]) -> Instruction -> [Register]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Instruction -> [Operand]
get_ops) [Instruction]
instrs in
    [Register] -> [Register] -> Register
forall {t :: * -> *} {t}. (Foldable t, Eq t) => [t] -> t t -> t
find_element_not_in [Register]
regs [Register]
used_regs
 where
  get_ops :: Instruction -> [Operand]
get_ops i :: Instruction
i@(Instruction Word64
addr [Prefix]
pre Opcode
op Maybe Operand
Nothing [Operand]
ops Int
annot) = [Operand]
ops




-- | There is one specific symbol frequently encountered for which we cannot find the appropiate library to load.
-- It is related to debugging information (the -g option of GCC).
-- We therefore pvodie our own implementation: just a dummy, which is what the real function seems to do as well.
__gmon_start_implementation :: String
__gmon_start_implementation = String
"void __gmon_start__ () { return; }"