rreil.ml 11.7 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
mb0 committed
3 4
export = translate

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

mb0's avatar
Foo.  
mb0 committed
15 16
type sem_arity1 = {size: int, opnd1: sem_linear}
type sem_arity2 = {size: int, opnd1: sem_linear, opnd2: sem_linear}
mb0's avatar
mb0 committed
17
type sem_cmp = {size: int, opnd1: sem_linear, opnd2: sem_linear}
mb0's avatar
mb0 committed
18

mb0's avatar
Foo.  
mb0 committed
19 20
type sem_address = {size: int, address: sem_linear}
type sem_var = {id:sem_id, offset:int}
mb0's avatar
mb0 committed
21

mb0's avatar
Foo.  
mb0 committed
22 23 24
type sem_linear =
   SEM_LIN_VAR of sem_var
 | SEM_LIN_IMM of {imm:int}
mb0's avatar
mb0 committed
25 26
 | 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
27
 | SEM_LIN_SCALE of {imm:int, opnd:sem_linear}
mb0's avatar
mb0 committed
28

mb0's avatar
Foo.  
mb0 committed
29 30
type sem_op =
   SEM_LIN of sem_arity1
mb0's avatar
mb0 committed
31
 | SEM_BSWAP of sem_arity1 
mb0's avatar
Foo.  
mb0 committed
32
 | SEM_MUL of sem_arity2
mb0's avatar
mb0 committed
33
 | SEM_DIV of sem_arity2
mb0's avatar
mb0 committed
34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50
 | 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
51 52 53 54

type sem_stmt = 
   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
55
 | SEM_STORE of {address: sem_address, rhs: sem_op}
mb0's avatar
Foo.  
mb0 committed
56
 | SEM_LABEL of {id: int}
mb0's avatar
mb0 committed
57 58
 | SEM_IF_GOTO_LABEL of {cond:sem_linear, label: int}
 | SEM_IF_GOTO of {cond: sem_linear, size:int, target: sem_address}
mb0's avatar
Foo.  
mb0 committed
59 60 61 62 63
 | SEM_CALL of {cond: sem_linear, size:int, target: sem_address}
 | SEM_RETURN of {cond: sem_linear, size:int, target: sem_address}

type sem_stmts = 
   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 68 69 70 71 72 73 74
type sem_writeback =
   SEM_WRITE_VAR of {size: int, id: sem_var}
 | SEM_WRITE_MEM of {size: int, address: sem_linear}

val revSeq stmts =
   let
      val lp stmt acc =
         case stmt of
            SEM_NIL: acc
mb0's avatar
Up.  
mb0 committed
75
          | SEM_CONS x: lp x.tl (SEM_CONS{hd=x.hd, tl=acc})
mb0's avatar
mb0 committed
76 77 78 79 80
         end
   in
      lp stmts SEM_NIL
   end

mb0's avatar
mb0 committed
81 82 83
val resultSize op =
   case op of
      SEM_CMPLES x : 1
mb0's avatar
Up.  
mb0 committed
84
    | SEM_MUL x : x.size
mb0's avatar
mb0 committed
85 86 87 88
   end

val operandSize op =
   case op of
mb0's avatar
Up.  
mb0 committed
89
      SEM_CMPLES x : x.size
mb0's avatar
mb0 committed
90 91 92
    | x : resultSize op
   end

mb0's avatar
mb0 committed
93 94
val guessSizeOf dst/src1 src2 = 
   case dst/src1 of
mb0's avatar
mb0 committed
95
      REG r: return ($size (semanticRegisterOf r))
mb0's avatar
Up.  
mb0 committed
96
    | MEM x: return x.sz
mb0's avatar
Foo.  
mb0 committed
97 98 99
    | _:
         case src2 of
            REG r: return ($size (semanticRegisterOf r))
mb0's avatar
Up.  
mb0 committed
100
          | MEM x: return x.sz
mb0's avatar
Foo.  
mb0 committed
101
         end
mb0's avatar
mb0 committed
102 103
   end

mb0's avatar
mb0 committed
104 105 106
val sizeOf op =
   case op of
      REG r: return ($size (semanticRegisterOf r))
mb0's avatar
Up.  
mb0 committed
107
    | MEM x: return x.sz
mb0's avatar
mb0 committed
108 109 110 111 112 113 114 115
    | IMM8 i: return (8)
    | IMM16 i: return (16)
    | IMM32 i: return (32)
    | IMM64 i: return (64)
   end

val var//0 x = {id=x,offset=0}
val var x = SEM_LIN_VAR x
mb0's avatar
sem.  
mb0 committed
116

mb0's avatar
mb0 committed
117
val mktemp = do
mb0's avatar
sem.  
mb0 committed
118
   t <- query $tmp;
mb0's avatar
Foo.  
mb0 committed
119
   t' <- return (t + 1);
mb0's avatar
sem.  
mb0 committed
120
   update @{tmp=t'};
mb0's avatar
Foo.  
mb0 committed
121
   return {id=VIRT_T t,offset=0}
mb0's avatar
sem.  
mb0 committed
122
end
mb0's avatar
mb0 committed
123

mb0's avatar
mb0 committed
124 125 126 127 128 129 130
val mklabel = do
   l <- query $lab;
   l' <- return (l + 1);
   update @{lab=l'};
   return (l)
end

mb0's avatar
mb0 committed
131
val /ASSIGN a b = SEM_ASSIGN{lhs=a,rhs=b}
mb0's avatar
Foo.  
mb0 committed
132
val /LOAD sz a b = SEM_LOAD{lhs=a,size=sz,address=b}
mb0's avatar
mb0 committed
133
val /STORE a b = SEM_STORE{address=a,rhs=b}
mb0's avatar
Foo.  
mb0 committed
134
val /ADD a b = SEM_LIN_ADD{opnd1=a,opnd2=b}
mb0's avatar
mb0 committed
135 136 137 138
val /SUB a b = SEM_LIN_SUB{opnd1=a,opnd2=b}
val /LABEL l = SEM_LABEL{id=l}
val /IFGOTOLABEL c l = SEM_IF_GOTO_LABEL{cond=c,label=l}
val /GOTOLABEL l = SEM_IF_GOTO_LABEL{cond=SEM_LIN_IMM{imm=1},label=l}
mb0's avatar
mb0 committed
139 140

val push insn = do
mb0's avatar
Foo.  
mb0 committed
141 142
   tl <- query $stack;
   update @{stack=SEM_CONS{hd=insn,tl=tl}}
mb0's avatar
mb0 committed
143
end
mb0's avatar
mb0 committed
144

mb0's avatar
Foo.  
mb0 committed
145
val mov sz a b = push (/ASSIGN a (SEM_LIN{size=sz,opnd1=b}))
mb0's avatar
mb0 committed
146
val undef sz a = push (/ASSIGN a (SEM_ARB{size=sz}))
mb0's avatar
Foo.  
mb0 committed
147
val load sz a psz b = push (/LOAD sz a {size=psz,address=b})
mb0's avatar
mb0 committed
148
val store a b = push (/STORE a b)
mb0's avatar
Foo.  
mb0 committed
149
val add sz a b c = push (/ASSIGN a (SEM_LIN{size=sz,opnd1= /ADD b c}))
mb0's avatar
mb0 committed
150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172
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}))
val bswap sz a b = push (/ASSIGN a (SEM_BSWAP{size=sz,opnd1=b}))
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}))
val label l = push (/LABEL l)
val ifgotolabel c l = push (/IFGOTOLABEL c l)
val gotolabel l = push (/GOTOLABEL l)
mb0's avatar
mb0 committed
173

mb0's avatar
mb0 committed
174
val const i = return (SEM_LIN_IMM{imm=i})
mb0's avatar
mb0 committed
175

mb0's avatar
Up.  
mb0 committed
176 177
val /+ x offs = @{offset=offs} x
val /++ x offs = @{offset= $offset x + offs} x
mb0's avatar
mb0 committed
178

mb0's avatar
Foo.  
mb0 committed
179
val convWith conv sz x = 
mb0's avatar
mb0 committed
180
   let
mb0's avatar
Foo.  
mb0 committed
181 182 183 184 185
      val convImm conv x = return (SEM_LIN_IMM{imm=conv x})
      
      val convReg x = return (SEM_LIN_VAR(semanticRegisterOf x))

      val convSum conv sz x = 
mb0's avatar
Up.  
mb0 committed
186 187
         do op1 <- convWith conv sz x.a;
            op2 <- convWith conv sz x.b;
mb0's avatar
Foo.  
mb0 committed
188 189 190 191 192 193 194
            return
               (SEM_LIN_ADD
                  {opnd1=op1,
                   opnd2=op2})
         end

      val convScale conv sz x =
mb0's avatar
Up.  
mb0 committed
195
         do op <- convWith conv sz x.opnd;
mb0's avatar
Foo.  
mb0 committed
196 197 198 199 200 201 202 203 204 205 206 207
            return
               (SEM_LIN_SCALE
                  {opnd=op,
                   imm=
                     case $imm x of
                        '00': 1
                      | '01': 2
                      | '10': 4
                      | '11': 8
                     end})
         end

mb0's avatar
Up.  
mb0 committed
208
      val convMem x = convWith sx x.psz x.opnd
mb0's avatar
mb0 committed
209 210
   in
      case x of
mb0's avatar
Foo.  
mb0 committed
211 212 213 214 215 216 217 218
         IMM8 x: convImm conv x
       | IMM16 x: convImm conv x
       | IMM32 x: convImm conv x
       | IMM64 x: convImm conv x
       | REG x: convReg x
       | SUM x: convSum conv sz x
       | SCALE x: convScale conv sz x
       | MEM x:
mb0's avatar
mb0 committed
219
            do t <- mktemp;
mb0's avatar
Foo.  
mb0 committed
220
               address <- convMem x;
mb0's avatar
Up.  
mb0 committed
221
               load sz t x.psz address;
mb0's avatar
mb0 committed
222
               return (var t)
mb0's avatar
Foo.  
mb0 committed
223 224
            end
      end
mb0's avatar
mb0 committed
225 226
   end

mb0's avatar
Foo.  
mb0 committed
227 228
val read sz x = convWith zx sz x

mb0's avatar
mb0 committed
229 230 231
val write sz x =
   case x of
      MEM x:
mb0's avatar
Up.  
mb0 committed
232
         do address <- convWith sx x.psz x.opnd;
mb0's avatar
mb0 committed
233 234
            return
               (SEM_WRITE_MEM
mb0's avatar
Up.  
mb0 committed
235
                  {size= x.psz,
mb0's avatar
mb0 committed
236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254
                   address=address})
         end
    | REG x:
         do id <- return (semanticRegisterOf x);
            return
               (SEM_WRITE_VAR
                  {size= $size id,
                   id=id})
         end
   end

val commit sz a b =
   case a of
      SEM_WRITE_MEM x:
         store x (SEM_LIN{size=sz,opnd1=b})
    | SEM_WRITE_VAR x:
         #TODO: no zero extension when not in 64bit mode
         case sz of
            32:
mb0's avatar
Up.  
mb0 committed
255
               case x.id.offset of
mb0's avatar
mb0 committed
256
                  0:
mb0's avatar
Up.  
mb0 committed
257
                     do mov 32 x.id b;
mb0's avatar
mb0 committed
258
                        # Zero the upper half of the given register/variable
mb0's avatar
Up.  
mb0 committed
259
                        mov 32 (@{offset=32} x.id) (SEM_LIN_IMM {imm=0})
mb0's avatar
mb0 committed
260
                     end
mb0's avatar
Up.  
mb0 committed
261
                | _: mov sz x.id b
mb0's avatar
mb0 committed
262
               end
mb0's avatar
Up.  
mb0 committed
263
          | _: mov sz x.id b 
mb0's avatar
mb0 committed
264 265 266 267 268 269 270 271 272
         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 fCF = return (var//0 VIRT_LTU)
mb0's avatar
Up.  
mb0 committed
273 274 275 276 277

val fOF = return (var//0 ARCH_R ~1) # OF
val fSF = return (var//0 ARCH_R ~2) # SF
val fAF = return (var//0 ARCH_R ~3) # AF

mb0's avatar
mb0 committed
278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326
val zero = return (SEM_LIN_IMM{imm=0})

val emitAddFlags sz a b c =
   do eq <- fEQ;
      les <- fLES;
      leu <- fLEU;
      lts <- fLTS;
      ltu <- fCF;
      sf <- fSF;
      ov <- fOF;
      t1 <- mktemp;
      t2 <- mktemp;
      t3 <- mktemp;
      zer0 <- zero;
      # HACKERS-DELIGHT p27 
      # TODO: Compute {ltu} flag
      undef 1 ltu;
      xorb sz t1 a b;
      xorb sz t2 a c;
      andb sz t3 (var t1) (var t2);
      cmplts sz ov (var t3) zer0;
      cmplts sz sf a zer0;
      cmpeq sz eq a zer0;
      xorb 1 lts (var sf) (var ov);
      orb 1 leu (var ltu) (var eq);
      orb 1 les (var lts) (var eq)
   end

val emitSubFlags sz a b c = 
   do eq <- fEQ;
      les <- fLES;
      leu <- fLEU;
      lts <- fLTS;
      ltu <- fCF;
      sf <- fSF;
      ov <- fOF;
      t1 <- mktemp;
      t2 <- mktemp;
      t3 <- mktemp;
      zer0 <- zero;
      cmpltu sz ltu b c;
      cmpleu sz leu b c;
      cmplts sz lts b c;
      cmples sz les b c;
      cmpeq sz eq b c;
      cmplts sz sf a zer0;
      xorb 1 ov (var lts) (var sf)
   end

mb0's avatar
Foo.  
mb0 committed
327 328
val semantics insn =
  case insn of
mb0's avatar
mb0 committed
329
      ADD x:
mb0's avatar
Up.  
mb0 committed
330 331 332 333
         do sz <- guessSizeOf x.opnd1 x.opnd2;
            a <- write sz x.opnd1;
            b <- read sz x.opnd1;
            c <- read sz x.opnd2;
mb0's avatar
mb0 committed
334 335 336 337
            t <- mktemp;
            add sz t b c;
            emitAddFlags sz (var t) b c;
            commit sz a (var t)
mb0's avatar
Foo.  
mb0 committed
338
         end
mb0's avatar
mb0 committed
339 340

    | CMP x:
mb0's avatar
Up.  
mb0 committed
341 342 343 344
         do sz <- guessSizeOf x.opnd1 x.opnd2;
            a <- write sz x.opnd1;
            b <- read sz x.opnd1;
            c <- read sz x.opnd2;
mb0's avatar
mb0 committed
345 346 347
            t <- mktemp;
            sub sz t b c;
            emitSubFlags sz (var t) b c
mb0's avatar
mb0 committed
348
         end
mb0's avatar
mb0 committed
349

mb0's avatar
Foo.  
mb0 committed
350
    | MOV x:   
mb0's avatar
Up.  
mb0 committed
351 352 353
         do sz <- guessSizeOf x.opnd1 x.opnd2;
            a <- write sz x.opnd1;
            b <- read sz x.opnd1;
mb0's avatar
mb0 committed
354 355 356 357
            commit sz a b
         end

    | SHL x:
mb0's avatar
Up.  
mb0 committed
358 359 360 361 362
         do sz <- sizeOf x.opnd1;
            szOp2 <- sizeOf x.opnd2;
            a <- write sz x.opnd1;
            b <- read sz x.opnd1;
            c <- read szOp2 x.opnd2;
mb0's avatar
mb0 committed
363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390

            ## Temporary variables:
            t1 <- mktemp;
            t2 <- mktemp;
            cnt <- mktemp;
            cntIsZero <- mktemp;
            cntIsOne <- mktemp;
            af <- fAF;
            ov <- fOF;
            cf <- fCF;
            mask <- const
               (case sz of
                   8: 31
                 | 16: 31
                 | 32: 31
                 | 64: 63
                end);
            zer0 <- const 0;
            one <- const 1;

            ## Instruction semantics:
            exit <- mklabel;
            setflag <- mklabel;
            convert sz cnt szOp2 c;
            andb sz cnt (var cnt) mask;
            cmpeq sz cntIsZero (var cnt) zer0;
            ifgotolabel (var cntIsZero) exit; 
            shl sz t1 b (/SUB (var cnt) one);
mb0's avatar
Up.  
mb0 committed
391
            mov 1 cf (var (t1 /+ (sz - 1)));
mb0's avatar
mb0 committed
392 393 394 395 396 397
            shl sz t2 b (var cnt);
            cmpeq sz cntIsOne (var cnt) one;
            ifgotolabel (var cntIsOne) setflag;
            undef 1 ov; 
            gotolabel exit;
            label setflag;
mb0's avatar
Up.  
mb0 committed
398
            xorb 1 ov (var cf) (var (t2 /+ (sz - 1)));
mb0's avatar
mb0 committed
399 400 401 402 403 404
            label exit;
            undef 1 af;
            commit sz a (var t2)
         end

    | SUB x:
mb0's avatar
Up.  
mb0 committed
405 406 407 408
         do sz <- guessSizeOf x.opnd1 x.opnd2;
            a <- write sz x.opnd1;
            b <- read sz x.opnd1;
            c <- read sz x.opnd2;
mb0's avatar
mb0 committed
409 410 411 412
            t <- mktemp;
            sub sz t b c;
            emitSubFlags sz (var t) b c;
            commit sz a (var t)
mb0's avatar
Foo.  
mb0 committed
413 414 415 416
         end
   end

val translate insn = 
mb0's avatar
mb0 committed
417
   do update@{stack=SEM_NIL,tmp=0,lab=0};
mb0's avatar
Foo.  
mb0 committed
418 419
      semantics insn;
      stack <- query $stack;
mb0's avatar
mb0 committed
420
      return (revSeq stack)
mb0's avatar
mb0 committed
421
   end
mb0's avatar
mb0 committed
422