diff --git a/regression/Makefile b/regression/Makefile index 0cbd2aeb8..64590eb86 100644 --- a/regression/Makefile +++ b/regression/Makefile @@ -1,8 +1,8 @@ -TESTS=$(basename $(wildcard test*.expr)) +TESTS=$(basename $(wildcard test001*.expr)) RC=../src/rc.opt -.PHONY: check $(TESTS) +.PHONY: check $(TESTS) check: $(TESTS) diff --git a/regression/test001.expr b/regression/test001.expr index f8bdc2601..c5327d48e 100644 --- a/regression/test001.expr +++ b/regression/test001.expr @@ -1,4 +1,116 @@ -x := read (); -y := read (); -z := x*y*3; -write (z) +fun foo (p1, p2, p3) { + return p1 +} + +fun f1 (p1, p2, p3) local p4, p5 { + p4 := {}; + while (1) do + case p2[p3[0]] of + A (a, b) -> + p5 := foo(p3, p2, a); + p4 := p5 : p4; + foo(p3, b, p5) + |B (a, b) -> + case P(foo(p3, p2, a), foo(p3, p2, b)) of + P (L (a), L (b)) -> p5 := L (a + b) + |P (a, b) -> p5 := foo(p3, a, b) + esac; + p4 := p5 : p4; + foo(p3, b, p5) + |C (a, b) -> + case P(foo(p3, p2, a), foo(p3, p2, b)) of + P (L (a), L (b)) -> p5 := L (a - b) + |P (a, b) -> p5 := foo(p3, a, b) + esac; + p4 := p5 : p4; + foo(p3, b, p5) + |D (a) -> + p5 := foo(p3, p2, a); + p4 := p5 : p4; + case p3[1][7] of + L (m) -> p3[1][7] := L (m + 1); + p3[2][m + 1] := p5 + esac + |E -> + return p4 + |a -> skip + esac + od; + return p4 +} + +fun f2 (p1, p2, p3) local p4, p5 { + p4 := {}; + while (1) do + case p2[p3[0]] of + A (a, b) -> + p5 := foo(p3, p2, a); + p4 := p5 : p4; + foo(p3, b, p5) + |B (a, b) -> + case P(foo(p3, p2, a), foo(p3, p2, b)) of + P (L (a), L (b)) -> p5 := L (a + b) + |P (a, b) -> p5 := foo(p3, a, b) + esac; + p4 := p5 : p4; + foo(p3, b, p5) + |C (a, b) -> + case P(foo(p3, p2, a), foo(p3, p2, b)) of + P (L (a), L (b)) -> p5 := L (a - b) + |P (a, b) -> p5 := foo(p3, a, b) + esac; + p4 := p5 : p4; + foo(p3, b, p5) + |D (a) -> + p5 := foo(p3, p2, a); + p4 := p5 : p4; + case p3[1][7] of + L (m) -> p3[1][7] := L (m + 1); + p3[2][m + 1] := p5 + esac + |E -> + return p4 + |a -> skip + esac + od; + return p4 +} + +fun f3 (p1, p2, p3) local p4, p5 { + p4 := {}; + while (1) do + case p2[p3[0]] of + A (a, b) -> + p5 := foo(p3, p2, a); + p4 := p5 : p4; + foo(p3, b, p5) + |B (a, b) -> + case P(foo(p3, p2, a), foo(p3, p2, b)) of + P (L (a), L (b)) -> p5 := L (a + b) + |P (a, b) -> p5 := foo(p3, a, b) + esac; + p4 := p5 : p4; + foo(p3, b, p5) + |C (a, b) -> + case P(foo(p3, p2, a), foo(p3, p2, b)) of + P (L (a), L (b)) -> p5 := L (a - b) + |P (a, b) -> p5 := foo(p3, a, b) + esac; + p4 := p5 : p4; + foo(p3, b, p5) + |D (a) -> + p5 := foo(p3, p2, a); + p4 := p5 : p4; + case p3[1][7] of + L (m) -> p3[1][7] := L (m + 1); + p3[2][m + 1] := p5 + esac + |E -> + return p4 + |a -> skip + esac + od; + return p4 +} + +write(7) diff --git a/src/Driver.ml b/src/Driver.ml index 7da693768..e72b155a7 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -30,7 +30,7 @@ let parse infile = ] s end ) - (ostap (!(Language.parse Language.Expr.defaultInfix) -EOF)) + (ostap (!(Language.parse Language.Infix.default) -EOF)) let main = try diff --git a/src/Language.ml b/src/Language.ml index c0ab9c64d..21adca9a6 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -260,13 +260,13 @@ module Expr = (* intrinsic (for evaluation) *) | Intrinsic of (config -> config) (* control (for control flow) *) | Control of (config -> t * config) - (* Reff : parsed expression should return value Reff (look for ":="); - Val : -//- returns simple value; - Void : parsed expression should not return any value; *) - type atr = Reff | Void | Val - let notRef x = match x with Reff -> false | _ -> true - let isVoid x = match x with Void -> true | _ -> false - let isValue x = match x with Void -> false | _ -> true (* functions for handling atribute *) + (* Available binary operators: + !! --- disjunction + && --- conjunction + ==, !=, <=, <, >=, > --- comparisons + +, - --- addition, subtraction + *, /, % --- multiplication, division, reminder + *) (* Update state *) let update st x v = @@ -400,48 +400,6 @@ module Expr = in eval env conf Skip (schedule_list [e; Intrinsic (fun conf -> branch conf bs)]) - (* places ignore if expression should be void *) - let ignore atr expr = if isVoid atr then Ignore expr else expr - - (* semantics for default set of infixes *) - (* Available binary operators: - !! --- disjunction - && --- conjunction - ==, !=, <=, <, >=, > --- comparisons - +, - --- addition, subtraction - *, /, % --- multiplication, division, reminder - *) - - let sem_init s = (fun x atr y -> - ignore atr ( - match s with - | ":" -> Sexp ("cons", [x; y]) - | "++" -> Call (Var "strcat", [x; y]) - | ":=" -> Assign (x, y) - | _ -> Binop (s, x, y) - )), (fun _ -> (if s = ":=" then Reff else Val), Val) - - let defaultInfix : (t, atr) Util.Infix.t = - fst (Array.fold_left - (fun (infix, prev) (a, s) -> - let fstOp = List.hd s in - let newInfix = match Util.Infix.after (0, 0) prev fstOp a (sem_init fstOp) infix with `Ok t -> t in - (List.fold_right (fun s infix -> match Util.Infix.at (0, 0) fstOp s (sem_init s) infix with `Ok t -> t) s newInfix, fstOp) - ) - ((Util.Infix.singleton `Righta ":=" (sem_init ":=")), ":=") - [| - `Righta, [":"]; - `Lefta , ["!!"]; - `Lefta , ["&&"]; - `Lefta , ["=="; "!="; "<="; "<"; ">="; ">"]; - `Lefta , ["++"; "+" ; "-"]; - `Lefta , ["*" ; "/"; "%"]; - |] - ) - - (* semantics for infixes creaed in runtime *) - let sem s = (fun x atr y -> ignore atr (Call (Var s, [x; y]))), (fun _ -> Val, Val) - (* Expression parser. You can use the following terminals: LIDENT --- a non-empty identifier a-z[a-zA-Z0-9_]* as a string @@ -449,91 +407,229 @@ module Expr = DECIMAL --- a decimal constant [0-9]+ as a string *) + (* Propagates *) + let rec propagate_ref = function + | Var x -> Ref x + | Elem (e, i) -> ElemRef (e, i) + | Seq (s1, s2) -> Seq (s1, propagate_ref s2) + | If (e, t1, t2) -> If (e, propagate_ref t1, propagate_ref t2) + | Case (e, bs) -> Case (e, List.map (fun (p, e) -> p, propagate_ref e) bs) + | _ -> raise (Semantic_error "not a destination") + + (* Balance values *) + let rec balance_value = function + | Array es -> Array (List.map balance_value es) + | Sexp (s, es) -> Sexp (s, List.map balance_value es) + | Binop (o, l, r) -> Binop (o, balance_value l, balance_value r) + | Elem (b, i) -> Elem (balance_value b, balance_value i) + | ElemRef (b, i) -> ElemRef (balance_value b, balance_value i) + | Length x -> Length (balance_value x) + | StringVal x -> StringVal (balance_value x) + | Call (f, es) -> Call (balance_value f, List.map balance_value es) + | Assign (d, s) -> Assign (balance_value d, balance_value s) + | Seq (l, r) -> Seq (balance_void l, balance_value r) + | If (c, t, e) -> If (balance_value c, balance_value t, balance_value e) + | Case (e, ps) -> Case (balance_value e, List.map (fun (p, e) -> p, balance_value e) ps) + + | Return _ + | While _ + | Repeat _ + | Skip -> raise (Semantic_error "missing value") + + | e -> e + and balance_void = function + | If (c, t, e) -> If (balance_value c, balance_void t, balance_void e) + | Seq (l, r) -> Seq (balance_void l, balance_void r) + | Case (e, ps) -> Case (balance_value e, List.map (fun (p, e) -> p, balance_void e) ps) + | While (e, s) -> While (balance_value e, balance_void s) + | Repeat (s, e) -> Repeat (balance_void s, balance_value e) + | Return (Some e) -> Return (Some (balance_value e)) + | Return None -> Return None + | Skip -> Skip + | e -> Ignore (balance_value e) + + (* ======= *) + + let left f c x y = f (c x) y + let right f c x y = c (f x y) + + let expr f ops opnd = + let ops = + Array.map + (fun (assoc, list) -> + let g = match assoc with `Lefta | `Nona -> left | `Righta -> right in + assoc = `Nona, altl (List.map (fun (oper, sema) -> ostap (!(oper) {g sema})) list) + ) + ops + in + let n = Array.length ops in + let op i = snd ops.(i) in + let nona i = fst ops.(i) in + let id x = x in + let ostap ( + inner[l][c]: f[ostap ( + {n = l } => x:opnd {c x} + | {n > l && not (nona l)} => x:inner[l+1][id] b:(-o:op[l] inner[l][o c x])? { + match b with None -> c x | Some x -> x + } + | {n > l && nona l} => x:inner[l+1][id] b:(op[l] inner[l+1][id])? { + c (match b with None -> x | Some (o, y) -> o id x y) + })] + ) + in + ostap (inner[0][id]) + + (* ======= *) + ostap ( - parse[infix][atr]: h:basic[infix][Void] -";" t:parse[infix][atr] {Seq (h, t)} - | basic[infix][atr]; + parse[infix]: h:basic[infix] t:(-";" parse[infix])? {match t with None -> h | Some t -> Seq (h, t)}; + basic[infix]: + !(expr + (fun x -> x) + (Array.map (fun (a, l) -> a, List.map (fun (s, f) -> ostap (- $(s)), f) l) infix) + (primary infix)); + primary[infix]: + b:base[infix] is:(-"[" i:parse[infix] -"]" {`Elem i} | -"." (%"length" {`Len} | %"string" {`Str} | f:LIDENT {`Post f})) * { + List.fold_left + (fun b -> + function + | `Elem i -> Elem (b, i) + | `Len -> Length b + | `Str -> StringVal b + | `Post f -> Call (Var f, [b]) + ) + b + is + }; + base[infix]: + n:DECIMAL {Const n} + | s:STRING {String (unquote s)} + | c:CHAR {Const (Char.code c)} + | "[" es:!(Util.list0)[parse infix] "]" {Array es} + | "{" es:!(Util.list0)[parse infix] "}" {match es with + | [] -> Const 0 + | _ -> List.fold_right (fun x acc -> Sexp ("cons", [x; acc])) es (Const 0) + } + | t:UIDENT args:(-"(" !(Util.list)[parse infix] -")")? {Sexp (t, match args with None -> [] | Some args -> args)} + | x:LIDENT s:("(" args:!(Util.list0)[parse infix] ")" {Call (Var x, args)} | empty {Var x}) {s} - basic[infix][atr]: !(Ostap.Util.newexpr (fun x -> x) (infix) (primary infix) atr); + | %"skip" {Skip} - primary[infix][atr]: - b:base[infix][Val] is:(-"[" i:parse[infix][Val] -"]" {`Elem i} | -"." (%"length" {`Len} | %"string" {`Str} | f:LIDENT {`Post f}))+ - => {match (List.hd (List.rev is)), atr with - | `Elem i, Reff -> true - | _, Reff -> false - | _, _ -> true} => - { - let lastElem = List.hd (List.rev is) in - let is = List.rev (List.tl (List.rev is)) in - let b = - List.fold_left - (fun b -> - function - | `Elem i -> Elem (b, i) - | `Len -> Length b - | `Str -> StringVal b - | `Post f -> Call (Var f, [b]) - ) - b - is - in - let res = match lastElem, atr with - | `Elem i, Reff -> ElemRef (b, i) - | `Elem i, _ -> Elem (b, i) - | `Len, _ -> Length b - | `Str, _ -> StringVal b - | `Post f, _ -> Call (Var f, [b]) - in - ignore atr res + | %"if" e:!(parse infix) + %"then" the:parse[infix] + elif:(%"elif" parse[infix] %"then" parse[infix])* + els:(%"else" parse[infix])? + %"fi" { + If (e, the, + List.fold_right + (fun (e, t) elif -> If (e, t, elif)) + elif + (match els with None -> Skip | Some s -> s) + ) } - | base[infix][atr]; - base[infix][atr]: - n:DECIMAL => {notRef atr} => {ignore atr (Const n)} - | s:STRING => {notRef atr} => {ignore atr (String (unquote s))} - | c:CHAR => {notRef atr} => {ignore atr (Const (Char.code c))} - | "[" es:!(Util.list0)[parse infix Val] "]" => {notRef atr} => {ignore atr (Array es)} - | "{" es:!(Util.list0)[parse infix Val] "}" => {notRef atr} => {ignore atr (match es with - | [] -> Const 0 - | _ -> List.fold_right (fun x acc -> Sexp ("cons", [x; acc])) es (Const 0)) - } - | t:UIDENT args:(-"(" !(Util.list)[parse infix Val] -")")? => {notRef atr} => {ignore atr (Sexp (t, match args with - | None -> [] - | Some args -> args)) - } - | x:LIDENT s:( "(" args:!(Util.list0)[parse infix Val] ")" => {notRef atr} => {Call (Var x, args)} - | empty {if notRef atr then Var x else Ref x}) {ignore atr s} - | {isVoid atr} => %"skip" {Skip} + | %"while" e:parse[infix] %"do" s:parse[infix] %"od" {While (e, s)} - | %"if" e:!(parse infix Val) %"then" the:parse[infix][atr] - elif:(%"elif" parse[infix][Val] %"then" parse[infix][atr])* - %"else" els:parse[infix][atr] %"fi" - {If (e, the, List.fold_right (fun (e, t) elif -> If (e, t, elif)) elif els)} - | %"if" e:!(parse infix Val) %"then" the:parse[infix][Void] - elif:(%"elif" parse[infix][Val] %"then" parse[infix][atr])* - => {isVoid atr} => %"fi" - {If (e, the, List.fold_right (fun (e, t) elif -> If (e, t, elif)) elif Skip)} + | %"for" i:parse[infix] "," c:parse[infix] "," s:parse[infix] %"do" b:parse[infix] %"od" { + Seq (i, While (c, Seq (b, s))) + } - | %"while" e:parse[infix][Val] %"do" s:parse[infix][Void] - => {isVoid atr} => %"od" {While (e, s)} + | %"repeat" s:parse[infix] %"until" e:basic[infix] {Repeat (s, e)} + | %"return" e:basic[infix]? {Return e} - | %"for" i:parse[infix][Void] "," c:parse[infix][Val] "," s:parse[infix][Void] %"do" b:parse[infix][Void] => {isVoid atr} => %"od" - {Seq (i, While (c, Seq (b, s)))} + | %"case" e:parse[infix] %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) -"->" parse[infix])] %"esac" {Case (e, bs)} - | %"repeat" s:parse[infix][Void] %"until" e:basic[infix][Val] - => {isVoid atr} => {Repeat (s, e)} - | %"return" e:basic[infix][Val]? => {isVoid atr} => {Return e} - - | %"case" e:parse[infix][Val] %"of" bs:!(Util.listBy1)[ostap ("|")][ostap (!(Pattern.parse) -"->" parse[infix][atr])] %"esac" - {Case (e, bs)} - | %"case" e:parse[infix][Val] %"of" bs:(!(Pattern.parse) -"->" parse[infix][Void]) => {isVoid atr} => %"esac" - {Case (e, [bs])} - - | -"(" parse[infix][atr] -")" + | -"(" parse[infix] -")" ) end +(* Infix helpers *) +module Infix = + struct + type t = ([`Lefta | `Righta | `Nona] * (string * (Expr.t -> Expr.t -> Expr.t)) list) array + + let name infix = + let b = Buffer.create 64 in + Buffer.add_string b "__Infix_"; + Seq.iter (fun c -> Buffer.add_string b (string_of_int @@ Char.code c)) @@ String.to_seq infix; + Buffer.contents b + + let default : t = + Array.map (fun (a, s) -> + a, + List.map (fun s -> s, + (fun x y -> + match s with + | ":" -> Expr.Sexp ("cons", [x; y]) + | "++" -> Expr.Call (Var "strcat", [x; y]) + | ":=" -> Expr.Assign (Expr.propagate_ref x, y) + | _ -> Expr.Binop (s, x, y) + ) + ) s + ) + [| + `Righta, [":="]; + `Righta, [":"]; + `Lefta , ["!!"]; + `Lefta , ["&&"]; + `Nona , ["=="; "!="; "<="; "<"; ">="; ">"]; + `Lefta , ["++"; "+" ; "-"]; + `Lefta , ["*" ; "/"; "%"]; + |] + + exception Break of [`Ok of t | `Fail of string] + + let find_op infix op cb ce = + try + Array.iteri (fun i (_, l) -> if List.exists (fun (s, _) -> s = op) l then raise (Break (cb i))) infix; + ce () + with Break x -> x + + let no_op op coord = `Fail (Printf.sprintf "infix ``%s'' not found in the scope at %s" op (Msg.Coord.toString coord)) + + let sem name x y = Expr.Call (Var name, [x; y]) + + let at coord op newp name infix = + find_op infix op + (fun i -> + `Ok (Array.init (Array.length infix) + (fun j -> + if j = i + then let (a, l) = infix.(i) in (a, (newp, sem name) :: l) + else infix.(j) + )) + ) + (fun _ -> no_op op coord) + + let before coord op newp ass name infix = + find_op infix op + (fun i -> + `Ok (Array.init (1 + Array.length infix) + (fun j -> + if j < i + then infix.(j) + else if j = i then (ass, [newp, sem name]) + else infix.(j-1) + )) + ) + (fun _ -> no_op op coord) + + let after coord op newp ass name infix = + find_op infix op + (fun i -> + `Ok (Array.init (1 + Array.length infix) + (fun j -> + if j <= i + then infix.(j) + else if j = i+1 then (ass, [newp, sem name]) + else infix.(j-1) + )) + ) + (fun _ -> no_op op coord) + + end (* Function and procedure definitions *) module Definition = @@ -545,23 +641,23 @@ module Definition = ostap ( arg : LIDENT; position[ass][coord][newp]: - %"at" s:STRING {Util.Infix.at coord (unquote s) newp} - | f:(%"before" {Util.Infix.before} | %"after" {Util.Infix.after}) s:STRING {f coord (unquote s) newp ass}; + %"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}) l:$ op:(s:STRING {unquote s}) md:position[ass][l#coord][op] { - let name = Util.Infix.name op in - match md (Expr.sem name) infix with + let name = Infix.name op in + match md name infix with | `Ok infix' -> name, infix' | `Fail msg -> raise (Semantic_error msg) }; parse[infix]: <(name, infix')> : head[infix] "(" args:!(Util.list0 arg) ")" locs:(%"local" !(Util.list arg))? - "{" body:!(Expr.parse infix' Void) "}" { - (name, (args, (match locs with None -> [] | Some l -> l), body)), infix' + "{" body:!(Expr.parse infix') "}" { + (name, (args, (match locs with None -> [] | Some l -> l), Expr.balance_void body)), infix' } ) @@ -600,7 +696,7 @@ let eval (defs, body) i = (* Top-level parser *) ostap ( - parse[infix]: <(defs, infix')> : definitions[infix] body:!(Expr.parse infix' Void) {defs, body}; + parse[infix]: <(defs, infix')> : definitions[infix] body:!(Expr.parse infix') {defs, Expr.balance_void body}; definitions[infix]: <(def, infix')> : !(Definition.parse infix) <(defs, infix'')> : definitions[infix'] {def::defs, infix''} | empty {[], infix} diff --git a/src/X86.ml b/src/X86.ml index 992f5f852..87c9d9873 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -1,28 +1,28 @@ open GT - + (* X86 codegeneration interface *) (* The registers: *) let regs = [|"%ebx"; "%ecx"; "%esi"; "%edi"; "%eax"; "%edx"; "%ebp"; "%esp"|] -(* We can not freely operate with all register; only 3 by now *) +(* 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;; (* We need to distinguish the following operand types: *) -@type opnd = +@type opnd = | R of int (* hard register *) | S of int (* a position on the hardware stack *) | M of string (* a named memory location *) | L of int (* an immediate operand *) -| I of opnd (* an indirect operand *) +| I of opnd (* an indirect operand *) with show let show_opnd = show(opnd) - -(* For convenience we define the following synonyms for the registers: *) + +(* For convenience we define the following synonyms for the registers: *) let ebx = R 0 let ecx = R 1 let esi = R 2 @@ -41,7 +41,7 @@ type instr = (* 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 *) +(* 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 @@ -56,7 +56,7 @@ type instr = (* arithmetic correction: or 0x0001 *) | Or1 of opnd (* arithmetic correction: shl 1 *) | Sal1 of opnd (* arithmetic correction: shr 1 *) | Sar1 of opnd - | Repmovsl + | Repmovsl (* Instruction printer *) let show instr = let binop = function @@ -64,7 +64,7 @@ let show instr = | "-" -> "subl" | "*" -> "imull" | "&&" -> "andl" - | "!!" -> "orl" + | "!!" -> "orl" | "^" -> "xorl" | "cmp" -> "cmpl" | _ -> failwith "unknown binary operator" @@ -98,7 +98,7 @@ let show instr = | 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 @@ -119,9 +119,9 @@ let compile env code = | "!=" -> "ne" | ">=" -> "ge" | ">" -> "g" - | _ -> failwith "unknown operator" + | _ -> failwith "unknown operator" in - let rec compile' env scode = + 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 call env f n = @@ -143,7 +143,7 @@ let compile env code = | "Barray" -> List.rev @@ (Push (L n)) :: pushs | "Bsexp" -> List.rev @@ (Push (L n)) :: pushs | "Bsta" -> pushs - | _ -> List.rev pushs + | _ -> List.rev pushs in env, pushr @ pushs @ [Call f; Binop ("+", L (4 * List.length pushs), esp)] @ (List.rev popr) in @@ -158,7 +158,7 @@ let compile env code = | CONST n -> let s, env' = env#allocate in (env', [Mov (L ((n lsl 1) lor 1), s)]) - + | STRING s -> let s, env = env#string s in let l, env = env#allocate in @@ -172,7 +172,7 @@ let compile env code = | S _ | M _ -> [Lea (env'#loc x, eax); Mov (eax, s)] | _ -> [Lea (env'#loc x, s)] ) - + | LD x -> let s, env' = (env#variable x)#allocate in env', @@ -181,7 +181,7 @@ let compile env code = | _ -> [Mov (env'#loc x, s)] ) - | ST x -> + | ST x -> let env' = env#variable x in let s = env'#peek in env', @@ -189,18 +189,18 @@ let compile env code = | S _ | M _ -> [Mov (s, eax); Mov (eax, env'#loc x)] | _ -> [Mov (s, env'#loc x)] ) - + | STA -> call env ".sta" 3 - + | 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 eax); Mov (edx, x)] | _ -> [Mov (v, eax); Mov (eax, I x); Mov (eax, x)] - ) - + ) + | BINOP op -> let x, y, env' = env#pop2 in env'#push y, @@ -243,7 +243,7 @@ let compile env code = Binop ("cmp", x, y); Set (suffix op, "%al"); Sal1 eax; - Or1 eax; + Or1 eax; Mov (eax, y) ] ) @@ -263,13 +263,13 @@ let compile env code = 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) - ] + ] | "!!" -> [Mov (y, eax); Sar1 eax; @@ -280,24 +280,24 @@ let compile env code = Sal1 eax; Or1 eax; Mov (eax, y) - ] + ] | "+" -> - if on_stack x && on_stack 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 + 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 -> (if env#is_barrier then (env#drop_barrier)#retrieve_stack s else 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, a, l) -> env#assert_empty_stack; let env = env#enter f a l in @@ -307,8 +307,8 @@ let compile env code = Mov (M ("$" ^ (env#allocated_size)), ecx); Repmovsl ] - - | END -> + + | END -> env#endfunc, [Label env#epilogue; Mov (ebp, esp); Pop ebp; @@ -316,11 +316,11 @@ let compile env code = 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) ] - - | RET -> + + | RET -> let x, env = env#pop in env, [Mov (x, eax); Jmp env#epilogue] - + | CALL (f, n) -> call env f n | SEXP (t, n) -> @@ -330,16 +330,16 @@ let compile env 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 @@ -362,8 +362,8 @@ let compile env code = | String -> ".string_tag_patt" | Sexp -> ".sexp_tag_patt" ) 1 - - | ENTER xs -> + + | ENTER xs -> let env, code = List.fold_left (fun (env, code) v -> @@ -373,7 +373,7 @@ let compile env code = (env#scope @@ List.rev xs, []) xs in env, List.flatten @@ List.rev code - + | LEAVE -> env#unscope, [] in let env'', code'' = compile' env' scode' in @@ -381,11 +381,11 @@ let compile env code = in compile' env code -(* A set of strings *) -module S = Set.Make (String) +(* A set of strings *) +module S = Set.Make (String) (* A map indexed by strings *) -module M = Map.Make (String) +module M = Map.Make (String) (* Environment implementation *) class env = @@ -407,15 +407,15 @@ class env = val max_locals_size = 0 method max_locals_size = max_locals_size - + method endfunc = if stack_slots > max_locals_size then {< max_locals_size = stack_slots >} else self - + method show_stack = GT.show(list) (GT.show(opnd)) stack - + method print_locals = Printf.printf "LOCALS: size = %d\n" static_size; List.iter @@ -428,7 +428,7 @@ class env = (* Assert empty stack *) method assert_empty_stack = assert (stack = []) - + (* check barrier condition *) method is_barrier = barrier @@ -437,22 +437,22 @@ class env = (* drop barrier *) method drop_barrier = {< barrier = false >} - + (* associates a stack to a label *) method set_stack l = (*Printf.printf "Setting stack for %s\n" l;*) {< stackmap = M.add l stack stackmap >} - + (* 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 - + (* gets a name for a global variable *) method loc x = try S (- (List.assoc x args) - 1) - with Not_found -> + with Not_found -> try S (assoc x locals) with Not_found -> M ("global_" ^ x) - + (* allocates a fresh position on a symbolic stack *) - method allocate = + method allocate = let x, n = let rec allocate' = function | [] -> ebx , 0 @@ -485,8 +485,8 @@ class env = for i = 0 to min (String.length tag - 1) 4 do h := (!h lsl 6) lor (String.index chars tag.[i]) done; - !h - + !h + (* registers a variable in the environment *) method variable x = match self#loc x with @@ -500,18 +500,18 @@ class env = let y = Printf.sprintf "string_%d" scount in let m = M.add x y stringm in y, {< scount = scount + 1; stringm = m>} - - (* gets all global variables *) + + (* gets all global variables *) method globals = S.elements globals - (* gets all string definitions *) + (* gets all string definitions *) method strings = M.bindings stringm (* 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 a l = let n = List.length l in @@ -527,10 +527,10 @@ class env = method unscope = let n = List.length (List.hd locals) in {< static_size = static_size - n; locals = List.tl locals >} - + (* 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 @@ -542,9 +542,9 @@ class env = | _::tl -> inner (d+1) acc tl in inner 0 [] stack - + 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 *) @@ -552,7 +552,7 @@ let genasm (ds, stmt) = let stmt = Language.Expr.Seq ( Language.Expr.Ignore (Language.Expr.Call (Language.Expr.Var "__gc_init", [])), - Language.Expr.Seq (stmt, Language.Expr.Return (Some (Language.Expr.Call (Language.Expr.Var "raw", [Language.Expr.Const 0])))) + Language.Expr.Seq (stmt, Language.Expr.Return (Some (Language.Expr.Call (Language.Expr.Var "raw", [Language.Expr.Const 0])))) ) in let env, code = @@ -582,4 +582,3 @@ let build prog name = 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) -