From 0bf4c8582574b9c7bea43547d75b87c85fdee1e1 Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Wed, 4 Nov 2020 22:40:19 +0100 Subject: Smart scheduler build problem and flatten solution OK --- aarch64/PostpassSchedulingOracle.ml | 482 ++++++++++++++++++------------------ 1 file changed, 245 insertions(+), 237 deletions(-) (limited to 'aarch64/PostpassSchedulingOracle.ml') diff --git a/aarch64/PostpassSchedulingOracle.ml b/aarch64/PostpassSchedulingOracle.ml index 31864384..eba10496 100644 --- a/aarch64/PostpassSchedulingOracle.ml +++ b/aarch64/PostpassSchedulingOracle.ml @@ -5,6 +5,7 @@ (* Sylvain Boulmé Grenoble-INP, VERIMAG *) (* David Monniaux CNRS, VERIMAG *) (* Cyril Six Kalray *) +(* Léo Gourdin UGA, VERIMAG *) (* *) (* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) (* This file is distributed under the terms of the INRIA *) @@ -14,20 +15,18 @@ (*open Asm*) open Asmblock +open OpWeightsAsm (*open Printf*) (*open Camlcoq*) -(*open InstructionScheduler*) +open InstructionScheduler (*open TargetPrinter.Target*) let debug = false (** - * Extracting infos from Asmvliw instructions + * Extracting infos from Asm instructions *) -(* TODO remove? type immediate = I32 of Integers.Int.int | I64 of Integers.Int64.int | Off of offset*) -(*type location = Reg of preg | Mem*) - type real_instruction = | Add | Adr | Adrp | And | Asr | B | Bic | Bl | Blr | Br | Cbnz | Cbz | Cls | Clz | Cmn | Cmp | Csel | Cset | Eon | Eor | Fabs | Fadd | Fcmp | Fcsel @@ -39,19 +38,17 @@ type real_instruction = | Tbnz | Tbz | Tst | Ubfiz | Ubfx | Ucvtf | Udiv | Umulh | Uxtb | Uxth | Uxtw | Uxtx -(* TODO remove? type ab_inst_rec = {*) - (*inst: real_instruction;*) - (*write_locs : location list;*) - (*read_locs : location list;*) - (*read_at_id : location list; (* Must be contained in read_locs *)*) - (*read_at_e1 : location list; (* idem *)*) - (*imm : immediate option;*) - (*is_control : bool;*) -(*}*) +type ab_inst_rec = { + inst: instruction; + is_control : bool; + usage: int array; (* resources consumed by the instruction *) + latency: int; +} (** Asm constructor to real instructions *) exception OpaqueInstruction +exception NYI (* XXX *) let arith_p_real = function | Padrp(_,_) -> Adrp @@ -96,6 +93,25 @@ let arith_ppp_real = function | Pfmul(_) -> Fmul | Pfsub(_) -> Fsub +let arith_rr0r_real = function + | Padd(_,_) -> Add + | Psub(_,_) -> Sub + | Pand(_,_) -> And + | Pbic(_,_) -> Bic + | Peon(_,_) -> Eon + | Peor(_,_) -> Eor + | Porr(_,_) -> Orr + | Porn(_,_) -> Orn + +let arith_rr0_real = function + | Pandimm(_,_) -> And + | Peorimm(_,_) -> Eor + | Porrimm(_,_) -> Orr + +let arith_arrrr0_real = function + | Pmadd(_) -> Madd + | Pmsub(_) -> Msub + let arith_comparison_p_real = function | Pfcmp0(_) -> Fcmp | Pcmpimm(_,_) -> Cmp @@ -142,7 +158,7 @@ let store_rs_a_real = function | Pstrd -> Str | Pstrd_a -> Str -let load_rs_a_real = function +let load_rd_a_real = function | Pldrw -> Ldr | Pldrw_a -> Ldr | Pldrx -> Ldr @@ -207,31 +223,32 @@ let load_rs_a_real = function (*let arith_rr_rec i rd rs = { inst = arith_rr_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = None; is_control = false;*) (*read_at_id = []; read_at_e1 = [] }*) -(*let arith_r_rec i rd = match i with*) - (*(* For Ploadsymbol, writing the highest integer since we do not know how many bits does a symbol have *)*) - (*| Ploadsymbol (id, ofs) -> { inst = loadsymbol_real; write_locs = [Reg rd]; read_locs = []; imm = Some (I64 Integers.Int64.max_signed);*) - (*is_control = false; read_at_id = []; read_at_e1 = [] }*) +(*let arith_p_rec i rd = { inst = arith_p_real i; is_control = false }*) +(*let arith_pp_rec i rd rs = { inst = arith_pp_real i; is_control = false }*) +(*let arith_ppp_rec i rd r1 r2 = { inst = arith_ppp_real i; is_control = false }*) +(*let arith_rr0r_rec i rd r1 r2 = { inst = arith_rr0r_real i; is_control = false }*) +(*let arith_rr0_rec i rd r1 = { inst = arith_rr0_real i; is_control = false }*) +(*let arith_arrrr0_rec i rd r1 r2 r3 = { inst = arith_arrrr0_real i; is_control = false }*) +(*let arith_comparison_pp_rec i r1 r2 = { inst = arith_comparison_pp_real i; is_control = false }*) +(*let arith_comparison_r0r_rec i r1 r2 = { inst = arith_comparison_r0r_real i; is_control = false }*) +(*let arith_comparison_p_rec i r1 = { inst = arith_comparison_p_real i; is_control = false }*) +(*let load_rec ld rd a = { inst = load_rd_a_real ld; is_control = false }*) +(*let store_rec st r a = { inst = store_rs_a_real st; is_control = false }*) (*let arith_rec i =*) (*match i with*) - (*| PArithRRI32 (i, rd, rs, imm32) -> arith_rri32_rec i (IR rd) (IR rs) (Some (I32 imm32))*) - (*| PArithRRI64 (i, rd, rs, imm64) -> arith_rri64_rec i (IR rd) (IR rs) (Some (I64 imm64))*) - (*| PArithRRR (i, rd, rs1, rs2) -> arith_rrr_rec i (IR rd) (IR rs1) (IR rs2)*) - (*| PArithARR (i, rd, rs) -> arith_arr_rec i (IR rd) (IR rs)*) - (*(* Seems like single constant constructor types are elided *)*) - (*| PArithARRI32 (i, rd, rs, imm32) -> arith_arri32_rec i (IR rd) (IR rs) (Some (I32 imm32))*) - (*| PArithARRI64 (i, rd, rs, imm64) -> arith_arri64_rec i (IR rd) (IR rs) (Some (I64 imm64))*) - (*| PArithARRR (i, rd, rs1, rs2) -> arith_arrr_rec i (IR rd) (IR rs1) (IR rs2)*) - (*| PArithRI32 (rd, imm32) -> { inst = arith_ri32_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I32 imm32)) ; is_control = false;*) - (*read_at_id = []; read_at_e1 = [] }*) - (*| PArithRI64 (rd, imm64) -> { inst = arith_ri64_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I64 imm64)) ; is_control = false;*) - (*read_at_id = []; read_at_e1 = [] }*) - (*| PArithRF32 (rd, f) -> { inst = arith_rf32_real; write_locs = [Reg (IR rd)]; read_locs = [];*) - (*imm = (Some (I32 (Floats.Float32.to_bits f))); is_control = false; read_at_id = []; read_at_e1 = []}*) - (*| PArithRF64 (rd, f) -> { inst = arith_rf64_real; write_locs = [Reg (IR rd)]; read_locs = [];*) - (*imm = (Some (I64 (Floats.Float.to_bits f))); is_control = false; read_at_id = []; read_at_e1 = []}*) - (*| PArithRR (i, rd, rs) -> arith_rr_rec i (IR rd) (IR rs)*) - (*| PArithR (i, rd) -> arith_r_rec i (IR rd)*) + (*| PArithP (i', rd) -> arith_p_rec i' rd*) + (*| PArithPP (i', rd, rs) -> arith_pp_rec i' rd rs*) + (*| PArithPPP (i', rd, r1, r2) -> arith_ppp_rec i' rd r1 r2*) + (*| PArithRR0R (i', rd, r1, r2) -> arith_rr0r_rec i' rd r1 r2*) + (*| PArithRR0 (i', rd, r1) -> arith_rr0_rec i' rd r1*) + (*| PArithARRRR0 (i', rd, r1, r2, r3) -> arith_arrrr0_rec i' rd r1 r2 r3*) + (*| PArithComparisonPP (i', r1, r2) -> arith_comparison_pp_rec i' r1 r2*) + (*| PArithComparisonR0R (i', r1, r2) -> arith_comparison_r0r_rec i' r1 r2*) + (*| PArithComparisonP (i', r1) -> arith_comparison_p_rec i' r1*) + (*| _ -> raise NYI*) + + (*let load_rec i = match i with*) (*| PLoadRRO (trap, i, rs1, rs2, imm) ->*) @@ -271,49 +288,61 @@ let load_rs_a_real = function (*let set_rec rd (rs:gpreg) = { inst = set_real; write_locs = [Reg rd]; read_locs = [Reg (IR rs)]; imm = None; is_control = false;*) (*read_at_id = [Reg (IR rs)]; read_at_e1 = [] }*) -(*let basic_rec i =*) +let basic_rec i = + let opweights = get_opweights () + and i' = PBasic i in + { inst = i'; usage = opweights.resources_of_op i' 0; latency = opweights.latency_of_op i' 0; is_control = false } + (*match i with*) + (*| PArith (i') -> arith_rec i'*) + (*| PLoad (ld, rd, a) -> load_rec ld rd a*) + (*| PStore (st, r, a) -> store_rec st r a*) + (*| Pallocframe (_,_) -> raise OpaqueInstruction*) + (*| Pfreeframe (_,_) -> raise OpaqueInstruction*) + (*| Ploadsymbol (rd, id) -> raise OpaqueInstruction (* XXX how to manage this one? *)*) + (*| Pcvtsw2x (rd, r1) -> { inst = Sxtw; is_control = false }*) + (*| Pcvtuw2x (rd, r1) -> { inst = Uxtw; is_control = false }*) + (*| Pcvtx2w (rd) -> raise OpaqueInstruction (* XXX NYI in TargetPrinter? *)*) + (*(*| Pget (rd, rs) -> get_rec rd rs*)*) + (*(*| Pset (rd, rs) -> set_rec rd rs*)*) + (*(*| Pnop -> { inst = nop_real; write_locs = []; read_locs = []; imm = None ; is_control = false; read_at_id = []; read_at_e1 = []}*)*) + +let builtin_rec ef args res = raise OpaqueInstruction (* XXX not sure *) + +(*let ctl_flow_rec i =*) + (*let opweights = OpWeightsAsm.get_opweights () in*) + (*{ inst = i; usage = opweights.resources_of_op i 0; latency = opweights.latency_of_op i 0; is_control = true }*) (*match i with*) - (*| PArith i -> arith_rec i*) - (*| PLoad i -> load_rec i*) - (*| PStore i -> store_rec i*) - (*| Pallocframe (_, _) -> raise OpaqueInstruction*) - (*| Pfreeframe (_, _) -> raise OpaqueInstruction*) - (*| Pget (rd, rs) -> get_rec rd rs*) - (*| Pset (rd, rs) -> set_rec rd rs*) - (*| Pnop -> { inst = nop_real; write_locs = []; read_locs = []; imm = None ; is_control = false; read_at_id = []; read_at_e1 = []}*) - -(*let expand_rec = function*) - (*| Pbuiltin _ -> raise OpaqueInstruction*) - -(*let ctl_flow_rec = function*) - (*| Pret -> { inst = ret_real; write_locs = []; read_locs = [Reg RA]; imm = None ; is_control = true; read_at_id = [Reg RA]; read_at_e1 = []}*) - (*| Pcall lbl -> { inst = call_real; write_locs = [Reg RA]; read_locs = []; imm = None ; is_control = true; read_at_id = []; read_at_e1 = []}*) - (*| Picall r -> { inst = icall_real; write_locs = [Reg RA]; read_locs = [Reg (IR r)]; imm = None; is_control = true;*) - (*read_at_id = [Reg (IR r)]; read_at_e1 = [] }*) - (*| Pgoto lbl -> { inst = goto_real; write_locs = []; read_locs = []; imm = None ; is_control = true; read_at_id = []; read_at_e1 = []}*) - (*| Pigoto r -> { inst = igoto_real; write_locs = []; read_locs = [Reg (IR r)]; imm = None ; is_control = true;*) - (*read_at_id = [Reg (IR r)]; read_at_e1 = [] }*) - (*| Pj_l lbl -> { inst = goto_real; write_locs = []; read_locs = []; imm = None ; is_control = true; read_at_id = []; read_at_e1 = []}*) - (*| Pcb (bt, rs, lbl) -> { inst = cb_real; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true;*) - (*read_at_id = [Reg (IR rs)]; read_at_e1 = [] }*) - (*| Pcbu (bt, rs, lbl) -> { inst = cbu_real; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true;*) - (*read_at_id = [Reg (IR rs)]; read_at_e1 = [] }*) - (*| Pjumptable (r, _) -> raise OpaqueInstruction (* { inst = "Pjumptable"; write_locs = [Reg (IR GPR62); Reg (IR GPR63)]; read_locs = [Reg (IR r)]; imm = None ; is_control = true} *)*) - -(*let control_rec i =*) + (*| Pb(_) -> { inst = B; is_control = true }*) + (*| Pbc(_,_) -> { inst = B; is_control = true }*) + (*| Pbl(_,_) -> { inst = Bl; is_control = true }*) + (*| Pbs(_,_) -> { inst = B; is_control = true }*) + (*| Pblr(_,_) -> { inst = Blr; is_control = true }*) + (*| Pbr(_,_) -> { inst = Br; is_control = true }*) + (*| Pret(_) -> { inst = Ret; is_control = true }*) + (*| Pcbnz(_,_,_) -> { inst = Cbnz; is_control = true }*) + (*| Pcbz(_,_,_) -> { inst = Cbz; is_control = true }*) + (*| Ptbnz(_,_,_,_) -> { inst = Tbnz; is_control = true }*) + (*| Ptbz(_,_,_,_) -> { inst = Tbz; is_control = true }*) + (*| Pbtbl(_,_) -> raise OpaqueInstruction (* XXX how to manage this one? Maybe Br *)*) + +let control_rec i = + let opweights = get_opweights () + and i' = PControl i in + { inst = i'; usage = opweights.resources_of_op i' 0; latency = opweights.latency_of_op i' 0; is_control = true } (*match i with*) - (*| PExpand i -> expand_rec i*) - (*| PCtlFlow i -> ctl_flow_rec i*) + (*| Pbuiltin (ef, args, res) -> builtin_rec ef args res*) + (*| PCtlFlow (i') -> ctl_flow_rec i'*) -(*let rec basic_recs body = match body with*) - (*| [] -> []*) - (*| bi :: body -> (basic_rec bi) :: (basic_recs body)*) +(* TODO Continue here by calling constructors *) +let rec basic_recs body = match body with + | [] -> [] + | bi :: body -> (basic_rec bi) :: (basic_recs body) -(*let exit_rec exit = match exit with*) - (*| None -> []*) - (*| Some ex -> [control_rec ex]*) +let exit_rec exit = match exit with + | None -> [] + | Some ex -> [control_rec ex] -(*let instruction_recs bb = (basic_recs bb.body) @ (exit_rec bb.exit)*) +let instruction_recs bb = (basic_recs bb.body) @ (exit_rec bb.exit) (** * Providing informations relative to the real instructions @@ -321,10 +350,6 @@ let load_rs_a_real = function (** Abstraction providing all the necessary informations for solving the scheduling problem *) (*type inst_info = {*) - (*write_locs : location list;*) - (*read_locs : location list;*) - (*reads_at_id : bool;*) - (*reads_at_e1 : bool;*) (*is_control : bool;*) (*usage: int array; (* resources consumed by the instruction *)*) (*latency: int;*) @@ -614,19 +639,16 @@ let load_rs_a_real = function (*| [] -> true*) (*| b::lb -> if (List.mem b la) then false else empty_inter la lb*) -(*let rec_to_info r : inst_info =*) - (*let usage = rec_to_usage r*) - (*and latency = real_inst_to_latency r.inst*) - (*and reads_at_id = not (empty_inter r.read_locs r.read_at_id)*) - (*and reads_at_e1 = not (empty_inter r.read_locs r.read_at_e1)*) - (*in { write_locs = r.write_locs; read_locs = r.read_locs; usage=usage; latency=latency; is_control=r.is_control;*) - (*reads_at_id = reads_at_id; reads_at_e1 = reads_at_e1 }*) +(*let rec_to_info (r : ab_inst_rec) : inst_info =*) + (*let opweights = OpWeightsAsm.get_opweights ()*) + (*in { usage=opweights.resources_of_op r.inst; latency=opweights.latency_of_op r.inst; is_control=r.is_control }*) (*let instruction_infos bb = List.map rec_to_info (instruction_recs bb)*) +let instruction_infos bb = instruction_recs bb -(*let instruction_usages bb =*) - (*let usages = List.map (fun info -> info.usage) (instruction_infos bb)*) - (*in Array.of_list usages*) +let instruction_usages bb = + let usages = List.map (fun info -> info.usage) (instruction_infos bb) + in Array.of_list usages (** * Latency constraints building @@ -672,109 +694,106 @@ let load_rs_a_real = function (*in let lat = ifrom.latency + dlat*) (*in assert (lat >= 0); if (lat == 0) then 1 else lat*) -(*let latency_constraints bb =*) - (*let written = LocHash.create 70*) - (*and read = LocHash.create 70*) - (*and count = ref 0*) - (*and constraints = ref []*) - (*and instr_infos = instruction_infos bb*) - (*in let step (i: inst_info) =*) - (*let raw = get_accesses written i.read_locs*) - (*and waw = get_accesses written i.write_locs*) - (*and war = get_accesses read i.write_locs*) - (*in begin*) - (*List.iter (fun i -> constraints := {instr_from = i; instr_to = !count;*) - (*latency = compute_latency (List.nth instr_infos i) (List.nth instr_infos !count)} :: !constraints) raw;*) - (*List.iter (fun i -> constraints := {instr_from = i; instr_to = !count;*) - (*latency = compute_latency (List.nth instr_infos i) (List.nth instr_infos !count)} :: !constraints) waw;*) - (*List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; latency = 0} :: !constraints) war;*) - (*if i.is_control then List.iter (fun n -> constraints := {instr_from = n; instr_to = !count; latency = 0} :: !constraints) (intlist !count);*) - (*(* Updating "read" and "written" hashmaps *)*) - (*List.iter (fun loc ->*) - (*begin *) - (*LocHash.replace written loc [!count];*) - (*LocHash.replace read loc []; (* Clearing all the entries of "read" hashmap when a register is written *)*) - (*end) i.write_locs;*) - (*List.iter (fun loc -> LocHash.replace read loc ((!count) :: (find_in_hash read loc))) i.read_locs;*) - (*count := !count + 1*) - (*end*) - (*in (List.iter step instr_infos; !constraints)*) +let latency_constraints bb = + let count = ref 0 + and constraints = ref [] + and instr_infos = instruction_infos bb + in let step (i: ab_inst_rec) = + begin + constraints := {instr_from = !count; instr_to = !count+1; latency = i.latency} :: !constraints; + count := !count + 1 + end + in (List.iter step instr_infos; !constraints) (** * Using the InstructionScheduler *) -(* TODO RESUME HERE -(*let build_problem bb = *) - (*{ max_latency = -1; resource_bounds = resource_bounds;*) - (*instruction_usages = instruction_usages bb; latency_constraints = latency_constraints bb }*) - -let rec find_min_opt (l: int option list) = - match l with - | [] -> None - | e :: l -> - begin match find_min_opt l with - | None -> e - | Some m -> - begin match e with - | None -> Some m - | Some n -> if n < m then Some n else Some m - end - end +(* TODO RESUME HERE *) -let rec filter_indexes predicate = function - | [] -> [] - | e :: l -> if (predicate e) then e :: (filter_indexes predicate l) else filter_indexes predicate l +let opweights = OpWeightsAsm.get_opweights () + +let build_problem bb = +{ max_latency = -1; resource_bounds = opweights.pipelined_resource_bounds; + instruction_usages = instruction_usages bb; latency_constraints = latency_constraints bb } + +(*let rec find_min_opt (l: int option list) =*) + (*match l with*) + (*| [] -> None *) + (*| e :: l ->*) + (*begin match find_min_opt l with*) + (*| None -> e*) + (*| Some m ->*) + (*begin match e with*) + (*| None -> Some m*) + (*| Some n -> if n < m then Some n else Some m*) + (*end*) + (*end*) + +(*let rec filter_indexes predicate = function*) + (*| [] -> []*) + (*| e :: l -> if (predicate e) then e :: (filter_indexes predicate l) else filter_indexes predicate l*) let get_from_indexes indexes l = List.map (List.nth l) indexes -let is_basic = function PBasic _ -> true | _ -> false -let is_control = function PCtlFlow _ -> true | PExpand _ -> true | _ -> false +(*let is_basic = function PBasic _ -> true | _ -> false*) +let is_control = function PControl _ -> true | _ -> false let to_basic = function PBasic i -> i | _ -> failwith "to_basic: control instruction found" let to_control = function PControl i -> i | _ -> failwith "to_control: basic instruction found" -let bundlize li hd = +let rec body_to_instrs bdy = + match bdy with + | [] -> [] + | i :: l' -> PBasic i :: body_to_instrs l' + +let rec instrs_to_bdy instrs = + match instrs with + | [] -> [] + | PBasic i :: l' -> i :: instrs_to_bdy l' + | PControl _ :: l' -> failwith "instrs_to_bdy: control instruction found" + +let repack li hd = let last = List.nth li (List.length li - 1) in if is_control last then let cut_li = Array.to_list @@ Array.sub (Array.of_list li) 0 (List.length li - 1) - in { header = hd; body = cut_li; exit = Some (to_control last) } + in { header = hd; body = (instrs_to_bdy cut_li); exit = Some (to_control last) } else - { header = hd; body = li; exit = None } + { header = hd; body = (instrs_to_bdy li); exit = None } -let extract_some o = match o with Some e -> e | None -> failwith "extract_some: None found" +(*let extract_some o = match o with Some e -> e | None -> failwith "extract_some: None found"*) -let rec find_min = function - | [] -> None - | e :: l -> - match find_min l with - | None -> Some e - | Some m -> if (e < m) then Some e else Some m +(*let rec find_min = function*) + (*| [] -> None*) + (*| e :: l ->*) + (*match find_min l with*) + (*| None -> Some e*) + (*| Some m -> if (e < m) then Some e else Some m*) -let rec remove_all m = function - | [] -> [] - | e :: l -> if m=e then remove_all m l - else e :: (remove_all m l) +(*let rec remove_all m = function*) + (*| [] -> []*) + (*| e :: l -> if m=e then remove_all m l*) + (*else e :: (remove_all m l)*) -let rec find_mins l = match find_min l with - | None -> [] - | Some m -> m :: find_mins (remove_all m l) +(*let rec find_mins l = match find_min l with*) + (*| None -> []*) + (*| Some m -> m :: find_mins (remove_all m l)*) -let find_all_indices m l = - let rec find m off = function - | [] -> [] - | e :: l -> if m=e then off :: find m (off+1) l - else find m (off+1) l - in find m 0 l +(*let find_all_indices m l = *) + (*let rec find m off = function*) + (*| [] -> []*) + (*| e :: l -> if m=e then off :: find m (off+1) l*) + (*else find m (off+1) l*) + (*in find m 0 l*) module TimeHash = Hashtbl -(* Hash table : time => list of instruction ids *) +(*Hash table : time => list of instruction ids *) -let hashtbl2list h maxint = +let hashtbl2flatarray h maxint = let rec f i = match TimeHash.find_opt h i with | None -> if (i > maxint) then [] else (f (i+1)) - | Some bund -> bund :: (f (i+1)) - in f 0 + | Some bund -> bund @ (f (i+1)) + in f 0 let find_max l = let rec f = function @@ -786,7 +805,7 @@ let find_max l = | None -> raise Not_found | Some m -> m -(* [0, 2, 3, 1, 1, 2, 4, 5] -> [[0], [3, 4], [1, 5], [2], [6], [7]] *) +(*(* [0, 2, 3, 1, 1, 2, 4, 5] -> [[0], [3, 4], [1, 5], [2], [6], [7]] *)*) let minpack_list (l: int list) = let timehash = TimeHash.create (List.length l) in let rec f i = function @@ -799,58 +818,52 @@ let minpack_list (l: int list) = end in begin f 0 l; - hashtbl2list timehash (find_max l) + hashtbl2flatarray timehash (find_max l) end;; -(* let minpack_list l = - let mins = find_mins l - in List.map (fun m -> find_all_indices m l) mins - *) +(*let minpack_list l =*) + (*let mins = find_mins l*) + (*in List.map (fun m -> find_all_indices m l) mins*) -let bb_to_instrs bb = bb.body @ (match bb.exit with None -> [] | Some e -> [Some e]) +let bb_to_instrs bb = body_to_instrs bb.body @ (match bb.exit with None -> [] | Some e -> [PControl e]) -let bundlize_solution bb sol = +let build_solution bb sol = + (* Remove last element - the total *) let tmp = (Array.to_list @@ Array.sub sol 0 (Array.length sol - 1)) - in let packs = minpack_list tmp + in let pack = minpack_list tmp and instrs = bb_to_instrs bb - in let rec bund hd = function - | [] -> [] - | pack :: packs -> bundlize (get_from_indexes pack instrs) hd :: (bund [] packs) - in bund bb.header packs -*) + in repack (get_from_indexes pack instrs) bb.header + (*in let rec bund hd = function*) + (*| [] -> []*) + (*| pack :: packs -> repack (get_from_indexes pack instrs) hd :: (bund [] packs)*) + (*in bund bb.header packs*) + (*let print_inst oc = function*) - (*| Asm.Pallocframe(sz, ofs) -> fprintf oc " Pallocframe\n"*) - (*| Asm.Pfreeframe(sz, ofs) -> fprintf oc " Pfreeframe\n"*) - (*| Asm.Pbuiltin(ef, args, res) -> fprintf oc " Pbuiltin\n"*) - (*| i -> print_instruction oc i*) + (*| i -> TargetPrinter.Target.print_instruction oc i*) + (*(*| Asm.Pallocframe(sz, ofs) -> Printf.fprintf oc " Pallocframe\n"*)*) + (*(*| Asm.Pfreeframe(sz, ofs) -> Printf.fprintf oc " Pfreeframe\n"*)*) + (*(*| Asm.Pbuiltin(ef, args, res) -> Printf.fprintf oc " Pbuiltin\n"*)*) + (*(*| i -> TargetPrinter.Target.print_instruction oc i*)*) (*let print_bb oc bb =*) - (*let asm_instructions = Asm.unfold_bblock bb*) - (*in List.iter (print_inst oc) asm_instructions*) - -(*let print_schedule sched =*) - (*print_string "[ ";*) - (*Array.iter (fun x -> Printf.printf "%d; " x) sched;*) - (*print_endline "]";;*) - -(*let do_schedule bb =*) - (*let problem = build_problem bb in*) - (*(if debug then print_problem stdout problem);*) - (*let solution = scheduler_by_name (!Clflags.option_fpostpass_sched) problem*) - (*in match solution with*) - (*| None -> failwith "Could not find a valid schedule"*) - (*| Some sol ->*) - (*((if debug then print_schedule sol);*) - (*let bundles = bundlize_solution bb sol in *) - (*(if debug then*) - (*begin*) - (*Printf.eprintf "Scheduling the following group of instructions:\n";*) - (*print_bb stderr bb;*) - (*Printf.eprintf "Gave the following solution:\n";*) - (*List.iter (print_bb stderr) bundles;*) - (*Printf.eprintf "--------------------------------\n"*) - (*end;*) - (*bundles))*) + (*match Asmgen.Asmblock_TRANSF.unfold_bblock bb with*) + (*| Errors.OK instructions -> List.iter (print_inst oc) instructions*) + (*| Errors.Error _ -> Printf.eprintf "Error in print_bb"*) + +let print_schedule sched = + print_string "[ "; + Array.iter (fun x -> Printf.printf "%d; " x) sched; + print_endline "]";; + +let do_schedule bb = + let problem = build_problem bb in + (if debug then print_problem stdout problem); + let solution = scheduler_by_name (!Clflags.option_fpostpass_sched) problem + in match solution with + | None -> failwith "Could not find a valid schedule" + | Some sol -> + ((if debug then print_schedule sol); + build_solution bb sol) (** * Dumb schedule if the above doesn't work @@ -868,32 +881,29 @@ let is_opaque = function | _ -> false (* Returns : (accumulated instructions, remaining instructions, opaque instruction if found) *) -let rec biggest_wo_opaque = function +(*let rec biggest_wo_opaque = function | [] -> ([], [], None) | i :: li -> if is_opaque i then ([], li, Some i) else let big, rem, opaque = biggest_wo_opaque li in (i :: big, rem, opaque);; -(*let separate_opaque bb =*) - (*let instrs = bb_to_instrs bb*) - (*in let rec f hd li =*) - (*match li with*) - (*| [] -> []*) - (*| li -> let big, rem, opaque = biggest_wo_opaque li in*) - (*match opaque with*) - (*| Some i ->*) - (*(match big with*) - (*| [] -> (bundlize [i] hd) :: (f [] rem)*) - (*| big -> (bundlize big hd) :: (bundlize [i] []) :: (f [] rem)*) - (**) - (*| None -> (bundlize big hd) :: (f [] rem)*) - (*in f bb.header instrs*) - -(*let smart_schedule bb =*) - (*let lbb = separate_opaque bb*) - (*in let rec f = function*) - (*| [] -> []*) - (*| bb :: lbb -> *) - (*let bundles =*) +let separate_opaque bb = + let instrs = bb_to_instrs bb + in let rec f hd li = + match li with + | [] -> [] + | li -> let big, rem, opaque = biggest_wo_opaque li in + match opaque with + | Some i -> + (match big with + | [] -> (bundlize [i] hd) :: (f [] rem) + | big -> (bundlize big hd) :: (bundlize [i] []) :: (f [] rem) + ) + | None -> (bundlize big hd) :: (f [] rem) + in f bb.header instrs*) + +let smart_schedule bb = + (*let lbb = separate_opaque bb in*) + let bb' = do_schedule bb in (bb'.body, bb'.exit) (*try do_schedule bb*) (*with OpaqueInstruction -> dumb_schedule bb*) (*| e -> *) @@ -909,14 +919,12 @@ let rec biggest_wo_opaque = function (*dumb_schedule bb*) (**)*) (*end*) - (*in bundles @ (f lbb)*) - (*in f lbb*) let bblock_schedule bb = - (*if debug then (eprintf "###############################\n"; Printf.eprintf "SCHEDULING\n"; print_bb stderr bb);*) - (* print_problem (build_problem bb); *) - (*TODO if Compopts.optim_postpass () then smart_schedule bb else dumb_schedule bb*) - dumb_schedule bb + if debug then (Printf.eprintf "###############################\n"; Printf.eprintf "SCHEDULING\n"); + print_problem stdout (build_problem bb); + (*if Compopts.optim_postpass () then smart_schedule bb else dumb_schedule bb*) + smart_schedule bb (** Called schedule function from Coq *) -- cgit