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

FCF (alpha)

Browse source
This commit is contained in:
Dmitry Boulytchev 2019-10-16 21:07:27 +03:00
parent aa1d88e303
commit d99588a6db
9 changed files with 138 additions and 89 deletions
Download patch file Download diff file Expand all files Collapse all files

2
regression/Makefile
View file

@ -9,7 +9,7 @@ check: $(TESTS)
$(TESTS): %: %.expr $(TESTS): %: %.expr
@echo $@ @echo $@
$(RC) $< && cat $@.input | ./$@ 2> /dev/null > $@.log && diff $@.log orig/$@.log $(RC) $< && cat $@.input | ./$@ 2> /dev/null > $@.log && diff $@.log orig/$@.log
# cat $@.input | $(RC) -i $< > $@.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 cat $@.input | $(RC) -s $< 2> /dev/null > $@.log && diff $@.log orig/$@.log
clean: clean:

2
regression/test061.expr
View file

@ -6,5 +6,7 @@ fun plus (x) {
return f return f
} }
local x = read ();
write (plus(5)(6)); write (plus(5)(6));
write (plus(8)(10)) write (plus(8)(10))

2
regression/test062.expr
View file

@ -17,4 +17,6 @@ fun a (x, y) {
} }
} }
local x = read ();
a (5, 7) () a (5, 7) ()

2
regression/test065.expr
View file

@ -18,4 +18,6 @@ fun p (l) {
esac esac
} }
local x = read ();
p (f ()) p (f ())

2
regression/test066.expr
View file

@ -8,4 +8,6 @@ fun f (a) {
return g (a) return g (a)
} }
local x = read ();
write (f(10)(5)) write (f(10)(5))

2
regression/test067.expr
View file

@ -2,4 +2,6 @@ infixr "**" before "*" (f, g) {
return fun (x) {return f (g (x))} return fun (x) {return f (g (x))}
} }
local x = read ();
write ((fun (x) {return x+2} ** fun (x) {return x+3})(7)) write ((fun (x) {return x+2} ** fun (x) {return x+3})(7))

8
runtime/runtime.c
View file

@ -8,7 +8,7 @@
# include <sys/mman.h> # include <sys/mman.h>
# include <assert.h> # include <assert.h>
/*# define __ENABLE_GC__*/ # define __ENABLE_GC__
# ifndef __ENABLE_GC__ # ifndef __ENABLE_GC__
# define alloc malloc # define alloc malloc
# endif # endif
@ -281,9 +281,9 @@ extern void* Bclosure (int n, void *entry, ...) {
va_start(args, n); va_start(args, n);
for (i = 1; i<n; i++) { for (i = 0; i<n; i++) {
ai = va_arg(args, int); ai = va_arg(args, int);
((int*)r->contents)[i] = ai; ((int*)r->contents)[i+1] = ai;
} }
va_end(args); va_end(args);
@ -528,8 +528,8 @@ extern void __gc_root_scan_stack ();
/* Mark-and-copy */ /* Mark-and-copy */
/* ======================================== */ /* ======================================== */
//static size_t SPACE_SIZE = 128;
static size_t SPACE_SIZE = 1280; static size_t SPACE_SIZE = 1280;
// static size_t SPACE_SIZE = 1280;
# define POOL_SIZE (2*SPACE_SIZE) # define POOL_SIZE (2*SPACE_SIZE)
static void swap (size_t ** a, size_t ** b) { static void swap (size_t ** a, size_t ** b) {

4
src/Language.ml
View file

@ -102,7 +102,7 @@ module Value =
module Builtin = module Builtin =
struct struct
let list = ["read"; "write"; ".elem"; ".length"; ".array"; ".stringval"; "__gc_init"; "raw"] let list = ["read"; "write"; ".elem"; ".length"; ".array"; ".stringval"]
let bindings () = List.map (fun name -> name, Value.Builtin name) list let bindings () = List.map (fun name -> name, Value.Builtin name) list
let names = List.map (fun name -> name, false) list let names = List.map (fun name -> name, false) list
@ -120,8 +120,6 @@ module Builtin =
| ".length" -> (st, i, o, (Value.of_int (match List.hd args with Value.Sexp (_, a) | Value.Array a -> Array.length a | Value.String s -> Bytes.length s))::vs) | ".length" -> (st, i, o, (Value.of_int (match List.hd args with Value.Sexp (_, a) | Value.Array a -> Array.length a | Value.String s -> Bytes.length s))::vs)
| ".array" -> (st, i, o, (Value.of_array @@ Array.of_list args)::vs) | ".array" -> (st, i, o, (Value.of_array @@ Array.of_list args)::vs)
| ".stringval" -> let [a] = args in (st, i, o, (Value.of_string @@ Value.string_val a)::vs) | ".stringval" -> let [a] = args in (st, i, o, (Value.of_string @@ Value.string_val a)::vs)
| "__gc_init" -> (st, i, o, vs)
| "raw" -> let [a] = args in (st, i, o, a :: vs)
end end

203
src/X86.ml
View file

@ -15,11 +15,11 @@ let word_size = 4;;
(* We need to distinguish the following operand types: *) (* We need to distinguish the following operand types: *)
@type opnd = @type opnd =
| R of int (* hard register *) | R of int (* hard register *)
| S of int (* a position on the hardware stack *) | S of int (* a position on the hardware stack *)
| M of string (* a named memory location *) | M of string (* a named memory location *)
| L of int (* an immediate operand *) | L of int (* an immediate operand *)
| I of opnd (* an indirect operand *) | I of int * opnd (* an indirect operand with offset *)
with show with show
let show_opnd = show(opnd) let show_opnd = show(opnd)
@ -73,13 +73,14 @@ let show instr =
| _ -> failwith "unknown binary operator" | _ -> failwith "unknown binary operator"
in in
let rec opnd = function let rec opnd = function
| R i -> regs.(i) | R i -> regs.(i)
| S i -> if i >= 0 | S i -> if i >= 0
then Printf.sprintf "-%d(%%ebp)" ((i+1) * word_size) then Printf.sprintf "-%d(%%ebp)" ((i+1) * word_size)
else Printf.sprintf "%d(%%ebp)" (8+(-i-1) * word_size) else Printf.sprintf "%d(%%ebp)" (8+(-i-1) * word_size)
| M x -> x | M x -> x
| L i -> Printf.sprintf "$%d" i | L i -> Printf.sprintf "$%d" i
| I x -> Printf.sprintf "(%s)" (opnd x) | I (0, x) -> Printf.sprintf "(%s)" (opnd x)
| I (n, x) -> Printf.sprintf "%d(%s)" n (opnd x)
in in
match instr with match instr with
| Cltd -> "\tcltd" | Cltd -> "\tcltd"
@ -132,6 +133,7 @@ let compile env code =
let pushr, popr = let pushr, popr =
List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n) List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n)
in in
let pushr, popr = env#save_closure @ pushr, env#rest_closure @ popr in
let env, code = let env, code =
let rec push_args env acc = function let rec push_args env acc = function
| 0 -> env, acc | 0 -> env, acc
@ -141,35 +143,73 @@ let compile env code =
let env, pushs = push_args env [] n in let env, pushs = push_args env [] n in
let pushs = List.rev pushs in let pushs = List.rev pushs in
let closure, env = env#pop in let closure, env = env#pop in
let call_closure = [Mov (closure, eax); CallI closure] in let call_closure = [Mov (closure, edx); CallI closure] in
env, pushr @ pushs @ call_closure @ [Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr) env, pushr @ pushs @ call_closure @ [Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr)
in in
let y, env = env#allocate in env, code @ [Mov (eax, y)] let y, env = env#allocate in env, code @ [Mov (eax, y)]
in in
let call env f n = let call env f n =
let f = let closure =
match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f try
let BEGIN (_, _, _, closure) :: _ = env#labeled f in closure
with Not_found -> []
in in
let pushr, popr = match closure with
List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n) | [] ->
in let f =
let env, code = match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f
let rec push_args env acc = function in
| 0 -> env, acc let pushr, popr =
| n -> let x, env = env#pop in List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n)
push_args env ((Push x)::acc) (n-1) in
in let pushr, popr = env#save_closure @ pushr, env#rest_closure @ popr in
let env, pushs = push_args env [] n in let env, code =
let pushs = let rec push_args env acc = function
match f with | 0 -> env, acc
| "Barray" -> List.rev @@ (Push (L n)) :: pushs | n -> let x, env = env#pop in
| "Bsexp" -> List.rev @@ (Push (L n)) :: pushs push_args env ((Push x)::acc) (n-1)
| "Bsta" -> pushs in
| _ -> List.rev pushs let env, pushs = push_args env [] n in
in let pushs =
env, pushr @ pushs @ [Call f; Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr) match f with
in | "Barray" -> List.rev @@ (Push (L n)) :: pushs
let y, env = env#allocate in env, code @ [Mov (eax, y)] | "Bsexp" -> List.rev @@ (Push (L n)) :: pushs
| "Bsta" -> pushs
| _ -> List.rev pushs
in
env, pushr @ pushs @ [Call f; Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr)
in
let y, env = env#allocate in env, code @ [Mov (eax, y)]
| _ ->
let pushr, popr =
List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n)
in
let pushr, popr = env#save_closure @ pushr, env#rest_closure @ popr in
let rec push_args env acc = function
| 0 -> env, acc
| n -> let x, env = env#pop in
push_args env ((Push x)::acc) (n-1)
in
let env, push_args = push_args env [] n in
let push_args = List.rev push_args in
let closure_len = List.length closure in
let push_closure =
List.map (fun d -> Push (env#loc d)) @@ List.rev closure
in
let s, env = env#allocate in
(env, pushr @
push_args @
push_closure @
[Push (M ("$" ^ f));
Push (L closure_len);
Call "Bclosure";
Binop ("+", L (word_size * (closure_len + 2)), esp);
Mov (eax, edx);
CallI edx;
Binop ("+", L (word_size * List.length push_args), esp);
Mov (eax, s)
] @
List.rev popr)
in in
match scode with match scode with
| [] -> env, [] | [] -> env, []
@ -239,8 +279,8 @@ let compile env code =
let v, x, env' = env#pop2 in let v, x, env' = env#pop2 in
env'#push x, env'#push x,
(match x with (match x with
| S _ | M _ -> [Mov (v, edx); Mov (x, eax); Mov (edx, I eax); Mov (edx, x)] | S _ | M _ -> [Mov (v, edx); Mov (x, eax); Mov (edx, I (0, eax)); Mov (edx, x)] @ env#reload_closure
| _ -> [Mov (v, eax); Mov (eax, I x); Mov (eax, x)] | _ -> [Mov (v, eax); Mov (eax, I (0, x)); Mov (eax, x)]
) )
| BINOP op -> | BINOP op ->
@ -268,7 +308,7 @@ let compile env code =
Sal1 edx; Sal1 edx;
Or1 edx; Or1 edx;
Mov (edx, y) Mov (edx, y)
] ] @ env#reload_closure
| "<" | "<=" | "==" | "!=" | ">=" | ">" -> | "<" | "<=" | "==" | "!=" | ">=" | ">" ->
(match x with (match x with
| M _ | S _ -> | M _ | S _ ->
@ -279,7 +319,7 @@ let compile env code =
Sal1 eax; Sal1 eax;
Or1 eax; Or1 eax;
Mov (eax, y) Mov (eax, y)
] ] @ env#reload_closure
| _ -> | _ ->
[Binop ("^" , eax, eax); [Binop ("^" , eax, eax);
Binop ("cmp", x, y); Binop ("cmp", x, y);
@ -311,7 +351,7 @@ let compile env code =
Sal1 eax; Sal1 eax;
Or1 eax; Or1 eax;
Mov (eax, y) Mov (eax, y)
] ] @ env#reload_closure
| "!!" -> | "!!" ->
[Mov (y, eax); [Mov (y, eax);
Sar1 eax; Sar1 eax;
@ -344,24 +384,30 @@ let compile env code =
env#assert_empty_stack; env#assert_empty_stack;
let has_closure = closure <> [] in let has_closure = closure <> [] in
let env = env#enter f nlocals has_closure in let env = env#enter f nlocals has_closure in
env, (if has_closure then [Push eax] else []) @ env, (if has_closure then [Push edx] else []) @
[Push ebp; [Push ebp;
Mov (esp, ebp); Mov (esp, ebp);
Binop ("-", M ("$" ^ env#lsize), esp); Binop ("-", M ("$" ^ env#lsize), esp);
Mov (esp, edi); Mov (esp, edi);
Mov (M "$filler", esi); Mov (M "$filler", esi);
Mov (M ("$" ^ (env#allocated_size)), ecx); Mov (M ("$" ^ (env#allocated_size)), ecx);
Repmovsl Repmovsl
] ] @
(if f = "main" then [Call "L__gc_init"] else [])
| END -> | END ->
env#endfunc, [Label env#epilogue; let name = env#fname in
Mov (ebp, esp); env#leave, [
Pop ebp; Label env#epilogue;
Ret; Mov (ebp, esp);
Meta (Printf.sprintf "\t.set\t%s,\t%d" env#lsize (env#allocated * word_size)); Pop ebp
Meta (Printf.sprintf "\t.set\t%s,\t%d" env#allocated_size env#allocated) ] @
] env#rest_closure @
(if name = "main" then [Binop ("^", eax, eax)] else []) @
[Ret;
Meta (Printf.sprintf "\t.set\t%s,\t%d" env#lsize (env#allocated * word_size));
Meta (Printf.sprintf "\t.set\t%s,\t%d" env#allocated_size env#allocated)
]
| RET -> | RET ->
let x, env = env#pop in let x, env = env#pop in
@ -448,8 +494,21 @@ class env prg =
val has_closure = false val has_closure = false
method max_locals_size = max_locals_size method max_locals_size = max_locals_size
method has_closure = has_closure
method save_closure =
if has_closure then [Push edx] else []
method endfunc = method rest_closure =
if has_closure then [Pop edx] else []
method reload_closure =
if has_closure then [Mov (S 0, edx)] else []
method fname = fname
method leave =
if stack_slots > max_locals_size if stack_slots > max_locals_size
then {< max_locals_size = stack_slots >} then {< max_locals_size = stack_slots >}
else self else self
@ -491,16 +550,10 @@ class env prg =
match x with match x with
| Value.Global name -> M ("global_" ^ name) | Value.Global name -> M ("global_" ^ name)
| Value.Fun name -> M ("$" ^ name) | Value.Fun name -> M ("$" ^ name)
| Value.Local i -> S ((if has_closure then 1 else 0) + i) | Value.Local i -> S i
| Value.Arg i -> S (- (i+1)) | Value.Arg i -> S (- (i + if has_closure then 2 else 1))
| Value.Access i -> invalid_arg "closure access not yet implemented" | Value.Access i -> I (word_size * (i+1), edx)
(*
try S (- (List.assoc x args) - 1)
with Not_found ->
try S (assoc x locals) with Not_found -> M ("global_" ^ x)
*)
(* allocates a fresh position on a symbolic stack *) (* allocates a fresh position on a symbolic stack *)
method allocate = method allocate =
let x, n = let x, n =
@ -564,8 +617,7 @@ class env prg =
(* enters a function *) (* enters a function *)
method enter f nlocals has_closure = method enter f nlocals has_closure =
let n = nlocals + (if has_closure then 1 else 0) in {< static_size = nlocals; stack_slots = nlocals; stack = []; fname = f; has_closure = has_closure >}
{< static_size = n; stack_slots = n; stack = []; fname = f; has_closure = has_closure >}
(* returns a label for the epilogue *) (* returns a label for the epilogue *)
method epilogue = Printf.sprintf "L%s_epilogue" fname method epilogue = Printf.sprintf "L%s_epilogue" fname
@ -588,18 +640,7 @@ class env prg =
the stack code, then generates x86 assember code, then prints the assembler file the stack code, then generates x86 assember code, then prints the assembler file
*) *)
let genasm prog = let genasm prog =
let decorate e = let sm = SM.compile prog in
Expr.Seq (
Expr.Ignore (Expr.Call (Expr.Var "__gc_init", [])),
Expr.Seq (e, Expr.Return (Some (Expr.Call (Expr.Var "raw", [Expr.Const 0]))))
)
in
let expr =
match prog with
| Expr.Scope (defs, e) -> Expr.Scope (defs, decorate e)
| _ -> decorate prog
in
let sm = SM.compile expr in
let env, code = compile (new env sm) sm in let env, code = compile (new env sm) sm in
let gc_start, gc_end = "__gc_data_start", "__gc_data_end" in let gc_start, gc_end = "__gc_data_start", "__gc_data_end" in
let data = [Meta "\t.data"; let data = [Meta "\t.data";