commit 96251837db7c698a76d997f1449f0cd47885f203
parent 86dfca58460639f9a969aa312f0adf17e79be1f0
Author: Quentin Carbonneaux <quentin.carbonneaux@yale.edu>
Date: Thu, 11 Feb 2016 10:33:44 -0500
leave the prototype to git history
Diffstat:
12 files changed, 0 insertions(+), 1726 deletions(-)
diff --git a/proto/.gitignore b/proto/.gitignore
@@ -1,4 +0,0 @@
-bak
-*.o
-*.cm[io]
-t.out
diff --git a/proto/Makefile b/proto/Makefile
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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;
-}
