open GT open Language (* The type for patters *) @type patt = StrCmp | String | Array | Sexp | Boxed | UnBoxed | Closure with show (* The type for the stack machine instructions *) @type insn = (* binary operator *) | BINOP of string (* put a constant on the stack *) | CONST of int (* put a string on the stack *) | STRING of string (* create an S-expression *) | SEXP of string * int (* load a variable to the stack *) | LD of Value.designation (* load a variable address to the stack *) | LDA of Value.designation (* store a value into a variable *) | ST of Value.designation (* store a value into a reference *) | STI (* store a value into array/sexp/string *) | STA (* a label *) | LABEL of string (* unconditional jump *) | JMP of string (* conditional jump *) | CJMP of string * string (* begins procedure definition *) | BEGIN of string * int * int * Value.designation list (* end procedure definition *) | END (* create a closure *) | CLOSURE of string * Value.designation list (* proto closure *) | PROTO of string * string (* 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 (* duplicates the top element *) | DUP (* swaps two top elements *) | SWAP (* checks the tag and arity of S-expression *) | TAG of string * int (* checks the tag and size of array *) | ARRAY of int (* checks various patterns *) | PATT of patt (* match failure (location, leave a value *) | FAIL of Loc.t * bool (* external definition *) | EXTERN of string (* public definition *) | PUBLIC of string with show (* The type for the stack machine program *) @type prg = insn list with show let show_prg p = let b = Buffer.create 512 in List.iter (fun i -> Buffer.add_string b (show(insn) i); Buffer.add_string b "\n") p; Buffer.contents b;; (* Values *) @type value = (string, value array) Value.t with show (* Local state of the SM *) @type local = { args : value array; locals : value array; closure : value array } with show (* Global state of the SM *) @type global = (string, value) arrow (* Control stack *) @type control = (prg * local) list with show (* Data stack *) @type stack = value list with show (* The type for the stack machine configuration: control stack, stack, global and local states, input and output streams *) type config = control * stack * global * local * int list * int list (* Stack machine interpreter val eval : env -> config -> prg -> config Takes an environment, a configuration and a program, and returns a configuration as a result. The environment is used to locate a label to jump to (via method env#labeled ) *) let split n l = let rec unzip (taken, rest) = function | 0 -> (List.rev taken, rest) | n -> let h::tl = rest in unzip (h::taken, tl) (n-1) in unzip ([], l) n let update glob loc z = function | Value.Global x -> State.bind x z glob | Value.Local i -> loc.locals.(i) <- z; glob | Value.Arg i -> loc.args.(i) <- z; glob | Value.Access i -> loc.closure.(i) <- z; glob let print_stack memo s = Printf.eprintf "Memo %!"; List.iter (fun v -> Printf.eprintf "%s " @@ show(value) v) s; Printf.eprintf "\n%!" let show_insn = show insn let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = function | [] -> conf | insn :: prg' -> (* Printf.eprintf "eval\n"; Printf.eprintf " insn=%s\n" (show_insn insn); Printf.eprintf " stack=%s\n" (show(list) (show(value)) stack); Printf.eprintf "end\n"; *) (match insn with | PUBLIC _ | EXTERN _ -> eval env conf prg' | BINOP op -> let y::x::stack' = stack in eval env (cstack, (Value.of_int @@ Expr.to_func op (Value.to_int x) (Value.to_int y)) :: stack', glob, loc, i, o) prg' | CONST n -> eval env (cstack, (Value.of_int n)::stack, glob, loc, i, o) prg' | STRING s -> eval env (cstack, (Value.of_string @@ Bytes.of_string s)::stack, glob, loc, i, o) prg' | SEXP (s, n) -> let vs, stack' = split n stack in eval env (cstack, (Value.sexp s @@ List.rev vs)::stack', glob, loc, i, o) prg' | LD x -> eval env (cstack, (match x with | Value.Global x -> glob x | Value.Local i -> loc.locals.(i) | Value.Arg i -> loc.args.(i) | Value.Access i -> loc.closure.(i)) :: stack, glob, loc, i, o) prg' | LDA x -> eval env (cstack, (Value.Var x) :: stack, glob, loc, i, o) prg' | ST x -> let z::stack' = stack in eval env (cstack, z::stack', update glob loc z x, loc, i, o) prg' | STI -> let z::(Value.Var r)::stack' = stack in eval env (cstack, z::stack', update glob loc z r, loc, i, o) prg' | STA -> let v::j::x::stack' = stack in Value.update_elem x (Value.to_int j) v; eval env (cstack, v::stack', glob, loc, i, o) prg' | 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') | CLOSURE (name, dgs) -> let closure = Array.of_list @@ List.map ( function | Value.Arg i -> loc.args.(i) | Value.Local i -> loc.locals.(i) | Value.Access i -> loc.closure.(i) | _ -> invalid_arg "wrong value in CLOSURE") dgs in eval env (cstack, (Value.Closure ([], name, closure)) :: stack, glob, loc, i, o) prg' | CALL (f, n) -> let args, stack' = split n stack in if env#is_label f then eval env ((prg', loc)::cstack, stack', glob, {args = Array.of_list (List.rev args); locals = [||]; closure = [||]}, i, o) (env#labeled f) else eval env (env#builtin f args ((cstack, stack', glob, loc, i, o) : config)) prg' | CALLC n -> let vs, stack' = split (n+1) stack in let f::args = List.rev vs in (match f with | Value.Builtin f -> eval env (env#builtin f (List.rev args) ((cstack, stack', glob, loc, i, o) : config)) prg' | Value.Closure (_, f, closure) -> eval env ((prg', loc)::cstack, stack', glob, {args = Array.of_list args; locals = [||]; closure = closure}, i, o) (env#labeled 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' | END -> (match cstack with | (prg', loc')::cstack' -> eval env (cstack', (*Value.Empty ::*) stack, glob, loc', i, o) prg' | [] -> conf ) | RET -> (match cstack with | (prg', loc')::cstack' -> eval env (cstack', stack, glob, loc', i, o) prg' | [] -> conf ) | DROP -> eval env (cstack, List.tl stack, glob, loc, i, o) prg' | DUP -> eval env (cstack, List.hd stack :: stack, glob, loc, i, o) prg' | SWAP -> let x::y::stack' = stack in eval env (cstack, y::x::stack', glob, loc, i, o) prg' | TAG (t, n) -> let x::stack' = stack in eval env (cstack, (Value.of_int @@ match x with Value.Sexp (t', a) when t' = t && Array.length a = n -> 1 | _ -> 0) :: stack', glob, loc, i, o) prg' | ARRAY n -> let x::stack' = stack in eval env (cstack, (Value.of_int @@ match x with Value.Array a when Array.length a = n -> 1 | _ -> 0) :: stack', glob, loc, i, o) prg' | PATT StrCmp -> let x::y::stack' = stack in eval env (cstack, (Value.of_int @@ match x, y with (Value.String xs, Value.String ys) when xs = ys -> 1 | _ -> 0) :: stack', glob, loc, i, o) prg' | PATT Array -> let x::stack' = stack in eval env (cstack, (Value.of_int @@ match x with Value.Array _ -> 1 | _ -> 0) :: stack', glob, loc, i, o) prg' | PATT String -> let x::stack' = stack in eval env (cstack, (Value.of_int @@ match x with Value.String _ -> 1 | _ -> 0) :: stack', glob, loc, i, o) prg' | PATT Sexp -> let x::stack' = stack in eval env (cstack, (Value.of_int @@ match x with Value.Sexp _ -> 1 | _ -> 0) :: stack', glob, loc, i, o) prg' | PATT Boxed -> let x::stack' = stack in eval env (cstack, (Value.of_int @@ match x with Value.Int _ -> 0 | _ -> 1) :: stack', glob, loc, i, o) prg' | PATT UnBoxed -> let x::stack' = stack in eval env (cstack, (Value.of_int @@ match x with Value.Int _ -> 1 | _ -> 0) :: stack', glob, loc, i, o) prg' | PATT Closure -> let x::stack' = stack in eval env (cstack, (Value.of_int @@ match x with Value.Closure _ -> 1 | _ -> 0) :: stack', glob, loc, i, o) prg' | FAIL (l, _) -> let x::_ = stack in raise (Failure (Printf.sprintf "matching value %s failure at %s" (show(value) x) (show(Loc.t) l))) ) (* Top-level evaluation val run : prg -> int list -> int list 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 glob = State.undefined in let (_, _, _, _, i, o) = eval object 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 (cstack, (match r with [r] -> (Obj.magic r)::stack | _ -> Value.Empty :: stack), glob, loc, i, o) end ([], [], (List.fold_left (fun s (name, value) -> State.bind name value s) glob (Builtin.bindings ())), {locals=[||]; args=[||]; closure=[||]}, i, []) p in o (* Stack machine compiler val compile : Language.t -> prg Takes a program in the source language and returns an equivalent program for the stack machine *) let label s = "L" ^ s let scope_label i s = label s ^ "_" ^ string_of_int i let check_name_and_add names name mut = if List.exists (fun (n, _) -> n = name) names then report_error ~loc:(Loc.get name) (Printf.sprintf "name \"%s\" is already defined in the scope" (Subst.subst name)) else (name, mut) :: names ;; @type funscope = { st : Value.designation State.t; arg_index : int; local_index : int; acc_index : int; nlocals : int; closure : Value.designation list } with show @type fundef = { name : string; args : string list; body : Expr.t; scope : funscope; } with show @type context = | Top of fundef list | Item of fundef * fundef list * context with show let init_scope st = { st = st; arg_index = 0; acc_index = 0; local_index = 0; nlocals = 0; closure = [] } let to_fundef name args body st = { name = name; args = args; body = body; scope = init_scope st; } let from_fundef fd = (fd.name, fd.args, fd.body, fd.scope.st) let open_scope c fd = match c with | Top _ -> Item (fd, [], c) | Item (p, fds, up) -> Item (fd, [], Item ({p with scope = fd.scope}, fds, up)) let close_scope (Item (f, [], c)) = c let add_fun c fd = match c with | Top fds -> Top (fd :: fds) | Item (parent, fds, up) -> Item (parent, fd :: fds, up) let rec pick = function | Item (parent, fd :: fds, up) -> Item (parent, fds, up), Some fd | Top (fd :: fds) -> Top fds, Some fd | c -> c, None let top = function Item (p, _, _) -> Some p | _ -> None let rec propagate_acc (Item (p, fds, up) as item) name = match State.eval p.scope.st name with | Value.Access n when n = ~-1 -> let index = p.scope.acc_index in let up', loc = propagate_acc up name in Item ({p with scope = {p.scope with st = State.update name (Value.Access index) p.scope.st; acc_index = p.scope.acc_index + 1; closure = loc :: p.scope.closure }}, fds, up'), Value.Access index | other -> item, other module FC = Map.Make (struct type t = string * string let compare = Pervasives.compare end) class funinfo = object (self : 'self) val funtree = (Pervasives.ref M.empty : string M.t ref) val closures = (Pervasives.ref M.empty : Value.designation list M.t ref) val functx = (Pervasives.ref FC.empty : Value.designation list FC.t ref) method show_funinfo = Printf.sprintf "funtree: %s\nclosures: %s\ncontexts: %s\n" (show(list) (fun (x, y) -> x ^ ": " ^ y) @@ M.bindings !funtree) (show(list) (fun (x, y) -> x ^ ": " ^ show(list) (show(Value.designation)) y) @@ M.bindings !closures) (show(list) (fun ((x, y), v) -> "(" ^ x ^ ", " ^ y ^ ")" ^ show(list) (show(Value.designation)) v) @@ FC.bindings !functx) method lookup_closure p = FC.find p !functx method register_call f c = functx := FC.add (f, c) [] !functx; self method register_fun f p = funtree := M.add f p !funtree; self method register_closure f c = closures := M.add f c !closures; self method private get_parent f = M.find f !funtree method get_closure f = M.find f !closures method private propagate_for_call (f, c) = try let fp = self#get_parent f in let rec find_path current = if fp = current then [] else find_path (self#get_parent current) @ [current] in let path = find_path c in let changed = Pervasives.ref false in let rec propagate_downwards current_closure = function | [] -> current_closure | f :: tl -> let fclosure = self#get_closure f in let delta = Pervasives.ref fclosure in let index = Pervasives.ref (List.length fclosure) in let added = Pervasives.ref false in let add_to_closure loc = added := true; delta := !delta @ [loc]; let loc' = Value.Access !index in incr index; loc' in let next_closure = List.map (fun loc -> let rec find_index i = function | [] -> raise Not_found | loc' :: tl -> if loc' = loc then Value.Access i else find_index (i+1) tl in try find_index 0 fclosure with Not_found -> add_to_closure loc ) current_closure in if !added then ( changed := true; closures := M.add f !delta !closures ); propagate_downwards next_closure tl in let closure = propagate_downwards (self#get_closure f) path in functx := FC.add (f, c) closure !functx; !changed with Not_found -> false method propagate_closures = while List.fold_left (fun flag (call, _) -> flag || self#propagate_for_call call) false @@ FC.bindings !functx do () done; self end class env cmd imports = object (self : 'self) val label_index = 0 val scope_index = 0 val lam_index = 0 val scope = init_scope State.I val fundefs = Top [] val decls = [] val funinfo = new funinfo method show_funinfo = funinfo#show_funinfo method get_closure p = try funinfo#lookup_closure p with Not_found -> [] method get_fun_closure f = funinfo#get_closure f method propagate_closures = {< funinfo = funinfo#propagate_closures >} method register_call f = {< funinfo = funinfo#register_call f self#current_function >} method register_fun f = {< funinfo = funinfo#register_fun f self#current_function >} method register_closure f = {< funinfo = funinfo#register_closure f self#closure >} method current_function = match fundefs with Top _ -> "main" | Item (fd, _, _) -> fd.name method private import_imports = let paths = cmd#get_include_paths in let env = List.fold_left (fun env import -> let _, intfs = Interface.find import paths in List.fold_left (fun env -> function | `Variable name -> env#add_name name `Extern true | `Fun name -> env#add_fun_name name `Extern | _ -> env ) env intfs ) self imports in env method global_scope = scope_index = 0 method get_label = (label @@ string_of_int label_index), {< label_index = label_index + 1 >} method nargs = scope.arg_index method nlocals = scope.nlocals method get_decls = let opt_label = function true -> label | _ -> fun x -> "global_" ^ x in List.flatten @@ List.map (function | (name, `Extern, f) -> [EXTERN (opt_label f name)] | (name, `Public, f) -> [PUBLIC (opt_label f name)] | (name, `PublicExtern, f) -> [PUBLIC (opt_label f name); EXTERN (opt_label f name)] | _ -> invalid_arg "must not happen" ) @@ List.filter (function (_, `Local, _) -> false | _ -> true) decls method push_scope = match scope.st with | State.I -> {< scope_index = scope_index + 1; scope = { scope with st = State.G ([], State.undefined) } >} # import_imports | _ -> {< scope_index = scope_index + 1; scope = { scope with st = State.L ([], State.undefined, scope.st) } >} method pop_scope = match scope.st with | State.I -> {< scope = {scope with st = State.I} >} | State.G _ -> {< scope = {scope with st = State.I} >} | State.L (xs, _, x) -> {< scope = { scope with st = x; local_index = scope.local_index - List.length xs } >} method open_fun_scope (name, args, body, st') = {< fundefs = open_scope fundefs { name = name; args = args; body = body; scope = {scope with st = st'}; }; scope = init_scope ( let rec readdress_to_closure = function | State.L (xs, st, tl) -> State.L (xs, (fun name -> match st name with Value.Fun _ as x -> x | _ -> Value.Access (~-1)), readdress_to_closure tl) | st -> st in readdress_to_closure st' ); >} # push_scope method close_fun_scope = let fundefs' = close_scope fundefs in match top fundefs' with | Some fd -> {< fundefs = fundefs'; scope = fd.scope >} # pop_scope | None -> {< fundefs = fundefs' >} # pop_scope method add_arg (name : string) = {< scope = { scope with st = (match scope.st with | State.I | State.G _ -> invalid_arg "wrong scope in add_arg" | State.L (names, s, p) -> State.L (check_name_and_add names name true, State.bind name (Value.Arg scope.arg_index) s, p) ); arg_index = scope.arg_index + 1 } >} method check_scope m name = match m with | `Local -> () | _ -> report_error (Printf.sprintf "external/public definitions (\"%s\") not allowed in local scopes" (Subst.subst name)) method add_name (name : string) (m : [`Local | `Extern | `Public | `PublicExtern]) (mut : bool) = {< decls = (name, m, false) :: decls; scope = { scope with st = (match scope.st with | State.I -> invalid_arg "uninitialized scope" | State.G (names, s) -> State.G ((match m with `Extern | `PublicExtern -> names | _ -> check_name_and_add names name mut), State.bind name (Value.Global name) s) | State.L (names, s, p) -> self#check_scope m name; 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) } >} method fun_internal_name (name : string) = (match scope.st with State.G _ -> label | _ -> scope_label scope_index) name method add_fun_name (name : string) (m : [`Local | `Extern | `Public | `PublicExtern]) = let name' = self#fun_internal_name name in let st' = match scope.st with | State.I -> invalid_arg "uninitialized scope" | State.G (names, s) -> State.G ((match m with `Extern | `PublicExtern -> names | _ -> check_name_and_add names name false), State.bind name (Value.Fun name') s) | State.L (names, s, p) -> self#check_scope m name; State.L (check_name_and_add names name false, State.bind name (Value.Fun name') s, p) in {< decls = (name, m, true) :: decls; scope = {scope with st = st'} >} method add_lambda (args : string list) (body : Expr.t) = let name' = self#fun_internal_name (Printf.sprintf "lambda_%d" lam_index) in {< fundefs = add_fun fundefs (to_fundef name' args body scope.st); lam_index = lam_index + 1 >} # register_fun name', name' method add_fun (name : string) (args : string list) (m : [`Local | `Extern | `Public | `PublicExtern]) (body : Expr.t) = let name' = self#fun_internal_name name in match m with | `Extern -> self | _ -> {< fundefs = add_fun fundefs (to_fundef name' args body scope.st) >} # register_fun name' method lookup name = match State.eval scope.st name with | Value.Access n when n = ~-1 -> let index = scope.acc_index in let fundefs', loc = propagate_acc fundefs name in {< fundefs = fundefs'; scope = { scope with st = State.update name (Value.Access index) scope.st; acc_index = scope.acc_index + 1; closure = loc :: scope.closure } >}, Value.Access index | other -> self, other method next_definition = match pick fundefs with | fds, None -> None | fds, Some fd -> Some ({< fundefs = fds >}, from_fundef fd) method closure = List.rev scope.closure end let compile cmd ((imports, infixes), p) = let rec pattern env lfalse = function | Pattern.Wildcard -> env, false, [DROP] | Pattern.Named (_, p) -> pattern env lfalse p | Pattern.Const c -> env, true, [CONST c; BINOP "=="; CJMP ("z", lfalse)] | Pattern.String s -> env, true, [STRING s; PATT StrCmp; CJMP ("z", lfalse)] | Pattern.ArrayTag -> env, true, [PATT Array; CJMP ("z", lfalse)] | Pattern.StringTag -> env, true, [PATT String; CJMP ("z", lfalse)] | Pattern.SexpTag -> env, true, [PATT Sexp; CJMP ("z", lfalse)] | Pattern.UnBoxed -> env, true, [PATT UnBoxed; CJMP ("z", lfalse)] | Pattern.Boxed -> env, true, [PATT Boxed; CJMP ("z", lfalse)] | Pattern.ClosureTag -> env, true, [PATT Closure; CJMP ("z", lfalse)] | Pattern.Array ps -> let lhead, env = env#get_label in let ldrop, env = env#get_label in let tag = [DUP; ARRAY (List.length ps); CJMP ("nz", lhead); LABEL ldrop; DROP; JMP lfalse; LABEL lhead] in let code, env = pattern_list lhead ldrop env ps in env, true, tag @ code @ [DROP] | Pattern.Sexp (t, ps) -> let lhead, env = env#get_label in let ldrop, env = env#get_label in let tag = [DUP; TAG (t, List.length ps); CJMP ("nz", lhead); LABEL ldrop; DROP; JMP lfalse; LABEL lhead] in let code, env = pattern_list lhead ldrop env ps in env, true, tag @ code @ [DROP] and pattern_list lhead ldrop env ps = let _, env, code = List.fold_left (fun (i, env, code) p -> let env, _, pcode = pattern env ldrop p in i+1, env, ([DUP; CONST i; CALL (".elem", 2)] @ pcode) :: code ) (0, env, []) ps in List.flatten (List.rev code), env and bindings env p = let bindings = transform(Pattern.t) (fun fself -> object inherit [int list, _, (string * int list) list] @Pattern.t method c_Wildcard path _ = [] method c_Named path _ s p = [s, path] @ fself path p method c_Sexp path _ x ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps method c_UnBoxed _ _ = [] method c_StringTag _ _ = [] method c_String _ _ _ = [] method c_SexpTag _ _ = [] method c_Const _ _ _ = [] method c_Boxed _ _ = [] method c_ArrayTag _ _ = [] method c_ClosureTag _ _ = [] method c_Array path _ ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps end) [] p in let env, code = List.fold_left (fun (env, acc) (name, path) -> let env = env#add_name name `Local true in let env, dsg = env#lookup name in env, ([DUP] @ List.concat (List.map (fun i -> [CONST i; CALL (".elem", 2)]) path) @ [ST dsg; DROP]) :: acc ) (env, []) (List.rev bindings) in env, (List.flatten code) @ [DROP] and add_code (env, flag, s) l f s' = env, f, s @ (if flag then [LABEL l] else []) @ s' and compile_list l env = function | [] -> env, false, [] | [e] -> compile_expr l env e | e::es -> let les, env = env#get_label in let env, flag1, s1 = compile_expr les env e in let env, flag2, s2 = compile_list l env es in add_code (env, flag1, s1) les flag2 s2 and compile_expr l env = function | Expr.Lambda (args, b) -> let env, name = env#add_lambda args b in env#register_call name, false, [PROTO (name, env#current_function)] | Expr.Scope (ds, e) -> let env = env#push_scope in let env, e, funs = List.fold_left (fun (env, e, funs) -> function | name, (m, `Fun (args, b)) -> env#add_fun_name name m, e, (name, args, m, b) :: funs | name, (m, `Variable None) -> env#add_name name m true, e, funs | name, (m, `Variable (Some v)) -> env#add_name name m true, Expr.Seq (Expr.Ignore (Expr.Assign (Expr.Ref name, v)), e), funs ) (env, e, []) (List.rev ds) 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 l env e in env#pop_scope, flag, code | Expr.Unit -> env, false, [CONST 0] | Expr.Ignore s -> let ls, env = env#get_label in add_code (compile_expr ls env s) ls false [DROP] | Expr.ElemRef (x, i) -> compile_list l env [x; i] | Expr.Var x -> let env, acc = env#lookup x in (match acc with Value.Fun name -> env#register_call name, false, [PROTO (name, env#current_function)] | _ -> env, false, [LD acc]) | Expr.Ref x -> let env, acc = env#lookup x in env, false, [LDA acc] | Expr.Const n -> env, false, [CONST n] | Expr.String s -> env, false, [STRING s] | Expr.Binop (op, x, y) -> let lop, env = env#get_label in add_code (compile_list lop env [x; y]) lop false [BINOP op] | Expr.Call (f, args) -> let lcall, env = env#get_label in (match f with | Expr.Var name -> let env, acc = env#lookup name in (match acc with | Value.Fun name -> 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)] ) | Expr.Array xs -> let lar, env = env#get_label in add_code (compile_list lar env xs) lar false [CALL (".array", List.length xs)] | Expr.Sexp (t, xs) -> let lsexp, env = env#get_label in add_code (compile_list lsexp env xs) lsexp false [SEXP (t, List.length xs)] | Expr.Elem (a, i) -> let lelem, env = env#get_label in add_code (compile_list lelem env [a; i]) lelem false [CALL (".elem", 2)] | Expr.Length e -> let llen, env = env#get_label in add_code (compile_expr llen env e) llen false [CALL (".length", 1)] | Expr.StringVal e -> let lsv, env = env#get_label in add_code (compile_expr lsv env e) lsv false [CALL (".stringval", 1)] | Expr.Assign (x, e) -> let lassn, env = env#get_label in add_code (compile_list lassn env [x; e]) lassn false [match x with Expr.ElemRef _ -> STA | _ -> STI] | Expr.Skip -> env, false, [] | Expr.Seq (s1, s2) -> compile_list l env [s1; s2] | Expr.If (c, s1, s2) -> let le, env = env#get_label in let l2, env = env#get_label in let env, fe , se = compile_expr le env c in let env, flag1, s1 = compile_expr l env s1 in let env, flag2, s2 = compile_expr l env s2 in env, true, se @ (if fe then [LABEL le] else []) @ [CJMP ("z", l2)] @ s1 @ (if flag1 then [] else [JMP l]) @ [LABEL l2] @ s2 @ (if flag2 then [] else [JMP l]) | Expr.While (c, s) -> let lexp, env = env#get_label in let loop, env = env#get_label in let cond, env = env#get_label in let env, fe, se = compile_expr lexp env c in let env, _ , s = compile_expr cond env s in env, false, [JMP cond; LABEL loop] @ s @ [LABEL cond] @ se @ (if fe then [LABEL lexp] else []) @ [CJMP ("nz", loop)] | Expr.Repeat (s, c) -> let lexp , env = env#get_label in let loop , env = env#get_label in let check, env = env#get_label in let env, fe , se = compile_expr lexp env c in let env, flag, body = compile_expr check env s in env, false, [LABEL loop] @ body @ (if flag then [LABEL check] else []) @ se @ (if fe then [LABEL lexp] else []) @ [CJMP ("z", loop)] | Expr.Return (Some e) -> let lret, env = env#get_label in add_code (compile_expr lret env e) lret false [RET] | Expr.Return None -> env, false, [CONST 0; RET] | Expr.Leave -> env, false, [] | Expr.Case (e, brs, loc, atr) -> let n = List.length brs - 1 in let lfail, env = env#get_label in let lexp , env = env#get_label in let env , fe , se = compile_expr lexp env e in let env , _, _, code, fail = List.fold_left (fun ((env, lab, i, code, continue) as acc) (p, s) -> if continue then let (lfalse, env), jmp = if i = n then (lfail, env), [] else env#get_label, [JMP l] in let env, lfalse', pcode = pattern env lfalse p in let env = env#push_scope in let env, bindcode = bindings env p in let env, l' , scode = compile_expr 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') else acc ) (env, None, 0, [], true) brs in env, true, se @ (if fe then [LABEL lexp] else []) @ [DUP] @ (List.flatten @@ List.rev code) @ [JMP l] @ if fail then [LABEL lfail; FAIL (loc, atr != Expr.Void); JMP l] else [] in 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 (*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);*) let env = env#register_closure name in let code = ([LABEL name; BEGIN (name, env#nargs, env#nlocals, env#closure)] @ code @ (if flag then [LABEL lend] else []) @ [END]) :: funcode in env#close_fun_scope, code and compile_fundefs acc env = match env#next_definition with | None -> env, acc | Some (env, def) -> let env, code = compile_fundef env def in compile_fundefs (acc @ code) env in let fix_closures env prg = let rec inner state = function | [] -> [] | BEGIN (f, a, l, c) :: tl -> BEGIN (f, a, l, try env#get_fun_closure f with Not_found -> c) :: 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 | [] -> 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 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, 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; *) 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