open GT open Language (* The type for patters *) type patt = StrCmp | String | Array | Sexp | Boxed | UnBoxed | Closure [@@deriving gt ~options:{ show; enum }] (* The type for local scopes tree *) type scope = { blab : string; elab : string; names : (string * int) list; subs : scope list; } [@@deriving gt ~options:{ show }] let show_scope = show scope (* 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 (* takes an element of array/string/sexp *) | ELEM (* a label *) | LABEL of string (* a forwarded label *) | FLABEL 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 * 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 (* proto closure to a possible constant *) | PPROTO of string * string (* proto call *) | PCALLC of int * bool (* calls a closure *) | CALLC of int * bool (* calls a function/procedure *) | CALL of string * int * bool (* 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 (* import clause *) | IMPORT of string (* line info *) | LINE of int [@@deriving gt ~options:{ show }] (* The type for the stack machine program *) type prg = insn list [@@deriving gt ~options:{ show }] module ByteCode = struct module M = Map.Make (String) module S = Set.Make (String) module StringTab = struct type t = { mutable smap : int M.t; buffer : Buffer.t; mutable index : int } let create () = { smap = M.empty; buffer = Buffer.create 255; index = 0 } let add st s = try let i = M.find s st.smap in i with Not_found -> let i = st.index in Buffer.add_string st.buffer s; Buffer.add_char st.buffer (Char.chr 0); st.smap <- M.add s i st.smap; st.index <- st.index + String.length s + 1; i end exception Found of int let opnum = let optab = [ "+"; "-"; "*"; "/"; "%"; "<"; "<="; ">"; ">="; "=="; "!="; "&&"; "!!" ] in fun s -> try ignore @@ List.fold_left (fun i op -> if s = op then raise (Found i) else i + 1) 1 optab; failwith (Printf.sprintf "ERROR: undefined binary operator '%s'" s) with Found i -> i (* Below are the the numbers of occurrencies of SM instructions for the stdlib+lama compiler itself 7328 SLABEL 5351 CALL 5321 DROP 4437 LABEL 4331 LD 4213 DUP 3979 EXTERN 3525 CONST 2503 LINE 2281 JMP 1400 ST 1122 CJMP 922 END 922 BEGIN 790 SEXP 770 CLOSURE 519 TAG 493 STRING 354 FAIL 349 CALLC 339 BINOP 289 ARRAY 270 PUBLIC 87 PATT 39 STA 16 FLABEL *) let compile cmd insns = (* let word_size = 4 in *) let code = Buffer.create 256 in let st = StringTab.create () in let lmap = Stdlib.ref M.empty in let pubs = Stdlib.ref S.empty in let imports = Stdlib.ref S.empty in let globals = Stdlib.ref M.empty in let glob_count = Stdlib.ref 0 in let fixups = Stdlib.ref [] in let add_lab l = lmap := M.add l (Buffer.length code) !lmap in let add_public l = pubs := S.add l !pubs in let add_import l = imports := S.add l !imports in let add_fixup l = fixups := (Buffer.length code, l) :: !fixups in let add_bytes = List.iter (fun x -> Buffer.add_char code @@ Char.chr x) in let add_ints = List.iter (fun x -> Buffer.add_int32_ne code @@ Int32.of_int x) in let add_strings = List.iter (fun x -> Buffer.add_int32_ne code @@ Int32.of_int @@ StringTab.add st x) in let add_designations n = let b x = match n with None -> x | Some b -> (b * 16) + x in List.iter (function | Value.Global s -> let i = try M.find s !globals with Not_found -> let i = !glob_count in incr glob_count; globals := M.add s i !globals; i in add_bytes [ b 0 ]; add_ints [ i ] | Value.Local n -> add_bytes [ b 1 ]; add_ints [ n ] | Value.Arg n -> add_bytes [ b 2 ]; add_ints [ n ] | Value.Access n -> add_bytes [ b 3 ]; add_ints [ n ] | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)) in let insn_code = function (* 0x0s *) | BINOP s -> add_bytes [ opnum s ] (* 0x10 n:32 *) | CONST n -> add_bytes [ (1 * 16) + 0 ]; add_ints [ n ] (* 0x11 s:32 *) | STRING s -> add_bytes [ (1 * 16) + 1 ]; add_strings [ s ] (* 0x12 s:32 n:32 *) | SEXP (s, n) -> add_bytes [ (1 * 16) + 2 ]; add_strings [ s ]; add_ints [ n ] (* 0x13 *) | STI -> add_bytes [ (1 * 16) + 3 ] (* 0x14 *) | STA -> add_bytes [ (1 * 16) + 4 ] | LABEL s | FLABEL s | SLABEL s -> add_lab s (* 0x15 l:32 *) | JMP s -> add_bytes [ (1 * 16) + 5 ]; add_fixup s; add_ints [ 0 ] (* 0x16 *) | END -> add_bytes [ (1 * 16) + 6 ] (* 0x17 *) | RET -> add_bytes [ (1 * 16) + 7 ] (* 0x18 *) | DROP -> add_bytes [ (1 * 16) + 8 ] (* 0x19 *) | DUP -> add_bytes [ (1 * 16) + 9 ] (* 0x1a *) | SWAP -> add_bytes [ (1 * 16) + 10 ] (* 0x1b *) | ELEM -> add_bytes [ (1 * 16) + 11 ] (* 0x2d n:32 *) | LD d -> add_designations (Some 2) [ d ] (* 0x3d n:32 *) | LDA d -> add_designations (Some 3) [ d ] (* 0x4d n:32 *) | ST d -> add_designations (Some 4) [ d ] (* 0x50 l:32 *) | CJMP ("z", s) -> add_bytes [ (5 * 16) + 0 ]; add_fixup s; add_ints [ 0 ] (* 0x51 l:32 *) | CJMP ("nz", s) -> add_bytes [ (5 * 16) + 1 ]; add_fixup s; add_ints [ 0 ] (* 0x70 *) | CALL ("Lread", _, _) -> add_bytes [ (7 * 16) + 0 ] (* 0x71 *) | CALL ("Lwrite", _, _) -> add_bytes [ (7 * 16) + 1 ] (* 0x72 *) | CALL ("Llength", _, _) -> add_bytes [ (7 * 16) + 2 ] (* 0x73 *) | CALL ("Lstring", _, _) -> add_bytes [ (7 * 16) + 3 ] (* 0x74 *) | CALL (".array", n, _) -> add_bytes [ (7 * 16) + 4 ]; add_ints [ n ] (* 0x52 n:32 n:32 *) | BEGIN (_, a, l, [], _, _) -> add_bytes [ (5 * 16) + 2 ]; add_ints [ a; l ] (* with no closure *) (* 0x53 n:32 n:32 *) | BEGIN (_, a, l, _, _, _) -> add_bytes [ (5 * 16) + 3 ]; add_ints [ a; l ] (* with a closure *) (* 0x54 l:32 n:32 d*:32 *) | CLOSURE (s, ds) -> add_bytes [ (5 * 16) + 4 ]; add_fixup s; add_ints [ 0; List.length ds ]; add_designations None ds (* 0x55 n:32 *) | CALLC (n, _) -> add_bytes [ (5 * 16) + 5 ]; add_ints [ n ] (* 0x56 l:32 n:32 *) | CALL (fn, n, _) -> add_bytes [ (5 * 16) + 6 ]; add_fixup fn; add_ints [ 0; n ] (* 0x57 s:32 n:32 *) | TAG (s, n) -> add_bytes [ (5 * 16) + 7 ]; add_strings [ s ]; add_ints [ n ] (* 0x58 n:32 *) | ARRAY n -> add_bytes [ (5 * 16) + 8 ]; add_ints [ n ] (* 0x59 n:32 n:32 *) | FAIL ((l, c), _) -> add_bytes [ (5 * 16) + 9 ]; add_ints [ l; c ] (* 0x5a n:32 *) | LINE n -> add_bytes [ (5 * 16) + 10 ]; add_ints [ n ] (* 0x6p *) | PATT p -> add_bytes [ (6 * 16) + enum patt p ] | EXTERN _ -> () | PUBLIC s -> add_public s | IMPORT s -> add_import s | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__) in List.iter insn_code insns; add_bytes [ 255 ]; let code = Buffer.to_bytes code in List.iter (fun (ofs, l) -> Bytes.set_int32_ne code ofs (Int32.of_int @@ try M.find l !lmap with Not_found -> failwith (Printf.sprintf "ERROR: undefined label '%s'" l))) !fixups; let pubs = List.map (fun l -> ( Int32.of_int @@ StringTab.add st l, Int32.of_int @@ try M.find l !lmap with Not_found -> failwith (Printf.sprintf "ERROR: undefined label '%s'" l) )) @@ S.elements !pubs in let st = Buffer.to_bytes st.StringTab.buffer in let file = Buffer.create 1024 in Buffer.add_int32_ne file (Int32.of_int @@ Bytes.length st); Buffer.add_int32_ne file (Int32.of_int @@ !glob_count); Buffer.add_int32_ne file (Int32.of_int @@ List.length pubs); List.iter (fun (n, o) -> Buffer.add_int32_ne file n; Buffer.add_int32_ne file o) pubs; Buffer.add_bytes file st; Buffer.add_bytes file code; let f = open_out_bin (Printf.sprintf "%s.bc" cmd#basename) in Buffer.output_buffer f file; close_out f end 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 [@@deriving gt ~options:{ show }] (* Local state of the SM *) type local = { args : value array; locals : value array; closure : value array } [@@deriving gt ~options:{ show }] (* Global state of the SM *) type global = (string, value) arrow [@@deriving gt] (* Control stack *) type control = (prg * local) list [@@deriving gt ~options:{ show }] (* Data stack *) type stack = value list [@@deriving gt ~options:{ 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[@ocaml.warning "-8"] (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 | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__) let print_stack _ s = Printf.eprintf "Memo %!"; List.iter (fun v -> Printf.eprintf "%s " @@ show value v) s; Printf.eprintf "\n%!" let show_insn = show insn let[@ocaml.warning "-8-20"] 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 | IMPORT _ | PUBLIC _ | EXTERN _ | LINE _ -> eval env conf prg' | BINOP "==" -> let (y :: x :: stack') = stack in let z = match (x, y) with | Value.Int _, Value.Int _ -> Value.of_int @@ Expr.to_func "==" (Value.to_int x) (Value.to_int y) | Value.Int _, _ | _, Value.Int _ -> Value.of_int 0 | _ -> failwith "unexpected operands in comparison: %s vs. %s\n" (show Value.t (fun _ -> "") (fun _ -> "") x) (show Value.t (fun _ -> "") (fun _ -> "") y) in eval env (cstack, z :: stack', glob, loc, i, o) 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' | ELEM -> let (a :: b :: stack') = stack in eval env (env#builtin ".elem" [ a; b ] (cstack, 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 (z :: j :: stack') = stack in match j with | Value.Var r -> eval env (cstack, z :: stack', update glob loc z r, loc, i, o) prg' | Value.Int _ -> let (x :: stack') = stack' in Value.update_elem x (Value.to_int j) z; eval env (cstack, z :: stack', glob, loc, i, o) prg') | SLABEL _ | LABEL _ | FLABEL _ -> 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 }, 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 | FLABEL 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 _, _, _, _, _, o = eval (object inherit indexer p method builtin f args ((cstack, stack, glob, loc, i, o) : config) = let f = match f.[0] with | 'L' -> String.sub f 1 (String.length f - 1) | _ -> f in let _, 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 ) [@@ocaml.warning "-8"] 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; scopes : scope list; } [@@deriving gt ~options:{ show }] type fundef = { name : string; args : string list; body : Expr.t; scope : funscope; } [@@deriving gt ~options:{ show }] type context = Top of fundef list | Item of fundef * fundef list * context [@@deriving gt ~options:{ show }] let init_scope st = { st; arg_index = 0; acc_index = 0; local_index = 0; nlocals = 0; closure = []; scopes = []; } let to_fundef name args body st = { name; args; 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[@ocaml.warning "-8"] close_scope (Item (_, [], 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[@ocaml.warning "-39"] 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[@ocaml.warning "-8"] 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 = Stdlib.compare end) class funinfo = object (self : 'self) val funtree : string M.t ref = Stdlib.ref M.empty val closures : Value.designation list M.t ref = Stdlib.ref M.empty val functx : Value.designation list FC.t ref = Stdlib.ref FC.empty 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 = Stdlib.ref false in let rec propagate_downwards current_closure = function | [] -> current_closure | f :: tl -> let fclosure = self#get_closure f in let delta = Stdlib.ref fclosure in let index = Stdlib.ref (List.length fclosure) in let added = Stdlib.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 val line = None val end_label = "" 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 = {} method register_call f = {} method register_fun f = {} method register_closure f = {} 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 Mut | `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, {}) method get_end_label = let lab = label @@ string_of_int label_index in (lab, {}) method end_label = end_label 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 (blab : string) (elab : string) = (*Printf.printf "push: Scope local index = %d\n" scope.local_index;*) match scope.st with | State.I -> {} #import_imports | _ -> {} method pop_scope = match scope.st with | State.I -> {} | State.G _ -> {} | State.L (xs, _, x) -> { x <> FVal) xs) (*xs*); scopes = (match scope.scopes with | [ _ ] -> scope.scopes | hs :: ps :: tl -> { ps with subs = hs :: ps.subs } :: tl | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)); }>} method open_fun_scope blab elab (name, args, body, st') = { 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 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 -> ({}#pop_scope, scopes) | None -> ({}#pop_scope, scopes) method add_arg (name : string) = { invalid_arg "wrong scope in add_arg" | State.L (names, s, p) -> State.L ( check_name_and_add names name Mut, 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 : Language.k) = { 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 (*Printf.printf "Var: %s -> %d\n" name scope.local_index;*) 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); scopes = (match scope.scopes with | ts :: tl -> { ts with names = (name, scope.local_index) :: ts.names; } :: tl | _ -> scope.scopes); }>} 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 FVal), 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 FVal, State.bind name (Value.Fun name') s, p ) in {} method add_lambda (args : string list) (body : Expr.t) = let name' = self#fun_internal_name (Printf.sprintf "lambda_%d" lam_index) in ( {} #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 | _ -> {} #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 ( {}, Value.Access index ) | other -> (self, other) method next_definition = match pick fundefs with | _, None -> None | fds, Some fd -> Some ({}, from_fundef fd) method closure = List.rev scope.closure method gen_line name = match Loc.get name with | None -> (self, []) | Some (l, _) -> ( match line with | None -> ({}, [ LINE l ]) | Some l' when l' <> l -> ({}, [ LINE l ]) | _ -> (self, [])) end [@@ocaml.warning "-15"] let compile cmd ((imports, _), 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 _ 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; ELEM (*CALL (".elem", 2, false)*) ] @ 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_t method c_Wildcard _ _ = [] method c_Named path _ s p = [ (s, path) ] @ fself path p method c_Sexp path _ _ 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) -> (*Printf.printf "Bindings..\n";*) let env = env#add_name name `Local Mut in let env, dsg = env#lookup name in (*Printf.printf "End Bindings..\n";*) ( env, ([ DUP ] @ List.concat (List.map (fun i -> [ CONST i; ELEM (* CALL (".elem", 2, false)*) ]) 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 tail l env = function | [] -> (env, false, []) | [ e ] -> compile_expr tail l env e | e :: es -> let les, env = env#get_label in let env, flag1, s1 = compile_expr false les env e in let env, flag2, s2 = compile_list tail l env es in add_code (env, flag1, s1) les flag2 s2 and[@ocaml.warning "-8"] compile_expr tail l env = function | Expr.Lambda (args, b) -> let env, lines = List.fold_left (fun (env, acc) name -> let env, ln = env#gen_line name in (env, acc @ ln)) (env, []) args in let env, name = env#add_lambda args b in ( env#register_call name, false, lines @ [ PROTO (name, env#current_function) ] ) | Expr.Scope (ds, e) -> 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) -> 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 Mut, e, funs) | name, (m, `Variable (Some v)) -> ( env#add_name name m Mut, 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 tail l env e in (env#pop_scope, flag, [ SLABEL blab ] @ code @ [ SLABEL elab ]) | Expr.Unit -> (env, false, [ CONST 0 ]) | Expr.Ignore s -> let ls, env = env#get_label in add_code (compile_expr tail ls env s) ls false [ DROP ] | Expr.ElemRef (x, i) -> compile_list tail l env [ x; i ] | Expr.Var x -> ( let env, line = env#gen_line x in let env, acc = env#lookup x in (*Printf.printf "Looking up %s -> %s\n" x (show(Value.designation) acc);*) match acc with | Value.Fun name -> ( env#register_call name, false, line @ [ PROTO (name, env#current_function) ] ) | _ -> (env, false, line @ [ LD acc ])) | Expr.Ref x -> let env, line = env#gen_line x in let env, acc = env#lookup x in (env, false, line @ [ 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 false 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, line = env#gen_line name in 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 false lcall env args) lcall false [ PCALLC (List.length args, tail) ] in (env, f, line @ (PPROTO (name, env#current_function) :: code)) | _ -> add_code (compile_list false lcall env (f :: args)) lcall false [ CALLC (List.length args, tail) ]) | _ -> add_code (compile_list false lcall env (f :: args)) lcall false [ CALLC (List.length args, tail) ]) | Expr.Array xs -> let lar, env = env#get_label in add_code (compile_list false lar env xs) lar false [ CALL (".array", List.length xs, tail) ] | Expr.Sexp (t, xs) -> let lsexp, env = env#get_label in add_code (compile_list false 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 false lelem env [ a; i ]) lelem false [ ELEM (* CALL (".elem", 2, tail) *) ] | Expr.Assign (Expr.Ref x, e) -> let lassn, env = env#get_label in let env, line = env#gen_line x in let env, acc = env#lookup x in add_code (compile_expr false lassn env e) lassn false (line @ [ ST acc ]) | Expr.Assign (x, e) -> let lassn, env = env#get_label in add_code (compile_list false lassn env [ x; e ]) lassn false [ (match x with Expr.Ref _ -> STI | _ -> STA) ] (*Expr.ElemRef _ -> STA | _ -> STI]*) | Expr.Skip -> (env, false, []) | Expr.Seq (s1, s2) -> compile_list tail 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 false le env c in let env, flag1, s1 = compile_expr tail l env s1 in let env, flag2, s2 = compile_expr tail 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 false lexp env c in let env, _, s = compile_expr false cond env s in ( env, false, [ JMP cond; FLABEL loop ] @ s @ [ LABEL cond ] @ se @ (if fe then [ LABEL lexp ] else []) @ [ CJMP ("nz", loop) ] ) | Expr.DoWhile (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 false lexp env c in let env, flag, body = compile_expr false check env s in ( env, false, [ LABEL loop ] @ body @ (if flag then [ LABEL check ] else []) @ se @ (if fe then [ LABEL lexp ] else []) @ [ CJMP ("nz", loop) ] ) | 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 false 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 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, _, scode = compile_expr tail l env s in let env = env#pop_scope in ( 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 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, _) 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 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_end_label in let env, _, code = compile_expr true 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 nargs, nlocals, closure = (env#nargs, env#nlocals, env#closure) in let env, scopes = env#close_fun_scope in let code = ([ LABEL name; BEGIN (name, nargs, nlocals, closure, args, scopes); SLABEL blab; ] @ code @ [ LABEL lend; SLABEL elab; END ]) :: funcode in (env, 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, 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 | [] -> inner (Some f :: state) tl | closure -> CLOSURE (f, closure) :: inner (None :: state) tl) | PCALLC (n, tail) :: tl -> ( match state with | None :: state' -> CALLC (n, tail) :: inner state' tl | Some f :: state' -> CALL (f, n, tail) :: inner state' tl | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)) | 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 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 prg = List.map (fun i -> IMPORT i) imports @ [ 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