st/lama_byterun
1
0
Fork 0
mirror of https://github.com/ProgramSnail/Lama.git synced 2025-12-06 06:48:48 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

FSF in SM (only obe-level closure yet)

Browse source
This commit is contained in:
Dmitry Boulytchev 2019-10-11 17:25:58 +03:00
parent 89e0d04f3d
commit 4fec2aa29e
8 changed files with 160 additions and 53 deletions
Download patch file Download diff file Expand all files Collapse all files

4
regression/Makefile
View file

@ -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)

2
regression/orig/test065.log Normal file
View file

@ -0,0 +1,2 @@
> 2
1

21
regression/test065.expr Normal file
View file

@ -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 ())

1
regression/test065.input Normal file
View file

@ -0,0 +1 @@
5

8
src/Driver.ml
View file

@ -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] <input file.expr>\n"

63
src/Language.ml
View file

@ -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

112
src/SM.ml
View file

@ -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

2
src/X86.ml
View file

@ -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";