rreil.ml 6.4 KB
Newer Older
mb0's avatar
Up.  
mb0 committed
1
# vim:filetype=sml:ts=3:sw=3:expandtab
mb0's avatar
mb0 committed
2

mb0's avatar
Foo.  
mb0 committed
3
type sem_id =
4
   VIRT_EQ  # ==
mb0's avatar
mb0 committed
5 6 7 8 9
 | VIRT_NEQ # /=
 | VIRT_LES # <=s
 | VIRT_LEU # <=u
 | VIRT_LTS # <s
 | VIRT_LTU # <u
mb0's avatar
Foo.  
mb0 committed
10
 | VIRT_T of int
mb0's avatar
mb0 committed
11

mb0's avatar
Foo.  
mb0 committed
12 13
type sem_arity1 = {size: int, opnd1: sem_linear}
type sem_arity2 = {size: int, opnd1: sem_linear, opnd2: sem_linear}
mb0's avatar
mb0 committed
14
type sem_cmp = {size: int, opnd1: sem_linear, opnd2: sem_linear}
mb0's avatar
mb0 committed
15

mb0's avatar
Foo.  
mb0 committed
16 17
type sem_address = {size: int, address: sem_linear}
type sem_var = {id:sem_id, offset:int}
mb0's avatar
mb0 committed
18

mb0's avatar
Foo.  
mb0 committed
19 20 21
type sem_linear =
   SEM_LIN_VAR of sem_var
 | SEM_LIN_IMM of {imm:int}
mb0's avatar
mb0 committed
22 23
 | SEM_LIN_ADD of {opnd1: sem_linear, opnd2: sem_linear}
 | SEM_LIN_SUB of {opnd1: sem_linear, opnd2: sem_linear}
mb0's avatar
Foo.  
mb0 committed
24
 | SEM_LIN_SCALE of {imm:int, opnd:sem_linear}
mb0's avatar
mb0 committed
25

mb0's avatar
Foo.  
mb0 committed
26 27 28
type sem_op =
   SEM_LIN of sem_arity1
 | SEM_MUL of sem_arity2
mb0's avatar
mb0 committed
29
 | SEM_DIV of sem_arity2
mb0's avatar
mb0 committed
30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46
 | SEM_DIVS of sem_arity2
 | SEM_MOD of sem_arity2
 | SEM_SHL of sem_arity2
 | SEM_SHR of sem_arity2
 | SEM_SHRS of sem_arity2
 | SEM_AND of sem_arity2
 | SEM_OR of sem_arity2
 | SEM_XOR of sem_arity2
 | SEM_SX of {size: int, fromsize: int, opnd1: sem_linear}
 | SEM_ZX of {size: int, fromsize: int, opnd1: sem_linear}
 | SEM_CMPEQ of sem_cmp
 | SEM_CMPNEQ of sem_cmp
 | SEM_CMPLES of sem_cmp
 | SEM_CMPLEU of sem_cmp
 | SEM_CMPLTS of sem_cmp
 | SEM_CMPLTU of sem_cmp
 | SEM_ARB of {size: int}
mb0's avatar
Foo.  
mb0 committed
47

Julian Kranz's avatar
Julian Kranz committed
48
type sem_stmt =
mb0's avatar
Foo.  
mb0 committed
49 50
   SEM_ASSIGN of {lhs: sem_var, rhs: sem_op}
 | SEM_LOAD of {lhs: sem_var, size: int, address: sem_address}
mb0's avatar
mb0 committed
51
 | SEM_STORE of {address: sem_address, rhs: sem_op}
Julian Kranz's avatar
Julian Kranz committed
52 53
 | SEM_ITE of {cond: sem_linear, then_branch: sem_stmts, else_branch: sem_stmts}
 | SEM_WHILE of {cond: sem_linear, body: sem_stmts}
Julian Kranz's avatar
Julian Kranz committed
54
 | SEM_CBRANCH of {cond: sem_linear, target-true: sem_address, target-false: sem_address}
Julian Kranz's avatar
Julian Kranz committed
55 56 57 58 59 60 61
 | SEM_BRANCH of {hint: branch_hint, target: sem_address}

 type branch_hint =
    HINT_JUMP
  | HINT_CALL
  | HINT_RET

Julian Kranz's avatar
Julian Kranz committed
62
type sem_stmts =
mb0's avatar
Foo.  
mb0 committed
63
   SEM_CONS of {hd:sem_stmt, tl:sem_stmts}
mb0's avatar
mb0 committed
64 65
 | SEM_NIL

mb0's avatar
mb0 committed
66 67
type sem_writeback =
   SEM_WRITE_VAR of {size: int, id: sem_var}
Julian Kranz's avatar
Julian Kranz committed
68
 | SEM_WRITE_MEM of {size: int, address: sem_linear, segment:seg_override}
mb0's avatar
mb0 committed
69

mb0's avatar
Up  
mb0 committed
70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93
val rreil-sizeOf op =
   case op of
      SEM_LIN x: x.size
    | SEM_MUL x: x.size
    | SEM_DIV x: x.size
    | SEM_DIVS x: x.size
    | SEM_MOD x: x.size
    | SEM_SHL x: x.size
    | SEM_SHR x: x.size
    | SEM_SHRS x: x.size
    | SEM_AND x: x.size
    | SEM_OR x: x.size
    | SEM_XOR x: x.size
    | SEM_SX x: x.size
    | SEM_ZX x: x.size
    | SEM_CMPEQ x: 1
    | SEM_CMPNEQ x: 1
    | SEM_CMPLES x: 1
    | SEM_CMPLEU x: 1
    | SEM_CMPLTS x: 1
    | SEM_CMPLTU x: 1
    | SEM_ARB x: x.size
   end

mb0's avatar
Up.  
mb0 committed
94
val rreil-stmts-rev stmts =
mb0's avatar
mb0 committed
95 96 97 98
   let
      val lp stmt acc =
         case stmt of
            SEM_NIL: acc
mb0's avatar
Up.  
mb0 committed
99
          | SEM_CONS x: lp x.tl (SEM_CONS{hd=x.hd, tl=acc})
mb0's avatar
mb0 committed
100 101 102 103 104
         end
   in
      lp stmts SEM_NIL
   end

Axel Simon's avatar
Axel Simon committed
105 106 107
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}
mb0's avatar
mb0 committed
108
val var x = SEM_LIN_VAR x
Julian Kranz's avatar
Julian Kranz committed
109
val lin sz l = SEM_LIN {size=sz, opnd1=l}
Julian Kranz's avatar
Julian Kranz committed
110
val address sz addr = {size=sz, address=addr}
mb0's avatar
sem.  
mb0 committed
111

mb0's avatar
mb0 committed
112
val mktemp = do
mb0's avatar
sem.  
mb0 committed
113
   t <- query $tmp;
mb0's avatar
Foo.  
mb0 committed
114
   t' <- return (t + 1);
mb0's avatar
sem.  
mb0 committed
115
   update @{tmp=t'};
mb0's avatar
Foo.  
mb0 committed
116
   return {id=VIRT_T t,offset=0}
mb0's avatar
sem.  
mb0 committed
117
end
mb0's avatar
mb0 committed
118

mb0's avatar
mb0 committed
119 120 121 122
val mklabel = do
   l <- query $lab;
   l' <- return (l + 1);
   update @{lab=l'};
mb0's avatar
Up.  
mb0 committed
123
   return l
mb0's avatar
mb0 committed
124 125
end

mb0's avatar
mb0 committed
126
val /ASSIGN a b = SEM_ASSIGN{lhs=a,rhs=b}
mb0's avatar
Foo.  
mb0 committed
127
val /LOAD sz a b = SEM_LOAD{lhs=a,size=sz,address=b}
mb0's avatar
mb0 committed
128
val /STORE a b = SEM_STORE{address=a,rhs=b}
mb0's avatar
Foo.  
mb0 committed
129
val /ADD a b = SEM_LIN_ADD{opnd1=a,opnd2=b}
mb0's avatar
mb0 committed
130
val /SUB a b = SEM_LIN_SUB{opnd1=a,opnd2=b}
Julian Kranz's avatar
Julian Kranz committed
131 132
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}
Axel Simon's avatar
Axel Simon committed
133
val /BRANCH hint address =SEM_BRANCH{hint=hint,target=address}
Julian Kranz's avatar
Julian Kranz committed
134
val /CBRANCH cond target-true target-false = SEM_CBRANCH{cond=cond,target-true=target-true,target-false=target-false}
mb0's avatar
mb0 committed
135 136

val push insn = do
mb0's avatar
Foo.  
mb0 committed
137 138
   tl <- query $stack;
   update @{stack=SEM_CONS{hd=insn,tl=tl}}
mb0's avatar
mb0 committed
139
end
mb0's avatar
mb0 committed
140

Julian Kranz's avatar
Julian Kranz committed
141 142 143
val pop-all = do
  head <- query $stack;
  update @{stack=SEM_NIL};
Julian Kranz's avatar
Julian Kranz committed
144
  return head
Julian Kranz's avatar
Julian Kranz committed
145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161
end

#val connect-tail stmt tail =
#  case stmt of
#     SEM_NIL: tail
#   | SEM_CONS x: SEM_CONS{hd=x.hd,tl=(connect-tail x.tl tail)}
#  end

#val concat stmt = do
#  tail <- query $stack;
#  update @{stack=(connect-tail stmt tail)}
#end

val stack-set stmt = do
   update @{stack=stmt}
end

mb0's avatar
Foo.  
mb0 committed
162
val mov sz a b = push (/ASSIGN a (SEM_LIN{size=sz,opnd1=b}))
mb0's avatar
mb0 committed
163
val undef sz a = push (/ASSIGN a (SEM_ARB{size=sz}))
mb0's avatar
Foo.  
mb0 committed
164
val load sz a psz b = push (/LOAD sz a {size=psz,address=b})
mb0's avatar
mb0 committed
165
val store a b = push (/STORE a b)
mb0's avatar
Foo.  
mb0 committed
166
val add sz a b c = push (/ASSIGN a (SEM_LIN{size=sz,opnd1= /ADD b c}))
mb0's avatar
mb0 committed
167 168 169 170 171 172 173 174 175 176
val sub sz a b c = push (/ASSIGN a (SEM_LIN{size=sz,opnd1= /SUB b c}))
val andb sz a b c = push (/ASSIGN a (SEM_AND{size=sz,opnd1=b,opnd2=c}))
val orb sz a b c = push (/ASSIGN a (SEM_OR{size=sz,opnd1=b,opnd2=c}))
val xorb sz a b c = push (/ASSIGN a (SEM_XOR{size=sz,opnd1=b,opnd2=c}))
val mul sz a b c = push (/ASSIGN a (SEM_MUL{size=sz,opnd1=b,opnd2=c}))
val div sz a b c = push (/ASSIGN a (SEM_DIV{size=sz,opnd1=b,opnd2=c}))
val divs sz a b c = push (/ASSIGN a (SEM_DIVS{size=sz,opnd1=b,opnd2=c}))
val shl sz a b c = push (/ASSIGN a (SEM_SHL{size=sz,opnd1=b,opnd2=c}))
val shr sz a b c = push (/ASSIGN a (SEM_SHR{size=sz,opnd1=b,opnd2=c}))
val shrs sz a b c = push (/ASSIGN a (SEM_SHRS{size=sz,opnd1=b,opnd2=c}))
Julian Kranz's avatar
Julian Kranz committed
177
val modulo sz a b c = push (/ASSIGN a (SEM_MOD{size=sz,opnd1=b,opnd2=c}))
mb0's avatar
mb0 committed
178 179 180 181 182 183 184 185 186
val movsx szA a szB b = push (/ASSIGN a (SEM_SX{size=szA,fromsize=szB,opnd1=b}))
val movzx szA a szB b = push (/ASSIGN a (SEM_ZX{size=szA,fromsize=szB,opnd1=b}))
val convert szA a szB b = push (/ASSIGN a (SEM_ZX{size=szA,fromsize=szB,opnd1=b}))
val cmpeq sz f a b = push (/ASSIGN f (SEM_CMPEQ{size=sz,opnd1=a,opnd2=b}))
val cmpneq sz f a b = push (/ASSIGN f (SEM_CMPNEQ{size=sz,opnd1=a,opnd2=b}))
val cmples sz f a b = push (/ASSIGN f (SEM_CMPLES{size=sz,opnd1=a,opnd2=b}))
val cmpleu sz f a b = push (/ASSIGN f (SEM_CMPLEU{size=sz,opnd1=a,opnd2=b}))
val cmplts sz f a b = push (/ASSIGN f (SEM_CMPLTS{size=sz,opnd1=a,opnd2=b}))
val cmpltu sz f a b = push (/ASSIGN f (SEM_CMPLTU{size=sz,opnd1=a,opnd2=b}))
Julian Kranz's avatar
Julian Kranz committed
187 188
val ite c t e = push (/ITE c t e)
val while c b = push (/WHILE c b)
Axel Simon's avatar
Axel Simon committed
189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204
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
mb0's avatar
mb0 committed
205

mb0's avatar
mb0 committed
206
val const i = return (SEM_LIN_IMM{imm=i})
Julian Kranz's avatar
Julian Kranz committed
207
val imm i = SEM_LIN_IMM{imm=i}
mb0's avatar
mb0 committed
208

mb0's avatar
Up.  
mb0 committed
209 210
val /+ x offs = @{offset=offs} x
val /++ x offs = @{offset= $offset x + offs} x