diff options
| -rw-r--r-- | proto/.gitignore | 4 | ||||
| -rw-r--r-- | proto/Makefile | 11 | ||||
| -rw-r--r-- | proto/TODO | 54 | ||||
| -rw-r--r-- | proto/bak.ml | 132 | ||||
| -rw-r--r-- | proto/ctests/eucl.c | 17 | ||||
| -rw-r--r-- | proto/ctests/pspill.c | 20 | ||||
| -rw-r--r-- | proto/ctests/psum.c | 13 | ||||
| -rw-r--r-- | proto/elf.ml | 200 | ||||
| -rw-r--r-- | proto/heap.ml | 60 | ||||
| -rw-r--r-- | proto/lo.ml | 478 | ||||
| -rw-r--r-- | proto/lo2.ml | 713 | ||||
| -rw-r--r-- | proto/tmain.c | 24 |
12 files changed, 0 insertions, 1726 deletions
diff --git a/proto/.gitignore b/proto/.gitignore deleted file mode 100644 index 2dc12a1..0000000 --- a/proto/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -bak -*.o -*.cm[io] -t.out diff --git a/proto/Makefile b/proto/Makefile deleted file mode 100644 index f137b4a..0000000 --- a/proto/Makefile +++ /dev/null @@ -1,11 +0,0 @@ -.PHONY: test clean - -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 deleted file mode 100644 index e144c66..0000000 --- a/proto/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/proto/bak.ml b/proto/bak.ml deleted file mode 100644 index cd1aff2..0000000 --- a/proto/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/proto/ctests/eucl.c b/proto/ctests/eucl.c deleted file mode 100644 index fd2e9c9..0000000 --- a/proto/ctests/eucl.c +++ /dev/null @@ -1,17 +0,0 @@ -#include <stdio.h> - -int main() -{ - int a = 123456; - int b = 32223; - int t; - - do { - t = a % b; - a = b; - b = t; - } while (b); - - printf("%d\n", a); - return 0; -} diff --git a/proto/ctests/pspill.c b/proto/ctests/pspill.c deleted file mode 100644 index d3dfba8..0000000 --- a/proto/ctests/pspill.c +++ /dev/null @@ -1,20 +0,0 @@ -long f() { - long l00, l01, l02, l03, l04, l05, l06, l07, l08, l09, l10, l11, l12, l13; - - l00 = 42; - l01 = l00 + l00; - l02 = l00 + l01; - l03 = l00 + l02; - l04 = l00 + l03; - l05 = l00 + l04; - l06 = l00 + l05; - l07 = l06 + l06; - l08 = l05 + l07; - l09 = l04 + l08; - l10 = l03 + l09; - l11 = l02 + l10; - l12 = l01 + l11; - l13 = l00 + l12; - - return l13; -} diff --git a/proto/ctests/psum.c b/proto/ctests/psum.c deleted file mode 100644 index 4ea6a03..0000000 --- a/proto/ctests/psum.c +++ /dev/null @@ -1,13 +0,0 @@ -long f() { - long n, n0, s; - - s = 0; - n = 1234567; - for (;;) { - n0 = n - 1; - s = s + n; - if (!n0) break; - n = n0; - } - return s; -} diff --git a/proto/elf.ml b/proto/elf.ml deleted file mode 100644 index d83f4fd..0000000 --- a/proto/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/proto/heap.ml b/proto/heap.ml deleted file mode 100644 index 79081b9..0000000 --- a/proto/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/proto/lo.ml b/proto/lo.ml deleted file mode 100644 index be2323d..0000000 --- a/proto/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/proto/lo2.ml b/proto/lo2.ml deleted file mode 100644 index 64bf3ae..0000000 --- a/proto/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/tmain.c b/proto/tmain.c deleted file mode 100644 index 79e1c24..0000000 --- a/proto/tmain.c +++ /dev/null @@ -1,24 +0,0 @@ -#include <stdio.h> -#include <time.h> - -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<NRounds; i++) { - t0 = clock(); - l = f(); - t0 = clock() - t0; - if (t0 < tmin) - tmin = t0; - } - printf("f() = %ld\n", l); - printf(" %.4f secs\n", (double)t0/CLOCKS_PER_SEC); - return 0; -} |