rreil.ml 6.71 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

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

Julian Kranz's avatar
Gdrr  
Julian Kranz committed
16
type sem_address = {size:int, address: sem_linear}
mb0's avatar
Foo.  
mb0 committed
17
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}
Julian Kranz's avatar
Gdrr  
Julian Kranz 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
 | 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
Julian Kranz's avatar
Gdrr  
Julian Kranz committed
38 39
 | SEM_SX of {size:int, fromsize:int, opnd1:sem_linear}
 | SEM_ZX of {size:int, fromsize:int, opnd1:sem_linear}
mb0's avatar
mb0 committed
40 41 42 43 44 45
 | 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
Julian Kranz's avatar
Gdrr  
Julian Kranz committed
46
 | SEM_ARB of {size:int}
mb0's avatar
Foo.  
mb0 committed
47

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

Julian Kranz's avatar
Gdrr  
Julian Kranz committed
57
type branch_hint =
Julian Kranz's avatar
Julian Kranz committed
58 59 60 61
    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
type sem_writeback =
Julian Kranz's avatar
Gdrr  
Julian Kranz committed
67 68
   SEM_WRITE_VAR of {size:int, id:sem_var}
 | 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
val _var x = {id=x,offset=0}
val _var x _offset o = {id=x, offset=o}
Julian Kranz's avatar
Julian Kranz committed
107
val at-offset v o = @{offset=o} v
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

Julian Kranz's avatar
Julian Kranz committed
112 113 114 115 116 117 118 119 120
type temp_list =
   TLIST_CONS of {hd:sem_var, tl:temp_list}
 | TLIST_NIL

val temp_id x =
  case x of
     VIRT_T v: v
  end

mb0's avatar
mb0 committed
121
val mktemp = do
Julian Kranz's avatar
Julian Kranz committed
122 123 124 125 126 127 128 129 130 131 132 133 134 135
   #t <- query $tmp;
   #t' <- return (t + 1);
   #update @{tmp=t'};
   #return {id=VIRT_T t,offset=0}
   l <- query $tmp;
   t' <- return (
     case l of
        TLIST_CONS x: _var (VIRT_T ((temp_id x.hd.id) + 1))
      | TLIST_NIL: _var (VIRT_T 0)
     end
   );
   l' <- return (TLIST_CONS {hd=t', tl=l});
   update @{tmp=l'};
   return t'
mb0's avatar
sem.  
mb0 committed
136
end
mb0's avatar
mb0 committed
137

mb0's avatar
mb0 committed
138 139 140 141
val mklabel = do
   l <- query $lab;
   l' <- return (l + 1);
   update @{lab=l'};
mb0's avatar
Up.  
mb0 committed
142
   return l
mb0's avatar
mb0 committed
143 144
end

mb0's avatar
mb0 committed
145
val /ASSIGN a b = SEM_ASSIGN{lhs=a,rhs=b}
mb0's avatar
Foo.  
mb0 committed
146
val /LOAD sz a b = SEM_LOAD{lhs=a,size=sz,address=b}
mb0's avatar
mb0 committed
147
val /STORE a b = SEM_STORE{address=a,rhs=b}
mb0's avatar
Foo.  
mb0 committed
148
val /ADD a b = SEM_LIN_ADD{opnd1=a,opnd2=b}
mb0's avatar
mb0 committed
149
val /SUB a b = SEM_LIN_SUB{opnd1=a,opnd2=b}
Julian Kranz's avatar
Julian Kranz committed
150 151
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
152
val /BRANCH hint address =SEM_BRANCH{hint=hint,target=address}
Julian Kranz's avatar
Julian Kranz committed
153
val /CBRANCH cond target-true target-false = SEM_CBRANCH{cond=cond,target-true=target-true,target-false=target-false}
mb0's avatar
mb0 committed
154 155

val push insn = do
mb0's avatar
Foo.  
mb0 committed
156 157
   tl <- query $stack;
   update @{stack=SEM_CONS{hd=insn,tl=tl}}
mb0's avatar
mb0 committed
158
end
mb0's avatar
mb0 committed
159

Julian Kranz's avatar
Julian Kranz committed
160 161 162
val pop-all = do
  head <- query $stack;
  update @{stack=SEM_NIL};
Julian Kranz's avatar
Julian Kranz committed
163
  return head
Julian Kranz's avatar
Julian Kranz committed
164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180
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
181
val mov sz a b = push (/ASSIGN a (SEM_LIN{size=sz,opnd1=b}))
mb0's avatar
mb0 committed
182
val undef sz a = push (/ASSIGN a (SEM_ARB{size=sz}))
mb0's avatar
Foo.  
mb0 committed
183
val load sz a psz b = push (/LOAD sz a {size=psz,address=b})
mb0's avatar
mb0 committed
184
val store a b = push (/STORE a b)
mb0's avatar
Foo.  
mb0 committed
185
val add sz a b c = push (/ASSIGN a (SEM_LIN{size=sz,opnd1= /ADD b c}))
mb0's avatar
mb0 committed
186 187 188 189 190 191 192 193 194 195
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
196
val modulo sz a b c = push (/ASSIGN a (SEM_MOD{size=sz,opnd1=b,opnd2=c}))
mb0's avatar
mb0 committed
197 198 199 200 201 202 203 204 205
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
206 207
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
208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223
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
224

mb0's avatar
mb0 committed
225
val const i = return (SEM_LIN_IMM{imm=i})
Julian Kranz's avatar
Julian Kranz committed
226
val imm i = SEM_LIN_IMM{imm=i}
mb0's avatar
mb0 committed
227

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