DidaWiki

(** some support to the analysis of D-RISC code on pipeline processors
    This includes the possibility to find dependencies in linear 
    D-RISC code and to execute D-RISC instructions with a given 
    configuration of registers and memory (with no cache).
    @author Marco Danelutto 
    @year 2011
*)
 
open Printf;;
 
(** the type modelling registers *)
type reg = Reg of int;;
 
(** the type modelling labels: either strings or offsets *)
type label = LabOff of int | LabLab of string;;
 
(** the type modelling the constants: e.g. #i -> Const(i) *)
type const = Const of int;;
 
(** the assembler opcodes *)
type asm = 
   ADD of reg*reg*reg
|  SUB of reg*reg*reg
|  MUL of reg*reg*reg
|  DIV of reg*reg*reg
|  ADDI of reg*const*reg
|  SUBI of reg*const*reg
|  INC of reg
|  DEC of reg
|  LD of reg*reg*reg
|  LDI of reg*const*reg
|  ST of reg*reg*reg
|  STI of reg*const*reg
|  CALL of reg*reg
|  GOTOR of reg
|  GOTOL of label
|  IFLEQ of reg*reg*label
|  IFLE of reg*reg*label
|  IFGEQ of reg*reg*label
|  IFGE of reg*reg*label
|  IFEQ of reg*reg*label
|  IFNEQ of reg*reg*label
|  END
;;
 
(** the assembler instruction: may have a label *)
type instruction = 
   Instr of asm 
|  LabInstr of label*asm;;
 
(** returns the domain of an instruction *)
let domain = function 
   ADD(a,b,c) -> [a;b]
|  SUB(a,b,c) -> [a;b]
|  MUL(a,b,c) -> [a;b]
|  DIV(a,b,c) -> [a;b]
|  ADDI(a,b,c) -> [a]
|  SUBI(a,b,c) -> [a]
|  INC(a) -> [a]
|  DEC(a) -> [a]
|  LD(a,b,c) -> [a;b]
|  ST(a,b,c) -> [a;b;c]
|  LDI(a,b,c) -> [a]
|  STI(a,b,c) -> [a;c]
|  CALL(a,b) -> [a]
|  GOTOR(a) -> [a]
|  GOTOL(a) -> []
|  IFLEQ(a,b,c) -> [a;b]
|  IFLE(a,b,c) -> [a;b]
|  IFGEQ(a,b,c) -> [a;b]
|  IFGE(a,b,c) -> [a;b]
|  IFEQ(a,b,c) -> [a;b]
|  IFNEQ(a,b,c) -> [a;b]
|  END -> []
;;
 
(** returns the range of an instruction *)
let codomain = function 
   ADD(a,b,c) -> [c]
|  SUB(a,b,c) -> [c]
|  MUL(a,b,c) -> [c]
|  DIV(a,b,c) -> [c]
|  ADDI(a,b,c) -> [c]
|  SUBI(a,b,c) -> [c]
|  INC(a) -> [a]
|  DEC(a) -> [a]
|  LD(a,b,c) -> [c]
|  ST(a,b,c) -> []
|  LDI(a,b,c) -> [c]
|  STI(a,b,c) -> []
|  CALL(a,b) -> []
|  GOTOR(a) -> []
|  GOTOL(a) -> []
|  IFLEQ(a,b,c) -> []
|  IFLE(a,b,c) -> []
|  IFGEQ(a,b,c) -> []
|  IFGE(a,b,c) -> []
|  IFEQ(a,b,c) -> []
|  IFNEQ(a,b,c) -> []
|  END -> []
;;
 
(** function computing the intersection of two lists. 
    This is used to compute Bernstein conditions *)
let intersect l1 l2 = 
  let a1 = Array.of_list l1 in
  let a2 = Array.of_list l2 in
  let res = ref [] in 
  let n1 = Array.length a1 in 
  let n2 = Array.length a2 in 
  for i=0 to (n1-1) do 
    for j=0 to (n2-1) do 
      if(a1.(i) = a2.(j))
      then res := a2.(j) :: !res 
    done
  done; 
  !res
;;
 
(** checks if an instruction is "executed" on the IU *)
let iu_instruction = function
    IFLEQ(a,b,c) -> true
  | IFLE(a,b,c)  -> true
  | IFGEQ(a,b,c) -> true
  | IFGE(a,b,c)  -> true
  | IFEQ(a,b,c)  -> true
  | IFNEQ(a,b,c) -> true
  | LD(a,b,c)    -> true
  | LDI(a,b,c)   -> true
  | ST(a,b,c)    -> true
  | STI(a,b,c)   -> true
  | _ -> false
;;
 
(** data dependency: 
	instructions inducing the data dependencies
	interested register(s) 
	"distance"
	"N"
*) 
type datadep = 
  NoDataDep 
| DataDep of int * asm * int * asm * reg list * int * int ;;
 
(** removes labels from an instruction, if present, 
    and returns the assembler instruction only *)
let delab = function
  LabInstr(l,i) -> i 
| Instr(i) -> i;;
 
(** check whether there is a data dependency among instructions
    @param a1 the address of the first instruction
    @param a2 the address of the second instruction
    @param li1 the first instruction 
    @param li2 the second instruction 
    @param dist the distance between instructions 
    @param n the N parameter
*)
let data_dep_i a1 a2 li1 li2 dist n = 
  let i1 = delab li1 in 
  let i2 = delab li2 in
  let wrs = codomain(i1) in
  let rds = domain(i2) in 
  let regset = (intersect rds wrs) in 
  if(iu_instruction i2 && not(regset = []))
    then DataDep(a1,i1,a2,i2,(intersect rds wrs),dist,n)
    else NoDataDep;;
 
(** checks whether there is a load in the sequence 
    leading to the dependency 
    @param i1 the starting point of the sequence
    @param i2 the ending point of the sequence 
    @param prog the program with the sequence *)
let loadsinsequence prog i1 i2 = 
  let aprog = Array.of_list prog in 
  let bign  = ref false in 
  for i=i1 to (i2-1) do
    let asmi = match aprog.(i) with 
	    	Instr(ai) -> ai
	       |LabInstr(l,ai) -> ai in
    bign := match asmi with 
		LD(a,b,c) -> true
	    |   LDI(a,b,c) -> true
	    |   _ -> !bign
  done; 
  !bign
;; 
 
(** finds all data dependencies in a program 
    @param prog the program *)
let data_deps prog = 
  let aprog = Array.of_list prog in
  let n     = Array.length aprog in 
  let res   = ref [] in
  let start = ref 0 in 
  for i=0 to (n-2) do
    for j=(i+1) to (n-1) do
      let i1 = aprog.(i) in 
      let i2 = aprog.(j) in 
      let dd = (data_dep_i i j i1 i2 (j-i) 0) in (* N=0 TODO *)
        match dd with 
          NoDataDep -> ()
        | DataDep(i,i1,j,i2,regs,dist,n) -> 
	    let hasloads = loadsinsequence prog !start (j-1) in
   	    let bign = if(hasloads) then 2 else 1 in
            let dd = DataDep(i,i1,j,i2,regs,dist,bign) in
 
	    start := j;
	    res := (List.append (!res) [dd])
    done
  done;
  !res
;;
 
(** bernstein conditions check *)
let bernstein i1 i2 = 
  let d1 = domain i1 in 
  let d2 = domain i2 in 
  let c1 = codomain i1 in 
  let c2 = codomain i2 in
  let d1c2 = intersect d1 c2 in 
  let d2c1 = intersect d2 c1 in 
  if(d1c2 = [] && d2c1 = []) 
  then true
  else false
;;
 
(** pretty print a register *) 
let pp_reg = function
  Reg(x) -> printf " R_%d " x ;;
 
(** pretty print a list of registers *)
let rec pp_regs = function 
  [] -> ()
| r::rr -> (pp_reg r);(pp_regs rr);;
 
(** pretty print the register set
    Used in pretty print of the 
    environment of execution of a program *)
let pp_reg_set r = 
  let n = Array.length r in 
  for i=0 to (n-1) do
    printf " R%d=%d " i !(r.(i))
  done; 
  printf "\n"
;;
 
(** pretty print a memory state. Used in pretty print of the 
    environment of execution of a program *)
let pp_mem r = 
  let n = Array.length r in 
  for i=0 to (n-1) do
    if(i mod 5 == 0) 
    then printf " M%d=%d " i !(r.(i))
    else printf " %d " !(r.(i));
    if(i mod 19 == 0 && not (i = 0)) 
    then printf "\n"
  done; 
  printf "\n"
;;
 
(** pretty print a label *)
let pp_lab = function 
  LabLab(s) -> printf " %s " s
| LabOff(o) -> printf "L(%d) " o;;
 
(** pretty print a constant *)
let pp_const = function 
  Const c -> printf " #%d " c;;
 
(** pretty print a D-RISC instruction 
    This should still be completed. 
    In case you see a NOFORMATAVAILABLE you should add a clause
    to handle the missing instruction print *)
let pp_asm = function 
  ADD(a,b,c) -> printf "ADD "; pp_reg(a); pp_reg(b); pp_reg(c)
| INC(a) -> printf "INC"; pp_reg(a)
| IFLE(r1,r2,l) -> printf "IF< "; pp_reg(r1); pp_reg(r2); pp_lab(l)
| IFEQ(r1,r2,l) -> printf "IF= "; pp_reg(r1); pp_reg(r2); pp_lab(l)
| LD(a,b,c) -> printf "LOAD "; pp_reg(a); pp_reg(b); pp_reg(c)
| ST(a,b,c) -> printf "STORE "; pp_reg(a); pp_reg(b); pp_reg(c)
| END -> printf "END "
| _ -> printf "NOFORMATAVAILABLE"
;;
 
(** pretty print an instruction, possibly with a label *)
let pp_instr add = function 
  Instr(i) -> printf "%d.\t" add; pp_asm(i); printf "\n"
| LabInstr(l,i) -> printf "%d. " add; 	
		   pp_lab(l); printf ":"; pp_asm(i); printf "\n"
;;
 
(** pretty print a whole program, starting with at a given address *)
let rec pp_prog add = function 
  [] -> printf "\n"
| i::ri -> (pp_instr add i); (pp_prog (add+1) ri)
;;
 
(** pretty print a program, assuming it is allocated from address 0 *)
let pp_program p = (pp_prog 1 p);;
 
 
(** pretty print a data dependency *) 
let pp_dd = function 
  NoDataDep -> ()
| DataDep(a1,i1,a2,i2,regl,d,n) -> 
   printf "DD:: "; 
   printf "%d. " a1; pp_asm i1; printf " ==>> "; 
   printf "%d. " a2; pp_asm i2; 
   printf " (d=%d N=%d) due to reg(s)" d n;
   pp_regs regl;
   printf "\n";;
 
(** pretty print a list of dependencies *)
let rec pp_deps = function 
   [] -> ()
|  d::rd -> (pp_dd d);(pp_deps rd);;
 
 
(** transforms a list of instructions (with labels) into  
    a list of assembler instruction (with no labels) *)
let rec prog_to_asm p = 
  List.map delab p;;
 
 
(** shortcut to maps ... *)
type assoc = Ass of string * int;;
 
(** checks whether a key is in a map *)
let rec hasKey k = function 
   [] -> false
|  Ass(kk,vv)::rm -> if(kk = k) then true else (hasKey k rm);;
 
(** looks up a key in a map*)
let rec valueOfKey k labs = 
  match labs with 
    [] -> failwith "key not found"
  | Ass(kk,vv)::rl -> if(kk=k) then vv else (valueOfKey k rl);;
 
(** execution environment (the state of the processor + 
    the labels compiled. 
    an environment is 
	pc, reg, mem, labels
 *)
type penv = 
  Penv of int ref * int ref array * int ref array * assoc list;;
 
(** pretty print the environment *)
let dump penv = 
  match penv with 
     Penv(pc,r,m,a) ->
	printf "PC=%d \n" !pc; 
        pp_reg_set r;
        pp_mem m
;;
 
(** execute one instruction within an environment 
    @param i the instruction to be executed 
    @param env the initial environment. it is modified via side effects *)
let exec_i i env = 
  match env with 
    Penv(pc,r,m,labs) ->
  (match i with 
    ADD(Reg(a),Reg(b),Reg(c)) -> r.(c) := !(r.(a)) + !(r.(b));pc:= !pc+1
|   SUB(Reg(a),Reg(b),Reg(c)) -> r.(c) := !(r.(a)) - !(r.(b));pc:= !pc+1
|   MUL(Reg(a),Reg(b),Reg(c)) -> r.(c) := !(r.(a)) * !(r.(b));pc:= !pc+1
|   DIV(Reg(a),Reg(b),Reg(c)) -> r.(c) := !(r.(a)) / !(r.(b));pc:= !pc+1
|   ADDI(Reg(a),Const(b),Reg(c)) -> r.(c) := !(r.(a)) + b;pc:= !pc+1
|   SUBI(Reg(a),Const(b),Reg(c)) -> r.(c) := !(r.(a)) - b;pc:= !pc+1
|   INC(Reg(a)) -> r.(a) := !(r.(a))+1; pc:= !pc +1
|   DEC(Reg(a)) -> r.(a) := !(r.(a))-1; pc:= !pc +1
|   LD(Reg(a),Reg(b),Reg(c)) -> 
	let ind = !(r.(a)) + !(r.(b)) in 
	  r.(c) := !(m.(ind)); pc := !pc + 1
|   LDI(Reg(a),Const(b),Reg(c)) -> 
	let ind = !(r.(a)) + b in 
	  r.(c) := !(m.(ind)); pc := !pc + 1
|   ST(Reg(a),Reg(b),Reg(c)) -> 
        let ind = !(r.(a)) + !(r.(b)) in
          m.(ind) := !(r.(c)); pc := !pc + 1
|   STI(Reg(a),Const(b),Reg(c)) -> 
        let ind = !(r.(a)) + b in
          m.(ind) := !(r.(c)); pc := !pc + 1
|   CALL(Reg(f), Reg(ret)) -> 
	r.(ret):= !pc + 1;
 	pc := !(r.(f))
|   GOTOR(Reg(l)) ->  pc := !(r.(l))
|   GOTOL(LabLab(ll)) ->  
	let l = valueOfKey ll labs in
           pc := !pc + l 
|   IFLEQ(Reg(r1),Reg(r2),LabOff(l)) ->
       if(!(r.(r1)) <= !(r.(r2))) 
       then pc := !pc + l 
       else pc := !pc + 1
|   IFLE(Reg(r1),Reg(r2),LabOff(l)) ->
       if(!(r.(r1)) < !(r.(r2))) 
       then pc := !pc + l 
       else pc := !pc + 1
|   IFGEQ(Reg(r1),Reg(r2),LabOff(l)) ->
       if(!(r.(r1)) >= !(r.(r2))) 
       then pc := !pc + l 
       else pc := !pc + 1
|   IFGE(Reg(r1),Reg(r2),LabOff(l)) ->
       if(!(r.(r1)) > !(r.(r2))) 
       then pc := !pc + l 
       else pc := !pc + 1
|   IFEQ(Reg(r1),Reg(r2),LabOff(l)) ->
       if(!(r.(r1)) = !(r.(r2))) 
       then pc := !pc + l 
       else pc := !pc + 1
|   IFNEQ(Reg(r1),Reg(r2),LabOff(l)) ->
       if(not(!(r.(r1)) = !(r.(r2)))) 
       then pc := !pc + l 
       else pc := !pc + 1
| _ -> printf "UNINPLEMENTED")
;;
 
(** compile labels. Takes a program with labels and returns 
    a map with the label addresses
    @param pgm the program
    @param addr the initial address of the program  *)
let rec labels pgm addr = 
  match pgm with 
    [] -> []
  | i::ri -> 
      (match i with 
         Instr(i) -> (labels ri (addr+1))
       | LabInstr(LabLab(l),i) -> Ass(l,addr)::(labels ri (addr+1))
       | LabInstr(LabOff(l),i) -> (labels ri (addr+1))
      )
;;