diff --git a/.gitignore b/.gitignore deleted file mode 100644 index a28eac24..00000000 --- a/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -/Driver -/Driver.cmi -/Driver.cmo -/Expr.cmi -/Expr.cmo diff --git a/.travis-opam.sh b/.travis-opam.sh new file mode 100644 index 00000000..c4399c7d --- /dev/null +++ b/.travis-opam.sh @@ -0,0 +1,37 @@ +echo -en "travis_fold:start:prepare.ci\r" +# If a fork of these scripts is specified, use that GitHub user instead +fork_user=${FORK_USER:-ocaml} + +# If a branch of these scripts is specified, use that branch instead of 'master' +fork_branch=${FORK_BRANCH:-master} + +### Bootstrap + +set -uex + +get() { + wget https://raw.githubusercontent.com/${fork_user}/ocaml-ci-scripts/${fork_branch}/$@ +} + +TMP_BUILD=$(mktemp -d 2>/dev/null || mktemp -d -t 'citmpdir') +cd ${TMP_BUILD} + +get .travis-ocaml.sh +get yorick.mli +get yorick.ml +get ci_opam.ml + +sh .travis-ocaml.sh +export OPAMYES=1 +eval $(opam config env) + +# This could be removed with some OPAM variable plumbing into build commands +opam install ocamlfind + +ocamlc.opt yorick.mli +ocamlfind ocamlc -c yorick.ml + +ocamlfind ocamlc -o ci-opam -package unix -linkpkg yorick.cmo ci_opam.ml +cd - + +echo -en "travis_fold:end:prepare.ci\r" diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 00000000..b8a584d9 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,9 @@ +language: c +sudo: required +script: + - bash -ex .travis-opam.sh + - ./installBuildRun.sh +env: + - OCAML_VERSION=4.04 +os: + - linux diff --git a/installBuildRun.sh b/installBuildRun.sh new file mode 100755 index 00000000..70dfbfb8 --- /dev/null +++ b/installBuildRun.sh @@ -0,0 +1,14 @@ +opam pin add GT https://github.com/Kakadu/GT.git -n -y +opam pin add ostap https://github.com/dboulytchev/ostap.git -n -y +opam install camlp5 -y +opam install GT ostap ocamlfind -y +eval `opam config env` +sudo apt-get install gcc-multilib -y + +make + +cd regression +make + +cd deep-expressions +make diff --git a/regression/Makefile b/regression/Makefile index bbecbbd4..27a27d10 100644 --- a/regression/Makefile +++ b/regression/Makefile @@ -1,6 +1,6 @@ -TESTS=test001 test002 test012 test013 test003 test004 test005 test006 test007 test008 test009 test010 test011 test014 test015 test016 test017 test018 +TESTS=test001 test002 test012 test013 test003 test004 test005 test006 test007 test008 test009 test010 test014 test015 test016 test017 test018 test019 test020 test021 test022 test023 -# test019 test020 test021 test022 test023 test024 test025 test026 +# test011 test024 test025 test026 # test027 test028 test029 test030 .PHONY: check $(TESTS) diff --git a/src/Driver.ml b/src/Driver.ml index 5c8e0b34..912cb75d 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -8,7 +8,7 @@ let parse filename = Util.parse (object inherit Matcher.t s - inherit Util.Lexers.ident ["read"; "write"; "skip"] s + inherit Util.Lexers.ident ["read"; "write"; "skip"; "if"; "fi"; "then"; "else"; "while"; "do"; "od"; "repeat"; "until"; "for"] s inherit Util.Lexers.decimal s inherit Util.Lexers.skip [ Matcher.Skip.whitespaces " \t\n"; diff --git a/src/Interpret.ml b/src/Interpret.ml index 9f863d55..1cd543ad 100644 --- a/src/Interpret.ml +++ b/src/Interpret.ml @@ -1,49 +1,52 @@ -open Language - -(* Interpreter for expressions *) -module Expr = - struct - - open Expr - - let rec eval expr st = - let eval' e = eval e st in - match expr with - | Var x -> st x - | Const z -> z - | Add (x, y) -> eval' x + eval' y - | Mul (x, y) -> eval' x * eval' y - - end - -(* Interpreter for statements *) -module Stmt = - struct - - open Stmt - - (* State update primitive *) - let update st x v = fun y -> if y = x then v else st y - - let rec eval stmt ((st, input, output) as conf) = - match stmt with - | Skip -> conf - | Assign (x, e) -> (update st x (Expr.eval e st), input, output) - | Read x -> - let z :: input' = input in - (update st x z, input', output) - | Write e -> (st, input, output @ [Expr.eval e st]) - | Seq (s1, s2) -> eval s1 conf |> eval s2 - - end - -module Program = - struct - - let eval p input = - let (_, _, output) = - Stmt.eval p ((fun _ -> failwith "undefined variable"), input, []) - in - output - - end +open Language + +(* Interpreter for expressions *) +module Expr = + struct + + open Expr + open Language.BinOp + + let rec eval expr st = + let eval' e = eval e st in + match expr with + | Var x -> st x + | Const z -> z + | Binop (op, x, y) -> (apply op) (eval' x) (eval' y) + + end + +(* Interpreter for statements *) +module Stmt = + struct + + open Stmt + + (* State update primitive *) + let update st x v = fun y -> if y = x then v else st y + + let rec eval stmt ((st, input, output) as conf) = + match stmt with + | Skip -> conf + | Assign (x, e) -> (update st x (Expr.eval e st), input, output) + | Write e -> (st, input, output @ [Expr.eval e st]) + | Seq (s1, s2) -> eval s1 conf |> eval s2 + | Read x -> + let z :: input' = input in + (update st x z, input', output) + | If (e, s1, s2) -> if (Expr.eval e st) <> 0 then (eval s1 conf) else (eval s2 conf) + (*eval self again but with new conf (which is eval'ed body of while')*) + | While (e, s) -> if (Expr.eval e st) <> 0 then eval stmt (eval s conf) else conf + + end + +module Program = + struct + + let eval p input = + let (_, _, output) = + Stmt.eval p ((fun _ -> failwith "undefined variable"), input, []) + in + output + + end diff --git a/src/Language.ml b/src/Language.ml index 96ac3e01..93bfdae1 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -1,20 +1,52 @@ -(* AST for expressions *) +open Ostap +open Matcher + module Expr = struct type t = | Var of string | Const of int - | Add of t * t - | Mul of t * t + | Binop of string * t * t ostap ( - parse: x:mull "+" y:parse {Add (x,y)} | mull; - mull : x:prim "*" y:mull {Mul (x,y)} | prim; - prim : - n:DECIMAL {Const n} - | e:IDENT {Var e} - | -"(" parse -")" + parse: + orins; + + orins: + l:andins suf:(("!!") andins)* { + List.fold_left (fun l (op, r) -> Binop (Token.repr op, l, r)) l suf + } + | andins; + + andins: + l:cmp suf:(("&&") cmp)* { + List.fold_left (fun l (op, r) -> Binop (Token.repr op, l, r)) l suf + } + | cmp; + + cmp: + l:add suf:(("<=" | "<" | ">=" | ">" | "==" | "!=") add)* { + List.fold_left (fun l (op, r) -> Binop (Token.repr op, l, r)) l suf + } + | add; + + add: + l:mull suf:(("+" | "-") mull)* { + List.fold_left (fun l (op, r) -> Binop (Token.repr op, l, r)) l suf + } + | mull; + + mull: + l:prim suf:(("*" | "/" | "%") prim)* { + List.fold_left (fun l (op, r) -> Binop (Token.repr op, l, r)) l suf + } + | prim; + + prim: + n:DECIMAL {Const n} + | x:IDENT {Var x} + | -"(" parse -")" ) end @@ -29,6 +61,9 @@ module Stmt = | Read of string | Write of Expr.t | Seq of t * t + | If of Expr.t * t * t + | While of Expr.t * t + | Repeat of t * Expr.t let expr = Expr.parse @@ -36,13 +71,49 @@ module Stmt = simp: x:IDENT ":=" e:expr {Assign (x, e)} | %"read" "(" x:IDENT ")" {Read x} | %"write" "(" e:expr ")" {Write e} - | %"skip" {Skip}; - + | %"skip" {Skip} + | %"if" e:!(Expr.parse) + %"then" s1:!(parse) + %"else" s2:!(parse) + %"fi" {If (e, s1, s2)} + | %"if" e:!(Expr.parse) + %"then" s1:!(parse) + %"fi" {If (e, s1, Skip)} + | %"while" e:!(Expr.parse) + %"do" s:!(parse) + %"od" {While (e, s)} + | %"repeat" s:!(parse) + %"until" e:!(Expr.parse) {Seq (s, While (Binop ("==", e, Const 0), s))} + | %"for" i:!(parse) "," n:!(Expr.parse) "," b:!(parse) + %"do" a:!(parse) + %"od" {Seq (i, (While (n, Seq (a, b))))}; parse: s:simp ";" d:parse {Seq (s,d)} | simp ) end + +module BinOp = + struct + + let apply op = + match op with + | "+" -> fun x y -> x + y + | "*" -> fun x y -> x * y + | "-" -> fun x y -> x - y + | "/" -> fun x y -> x / y + | "%" -> fun x y -> x mod y + | "<" -> fun x y -> if x < y then 1 else 0 + | "<=" -> fun x y -> if x <= y then 1 else 0 + | ">" -> fun x y -> if x > y then 1 else 0 + | ">=" -> fun x y -> if x >= y then 1 else 0 + | "==" -> fun x y -> if x = y then 1 else 0 + | "!=" -> fun x y -> if x <> y then 1 else 0 + | "&&" -> fun x y -> if (x <> 0) && (y <> 0) then 1 else 0 + | "!!" -> fun x y -> if (x <> 0) || (y <> 0) then 1 else 0 + + end + module Program = struct diff --git a/src/StackMachine.ml b/src/StackMachine.ml index 870537a4..aa0b0744 100644 --- a/src/StackMachine.ml +++ b/src/StackMachine.ml @@ -8,8 +8,10 @@ module Instr = | PUSH of int | LD of string | ST of string - | ADD - | MUL + | BINOP of string + | GOTO of string + | IFGOTO of string * string + | LABEL of string end @@ -25,36 +27,48 @@ module Interpret = open Instr open Interpret.Stmt + open Language.BinOp + + let e_to_op = function + | "z" -> (==) + | "nz" -> (!=) + | _ -> failwith "Stack machine.e_to_op: Unknown parameter" + + (* Get instruction pointer for label lbl in the code*) + let rec find_ip lbl code = + match code with + | [] -> failwith "Stack machine.Find ip: Unknown label" + | i::code' -> if i = LABEL lbl then 0 else 1 + find_ip lbl code' let run prg input = - let rec run' prg ((stack, st, input, output) as conf) = - match prg with - | [] -> conf - | i :: prg' -> - run' prg' ( + let rec run' prg ((stack, st, input, output, ip) as conf) = + if ip >= (List.length prg) + then conf + else let i = (List.nth prg ip) in + run' prg ( match i with | READ -> let z :: input' = input in - (z :: stack, st, input', output) + (z :: stack, st, input', output, ip + 1) | WRITE -> let z :: stack' = stack in - (stack', st, input, output @ [z]) - | PUSH n -> (n :: stack, st, input, output) - | LD x -> (st x :: stack, st, input, output) - | ST x -> let z :: stack' = stack in - (stack', update st x z, input, output) - | _ -> let y :: x :: stack' = stack in - ((match i with ADD -> (+) | _ -> ( * )) x y :: stack', - st, - input, - output - ) - ) + (stack', st, input, output @ [z], ip + 1) + | PUSH n -> (n :: stack, st, input, output, ip + 1) + | LD x -> (st x :: stack, st, input, output, ip + 1) + | ST x -> let z :: stack' = stack in + (stack', update st x z, input, output, ip + 1) + | BINOP op -> + let y::x::stack' = stack in + ((apply op x y)::stack', st, input, output, ip + 1) + | LABEL lbl -> + (stack, st, input, output, ip + 1) + | GOTO lbl -> + (stack, st, input, output, (find_ip lbl prg)) + | IFGOTO (e, lbl) -> + let y::stack' = stack in + (stack', st, input, output, if ((e_to_op e) y 0) then (find_ip lbl prg) else ip + 1) + ) in - let (_, _, _, output) = - run' prg ([], - (fun _ -> failwith "undefined variable"), - input, - [] - ) + let (_, _, _, output, _) = + run' prg ([], (fun _ -> failwith "undefined variable"), input, [], 0) in output end @@ -72,8 +86,7 @@ module Compile = let rec compile = function | Var x -> [LD x] | Const n -> [PUSH n] - | Add (x, y) -> (compile x) @ (compile y) @ [ADD] - | Mul (x, y) -> (compile x) @ (compile y) @ [MUL] + | Binop (op, x, y) -> (compile x) @ (compile y) @ [BINOP op] end @@ -82,12 +95,34 @@ module Compile = open Language.Stmt + let i = ref (-1) + let create_new_lbl () = + i:= !i + 1; + string_of_int !i + let rec compile = function | Skip -> [] | Assign (x, e) -> Expr.compile e @ [ST x] | Read x -> [READ; ST x] | Write e -> Expr.compile e @ [WRITE] | Seq (l, r) -> compile l @ compile r + | If (e, s1, s2) -> + let lbl1 = create_new_lbl () in + let lbl2 = create_new_lbl () in + Expr.compile e + @ [IFGOTO ("z", lbl1)] + @ compile s1 + @ [GOTO lbl2; LABEL lbl1] + @ compile s2 + @ [LABEL lbl2] + | While (e, s) -> + let lbl1 = create_new_lbl () in + let lbl2 = create_new_lbl () in + [GOTO lbl2; LABEL lbl1] + @ compile s + @ [LABEL lbl2] + @ Expr.compile e + @ [IFGOTO ("nz", lbl1)] end diff --git a/src/X86.ml b/src/X86.ml index 9f0544af..cc5f8333 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -6,16 +6,36 @@ type opnd = R of int | S of int | L of int | M of string let regs = [|"%eax"; "%ebx"; "%ecx"; "%esi"; "%edi"; "%edx"; "%esp"; "%ebp"|] let nregs = Array.length regs - 3 + let [|eax; ebx; ecx; esi; edi; edx; esp; ebp|] = Array.mapi (fun i _ -> R i) regs + type instr = | Add of opnd * opnd | Mul of opnd * opnd +| Sub of opnd * opnd +| Div of opnd * opnd +| Mod of opnd * opnd | Mov of opnd * opnd +| Cmp of opnd * opnd +| Xor of opnd * opnd +| Or of opnd * opnd +| And of opnd * opnd | Push of opnd | Pop of opnd -| Call of string +| Cdq +| Setl +| Setle +| Setg +| Setge +| Sete +| Setne +| Movzbl | Ret +| Call of string +| Lbl of string +| Goto of string +| Ifgoto of string * string let to_string buf code = let instr = @@ -26,13 +46,40 @@ let to_string buf code = | M s -> s in function - | Add (x, y) -> Printf.sprintf "addl\t%s,%s" (opnd x) (opnd y) - | Mul (x, y) -> Printf.sprintf "imull\t%s,%s" (opnd x) (opnd y) - | Mov (x, y) -> Printf.sprintf "movl\t%s,%s" (opnd x) (opnd y) - | Push x -> Printf.sprintf "pushl\t%s" (opnd x) - | Pop x -> Printf.sprintf "popl\t%s" (opnd x) - | Call x -> Printf.sprintf "call\t%s" x - | Ret -> "ret" + | Add (s1, s2) -> Printf.sprintf "\taddl\t%s,\t%s" (opnd s1) (opnd s2) + | Mul (s1, s2) -> Printf.sprintf "\timull\t%s,\t%s" (opnd s1) (opnd s2) + | Sub (s1, s2) -> Printf.sprintf "\tsubl\t%s,\t%s" (opnd s1) (opnd s2) + | Div (s1, s2) -> Printf.sprintf "\tidivl\t%s" (opnd s1) + + | Mov (s1, s2) -> Printf.sprintf "\tmovl\t%s,\t%s" (opnd s1) (opnd s2) + | Cmp (s1, s2) -> Printf.sprintf "\tcmp\t%s,\t%s" (opnd s1) (opnd s2) + | Push s -> Printf.sprintf "\tpushl\t%s" (opnd s ) + | Pop s -> Printf.sprintf "\tpopl\t%s" (opnd s ) + + | Xor (s1, s2) -> Printf.sprintf "\txorl\t%s,\t%s" (opnd s1) (opnd s2) + | Or (s1, s2) -> Printf.sprintf "\torl\t%s,\t%s" (opnd s1) (opnd s2) + | And (s1, s2) -> Printf.sprintf "\tandl\t%s,\t%s" (opnd s1) (opnd s2) + + (*выставляем байты если выполняются условия*) + | Setl -> "\tsetl\t%al" + | Setle -> "\tsetle\t%al" + | Setg -> "\tsetg\t%al" + | Setge -> "\tsetge\t%al" + | Sete -> "\tsete\t%al" + | Setne -> "\tsetne\t%al" + + + (*в wrap_mem_access мы в y кладём edx, соотв. здесь al кладём в edx*) + | Movzbl -> "\tmovzbl\t%al,\t%edx" + + (*делаем знаковое деление*) + | Cdq -> "\tcdq" + | Ret -> "\tret" + | Call p -> Printf.sprintf "\tcall\t%s" p + + | Lbl s -> Printf.sprintf "label%s:" s + | Goto s -> Printf.sprintf "\tjmp\tlabel%s" s + | Ifgoto (e, s) -> Printf.sprintf "\tj%s\tlabel%s" e s in let out s = Buffer.add_string buf "\t"; @@ -42,14 +89,23 @@ let to_string buf code = List.iter (fun i -> out @@ instr i) code module S = Set.Make (String) - + +let save_eax_edx f = + [Push eax; Push edx] @ f @ [Pop edx; Pop eax] + +let wrap_mem_access x y f = + save_eax_edx @@ [Mov (x, eax); Mov (y, edx)] @ (f eax edx) @ [Mov (edx, y)] + +let compare x y cmp = + [Cmp (x, y); cmp; Movzbl] + class env = object (this) val locals = S.empty val depth = 0 method allocate = function - | [] -> this, R 0 + | [] -> this, R 1 | R i :: _ when i < nregs - 1 -> this, R (i+1) | S i :: _ -> {< depth = max depth (i+1) >}, S (i+1) | _ -> {< depth = max depth 1 >}, S 1 @@ -71,26 +127,71 @@ let rec sint env prg sstack = | LD x -> let env' = env#local x in let env'', s = env'#allocate sstack in - env'', [Mov (M x, s)], s :: sstack - | ST x -> + env'', (wrap_mem_access (M x) s @@ fun x y -> [Mov (x, y)]), s :: sstack + | ST x -> let env' = env#local x in let s :: sstack' = sstack in env', [Mov (s, M x)], sstack' | READ -> env, [Call "lread"], [eax] | WRITE -> - env, [Push eax; Call "lwrite"; Pop edx], [] - | _ -> + env, [Push (R 1); Call "lwrite"; Pop (R 1)], [] + | LABEL lbl -> + (env, [Lbl lbl], sstack) + | GOTO lbl -> + (env, [Goto lbl], sstack) + | IFGOTO (e, lbl) -> + let y::stack' = sstack in + (env, [Cmp (L 0, y); Ifgoto (e, lbl)], stack') + | BINOP op -> let x::(y::_ as sstack') = sstack in - (fun op -> - match x, y with - | S _, S _ -> env, [Mov (y, edx); op x edx; Mov (edx, y)], sstack' - | _ -> env, [op x y], sstack' - ) - (match i with - | MUL -> fun x y -> Mul (x, y) - | ADD -> fun x y -> Add (x, y) - ) + env, (match op with + | "+" -> + wrap_mem_access x y @@ fun x y -> [Add (x, y); Mov (y, eax)] + | "-" -> + wrap_mem_access x y @@ fun x y -> [Sub (x, y); Mov (y, eax)] + | "*" -> + save_eax_edx [Mov (y, eax); Mul (x, eax); Mov (eax, y)] + | "/" -> + save_eax_edx [Mov (y, eax); Cdq; Div (x, y); Mov (eax, y)] + | "%" -> + save_eax_edx [Mov (y, eax); Cdq; Div (x, y); Mov (edx, y)] + | "<" -> + wrap_mem_access x y @@ fun x y -> compare x y Setl + | "<=" -> + wrap_mem_access x y @@ fun x y -> compare x y Setle + | ">" -> + wrap_mem_access x y @@ fun x y -> compare x y Setg + | ">=" -> + wrap_mem_access x y @@ fun x y -> compare x y Setge + | "==" -> + wrap_mem_access x y @@ fun x y -> compare x y Sete + | "!=" -> + wrap_mem_access x y @@ fun x y -> compare x y Setne + | "&&" -> + save_eax_edx [ + (* Set eax value to null, mov x to edx, check that edx is not null + if it is true - in eax we now have not null + *) + Xor (eax, eax); + Mov (x, edx); + Cmp (edx, eax); + Setne; + Mov (y, edx); + Mul (eax, edx); + Xor (eax, eax); + Cmp (edx, eax); + Setne; + Mov (eax, y)] + | "!!" -> + save_eax_edx [ + Xor (eax, eax); + Mov (x, edx); + Or (y, edx); + Cmp (edx, eax); + Setne; + Mov (eax, y)] + ), sstack' in let env, code', sstack'' = sint env prg' sstack' in env, code @ code', sstack''