From a2f316164e9983262bd1ddd261ab2ef186162f93 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Thu, 10 Sep 2020 09:07:38 +0300 Subject: [PATCH] gdb support; no closures yet. --- src/SM.ml | 76 +++++++++++++++++++++++++++++++++++--------------- src/X86.ml | 48 ++++++++++++++++++++++--------- src/version.ml | 2 +- 3 files changed, 89 insertions(+), 37 deletions(-) diff --git a/src/SM.ml b/src/SM.ml index 482937a82..bc6f8a053 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -4,6 +4,16 @@ open Language (* The type for patters *) @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 *) @type insn = (* binary operator *) | BINOP of string @@ -16,9 +26,10 @@ open Language (* store a value into a reference *) | STI (* store a value into array/sexp/string *) | STA (* a label *) | LABEL of string +(* a scope label *) | SLABEL of string (* unconditional jump *) | JMP of 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 (* create a closure *) | CLOSURE of string * Value.designation list (* 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; 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) | 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') @@ -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 ) - | 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 | (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; acc_index : int; nlocals : int; - closure : Value.designation list + closure : Value.designation list; + scopes : scope list; } with show @type fundef = { @@ -290,7 +302,8 @@ let init_scope st = { acc_index = 0; local_index = 0; nlocals = 0; - closure = [] + closure = []; + scopes = []; } let to_fundef name args body st = { @@ -485,7 +498,7 @@ object (self : 'self) ) @@ List.filter (function (_, `Local, _) -> false | _ -> true) decls - method push_scope = + method push_scope (blab : string) (elab : string) = match scope.st with | State.I -> {< @@ -500,7 +513,8 @@ object (self : 'self) {< scope_index = scope_index + 1; scope = { 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 with 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 { name = name; @@ -533,13 +550,15 @@ object (self : 'self) in readdress_to_closure st' ); - >} # push_scope + >} # push_scope blab elab 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 match top fundefs' with - | Some fd -> {< fundefs = fundefs'; scope = fd.scope >} # pop_scope - | None -> {< fundefs = fundefs' >} # pop_scope + | Some fd -> {< fundefs = fundefs'; scope = fd.scope >} # pop_scope, scopes + | None -> {< fundefs = fundefs' >} # pop_scope, scopes method add_arg (name : string) = {< 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) ); 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)] | 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 = List.fold_left (fun (env, e, funs) -> @@ -744,7 +768,7 @@ let compile cmd ((imports, infixes), p) = 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 - env#pop_scope, flag, code + env#pop_scope, flag, [SLABEL blab] @ code @ [SLABEL elab] | Expr.Unit -> env, false, [CONST 0] @@ -845,11 +869,13 @@ let compile cmd ((imports, infixes), p) = else env#get_label, [JMP l] 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, l' , scode = compile_expr tail l env s 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 ) (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) = (* 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"); *) - 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..."); *) let env = List.fold_left (fun env arg -> env#add_arg arg) env args 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 (*Printf.eprintf "Function: %s, closure: %s\n%!" name (show(list) (show(Value.designation)) env#closure);*) 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 = - ([LABEL name; BEGIN (name, args, env#nargs, env#nlocals, env#closure)] @ + ([LABEL name; BEGIN (name, nargs, nlocals, closure, args, scopes); SLABEL blab] @ code @ (if flag then [LABEL lend] else []) @ - [END]) :: funcode + [SLABEL elab; END]) :: funcode in - env#close_fun_scope, code + env, code and compile_fundefs acc env = match env#next_definition with | None -> env, acc @@ -884,7 +914,7 @@ let compile cmd ((imports, infixes), p) = let fix_closures env prg = 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 | PPROTO (f, c) :: tl -> (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 code = if flag then code @ [LABEL lend] else code 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 (*Printf.eprintf "Before propagating closures:\n"; Printf.eprintf "%s\n%!" env#show_funinfo; diff --git a/src/X86.ml b/src/X86.ml index 4ead5e8f1..da0c11fb3 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -62,7 +62,23 @@ type instr = (* arithmetic correction: shr 1 *) | Sar1 of opnd | Repmovsl (* Instruction printer *) +let stack_offset i = + if i >= 0 + then (i+1) * word_size + else 8 + (-i-1) * word_size + 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 | "+" -> "addl" | "-" -> "subl" @@ -74,17 +90,6 @@ let show instr = | "test" -> "test" | _ -> failwith "unknown binary operator" 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 | Cltd -> "\tcltd" | 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] else [Binop (op, x, y); Or1 y] ) + | 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] | CJMP (s, l) -> let x, env = env#pop in 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 = if f.[0] = 'L' then String.sub f 1 (String.length f - 1) else f in @@ -403,7 +424,8 @@ let compile cmd env imports code = then [] else [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"] @ diff --git a/src/version.ml b/src/version.ml index 3e305c0e5..807c52e76 100644 --- a/src/version.ml +++ b/src/version.ml @@ -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"