mirror of
https://github.com/ProgramSnail/Lama.git
synced 2025-12-05 22:38:44 +00:00
FCF in X86 (no closure access yet)
This commit is contained in:
Dmitry Boulytchev
parent
763f5fe486
commit
aa1d88e303
9 changed files with 202 additions and 73 deletions
|
|
@ -9,7 +9,7 @@ check: $(TESTS)
|
|||
$(TESTS): %: %.expr
|
||||
@echo $@
|
||||
$(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
|
||||
|
||||
clean:
|
||||
|
|
|
|||
|
|
@ -15,6 +15,8 @@ fun print_list (x) {
|
|||
esac
|
||||
}
|
||||
|
||||
local x = read ();
|
||||
|
||||
print_list ({1, 2, 3});
|
||||
print_list (map (a, {1, 2, 3}));
|
||||
print_list (map (b, {1, 2, 3}))
|
||||
|
|
|
|||
|
|
@ -17,4 +17,6 @@ fun c () {
|
|||
write (2)
|
||||
}
|
||||
|
||||
local x = read ();
|
||||
|
||||
f ({a, b, c})
|
||||
|
|
@ -10,6 +10,8 @@ fun f (l) {
|
|||
esac
|
||||
}
|
||||
|
||||
local x = read ();
|
||||
|
||||
write (f ({}));
|
||||
write (f ({1}));
|
||||
write (f ({1, 1}));
|
||||
|
|
|
|||
|
|
@ -6,4 +6,6 @@ fun traverse (l) {
|
|||
esac
|
||||
}
|
||||
|
||||
local x = read ();
|
||||
|
||||
traverse ({1, fun () write(100), 2, 3, 4, 5, fun () write (200), 6, 7})
|
||||
|
|
@ -1,3 +1,5 @@
|
|||
infixr "++" at "+" (a, b) {return a+b}
|
||||
|
||||
local x = read ();
|
||||
|
||||
write (infix "++" (2, 3))
|
||||
|
|
@ -8,7 +8,13 @@
|
|||
# include <sys/mman.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 */
|
||||
typedef struct {
|
||||
size_t * begin;
|
||||
|
|
@ -22,14 +28,27 @@ static pool to_space;
|
|||
size_t *current;
|
||||
/* end */
|
||||
|
||||
# ifdef __ENABLE_GC__
|
||||
|
||||
/* GC extern invariant for built-in functions */
|
||||
extern void __pre_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 */
|
||||
|
||||
# define STRING_TAG 0x00000001
|
||||
# define ARRAY_TAG 0x00000003
|
||||
# define SEXP_TAG 0x00000005
|
||||
# define STRING_TAG 0x00000001
|
||||
# define ARRAY_TAG 0x00000003
|
||||
# define SEXP_TAG 0x00000005
|
||||
# define CLOSURE_TAG 0x00000007
|
||||
|
||||
# define LEN(x) ((x & 0xFFFFFFF8) >> 3)
|
||||
# define TAG(x) (x & 0x00000007)
|
||||
|
|
@ -244,6 +263,36 @@ 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);
|
||||
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, ...) {
|
||||
va_list args = (va_list) BOX (NULL);
|
||||
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) {
|
||||
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;
|
||||
|
||||
# ifdef __ENABLE_GC__
|
||||
|
||||
extern void L__gc_init ();
|
||||
|
||||
# else
|
||||
|
||||
# define L__gc_init __gc_init_subst
|
||||
void __gc_init_subst () {}
|
||||
|
||||
# endif
|
||||
|
||||
extern void __gc_root_scan_stack ();
|
||||
|
||||
/* ======================================== */
|
||||
/* Mark-and-copy */
|
||||
/* ======================================== */
|
||||
|
||||
static size_t SPACE_SIZE = 128;
|
||||
static size_t SPACE_SIZE = 1280;
|
||||
// static size_t SPACE_SIZE = 1280;
|
||||
# define POOL_SIZE (2*SPACE_SIZE)
|
||||
|
||||
|
|
@ -578,6 +643,20 @@ extern size_t * gc_copy (size_t *obj) {
|
|||
objj = d;
|
||||
#endif
|
||||
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:
|
||||
#ifdef DEBUG_PRINT
|
||||
printf ("gc_copy:array_tag; len = %zu\n", LEN(d->tag)); fflush (stdout);
|
||||
|
|
@ -736,6 +815,19 @@ static void printFromSpace (void) {
|
|||
fflush (stdout);
|
||||
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:
|
||||
printf ("(=>%p): ARRAY\n\t", d->contents);
|
||||
len = LEN(d->tag);
|
||||
|
|
@ -781,6 +873,7 @@ static void printFromSpace (void) {
|
|||
}
|
||||
#endif
|
||||
|
||||
#ifdef __ENABLE_GC__
|
||||
extern void * alloc (size_t size) {
|
||||
void * p = (void*)BOX(NULL);
|
||||
if (from_space.current + size < from_space.end) {
|
||||
|
|
@ -805,3 +898,4 @@ extern void * alloc (size_t size) {
|
|||
#endif
|
||||
return gc (size);
|
||||
}
|
||||
# endif
|
||||
|
|
|
|||
25
src/SM.ml
25
src/SM.ml
|
|
@ -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
|
||||
*)
|
||||
|
||||
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 module M = Map.Make (String) in
|
||||
let rec make_env (m, s) = function
|
||||
| [] -> (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 glob = State.undefined in
|
||||
let (_, _, _, _, i, o) =
|
||||
eval
|
||||
object
|
||||
method is_label l = M.mem l m
|
||||
method labeled l = M.find l m
|
||||
inherit indexer p
|
||||
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 (st, i, o, r) = Language.Builtin.eval (State.I, i, o, []) (List.map Obj.magic @@ List.rev args) f in
|
||||
|
|
|
|||
134
src/X86.ml
134
src/X86.ml
|
|
@ -48,6 +48,7 @@ type instr =
|
|||
(* pushes the operand on the hardware stack *) | Push 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 indirect address *) | CallI of opnd
|
||||
(* returns from a function *) | Ret
|
||||
(* a label in the code *) | Label of string
|
||||
(* a conditional jump *) | CJmp of string * string
|
||||
|
|
@ -91,6 +92,7 @@ let show instr =
|
|||
| Pop s -> Printf.sprintf "\tpopl\t%s" (opnd s)
|
||||
| Ret -> "\tret"
|
||||
| Call p -> Printf.sprintf "\tcall\t%s" p
|
||||
| CallI o -> Printf.sprintf "\tcall\t*(%s)" (opnd o)
|
||||
| Label l -> Printf.sprintf "%s:\n" l
|
||||
| Jmp l -> Printf.sprintf "\tjmp\t%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 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 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 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
|
||||
| _ -> List.rev pushs
|
||||
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
|
||||
let y, env = env#allocate in env, code @ [Mov (eax, y)]
|
||||
in
|
||||
|
|
@ -157,6 +177,26 @@ let compile env code =
|
|||
let stack = env#show_stack in
|
||||
let env', code' =
|
||||
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 ->
|
||||
let s, env' = env#allocate in
|
||||
(env', [Mov (L ((n lsl 1) lor 1), s)])
|
||||
|
|
@ -302,38 +342,23 @@ let compile env code =
|
|||
|
||||
| BEGIN (f, nargs, nlocals, closure) ->
|
||||
env#assert_empty_stack;
|
||||
let env = env#enter f (nlocals + if closure = [] then 0 else 1) 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
|
||||
let has_closure = closure <> [] in
|
||||
let env = env#enter f nlocals has_closure in
|
||||
env, (if has_closure then [Push eax] else []) @
|
||||
[Push ebp;
|
||||
Mov (esp, ebp);
|
||||
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 ->
|
||||
env#endfunc, [Label env#epilogue;
|
||||
Mov (ebp, esp);
|
||||
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#allocated_size env#allocated)
|
||||
]
|
||||
|
|
@ -344,8 +369,7 @@ let compile env code =
|
|||
|
||||
| CALL (f, n) -> call env f n
|
||||
|
||||
| CALLC n ->
|
||||
invalid_arg "CALLC not supported yet"
|
||||
| CALLC n -> callc env n
|
||||
|
||||
| SEXP (t, n) ->
|
||||
let s, env = env#allocate in
|
||||
|
|
@ -385,6 +409,7 @@ let compile env code =
|
|||
| Array -> ".array_tag_patt"
|
||||
| String -> ".string_tag_patt"
|
||||
| Sexp -> ".sexp_tag_patt"
|
||||
| Closure -> ".closure_tag_patt"
|
||||
) 1
|
||||
|
||||
| i ->
|
||||
|
|
@ -402,23 +427,25 @@ module S = Set.Make (String)
|
|||
module M = Map.Make (String)
|
||||
|
||||
(* Environment implementation *)
|
||||
class env =
|
||||
class env prg =
|
||||
let chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" 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
|
||||
object (self)
|
||||
val globals = S.empty (* a set of global variables *)
|
||||
val stringm = M.empty (* a string map *)
|
||||
val scount = 0 (* string count *)
|
||||
val stack_slots = 0 (* maximal number of stack positions *)
|
||||
val static_size = 0 (* static data size *)
|
||||
val stack = [] (* symbolic stack *)
|
||||
val args = [] (* function arguments *)
|
||||
val locals = [] (* function local variables *)
|
||||
val fname = "" (* function name *)
|
||||
val stackmap = M.empty (* labels to stack map *)
|
||||
val barrier = false (* barrier condition *)
|
||||
inherit SM.indexer prg
|
||||
val globals = S.empty (* a set of global variables *)
|
||||
val stringm = M.empty (* a string map *)
|
||||
val scount = 0 (* string count *)
|
||||
val stack_slots = 0 (* maximal number of stack positions *)
|
||||
val static_size = 0 (* static data size *)
|
||||
val stack = [] (* symbolic stack *)
|
||||
val args = [] (* function arguments *)
|
||||
val locals = [] (* function local variables *)
|
||||
val fname = "" (* function name *)
|
||||
val stackmap = M.empty (* labels to stack map *)
|
||||
val barrier = false (* barrier condition *)
|
||||
val max_locals_size = 0
|
||||
val has_closure = false
|
||||
|
||||
method max_locals_size = max_locals_size
|
||||
|
||||
|
|
@ -463,8 +490,8 @@ class env =
|
|||
method loc x =
|
||||
match x with
|
||||
| Value.Global name -> M ("global_" ^ name)
|
||||
| Value.Fun name -> M name
|
||||
| Value.Local i -> S i
|
||||
| Value.Fun name -> M ("$" ^ name)
|
||||
| Value.Local i -> S ((if has_closure then 1 else 0) + i)
|
||||
| Value.Arg i -> S (- (i+1))
|
||||
| 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
|
||||
|
||||
(* enters a function *)
|
||||
method enter f nlocals =
|
||||
{< static_size = nlocals; stack_slots = nlocals; stack = []; fname = f >}
|
||||
method enter f nlocals has_closure =
|
||||
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 *)
|
||||
method epilogue = Printf.sprintf "L%s_epilogue" fname
|
||||
|
||||
|
|
@ -584,7 +600,7 @@ let genasm prog =
|
|||
| _ -> decorate prog
|
||||
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 data = [Meta "\t.data";
|
||||
Meta (Printf.sprintf "filler:\t.fill\t%d, 4, 1" env#max_locals_size);
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue