From 49250b02167eff8b98cade7185c8f1d8b3fa267b Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Sun, 29 Dec 2019 02:12:50 +0300 Subject: [PATCH] Fixed an ugly bug in FCF support. Now for real? --- regression/Makefile | 2 +- src/SM.ml | 43 +++++++++++++++++------ src/X86.ml | 83 +++++++++++++-------------------------------- 3 files changed, 57 insertions(+), 71 deletions(-) diff --git a/regression/Makefile b/regression/Makefile index 7afe4d838..5a3a18223 100644 --- a/regression/Makefile +++ b/regression/Makefile @@ -8,9 +8,9 @@ check: $(TESTS) $(TESTS): %: %.expr @echo $@ - $(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log cat $@.input | $(RC) -i $< > $@.log && diff $@.log orig/$@.log cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log + $(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log clean: $(RM) test*.log *.s *~ $(TESTS) diff --git a/src/SM.ml b/src/SM.ml index fae5df5d0..2f82258ed 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -22,7 +22,9 @@ open Language (* end procedure definition *) | END (* create a closure *) | CLOSURE of string * Value.designation list (* proto closure *) | PROTO of string * string -(* calls a closure *) | CALLC of int +(* proto closure to a possible constant *) | PPROTO of string * string +(* proto call *) | PCALLC of int +(* calls a closure *) | CALLC of int (* calls a function/procedure *) | CALL of string * int (* returns from a function *) | RET (* drops the top element off *) | DROP @@ -737,14 +739,16 @@ let compile cmd ((imports, infixes), p) = | Expr.Call (f, args) -> let lcall, env = env#get_label in (match f with - (*| Expr.Var name -> + | Expr.Var name -> let env, acc = env#lookup name in (match acc with | Value.Fun name -> - add_code (compile_list lcall env args) lcall false [CALL (name, List.length args)] + let env = env#register_call name in + let env, f, code = add_code (compile_list lcall env args) lcall false [PCALLC (List.length args)] in + env, f, PPROTO (name, env#current_function) :: code | _ -> add_code (compile_list lcall env (f :: args)) lcall false [CALLC (List.length args)] - )*) + ) | _ -> add_code (compile_list lcall env (f :: args)) lcall false [CALLC (List.length args)] ) @@ -829,15 +833,13 @@ 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 env = env#open_fun_scope 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 let env, flag, code = compile_expr lend env stmt 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 code = ([LABEL name; BEGIN (name, env#nargs, env#nlocals, env#closure)] @ @@ -853,7 +855,24 @@ let compile cmd ((imports, infixes), p) = let env, code = compile_fundef env def in compile_fundefs (acc @ code) env in - let rec fix_closures env prg = List.map (function PROTO (f, c) -> CLOSURE (f, env#get_closure (f, c)) | insn -> insn) prg in + let fix_closures env prg = + let rec inner state = function + | [] -> [] + | 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 + | [] -> inner (Some f :: state) tl + | closure -> CLOSURE (f, closure) :: inner (None :: state) tl + ) + | PCALLC n :: tl -> + (match state with + | None :: state' -> CALLC n :: inner state' tl + | Some f :: state' -> CALL (f, n) :: inner state' tl + ) + | insn :: tl -> insn :: inner state tl + in + inner [] prg + in let env = new env cmd imports in let lend, env = env#get_label in let env, flag, code = compile_expr lend env p in @@ -861,11 +880,15 @@ let compile cmd ((imports, infixes), p) = let has_main = List.length code > 0 in let env, prg = compile_fundefs [if has_main then [LABEL "main"; BEGIN ("main", 0, env#nlocals, [])] @ code @ [END] else []] env in let prg = (if has_main then [PUBLIC "main"] else []) @ 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; + *) let env = env#propagate_closures in + (* Printf.eprintf "After propagating closures:\n"; Printf.eprintf "%s\n%!" env#show_funinfo; + *) + (*Printf.eprintf "Before fix:\n%s\n" (show_prg prg); *) let prg = fix_closures env prg in cmd#dump_SM prg; prg diff --git a/src/X86.ml b/src/X86.ml index 5afb61378..4f94ec777 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -155,67 +155,30 @@ let compile cmd env code = let y, env = env#allocate in env, code @ [Mov (eax, y)] in let call env f n = - let closure = - (*try - let BEGIN (_, _, _, closure) :: _ = env#labeled f in closure - with Not_found ->*) [] (* !!! *) + let f = + match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f in - match closure with - | [] -> - let f = - match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f - in - 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 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 = - match f with - | "Barray" -> List.rev @@ (Push (L n)) :: pushs - | "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) + 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 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 = + match f with + | "Barray" -> List.rev @@ (Push (L n)) :: pushs + | "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)] in match scode with | [] -> env, []