From 4fec2aa29eeca079efb9ec48b47ccf075e526e83 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Fri, 11 Oct 2019 17:25:58 +0300 Subject: [PATCH] FSF in SM (only obe-level closure yet) --- regression/Makefile | 4 +- regression/orig/test065.log | 2 + regression/test065.expr | 21 +++++++ regression/test065.input | 1 + src/Driver.ml | 8 ++- src/Language.ml | 63 ++++++++++++++------ src/SM.ml | 112 ++++++++++++++++++++++++++---------- src/X86.ml | 2 +- 8 files changed, 160 insertions(+), 53 deletions(-) create mode 100644 regression/orig/test065.log create mode 100644 regression/test065.expr create mode 100644 regression/test065.input diff --git a/regression/Makefile b/regression/Makefile index f3ef37b65..40ae14613 100644 --- a/regression/Makefile +++ b/regression/Makefile @@ -1,4 +1,4 @@ -TESTS=$(basename $(wildcard test*.expr)) +TESTS=$(sort $(basename $(wildcard test*.expr))) RC=../src/rc.opt @@ -10,7 +10,7 @@ $(TESTS): %: %.expr @echo $@ # @$(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log cat $@.input | $(RC) -i $< > $@.log && diff $@.log orig/$@.log - @cat $@.input | $(RC) -s $< 2> /dev/null > $@.log && diff $@.log orig/$@.log; true + cat $@.input | $(RC) -s $< 2> /dev/null > $@.log && diff $@.log orig/$@.log clean: $(RM) test*.log *.s *~ $(TESTS) diff --git a/regression/orig/test065.log b/regression/orig/test065.log new file mode 100644 index 000000000..a301ff37a --- /dev/null +++ b/regression/orig/test065.log @@ -0,0 +1,2 @@ +> 2 +1 diff --git a/regression/test065.expr b/regression/test065.expr new file mode 100644 index 000000000..51434051f --- /dev/null +++ b/regression/test065.expr @@ -0,0 +1,21 @@ +fun f () { + local x, l = {}; + fun g () {return x} + + x := 1; + l := g : l; + + x := 2; + l := g : l; + + return l +} + +fun p (l) { + case l of + {} -> skip + | h : tl -> write (h ()); p (tl) + esac +} + +p (f ()) \ No newline at end of file diff --git a/regression/test065.input b/regression/test065.input new file mode 100644 index 000000000..7ed6ff82d --- /dev/null +++ b/regression/test065.input @@ -0,0 +1 @@ +5 diff --git a/src/Driver.ml b/src/Driver.ml index b4650a996..bba88ef78 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -41,10 +41,13 @@ let main = match (try parse infile with Language.Semantic_error msg -> `Fail msg) with | `Ok prog -> if to_compile - then + then ( let basename = Filename.chop_suffix infile ".expr" in (* ignore @@ X86.build prog basename *) (* TODO! *) () - else + ) + else ( + (* Printf.printf "Program:\n%s\n" (GT.show(Language.Expr.t) prog);*) + (*Format.printf "Program\n%s\n%!" (HTML.toHTML ((GT.html(Language.Expr.t)) prog));*) let rec read acc = try let r = read_int () in @@ -59,6 +62,7 @@ let main = else SM.run (SM.compile prog) input in List.iter (fun i -> Printf.printf "%d\n" i) output + ) | `Fail er -> Printf.eprintf "Error: %s\n" er (* with Invalid_argument _ -> Printf.printf "Usage: rc [-i | -s] \n" diff --git a/src/Language.ml b/src/Language.ml index 4ebf8bcdf..dd1e5c821 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -2,6 +2,7 @@ The library provides "@type ..." syntax extension and plugins like show, etc. *) module OrigList = List + open GT (* Opening a library for combinator-based syntax analysis *) @@ -22,7 +23,8 @@ module Value = | Local of int | Arg of int | Access of int - with show + | Fun of string + with show,html @type ('a, 'b) t = | Empty @@ -33,8 +35,9 @@ module Value = | Array of ('a, 'b) t array | Sexp of string * ('a, 'b) t array | Closure of string list * 'a * 'b + | FunRef of string * string list * 'a * int | Builtin of string - with show + with show,html let to_int = function | Int n -> n @@ -125,11 +128,30 @@ module State = struct (* State: global state, local state, scope variables *) - type 'a t = + @type 'a t = | I - | G of (string * bool) list * (string -> 'a) - | L of (string * bool) list * (string -> 'a) * 'a t - + | G of (string * bool) list * (string, 'a) arrow + | L of (string * bool) list * (string, 'a) arrow * 'a t + with show,html + + (* Get the depth level of a state *) + let rec level = function + | I -> 0 + | G _ -> 1 + | L (_, _, st) -> 1 + level st + + (* Prune state to a certain level *) + let prune st n = + let rec inner n st = + match st with + | I -> st, 0 + | G (xs, s) -> st, 1 + | L (xs, s, st') -> + let st'', l = inner n st' in + (if l >= n then st'' else st), l+1 + in + fst @@ inner n st + (* Undefined state *) let undefined x = failwith (Printf.sprintf "Undefined variable: %s" x) @@ -229,7 +251,7 @@ module Pattern = (* any sexp value *) | SexpTag (* any array value *) | ArrayTag (* any closure *) | ClosureTag - with show, foldl + with show, foldl, html (* Pattern parser *) ostap ( @@ -273,13 +295,12 @@ module Expr = (* The type of configuration: a state, an input stream, an output stream, and a stack of values *) - type 'a value = ('a, 'a value State.t) Value.t - type 'a config = 'a value State.t * int list * int list * 'a value list - + @type 'a value = ('a, 'a value State.t) Value.t with show,html + @type 'a config = 'a value State.t * int list * int list * 'a value list with show,html (* The type for expressions. Note, in regular OCaml there is no "@type..." notation, it came from GT. *) - type t = + @type t = (* integer constant *) | Const of int (* array *) | Array of t list (* string *) | String of string @@ -302,11 +323,13 @@ module Expr = (* return statement *) | Return of t option (* ignore a value *) | Ignore of t (* unit value *) | Unit - (* entering the scope *) | Scope of (string * [`Fun of string list * t | `Variable of t option]) list * t + (* entering the scope *) | Scope of (string * decl) list * t (* lambda expression *) | Lambda of string list * t (* leave a scope *) | Leave - (* intrinsic (for evaluation) *) | Intrinsic of (t config -> t config) - (* control (for control flow) *) | Control of (t config -> t * t config) + (* intrinsic (for evaluation) *) | Intrinsic of (t config, t config) arrow + (* control (for control flow) *) | Control of (t config, t * t config) arrow + and decl = [`Fun of string list * t | `Variable of t option] + with show,html (* Reff : parsed expression should return value Reff (look for ":="); Val : -//- returns simple value; @@ -394,7 +417,7 @@ module Expr = List.fold_left (fun (vs, bd, bnd) -> function | (name, `Variable value) -> (name, true) :: vs, (match value with None -> bd | Some v -> Seq (Ignore (Assign (Ref name, v)), bd)), bnd - | (name, `Fun (args, b)) -> (name, false) :: vs, bd, (name, Value.Closure (args, b, st)) :: bnd + | (name, `Fun (args, b)) -> (name, false) :: vs, bd, (name, Value.FunRef (name, args, b, 1 + State.level st)) :: bnd ) ([], body, []) (List.rev defs) @@ -416,7 +439,13 @@ module Expr = | StringVal s -> eval conf k (schedule_list [s; Intrinsic (fun (st, i, o, s::vs) -> (st, i, o, (Value.of_string @@ Value.string_val s)::vs))]) | Var x -> - eval (st, i, o, (State.eval st x) :: vs) Skip k + let v = + match State.eval st x with + | Value.FunRef (_, args, body, level) -> + Value.Closure (args, body, State.prune st level) + | v -> v + in + eval (st, i, o, v :: vs) Skip k | Ref x -> eval (st, i, o, (Value.Var (Value.Global x)) :: vs) Skip k | Array xs -> @@ -640,7 +669,7 @@ module Expr = | s:STRING => {notRef atr} => {ignore atr (String (unquote s))} | c:CHAR => {notRef atr} => {ignore atr (Const (Char.code c))} | %"infix" s:STRING => {notRef atr} => {ignore atr (Var (infix_name @@ unquote s))} - | %"fun" "(" args:!(Util.list0)[ostap (STRING)] ")" body:parse[def][infix][Void] => {notRef atr} => {ignore atr (Lambda (args, body))} + | %"fun" "(" args:!(Util.list0)[ostap (LIDENT)] ")" body:basic[def][infix][Void] => {notRef atr} => {ignore atr (Lambda (args, body))} | "[" es:!(Util.list0)[parse def infix Val] "]" => {notRef atr} => {ignore atr (Array es)} | -"{" scope[def][infix][atr][parse def] -"}" | "{" es:!(Util.list0)[parse def infix Val] "}" => {notRef atr} => {ignore atr (match es with diff --git a/src/SM.ml b/src/SM.ml index eeb727f83..709c610bb 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -2,7 +2,7 @@ open GT open Language (* The type for patters *) -@type patt = StrCmp | String | Array | Sexp | Boxed | UnBoxed with show +@type patt = StrCmp | String | Array | Sexp | Boxed | UnBoxed | Closure with show (* The type for the stack machine instructions *) @type insn = @@ -18,8 +18,9 @@ open Language (* a label *) | LABEL of string (* unconditional jump *) | JMP of string (* conditional jump *) | CJMP of string * string -(* begins procedure definition *) | BEGIN of string * int * int +(* begins procedure definition *) | BEGIN of string * int * int * Value.designation list (* end procedure definition *) | END +(* create a closure *) | CLOSURE of string (* calls a function/procedure *) | CALL of int (* returns from a function *) | RET (* drops the top element off *) | DROP @@ -111,21 +112,31 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio | JMP l -> eval env conf (env#labeled l) | CJMP (c, l) -> let x::stack' = stack in eval env (cstack, stack', glob, loc, i, o) (if (c = "z" && Value.to_int x = 0) || (c = "nz" && Value.to_int x <> 0) then env#labeled l else prg') + + | CLOSURE name -> let BEGIN (_, _, _, dgs) :: _ = env#labeled name in + let closure = + Array.of_list @@ + List.map ( + function + | Value.Arg i -> loc.args.(i) + | Value.Local i -> loc.locals.(i) + | Value.Access i -> loc.closure.(i) + | _ -> invalid_arg "wrong value in CLOSURE") + dgs + in + eval env (cstack, (Value.Closure ([], name, closure)) :: stack, glob, loc, i, o) prg' | CALL n -> let vs, stack' = split (n+1) stack in let f::args = List.rev vs in - let args = List.rev args in (match f with - | Value.Builtin f -> eval env (env#builtin f args ((cstack, stack', glob, loc, i, o) : config)) prg' - | Value.Closure (_, f, _) -> eval env ((prg', loc)::cstack, stack, glob, loc, i, o) (env#labeled f) + | Value.Builtin f -> + eval env (env#builtin f (List.rev args) ((cstack, stack', glob, loc, i, o) : config)) prg' + | Value.Closure (_, f, closure) -> + eval env ((prg', loc)::cstack, stack', glob, {args = Array.of_list args; locals = [||]; closure = closure}, i, o) (env#labeled f) + | _ -> invalid_arg "not a closure (or a builtin) in CALL: %s\n" @@ show(value) f ) - | BEGIN (_, args, locals) -> let vs, stack' = split (args+1) stack in - let _ :: aargs = List.rev vs in - let aargs = aargs in - eval env (cstack, stack', glob, {args = Array.init args (fun i -> List.nth aargs i); - locals = Array.init locals (fun _ -> Value.Empty); - closure = [||]}, i, o) prg' + | BEGIN (_, _, locals, _) -> eval env (cstack, stack, glob, {loc with locals = Array.init locals (fun _ -> Value.Empty)}, i, o) prg' | END -> (match cstack with | (prg', loc')::cstack' -> eval env (cstack', Value.Empty :: stack, glob, loc', i, o) prg' @@ -157,6 +168,8 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio eval env (cstack, (Value.of_int @@ match x with Value.Int _ -> 0 | _ -> 1) :: stack', glob, loc, i, o) prg' | PATT UnBoxed -> let x::stack' = stack in eval env (cstack, (Value.of_int @@ match x with Value.Int _ -> 1 | _ -> 0) :: stack', glob, loc, i, o) prg' + | PATT Closure -> let x::stack' = stack in + eval env (cstack, (Value.of_int @@ match x with Value.Closure _ -> 1 | _ -> 0) :: stack', glob, loc, i, o) prg' ) (* Top-level evaluation @@ -206,13 +219,17 @@ let check_name_and_add names name mut = class env = object (self : 'self) - val label_index = 0 - val scope_index = 0 - val local_index = 0 - val arg_index = 0 - val nlocals = 0 - val st = (State.I : Value.designation State.t) - val fundefs = ([] : (string * string list * Expr.t * Value.designation State.t) list) + val label_index = 0 + val scope_index = 0 + val local_index = 0 + val arg_index = 0 + val acc_index = 0 + val nlocals = 0 + val lam_index = 0 + val st = (State.I : Value.designation State.t) + val enclosing_st = (State.I : Value.designation State.t) + val closure = ([] : Value.designation list) + val fundefs = ([] : (string * string list * Expr.t * Value.designation State.t) list) method get_label = (label @@ string_of_int label_index), {< label_index = label_index + 1 >} @@ -232,7 +249,21 @@ object (self : 'self) | State.L (xs, _, x) -> {< st = x; local_index = local_index - List.length xs >} method init_fun_scope (st' : Value.designation State.t) = - {< st = st'; arg_index = 0; local_index = 0; nlocals = 0 >} # push_scope + {< st = ( + let rec readdress_to_closure = function + | State.L (xs, _, tl) -> + State.L (xs, (fun _ -> Value.Access (~-1)), readdress_to_closure tl) + | st -> st + in + readdress_to_closure st' + ); + enclosing_st = st'; + arg_index = 0; + local_index = 0; + acc_index = 0; + nlocals = 0; + closure = [] + >} # push_scope method add_arg (name : string) = {< st = (match st with @@ -265,27 +296,40 @@ object (self : 'self) | State.I -> invalid_arg "uninitialized scope" | State.G (names, s) -> - State.G (check_name_and_add names name false, State.bind name (Value.Global name') s) + State.G (check_name_and_add names name false, State.bind name (Value.Fun name') s) | State.L (names, s, p) -> - State.L (check_name_and_add names name false, State.bind name (Value.Global name') s, p) + State.L (check_name_and_add names name false, State.bind name (Value.Fun name') s, p) in {< st = st' >} - + + method add_lambda (args : string list) (body : Expr.t) = + let name' = self#fun_internal_name (Printf.sprintf "lambda_%d" lam_index) in + {< fundefs = (name', args, body, st) :: fundefs; lam_index = lam_index + 1 >}, name' + method add_fun (name : string) (args : string list) (body : Expr.t) = let name' = self#fun_internal_name name in {< fundefs = (name', args, body, st) :: fundefs >} - method lookup name = State.eval st name + method lookup name = + match State.eval st name with + | Value.Access n when n = ~-1 -> + let index = acc_index in + let enclosing_loc = State.eval enclosing_st name in + {< st = State.update name (Value.Access index) st; acc_index = acc_index + 1; closure = enclosing_loc :: closure >}, Value.Access index + + | other -> self, other method next_definition = match fundefs with | [] -> None - | (name, args, body, st) :: rest -> Some ({< fundefs = rest>}, (name, args, body, st)) - + | (name, args, body, st) :: rest -> Some ({< fundefs = rest >}, (name, args, body, st)) + + method closure = List.rev closure + end let compile p = @@ -299,6 +343,7 @@ let compile p = | Pattern.SexpTag -> env, true, [PATT Sexp; CJMP ("z", lfalse)] | Pattern.UnBoxed -> env, true, [PATT UnBoxed; CJMP ("z", lfalse)] | Pattern.Boxed -> env, true, [PATT Boxed; CJMP ("z", lfalse)] + | Pattern.ClosureTag -> env, true, [PATT Closure; CJMP ("z", lfalse)] | Pattern.Array ps -> let lhead, env = env#get_label in let ldrop, env = env#get_label in @@ -347,10 +392,11 @@ let compile p = List.fold_left (fun (env, acc) (name, path) -> let env = env#add_name name true in + let env, dsg = env#lookup name in env, ([DUP] @ List.concat (List.map (fun i -> [LD (Value.Global ".elem"); SWAP; CONST i; CALL 2]) path) @ - [ST (env#lookup name); DROP]) :: acc + [ST dsg; DROP]) :: acc ) (env, []) (List.rev bindings) @@ -366,6 +412,10 @@ let compile p = let env, flag2, s2 = compile_list l env es in add_code (env, flag1, s1) les flag2 s2 and compile_expr l env = function + | Expr.Lambda (args, b) -> + let env, name = env#add_lambda args b in + env, false, [CLOSURE name] + | Expr.Scope (ds, e) -> let env = env#push_scope in let env, e, funs = @@ -389,8 +439,8 @@ let compile p = add_code (compile_expr ls env s) ls false [DROP] | Expr.ElemRef (x, i) -> compile_list l env [x; i] - | Expr.Var x -> env, false, [LD (env#lookup x)] - | Expr.Ref x -> env, false, [LDA (env#lookup x)] + | Expr.Var x -> let env, acc = env#lookup x in env, false, [match acc with Value.Fun name -> CLOSURE name | _ -> LD acc] + | Expr.Ref x -> let env, acc = env#lookup x in env, false, [LDA acc] | Expr.Const n -> env, false, [CONST n] | Expr.String s -> env, false, [STRING s] | Expr.Binop (op, x, y) -> let lop, env = env#get_label in @@ -492,9 +542,9 @@ let compile p = let env = env#init_fun_scope st in let env = List.fold_left (fun env arg -> env#add_arg arg) env args in let lend, env = env#get_label in - let env, flag, code = compile_expr lend env stmt in + let env, flag, code = compile_expr lend env stmt in env#pop_scope, - [LABEL name; BEGIN (name, env#nargs, env#nlocals)] @ + [LABEL name; BEGIN (name, env#nargs, env#nlocals, env#closure)] @ code @ (if flag then [LABEL lend] else []) @ [END] @@ -509,5 +559,5 @@ let compile p = let env = new env in let lend, env = env#get_label in let env, flag, code = compile_expr lend env p in - let prg = compile_fundefs [[BEGIN ("main", 0, env#nlocals)] @(if flag then code @ [LABEL lend] else code) @ [END]] env in + let prg = compile_fundefs [[BEGIN ("main", 0, env#nlocals, [])] @(if flag then code @ [LABEL lend] else code) @ [END]] env in print_prg prg; prg diff --git a/src/X86.ml b/src/X86.ml index 5c5d4972b..a31cf9242 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -559,7 +559,7 @@ let genasm (ds, stmt) = let env, code = compile (new env) - ((LABEL "main") :: (BEGIN ("main", 0, 0)) :: [] (* TODO! SM.compile (ds, stmt) *)) + ((LABEL "main") :: (BEGIN ("main", 0, 0, [])) :: [] (* TODO! SM.compile (ds, stmt) *)) in let gc_start, gc_end = "__gc_data_start", "__gc_data_end" in let data = [Meta "\t.data";