(**********************************************************************)
(* (c) Greg Morrisett, Steve Zdancewic                                *)
(*     June 1998, all rights reserved.                                *)
(**********************************************************************)

(* cfginstr.ml
 *
 * Implements some useful functions for extracting information from
 * TAL instructions
 *)

open Utilities
open Tal
open Set

let g_set g = match g with
  Reg r -> singleton compare_regs r
| Prjr ((r, _), _) -> singleton compare_regs r
| _ -> empty compare_regs

let arithBinRegs dest src =
  let d = g_set dest in
  let s = g_set src in
  let ds = union d s in
  match dest with
    Reg r -> (d, ds)
  | _ -> (empty compare_regs, ds)

let arithUnRegs dest =
  let d = g_set dest in
  match dest with
    Reg r -> (d, d)
  | _ -> (empty compare_regs, d)

let arithMDRegs op src = 
  let l = from_list compare_regs [Eax; Edx] in
  match op with
    (Mul | Imul1) -> (l, insert (g_set src) Eax)
  | (Div | Idiv) -> (l, union l (g_set src))

let convRegs c = 
  let s = singleton compare_regs in
  let seax = s Eax in
  match c with
    (Cbw | Cwde) -> (seax, seax)
  | (Cwd | Cdq) -> (insert (seax) Edx, seax)
  | Movsx (r, _, g, _) -> (s r, g_set g)
  | Movzx (r, _, g, _) -> (s r, g_set g)

(* Determines the registers defined and used by a given instruction.  The sets *)
(* returned exclude Esp, since that is a reserved register and unneccesary for *)
(* the interference graph. *)
let def_use i = 
  let e = empty compare_regs in
  let s = singleton compare_regs in
  match i with
    ArithBin(_, dest, src) -> arithBinRegs dest src
  | ArithUn(_, dest) -> arithUnRegs dest
  | ArithMD(op, src) -> arithMDRegs op src
  | ArithSR(_, g, None) -> (g_set g, insert (g_set g) Ecx)
  | ArithSR(_, g, Some _) -> (g_set g, g_set g)
  | Bswap r -> (s r, s r)
  | Call (g, _) -> (e, g_set g)
  | Clc -> (e, e)
  | Cmc -> (e, e)
  | Cmovcc(_, r1, (g, _)) -> (s r1, g_set g)
  | Cmp(g1, g2) -> (e, union (g_set g1) (g_set g2))
  | Conv c -> convRegs c
  | Imul3 (r, g, _) -> (s r, g_set g)
  | Int _ -> (e, e)
  | Into -> (e, e)
  | Jcc (_, _) -> (e, e)
  | Jecxz _ -> (e, s Ecx)
  | Jmp (g, _) -> (e, g_set g)
  | Lahf -> (s Eax, e)
  | Lea (r, g) -> (s r, g_set g)
  | Loopd _ -> (s Ecx, e)
  | Mov (Reg r, (g, _)) -> (s r, g_set g)
  | Mov (g1, (g2, _)) -> (e, union (g_set g1) (g_set g2))
  | Nop -> (e, e)
  | Pop g -> (g_set g, e)
  | Popad -> (from_list compare_regs [Edi; Esi; Eax; Ebx; Ecx; Edx; Ebp], e)
  | Popfd -> (e, e)
  | Push (g, _) -> (e, g_set g)
  | Pushad -> (e, from_list compare_regs [Edi; Esi; Eax; Ebx; Ecx; Edx; Ebp])
  | Pushfd -> (e, e)
  | Retn _ -> (e, e)
  | Sahf -> (e, s Eax)
  | Setcc (_, g) -> (g_set g, g_set g)
  | Shld (g, r, None) -> (g_set g, insert (union (g_set g) (s r)) Ecx)
  | Shld (g, r, Some _) -> (g_set g, union (g_set g) (s r))
  | Shrd (g, r, None) -> (g_set g, insert (union (g_set g) (s r)) Ecx)
  | Shrd (g, r, Some _) -> (g_set g, union (g_set g) (s r))
  | Stc -> (e, e)
  | Test (g1, g2) -> (e, union (g_set g1) (g_set g2))
  | Xchg (g, r) -> let u = insert (g_set g) r in (u, u)
  | Asub (r1, g1, _, r2, g2) -> (s r1, insert (union (g_set g1) (g_set g2)) r2)
  | Aupd (g1, _, r1, r2, g2) -> (e, insert (insert (union (g_set g1) (g_set g2)) 
					      r1) r2)
  | Bexn (r, g, _) -> (e, insert (g_set g) r)
  | Btagi (r, _, _, _) -> (e, s r)
  | Btagvar (r, _, _, _, _) -> (e, s r)
  | Coerce (r, cl) -> (s r, s r)  
  | Comment _ -> (e, e)
  | Fallthru _ -> (e, e)
  | Malloc (_, _) -> (from_list compare_regs [Eax; Ebx; Ecx; Edx; Esi; Edi], e)
  | Unpack (_, r, (g, _)) -> (s r, g_set g)

let is_move i = 
  match i with
    Mov (Reg _, ((Reg _), _)) -> true
  | _ -> false

(* EOF: cfginstr.ml *)
