st/lama_byterun
1
0
Fork 0
mirror of https://github.com/ProgramSnail/Lama.git synced 2025-12-23 07:08:46 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Merge pull request #13 from kverty/functioning

Browse source 
Functioning compiler
This commit is contained in:
Dmitry Boulytchev 2019-09-10 02:12:55 +03:00 • committed by GitHub
commit a2d7448b57
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
5 changed files with 406 additions and 199 deletions
Download patch file Download diff file Expand all files Collapse all files

4
regression/Makefile
View file

@ -1,8 +1,8 @@
TESTS=$(basename $(wildcard test*.expr)) TESTS=$(basename $(wildcard test001*.expr))
RC=../src/rc.opt RC=../src/rc.opt
.PHONY: check $(TESTS) .PHONY: check $(TESTS)
check: $(TESTS) check: $(TESTS)

120
regression/test001.expr
View file

@ -1,4 +1,116 @@
x := read (); fun foo (p1, p2, p3) {
y := read (); return p1
z := x*y*3; }
write (z)
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)

2
src/Driver.ml
View file

@ -30,7 +30,7 @@ let parse infile =
] s ] s
end end
) )
(ostap (!(Language.parse Language.Expr.defaultInfix) -EOF)) (ostap (!(Language.parse Language.Infix.default) -EOF))
let main = let main =
try try

350
src/Language.ml
View file

@ -260,13 +260,13 @@ module Expr =
(* intrinsic (for evaluation) *) | Intrinsic of (config -> config) (* intrinsic (for evaluation) *) | Intrinsic of (config -> config)
(* control (for control flow) *) | Control of (config -> t * config) (* control (for control flow) *) | Control of (config -> t * config)
(* Reff : parsed expression should return value Reff (look for ":="); (* Available binary operators:
Val : -//- returns simple value; !! --- disjunction
Void : parsed expression should not return any value; *) && --- conjunction
type atr = Reff | Void | Val ==, !=, <=, <, >=, > --- comparisons
let notRef x = match x with Reff -> false | _ -> true +, - --- addition, subtraction
let isVoid x = match x with Void -> true | _ -> false *, /, % --- multiplication, division, reminder
let isValue x = match x with Void -> false | _ -> true (* functions for handling atribute *) *)
(* Update state *) (* Update state *)
let update st x v = let update st x v =
@ -400,48 +400,6 @@ module Expr =
in in
eval env conf Skip (schedule_list [e; Intrinsic (fun conf -> branch conf bs)]) 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: (* Expression parser. You can use the following terminals:
LIDENT --- a non-empty identifier a-z[a-zA-Z0-9_]* as a string 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 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 ( ostap (
parse[infix][atr]: h:basic[infix][Void] -";" t:parse[infix][atr] {Seq (h, t)} parse[infix]: h:basic[infix] t:(-";" parse[infix])? {match t with None -> h | Some t -> Seq (h, t)};
| basic[infix][atr]; 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]: | %"if" e:!(parse infix)
b:base[infix][Val] is:(-"[" i:parse[infix][Val] -"]" {`Elem i} | -"." (%"length" {`Len} | %"string" {`Str} | f:LIDENT {`Post f}))+ %"then" the:parse[infix]
=> {match (List.hd (List.rev is)), atr with elif:(%"elif" parse[infix] %"then" parse[infix])*
| `Elem i, Reff -> true els:(%"else" parse[infix])?
| _, Reff -> false %"fi" {
| _, _ -> true} => If (e, the,
{ List.fold_right
let lastElem = List.hd (List.rev is) in (fun (e, t) elif -> If (e, t, elif))
let is = List.rev (List.tl (List.rev is)) in elif
let b = (match els with None -> Skip | Some s -> s)
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
} }
| 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] | %"for" i:parse[infix] "," c:parse[infix] "," s:parse[infix] %"do" b:parse[infix] %"od" {
elif:(%"elif" parse[infix][Val] %"then" parse[infix][atr])* Seq (i, While (c, Seq (b, s)))
%"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)}
| %"while" e:parse[infix][Val] %"do" s:parse[infix][Void] | %"repeat" s:parse[infix] %"until" e:basic[infix] {Repeat (s, e)}
=> {isVoid atr} => %"od" {While (e, s)} | %"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" | %"case" e:parse[infix] %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) -"->" parse[infix])] %"esac" {Case (e, bs)}
{Seq (i, While (c, Seq (b, s)))}
| %"repeat" s:parse[infix][Void] %"until" e:basic[infix][Val] | -"(" parse[infix] -")"
=> {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] -")"
) )
end 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 *) (* Function and procedure definitions *)
module Definition = module Definition =
@ -545,23 +641,23 @@ module Definition =
ostap ( ostap (
arg : LIDENT; arg : LIDENT;
position[ass][coord][newp]: position[ass][coord][newp]:
%"at" s:STRING {Util.Infix.at coord (unquote s) newp} %"at" s:STRING {Infix.at coord (unquote s) newp}
| f:(%"before" {Util.Infix.before} | %"after" {Util.Infix.after}) s:STRING {f coord (unquote s) newp ass}; | f:(%"before" {Infix.before} | %"after" {Infix.after}) s:STRING {f coord (unquote s) newp ass};
head[infix]: head[infix]:
%"fun" name:LIDENT {name, infix} %"fun" name:LIDENT {name, infix}
| ass:(%"infix" {`Nona} | %"infixl" {`Lefta} | %"infixr" {`Righta}) | ass:(%"infix" {`Nona} | %"infixl" {`Lefta} | %"infixr" {`Righta})
l:$ op:(s:STRING {unquote s}) l:$ op:(s:STRING {unquote s})
md:position[ass][l#coord][op] { md:position[ass][l#coord][op] {
let name = Util.Infix.name op in let name = Infix.name op in
match md (Expr.sem name) infix with match md name infix with
| `Ok infix' -> name, infix' | `Ok infix' -> name, infix'
| `Fail msg -> raise (Semantic_error msg) | `Fail msg -> raise (Semantic_error msg)
}; };
parse[infix]: parse[infix]:
<(name, infix')> : head[infix] "(" args:!(Util.list0 arg) ")" <(name, infix')> : head[infix] "(" args:!(Util.list0 arg) ")"
locs:(%"local" !(Util.list arg))? locs:(%"local" !(Util.list arg))?
"{" body:!(Expr.parse infix' Void) "}" { "{" body:!(Expr.parse infix') "}" {
(name, (args, (match locs with None -> [] | Some l -> l), body)), 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 *) (* Top-level parser *)
ostap ( 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]: definitions[infix]:
<(def, infix')> : !(Definition.parse infix) <(defs, infix'')> : definitions[infix'] {def::defs, infix''} <(def, infix')> : !(Definition.parse infix) <(defs, infix'')> : definitions[infix'] {def::defs, infix''}
| empty {[], infix} | empty {[], infix}

129
src/X86.ml
View file

@ -1,28 +1,28 @@
open GT open GT
(* X86 codegeneration interface *) (* X86 codegeneration interface *)
(* The registers: *) (* 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 *) (* We can not freely operate with all register; only 3 by now *)
let num_of_regs = Array.length regs - 5 let num_of_regs = Array.length regs - 5
(* We need to know the word size to calculate offsets correctly *) (* 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: *) (* We need to distinguish the following operand types: *)
@type opnd = @type opnd =
| R of int (* hard register *) | R of int (* hard register *)
| S of int (* a position on the hardware stack *) | S of int (* a position on the hardware stack *)
| M of string (* a named memory location *) | M of string (* a named memory location *)
| L of int (* an immediate operand *) | L of int (* an immediate operand *)
| I of opnd (* an indirect operand *) | I of opnd (* an indirect operand *)
with show with show
let show_opnd = show(opnd) 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 ebx = R 0
let ecx = R 1 let ecx = R 1
let esi = R 2 let esi = R 2
@ -41,7 +41,7 @@ type instr =
(* x86 integer division, see instruction set reference *) | IDiv of opnd (* x86 integer division, see instruction set reference *) | IDiv of opnd
(* see instruction set reference *) | Cltd (* see instruction set reference *) | Cltd
(* sets a value from flags; the first operand is the *) | Set of string * string (* 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 *) (* the second --- (sub)register name *)
(* pushes the operand on the hardware stack *) | Push of opnd (* pushes the operand on the hardware stack *) | Push of opnd
(* pops from the hardware stack to the operand *) | Pop 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: or 0x0001 *) | Or1 of opnd
(* arithmetic correction: shl 1 *) | Sal1 of opnd (* arithmetic correction: shl 1 *) | Sal1 of opnd
(* arithmetic correction: shr 1 *) | Sar1 of opnd (* arithmetic correction: shr 1 *) | Sar1 of opnd
| Repmovsl | Repmovsl
(* Instruction printer *) (* Instruction printer *)
let show instr = let show instr =
let binop = function let binop = function
@ -64,7 +64,7 @@ let show instr =
| "-" -> "subl" | "-" -> "subl"
| "*" -> "imull" | "*" -> "imull"
| "&&" -> "andl" | "&&" -> "andl"
| "!!" -> "orl" | "!!" -> "orl"
| "^" -> "xorl" | "^" -> "xorl"
| "cmp" -> "cmpl" | "cmp" -> "cmpl"
| _ -> failwith "unknown binary operator" | _ -> failwith "unknown binary operator"
@ -98,7 +98,7 @@ let show instr =
| Sal1 s -> Printf.sprintf "\tsall\t%s" (opnd s) | Sal1 s -> Printf.sprintf "\tsall\t%s" (opnd s)
| Sar1 s -> Printf.sprintf "\tsarl\t%s" (opnd s) | Sar1 s -> Printf.sprintf "\tsarl\t%s" (opnd s)
| Repmovsl -> Printf.sprintf "\trep movsl\t" | Repmovsl -> Printf.sprintf "\trep movsl\t"
(* Opening stack machine to use instructions without fully qualified names *) (* Opening stack machine to use instructions without fully qualified names *)
open SM open SM
@ -119,9 +119,9 @@ let compile env code =
| "!=" -> "ne" | "!=" -> "ne"
| ">=" -> "ge" | ">=" -> "ge"
| ">" -> "g" | ">" -> "g"
| _ -> failwith "unknown operator" | _ -> failwith "unknown operator"
in in
let rec compile' env scode = let rec compile' env scode =
let on_stack = function S _ -> true | _ -> false in 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 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 = let call env f n =
@ -143,7 +143,7 @@ let compile env code =
| "Barray" -> List.rev @@ (Push (L n)) :: pushs | "Barray" -> List.rev @@ (Push (L n)) :: pushs
| "Bsexp" -> List.rev @@ (Push (L n)) :: pushs | "Bsexp" -> List.rev @@ (Push (L n)) :: pushs
| "Bsta" -> pushs | "Bsta" -> pushs
| _ -> List.rev pushs | _ -> List.rev pushs
in in
env, pushr @ pushs @ [Call f; Binop ("+", L (4 * List.length pushs), esp)] @ (List.rev popr) env, pushr @ pushs @ [Call f; Binop ("+", L (4 * List.length pushs), esp)] @ (List.rev popr)
in in
@ -158,7 +158,7 @@ let compile env code =
| CONST n -> | CONST n ->
let s, env' = env#allocate in let s, env' = env#allocate in
(env', [Mov (L ((n lsl 1) lor 1), s)]) (env', [Mov (L ((n lsl 1) lor 1), s)])
| STRING s -> | STRING s ->
let s, env = env#string s in let s, env = env#string s in
let l, env = env#allocate 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)] | S _ | M _ -> [Lea (env'#loc x, eax); Mov (eax, s)]
| _ -> [Lea (env'#loc x, s)] | _ -> [Lea (env'#loc x, s)]
) )
| LD x -> | LD x ->
let s, env' = (env#variable x)#allocate in let s, env' = (env#variable x)#allocate in
env', env',
@ -181,7 +181,7 @@ let compile env code =
| _ -> [Mov (env'#loc x, s)] | _ -> [Mov (env'#loc x, s)]
) )
| ST x -> | ST x ->
let env' = env#variable x in let env' = env#variable x in
let s = env'#peek in let s = env'#peek in
env', env',
@ -189,18 +189,18 @@ let compile env code =
| S _ | M _ -> [Mov (s, eax); Mov (eax, env'#loc x)] | S _ | M _ -> [Mov (s, eax); Mov (eax, env'#loc x)]
| _ -> [Mov (s, env'#loc x)] | _ -> [Mov (s, env'#loc x)]
) )
| STA -> | STA ->
call env ".sta" 3 call env ".sta" 3
| STI -> | STI ->
let v, x, env' = env#pop2 in let v, x, env' = env#pop2 in
env'#push x, env'#push x,
(match x with (match x with
| S _ | M _ -> [Mov (v, edx); Mov (x, eax); Mov (edx, I eax); Mov (edx, x)] | 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)] | _ -> [Mov (v, eax); Mov (eax, I x); Mov (eax, x)]
) )
| BINOP op -> | BINOP op ->
let x, y, env' = env#pop2 in let x, y, env' = env#pop2 in
env'#push y, env'#push y,
@ -243,7 +243,7 @@ let compile env code =
Binop ("cmp", x, y); Binop ("cmp", x, y);
Set (suffix op, "%al"); Set (suffix op, "%al");
Sal1 eax; Sal1 eax;
Or1 eax; Or1 eax;
Mov (eax, y) Mov (eax, y)
] ]
) )
@ -263,13 +263,13 @@ let compile env code =
Binop (op, y, edx); Binop (op, y, edx);
Mov (L 0, edx); Mov (L 0, edx);
Set ("ne", "%dl"); Set ("ne", "%dl");
Binop (op, edx, eax); Binop (op, edx, eax);
Set ("ne", "%al"); Set ("ne", "%al");
Sal1 eax; Sal1 eax;
Or1 eax; Or1 eax;
Mov (eax, y) Mov (eax, y)
] ]
| "!!" -> | "!!" ->
[Mov (y, eax); [Mov (y, eax);
Sar1 eax; Sar1 eax;
@ -280,24 +280,24 @@ let compile env code =
Sal1 eax; Sal1 eax;
Or1 eax; Or1 eax;
Mov (eax, y) 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)] then [Mov (x, eax); Dec eax; Binop ("+", eax, y)]
else [Binop (op, x, y); Dec 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] then [Mov (x, eax); Binop (op, eax, y); Or1 y]
else [Binop (op, x, 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] | 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] | JMP l -> (env#set_stack l)#set_barrier, [Jmp l]
| CJMP (s, l) -> | CJMP (s, l) ->
let x, env = env#pop in let x, env = env#pop in
env#set_stack l, [Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp (s, l)] env#set_stack l, [Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp (s, l)]
| BEGIN (f, a, l) -> | BEGIN (f, a, l) ->
env#assert_empty_stack; env#assert_empty_stack;
let env = env#enter f a l in let env = env#enter f a l in
@ -307,8 +307,8 @@ let compile env code =
Mov (M ("$" ^ (env#allocated_size)), ecx); Mov (M ("$" ^ (env#allocated_size)), ecx);
Repmovsl Repmovsl
] ]
| END -> | END ->
env#endfunc, [Label env#epilogue; env#endfunc, [Label env#epilogue;
Mov (ebp, esp); Mov (ebp, esp);
Pop ebp; 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#lsize (env#allocated * word_size));
Meta (Printf.sprintf "\t.set\t%s,\t%d" env#allocated_size env#allocated) Meta (Printf.sprintf "\t.set\t%s,\t%d" env#allocated_size env#allocated)
] ]
| RET -> | RET ->
let x, env = env#pop in let x, env = env#pop in
env, [Mov (x, eax); Jmp env#epilogue] env, [Mov (x, eax); Jmp env#epilogue]
| CALL (f, n) -> call env f n | CALL (f, n) -> call env f n
| SEXP (t, n) -> | SEXP (t, n) ->
@ -330,16 +330,16 @@ let compile env code =
| DROP -> | DROP ->
snd env#pop, [] snd env#pop, []
| DUP -> | DUP ->
let x = env#peek in let x = env#peek in
let s, env = env#allocate in let s, env = env#allocate in
env, mov x s env, mov x s
| SWAP -> | SWAP ->
let x, y = env#peek2 in let x, y = env#peek2 in
env, [Push x; Push y; Pop x; Pop y] env, [Push x; Push y; Pop x; Pop y]
| TAG (t, n) -> | TAG (t, n) ->
let s1, env = env#allocate in let s1, env = env#allocate in
let s2, env = env#allocate in let s2, env = env#allocate in
@ -362,8 +362,8 @@ let compile env code =
| String -> ".string_tag_patt" | String -> ".string_tag_patt"
| Sexp -> ".sexp_tag_patt" | Sexp -> ".sexp_tag_patt"
) 1 ) 1
| ENTER xs -> | ENTER xs ->
let env, code = let env, code =
List.fold_left List.fold_left
(fun (env, code) v -> (fun (env, code) v ->
@ -373,7 +373,7 @@ let compile env code =
(env#scope @@ List.rev xs, []) xs (env#scope @@ List.rev xs, []) xs
in in
env, List.flatten @@ List.rev code env, List.flatten @@ List.rev code
| LEAVE -> env#unscope, [] | LEAVE -> env#unscope, []
in in
let env'', code'' = compile' env' scode' in let env'', code'' = compile' env' scode' in
@ -381,11 +381,11 @@ let compile env code =
in in
compile' env code compile' env code
(* A set of strings *) (* A set of strings *)
module S = Set.Make (String) module S = Set.Make (String)
(* A map indexed by strings *) (* A map indexed by strings *)
module M = Map.Make (String) module M = Map.Make (String)
(* Environment implementation *) (* Environment implementation *)
class env = class env =
@ -407,15 +407,15 @@ class env =
val max_locals_size = 0 val max_locals_size = 0
method max_locals_size = max_locals_size method max_locals_size = max_locals_size
method endfunc = method endfunc =
if stack_slots > max_locals_size if stack_slots > max_locals_size
then {< max_locals_size = stack_slots >} then {< max_locals_size = stack_slots >}
else self else self
method show_stack = method show_stack =
GT.show(list) (GT.show(opnd)) stack GT.show(list) (GT.show(opnd)) stack
method print_locals = method print_locals =
Printf.printf "LOCALS: size = %d\n" static_size; Printf.printf "LOCALS: size = %d\n" static_size;
List.iter List.iter
@ -428,7 +428,7 @@ class env =
(* Assert empty stack *) (* Assert empty stack *)
method assert_empty_stack = assert (stack = []) method assert_empty_stack = assert (stack = [])
(* check barrier condition *) (* check barrier condition *)
method is_barrier = barrier method is_barrier = barrier
@ -437,22 +437,22 @@ class env =
(* drop barrier *) (* drop barrier *)
method drop_barrier = {< barrier = false >} method drop_barrier = {< barrier = false >}
(* associates a stack to a label *) (* 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;*) {< stackmap = M.add l stack stackmap >}
(* retrieves a stack for a label *) (* retrieves a stack for a label *)
method retrieve_stack l = (*Printf.printf "Retrieving stack for %s\n" l;*) method retrieve_stack l = (*Printf.printf "Retrieving stack for %s\n" l;*)
try {< stack = M.find l stackmap >} with Not_found -> self try {< stack = M.find l stackmap >} with Not_found -> self
(* gets a name for a global variable *) (* gets a name for a global variable *)
method loc x = method loc x =
try S (- (List.assoc x args) - 1) try S (- (List.assoc x args) - 1)
with Not_found -> with Not_found ->
try S (assoc x locals) with Not_found -> M ("global_" ^ x) try S (assoc x locals) with Not_found -> M ("global_" ^ x)
(* allocates a fresh position on a symbolic stack *) (* allocates a fresh position on a symbolic stack *)
method allocate = method allocate =
let x, n = let x, n =
let rec allocate' = function let rec allocate' = function
| [] -> ebx , 0 | [] -> ebx , 0
@ -485,8 +485,8 @@ class env =
for i = 0 to min (String.length tag - 1) 4 do 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; done;
!h !h
(* registers a variable in the environment *) (* registers a variable in the environment *)
method variable x = method variable x =
match self#loc x with match self#loc x with
@ -500,18 +500,18 @@ class env =
let y = Printf.sprintf "string_%d" scount in let y = Printf.sprintf "string_%d" scount in
let m = M.add x y stringm in let m = M.add x y stringm in
y, {< scount = scount + 1; stringm = m>} y, {< scount = scount + 1; stringm = m>}
(* gets all global variables *) (* gets all global variables *)
method globals = S.elements globals method globals = S.elements globals
(* gets all string definitions *) (* gets all string definitions *)
method strings = M.bindings stringm method strings = M.bindings stringm
(* gets a number of stack positions allocated *) (* gets a number of stack positions allocated *)
method allocated = stack_slots method allocated = stack_slots
method allocated_size = Printf.sprintf "LS%s_SIZE" fname method allocated_size = Printf.sprintf "LS%s_SIZE" fname
(* enters a function *) (* enters a function *)
method enter f a l = method enter f a l =
let n = List.length l in let n = List.length l in
@ -527,10 +527,10 @@ class env =
method unscope = method unscope =
let n = List.length (List.hd locals) in let n = List.length (List.hd locals) in
{< static_size = static_size - n; locals = List.tl locals >} {< static_size = static_size - n; locals = List.tl locals >}
(* returns a label for the epilogue *) (* returns a label for the epilogue *)
method epilogue = Printf.sprintf "L%s_epilogue" fname method epilogue = Printf.sprintf "L%s_epilogue" fname
(* returns a name for local size meta-symbol *) (* returns a name for local size meta-symbol *)
method lsize = Printf.sprintf "L%s_SIZE" fname method lsize = Printf.sprintf "L%s_SIZE" fname
@ -542,9 +542,9 @@ class env =
| _::tl -> inner (d+1) acc tl | _::tl -> inner (d+1) acc tl
in in
inner 0 [] stack inner 0 [] stack
end end
(* Generates an assembler text for a program: first compiles the program into (* 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 the stack code, then generates x86 assember code, then prints the assembler file
*) *)
@ -552,7 +552,7 @@ let genasm (ds, stmt) =
let stmt = let stmt =
Language.Expr.Seq ( Language.Expr.Seq (
Language.Expr.Ignore (Language.Expr.Call (Language.Expr.Var "__gc_init", [])), 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 in
let env, code = let env, code =
@ -582,4 +582,3 @@ let build prog name =
close_out outf; close_out outf;
let inc = try Sys.getenv "RC_RUNTIME" with _ -> "../runtime" in 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) Sys.command (Printf.sprintf "gcc -g -m32 -o %s %s.s %s/runtime.a" name name inc)