diff --git a/dune-project b/dune-project new file mode 100644 index 000000000..31718a853 --- /dev/null +++ b/dune-project @@ -0,0 +1,3 @@ +(lang dune 3.3) + +(cram enable) diff --git a/src/.ocamlformat b/src/.ocamlformat new file mode 100644 index 000000000..1756ba7ac --- /dev/null +++ b/src/.ocamlformat @@ -0,0 +1 @@ +profile=default \ No newline at end of file diff --git a/src/Driver.ml b/src/Driver.ml index 01ebf0838..ee147f3c2 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -2,184 +2,223 @@ exception Commandline_error of string class options args = let n = Array.length args in - let dump_ast = 0b1 in - let dump_sm = 0b010 in + let dump_ast = 0b1 in + let dump_sm = 0b010 in let dump_source = 0b100 in (* Kakadu: binary masks are cool for C code, but for OCaml I don't see any reason to save memory like this *) let help_string = - "Lama compiler. (C) JetBrains Reserach, 2017-2020.\n" ^ - "Usage: lamac \n\n" ^ - "When no options specified, builds the source file into executable.\n" ^ - "Options:\n" ^ - " -c --- compile into object file\n" ^ - " -o --- write executable into file \n" ^ - " -I --- add into unit search path list\n" ^ - " -i --- interpret on a source-level interpreter\n" ^ - " -s --- compile into stack machine code and interpret on the stack machine initerpreter\n" ^ - " -dp --- dump AST (the output will be written into .ast file)\n" ^ - " -dsrc --- dump pretty-printed source code\n" ^ - " -ds --- dump stack machine code (the output will be written into .sm file; has no\n" ^ - " effect if -i option is specfied)\n" ^ - " -b --- compile to a stack machine bytecode\n" ^ - " -v --- show version\n" ^ - " -h --- show this help\n" + "Lama compiler. (C) JetBrains Reserach, 2017-2020.\n" + ^ "Usage: lamac \n\n" + ^ "When no options specified, builds the source file into executable.\n" + ^ "Options:\n" ^ " -c --- compile into object file\n" + ^ " -o --- write executable into file \n" + ^ " -I --- add into unit search path list\n" + ^ " -i --- interpret on a source-level interpreter\n" + ^ " -s --- compile into stack machine code and interpret on the \ + stack machine initerpreter\n" + ^ " -dp --- dump AST (the output will be written into .ast file)\n" + ^ " -dsrc --- dump pretty-printed source code\n" + ^ " -ds --- dump stack machine code (the output will be written \ + into .sm file; has no\n" + ^ " effect if -i option is specfied)\n" + ^ " -b --- compile to a stack machine bytecode\n" + ^ " -v --- show version\n" ^ " -h --- show this help\n" in object (self) val version = ref false - val help = ref false - val i = ref 1 - val infile = ref (None : string option) + val help = ref false + val i = ref 1 + val infile = ref (None : string option) val outfile = ref (None : string option) - val paths = ref [X86.get_std_path ()] - val mode = ref (`Default : [`Default | `Eval | `SM | `Compile | `BC]) - val curdir = Unix.getcwd () - val debug = ref false + val paths = ref [ X86.get_std_path () ] + val mode = ref (`Default : [ `Default | `Eval | `SM | `Compile | `BC ]) + val curdir = Unix.getcwd () + val debug = ref false + (* Workaround until Ostap starts to memoize properly *) - val const = ref false + val const = ref false + (* end of the workaround *) - val dump = ref 0 + val dump = ref 0 + initializer - let rec loop () = - match self#peek with - | Some opt -> - (match opt with - (* Workaround until Ostap starts to memoize properly *) - | "-w" -> self#set_workaround - (* end of the workaround *) - | "-c" -> self#set_mode `Compile - | "-o" -> (match self#peek with None -> raise (Commandline_error "File name expected after '-o' specifier") | Some fname -> self#set_outfile fname) - | "-I" -> (match self#peek with None -> raise (Commandline_error "Path expected after '-I' specifier") | Some path -> self#add_include_path path) - | "-s" -> self#set_mode `SM - | "-b" -> self#set_mode `BC - | "-i" -> self#set_mode `Eval - | "-ds" -> self#set_dump dump_sm - | "-dsrc" -> self#set_dump dump_source - | "-dp" -> self#set_dump dump_ast - | "-h" -> self#set_help - | "-v" -> self#set_version - | "-g" -> self#set_debug - | _ -> - if opt.[0] = '-' - then raise (Commandline_error (Printf.sprintf "Invalid command line specifier ('%s')" opt)) - else self#set_infile opt - ); - loop () - | None -> () - in loop () + let rec loop () = + match self#peek with + | Some opt -> + (match opt with + (* Workaround until Ostap starts to memoize properly *) + | "-w" -> self#set_workaround + (* end of the workaround *) + | "-c" -> self#set_mode `Compile + | "-o" -> ( + match self#peek with + | None -> + raise + (Commandline_error "File name expected after '-o' specifier") + | Some fname -> self#set_outfile fname) + | "-I" -> ( + match self#peek with + | None -> + raise (Commandline_error "Path expected after '-I' specifier") + | Some path -> self#add_include_path path) + | "-s" -> self#set_mode `SM + | "-b" -> self#set_mode `BC + | "-i" -> self#set_mode `Eval + | "-ds" -> self#set_dump dump_sm + | "-dsrc" -> self#set_dump dump_source + | "-dp" -> self#set_dump dump_ast + | "-h" -> self#set_help + | "-v" -> self#set_version + | "-g" -> self#set_debug + | _ -> + if opt.[0] = '-' then + raise + (Commandline_error + (Printf.sprintf "Invalid command line specifier ('%s')" opt)) + else self#set_infile opt); + loop () + | None -> () + in + loop () + (* Workaround until Ostap starts to memoize properly *) method is_workaround = !const - method private set_workaround = - const := true + method private set_workaround = const := true + (* end of the workaround *) - method private set_help = help := true + method private set_help = help := true method private set_version = version := true - method private set_dump mask = - dump := !dump lor mask + method private set_dump mask = dump := !dump lor mask + method private set_infile name = match !infile with - | None -> infile := Some name - | Some name' -> raise (Commandline_error (Printf.sprintf "Input file ('%s') already specified" name')) + | None -> infile := Some name + | Some name' -> + raise + (Commandline_error + (Printf.sprintf "Input file ('%s') already specified" name')) + method private set_outfile name = match !outfile with - | None -> outfile := Some name - | Some name' -> raise (Commandline_error (Printf.sprintf "Output file ('%s') already specified" name')) - method private add_include_path path = - paths := path :: !paths + | None -> outfile := Some name + | Some name' -> + raise + (Commandline_error + (Printf.sprintf "Output file ('%s') already specified" name')) + + method private add_include_path path = paths := path :: !paths + method private set_mode s = match !mode with | `Default -> mode := s | _ -> raise (Commandline_error "Extra compilation mode specifier") + method private peek = let j = !i in - if j < n - then (incr i; Some (args.(j))) + if j < n then ( + incr i; + Some args.(j)) else None + method get_mode = !mode + method get_output_option = match !outfile with - | None -> Printf.sprintf "-o %s" self#basename + | None -> Printf.sprintf "-o %s" self#basename | Some name -> Printf.sprintf "-o %s" name + method get_absolute_infile = let f = self#get_infile in if Filename.is_relative f then Filename.concat curdir f else f + method get_infile = match !infile with - | None -> raise (Commandline_error "Input file not specified") + | None -> raise (Commandline_error "Input file not specified") | Some name -> name + method get_help = !help method get_include_paths = !paths - method basename = Filename.chop_suffix (Filename.basename self#get_infile) ".lama" + + method basename = + Filename.chop_suffix (Filename.basename self#get_infile) ".lama" + method topname = - match !mode with - | `Compile -> "init" ^ self#basename - | _ -> "main" + match !mode with `Compile -> "init" ^ self#basename | _ -> "main" + method dump_file ext contents = let name = self#basename in let outf = open_out (Printf.sprintf "%s.%s" name ext) in Printf.fprintf outf "%s" contents; close_out outf + method dump_AST ast = - if (!dump land dump_ast) > 0 - then ( + if !dump land dump_ast > 0 then ( let buf = Buffer.create 1024 in Buffer.add_string buf ""; - Buffer.add_string buf (Printf.sprintf " %s " self#get_infile); + Buffer.add_string buf + (Printf.sprintf " %s " self#get_infile); Buffer.add_string buf "
  • "; - GT.html(Language.Expr.t) ast buf; + GT.html Language.Expr.t ast buf; Buffer.add_string buf "
    • "; Buffer.add_string buf ""; - self#dump_file "html" (Buffer.contents buf) - ) - method dump_source (ast: Language.Expr.t) = - if (!dump land dump_source) > 0 - then Pprinter.pp Format.std_formatter ast; - method dump_SM sm = - if (!dump land dump_sm) > 0 - then self#dump_file "sm" (SM.show_prg sm) + self#dump_file "html" (Buffer.contents buf)) + + method dump_source (ast : Language.Expr.t) = + if !dump land dump_source > 0 then Pprinter.pp Format.std_formatter ast + + method dump_SM sm = + if !dump land dump_sm > 0 then self#dump_file "sm" (SM.show_prg sm) else () + method greet = (match !outfile with - | None -> () - | Some _ -> (match !mode with `Default -> () | _ -> Printf.printf "Output file option ignored in this mode.\n") - ); + | None -> () + | Some _ -> ( + match !mode with + | `Default -> () + | _ -> Printf.printf "Output file option ignored in this mode.\n")); if !version then Printf.printf "%s\n" Version.version; - if !help then Printf.printf "%s" help_string - method get_debug = - if !debug then "" else "-g" - method set_debug = - debug := true + if !help then Printf.printf "%s" help_string + + method get_debug = if !debug then "" else "-g" + method set_debug = debug := true end -let main = +let[@ocaml.warning "-32"] main = try let cmd = new options Sys.argv in cmd#greet; - match (try Language.run_parser cmd with Language.Semantic_error msg -> `Fail msg) with - | `Ok prog -> - cmd#dump_AST (snd prog); - cmd#dump_source (snd prog); - (match cmd#get_mode with - | `Default | `Compile -> - ignore @@ X86.build cmd prog - | `BC -> - SM.ByteCode.compile cmd (SM.compile cmd prog) + match + try Language.run_parser cmd + with Language.Semantic_error msg -> `Fail msg + with + | `Ok prog -> ( + cmd#dump_AST (snd prog); + cmd#dump_source (snd prog); + match cmd#get_mode with + | `Default | `Compile -> ignore @@ X86.build cmd prog + | `BC -> SM.ByteCode.compile cmd (SM.compile cmd prog) | _ -> - let rec read acc = - try - let r = read_int () in - Printf.printf "> "; - read (acc @ [r]) - with End_of_file -> acc - in - let input = read [] in - let output = - if cmd#get_mode = `Eval - then Language.eval prog input - else SM.run (SM.compile cmd prog) input - in - List.iter (fun i -> Printf.printf "%d\n" i) output - ) - | `Fail er -> Printf.eprintf "Error: %s\n" er; exit 255 + let rec read acc = + try + let r = read_int () in + Printf.printf "> "; + read (acc @ [ r ]) + with End_of_file -> acc + in + let input = read [] in + let output = + if cmd#get_mode = `Eval then Language.eval prog input + else SM.run (SM.compile cmd prog) input + in + List.iter (fun i -> Printf.printf "%d\n" i) output) + | `Fail er -> + Printf.eprintf "Error: %s\n" er; + exit 255 with - | Language.Semantic_error msg -> Printf.printf "Error: %s\n" msg; exit 255 - | Commandline_error msg -> Printf.printf "%s\n" msg; exit 255 + | Language.Semantic_error msg -> + Printf.printf "Error: %s\n" msg; + exit 255 + | Commandline_error msg -> + Printf.printf "%s\n" msg; + exit 255 diff --git a/src/Language.ml b/src/Language.ml index 693649d3d..d685fce64 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -3,6 +3,8 @@ *) module OrigList = List +[@@@ocaml.warning "-7-8-13-15-20-26-27-32"] + open GT (* Opening a library for combinator-based syntax analysis *) @@ -55,7 +57,7 @@ module Loc = let report_error ?(loc=None) str = raise (Semantic_error (str ^ match loc with None -> "" | Some (l, c) -> Printf.sprintf " at (%d, %d)" l c));; - + @type k = Unmut | Mut | FVal with show, html, foldl (* Values *) @@ -85,7 +87,7 @@ module Value = with show, html, foldl let is_int = function Int _ -> true | _ -> false - + let to_int = function | Int n -> n | x -> failwith (Printf.sprintf "int value expected (%s)\n" (show(t) (fun _ -> "") (fun _ -> "") x)) @@ -114,6 +116,7 @@ module Value = match x with | Sexp (_, a) | Array a -> ignore (update_array a i v) | String a -> ignore (update_string a i (Char.chr @@ to_int v)) + | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__) let string_val v = let buf = Buffer.create 128 in @@ -121,8 +124,7 @@ module Value = let rec inner = function | Int n -> append (string_of_int n) | String s -> append "\""; append @@ Bytes.to_string s; append "\"" - | Array a -> let n = Array.length a in - append "["; Array.iteri (fun i a -> (if i > 0 then append ", "); inner a) a; append "]" + | Array a -> append "["; Array.iteri (fun i a -> (if i > 0 then append ", "); inner a) a; append "]" | Sexp (t, a) -> let n = Array.length a in if t = "cons" then ( @@ -131,6 +133,7 @@ module Value = | [||] -> () | [|x; Int 0|] -> inner x | [|x; Sexp ("cons", a)|] -> inner x; append ", "; inner_list a + | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__) in inner_list a; append "}" ) @@ -139,6 +142,7 @@ module Value = (if n > 0 then (append " ("; Array.iteri (fun i a -> (if i > 0 then append ", "); inner a) a; append ")")) ) + | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__) in inner v; Bytes.of_string @@ Buffer.contents buf @@ -156,24 +160,27 @@ module Builtin = let eval (st, i, o, vs) args = function | "read" -> (match i with z::i' -> (st, i', o, (Value.of_int z)::vs) | _ -> failwith "Unexpected end of input") | "write" -> (st, i, o @ [Value.to_int @@ List.hd args], Value.Empty :: vs) - | ".elem" -> let [b; j] = args in - (st, i, o, let i = Value.to_int j in - (match b with - | Value.String s -> Value.of_int @@ Char.code (Bytes.get s i) - | Value.Array a -> a.(i) - | Value.Sexp (_, a) -> a.(i) - ) :: vs + | ".elem" -> (match args with + | [b; j] -> (st, i, o, let i = Value.to_int j in + (match b with + | Value.String s -> Value.of_int @@ Char.code (Bytes.get s i) + | Value.Array a -> a.(i) + | Value.Sexp (_, a) -> a.(i) + | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__) + ) :: vs + ) + | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__) ) - | "length" -> (st, i, o, (Value.of_int (match List.hd args with Value.Sexp (_, a) | Value.Array a -> Array.length a | Value.String s -> Bytes.length s))::vs) + | "length" -> (st, i, o, (Value.of_int (match List.hd args with Value.Sexp (_, a) | Value.Array a -> Array.length a | Value.String s -> Bytes.length s | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)))::vs) | ".array" -> (st, i, o, (Value.of_array @@ Array.of_list args)::vs) - | "string" -> let [a] = args in (st, i, o, (Value.of_string @@ Value.string_val a)::vs) - + | "string" -> (match args with | [a] -> (st, i, o, (Value.of_string @@ Value.string_val a)::vs) | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)) + | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__) end (* States *) module State = struct - + (* State: global state, local state, scope variables *) @type 'a t = | I @@ -273,7 +280,7 @@ module State = | _ -> L (xs, s, st) (* Drop a local scope *) - let drop = function L (_, _, e) -> e | G _ -> I + let drop = function L (_, _, e) -> e | G _ -> I | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__) (* Observe a variable in a state and print it to stderr *) let observe st x = @@ -440,19 +447,18 @@ module Expr = let seq x = function Skip -> x | y -> Seq (x, y) - let schedule_list h::tl = - List.fold_left seq h tl + let schedule_list = function h::tl -> List.fold_left seq h tl | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__) let rec take = function | 0 -> fun rest -> [], rest - | n -> fun h::tl -> let tl', rest = take (n-1) tl in h :: tl', rest + | n -> function h::tl -> let tl', rest = take (n-1) tl in h :: tl', rest | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__) let rec eval ((st, i, o, vs) as conf) k expr = - let print_values vs = + (* let print_values vs = Printf.eprintf "Values:\n%!"; List.iter (fun v -> Printf.eprintf "%s\n%!" @@ show(Value.t) (fun _ -> "") (fun _ -> "") v) vs; Printf.eprintf "End Values\n%!" - in + in *) match expr with | Lambda (args, body) -> eval (st, i, o, Value.Closure (args, body, [|st|]) :: vs) Skip k @@ -500,73 +506,78 @@ module Expr = | Sexp (t, xs) -> eval conf k (schedule_list (xs @ [Intrinsic (fun (st, i, o, vs) -> let es, vs' = take (List.length xs) vs in (st, i, o, Value.Sexp (t, Array.of_list (List.rev es)) :: vs'))])) | Binop (op, x, y) -> - eval conf k (schedule_list [x; y; Intrinsic (fun (st, i, o, y::x::vs) -> (st, i, o, (Value.of_int @@ to_func op (Value.to_int x) (Value.to_int y)) :: vs))]) + eval conf k (schedule_list [x; y; Intrinsic (function (st, i, o, y::x::vs) -> (st, i, o, (Value.of_int @@ to_func op (Value.to_int x) (Value.to_int y)) :: vs) | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__))]) | Elem (b, i) -> - eval conf k (schedule_list [b; i; Intrinsic (fun (st, i, o, j::b::vs) -> Builtin.eval (st, i, o, vs) [b; j] ".elem")]) + eval conf k (schedule_list [b; i; Intrinsic (function (st, i, o, j::b::vs) -> Builtin.eval (st, i, o, vs) [b; j] ".elem" | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__))]) | ElemRef (b, i) -> - eval conf k (schedule_list [b; i; Intrinsic (fun (st, i, o, j::b::vs) -> (st, i, o, (Value.Elem (b, Value.to_int j))::vs))]) + eval conf k (schedule_list [b; i; Intrinsic (function (st, i, o, j::b::vs) -> (st, i, o, (Value.Elem (b, Value.to_int j))::vs) | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__))]) | Call (f, args) -> eval conf k (schedule_list (f :: args @ [Intrinsic (fun (st, i, o, vs) -> let es, vs' = take (List.length args + 1) vs in - let f :: es = List.rev es in - (match f with - | Value.Builtin name -> - Builtin.eval (st, i, o, vs') es name - | Value.Closure (args, body, closure) -> - let st' = State.push (State.leave st closure.(0)) (State.from_list @@ List.combine args es) (List.map (fun x -> x, Mut) args) in - let st'', i', o', vs'' = eval (st', i, o, []) Skip body in - closure.(0) <- st''; - (State.leave st'' st, i', o', match vs'' with [v] -> v::vs' | _ -> Value.Empty :: vs') - | _ -> report_error (Printf.sprintf "callee did not evaluate to a function: \"%s\"" (show(Value.t) (fun _ -> "") (fun _ -> "") f)) - ))])) + match List.rev es with + | f :: es -> + (match f with + | Value.Builtin name -> + Builtin.eval (st, i, o, vs') es name + | Value.Closure (args, body, closure) -> + let st' = State.push (State.leave st closure.(0)) (State.from_list @@ List.combine args es) (List.map (fun x -> x, Mut) args) in + let st'', i', o', vs'' = eval (st', i, o, []) Skip body in + closure.(0) <- st''; + (State.leave st'' st, i', o', match vs'' with [v] -> v::vs' | _ -> Value.Empty :: vs') + | _ -> report_error (Printf.sprintf "callee did not evaluate to a function: \"%s\"" (show(Value.t) (fun _ -> "") (fun _ -> "") f)) + ) + | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__) + )])) | Leave -> eval (State.drop st, i, o, vs) Skip k | Assign (x, e) -> - eval conf k (schedule_list [x; e; Intrinsic (fun (st, i, o, v::x::vs) -> (update st x v, i, o, v::vs))]) + eval conf k (schedule_list [x; e; Intrinsic (function (st, i, o, v::x::vs) -> (update st x v, i, o, v::vs) | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__))]) | Seq (s1, s2) -> eval conf (seq s2 k) s1 | Skip -> (match k with Skip -> conf | _ -> eval conf Skip k) | If (e, s1, s2) -> - eval conf k (schedule_list [e; Control (fun (st, i, o, e::vs) -> (if Value.to_int e <> 0 then s1 else s2), (st, i, o, vs))]) + eval conf k (schedule_list [e; Control (function (st, i, o, e::vs) -> (if Value.to_int e <> 0 then s1 else s2), (st, i, o, vs) | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__))]) | While (e, s) -> - eval conf k (schedule_list [e; Control (fun (st, i, o, e::vs) -> (if Value.to_int e <> 0 then seq s expr else Skip), (st, i, o, vs))]) + eval conf k (schedule_list [e; Control (function (st, i, o, e::vs) -> (if Value.to_int e <> 0 then seq s expr else Skip), (st, i, o, vs) | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__))]) | DoWhile (s, e) -> eval conf (seq (While (e, s)) k) s | Case (e, bs, _, _)-> - let rec branch ((st, i, o, v::vs) as conf) = function - | [] -> failwith (Printf.sprintf "Pattern matching failed: no branch is selected while matching %s\n" (show(Value.t) (fun _ -> "") (fun _ -> "") v)) - | (patt, body)::tl -> - let rec match_patt patt v st = - let update x v = function - | None -> None - | Some s -> Some (State.bind x v s) - in - match patt, v with - | Pattern.Named (x, p), v -> update x v (match_patt p v st ) - | Pattern.Wildcard , _ -> st - | Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' && List.length ps = Array.length vs -> match_list ps (Array.to_list vs) st - | Pattern.Array ps , Value.Array vs when List.length ps = Array.length vs -> match_list ps (Array.to_list vs) st - | Pattern.Const n , Value.Int n' when n = n' -> st - | Pattern.String s , Value.String s' when s = Bytes.to_string s' -> st - | Pattern.Boxed , Value.String _ - | Pattern.Boxed , Value.Array _ - | Pattern.UnBoxed , Value.Int _ - | Pattern.Boxed , Value.Sexp (_, _) - | Pattern.StringTag , Value.String _ - | Pattern.ArrayTag , Value.Array _ - | Pattern.ClosureTag , Value.Closure _ - | Pattern.SexpTag , Value.Sexp (_, _) -> st - | _ -> None - and match_list ps vs s = - match ps, vs with - | [], [] -> s - | p::ps, v::vs -> match_list ps vs (match_patt p v s) - | _ -> None - in - match match_patt patt v (Some State.undefined) with - | None -> branch conf tl - | Some st' -> eval (State.push st st' (List.map (fun x -> x, Unmut) @@ Pattern.vars patt), i, o, vs) k (Seq (body, Leave)) + let rec branch = + function (_,_,_,[]) -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__) + | ((st, i, o, v::vs) as conf) -> function + | [] -> failwith (Printf.sprintf "Pattern matching failed: no branch is selected while matching %s\n" (show(Value.t) (fun _ -> "") (fun _ -> "") v)) + | (patt, body)::tl -> + let rec match_patt patt v st = + let update x v = function + | None -> None + | Some s -> Some (State.bind x v s) + in + match patt, v with + | Pattern.Named (x, p), v -> update x v (match_patt p v st ) + | Pattern.Wildcard , _ -> st + | Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' && List.length ps = Array.length vs -> match_list ps (Array.to_list vs) st + | Pattern.Array ps , Value.Array vs when List.length ps = Array.length vs -> match_list ps (Array.to_list vs) st + | Pattern.Const n , Value.Int n' when n = n' -> st + | Pattern.String s , Value.String s' when s = Bytes.to_string s' -> st + | Pattern.Boxed , Value.String _ + | Pattern.Boxed , Value.Array _ + | Pattern.UnBoxed , Value.Int _ + | Pattern.Boxed , Value.Sexp (_, _) + | Pattern.StringTag , Value.String _ + | Pattern.ArrayTag , Value.Array _ + | Pattern.ClosureTag , Value.Closure _ + | Pattern.SexpTag , Value.Sexp (_, _) -> st + | _ -> None + and match_list ps vs s = + match ps, vs with + | [], [] -> s + | p::ps, v::vs -> match_list ps vs (match_patt p v s) + | _ -> None + in + match match_patt patt v (Some State.undefined) with + | None -> branch conf tl + | Some st' -> eval (State.push st st' (List.map (fun x -> x, Unmut) @@ Pattern.vars patt), i, o, vs) k (Seq (body, Leave)) in eval conf Skip (schedule_list [e; Intrinsic (fun conf -> branch conf bs)]) @@ -635,14 +646,14 @@ module Expr = let not_a_reference s = new Reason.t (Msg.make "not a reference" [||] (Msg.Locator.Point s#coord)) (* UGLY! *) - let predefined_op : (Obj.t -> Obj.t -> Obj.t) ref = Pervasives.ref (fun _ _ -> invalid_arg "must not happen") + let predefined_op : (Obj.t -> Obj.t -> Obj.t) ref = Stdlib.ref (fun _ _ -> invalid_arg "must not happen") - let defCell = Pervasives.ref 0 + let defCell = Stdlib.ref 0 (* ======= *) let makeParsers env = - let makeParser, makeBasicParser, makeScopeParser = - let def s = let Some def = Obj.magic !defCell in def s in + let [@ocaml.warning "-26"] makeParser, makeBasicParser, makeScopeParser = + let [@ocaml.warning "-20"] def s = let [@ocaml.warning "-8"] Some def = Obj.magic !defCell in def s in let ostap ( parse[infix][atr]: h:basic[infix][Void] -";" t:parse[infix][atr] {Seq (h, t)} | basic[infix][atr]; scope[infix][atr]: <(d, infix')> : def[infix] expr:parse[infix'][atr] {Scope (d, expr)} | {isVoid atr} => <(d, infix')> : def[infix] => {d <> []} => {Scope (d, materialize atr Skip)}; @@ -872,7 +883,7 @@ module Infix = show(showable) @@ Array.map (fun (ass, (_, l)) -> List.map (fun (str, kind, _) -> ass, str, kind) l) infix let extract_exports infix = - let ass_string = function `Lefta -> "L" | `Righta -> "R" | _ -> "I" in + (* let ass_string = function `Lefta -> "L" | `Righta -> "R" | _ -> "I" in *) let exported = Array.map (fun (ass, (_, ops)) -> @@ -1013,7 +1024,7 @@ module Definition = (* end of the workaround *) ) - let makeParser env exprBasic exprScope = + let [@ocaml.warning "-26"] makeParser env exprBasic exprScope = let ostap ( arg : l:$ x:LIDENT {Loc.attach x l#coord; x}; position[pub][ass][coord][newp]: @@ -1107,7 +1118,7 @@ module Interface = Buffer.contents buf (* Read an interface file *) - let read fname = + let [@ocaml.warning "-26"] read fname = let ostap ( funspec: "F" "," i:IDENT ";" {`Fun i}; varspec: "V" "," i:IDENT ";" {`Variable i}; @@ -1201,8 +1212,8 @@ ostap ( let parse cmd = let env = object - val imports = Pervasives.ref ([] : string list) - val tmp_index = Pervasives.ref 0 + val imports = Stdlib.ref ([] : string list) + val tmp_index = Stdlib.ref 0 method add_import imp = imports := imp :: !imports method get_tmp = let index = !tmp_index in incr tmp_index; Printf.sprintf "__tmp%d" index @@ -1223,7 +1234,7 @@ let parse cmd = definitions in - let definitions = Pervasives.ref None in + let definitions = Stdlib.ref None in let (makeParser, makeBasicParser, makeScopeParser) = Expr.makeParsers env in @@ -1233,7 +1244,7 @@ let parse cmd = definitions := Some (makeDefinitions env exprBasic exprScope); - let Some definitions = !definitions in + let [@ocaml.warning "-8-20"] Some definitions = !definitions in let ostap ( parse[cmd]: @@ -1255,7 +1266,7 @@ let run_parser cmd = "while"; "do"; "od"; "for"; "fun"; "var"; "public"; "external"; "import"; - "case"; "of"; "esac"; + "case"; "of"; "esac"; "box"; "val"; "str"; "sexp"; "array"; "infix"; "infixl"; "infixr"; "at"; "before"; "after"; "true"; "false"; "lazy"; "eta"; "syntax"] diff --git a/src/Makefile b/src/Makefile index 58bfb9221..c60fbf970 100644 --- a/src/Makefile +++ b/src/Makefile @@ -8,7 +8,9 @@ PXFLAGS = $(CAMLP5) BFLAGS = -rectypes -g -w -13-58 -package GT,ostap,unix OFLAGS = $(BFLAGS) -all: depend metagen $(TOPFILE) +all: # depend metagen # $(TOPFILE) + dune build ./Driver.exe + ln -sf ../_build/default/src/Driver.exe lamac metagen: echo "let version = \"Version `git rev-parse --abbrev-ref HEAD`, `git rev-parse --short HEAD`, `git rev-parse --verify HEAD |git show --no-patch --no-notes --pretty='%cd'`\"" > version.ml @@ -25,6 +27,7 @@ $(TOPFILE).byte: $(SOURCES:.ml=.cmo) clean: $(RM) $(TOPFILE) *.cm[ioxa] *.annot *.o *.opt *.byte *~ .depend + dune clean -include .depend # generic rules @@ -44,4 +47,4 @@ clean: $(OCAMLOPT) -c $(OFLAGS) $(STATIC) $(PXFLAGS) $< %.cmx: %.ml - $(OCAMLOPT) -c $(OFLAGS) $(STATIC) $(PXFLAGS) $< + $(OCAMLOPT) -c $(OFLAGS) $(STATIC) $(PXFLAGS) $< \ No newline at end of file diff --git a/src/SM.ml b/src/SM.ml index 43362125b..8397571b2 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -1,266 +1,398 @@ -open GT +open GT open Language (* The type for patters *) -@type patt = StrCmp | String | Array | Sexp | Boxed | UnBoxed | Closure with show, enum +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; -} with show +(* 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);; +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 -with show - +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 with show +type prg = insn list [@@deriving gt ~options:{ show }] -module ByteCode = - struct - - module M = Map.Make (String) - module S = Set.Make (String) +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} + 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 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 -> + let add st 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] - ) - 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, tail) -> add_bytes [5*16 + 5]; add_ints [n] - (* 0x56 l:32 n:32 *) | CALL (fn, n, tail) -> 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 s -> () - | PUBLIC s -> add_public s - | IMPORT s -> add_import s - 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 - + 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;; + 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 - +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 } with show +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 +type global = (string, value) arrow [@@deriving gt] (* Control stack *) -@type control = (prg * local) list with show +type control = (prg * local) list [@@deriving gt ~options:{ show }] (* Data stack *) -@type stack = value list with show - -(* The type for the stack machine configuration: control stack, stack, global and local states, +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 +type config = control * stack * global * local * int list * int list (* Stack machine interpreter @@ -268,151 +400,338 @@ type config = control * stack * global * local * int list * int list 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) + | 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 + | 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 memo s = +let print_stack _ s = Printf.eprintf "Memo %!"; - List.iter (fun v -> Printf.eprintf "%s " @@ show(value) v) s; + 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' -> - (* + +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 = 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))) - ) + 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 @@ -421,37 +740,60 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio Takes a program, an input stream, and returns an output stream this program calculates *) -module M = Map.Make (String) +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 + | [] -> 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 run p i = let module M = Map.Make (String) in let glob = State.undefined in - let (_, _, _, _, i, o) = + let _, _, _, _, _, o = eval - object + (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, []) + + 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 + o (* Stack machine compiler @@ -459,685 +801,869 @@ let run p i = Takes a program in the source language and returns an equivalent program for the stack machine -*) -let label s = "L" ^ s +*) +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)) + 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; -} 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 = []; - scopes = []; - } - -let to_fundef name args body st = { - name = name; - args = args; - body = body; - scope = init_scope st; +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) + | 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 - + 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) + | 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[@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 rec propagate_acc (Item (p, fds, up) as item) name = +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 + 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) +module FC = Map.Make (struct + type t = string * string + + let compare = Stdlib.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) + 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 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 lookup_closure p = FC.find p !functx - method register_fun f p = funtree := M.add f p !funtree; self + method register_call f c = + functx := FC.add (f, c) [] !functx; + self - method register_closure f c = closures := M.add f c !closures; self + method register_fun f p = + funtree := M.add f p !funtree; + self - method private get_parent f = M.find f !funtree + method register_closure f c = + closures := M.add f c !closures; + self - 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 + 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 - 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 + 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 - 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 = "" + 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 show_funinfo = funinfo#show_funinfo + method register_call f = + {} - 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 = + {} - method register_fun f = {< funinfo = funinfo#register_fun f self#current_function >} + method register_closure f = + {} - method register_closure f = {< funinfo = funinfo#register_closure f self#closure >} + method current_function = + match fundefs with Top _ -> "main" | Item (fd, _, _) -> fd.name - 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 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), {< label_index = label_index + 1 >} - method get_end_label = - let lab = label @@ string_of_int label_index in - lab, {< end_label = lab; label_index = label_index + 1 >} - - method end_label = end_label - - method nargs = scope.arg_index - method nlocals = scope.nlocals + method global_scope = scope_index = 0 - 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 -> - {< - 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); - scopes = {blab = blab; elab = elab; names = []; subs = []} :: scope.scopes - } - >} + method get_label = + (label @@ string_of_int label_index, {}) - 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 = ((*Printf.printf "pop: Scope local index = %d\n" (scope.local_index - List.length xs);*) scope.local_index - List.length (List.filter (fun (_, x) -> x <> FVal) xs) (*xs*)); - scopes = match scope.scopes with - [_] -> scope.scopes - | hs :: ps :: tl -> {ps with subs = hs :: ps.subs} :: tl - } - >} + method get_end_label = + let lab = label @@ string_of_int label_index in + (lab, {}) - method open_fun_scope blab elab (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 blab elab + method end_label = end_label + method nargs = scope.arg_index + method nlocals = scope.nlocals - 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, scopes - | None -> {< fundefs = fundefs' >} # pop_scope, scopes - - 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 Mut, State.bind name (Value.Arg scope.arg_index) s, p) - ); - arg_index = scope.arg_index + 1 - } - >} + 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 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) = {< - 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 ((*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' = + method push_scope (blab : string) (elab : string) = + (*Printf.printf "push: Scope local index = %d\n" scope.local_index;*) 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 - {< - decls = (name, m, true) :: decls; - scope = {scope with st = st'} - >} + {} + #import_imports + | _ -> + {} - 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 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 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 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 closure = List.rev scope.closure + 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 gen_line name = - match Loc.get name with - | None -> self, [] - | Some (l, _) -> - match line with - | None -> {< line = Some l >}, [LINE l] - | Some l' when l' <> l -> {< line = Some l >}, [LINE l] - | _ -> self, [] -end - -let compile cmd ((imports, infixes), p) = + 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 lhead ldrop env ps = + | 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 + 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 + (List.flatten (List.rev code), env) and bindings env p = let bindings = - transform(Pattern.t) + 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 + 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 + 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' + ( 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 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, l' , 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 [] + | [] -> (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, st) as fd) = + 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 + 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, flag, code = compile_expr true lend env stmt in - let env, funcode = compile_fundefs [] env in + 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 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 + ([ + LABEL name; + BEGIN (name, nargs, nlocals, closure, args, scopes); + SLABEL blab; + ] + @ code + @ [ LABEL lend; SLABEL elab; END ]) + :: funcode in - env, code + (env, code) and compile_fundefs acc env = match env#next_definition with - | None -> env, acc + | None -> (env, acc) | Some (env, def) -> - let env, code = compile_fundef env def in - compile_fundefs (acc @ code) env + 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 - ) - | insn :: tl -> insn :: 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 + | [] -> 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 = 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 + 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; - *) + Printf.eprintf "%s\n%!" env#show_funinfo; + *) let env = env#propagate_closures in (* Printf.eprintf "After propagating closures:\n"; diff --git a/src/X86.ml b/src/X86.ml index aefcd6319..b8c989bb1 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -1,29 +1,28 @@ open GT open Language -open SM - + (* X86 codegeneration interface *) (* The registers: *) -let regs = [|"%ebx"; "%ecx"; "%esi"; "%edi"; "%eax"; "%edx"; "%ebp"; "%esp"|] +let regs = [| "%ebx"; "%ecx"; "%esi"; "%edi"; "%eax"; "%edx"; "%ebp"; "%esp" |] (* We can not freely operate with all register; only 3 by now *) let num_of_regs = Array.length regs - 5 (* We need to know the word size to calculate offsets correctly *) -let word_size = 4;; +let word_size = 4 (* We need to distinguish the following operand types: *) -@type opnd = -| R of int (* hard register *) -| S of int (* a position on the hardware stack *) -| C (* a saved closure *) -| M of string (* a named memory location *) -| L of int (* an immediate operand *) -| I of int * opnd (* an indirect operand with offset *) -with show +type opnd = + | R of int (* hard register *) + | S of int (* a position on the hardware stack *) + | C (* a saved closure *) + | M of string (* a named memory location *) + | L of int (* an immediate operand *) + | I of int * opnd (* an indirect operand with offset *) +[@@deriving gt ~options:{ show }] -let show_opnd = show(opnd) +let show_opnd = show opnd (* For convenience we define the following synonyms for the registers: *) let ebx = R 0 @@ -37,80 +36,98 @@ let esp = R 7 (* Now x86 instruction (we do not need all of them): *) type instr = -(* copies a value from the first to the second operand *) | Mov of opnd * opnd -(* loads an address of the first operand into the second *) | Lea of opnd * opnd -(* makes a binary operation; note, the first operand *) | Binop of string * opnd * opnd -(* designates x86 operator, not the source language one *) -(* x86 integer division, see instruction set reference *) | IDiv of opnd -(* see instruction set reference *) | Cltd -(* sets a value from flags; the first operand is the *) | Set of string * string -(* suffix, which determines the value being set, the *) -(* the second --- (sub)register name *) -(* pushes the operand on the hardware stack *) | Push of opnd -(* pops from the hardware stack to the operand *) | Pop of opnd -(* call a function by a name *) | Call of string -(* call a function by indirect address *) | CallI of opnd -(* returns from a function *) | Ret -(* a label in the code *) | Label of string -(* a conditional jump *) | CJmp of string * string -(* a non-conditional jump *) | Jmp of string -(* directive *) | Meta of string + (* copies a value from the first to the second operand *) + | Mov of opnd * opnd + (* loads an address of the first operand into the second *) + | Lea of opnd * opnd + (* makes a binary operation; note, the first operand *) + | Binop of string * opnd * opnd + (* designates x86 operator, not the source language one *) + (* x86 integer division, see instruction set reference *) + | IDiv of opnd + (* see instruction set reference *) + | Cltd + (* sets a value from flags; the first operand is the *) + | Set of string * string + (* suffix, which determines the value being set, the *) + (* the second --- (sub)register name *) + (* pushes the operand on the hardware stack *) + | Push of opnd + (* pops from the hardware stack to the operand *) + | Pop of opnd + (* call a function by a name *) + | Call of string + (* call a function by indirect address *) + | CallI of opnd + (* returns from a function *) + | Ret + (* a label in the code *) + | Label of string + (* a conditional jump *) + | CJmp of string * string + (* a non-conditional jump *) + | Jmp of string + (* directive *) + | Meta of string + (* arithmetic correction: decrement *) + | Dec of opnd + (* arithmetic correction: or 0x0001 *) + | Or1 of opnd + (* arithmetic correction: shl 1 *) + | Sal1 of opnd + (* arithmetic correction: shr 1 *) + | Sar1 of opnd + | Repmovsl -(* arithmetic correction: decrement *) | Dec of opnd -(* arithmetic correction: or 0x0001 *) | Or1 of opnd -(* arithmetic correction: shl 1 *) | Sal1 of opnd -(* 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 - + 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) + | 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" - | "*" -> "imull" - | "&&" -> "andl" - | "!!" -> "orl" - | "^" -> "xorl" - | "cmp" -> "cmpl" - | "test" -> "test" - | _ -> failwith "unknown binary operator" + | "+" -> "addl" + | "-" -> "subl" + | "*" -> "imull" + | "&&" -> "andl" + | "!!" -> "orl" + | "^" -> "xorl" + | "cmp" -> "cmpl" + | "test" -> "test" + | _ -> failwith "unknown binary operator" in match instr with - | Cltd -> "\tcltd" - | Set (suf, s) -> Printf.sprintf "\tset%s\t%s" suf s - | IDiv s1 -> Printf.sprintf "\tidivl\t%s" (opnd s1) - | Binop (op, s1, s2) -> Printf.sprintf "\t%s\t%s,\t%s" (binop op) (opnd s1) (opnd s2) - | Mov (s1, s2) -> Printf.sprintf "\tmovl\t%s,\t%s" (opnd s1) (opnd s2) - | Lea (x, y) -> Printf.sprintf "\tleal\t%s,\t%s" (opnd x) (opnd y) - | Push s -> Printf.sprintf "\tpushl\t%s" (opnd s) - | Pop s -> Printf.sprintf "\tpopl\t%s" (opnd s) - | Ret -> "\tret" - | Call p -> Printf.sprintf "\tcall\t%s" p - | CallI o -> Printf.sprintf "\tcall\t*(%s)" (opnd o) - | Label l -> Printf.sprintf "%s:\n" l - | Jmp l -> Printf.sprintf "\tjmp\t%s" l - | CJmp (s , l) -> Printf.sprintf "\tj%s\t%s" s l - | Meta s -> Printf.sprintf "%s\n" s - | Dec s -> Printf.sprintf "\tdecl\t%s" (opnd s) - | Or1 s -> Printf.sprintf "\torl\t$0x0001,\t%s" (opnd s) - | Sal1 s -> Printf.sprintf "\tsall\t%s" (opnd s) - | Sar1 s -> Printf.sprintf "\tsarl\t%s" (opnd s) - | Repmovsl -> Printf.sprintf "\trep movsl\t" + | Cltd -> "\tcltd" + | Set (suf, s) -> Printf.sprintf "\tset%s\t%s" suf s + | IDiv s1 -> Printf.sprintf "\tidivl\t%s" (opnd s1) + | Binop (op, s1, s2) -> + Printf.sprintf "\t%s\t%s,\t%s" (binop op) (opnd s1) (opnd s2) + | Mov (s1, s2) -> Printf.sprintf "\tmovl\t%s,\t%s" (opnd s1) (opnd s2) + | Lea (x, y) -> Printf.sprintf "\tleal\t%s,\t%s" (opnd x) (opnd y) + | Push s -> Printf.sprintf "\tpushl\t%s" (opnd s) + | Pop s -> Printf.sprintf "\tpopl\t%s" (opnd s) + | Ret -> "\tret" + | Call p -> Printf.sprintf "\tcall\t%s" p + | CallI o -> Printf.sprintf "\tcall\t*(%s)" (opnd o) + | Label l -> Printf.sprintf "%s:\n" l + | Jmp l -> Printf.sprintf "\tjmp\t%s" l + | CJmp (s, l) -> Printf.sprintf "\tj%s\t%s" s l + | Meta s -> Printf.sprintf "%s\n" s + | Dec s -> Printf.sprintf "\tdecl\t%s" (opnd s) + | Or1 s -> Printf.sprintf "\torl\t$0x0001,\t%s" (opnd s) + | Sal1 s -> Printf.sprintf "\tsall\t%s" (opnd s) + | Sar1 s -> Printf.sprintf "\tsarl\t%s" (opnd s) + | Repmovsl -> Printf.sprintf "\trep movsl\t" (* Opening stack machine to use instructions without fully qualified names *) open SM @@ -126,464 +143,541 @@ let compile cmd env imports code = (* SM.print_prg code; *) flush stdout; let suffix = function - | "<" -> "l" - | "<=" -> "le" - | "==" -> "e" - | "!=" -> "ne" - | ">=" -> "ge" - | ">" -> "g" - | _ -> failwith "unknown operator" + | "<" -> "l" + | "<=" -> "le" + | "==" -> "e" + | "!=" -> "ne" + | ">=" -> "ge" + | ">" -> "g" + | _ -> failwith "unknown operator" in - let box n = (n lsl 1) lor 1 in + let box n = (n lsl 1) lor 1 in let rec compile' env scode = let on_stack = function S _ -> true | _ -> false in - let mov x s = if on_stack x && on_stack s then [Mov (x, eax); Mov (eax, s)] else [Mov (x, s)] in - let callc env n tail = - let tail = tail && env#nargs = n in - if tail - then ( - let rec push_args env acc = function - | 0 -> env, acc - | n -> let x, env = env#pop in - if x = env#loc (Value.Arg (n-1)) - then push_args env acc (n-1) - else push_args env ((mov x (env#loc (Value.Arg (n-1)))) @ acc) (n-1) - in - let env , pushs = push_args env [] n in - let closure, env = env#pop in - let y , env = env#allocate in - env, pushs @ [Mov (closure, edx); - Mov (I(0, edx), eax); - Mov (ebp, esp); - Pop (ebp)] @ - (if env#has_closure then [Pop ebx] else []) @ - [Jmp "*%eax"] (* UGLY!!! *) - ) - else ( - 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 = List.rev pushs in - let closure, env = env#pop in - let call_closure = - if on_stack closure - then [Mov (closure, edx); Mov (edx, eax); CallI eax] - else [Mov (closure, edx); CallI closure] - in - env, pushr @ pushs @ call_closure @ [Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr) - in - let y, env = env#allocate in env, code @ [Mov (eax, y)] - ) + let mov x s = + if on_stack x && on_stack s then [ Mov (x, eax); Mov (eax, s) ] + else [ Mov (x, s) ] in - let call env f n tail = - let tail = tail && env#nargs = n && f.[0] <> '.' in - let f = - match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f - in - if tail - then ( + let callc env n tail = + let tail = tail && env#nargs = n in + if tail then let rec push_args env acc = function - | 0 -> env, acc - | n -> let x, env = env#pop in - if x = env#loc (Value.Arg (n-1)) - then push_args env acc (n-1) - else push_args env ((mov x (env#loc (Value.Arg (n-1)))) @ acc) (n-1) + | 0 -> (env, acc) + | n -> + let x, env = env#pop in + if x = env#loc (Value.Arg (n - 1)) then push_args env acc (n - 1) + else + push_args env (mov x (env#loc (Value.Arg (n - 1))) @ acc) (n - 1) in let env, pushs = push_args env [] n in - let y, env = env#allocate in - env, pushs @ [Mov (ebp, esp); Pop (ebp)] @ (if env#has_closure then [Pop ebx] else []) @ [Jmp f] - ) - else ( + let closure, env = env#pop in + let _, env = env#allocate in + ( env, + pushs + @ [ + Mov (closure, edx); Mov (I (0, edx), eax); Mov (ebp, esp); Pop ebp; + ] + @ (if env#has_closure then [ Pop ebx ] else []) + @ [ Jmp "*%eax" ] ) (* UGLY!!! *) + else 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 + 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) + | 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 (box n))) :: pushs - | "Bsexp" -> List.rev @@ (Push (L (box n))) :: pushs - | "Bsta" -> pushs - | _ -> List.rev pushs + let pushs = List.rev pushs in + let closure, env = env#pop in + let call_closure = + if on_stack closure then + [ Mov (closure, edx); Mov (edx, eax); CallI eax ] + else [ Mov (closure, edx); CallI closure ] in - env, pushr @ pushs @ [Call f; Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr) + ( env, + pushr @ pushs @ call_closure + @ [ Binop ("+", L (word_size * List.length pushs), esp) ] + @ List.rev popr ) in - let y, env = env#allocate in env, code @ [Mov (eax, y)] - ) + let y, env = env#allocate in + (env, code @ [ Mov (eax, y) ]) + in + let call env f n tail = + let tail = tail && env#nargs = n && f.[0] <> '.' in + let f = + match f.[0] with + | '.' -> "B" ^ String.sub f 1 (String.length f - 1) + | _ -> f + in + if tail then + let rec push_args env acc = function + | 0 -> (env, acc) + | n -> + let x, env = env#pop in + if x = env#loc (Value.Arg (n - 1)) then push_args env acc (n - 1) + else + push_args env (mov x (env#loc (Value.Arg (n - 1))) @ acc) (n - 1) + in + let env, pushs = push_args env [] n in + let _, env = env#allocate in + ( env, + pushs + @ [ Mov (ebp, esp); Pop ebp ] + @ (if env#has_closure then [ Pop ebx ] else []) + @ [ Jmp f ] ) + else + 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 (box n)) :: pushs) + | "Bsexp" -> List.rev @@ (Push (L (box 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, [] + | [] -> (env, []) | instr :: scode' -> let stack = "" (* env#show_stack*) in (* Printf.printf "insn=%s, stack=%s\n%!" (GT.show(insn) instr) (env#show_stack); *) let env', code' = - if env#is_barrier - then match instr with - | LABEL s -> if env#has_stack s then (env#drop_barrier)#retrieve_stack s, [Label s] else env#drop_stack, [] - | FLABEL s -> env#drop_barrier, [Label s] - | SLABEL s -> env, [Label s] - | _ -> env, [] + if env#is_barrier then + match instr with + | LABEL s -> + if env#has_stack s then + (env#drop_barrier#retrieve_stack s, [ Label s ]) + else (env#drop_stack, []) + | FLABEL s -> (env#drop_barrier, [ Label s ]) + | SLABEL s -> (env, [ Label s ]) + | _ -> (env, []) else - match instr with - | PUBLIC name -> env#register_public name, [] - | EXTERN name -> env#register_extern name, [] - | IMPORT name -> env, [] - - | CLOSURE (name, closure) -> - let pushr, popr = - List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers 0) - 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_closure @ - [Push (M ("$" ^ name)); - Push (L (box closure_len)); - Call "Bclosure"; - Binop ("+", L (word_size * (closure_len + 2)), esp); - Mov (eax, s)] @ - List.rev popr @ env#reload_closure) - - | CONST n -> - let s, env' = env#allocate in - (env', [Mov (L (box n), s)]) - - | STRING s -> - let s, env = env#string s in - let l, env = env#allocate in - let env, call = call env ".string" 1 false in - (env, Mov (M ("$" ^ s), l) :: call) - - | LDA x -> - let s, env' = (env #variable x)#allocate in - let s', env''= env'#allocate in - env'', - [Lea (env'#loc x, eax); Mov (eax, s); Mov (eax, s')] - - | LD x -> - let s, env' = (env#variable x)#allocate in - env', - (match s with - | S _ | M _ -> [Mov (env'#loc x, eax); Mov (eax, s)] - | _ -> [Mov (env'#loc x, s)] - ) - - | ST x -> - let env' = env#variable x in - let s = env'#peek in - env', - (match s with - | S _ | M _ -> [Mov (s, eax); Mov (eax, env'#loc x)] - | _ -> [Mov (s, env'#loc x)] - ) - - | STA -> - call env ".sta" 3 false - - | STI -> - let v, x, env' = env#pop2 in - env'#push x, - (match x with - | S _ | M _ -> [Mov (v, edx); Mov (x, eax); Mov (edx, I (0, eax)); Mov (edx, x)] @ env#reload_closure - | _ -> [Mov (v, eax); Mov (eax, I (0, x)); Mov (eax, x)] - ) - - | BINOP op -> - let x, y, env' = env#pop2 in - env'#push y, - (* (match op with - |"<" | "<=" | "==" | "!=" | ">=" | ">" -> - [Push (eax); - Push (edx); - Mov (y, eax); - Binop("&&", L(1), eax); - Mov (x, edx); - Binop("&&", L(1), edx); - Binop("cmp", eax, edx); - CJmp ("nz", "_ERROR2"); - Pop (edx); - Pop (eax)] - (* | "+" | "-" | "*" | "/" -> *) - | _ -> - [Mov (y, eax); - Binop("&&", L(1), eax); - Binop("cmp", L(0), eax); - CJmp ("z", "_ERROR"); - Mov (x, eax); - Binop("&&", L(1), eax); - Binop("cmp", L(0), eax); - CJmp ("z", "_ERROR")] - | _ -> []) @ *) - (match op with - | "/" -> - [Mov (y, eax); - Sar1 eax; - Cltd; - (* x := x >> 1 ?? *) - Sar1 x; (*!!!*) - IDiv x; - Sal1 eax; - Or1 eax; - Mov (eax, y) - ] - | "%" -> - [Mov (y, eax); - Sar1 eax; - Cltd; - (* x := x >> 1 ?? *) - Sar1 x; (*!!!*) - IDiv x; - Sal1 edx; - Or1 edx; - Mov (edx, y) - ] @ env#reload_closure - | "<" | "<=" | "==" | "!=" | ">=" | ">" -> - (match x with - | M _ | S _ -> - [Binop ("^", eax, eax); - Mov (x, edx); - Binop ("cmp", edx, y); - Set (suffix op, "%al"); - Sal1 eax; - Or1 eax; - Mov (eax, y) - ] @ env#reload_closure + match instr with + | PUBLIC name -> (env#register_public name, []) + | EXTERN name -> (env#register_extern name, []) + | IMPORT _ -> (env, []) + | CLOSURE (name, closure) -> + let pushr, popr = + List.split + @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers 0) + 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_closure + @ [ + Push (M ("$" ^ name)); + Push (L (box closure_len)); + Call "Bclosure"; + Binop ("+", L (word_size * (closure_len + 2)), esp); + Mov (eax, s); + ] + @ List.rev popr @ env#reload_closure ) + | CONST n -> + let s, env' = env#allocate in + (env', [ Mov (L (box n), s) ]) + | STRING s -> + let s, env = env#string s in + let l, env = env#allocate in + let env, call = call env ".string" 1 false in + (env, Mov (M ("$" ^ s), l) :: call) + | LDA x -> + let s, env' = (env#variable x)#allocate in + let s', env'' = env'#allocate in + (env'', [ Lea (env'#loc x, eax); Mov (eax, s); Mov (eax, s') ]) + | LD x -> ( + let s, env' = (env#variable x)#allocate in + ( env', + match s with + | S _ | M _ -> [ Mov (env'#loc x, eax); Mov (eax, s) ] + | _ -> [ Mov (env'#loc x, s) ] )) + | ST x -> ( + let env' = env#variable x in + let s = env'#peek in + ( env', + match s with + | S _ | M _ -> [ Mov (s, eax); Mov (eax, env'#loc x) ] + | _ -> [ Mov (s, env'#loc x) ] )) + | STA -> call env ".sta" 3 false + | STI -> ( + let v, x, env' = env#pop2 in + ( env'#push x, + match x with + | S _ | M _ -> + [ + Mov (v, edx); + Mov (x, eax); + Mov (edx, I (0, eax)); + Mov (edx, x); + ] + @ env#reload_closure + | _ -> [ Mov (v, eax); Mov (eax, I (0, x)); Mov (eax, x) ] )) + | BINOP op -> ( + let x, y, env' = env#pop2 in + ( env'#push y, + (* (match op with + |"<" | "<=" | "==" | "!=" | ">=" | ">" -> + [Push (eax); + Push (edx); + Mov (y, eax); + Binop("&&", L(1), eax); + Mov (x, edx); + Binop("&&", L(1), edx); + Binop("cmp", eax, edx); + CJmp ("nz", "_ERROR2"); + Pop (edx); + Pop (eax)] + (* | "+" | "-" | "*" | "/" -> *) + | _ -> + [Mov (y, eax); + Binop("&&", L(1), eax); + Binop("cmp", L(0), eax); + CJmp ("z", "_ERROR"); + Mov (x, eax); + Binop("&&", L(1), eax); + Binop("cmp", L(0), eax); + CJmp ("z", "_ERROR")] + | _ -> []) @ *) + match op with + | "/" -> + [ + Mov (y, eax); + Sar1 eax; + Cltd; + (* x := x >> 1 ?? *) + Sar1 x; + (*!!!*) + IDiv x; + Sal1 eax; + Or1 eax; + Mov (eax, y); + ] + | "%" -> + [ + Mov (y, eax); + Sar1 eax; + Cltd; + (* x := x >> 1 ?? *) + Sar1 x; + (*!!!*) + IDiv x; + Sal1 edx; + Or1 edx; + Mov (edx, y); + ] + @ env#reload_closure + | "<" | "<=" | "==" | "!=" | ">=" | ">" -> ( + match x with + | M _ | S _ -> + [ + Binop ("^", eax, eax); + Mov (x, edx); + Binop ("cmp", edx, y); + Set (suffix op, "%al"); + Sal1 eax; + Or1 eax; + Mov (eax, y); + ] + @ env#reload_closure + | _ -> + [ + Binop ("^", eax, eax); + Binop ("cmp", x, y); + Set (suffix op, "%al"); + Sal1 eax; + Or1 eax; + Mov (eax, y); + ]) + | "*" -> + if on_stack y then + [ + Dec y; + Mov (x, eax); + Sar1 eax; + Binop (op, y, eax); + Or1 eax; + Mov (eax, y); + ] + else + [ + Dec y; + Mov (x, eax); + Sar1 eax; + Binop (op, eax, y); + Or1 y; + ] + | "&&" -> + [ + Dec x; + (*!!!*) + Mov (x, eax); + Binop (op, x, eax); + Mov (L 0, eax); + Set ("ne", "%al"); + Dec y; + (*!!!*) + Mov (y, edx); + Binop (op, y, edx); + Mov (L 0, edx); + Set ("ne", "%dl"); + Binop (op, edx, eax); + Set ("ne", "%al"); + Sal1 eax; + Or1 eax; + Mov (eax, y); + ] + @ env#reload_closure + | "!!" -> + [ + Mov (y, eax); + Sar1 eax; + Sar1 x; + (*!!!*) + Binop (op, x, eax); + Mov (L 0, eax); + Set ("ne", "%al"); + Sal1 eax; + Or1 eax; + Mov (eax, y); + ] + | "+" -> + if on_stack x && on_stack y then + [ Mov (x, eax); Dec eax; Binop ("+", eax, y) ] + else [ Binop (op, x, y); Dec y ] + | "-" -> + if on_stack x && on_stack y then + [ Mov (x, eax); Binop (op, eax, y); Or1 y ] + else [ Binop (op, x, y); Or1 y ] | _ -> - [Binop ("^" , eax, eax); - Binop ("cmp", x, y); - Set (suffix op, "%al"); - Sal1 eax; - Or1 eax; - Mov (eax, y) - ] - ) - | "*" -> - if on_stack y - then [Dec y; Mov (x, eax); Sar1 eax; Binop (op, y, eax); Or1 eax; Mov (eax, y)] - else [Dec y; Mov (x, eax); Sar1 eax; Binop (op, eax, y); Or1 y] - | "&&" -> - [Dec x; (*!!!*) - Mov (x, eax); - Binop (op, x, eax); - Mov (L 0, eax); - Set ("ne", "%al"); - - Dec y; (*!!!*) - Mov (y, edx); - Binop (op, y, edx); - Mov (L 0, edx); - Set ("ne", "%dl"); - - Binop (op, edx, eax); - Set ("ne", "%al"); - Sal1 eax; - Or1 eax; - Mov (eax, y) - ] @ env#reload_closure - | "!!" -> - [Mov (y, eax); - Sar1 eax; - Sar1 x; (*!!!*) - Binop (op, x, eax); - Mov (L 0, eax); - Set ("ne", "%al"); - Sal1 eax; - Or1 eax; - Mov (eax, y) - ] - | "+" -> - if on_stack x && on_stack y - then [Mov (x, eax); Dec eax; Binop ("+", eax, y)] - else [Binop (op, x, y); Dec y] - | "-" -> - if on_stack x && on_stack y - then [Mov (x, eax); Binop (op, eax, y); Or1 y] - else [Binop (op, x, y); Or1 y] - ) - - | LABEL s - | FLABEL 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, 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 - env#assert_empty_stack; - let has_closure = closure <> [] in - let env = env#enter f nargs nlocals has_closure in - env, [Meta (Printf.sprintf "\t.type %s, @function" name)] @ - (if f = "main" - 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.flatten @@ List.map stabs_scope scopes) - ) + failwith + (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ + __LINE__) )) + | LABEL s | FLABEL 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, 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) @ - [Meta "\t.cfi_startproc"] @ - (if has_closure then [Push edx] else []) @ - (if f = cmd#topname - then - [Mov (M "_init", eax); - Binop ("test", eax, eax); - CJmp ("z", "_continue"); - Ret; - Label ("_ERROR"); - Call "Lbinoperror"; - Ret; - Label ("_ERROR2"); - Call "Lbinoperror2"; - Ret; - Label "_continue"; - Mov (L 1, M "_init"); + 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 + env#assert_empty_stack; + let has_closure = closure <> [] in + let env = env#enter f nargs nlocals has_closure in + ( env, + [ Meta (Printf.sprintf "\t.type %s, @function" name) ] + @ (if f = "main" 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.flatten + @@ List.map stabs_scope scopes) + @ [ Meta "\t.cfi_startproc" ] + @ (if has_closure then [ Push edx ] else []) + @ (if f = cmd#topname then + [ + Mov (M "_init", eax); + Binop ("test", eax, eax); + CJmp ("z", "_continue"); + Ret; + Label "_ERROR"; + Call "Lbinoperror"; + Ret; + Label "_ERROR2"; + Call "Lbinoperror2"; + Ret; + Label "_continue"; + Mov (L 1, M "_init"); ] - else [] - ) @ - [Push ebp; - Meta ("\t.cfi_def_cfa_offset\t" ^ if has_closure then "12" else "8"); - Meta ("\t.cfi_offset 5, -" ^ if has_closure then "12" else "8"); - Mov (esp, ebp); - Meta "\t.cfi_def_cfa_register\t5"; - Binop ("-", M ("$" ^ env#lsize), esp); - Mov (esp, edi); - Mov (M "$filler", esi); - Mov (M ("$" ^ (env#allocated_size)), ecx); - Repmovsl - ] @ - (if f = "main" - then [Call "__gc_init"; Push (I (12, ebp)); Push (I (8, ebp)); Call "set_args"; Binop ("+", L 8, esp)] - else [] - ) @ - (if f = cmd#topname - then List.map (fun i -> Call ("init" ^ i)) (List.filter (fun i -> i <> "Std") imports) - else [] - ) - - | END -> - let x, env = env#pop in - env#assert_empty_stack; - let name = env#fname in - env#leave, [ - Mov (x, eax); (*!!*) - Label env#epilogue; - Mov (ebp, esp); - Pop ebp; - ] @ - env#rest_closure @ - (if name = "main" then [Binop ("^", eax, eax)] else []) @ - [Meta "\t.cfi_restore\t5"; - Meta "\t.cfi_def_cfa\t4, 4"; - Ret; - Meta "\t.cfi_endproc"; - Meta (Printf.sprintf "\t.set\t%s,\t%d" env#lsize (env#allocated * word_size)); - Meta (Printf.sprintf "\t.set\t%s,\t%d" env#allocated_size env#allocated); - Meta (Printf.sprintf "\t.size %s, .-%s" name name); - ] - - | RET -> - let x = env#peek in - env, [Mov (x, eax); Jmp env#epilogue] - - | ELEM -> call env ".elem" 2 false - - | CALL (f, n, tail) -> call env f n tail - - | CALLC (n, tail) -> callc env n tail - - | SEXP (t, n) -> - let s, env = env#allocate in - let env, code = call env ".sexp" (n+1) false in - env, [Mov (L (box (env#hash t)), s)] @ code - - | DROP -> - snd env#pop, [] - - | DUP -> - let x = env#peek in - let s, env = env#allocate in - env, mov x s - - | SWAP -> - let x, y = env#peek2 in - env, [Push x; Push y; Pop x; Pop y] - - | TAG (t, n) -> - let s1, env = env#allocate in - let s2, env = env#allocate in - let env, code = call env ".tag" 3 false in - env, [Mov (L (box (env#hash t)), s1); Mov (L (box n), s2)] @ code - - | ARRAY n -> - let s, env = env#allocate in - let env, code = call env ".array_patt" 2 false in - env, [Mov (L (box n), s)] @ code - - | PATT StrCmp -> call env ".string_patt" 2 false - - | PATT patt -> - call env - (match patt with - | Boxed -> ".boxed_patt" - | UnBoxed -> ".unboxed_patt" - | Array -> ".array_tag_patt" - | String -> ".string_tag_patt" - | Sexp -> ".sexp_tag_patt" - | Closure -> ".closure_tag_patt" - ) 1 false - | LINE (line) -> - env#gen_line line - - | FAIL ((line, col), value) -> - let v, env = if value then env#peek, env else env#pop in - let s, env = env#string cmd#get_infile in - env, [Push (L (box col)); Push (L (box line)); Push (M ("$" ^ s)); Push v; Call "Bmatch_failure"; Binop ("+", L (4 * word_size), esp)] - - | i -> - invalid_arg (Printf.sprintf "invalid SM insn: %s\n" (GT.show(insn) i)) + else []) + @ [ + Push ebp; + Meta + ("\t.cfi_def_cfa_offset\t" + ^ if has_closure then "12" else "8"); + Meta + ("\t.cfi_offset 5, -" + ^ if has_closure then "12" else "8"); + Mov (esp, ebp); + Meta "\t.cfi_def_cfa_register\t5"; + Binop ("-", M ("$" ^ env#lsize), esp); + Mov (esp, edi); + Mov (M "$filler", esi); + Mov (M ("$" ^ env#allocated_size), ecx); + Repmovsl; + ] + @ (if f = "main" then + [ + Call "__gc_init"; + Push (I (12, ebp)); + Push (I (8, ebp)); + Call "set_args"; + Binop ("+", L 8, esp); + ] + else []) + @ + if f = cmd#topname then + List.map + (fun i -> Call ("init" ^ i)) + (List.filter (fun i -> i <> "Std") imports) + else [] ) + | END -> + let x, env = env#pop in + env#assert_empty_stack; + let name = env#fname in + ( env#leave, + [ + Mov (x, eax); + (*!!*) + Label env#epilogue; + Mov (ebp, esp); + Pop ebp; + ] + @ env#rest_closure + @ (if name = "main" then [ Binop ("^", eax, eax) ] else []) + @ [ + Meta "\t.cfi_restore\t5"; + Meta "\t.cfi_def_cfa\t4, 4"; + Ret; + Meta "\t.cfi_endproc"; + Meta + (Printf.sprintf "\t.set\t%s,\t%d" env#lsize + (env#allocated * word_size)); + Meta + (Printf.sprintf "\t.set\t%s,\t%d" env#allocated_size + env#allocated); + Meta (Printf.sprintf "\t.size %s, .-%s" name name); + ] ) + | RET -> + let x = env#peek in + (env, [ Mov (x, eax); Jmp env#epilogue ]) + | ELEM -> call env ".elem" 2 false + | CALL (f, n, tail) -> call env f n tail + | CALLC (n, tail) -> callc env n tail + | SEXP (t, n) -> + let s, env = env#allocate in + let env, code = call env ".sexp" (n + 1) false in + (env, [ Mov (L (box (env#hash t)), s) ] @ code) + | DROP -> (snd env#pop, []) + | DUP -> + let x = env#peek in + let s, env = env#allocate in + (env, mov x s) + | SWAP -> + let x, y = env#peek2 in + (env, [ Push x; Push y; Pop x; Pop y ]) + | TAG (t, n) -> + let s1, env = env#allocate in + let s2, env = env#allocate in + let env, code = call env ".tag" 3 false in + ( env, + [ Mov (L (box (env#hash t)), s1); Mov (L (box n), s2) ] @ code + ) + | ARRAY n -> + let s, env = env#allocate in + let env, code = call env ".array_patt" 2 false in + (env, [ Mov (L (box n), s) ] @ code) + | PATT StrCmp -> call env ".string_patt" 2 false + | PATT patt -> + call env + (match patt with + | Boxed -> ".boxed_patt" + | UnBoxed -> ".unboxed_patt" + | Array -> ".array_tag_patt" + | String -> ".string_tag_patt" + | Sexp -> ".sexp_tag_patt" + | Closure -> ".closure_tag_patt" + | StrCmp -> + failwith + (Printf.sprintf "Unexpected pattern: StrCmp %s: %d" + __FILE__ __LINE__)) + 1 false + | LINE line -> env#gen_line line + | FAIL ((line, col), value) -> + let v, env = if value then (env#peek, env) else env#pop in + let s, env = env#string cmd#get_infile in + ( env, + [ + Push (L (box col)); + Push (L (box line)); + Push (M ("$" ^ s)); + Push v; + Call "Bmatch_failure"; + Binop ("+", L (4 * word_size), esp); + ] ) + | i -> + invalid_arg + (Printf.sprintf "invalid SM insn: %s\n" (GT.show insn i)) in let env'', code'' = compile' env' scode' in - env'', [Meta (Printf.sprintf "# %s / % s" (GT.show(SM.insn) instr) stack)] @ code' @ code'' + ( env'', + [ Meta (Printf.sprintf "# %s / %s" (GT.show SM.insn instr) stack) ] + @ code' @ code'' ) in compile' env code - + (* A set of strings *) module S = Set.Make (String) @@ -592,57 +686,50 @@ module M = Map.Make (String) (* Environment implementation *) class env prg = - let chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'" in - let make_assoc l i = List.combine l (List.init (List.length l) (fun x -> x + i)) in - let rec assoc x = function [] -> raise Not_found | l :: ls -> try List.assoc x l with Not_found -> assoc x ls in + let chars = + "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'" + in + (* let make_assoc l i = + List.combine l (List.init (List.length l) (fun x -> x + i)) + in *) + (* let rec assoc x = function + | [] -> raise Not_found + | l :: ls -> ( try List.assoc x l with Not_found -> assoc x ls) + in *) object (self) inherit SM.indexer prg - val globals = S.empty (* a set of global variables *) - val stringm = M.empty (* a string map *) - val scount = 0 (* string count *) - val stack_slots = 0 (* maximal number of stack positions *) - - val static_size = 0 (* static data size *) - val stack = [] (* symbolic stack *) - val nargs = 0 (* number of function arguments *) - val locals = [] (* function local variables *) - val fname = "" (* function name *) - val stackmap = M.empty (* labels to stack map *) - val barrier = false (* barrier condition *) + val globals = S.empty (* a set of global variables *) + val stringm = M.empty (* a string map *) + val scount = 0 (* string count *) + val stack_slots = 0 (* maximal number of stack positions *) + val static_size = 0 (* static data size *) + val stack = [] (* symbolic stack *) + val nargs = 0 (* number of function arguments *) + val locals = [] (* function local variables *) + val fname = "" (* function name *) + val stackmap = M.empty (* labels to stack map *) + val barrier = false (* barrier condition *) val max_locals_size = 0 - val has_closure = false - val publics = S.empty - val externs = S.empty - val nlabels = 0 - val first_line = true - + val has_closure = false + val publics = S.empty + val externs = S.empty + val nlabels = 0 + val first_line = true method publics = S.elements publics - - method register_public name = {< publics = S.add name publics >} - method register_extern name = {< externs = S.add name externs >} - + method register_public name = {} + method register_extern name = {} method max_locals_size = max_locals_size - method has_closure = has_closure - - method save_closure = - if has_closure then [Push edx] else [] - - method rest_closure = - if has_closure then [Pop edx] else [] - - method reload_closure = - if has_closure then [Mov (C (*S 0*), edx)] else [] - + method save_closure = if has_closure then [ Push edx ] else [] + method rest_closure = if has_closure then [ Pop edx ] else [] + method reload_closure = if has_closure then [ Mov (C (*S 0*), edx) ] else [] method fname = fname - + method leave = - if stack_slots > max_locals_size - then {< max_locals_size = stack_slots >} + if stack_slots > max_locals_size then {} else self - method show_stack = - GT.show(list) (GT.show(opnd)) stack + method show_stack = GT.show list (GT.show opnd) stack method print_locals = Printf.printf "LOCALS: size = %d\n" static_size; @@ -650,8 +737,8 @@ class env prg = (fun l -> Printf.printf "("; List.iter (fun (a, i) -> Printf.printf "%s=%d " a i) l; - Printf.printf ")\n" - ) locals; + Printf.printf ")\n") + locals; Printf.printf "END LOCALS\n" (* Assert empty stack *) @@ -661,107 +748,113 @@ class env prg = method is_barrier = barrier (* set barrier *) - method set_barrier = {< barrier = true >} + method set_barrier = {} (* drop barrier *) - method drop_barrier = {< barrier = false >} + method drop_barrier = {} (* drop stack *) - method drop_stack = {< stack = [] >} + method drop_stack = {} (* associates a stack to a label *) - method set_stack l = (*Printf.printf "Setting stack for %s\n" l;*) - {< stackmap = M.add l stack stackmap >} + method set_stack l = + (*Printf.printf "Setting stack for %s\n" l;*) + {} (* retrieves a stack for a label *) - method retrieve_stack l = (*Printf.printf "Retrieving stack for %s\n" l;*) - try {< stack = M.find l stackmap >} with Not_found -> self + method retrieve_stack l = + (*Printf.printf "Retrieving stack for %s\n" l;*) + try {} with Not_found -> self (* checks if there is a stack for a label *) - method has_stack l = (*Printf.printf "Retrieving stack for %s\n" l;*) + method has_stack l = + (*Printf.printf "Retrieving stack for %s\n" l;*) M.mem l stackmap (* gets a name for a global variable *) method loc x = match x with | Value.Global name -> M ("global_" ^ name) - | Value.Fun name -> M ("$" ^ name) - | Value.Local i -> S i - | Value.Arg i -> S (- (i + if has_closure then 2 else 1)) - | Value.Access i -> I (word_size * (i+1), edx) - + | Value.Fun name -> M ("$" ^ name) + | Value.Local i -> S i + | Value.Arg i -> S (-(i + if has_closure then 2 else 1)) + | Value.Access i -> I (word_size * (i + 1), edx) + (* allocates a fresh position on a symbolic stack *) method allocate = let x, n = - let rec allocate' = function - | [] -> ebx , 0 - | (S n)::_ -> S (n+1) , n+2 - | (R n)::_ when n < num_of_regs -> R (n+1) , stack_slots - | _ -> S static_size, static_size+1 + let allocate' = function + | [] -> (ebx, 0) + | S n :: _ -> (S (n + 1), n + 2) + | R n :: _ when n < num_of_regs -> (R (n + 1), stack_slots) + | _ -> (S static_size, static_size + 1) in allocate' stack in - x, {< stack_slots = max n stack_slots; stack = x::stack >} + (x, {}) (* pushes an operand to the symbolic stack *) - method push y = {< stack = y::stack >} + method push y = {} (* pops one operand from the symbolic stack *) - method pop = let x::stack' = stack in x, {< stack = stack' >} + method pop = + let[@ocaml.warning "-8"] (x :: stack') = stack in + (x, {}) (* pops two operands from the symbolic stack *) - method pop2 = let x::y::stack' = stack in x, y, {< stack = stack' >} + method pop2 = + let[@ocaml.warning "-8"] (x :: y :: stack') = stack in + (x, y, {}) (* peeks the top of the stack (the stack does not change) *) method peek = List.hd stack (* peeks two topmost values from the stack (the stack itself does not change) *) - method peek2 = let x::y::_ = stack in x, y + method peek2 = + let[@ocaml.warning "-8"] (x :: y :: _) = stack in + (x, y) (* tag hash: gets a hash for a string tag *) method hash tag = - let h = Pervasives.ref 0 in + let h = Stdlib.ref 0 in for i = 0 to min (String.length tag - 1) 4 do - h := (!h lsl 6) lor (String.index chars tag.[i]) + h := (!h lsl 6) lor String.index chars tag.[i] done; !h (* registers a variable in the environment *) method variable x = match x with - | Value.Global name -> {< globals = S.add ("global_" ^ name) globals >} - | _ -> self + | Value.Global name -> {} + | _ -> self (* registers a string constant *) method string x = let escape x = - let n = String.length x in - let buf = Buffer.create (n*2) in + let n = String.length x in + let buf = Buffer.create (n * 2) in let rec iterate i = - if i < n - then ( + if i < n then ( (match x.[i] with - | '"' -> Buffer.add_string buf "\\\"" + | '"' -> Buffer.add_string buf "\\\"" | '\n' -> Buffer.add_string buf "\n" | '\t' -> Buffer.add_string buf "\t" - | c -> Buffer.add_char buf c - ); - iterate (i+1) - ) + | c -> Buffer.add_char buf c); + iterate (i + 1)) in iterate 0; Buffer.contents buf in let x = escape x in - try M.find x stringm, self + try (M.find x stringm, self) with Not_found -> let y = Printf.sprintf "string_%d" scount in let m = M.add x y stringm in - y, {< scount = scount + 1; stringm = m>} + (y, {}) (* gets number of arguments in the current function *) method nargs = nargs - + (* gets all global variables *) method globals = S.elements (S.diff globals externs) @@ -770,108 +863,146 @@ class env prg = (* gets a number of stack positions allocated *) method allocated = stack_slots - method allocated_size = Printf.sprintf "LS%s_SIZE" fname - + (* enters a function *) method enter f nargs nlocals has_closure = - {< nargs = nargs; static_size = nlocals; stack_slots = nlocals; stack = []; fname = f; has_closure = has_closure; first_line = true >} + {} (* returns a label for the epilogue *) method epilogue = Printf.sprintf "L%s_epilogue" fname (* returns a name for local size meta-symbol *) method lsize = Printf.sprintf "L%s_SIZE" fname - + (* returns a list of live registers *) method live_registers depth = let rec inner d acc = function - | [] -> acc - | (R _ as r)::tl -> inner (d+1) (if d >= depth then (r::acc) else acc) tl - | _::tl -> inner (d+1) acc tl + | [] -> acc + | (R _ as r) :: tl -> + inner (d + 1) (if d >= depth then r :: acc else acc) tl + | _ :: tl -> inner (d + 1) acc tl in inner 0 [] stack (* generate a line number information for current function *) method gen_line line = let lab = Printf.sprintf ".L%d" nlabels in - {< nlabels = nlabels + 1; first_line = false >}, - if fname = "main" - then - [Meta (Printf.sprintf "\t.stabn 68,0,%d,%s" line lab); Label lab] - else - (if first_line then [Meta (Printf.sprintf "\t.stabn 68,0,%d,0" line)] else []) @ - [Meta (Printf.sprintf "\t.stabn 68,0,%d,%s-%s" line lab fname); Label lab] - + ( {}, + if fname = "main" then + [ Meta (Printf.sprintf "\t.stabn 68,0,%d,%s" line lab); Label lab ] + else + (if first_line then + [ Meta (Printf.sprintf "\t.stabn 68,0,%d,0" line) ] + else []) + @ [ + Meta (Printf.sprintf "\t.stabn 68,0,%d,%s-%s" line lab fname); + Label lab; + ] ) end (* Generates an assembler text for a program: first compiles the program into the stack code, then generates x86 assember code, then prints the assembler file *) let genasm cmd prog = - let sm = SM.compile cmd prog in + let sm = SM.compile cmd prog in let env, code = compile cmd (new env sm) (fst (fst prog)) sm in let globals = List.map (fun s -> Meta (Printf.sprintf "\t.globl\t%s" s)) env#publics in - let data = [Meta "\t.data"] @ - (List.map (fun (s, v) -> Meta (Printf.sprintf "%s:\t.string\t\"%s\"" v s)) env#strings) @ - [Meta "_init:\t.int 0"; - Meta "\t.section custom_data,\"aw\",@progbits"; - Meta (Printf.sprintf "filler:\t.fill\t%d, 4, 1" env#max_locals_size)] @ - (List.concat @@ - List.map - (fun s -> [Meta (Printf.sprintf "\t.stabs \"%s:S1\",40,0,0,%s" (String.sub s (String.length "global_") (String.length s - String.length "global_")) s); - Meta (Printf.sprintf "%s:\t.int\t1" s)]) - env#globals - ) + let data = + [ Meta "\t.data" ] + @ List.map + (fun (s, v) -> Meta (Printf.sprintf "%s:\t.string\t\"%s\"" v s)) + env#strings + @ [ + Meta "_init:\t.int 0"; + Meta "\t.section custom_data,\"aw\",@progbits"; + Meta (Printf.sprintf "filler:\t.fill\t%d, 4, 1" env#max_locals_size); + ] + @ List.concat + @@ List.map + (fun s -> + [ + Meta + (Printf.sprintf "\t.stabs \"%s:S1\",40,0,0,%s" + (String.sub s (String.length "global_") + (String.length s - String.length "global_")) + s); + Meta (Printf.sprintf "%s:\t.int\t1" s); + ]) + env#globals in let asm = Buffer.create 1024 in List.iter (fun i -> Buffer.add_string asm (Printf.sprintf "%s\n" @@ show i)) - ([Meta (Printf.sprintf "\t.file \"%s\"" cmd#get_absolute_infile); - Meta (Printf.sprintf "\t.stabs \"%s\",100,0,0,.Ltext" cmd#get_absolute_infile)] @ - globals @ - data @ - [Meta "\t.text"; Label ".Ltext"; Meta "\t.stabs \"data:t1=r1;0;4294967295;\",128,0,0,0"] @ - code); + ([ + Meta (Printf.sprintf "\t.file \"%s\"" cmd#get_absolute_infile); + Meta + (Printf.sprintf "\t.stabs \"%s\",100,0,0,.Ltext" + cmd#get_absolute_infile); + ] + @ globals @ data + @ [ + Meta "\t.text"; + Label ".Ltext"; + Meta "\t.stabs \"data:t1=r1;0;4294967295;\",128,0,0,0"; + ] + @ code); Buffer.contents asm let get_std_path () = - match Sys.getenv_opt "LAMA" with - | Some s -> s - | None -> Stdpath.path - + match Sys.getenv_opt "LAMA" with Some s -> s | None -> Stdpath.path + (* Builds a program: generates the assembler file and compiles it with the gcc toolchain *) let build cmd prog = let find_objects imports paths = let module S = Set.Make (String) in let rec iterate acc s = function - | [] -> acc - | import::imports -> - if S.mem import s - then iterate acc s imports - else - let path, intfs = Interface.find import paths in - iterate - ((Filename.concat path (import ^ ".o")) :: acc) - (S.add import s) - ((List.map (function `Import name -> name | _ -> invalid_arg "must not happen") @@ - List.filter (function `Import _ -> true | _ -> false) intfs) @ - imports) + | [] -> acc + | import :: imports -> + if S.mem import s then iterate acc s imports + else + let path, intfs = Interface.find import paths in + iterate + (Filename.concat path (import ^ ".o") :: acc) + (S.add import s) + ((List.map (function + | `Import name -> name + | _ -> invalid_arg "must not happen") + @@ List.filter (function `Import _ -> true | _ -> false) intfs) + @ imports) in iterate [] (S.add "Std" S.empty) imports in cmd#dump_file "s" (genasm cmd prog); cmd#dump_file "i" (Interface.gen prog); - let inc = get_std_path () in + let inc = get_std_path () in + let compiler = "gcc" in + let flags = "-no-pie -m32" in match cmd#get_mode with | `Default -> - let objs = find_objects (fst @@ fst prog) cmd#get_include_paths in - let buf = Buffer.create 255 in - List.iter (fun o -> Buffer.add_string buf o; Buffer.add_string buf " ") objs; - let gcc_cmdline = Printf.sprintf "gcc %s -m32 %s %s.s %s %s/runtime.a" cmd#get_debug cmd#get_output_option cmd#basename (Buffer.contents buf) inc in - Sys.command gcc_cmdline + let objs = find_objects (fst @@ fst prog) cmd#get_include_paths in + let buf = Buffer.create 255 in + List.iter + (fun o -> + Buffer.add_string buf o; + Buffer.add_string buf " ") + objs; + let gcc_cmdline = + Printf.sprintf "%s %s %s %s %s.s %s %s/runtime.a" compiler flags + cmd#get_debug cmd#get_output_option cmd#basename (Buffer.contents buf) + inc + in + Sys.command gcc_cmdline | `Compile -> - Sys.command (Printf.sprintf "gcc %s -m32 -c %s.s" cmd#get_debug cmd#basename) + Sys.command + (Printf.sprintf "%s %s %s -c %s.s" compiler flags cmd#get_debug + cmd#basename) | _ -> invalid_arg "must not happen" diff --git a/src/dune b/src/dune new file mode 100644 index 000000000..f99f6c3fb --- /dev/null +++ b/src/dune @@ -0,0 +1,111 @@ +(env + (dev + (flags + (:standard -warn-error -3-7-8-13-15-20-26-27-32-33-39)))) + +(rule + (targets version.ml) + (action + (progn + (with-stdout-to + version2.ml + (progn + (run echo let version = "\"") + (run echo Version) + (run git rev-parse --abbrev-ref HEAD) + (run echo , " ") + (run git rev-parse --short HEAD) + (run echo , " ") + (pipe-stdout + (run git rev-parse --verify HEAD) + (run git show --no-patch --no-notes --pretty='%cd')) + (run echo "\""))) + (with-stdout-to + version.ml + (pipe-stdout + (run cat version2.ml) + (run tr -d '\n')))))) + +(rule + (targets stdpath.ml) + (action + (progn + (with-stdout-to + stdpath2.ml + (progn + (run echo let path = "\"") + (run opam var share) + (run echo /Lama) + (run echo "\""))) + (with-stdout-to + stdpath.ml + (pipe-stdout + (run cat stdpath2.ml) + (run tr -d '\n')))))) + +(library + (name liba) + (modules Language Pprinter stdpath version X86 SM) + (libraries GT ostap) + (flags + (:standard + -rectypes + ;-dsource + )) + ; (ocamlopt_flags + ; (:standard -dsource)) + (wrapped false) + (preprocess + (per_module + ((pps GT.ppx_all) + SM + X86) + ((action + (run %{project_root}/src/pp5+gt+plugins+ostap+dump.byte %{input-file})) + Language + Pprinter + stdpath + version))) + (preprocessor_deps + (file %{project_root}/src/pp5+gt+plugins+ostap+dump.byte) + ;(file %{project_root}/src/pp5+gt+plugins+ostap+dump.exe) + ) + ;(inline_tests) + ) + +(executable + (name Driver) + (flags + (:standard + -rectypes + ;-dsource + )) + (modules Driver) + (libraries liba unix)) + +; (rule +; (targets pp5+gt+plugins+ostap+dump.exe) +; (deps +; (package GT)) +; (action +; (run +; mkcamlp5.opt +; -package +; camlp5,camlp5.pa_o,camlp5.pr_dump,camlp5.extend,camlp5.quotations,ostap.syntax,GT.syntax.all,GT.syntax +; -o +; %{targets}))) + +(rule + (targets pp5+gt+plugins+ostap+dump.byte) + (deps + (package GT)) + (action + (run + mkcamlp5 + -package + camlp5,camlp5.pa_o,camlp5.pr_o,ostap.syntax,GT.syntax.all,GT.syntax + -o + %{targets}))) + +(cram + (deps ./Driver.exe))