Fixes defined variables, fixes live variables, implements reduces registers, fixes risc semantic

This commit is contained in:
elvis
2024-12-27 21:11:38 +01:00
parent f1b4c3a17d
commit 3be05222ab
15 changed files with 866 additions and 214 deletions

View File

@ -59,7 +59,8 @@ module RISCAssembly = struct
type t = {
code : risci list;
inputval: int option
inputval: int option;
inputoutputreg: (register * register) option;
}
let pp_risci (ppf: out_channel) (v: risci) : unit =
@ -285,4 +286,9 @@ let rec helper
let convert (prg: CfgRISC.RISCCfg.t) : RISCAssembly.t =
{code = (helper prg (Option.get prg.initial) [] |> fst |>
List.append ([Label "main"] : RISCAssembly.risci list));
inputval = prg.inputVal}
inputval = prg.inputVal;
inputoutputreg =
match prg.inputOutputVar with
None -> None
| Some (i, o) -> Some ({index = i}, {index = o})
}

View File

@ -50,7 +50,8 @@ module RISCAssembly : sig
type t = {
code : risci list;
inputval: int option
inputval: int option;
inputoutputreg: (register * register) option;
}
val pp_risci : out_channel -> risci -> unit

View File

@ -13,7 +13,8 @@ module RISCArchitecture = struct
type t = {
code: RISC.RISCAssembly.risci list CodeMap.t;
registers: int RegisterMap.t;
memory: int MemoryMap.t
memory: int MemoryMap.t;
outputreg: Register.t;
}
end
@ -101,7 +102,8 @@ let reduce_instructions (prg: RISCArchitecture.t) (lo: string list) : int =
else
prg
)
| Nop :: tl -> helper prg tl current_label
| Nop :: tl ->
helper prg tl current_label
| BRegOp (brop, r1, r2, r3) :: tl -> (
let n = (match_operator_r brop)
(RegisterMap.find {index = r1.index} prg.registers)
@ -136,7 +138,8 @@ let reduce_instructions (prg: RISCArchitecture.t) (lo: string list) : int =
)
)
| Load (r1, r3) :: tl -> (
let n = MemoryMap.find
let n =
MemoryMap.find
(RegisterMap.find {index = r1.index} prg.registers)
prg.memory
in
@ -164,14 +167,29 @@ let reduce_instructions (prg: RISCArchitecture.t) (lo: string list) : int =
| Label _ :: tl -> helper prg tl current_label
in
RegisterMap.find
{index = "out"}
prg.outputreg
(helper prg (CodeMap.find "main" prg.code) "main").registers
let reduce (prg: RISC.RISCAssembly.t) : int =
reduce_instructions {code = convert prg;
registers =
RegisterMap.singleton
{index = "in"}
(Option.value prg.inputval ~default:0);
memory = MemoryMap.empty} (label_order prg)
reduce_instructions
{code = convert prg;
registers = (
match prg.inputoutputreg with
| None ->
RegisterMap.singleton
{index = "in"}
(Option.value prg.inputval ~default:0)
| Some (i, _) ->
RegisterMap.singleton
{index = i.index}
(Option.value prg.inputval ~default:0)
);
memory = MemoryMap.empty;
outputreg = (
match prg.inputoutputreg with
| None -> {index = "out"}
| Some (_, o) -> {index = o.index}
)
}
(label_order prg)

View File

@ -50,13 +50,13 @@ let variables_used (instr : DVCfg.elt) : DVCfg.internal list =
| Nop
| LoadI (_, _) ->
acc
| Store (r1, r2)
| BRegOp (_, r1, r2, _) ->
DVCeltSet.add r1.index acc |>
DVCeltSet.add r2.index
| BImmOp (_, r1, _, _)
| URegOp (_, r1, _)
| Load (r1, _)
| Store (r1, _) ->
| Load (r1, _) ->
DVCeltSet.add r1.index acc
in
@ -71,24 +71,18 @@ let variables_used_all (instructions : DVCfg.elt list) : DVCfg.internal list =
let variables_defined (instructions : DVCfg.elt) : DVCfg.internal list =
let helper (acc: DVCeltSet.t) (instr: DVCfg.elt) =
match instr with
| Nop -> acc
| Nop
| Store (_, _) -> acc
| BRegOp (_, _, _, r3)
| BImmOp (_, _, _, r3)
| URegOp (_, _, r3)
| Load (_, r3)
| LoadI (_, r3)
| Store (_, r3) ->
| LoadI (_, r3) ->
DVCeltSet.add r3.index acc
in
helper DVCeltSet.empty instructions |> DVCeltSet.to_list
let variables_defined_all (instructions : DVCfg.elt list) : DVCfg.internal list =
List.fold_left (fun (acc: DVCeltSet.t) (instr: DVCfg.elt) ->
DVCeltSet.union acc (variables_defined instr |> DVCeltSet.of_list)
) DVCeltSet.empty instructions |> DVCeltSet.to_list
(* init function, assign the bottom to everything *)
let _init_bottom : (DVCfg.elt list -> DVCfg.internalnode) =
@ -104,91 +98,91 @@ let init_top (all_variables) : (DVCfg.elt list -> DVCfg.internalnode) =
(fun _ -> (all_variables, all_variables)))})
(* piece of code that computes vout for the whole block, not used,
use lub below *)
let _dumb_lub (t: DVCfg.t) (node: Cfg.Node.t) : DVCfg.internalnode =
let previnternalvar = Cfg.NodeMap.find node t.internalvar in
let code = Cfg.NodeMap.find node t.t.content in
{ previnternalvar with
internalout =
Utility.unique_union (variables_defined_all code) (previnternalvar.internalin)
}
(* We consider only the propagation in the middle elements during the lub.
This incurs in a performance penality, but it is simpler to implement.
Each node is connected to one previus node.
*)
let lub (t: DVCfg.t) (node: Cfg.Node.t) : DVCfg.internalnode =
let previnternalvar = Cfg.NodeMap.find node t.internalvar in
let code = match Cfg.NodeMap.find_opt node t.t.content with
None -> []
| Some c -> c
in
let newinternalbetween = (
List.map
(fun (code, (i, _o)) ->
(i, Utility.unique_union i (variables_defined code)))
(List.combine code previnternalvar.internalbetween)
) in
let newinternalout =
match newinternalbetween with
| [] -> previnternalvar.internalin
| _ -> (snd (Utility.last_list newinternalbetween))
in
{ previnternalvar with
internalbetween =
List.mapi (* we don't NEED the index but i = 0 is easier to write than
to check if vinout is None *)
(fun i (ithcode, vinout, ithcodeprev) ->
if i = 0 then
let dvin = previnternalvar.internalin in
(dvin, Utility.unique_union dvin (variables_defined ithcode))
else (
let ithcodeprev = match ithcodeprev with
None -> ([], [])
| Some x -> x
in
match vinout with
None ->
([], variables_defined ithcode)
| Some prevdvbtw ->
(snd prevdvbtw,
Utility.unique_union
(variables_defined ithcode)
(ithcodeprev |> fst)
))
)
(* ugly code that zips the three lists that we need to compute each vin
and vout for the middle of the code *)
(Utility.combine_thrice
code
(Utility.pad_opt
(Utility.prev previnternalvar.internalbetween None) None (List.length code))
(Utility.pad previnternalvar.internalbetween None (List.length code))
);
internalout =
match previnternalvar.internalbetween with
[] -> previnternalvar.internalin
| _ -> (snd (Utility.last_list previnternalvar.internalbetween))
}
internalbetween = newinternalbetween;
internalout = newinternalout }
let lucf (t: DVCfg.t) (node: Cfg.Node.t) : DVCfg.internalnode =
let previnternalvar = Cfg.NodeMap.find node t.internalvar in
if Option.equal (=) (Some node) t.t.initial then
(* if L is initial set dvin to the "in" register *)
let newinternalin = (
match t.t.inputOutputVar with
Some (i, _) -> [i]
| None -> []
) in
let newinternalbetween = ( (* set the dvin of each to the previous dvout *)
match previnternalvar.internalbetween with
[] -> []
| [(_i, o)] -> [(newinternalin, o)]
| (_i, o) :: btwrest ->
(newinternalin, o) :: (
List.map (fun ((_i, o), (_previ, prevo)) -> (prevo, o))
(Utility.combine_twice btwrest previnternalvar.internalbetween)
)
) in
{ previnternalvar with
internalin =
match t.t.inputOutputVar with
Some (i, _) -> [i]
| None -> []
}
internalin = newinternalin;
internalbetween = newinternalbetween }
else
(* if L is not initial set dvin to the intersection of the previous node's
dvouts *)
let prevnodes = Cfg.NodeMap.find node t.t.reverseEdges in
let newinternalin = (
match prevnodes with
| [] ->
[]
| [prevnode] ->
(Cfg.NodeMap.find prevnode t.internalvar).internalout
| [prevnode1; prevnode2] ->
Utility.unique_intersection
(Cfg.NodeMap.find prevnode1 t.internalvar).internalout
(Cfg.NodeMap.find prevnode2 t.internalvar).internalout
| prevnode :: restnodes ->
List.fold_left (* intersection of all previous nodes' dvout *)
(fun acc prevnode ->
Utility.unique_intersection
acc
(Cfg.NodeMap.find prevnode t.internalvar).internalout)
(Cfg.NodeMap.find prevnode t.internalvar).internalout
restnodes
) in
let newinternalbetween =
match previnternalvar.internalbetween with
[] -> []
| [(_i, o)] -> [(newinternalin, o)]
| (_i, o) :: btwrest ->
(newinternalin, o) :: (
List.map (fun ((_i, o), (_previ, prevo)) -> (prevo, o))
(Utility.combine_twice btwrest previnternalvar.internalbetween)
)
in
{ previnternalvar with
internalin =
match prevnodes with
[] -> []
| [prevnode] -> (Cfg.NodeMap.find prevnode t.internalvar).internalout
| [prevnode1; prevnode2] ->
Utility.unique_intersection
(Cfg.NodeMap.find prevnode1 t.internalvar).internalout
(Cfg.NodeMap.find prevnode2 t.internalvar).internalout
| _ ->
List.fold_left (* intersection of all previous nodes' dvout *)
(fun acc prevnode ->
Utility.unique_intersection acc (Cfg.NodeMap.find prevnode t.internalvar).internalout)
[]
prevnodes
}
internalin = newinternalin;
internalbetween = newinternalbetween }
let update (t: DVCfg.t) (node: Cfg.Node.t) : DVCfg.internalnode =
@ -198,10 +192,16 @@ let update (t: DVCfg.t) (node: Cfg.Node.t) : DVCfg.internalnode =
let compute_defined_variables (cfg: RISCCfg.t) : DVCfg.t =
let all_variables = List.fold_left
(fun acc (_, code) -> Utility.unique_union acc (variables_all code))
(fun acc (_, code) ->
Utility.unique_union acc (variables_all code))
[]
(Cfg.NodeMap.to_list cfg.content)
in
let all_variables =
match cfg.inputOutputVar with
| None -> all_variables
| Some (i, o) -> Utility.unique_union all_variables [i;o]
in
DVCfg.from_cfg cfg
|> DVCfg.fixed_point ~init:(init_top all_variables) ~update:update

View File

@ -3,6 +3,7 @@ open Analysis
module Variable : sig
type t
val pp : out_channel -> t -> unit
val pplist : out_channel -> t list -> unit
end
module RISCCfg = CfgRISC.RISCCfg

View File

@ -13,6 +13,7 @@
(modules Lexer Parser Types Semantics
CfgImp ReplacePowerMod
CfgRISC DefinedVariables LiveVariables
ReduceRegisters
RISC RISCSemantics)
(libraries analysis utility menhirLib))

View File

@ -24,45 +24,33 @@ let variables_used (instr : DVCfg.elt) : DVCfg.internal list =
| Nop
| LoadI (_, _) ->
acc
| BRegOp (_, r1, r2, _) ->
| BRegOp (_, r1, r2, _)
| Store (r1, r2) ->
DVCeltSet.add r1.index acc |>
DVCeltSet.add r2.index
| BImmOp (_, r1, _, _)
| URegOp (_, r1, _)
| Load (r1, _)
| Store (r1, _) ->
| Load (r1, _) ->
DVCeltSet.add r1.index acc
in
helper DVCeltSet.empty instr |> DVCeltSet.to_list
let _variables_used_all (instructions : DVCfg.elt list) : DVCfg.internal list =
List.fold_left (fun (acc: DVCeltSet.t) (instr: DVCfg.elt) ->
DVCeltSet.union acc (variables_used instr |> DVCeltSet.of_list)
) DVCeltSet.empty instructions |> DVCeltSet.to_list
let variables_defined (instructions : DVCfg.elt) : DVCfg.internal list =
let helper (acc: DVCeltSet.t) (instr: DVCfg.elt) =
match instr with
| Nop -> acc
| Nop
| Store (_, _) -> acc
| BRegOp (_, _, _, r3)
| BImmOp (_, _, _, r3)
| URegOp (_, _, r3)
| Load (_, r3)
| LoadI (_, r3)
| Store (_, r3) ->
| LoadI (_, r3) ->
DVCeltSet.add r3.index acc
in
helper DVCeltSet.empty instructions |> DVCeltSet.to_list
let _variables_defined_all (instructions : DVCfg.elt list) : DVCfg.internal list =
List.fold_left (fun (acc: DVCeltSet.t) (instr: DVCfg.elt) ->
DVCeltSet.union acc (variables_defined instr |> DVCeltSet.of_list)
) DVCeltSet.empty instructions |> DVCeltSet.to_list
(* init function, assign the bottom to everything *)
let init : (DVCfg.elt list -> DVCfg.internalnode) =
(fun l -> {internalin = [];
@ -75,58 +63,68 @@ let lub (t: DVCfg.t) (node: Cfg.Node.t) : DVCfg.internalnode =
None -> []
| Some c -> c
in
let newinternalbetween = (
List.map
(fun (code, (_i, o)) ->
(Utility.unique_union
(variables_used code)
(Utility.subtraction o (variables_defined code)), o))
(Utility.combine_twice code previnternalvar.internalbetween)
) in
let newinternalin =
match newinternalbetween with
| [] -> previnternalvar.internalout
| (i, _)::_ -> i
in
{ previnternalvar with
internalbetween =
List.map (fun (prevbtw, code, nextprevbtw) ->
let newin = Utility.unique_union (variables_used code)
(Utility.subtraction (snd prevbtw) (variables_defined code))
in
match nextprevbtw with
None -> (newin, snd prevbtw)
| Some (newout, _) -> (newin, newout)
)
(Utility.combine_thrice previnternalvar.internalbetween code
(Utility.pad (List.tl previnternalvar.internalbetween) None (List.length previnternalvar.internalbetween)))
;
internalin = fst (List.hd previnternalvar.internalbetween);
}
internalbetween = newinternalbetween;
internalin = newinternalin; }
let lucf (t: DVCfg.t) (node: Cfg.Node.t) : DVCfg.internalnode =
let previnternalvar = Cfg.NodeMap.find node t.internalvar in
if Option.equal (=) (Some node) t.t.terminal then
let outputvarlist = match t.t.inputOutputVar with
let newinternalout = (
if Option.equal (=) (Some node) t.t.terminal then (
match t.t.inputOutputVar with
Some (_, o) -> [o]
| None -> []
in
{ previnternalvar with
internalout = outputvarlist;
internalbetween = (
let last_elem = Utility.last_list previnternalvar.internalbetween in
(Utility.drop_last_element_list previnternalvar.internalbetween) @
[(fst last_elem, outputvarlist)]
)
}
else
let nextnodes = Cfg.NodeMap.find_opt node t.t.edges in
let newinternalout = match nextnodes with
None -> []
| Some (node, None) -> (Cfg.NodeMap.find node t.internalvar).internalin
) else (
let nextnodes = Cfg.NodeMap.find_opt node t.t.edges in
match nextnodes with
| None -> []
| Some (node, None) ->
(Cfg.NodeMap.find node t.internalvar).internalin
| Some (node1, Some node2) ->
Utility.unique_union
(Cfg.NodeMap.find node1 t.internalvar).internalin
(Cfg.NodeMap.find node2 t.internalvar).internalin
in
{ previnternalvar with
internalout = newinternalout;
internalbetween = (
let last_elem = Utility.last_list previnternalvar.internalbetween in
(Utility.drop_last_element_list previnternalvar.internalbetween) @
[(fst last_elem, newinternalout)]
)
}
)
) in
let newinternalbetween = (
match List.rev previnternalvar.internalbetween with
| [] -> []
| (i, _o) :: btwrest ->
let btwrest = List.rev btwrest in
let newbtwrest = List.map2
(fun (i, _o) (nexti, _nexto) -> (i, nexti))
btwrest
(Utility.drop_first_element_list previnternalvar.internalbetween)
in
newbtwrest @ [(i, newinternalout)]
) in
{ previnternalvar with
internalout = newinternalout;
internalbetween = newinternalbetween; }
let update (t: DVCfg.t) (node: Cfg.Node.t) : DVCfg.internalnode =
let newt = {t with internalvar = (Cfg.NodeMap.add node (lucf t node) t.internalvar)} in
let newt = {t with internalvar = (Cfg.NodeMap.add node
(lucf t node)
t.internalvar)} in
lub newt node
@ -135,10 +133,136 @@ let compute_live_variables (cfg: RISCCfg.t) : DVCfg.t =
|> DVCfg.fixed_point ~init:init ~update:update
module VariableMap = struct
include Map.Make(Variable)
let first_empty next start m l =
let bindings =
List.fold_left (
fun acc x ->
match find_opt x m with
| None -> acc
| Some x -> x :: acc) [] l |> List.sort Variable.compare in
let rec aux x =
if List.mem x bindings
then aux (next x)
else x
in
aux start
let first_empty_Variable m l =
let next = fun x -> x |> int_of_string |> (+) 1 |> string_of_int in
let start = "1" in
first_empty next start m l
let get_mapping m l r =
match find_opt r m with
| None -> (
let newr = first_empty_Variable m l in
let newm = add r newr m in
(newm, newr)
)
| Some r -> (m, r)
end
(* just rename the registers that dont share live status *)
let optimize_cfg (t: DVCfg.t) : DVCfg.t =
t
let replace_code ((vin, vout): Variable.t list * Variable.t list)
(a: Variable.t VariableMap.t)
(code: DVCfg.elt)
: (Variable.t VariableMap.t * DVCfg.elt) =
match code with
| Nop -> (
(a, Nop)
)
| BRegOp (brop, r1, r2, r3) -> (
let (newa, newr1) = VariableMap.get_mapping a vin r1.index in
let (newa, newr2) = VariableMap.get_mapping newa vin r2.index in
let (newa, newr3) = VariableMap.get_mapping newa vout r3.index in
(newa, BRegOp (brop, {index = newr1}, {index = newr2}, {index = newr3}))
)
| BImmOp (biop, r1, i, r3) -> (
let (newa, newr1) = VariableMap.get_mapping a vin r1.index in
let (newa, newr3) = VariableMap.get_mapping newa vout r3.index in
(newa, BImmOp (biop, {index = newr1}, i, {index = newr3}))
)
| URegOp (urop, r1, r3) -> (
let (newa, newr1) = VariableMap.get_mapping a vin r1.index in
let (newa, newr3) = VariableMap.get_mapping newa vout r3.index in
(newa, URegOp (urop, {index = newr1}, {index = newr3}))
)
| Load (r1, r3) -> (
let (newa, newr1) = VariableMap.get_mapping a vin r1.index in
let (newa, newr3) = VariableMap.get_mapping newa vout r3.index in
(newa, Load ({index = newr1}, {index = newr3}))
)
| LoadI (i, r3) -> (
let (newa, newr3) = VariableMap.get_mapping a vout r3.index in
(newa, LoadI (i, {index = newr3}))
)
| Store (r1, r3) -> (
let (newa, newr1) = VariableMap.get_mapping a vin r1.index in
let (newa, newr3) = VariableMap.get_mapping newa vout r3.index in
(newa, Store ({index = newr1}, {index = newr3}))
)
in
let aux (assignments: Variable.t VariableMap.t) (t: DVCfg.t) (node: Cfg.Node.t)
: (Variable.t VariableMap.t * DVCfg.t) =
let livevars = Cfg.NodeMap.find node t.internalvar in
let code =
match Cfg.NodeMap.find_opt node t.t.content with
| None -> []
| Some x -> x
in
let newcode, newassignments =
(List.fold_left2
(fun (acc, assignments) btw code ->
let na, nc = replace_code btw assignments code in
(acc @ [nc], na)
)
([], assignments)
livevars.internalbetween
code)
in
let newcontent = Cfg.NodeMap.add
node
newcode
t.t.content
in
let newt = { t with t = { t.t with content = newcontent } } in
(newassignments, newt)
in
(* --------- *)
let assignments = VariableMap.empty in
let a, newt =
Cfg.NodeSet.fold (* for each node we replace all the variables with the
optimized ones *)
(fun node (ass, t) -> aux ass t node)
t.t.nodes
(assignments, t)
in
{ newt with
t = { newt.t with
inputOutputVar =
match newt.t.inputOutputVar with
None -> None
| Some (i, o) -> (
match VariableMap.find_opt i a, VariableMap.find_opt o a with
| None, None -> Some (i, o)
| Some i, None -> Some (i, o)
| None, Some o -> Some (i, o)
| Some i, Some o -> Some (i, o)
)
}}
let compute_cfg (dvcfg: DVCfg.t) : RISCCfg.t =

View File

@ -0,0 +1,416 @@
open Analysis
module Variable = struct
type t = string
let _pp (ppf: out_channel) (v: t) : unit =
Printf.fprintf ppf "%s" v
let _pplist (ppf: out_channel) (vv: t list) : unit =
List.iter (Printf.fprintf ppf "%s, ") vv
let compare a b =
String.compare a b
end
module RISCCfg = CfgRISC.RISCCfg
module VariableMap = Map.Make(Variable)
let variables_frequency (instr : RISCCfg.elt) : (Variable.t * int) list =
let add_one = (fun x -> match x with None -> Some 1 | Some x -> Some (x + 1)) in
let helper (acc: int VariableMap.t) (instr: RISCCfg.elt) =
match instr with
| Nop ->
acc
| BRegOp (_, r1, r2, r3) ->
VariableMap.update r1.index add_one acc |>
VariableMap.update r2.index add_one |>
VariableMap.update r3.index add_one
| BImmOp (_, r1, _, r3)
| URegOp (_, r1, r3)
| Load (r1, r3)
| Store (r1, r3) ->
VariableMap.update r1.index add_one acc |>
VariableMap.update r3.index add_one
| LoadI (_, r3) ->
VariableMap.update r3.index add_one acc
in
helper VariableMap.empty instr |> VariableMap.to_list
let variables_all_frequency (instructions : RISCCfg.elt list) : (Variable.t * int) list =
List.fold_left (fun (acc: int VariableMap.t) (instr: RISCCfg.elt) ->
VariableMap.union (fun _v x y -> Some (x + y)) acc (variables_frequency instr |> VariableMap.of_list)
) VariableMap.empty instructions |> VariableMap.to_list
let reduceregisters (n: int) (cfg: RISCCfg.t) : RISCCfg.t =
(if n < 4 then (failwith "ReduceRegisters: number of registers too small") else ());
(* we get all the variables with associated frequency (only syntactic use) *)
let all_variables = List.fold_left
(fun acc (_, code) ->
Utility.unique_union acc (variables_all_frequency code))
[]
(Cfg.NodeMap.to_list cfg.content)
in
let all_variables =
match cfg.inputOutputVar with
| None -> all_variables
| Some (i, _o) -> (
match List.assoc_opt i all_variables with
| None -> (i, 1) :: all_variables
| Some f -> (i, f+1) :: (List.remove_assoc i all_variables)
)
in
let all_variables =
match cfg.inputOutputVar with
| None -> all_variables
| Some (_i, o) -> (
match List.assoc_opt o all_variables with
| None -> (o, 1) :: all_variables
| Some f -> (o, f+1) :: (List.remove_assoc o all_variables)
)
in
let replaceregisters
(remappedregisters: Variable.t VariableMap.t)
(memorymap: int VariableMap.t)
(temporaryregisters: Variable.t list)
(code: RISCCfg.elt list)
: RISCCfg.elt list =
let tmpreg1: CfgRISC.RISCSimpleStatements.register =
{index = List.nth temporaryregisters 0} in
let tmpreg2: CfgRISC.RISCSimpleStatements.register =
{index = List.nth temporaryregisters 1} in
let aux (instruction: RISCCfg.elt) : RISCCfg.elt list =
match instruction with
| Nop -> [Nop]
| BRegOp (brop, r1, r2, r3) -> (
match ( VariableMap.find_opt r1.index remappedregisters,
VariableMap.find_opt r2.index remappedregisters,
VariableMap.find_opt r3.index remappedregisters,
VariableMap.find_opt r1.index memorymap,
VariableMap.find_opt r1.index memorymap,
VariableMap.find_opt r3.index memorymap )
with
| Some r1, Some r2, Some r3, _, _, _ ->
[BRegOp (brop, {index = r1}, {index = r2}, {index = r3})]
| Some r1, Some r2, None, _, _, Some m3 ->
[BRegOp (brop, {index = r1}, {index = r2}, tmpreg2);
LoadI (m3, tmpreg1);
Store (tmpreg2, tmpreg1)]
| Some r1, None, Some r3, _, Some m2, _ ->
[LoadI (m2, tmpreg2);
Load (tmpreg2, tmpreg2);
BRegOp (brop, {index = r1}, tmpreg2, {index = r3})]
| None, Some r2, Some r3, Some m1, _, _ ->
[LoadI (m1, tmpreg1);
Load (tmpreg1, tmpreg1);
BRegOp (brop, tmpreg1, {index = r2}, {index = r3})]
| None, None, Some r3, Some m1, Some m2, _ ->
[LoadI (m1, tmpreg1);
Load (tmpreg1, tmpreg1);
LoadI (m2, tmpreg2);
Load (tmpreg2, tmpreg2);
BRegOp (brop, tmpreg1, tmpreg2, {index = r3})]
| None, None, None, Some m1, Some m2, Some m3 ->
[LoadI (m1, tmpreg1);
Load (tmpreg1, tmpreg1);
LoadI (m2, tmpreg2);
Load (tmpreg2, tmpreg2);
BRegOp (brop, tmpreg1, tmpreg2, tmpreg2);
LoadI (m3, tmpreg1);
Store (tmpreg2, tmpreg1)]
| _ -> [BRegOp (brop, {index = r1.index}, {index = r2.index}, {index = r3.index})]
)
| BImmOp (biop, r1, i, r3) -> (
match ( VariableMap.find_opt r1.index remappedregisters,
VariableMap.find_opt r3.index remappedregisters,
VariableMap.find_opt r1.index memorymap,
VariableMap.find_opt r3.index memorymap )
with
| Some r1, Some r3, _, _ ->
[BImmOp (biop, {index = r1}, i, {index = r3})]
| Some r1, None, _, Some m3 ->
[BImmOp (biop, {index = r1}, i, tmpreg2);
LoadI (m3, tmpreg1);
Store (tmpreg2, tmpreg1)]
| None, Some r3, Some m1, _ ->
[LoadI (m1, tmpreg1);
Load (tmpreg1, tmpreg1);
BImmOp (biop, tmpreg1, i, {index = r3})]
| None, None, Some m1, Some m3 ->
[LoadI (m1, tmpreg1);
Load (tmpreg1, tmpreg1);
BImmOp (biop, tmpreg1, i, tmpreg2);
LoadI (m3, tmpreg1);
Store (tmpreg2, tmpreg1)]
| _ -> failwith ("ReduceRegisters: fail to partition a set, some" ^
" registers have no binding.")
)
| URegOp (urop, r1, r3) ->(
match ( VariableMap.find_opt r1.index remappedregisters,
VariableMap.find_opt r3.index remappedregisters,
VariableMap.find_opt r1.index memorymap,
VariableMap.find_opt r3.index memorymap )
with
| Some r1, Some r3, _, _ ->
[URegOp (urop, {index = r1}, {index = r3})]
| Some r1, None, _, Some m3 ->
[URegOp (urop, {index = r1}, tmpreg2);
LoadI (m3, tmpreg1);
Store (tmpreg2, tmpreg1)]
| None, Some r3, Some m1, _ ->
[LoadI (m1, tmpreg1);
Load (tmpreg1, tmpreg1);
URegOp (urop, tmpreg1, {index = r3})]
| None, None, Some m1, Some m3 ->
[LoadI (m1, tmpreg1);
Load (tmpreg1, tmpreg1);
URegOp (urop, tmpreg1, tmpreg2);
LoadI (m3, tmpreg1);
Store (tmpreg2, tmpreg1)]
| _ -> failwith ("ReduceRegisters: fail to partition a set, some" ^
" registers have no binding.")
)
| Load (r1, r3) -> (
match ( VariableMap.find_opt r1.index remappedregisters,
VariableMap.find_opt r3.index remappedregisters,
VariableMap.find_opt r1.index memorymap,
VariableMap.find_opt r3.index memorymap )
with
| Some r1, Some r3, _, _ ->
[Load ({index = r1}, {index = r3})]
| Some r1, None, _, Some m3 ->
[Load ({index = r1}, tmpreg2);
LoadI (m3, tmpreg1);
Store (tmpreg2, tmpreg1)]
| None, Some r3, Some m1, _ ->
[LoadI (m1, tmpreg1);
Load (tmpreg1, tmpreg1);
Load (tmpreg1, {index = r3})]
| None, None, Some m1, Some m3 ->
[LoadI (m1, tmpreg1);
Load (tmpreg1, tmpreg1);
Load (tmpreg1, tmpreg2);
LoadI (m3, tmpreg1);
Store (tmpreg2, tmpreg1)]
| _ -> failwith ("ReduceRegisters: fail to partition a set, some" ^
" registers have no binding.")
)
| LoadI (i, r3) -> (
(* we want to store an integer in memory immediately (strange, but
unless better heuristic to choose the variables to replace we are
stuck) *)
match ( VariableMap.find_opt r3.index remappedregisters,
VariableMap.find_opt r3.index memorymap )
with
| Some r3, _ ->
[LoadI (i, {index = r3})]
| None, Some m3 ->
[LoadI (i, tmpreg2);
LoadI (m3, tmpreg1);
Store (tmpreg2, tmpreg1)]
| _ -> failwith ("ReduceRegisters: fail to partition a set, some" ^
" registers have no binding.")
)
| Store (r1, r3) -> (
(* we want to maybe store an address in memory (very confusing, don't
think can happen) *)
match ( VariableMap.find_opt r1.index remappedregisters,
VariableMap.find_opt r3.index remappedregisters,
VariableMap.find_opt r1.index memorymap,
VariableMap.find_opt r3.index memorymap )
with
| Some r1, Some r3, _, _ ->
[Store ({index = r1}, {index = r3})]
| Some r1, None, _, Some m3 ->
[Store ({index = r1}, tmpreg2);
LoadI (m3, tmpreg1);
Store (tmpreg2, tmpreg1)]
| None, Some r3, Some m1, _ ->
[LoadI (m1, tmpreg1);
Load (tmpreg1, tmpreg1);
Store (tmpreg1, {index = r3})]
| None, None, Some m1, Some m3 ->
[LoadI (m1, tmpreg1);
Load (tmpreg1, tmpreg1);
Store (tmpreg1, tmpreg2);
LoadI (m3, tmpreg1);
Store (tmpreg2, tmpreg1)]
| _ -> failwith ("ReduceRegisters: fail to partition a set, some" ^
" registers have no binding.")
)
in
List.map (fun x ->
Printf.printf "Converting: %a\n" CfgRISC.RISCSimpleStatements.pp x;
let tmp = aux x in
Printf.printf "Into: %a\n\n" CfgRISC.RISCSimpleStatements.pplist tmp;
tmp
) code |> List.concat
in
let aux (cfg: RISCCfg.t) all_variables =
(* we keep the first two variables free for immediate use *)
let most_frequent, least_frequent =
List.sort (fun (_a, fa) (_b, fb) -> Int.compare fb fa) all_variables
|> Utility.take (n-2)
in
let most_frequent = fst (List.split most_frequent) in
let least_frequent = fst (List.split least_frequent) in
(* we map the most frequent to new registers, so that the first two are
always free *)
let most_frequent_mapping = (* +3 because starts at 0, but we want to start
at 1*)
List.mapi (fun n v -> (v, (string_of_int (n+3): Variable.t))) most_frequent
|> VariableMap.of_list
in
(* we map the least to memory *)
let least_frequent_mapping =
List.mapi (fun n v -> (v, (n: int))) least_frequent
|> VariableMap.of_list
in
Printf.printf "Most freq mapping:\n";
List.iter (fun (a, b) -> Printf.printf "%s -> %s\n" a b) (VariableMap.to_list most_frequent_mapping);
Printf.printf "Least freq mapping:\n";
List.iter (fun (a, b) -> Printf.printf "%s -> mem %d\n" a b) (VariableMap.to_list least_frequent_mapping);
(* we need to replace both at the same time, because we might have mapped
some registers to already used registers, so a double pass might not
differentiate the two *)
(* special care must be taken for the in and out registers *)
let newcfg = {
cfg with
content = Cfg.NodeMap.map
(fun x -> replaceregisters most_frequent_mapping least_frequent_mapping ["1"; "2"] x)
cfg.content}
in
match newcfg.inputOutputVar with
| None -> newcfg (* if no input or output variables we ignore *)
| Some (i, o) -> (
match (VariableMap.find_opt i most_frequent_mapping,
VariableMap.find_opt o most_frequent_mapping,
VariableMap.find_opt i least_frequent_mapping,
VariableMap.find_opt o least_frequent_mapping )
with (*we check if in and out are simply remapped or are put in memory*)
| Some i, Some o, _, _ ->
{ newcfg with inputOutputVar = Some (i, o) }
| Some i, None, _, Some mo -> ( (* since the output simbol is in memory
we need to first retrive it and then
put the result in a temporary
register *)
match newcfg.terminal with (* we check for the terminal node, if not
present we are very confused and dont
modify the out variable *)
| None -> { newcfg with inputOutputVar = Some (i, o)}
| Some n -> (
let terminalcontent = (
match Cfg.NodeMap.find_opt n newcfg.content with
| None -> []
| Some x -> x
) @ [LoadI (mo, {index = "2"});
Load ({index = "2"}, {index = "2"})]
in
let content = Cfg.NodeMap.add n terminalcontent newcfg.content in
{ newcfg with
inputOutputVar = Some (i, "2");
content = content
}
)
)
| None, Some o, Some mi, _ -> ( (* the input simbol should be stored in
memory *)
match newcfg.initial with
| None -> { newcfg with inputOutputVar = Some (i, o) }
| Some n -> (
let initialcontent =
[(LoadI (mi, {index = "2"}) : RISCCfg.elt);
Store ({index = "1"}, {index = "2"})] @ (
match Cfg.NodeMap.find_opt n newcfg.content with
| None -> []
| Some x -> x
)
in
let content = Cfg.NodeMap.add n initialcontent newcfg.content in
{ newcfg with
inputOutputVar = Some ("1", o);
content = content
}
)
)
| None, None, Some mi, Some mo -> ( (* both simbols should be in
memory *)
match newcfg.initial, newcfg.terminal with
| None, None -> { newcfg with inputOutputVar = Some (i, o) }
| None, Some n -> (
let terminalcontent = (
match Cfg.NodeMap.find_opt n newcfg.content with
| None -> []
| Some x -> x
) @ [LoadI (mo, {index = "2"});
Load ({index = "2"}, {index = "2"})]
in
let content = Cfg.NodeMap.add n terminalcontent newcfg.content in
{ newcfg with
inputOutputVar = Some (i, "2");
content = content
}
)
| Some n, None -> (
let initialcontent =
[(LoadI (mi, {index = "2"}) : RISCCfg.elt);
Store ({index = "1"}, {index = "2"})] @ (
match Cfg.NodeMap.find_opt n newcfg.content with
| None -> []
| Some x -> x
)
in
let content = Cfg.NodeMap.add n initialcontent newcfg.content in
{ newcfg with
inputOutputVar = Some ("1", o);
content = content
}
)
| Some ni, Some no -> (
let initialcontent =
[(LoadI (mi, {index = "2"}) : RISCCfg.elt);
Store ({index = "1"}, {index = "2"})] @ (
match Cfg.NodeMap.find_opt ni newcfg.content with
| None -> []
| Some x -> x
)
in
let terminalcontent = (
match Cfg.NodeMap.find_opt no newcfg.content with
| None -> []
| Some x -> x
) @ [LoadI (mo, {index = "2"});
Load ({index = "2"}, {index = "2"})]
in
let content = Cfg.NodeMap.add ni initialcontent newcfg.content in
let content = Cfg.NodeMap.add no terminalcontent content in
{ newcfg with
inputOutputVar = Some ("1", "2");
content = content
}
)
)
| _ -> failwith ("ReduceRegisters: fail to partition a set, some" ^
" registers have no binding.")
)
in
( if List.length all_variables < n
then cfg
else aux cfg all_variables )

View File

@ -0,0 +1,3 @@
module RISCCfg = CfgRISC.RISCCfg
val reduceregisters : int -> RISCCfg.t -> RISCCfg.t