From 037c716b6514cc717b7208457fb72085e4c278ab Mon Sep 17 00:00:00 2001 From: Quentin Carbonneaux Date: Fri, 10 Jul 2015 03:16:11 -0400 Subject: move ml prototype in a subdir --- .gitignore | 7 - Makefile | 13 - TODO | 54 ----- bak.ml | 132 ---------- elf.ml | 200 ---------------- heap.ml | 60 ----- lo.ml | 478 ------------------------------------- lo2.ml | 713 ------------------------------------------------------- proto/.gitignore | 7 + proto/Makefile | 13 + proto/TODO | 54 +++++ proto/bak.ml | 132 ++++++++++ proto/elf.ml | 200 ++++++++++++++++ proto/heap.ml | 60 +++++ proto/lo.ml | 478 +++++++++++++++++++++++++++++++++++++ proto/lo2.ml | 713 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ proto/tmain.c | 24 ++ tmain.c | 24 -- 18 files changed, 1681 insertions(+), 1681 deletions(-) delete mode 100644 .gitignore delete mode 100644 Makefile delete mode 100644 TODO delete mode 100644 bak.ml delete mode 100644 elf.ml delete mode 100644 heap.ml delete mode 100644 lo.ml delete mode 100644 lo2.ml create mode 100644 proto/.gitignore create mode 100644 proto/Makefile create mode 100644 proto/TODO create mode 100644 proto/bak.ml create mode 100644 proto/elf.ml create mode 100644 proto/heap.ml create mode 100644 proto/lo.ml create mode 100644 proto/lo2.ml create mode 100644 proto/tmain.c delete mode 100644 tmain.c diff --git a/.gitignore b/.gitignore deleted file mode 100644 index ff9fbe2..0000000 --- a/.gitignore +++ /dev/null @@ -1,7 +0,0 @@ -t -bak -.comfile -*.o -*.cm[io] -lisc/lo -t.out diff --git a/Makefile b/Makefile deleted file mode 100644 index c6ebd16..0000000 --- a/Makefile +++ /dev/null @@ -1,13 +0,0 @@ -.PHONY: all test clean - -all: bak - -bak: elf.ml lo2.ml - ocamlc -g -o bak elf.ml lo2.ml - -test: bak - @./bak test - @cc -O2 -o t.out tmain.c t.o && ./t.out - -clean: - rm -f bak *.out *.o *.cm[io] diff --git a/TODO b/TODO deleted file mode 100644 index e144c66..0000000 --- a/TODO +++ /dev/null @@ -1,54 +0,0 @@ -Features -- Operand classes for instructions -- Hints in register allocation -- Fixed register instructions (div, mul) - Is this part of "operand classes"? - -Instructions -- ADD SUB SDIV UDIV SREM UREM MUL LSL LSR ASL ASR -- SEXT ZEXT (we need 8, 16, 32, 64 bits) -- CMP ... -- ALLOC STORE LOAD (we need 8, 16, 32, 64 bits) -(- PTR) -- CALL BRZ JMP RET - -Machine -- SREG GREG -- Register use/defs for all instructions. - -Types -- Integer (32 & 64 bits) -(- Structure "{a,b,c}") -(- Pointer (to type "t")) - -Questions -- Q: Should we allow constant operands? - A: - It looks like `Con instructions are a bad idea because - they introduce spurious live ranges. - This was not a huge problem, modifications s in loc and - getreg only fixed this. Still, it makes use larger bit - vectors during the liveness analysis. -- Q: How to represent the IR? - A: - So far, a graph of basic blocks composed of quadruples - seems to be the most convenient. -- Q: Do we need types? - -Problems -- x = y op z [fixed using freeze] - if x is spilled, y can be moved to a spill location - to free one register for x, this is kind of stupid. - We can probably fix this by having a better heuristic - for spilling decisions. -- [tentative fix: 4fc98da] - Phi defined variables with spill location do not work. -- At the end of a block we call loc on all live variables, - if there are not enough registers, some variables get - assigned spill locations. We need to be able to spill - variables that are already in register. - NOTE: Following Braun & Hack we could do one pass - first that determines what variables are in register - at the end of loops. This sounds good because - back-edges are actually easier to detect than loop - headers! diff --git a/bak.ml b/bak.ml deleted file mode 100644 index cd1aff2..0000000 --- a/bak.ml +++ /dev/null @@ -1,132 +0,0 @@ -type id = int -type ty = - | TInt of bool * int - | TArr of int * ty - | TPtr of ty - | TVoid -type con = CInt of int -type cnd = Ge | Le | Gt | Lt | Ne | Eq -type ins = - | IAlloc of ty - | IMem of id - | ISto of id * id - | IAdd of id * id - | ISub of id * id - | ICon of ty * con - | IBr of id * cnd * id * id - | IJmp of id - | IPhi of ty * id * id - -let isint = function TInt _ -> true | _ -> false -let isbranch = function IBr _ | IJmp _ -> true | _ -> false - -exception Type of string -let tychk blk = - let typs = Array.make (Array.length blk) TVoid in - let blks = ref [] in - let jmp src dst = - let rec f = function - | (blk, srcs) :: tl when blk = dst -> - (blk, src :: srcs) :: tl - | b :: tl when fst b < dst -> b :: f tl - | l -> - let srcs = - if dst = 0 then [src] else - if isbranch blk.(dst-1) - then [src] else [dst-1; src] in - (dst, srcs) :: l in - blks := f !blks in - let f i = (* do easy type checks *) - let chn n = - if n >= i || n < 0 then - raise (Type "broken data dependency") in - function - | IPhi (ty, _, _) -> - if ty = TVoid then - raise (Type "invalid void phi"); - typs.(i) <- ty - | ICon (ty, _) -> typs.(i) <- ty - | IAlloc ty -> - if ty = TVoid then - raise (Type "invalid void alloc"); - typs.(i) <- TPtr ty - | IMem n -> - chn n; - (match typs.(n) with - | TPtr ty -> typs.(i) <- ty - | _ -> raise (Type "invalid dereference") - ) - | ISto (a, b) -> - chn a; chn b; - if typs.(a) <> TPtr typs.(b) then - raise (Type "invalid store") - | IAdd (a, b) -> - chn a; chn b; - if not (isint typs.(b)) then - raise (Type "second add operand not integral"); - (match typs.(a) with - | (TPtr _) as t -> typs.(i) <- t - | (TInt _) as t -> - if t <> typs.(b) then - raise (Type "invalid heterogeneous addition"); - typs.(i) <- t - | _ -> raise (Type "invalid type for addition") - ) - | ISub (a, b) -> - chn a; chn b; - (match typs.(a), typs.(b) with - | (TPtr _ as ta), (TPtr _ as tb) -> - if ta <> tb then - raise (Type "substracted pointers have different types"); - typs.(i) <- TInt (true, 64) - | (TInt _ as ta), (TInt _ as tb) -> - if ta <> tb then - raise (Type "invalid heterogeneous substraction"); - typs.(i) <- ta - | _ -> raise (Type "invalid type for substraction") - ) - | IBr (_, _, _, dst) -> jmp i dst; jmp i (i+1) - | IJmp dst -> jmp i dst in - Array.iteri f blk; - let f = function (* check types at phi nodes *) - | IPhi (_, a, b) -> - if typs.(a) <> typs.(b) then - raise (Type "ill-typed phi node") - | _ -> () in - Array.iter f blk; - let bbase i = - let rec f base = function - | [] -> base - | (b, _) :: _ when b > i -> base - | (b, _) :: tl -> f b tl in - f 0 !blks in - let f i = function (* check validity of ssa *) - | IPhi (_, a, b) -> - let callers = - List.map bbase (List.assoc (bbase i) !blks) in - let ba = bbase a and bb = bbase b in - if ba = bb - || not (List.mem ba callers) - || not (List.mem bb callers) - then - raise (Type "invalid phi node"); - | IAdd (a, b) | ISub (a, b) | ISto (a, b) | IBr (a, _, b, _) -> - let bi = bbase i in - if bbase a <> bi || bbase b <> bi then - raise (Type "operands of non-phy not in current block") - | IMem a -> - if bbase a <> bbase i then - raise (Type "operands of non-phy not in current block") - | IJmp _ | ICon _ | IAlloc _ -> () in - Array.iteri f blk - - (* tests *) -let _ = - let int = TInt (true, 32) in - let p0 = [| - (* 0 *) ICon (int, CInt 1); - (* 1 *) ICon (int, CInt 42); - (* 2 *) IPhi (int, 0, 2); - (* 3 *) IAdd (1, 2); - (* 4 *) IJmp 1 - |] in tychk p0 diff --git a/elf.ml b/elf.ml deleted file mode 100644 index d83f4fd..0000000 --- a/elf.ml +++ /dev/null @@ -1,200 +0,0 @@ -(* This is a module to spit simple ELF - object files that can afterwards be - linked to build an application. -*) - -let hash s = - (* The ELF hash function. *) - let open Int64 in (* I doubt this is necessary... *) - let rec f p h = - if p = String.length s then to_int h else - let h = shift_left h 4 in - let h = add h (of_int (int_of_char s.[p])) in - let g = logand h (of_int 0xf0000000) in - let h = logxor h (shift_right g 24) in - f (p+1) (logand h (of_int 0x0fffffff)) in - f 0 (of_int 0) - -let le n x = - (* Make a string of bytes in little endian convention. *) - let b = Bytes.create n in - let rec f i x = - if i = n then () else - let d = char_of_int (x land 0xff) in - Bytes.set b i d; - f (i+1) (x lsr 8) in - f 0 x; Bytes.to_string b - -let stt_NOTYPE = 0 -let stt_OBJECT = 1 -let stt_FUNC = 2 - -let stb_LOCAL = 0 -let stb_GLOBAL = 16 -let stb_WEAK = 32 - -let sht_NULL = le 4 0 -let sht_PROGBITS = le 4 1 -let sht_SYMTAB = le 4 2 -let sht_STRTAB = le 4 3 -let sht_RELA = le 4 4 -let sht_NOTE = le 4 7 -let sht_NOBITS = le 4 8 - -let shf_WRITE = 1 -let shf_ALLOC = 2 -let shf_EXECINSTR = 4 - -let barebones_elf oc fn text = - let header = String.concat "" - [ "\x7fELF" (* e_ident, magic *) - ; "\x02" (* e_ident, ELFCLASS64 *) - ; "\x01" (* e_ident, ELFDATA2LSB *) - ; "\x01" (* e_indent, EV_CURRENT *) - ; "\x00" (* e_ident, ELFOSABI_SYSV *) - ; "\x00" (* e_ident, ABI version *) - ; "\x00\x00\x00\x00\x00\x00\x00" (* e_ident, padding *) - ; "\x01\x00" (* e_type, ET_REL *) - ; "\x3e\x00" (* e_machine, EM_X86_64 *) - ; "\x01\x00\x00\x00" (* e_version, EV_CURRENT *) - ; "\x00\x00\x00\x00\x00\x00\x00\x00" (* e_entry, unused *) - ; "\x00\x00\x00\x00\x00\x00\x00\x00" (* e_phoff, unused *) - ; "\x40\x00\x00\x00\x00\x00\x00\x00" (* e_shoff, 64 *) - ; "\x00\x00\x00\x00" (* e_flags, 0 *) - ; "\x40\x00" (* e_hsize, 64 *) - ; "\x00\x00" (* e_phentsize, 0 *) - ; "\x00\x00" (* e_phnum, 0 *) - ; "\x40\x00" (* e_shentsize, 64 *) - ; "\x07\x00" (* e_shnum, 7 *) - ; "\x06\x00" (* e_shstrndx, 6 *) - ] in - - (* We will use the following section organization. - 1- .text PROGBITS - 2- .data PROGBITS - 3- .bss NOBITS - 4- .rela RELA - 5- .symtab SYMTAB - 6- .strtab STRTAB - *) - - let adds s x = (String.length s, s ^ x ^ "\x00") in - (* section names *) - let textstr, strtab = adds "\x00" ".text" in - let datastr, strtab = adds strtab ".data" in - let bssstr , strtab = adds strtab ".bss" in - let relastr, strtab = adds strtab ".rela" in - let symtstr, strtab = adds strtab ".symt" in - let strtstr, strtab = adds strtab ".strt" in - (* function names *) - let fnstr, strtab = adds strtab fn in - - let symtab = String.concat "" - [ le 0x18 0 (* first symbol is reserved *) - ; le 4 fnstr (* st_name *) - ; le 1 (stt_FUNC lor stb_GLOBAL) (* st_info *) - ; "\x00" (* st_other *) - ; le 2 1 (* st_shndx, .text *) - ; le 8 0 (* st_value, offset in .text section *) - ; le 8 (String.length text) (* st_size *) - ] in - - let textoff = 64 + 7 * 64 in - let txtlen, txtpad = - let l = String.length text in - let p = (l + 7) land 7 in - (l, p) in - let dataoff = textoff + txtlen + txtpad in - let bssoff = dataoff + 0 in - let relaoff = bssoff + 0 in - let symtoff = relaoff + 0 in - let strtoff = symtoff + String.length symtab in - - let sh = String.concat "" - [ le 64 0 (* first section header is reserved *) - (* .text *) - ; le 4 textstr (* sh_name *) - ; sht_PROGBITS (* sh_type *) - ; le 8 (shf_ALLOC lor shf_EXECINSTR) (* sh_flags *) - ; le 8 0 (* sh_addr *) - ; le 8 textoff (* sh_offset *) - ; le 8 txtlen (* sh_size *) - ; le 4 0 (* sh_link *) - ; le 4 0 (* sh_info *) - ; le 8 1 (* sh_addralign *) - ; le 8 0 (* sh_entsize *) - (* .data *) - ; le 4 datastr (* sh_name *) - ; sht_PROGBITS (* sh_type *) - ; le 8 (shf_ALLOC lor shf_WRITE) (* sh_flags *) - ; le 8 0 (* sh_addr *) - ; le 8 dataoff (* sh_offset *) - ; le 8 0 (* sh_size *) - ; le 4 0 (* sh_link *) - ; le 4 0 (* sh_info *) - ; le 8 1 (* sh_addralign *) - ; le 8 0 (* sh_entsize *) - (* .bss *) - ; le 4 bssstr (* sh_name *) - ; sht_NOBITS (* sh_type *) - ; le 8 (shf_ALLOC lor shf_WRITE) (* sh_flags *) - ; le 8 0 (* sh_addr *) - ; le 8 bssoff (* sh_offset *) - ; le 8 0 (* sh_size *) - ; le 4 0 (* sh_link *) - ; le 4 0 (* sh_info *) - ; le 8 1 (* sh_addralign *) - ; le 8 0 (* sh_entsize *) - (* .rela *) - ; le 4 relastr (* sh_name *) - ; sht_RELA (* sh_type *) - ; le 8 0 (* sh_flags *) - ; le 8 0 (* sh_addr *) - ; le 8 relaoff (* sh_offset *) - ; le 8 0 (* sh_size *) - ; le 4 5 (* sh_link, symtab index *) - ; le 4 1 (* sh_info, text section *) - ; le 8 1 (* sh_addralign *) - ; le 8 0x18 (* sh_entsize *) - (* .symtab *) - ; le 4 symtstr (* sh_name *) - ; sht_SYMTAB (* sh_type *) - ; le 8 0 (* sh_flags *) - ; le 8 0 (* sh_addr *) - ; le 8 symtoff (* sh_offset *) - ; le 8 (String.length symtab) (* sh_size *) - ; le 4 6 (* sh_link, strtab index *) - ; le 4 1 (* sh_info, first non-local symbol *) - ; le 8 1 (* sh_addralign *) - ; le 8 0x18 (* sh_entsize *) - (* .strtab *) - ; le 4 strtstr (* sh_name *) - ; sht_STRTAB (* sh_type *) - ; le 8 0 (* sh_flags *) - ; le 8 0 (* sh_addr *) - ; le 8 strtoff (* sh_offset *) - ; le 8 (String.length strtab) (* sh_size *) - ; le 4 0 (* sh_link *) - ; le 4 0 (* sh_info *) - ; le 8 1 (* sh_addralign *) - ; le 8 0x18 (* sh_entsize *) - ] in - - List.iter (output_string oc) - [ header - ; sh - ; text; String.make txtpad '\x90' - ; symtab - ; strtab - ] - - -(* -let _ = - let oc = open_out "test.o" in - let text = String.concat "" - [ "\xb8\x2a\x00\x00\x00" (* mov 42, %eax *) - ; "\xc3" (* retq *) - ] in - barebones_elf oc "main" text -*) diff --git a/heap.ml b/heap.ml deleted file mode 100644 index 79081b9..0000000 --- a/heap.ml +++ /dev/null @@ -1,60 +0,0 @@ -(* Generic binary heaps. *) -module Heap: sig - type 'a t - val create: ('a -> 'a -> int) -> 'a t - val add: 'a t -> 'a -> unit - val popd: 'a t -> unit - val pop: 'a t -> 'a option - val top: 'a t -> 'a option -end = struct - type 'a t = - { mutable arr: 'a array - ; mutable len: int - ; cmp: 'a -> 'a -> int - } - - let mkarray n = Array.make n (Obj.magic 0) - let create cmp = {arr = mkarray 2; len = 0; cmp } - let top {arr; len; _} = - if len = 0 then None else Some arr.(1) - let swap arr i j = - let tmp = arr.(i) in - arr.(i) <- arr.(j); - arr.(j) <- tmp - - let rec bblup cmp arr i = - let prnt = i/2 in - if prnt = 0 then () else - if cmp arr.(prnt) arr.(i) < 0 then () else - (swap arr prnt i; bblup cmp arr prnt) - let add ({arr; len; cmp} as hp) x = - let arr = - let alen = Array.length arr in - if alen > len+1 then arr else - let arr' = mkarray (alen * 2) in - Array.blit arr 0 arr' 0 alen; - hp.arr <- arr'; - arr' in - hp.len <- len + 1; - arr.(hp.len) <- x; - bblup cmp arr hp.len - - let rec bbldn cmp arr i len = - let ch0 = 2*i in - let ch1 = ch0 + 1 in - if ch0 > len then () else - let mn = - if ch1 > len then ch0 else - if cmp arr.(ch0) arr.(ch1) < 0 - then ch0 else ch1 in - if cmp arr.(i) arr.(mn) <= 0 then () else - (swap arr i mn; bbldn cmp arr mn len) - let popd ({arr; len; cmp} as hp) = - if len = 0 then () else - arr.(1) <- arr.(len); - hp.len <- len - 1; - bbldn cmp arr 1 len - let pop hp = - let r = top hp in - popd hp; r -end diff --git a/lo.ml b/lo.ml deleted file mode 100644 index be2323d..0000000 --- a/lo.ml +++ /dev/null @@ -1,478 +0,0 @@ -module ISet = Set.Make - (struct - type t = int - let compare = compare - end) - -type unop = Not -type binop = - | Add | Sub - | Le | Ge | Lt | Gt | Eq | Ne - -type ('ref, 'loc) phi = { pjmp: 'loc; pvar: 'ref } - -type ('ref, 'loc) ir = - | INop - | ICon of int - | IUop of unop * 'ref - | IBop of 'ref * binop * 'ref - | IBrz of 'ref * 'loc * 'loc - | IJmp of 'loc - | IPhi of ('ref, 'loc) phi list - -(* Phi nodes must be at the join of branches - in the control flow graph, if n branches - join, the phi node must have n elements in - its list that indicate the value to merge - from each of the branches. - The id given in each of -*) - - -(* Here, we analyze a program backwards to - compute the liveness of all variables. - We assume that all phi nodes are placed - correctly. -*) -let liveness p = - (* The idea is now to reach a fixpoint - by applying the same backward liveness - propagation a sufficient number of - times. - The [changed] variable will tell us - when we reached the fixpoint, it is - reset to false at each iteration. - *) - let changed = ref true in - let liveout = Array.make (Array.length p) ISet.empty in - - let setlive v l = - (* Extend the liveness of v to l. *) - if not (ISet.mem v liveout.(l)) then begin - changed := true; - liveout.(l) <- ISet.add v liveout.(l); - end in - - let succs i = - (* Retreive the successor nodes of i. *) - if i = Array.length p -1 then [] else - match p.(i) with - | IBrz (_, i1, i2) -> [i1; i2] - | IJmp i1 -> [i1] - | _ -> [i+1] in - - let gen i = ISet.of_list - (* Get the Gen set of i. *) - begin match p.(i) with - | IUop (_, i1) -> [i1] - | IBop (i1, _, i2) -> [i1; i2] - | IPhi l -> - List.iter (fun {pjmp; pvar} -> - setlive pvar pjmp - ) l; [] - | _ -> [] - end in - - let livein i = - (* Get the live In set of i. *) - let s = liveout.(i) in - let s = ISet.union s (gen i) in - ISet.remove i s in - - (* The fixpoint computation. *) - while !changed do - changed := false; - for i = Array.length p -1 downto 0 do - (* Collect live Ins of all successor blocks. *) - let live = List.fold_left (fun live i' -> - ISet.union live (livein i') - ) ISet.empty (succs i) in - ISet.iter (fun i' -> - setlive i' i - ) live - done - done; - liveout - - -type loc = - | L0 (* No location. *) - | LCon of int (* Constant. *) - | LReg of int (* Machine register. *) - | LSpl of int (* Spill location. *) - -type spill = { sreg: int; soff: int } - -type regir = - | RIR of int * (loc, int ref) ir - | RMove of loc * loc - -(* The reg IR adds spill saves and restores to standard - IR instructions. The register allocator below uses - these new instructions when the physical machine lacks - registers. -*) - -let regalloc nr p l = - (* The final reg IR is built here. *) - let rir = ref [] in - let emit r = rir := r :: !rir in - let ipos = Array.init (Array.length p) ref in - emit (RIR (-1, INop)); - - (* Hints help the allocator to know what register - to use. They can be combined using the |> - operator below. *) - let hints = Array.make (Array.length p) (-1) in - (* let ( |> ) a b = if a < 0 then b else a in *) - - (* Number of spill slots. *) - let spill = ref 0 in - - (* Associative list binding live ir to locations, - ordered by freshness. *) - let locs = ref [] in - let setloc i l = locs := (i, l) :: !locs in - let setspill i = - setloc i (LSpl !spill); - incr spill; !spill - 1 in - - (* Get free registers. *) - let free () = - let rl = Array.to_list (Array.init nr (fun i -> i)) in - List.filter (fun r -> - not (List.mem (LReg r) (List.map snd !locs)) - ) rl in - - (* Allocate a register for an ir. *) - let alloc hint i = - let ret r = setloc i (LReg r); r in - let free = free () in - if List.mem hint free then ret hint - else match free with r::_ -> ret r - | [] -> (* No more free registers, force spill. *) - let regof = function LReg r -> r | _ -> -1 in - let cmpf (a,_) (b,_) = compare a b in - let l = List.map (fun (i,l) -> (i,regof l)) !locs in - let l = List.filter (fun (_,r) -> r >= 0) l in - let sir, sreg = List.hd (List.sort cmpf l) in (* Take the oldest. *) - locs := snd (List.partition ((=) (sir, LReg sreg)) !locs); - let soff = - match try List.assoc sir !locs with _ -> L0 with - | LSpl n -> n - | _ -> setspill sir in - emit (RMove (LReg sreg, LSpl soff)); - ret sreg in - - (* Find a register for a destination. *) - let dst i = - let li = - try List.assoc i !locs with Not_found -> L0 in - let r = match li with - | LReg r -> r - | _ -> alloc hints.(i) i in - begin match li with - | LSpl l -> emit (RMove (LSpl l, LReg r)) - | _ -> () - end; - locs := snd (List.partition (fun (j,_) -> j=i) !locs); - r in - - let phis = ref [] in - - (* Find a location for an operand. *) - let loc i = - try List.assoc i !locs with Not_found -> - try List.assoc i !phis with Not_found -> - match p.(i) with - | ICon k -> setloc i (LCon k); LCon k - | _ -> LReg (alloc hints.(i) i) in - - let loc2 i = - try List.assoc i !locs with Not_found -> - try List.assoc i !phis with Not_found -> - match p.(i) with - | ICon k -> setloc i (LCon k); LCon k - | _ -> - (* Here, we just want to avoid using the - same register we used for the first - operand. *) - if free () = [] then LSpl (setspill i) - else LReg (alloc hints.(i) i) in - - let philoc i = - match p.(i) with - | IPhi pl -> - (try List.assoc i !phis with Not_found -> - let l = loc2 i in - phis := (i, l) :: !phis; - begin match l with - | LReg h -> List.iter (fun x -> hints.(x.pvar) <- h) pl; - | _ -> () - end; - l) - | _ -> failwith "regalloc: invalid call to philoc" in - let rec movs jmp i = - if i >= Array.length p then () else - match p.(i) with - | IPhi l -> - let l = List.filter (fun x -> x.pjmp = jmp) l in - assert (List.length l = 1); - let pl = philoc i in - let v = (List.hd l).pvar in - let vl = loc2 v in - emit (RMove (pl, vl)); - movs jmp (i+1) - | _ -> () in - - - (* Going backwards. *) - for i = Array.length p -1 downto 0 do - - (* Forget about all bindings not live - at the end of the instruction. *) - locs := List.filter - (fun (i',_) -> ISet.mem i' l.(i)) !locs; - - begin match p.(i) with - | IPhi _ -> () - | ICon _ | INop -> - movs i (i+1) - | IBrz (i', l1, l2) -> - emit (RIR (-1, IJmp ipos.(l2))); - movs i l2; - let li' = loc i' in - let p = List.length !rir in - emit (RIR (-1, IBrz (li', ipos.(l1), ref p))); - movs i l1 - | IJmp l -> - emit (RIR (-1, IJmp ipos.(l))); - movs i l; - | IUop (op, i') -> - let r = dst i in - let li' = hints.(i') <- r; loc i' in - emit (RIR (r, IUop (op, li'))); - movs i (i+1) - | IBop (il, op, ir) -> - let r = dst i in - let lil = hints.(il) <- r; loc il in - let lir = loc2 ir in - emit (RIR (r, IBop (lil, op, lir))); - movs i (i+1) - end; - - (* Update position of the current instruction. *) - ipos.(i) := List.length !rir; - done; - - (Array.of_list !rir, !spill) - - -module type ARCH = sig - type label type reg - type brtype = Jump | NonZ of reg - - (* Labels for branching. *) - val newlbl: unit -> label - val setlbl: label -> unit - - (* Register creation. *) - val regk: int -> reg - val regn: int -> reg - - (* Register spilling and restoration. *) - val spill: reg -> int -> unit - val resto: int -> reg -> unit - (* Boring instructions. *) - val mov: reg -> reg -> unit - val bop: binop -> reg -> reg -> reg -> unit - val uop: unop -> reg -> reg -> unit - val br: brtype -> label -> unit - - (* Initialization finalization. *) - val reset: int -> unit - val code: unit -> string -end - - - -(* Testing. *) - -let parse src = - let blocks = Hashtbl.create 31 in - let rec addlbl idx l = - let l = String.trim l in - try - let il = String.index l ':' in - let lbl = String.sub l 0 il in - Hashtbl.add blocks lbl idx; - let l = - String.sub l (il+1) - (String.length l -(il+1)) in - addlbl idx l - with Not_found -> l ^ " " in - let src = List.mapi addlbl src in - let p = Array.make (List.length src) INop in - List.iteri (fun idx l -> - let fail s = - failwith - (Printf.sprintf "line %d: %s" (idx+1) s) in - let tok = - let p = ref 0 in fun () -> - try - while l.[!p] = ' ' do incr p done; - let p0 = !p in - while l.[!p] <> ' ' do incr p done; - String.sub l p0 (!p - p0) - with _ -> fail "token expected" in - let id () = - let v = tok () in - try Hashtbl.find blocks v - with _ -> fail ("unknown variable " ^ v) in - let instr = - if l = " " then INop else - let bop o = - let i1 = id () in - let i2 = id () in - IBop (i1, o, i2) in - match tok () with - | "con" -> ICon (int_of_string (tok ())) - | "not" -> IUop (Not, id ()) - | "add" -> bop Add - | "sub" -> bop Sub - | "cle" -> bop Le - | "cge" -> bop Ge - | "clt" -> bop Lt - | "cgt" -> bop Gt - | "ceq" -> bop Eq - | "cne" -> bop Ne - | "phi" -> - let exp t = - let t' = tok () in - if t' <> t then - fail ("unexpected " ^ t') in - let rec f () = - match tok () with - | "[" -> - let pjmp = id () in - let pvar = id () in - exp "]"; - {pjmp; pvar} :: f () - | "." -> [] - | t -> fail ("unexpected " ^ t) in - IPhi (f ()) - | "brz" -> - let v = id () in - let bz = id () in - let bn = id () in - IBrz (v, bz, bn) - | "jmp" -> IJmp (id ()) - | i -> fail ("invalid " ^ i) in - p.(idx) <- instr - ) src; - p - -let t_sum = - [ "k0: con 0" - ; "ni: con 1234" - ; "k1: con 1" - ; "n0: phi [ jmp n1 ] [ k1 ni ] ." - ; "f1: phi [ jmp f2 ] [ k1 k1 ] ." - ; "n1: sub n0 k1" - ; "f2: add f1 n0" - ; "jmp: brz n1 end n0" - (* ; "jmp: jmp n0" *) - ; "end:" - ] - -(* - The following program has irreducible - control-flow. The control flow is - pictured below. - - +--b1 <- defs r0, r1 - | | - b2 b3 - | | - \ b4<-+ <- uses r0 - \ | | - +--b5 | <- uses r1 - | | | - b7 b6--+ - - A simple implementation (that works for - non-irreducible control flows) proceeds - backwards, it would successfully make r1 - live in b2 and b3 but r0 would fail to be - live in b2. It would become live for the - loop b4-b5-b6 when reaching the loop header - b4, but the simple algorithm would not - propagate back to b2. -*) - -let t_irred = - [ "k0: con 0" - ; "r0: con 1" - ; "r1: con 2" - ; "b1: brz k0 b2 b3" - ; "b2: jmp b5" - ; "b3:" - ; "b4: add r0 k0" - ; "b50: add r1 k0" - ; "b5: brz k0 b6 b7" - ; "b6: jmp b4" - ; "b7:" - ] - -let _ = - let src = t_sum in - let p = parse src in - let open Printf in - - printf "** Program:\n"; - List.iter (printf "%s\n") src; - - printf "\n** Liveness analysis:\n"; - let l = liveness p in - for i = 0 to Array.length p -1 do - printf "%04d:" i; - ISet.iter (printf " %04d") l.(i); - printf "\n"; - done; - - printf "\n** Register allocation:\n"; - let regs = [| "rax"; "rbx" |] in (* ; "rbx"; "rcx" |] in *) - let loc = function - | L0 -> assert false - | LReg r -> regs.(r) - | LCon k -> sprintf "$%d" k - | LSpl n -> sprintf "%d(sp)" n in - let r, _ = regalloc (Array.length regs) p l in - let bop_str = function - | Add -> "add" | Sub -> "sub" - | Le -> "cle" | Ge -> "cge" - | Lt -> "clt" | Gt -> "cgt" - | Eq -> "ceq" | Ne -> "cne" in - let lr = Array.length r in - let inum l = lr - !l in - for i = 0 to lr -1 do - printf "%03d " i; - begin match r.(i) with - | RIR (r, IUop (Not, i')) -> - printf "%s = not %s" regs.(r) (loc i') - | RIR (r, IBop (i1, o, i2)) -> - printf "%s = %s %s %s" - regs.(r) (bop_str o) (loc i1) (loc i2) - | RIR (_, IBrz (i', l1, l2)) -> - printf "brz %s %03d %03d" (loc i') - (inum l1) (inum l2) - | RIR (_, IJmp l) -> - printf "jmp %03d" (inum l) - | RIR (_, IPhi l) -> - printf "phi" - | RMove (t, f) -> - printf "%s = %s" (loc t) (loc f) - | _ -> () - end; - printf "\n" - done diff --git a/lo2.ml b/lo2.ml deleted file mode 100644 index 64bf3ae..0000000 --- a/lo2.ml +++ /dev/null @@ -1,713 +0,0 @@ -type uop = Neg -type bop = Add | Sub | Mul | Div | Rem | CLe | CEq - -type bref = int (* Block references. *) -type 'op seqi = [ `Con of int | `Uop of uop * 'op | `Bop of 'op * bop * 'op ] -type 'op jmpi = [ `Brz of 'op * bref * bref | `Jmp of bref | `Ret of 'op ] - -type ('ins, 'phi, 'jmp) bb = - { mutable bb_name: string - ; mutable bb_phis: 'phi array - ; mutable bb_inss: 'ins array - ; mutable bb_jmp: 'jmp - } - - -(* ** Liveness analysis. ** *) -type iref = IRPhi of (bref * int) | IRIns of (bref * int) -let blk = function IRPhi (b, _) | IRIns (b, _) -> b -type iprog = (iref seqi, [`Phi of iref list], iref jmpi) bb array - -module IRSet = Set.Make( - struct type t = iref let compare = compare end -) - -let liveout lh ir = - try Hashtbl.find lh ir with Not_found -> - let e = IRSet.empty in Hashtbl.add lh ir e; e -let livein lh p ir = - let gen (b, i) = IRSet.of_list begin - let {bb_inss; bb_jmp; _} = p.(b) in - if i = -1 then [] else - if i = Array.length bb_inss - then match bb_jmp with - | `Brz (i1, _, _) | `Ret i1 -> [i1] - | `Jmp _ -> [] - else match bb_inss.(i) with - | `Uop (_, i1) -> [i1] - | `Bop (i1, _, i2) -> [i1; i2] - | `Con _ -> [] - end in - let kill ((b, i) as ir) = - if i >= 0 then IRSet.singleton (IRIns ir) else - fst (Array.fold_left - (fun (k, i) _ -> (IRSet.add (IRPhi (b, i)) k, i+1)) - (IRSet.empty, 0) p.(b).bb_phis - ) in - let s = liveout lh ir in - let s = IRSet.union s (gen ir) in - IRSet.diff s (kill ir) - -let liveness (p: iprog) = - let module H = Hashtbl in - let changed = ref true in (* Witness for fixpoint. *) - let nbb = Array.length p in - let lh = H.create 1001 in - let setlive ir ir' = (* Mark ir live at ir'. *) - let lir' = liveout lh ir' in - if not (IRSet.mem ir lir') then begin - changed := true; - H.replace lh ir' (IRSet.add ir lir'); - end in - let succs (b, i) = (* Successor nodes of an instruction. *) - let {bb_inss; bb_jmp; _} = p.(b) in - if i = Array.length bb_inss then - if b+1 = nbb then [] else - match bb_jmp with - | `Brz (_, b1, b2) -> [(b1, -1); (b2, -1)] - | `Jmp b1 -> [(b1, -1)] - | `Ret _ -> [] - else [(b, i+1)] in - while !changed do - changed := false; - for b = nbb - 1 downto 0 do - let bb = p.(b) in - for i = Array.length bb.bb_inss downto -1 do - let ir = (b, i) in - let live = List.fold_left (fun live ir' -> - IRSet.union live (livein lh p ir') - ) IRSet.empty (succs ir) in - IRSet.iter (fun ir' -> setlive ir' ir) live - done; - Array.iter (fun (`Phi il) -> - List.iter (fun ir -> - let br = blk ir in - setlive ir (br, Array.length p.(br).bb_inss) - ) il - ) bb.bb_phis; - done - done; - lh (* Return the final hash table. *) - - -(* ** Register allocation. ** *) -type loc = LVoid | LReg of int | LSpill of int | LCon of int -type 'op rins = { ri_res: 'op; ri_ins: [ 'op seqi | `Mov of 'op ] } -type 'op rphi = { rp_res: 'op; rp_spill: int option; rp_list: (bref * loc) list } -type rprog = (loc rins, loc rphi, loc jmpi) bb array - -let nregs = ref 3 -let regalloc (p: iprog): rprog = - let module H = struct - include Hashtbl - let find h ir = - try find h ir with Not_found -> - let k = ref 0 in - let isconst = function - `Con c -> k := c; true | _ -> false in - match ir with - | IRIns (b, i) when isconst p.(b).bb_inss.(i) -> LCon !k - | _ -> LVoid - end in - - let lh = liveness p in - let nbb = Array.length p in - let rp = Array.init nbb (fun i -> - { bb_name = p.(i).bb_name - ; bb_phis = [| |] - ; bb_inss = [| |] - ; bb_jmp = `Jmp (-1) - } - ) in - let outmaps = Array.make nbb [] in - let inmaps = Array.make nbb [] in - let bb = ref [] in (* Basic block in construction. *) - let emiti l i = bb := {ri_res=l; ri_ins=i} :: !bb in - let act = H.create 101 in (* The active list. *) - let regs = Array.init !nregs (fun i -> i) |> Array.to_list in - let free = ref regs in (* Free registers. *) - - let nspill = ref 0 in - let newspill () = incr nspill; !nspill - 1 in - let getspill ir = - match H.find act ir with - | LSpill s -> s - | _ -> -1 in - - let kill ir = - match H.find act ir with - | LReg r -> H.remove act ir; free := r :: !free - | _ -> H.remove act ir in - - let loc ir = - match H.find act ir with - | LVoid -> - let l = - match !free with - | r :: f -> free := f; LReg r - | [] -> LSpill (newspill ()) - in - H.add act ir l; l - | l -> l in - - let rec getreg frz = (* Aggressively obtain one register. *) - match !free with - | r :: f when List.mem r frz -> (* Frozen, can't use it. *) - free := f; - let r' = getreg frz in - free := r :: !free; r' - | r :: f -> free := f; r - | [] -> (* Spill needed! *) - match - H.fold (fun ir loc l -> (* Find candidates. *) - match loc with - | LReg r when not (List.mem r frz) -> - (ir, r) :: l - | _ -> l - ) act [] (* |> sort by spill cost *) - with [] -> failwith "god damn it, not enough registers" - | (ir, r) :: _ -> - H.remove act ir; - let s = getspill ir in - let s = - if s >= 0 then s else - let s' = newspill () in - H.add act ir (LSpill s'); s' in - emiti (LReg r) (`Mov (LSpill s)); - r in - - let getreg frz = - let r = getreg frz in - assert (not (List.mem r !free)); - r in - - let regloc frz ir = - match H.find act ir with - | (LCon _ | LReg _) as loc -> loc - | _ -> - let r = getreg frz in - H.add act ir (LReg r); - LReg r in - - for b = nbb - 1 downto 0 do - let bi = p.(b).bb_inss in - let bl = Array.length bi in - - (* Fill outmaps with the allocation state at - * the end of the block (after the final branch). - *) - let lvout = liveout lh (b, bl) in - outmaps.(b) <- begin - IRSet.fold (fun ir m -> (ir, loc ir) :: m) lvout [] - end; - - let jmp = - match p.(b).bb_jmp with - | `Jmp br -> `Jmp br - | `Ret (ir) -> `Ret (loc ir) - | `Brz (ir, br1, br2) -> - `Brz (loc ir, br1, br2) in - rp.(b).bb_jmp <- jmp; - - for i = bl - 1 downto 0 do - let ir = IRIns (b, i) in - begin match H.find act ir with - | LCon _ | LVoid -> () (* Dead code. *) - | lir -> - let r, frz = - match lir with - | LSpill s -> - let frz = - let block ir l = - match H.find act ir with - | LReg r -> r :: l - | _ -> l in - match bi.(i) with - | `Uop (_, ir) -> - [] |> block ir - | `Bop (ir1, _, ir2) -> - [] |> block ir1 |> block ir2 - | _ -> [] in - let r = getreg frz in - free := r :: !free; (* Add it straight back to free, but freeze it. *) - (r, [r]) - | LReg r -> kill ir; (r, []) - | _ -> assert false - in - let s = getspill ir in - begin match bi.(i) with - | `Con k -> () - | `Uop (op, ir') -> - let l' = regloc frz ir' in - if s >= 0 then emiti (LSpill s) (`Mov (LReg r)); - emiti (LReg r) (`Uop (op, l')) - | `Bop (ir1, op, ir2) -> - (* Special case: Division uses RDX, we - * need to make sure it is free for use. - *) - let rdx = 1 in - if (op = Div || op = Rem) && not (List.mem rdx !free) then - getreg (List.filter ((<>) rdx) regs) |> ignore - else - free := (List.filter ((<>) rdx) !free); - let l1 = regloc frz ir1 in - let frz = match l1 with - | LReg r1 -> r1 :: frz - | _ -> frz in - let l2 = regloc frz ir2 in - if s >= 0 then emiti (LSpill s) (`Mov (LReg r)); - emiti (LReg r) (`Bop (l1, op, l2)); - if op = Div || op = Rem then - free := rdx :: !free; - end; - end - done; - - let lvin = liveout lh (b, -1) in - inmaps.(b) <- begin - IRSet.fold (fun ir l -> - let loc = H.find act ir in - if blk ir = b then - kill ir; (* Kill current block's phis *) - let s = getspill ir in - kill ir; - if s >= 0 then - (ir, (loc, Some s)) :: l - else - (ir, (loc, None)) :: l - ) lvin [] - end; - - rp.(b).bb_inss <- Array.of_list !bb; - bb := []; - done; - - (* Compute phis. *) - for b = 0 to nbb - 1 do - rp.(b).bb_phis <- Array.of_list begin - IRSet.fold (fun ir l -> - match ir with - | IRPhi (b', pr) when b' = b -> - let `Phi pl = p.(b).bb_phis.(pr) in - let pl = - let f ir = - let b = blk ir in - (b, List.assoc ir outmaps.(b)) in - List.map f pl |> - List.sort (fun (a,_) (b,_) -> compare a b) in - let res, spl = List.assoc ir inmaps.(b) in - { rp_res = res - ; rp_spill = spl - ; rp_list = pl - } :: l - | _ -> assert (blk ir <> b); - (* Forgive me, I sin!! *) - let rl = ref [] in - for b = 0 to nbb - 1 do - let bl = Array.length p.(b).bb_inss in - if IRSet.mem ir (liveout lh (b, bl)) then - rl := (b, List.assoc ir outmaps.(b)) :: !rl - done; - { rp_res = fst (List.assoc ir inmaps.(b)) - ; rp_spill = None - ; rp_list = List.rev !rl - } :: l - ) (liveout lh (b, -1)) [] - end - done; - - rp - - -(* ** Phi resolution. ** *) -(* Machine program, ready for code generation. *) -type mprog = (loc rins, unit, loc jmpi) bb array - -let movgen (p: rprog): mprog = - - let parmov b b' = - let tmp = LReg (-1) in - let src, dst = - let phis = p.(b').bb_phis in - Array.map (fun x -> List.assoc b x.rp_list) phis, - Array.map (fun x -> x.rp_res) phis in - let n = Array.length dst in - let status = Array.make n `ToMove in - let ms = ref [] in - let emov dst src = - ms := {ri_res = dst; ri_ins = `Mov src} :: !ms in - let rec mv i = - if src.(i) <> dst.(i) then begin - status.(i) <- `Moving; - for j = 0 to n - 1 do - if src.(j) = dst.(i) then - match status.(j) with - | `ToMove -> mv j - | `Moving -> emov tmp src.(j); src.(j) <- tmp - | `Moved -> () - done; - emov dst.(i) src.(i); - status.(i) <- `Moved; - end in - for i = 0 to n - 1 do - if status.(i) = `ToMove then mv i - done; - Array.iter (fun {rp_res; rp_spill} -> - match rp_spill with - | Some spl when LSpill spl <> rp_res -> - emov (LSpill spl) rp_res - | _ -> () - ) p.(b').bb_phis; - List.rev !ms |> Array.of_list in - - let nbb = Array.length p in - let bmap = Array.init nbb (fun i -> -i - 1) in - let bn = ref 0 in - let mp = ref [] in - let addb b = mp := b :: !mp; incr bn; !bn - 1 in - - for b = 0 to nbb - 1 do - let b' = - { bb_name = p.(b).bb_name - ; bb_phis = [| |] - ; bb_inss = p.(b).bb_inss - ; bb_jmp = `Jmp (-1) - } in - bmap.(b) <- addb b'; - let movbb suff jb = - if jb = -1 then -1 else - let c = parmov b jb in - if c = [| |] then bmap.(jb) else - addb - { bb_name = p.(b).bb_name ^ suff - ; bb_phis = [| |] - ; bb_inss = c - ; bb_jmp = `Jmp bmap.(jb) - } in - b'.bb_jmp <- begin - match p.(b).bb_jmp with - | `Jmp b1 -> `Jmp (movbb "_mov" b1) - | `Ret (l) -> `Ret (l) - | `Brz (l, b1, b2) -> - let b1', b2' = - if b1 = b + 1 then - let b2' = movbb "_mov2" b2 in - let b1' = movbb "_mov1" b1 in - (b1', b2') - else - let b1' = movbb "_mov1" b1 in - let b2' = movbb "_mov2" b2 in - (b1', b2') in - `Brz (l, b1', b2') - end; - done; - List.rev !mp - |> Array.of_list - |> Array.map (fun b -> - let f n = - if n >= -1 then n else bmap.(-n - 1) in - { b with bb_jmp = - match b.bb_jmp with - | `Ret (l) -> `Ret (l) - | `Jmp b1 -> `Jmp (f b1) - | `Brz (l, b1, b2) -> `Brz (l, f b1, f b2) - } - ) - - -(* ** X86-64 code generation. ** *) -let codegen (p: mprog): string = - let cl = ref [] and off = ref 0 in - let outs s = cl := s :: !cl; off := !off + String.length s in - let outb b = outs (String.make 1 (Char.chr b)) in - - (* output prelude *) - outb 0x55; (* push %rbp *) - outs "\x48\x89\xe5"; (* mov %rsp, %rbp *) - - let regmap = [| (* only caller-save regs, for now *) - 0; (* rax *) - 1; (* rcx *) - 2; (* rdx *) (* comes late because of division *) - (* look for RDX and change there too! *) - 6; (* rsi *) - 7; (* rdi *) - 8; (* r8 *) - 9; (* r9 *) - 10; (* r10 *) - 11; (* r11 *) - |] in - let regn = function - | LReg r -> regmap.(r+1) - | _ -> failwith "register expected in regn" in - - let rexp rg rm = - let rex = 0x48 in - let rg, rex = if rg > 7 - then rg-8, rex lor 4 - else rg, rex in - let rm, rex = if rm > 7 - then rm-8, rex lor 1 - else rm, rex in - (rex, rg, rm) in - - let modrm ?(md=3) r m = - (md lsl 6) + (r lsl 3) + m in - - let lite ?byt x = - let byt = match byt with - Some b -> b | None -> Bytes.create 4 in - let rec f i x = - if i = 4 then () else begin - Bytes.set byt i (Char.chr (x land 0xff)); - f (i+1) (x lsr 8) - end in - f 0 x; Bytes.unsafe_to_string byt in - - let oins op r m = - let rex, r, m = rexp r m in - outb rex; outb op; outb (modrm r m) in - - let slot s = - let c = ((-1-s) * 8) land 0xff in - assert (c < 256); - c in - - let move l l1 = match l, l1 with - | (LReg _ as r), LCon k -> - oins 0xc7 0 (regn r); outs (lite k) - | LSpill s, LCon k -> - outb 0x48; - outb 0xc7; - outb (modrm ~md:1 0 5); - outb (slot s); - outs (lite k) - | (LReg _ as r), (LReg _ as r1) -> - let rex, r1, r = rexp (regn r1) (regn r) in - outb rex; outb 0x89; outb (modrm r1 r) - | (LReg _ as r), LSpill s -> - let rex, r, m = rexp (regn r) 5 in - outb rex; outb 0x8b; outb (modrm ~md:1 r m); outb (slot s) - | LSpill s, (LReg _ as r) -> - let rex, r, m = rexp (regn r) 5 in - outb rex; outb 0x89; outb (modrm ~md:1 r m); outb (slot s) - | _ -> failwith "invalid move" in - - let nbb = Array.length p in - let boffs = Array.make nbb (`Unk []) in - let label b = - let p0 = !off + 4 in - match boffs.(b) with - | `Unk l -> - let lbl = lite p0 in - boffs.(b) <- `Unk (lbl :: l); - lbl - | `Kno p -> lite (p - p0) in - - for b = 0 to nbb - 1 do - let pl = - match boffs.(b) with - | `Unk pl -> pl | _ -> [] in - List.iter (fun s -> (* back-patching *) - let p = - Char.code s.[0] + - Char.code s.[1] lsl 8 + - Char.code s.[2] lsl 16 + - Char.code s.[3] lsl 24 in - let byt = Bytes.unsafe_of_string s in - ignore (lite ~byt (!off - p)) - ) pl; - boffs.(b) <- `Kno !off; - - let is = p.(b).bb_inss in - for i = 0 to Array.length is - 1 do - match is.(i) with - | { ri_res = l; ri_ins = `Bop (l1, op, l2) } -> - let l2 = - if l1 = l || op = Div || op = Rem then l2 else - if l2 = l then begin - move (LReg (-1)) l; - move l l1; - LReg (-1) - end else - (move l l1; l2) in - begin match op with - | Add -> - begin match l2 with - | LCon k -> oins 0x81 0 (regn l); outs (lite k) - | LReg _ -> oins 0x01 (regn l2) (regn l) - | _ -> assert false - end - | Sub -> - begin match l2 with - | LCon k -> oins 0x81 5 (regn l); outs (lite k) - | LReg _ -> oins 0x29 (regn l2) (regn l) - | _ -> assert false - end - | Div -> - move (LReg (-1)) l1; - outb 0x99; (* cltd *) - oins 0xf7 7 (regn l2); - move l (LReg (-1)); (* quotient in rax *) - | Rem -> - move (LReg (-1)) l1; - outb 0x99; (* cltd *) - oins 0xf7 7 (regn l2); - if l <> LReg 1 then (* RDX *) - move l (LReg 1); (* remainder in rdx *) - | Mul -> failwith "Mul not implemented" - | CLe -> failwith "CLe not implemented" - | CEq -> failwith "CEq not implemented" - end - | { ri_res = l; ri_ins = `Uop (Neg, l1) } -> - if l <> l1 then - move l l1; - oins 0xf7 3 (regn l) - | { ri_res = l; ri_ins = `Mov l1 } -> - move l l1 - | { ri_res = l; ri_ins = `Con k } -> - move l (LCon k) - done; - - begin match p.(b).bb_jmp with - | `Brz (r, b1, b2) when b1 >= 0 && b2 >= 0 -> - oins 0x85 (regn r) (regn r); - if b1 = b+1 then - (outb 0x0f; outb 0x85; outs (label b2)) - else if b2 = b+1 then - (outb 0x0f; outb 0x84; outs (label b1)) - else - failwith "double branch" - | `Jmp b1 when b1 >= 0 -> - if b1 <> b+1 then - (outb 0xe9; outs (label b1)) - | `Ret (l) -> - move (LReg (-1)) l; - outb 0x5d; (* pop %rbp *) - outb 0xc3; (* retq *) - | _ -> () - end - done; - - String.concat "" (List.rev !cl) - - -(* Little test programs. *) -let pbasic: iprog = - [| { bb_name = "start" - ; bb_phis = [| |] - ; bb_inss = - [| `Con 2 - ; `Con 3 - ; `Bop (IRIns (0, 0), Add, IRIns (0, 1)) - ; `Bop (IRIns (0, 0), Add, IRIns (0, 2)) - |] - ; bb_jmp = `Ret (IRIns (0, 3)) - } - |] - -let pcount: iprog = - [| { bb_name = "init" - ; bb_phis = [||] - ; bb_inss = [| `Con 1234567; `Con 1 |] - ; bb_jmp = `Jmp 1 - } - ; { bb_name = "loop" - ; bb_phis = [| `Phi [IRIns (0, 0); IRIns (1, 0)] |] - ; bb_inss = [| `Bop (IRPhi (1, 0), Sub, IRIns (0, 1)) |] - ; bb_jmp = `Brz (IRIns (1, 0), 2, 1) - } - ; { bb_name = "end" - ; bb_phis = [||] - ; bb_inss = [| `Con 42 |] - ; bb_jmp = `Ret (IRIns (0,1)) - } - |] - -let psum: iprog = - [| { bb_name = "init" - ; bb_phis = [||] - ; bb_inss = [| `Con 1234567; `Con 1; `Con 0 |] - ; bb_jmp = `Jmp 1 - } - ; { bb_name = "loop" - ; bb_phis = - [| `Phi [IRIns (0, 0); IRIns (1, 0)] (* n = phi(100, n1) *) - ; `Phi [IRIns (0, 2); IRIns (1, 1)] (* s = phi(1, s1) *) - |] - ; bb_inss = - [| `Bop (IRPhi (1, 0), Sub, IRIns (0, 1)) (* n1 = n - 1 *) - ; `Bop (IRPhi (1, 1), Add, IRPhi (1, 0)) (* s1 = s + n *) - |] - ; bb_jmp = `Brz (IRIns (1, 0), 2, 1) - } - ; { bb_name = "end" - ; bb_phis = [||] - ; bb_inss = [| `Con 42 |] - ; bb_jmp = `Ret (IRIns (1,1)) - } - |] - -let peucl: iprog = - [| { bb_name = "init" - ; bb_phis = [||] - ; bb_inss = [| `Con 123456; `Con 32223 |] - ; bb_jmp = `Jmp 1 - } - ; { bb_name = "loop" - ; bb_phis = - [| `Phi [IRIns (0, 0); IRPhi (1, 1)] - ; `Phi [IRIns (0, 1); IRIns (1, 0)] - |] - ; bb_inss = - [| `Bop (IRPhi (1, 0), Rem, IRPhi (1, 1)) - |] - ; bb_jmp = `Brz (IRIns (1, 0), 2, 1) - } - ; { bb_name = "end" - ; bb_phis = [||] - ; bb_inss = [||] - ; bb_jmp = `Ret (IRPhi (1, 1)) - } - |] - -let pspill: iprog = - [| { bb_name = "init" - ; bb_phis = [||] - ; bb_inss = -(* 00 *) [| `Con 42 -(* 01 *) ; `Bop (IRIns (0, 0), Add, IRIns (0, 0)) -(* 02 *) ; `Bop (IRIns (0, 0), Add, IRIns (0, 1)) -(* 03 *) ; `Bop (IRIns (0, 0), Add, IRIns (0, 2)) -(* 04 *) ; `Bop (IRIns (0, 0), Add, IRIns (0, 3)) -(* 05 *) ; `Bop (IRIns (0, 0), Add, IRIns (0, 4)) -(* 06 *) ; `Bop (IRIns (0, 0), Add, IRIns (0, 5)) -(* 07 *) ; `Bop (IRIns (0, 6), Add, IRIns (0, 6)) -(* 08 *) ; `Bop (IRIns (0, 5), Add, IRIns (0, 7)) -(* 09 *) ; `Bop (IRIns (0, 4), Add, IRIns (0, 8)) -(* 10 *) ; `Bop (IRIns (0, 3), Add, IRIns (0, 9)) -(* 11 *) ; `Bop (IRIns (0, 2), Add, IRIns (0, 10)) -(* 12 *) ; `Bop (IRIns (0, 1), Add, IRIns (0, 11)) -(* 13 *) ; `Bop (IRIns (0, 0), Add, IRIns (0, 12)) - |] - ; bb_jmp = `Ret (IRIns (0, 13)) - } - |] - - -(* ------------------------------------------------------------------------ *) - -let oneshot () = - () - -let _ = - if Array.length Sys.argv > 1 && Sys.argv.(1) = "test" then - let oc = open_out "t.o" in - nregs := 3; - let s = peucl |> regalloc |> movgen |> codegen in - Elf.barebones_elf oc "f" s; - close_out oc; - else - oneshot () - -(* ------------------------------------------------------------------------ *) diff --git a/proto/.gitignore b/proto/.gitignore new file mode 100644 index 0000000..ff9fbe2 --- /dev/null +++ b/proto/.gitignore @@ -0,0 +1,7 @@ +t +bak +.comfile +*.o +*.cm[io] +lisc/lo +t.out diff --git a/proto/Makefile b/proto/Makefile new file mode 100644 index 0000000..c6ebd16 --- /dev/null +++ b/proto/Makefile @@ -0,0 +1,13 @@ +.PHONY: all test clean + +all: bak + +bak: elf.ml lo2.ml + ocamlc -g -o bak elf.ml lo2.ml + +test: bak + @./bak test + @cc -O2 -o t.out tmain.c t.o && ./t.out + +clean: + rm -f bak *.out *.o *.cm[io] diff --git a/proto/TODO b/proto/TODO new file mode 100644 index 0000000..e144c66 --- /dev/null +++ b/proto/TODO @@ -0,0 +1,54 @@ +Features +- Operand classes for instructions +- Hints in register allocation +- Fixed register instructions (div, mul) + Is this part of "operand classes"? + +Instructions +- ADD SUB SDIV UDIV SREM UREM MUL LSL LSR ASL ASR +- SEXT ZEXT (we need 8, 16, 32, 64 bits) +- CMP ... +- ALLOC STORE LOAD (we need 8, 16, 32, 64 bits) +(- PTR) +- CALL BRZ JMP RET + +Machine +- SREG GREG +- Register use/defs for all instructions. + +Types +- Integer (32 & 64 bits) +(- Structure "{a,b,c}") +(- Pointer (to type "t")) + +Questions +- Q: Should we allow constant operands? + A: + It looks like `Con instructions are a bad idea because + they introduce spurious live ranges. + This was not a huge problem, modifications s in loc and + getreg only fixed this. Still, it makes use larger bit + vectors during the liveness analysis. +- Q: How to represent the IR? + A: + So far, a graph of basic blocks composed of quadruples + seems to be the most convenient. +- Q: Do we need types? + +Problems +- x = y op z [fixed using freeze] + if x is spilled, y can be moved to a spill location + to free one register for x, this is kind of stupid. + We can probably fix this by having a better heuristic + for spilling decisions. +- [tentative fix: 4fc98da] + Phi defined variables with spill location do not work. +- At the end of a block we call loc on all live variables, + if there are not enough registers, some variables get + assigned spill locations. We need to be able to spill + variables that are already in register. + NOTE: Following Braun & Hack we could do one pass + first that determines what variables are in register + at the end of loops. This sounds good because + back-edges are actually easier to detect than loop + headers! diff --git a/proto/bak.ml b/proto/bak.ml new file mode 100644 index 0000000..cd1aff2 --- /dev/null +++ b/proto/bak.ml @@ -0,0 +1,132 @@ +type id = int +type ty = + | TInt of bool * int + | TArr of int * ty + | TPtr of ty + | TVoid +type con = CInt of int +type cnd = Ge | Le | Gt | Lt | Ne | Eq +type ins = + | IAlloc of ty + | IMem of id + | ISto of id * id + | IAdd of id * id + | ISub of id * id + | ICon of ty * con + | IBr of id * cnd * id * id + | IJmp of id + | IPhi of ty * id * id + +let isint = function TInt _ -> true | _ -> false +let isbranch = function IBr _ | IJmp _ -> true | _ -> false + +exception Type of string +let tychk blk = + let typs = Array.make (Array.length blk) TVoid in + let blks = ref [] in + let jmp src dst = + let rec f = function + | (blk, srcs) :: tl when blk = dst -> + (blk, src :: srcs) :: tl + | b :: tl when fst b < dst -> b :: f tl + | l -> + let srcs = + if dst = 0 then [src] else + if isbranch blk.(dst-1) + then [src] else [dst-1; src] in + (dst, srcs) :: l in + blks := f !blks in + let f i = (* do easy type checks *) + let chn n = + if n >= i || n < 0 then + raise (Type "broken data dependency") in + function + | IPhi (ty, _, _) -> + if ty = TVoid then + raise (Type "invalid void phi"); + typs.(i) <- ty + | ICon (ty, _) -> typs.(i) <- ty + | IAlloc ty -> + if ty = TVoid then + raise (Type "invalid void alloc"); + typs.(i) <- TPtr ty + | IMem n -> + chn n; + (match typs.(n) with + | TPtr ty -> typs.(i) <- ty + | _ -> raise (Type "invalid dereference") + ) + | ISto (a, b) -> + chn a; chn b; + if typs.(a) <> TPtr typs.(b) then + raise (Type "invalid store") + | IAdd (a, b) -> + chn a; chn b; + if not (isint typs.(b)) then + raise (Type "second add operand not integral"); + (match typs.(a) with + | (TPtr _) as t -> typs.(i) <- t + | (TInt _) as t -> + if t <> typs.(b) then + raise (Type "invalid heterogeneous addition"); + typs.(i) <- t + | _ -> raise (Type "invalid type for addition") + ) + | ISub (a, b) -> + chn a; chn b; + (match typs.(a), typs.(b) with + | (TPtr _ as ta), (TPtr _ as tb) -> + if ta <> tb then + raise (Type "substracted pointers have different types"); + typs.(i) <- TInt (true, 64) + | (TInt _ as ta), (TInt _ as tb) -> + if ta <> tb then + raise (Type "invalid heterogeneous substraction"); + typs.(i) <- ta + | _ -> raise (Type "invalid type for substraction") + ) + | IBr (_, _, _, dst) -> jmp i dst; jmp i (i+1) + | IJmp dst -> jmp i dst in + Array.iteri f blk; + let f = function (* check types at phi nodes *) + | IPhi (_, a, b) -> + if typs.(a) <> typs.(b) then + raise (Type "ill-typed phi node") + | _ -> () in + Array.iter f blk; + let bbase i = + let rec f base = function + | [] -> base + | (b, _) :: _ when b > i -> base + | (b, _) :: tl -> f b tl in + f 0 !blks in + let f i = function (* check validity of ssa *) + | IPhi (_, a, b) -> + let callers = + List.map bbase (List.assoc (bbase i) !blks) in + let ba = bbase a and bb = bbase b in + if ba = bb + || not (List.mem ba callers) + || not (List.mem bb callers) + then + raise (Type "invalid phi node"); + | IAdd (a, b) | ISub (a, b) | ISto (a, b) | IBr (a, _, b, _) -> + let bi = bbase i in + if bbase a <> bi || bbase b <> bi then + raise (Type "operands of non-phy not in current block") + | IMem a -> + if bbase a <> bbase i then + raise (Type "operands of non-phy not in current block") + | IJmp _ | ICon _ | IAlloc _ -> () in + Array.iteri f blk + + (* tests *) +let _ = + let int = TInt (true, 32) in + let p0 = [| + (* 0 *) ICon (int, CInt 1); + (* 1 *) ICon (int, CInt 42); + (* 2 *) IPhi (int, 0, 2); + (* 3 *) IAdd (1, 2); + (* 4 *) IJmp 1 + |] in tychk p0 diff --git a/proto/elf.ml b/proto/elf.ml new file mode 100644 index 0000000..d83f4fd --- /dev/null +++ b/proto/elf.ml @@ -0,0 +1,200 @@ +(* This is a module to spit simple ELF + object files that can afterwards be + linked to build an application. +*) + +let hash s = + (* The ELF hash function. *) + let open Int64 in (* I doubt this is necessary... *) + let rec f p h = + if p = String.length s then to_int h else + let h = shift_left h 4 in + let h = add h (of_int (int_of_char s.[p])) in + let g = logand h (of_int 0xf0000000) in + let h = logxor h (shift_right g 24) in + f (p+1) (logand h (of_int 0x0fffffff)) in + f 0 (of_int 0) + +let le n x = + (* Make a string of bytes in little endian convention. *) + let b = Bytes.create n in + let rec f i x = + if i = n then () else + let d = char_of_int (x land 0xff) in + Bytes.set b i d; + f (i+1) (x lsr 8) in + f 0 x; Bytes.to_string b + +let stt_NOTYPE = 0 +let stt_OBJECT = 1 +let stt_FUNC = 2 + +let stb_LOCAL = 0 +let stb_GLOBAL = 16 +let stb_WEAK = 32 + +let sht_NULL = le 4 0 +let sht_PROGBITS = le 4 1 +let sht_SYMTAB = le 4 2 +let sht_STRTAB = le 4 3 +let sht_RELA = le 4 4 +let sht_NOTE = le 4 7 +let sht_NOBITS = le 4 8 + +let shf_WRITE = 1 +let shf_ALLOC = 2 +let shf_EXECINSTR = 4 + +let barebones_elf oc fn text = + let header = String.concat "" + [ "\x7fELF" (* e_ident, magic *) + ; "\x02" (* e_ident, ELFCLASS64 *) + ; "\x01" (* e_ident, ELFDATA2LSB *) + ; "\x01" (* e_indent, EV_CURRENT *) + ; "\x00" (* e_ident, ELFOSABI_SYSV *) + ; "\x00" (* e_ident, ABI version *) + ; "\x00\x00\x00\x00\x00\x00\x00" (* e_ident, padding *) + ; "\x01\x00" (* e_type, ET_REL *) + ; "\x3e\x00" (* e_machine, EM_X86_64 *) + ; "\x01\x00\x00\x00" (* e_version, EV_CURRENT *) + ; "\x00\x00\x00\x00\x00\x00\x00\x00" (* e_entry, unused *) + ; "\x00\x00\x00\x00\x00\x00\x00\x00" (* e_phoff, unused *) + ; "\x40\x00\x00\x00\x00\x00\x00\x00" (* e_shoff, 64 *) + ; "\x00\x00\x00\x00" (* e_flags, 0 *) + ; "\x40\x00" (* e_hsize, 64 *) + ; "\x00\x00" (* e_phentsize, 0 *) + ; "\x00\x00" (* e_phnum, 0 *) + ; "\x40\x00" (* e_shentsize, 64 *) + ; "\x07\x00" (* e_shnum, 7 *) + ; "\x06\x00" (* e_shstrndx, 6 *) + ] in + + (* We will use the following section organization. + 1- .text PROGBITS + 2- .data PROGBITS + 3- .bss NOBITS + 4- .rela RELA + 5- .symtab SYMTAB + 6- .strtab STRTAB + *) + + let adds s x = (String.length s, s ^ x ^ "\x00") in + (* section names *) + let textstr, strtab = adds "\x00" ".text" in + let datastr, strtab = adds strtab ".data" in + let bssstr , strtab = adds strtab ".bss" in + let relastr, strtab = adds strtab ".rela" in + let symtstr, strtab = adds strtab ".symt" in + let strtstr, strtab = adds strtab ".strt" in + (* function names *) + let fnstr, strtab = adds strtab fn in + + let symtab = String.concat "" + [ le 0x18 0 (* first symbol is reserved *) + ; le 4 fnstr (* st_name *) + ; le 1 (stt_FUNC lor stb_GLOBAL) (* st_info *) + ; "\x00" (* st_other *) + ; le 2 1 (* st_shndx, .text *) + ; le 8 0 (* st_value, offset in .text section *) + ; le 8 (String.length text) (* st_size *) + ] in + + let textoff = 64 + 7 * 64 in + let txtlen, txtpad = + let l = String.length text in + let p = (l + 7) land 7 in + (l, p) in + let dataoff = textoff + txtlen + txtpad in + let bssoff = dataoff + 0 in + let relaoff = bssoff + 0 in + let symtoff = relaoff + 0 in + let strtoff = symtoff + String.length symtab in + + let sh = String.concat "" + [ le 64 0 (* first section header is reserved *) + (* .text *) + ; le 4 textstr (* sh_name *) + ; sht_PROGBITS (* sh_type *) + ; le 8 (shf_ALLOC lor shf_EXECINSTR) (* sh_flags *) + ; le 8 0 (* sh_addr *) + ; le 8 textoff (* sh_offset *) + ; le 8 txtlen (* sh_size *) + ; le 4 0 (* sh_link *) + ; le 4 0 (* sh_info *) + ; le 8 1 (* sh_addralign *) + ; le 8 0 (* sh_entsize *) + (* .data *) + ; le 4 datastr (* sh_name *) + ; sht_PROGBITS (* sh_type *) + ; le 8 (shf_ALLOC lor shf_WRITE) (* sh_flags *) + ; le 8 0 (* sh_addr *) + ; le 8 dataoff (* sh_offset *) + ; le 8 0 (* sh_size *) + ; le 4 0 (* sh_link *) + ; le 4 0 (* sh_info *) + ; le 8 1 (* sh_addralign *) + ; le 8 0 (* sh_entsize *) + (* .bss *) + ; le 4 bssstr (* sh_name *) + ; sht_NOBITS (* sh_type *) + ; le 8 (shf_ALLOC lor shf_WRITE) (* sh_flags *) + ; le 8 0 (* sh_addr *) + ; le 8 bssoff (* sh_offset *) + ; le 8 0 (* sh_size *) + ; le 4 0 (* sh_link *) + ; le 4 0 (* sh_info *) + ; le 8 1 (* sh_addralign *) + ; le 8 0 (* sh_entsize *) + (* .rela *) + ; le 4 relastr (* sh_name *) + ; sht_RELA (* sh_type *) + ; le 8 0 (* sh_flags *) + ; le 8 0 (* sh_addr *) + ; le 8 relaoff (* sh_offset *) + ; le 8 0 (* sh_size *) + ; le 4 5 (* sh_link, symtab index *) + ; le 4 1 (* sh_info, text section *) + ; le 8 1 (* sh_addralign *) + ; le 8 0x18 (* sh_entsize *) + (* .symtab *) + ; le 4 symtstr (* sh_name *) + ; sht_SYMTAB (* sh_type *) + ; le 8 0 (* sh_flags *) + ; le 8 0 (* sh_addr *) + ; le 8 symtoff (* sh_offset *) + ; le 8 (String.length symtab) (* sh_size *) + ; le 4 6 (* sh_link, strtab index *) + ; le 4 1 (* sh_info, first non-local symbol *) + ; le 8 1 (* sh_addralign *) + ; le 8 0x18 (* sh_entsize *) + (* .strtab *) + ; le 4 strtstr (* sh_name *) + ; sht_STRTAB (* sh_type *) + ; le 8 0 (* sh_flags *) + ; le 8 0 (* sh_addr *) + ; le 8 strtoff (* sh_offset *) + ; le 8 (String.length strtab) (* sh_size *) + ; le 4 0 (* sh_link *) + ; le 4 0 (* sh_info *) + ; le 8 1 (* sh_addralign *) + ; le 8 0x18 (* sh_entsize *) + ] in + + List.iter (output_string oc) + [ header + ; sh + ; text; String.make txtpad '\x90' + ; symtab + ; strtab + ] + + +(* +let _ = + let oc = open_out "test.o" in + let text = String.concat "" + [ "\xb8\x2a\x00\x00\x00" (* mov 42, %eax *) + ; "\xc3" (* retq *) + ] in + barebones_elf oc "main" text +*) diff --git a/proto/heap.ml b/proto/heap.ml new file mode 100644 index 0000000..79081b9 --- /dev/null +++ b/proto/heap.ml @@ -0,0 +1,60 @@ +(* Generic binary heaps. *) +module Heap: sig + type 'a t + val create: ('a -> 'a -> int) -> 'a t + val add: 'a t -> 'a -> unit + val popd: 'a t -> unit + val pop: 'a t -> 'a option + val top: 'a t -> 'a option +end = struct + type 'a t = + { mutable arr: 'a array + ; mutable len: int + ; cmp: 'a -> 'a -> int + } + + let mkarray n = Array.make n (Obj.magic 0) + let create cmp = {arr = mkarray 2; len = 0; cmp } + let top {arr; len; _} = + if len = 0 then None else Some arr.(1) + let swap arr i j = + let tmp = arr.(i) in + arr.(i) <- arr.(j); + arr.(j) <- tmp + + let rec bblup cmp arr i = + let prnt = i/2 in + if prnt = 0 then () else + if cmp arr.(prnt) arr.(i) < 0 then () else + (swap arr prnt i; bblup cmp arr prnt) + let add ({arr; len; cmp} as hp) x = + let arr = + let alen = Array.length arr in + if alen > len+1 then arr else + let arr' = mkarray (alen * 2) in + Array.blit arr 0 arr' 0 alen; + hp.arr <- arr'; + arr' in + hp.len <- len + 1; + arr.(hp.len) <- x; + bblup cmp arr hp.len + + let rec bbldn cmp arr i len = + let ch0 = 2*i in + let ch1 = ch0 + 1 in + if ch0 > len then () else + let mn = + if ch1 > len then ch0 else + if cmp arr.(ch0) arr.(ch1) < 0 + then ch0 else ch1 in + if cmp arr.(i) arr.(mn) <= 0 then () else + (swap arr i mn; bbldn cmp arr mn len) + let popd ({arr; len; cmp} as hp) = + if len = 0 then () else + arr.(1) <- arr.(len); + hp.len <- len - 1; + bbldn cmp arr 1 len + let pop hp = + let r = top hp in + popd hp; r +end diff --git a/proto/lo.ml b/proto/lo.ml new file mode 100644 index 0000000..be2323d --- /dev/null +++ b/proto/lo.ml @@ -0,0 +1,478 @@ +module ISet = Set.Make + (struct + type t = int + let compare = compare + end) + +type unop = Not +type binop = + | Add | Sub + | Le | Ge | Lt | Gt | Eq | Ne + +type ('ref, 'loc) phi = { pjmp: 'loc; pvar: 'ref } + +type ('ref, 'loc) ir = + | INop + | ICon of int + | IUop of unop * 'ref + | IBop of 'ref * binop * 'ref + | IBrz of 'ref * 'loc * 'loc + | IJmp of 'loc + | IPhi of ('ref, 'loc) phi list + +(* Phi nodes must be at the join of branches + in the control flow graph, if n branches + join, the phi node must have n elements in + its list that indicate the value to merge + from each of the branches. + The id given in each of +*) + + +(* Here, we analyze a program backwards to + compute the liveness of all variables. + We assume that all phi nodes are placed + correctly. +*) +let liveness p = + (* The idea is now to reach a fixpoint + by applying the same backward liveness + propagation a sufficient number of + times. + The [changed] variable will tell us + when we reached the fixpoint, it is + reset to false at each iteration. + *) + let changed = ref true in + let liveout = Array.make (Array.length p) ISet.empty in + + let setlive v l = + (* Extend the liveness of v to l. *) + if not (ISet.mem v liveout.(l)) then begin + changed := true; + liveout.(l) <- ISet.add v liveout.(l); + end in + + let succs i = + (* Retreive the successor nodes of i. *) + if i = Array.length p -1 then [] else + match p.(i) with + | IBrz (_, i1, i2) -> [i1; i2] + | IJmp i1 -> [i1] + | _ -> [i+1] in + + let gen i = ISet.of_list + (* Get the Gen set of i. *) + begin match p.(i) with + | IUop (_, i1) -> [i1] + | IBop (i1, _, i2) -> [i1; i2] + | IPhi l -> + List.iter (fun {pjmp; pvar} -> + setlive pvar pjmp + ) l; [] + | _ -> [] + end in + + let livein i = + (* Get the live In set of i. *) + let s = liveout.(i) in + let s = ISet.union s (gen i) in + ISet.remove i s in + + (* The fixpoint computation. *) + while !changed do + changed := false; + for i = Array.length p -1 downto 0 do + (* Collect live Ins of all successor blocks. *) + let live = List.fold_left (fun live i' -> + ISet.union live (livein i') + ) ISet.empty (succs i) in + ISet.iter (fun i' -> + setlive i' i + ) live + done + done; + liveout + + +type loc = + | L0 (* No location. *) + | LCon of int (* Constant. *) + | LReg of int (* Machine register. *) + | LSpl of int (* Spill location. *) + +type spill = { sreg: int; soff: int } + +type regir = + | RIR of int * (loc, int ref) ir + | RMove of loc * loc + +(* The reg IR adds spill saves and restores to standard + IR instructions. The register allocator below uses + these new instructions when the physical machine lacks + registers. +*) + +let regalloc nr p l = + (* The final reg IR is built here. *) + let rir = ref [] in + let emit r = rir := r :: !rir in + let ipos = Array.init (Array.length p) ref in + emit (RIR (-1, INop)); + + (* Hints help the allocator to know what register + to use. They can be combined using the |> + operator below. *) + let hints = Array.make (Array.length p) (-1) in + (* let ( |> ) a b = if a < 0 then b else a in *) + + (* Number of spill slots. *) + let spill = ref 0 in + + (* Associative list binding live ir to locations, + ordered by freshness. *) + let locs = ref [] in + let setloc i l = locs := (i, l) :: !locs in + let setspill i = + setloc i (LSpl !spill); + incr spill; !spill - 1 in + + (* Get free registers. *) + let free () = + let rl = Array.to_list (Array.init nr (fun i -> i)) in + List.filter (fun r -> + not (List.mem (LReg r) (List.map snd !locs)) + ) rl in + + (* Allocate a register for an ir. *) + let alloc hint i = + let ret r = setloc i (LReg r); r in + let free = free () in + if List.mem hint free then ret hint + else match free with r::_ -> ret r + | [] -> (* No more free registers, force spill. *) + let regof = function LReg r -> r | _ -> -1 in + let cmpf (a,_) (b,_) = compare a b in + let l = List.map (fun (i,l) -> (i,regof l)) !locs in + let l = List.filter (fun (_,r) -> r >= 0) l in + let sir, sreg = List.hd (List.sort cmpf l) in (* Take the oldest. *) + locs := snd (List.partition ((=) (sir, LReg sreg)) !locs); + let soff = + match try List.assoc sir !locs with _ -> L0 with + | LSpl n -> n + | _ -> setspill sir in + emit (RMove (LReg sreg, LSpl soff)); + ret sreg in + + (* Find a register for a destination. *) + let dst i = + let li = + try List.assoc i !locs with Not_found -> L0 in + let r = match li with + | LReg r -> r + | _ -> alloc hints.(i) i in + begin match li with + | LSpl l -> emit (RMove (LSpl l, LReg r)) + | _ -> () + end; + locs := snd (List.partition (fun (j,_) -> j=i) !locs); + r in + + let phis = ref [] in + + (* Find a location for an operand. *) + let loc i = + try List.assoc i !locs with Not_found -> + try List.assoc i !phis with Not_found -> + match p.(i) with + | ICon k -> setloc i (LCon k); LCon k + | _ -> LReg (alloc hints.(i) i) in + + let loc2 i = + try List.assoc i !locs with Not_found -> + try List.assoc i !phis with Not_found -> + match p.(i) with + | ICon k -> setloc i (LCon k); LCon k + | _ -> + (* Here, we just want to avoid using the + same register we used for the first + operand. *) + if free () = [] then LSpl (setspill i) + else LReg (alloc hints.(i) i) in + + let philoc i = + match p.(i) with + | IPhi pl -> + (try List.assoc i !phis with Not_found -> + let l = loc2 i in + phis := (i, l) :: !phis; + begin match l with + | LReg h -> List.iter (fun x -> hints.(x.pvar) <- h) pl; + | _ -> () + end; + l) + | _ -> failwith "regalloc: invalid call to philoc" in + let rec movs jmp i = + if i >= Array.length p then () else + match p.(i) with + | IPhi l -> + let l = List.filter (fun x -> x.pjmp = jmp) l in + assert (List.length l = 1); + let pl = philoc i in + let v = (List.hd l).pvar in + let vl = loc2 v in + emit (RMove (pl, vl)); + movs jmp (i+1) + | _ -> () in + + + (* Going backwards. *) + for i = Array.length p -1 downto 0 do + + (* Forget about all bindings not live + at the end of the instruction. *) + locs := List.filter + (fun (i',_) -> ISet.mem i' l.(i)) !locs; + + begin match p.(i) with + | IPhi _ -> () + | ICon _ | INop -> + movs i (i+1) + | IBrz (i', l1, l2) -> + emit (RIR (-1, IJmp ipos.(l2))); + movs i l2; + let li' = loc i' in + let p = List.length !rir in + emit (RIR (-1, IBrz (li', ipos.(l1), ref p))); + movs i l1 + | IJmp l -> + emit (RIR (-1, IJmp ipos.(l))); + movs i l; + | IUop (op, i') -> + let r = dst i in + let li' = hints.(i') <- r; loc i' in + emit (RIR (r, IUop (op, li'))); + movs i (i+1) + | IBop (il, op, ir) -> + let r = dst i in + let lil = hints.(il) <- r; loc il in + let lir = loc2 ir in + emit (RIR (r, IBop (lil, op, lir))); + movs i (i+1) + end; + + (* Update position of the current instruction. *) + ipos.(i) := List.length !rir; + done; + + (Array.of_list !rir, !spill) + + +module type ARCH = sig + type label type reg + type brtype = Jump | NonZ of reg + + (* Labels for branching. *) + val newlbl: unit -> label + val setlbl: label -> unit + + (* Register creation. *) + val regk: int -> reg + val regn: int -> reg + + (* Register spilling and restoration. *) + val spill: reg -> int -> unit + val resto: int -> reg -> unit + (* Boring instructions. *) + val mov: reg -> reg -> unit + val bop: binop -> reg -> reg -> reg -> unit + val uop: unop -> reg -> reg -> unit + val br: brtype -> label -> unit + + (* Initialization finalization. *) + val reset: int -> unit + val code: unit -> string +end + + + +(* Testing. *) + +let parse src = + let blocks = Hashtbl.create 31 in + let rec addlbl idx l = + let l = String.trim l in + try + let il = String.index l ':' in + let lbl = String.sub l 0 il in + Hashtbl.add blocks lbl idx; + let l = + String.sub l (il+1) + (String.length l -(il+1)) in + addlbl idx l + with Not_found -> l ^ " " in + let src = List.mapi addlbl src in + let p = Array.make (List.length src) INop in + List.iteri (fun idx l -> + let fail s = + failwith + (Printf.sprintf "line %d: %s" (idx+1) s) in + let tok = + let p = ref 0 in fun () -> + try + while l.[!p] = ' ' do incr p done; + let p0 = !p in + while l.[!p] <> ' ' do incr p done; + String.sub l p0 (!p - p0) + with _ -> fail "token expected" in + let id () = + let v = tok () in + try Hashtbl.find blocks v + with _ -> fail ("unknown variable " ^ v) in + let instr = + if l = " " then INop else + let bop o = + let i1 = id () in + let i2 = id () in + IBop (i1, o, i2) in + match tok () with + | "con" -> ICon (int_of_string (tok ())) + | "not" -> IUop (Not, id ()) + | "add" -> bop Add + | "sub" -> bop Sub + | "cle" -> bop Le + | "cge" -> bop Ge + | "clt" -> bop Lt + | "cgt" -> bop Gt + | "ceq" -> bop Eq + | "cne" -> bop Ne + | "phi" -> + let exp t = + let t' = tok () in + if t' <> t then + fail ("unexpected " ^ t') in + let rec f () = + match tok () with + | "[" -> + let pjmp = id () in + let pvar = id () in + exp "]"; + {pjmp; pvar} :: f () + | "." -> [] + | t -> fail ("unexpected " ^ t) in + IPhi (f ()) + | "brz" -> + let v = id () in + let bz = id () in + let bn = id () in + IBrz (v, bz, bn) + | "jmp" -> IJmp (id ()) + | i -> fail ("invalid " ^ i) in + p.(idx) <- instr + ) src; + p + +let t_sum = + [ "k0: con 0" + ; "ni: con 1234" + ; "k1: con 1" + ; "n0: phi [ jmp n1 ] [ k1 ni ] ." + ; "f1: phi [ jmp f2 ] [ k1 k1 ] ." + ; "n1: sub n0 k1" + ; "f2: add f1 n0" + ; "jmp: brz n1 end n0" + (* ; "jmp: jmp n0" *) + ; "end:" + ] + +(* + The following program has irreducible + control-flow. The control flow is + pictured below. + + +--b1 <- defs r0, r1 + | | + b2 b3 + | | + \ b4<-+ <- uses r0 + \ | | + +--b5 | <- uses r1 + | | | + b7 b6--+ + + A simple implementation (that works for + non-irreducible control flows) proceeds + backwards, it would successfully make r1 + live in b2 and b3 but r0 would fail to be + live in b2. It would become live for the + loop b4-b5-b6 when reaching the loop header + b4, but the simple algorithm would not + propagate back to b2. +*) + +let t_irred = + [ "k0: con 0" + ; "r0: con 1" + ; "r1: con 2" + ; "b1: brz k0 b2 b3" + ; "b2: jmp b5" + ; "b3:" + ; "b4: add r0 k0" + ; "b50: add r1 k0" + ; "b5: brz k0 b6 b7" + ; "b6: jmp b4" + ; "b7:" + ] + +let _ = + let src = t_sum in + let p = parse src in + let open Printf in + + printf "** Program:\n"; + List.iter (printf "%s\n") src; + + printf "\n** Liveness analysis:\n"; + let l = liveness p in + for i = 0 to Array.length p -1 do + printf "%04d:" i; + ISet.iter (printf " %04d") l.(i); + printf "\n"; + done; + + printf "\n** Register allocation:\n"; + let regs = [| "rax"; "rbx" |] in (* ; "rbx"; "rcx" |] in *) + let loc = function + | L0 -> assert false + | LReg r -> regs.(r) + | LCon k -> sprintf "$%d" k + | LSpl n -> sprintf "%d(sp)" n in + let r, _ = regalloc (Array.length regs) p l in + let bop_str = function + | Add -> "add" | Sub -> "sub" + | Le -> "cle" | Ge -> "cge" + | Lt -> "clt" | Gt -> "cgt" + | Eq -> "ceq" | Ne -> "cne" in + let lr = Array.length r in + let inum l = lr - !l in + for i = 0 to lr -1 do + printf "%03d " i; + begin match r.(i) with + | RIR (r, IUop (Not, i')) -> + printf "%s = not %s" regs.(r) (loc i') + | RIR (r, IBop (i1, o, i2)) -> + printf "%s = %s %s %s" + regs.(r) (bop_str o) (loc i1) (loc i2) + | RIR (_, IBrz (i', l1, l2)) -> + printf "brz %s %03d %03d" (loc i') + (inum l1) (inum l2) + | RIR (_, IJmp l) -> + printf "jmp %03d" (inum l) + | RIR (_, IPhi l) -> + printf "phi" + | RMove (t, f) -> + printf "%s = %s" (loc t) (loc f) + | _ -> () + end; + printf "\n" + done diff --git a/proto/lo2.ml b/proto/lo2.ml new file mode 100644 index 0000000..64bf3ae --- /dev/null +++ b/proto/lo2.ml @@ -0,0 +1,713 @@ +type uop = Neg +type bop = Add | Sub | Mul | Div | Rem | CLe | CEq + +type bref = int (* Block references. *) +type 'op seqi = [ `Con of int | `Uop of uop * 'op | `Bop of 'op * bop * 'op ] +type 'op jmpi = [ `Brz of 'op * bref * bref | `Jmp of bref | `Ret of 'op ] + +type ('ins, 'phi, 'jmp) bb = + { mutable bb_name: string + ; mutable bb_phis: 'phi array + ; mutable bb_inss: 'ins array + ; mutable bb_jmp: 'jmp + } + + +(* ** Liveness analysis. ** *) +type iref = IRPhi of (bref * int) | IRIns of (bref * int) +let blk = function IRPhi (b, _) | IRIns (b, _) -> b +type iprog = (iref seqi, [`Phi of iref list], iref jmpi) bb array + +module IRSet = Set.Make( + struct type t = iref let compare = compare end +) + +let liveout lh ir = + try Hashtbl.find lh ir with Not_found -> + let e = IRSet.empty in Hashtbl.add lh ir e; e +let livein lh p ir = + let gen (b, i) = IRSet.of_list begin + let {bb_inss; bb_jmp; _} = p.(b) in + if i = -1 then [] else + if i = Array.length bb_inss + then match bb_jmp with + | `Brz (i1, _, _) | `Ret i1 -> [i1] + | `Jmp _ -> [] + else match bb_inss.(i) with + | `Uop (_, i1) -> [i1] + | `Bop (i1, _, i2) -> [i1; i2] + | `Con _ -> [] + end in + let kill ((b, i) as ir) = + if i >= 0 then IRSet.singleton (IRIns ir) else + fst (Array.fold_left + (fun (k, i) _ -> (IRSet.add (IRPhi (b, i)) k, i+1)) + (IRSet.empty, 0) p.(b).bb_phis + ) in + let s = liveout lh ir in + let s = IRSet.union s (gen ir) in + IRSet.diff s (kill ir) + +let liveness (p: iprog) = + let module H = Hashtbl in + let changed = ref true in (* Witness for fixpoint. *) + let nbb = Array.length p in + let lh = H.create 1001 in + let setlive ir ir' = (* Mark ir live at ir'. *) + let lir' = liveout lh ir' in + if not (IRSet.mem ir lir') then begin + changed := true; + H.replace lh ir' (IRSet.add ir lir'); + end in + let succs (b, i) = (* Successor nodes of an instruction. *) + let {bb_inss; bb_jmp; _} = p.(b) in + if i = Array.length bb_inss then + if b+1 = nbb then [] else + match bb_jmp with + | `Brz (_, b1, b2) -> [(b1, -1); (b2, -1)] + | `Jmp b1 -> [(b1, -1)] + | `Ret _ -> [] + else [(b, i+1)] in + while !changed do + changed := false; + for b = nbb - 1 downto 0 do + let bb = p.(b) in + for i = Array.length bb.bb_inss downto -1 do + let ir = (b, i) in + let live = List.fold_left (fun live ir' -> + IRSet.union live (livein lh p ir') + ) IRSet.empty (succs ir) in + IRSet.iter (fun ir' -> setlive ir' ir) live + done; + Array.iter (fun (`Phi il) -> + List.iter (fun ir -> + let br = blk ir in + setlive ir (br, Array.length p.(br).bb_inss) + ) il + ) bb.bb_phis; + done + done; + lh (* Return the final hash table. *) + + +(* ** Register allocation. ** *) +type loc = LVoid | LReg of int | LSpill of int | LCon of int +type 'op rins = { ri_res: 'op; ri_ins: [ 'op seqi | `Mov of 'op ] } +type 'op rphi = { rp_res: 'op; rp_spill: int option; rp_list: (bref * loc) list } +type rprog = (loc rins, loc rphi, loc jmpi) bb array + +let nregs = ref 3 +let regalloc (p: iprog): rprog = + let module H = struct + include Hashtbl + let find h ir = + try find h ir with Not_found -> + let k = ref 0 in + let isconst = function + `Con c -> k := c; true | _ -> false in + match ir with + | IRIns (b, i) when isconst p.(b).bb_inss.(i) -> LCon !k + | _ -> LVoid + end in + + let lh = liveness p in + let nbb = Array.length p in + let rp = Array.init nbb (fun i -> + { bb_name = p.(i).bb_name + ; bb_phis = [| |] + ; bb_inss = [| |] + ; bb_jmp = `Jmp (-1) + } + ) in + let outmaps = Array.make nbb [] in + let inmaps = Array.make nbb [] in + let bb = ref [] in (* Basic block in construction. *) + let emiti l i = bb := {ri_res=l; ri_ins=i} :: !bb in + let act = H.create 101 in (* The active list. *) + let regs = Array.init !nregs (fun i -> i) |> Array.to_list in + let free = ref regs in (* Free registers. *) + + let nspill = ref 0 in + let newspill () = incr nspill; !nspill - 1 in + let getspill ir = + match H.find act ir with + | LSpill s -> s + | _ -> -1 in + + let kill ir = + match H.find act ir with + | LReg r -> H.remove act ir; free := r :: !free + | _ -> H.remove act ir in + + let loc ir = + match H.find act ir with + | LVoid -> + let l = + match !free with + | r :: f -> free := f; LReg r + | [] -> LSpill (newspill ()) + in + H.add act ir l; l + | l -> l in + + let rec getreg frz = (* Aggressively obtain one register. *) + match !free with + | r :: f when List.mem r frz -> (* Frozen, can't use it. *) + free := f; + let r' = getreg frz in + free := r :: !free; r' + | r :: f -> free := f; r + | [] -> (* Spill needed! *) + match + H.fold (fun ir loc l -> (* Find candidates. *) + match loc with + | LReg r when not (List.mem r frz) -> + (ir, r) :: l + | _ -> l + ) act [] (* |> sort by spill cost *) + with [] -> failwith "god damn it, not enough registers" + | (ir, r) :: _ -> + H.remove act ir; + let s = getspill ir in + let s = + if s >= 0 then s else + let s' = newspill () in + H.add act ir (LSpill s'); s' in + emiti (LReg r) (`Mov (LSpill s)); + r in + + let getreg frz = + let r = getreg frz in + assert (not (List.mem r !free)); + r in + + let regloc frz ir = + match H.find act ir with + | (LCon _ | LReg _) as loc -> loc + | _ -> + let r = getreg frz in + H.add act ir (LReg r); + LReg r in + + for b = nbb - 1 downto 0 do + let bi = p.(b).bb_inss in + let bl = Array.length bi in + + (* Fill outmaps with the allocation state at + * the end of the block (after the final branch). + *) + let lvout = liveout lh (b, bl) in + outmaps.(b) <- begin + IRSet.fold (fun ir m -> (ir, loc ir) :: m) lvout [] + end; + + let jmp = + match p.(b).bb_jmp with + | `Jmp br -> `Jmp br + | `Ret (ir) -> `Ret (loc ir) + | `Brz (ir, br1, br2) -> + `Brz (loc ir, br1, br2) in + rp.(b).bb_jmp <- jmp; + + for i = bl - 1 downto 0 do + let ir = IRIns (b, i) in + begin match H.find act ir with + | LCon _ | LVoid -> () (* Dead code. *) + | lir -> + let r, frz = + match lir with + | LSpill s -> + let frz = + let block ir l = + match H.find act ir with + | LReg r -> r :: l + | _ -> l in + match bi.(i) with + | `Uop (_, ir) -> + [] |> block ir + | `Bop (ir1, _, ir2) -> + [] |> block ir1 |> block ir2 + | _ -> [] in + let r = getreg frz in + free := r :: !free; (* Add it straight back to free, but freeze it. *) + (r, [r]) + | LReg r -> kill ir; (r, []) + | _ -> assert false + in + let s = getspill ir in + begin match bi.(i) with + | `Con k -> () + | `Uop (op, ir') -> + let l' = regloc frz ir' in + if s >= 0 then emiti (LSpill s) (`Mov (LReg r)); + emiti (LReg r) (`Uop (op, l')) + | `Bop (ir1, op, ir2) -> + (* Special case: Division uses RDX, we + * need to make sure it is free for use. + *) + let rdx = 1 in + if (op = Div || op = Rem) && not (List.mem rdx !free) then + getreg (List.filter ((<>) rdx) regs) |> ignore + else + free := (List.filter ((<>) rdx) !free); + let l1 = regloc frz ir1 in + let frz = match l1 with + | LReg r1 -> r1 :: frz + | _ -> frz in + let l2 = regloc frz ir2 in + if s >= 0 then emiti (LSpill s) (`Mov (LReg r)); + emiti (LReg r) (`Bop (l1, op, l2)); + if op = Div || op = Rem then + free := rdx :: !free; + end; + end + done; + + let lvin = liveout lh (b, -1) in + inmaps.(b) <- begin + IRSet.fold (fun ir l -> + let loc = H.find act ir in + if blk ir = b then + kill ir; (* Kill current block's phis *) + let s = getspill ir in + kill ir; + if s >= 0 then + (ir, (loc, Some s)) :: l + else + (ir, (loc, None)) :: l + ) lvin [] + end; + + rp.(b).bb_inss <- Array.of_list !bb; + bb := []; + done; + + (* Compute phis. *) + for b = 0 to nbb - 1 do + rp.(b).bb_phis <- Array.of_list begin + IRSet.fold (fun ir l -> + match ir with + | IRPhi (b', pr) when b' = b -> + let `Phi pl = p.(b).bb_phis.(pr) in + let pl = + let f ir = + let b = blk ir in + (b, List.assoc ir outmaps.(b)) in + List.map f pl |> + List.sort (fun (a,_) (b,_) -> compare a b) in + let res, spl = List.assoc ir inmaps.(b) in + { rp_res = res + ; rp_spill = spl + ; rp_list = pl + } :: l + | _ -> assert (blk ir <> b); + (* Forgive me, I sin!! *) + let rl = ref [] in + for b = 0 to nbb - 1 do + let bl = Array.length p.(b).bb_inss in + if IRSet.mem ir (liveout lh (b, bl)) then + rl := (b, List.assoc ir outmaps.(b)) :: !rl + done; + { rp_res = fst (List.assoc ir inmaps.(b)) + ; rp_spill = None + ; rp_list = List.rev !rl + } :: l + ) (liveout lh (b, -1)) [] + end + done; + + rp + + +(* ** Phi resolution. ** *) +(* Machine program, ready for code generation. *) +type mprog = (loc rins, unit, loc jmpi) bb array + +let movgen (p: rprog): mprog = + + let parmov b b' = + let tmp = LReg (-1) in + let src, dst = + let phis = p.(b').bb_phis in + Array.map (fun x -> List.assoc b x.rp_list) phis, + Array.map (fun x -> x.rp_res) phis in + let n = Array.length dst in + let status = Array.make n `ToMove in + let ms = ref [] in + let emov dst src = + ms := {ri_res = dst; ri_ins = `Mov src} :: !ms in + let rec mv i = + if src.(i) <> dst.(i) then begin + status.(i) <- `Moving; + for j = 0 to n - 1 do + if src.(j) = dst.(i) then + match status.(j) with + | `ToMove -> mv j + | `Moving -> emov tmp src.(j); src.(j) <- tmp + | `Moved -> () + done; + emov dst.(i) src.(i); + status.(i) <- `Moved; + end in + for i = 0 to n - 1 do + if status.(i) = `ToMove then mv i + done; + Array.iter (fun {rp_res; rp_spill} -> + match rp_spill with + | Some spl when LSpill spl <> rp_res -> + emov (LSpill spl) rp_res + | _ -> () + ) p.(b').bb_phis; + List.rev !ms |> Array.of_list in + + let nbb = Array.length p in + let bmap = Array.init nbb (fun i -> -i - 1) in + let bn = ref 0 in + let mp = ref [] in + let addb b = mp := b :: !mp; incr bn; !bn - 1 in + + for b = 0 to nbb - 1 do + let b' = + { bb_name = p.(b).bb_name + ; bb_phis = [| |] + ; bb_inss = p.(b).bb_inss + ; bb_jmp = `Jmp (-1) + } in + bmap.(b) <- addb b'; + let movbb suff jb = + if jb = -1 then -1 else + let c = parmov b jb in + if c = [| |] then bmap.(jb) else + addb + { bb_name = p.(b).bb_name ^ suff + ; bb_phis = [| |] + ; bb_inss = c + ; bb_jmp = `Jmp bmap.(jb) + } in + b'.bb_jmp <- begin + match p.(b).bb_jmp with + | `Jmp b1 -> `Jmp (movbb "_mov" b1) + | `Ret (l) -> `Ret (l) + | `Brz (l, b1, b2) -> + let b1', b2' = + if b1 = b + 1 then + let b2' = movbb "_mov2" b2 in + let b1' = movbb "_mov1" b1 in + (b1', b2') + else + let b1' = movbb "_mov1" b1 in + let b2' = movbb "_mov2" b2 in + (b1', b2') in + `Brz (l, b1', b2') + end; + done; + List.rev !mp + |> Array.of_list + |> Array.map (fun b -> + let f n = + if n >= -1 then n else bmap.(-n - 1) in + { b with bb_jmp = + match b.bb_jmp with + | `Ret (l) -> `Ret (l) + | `Jmp b1 -> `Jmp (f b1) + | `Brz (l, b1, b2) -> `Brz (l, f b1, f b2) + } + ) + + +(* ** X86-64 code generation. ** *) +let codegen (p: mprog): string = + let cl = ref [] and off = ref 0 in + let outs s = cl := s :: !cl; off := !off + String.length s in + let outb b = outs (String.make 1 (Char.chr b)) in + + (* output prelude *) + outb 0x55; (* push %rbp *) + outs "\x48\x89\xe5"; (* mov %rsp, %rbp *) + + let regmap = [| (* only caller-save regs, for now *) + 0; (* rax *) + 1; (* rcx *) + 2; (* rdx *) (* comes late because of division *) + (* look for RDX and change there too! *) + 6; (* rsi *) + 7; (* rdi *) + 8; (* r8 *) + 9; (* r9 *) + 10; (* r10 *) + 11; (* r11 *) + |] in + let regn = function + | LReg r -> regmap.(r+1) + | _ -> failwith "register expected in regn" in + + let rexp rg rm = + let rex = 0x48 in + let rg, rex = if rg > 7 + then rg-8, rex lor 4 + else rg, rex in + let rm, rex = if rm > 7 + then rm-8, rex lor 1 + else rm, rex in + (rex, rg, rm) in + + let modrm ?(md=3) r m = + (md lsl 6) + (r lsl 3) + m in + + let lite ?byt x = + let byt = match byt with + Some b -> b | None -> Bytes.create 4 in + let rec f i x = + if i = 4 then () else begin + Bytes.set byt i (Char.chr (x land 0xff)); + f (i+1) (x lsr 8) + end in + f 0 x; Bytes.unsafe_to_string byt in + + let oins op r m = + let rex, r, m = rexp r m in + outb rex; outb op; outb (modrm r m) in + + let slot s = + let c = ((-1-s) * 8) land 0xff in + assert (c < 256); + c in + + let move l l1 = match l, l1 with + | (LReg _ as r), LCon k -> + oins 0xc7 0 (regn r); outs (lite k) + | LSpill s, LCon k -> + outb 0x48; + outb 0xc7; + outb (modrm ~md:1 0 5); + outb (slot s); + outs (lite k) + | (LReg _ as r), (LReg _ as r1) -> + let rex, r1, r = rexp (regn r1) (regn r) in + outb rex; outb 0x89; outb (modrm r1 r) + | (LReg _ as r), LSpill s -> + let rex, r, m = rexp (regn r) 5 in + outb rex; outb 0x8b; outb (modrm ~md:1 r m); outb (slot s) + | LSpill s, (LReg _ as r) -> + let rex, r, m = rexp (regn r) 5 in + outb rex; outb 0x89; outb (modrm ~md:1 r m); outb (slot s) + | _ -> failwith "invalid move" in + + let nbb = Array.length p in + let boffs = Array.make nbb (`Unk []) in + let label b = + let p0 = !off + 4 in + match boffs.(b) with + | `Unk l -> + let lbl = lite p0 in + boffs.(b) <- `Unk (lbl :: l); + lbl + | `Kno p -> lite (p - p0) in + + for b = 0 to nbb - 1 do + let pl = + match boffs.(b) with + | `Unk pl -> pl | _ -> [] in + List.iter (fun s -> (* back-patching *) + let p = + Char.code s.[0] + + Char.code s.[1] lsl 8 + + Char.code s.[2] lsl 16 + + Char.code s.[3] lsl 24 in + let byt = Bytes.unsafe_of_string s in + ignore (lite ~byt (!off - p)) + ) pl; + boffs.(b) <- `Kno !off; + + let is = p.(b).bb_inss in + for i = 0 to Array.length is - 1 do + match is.(i) with + | { ri_res = l; ri_ins = `Bop (l1, op, l2) } -> + let l2 = + if l1 = l || op = Div || op = Rem then l2 else + if l2 = l then begin + move (LReg (-1)) l; + move l l1; + LReg (-1) + end else + (move l l1; l2) in + begin match op with + | Add -> + begin match l2 with + | LCon k -> oins 0x81 0 (regn l); outs (lite k) + | LReg _ -> oins 0x01 (regn l2) (regn l) + | _ -> assert false + end + | Sub -> + begin match l2 with + | LCon k -> oins 0x81 5 (regn l); outs (lite k) + | LReg _ -> oins 0x29 (regn l2) (regn l) + | _ -> assert false + end + | Div -> + move (LReg (-1)) l1; + outb 0x99; (* cltd *) + oins 0xf7 7 (regn l2); + move l (LReg (-1)); (* quotient in rax *) + | Rem -> + move (LReg (-1)) l1; + outb 0x99; (* cltd *) + oins 0xf7 7 (regn l2); + if l <> LReg 1 then (* RDX *) + move l (LReg 1); (* remainder in rdx *) + | Mul -> failwith "Mul not implemented" + | CLe -> failwith "CLe not implemented" + | CEq -> failwith "CEq not implemented" + end + | { ri_res = l; ri_ins = `Uop (Neg, l1) } -> + if l <> l1 then + move l l1; + oins 0xf7 3 (regn l) + | { ri_res = l; ri_ins = `Mov l1 } -> + move l l1 + | { ri_res = l; ri_ins = `Con k } -> + move l (LCon k) + done; + + begin match p.(b).bb_jmp with + | `Brz (r, b1, b2) when b1 >= 0 && b2 >= 0 -> + oins 0x85 (regn r) (regn r); + if b1 = b+1 then + (outb 0x0f; outb 0x85; outs (label b2)) + else if b2 = b+1 then + (outb 0x0f; outb 0x84; outs (label b1)) + else + failwith "double branch" + | `Jmp b1 when b1 >= 0 -> + if b1 <> b+1 then + (outb 0xe9; outs (label b1)) + | `Ret (l) -> + move (LReg (-1)) l; + outb 0x5d; (* pop %rbp *) + outb 0xc3; (* retq *) + | _ -> () + end + done; + + String.concat "" (List.rev !cl) + + +(* Little test programs. *) +let pbasic: iprog = + [| { bb_name = "start" + ; bb_phis = [| |] + ; bb_inss = + [| `Con 2 + ; `Con 3 + ; `Bop (IRIns (0, 0), Add, IRIns (0, 1)) + ; `Bop (IRIns (0, 0), Add, IRIns (0, 2)) + |] + ; bb_jmp = `Ret (IRIns (0, 3)) + } + |] + +let pcount: iprog = + [| { bb_name = "init" + ; bb_phis = [||] + ; bb_inss = [| `Con 1234567; `Con 1 |] + ; bb_jmp = `Jmp 1 + } + ; { bb_name = "loop" + ; bb_phis = [| `Phi [IRIns (0, 0); IRIns (1, 0)] |] + ; bb_inss = [| `Bop (IRPhi (1, 0), Sub, IRIns (0, 1)) |] + ; bb_jmp = `Brz (IRIns (1, 0), 2, 1) + } + ; { bb_name = "end" + ; bb_phis = [||] + ; bb_inss = [| `Con 42 |] + ; bb_jmp = `Ret (IRIns (0,1)) + } + |] + +let psum: iprog = + [| { bb_name = "init" + ; bb_phis = [||] + ; bb_inss = [| `Con 1234567; `Con 1; `Con 0 |] + ; bb_jmp = `Jmp 1 + } + ; { bb_name = "loop" + ; bb_phis = + [| `Phi [IRIns (0, 0); IRIns (1, 0)] (* n = phi(100, n1) *) + ; `Phi [IRIns (0, 2); IRIns (1, 1)] (* s = phi(1, s1) *) + |] + ; bb_inss = + [| `Bop (IRPhi (1, 0), Sub, IRIns (0, 1)) (* n1 = n - 1 *) + ; `Bop (IRPhi (1, 1), Add, IRPhi (1, 0)) (* s1 = s + n *) + |] + ; bb_jmp = `Brz (IRIns (1, 0), 2, 1) + } + ; { bb_name = "end" + ; bb_phis = [||] + ; bb_inss = [| `Con 42 |] + ; bb_jmp = `Ret (IRIns (1,1)) + } + |] + +let peucl: iprog = + [| { bb_name = "init" + ; bb_phis = [||] + ; bb_inss = [| `Con 123456; `Con 32223 |] + ; bb_jmp = `Jmp 1 + } + ; { bb_name = "loop" + ; bb_phis = + [| `Phi [IRIns (0, 0); IRPhi (1, 1)] + ; `Phi [IRIns (0, 1); IRIns (1, 0)] + |] + ; bb_inss = + [| `Bop (IRPhi (1, 0), Rem, IRPhi (1, 1)) + |] + ; bb_jmp = `Brz (IRIns (1, 0), 2, 1) + } + ; { bb_name = "end" + ; bb_phis = [||] + ; bb_inss = [||] + ; bb_jmp = `Ret (IRPhi (1, 1)) + } + |] + +let pspill: iprog = + [| { bb_name = "init" + ; bb_phis = [||] + ; bb_inss = +(* 00 *) [| `Con 42 +(* 01 *) ; `Bop (IRIns (0, 0), Add, IRIns (0, 0)) +(* 02 *) ; `Bop (IRIns (0, 0), Add, IRIns (0, 1)) +(* 03 *) ; `Bop (IRIns (0, 0), Add, IRIns (0, 2)) +(* 04 *) ; `Bop (IRIns (0, 0), Add, IRIns (0, 3)) +(* 05 *) ; `Bop (IRIns (0, 0), Add, IRIns (0, 4)) +(* 06 *) ; `Bop (IRIns (0, 0), Add, IRIns (0, 5)) +(* 07 *) ; `Bop (IRIns (0, 6), Add, IRIns (0, 6)) +(* 08 *) ; `Bop (IRIns (0, 5), Add, IRIns (0, 7)) +(* 09 *) ; `Bop (IRIns (0, 4), Add, IRIns (0, 8)) +(* 10 *) ; `Bop (IRIns (0, 3), Add, IRIns (0, 9)) +(* 11 *) ; `Bop (IRIns (0, 2), Add, IRIns (0, 10)) +(* 12 *) ; `Bop (IRIns (0, 1), Add, IRIns (0, 11)) +(* 13 *) ; `Bop (IRIns (0, 0), Add, IRIns (0, 12)) + |] + ; bb_jmp = `Ret (IRIns (0, 13)) + } + |] + + +(* ------------------------------------------------------------------------ *) + +let oneshot () = + () + +let _ = + if Array.length Sys.argv > 1 && Sys.argv.(1) = "test" then + let oc = open_out "t.o" in + nregs := 3; + let s = peucl |> regalloc |> movgen |> codegen in + Elf.barebones_elf oc "f" s; + close_out oc; + else + oneshot () + +(* ------------------------------------------------------------------------ *) diff --git a/proto/tmain.c b/proto/tmain.c new file mode 100644 index 0000000..79e1c24 --- /dev/null +++ b/proto/tmain.c @@ -0,0 +1,24 @@ +#include +#include + +enum { NRounds = 150 }; + +extern long f(void); + +int main() +{ + clock_t t0, tmin; + long i, l; + + tmin = 10 * CLOCKS_PER_SEC; + for (i=0; i -#include - -enum { NRounds = 150 }; - -extern long f(void); - -int main() -{ - clock_t t0, tmin; - long i, l; - - tmin = 10 * CLOCKS_PER_SEC; - for (i=0; i