Skip to content

GitLab

Commit c1dce6dd authored by Axel Simon's avatar Axel Simon
Browse files

some restructuring

parent 43cc3e2e
Hide whitespace changes
Inline Side-by-side
detail/codegen/codegen-mangle.sml
View file @ c1dce6dd
......@@ -21,7 +21,7 @@ structure Mangle = struct
fun getString sym =
let
val s = VI.getString (!variables, sym)
val s = VI.getInternalString (!variables, sym)
in
if String.isPrefix "%" s then getStringOfPrim sym
else s
......
detail/desugar/desugar-decode-syntax.sml
View file @ c1dce6dd
......@@ -133,7 +133,7 @@ structure DesugarDecode = struct
and desugarMatches tok decls = let
(* +DEBUG:overlapping-patterns *)
val () = Pretty.prettyTo (TextIO.stdOut, layoutDecls decls)
(*val () = Pretty.prettyTo (TextIO.stdOut, layoutDecls decls) *)
val equiv = buildEquivClass decls
(* +DEBUG:overlapping-patterns *)
(* val () =
......
detail/driver/main.sml
View file @ c1dce6dd
......@@ -7,11 +7,13 @@ structure Main = struct
fun all ins =
Parser.run ins >>=
ResolveSymbols.run >>=
Desugar.run >>=
ResolveSymbols.run >>= (fn ast =>
ResolveTypeInfo.run ast >>= (fn tInfo =>
TypeInference.run (tInfo, ast) >>= (fn tys =>
Desugar.run ast >>=
CPSPasses.run >>=
CodegenPasses.run
)))
fun run fps = let
val ers = Error.mkErrStream'()
val () = Controls.set (BasicControl.verbose, 1)
......
detail/semantic/inference.sml
View file @ c1dce6dd
......@@ -651,7 +651,7 @@ fun typeInferencePass (errStrm, ti : TI.type_info, ast) = let
let
val env = infExp (st,env) e
val bVar = BD.freshBVar ()
val env = E.meetBoolean (BD.meetVarOne bVar, env)
(*val env = E.meetBoolean (BD.meetVarOne bVar, env)*)
in
((bVar, fid) :: nts, env)
end
......@@ -703,8 +703,7 @@ fun typeInferencePass (errStrm, ti : TI.type_info, ast) = let
(*val _ = TextIO.print ("**** rec update: pushing field " ^ SymbolTable.getString(!SymbolTables.fieldTable, fid) ^ ".\n")*)
val bVar = BD.freshBVar ()
val env = case eOpt of
SOME e => E.meetBoolean (BD.meetVarOne bVar,
infExp (st,env) e)
SOME e => infExp (st,env) e
| NONE => E.meetBoolean (BD.meetVarZero bVar,
E.pushTop env)
in
......
detail/semantic/symbol-table-type.sml
View file @ c1dce6dd
......@@ -33,6 +33,7 @@ signature SymbolTableSig = sig
val listItems: table -> symid list
val getAtom : (table * symid) -> Atom.atom
val getInternalString : (table * symid) -> string
val getString : (table * symid) -> string
val getSpan : (table * symid) -> Error.span
......@@ -143,6 +144,8 @@ structure SymbolTable :> SymbolTableSig = struct
| (NONE) => raise InvalidSymbolId
fun getAtom ti = let val (atom,_,_) = getSymbolInfo ti in atom end
fun getInternalString (ti as (_, SymId i)) =
Atom.toString (getAtom ti) ^ Int.toString i
fun getString (ti as (_, SymId i)) =
Atom.toString (getAtom ti) ^
(if concisePrint then "" else "#" ^ Int.toString i)
......
detail/semantic/typing/environment.sml
View file @ c1dce6dd
......@@ -831,9 +831,11 @@ end = struct
SOME f => SOME f
| NONE => affectedField (bVar, env)) fOpt envs
val fStr = case fOpt of
NONE => "some field" ^ " with vars " ^ BD.setToString bVar
NONE => "some field"
| SOME f => "field " ^
SymbolTable.getString(!SymbolTables.fieldTable, f)
val fStr = if Types.concisePrint then fStr else
fStr ^ " with vars " ^ BD.setToString bVar
in
raise UnificationFailure (fStr ^ " cannot flow here")
end
......
specifications/rreil/rreil-pretty.ml
View file @ c1dce6dd
......@@ -81,7 +81,6 @@ val rreil-show-linear lin =
val rreil-show-id id =
case id of
ARCH_R x: arch-show-id x
| VIRT_EQ: "EQ"
| VIRT_NEQ: "NEQ"
| VIRT_LES: "LES"
......@@ -89,4 +88,5 @@ val rreil-show-id id =
| VIRT_LTS: "LTS"
| VIRT_LTU: "LTU"
| VIRT_T x: "T" +++ showint x
| _: arch-show-id id
end
specifications/rreil/rreil.ml
View file @ c1dce6dd
......@@ -111,8 +111,9 @@ val rreil-stmts-rev stmts =
lp stmts SEM_NIL
end
val var//0 x = {id=x,offset=0}
val at-offset x offset = {id=x.id,offset=offset}
val _var x = {id=x,offset=0}
val _var x _offset o = {id=x, offset=o}
val at-offset v o = {id=v.id, offset=o}
val var x = SEM_LIN_VAR x
val lin sz l = SEM_LIN {size=sz, opnd1=l}
val address sz addr = {size=sz, address=addr}
......@@ -142,7 +143,7 @@ val /IFGOTO c sz t = SEM_IF_GOTO{cond=c,size=sz,target=t}
val /GOTOLABEL l = SEM_IF_GOTO_LABEL{cond=SEM_LIN_IMM{imm=1},label=l}
val /ITE c t e = SEM_ITE{cond=c,then_branch=t,else_branch=e}
val /WHILE c b = SEM_WHILE{cond=c,body=b}
val /BRANCH hint address = SEM_BRANCH{hint=hint,target=address}
val /BRANCH hint address =SEM_BRANCH{hint=hint,target=address}
val /CBRANCH cond target-true target-false = SEM_CBRANCH{cond=cond,target-true=target-true,target-false=target-false}
val push insn = do
......@@ -202,10 +203,22 @@ val gotolabel l = push (/GOTOLABEL l)
val ifgoto c sz addr = push (/IFGOTO c sz addr)
val ite c t e = push (/ITE c t e)
val while c b = push (/WHILE c b)
val jump address = push (/BRANCH HINT_JUMP address)
val call address = push (/BRANCH HINT_CALL address)
val ret address = push (/BRANCH HINT_RET address)
val cbranch cond target-true target-false = push (/CBRANCH cond target-true target-false)
val jump address = do
update @{foundJump = '1'};
push (/BRANCH HINT_JUMP address)
end
val call address = do
update @{foundJump = '1'};
push (/BRANCH HINT_CALL address)
end
val ret address = do
update @{foundJump = '1'};
push (/BRANCH HINT_RET address)
end
val cbranch cond target-true target-false = do
update @{foundJump = '1'};
push (/CBRANCH cond target-true target-false)
end
val const i = return (SEM_LIN_IMM{imm=i})
val imm i = SEM_LIN_IMM{imm=i}
......
specifications/x86/x86-rreil-registermapping.ml
View file @ c1dce6dd
# This file maps syntactic registers to semantic registers used in RREIL.
val semantic-register-of r =
case r of
RAX: {id=ARCH_R 0,offset=0,size=64}
| RBX: {id=ARCH_R 1,offset=0,size=64}
| RCX: {id=ARCH_R 2,offset=0,size=64}
| RDX: {id=ARCH_R 3,offset=0,size=64}
| R8 : {id=ARCH_R 4,offset=0,size=64}
| R9 : {id=ARCH_R 5,offset=0,size=64}
| R10: {id=ARCH_R 6,offset=0,size=64}
| R11: {id=ARCH_R 7,offset=0,size=64}
| R12: {id=ARCH_R 8,offset=0,size=64}
| R13: {id=ARCH_R 9,offset=0,size=64}
| R14: {id=ARCH_R 10,offset=0,size=64}
| R15: {id=ARCH_R 11,offset=0,size=64}
| RSP: {id=ARCH_R 12,offset=0,size=64}
| RBP: {id=ARCH_R 13,offset=0,size=64}
| RSI: {id=ARCH_R 14,offset=0,size=64}
| RDI: {id=ARCH_R 15,offset=0,size=64}
| EAX: {id=ARCH_R 0,offset=0,size=32}
| EBX: {id=ARCH_R 1,offset=0,size=32}
| ECX: {id=ARCH_R 2,offset=0,size=32}
| EDX: {id=ARCH_R 3,offset=0,size=32}
| R8D: {id=ARCH_R 4,offset=0,size=32}
| R9D: {id=ARCH_R 5,offset=0,size=32}
| R10D: {id=ARCH_R 6,offset=0,size=32}
| R11D: {id=ARCH_R 7,offset=0,size=32}
| R12D: {id=ARCH_R 8,offset=0,size=32}
| R13D: {id=ARCH_R 9,offset=0,size=32}
| R14D: {id=ARCH_R 10,offset=0,size=32}
| R15D: {id=ARCH_R 11,offset=0,size=32}
| ESP: {id=ARCH_R 12,offset=0,size=32}
| EBP: {id=ARCH_R 13,offset=0,size=32}
| ESI: {id=ARCH_R 14,offset=0,size=32}
| EDI: {id=ARCH_R 15,offset=0,size=32}
| CS: {id=ARCH_R 16,offset=0,size=16}
end
val sdt-ss = return (_var (VIRT_T ~100))
val arch-show-id r =
case r of
0: "RAX"
| 1: "RBX"
| 2: "RCX"
| 3: "RDX"
| 4: "R8"
| 5: "R9"
| 6: "R10"
| 7: "R11"
| 8: "R12"
| 9: "R13"
| 10: "R14"
| 11: "R15"
| 12: "RSP"
| 13: "RBP"
| 14: "RSI"
| 15: "RDI"
| _ : "ARCH(" +++ showint r +++ ")"
end
# define functions that generate EFLAGS variables
val fCF = return (_var Sem_FLAGS _offset 0)
val fPF = return (_var Sem_FLAGS _offset 2)
val fAF = return (_var Sem_FLAGS _offset 4)
val fZF = return (_var Sem_FLAGS _offset 6)
val fSF = return (_var Sem_FLAGS _offset 7)
val fDF = return (_var Sem_FLAGS _offset 10)
val fOF = return (_var Sem_FLAGS _offset 11)
type sem_id
= Sem_IP
| Sem_FLAGS
| Sem_MXCSR
| Sem_AX
| Sem_BX
| Sem_CX
| Sem_DX
| Sem_SI
| Sem_DI
| Sem_SP
| Sem_BP
| Sem_R8
| Sem_R9
| Sem_R10
| Sem_R11
| Sem_R12
| Sem_R13
| Sem_R14
| Sem_R15
| Sem_CS # the segment registers represent their entry in the segment table
| Sem_DS
| Sem_SS
| Sem_ES
| Sem_FS
| Sem_GS
| Sem_ST0
| Sem_ST1
| Sem_ST2
| Sem_ST3
| Sem_ST4
| Sem_ST5
| Sem_ST6
| Sem_ST7
| Sem_MM0
| Sem_MM1
| Sem_MM2
| Sem_MM3
| Sem_MM4
| Sem_MM5
| Sem_MM6
| Sem_MM7
| Sem_MM8
| Sem_XMM0
| Sem_XMM1
| Sem_XMM2
| Sem_XMM3
| Sem_XMM4
| Sem_XMM5
| Sem_XMM6
| Sem_XMM7
| Sem_XMM8
| Sem_XMM9
| Sem_XMM10
| Sem_XMM11
| Sem_XMM12
| Sem_XMM13
| Sem_XMM14
| Sem_XMM15
val semantic-register-of r = case r of
AL : {id=Sem_AX,offset=0,size=8}
| AH : {id=Sem_AX,offset=8,size=8}
| AX : {id=Sem_AX,offset=0,size=16}
| EAX : {id=Sem_AX,offset=0,size=32}
| RAX : {id=Sem_AX,offset=0,size=64}
| BL : {id=Sem_BX,offset=0,size=8}
| BH : {id=Sem_BX,offset=8,size=8}
| BX : {id=Sem_BX,offset=0,size=16}
| EBX : {id=Sem_BX,offset=0,size=32}
| RBX : {id=Sem_BX,offset=0,size=64}
| CL : {id=Sem_CX,offset=0,size=8}
| CH : {id=Sem_CX,offset=8,size=8}
| CX : {id=Sem_CX,offset=0,size=16}
| ECX : {id=Sem_CX,offset=0,size=32}
| RCX : {id=Sem_CX,offset=0,size=64}
| DL : {id=Sem_DX,offset=0,size=8}
| DH : {id=Sem_DX,offset=8,size=8}
| DX : {id=Sem_DX,offset=0,size=16}
| EDX : {id=Sem_DX,offset=0,size=32}
| RDX : {id=Sem_DX,offset=0,size=64}
| R8B : {id=Sem_R8,offset=0,size=8}
| R8L : {id=Sem_R8,offset=0,size=16}
| R8D : {id=Sem_R8,offset=0,size=32}
| R8 : {id=Sem_R8,offset=0,size=64}
| R9B : {id=Sem_R9,offset=0,size=8}
| R9L : {id=Sem_R9,offset=0,size=16}
| R9D : {id=Sem_R9,offset=0,size=32}
| R9 : {id=Sem_R9,offset=0,size=64}
| R10B : {id=Sem_R10,offset=0,size=8}
| R10L : {id=Sem_R10,offset=0,size=16}
| R10D : {id=Sem_R10,offset=0,size=32}
| R10 : {id=Sem_R10,offset=0,size=64}
| R11B : {id=Sem_R11,offset=0,size=8}
| R11L : {id=Sem_R11,offset=0,size=16}
| R11D : {id=Sem_R11,offset=0,size=32}
| R11 : {id=Sem_R11,offset=0,size=64}
| R12B : {id=Sem_R12,offset=0,size=8}
| R12L : {id=Sem_R12,offset=0,size=16}
| R12D : {id=Sem_R12,offset=0,size=32}
| R12 : {id=Sem_R12,offset=0,size=64}
| R13B : {id=Sem_R13,offset=0,size=8}
| R13L : {id=Sem_R13,offset=0,size=16}
| R13D : {id=Sem_R13,offset=0,size=32}
| R13 : {id=Sem_R13,offset=0,size=64}
| R14B : {id=Sem_R14,offset=0,size=8}
| R14L : {id=Sem_R14,offset=0,size=16}
| R14D : {id=Sem_R14,offset=0,size=32}
| R14 : {id=Sem_R14,offset=0,size=64}
| R15B : {id=Sem_R15,offset=0,size=8}
| R15L : {id=Sem_R15,offset=0,size=16}
| R15D : {id=Sem_R15,offset=0,size=32}
| R15 : {id=Sem_R15,offset=0,size=64}
| SP : {id=Sem_SP, offset=0,size=16}
| ESP : {id=Sem_SP, offset=0,size=32}
| RSP : {id=Sem_SP, offset=0,size=64}
| BP : {id=Sem_BP, offset=0,size=16}
| EBP : {id=Sem_BP, offset=0,size=32}
| RBP : {id=Sem_BP, offset=0,size=64}
| SI : {id=Sem_SI, offset=0,size=16}
| ESI : {id=Sem_SI, offset=0,size=32}
| RSI : {id=Sem_SI, offset=0,size=64}
| DI : {id=Sem_DI, offset=0,size=16}
| EDI : {id=Sem_DI, offset=0,size=32}
| RDI : {id=Sem_DI, offset=0,size=64}
| XMM0 : {id=Sem_XMM0, offset=0,size=128}
| XMM1 : {id=Sem_XMM1, offset=0,size=128}
| XMM2 : {id=Sem_XMM2, offset=0,size=128}
| XMM3 : {id=Sem_XMM3, offset=0,size=128}
| XMM4 : {id=Sem_XMM4, offset=0,size=128}
| XMM5 : {id=Sem_XMM5, offset=0,size=128}
| XMM6 : {id=Sem_XMM6, offset=0,size=128}
| XMM7 : {id=Sem_XMM7, offset=0,size=128}
| XMM8 : {id=Sem_XMM8, offset=0,size=128}
| XMM9 : {id=Sem_XMM9, offset=0,size=128}
| XMM10 : {id=Sem_XMM10, offset=0,size=128}
| XMM11 : {id=Sem_XMM11, offset=0,size=128}
| XMM12 : {id=Sem_XMM12, offset=0,size=128}
| XMM13 : {id=Sem_XMM13, offset=0,size=128}
| XMM14 : {id=Sem_XMM14, offset=0,size=128}
| XMM15 : {id=Sem_XMM15, offset=0,size=128}
| YMM0 : {id=Sem_XMM0, offset=0,size=256}
| YMM1 : {id=Sem_XMM1, offset=0,size=256}
| YMM2 : {id=Sem_XMM2, offset=0,size=256}
| YMM3 : {id=Sem_XMM3, offset=0,size=256}
| YMM4 : {id=Sem_XMM4, offset=0,size=256}
| YMM5 : {id=Sem_XMM5, offset=0,size=256}
| YMM6 : {id=Sem_XMM6, offset=0,size=256}
| YMM7 : {id=Sem_XMM7, offset=0,size=256}
| YMM8 : {id=Sem_XMM8, offset=0,size=256}
| YMM9 : {id=Sem_XMM9, offset=0,size=256}
| YMM10 : {id=Sem_XMM10, offset=0,size=256}
| YMM11 : {id=Sem_XMM11, offset=0,size=256}
| YMM12 : {id=Sem_XMM12, offset=0,size=256}
| YMM13 : {id=Sem_XMM13, offset=0,size=256}
| YMM14 : {id=Sem_XMM14, offset=0,size=256}
| YMM15 : {id=Sem_XMM15, offset=0,size=256}
| MM0 : {id=Sem_MM0, offset=0, size=64}
| MM1 : {id=Sem_MM1, offset=0, size=64}
| MM2 : {id=Sem_MM2, offset=0, size=64}
| MM3 : {id=Sem_MM3, offset=0, size=64}
| MM4 : {id=Sem_MM4, offset=0, size=64}
| MM5 : {id=Sem_MM5, offset=0, size=64}
| MM6 : {id=Sem_MM6, offset=0, size=64}
| MM7 : {id=Sem_MM7, offset=0, size=64}
| ES : {id=Sem_ES, offset=0, size=64} # content of segment table
| SS : {id=Sem_SS, offset=0, size=64}
| DS : {id=Sem_DS, offset=0, size=64}
| FS : {id=Sem_FS, offset=0, size=64}
| GS : {id=Sem_GS, offset=0, size=64}
| CS : {id=Sem_CS, offset=0, size=64}
| ST0 : {id=Sem_ST0, offset=0, size=80}
| ST1 : {id=Sem_ST1, offset=0, size=80}
| ST2 : {id=Sem_ST2, offset=0, size=80}
| ST3 : {id=Sem_ST3, offset=0, size=80}
| ST4 : {id=Sem_ST4, offset=0, size=80}
| ST5 : {id=Sem_ST5, offset=0, size=80}
| ST6 : {id=Sem_ST6, offset=0, size=80}
| ST7 : {id=Sem_ST7, offset=0, size=80}
| RIP : {id=Sem_IP, offset=0, size=64}
end
val arch-show-id r = case r of
Sem_IP : "IP"
| Sem_FLAGS : "FLAGS"
| Sem_MXCSR : "MXCSR"
| Sem_AX : "AX"
| Sem_BX : "BX"
| Sem_CX : "CX"
| Sem_DX : "DX"
| Sem_SI : "SI"
| Sem_DI : "DI"
| Sem_SP : "SP"
| Sem_BP : "BP"
| Sem_R8 : "R8"
| Sem_R9 : "R9"
| Sem_R10 : "R10"
| Sem_R11 : "R11"
| Sem_R12 : "R12"
| Sem_R13 : "R13"
| Sem_R14 : "R14"
| Sem_R15 : "R15"
| Sem_CS : "CS"
| Sem_DS : "DS"
| Sem_SS : "SS"
| Sem_ES : "ES"
| Sem_FS : "FS"
| Sem_GS : "GS"
| Sem_ST0 : "ST0"
| Sem_ST1 : "ST1"
| Sem_ST2 : "ST2"
| Sem_ST3 : "ST3"
| Sem_ST4 : "ST4"
| Sem_ST5 : "ST5"
| Sem_ST6 : "ST6"
| Sem_ST7 : "ST7"
| Sem_MM0 : "MM0"
| Sem_MM1 : "MM1"
| Sem_MM2 : "MM2"
| Sem_MM3 : "MM3"
| Sem_MM4 : "MM4"
| Sem_MM5 : "MM5"
| Sem_MM6 : "MM6"
| Sem_MM7 : "MM7"
| Sem_MM8 : "MM8"
| Sem_XMM0 : "XMM0"
| Sem_XMM1 : "XMM1"
| Sem_XMM2 : "XMM2"
| Sem_XMM3 : "XMM3"
| Sem_XMM4 : "XMM4"
| Sem_XMM5 : "XMM5"
| Sem_XMM6 : "XMM6"
| Sem_XMM7 : "XMM7"
| Sem_XMM8 : "XMM8"
| Sem_XMM9 : "XMM9"
| Sem_XMM10 : "XMM10"
| Sem_XMM11 : "XMM11"
| Sem_XMM12 : "XMM12"
| Sem_XMM13 : "XMM13"
| Sem_XMM14 : "XMM14"
| Sem_XMM15 : "XMM15"
end
specifications/x86/x86-rreil-translator.ml
View file @ c1dce6dd
# vim:filetype=sml:ts=3:sw=3:expandtab
export = translate
export = translate translateBlock
val t-mode64? = do
mode64 <- query $mode64;
......@@ -208,21 +208,12 @@ val commit sz a b =
end
end
val fEQ = return (var//0 VIRT_EQ)
val fNEQ = return (var//0 VIRT_NEQ)
val fLES = return (var//0 VIRT_LES)
val fLEU = return (var//0 VIRT_LEU)
val fLTS = return (var//0 VIRT_LTS)
val fLTU = return (var//0 VIRT_LTU)
val sdt-ss = return (var//0 (VIRT_T ~100))
val fOF = return (var//0 (ARCH_R ~1)) # OF
val fSF = return (var//0 (ARCH_R ~2)) # SF
val fZF = return (var//0 (ARCH_R ~3)) # ZF
val fAF = return (var//0 (ARCH_R ~4)) # AF
val fPF = return (var//0 (ARCH_R ~5)) # PF
val fCF = return (var//0 (ARCH_R ~6)) # CF
val fEQ = return (_var VIRT_EQ)
val fNEQ = return (_var VIRT_NEQ)
val fLES = return (_var VIRT_LES)
val fLEU = return (_var VIRT_LEU)
val fLTS = return (_var VIRT_LTS)
val fLTU = return (_var VIRT_LTU)
val zero = return (SEM_LIN_IMM{imm=0})
......@@ -2309,3 +2300,28 @@ val translate-bottom-up insn =
stack <- query $stack;
return stack
end
val transInstr = do
ic <- query $ins_count;
update@{tmp=0,ins_count=ic+1};
insn <- decode;
semantics insn
end
val transBlock = do
update@{stack=SEM_NIL,foundJump='0'};
transInstr;
jmp <- query $foundJump;
ic <- query $ins_count;
if jmp or ic>10 then query $stack else transBlock
end
val translateBlock = do
update @{ins_count=0,mode64='1'};
# the type checker is seriously broken when it comes to infinite recursion,
# I cannot as of yet reproduce this bug
update @{ptrsz=0, reg/opcode='000', rm='000', mod='00', vexm='00001', vexv='0000', vexl='0', vexw='0'};
transBlock
end
\ No newline at end of file
specifications/x86/x86.ml
View file @ c1dce6dd
......@@ -16,6 +16,12 @@ export = decode
# recursion-depth = p64 = 4
val decode = do
update @{tab=void};
main
end
val main = do
t <- query $tab;
update
@{mode64='1',
repne='0',
......@@ -28,9 +34,12 @@ val decode = do
opndsz='0',
addrsz='0',
lock='0',
segment=DS,
ptrty=32}; #TODO: check
p64
segment=SEG_DEFAULT,
ptrty=32, #TODO: check
~tab};
instr <- p64;
update @{tab=t};
return instr
end
val complement v = not v
......@@ -39,12 +48,44 @@ val set-opndsz = update@{opndsz='1'}
val set-repne = update@{repne='1'}
val set-rep = update@{rep='1'}
val set-CS = update@{segment=CS}
val set-DS = update@{segment=DS}
val set-ES = update@{segment=ES}
val set-FS = update@{segment=FS}
val set-GS = update@{segment=GS}
val set-SS = update@{segment=SS}
# Segment prefix handling
type seg_override =
SEG_DEFAULT
| SEG_OVERRIDE of register