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

FCF in X86 (no closure access yet)

Browse source
This commit is contained in:
Dmitry Boulytchev 2019-10-16 01:13:52 +03:00
parent 763f5fe486
commit aa1d88e303
9 changed files with 202 additions and 73 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/test058.expr
View file

@ -15,6 +15,8 @@ fun print_list (x) {
esac esac
} }
local x = read ();
print_list ({1, 2, 3}); print_list ({1, 2, 3});
print_list (map (a, {1, 2, 3})); print_list (map (a, {1, 2, 3}));
print_list (map (b, {1, 2, 3})) print_list (map (b, {1, 2, 3}))

2
regression/test059.expr
View file

@ -17,4 +17,6 @@ fun c () {
write (2) write (2)
} }
local x = read ();
f ({a, b, c}) f ({a, b, c})

2
regression/test060.expr
View file

@ -10,6 +10,8 @@ fun f (l) {
esac esac
} }
local x = read ();
write (f ({})); write (f ({}));
write (f ({1})); write (f ({1}));
write (f ({1, 1})); write (f ({1, 1}));

2
regression/test063.expr
View file

@ -6,4 +6,6 @@ fun traverse (l) {
esac esac
} }
local x = read ();
traverse ({1, fun () write(100), 2, 3, 4, 5, fun () write (200), 6, 7}) traverse ({1, fun () write(100), 2, 3, 4, 5, fun () write (200), 6, 7})

2
regression/test064.expr
View file

@ -1,3 +1,5 @@
infixr "++" at "+" (a, b) {return a+b} infixr "++" at "+" (a, b) {return a+b}
local x = read ();
write (infix "++" (2, 3)) write (infix "++" (2, 3))

104
runtime/runtime.c
View file

@ -8,7 +8,13 @@
# include <sys/mman.h> # include <sys/mman.h>
# include <assert.h> # include <assert.h>
// # define DEBUG_PRINT 1 /*# define __ENABLE_GC__*/
# ifndef __ENABLE_GC__
# define alloc malloc
# endif
/*# define DEBUG_PRINT 1*/
/* GC pool structure and data; declared here in order to allow debug print */ /* GC pool structure and data; declared here in order to allow debug print */
typedef struct { typedef struct {
size_t * begin; size_t * begin;
@ -22,14 +28,27 @@ static pool to_space;
size_t *current; size_t *current;
/* end */ /* end */
# ifdef __ENABLE_GC__
/* GC extern invariant for built-in functions */ /* GC extern invariant for built-in functions */
extern void __pre_gc (); extern void __pre_gc ();
extern void __post_gc (); extern void __post_gc ();
# else
# define __pre_gc __pre_gc_subst
# define __post_gc __post_gc_subst
void __pre_gc_subst () {}
void __post_gc_subst () {}
# endif
/* end */ /* end */
# define STRING_TAG 0x00000001 # define STRING_TAG 0x00000001
# define ARRAY_TAG 0x00000003 # define ARRAY_TAG 0x00000003
# define SEXP_TAG 0x00000005 # define SEXP_TAG 0x00000005
# define CLOSURE_TAG 0x00000007
# define LEN(x) ((x & 0xFFFFFFF8) >> 3) # define LEN(x) ((x & 0xFFFFFFF8) >> 3)
# define TAG(x) (x & 0x00000007) # define TAG(x) (x & 0x00000007)
@ -244,6 +263,36 @@ extern void* Bstringval (void *p) {
return s; return s;
} }
extern void* Bclosure (int n, void *entry, ...) {
va_list args = (va_list) BOX (NULL);
int i = BOX(0),
ai = BOX(0);
data *r = (data*) BOX (NULL);
__pre_gc ();
#ifdef DEBUG_PRINT
printf ("Bclosure: create n = %d\n", n); fflush(stdout);
#endif
r = (data*) alloc (sizeof(int) * (n+2));
r->tag = CLOSURE_TAG | (n << 3);
((void**) r->contents)[0] = entry;
va_start(args, n);
for (i = 1; i<n; i++) {
ai = va_arg(args, int);
((int*)r->contents)[i] = ai;
}
va_end(args);
__post_gc();
return r->contents;
}
extern void* Barray (int n, ...) { extern void* Barray (int n, ...) {
va_list args = (va_list) BOX (NULL); va_list args = (va_list) BOX (NULL);
int i = BOX(0), int i = BOX(0),
@ -350,6 +399,12 @@ extern int Bstring_patt (void *x, void *y) {
} }
} }
extern int Bclosure_tag_patt (void *x) {
if (UNBOXED(x)) return BOX(0);
return BOX(TAG(TO_DATA(x)->tag) == CLOSURE_TAG);
}
extern int Bboxed_patt (void *x) { extern int Bboxed_patt (void *x) {
return BOX(UNBOXED(x) ? 0 : 1); return BOX(UNBOXED(x) ? 0 : 1);
} }
@ -456,14 +511,24 @@ extern int Lwrite (int n) {
extern const size_t __gc_data_end, __gc_data_start; extern const size_t __gc_data_end, __gc_data_start;
# ifdef __ENABLE_GC__
extern void L__gc_init (); extern void L__gc_init ();
# else
# define L__gc_init __gc_init_subst
void __gc_init_subst () {}
# endif
extern void __gc_root_scan_stack (); 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)
@ -578,6 +643,20 @@ extern size_t * gc_copy (size_t *obj) {
objj = d; objj = d;
#endif #endif
switch (TAG(d->tag)) { switch (TAG(d->tag)) {
case CLOSURE_TAG:
#ifdef DEBUG_PRINT
printf ("gc_copy:closure_tag; len = %zu\n", LEN(d->tag)); fflush (stdout);
#endif
current += (LEN(d->tag) + 1) * sizeof (int);
*copy = d->tag;
copy++;
*copy = d->contents[0];
copy++;
i = LEN(d->tag) - 1;
d->tag = (int) (copy-1);
copy_elements (copy, obj, i);
break;
case ARRAY_TAG: case ARRAY_TAG:
#ifdef DEBUG_PRINT #ifdef DEBUG_PRINT
printf ("gc_copy:array_tag; len = %zu\n", LEN(d->tag)); fflush (stdout); printf ("gc_copy:array_tag; len = %zu\n", LEN(d->tag)); fflush (stdout);
@ -736,6 +815,19 @@ static void printFromSpace (void) {
fflush (stdout); fflush (stdout);
break; break;
case CLOSURE_TAG:
printf ("(=>%p): CLOSURE\n\t", d->contents);
len = LEN(d->tag);
for (int i = 1; i < len; i++) {
int elem = ((int*)d->contents)[i];
if (UNBOXED(elem)) printf ("%d ", elem);
else printf ("%p ", elem);
}
len += 1;
printf ("\n");
fflush (stdout);
break;
case ARRAY_TAG: case ARRAY_TAG:
printf ("(=>%p): ARRAY\n\t", d->contents); printf ("(=>%p): ARRAY\n\t", d->contents);
len = LEN(d->tag); len = LEN(d->tag);
@ -781,6 +873,7 @@ static void printFromSpace (void) {
} }
#endif #endif
#ifdef __ENABLE_GC__
extern void * alloc (size_t size) { extern void * alloc (size_t size) {
void * p = (void*)BOX(NULL); void * p = (void*)BOX(NULL);
if (from_space.current + size < from_space.end) { if (from_space.current + size < from_space.end) {
@ -805,3 +898,4 @@ extern void * alloc (size_t size) {
#endif #endif
return gc (size); return gc (size);
} }
# endif

25
src/SM.ml
View file

@ -208,19 +208,28 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio
Takes a program, an input stream, and returns an output stream this program calculates Takes a program, an input stream, and returns an output stream this program calculates
*) *)
module M = Map.Make (String)
class indexer prg =
let rec make_env m = function
| [] -> m
| (LABEL l) :: tl -> make_env (M.add l tl m) tl
| _ :: tl -> make_env m tl
in
let m = make_env M.empty prg in
object
method is_label l = M.mem l m
method labeled l = M.find l m
end
let run p i = let run p i =
let module M = Map.Make (String) in let module M = Map.Make (String) in
let rec make_env (m, s) = function let glob = State.undefined in
| [] -> (m, s)
| (LABEL l) :: tl -> make_env (M.add l tl m, State.bind l (Value.Closure ([], l, [||])) s) tl
| _ :: tl -> make_env (m, s) tl
in
let m, glob = make_env (M.empty, State.undefined) p in
let (_, _, _, _, i, o) = let (_, _, _, _, i, o) =
eval eval
object object
method is_label l = M.mem l m inherit indexer p
method labeled l = M.find l m
method builtin f args ((cstack, stack, glob, loc, i, o) as conf : config) = method builtin f args ((cstack, stack, glob, loc, i, o) as conf : config) =
let f = match f.[0] with 'L' -> String.sub f 1 (String.length f - 1) | _ -> f in let f = match f.[0] with 'L' -> String.sub f 1 (String.length f - 1) | _ -> f in
let (st, i, o, r) = Language.Builtin.eval (State.I, i, o, []) (List.map Obj.magic @@ List.rev args) f in let (st, i, o, r) = Language.Builtin.eval (State.I, i, o, []) (List.map Obj.magic @@ List.rev args) f in

132
src/X86.ml
View file

@ -48,6 +48,7 @@ type instr =
(* pushes the operand on the hardware stack *) | Push of opnd (* pushes the operand on the hardware stack *) | Push of opnd
(* pops from the hardware stack to the operand *) | Pop of opnd (* pops from the hardware stack to the operand *) | Pop of opnd
(* call a function by a name *) | Call of string (* call a function by a name *) | Call of string
(* call a function by indirect address *) | CallI of opnd
(* returns from a function *) | Ret (* returns from a function *) | Ret
(* a label in the code *) | Label of string (* a label in the code *) | Label of string
(* a conditional jump *) | CJmp of string * string (* a conditional jump *) | CJmp of string * string
@ -91,6 +92,7 @@ let show instr =
| Pop s -> Printf.sprintf "\tpopl\t%s" (opnd s) | Pop s -> Printf.sprintf "\tpopl\t%s" (opnd s)
| Ret -> "\tret" | Ret -> "\tret"
| Call p -> Printf.sprintf "\tcall\t%s" p | Call p -> Printf.sprintf "\tcall\t%s" p
| CallI o -> Printf.sprintf "\tcall\t*(%s)" (opnd o)
| Label l -> Printf.sprintf "%s:\n" l | Label l -> Printf.sprintf "%s:\n" l
| Jmp l -> Printf.sprintf "\tjmp\t%s" l | Jmp l -> Printf.sprintf "\tjmp\t%s" l
| CJmp (s , l) -> Printf.sprintf "\tj%s\t%s" s l | CJmp (s , l) -> Printf.sprintf "\tj%s\t%s" s l
@ -126,6 +128,24 @@ let compile env code =
let rec compile' env scode = let rec compile' env scode =
let on_stack = function S _ -> true | _ -> false in 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 let mov x s = if on_stack x && on_stack s then [Mov (x, eax); Mov (eax, s)] else [Mov (x, s)] in
let callc env n =
let pushr, popr =
List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n)
in
let env, code =
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, pushs = push_args env [] n in
let pushs = List.rev pushs in
let closure, env = env#pop in
let call_closure = [Mov (closure, eax); CallI closure] in
env, pushr @ pushs @ call_closure @ [Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr)
in
let y, env = env#allocate in env, code @ [Mov (eax, y)]
in
let call env f n = let call env f n =
let f = let f =
match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f
@ -147,7 +167,7 @@ let compile env code =
| "Bsta" -> pushs | "Bsta" -> pushs
| _ -> List.rev pushs | _ -> List.rev pushs
in in
env, pushr @ pushs @ [Call f; Binop ("+", L (4 * List.length pushs), esp)] @ (List.rev popr) env, pushr @ pushs @ [Call f; 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
@ -157,6 +177,26 @@ let compile env code =
let stack = env#show_stack in let stack = env#show_stack in
let env', code' = let env', code' =
match instr with match instr with
| CLOSURE name ->
let pushr, popr =
List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers 0)
in
let BEGIN (_, _, _, closure) :: _ = env#labeled name 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_closure @
[Push (M ("$" ^ name));
Push (L closure_len);
Call "Bclosure";
Binop ("+", L (word_size * (closure_len + 2)), esp);
Mov (eax, s)] @
List.rev popr)
| CONST n -> | CONST n ->
let s, env' = env#allocate in let s, env' = env#allocate in
(env', [Mov (L ((n lsl 1) lor 1), s)]) (env', [Mov (L ((n lsl 1) lor 1), s)])
@ -302,38 +342,23 @@ let compile env code =
| BEGIN (f, nargs, nlocals, closure) -> | BEGIN (f, nargs, nlocals, closure) ->
env#assert_empty_stack; env#assert_empty_stack;
let env = env#enter f (nlocals + if closure = [] then 0 else 1) in let has_closure = closure <> [] in
env, [Push ebp; Mov (esp, ebp); Binop ("-", M ("$" ^ env#lsize), esp); let env = env#enter f nlocals has_closure in
Mov (esp, edi); env, (if has_closure then [Push eax] else []) @
Mov (M "$filler", esi); [Push ebp;
Mov (M ("$" ^ (env#allocated_size)), ecx); Mov (esp, ebp);
Repmovsl Binop ("-", M ("$" ^ env#lsize), esp);
Mov (esp, edi);
Mov (M "$filler", esi);
Mov (M ("$" ^ (env#allocated_size)), ecx);
Repmovsl
] ]
(*
env, [Push ebp; Mov (esp, ebp); Binop ("-", M ("$" ^ string_of_int @@ word_size * size), esp);
Mov (esp, edi);
Mov (M "$filler", esi);
Mov (M ("$" ^ string_of_int size), ecx);
Repmovsl
]
*)
(*
| BEGIN (f, nargs, nlocals, closure) ->
env#assert_empty_stack;
let env = env#enter f a l in
env, [Push ebp; Mov (esp, ebp); Binop ("-", M ("$" ^ env#lsize), esp);
Mov (esp, edi);
Mov (M "$filler", esi);
Mov (M ("$" ^ (env#allocated_size)), ecx);
Repmovsl
]
*)
| END -> | END ->
env#endfunc, [Label env#epilogue; env#endfunc, [Label env#epilogue;
Mov (ebp, esp); Mov (ebp, esp);
Pop ebp; Pop ebp;
Ret ; 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#lsize (env#allocated * word_size));
Meta (Printf.sprintf "\t.set\t%s,\t%d" env#allocated_size env#allocated) Meta (Printf.sprintf "\t.set\t%s,\t%d" env#allocated_size env#allocated)
] ]
@ -344,8 +369,7 @@ let compile env code =
| CALL (f, n) -> call env f n | CALL (f, n) -> call env f n
| CALLC n -> | CALLC n -> callc env n
invalid_arg "CALLC not supported yet"
| SEXP (t, n) -> | SEXP (t, n) ->
let s, env = env#allocate in let s, env = env#allocate in
@ -385,6 +409,7 @@ let compile env code =
| Array -> ".array_tag_patt" | Array -> ".array_tag_patt"
| String -> ".string_tag_patt" | String -> ".string_tag_patt"
| Sexp -> ".sexp_tag_patt" | Sexp -> ".sexp_tag_patt"
| Closure -> ".closure_tag_patt"
) 1 ) 1
| i -> | i ->
@ -402,23 +427,25 @@ module S = Set.Make (String)
module M = Map.Make (String) module M = Map.Make (String)
(* Environment implementation *) (* Environment implementation *)
class env = class env prg =
let chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" in let chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" in
let make_assoc l i = List.combine l (List.init (List.length l) (fun x -> x + i)) in let make_assoc l i = List.combine l (List.init (List.length l) (fun x -> x + i)) in
let rec assoc x = function [] -> raise Not_found | l :: ls -> try List.assoc x l with Not_found -> assoc x ls in let rec assoc x = function [] -> raise Not_found | l :: ls -> try List.assoc x l with Not_found -> assoc x ls in
object (self) object (self)
val globals = S.empty (* a set of global variables *) inherit SM.indexer prg
val stringm = M.empty (* a string map *) val globals = S.empty (* a set of global variables *)
val scount = 0 (* string count *) val stringm = M.empty (* a string map *)
val stack_slots = 0 (* maximal number of stack positions *) val scount = 0 (* string count *)
val static_size = 0 (* static data size *) val stack_slots = 0 (* maximal number of stack positions *)
val stack = [] (* symbolic stack *) val static_size = 0 (* static data size *)
val args = [] (* function arguments *) val stack = [] (* symbolic stack *)
val locals = [] (* function local variables *) val args = [] (* function arguments *)
val fname = "" (* function name *) val locals = [] (* function local variables *)
val stackmap = M.empty (* labels to stack map *) val fname = "" (* function name *)
val barrier = false (* barrier condition *) val stackmap = M.empty (* labels to stack map *)
val barrier = false (* barrier condition *)
val max_locals_size = 0 val max_locals_size = 0
val has_closure = false
method max_locals_size = max_locals_size method max_locals_size = max_locals_size
@ -463,8 +490,8 @@ class env =
method loc x = method loc x =
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 i | Value.Local i -> S ((if has_closure then 1 else 0) + i)
| Value.Arg i -> S (- (i+1)) | Value.Arg i -> S (- (i+1))
| Value.Access i -> invalid_arg "closure access not yet implemented" | Value.Access i -> invalid_arg "closure access not yet implemented"
@ -536,21 +563,10 @@ class env =
method allocated_size = Printf.sprintf "LS%s_SIZE" fname method allocated_size = Printf.sprintf "LS%s_SIZE" fname
(* enters a function *) (* enters a function *)
method enter f nlocals = method enter f nlocals has_closure =
{< static_size = nlocals; stack_slots = nlocals; stack = []; fname = f >} let n = nlocals + (if has_closure then 1 else 0) in
{< static_size = n; stack_slots = n; stack = []; fname = f; has_closure = has_closure >}
(*
(* enters a scope *)
method scope vars =
let n = List.length vars in
let static_size' = n + static_size in
{< stack_slots = max stack_slots static_size'; static_size = static_size'; locals = (make_assoc vars static_size) :: locals >}
(* leaves a scope *)
method unscope =
let n = List.length (List.hd locals) in
{< static_size = static_size - n; locals = List.tl locals >}
*)
(* 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
@ -584,7 +600,7 @@ let genasm prog =
| _ -> decorate prog | _ -> decorate prog
in in
let sm = SM.compile expr in let sm = SM.compile expr in
let env, code = compile (new env) 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";
Meta (Printf.sprintf "filler:\t.fill\t%d, 4, 1" env#max_locals_size); Meta (Printf.sprintf "filler:\t.fill\t%d, 4, 1" env#max_locals_size);