diff --git a/doc/spec/01.general_characteristic.tex b/doc/spec/01.general_characteristic.tex new file mode 100644 index 000000000..e4000c073 --- /dev/null +++ b/doc/spec/01.general_characteristic.tex @@ -0,0 +1,13 @@ +\section{General Characteristic of the Language} + +\begin{itemize} +\item procedural with first-class functions~--- functions can be passed as arguments, placed in data structures, + returned and constructed at runtime via closures mechanism; +\item with lexical static scoping; +\item strict~--- all arguments of function application are evaluated before function's body; +\item imperative~--- variables can be re-assigned, function calls can have side effects; +\item untyped~--- no static type checking is performed; +\item supports S-expressions and pattern-matching; +\item supports user-defined infix operators, including those defined in local scopes; +\item with automatic memory management (garbage collection). +\end{itemize} diff --git a/doc/spec/02.notation.tex b/doc/spec/02.notation.tex new file mode 100644 index 000000000..8ae0fb166 --- /dev/null +++ b/doc/spec/02.notation.tex @@ -0,0 +1,50 @@ +\section{Notation} + +Pairs and tuples: + +\[ +\inbr{\bullet,\,\bullet,\,\dots} +\] + +Lists of elements of kind $X$: + +\[ +X^* +\] + +Deconstructing lists into sublists: + +\[ +h\circ t +\] + +This applies also to lists of length 1. Empty list is denoted + +\[ + \epsilon +\] + + +For a mapping $f : X\to Y$ we use the following definition: + +\[ +f [x\gets y] = \lambda\,z\,.\, +\left\{ +\begin{array}{rcl} + y &,& x = z \\ + f\;x &,& x\neq z +\end{array} +\right. +\] + +Empty mapping (undefined everywhere) is denoted $\Lambda$, the domain of a mapping $f$~--- $\dom{f}$, and we abbreviate + +\[ + \Lambda[x_1\gets y_1][x_2\gets y_2]\dots[x_k\gets y_k] +\] + +as + +\[ + [x_1\gets y_1,\,x_2\gets y_2,\,\dots,\,x_k\gets y_k] +\] diff --git a/doc/spec/03.values.tex b/doc/spec/03.values.tex new file mode 100644 index 000000000..c50fa1006 --- /dev/null +++ b/doc/spec/03.values.tex @@ -0,0 +1,20 @@ +\section{Names, Values and States} + +\begin{table}[t] + \begin{tabular}{cccl} + denotation & instances & definition & comments \\ + \hline + $\mathscr X$ & $x,\,y,\,z,\,\dots$ & & variables \\ + $\mathscr T$ & $\llang{C},\,\llang{D},\,\dots$ & & tags (constructors) \\ + $\Sigma$ & $\sigma$ & $\mathscr X\to\mathscr V$ & bindings (a partial map from variables to values) \\ + $\Sigma_{\mathscr X}$ & $\inbr{\sigma,\,S}$ & $2^{\mathscr X}\times\Sigma$ & local scope (a set of variable and bindings) \\ + $St$ & $\inbr{\sigma_g,\,ss}$ & $\Sigma\times\Sigma^*_{\mathscr X}$ & state (global bindings and a stack of local scopes) \\ + $\mathscr L$ & $l$ & & locations \\ + $M$ & $\mu$ & $\mathscr L\to\mathscr C$ & abstract memory (a partial map from locations to composite values) \\ + $\mathscr V$ & $v$ & $\mathbb Z\uplus \mathscr L$ & values (integer values or locations) \\ + $\mathscr C$ & & $Arr\uplus Sexp \uplus Clo$ & composite values (arrays, S-expressions or closures) \\ + $Arr$ & & $\mathbb N\times (\mathbb N\to\mathscr V)$ & arrays (length and element function) \\ + $Sexp$ & & $\mathscr T \times Arr$ & S-expressions (tag and array of subvalues) \\ + $Clo$ & & $\mathscr X \times \Sigma^*_{\mathscr X}$ & closures (function name and a stack of local scopes) + \end{tabular} +\end{table} diff --git a/doc/spec/spec.tex b/doc/spec/spec.tex index e4f7f8b16..9994f33eb 100644 --- a/doc/spec/spec.tex +++ b/doc/spec/spec.tex @@ -25,6 +25,7 @@ \usepackage{multirow,bigdelim} \usepackage{subcaption} \usepackage{placeins} +\usepackage{xspace} \makeatletter @@ -71,15 +72,12 @@ \renewcommand{\emptyset}{\varnothing} \newcommand{\dom}[1]{\mathtt{dom}\;{#1}} \newcommand{\primi}[2]{\mathbf{#1}\;{#2}} - +\newcommand{\sial}{S\textit{\lower -.5ex\hbox{I}\kern -.1667em\lower .5ex\hbox {A}}\kern -.125emL\@\xspace} \definecolor{light-gray}{gray}{0.90} \newcommand{\graybox}[1]{\colorbox{light-gray}{#1}} -\lstdefinelanguage{ocaml}{ -keywords={let, begin, end, in, match, type, and, fun, -function, try, mod, with, class, object, method, of, rec, repeat, until, -while, not, do, done, as, val, inherit, module, sig, @type, struct, -if, then, else, open, virtual, new, fresh, skip, od, fi, elif, for, local, return, read, write, fi, case, esac, od}, +\lstdefinelanguage{sial}{ +keywords={fun, case, esac, do, od, if, then, else, elif, fi, skip, repeat, until, for, local}, sensitive=true, %basicstyle=\small, commentstyle=\scriptsize\rmfamily, @@ -88,7 +86,7 @@ identifierstyle=\ttfamily, basewidth={0.5em,0.5em}, columns=fixed, fontadjust=true, -literate={->}{{$\to$}}3 {===}{{$\equiv$}}1 {=/=}{{$\not\equiv$}}1 {|>}{{$\triangleright$}}3 {\&\&\&}{{$\wedge$}}2 {|||}{{$\vee$}}2 {^}{{$\uparrow$}}1, +literate={->}{{$\to$}}3, morecomment=[s]{(*}{*)} } @@ -101,16 +99,12 @@ commentstyle=\scriptsize\rmfamily, basewidth={0.5em,0.5em}, fontadjust=true, escapechar=!, -language=ocaml +language=sial } \sloppy -\newcommand{\ocaml}{\texttt{OCaml}\xspace} - -\theoremstyle{definition} - -\title{Introduction to Programming Languages, Compilers and Tools} +\title{\sial Language Definition} \author{Dmitry Boulytchev} @@ -118,13 +112,8 @@ language=ocaml \maketitle -\input{01} -\input{02} -\input{03} -\input{04} -\input{05} -\input{06} -\input{07} -\input{08} +\input{01.general_characteristic} +\input{02.notation} +\input{03.values} \end{document} diff --git a/regression/x86only/test001.expr b/regression/x86only/test001.expr index 998a9d542..2843db667 100644 --- a/regression/x86only/test001.expr +++ b/regression/x86only/test001.expr @@ -1,3 +1,5 @@ +external fun printf (); + fun insert (tree, value) { case tree of Empty -> return Node (value, Empty, Empty) diff --git a/regression/x86only/test002.expr b/regression/x86only/test002.expr index 9f3ecd3b1..a45b43f36 100644 --- a/regression/x86only/test002.expr +++ b/regression/x86only/test002.expr @@ -1,3 +1,5 @@ +external fun printf (); + fun collect_ints_acc (v, tail) { local i; diff --git a/regression/x86only/test003.expr b/regression/x86only/test003.expr index f6a6c05fc..507b45bd8 100644 --- a/regression/x86only/test003.expr +++ b/regression/x86only/test003.expr @@ -1,3 +1,5 @@ +external fun printf (); + local lists = [ {}, {1, 2, 3, 4}, diff --git a/regression/x86only/test004.expr b/regression/x86only/test004.expr index dd6d8f6e5..bf31684d0 100644 --- a/regression/x86only/test004.expr +++ b/regression/x86only/test004.expr @@ -1,3 +1,5 @@ +external fun printf (); + fun hd (l) { case l of h : _ -> return h diff --git a/src/Driver.ml b/src/Driver.ml index d9f26727d..8bd314725 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -8,7 +8,7 @@ let parse infile = "while"; "do"; "od"; "repeat"; "until"; "for"; - "fun"; "local"; "return"; + "fun"; "local"; "public"; "external"; "return"; "length"; "string"; "case"; "of"; "esac"; "when"; @@ -32,36 +32,91 @@ let parse infile = ) (ostap (!(Language.parse Language.Infix.default) -EOF)) +exception Commandline_error of string + +class options args = + let n = Array.length args in + let rec fix f = f (fix f) in + object (self) + val i = ref 1 + val infile = ref (None : string option) + val paths = ref ([] : string list) + val mode = ref (`Default : [`Default | `Eval | `SM | `Compile ]) + val help = ref false + initializer + let rec loop () = + match self#peek with + | Some opt -> + (match opt with + | "-c" -> self#set_mode `Compile + | "-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 + | "-i" -> self#set_mode `Eval + | "-h" -> self#set_help + | _ -> + if opt.[0] = '-' + then raise (Commandline_error (Printf.sprintf "invalid command line specifier ('%s')" opt)) + else self#set_infile opt + ); + loop () + | None -> () + in loop () + 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')) + 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))) + else None + method private set_help = help := true + method get_mode = !mode + method get_infile = + match !infile with + | None -> raise (Commandline_error "input file not specified") + | Some name -> name + method get_help = !help + method get_include_paths = !paths + end + let main = (* try*) - let interpret = Sys.argv.(1) = "-i" in + let cmd = new options Sys.argv in + + (*let interpret = Sys.argv.(1) = "-i" in let stack = Sys.argv.(1) = "-s" in let to_compile = not (interpret || stack) in let infile = Sys.argv.(if not to_compile then 2 else 1) in - match (try parse infile with Language.Semantic_error msg -> `Fail msg) with + *) + match (try parse cmd#get_infile with Language.Semantic_error msg -> `Fail msg) with | `Ok prog -> - if to_compile - then ( - let basename = Filename.chop_suffix infile ".expr" in - ignore @@ X86.build prog basename - ) - else ( - (* Printf.printf "Program:\n%s\n" (GT.show(Language.Expr.t) prog);*) - (*Format.printf "Program\n%s\n%!" (HTML.toHTML ((GT.html(Language.Expr.t)) 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 interpret - then Language.eval prog input - else SM.run (SM.compile prog) input - in - List.iter (fun i -> Printf.printf "%d\n" i) output + (match cmd#get_mode with + | `Default | `Compile -> + ignore @@ X86.build cmd prog + | _ -> + (* Printf.printf "Program:\n%s\n" (GT.show(Language.Expr.t) prog);*) + (*Format.printf "Program\n%s\n%!" (HTML.toHTML ((GT.html(Language.Expr.t)) 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 prog) input + in + List.iter (fun i -> Printf.printf "%d\n" i) output ) | `Fail er -> Printf.eprintf "Error: %s\n" er (* with Invalid_argument _ -> diff --git a/src/Language.ml b/src/Language.ml index 596ef0334..59fea8020 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -328,7 +328,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 = [`Fun of string list * t | `Variable of t option] + and decl = [`Local | `Public | `Extern] * [`Fun of string list * t | `Variable of t option] with show,html (* Reff : parsed expression should return value Reff (look for ":="); @@ -416,11 +416,16 @@ module Expr = let vars, body, bnds = List.fold_left (fun (vs, bd, bnd) -> function - | (name, `Variable value) -> (name, true) :: vs, (match value with None -> bd | Some v -> Seq (Ignore (Assign (Ref name, v)), bd)), bnd - | (name, `Fun (args, b)) -> (name, false) :: vs, bd, (name, Value.FunRef (name, args, b, 1 + State.level st)) :: bnd + | (name, (_, `Variable value)) -> (name, true) :: vs, (match value with None -> bd | Some v -> Seq (Ignore (Assign (Ref name, v)), bd)), bnd + | (name, (_, `Fun (args, b))) -> (name, false) :: vs, bd, (name, Value.FunRef (name, args, b, 1 + State.level st)) :: bnd ) ([], body, []) - (List.rev defs) + (List.rev @@ + List.map (function + | (name, (`Extern, _)) -> raise (Semantic_error (Printf.sprintf "external names ('%s') not supported in evaluation" name)) + | x -> x + ) + defs) in eval (State.push st (State.from_list bnds) vars, i, o, vs) k (Seq (body, Leave)) | Unit -> @@ -447,7 +452,7 @@ module Expr = in eval (st, i, o, v :: vs) Skip k | Ref x -> - eval (st, i, o, (Value.Var (Value.Global x)) :: vs) Skip k + eval (st, i, o, (Value.Var (Value.Global x)) :: vs) Skip k (* only Value.Global is supported in interpretation *) | Array xs -> eval conf k (schedule_list (xs @ [Intrinsic (fun (st, i, o, vs) -> let es, vs' = take (List.length xs) vs in Builtin.eval (st, i, o, vs') (List.rev es) ".array")])) | Sexp (t, xs) -> @@ -700,9 +705,8 @@ module Expr = | %"for" i:parse[def][infix][Void] "," c:parse[def][infix][Val] "," s:parse[def][infix][Void] %"do" b:scope[def][infix][Void][parse def] => {isVoid atr} => %"od" {Seq (i, While (c, Seq (b, s)))} - | %"repeat" s:scope[def][infix][Void][parse def] %"until" e:basic[def][infix][Val] - => {isVoid atr} => {Repeat (s, e)} - | %"return" e:basic[def][infix][Val]? => {isVoid atr} => {Return e} + | %"repeat" s:scope[def][infix][Void][parse def] %"until" e:basic[def][infix][Val] => {isVoid atr} => {Repeat (s, e)} + | %"return" e:basic[def][infix][Val]? => {isVoid atr} => {Return e} | %"case" e:parse[def][infix][Val] %"of" bs:!(Util.listBy1)[ostap ("|")][ostap (!(Pattern.parse) -"->" parse[def][infix][atr])] %"esac" {Case (e, bs)} @@ -792,29 +796,43 @@ module Definition = (* The type for a definition: aither a function/infix, or a local variable *) type t = string * [`Fun of string list * Expr.t | `Variable of Expr.t option] + + let unopt_mod = function None -> `Local | Some m -> m ostap ( - arg : LIDENT; + arg : LIDENT; position[ass][coord][newp]: %"at" s:STRING {Infix.at coord (unquote s) newp} | f:(%"before" {Infix.before} | %"after" {Infix.after}) s:STRING {f coord (unquote s) newp ass}; head[infix]: - %"fun" name:LIDENT {name, infix} - | ass:(%"infix" {`Nona} | %"infixl" {`Lefta} | %"infixr" {`Righta}) + m:(%"external" {`Extern} | %"public" {`Public})? %"fun" name:LIDENT {unopt_mod m, name, name, infix} + | m:(%"public" {`Public})? ass:(%"infix" {`Nona} | %"infixl" {`Lefta} | %"infixr" {`Righta}) l:$ op:(s:STRING {unquote s}) md:position[ass][l#coord][op] { let name = Expr.infix_name op in match md (Expr.sem name) infix with - | `Ok infix' -> name, infix' + | `Ok infix' -> unopt_mod m, op, name, infix' | `Fail msg -> raise (Semantic_error msg) }; - local_var[infix][expr][def]: name:LIDENT value:(-"=" expr[def][infix][Expr.Val])? {name, `Variable value}; + local_var[m][infix][expr][def]: name:LIDENT value:(-"=" expr[def][infix][Expr.Val])? { + match m, value with + | `Extern, Some _ -> raise (Semantic_error (Printf.sprintf "initial value for an external variable '%s' can not be specified" name)) + | _ -> name, (m,`Variable value) + }; parse[infix][expr][def]: - %"local" locs:!(Util.list (local_var infix expr def)) ";" {locs, infix} - | <(name, infix')> : head[infix] "(" args:!(Util.list0 arg) ")" - body:expr[def][infix'][Expr.Void] { - [(name, `Fun (args, body))], infix' - } + m:(%"local" {`Local} | %"public" {`Public} | %"external" {`Extern}) + locs:!(Util.list (local_var m infix expr def)) ";" {locs, infix} + | - <(m, orig_name, name, infix')> : head[infix] -"(" -args:!(Util.list0 arg) -")" + (body:expr[def][infix'][Expr.Void] { + match m with + | `Extern -> raise (Semantic_error (Printf.sprintf "body for an external function '%s' can not be specified" orig_name)) + | _ -> [(name, (m, `Fun (args, body)))], infix' + } | + ";" { + match m with + | `Extern -> [(name, (m, `Fun (args, Expr.Skip)))], infix' + | _ -> raise (Semantic_error (Printf.sprintf "missing body for the function/infix '%s'" orig_name)) + }) ) end @@ -836,8 +854,13 @@ let eval expr i = (* Top-level parser *) ostap ( - parse[infix]: !(Expr.scope definitions infix Expr.Void (Expr.parse definitions)); + parse[infix]: + <(d, infix')> : definitions[infix] expr:!(Expr.parse definitions infix' Expr.Void)? { + Expr.Scope (d, match expr with None -> Expr.Skip | Some e -> e) + }; definitions[infix]: - <(def, infix')> : !(Definition.parse infix Expr.basic definitions) <(defs, infix'')> : definitions[infix'] {def @ defs, infix''} + <(def, infix')> : !(Definition.parse infix Expr.basic definitions) <(defs, infix'')> : definitions[infix'] { + def @ defs, infix'' + } | empty {[], infix} ) diff --git a/src/SM.ml b/src/SM.ml index 9747ac7be..32e5e3654 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -30,6 +30,8 @@ open Language (* 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 +(* external definition *) | EXTERN of string +(* public definition *) | PUBLIC of string with show (* The type for the stack machine program *) @@ -94,6 +96,7 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio Printf.eprintf "end\n"; *) (match insn with + | PUBLIC _ | EXTERN _ -> eval env conf prg' | BINOP op -> let y::x::stack' = stack in eval env (cstack, (Value.of_int @@ Expr.to_func op (Value.to_int x) (Value.to_int y)) :: stack', glob, loc, i, o) prg' | CONST n -> eval env (cstack, (Value.of_int n)::stack, glob, loc, i, o) prg' | STRING s -> eval env (cstack, (Value.of_string @@ Bytes.of_string s)::stack, glob, loc, i, o) prg' @@ -337,12 +340,19 @@ object (self : 'self) val lam_index = 0 val scope = init_scope State.I val fundefs = Top [] - + val decls = [] + + method global_scope = scope_index = 0 + method get_label = (label @@ string_of_int label_index), {< label_index = label_index + 1 >} method nargs = scope.arg_index method nlocals = scope.nlocals - + + method get_decls = + List.map (function (name, `Extern) -> EXTERN name | (name, `Public) -> PUBLIC name | _ -> invalid_arg "must not happen") @@ + List.filter (function (_, `Local) -> false | _ -> true) decls + method push_scope = {< scope_index = scope_index + 1; scope = { @@ -414,8 +424,15 @@ object (self : 'self) arg_index = scope.arg_index + 1 } >} - - method add_name (name : string) (mut : bool) = {< + + method check_scope m name = + match m with + | `Local -> () + | _ -> + raise (Semantic_error (Printf.sprintf "external/public definitions ('%s') not allowed in local scopes" name)) + + method add_name (name : string) (m : [`Local | `Extern | `Public]) (mut : bool) = {< + decls = (name, m) :: decls; scope = { scope with st = (match scope.st with @@ -424,6 +441,7 @@ object (self : 'self) | State.G (names, s) -> State.G (check_name_and_add names name mut, State.bind name (Value.Global name) s) | State.L (names, s, p) -> + self#check_scope m name; State.L (check_name_and_add names name mut, State.bind name (Value.Local scope.local_index) s, p) ); local_index = (match scope.st with State.L _ -> scope.local_index + 1 | _ -> scope.local_index); @@ -434,7 +452,7 @@ object (self : 'self) method fun_internal_name (name : string) = (match scope.st with State.G _ -> label | _ -> scope_label scope_index) name - method add_fun_name (name : string) = + method add_fun_name (name : string) (m : [`Local | `Extern | `Public]) = let name' = self#fun_internal_name name in let st' = match scope.st with @@ -443,9 +461,11 @@ object (self : 'self) | State.G (names, s) -> State.G (check_name_and_add names name false, State.bind name (Value.Fun name') s) | State.L (names, s, p) -> + self#check_scope m name; State.L (check_name_and_add names name false, State.bind name (Value.Fun name') s, p) in {< + decls = (name, m) :: decls; scope = {scope with st = st'} >} @@ -453,11 +473,14 @@ object (self : 'self) 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 >}, name' - method add_fun (name : string) (args : string list) (body : Expr.t) = + method add_fun (name : string) (args : string list) (m : [`Local | `Extern | `Public]) (body : Expr.t) = let name' = self#fun_internal_name name in - {< - fundefs = add_fun fundefs (to_fundef name' args body scope.st) - >} + match m with + | `Extern -> self + | _ -> + {< + fundefs = add_fun fundefs (to_fundef name' args body scope.st) + >} method lookup name = match State.eval scope.st name with @@ -543,7 +566,7 @@ let compile p = let env, code = List.fold_left (fun (env, acc) (name, path) -> - let env = env#add_name name true in + let env = env#add_name name `Local true in let env, dsg = env#lookup name in env, ([DUP] @ @@ -574,14 +597,14 @@ let compile p = List.fold_left (fun (env, e, funs) -> function - | name, `Fun (args, b) -> env#add_fun_name name, e, (name, args, b) :: funs - | name, `Variable None -> env#add_name name true, e, funs - | name, `Variable (Some v) -> env#add_name name true, Expr.Seq (Expr.Ignore (Expr.Assign (Expr.Ref name, v)), e), funs + | name, (m, `Fun (args, b)) -> env#add_fun_name name m, e, (name, args, m, b) :: funs + | name, (m, `Variable None) -> env#add_name name m true, e, funs + | name, (m, `Variable (Some v)) -> env#add_name name m true, Expr.Seq (Expr.Ignore (Expr.Assign (Expr.Ref name, v)), e), funs ) (env, e, []) (List.rev ds) in - let env = List.fold_left (fun env (name, args, b) -> env#add_fun name args b) env funs in + let env = List.fold_left (fun env (name, args, m, b) -> env#add_fun name args m b) env funs in let env, flag, code = compile_expr l env e in env#pop_scope, flag, code @@ -709,6 +732,8 @@ let compile p = let env = new env in let lend, env = env#get_label in let env, flag, code = compile_expr lend env p in - let env, prg = compile_fundefs [[LABEL "main"; BEGIN ("main", 0, env#nlocals, [])] @(if flag then code @ [LABEL lend] else code) @ [END]] env in - let prg = List.flatten prg in + let code = if flag then code @ [LABEL lend] else code in + let has_main = List.length code > 0 in + let env, prg = compile_fundefs [if has_main then [LABEL "main"; BEGIN ("main", 0, env#nlocals, [])] @ code @ [END] else []] env in + let prg = (if has_main then [PUBLIC "main"] else []) @ env#get_decls @ List.flatten prg in prg diff --git a/src/X86.ml b/src/X86.ml index 2d640ccd7..6b82b3cbb 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -217,6 +217,9 @@ let compile env code = let stack = env#show_stack in let env', code' = match instr with + | PUBLIC name -> env#register_public name, [] + | EXTERN name -> env#register_extern name, [] + | CLOSURE name -> let pushr, popr = List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers 0) @@ -492,7 +495,14 @@ class env prg = val barrier = false (* barrier condition *) val max_locals_size = 0 val has_closure = false + val publics = S.empty + val externs = S.empty + method publics = S.elements publics + + method register_public name = {< publics = S.add name publics >} + method register_extern name = {< externs = S.add name externs >} + method max_locals_size = max_locals_size method has_closure = has_closure @@ -548,7 +558,7 @@ class env prg = (* gets a name for a global variable *) method loc x = match x with - | Value.Global name -> M ("global_" ^ name) + | 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)) @@ -593,7 +603,7 @@ class env prg = (* registers a variable in the environment *) method variable x = match x with - | Value.Global name -> {< globals = S.add ("global_" ^ name) globals >} + | Value.Global name -> {< globals = S.add ((*"global_" ^*) name) globals >} | _ -> self (* registers a string constant *) @@ -605,7 +615,7 @@ class env prg = y, {< scount = scount + 1; stringm = m>} (* gets all global variables *) - method globals = S.elements globals + method globals = S.elements (S.diff globals externs) (* gets all string definitions *) method strings = M.bindings stringm @@ -643,24 +653,32 @@ let genasm prog = let sm = SM.compile prog in let env, code = compile (new env sm) sm in let gc_start, gc_end = "__gc_data_start", "__gc_data_end" in + let globals = + List.map (fun s -> Meta (Printf.sprintf "\t.globl\t%s" s)) ([gc_start; gc_end] @ env#publics) + in let data = [Meta "\t.data"; Meta (Printf.sprintf "filler:\t.fill\t%d, 4, 1" env#max_locals_size); - Meta (Printf.sprintf "\t.globl\t%s" gc_start); Meta (Printf.sprintf "\t.globl\t%s" gc_end)] @ - [Meta (Printf.sprintf "%s:" gc_start)] @ - (List.map (fun s -> Meta (Printf.sprintf "%s:\t.int\t1" s )) env#globals) @ - [Meta (Printf.sprintf "%s:" gc_end)] @ - (List.map (fun (s, v) -> Meta (Printf.sprintf "%s:\t.string\t\"%s\"" v s)) env#strings) + Meta (Printf.sprintf "%s:" gc_start)] @ + (List.map (fun s -> Meta (Printf.sprintf "%s:\t.int\t1" s)) env#globals) @ + [Meta (Printf.sprintf "%s:" gc_end)] @ + (List.map (fun (s, v) -> Meta (Printf.sprintf "%s:\t.string\t\"%s\"" v s)) env#strings) in let asm = Buffer.create 1024 in List.iter (fun i -> Buffer.add_string asm (Printf.sprintf "%s\n" @@ show i)) - (data @ [Meta "\t.text"; Meta "\t.globl\tmain"] @ code); + (globals @ data @ [Meta "\t.text"] @ code); Buffer.contents asm (* Builds a program: generates the assembler file and compiles it with the gcc toolchain *) -let build prog name = +let build cmd prog = + let name = Filename.chop_suffix cmd#get_infile ".expr" in let outf = open_out (Printf.sprintf "%s.s" name) in Printf.fprintf outf "%s" (genasm prog); close_out outf; let inc = try Sys.getenv "RC_RUNTIME" with _ -> "../runtime" in - Sys.command (Printf.sprintf "gcc -g -m32 -o %s %s.s %s/runtime.a" name name inc) + match cmd#get_mode with + | `Default -> + Sys.command (Printf.sprintf "gcc -g -m32 -o %s %s.s %s/runtime.a" name name inc) + | `Compile -> + Sys.command (Printf.sprintf "gcc -g -m32 -c %s.s" name) + | _ -> invalid_arg "must not happen"