qbe in native build
This commit is contained in:
110
src/qbe/tools/abi8.py
Executable file
110
src/qbe/tools/abi8.py
Executable file
@@ -0,0 +1,110 @@
|
||||
#!/usr/bin/python3
|
||||
|
||||
# support script to create
|
||||
# the abi8.ssa test
|
||||
|
||||
def ctype(arg):
|
||||
if arg[0] == 'p': return ctype(arg[1:])
|
||||
if arg[0] == ':': return 'S' + arg[1:]
|
||||
return {'w':'int', 'l':'long',
|
||||
's':'float', 'd':'double'}[arg]
|
||||
|
||||
def cparam(iarg):
|
||||
return ctype(iarg[1]) + ' p' + str(iarg[0])
|
||||
|
||||
def gencfn(id, args):
|
||||
out = '# extern void qfn' + id + '('
|
||||
out += ', '.join(map(ctype, args)) + ');\n'
|
||||
out += '# void cfn' + id + '('
|
||||
out += ', '.join(map(cparam, enumerate(args)))
|
||||
out += ') {\n'
|
||||
out += '# \tprintf("qbe->c(%d)", ' + id + ');\n'
|
||||
out += '# \t'
|
||||
for (i, arg) in enumerate(args):
|
||||
if arg[0] != 'p': continue
|
||||
ty = arg[1:]
|
||||
if ty[0] == ':':
|
||||
out += 'p' + ty[1:] + '(&'
|
||||
else:
|
||||
out += 'p' + ty + '('
|
||||
out += 'p' + str(i) + '); '
|
||||
out += 'puts("");\n'
|
||||
out += '# \tqfn' + id + '('
|
||||
out += ', '.join('p'+str(i) for i in range(len(args)))
|
||||
out += ');\n'
|
||||
out += '# }\n'
|
||||
return out
|
||||
|
||||
def qparam(iarg):
|
||||
ty = iarg[1][1:] if iarg[1][0] == 'p' else iarg[1]
|
||||
return ty + ' %p' + str(iarg[0])
|
||||
|
||||
def genqfn(id, args):
|
||||
out = 'export\nfunction $qfn' + id + '('
|
||||
out += ', '.join(map(qparam, enumerate(args)))
|
||||
out += ') {\n'
|
||||
out += '@start\n'
|
||||
out += '\t%r0 =w call $printf(l $ctoqbestr, w ' + id + ')\n'
|
||||
for (i, arg) in enumerate(args):
|
||||
if arg[0] != 'p': continue
|
||||
ty = arg[1:]
|
||||
if ty[0] == ':':
|
||||
out += '\tcall $p' + ty[1:]
|
||||
out += '(l %p' + str(i) + ')\n'
|
||||
else:
|
||||
out += '\tcall $p' + ty
|
||||
out += '(' + ty + ' %p' + str(i) + ')\n'
|
||||
out += '\t%r1 =w call $puts(l $emptystr)\n'
|
||||
out += '\tret\n'
|
||||
out += '}\n'
|
||||
return out
|
||||
|
||||
def carg(iarg):
|
||||
i, arg = iarg
|
||||
print = arg[0] == 'p'
|
||||
ty = arg if not print else arg[1:]
|
||||
if ty[0] == ':':
|
||||
if print:
|
||||
return ty + ' $' + ty[1:]
|
||||
else:
|
||||
return ty + ' $z' + ty[1:]
|
||||
if not print:
|
||||
return ty + ' 0'
|
||||
if ty == 'w' or ty == 'l':
|
||||
return ty + ' ' + str(i+1)
|
||||
if ty == 's' or ty == 'd':
|
||||
flt = str(i+1) + '.' + str(i+1)
|
||||
return ty + ' ' + ty + '_' + flt
|
||||
|
||||
def genmaincall(id, args):
|
||||
out = '\tcall $cfn' + id + '('
|
||||
out += ', '.join(map(carg, enumerate(args)))
|
||||
out += ')\n'
|
||||
return out
|
||||
|
||||
def gen(tvec):
|
||||
for i, t in enumerate(tvec):
|
||||
print(genqfn(str(i), t), end='')
|
||||
print('')
|
||||
for i, t in enumerate(tvec):
|
||||
print(genmaincall(str(i), t), end='')
|
||||
print('')
|
||||
for i, t in enumerate(tvec):
|
||||
print(gencfn(str(i), t), end='')
|
||||
|
||||
TVEC = [
|
||||
['s']*8 + ['ps'],
|
||||
['pw', 'ps', 'p:fi1'],
|
||||
['pw', 'p:fi2', 'ps'],
|
||||
['pw', 'ps', 'p:fi3'],
|
||||
['p:ss'],
|
||||
['d']*7 + ['p:ss', 'ps', 'pl'],
|
||||
['p:lb'],
|
||||
['w']*7 + ['p:lb'],
|
||||
['w']*8 + ['p:lb'],
|
||||
[ 'p:big' ],
|
||||
['w']*8 + ['p:big', 'ps', 'pl'],
|
||||
]
|
||||
|
||||
if __name__ == '__main__':
|
||||
gen(TVEC)
|
||||
107
src/qbe/tools/abifuzz.sh
Executable file
107
src/qbe/tools/abifuzz.sh
Executable file
@@ -0,0 +1,107 @@
|
||||
#!/bin/sh
|
||||
|
||||
OCAMLC=${OCAMLC:-/usr/bin/ocamlc}
|
||||
DIR=`cd $(dirname "$0"); pwd`
|
||||
QBE=$DIR/../qbe
|
||||
|
||||
failure() {
|
||||
echo "Failure at stage:" $1 >&2
|
||||
exit 1
|
||||
}
|
||||
|
||||
cleanup() {
|
||||
rm -fr $TMP
|
||||
}
|
||||
|
||||
init() {
|
||||
cp $DIR/callgen.ml $TMP
|
||||
pushd $TMP > /dev/null
|
||||
|
||||
cat > Makefile << EOM
|
||||
|
||||
.PHONY: test
|
||||
test: caller.o callee.o
|
||||
c99 -o \$@ caller.o callee.o
|
||||
%.o: %.c
|
||||
c99 -c -o \$@ \$<
|
||||
%.o: %.ssa
|
||||
$QBE -o \$*.s \$<
|
||||
c99 -c -o \$@ \$*.s
|
||||
|
||||
EOM
|
||||
|
||||
if ! $OCAMLC callgen.ml -o callgen
|
||||
then
|
||||
popd > /dev/null
|
||||
cleanup
|
||||
failure "abifuzz compilation"
|
||||
fi
|
||||
popd > /dev/null
|
||||
}
|
||||
|
||||
once() {
|
||||
if test -z "$3"
|
||||
then
|
||||
$TMP/callgen $TMP $1 $2
|
||||
else
|
||||
$TMP/callgen -s $3 $TMP $1 $2
|
||||
fi
|
||||
make -C $TMP test > /dev/null || failure "building"
|
||||
$TMP/test || failure "runtime"
|
||||
}
|
||||
|
||||
usage() {
|
||||
echo "usage: abitest.sh [-callssa] [-callc] [-s SEED] [-n ITERATIONS]" >&2
|
||||
exit 1
|
||||
}
|
||||
|
||||
N=1
|
||||
CALLER=c
|
||||
CALLEE=ssa
|
||||
|
||||
while test -n "$1"
|
||||
do
|
||||
case "$1" in
|
||||
"-callssa")
|
||||
CALLER=c
|
||||
CALLEE=ssa
|
||||
;;
|
||||
"-callc")
|
||||
CALLER=ssa
|
||||
CALLEE=c
|
||||
;;
|
||||
"-s")
|
||||
test -n "$2" || usage
|
||||
shift
|
||||
SEED="$1"
|
||||
;;
|
||||
"-n")
|
||||
test -n "$2" || usage
|
||||
shift
|
||||
N="$1"
|
||||
;;
|
||||
*)
|
||||
usage
|
||||
;;
|
||||
esac
|
||||
shift
|
||||
done
|
||||
|
||||
TMP=`mktemp -d abifuzz.XXXXXX`
|
||||
|
||||
init
|
||||
|
||||
if test -n "$S"
|
||||
then
|
||||
once $CALLER $CALLEE $SEED
|
||||
else
|
||||
for n in `seq $N`
|
||||
do
|
||||
once $CALLER $CALLEE
|
||||
echo "$n" | grep "00$"
|
||||
done
|
||||
fi
|
||||
|
||||
echo "All done."
|
||||
|
||||
cleanup
|
||||
535
src/qbe/tools/callgen.ml
Normal file
535
src/qbe/tools/callgen.ml
Normal file
@@ -0,0 +1,535 @@
|
||||
(* abi fuzzer, generates two modules one calling
|
||||
* the other in two possibly different languages
|
||||
*)
|
||||
|
||||
type _ bty =
|
||||
| Char: int bty
|
||||
| Short: int bty
|
||||
| Int: int bty
|
||||
| Long: int bty
|
||||
| Float: float bty
|
||||
| Double: float bty
|
||||
|
||||
type _ sty =
|
||||
| Field: 'a bty * 'b sty -> ('a * 'b) sty
|
||||
| Empty: unit sty
|
||||
|
||||
type _ aty =
|
||||
| Base: 'a bty -> 'a aty
|
||||
| Struct: 'a sty -> 'a aty
|
||||
|
||||
type anyb = AB: _ bty -> anyb (* kinda boring... *)
|
||||
type anys = AS: _ sty -> anys
|
||||
type anya = AA: _ aty -> anya
|
||||
type testb = TB: 'a bty * 'a -> testb
|
||||
type testa = TA: 'a aty * 'a -> testa
|
||||
|
||||
|
||||
let align a x =
|
||||
let m = x mod a in
|
||||
if m <> 0 then x + (a-m) else x
|
||||
|
||||
let btysize: type a. a bty -> int = function
|
||||
| Char -> 1
|
||||
| Short -> 2
|
||||
| Int -> 4
|
||||
| Long -> 8
|
||||
| Float -> 4
|
||||
| Double -> 8
|
||||
|
||||
let btyalign = btysize
|
||||
|
||||
let styempty: type a. a sty -> bool = function
|
||||
| Field _ -> false
|
||||
| Empty -> true
|
||||
|
||||
let stysize s =
|
||||
let rec f: type a. int -> a sty -> int =
|
||||
fun sz -> function
|
||||
| Field (b, s) ->
|
||||
let a = btyalign b in
|
||||
f (align a sz + btysize b) s
|
||||
| Empty -> sz in
|
||||
f 0 s
|
||||
|
||||
let rec styalign: type a. a sty -> int = function
|
||||
| Field (b, s) -> max (btyalign b) (styalign s)
|
||||
| Empty -> 1
|
||||
|
||||
|
||||
(* Generate types and test vectors. *)
|
||||
module Gen = struct
|
||||
module R = Random
|
||||
|
||||
let init = function
|
||||
| None ->
|
||||
let f = open_in "/dev/urandom" in
|
||||
let seed =
|
||||
Char.code (input_char f) lsl 16 +
|
||||
Char.code (input_char f) lsl 8 +
|
||||
Char.code (input_char f) in
|
||||
close_in f;
|
||||
R.init seed;
|
||||
seed
|
||||
| Some seed ->
|
||||
R.init seed;
|
||||
seed
|
||||
|
||||
let int sz =
|
||||
let bound = 1 lsl (8 * min sz 3 - 1) in
|
||||
let i = R.int bound in
|
||||
if R.bool () then - i else i
|
||||
|
||||
let float () =
|
||||
let f = R.float 1000. in
|
||||
if R.bool () then -. f else f
|
||||
|
||||
let testv: type a. a aty -> a =
|
||||
let tb: type a. a bty -> a = function (* eh, dry... *)
|
||||
| Float -> float ()
|
||||
| Double -> float ()
|
||||
| Char -> int (btysize Char)
|
||||
| Short -> int (btysize Short)
|
||||
| Int -> int (btysize Int)
|
||||
| Long -> int (btysize Long) in
|
||||
let rec ts: type a. a sty -> a = function
|
||||
| Field (b, s) -> (tb b, ts s)
|
||||
| Empty -> () in
|
||||
function
|
||||
| Base b -> tb b
|
||||
| Struct s -> ts s
|
||||
|
||||
let b () = (* uniform *)
|
||||
match R.int 6 with
|
||||
| 0 -> AB Char
|
||||
| 1 -> AB Short
|
||||
| 2 -> AB Int
|
||||
| 3 -> AB Long
|
||||
| 4 -> AB Float
|
||||
| _ -> AB Double
|
||||
|
||||
let smax = 5 (* max elements in structs *)
|
||||
let structp = 0.3 (* odds of having a struct type *)
|
||||
let amax = 8 (* max function arguments *)
|
||||
|
||||
let s () =
|
||||
let rec f n =
|
||||
if n = 0 then AS Empty else
|
||||
let AB bt = b () in
|
||||
let AS st = f (n-1) in
|
||||
AS (Field (bt, st)) in
|
||||
f (1 + R.int (smax-1))
|
||||
|
||||
let a () =
|
||||
if R.float 1.0 > structp then
|
||||
let AB bt = b () in
|
||||
AA (Base bt)
|
||||
else
|
||||
let AB bt = b () in
|
||||
let AS st = s () in
|
||||
AA (Struct (Field (bt, st)))
|
||||
|
||||
let test () =
|
||||
let AA ty = a () in
|
||||
let t = testv ty in
|
||||
TA (ty, t)
|
||||
|
||||
let tests () =
|
||||
let rec f n =
|
||||
if n = 0 then [] else
|
||||
test () :: f (n-1) in
|
||||
f (R.int amax)
|
||||
|
||||
end
|
||||
|
||||
|
||||
(* Code generation for C *)
|
||||
module OutC = struct
|
||||
open Printf
|
||||
|
||||
let ctypelong oc name =
|
||||
let cb: type a. a bty -> unit = function
|
||||
| Char -> fprintf oc "char"
|
||||
| Short -> fprintf oc "short"
|
||||
| Int -> fprintf oc "int"
|
||||
| Long -> fprintf oc "long"
|
||||
| Float -> fprintf oc "float"
|
||||
| Double -> fprintf oc "double" in
|
||||
let rec cs: type a. int -> a sty -> unit =
|
||||
fun i -> function
|
||||
| Field (b, s) ->
|
||||
cb b;
|
||||
fprintf oc " f%d; " i;
|
||||
cs (i+1) s;
|
||||
| Empty -> () in
|
||||
function
|
||||
| Base b ->
|
||||
cb b;
|
||||
| Struct s ->
|
||||
fprintf oc "struct %s { " name;
|
||||
cs 1 s;
|
||||
fprintf oc "}";
|
||||
()
|
||||
|
||||
let ctype: type a. out_channel -> string -> a aty -> unit =
|
||||
fun oc name -> function
|
||||
| Struct _ -> fprintf oc "struct %s" name
|
||||
| t -> ctypelong oc "" t
|
||||
|
||||
let base: type a. out_channel -> a bty * a -> unit =
|
||||
fun oc -> function
|
||||
| Char, i -> fprintf oc "%d" i
|
||||
| Short, i -> fprintf oc "%d" i
|
||||
| Int, i -> fprintf oc "%d" i
|
||||
| Long, i -> fprintf oc "%d" i
|
||||
| Float, f -> fprintf oc "%ff" f
|
||||
| Double, f -> fprintf oc "%f" f
|
||||
|
||||
let init oc name (TA (ty, t)) =
|
||||
let inits s =
|
||||
let rec f: type a. a sty * a -> unit = function
|
||||
| Field (b, s), (tb, ts) ->
|
||||
base oc (b, tb);
|
||||
fprintf oc ", ";
|
||||
f (s, ts)
|
||||
| Empty, () -> () in
|
||||
fprintf oc "{ ";
|
||||
f s;
|
||||
fprintf oc "}"; in
|
||||
ctype oc name ty;
|
||||
fprintf oc " %s = " name;
|
||||
begin match (ty, t) with
|
||||
| Base b, tb -> base oc (b, tb)
|
||||
| Struct s, ts -> inits (s, ts)
|
||||
end;
|
||||
fprintf oc ";\n";
|
||||
()
|
||||
|
||||
let extension = ".c"
|
||||
|
||||
let comment oc s =
|
||||
fprintf oc "/* %s */\n" s
|
||||
|
||||
let prelude oc = List.iter (fprintf oc "%s\n")
|
||||
[ "#include <stdio.h>"
|
||||
; "#include <stdlib.h>"
|
||||
; ""
|
||||
; "static void fail(char *chk)"
|
||||
; "{"
|
||||
; "\tfprintf(stderr, \"fail: checking %s\\n\", chk);"
|
||||
; "\tabort();"
|
||||
; "}"
|
||||
; ""
|
||||
]
|
||||
|
||||
let typedef oc name = function
|
||||
| TA (Struct ts, _) ->
|
||||
ctypelong oc name (Struct ts);
|
||||
fprintf oc ";\n";
|
||||
| _ -> ()
|
||||
|
||||
let check oc name =
|
||||
let chkbase: type a. string -> a bty * a -> unit =
|
||||
fun name t ->
|
||||
fprintf oc "\tif (%s != " name;
|
||||
base oc t;
|
||||
fprintf oc ")\n\t\tfail(%S);\n" name; in
|
||||
function
|
||||
| TA (Base b, tb) -> chkbase name (b, tb)
|
||||
| TA (Struct s, ts) ->
|
||||
let rec f: type a. int -> a sty * a -> unit =
|
||||
fun i -> function
|
||||
| Field (b, s), (tb, ts) ->
|
||||
chkbase (Printf.sprintf "%s.f%d" name i) (b, tb);
|
||||
f (i+1) (s, ts);
|
||||
| Empty, () -> () in
|
||||
f 1 (s, ts)
|
||||
|
||||
let argname i = "arg" ^ string_of_int (i+1)
|
||||
|
||||
let proto oc (TA (tret, _)) args =
|
||||
ctype oc "ret" tret;
|
||||
fprintf oc " f(";
|
||||
let narg = List.length args in
|
||||
List.iteri (fun i (TA (targ, _)) ->
|
||||
ctype oc (argname i) targ;
|
||||
fprintf oc " %s" (argname i);
|
||||
if i <> narg-1 then
|
||||
fprintf oc ", ";
|
||||
) args;
|
||||
fprintf oc ")";
|
||||
()
|
||||
|
||||
let caller oc ret args =
|
||||
let narg = List.length args in
|
||||
prelude oc;
|
||||
typedef oc "ret" ret;
|
||||
List.iteri (fun i arg ->
|
||||
typedef oc (argname i) arg;
|
||||
) args;
|
||||
proto oc ret args;
|
||||
fprintf oc ";\n\nint main()\n{\n";
|
||||
List.iteri (fun i arg ->
|
||||
fprintf oc "\t";
|
||||
init oc (argname i) arg;
|
||||
) args;
|
||||
fprintf oc "\t";
|
||||
let TA (tret, _) = ret in
|
||||
ctype oc "ret" tret;
|
||||
fprintf oc " ret;\n\n";
|
||||
fprintf oc "\tret = f(";
|
||||
List.iteri (fun i _ ->
|
||||
fprintf oc "%s" (argname i);
|
||||
if i <> narg-1 then
|
||||
fprintf oc ", ";
|
||||
) args;
|
||||
fprintf oc ");\n";
|
||||
check oc "ret" ret;
|
||||
fprintf oc "\n\treturn 0;\n}\n";
|
||||
()
|
||||
|
||||
let callee oc ret args =
|
||||
prelude oc;
|
||||
typedef oc "ret" ret;
|
||||
List.iteri (fun i arg ->
|
||||
typedef oc (argname i) arg;
|
||||
) args;
|
||||
fprintf oc "\n";
|
||||
proto oc ret args;
|
||||
fprintf oc "\n{\n\t";
|
||||
init oc "ret" ret;
|
||||
fprintf oc "\n";
|
||||
List.iteri (fun i arg ->
|
||||
check oc (argname i) arg;
|
||||
) args;
|
||||
fprintf oc "\n\treturn ret;\n}\n";
|
||||
()
|
||||
|
||||
end
|
||||
|
||||
(* Code generation for QBE *)
|
||||
module OutIL = struct
|
||||
open Printf
|
||||
|
||||
let comment oc s =
|
||||
fprintf oc "# %s\n" s
|
||||
|
||||
let tmp, lbl =
|
||||
let next = ref 0 in
|
||||
(fun () -> incr next; "%t" ^ (string_of_int !next)),
|
||||
(fun () -> incr next; "@l" ^ (string_of_int !next))
|
||||
|
||||
let bvalue: type a. a bty * a -> string = function
|
||||
| Char, i -> sprintf "%d" i
|
||||
| Short, i -> sprintf "%d" i
|
||||
| Int, i -> sprintf "%d" i
|
||||
| Long, i -> sprintf "%d" i
|
||||
| Float, f -> sprintf "s_%f" f
|
||||
| Double, f -> sprintf "d_%f" f
|
||||
|
||||
let btype: type a. a bty -> string = function
|
||||
| Char -> "w"
|
||||
| Short -> "w"
|
||||
| Int -> "w"
|
||||
| Long -> "l"
|
||||
| Float -> "s"
|
||||
| Double -> "d"
|
||||
|
||||
let extension = ".ssa"
|
||||
|
||||
let argname i = "arg" ^ string_of_int (i+1)
|
||||
|
||||
let siter oc base s g =
|
||||
let rec f: type a. int -> int -> a sty * a -> unit =
|
||||
fun id off -> function
|
||||
| Field (b, s), (tb, ts) ->
|
||||
let off = align (btyalign b) off in
|
||||
let addr = tmp () in
|
||||
fprintf oc "\t%s =l add %d, %s\n" addr off base;
|
||||
g id addr (TB (b, tb));
|
||||
f (id + 1) (off + btysize b) (s, ts);
|
||||
| Empty, () -> () in
|
||||
f 0 0 s
|
||||
|
||||
let bmemtype b =
|
||||
if AB b = AB Char then "b" else
|
||||
if AB b = AB Short then "h" else
|
||||
btype b
|
||||
|
||||
let init oc = function
|
||||
| TA (Base b, tb) -> bvalue (b, tb)
|
||||
| TA (Struct s, ts) ->
|
||||
let base = tmp () in
|
||||
fprintf oc "\t%s =l alloc%d %d\n"
|
||||
base (styalign s) (stysize s);
|
||||
siter oc base (s, ts)
|
||||
begin fun _ addr (TB (b, tb)) ->
|
||||
fprintf oc "\tstore%s %s, %s\n"
|
||||
(bmemtype b) (bvalue (b, tb)) addr;
|
||||
end;
|
||||
base
|
||||
|
||||
let check oc id name =
|
||||
let bcheck = fun id name (b, tb) ->
|
||||
let tcmp = tmp () in
|
||||
let nxtl = lbl () in
|
||||
fprintf oc "\t%s =w ceq%s %s, %s\n"
|
||||
tcmp (btype b) name (bvalue (b, tb));
|
||||
fprintf oc "\tstorew %d, %%failcode\n" id;
|
||||
fprintf oc "\tjnz %s, %s, @fail\n" tcmp nxtl;
|
||||
fprintf oc "%s\n" nxtl; in
|
||||
function
|
||||
| TA (Base Char, i) ->
|
||||
let tval = tmp () in
|
||||
fprintf oc "\t%s =w extsb %s\n" tval name;
|
||||
bcheck id tval (Int, i)
|
||||
| TA (Base Short, i) ->
|
||||
let tval = tmp () in
|
||||
fprintf oc "\t%s =w extsh %s\n" tval name;
|
||||
bcheck id tval (Int, i)
|
||||
| TA (Base b, tb) ->
|
||||
bcheck id name (b, tb)
|
||||
| TA (Struct s, ts) ->
|
||||
siter oc name (s, ts)
|
||||
begin fun id' addr (TB (b, tb)) ->
|
||||
let tval = tmp () in
|
||||
let lsuffix =
|
||||
if AB b = AB Char then "sb" else
|
||||
if AB b = AB Short then "sh" else
|
||||
"" in
|
||||
fprintf oc "\t%s =%s load%s %s\n"
|
||||
tval (btype b) lsuffix addr;
|
||||
bcheck (100*id + id'+1) tval (b, tb);
|
||||
end;
|
||||
()
|
||||
|
||||
let ttype name = function
|
||||
| TA (Base b, _) -> btype b
|
||||
| TA (Struct _, _) -> ":" ^ name
|
||||
|
||||
let typedef oc name =
|
||||
let rec f: type a. a sty -> unit = function
|
||||
| Field (b, s) ->
|
||||
fprintf oc "%s" (bmemtype b);
|
||||
if not (styempty s) then
|
||||
fprintf oc ", ";
|
||||
f s;
|
||||
| Empty -> () in
|
||||
function
|
||||
| TA (Struct ts, _) ->
|
||||
fprintf oc "type :%s = { " name;
|
||||
f ts;
|
||||
fprintf oc " }\n";
|
||||
| _ -> ()
|
||||
|
||||
let postlude oc = List.iter (fprintf oc "%s\n")
|
||||
[ "@fail"
|
||||
; "# failure code"
|
||||
; "\t%fcode =w loadw %failcode"
|
||||
; "\t%f0 =w call $printf(l $failstr, w %fcode)"
|
||||
; "\t%f1 =w call $abort()"
|
||||
; "\tret 0"
|
||||
; "}"
|
||||
; ""
|
||||
; "data $failstr = { b \"fail on check %d\\n\", b 0 }"
|
||||
]
|
||||
|
||||
let caller oc ret args =
|
||||
let narg = List.length args in
|
||||
List.iteri (fun i arg ->
|
||||
typedef oc (argname i) arg;
|
||||
) args;
|
||||
typedef oc "ret" ret;
|
||||
fprintf oc "\nexport function w $main() {\n";
|
||||
fprintf oc "@start\n";
|
||||
fprintf oc "\t%%failcode =l alloc4 4\n";
|
||||
let targs = List.mapi (fun i arg ->
|
||||
comment oc ("define argument " ^ (string_of_int (i+1)));
|
||||
(ttype (argname i) arg, init oc arg)
|
||||
) args in
|
||||
comment oc "call test function";
|
||||
fprintf oc "\t%%ret =%s call $f(" (ttype "ret" ret);
|
||||
List.iteri (fun i (ty, tmp) ->
|
||||
fprintf oc "%s %s" ty tmp;
|
||||
if i <> narg-1 then
|
||||
fprintf oc ", ";
|
||||
) targs;
|
||||
fprintf oc ")\n";
|
||||
comment oc "check the return value";
|
||||
check oc 0 "%ret" ret;
|
||||
fprintf oc "\tret 0\n";
|
||||
postlude oc;
|
||||
()
|
||||
|
||||
let callee oc ret args =
|
||||
let narg = List.length args in
|
||||
List.iteri (fun i arg ->
|
||||
typedef oc (argname i) arg;
|
||||
) args;
|
||||
typedef oc "ret" ret;
|
||||
fprintf oc "\nexport function %s $f(" (ttype "ret" ret);
|
||||
List.iteri (fun i arg ->
|
||||
let a = argname i in
|
||||
fprintf oc "%s %%%s" (ttype a arg) a;
|
||||
if i <> narg-1 then
|
||||
fprintf oc ", ";
|
||||
) args;
|
||||
fprintf oc ") {\n";
|
||||
fprintf oc "@start\n";
|
||||
fprintf oc "\t%%failcode =l alloc4 4\n";
|
||||
List.iteri (fun i arg ->
|
||||
comment oc ("checking argument " ^ (string_of_int (i+1)));
|
||||
check oc (i+1) ("%" ^ argname i) arg;
|
||||
) args;
|
||||
comment oc "define the return value";
|
||||
let rettmp = init oc ret in
|
||||
fprintf oc "\tret %s\n" rettmp;
|
||||
postlude oc;
|
||||
()
|
||||
|
||||
end
|
||||
|
||||
|
||||
module type OUT = sig
|
||||
val extension: string
|
||||
val comment: out_channel -> string -> unit
|
||||
val caller: out_channel -> testa -> testa list -> unit
|
||||
val callee: out_channel -> testa -> testa list -> unit
|
||||
end
|
||||
|
||||
let _ =
|
||||
let usage code =
|
||||
Printf.eprintf "usage: abi.ml [-s SEED] DIR {c,ssa} {c,ssa}\n";
|
||||
exit code in
|
||||
|
||||
let outmod = function
|
||||
| "c" -> (module OutC : OUT)
|
||||
| "ssa" -> (module OutIL: OUT)
|
||||
| _ -> usage 1 in
|
||||
|
||||
let seed, dir, mcaller, mcallee =
|
||||
match Sys.argv with
|
||||
| [| _; "-s"; seed; dir; caller; callee |] ->
|
||||
let seed =
|
||||
try Some (int_of_string seed) with
|
||||
Failure _ -> usage 1 in
|
||||
seed, dir, outmod caller, outmod callee
|
||||
| [| _; dir; caller; callee |] ->
|
||||
None, dir, outmod caller, outmod callee
|
||||
| [| _; "-h" |] ->
|
||||
usage 0
|
||||
| _ ->
|
||||
usage 1 in
|
||||
|
||||
let seed = Gen.init seed in
|
||||
let tret = Gen.test () in
|
||||
let targs = Gen.tests () in
|
||||
let module OCaller = (val mcaller : OUT) in
|
||||
let module OCallee = (val mcallee : OUT) in
|
||||
let ocaller = open_out (dir ^ "/caller" ^ OCaller.extension) in
|
||||
let ocallee = open_out (dir ^ "/callee" ^ OCallee.extension) in
|
||||
OCaller.comment ocaller (Printf.sprintf "seed %d" seed);
|
||||
OCallee.comment ocallee (Printf.sprintf "seed %d" seed);
|
||||
OCaller.caller ocaller tret targs;
|
||||
OCallee.callee ocallee tret targs;
|
||||
()
|
||||
38
src/qbe/tools/cra.sh
Executable file
38
src/qbe/tools/cra.sh
Executable file
@@ -0,0 +1,38 @@
|
||||
#!/bin/sh
|
||||
|
||||
DIR=`cd $(dirname "$0"); pwd`
|
||||
QBE=$DIR/../qbe
|
||||
BUGF=/tmp/bug.id
|
||||
FIND=$1
|
||||
FIND=${FIND:-afl-find}
|
||||
|
||||
if ! test -f $BUGF
|
||||
then
|
||||
echo 1 > $BUGF
|
||||
fi
|
||||
|
||||
while true
|
||||
do
|
||||
ID=`cat $BUGF`
|
||||
|
||||
if test `ls $FIND/crashes/id* | wc -l` -lt $ID
|
||||
then
|
||||
rm -f bug.ssa
|
||||
echo "All done!"
|
||||
exit 0
|
||||
fi
|
||||
|
||||
BUG=`ls $FIND/crashes/id* | sed -ne "${ID}{p;q}"`
|
||||
|
||||
echo "*** Crash $ID"
|
||||
cp $BUG bug.ssa
|
||||
|
||||
$QBE bug.ssa > /dev/null
|
||||
RET=$?
|
||||
if test \( $RET -ne 0 \) -a \( $RET -ne 1 \)
|
||||
then
|
||||
exit 1
|
||||
fi
|
||||
|
||||
expr $ID + 1 > $BUGF
|
||||
done
|
||||
94
src/qbe/tools/lexh.c
Normal file
94
src/qbe/tools/lexh.c
Normal file
@@ -0,0 +1,94 @@
|
||||
/*% c99 -O3 -Wall -o # %
|
||||
*/
|
||||
#include <stdlib.h>
|
||||
#include <stdio.h>
|
||||
#include <string.h>
|
||||
#include <limits.h>
|
||||
#include <stdint.h>
|
||||
|
||||
char *tok[] = {
|
||||
|
||||
"add", "sub", "neg", "div", "rem", "udiv", "urem", "mul",
|
||||
"and", "or", "xor", "sar", "shr", "shl", "stored",
|
||||
"stores", "storel", "storew", "storeh", "storeb",
|
||||
"load", "loadsw", "loaduw", "loadsh", "loaduh",
|
||||
"loadsb", "loadub", "extsw", "extuw", "extsh",
|
||||
"extuh", "extsb", "extub", "exts", "truncd",
|
||||
"stosi", "dtosi", "stoui", "dtoui", "uwtof",
|
||||
"ultof", "swtof", "sltof", "cast", "copy",
|
||||
"alloc4", "alloc8", "alloc16", "culew", "cultw",
|
||||
"cslew", "csltw", "csgtw", "csgew", "cugtw",
|
||||
"cugew", "ceqw", "cnew", "culel", "cultl", "cslel",
|
||||
"csltl", "csgtl", "csgel", "cugtl", "cugel",
|
||||
"ceql", "cnel", "cles", "clts", "cgts", "cges",
|
||||
"cnes", "ceqs", "cos", "cuos", "cled", "cltd",
|
||||
"cgtd", "cged", "cned", "ceqd", "cod", "cuod",
|
||||
"vaarg", "vastart", "...", "env", "dbgloc",
|
||||
|
||||
"call", "phi", "jmp", "jnz", "ret", "hlt", "export",
|
||||
"function", "type", "data", "section", "align", "dbgfile",
|
||||
"blit", "l", "w", "sh", "uh", "h", "sb", "ub", "b",
|
||||
"d", "s", "z", "loadw", "loadl", "loads", "loadd",
|
||||
"alloc1", "alloc2", "thread", "common",
|
||||
|
||||
};
|
||||
enum {
|
||||
Ntok = sizeof tok / sizeof tok[0]
|
||||
};
|
||||
|
||||
uint32_t th[Ntok];
|
||||
|
||||
uint32_t
|
||||
hash(char *s)
|
||||
{
|
||||
uint32_t h;
|
||||
|
||||
h = 0;
|
||||
for (; *s; ++s)
|
||||
h = *s + 17*h;
|
||||
return h;
|
||||
}
|
||||
|
||||
int
|
||||
main()
|
||||
{
|
||||
char *bmap;
|
||||
uint32_t h, M, K;
|
||||
int i, j;
|
||||
|
||||
bmap = malloc(1u << 31);
|
||||
|
||||
for (i=0; i<Ntok; ++i) {
|
||||
h = hash(tok[i]);
|
||||
for (j=0; j<i; ++j)
|
||||
if (th[j] == h) {
|
||||
printf("error: hash()\n");
|
||||
printf("\t%s\n", tok[i]);
|
||||
printf("\t%s\n", tok[j]);
|
||||
exit(1);
|
||||
}
|
||||
th[i] = h;
|
||||
}
|
||||
|
||||
for (i=9; 1<<i < Ntok; ++i);
|
||||
M = 32 - i;
|
||||
|
||||
for (;; --M) {
|
||||
printf("trying M=%d...\n", M);
|
||||
K = 1;
|
||||
do {
|
||||
memset(bmap, 0, 1 << (32 - M));
|
||||
for (i=0; i<Ntok; ++i) {
|
||||
h = (th[i]*K) >> M;
|
||||
if (bmap[h])
|
||||
break;
|
||||
bmap[h] = 1;
|
||||
}
|
||||
if (i==Ntok) {
|
||||
printf("found K=%d for M=%d\n", K, M);
|
||||
exit(0);
|
||||
}
|
||||
K += 2;
|
||||
} while (K != 1);
|
||||
}
|
||||
}
|
||||
64
src/qbe/tools/log2.c
Normal file
64
src/qbe/tools/log2.c
Normal file
@@ -0,0 +1,64 @@
|
||||
#include <assert.h>
|
||||
#include <stdio.h>
|
||||
|
||||
typedef unsigned long long ullong;
|
||||
|
||||
char seen[64];
|
||||
ullong rbg = 0x1e0298f7a7e;
|
||||
|
||||
int
|
||||
bit()
|
||||
{
|
||||
int bit;
|
||||
|
||||
bit = rbg & 1;
|
||||
rbg >>= 1;
|
||||
return bit;
|
||||
}
|
||||
|
||||
int
|
||||
search(ullong n, int b, ullong *out)
|
||||
{
|
||||
int i, x;
|
||||
ullong y, z;
|
||||
|
||||
if (b == 64) {
|
||||
*out = n;
|
||||
return 1;
|
||||
}
|
||||
|
||||
x = 63 & ((n << (63 - b)) >> 58);
|
||||
assert(!(x & 0) && x <= 62);
|
||||
y = bit();
|
||||
|
||||
for (i=0; i<2; i++) {
|
||||
z = x | (y << 5);
|
||||
if (!seen[z]) {
|
||||
seen[z] = (63-b)+1;
|
||||
if (search(n | (y << b), b+1, out))
|
||||
return 1;
|
||||
seen[z] = 0;
|
||||
}
|
||||
y ^= 1;
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
int
|
||||
main()
|
||||
{
|
||||
ullong out;
|
||||
int i;
|
||||
|
||||
if (search(0, 0, &out)) {
|
||||
printf("0x%llx\n", out);
|
||||
for (i=0; i<64; i++) {
|
||||
printf((i&7) == 0 ? "\t" : " ");
|
||||
printf("%2d,", seen[i]-1);
|
||||
if ((i&7) == 7)
|
||||
printf("\n");
|
||||
}
|
||||
} else
|
||||
puts("not found");
|
||||
}
|
||||
3
src/qbe/tools/mgen/.gitignore
vendored
Normal file
3
src/qbe/tools/mgen/.gitignore
vendored
Normal file
@@ -0,0 +1,3 @@
|
||||
*.cm[iox]
|
||||
*.o
|
||||
mgen
|
||||
1
src/qbe/tools/mgen/.ocp-indent
Normal file
1
src/qbe/tools/mgen/.ocp-indent
Normal file
@@ -0,0 +1 @@
|
||||
match_clause=4
|
||||
16
src/qbe/tools/mgen/Makefile
Normal file
16
src/qbe/tools/mgen/Makefile
Normal file
@@ -0,0 +1,16 @@
|
||||
BIN = mgen
|
||||
SRC = \
|
||||
match.ml \
|
||||
fuzz.ml \
|
||||
cgen.ml \
|
||||
sexp.ml \
|
||||
test.ml \
|
||||
main.ml
|
||||
|
||||
$(BIN): $(SRC)
|
||||
ocamlopt -o $(BIN) -g str.cmxa $(SRC)
|
||||
|
||||
clean:
|
||||
rm -f *.cm? *.o $(BIN)
|
||||
|
||||
.PHONY: clean
|
||||
420
src/qbe/tools/mgen/cgen.ml
Normal file
420
src/qbe/tools/mgen/cgen.ml
Normal file
@@ -0,0 +1,420 @@
|
||||
open Match
|
||||
|
||||
type options =
|
||||
{ pfx: string
|
||||
; static: bool
|
||||
; oc: out_channel }
|
||||
|
||||
type side = L | R
|
||||
|
||||
type id_pred =
|
||||
| InBitSet of Int64.t
|
||||
| Ge of int
|
||||
| Eq of int
|
||||
|
||||
and id_test =
|
||||
| Pred of (side * id_pred)
|
||||
| And of id_test * id_test
|
||||
|
||||
type case_code =
|
||||
| Table of ((int * int) * int) list
|
||||
| IfThen of
|
||||
{ test: id_test
|
||||
; cif: case_code
|
||||
; cthen: case_code option }
|
||||
| Return of int
|
||||
|
||||
type case =
|
||||
{ swap: bool
|
||||
; code: case_code }
|
||||
|
||||
let cgen_case tmp nstates map =
|
||||
let cgen_test ids =
|
||||
match ids with
|
||||
| [id] -> Eq id
|
||||
| _ ->
|
||||
let min_id =
|
||||
List.fold_left min max_int ids in
|
||||
if List.length ids = nstates - min_id
|
||||
then Ge min_id
|
||||
else begin
|
||||
assert (nstates <= 64);
|
||||
InBitSet
|
||||
(List.fold_left (fun bs id ->
|
||||
Int64.logor bs
|
||||
(Int64.shift_left 1L id))
|
||||
0L ids)
|
||||
end
|
||||
in
|
||||
let symmetric =
|
||||
let inverse ((l, r), x) = ((r, l), x) in
|
||||
setify map = setify (List.map inverse map) in
|
||||
let map =
|
||||
let ordered ((l, r), _) = r <= l in
|
||||
if symmetric then
|
||||
List.filter ordered map
|
||||
else map
|
||||
in
|
||||
let exception BailToTable in
|
||||
try
|
||||
let st =
|
||||
match setify (List.map snd map) with
|
||||
| [st] -> st
|
||||
| _ -> raise BailToTable
|
||||
in
|
||||
(* the operation considered can only
|
||||
* generate a single state *)
|
||||
let pairs = List.map fst map in
|
||||
let ls, rs = List.split pairs in
|
||||
let ls = setify ls and rs = setify rs in
|
||||
if List.length ls > 1 && List.length rs > 1 then
|
||||
raise BailToTable;
|
||||
{ swap = symmetric
|
||||
; code =
|
||||
let pl = Pred (L, cgen_test ls)
|
||||
and pr = Pred (R, cgen_test rs) in
|
||||
IfThen
|
||||
{ test = And (pl, pr)
|
||||
; cif = Return st
|
||||
; cthen = Some (Return tmp) } }
|
||||
with BailToTable ->
|
||||
{ swap = symmetric
|
||||
; code = Table map }
|
||||
|
||||
let show_op (_cls, op) =
|
||||
"O" ^ show_op_base op
|
||||
|
||||
let indent oc i =
|
||||
Printf.fprintf oc "%s" (String.sub "\t\t\t\t\t" 0 i)
|
||||
|
||||
let emit_swap oc i =
|
||||
let pf m = Printf.fprintf oc m in
|
||||
let pfi n m = indent oc n; pf m in
|
||||
pfi i "if (l < r)\n";
|
||||
pfi (i+1) "t = l, l = r, r = t;\n"
|
||||
|
||||
let gen_tables oc tmp pfx nstates (op, c) =
|
||||
let i = 1 in
|
||||
let pf m = Printf.fprintf oc m in
|
||||
let pfi n m = indent oc n; pf m in
|
||||
let ntables = ref 0 in
|
||||
(* we must follow the order in which
|
||||
* we visit code in emit_case, or
|
||||
* else ntables goes out of sync *)
|
||||
let base = pfx ^ show_op op in
|
||||
let swap = c.swap in
|
||||
let rec gen c =
|
||||
match c with
|
||||
| Table map ->
|
||||
let name =
|
||||
if !ntables = 0 then base else
|
||||
base ^ string_of_int !ntables
|
||||
in
|
||||
assert (nstates <= 256);
|
||||
if swap then
|
||||
let n = nstates * (nstates + 1) / 2 in
|
||||
pfi i "static uchar %stbl[%d] = {\n" name n
|
||||
else
|
||||
pfi i "static uchar %stbl[%d][%d] = {\n"
|
||||
name nstates nstates;
|
||||
for l = 0 to nstates - 1 do
|
||||
pfi (i+1) "";
|
||||
for r = 0 to nstates - 1 do
|
||||
if not swap || r <= l then
|
||||
begin
|
||||
pf "%d"
|
||||
(try List.assoc (l,r) map
|
||||
with Not_found -> tmp);
|
||||
pf ",";
|
||||
end
|
||||
done;
|
||||
pf "\n";
|
||||
done;
|
||||
pfi i "};\n"
|
||||
| IfThen {cif; cthen} ->
|
||||
gen cif;
|
||||
Option.iter gen cthen
|
||||
| Return _ -> ()
|
||||
in
|
||||
gen c.code
|
||||
|
||||
let emit_case oc pfx no_swap (op, c) =
|
||||
let fpf = Printf.fprintf in
|
||||
let pf m = fpf oc m in
|
||||
let pfi n m = indent oc n; pf m in
|
||||
let rec side oc = function
|
||||
| L -> fpf oc "l"
|
||||
| R -> fpf oc "r"
|
||||
in
|
||||
let pred oc (s, pred) =
|
||||
match pred with
|
||||
| InBitSet bs -> fpf oc "BIT(%a) & %#Lx" side s bs
|
||||
| Eq id -> fpf oc "%a == %d" side s id
|
||||
| Ge id -> fpf oc "%d <= %a" id side s
|
||||
in
|
||||
let base = pfx ^ show_op op in
|
||||
let swap = c.swap in
|
||||
let ntables = ref 0 in
|
||||
let rec code i c =
|
||||
match c with
|
||||
| Return id -> pfi i "return %d;\n" id
|
||||
| Table map ->
|
||||
let name =
|
||||
if !ntables = 0 then base else
|
||||
base ^ string_of_int !ntables
|
||||
in
|
||||
incr ntables;
|
||||
if swap then
|
||||
pfi i "return %stbl[(l + l*l)/2 + r];\n" name
|
||||
else pfi i "return %stbl[l][r];\n" name
|
||||
| IfThen ({test = And (And (t1, t2), t3)} as r) ->
|
||||
code i @@ IfThen
|
||||
{r with test = And (t1, And (t2, t3))}
|
||||
| IfThen {test = And (Pred p, t); cif; cthen} ->
|
||||
pfi i "if (%a)\n" pred p;
|
||||
code i (IfThen {test = t; cif; cthen})
|
||||
| IfThen {test = Pred p; cif; cthen} ->
|
||||
pfi i "if (%a) {\n" pred p;
|
||||
code (i+1) cif;
|
||||
pfi i "}\n";
|
||||
Option.iter (code i) cthen
|
||||
in
|
||||
pfi 1 "case %s:\n" (show_op op);
|
||||
if not no_swap && c.swap then
|
||||
emit_swap oc 2;
|
||||
code 2 c.code
|
||||
|
||||
let emit_list
|
||||
?(limit=60) ?(cut_before_sep=false)
|
||||
~col ~indent:i ~sep ~f oc l =
|
||||
let sl = String.length sep in
|
||||
let rstripped_sep, rssl =
|
||||
if sep.[sl - 1] = ' ' then
|
||||
String.sub sep 0 (sl - 1), sl - 1
|
||||
else sep, sl
|
||||
in
|
||||
let lstripped_sep, lssl =
|
||||
if sep.[0] = ' ' then
|
||||
String.sub sep 1 (sl - 1), sl - 1
|
||||
else sep, sl
|
||||
in
|
||||
let rec line col acc = function
|
||||
| [] -> (List.rev acc, [])
|
||||
| s :: l ->
|
||||
let col = col + sl + String.length s in
|
||||
let no_space =
|
||||
if cut_before_sep || l = [] then
|
||||
col > limit
|
||||
else
|
||||
col + rssl > limit
|
||||
in
|
||||
if no_space then
|
||||
(List.rev acc, s :: l)
|
||||
else
|
||||
line col (s :: acc) l
|
||||
in
|
||||
let rec go col l =
|
||||
if l = [] then () else
|
||||
let ll, l = line col [] l in
|
||||
Printf.fprintf oc "%s" (String.concat sep ll);
|
||||
if l <> [] && cut_before_sep then begin
|
||||
Printf.fprintf oc "\n";
|
||||
indent oc i;
|
||||
Printf.fprintf oc "%s" lstripped_sep;
|
||||
go (8*i + lssl) l
|
||||
end else if l <> [] then begin
|
||||
Printf.fprintf oc "%s\n" rstripped_sep;
|
||||
indent oc i;
|
||||
go (8*i) l
|
||||
end else ()
|
||||
in
|
||||
go col (List.map f l)
|
||||
|
||||
let emit_numberer opts n =
|
||||
let pf m = Printf.fprintf opts.oc m in
|
||||
let tmp = (atom_state n Tmp).id in
|
||||
let con = (atom_state n AnyCon).id in
|
||||
let nst = Array.length n.states in
|
||||
let cases =
|
||||
StateMap.by_ops n.statemap |>
|
||||
List.map (fun (op, map) ->
|
||||
(op, cgen_case tmp nst map))
|
||||
in
|
||||
let all_swap =
|
||||
List.for_all (fun (_, c) -> c.swap) cases in
|
||||
(* opn() *)
|
||||
if opts.static then pf "static ";
|
||||
pf "int\n";
|
||||
pf "%sopn(int op, int l, int r)\n" opts.pfx;
|
||||
pf "{\n";
|
||||
cases |> List.iter
|
||||
(gen_tables opts.oc tmp opts.pfx nst);
|
||||
if List.exists (fun (_, c) -> c.swap) cases then
|
||||
pf "\tint t;\n\n";
|
||||
if all_swap then emit_swap opts.oc 1;
|
||||
pf "\tswitch (op) {\n";
|
||||
cases |> List.iter
|
||||
(emit_case opts.oc opts.pfx all_swap);
|
||||
pf "\tdefault:\n";
|
||||
pf "\t\treturn %d;\n" tmp;
|
||||
pf "\t}\n";
|
||||
pf "}\n\n";
|
||||
(* refn() *)
|
||||
if opts.static then pf "static ";
|
||||
pf "int\n";
|
||||
pf "%srefn(Ref r, Num *tn, Con *con)\n" opts.pfx;
|
||||
pf "{\n";
|
||||
let cons =
|
||||
List.filter_map (function
|
||||
| (Con c, s) -> Some (c, s.id)
|
||||
| _ -> None)
|
||||
n.atoms
|
||||
in
|
||||
if cons <> [] then
|
||||
pf "\tint64_t n;\n\n";
|
||||
pf "\tswitch (rtype(r)) {\n";
|
||||
pf "\tcase RTmp:\n";
|
||||
if tmp <> 0 then begin
|
||||
assert
|
||||
(List.exists (fun (_, s) ->
|
||||
s.id = 0
|
||||
) n.atoms &&
|
||||
(* no temp should ever get state 0 *)
|
||||
List.for_all (fun (a, s) ->
|
||||
s.id <> 0 ||
|
||||
match a with
|
||||
| AnyCon | Con _ -> true
|
||||
| _ -> false
|
||||
) n.atoms);
|
||||
pf "\t\tif (!tn[r.val].n)\n";
|
||||
pf "\t\t\ttn[r.val].n = %d;\n" tmp;
|
||||
end;
|
||||
pf "\t\treturn tn[r.val].n;\n";
|
||||
pf "\tcase RCon:\n";
|
||||
if cons <> [] then begin
|
||||
pf "\t\tif (con[r.val].type != CBits)\n";
|
||||
pf "\t\t\treturn %d;\n" con;
|
||||
pf "\t\tn = con[r.val].bits.i;\n";
|
||||
cons |> inverse |> group_by_fst
|
||||
|> List.iter (fun (id, cs) ->
|
||||
pf "\t\tif (";
|
||||
emit_list ~cut_before_sep:true
|
||||
~col:20 ~indent:2 ~sep:" || "
|
||||
~f:(fun c -> "n == " ^ Int64.to_string c)
|
||||
opts.oc cs;
|
||||
pf ")\n";
|
||||
pf "\t\t\treturn %d;\n" id
|
||||
);
|
||||
end;
|
||||
pf "\t\treturn %d;\n" con;
|
||||
pf "\tdefault:\n";
|
||||
pf "\t\treturn INT_MIN;\n";
|
||||
pf "\t}\n";
|
||||
pf "}\n\n";
|
||||
(* match[]: patterns per state *)
|
||||
if opts.static then pf "static ";
|
||||
pf "bits %smatch[%d] = {\n" opts.pfx nst;
|
||||
n.states |> Array.iteri (fun sn s ->
|
||||
let tops =
|
||||
List.filter_map (function
|
||||
| Top ("$" | "%") -> None
|
||||
| Top r -> Some ("BIT(P" ^ r ^ ")")
|
||||
| _ -> None) s.point |> setify
|
||||
in
|
||||
if tops <> [] then
|
||||
pf "\t[%d] = %s,\n"
|
||||
sn (String.concat " | " tops);
|
||||
);
|
||||
pf "};\n\n"
|
||||
|
||||
let var_id vars f =
|
||||
List.mapi (fun i x -> (x, i)) vars |>
|
||||
List.assoc f
|
||||
|
||||
let compile_action vars act =
|
||||
let pcs = Hashtbl.create 100 in
|
||||
let rec gen pc (act: Action.t) =
|
||||
try
|
||||
[10 + Hashtbl.find pcs act.id]
|
||||
with Not_found ->
|
||||
let code =
|
||||
match act.node with
|
||||
| Action.Stop ->
|
||||
[0]
|
||||
| Action.Push (sym, k) ->
|
||||
let c = if sym then 1 else 2 in
|
||||
[c] @ gen (pc + 1) k
|
||||
| Action.Set (v, {node = Action.Pop k; _})
|
||||
| Action.Set (v, ({node = Action.Stop; _} as k)) ->
|
||||
let v = var_id vars v in
|
||||
[3; v] @ gen (pc + 2) k
|
||||
| Action.Set _ ->
|
||||
(* for now, only atomic patterns can be
|
||||
* tied to a variable, so Set must be
|
||||
* followed by either Pop or Stop *)
|
||||
assert false
|
||||
| Action.Pop k ->
|
||||
[4] @ gen (pc + 1) k
|
||||
| Action.Switch cases ->
|
||||
let cases =
|
||||
inverse cases |> group_by_fst |>
|
||||
List.sort (fun (_, cs1) (_, cs2) ->
|
||||
let n1 = List.length cs1
|
||||
and n2 = List.length cs2 in
|
||||
compare n2 n1)
|
||||
in
|
||||
(* the last case is the one with
|
||||
* the max number of entries *)
|
||||
let cases = List.rev (List.tl cases)
|
||||
and last = fst (List.hd cases) in
|
||||
let ncases =
|
||||
List.fold_left (fun n (_, cs) ->
|
||||
List.length cs + n)
|
||||
0 cases
|
||||
in
|
||||
let body_off = 2 + 2 * ncases + 1 in
|
||||
let pc, tbl, body =
|
||||
List.fold_left
|
||||
(fun (pc, tbl, body) (a, cs) ->
|
||||
let ofs = body_off + List.length body in
|
||||
let case = gen pc a in
|
||||
let pc = pc + List.length case in
|
||||
let body = body @ case in
|
||||
let tbl =
|
||||
List.fold_left (fun tbl c ->
|
||||
tbl @ [c; ofs]
|
||||
) tbl cs
|
||||
in
|
||||
(pc, tbl, body))
|
||||
(pc + body_off, [], [])
|
||||
cases
|
||||
in
|
||||
let ofs = body_off + List.length body in
|
||||
let tbl = tbl @ [ofs] in
|
||||
assert (2 + List.length tbl = body_off);
|
||||
[5; ncases] @ tbl @ body @ gen pc last
|
||||
in
|
||||
if act.node <> Action.Stop then
|
||||
Hashtbl.replace pcs act.id pc;
|
||||
code
|
||||
in
|
||||
gen 0 act
|
||||
|
||||
let emit_matchers opts ms =
|
||||
let pf m = Printf.fprintf opts.oc m in
|
||||
if opts.static then pf "static ";
|
||||
pf "uchar *%smatcher[] = {\n" opts.pfx;
|
||||
List.iter (fun (vars, pname, m) ->
|
||||
pf "\t[P%s] = (uchar[]){\n" pname;
|
||||
pf "\t\t";
|
||||
let bytes = compile_action vars m in
|
||||
emit_list
|
||||
~col:16 ~indent:2 ~sep:","
|
||||
~f:string_of_int opts.oc bytes;
|
||||
pf "\n";
|
||||
pf "\t},\n")
|
||||
ms;
|
||||
pf "};\n\n"
|
||||
|
||||
let emit_c opts n =
|
||||
emit_numberer opts n
|
||||
413
src/qbe/tools/mgen/fuzz.ml
Normal file
413
src/qbe/tools/mgen/fuzz.ml
Normal file
@@ -0,0 +1,413 @@
|
||||
(* fuzz the tables and matchers generated *)
|
||||
open Match
|
||||
|
||||
module Buffer: sig
|
||||
type 'a t
|
||||
val create: ?capacity:int -> unit -> 'a t
|
||||
val reset: 'a t -> unit
|
||||
val size: 'a t -> int
|
||||
val get: 'a t -> int -> 'a
|
||||
val set: 'a t -> int -> 'a -> unit
|
||||
val push: 'a t -> 'a -> unit
|
||||
end = struct
|
||||
type 'a t =
|
||||
{ mutable size: int
|
||||
; mutable data: 'a array }
|
||||
let mk_array n = Array.make n (Obj.magic 0)
|
||||
let create ?(capacity = 10) () =
|
||||
if capacity < 0 then invalid_arg "Buffer.make";
|
||||
{size = 0; data = mk_array capacity}
|
||||
let reset b = b.size <- 0
|
||||
let size b = b.size
|
||||
let get b n =
|
||||
if n >= size b then invalid_arg "Buffer.get";
|
||||
b.data.(n)
|
||||
let set b n x =
|
||||
if n >= size b then invalid_arg "Buffer.set";
|
||||
b.data.(n) <- x
|
||||
let push b x =
|
||||
let cap = Array.length b.data in
|
||||
if size b = cap then begin
|
||||
let data = mk_array (2 * cap + 1) in
|
||||
Array.blit b.data 0 data 0 cap;
|
||||
b.data <- data
|
||||
end;
|
||||
let sz = size b in
|
||||
b.size <- sz + 1;
|
||||
set b sz x
|
||||
end
|
||||
|
||||
let binop_state n op s1 s2 =
|
||||
let key = K (op, s1, s2) in
|
||||
try StateMap.find key n.statemap
|
||||
with Not_found -> atom_state n Tmp
|
||||
|
||||
type id = int
|
||||
type term_data =
|
||||
| Binop of op * id * id
|
||||
| Leaf of atomic_pattern
|
||||
type term =
|
||||
{ id: id
|
||||
; data: term_data
|
||||
; state: p state }
|
||||
|
||||
let pp_term fmt (ta, id) =
|
||||
let fpf x = Format.fprintf fmt x in
|
||||
let rec pp _fmt id =
|
||||
match ta.(id).data with
|
||||
| Leaf (Con c) -> fpf "%Ld" c
|
||||
| Leaf AnyCon -> fpf "$%d" id
|
||||
| Leaf Tmp -> fpf "%%%d" id
|
||||
| Binop (op, id1, id2) ->
|
||||
fpf "@[(%s@%d:%d @[<hov>%a@ %a@])@]"
|
||||
(show_op op) id ta.(id).state.id
|
||||
pp id1 pp id2
|
||||
in pp fmt id
|
||||
|
||||
(* A term pool is a deduplicated set of term
|
||||
* that maintains nodes numbering using the
|
||||
* statemap passed at creation time *)
|
||||
module TermPool = struct
|
||||
type t =
|
||||
{ terms: term Buffer.t
|
||||
; hcons: (term_data, id) Hashtbl.t
|
||||
; numbr: numberer }
|
||||
|
||||
let create numbr =
|
||||
{ terms = Buffer.create ()
|
||||
; hcons = Hashtbl.create 100
|
||||
; numbr }
|
||||
let reset tp =
|
||||
Buffer.reset tp.terms;
|
||||
Hashtbl.clear tp.hcons
|
||||
|
||||
let size tp = Buffer.size tp.terms
|
||||
let term tp id = Buffer.get tp.terms id
|
||||
|
||||
let mk_leaf tp atm =
|
||||
let data = Leaf atm in
|
||||
match Hashtbl.find tp.hcons data with
|
||||
| id -> term tp id
|
||||
| exception Not_found ->
|
||||
let id = Buffer.size tp.terms in
|
||||
let state = atom_state tp.numbr atm in
|
||||
Buffer.push tp.terms {id; data; state};
|
||||
Hashtbl.add tp.hcons data id;
|
||||
term tp id
|
||||
let mk_binop tp op t1 t2 =
|
||||
let data = Binop (op, t1.id, t2.id) in
|
||||
match Hashtbl.find tp.hcons data with
|
||||
| id -> term tp id
|
||||
| exception Not_found ->
|
||||
let id = Buffer.size tp.terms in
|
||||
let state =
|
||||
binop_state tp.numbr op t1.state t2.state
|
||||
in
|
||||
Buffer.push tp.terms {id; data; state};
|
||||
Hashtbl.add tp.hcons data id;
|
||||
term tp id
|
||||
|
||||
let rec add_pattern tp = function
|
||||
| Bnr (op, p1, p2) ->
|
||||
let t1 = add_pattern tp p1 in
|
||||
let t2 = add_pattern tp p2 in
|
||||
mk_binop tp op t1 t2
|
||||
| Atm atm -> mk_leaf tp atm
|
||||
| Var (_, atm) -> add_pattern tp (Atm atm)
|
||||
|
||||
let explode_term tp id =
|
||||
let rec aux tms n id =
|
||||
let t = term tp id in
|
||||
match t.data with
|
||||
| Leaf _ -> (n, {t with id = n} :: tms)
|
||||
| Binop (op, id1, id2) ->
|
||||
let n1, tms = aux tms n id1 in
|
||||
let n = n1 + 1 in
|
||||
let n2, tms = aux tms n id2 in
|
||||
let n = n2 + 1 in
|
||||
(n, { t with data = Binop (op, n1, n2)
|
||||
; id = n } :: tms)
|
||||
in
|
||||
let n, tms = aux [] 0 id in
|
||||
Array.of_list (List.rev tms), n
|
||||
end
|
||||
|
||||
module R = Random
|
||||
|
||||
(* uniform pick in a list *)
|
||||
let list_pick l =
|
||||
let rec aux n l x =
|
||||
match l with
|
||||
| [] -> x
|
||||
| y :: l ->
|
||||
if R.int (n + 1) = 0 then
|
||||
aux (n + 1) l y
|
||||
else
|
||||
aux (n + 1) l x
|
||||
in
|
||||
match l with
|
||||
| [] -> invalid_arg "list_pick"
|
||||
| x :: l -> aux 1 l x
|
||||
|
||||
let term_pick ~numbr =
|
||||
let ops =
|
||||
if numbr.ops = [] then
|
||||
numbr.ops <-
|
||||
(StateMap.fold (fun k _ ops ->
|
||||
match k with
|
||||
| K (op, _, _) -> op :: ops)
|
||||
numbr.statemap [] |> setify);
|
||||
numbr.ops
|
||||
in
|
||||
let rec gen depth =
|
||||
(* exponential probability for leaves to
|
||||
* avoid skewing towards shallow terms *)
|
||||
let atm_prob = 0.75 ** float_of_int depth in
|
||||
if R.float 1.0 <= atm_prob || ops = [] then
|
||||
let atom, st = list_pick numbr.atoms in
|
||||
(st, Atm atom)
|
||||
else
|
||||
let op = list_pick ops in
|
||||
let s1, t1 = gen (depth - 1) in
|
||||
let s2, t2 = gen (depth - 1) in
|
||||
( binop_state numbr op s1 s2
|
||||
, Bnr (op, t1, t2) )
|
||||
in fun ~depth -> gen depth
|
||||
|
||||
exception FuzzError
|
||||
|
||||
let rec pattern_depth = function
|
||||
| Bnr (_, p1, p2) ->
|
||||
1 + max (pattern_depth p1) (pattern_depth p2)
|
||||
| Atm _ -> 0
|
||||
| Var (_, atm) -> pattern_depth (Atm atm)
|
||||
|
||||
let ( %% ) a b =
|
||||
1e2 *. float_of_int a /. float_of_int b
|
||||
|
||||
let progress ?(width = 50) msg pct =
|
||||
Format.eprintf "\x1b[2K\r%!";
|
||||
let progress_bar fmt =
|
||||
let n =
|
||||
let fwidth = float_of_int width in
|
||||
1 + int_of_float (pct *. fwidth /. 1e2)
|
||||
in
|
||||
Format.fprintf fmt " %s%s %.0f%%@?"
|
||||
(String.concat "" (List.init n (fun _ -> "▒")))
|
||||
(String.make (max 0 (width - n)) '-')
|
||||
pct
|
||||
in
|
||||
Format.kfprintf progress_bar
|
||||
Format.err_formatter msg
|
||||
|
||||
let fuzz_numberer rules numbr =
|
||||
(* pick twice the max pattern depth so we
|
||||
* have a chance to find non-trivial numbers
|
||||
* for the atomic patterns in the rules *)
|
||||
let depth =
|
||||
List.fold_left (fun depth r ->
|
||||
max depth (pattern_depth r.pattern))
|
||||
0 rules * 2
|
||||
in
|
||||
(* fuzz until the term pool we are constructing
|
||||
* is no longer growing fast enough; or we just
|
||||
* went through sufficiently many iterations *)
|
||||
let max_iter = 1_000_000 in
|
||||
let low_insert_rate = 1e-2 in
|
||||
let tp = TermPool.create numbr in
|
||||
let rec loop new_stats i =
|
||||
let (_, _, insert_rate) = new_stats in
|
||||
if insert_rate <= low_insert_rate then () else
|
||||
if i >= max_iter then () else
|
||||
(* periodically update stats *)
|
||||
let new_stats =
|
||||
let (num, cnt, rate) = new_stats in
|
||||
if num land 1023 = 0 then
|
||||
let rate =
|
||||
0.5 *. (rate +. float_of_int cnt /. 1023.)
|
||||
in
|
||||
progress " insert_rate=%.1f%%"
|
||||
(i %% max_iter) (rate *. 1e2);
|
||||
(num + 1, 0, rate)
|
||||
else new_stats
|
||||
in
|
||||
(* create a term and check that its number is
|
||||
* accurate wrt the rules *)
|
||||
let st, term = term_pick ~numbr ~depth in
|
||||
let state_matched =
|
||||
List.filter_map (fun cu ->
|
||||
match cu with
|
||||
| Top ("$" | "%") -> None
|
||||
| Top name -> Some name
|
||||
| _ -> None)
|
||||
st.point |> setify
|
||||
in
|
||||
let rule_matched =
|
||||
List.filter_map (fun r ->
|
||||
if pattern_match r.pattern term then
|
||||
Some r.name
|
||||
else None)
|
||||
rules |> setify
|
||||
in
|
||||
if state_matched <> rule_matched then begin
|
||||
let open Format in
|
||||
let pp_str_list =
|
||||
let pp_sep fmt () = fprintf fmt ",@ " in
|
||||
pp_print_list ~pp_sep pp_print_string
|
||||
in
|
||||
eprintf "@.@[<v2>fuzz error for %s"
|
||||
(show_pattern term);
|
||||
eprintf "@ @[state matched: %a@]"
|
||||
pp_str_list state_matched;
|
||||
eprintf "@ @[rule matched: %a@]"
|
||||
pp_str_list rule_matched;
|
||||
eprintf "@]@.";
|
||||
raise FuzzError;
|
||||
end;
|
||||
if state_matched = [] then
|
||||
loop new_stats (i + 1)
|
||||
else
|
||||
(* add to the term pool *)
|
||||
let old_size = TermPool.size tp in
|
||||
let _ = TermPool.add_pattern tp term in
|
||||
let new_stats =
|
||||
let (num, cnt, rate) = new_stats in
|
||||
if TermPool.size tp <> old_size then
|
||||
(num + 1, cnt + 1, rate)
|
||||
else
|
||||
(num + 1, cnt, rate)
|
||||
in
|
||||
loop new_stats (i + 1)
|
||||
in
|
||||
loop (1, 0, 1.0) 0;
|
||||
Format.eprintf
|
||||
"@.@[ generated %.3fMiB of test terms@]@."
|
||||
(float_of_int (Obj.reachable_words (Obj.repr tp))
|
||||
/. 128. /. 1024.);
|
||||
tp
|
||||
|
||||
let rec run_matcher stk m (ta, id as t) =
|
||||
let state id = ta.(id).state.id in
|
||||
match m.Action.node with
|
||||
| Action.Switch cases ->
|
||||
let m =
|
||||
try List.assoc (state id) cases
|
||||
with Not_found -> failwith "no switch case"
|
||||
in
|
||||
run_matcher stk m t
|
||||
| Action.Push (sym, m) ->
|
||||
let l, r =
|
||||
match ta.(id).data with
|
||||
| Leaf _ -> failwith "push on leaf"
|
||||
| Binop (_, l, r) -> (l, r)
|
||||
in
|
||||
if sym && state l > state r
|
||||
then run_matcher (l :: stk) m (ta, r)
|
||||
else run_matcher (r :: stk) m (ta, l)
|
||||
| Action.Pop m -> begin
|
||||
match stk with
|
||||
| id :: stk -> run_matcher stk m (ta, id)
|
||||
| [] -> failwith "pop on empty stack"
|
||||
end
|
||||
| Action.Set (v, m) ->
|
||||
(v, id) :: run_matcher stk m t
|
||||
| Action.Stop -> []
|
||||
|
||||
let rec term_match p (ta, id) =
|
||||
let (|>>) x f =
|
||||
match x with None -> None | Some x -> f x
|
||||
in
|
||||
let atom_match a =
|
||||
match ta.(id).data with
|
||||
| Leaf a' -> pattern_match (Atm a) (Atm a')
|
||||
| Binop _ -> pattern_match (Atm a) (Atm Tmp)
|
||||
in
|
||||
match p with
|
||||
| Var (v, a) when atom_match a ->
|
||||
Some [(v, id)]
|
||||
| Atm a when atom_match a -> Some []
|
||||
| (Atm _ | Var _) -> None
|
||||
| Bnr (op, pl, pr) -> begin
|
||||
match ta.(id).data with
|
||||
| Binop (op', idl, idr) when op' = op ->
|
||||
term_match pl (ta, idl) |>> fun l1 ->
|
||||
term_match pr (ta, idr) |>> fun l2 ->
|
||||
Some (l1 @ l2)
|
||||
| _ -> None
|
||||
end
|
||||
|
||||
let test_matchers tp numbr rules =
|
||||
let {statemap = sm; states = sa; _} = numbr in
|
||||
let total = ref 0 in
|
||||
let matchers =
|
||||
let htbl = Hashtbl.create (Array.length sa) in
|
||||
List.map (fun r -> (r.name, r.pattern)) rules |>
|
||||
group_by_fst |>
|
||||
List.iter (fun (r, ps) ->
|
||||
total := !total + List.length ps;
|
||||
let pm = (ps, lr_matcher sm sa rules r) in
|
||||
sa |> Array.iter (fun s ->
|
||||
if List.mem (Top r) s.point then
|
||||
Hashtbl.add htbl s.id pm));
|
||||
htbl
|
||||
in
|
||||
let seen = Hashtbl.create !total in
|
||||
for id = 0 to TermPool.size tp - 1 do
|
||||
if id land 1023 = 0 ||
|
||||
id = TermPool.size tp - 1 then begin
|
||||
progress
|
||||
" coverage=%.1f%%"
|
||||
(id %% TermPool.size tp)
|
||||
(Hashtbl.length seen %% !total)
|
||||
end;
|
||||
let t = TermPool.explode_term tp id in
|
||||
Hashtbl.find_all matchers
|
||||
(TermPool.term tp id).state.id |>
|
||||
List.iter (fun (ps, m) ->
|
||||
let norm = List.fast_sort compare in
|
||||
let ok =
|
||||
match norm (run_matcher [] m t) with
|
||||
| asn -> `Match (List.exists (fun p ->
|
||||
match term_match p t with
|
||||
| None -> false
|
||||
| Some asn' ->
|
||||
if asn = norm asn' then begin
|
||||
Hashtbl.replace seen p ();
|
||||
true
|
||||
end else false) ps)
|
||||
| exception e -> `RunFailure e
|
||||
in
|
||||
if ok <> `Match true then begin
|
||||
let open Format in
|
||||
let pp_asn fmt asn =
|
||||
fprintf fmt "@[<h>";
|
||||
pp_print_list
|
||||
~pp_sep:(fun fmt () -> fprintf fmt ";@ ")
|
||||
(fun fmt (v, d) ->
|
||||
fprintf fmt "@[%s←%d@]" v d)
|
||||
fmt asn;
|
||||
fprintf fmt "@]"
|
||||
in
|
||||
eprintf "@.@[<v2>matcher error for";
|
||||
eprintf "@ @[%a@]" pp_term t;
|
||||
begin match ok with
|
||||
| `RunFailure e ->
|
||||
eprintf "@ @[exception: %s@]"
|
||||
(Printexc.to_string e)
|
||||
| `Match (* false *) _ ->
|
||||
let asn = run_matcher [] m t in
|
||||
eprintf "@ @[assignment: %a@]"
|
||||
pp_asn asn;
|
||||
eprintf "@ @[<v2>could not match";
|
||||
List.iter (fun p ->
|
||||
eprintf "@ + @[%s@]"
|
||||
(show_pattern p)) ps;
|
||||
eprintf "@]"
|
||||
end;
|
||||
eprintf "@]@.";
|
||||
raise FuzzError
|
||||
end)
|
||||
done;
|
||||
Format.eprintf "@."
|
||||
|
||||
|
||||
214
src/qbe/tools/mgen/main.ml
Normal file
214
src/qbe/tools/mgen/main.ml
Normal file
@@ -0,0 +1,214 @@
|
||||
open Cgen
|
||||
open Match
|
||||
|
||||
let mgen ~verbose ~fuzz path lofs input oc =
|
||||
let info ?(level = 1) fmt =
|
||||
if level <= verbose then
|
||||
Printf.eprintf fmt
|
||||
else
|
||||
Printf.ifprintf stdout fmt
|
||||
in
|
||||
|
||||
let rules =
|
||||
match Sexp.(run_parser ppats) input with
|
||||
| `Error (ps, err, loc) ->
|
||||
Printf.eprintf "%s:%d:%d %s\n"
|
||||
path (lofs + ps.Sexp.line) ps.Sexp.coln err;
|
||||
Printf.eprintf "%s" loc;
|
||||
exit 1
|
||||
| `Ok rules -> rules
|
||||
in
|
||||
|
||||
info "adding ac variants...%!";
|
||||
let nparsed =
|
||||
List.fold_left
|
||||
(fun npats (_, _, ps) ->
|
||||
npats + List.length ps)
|
||||
0 rules
|
||||
in
|
||||
let varsmap = Hashtbl.create 10 in
|
||||
let rules =
|
||||
List.concat_map (fun (name, vars, patterns) ->
|
||||
(try assert (Hashtbl.find varsmap name = vars)
|
||||
with Not_found -> ());
|
||||
Hashtbl.replace varsmap name vars;
|
||||
List.map
|
||||
(fun pattern -> {name; vars; pattern})
|
||||
(List.concat_map ac_equiv patterns)
|
||||
) rules
|
||||
in
|
||||
info " %d -> %d patterns\n"
|
||||
nparsed (List.length rules);
|
||||
|
||||
let rnames =
|
||||
setify (List.map (fun r -> r.name) rules) in
|
||||
|
||||
info "generating match tables...%!";
|
||||
let sa, am, sm = generate_table rules in
|
||||
let numbr = make_numberer sa am sm in
|
||||
info " %d states, %d rules\n"
|
||||
(Array.length sa) (StateMap.cardinal sm);
|
||||
if verbose >= 2 then begin
|
||||
info "-------------\nstates:\n";
|
||||
Array.iteri (fun i s ->
|
||||
info " state %d: %s\n"
|
||||
i (show_pattern s.seen)) sa;
|
||||
info "-------------\nstatemap:\n";
|
||||
Test.print_sm stderr sm;
|
||||
info "-------------\n";
|
||||
end;
|
||||
|
||||
info "generating matchers...\n";
|
||||
let matchers =
|
||||
List.map (fun rname ->
|
||||
info "+ %s...%!" rname;
|
||||
let m = lr_matcher sm sa rules rname in
|
||||
let vars = Hashtbl.find varsmap rname in
|
||||
info " %d nodes\n" (Action.size m);
|
||||
info ~level:2 " -------------\n";
|
||||
info ~level:2 " automaton:\n";
|
||||
info ~level:2 "%s\n"
|
||||
(Format.asprintf " @[%a@]" Action.pp m);
|
||||
info ~level:2 " ----------\n";
|
||||
(vars, rname, m)
|
||||
) rnames
|
||||
in
|
||||
|
||||
if fuzz then begin
|
||||
info ~level:0 "fuzzing statemap...\n";
|
||||
let tp = Fuzz.fuzz_numberer rules numbr in
|
||||
info ~level:0 "testing %d patterns...\n"
|
||||
(List.length rules);
|
||||
Fuzz.test_matchers tp numbr rules
|
||||
end;
|
||||
|
||||
info "emitting C...\n";
|
||||
flush stderr;
|
||||
|
||||
let cgopts =
|
||||
{ pfx = ""; static = true; oc = oc } in
|
||||
emit_c cgopts numbr;
|
||||
emit_matchers cgopts matchers;
|
||||
|
||||
()
|
||||
|
||||
let read_all ic =
|
||||
let bufsz = 4096 in
|
||||
let buf = Bytes.create bufsz in
|
||||
let data = Buffer.create bufsz in
|
||||
let read = ref 0 in
|
||||
while
|
||||
read := input ic buf 0 bufsz;
|
||||
!read <> 0
|
||||
do
|
||||
Buffer.add_subbytes data buf 0 !read
|
||||
done;
|
||||
Buffer.contents data
|
||||
|
||||
let split_c src =
|
||||
let begin_re, eoc_re, end_re =
|
||||
let re = Str.regexp in
|
||||
( re "mgen generated code"
|
||||
, re "\\*/"
|
||||
, re "end of generated code" )
|
||||
in
|
||||
let str_match regexp str =
|
||||
try
|
||||
let _: int =
|
||||
Str.search_forward regexp str 0
|
||||
in true
|
||||
with Not_found -> false
|
||||
in
|
||||
|
||||
let rec go st lofs pfx rules lines =
|
||||
let line, lines =
|
||||
match lines with
|
||||
| [] ->
|
||||
failwith (
|
||||
match st with
|
||||
| `Prefix -> "could not find mgen section"
|
||||
| `Rules -> "mgen rules not terminated"
|
||||
| `Skip -> "mgen section not terminated"
|
||||
)
|
||||
| l :: ls -> (l, ls)
|
||||
in
|
||||
match st with
|
||||
| `Prefix ->
|
||||
let pfx = line :: pfx in
|
||||
if str_match begin_re line
|
||||
then
|
||||
let lofs = List.length pfx in
|
||||
go `Rules lofs pfx rules lines
|
||||
else go `Prefix 0 pfx rules lines
|
||||
| `Rules ->
|
||||
let pfx = line :: pfx in
|
||||
if str_match eoc_re line
|
||||
then go `Skip lofs pfx rules lines
|
||||
else go `Rules lofs pfx (line :: rules) lines
|
||||
| `Skip ->
|
||||
if str_match end_re line then
|
||||
let join = String.concat "\n" in
|
||||
let pfx = join (List.rev pfx) ^ "\n\n"
|
||||
and rules = join (List.rev rules)
|
||||
and sfx = join (line :: lines)
|
||||
in (lofs, pfx, rules, sfx)
|
||||
else go `Skip lofs pfx rules lines
|
||||
in
|
||||
|
||||
let lines = String.split_on_char '\n' src in
|
||||
go `Prefix 0 [] [] lines
|
||||
|
||||
let () =
|
||||
let usage_msg =
|
||||
"mgen [--fuzz] [--verbose <N>] <file>" in
|
||||
|
||||
let fuzz_arg = ref false in
|
||||
let verbose_arg = ref 0 in
|
||||
let input_paths = ref [] in
|
||||
|
||||
let anon_fun filename =
|
||||
input_paths := filename :: !input_paths in
|
||||
|
||||
let speclist =
|
||||
[ ( "--fuzz", Arg.Set fuzz_arg
|
||||
, " Fuzz tables and matchers" )
|
||||
; ( "--verbose", Arg.Set_int verbose_arg
|
||||
, "<N> Set verbosity level" )
|
||||
; ( "--", Arg.Rest_all (List.iter anon_fun)
|
||||
, " Stop argument parsing" ) ]
|
||||
in
|
||||
Arg.parse speclist anon_fun usage_msg;
|
||||
|
||||
let input_paths = !input_paths in
|
||||
let verbose = !verbose_arg in
|
||||
let fuzz = !fuzz_arg in
|
||||
let input_path, input =
|
||||
match input_paths with
|
||||
| ["-"] -> ("-", read_all stdin)
|
||||
| [path] -> (path, read_all (open_in path))
|
||||
| _ ->
|
||||
Printf.eprintf
|
||||
"%s: single input file expected\n"
|
||||
Sys.argv.(0);
|
||||
Arg.usage speclist usage_msg; exit 1
|
||||
in
|
||||
let mgen = mgen ~verbose ~fuzz in
|
||||
|
||||
if Str.last_chars input_path 2 <> ".c"
|
||||
then mgen input_path 0 input stdout
|
||||
else
|
||||
let tmp_path = input_path ^ ".tmp" in
|
||||
Fun.protect
|
||||
~finally:(fun () ->
|
||||
try Sys.remove tmp_path with _ -> ())
|
||||
(fun () ->
|
||||
let lofs, pfx, rules, sfx = split_c input in
|
||||
let oc = open_out tmp_path in
|
||||
output_string oc pfx;
|
||||
mgen input_path lofs rules oc;
|
||||
output_string oc sfx;
|
||||
close_out oc;
|
||||
Sys.rename tmp_path input_path;
|
||||
());
|
||||
|
||||
()
|
||||
651
src/qbe/tools/mgen/match.ml
Normal file
651
src/qbe/tools/mgen/match.ml
Normal file
@@ -0,0 +1,651 @@
|
||||
type cls = Kw | Kl | Ks | Kd
|
||||
type op_base =
|
||||
| Oadd
|
||||
| Osub
|
||||
| Omul
|
||||
| Oor
|
||||
| Oshl
|
||||
| Oshr
|
||||
type op = cls * op_base
|
||||
|
||||
let op_bases =
|
||||
[Oadd; Osub; Omul; Oor; Oshl; Oshr]
|
||||
|
||||
let commutative = function
|
||||
| (_, (Oadd | Omul | Oor)) -> true
|
||||
| (_, _) -> false
|
||||
|
||||
let associative = function
|
||||
| (_, (Oadd | Omul | Oor)) -> true
|
||||
| (_, _) -> false
|
||||
|
||||
type atomic_pattern =
|
||||
| Tmp
|
||||
| AnyCon
|
||||
| Con of int64
|
||||
(* Tmp < AnyCon < Con k *)
|
||||
|
||||
type pattern =
|
||||
| Bnr of op * pattern * pattern
|
||||
| Atm of atomic_pattern
|
||||
| Var of string * atomic_pattern
|
||||
|
||||
let is_atomic = function
|
||||
| (Atm _ | Var _) -> true
|
||||
| _ -> false
|
||||
|
||||
let show_op_base o =
|
||||
match o with
|
||||
| Oadd -> "add"
|
||||
| Osub -> "sub"
|
||||
| Omul -> "mul"
|
||||
| Oor -> "or"
|
||||
| Oshl -> "shl"
|
||||
| Oshr -> "shr"
|
||||
|
||||
let show_op (k, o) =
|
||||
show_op_base o ^
|
||||
(match k with
|
||||
| Kw -> "w"
|
||||
| Kl -> "l"
|
||||
| Ks -> "s"
|
||||
| Kd -> "d")
|
||||
|
||||
let rec show_pattern p =
|
||||
match p with
|
||||
| Atm Tmp -> "%"
|
||||
| Atm AnyCon -> "$"
|
||||
| Atm (Con n) -> Int64.to_string n
|
||||
| Var (v, p) ->
|
||||
show_pattern (Atm p) ^ "'" ^ v
|
||||
| Bnr (o, pl, pr) ->
|
||||
"(" ^ show_op o ^
|
||||
" " ^ show_pattern pl ^
|
||||
" " ^ show_pattern pr ^ ")"
|
||||
|
||||
let get_atomic p =
|
||||
match p with
|
||||
| (Atm a | Var (_, a)) -> Some a
|
||||
| _ -> None
|
||||
|
||||
let rec pattern_match p w =
|
||||
match p with
|
||||
| Var (_, p) ->
|
||||
pattern_match (Atm p) w
|
||||
| Atm Tmp ->
|
||||
begin match get_atomic w with
|
||||
| Some (Con _ | AnyCon) -> false
|
||||
| _ -> true
|
||||
end
|
||||
| Atm (Con _) -> w = p
|
||||
| Atm (AnyCon) ->
|
||||
not (pattern_match (Atm Tmp) w)
|
||||
| Bnr (o, pl, pr) ->
|
||||
begin match w with
|
||||
| Bnr (o', wl, wr) ->
|
||||
o' = o &&
|
||||
pattern_match pl wl &&
|
||||
pattern_match pr wr
|
||||
| _ -> false
|
||||
end
|
||||
|
||||
type +'a cursor = (* a position inside a pattern *)
|
||||
| Bnrl of op * 'a cursor * pattern
|
||||
| Bnrr of op * pattern * 'a cursor
|
||||
| Top of 'a
|
||||
|
||||
let rec fold_cursor c p =
|
||||
match c with
|
||||
| Bnrl (o, c', p') -> fold_cursor c' (Bnr (o, p, p'))
|
||||
| Bnrr (o, p', c') -> fold_cursor c' (Bnr (o, p', p))
|
||||
| Top _ -> p
|
||||
|
||||
let peel p x =
|
||||
let once out (p, c) =
|
||||
match p with
|
||||
| Var (_, p) -> (Atm p, c) :: out
|
||||
| Atm _ -> (p, c) :: out
|
||||
| Bnr (o, pl, pr) ->
|
||||
(pl, Bnrl (o, c, pr)) ::
|
||||
(pr, Bnrr (o, pl, c)) :: out
|
||||
in
|
||||
let rec go l =
|
||||
let l' = List.fold_left once [] l in
|
||||
if List.length l' = List.length l
|
||||
then l'
|
||||
else go l'
|
||||
in go [(p, Top x)]
|
||||
|
||||
let fold_pairs l1 l2 ini f =
|
||||
let rec go acc = function
|
||||
| [] -> acc
|
||||
| a :: l1' ->
|
||||
go (List.fold_left
|
||||
(fun acc b -> f (a, b) acc)
|
||||
acc l2) l1'
|
||||
in go ini l1
|
||||
|
||||
let iter_pairs l f =
|
||||
fold_pairs l l () (fun x () -> f x)
|
||||
|
||||
let inverse l =
|
||||
List.map (fun (a, b) -> (b, a)) l
|
||||
|
||||
type 'a state =
|
||||
{ id: int
|
||||
; seen: pattern
|
||||
; point: ('a cursor) list }
|
||||
|
||||
let rec binops side {point; _} =
|
||||
List.filter_map (fun c ->
|
||||
match c, side with
|
||||
| Bnrl (o, c, r), `L -> Some ((o, c), r)
|
||||
| Bnrr (o, l, c), `R -> Some ((o, c), l)
|
||||
| _ -> None)
|
||||
point
|
||||
|
||||
let group_by_fst l =
|
||||
List.fast_sort (fun (a, _) (b, _) ->
|
||||
compare a b) l |>
|
||||
List.fold_left (fun (oo, l, res) (o', c) ->
|
||||
match oo with
|
||||
| None -> (Some o', [c], [])
|
||||
| Some o when o = o' -> (oo, c :: l, res)
|
||||
| Some o -> (Some o', [c], (o, l) :: res))
|
||||
(None, [], []) |>
|
||||
(function
|
||||
| (None, _, _) -> []
|
||||
| (Some o, l, res) -> (o, l) :: res)
|
||||
|
||||
let sort_uniq cmp l =
|
||||
List.fast_sort cmp l |>
|
||||
List.fold_left (fun (eo, l) e' ->
|
||||
match eo with
|
||||
| None -> (Some e', l)
|
||||
| Some e when cmp e e' = 0 -> (eo, l)
|
||||
| Some e -> (Some e', e :: l))
|
||||
(None, []) |>
|
||||
(function
|
||||
| (None, _) -> []
|
||||
| (Some e, l) -> List.rev (e :: l))
|
||||
|
||||
let setify l =
|
||||
sort_uniq compare l
|
||||
|
||||
let normalize (point: ('a cursor) list) =
|
||||
setify point
|
||||
|
||||
let next_binary tmp s1 s2 =
|
||||
let pm w (_, p) = pattern_match p w in
|
||||
let o1 = binops `L s1 |>
|
||||
List.filter (pm s2.seen) |>
|
||||
List.map fst in
|
||||
let o2 = binops `R s2 |>
|
||||
List.filter (pm s1.seen) |>
|
||||
List.map fst in
|
||||
List.map (fun (o, l) ->
|
||||
o,
|
||||
{ id = -1
|
||||
; seen = Bnr (o, s1.seen, s2.seen)
|
||||
; point = normalize (l @ tmp) })
|
||||
(group_by_fst (o1 @ o2))
|
||||
|
||||
type p = string
|
||||
|
||||
module StateSet : sig
|
||||
type t
|
||||
val create: unit -> t
|
||||
val add: t -> p state ->
|
||||
[> `Added | `Found ] * p state
|
||||
val iter: t -> (p state -> unit) -> unit
|
||||
val elems: t -> (p state) list
|
||||
end = struct
|
||||
open Hashtbl.Make(struct
|
||||
type t = p state
|
||||
let equal s1 s2 = s1.point = s2.point
|
||||
let hash s = Hashtbl.hash s.point
|
||||
end)
|
||||
type nonrec t =
|
||||
{ h: int t
|
||||
; mutable next_id: int }
|
||||
let create () =
|
||||
{ h = create 500; next_id = 0 }
|
||||
let add set s =
|
||||
assert (s.point = normalize s.point);
|
||||
try
|
||||
let id = find set.h s in
|
||||
`Found, {s with id}
|
||||
with Not_found -> begin
|
||||
let id = set.next_id in
|
||||
set.next_id <- id + 1;
|
||||
add set.h s id;
|
||||
`Added, {s with id}
|
||||
end
|
||||
let iter set f =
|
||||
let f s id = f {s with id} in
|
||||
iter f set.h
|
||||
let elems set =
|
||||
let res = ref [] in
|
||||
iter set (fun s -> res := s :: !res);
|
||||
!res
|
||||
end
|
||||
|
||||
type table_key =
|
||||
| K of op * p state * p state
|
||||
|
||||
module StateMap = struct
|
||||
include Map.Make(struct
|
||||
type t = table_key
|
||||
let compare ka kb =
|
||||
match ka, kb with
|
||||
| K (o, sl, sr), K (o', sl', sr') ->
|
||||
compare (o, sl.id, sr.id)
|
||||
(o', sl'.id, sr'.id)
|
||||
end)
|
||||
let invert n sm =
|
||||
let rmap = Array.make n [] in
|
||||
iter (fun k {id; _} ->
|
||||
match k with
|
||||
| K (o, sl, sr) ->
|
||||
rmap.(id) <-
|
||||
(o, (sl.id, sr.id)) :: rmap.(id)
|
||||
) sm;
|
||||
Array.map group_by_fst rmap
|
||||
let by_ops sm =
|
||||
fold (fun tk s ops ->
|
||||
match tk with
|
||||
| K (op, l, r) ->
|
||||
(op, ((l.id, r.id), s.id)) :: ops)
|
||||
sm [] |> group_by_fst
|
||||
end
|
||||
|
||||
type rule =
|
||||
{ name: string
|
||||
; vars: string list
|
||||
; pattern: pattern }
|
||||
|
||||
let generate_table rl =
|
||||
let states = StateSet.create () in
|
||||
let rl =
|
||||
(* these atomic patterns must occur in
|
||||
* rules so that we are able to number
|
||||
* all possible refs *)
|
||||
[ { name = "$"; vars = []
|
||||
; pattern = Atm AnyCon }
|
||||
; { name = "%"; vars = []
|
||||
; pattern = Atm Tmp } ] @ rl
|
||||
in
|
||||
(* initialize states *)
|
||||
let ground =
|
||||
List.concat_map
|
||||
(fun r -> peel r.pattern r.name) rl |>
|
||||
group_by_fst
|
||||
in
|
||||
let tmp = List.assoc (Atm Tmp) ground in
|
||||
let con = List.assoc (Atm AnyCon) ground in
|
||||
let atoms = ref [] in
|
||||
let () =
|
||||
List.iter (fun (seen, l) ->
|
||||
let point =
|
||||
if pattern_match (Atm Tmp) seen
|
||||
then normalize (tmp @ l)
|
||||
else normalize (con @ l)
|
||||
in
|
||||
let s = {id = -1; seen; point} in
|
||||
let _, s = StateSet.add states s in
|
||||
match get_atomic seen with
|
||||
| Some atm -> atoms := (atm, s) :: !atoms
|
||||
| None -> ()
|
||||
) ground
|
||||
in
|
||||
(* setup loop state *)
|
||||
let map = ref StateMap.empty in
|
||||
let map_add k s' =
|
||||
map := StateMap.add k s' !map
|
||||
in
|
||||
let flag = ref `Added in
|
||||
let flagmerge = function
|
||||
| `Added -> flag := `Added
|
||||
| _ -> ()
|
||||
in
|
||||
(* iterate until fixpoint *)
|
||||
while !flag = `Added do
|
||||
flag := `Stop;
|
||||
let statel = StateSet.elems states in
|
||||
iter_pairs statel (fun (sl, sr) ->
|
||||
next_binary tmp sl sr |>
|
||||
List.iter (fun (o, s') ->
|
||||
let flag', s' =
|
||||
StateSet.add states s' in
|
||||
flagmerge flag';
|
||||
map_add (K (o, sl, sr)) s';
|
||||
));
|
||||
done;
|
||||
let states =
|
||||
StateSet.elems states |>
|
||||
List.sort (fun s s' -> compare s.id s'.id) |>
|
||||
Array.of_list
|
||||
in
|
||||
(states, !atoms, !map)
|
||||
|
||||
let intersperse x l =
|
||||
let rec go left right out =
|
||||
let out =
|
||||
(List.rev left @ [x] @ right) ::
|
||||
out in
|
||||
match right with
|
||||
| x :: right' ->
|
||||
go (x :: left) right' out
|
||||
| [] -> out
|
||||
in go [] l []
|
||||
|
||||
let rec permute = function
|
||||
| [] -> [[]]
|
||||
| x :: l ->
|
||||
List.concat (List.map
|
||||
(intersperse x) (permute l))
|
||||
|
||||
(* build all binary trees with ordered
|
||||
* leaves l *)
|
||||
let rec bins build l =
|
||||
let rec go l r out =
|
||||
match r with
|
||||
| [] -> out
|
||||
| x :: r' ->
|
||||
go (l @ [x]) r'
|
||||
(fold_pairs
|
||||
(bins build l)
|
||||
(bins build r)
|
||||
out (fun (l, r) out ->
|
||||
build l r :: out))
|
||||
in
|
||||
match l with
|
||||
| [] -> []
|
||||
| [x] -> [x]
|
||||
| x :: l -> go [x] l []
|
||||
|
||||
let products l ini f =
|
||||
let rec go acc la = function
|
||||
| [] -> f (List.rev la) acc
|
||||
| xs :: l ->
|
||||
List.fold_left (fun acc x ->
|
||||
go acc (x :: la) l)
|
||||
acc xs
|
||||
in go ini [] l
|
||||
|
||||
(* combinatorial nuke... *)
|
||||
let rec ac_equiv =
|
||||
let rec alevel o = function
|
||||
| Bnr (o', l, r) when o' = o ->
|
||||
alevel o l @ alevel o r
|
||||
| x -> [x]
|
||||
in function
|
||||
| Bnr (o, _, _) as p
|
||||
when associative o ->
|
||||
products
|
||||
(List.map ac_equiv (alevel o p)) []
|
||||
(fun choice out ->
|
||||
List.concat_map
|
||||
(bins (fun l r -> Bnr (o, l, r)))
|
||||
(if commutative o
|
||||
then permute choice
|
||||
else [choice]) @ out)
|
||||
| Bnr (o, l, r)
|
||||
when commutative o ->
|
||||
fold_pairs
|
||||
(ac_equiv l) (ac_equiv r) []
|
||||
(fun (l, r) out ->
|
||||
Bnr (o, l, r) ::
|
||||
Bnr (o, r, l) :: out)
|
||||
| Bnr (o, l, r) ->
|
||||
fold_pairs
|
||||
(ac_equiv l) (ac_equiv r) []
|
||||
(fun (l, r) out ->
|
||||
Bnr (o, l, r) :: out)
|
||||
| x -> [x]
|
||||
|
||||
module Action: sig
|
||||
type node =
|
||||
| Switch of (int * t) list
|
||||
| Push of bool * t
|
||||
| Pop of t
|
||||
| Set of string * t
|
||||
| Stop
|
||||
and t = private
|
||||
{ id: int; node: node }
|
||||
val equal: t -> t -> bool
|
||||
val size: t -> int
|
||||
val stop: t
|
||||
val mk_push: sym:bool -> t -> t
|
||||
val mk_pop: t -> t
|
||||
val mk_set: string -> t -> t
|
||||
val mk_switch: int list -> (int -> t) -> t
|
||||
val pp: Format.formatter -> t -> unit
|
||||
end = struct
|
||||
type node =
|
||||
| Switch of (int * t) list
|
||||
| Push of bool * t
|
||||
| Pop of t
|
||||
| Set of string * t
|
||||
| Stop
|
||||
and t =
|
||||
{ id: int; node: node }
|
||||
|
||||
let equal a a' = a.id = a'.id
|
||||
let size a =
|
||||
let seen = Hashtbl.create 10 in
|
||||
let rec node_size = function
|
||||
| Switch l ->
|
||||
List.fold_left
|
||||
(fun n (_, a) -> n + size a) 0 l
|
||||
| (Push (_, a) | Pop a | Set (_, a)) ->
|
||||
size a
|
||||
| Stop -> 0
|
||||
and size {id; node} =
|
||||
if Hashtbl.mem seen id
|
||||
then 0
|
||||
else begin
|
||||
Hashtbl.add seen id ();
|
||||
1 + node_size node
|
||||
end
|
||||
in
|
||||
size a
|
||||
|
||||
let mk =
|
||||
let hcons = Hashtbl.create 100 in
|
||||
let fresh = ref 0 in
|
||||
fun node ->
|
||||
let id =
|
||||
try Hashtbl.find hcons node
|
||||
with Not_found ->
|
||||
let id = !fresh in
|
||||
Hashtbl.add hcons node id;
|
||||
fresh := id + 1;
|
||||
id
|
||||
in
|
||||
{id; node}
|
||||
let stop = mk Stop
|
||||
let mk_push ~sym a = mk (Push (sym, a))
|
||||
let mk_pop a =
|
||||
match a.node with
|
||||
| Stop -> a
|
||||
| _ -> mk (Pop a)
|
||||
let mk_set v a = mk (Set (v, a))
|
||||
let mk_switch ids f =
|
||||
match List.map f ids with
|
||||
| [] -> failwith "empty switch";
|
||||
| c :: cs as cases ->
|
||||
if List.for_all (equal c) cs then c
|
||||
else
|
||||
let cases = List.combine ids cases in
|
||||
mk (Switch cases)
|
||||
|
||||
open Format
|
||||
let rec pp_node fmt = function
|
||||
| Switch l ->
|
||||
fprintf fmt "@[<v>@[<v2>switch{";
|
||||
let pp_case (c, a) =
|
||||
let pp_sep fmt () = fprintf fmt "," in
|
||||
fprintf fmt "@,@[<2>→%a:@ @[%a@]@]"
|
||||
(pp_print_list ~pp_sep pp_print_int)
|
||||
c pp a
|
||||
in
|
||||
inverse l |> group_by_fst |> inverse |>
|
||||
List.iter pp_case;
|
||||
fprintf fmt "@]@,}@]"
|
||||
| Push (true, a) -> fprintf fmt "pushsym@ %a" pp a
|
||||
| Push (false, a) -> fprintf fmt "push@ %a" pp a
|
||||
| Pop a -> fprintf fmt "pop@ %a" pp a
|
||||
| Set (v, a) -> fprintf fmt "set(%s)@ %a" v pp a
|
||||
| Stop -> fprintf fmt "•"
|
||||
and pp fmt a = pp_node fmt a.node
|
||||
end
|
||||
|
||||
(* a state is commutative if (a op b) enters
|
||||
* it iff (b op a) enters it as well *)
|
||||
let symmetric rmap id =
|
||||
List.for_all (fun (_, l) ->
|
||||
let l1, l2 =
|
||||
List.filter (fun (a, b) -> a <> b) l |>
|
||||
List.partition (fun (a, b) -> a < b)
|
||||
in
|
||||
setify l1 = setify (inverse l2))
|
||||
rmap.(id)
|
||||
|
||||
(* left-to-right matching of a set of patterns;
|
||||
* may raise if there is no lr matcher for the
|
||||
* input rule *)
|
||||
let lr_matcher statemap states rules name =
|
||||
let rmap =
|
||||
let nstates = Array.length states in
|
||||
StateMap.invert nstates statemap
|
||||
in
|
||||
let exception Stuck in
|
||||
(* the list of ids represents a class of terms
|
||||
* whose root ends up being labelled with one
|
||||
* such id; the gen function generates a matcher
|
||||
* that will, given any such term, assign values
|
||||
* for the Var nodes of one pattern in pats *)
|
||||
let rec gen
|
||||
: 'a. int list -> (pattern * 'a) list
|
||||
-> (int -> (pattern * 'a) list -> Action.t)
|
||||
-> Action.t
|
||||
= fun ids pats k ->
|
||||
Action.mk_switch (setify ids) @@ fun id_top ->
|
||||
let sym = symmetric rmap id_top in
|
||||
let id_ops =
|
||||
if sym then
|
||||
let ordered (a, b) = a <= b in
|
||||
List.map (fun (o, l) ->
|
||||
(o, List.filter ordered l))
|
||||
rmap.(id_top)
|
||||
else rmap.(id_top)
|
||||
in
|
||||
(* consider only the patterns that are
|
||||
* compatible with the current id *)
|
||||
let atm_pats, bin_pats =
|
||||
List.filter (function
|
||||
| Bnr (o, _, _), _ ->
|
||||
List.exists
|
||||
(fun (o', _) -> o' = o)
|
||||
id_ops
|
||||
| _ -> true) pats |>
|
||||
List.partition
|
||||
(fun (pat, _) -> is_atomic pat)
|
||||
in
|
||||
try
|
||||
if bin_pats = [] then raise Stuck;
|
||||
let pats_l =
|
||||
List.map (function
|
||||
| (Bnr (o, l, r), x) ->
|
||||
(l, (o, x, r))
|
||||
| _ -> assert false)
|
||||
bin_pats
|
||||
and pats_r =
|
||||
List.map (fun (l, (o, x, r)) ->
|
||||
(r, (o, l, x)))
|
||||
and patstop =
|
||||
List.map (fun (r, (o, l, x)) ->
|
||||
(Bnr (o, l, r), x))
|
||||
in
|
||||
let id_pairs = List.concat_map snd id_ops in
|
||||
let ids_l = List.map fst id_pairs
|
||||
and ids_r id_left =
|
||||
List.filter_map (fun (l, r) ->
|
||||
if l = id_left then Some r else None)
|
||||
id_pairs
|
||||
in
|
||||
(* match the left arm *)
|
||||
Action.mk_push ~sym
|
||||
(gen ids_l pats_l
|
||||
@@ fun lid pats ->
|
||||
(* then the right arm, considering
|
||||
* only the remaining possible
|
||||
* patterns and knowing that the
|
||||
* left arm was numbered 'lid' *)
|
||||
Action.mk_pop
|
||||
(gen (ids_r lid) (pats_r pats)
|
||||
@@ fun _rid pats ->
|
||||
(* continue with the parent *)
|
||||
k id_top (patstop pats)))
|
||||
with Stuck ->
|
||||
let atm_pats =
|
||||
let seen = states.(id_top).seen in
|
||||
List.filter (fun (pat, _) ->
|
||||
pattern_match pat seen) atm_pats
|
||||
in
|
||||
if atm_pats = [] then raise Stuck else
|
||||
let vars =
|
||||
List.filter_map (function
|
||||
| (Var (v, _), _) -> Some v
|
||||
| _ -> None) atm_pats |> setify
|
||||
in
|
||||
match vars with
|
||||
| [] -> k id_top atm_pats
|
||||
| [v] -> Action.mk_set v (k id_top atm_pats)
|
||||
| _ -> failwith "ambiguous var match"
|
||||
in
|
||||
(* generate a matcher for the rule *)
|
||||
let ids_top =
|
||||
Array.to_list states |>
|
||||
List.filter_map (fun {id; point = p; _} ->
|
||||
if List.exists ((=) (Top name)) p then
|
||||
Some id
|
||||
else None)
|
||||
in
|
||||
let rec filter_dups pats =
|
||||
match pats with
|
||||
| p :: pats ->
|
||||
if List.exists (pattern_match p) pats
|
||||
then filter_dups pats
|
||||
else p :: filter_dups pats
|
||||
| [] -> []
|
||||
in
|
||||
let pats_top =
|
||||
List.filter_map (fun r ->
|
||||
if r.name = name then
|
||||
Some r.pattern
|
||||
else None) rules |>
|
||||
filter_dups |>
|
||||
List.map (fun p -> (p, ()))
|
||||
in
|
||||
gen ids_top pats_top (fun _ pats ->
|
||||
assert (pats <> []);
|
||||
Action.stop)
|
||||
|
||||
type numberer =
|
||||
{ atoms: (atomic_pattern * p state) list
|
||||
; statemap: p state StateMap.t
|
||||
; states: p state array
|
||||
; mutable ops: op list
|
||||
(* memoizes the list of possible operations
|
||||
* according to the statemap *) }
|
||||
|
||||
let make_numberer sa am sm =
|
||||
{ atoms = am
|
||||
; states = sa
|
||||
; statemap = sm
|
||||
; ops = [] }
|
||||
|
||||
let atom_state n atm =
|
||||
List.assoc atm n.atoms
|
||||
292
src/qbe/tools/mgen/sexp.ml
Normal file
292
src/qbe/tools/mgen/sexp.ml
Normal file
@@ -0,0 +1,292 @@
|
||||
type pstate =
|
||||
{ data: string
|
||||
; line: int
|
||||
; coln: int
|
||||
; indx: int }
|
||||
|
||||
type perror =
|
||||
{ error: string
|
||||
; ps: pstate }
|
||||
|
||||
exception ParseError of perror
|
||||
|
||||
type 'a parser =
|
||||
{ fn: 'r. pstate -> ('a -> pstate -> 'r) -> 'r }
|
||||
|
||||
let update_pos ps beg fin =
|
||||
let l, c = (ref ps.line, ref ps.coln) in
|
||||
for i = beg to fin - 1 do
|
||||
if ps.data.[i] = '\n' then
|
||||
(incr l; c := 0)
|
||||
else
|
||||
incr c
|
||||
done;
|
||||
{ ps with line = !l; coln = !c }
|
||||
|
||||
let pret (type a) (x: a): a parser =
|
||||
let fn ps k = k x ps in { fn }
|
||||
|
||||
let pfail error: 'a parser =
|
||||
let fn ps _ = raise (ParseError {error; ps})
|
||||
in { fn }
|
||||
|
||||
let por: 'a parser -> 'a parser -> 'a parser =
|
||||
fun p1 p2 ->
|
||||
let fn ps k =
|
||||
try p1.fn ps k with ParseError e1 ->
|
||||
try p2.fn ps k with ParseError e2 ->
|
||||
if e1.ps.indx > e2.ps.indx then
|
||||
raise (ParseError e1)
|
||||
else
|
||||
raise (ParseError e2)
|
||||
in { fn }
|
||||
|
||||
let pbind: 'a parser -> ('a -> 'b parser) -> 'b parser =
|
||||
fun p1 p2 ->
|
||||
let fn ps k =
|
||||
p1.fn ps (fun x ps -> (p2 x).fn ps k)
|
||||
in { fn }
|
||||
|
||||
(* handy for recursive rules *)
|
||||
let papp p x = pbind (pret x) p
|
||||
|
||||
let psnd: 'a parser -> 'b parser -> 'b parser =
|
||||
fun p1 p2 -> pbind p1 (fun _x -> p2)
|
||||
|
||||
let pfst: 'a parser -> 'b parser -> 'a parser =
|
||||
fun p1 p2 -> pbind p1 (fun x -> psnd p2 (pret x))
|
||||
|
||||
module Infix = struct
|
||||
let ( let* ) = pbind
|
||||
let ( ||| ) = por
|
||||
let ( |<< ) = pfst
|
||||
let ( |>> ) = psnd
|
||||
end
|
||||
|
||||
open Infix
|
||||
|
||||
let pre: ?what:string -> string -> string parser =
|
||||
fun ?what re ->
|
||||
let what =
|
||||
match what with
|
||||
| None -> Printf.sprintf "%S" re
|
||||
| Some what -> what
|
||||
and re = Str.regexp re in
|
||||
let fn ps k =
|
||||
if not (Str.string_match re ps.data ps.indx) then
|
||||
(let error =
|
||||
Printf.sprintf "expected to match %s" what in
|
||||
raise (ParseError {error; ps}));
|
||||
let ps =
|
||||
let indx = Str.match_end () in
|
||||
{ (update_pos ps ps.indx indx) with indx }
|
||||
in
|
||||
k (Str.matched_string ps.data) ps
|
||||
in { fn }
|
||||
|
||||
let peoi: unit parser =
|
||||
let fn ps k =
|
||||
if ps.indx <> String.length ps.data then
|
||||
raise (ParseError
|
||||
{ error = "expected end of input"; ps });
|
||||
k () ps
|
||||
in { fn }
|
||||
|
||||
let pws = pre "[ \r\n\t*]*"
|
||||
let pws1 = pre "[ \r\n\t*]+"
|
||||
|
||||
let pthen p1 p2 =
|
||||
let* x1 = p1 in
|
||||
let* x2 = p2 in
|
||||
pret (x1, x2)
|
||||
|
||||
let rec plist_tail: 'a parser -> ('a list) parser =
|
||||
fun pitem ->
|
||||
(pws |>> pre ")" |>> pret []) |||
|
||||
(let* itm = pitem in
|
||||
let* itms = plist_tail pitem in
|
||||
pret (itm :: itms))
|
||||
|
||||
let plist pitem =
|
||||
pws |>> pre ~what:"a list" "("
|
||||
|>> plist_tail pitem
|
||||
|
||||
let plist1p p1 pitem =
|
||||
pws |>> pre ~what:"a list" "("
|
||||
|>> pthen p1 (plist_tail pitem)
|
||||
|
||||
let ppair p1 p2 =
|
||||
pws |>> pre ~what:"a pair" "("
|
||||
|>> pthen p1 p2 |<< pws |<< pre ")"
|
||||
|
||||
let run_parser p s =
|
||||
let ps =
|
||||
{data = s; line = 1; coln = 0; indx = 0} in
|
||||
try `Ok (p.fn ps (fun res _ps -> res))
|
||||
with ParseError e ->
|
||||
let rec bol i =
|
||||
if i = 0 then i else
|
||||
if i < String.length s && s.[i] = '\n'
|
||||
then i+1 (* XXX BUG *)
|
||||
else bol (i-1)
|
||||
in
|
||||
let rec eol i =
|
||||
if i = String.length s then i else
|
||||
if s.[i] = '\n' then i else
|
||||
eol (i+1)
|
||||
in
|
||||
let bol = bol e.ps.indx in
|
||||
let eol = eol e.ps.indx in
|
||||
(*
|
||||
Printf.eprintf "bol:%d eol:%d indx:%d len:%d\n"
|
||||
bol eol e.ps.indx (String.length s); (* XXX debug *)
|
||||
*)
|
||||
let lines =
|
||||
String.split_on_char '\n'
|
||||
(String.sub s bol (eol - bol))
|
||||
in
|
||||
let nl = List.length lines in
|
||||
let caret = ref (e.ps.indx - bol) in
|
||||
let msg = ref [] in
|
||||
let pfx = " > " in
|
||||
lines |> List.iteri (fun ln l ->
|
||||
if ln <> nl - 1 || l <> "" then begin
|
||||
let ll = String.length l + 1 in
|
||||
msg := (pfx ^ l ^ "\n") :: !msg;
|
||||
if !caret <= ll then begin
|
||||
let pad = String.make !caret ' ' in
|
||||
msg := (pfx ^ pad ^ "^\n") :: !msg;
|
||||
end;
|
||||
caret := !caret - ll;
|
||||
end;
|
||||
);
|
||||
`Error
|
||||
( e.ps, e.error
|
||||
, String.concat "" (List.rev !msg) )
|
||||
|
||||
(* ---------------------------------------- *)
|
||||
(* pattern parsing *)
|
||||
(* ---------------------------------------- *)
|
||||
(* Example syntax:
|
||||
|
||||
(with-vars (a b c d)
|
||||
(patterns
|
||||
(ob (add (tmp a) (con d)))
|
||||
(bsm (add (tmp b) (mul (tmp m) (con 2 4 8)))) ))
|
||||
*)
|
||||
open Match
|
||||
|
||||
let pint64 =
|
||||
let* s = pre "[-]?[0-9_]+" in
|
||||
pret (Int64.of_string s)
|
||||
|
||||
let pid =
|
||||
pre ~what:"an identifer"
|
||||
"[a-zA-Z][a-zA-Z0-9_]*"
|
||||
|
||||
let pop_base =
|
||||
let sob, obs = show_op_base, op_bases in
|
||||
let* s = pre ~what:"an operator"
|
||||
(String.concat "\\|" (List.map sob obs))
|
||||
in pret (List.find (fun o -> s = sob o) obs)
|
||||
|
||||
let pop = let* ob = pop_base in pret (Kl, ob)
|
||||
|
||||
let rec ppat vs =
|
||||
let pcons_tail =
|
||||
let* cs = plist_tail (pws1 |>> pint64) in
|
||||
match cs with
|
||||
| [] -> pret [AnyCon]
|
||||
| _ -> pret (List.map (fun c -> Con c) cs)
|
||||
in
|
||||
let pvar =
|
||||
let* id = pid in
|
||||
if not (List.mem id vs) then
|
||||
pfail ("unbound variable: " ^ id)
|
||||
else
|
||||
pret id
|
||||
in
|
||||
pws |>> (
|
||||
( let* c = pint64 in pret [Atm (Con c)] )
|
||||
|||
|
||||
( pre "(con)" |>> pret [Atm AnyCon] ) |||
|
||||
( let* cs = pre "(con" |>> pcons_tail in
|
||||
pret (List.map (fun c -> Atm c) cs) ) |||
|
||||
( let* v = pre "(con" |>> pws1 |>> pvar in
|
||||
let* cs = pcons_tail in
|
||||
pret (List.map (fun c -> Var (v, c)) cs) )
|
||||
|||
|
||||
( pre "(tmp)" |>> pret [Atm Tmp] ) |||
|
||||
( let* v = pre "(tmp" |>> pws1 |>> pvar in
|
||||
pws |>> pre ")" |>> pret [Var (v, Tmp)] )
|
||||
|||
|
||||
( let* (op, rands) =
|
||||
plist1p (pws |>> pop) (papp ppat vs) in
|
||||
let nrands = List.length rands in
|
||||
if nrands < 2 then
|
||||
pfail ( "binary op requires at least"
|
||||
^ " two arguments" )
|
||||
else
|
||||
let mk x y = Bnr (op, x, y) in
|
||||
pret
|
||||
(products rands []
|
||||
(fun rands pats ->
|
||||
(* construct a left-heavy tree *)
|
||||
let r0 = List.hd rands in
|
||||
let rs = List.tl rands in
|
||||
List.fold_left mk r0 rs :: pats)) )
|
||||
)
|
||||
|
||||
let pwith_vars ?(vs = []) p =
|
||||
( let* vs =
|
||||
pws |>> pre "(with-vars" |>> pws |>>
|
||||
plist (pws |>> pid)
|
||||
in pws |>> p vs |<< pws |<< pre ")" )
|
||||
||| p vs
|
||||
|
||||
let ppats =
|
||||
pwith_vars @@ fun vs ->
|
||||
pre "(patterns" |>> plist_tail
|
||||
(pwith_vars ~vs @@ fun vs ->
|
||||
let* n, ps = ppair pid (ppat vs) in
|
||||
pret (n, vs, ps))
|
||||
|
||||
(* ---------------------------------------- *)
|
||||
(* tests *)
|
||||
(* ---------------------------------------- *)
|
||||
|
||||
let () =
|
||||
if false then
|
||||
let show_patterns ps =
|
||||
"[" ^ String.concat "; "
|
||||
(List.map show_pattern ps) ^ "]"
|
||||
in
|
||||
let pat s =
|
||||
Printf.printf "parse %s = " s;
|
||||
let vars =
|
||||
[ "foobar"; "a"; "b"; "d"
|
||||
; "m"; "s"; "x" ]
|
||||
in
|
||||
match run_parser (ppat vars) s with
|
||||
| `Ok p ->
|
||||
Printf.printf "%s\n" (show_patterns p)
|
||||
| `Error (_, e, _) ->
|
||||
Printf.printf "ERROR: %s\n" e
|
||||
in
|
||||
pat "42";
|
||||
pat "(tmp)";
|
||||
pat "(tmp foobar)";
|
||||
pat "(con)";
|
||||
pat "(con 1 2 3)";
|
||||
pat "(con x 1 2 3)";
|
||||
pat "(add 1 2)";
|
||||
pat "(add 1 2 3 4)";
|
||||
pat "(sub 1 2)";
|
||||
pat "(sub 1 2 3)";
|
||||
pat "(tmp unbound_var)";
|
||||
pat "(add 0)";
|
||||
pat "(add 1 (add 2 3))";
|
||||
pat "(add (tmp a) (con d))";
|
||||
pat "(add (tmp b) (mul (tmp m) (con s 2 4 8)))";
|
||||
pat "(add (con 1 2) (con 3 4))";
|
||||
()
|
||||
134
src/qbe/tools/mgen/test.ml
Normal file
134
src/qbe/tools/mgen/test.ml
Normal file
@@ -0,0 +1,134 @@
|
||||
open Match
|
||||
open Fuzz
|
||||
open Cgen
|
||||
|
||||
(* unit tests *)
|
||||
|
||||
let test_pattern_match =
|
||||
let pm = pattern_match
|
||||
and nm = fun x y -> not (pattern_match x y) in
|
||||
begin
|
||||
assert (nm (Atm Tmp) (Atm (Con 42L)));
|
||||
assert (pm (Atm AnyCon) (Atm (Con 42L)));
|
||||
assert (nm (Atm (Con 42L)) (Atm AnyCon));
|
||||
assert (nm (Atm (Con 42L)) (Atm Tmp));
|
||||
end
|
||||
|
||||
let test_peel =
|
||||
let o = Kw, Oadd in
|
||||
let p = Bnr (o, Bnr (o, Atm Tmp, Atm Tmp),
|
||||
Atm (Con 42L)) in
|
||||
let l = peel p () in
|
||||
let () = assert (List.length l = 3) in
|
||||
let atomic_p (p, _) =
|
||||
match p with Atm _ -> true | _ -> false in
|
||||
let () = assert (List.for_all atomic_p l) in
|
||||
let l = List.map (fun (p, c) -> fold_cursor c p) l in
|
||||
let () = assert (List.for_all ((=) p) l) in
|
||||
()
|
||||
|
||||
let test_fold_pairs =
|
||||
let l = [1; 2; 3; 4; 5] in
|
||||
let p = fold_pairs l l [] (fun a b -> a :: b) in
|
||||
let () = assert (List.length p = 25) in
|
||||
let p = sort_uniq compare p in
|
||||
let () = assert (List.length p = 25) in
|
||||
()
|
||||
|
||||
(* test pattern & state *)
|
||||
|
||||
let print_sm oc =
|
||||
StateMap.iter (fun k s' ->
|
||||
match k with
|
||||
| K (o, sl, sr) ->
|
||||
let top =
|
||||
List.fold_left (fun top c ->
|
||||
match c with
|
||||
| Top r -> top ^ " " ^ r
|
||||
| _ -> top) "" s'.point
|
||||
in
|
||||
Printf.fprintf oc
|
||||
" (%s %d %d) -> %d%s\n"
|
||||
(show_op o)
|
||||
sl.id sr.id s'.id top)
|
||||
|
||||
let rules =
|
||||
let oa = Kl, Oadd in
|
||||
let om = Kl, Omul in
|
||||
let va = Var ("a", Tmp)
|
||||
and vb = Var ("b", Tmp)
|
||||
and vc = Var ("c", Tmp)
|
||||
and vs = Var ("s", Tmp) in
|
||||
let vars = ["a"; "b"; "c"; "s"] in
|
||||
let rule name pattern =
|
||||
List.map
|
||||
(fun pattern -> {name; vars; pattern})
|
||||
(ac_equiv pattern)
|
||||
in
|
||||
match `X64Addr with
|
||||
(* ------------------------------- *)
|
||||
| `X64Addr ->
|
||||
(* o + b *)
|
||||
rule "ob" (Bnr (oa, Atm Tmp, Atm AnyCon))
|
||||
@ (* b + s * m *)
|
||||
rule "bsm" (Bnr (oa, vb, Bnr (om, Var ("m", Con 2L), vs)))
|
||||
@
|
||||
rule "bsm" (Bnr (oa, vb, Bnr (om, Var ("m", Con 4L), vs)))
|
||||
@
|
||||
rule "bsm" (Bnr (oa, vb, Bnr (om, Var ("m", Con 8L), vs)))
|
||||
@ (* b + s *)
|
||||
rule "bs1" (Bnr (oa, vb, vs))
|
||||
@ (* o + s * m *)
|
||||
(* rule "osm" (Bnr (oa, Atm AnyCon, Bnr (om, Atm (Con 4L), Atm Tmp))) *) []
|
||||
@ (* o + b + s *)
|
||||
rule "obs1" (Bnr (oa, Bnr (oa, Var ("o", AnyCon), vb), vs))
|
||||
@ (* o + b + s * m *)
|
||||
rule "obsm" (Bnr (oa, Bnr (oa, Var ("o", AnyCon), vb),
|
||||
Bnr (om, Var ("m", Con 2L), vs)))
|
||||
@
|
||||
rule "obsm" (Bnr (oa, Bnr (oa, Var ("o", AnyCon), vb),
|
||||
Bnr (om, Var ("m", Con 4L), vs)))
|
||||
@
|
||||
rule "obsm" (Bnr (oa, Bnr (oa, Var ("o", AnyCon), vb),
|
||||
Bnr (om, Var ("m", Con 8L), vs)))
|
||||
(* ------------------------------- *)
|
||||
| `Add3 ->
|
||||
[ { name = "add"
|
||||
; vars = []
|
||||
; pattern = Bnr (oa, va, Bnr (oa, vb, vc)) } ] @
|
||||
[ { name = "add"
|
||||
; vars = []
|
||||
; pattern = Bnr (oa, Bnr (oa, va, vb), vc) } ]
|
||||
|
||||
(*
|
||||
|
||||
let sa, am, sm = generate_table rules
|
||||
let () =
|
||||
Array.iteri (fun i s ->
|
||||
Format.printf "@[state %d: %s@]@."
|
||||
i (show_pattern s.seen))
|
||||
sa
|
||||
let () = print_sm stdout sm; flush stdout
|
||||
|
||||
let matcher = lr_matcher sm sa rules "obsm" (* XXX *)
|
||||
let () = Format.printf "@[<v>%a@]@." Action.pp matcher
|
||||
let () = Format.printf "@[matcher size: %d@]@." (Action.size matcher)
|
||||
|
||||
let numbr = make_numberer sa am sm
|
||||
|
||||
let () =
|
||||
let opts = { pfx = ""
|
||||
; static = true
|
||||
; oc = stdout } in
|
||||
emit_c opts numbr;
|
||||
emit_matchers opts
|
||||
[ ( ["b"; "o"; "s"; "m"]
|
||||
, "obsm"
|
||||
, matcher ) ]
|
||||
|
||||
(*
|
||||
let tp = fuzz_numberer rules numbr
|
||||
let () = test_matchers tp numbr rules
|
||||
*)
|
||||
|
||||
*)
|
||||
262
src/qbe/tools/pmov.c
Normal file
262
src/qbe/tools/pmov.c
Normal file
@@ -0,0 +1,262 @@
|
||||
/*% rm -f rega.o main.o && cc -g -std=c99 -Wall -DTEST_PMOV -o pmov % *.o
|
||||
*
|
||||
* This is a test framwork for the dopm() function
|
||||
* in rega.c, use it when you want to modify it or
|
||||
* all the parallel move functions.
|
||||
*
|
||||
* You might need to decrease NIReg to see it
|
||||
* terminate, I used NIReg == 7 at most.
|
||||
*/
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
|
||||
static void assert_test(char *, int), fail(void), iexec(int *);
|
||||
|
||||
#include "../../rega.c"
|
||||
|
||||
static void bsinit_(BSet *, uint);
|
||||
|
||||
static RMap mbeg;
|
||||
static Ins ins[NIReg], *ip;
|
||||
static Blk dummyb = { .ins = ins };
|
||||
|
||||
int
|
||||
main()
|
||||
{
|
||||
Ins *i1;
|
||||
unsigned long long tm, rm, cnt;
|
||||
RMap mend;
|
||||
int reg[NIReg], val[NIReg+1];
|
||||
int t, i, r, nr;
|
||||
|
||||
tmp = (Tmp[Tmp0+NIReg]){{{0}}};
|
||||
for (t=0; t<Tmp0+NIReg; t++)
|
||||
if (t >= Tmp0) {
|
||||
tmp[t].cls = Kw;
|
||||
tmp[t].hint.r = -1;
|
||||
tmp[t].hint.m = 0;
|
||||
tmp[t].slot = -1;
|
||||
sprintf(tmp[t].name, "tmp%d", t-Tmp0+1);
|
||||
}
|
||||
|
||||
bsinit_(mbeg.b, Tmp0+NIReg);
|
||||
bsinit_(mend.b, Tmp0+NIReg);
|
||||
cnt = 0;
|
||||
for (tm = 0; tm < 1ull << (2*NIReg); tm++) {
|
||||
mbeg.n = 0;
|
||||
bszero(mbeg.b);
|
||||
ip = ins;
|
||||
|
||||
/* find what temporaries are in copy and
|
||||
* wether or not they are in register
|
||||
*/
|
||||
for (t=0; t<NIReg; t++)
|
||||
switch ((tm >> (2*t)) & 3) {
|
||||
case 0:
|
||||
/* not in copy, not in reg */
|
||||
break;
|
||||
case 1:
|
||||
/* not in copy, in reg */
|
||||
radd(&mbeg, Tmp0+t, t+1);
|
||||
break;
|
||||
case 2:
|
||||
/* in copy, not in reg */
|
||||
*ip++ = (Ins){OCopy, Kw, TMP(Tmp0+t), {R, R}};
|
||||
break;
|
||||
case 3:
|
||||
/* in copy, in reg */
|
||||
*ip++ = (Ins){OCopy, Kw, TMP(Tmp0+t), {R, R}};
|
||||
radd(&mbeg, Tmp0+t, t+1);
|
||||
break;
|
||||
}
|
||||
|
||||
if (ip == ins)
|
||||
/* cancel if the parallel move
|
||||
* is empty
|
||||
*/
|
||||
goto Nxt;
|
||||
|
||||
/* find registers for temporaries
|
||||
* in mbeg
|
||||
*/
|
||||
nr = ip - ins;
|
||||
rm = (1ull << (nr+1)) - 1;
|
||||
for (i=0; i<nr; i++)
|
||||
reg[i] = i+1;
|
||||
|
||||
for (;;) {
|
||||
/* set registers on copies
|
||||
*/
|
||||
for (i=0, i1=ins; i1<ip; i1++, i++)
|
||||
i1->arg[0] = TMP(reg[i]);
|
||||
|
||||
/* compile the parallel move
|
||||
*/
|
||||
rcopy(&mend, &mbeg);
|
||||
dopm(&dummyb, ip-1, &mend);
|
||||
cnt++;
|
||||
|
||||
/* check that mend contain mappings for
|
||||
* source registers and does not map any
|
||||
* assigned temporary, then check that
|
||||
* all temporaries in mend are mapped in
|
||||
* mbeg and not used in the copy
|
||||
*/
|
||||
for (i1=ins; i1<ip; i1++) {
|
||||
r = i1->arg[0].val;
|
||||
assert(rfree(&mend, r) == r);
|
||||
t = i1->to.val;
|
||||
assert(!bshas(mend.b, t));
|
||||
}
|
||||
for (i=0; i<mend.n; i++) {
|
||||
t = mend.t[i];
|
||||
assert(bshas(mbeg.b, t));
|
||||
t -= Tmp0;
|
||||
assert(((tm >> (2*t)) & 3) == 1);
|
||||
}
|
||||
|
||||
/* execute the code generated and check
|
||||
* that all assigned temporaries got their
|
||||
* value, and that all live variables's
|
||||
* content got preserved
|
||||
*/
|
||||
for (i=1; i<=NIReg; i++)
|
||||
val[i] = i;
|
||||
iexec(val);
|
||||
for (i1=ins; i1<ip; i1++) {
|
||||
t = i1->to.val;
|
||||
r = rfind(&mbeg, t);
|
||||
if (r != -1)
|
||||
assert(val[r] == i1->arg[0].val);
|
||||
}
|
||||
for (i=0; i<mend.n; i++) {
|
||||
t = mend.t[i];
|
||||
r = mend.r[i];
|
||||
assert(val[t-Tmp0+1] == r);
|
||||
}
|
||||
|
||||
/* find the next register assignment */
|
||||
i = nr - 1;
|
||||
for (;;) {
|
||||
r = reg[i];
|
||||
rm &= ~(1ull<<r);
|
||||
do
|
||||
r++;
|
||||
while (r <= NIReg && (rm & (1ull<<r)));
|
||||
if (r == NIReg+1) {
|
||||
if (i == 0)
|
||||
goto Nxt;
|
||||
i--;
|
||||
} else {
|
||||
rm |= (1ull<<r);
|
||||
reg[i++] = r;
|
||||
break;
|
||||
}
|
||||
}
|
||||
for (; i<nr; i++)
|
||||
for (r=1; r<=NIReg; r++)
|
||||
if (!(rm & (1ull<<r))) {
|
||||
rm |= (1ull<<r);
|
||||
reg[i] = r;
|
||||
break;
|
||||
}
|
||||
}
|
||||
Nxt: freeall();
|
||||
}
|
||||
printf("%llu tests successful!\n", cnt);
|
||||
exit(0);
|
||||
}
|
||||
|
||||
|
||||
/* execute what pmgen() wrote (swap, copy) */
|
||||
|
||||
#define validr(r) \
|
||||
rtype(r) == RTmp && \
|
||||
r.val > 0 && \
|
||||
r.val <= NIReg
|
||||
|
||||
static void
|
||||
iexec(int val[])
|
||||
{
|
||||
Ins *i;
|
||||
int t;
|
||||
|
||||
for (i=insb; i<curi; i++)
|
||||
switch (i->op) {
|
||||
default:
|
||||
assert(!"iexec: missing case\n");
|
||||
exit(1);
|
||||
case OSwap:
|
||||
assert(validr(i->arg[0]));
|
||||
assert(validr(i->arg[1]));
|
||||
t = val[i->arg[0].val];
|
||||
val[i->arg[0].val] = val[i->arg[1].val];
|
||||
val[i->arg[1].val] = t;
|
||||
break;
|
||||
case OCopy:
|
||||
assert(validr(i->to));
|
||||
assert(validr(i->arg[0]));
|
||||
val[i->to.val] = val[i->arg[0].val];
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/* failure diagnostics */
|
||||
|
||||
static int re;
|
||||
|
||||
static void
|
||||
replay()
|
||||
{
|
||||
RMap mend;
|
||||
|
||||
re = 1;
|
||||
bsinit_(mend.b, Tmp0+NIReg);
|
||||
rcopy(&mend, &mbeg);
|
||||
dopm(&dummyb, ip-1, &mend);
|
||||
}
|
||||
|
||||
static void
|
||||
fail()
|
||||
{
|
||||
Ins *i1;
|
||||
int i;
|
||||
|
||||
printf("\nIn registers: ");
|
||||
for (i=0; i<mbeg.n; i++)
|
||||
printf("%s(r%d) ",
|
||||
tmp[mbeg.t[i]].name,
|
||||
mbeg.r[i]);
|
||||
printf("\n");
|
||||
printf("Parallel move:\n");
|
||||
for (i1=ins; i1<ip; i1++)
|
||||
printf("\t %s <- r%d\n",
|
||||
tmp[i1->to.val].name,
|
||||
i1->arg[0].val);
|
||||
replay();
|
||||
abort();
|
||||
}
|
||||
|
||||
static void
|
||||
assert_test(char *s, int x)
|
||||
{
|
||||
if (x)
|
||||
return;
|
||||
if (re)
|
||||
abort();
|
||||
printf("!assertion failure: %s\n", s);
|
||||
fail();
|
||||
}
|
||||
|
||||
static void
|
||||
bsinit_(BSet *bs, uint n)
|
||||
{
|
||||
n = (n + NBit-1) / NBit;
|
||||
bs->nt = n;
|
||||
bs->t = emalloc(n * sizeof bs->t[0]);
|
||||
}
|
||||
|
||||
/* symbols required by the linker */
|
||||
char debug['Z'+1];
|
||||
267
src/qbe/tools/test.sh
Executable file
267
src/qbe/tools/test.sh
Executable file
@@ -0,0 +1,267 @@
|
||||
#!/bin/sh
|
||||
|
||||
dir=`dirname "$0"`
|
||||
if [ -z "${bin:-}" ]; then
|
||||
bin=$dir/../qbe
|
||||
fi
|
||||
if [ -z "${binref:-}" ]; then
|
||||
binref=${bin}.ref
|
||||
fi
|
||||
|
||||
tmp=/tmp/qbe.zzzz
|
||||
|
||||
drv=$tmp.c
|
||||
asm=$tmp.s
|
||||
asmref=$tmp.ref.s
|
||||
exe=$tmp.exe
|
||||
out=$tmp.out
|
||||
|
||||
qemu_not_needed() {
|
||||
"$@"
|
||||
}
|
||||
|
||||
cc=
|
||||
find_cc_and_qemu() {
|
||||
if [ -n "$cc" ]; then
|
||||
return
|
||||
fi
|
||||
target="$1"
|
||||
candidate_cc="$2"
|
||||
if $candidate_cc -v >/dev/null 2>&1; then
|
||||
cc=$candidate_cc
|
||||
echo "cc: $cc"
|
||||
|
||||
if [ "$target" = "$(uname -m)" ]
|
||||
then
|
||||
qemu=qemu_not_needed
|
||||
echo "qemu: not needed, testing native architecture"
|
||||
else
|
||||
qemu="$3"
|
||||
if $qemu -version >/dev/null 2>&1
|
||||
then
|
||||
sysroot=$($candidate_cc -print-sysroot)
|
||||
if [ -n "$sysroot" ]; then
|
||||
qemu="$qemu -L $sysroot"
|
||||
fi
|
||||
echo "qemu: $qemu"
|
||||
elif $qemu --version >/dev/null 2>&1
|
||||
then
|
||||
# wine
|
||||
:
|
||||
else
|
||||
qemu=
|
||||
echo "qemu: not found"
|
||||
fi
|
||||
fi
|
||||
echo
|
||||
|
||||
fi
|
||||
}
|
||||
|
||||
init() {
|
||||
case "$TARGET" in
|
||||
arm64)
|
||||
for p in aarch64-linux-musl aarch64-linux-gnu
|
||||
do
|
||||
find_cc_and_qemu aarch64 "$p-gcc -no-pie -static" "qemu-aarch64"
|
||||
done
|
||||
if test -z "$cc" -o -z "$qemu"
|
||||
then
|
||||
echo "Cannot find arm64 compiler or qemu."
|
||||
exit 77
|
||||
fi
|
||||
bin="$bin -t arm64"
|
||||
;;
|
||||
rv64)
|
||||
for p in riscv64-linux-musl riscv64-linux-gnu
|
||||
do
|
||||
find_cc_and_qemu riscv64 "$p-gcc -no-pie -static" "qemu-riscv64"
|
||||
done
|
||||
if test -z "$cc" -o -z "$qemu"
|
||||
then
|
||||
echo "Cannot find riscv64 compiler or qemu."
|
||||
exit 77
|
||||
fi
|
||||
bin="$bin -t rv64"
|
||||
;;
|
||||
x86_64)
|
||||
for p in x86_64-linux-musl x86_64-linux-gnu
|
||||
do
|
||||
find_cc_and_qemu x86_64 "$p-gcc -no-pie -static" "qemu-x86_64"
|
||||
done
|
||||
if test -z "$cc" -o -z "$qemu"
|
||||
then
|
||||
echo "Cannot find x86_64 compiler or qemu."
|
||||
exit 77
|
||||
fi
|
||||
bin="$bin -t amd64_sysv"
|
||||
;;
|
||||
amd64_win)
|
||||
for p in x86_64-w64-mingw32
|
||||
do
|
||||
find_cc_and_qemu x86_64-w64 "$p-gcc -static" "wine"
|
||||
done
|
||||
if test -z "$cc"
|
||||
then
|
||||
echo "Cannot find windows compiler or wine."
|
||||
exit 1
|
||||
fi
|
||||
export WINEDEBUG=-all
|
||||
bin="$bin -t amd64_win"
|
||||
;;
|
||||
"")
|
||||
case `uname` in
|
||||
*Darwin*)
|
||||
cc="cc"
|
||||
;;
|
||||
*OpenBSD*)
|
||||
cc="cc -nopie -lpthread"
|
||||
;;
|
||||
*FreeBSD*)
|
||||
cc="cc -lpthread"
|
||||
;;
|
||||
*)
|
||||
cc="${CC:-cc}"
|
||||
ccpost="-lpthread"
|
||||
;;
|
||||
esac
|
||||
TARGET=`$bin -t?`
|
||||
;;
|
||||
*)
|
||||
echo "Unknown target '$TARGET'."
|
||||
exit 77
|
||||
;;
|
||||
esac
|
||||
}
|
||||
|
||||
cleanup() {
|
||||
rm -f $drv $asm $exe $out
|
||||
}
|
||||
|
||||
extract() {
|
||||
WHAT="$1"
|
||||
FILE="$2"
|
||||
|
||||
awk "
|
||||
/^# >>> $WHAT/ {
|
||||
p = 1
|
||||
next
|
||||
}
|
||||
/^# <<</ {
|
||||
p = 0
|
||||
}
|
||||
p
|
||||
" $FILE \
|
||||
| sed -e 's/# //' \
|
||||
| sed -e 's/#$//'
|
||||
}
|
||||
|
||||
once() {
|
||||
t="$1"
|
||||
|
||||
if ! test -f $t
|
||||
then
|
||||
echo "invalid test file $t" >&2
|
||||
exit 1
|
||||
fi
|
||||
|
||||
if
|
||||
sed -e 1q $t |
|
||||
grep "skip.* $TARGET\( .*\)\?$" \
|
||||
>/dev/null
|
||||
then
|
||||
return 0
|
||||
fi
|
||||
|
||||
printf "%-45s" "$(basename $t)..."
|
||||
|
||||
if ! $bin -o $asm $t
|
||||
then
|
||||
echo "[qbe fail]"
|
||||
return 1
|
||||
fi
|
||||
|
||||
if test -x $binref
|
||||
then
|
||||
$binref -o $asmref $t 2>/dev/null
|
||||
fi
|
||||
|
||||
extract driver $t > $drv
|
||||
extract output $t > $out
|
||||
|
||||
if test -s $drv
|
||||
then
|
||||
src="$drv $asm"
|
||||
else
|
||||
src="$asm"
|
||||
fi
|
||||
|
||||
if ! $cc -g -o $exe $src $ccpost
|
||||
then
|
||||
echo "[cc fail]"
|
||||
return 1
|
||||
fi
|
||||
|
||||
if test -s $out
|
||||
then
|
||||
$qemu $exe a b c | tr -d '\r' | diff -u - $out
|
||||
ret=$?
|
||||
reason="output"
|
||||
else
|
||||
$qemu $exe a b c
|
||||
ret=$?
|
||||
reason="returned $ret"
|
||||
fi
|
||||
|
||||
if test $ret -ne 0
|
||||
then
|
||||
echo "[$reason fail]"
|
||||
return 1
|
||||
fi
|
||||
|
||||
echo "[ok]"
|
||||
|
||||
if test -f $asmref && ! cmp -s $asm $asmref
|
||||
then
|
||||
loc0=`wc -l $asm | cut -d' ' -f1`
|
||||
loc1=`wc -l $asmref | cut -d' ' -f1`
|
||||
printf " asm diff: %+d\n" $(($loc0 - $loc1))
|
||||
return 0
|
||||
fi
|
||||
}
|
||||
|
||||
#trap cleanup TERM QUIT
|
||||
|
||||
init
|
||||
|
||||
if test -z "$1"
|
||||
then
|
||||
echo "usage: tools/test.sh {all, SSAFILE}" 2>&1
|
||||
exit 1
|
||||
fi
|
||||
|
||||
case "$1" in
|
||||
"all")
|
||||
fail=0
|
||||
count=0
|
||||
for t in $dir/../test/[!_]*.ssa
|
||||
do
|
||||
once $t
|
||||
fail=`expr $fail + $?`
|
||||
count=`expr $count + 1`
|
||||
done
|
||||
if test $fail -ge 1
|
||||
then
|
||||
echo
|
||||
echo "$fail of $count tests failed!"
|
||||
else
|
||||
echo
|
||||
echo "All is fine!"
|
||||
fi
|
||||
exit $fail
|
||||
;;
|
||||
*)
|
||||
once $1
|
||||
exit $?
|
||||
;;
|
||||
esac
|
||||
161
src/qbe/tools/vatest.py
Normal file
161
src/qbe/tools/vatest.py
Normal file
@@ -0,0 +1,161 @@
|
||||
# generate variadic calls to test the
|
||||
# abi implementation
|
||||
|
||||
from random import seed, randint, uniform
|
||||
from struct import unpack
|
||||
|
||||
I, D = 'd', 'g'
|
||||
|
||||
formats = [
|
||||
# list of formats to test
|
||||
[I],
|
||||
[D],
|
||||
[I,D],
|
||||
[D,D],
|
||||
[I,I,I,I],
|
||||
[D,D,D,D],
|
||||
[I,D,I,D],
|
||||
[D,D,I,I],
|
||||
[I,I,D,D],
|
||||
[],
|
||||
]
|
||||
|
||||
generate = [
|
||||
# numbers of fixed integer and
|
||||
# floating point arguments to
|
||||
# test
|
||||
(0, 0), (1, 0), (0, 1), (4, 0),
|
||||
(0, 6), (5, 7), (10, 10), (9, 0),
|
||||
]
|
||||
|
||||
def mkargs(nargs, type, name):
|
||||
args = map(
|
||||
lambda n: ''.join([type, name, str(n), ', ']),
|
||||
range(nargs)
|
||||
)
|
||||
return ''.join(args)
|
||||
|
||||
def mkfstr(fmt):
|
||||
fstr = map(
|
||||
lambda x: {I: '%d ', D: '%g '}[x],
|
||||
fmt
|
||||
)
|
||||
return '"' + ''.join(fstr) + '\\n"'
|
||||
|
||||
def randargs(fmt):
|
||||
ra = {
|
||||
I: lambda: '{}'.format(randint(-10, 10)),
|
||||
D: lambda: '{0:.4g}'.format(uniform(-10, 10))
|
||||
}
|
||||
return list(map(lambda x: ra[x](), fmt))
|
||||
|
||||
def genssa(qbeprint, qbecall):
|
||||
funcs = [('qbeprint', qbeprint), ('qbecall', qbecall)]
|
||||
for fnum, (nia, nfa) in enumerate(generate):
|
||||
params = "{}{}l %fmt, ...".format(
|
||||
mkargs(nia, 'w ', '%argw'),
|
||||
mkargs(nfa, 'd ', '%argd')
|
||||
)
|
||||
for name, code in funcs:
|
||||
print('export function ${}{}({}) {}'
|
||||
.format(name, fnum, params, code)
|
||||
)
|
||||
|
||||
def gendriver():
|
||||
print('# >>> driver')
|
||||
print('# #include <stdarg.h>')
|
||||
print('# #include <stdio.h>')
|
||||
|
||||
for fnum, (nia, nfa) in enumerate(generate):
|
||||
params = "{}{}char *, ...".format(
|
||||
mkargs(nia, 'int ', 'argw'),
|
||||
mkargs(nfa, 'double ', 'argd')
|
||||
)
|
||||
for name in ['qbeprint', 'qbecall']:
|
||||
print('# extern void {}{}({});'
|
||||
.format(name, fnum, params)
|
||||
)
|
||||
|
||||
output = ''
|
||||
print('# int print(char *fmt, va_list *ap) {')
|
||||
print('# return vprintf(fmt, *ap);');
|
||||
print('# }')
|
||||
print('# int main() {')
|
||||
|
||||
for fnum, (nia, nfa) in enumerate(generate):
|
||||
info = '# ({} int, {} double)'.format(nia, nfa)
|
||||
print('# puts("{}");'.format(info))
|
||||
output += '# {}\n'.format(info)
|
||||
for fmt in formats:
|
||||
ra = randargs(fmt)
|
||||
vaargs = ', '.join(ra)
|
||||
expect = ' '.join(ra)
|
||||
if fmt:
|
||||
vaargs = ', ' + vaargs
|
||||
expect = expect + ' '
|
||||
args = ''.join(
|
||||
['0, '] * (nia+nfa) +
|
||||
[mkfstr(fmt), vaargs]
|
||||
)
|
||||
for name in ['qbeprint', 'qbecall']:
|
||||
print('# {}{}({});'
|
||||
.format(name, fnum, args)
|
||||
)
|
||||
output += '# {}\n'.format(expect)
|
||||
|
||||
print('# }')
|
||||
print('# <<<')
|
||||
|
||||
print('\n# >>> output\n' + output + '# <<<')
|
||||
|
||||
|
||||
qbeprint="""{{
|
||||
@start
|
||||
%fmtdbl =l alloc4 4
|
||||
%fmtint =l alloc4 4
|
||||
%emptys =l alloc4 4
|
||||
storew {}, %fmtint
|
||||
storew {}, %fmtdbl
|
||||
storew 0, %emptys
|
||||
%vp =l alloc8 32
|
||||
%fmt1 =l add 1, %fmt
|
||||
vastart %vp
|
||||
@loop
|
||||
%p =l phi @start %fmt1, @casef %p1, @cased %p1
|
||||
%c =w loadsb %p
|
||||
%p1 =l add 3, %p
|
||||
jnz %c, @loop1, @end
|
||||
@loop1
|
||||
%isg =w ceqw %c, 103
|
||||
jnz %isg, @casef, @cased
|
||||
@casef
|
||||
%dbl =d vaarg %vp
|
||||
%r =w call $printf(l %fmtdbl, ..., d %dbl)
|
||||
jmp @loop
|
||||
@cased
|
||||
%int =w vaarg %vp
|
||||
%r =w call $printf(l %fmtint, ..., w %int)
|
||||
jmp @loop
|
||||
@end
|
||||
%r =w call $puts(l %emptys)
|
||||
ret
|
||||
}}
|
||||
""".format(
|
||||
unpack("i", b'%d \x00')[0],
|
||||
unpack("i", b'%g \x00')[0]
|
||||
)
|
||||
|
||||
qbecall="""{
|
||||
@start
|
||||
%vp =l alloc8 32
|
||||
vastart %vp
|
||||
%r =w call $print(l %fmt, l %vp)
|
||||
ret
|
||||
}
|
||||
"""
|
||||
|
||||
|
||||
if __name__ == "__main__":
|
||||
seed(42)
|
||||
genssa(qbeprint, qbecall)
|
||||
gendriver()
|
||||
Reference in New Issue
Block a user