diff --git a/Makefile b/Makefile index e9ea331aa..e7e2e6eea 100644 --- a/Makefile +++ b/Makefile @@ -31,5 +31,5 @@ clean: make clean -C runtime make clean -C stdlib make clean -C regression - + $(MAKE) clean -C bench diff --git a/src/Driver.ml b/src/Driver.ml index 8b1322555..6213d941e 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -1,60 +1,27 @@ -open Ostap - -let parse cmd = - let s = Util.read cmd#get_infile in - let kws = [ - "skip"; - "if"; "then"; "else"; "elif"; "fi"; - "while"; "do"; "od"; - "repeat"; "until"; - "for"; - "fun"; "local"; "public"; "external"; "return"; "import"; - "length"; - "string"; - "case"; "of"; "esac"; "when"; - "boxed"; "unboxed"; "string"; "sexp"; "array"; - "infix"; "infixl"; "infixr"; "at"; "before"; "after"; - "true"; "false"; "lazy"; "eta"; "syntax"] - in - Util.parse - (object - inherit Matcher.t s - inherit Util.Lexers.decimal s - inherit Util.Lexers.string s - inherit Util.Lexers.char s - inherit Util.Lexers.infix s - inherit Util.Lexers.lident kws s - inherit Util.Lexers.uident kws s - inherit Util.Lexers.skip [ - Matcher.Skip.whitespaces " \t\n\r"; - Matcher.Skip.lineComment "--"; - Matcher.Skip.nestedComment "(*" "*)" - ] s - end - ) - (if cmd#is_workaround then ostap (p:!(Language.constparse cmd) -EOF) else ostap (p:!(Language.parse cmd) -EOF)) - exception Commandline_error of string - + class options args = let n = Array.length args in - let dump_ast = 1 in - let dump_sm = 2 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" ^ + " -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" ^ " -v --- show version\n" ^ - " -h --- show this help\n" + " -h --- show this help\n" in object (self) val version = ref false @@ -84,6 +51,7 @@ class options args = | "-s" -> self#set_mode `SM | "-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 @@ -97,12 +65,12 @@ class options args = | None -> () in loop () (* Workaround until Ostap starts to memoize properly *) - method is_workaround = !const + method is_workaround = !const method private set_workaround = const := true (* end of the workaround *) method private set_help = help := true - method private set_version = version := true + method private set_version = version := true method private set_dump mask = dump := !dump lor mask method private set_infile name = @@ -160,7 +128,11 @@ class options args = Buffer.add_string buf ""; self#dump_file "html" (Buffer.contents buf) ) - else () + 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) @@ -169,42 +141,43 @@ class options args = (match !outfile with | 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 + debug := true end - + let main = - try + try let cmd = new options Sys.argv in cmd#greet; - match (try parse cmd with Language.Semantic_error msg -> `Fail msg) with + 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 - | _ -> + | _ -> let rec read acc = try let r = read_int () in Printf.printf "> "; read (acc @ [r]) with End_of_file -> acc - in + 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 + 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 + | 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 e138ad3bb..403f6b579 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -294,7 +294,7 @@ module Pattern = (* any sexp value *) | SexpTag (* any array value *) | ArrayTag (* any closure *) | ClosureTag - with show, foldl, html + with show, foldl, html, fmt (* Pattern parser *) ostap ( @@ -349,6 +349,10 @@ module Expr = (* The type for expressions. Note, in regular OCaml there is no "@type..." notation, it came from GT. *) + + @type qualifier = [ `Local | `Public | `Extern | `PublicExtern ] + with show, html + @type t = (* integer constant *) | Const of int (* array *) | Array of t list @@ -377,7 +381,7 @@ module Expr = (* leave a scope *) | Leave (* intrinsic (for evaluation) *) | Intrinsic of (t config, t config) arrow (* control (for control flow) *) | Control of (t config, t * t config) arrow - and decl = [`Local | `Public | `Extern | `PublicExtern ] * [`Fun of string list * t | `Variable of t option] + and decl = qualifier * [`Fun of string list * t | `Variable of t option] with show, html let notRef = function Reff -> false | _ -> true @@ -1250,3 +1254,39 @@ let parse cmd = ) in parse cmd + + +let run_parser cmd = + let s = Util.read cmd#get_infile in + let kws = [ + "skip"; + "if"; "then"; "else"; "elif"; "fi"; + "while"; "do"; "od"; + "repeat"; "until"; + "for"; + "fun"; "local"; "public"; "external"; "return"; "import"; + "length"; + "string"; + "case"; "of"; "esac"; "when"; + "boxed"; "unboxed"; "string"; "sexp"; "array"; + "infix"; "infixl"; "infixr"; "at"; "before"; "after"; + "true"; "false"; "lazy"; "eta"; "syntax"] + in + Util.parse + (object + inherit Matcher.t s + inherit Util.Lexers.decimal s + inherit Util.Lexers.string s + inherit Util.Lexers.char s + inherit Util.Lexers.infix s + inherit Util.Lexers.lident kws s + inherit Util.Lexers.uident kws s + inherit Util.Lexers.skip [ + Matcher.Skip.whitespaces " \t\n\r"; + Matcher.Skip.lineComment "--"; + Matcher.Skip.nestedComment "(*" "*)" + ] s + end + ) + (if cmd#is_workaround then ostap (p:!(constparse cmd) -EOF) else ostap (p:!(parse cmd) -EOF)) + diff --git a/src/Makefile b/src/Makefile index 6e998215f..ed77617e0 100644 --- a/src/Makefile +++ b/src/Makefile @@ -2,12 +2,11 @@ TOPFILE = lamac OCAMLC = ocamlfind c OCAMLOPT = ocamlfind opt OCAMLDEP = ocamlfind dep -SOURCES = version.ml stdpath.ml Language.ml SM.ml X86.ml Driver.ml +SOURCES = version.ml stdpath.ml Language.ml Pprinter.ml SM.ml X86.ml Driver.ml CAMLP5 = -syntax camlp5o -package ostap.syntax,GT.syntax.all PXFLAGS = $(CAMLP5) -BFLAGS = -rectypes -g +BFLAGS = -rectypes -g -w -13-58 -package ostap,unix OFLAGS = $(BFLAGS) -LIBS = unix.cma all: depend metagen $(TOPFILE) @@ -19,10 +18,10 @@ depend: $(SOURCES) $(OCAMLDEP) $(PXFLAGS) *.ml > .depend $(TOPFILE): $(SOURCES:.ml=.cmx) - $(OCAMLOPT) -o $(TOPFILE) $(OFLAGS) $(LIBS:.cma=.cmxa) -linkpkg -package ostap $(SOURCES:.ml=.cmx) + $(OCAMLOPT) -o $(TOPFILE) $(OFLAGS) -linkpkg $(SOURCES:.ml=.cmx) $(TOPFILE).byte: $(SOURCES:.ml=.cmo) - $(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) $(LIBS) -linkpkg -package ostap $(SOURCES:.ml=.cmo) + $(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) -linkpkg $(SOURCES:.ml=.cmo) clean: rm -Rf *.cmi *.cmo *.cmx *.annot *.o *.opt *.byte *~ .depend diff --git a/src/Pprinter.ml b/src/Pprinter.ml new file mode 100644 index 000000000..b4e0aac95 --- /dev/null +++ b/src/Pprinter.ml @@ -0,0 +1,195 @@ +open Language + +class pp_pattern fself = object + inherit [Format.formatter, Pattern.t, unit] Pattern.t_t + + method c_Wildcard ppf _ = Format.fprintf ppf "_" + method c_Const ppf _ = Format.fprintf ppf "%d" + method c_Named ppf _ name _ = + (* TODO: should I ignore another argument? *) + Format.fprintf ppf "%s" name + method c_Sexp ppf _ name xs = + match name,xs with + | "cons", [l; r] -> + Format.fprintf ppf "%a@ :@ %a" fself l fself r + | _ -> + Format.fprintf ppf "@[%s@ (" name; + xs |> List.iter (Format.fprintf ppf "%a@ " fself); + Format.fprintf ppf ")@] " + + method c_Array ppf _ xs = + Format.fprintf ppf "@[{ "; + Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ", ") + fself ppf xs; + Format.fprintf ppf " }@]" + + method c_ArrayTag ppf _ = Format.fprintf ppf "#array" + method c_SexpTag ppf _ = Format.fprintf ppf "#sexp" + method c_ClosureTag ppf _ = Format.fprintf ppf "#fun" + method c_UnBoxed ppf _ = failwith "not implemented" + method c_String ppf _ = failwith "not implemented" + method c_StringTag ppf _ = failwith "not implemented" + method c_Boxed ppf _ = failwith "not implemented" +end + +let pp_pattern fmt p = + GT.transform Pattern.t (new pp_pattern) fmt p + +class pp_expr on_decl fself = +object + inherit [Format.formatter, Expr.t, unit] Expr.t_t + method c_Const ppf _ = Format.fprintf ppf "%d" + method c_Var ppf _ = Format.fprintf ppf "%s" + method c_Ref ppf _ = Format.fprintf ppf "%s" + method c_Array ppf _ xs = + Format.fprintf ppf "@[{@ "; + xs |> List.iteri (fun i -> + if i<>0 then Format.fprintf ppf ",@ "; + fself ppf); + Format.fprintf ppf " }@]" + method c_String ppf _ s = Format.fprintf ppf "\"%s\"" s + + method c_Sexp ppf _ name xs = + match name,xs with + | "cons", [l;r] -> Format.fprintf ppf "@[%a : %a@]" fself l fself r + | _ -> + Format.fprintf ppf "@[%s@ (" name; + xs |> List.iteri (fun i x -> + if i<>0 then Format.fprintf ppf ", "; + fself ppf x + ); + Format.fprintf ppf ")@]" + + method c_Binop ppf _ op l r = + Format.fprintf ppf "@[%a@ %s@ %a@]" fself l op fself r + method c_Elem ppf _ l idx = + Format.fprintf ppf "%a[%a]" fself l fself idx + method c_ElemRef ppf _ l idx = + (* TODO: should Elem and ElemRef be the same? *) + Format.fprintf ppf "%a[%a]" fself l fself idx + method c_Length ppf _ e = + Format.fprintf ppf "@[(%a).length@]" fself e + method c_StringVal ppf _ _x__519_ = + Format.fprintf ppf "StringVal @[(@,%a@,)@]" fself _x__519_ + method c_Call ppf _ f args = + Format.fprintf ppf "@[%a @[(" fself f; + args |> List.iteri (fun i arg -> + Format.fprintf ppf "%s%a" (if i<>0 then ", " else "") fself arg + ); + Format.fprintf ppf ")@]@]" + + + method c_Assign ppf _ _x__526_ _x__527_ = + Format.fprintf ppf "@[%a@ :=@ %a@]" fself _x__526_ fself _x__527_ + method c_Seq ppf _ l r = + Format.fprintf ppf "@[%a;@ %a@]" fself l fself r + method c_Skip ppf _ = Format.fprintf ppf "skip" + method c_If ppf _ _x__533_ _x__534_ _x__535_ = + Format.fprintf ppf "@[if %a then @[{@,%a@]@ @[} else {@,%a@]@ } fi@]" + fself _x__533_ fself _x__534_ fself _x__535_ + method c_While ppf _ cond body = + Format.fprintf ppf "@["; + Format.fprintf ppf "while %a do@," fself cond; + fself ppf body; + Format.fprintf ppf "@]@ "; + Format.fprintf ppf "od"; + (*Format.fprintf inh___536_ "While @[(@,%a,@,@ %a@,)@]" fself + cond fself body*) + method c_Repeat ppf _ cond body = + Format.fprintf ppf "@["; + Format.fprintf ppf "repeat@,%a" fself body; + Format.fprintf ppf "until %a@]" fself cond + + + method c_Case ppf _ scru cases _ _ = + Format.fprintf ppf "@["; + Format.fprintf ppf "@[case %a of@ @]@," fself scru; + Format.fprintf ppf "@["; + cases |> List.iteri (fun i (p,e) -> + Format.fprintf ppf "@[%s %a@ ->@ %a@]@ " (if i=0 then " " else "|") pp_pattern p fself e + ); + Format.fprintf ppf "@]"; + Format.fprintf ppf "@[esac@]"; + Format.fprintf ppf "@]" + + + method c_Return ppf _ e = + match e with + | None -> Format.fprintf ppf "return" + | Some e -> Format.fprintf ppf "@[return@ %a@]" fself e + + method c_Ignore ppf _ e = + Format.fprintf ppf "@[%a@]" fself e + method c_Unit ppf _ = Format.fprintf ppf "Unit " + method c_Scope ppf _ xs body = + Format.fprintf ppf "@["; + Format.pp_print_list ~pp_sep:(fun fmt () -> ()) + (fun ppf (name, d) -> + Format.fprintf ppf "@[%a@]@," (fun ppf -> on_decl (name,ppf)) d) + ppf xs; + fself ppf body; + Format.fprintf ppf "@]" + + method c_Lambda ppf _ args body = + Format.fprintf ppf "@[fun (%a) { %a }@]" + (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_text) + args + fself + body + + method c_Leave ppf _ = Format.fprintf ppf "Leave " + method c_Intrinsic ppf _ _ = + Format.fprintf ppf "Intrinsic" + + method c_Control ppf _ _ = + Format.fprintf ppf "Control" + +end + +class pp_decl fself on_expr = object(self) + inherit [ (string*Format.formatter), _, unit] Expr.decl_t + method qualifier ppf : Expr.qualifier -> _ = function + | `Local -> () + | `Extern -> Format.fprintf ppf "extern@ " + | `Public -> Format.fprintf ppf "public@ " + | `PublicExtern -> Format.fprintf ppf "not implemented %d" __LINE__ + + method args ppf = + Format.fprintf ppf "%a" @@ + Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",") + (Format.pp_print_text) + + method c_DECL (name,ppf) (qual, (item: [`Fun of string list * Expr.t | `Variable of Expr.t GT.option])) = + match item with + | `Variable(None) -> Format.fprintf ppf "local %s;" name + | `Variable(Some e) -> + Format.fprintf ppf "local %s = %a;" name on_expr e + | `Fun (ss,e) -> + Format.fprintf ppf "@["; + Format.fprintf ppf "@[%afun %s (%a) @]@," self#qualifier qual name self#args ss; + Format.fprintf ppf "@[{@,@[%a@]@]@ " on_expr e; + Format.fprintf ppf "}"; + Format.fprintf ppf "@]" + +end + + +let fix_decl decl0 t0 = + let rec traitdecl inh subj = + Expr.gcata_decl (decl0 traitdecl traitt) inh subj + and traitt inh subj = + Expr.gcata_t (t0 traitdecl traitt) inh subj + in + (traitdecl, traitt) + +let pp fmt s = + snd (fix_decl (new pp_decl) (new pp_expr)) fmt s + +let pp ppf ast = + let margin = + try int_of_string @@ Sys.getenv "LAMA_MARGIN" + with Failure _ | Not_found -> 35 + in + Format.set_margin margin; + Format.set_max_indent 15; + Format.printf "%a\n%!" pp ast