From cf78cd20e35529d16f37739f497c2299b98987df Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Thu, 13 Feb 2020 18:56:27 +0300 Subject: [PATCH] Opam/install --- Makefile | 15 ++++++++++- opam | 3 ++- regression/orig/test103.log | 3 +++ regression/test103.expr | 4 +++ regression/test103.input | 3 +++ runtime/runtime.c | 53 ++++++++++++++++++++----------------- src/Driver.ml | 2 +- src/Language.ml | 36 ++++++++++++++++++------- src/X86.ml | 24 ++++++++++------- 9 files changed, 96 insertions(+), 47 deletions(-) create mode 100644 regression/orig/test103.log create mode 100644 regression/test103.expr create mode 100644 regression/test103.input diff --git a/Makefile b/Makefile index 205c785a2..2286ef0a3 100644 --- a/Makefile +++ b/Makefile @@ -1,3 +1,6 @@ +EXECUTABLE = src/rc.opt +INSTALL ?= install -v +MKDIR ?= mkdir SHELL := /bin/bash .PHONY: all regression @@ -7,7 +10,17 @@ all: pushd runtime && make && popd pushd stdlib && make && popd -#install: ; +STD_FILES=$(shell ls stdlib/*.[oi] stdlib/*.expr runtime/runtime.a runtime/Std.i) +#$(info $(STD_FILES)) + +install: all + $(INSTALL) $(EXECUTABLE) `opam var bin` + $(MKDIR) -p `opam var share`/Lama + $(INSTALL) $(STD_FILES) `opam var share`/Lama/ + +uninstall: + $(RM) -r `opam var share`/Lama + $(RM) `opam var bin`/$(EXECUTABLE) regression: pushd regression && make clean check && popd diff --git a/opam b/opam index 4b3029516..2e3cb2856 100644 --- a/opam +++ b/opam @@ -20,7 +20,8 @@ build: [ [make "-f" "Makefile"] [make "-f" "Makefile" "regression"] {with-test} ] - +install: [make "install"] + #remove: ["ocamlfind" "remove" "compiler-workout"] #flags: light-uninstall diff --git a/regression/orig/test103.log b/regression/orig/test103.log new file mode 100644 index 000000000..6df4bc890 --- /dev/null +++ b/regression/orig/test103.log @@ -0,0 +1,3 @@ +> > > 0 +0 +5 diff --git a/regression/test103.expr b/regression/test103.expr new file mode 100644 index 000000000..3c1692362 --- /dev/null +++ b/regression/test103.expr @@ -0,0 +1,4 @@ +repeat + local n = read (); + write (n) +until n > 0 diff --git a/regression/test103.input b/regression/test103.input new file mode 100644 index 000000000..9ebaa43de --- /dev/null +++ b/regression/test103.input @@ -0,0 +1,3 @@ +0 +0 +5 \ No newline at end of file diff --git a/runtime/runtime.c b/runtime/runtime.c index 19ece6d8d..bc889d973 100644 --- a/runtime/runtime.c +++ b/runtime/runtime.c @@ -178,7 +178,7 @@ void* Ls__Infix_58 (void *p, void *q) { push_extra_root(&p); push_extra_root(&q); - res = Bsexp (3, p, q, 848787); + res = Bsexp (BOX(3), p, q, 848787); pop_extra_root(&q); pop_extra_root(&p); @@ -779,6 +779,8 @@ extern void* LmakeArray (int length) { r->tag = ARRAY_TAG | (n << 3); + memset (r->contents, 0, n * sizeof(int)); + __post_gc (); return r->contents; @@ -869,13 +871,13 @@ extern void* Bstringval (void *p) { return s; } -extern void* Bclosure (int n, void *entry, ...) { - va_list args = (va_list) BOX (NULL); - int i = BOX(0), - ai = BOX(0); +extern void* Bclosure (int bn, void *entry, ...) { + va_list args; + int i, ai; register int * ebp asm ("ebp"); - size_t * argss = NULL; - data *r = (data*) BOX (NULL); + size_t *argss; + data *r; + int n = UNBOX(bn); __pre_gc (); #ifdef DEBUG_PRINT @@ -917,12 +919,12 @@ extern void* Bclosure (int n, void *entry, ...) { return r->contents; } -extern void* Barray (int n, ...) { - va_list args = (va_list) BOX (NULL); - int i = BOX(0), - ai = BOX(0); - data *r = (data*) BOX (NULL); - +extern void* Barray (int bn, ...) { + va_list args; + int i, ai; + data *r; + int n = UNBOX(bn); + __pre_gc (); #ifdef DEBUG_PRINT @@ -949,13 +951,14 @@ extern void* Barray (int n, ...) { return r->contents; } -extern void* Bsexp (int n, ...) { - va_list args = (va_list) BOX (NULL); - int i = BOX(0); - int ai = BOX(0); - size_t * p = NULL; - sexp *r = (sexp*) BOX (NULL); - data *d = (data *) BOX (NULL); +extern void* Bsexp (int bn, ...) { + va_list args; + int i; + int ai; + size_t *p; + sexp *r; + data *d; + int n = UNBOX(bn); __pre_gc () ; @@ -995,27 +998,27 @@ extern void* Bsexp (int n, ...) { } extern int Btag (void *d, int t, int n) { - data *r = (data *) BOX (NULL); + data *r; if (UNBOXED(d)) return BOX(0); else { r = TO_DATA(d); #ifndef DEBUG_PRINT - return BOX(TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == t && LEN(r->tag) == n); + return BOX(TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == UNBOX(t) && LEN(r->tag) == UNBOX(n)); #else return BOX(TAG(r->tag) == SEXP_TAG && - GET_SEXP_TAG(TO_SEXP(d)->tag) == t && LEN(r->tag) == n); + GET_SEXP_TAG(TO_SEXP(d)->tag) == UNBOX(t) && LEN(r->tag) == UNBOX(n)); #endif } } extern int Barray_patt (void *d, int n) { - data *r = BOX(NULL); + data *r; if (UNBOXED(d)) return BOX(0); else { r = TO_DATA(d); - return BOX(TAG(r->tag) == ARRAY_TAG && LEN(r->tag) == n); + return BOX(TAG(r->tag) == ARRAY_TAG && LEN(r->tag) == UNBOX(n)); } } diff --git a/src/Driver.ml b/src/Driver.ml index 75638e59a..5c92fc6bf 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -44,7 +44,7 @@ class options args = object (self) val i = ref 1 val infile = ref (None : string option) - val paths = ref [try Sys.getenv "RC_RUNTIME" with _ -> "../runtime"] + val paths = ref [X86.get_std_path ()] val mode = ref (`Default : [`Default | `Eval | `SM | `Compile ]) (* Workaround until Ostap starts to memoize properly *) val const = ref false diff --git a/src/Language.ml b/src/Language.ml index 85989c4fa..32ff89905 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -83,7 +83,7 @@ module Value = let to_int = function | Int n -> n - | _ -> failwith "int value expected" + | x -> failwith (Printf.sprintf "int value expected (%s)\n" (show(t) (fun _ -> "") (fun _ -> "") x)) let to_string = function | String s -> s @@ -636,23 +636,24 @@ module Expr = ostap ( parse[def][infix][atr]: h:basic[def][infix][Void] -";" t:parse[def][infix][atr] {Seq (h, t)} | basic[def][infix][atr]; - scope[def][infix][atr][e]: <(d, infix')> : def[infix] expr:e[infix'][atr] {Scope (d, expr)}; + scope[def][infix][atr][e]: <(d, infix')> : def[infix] expr:e[infix'][atr] {Scope (d, expr)} | + <(d, infix')> : def[infix] => {d <> []} => {Scope (d, materialize atr Skip)}; basic[def][infix][atr]: !(expr (fun x -> x) (Array.map (fun (a, (atr, l)) -> a, (atr, List.map (fun (s, _, f) -> ostap (- $(s)), f) l)) infix) (primary def infix) atr); primary[def][infix][atr]: - s:(s:"-"? {match s with None -> fun x -> x | _ -> fun x -> Binop ("-", Const 0, x)}) + s:(s:"-"? {match s with None -> fun x -> x | _ -> fun x -> Binop ("-", Const 0, x)}) b:base[def][infix][Val] is:( "." f:LIDENT args:(-"(" !(Util.list)[parse def infix Val] -")")? {`Post (f, args)} | "." %"length" {`Len} | "." %"string" {`Str} | "[" i:parse[def][infix][Val] "]" {`Elem i} | "(" args:!(Util.list0)[parse def infix Val] ")" {`Call args} - )+ + )+ => {match (List.hd (List.rev is)), atr with | `Elem i, Reff -> true | _, Reff -> false | _, _ -> true} => - { + { let is = let rec fix_is = function | [ ] -> [] @@ -687,7 +688,7 @@ module Expr = in ignore atr (s res) } - | base[def][infix][atr]; + | base[def][infix][atr]; base[def][infix][atr]: l:$ n:DECIMAL => {notRef atr} :: (not_a_reference l) => {ignore atr (Const n)} | l:$ s:STRING => {notRef atr} :: (not_a_reference l) => {ignore atr (String s)} @@ -733,7 +734,22 @@ module Expr = | %"for" i:parse[def][infix][Void] "," c:parse[def][infix][Val] "," s:parse[def][infix][Void] %"do" b:scope[def][infix][Void][parse def] => {isVoid atr} => %"od" {materialize atr (Seq (i, While (c, Seq (b, s))))} - | %"repeat" s:scope[def][infix][Void][parse def] %"until" e:basic[def][infix][Val] => {isVoid atr} => {materialize atr (Repeat (s, e))} + | %"repeat" s:scope[def][infix][Void][parse def] %"until" e:basic[def][infix][Val] => {isVoid atr} => { + materialize atr @@ + match s with + | Scope (defs, s) -> + let defs, s = + List.fold_right (fun (name, def) (defs, s) -> + match def with + | (`Local, `Variable (Some expr)) -> + (name, (`Local, `Variable None)) :: defs, Seq (Ignore (Assign (Ref name, expr)), s) + | def -> (name, def) :: defs, s) + defs + ([], s) + in + Scope (defs, Repeat (s, e)) + | _ -> Repeat (s, e) + } | %"return" e:basic[def][infix][Val]? => {isVoid atr} => {Return e} | %"case" l:$ e:parse[def][infix][Val] %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) -"->" scope[def][infix][atr][parse def])] %"esac" @@ -941,7 +957,7 @@ module Definition = }; parse[infix][expr][expr'][def]: m:(%"local" {`Local} | %"public" e:(%"external")? {match e with None -> `Public | Some _ -> `PublicExtern} | %"external" {`Extern}) - locs:!(Util.list (local_var m infix expr' def)) ";" {locs, infix} + locs:!(Util.list (local_var m infix expr' def)) next:";" {locs, infix} | - <(m, orig_name, name, infix', flag)> : head[infix] -"(" -args:!(Util.list0 arg) -")" (l:$ "{" body:expr[def][infix'][Expr.Weak] "}" { if flag && List.length args != 2 then report_error ~loc:(Some l#coord) "infix operator should accept two arguments"; @@ -951,7 +967,7 @@ module Definition = } | l:$ ";" { match m with - | `Extern -> [(name, (m, `Fun (args, Expr.Skip)))], infix' + | `Extern -> [(name, (m, `Fun (args, Expr.Skip)))], infix' | _ -> report_error ~loc:(Some l#coord) (Printf.sprintf "missing body for the function/infix \"%s\"" orig_name) }) ) @@ -1084,7 +1100,7 @@ ostap ( definitions[infix]: <(def, infix')> : !(Definition.parse infix (fun def infix atr -> Expr.scope def infix atr (Expr.parse def)) (fun def infix atr -> Expr.basic def infix atr) - definitions) <(defs, infix'')> : definitions[infix'] { + definitions) <(defs, infix'')> : definitions[infix'] { def @ defs, infix'' } | empty {[], infix} diff --git a/src/X86.ml b/src/X86.ml index 66ac79831..96f441c26 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -128,7 +128,8 @@ let compile cmd env imports code = | ">=" -> "ge" | ">" -> "g" | _ -> failwith "unknown operator" - in + in + let box n = (n lsl 1) lor 1 in let rec compile' env scode = let on_stack = function S _ -> true | _ -> false in let mov x s = if on_stack x && on_stack s then [Mov (x, eax); Mov (eax, s)] else [Mov (x, s)] in @@ -172,8 +173,8 @@ let compile cmd env imports code = let env, pushs = push_args env [] n in let pushs = match f with - | "Barray" -> List.rev @@ (Push (L n)) :: pushs - | "Bsexp" -> List.rev @@ (Push (L n)) :: pushs + | "Barray" -> List.rev @@ (Push (L (box n))) :: pushs + | "Bsexp" -> List.rev @@ (Push (L (box n))) :: pushs | "Bsta" -> pushs | _ -> List.rev pushs in @@ -203,7 +204,7 @@ let compile cmd env imports code = pushr @ push_closure @ [Push (M ("$" ^ name)); - Push (L closure_len); + Push (L (box closure_len)); Call "Bclosure"; Binop ("+", L (word_size * (closure_len + 2)), esp); Mov (eax, s)] @ @@ -211,7 +212,7 @@ let compile cmd env imports code = | CONST n -> let s, env' = env#allocate in - (env', [Mov (L ((n lsl 1) lor 1), s)]) + (env', [Mov (L (box n), s)]) | STRING s -> let s, env = env#string s in @@ -431,12 +432,12 @@ let compile cmd env imports code = let s1, env = env#allocate in let s2, env = env#allocate in let env, code = call env ".tag" 3 in - env, [Mov (L env#hash t, s1); Mov (L n, s2)] @ code + env, [Mov (L (box (env#hash t)), s1); Mov (L (box n), s2)] @ code | ARRAY n -> let s, env = env#allocate in let env, code = call env ".array_patt" 2 in - env, [Mov (L n, s)] @ code + env, [Mov (L (box n), s)] @ code | PATT StrCmp -> call env ".string_patt" 2 @@ -454,7 +455,7 @@ let compile cmd env imports code = | FAIL ((line, col), value) -> let v, env = if value then env#peek, env else env#pop in let s, env = env#string cmd#get_infile in - env, [Push (L col); Push (L line); Push (M ("$" ^ s)); Push v; Call "Bmatch_failure"; Binop ("+", L (3 * word_size), esp)] + env, [Push (L (box col)); Push (L (box line)); Push (M ("$" ^ s)); Push v; Call "Bmatch_failure"; Binop ("+", L (3 * word_size), esp)] | i -> invalid_arg (Printf.sprintf "invalid SM insn: %s\n" (GT.show(insn) i)) @@ -688,6 +689,11 @@ let genasm cmd prog = (globals @ data @ [Meta "\t.text"] @ code); Buffer.contents asm +let get_std_path () = + match Sys.getenv_opt "RC_RUNTIME" with + | Some s -> s + | None -> "../runtime" + (* Builds a program: generates the assembler file and compiles it with the gcc toolchain *) let build cmd prog = let find_objects imports paths = @@ -710,7 +716,7 @@ let build cmd prog = in cmd#dump_file "s" (genasm cmd prog); cmd#dump_file "i" (Interface.gen prog); - let inc = try Sys.getenv "RC_RUNTIME" with _ -> "../runtime" in + let inc = get_std_path () in match cmd#get_mode with | `Default -> let objs = find_objects (fst @@ fst prog) cmd#get_include_paths in