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

gdb support; no closures yet.

Browse source
This commit is contained in:
Dmitry Boulytchev 2020-09-10 09:07:38 +03:00
parent 2dbd6808a5
commit a2f316164e
3 changed files with 89 additions and 37 deletions
Download patch file Download diff file Expand all files Collapse all files

76
src/SM.ml
View file

@ -4,6 +4,16 @@ open Language
(* The type for patters *) (* The type for patters *)
@type patt = StrCmp | String | Array | Sexp | Boxed | UnBoxed | Closure with show @type patt = StrCmp | String | Array | Sexp | Boxed | UnBoxed | Closure with show
(* The type for local scopes tree *)
@type scope = {
blab : string;
elab : string;
names : (string * int) list;
subs : scope list;
} with show
let show_scope = show(scope);;
(* The type for the stack machine instructions *) (* The type for the stack machine instructions *)
@type insn = @type insn =
(* binary operator *) | BINOP of string (* binary operator *) | BINOP of string
@ -16,9 +26,10 @@ open Language
(* store a value into a reference *) | STI (* store a value into a reference *) | STI
(* store a value into array/sexp/string *) | STA (* store a value into array/sexp/string *) | STA
(* a label *) | LABEL of string (* a label *) | LABEL of string
(* a scope label *) | SLABEL of string
(* unconditional jump *) | JMP of string (* unconditional jump *) | JMP of string
(* conditional jump *) | CJMP of string * string (* conditional jump *) | CJMP of string * string
(* begins procedure definition *) | BEGIN of string * string list * int * int * Value.designation list (* begins procedure definition *) | BEGIN of string * int * int * Value.designation list * string list * scope list
(* end procedure definition *) | END (* end procedure definition *) | END
(* create a closure *) | CLOSURE of string * Value.designation list (* create a closure *) | CLOSURE of string * Value.designation list
(* proto closure *) | PROTO of string * string (* proto closure *) | PROTO of string * string
@ -139,7 +150,7 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio
Value.update_elem x (Value.to_int j) v; Value.update_elem x (Value.to_int j) v;
eval env (cstack, v::stack', glob, loc, i, o) prg' eval env (cstack, v::stack', glob, loc, i, o) prg'
| LABEL _ -> eval env conf prg' | SLABEL _ | LABEL _ -> eval env conf prg'
| JMP l -> eval env conf (env#labeled l) | JMP l -> eval env conf (env#labeled l)
| CJMP (c, l) -> let x::stack' = stack in | 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') 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')
@ -171,7 +182,7 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio
| _ -> invalid_arg "not a closure (or a builtin) in CALL: %s\n" @@ show(value) f | _ -> invalid_arg "not a closure (or a builtin) in CALL: %s\n" @@ show(value) f
) )
| BEGIN (_, _, _, locals, _) -> eval env (cstack, stack, glob, {loc with locals = Array.init locals (fun _ -> Value.Empty)}, 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 | END -> (match cstack with
| (prg', loc')::cstack' -> eval env (cstack', (*Value.Empty ::*) stack, glob, loc', i, o) prg' | (prg', loc')::cstack' -> eval env (cstack', (*Value.Empty ::*) stack, glob, loc', i, o) prg'
@ -269,7 +280,8 @@ let check_name_and_add names name mut =
local_index : int; local_index : int;
acc_index : int; acc_index : int;
nlocals : int; nlocals : int;
closure : Value.designation list closure : Value.designation list;
scopes : scope list;
} with show } with show
@type fundef = { @type fundef = {
@ -290,7 +302,8 @@ let init_scope st = {
acc_index = 0; acc_index = 0;
local_index = 0; local_index = 0;
nlocals = 0; nlocals = 0;
closure = [] closure = [];
scopes = [];
} }
let to_fundef name args body st = { let to_fundef name args body st = {
@ -485,7 +498,7 @@ object (self : 'self)
) @@ ) @@
List.filter (function (_, `Local, _) -> false | _ -> true) decls List.filter (function (_, `Local, _) -> false | _ -> true) decls
method push_scope = method push_scope (blab : string) (elab : string) =
match scope.st with match scope.st with
| State.I -> | State.I ->
{< {<
@ -500,7 +513,8 @@ object (self : 'self)
{< scope_index = scope_index + 1; {< scope_index = scope_index + 1;
scope = { scope = {
scope with scope with
st = State.L ([], State.undefined, scope.st) st = State.L ([], State.undefined, scope.st);
scopes = {blab = blab; elab = elab; names = []; subs = []} :: scope.scopes
} }
>} >}
@ -513,11 +527,14 @@ object (self : 'self)
scope = { scope = {
scope with scope with
st = x; st = x;
local_index = scope.local_index - List.length xs local_index = scope.local_index - List.length xs;
scopes = match scope.scopes with
[_] -> scope.scopes
| hs :: ps :: tl -> {ps with subs = hs :: ps.subs} :: tl
} }
>} >}
method open_fun_scope (name, args, body, st') = method open_fun_scope blab elab (name, args, body, st') =
{< {<
fundefs = open_scope fundefs { fundefs = open_scope fundefs {
name = name; name = name;
@ -533,13 +550,15 @@ object (self : 'self)
in in
readdress_to_closure st' readdress_to_closure st'
); );
>} # push_scope >} # push_scope blab elab
method close_fun_scope = method close_fun_scope =
(*Printf.printf "Scopes: %s\n" @@ show(GT.list) show_scope scope.scopes;*)
let scopes = scope.scopes in
let fundefs' = close_scope fundefs in let fundefs' = close_scope fundefs in
match top fundefs' with match top fundefs' with
| Some fd -> {< fundefs = fundefs'; scope = fd.scope >} # pop_scope | Some fd -> {< fundefs = fundefs'; scope = fd.scope >} # pop_scope, scopes
| None -> {< fundefs = fundefs' >} # pop_scope | None -> {< fundefs = fundefs' >} # pop_scope, scopes
method add_arg (name : string) = {< method add_arg (name : string) = {<
scope = { scope = {
@ -574,7 +593,10 @@ object (self : 'self)
State.L (check_name_and_add names name mut, State.bind name (Value.Local scope.local_index) s, p) State.L (check_name_and_add names name mut, State.bind name (Value.Local scope.local_index) s, p)
); );
local_index = (match scope.st with State.L _ -> scope.local_index + 1 | _ -> scope.local_index); local_index = (match scope.st with State.L _ -> scope.local_index + 1 | _ -> scope.local_index);
nlocals = (match scope.st with State.L _ -> max (scope.local_index + 1) scope.nlocals | _ -> scope.nlocals) nlocals = (match scope.st with State.L _ -> max (scope.local_index + 1) scope.nlocals | _ -> scope.nlocals);
scopes = match scope.scopes with
ts :: tl -> {ts with names = (name, scope.local_index) :: ts.names} :: tl
| _ -> scope.scopes
} }
>} >}
@ -730,7 +752,9 @@ let compile cmd ((imports, infixes), p) =
env#register_call name, false, lines @ [PROTO (name, env#current_function)] env#register_call name, false, lines @ [PROTO (name, env#current_function)]
| Expr.Scope (ds, e) -> | Expr.Scope (ds, e) ->
let env = env#push_scope in let blab, env = env#get_label in
let elab, env = env#get_label in
let env = env#push_scope blab elab in
let env, e, funs = let env, e, funs =
List.fold_left List.fold_left
(fun (env, e, funs) -> (fun (env, e, funs) ->
@ -744,7 +768,7 @@ let compile cmd ((imports, infixes), p) =
in in
let env = List.fold_left (fun env (name, args, m, b) -> env#add_fun name args m b) env funs in let env = List.fold_left (fun env (name, args, m, b) -> env#add_fun name args m b) env funs in
let env, flag, code = compile_expr tail l env e in let env, flag, code = compile_expr tail l env e in
env#pop_scope, flag, code env#pop_scope, flag, [SLABEL blab] @ code @ [SLABEL elab]
| Expr.Unit -> env, false, [CONST 0] | Expr.Unit -> env, false, [CONST 0]
@ -845,11 +869,13 @@ let compile cmd ((imports, infixes), p) =
else env#get_label, [JMP l] else env#get_label, [JMP l]
in in
let env, lfalse', pcode = pattern env lfalse p in let env, lfalse', pcode = pattern env lfalse p in
let env = env#push_scope in let blab, env = env#get_label in
let elab, env = env#get_label in
let env = env#push_scope blab elab in
let env, bindcode = bindings env p in let env, bindcode = bindings env p in
let env, l' , scode = compile_expr tail l env s in let env, l' , scode = compile_expr tail l env s in
let env = env#pop_scope in let env = env#pop_scope in
(env, Some lfalse, i+1, ((match lab with None -> [] | Some l -> [LABEL l; DUP]) @ pcode @ bindcode @ scode @ jmp) :: code, lfalse') (env, Some lfalse, i+1, ((match lab with None -> [SLABEL blab] | Some l -> [SLABEL blab; LABEL l; DUP]) @ pcode @ bindcode @ scode @ jmp @ [SLABEL elab]) :: code, lfalse')
else acc else acc
) )
(env, None, 0, [], true) brs (env, None, 0, [], true) brs
@ -859,7 +885,9 @@ let compile cmd ((imports, infixes), p) =
let rec compile_fundef env ((name, args, stmt, st) as fd) = let rec compile_fundef env ((name, args, stmt, st) as fd) =
(* Printf.eprintf "Compile fundef: %s, state=%s\n" name (show(State.t) (show(Value.designation)) st); *) (* Printf.eprintf "Compile fundef: %s, state=%s\n" name (show(State.t) (show(Value.designation)) st); *)
(* Printf.eprintf "st (inner) = %s\n" (try show(Value.designation) @@ State.eval st "inner" with _ -> " not found"); *) (* Printf.eprintf "st (inner) = %s\n" (try show(Value.designation) @@ State.eval st "inner" with _ -> " not found"); *)
let env = env#open_fun_scope fd in let blab, env = env#get_label in
let elab, env = env#get_label in
let env = env#open_fun_scope blab elab fd in
(*Printf.eprintf "Lookup: %s\n%!" (try show(Value.designation) @@ snd (env#lookup "inner") with _ -> "no inner..."); *) (*Printf.eprintf "Lookup: %s\n%!" (try show(Value.designation) @@ snd (env#lookup "inner") with _ -> "no inner..."); *)
let env = List.fold_left (fun env arg -> env#add_arg arg) env args in let env = List.fold_left (fun env arg -> env#add_arg arg) env args in
let lend, env = env#get_label in let lend, env = env#get_label in
@ -867,13 +895,15 @@ let compile cmd ((imports, infixes), p) =
let env, funcode = compile_fundefs [] env in let env, funcode = compile_fundefs [] env in
(*Printf.eprintf "Function: %s, closure: %s\n%!" name (show(list) (show(Value.designation)) env#closure);*) (*Printf.eprintf "Function: %s, closure: %s\n%!" name (show(list) (show(Value.designation)) env#closure);*)
let env = env#register_closure name in let env = env#register_closure name in
let nargs, nlocals, closure = env#nargs, env#nlocals, env#closure in
let env, scopes = env#close_fun_scope in
let code = let code =
([LABEL name; BEGIN (name, args, env#nargs, env#nlocals, env#closure)] @ ([LABEL name; BEGIN (name, nargs, nlocals, closure, args, scopes); SLABEL blab] @
code @ code @
(if flag then [LABEL lend] else []) @ (if flag then [LABEL lend] else []) @
[END]) :: funcode [SLABEL elab; END]) :: funcode
in in
env#close_fun_scope, code env, code
and compile_fundefs acc env = and compile_fundefs acc env =
match env#next_definition with match env#next_definition with
| None -> env, acc | None -> env, acc
@ -884,7 +914,7 @@ let compile cmd ((imports, infixes), p) =
let fix_closures env prg = let fix_closures env prg =
let rec inner state = function let rec inner state = function
| [] -> [] | [] -> []
| BEGIN (f, a, na, l, c) :: tl -> BEGIN (f, a, na, l, try env#get_fun_closure f with Not_found -> c) :: inner state tl | BEGIN (f, na, l, c, a, s) :: tl -> BEGIN (f, na, l, (try env#get_fun_closure f with Not_found -> c), a, s) :: inner state tl
| PROTO (f, c) :: tl -> CLOSURE (f, env#get_closure (f, c)) :: inner state tl | PROTO (f, c) :: tl -> CLOSURE (f, env#get_closure (f, c)) :: inner state tl
| PPROTO (f, c) :: tl -> | PPROTO (f, c) :: tl ->
(match env#get_closure (f, c) with (match env#get_closure (f, c) with
@ -905,7 +935,7 @@ let compile cmd ((imports, infixes), p) =
let env, flag, code = compile_expr false lend env p in let env, flag, code = compile_expr false lend env p in
let code = if flag then code @ [LABEL lend] else code in let code = if flag then code @ [LABEL lend] else code in
let topname = cmd#topname in let topname = cmd#topname in
let env, prg = compile_fundefs [[LABEL topname; BEGIN (topname, [], (if topname = "main" then 2 else 0), env#nlocals, [])] @ code @ [END]] env in let env, prg = compile_fundefs [[LABEL topname; BEGIN (topname, (if topname = "main" then 2 else 0), env#nlocals, [], [], [])] @ code @ [END]] env in
let prg = [PUBLIC topname] @ env#get_decls @ List.flatten prg in let prg = [PUBLIC topname] @ env#get_decls @ List.flatten prg in
(*Printf.eprintf "Before propagating closures:\n"; (*Printf.eprintf "Before propagating closures:\n";
Printf.eprintf "%s\n%!" env#show_funinfo; Printf.eprintf "%s\n%!" env#show_funinfo;

48
src/X86.ml
View file

@ -62,7 +62,23 @@ type instr =
(* arithmetic correction: shr 1 *) | Sar1 of opnd (* arithmetic correction: shr 1 *) | Sar1 of opnd
| Repmovsl | Repmovsl
(* Instruction printer *) (* Instruction printer *)
let stack_offset i =
if i >= 0
then (i+1) * word_size
else 8 + (-i-1) * word_size
let show instr = let show instr =
let rec opnd = function
| R i -> regs.(i)
| C -> "4(%ebp)"
| S i -> if i >= 0
then Printf.sprintf "-%d(%%ebp)" (stack_offset i)
else Printf.sprintf "%d(%%ebp)" (stack_offset i)
| M x -> x
| L i -> Printf.sprintf "$%d" i
| I (0, x) -> Printf.sprintf "(%s)" (opnd x)
| I (n, x) -> Printf.sprintf "%d(%s)" n (opnd x)
in
let binop = function let binop = function
| "+" -> "addl" | "+" -> "addl"
| "-" -> "subl" | "-" -> "subl"
@ -74,17 +90,6 @@ let show instr =
| "test" -> "test" | "test" -> "test"
| _ -> failwith "unknown binary operator" | _ -> failwith "unknown binary operator"
in in
let rec opnd = function
| R i -> regs.(i)
| C -> "4(%ebp)"
| S i -> if i >= 0
then Printf.sprintf "-%d(%%ebp)" ((i+1) * word_size)
else Printf.sprintf "%d(%%ebp)" (8+(-i-1) * word_size)
| M x -> x
| L i -> Printf.sprintf "$%d" i
| I (0, x) -> Printf.sprintf "(%s)" (opnd x)
| I (n, x) -> Printf.sprintf "%d(%s)" n (opnd x)
in
match instr with match instr with
| Cltd -> "\tcltd" | Cltd -> "\tcltd"
| Set (suf, s) -> Printf.sprintf "\tset%s\t%s" suf s | Set (suf, s) -> Printf.sprintf "\tset%s\t%s" suf s
@ -383,15 +388,31 @@ let compile cmd env imports code =
then [Mov (x, eax); Binop (op, eax, y); Or1 y] then [Mov (x, eax); Binop (op, eax, y); Or1 y]
else [Binop (op, x, y); Or1 y] else [Binop (op, x, y); Or1 y]
) )
| LABEL s -> (if env#is_barrier then (env#drop_barrier)#retrieve_stack s else env), [Label s] | LABEL s -> (if env#is_barrier then (env#drop_barrier)#retrieve_stack s else env), [Label s]
| SLABEL s -> env, [Label s]
| JMP l -> (env#set_stack l)#set_barrier, [Jmp l] | JMP l -> (env#set_stack l)#set_barrier, [Jmp l]
| CJMP (s, l) -> | CJMP (s, l) ->
let x, env = env#pop in let x, env = env#pop in
env#set_stack l, [Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp (s, l)] env#set_stack l, [Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp (s, l)]
| BEGIN (f, args, nargs, nlocals, closure) -> | BEGIN (f, nargs, nlocals, closure, args, scopes) ->
let rec stabs_scope scope =
let names =
List.map
(fun (name, index) ->
Meta (Printf.sprintf "\t.stabs \"%s:1\",128,0,0,-%d" name (stack_offset index))
)
scope.names
in
names @
(if names = [] then [] else [Meta (Printf.sprintf "\t.stabn 192,0,0,%s-%s" scope.blab f)]) @
(List.flatten @@ List.map stabs_scope scope.subs) @
(if names = [] then [] else [Meta (Printf.sprintf "\t.stabn 224,0,0,%s-%s" scope.elab f)])
in
let name = let name =
if f.[0] = 'L' then String.sub f 1 (String.length f - 1) else f if f.[0] = 'L' then String.sub f 1 (String.length f - 1) else f
in in
@ -403,7 +424,8 @@ let compile cmd env imports code =
then [] then []
else else
[Meta (Printf.sprintf "\t.stabs \"%s:F1\",36,0,0,%s" name f)] @ [Meta (Printf.sprintf "\t.stabs \"%s:F1\",36,0,0,%s" name f)] @
(List.mapi (fun i a -> Meta (Printf.sprintf "\t.stabs \"%s:p1\",160,0,0,%d" a ((i*4) + 8))) args) (List.mapi (fun i a -> Meta (Printf.sprintf "\t.stabs \"%s:p1\",160,0,0,%d" a ((i*4) + 8))) args) @
(List.flatten @@ List.map stabs_scope scopes)
) )
@ @
[Meta "\t.cfi_startproc"; Meta "\t.cfi_adjust_cfa_offset\t4"] @ [Meta "\t.cfi_startproc"; Meta "\t.cfi_adjust_cfa_offset\t4"] @

2
src/version.ml
View file

@ -1 +1 @@
let version = "Version 1.00, e2e6d4799, Sun Sep 6 21:39:58 2020 +0300" let version = "Version 1.00, 2dbd6808a, Tue Sep 8 01:50:16 2020 +0300"