summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGuillaume Seguin <guillaume@segu.in>2009-01-10 15:20:31 +0100
committerGuillaume Seguin <guillaume@segu.in>2009-01-10 15:20:31 +0100
commitcb167a0eef0ba31cc7e01046333291180887fd1e (patch)
tree67447eeb9fac5b337d9fd209ed0f2ad81636c0ab
parent7c9a83390e3094cbed37ccaf98574dff0450c2c5 (diff)
downloadpetitcaml-cb167a0eef0ba31cc7e01046333291180887fd1e.tar.gz
petitcaml-cb167a0eef0ba31cc7e01046333291180887fd1e.tar.bz2
[petitcaml] Import current backend (almost nothing, broken, etc)
-rw-r--r--closure.ml120
-rw-r--r--compile.ml20
-rw-r--r--mips.ml97
3 files changed, 237 insertions, 0 deletions
diff --git a/closure.ml b/closure.ml
new file mode 100644
index 0000000..22c29a0
--- /dev/null
+++ b/closure.ml
@@ -0,0 +1,120 @@
+let next_fun_id = ref 0
+
+let get_function_name f =
+ match f.name with
+ | None ->
+ let name = Printf.sprintf "fun____%d" !next_fun_id
+ in
+ incr next_fun_id;
+ name
+ | Some s -> s
+
+
+module Sset = Set.Make(String)
+
+let rec motif_vars m =
+ match m.m with
+ | Munderscore -> Sset.empty
+ | Mident id -> Sset.singleton id
+ | Mtuple l -> List.fold_left (fun base motif ->
+ Sset.union base (motif_vars motif))
+ Sset.empty l
+
+let rec free_vars expr =
+ match expr.e with
+ | Econst _ -> Sset.empty
+ | Eident s -> Sset.singleton s
+ | Etuple l -> List.fold_left (fun base expr ->
+ Sset.union base (free_vars expr))
+ Sset.empty l
+ | Ebinop (e1, _, e2)
+ | Elistcons (e1, e2)
+ | Ecall (e1, e2) -> Sset.union (free_vars e1) (free_vars e2)
+ | Eunop (_, e) -> free_vars e
+ | Eif (e1, e2, e3) ->
+ Sset.union (Sset.union (free_vars e1) (free_vars e2))
+ (free_vars e3)
+ | Eletin ({m = Mident id}, {e = Efunc f}, e2) when f.recursive ->
+ Sset.diff (Sset.union (free_vars (raw_expr (Efunc f)))
+ (free_vars e2))
+ (Sset.singleton id)
+ | Eletin (m, e1, e2) ->
+ Sset.union (free_vars e1)
+ (Sset.diff (free_vars e2) (motif_vars m))
+ | Efunc f -> Sset.diff (free_vars f.body) (motif_vars f.arg)
+ | Ematch (match_expr, empty_expr, head_m, tail_m, result_expr) ->
+ let motifs_idents = Sset.union (motif_vars head_m)
+ (motif_vars tail_m)
+ in
+ Sset.union (Sset.union (free_vars match_expr)
+ (free_vars empty_expr))
+ (Sset.diff (free_vars result_expr) motifs_idents)
+ | Eclos _ -> failwith "Unreachable matching"
+
+let rec replace_funcs expr =
+ match expr.e with
+ | Econst _ -> expr, []
+ | Eident _ -> expr, []
+ | Etuple l ->
+ let l, letfuns =
+ List.fold_right (fun e (l, letfuns) ->
+ let e2, letfuns2 = replace_funcs e
+ in
+ (e2::l, letfuns2 @ letfuns))
+ l ([], [])
+ in
+ (raw_expr (Etuple l)), letfuns
+ | Ebinop (e1, o, e2) ->
+ let e1, letfuns1 = replace_funcs e1
+ and e2, letfuns2 = replace_funcs e2
+ in
+ (raw_expr (Ebinop (e1, o, e2))), letfuns1 @ letfuns2
+ | Eunop (o, e) ->
+ let e, letfuns = replace_funcs e
+ in
+ (raw_expr (Eunop (o, e))), letfuns
+ | Eletin (m, val_expr, body_expr) ->
+ let val_expr, letfuns1 = replace_funcs val_expr
+ and body_expr, letfuns2 = replace_funcs body_expr
+ in
+ (raw_expr (Eletin (m, val_expr, body_expr))),
+ letfuns1 @ letfuns2
+ | Efunc f ->
+ let fname = get_function_name f
+ in
+ let fvars = Sset.elements (free_vars expr)
+ in
+ (raw_expr (Eclos (fname, fvars))),
+ (build_letfun fname f fvars)
+ | Eif (cond_expr, then_expr, else_expr) ->
+ let cond_expr, letfuns1 = replace_funcs cond_expr
+ and then_expr, letfuns2 = replace_funcs then_expr
+ and else_expr, letfuns3 = replace_funcs else_expr
+ in
+ (raw_expr (Eif (cond_expr, then_expr, else_expr))),
+ letfuns1 @ letfuns2 @ letfuns3
+ | Elistcons (head_expr, tail_expr) ->
+ let head_expr, letfuns1 = replace_funcs head_expr
+ and tail_expr, letfuns2 = replace_funcs tail_expr
+ in
+ (raw_expr (Elistcons (head_expr, tail_expr))),
+ letfuns1 @ letfuns2
+ | Ecall (func_expr, arg_expr) ->
+ let func_expr, letfuns1 = replace_funcs func_expr
+ and arg_expr, letfuns2 = replace_funcs arg_expr
+ in
+ (raw_expr (Ecall (func_expr, arg_expr))),
+ letfuns1 @ letfuns2
+ | Ematch (match_expr, empty_expr, head_m, tail_m, result_expr) ->
+ let match_expr, letfuns1 = replace_funcs match_expr
+ and empty_expr, letfuns2 = replace_funcs empty_expr
+ and result_expr, letfuns3 = replace_funcs result_expr
+ in
+ (raw_expr (Ematch (match_expr, empty_expr,
+ head_m, tail_m, result_expr))),
+ letfuns1 @ letfuns2 @ letfuns3
+ | Eclos _ -> failwith "Unreachable matching"
+and build_letfun fname f fvars =
+ let fbody, letfuns = replace_funcs f.body
+ in
+ letfuns @ [(fname, fvars, f.arg, fbody)]
diff --git a/compile.ml b/compile.ml
new file mode 100644
index 0000000..e05f188
--- /dev/null
+++ b/compile.ml
@@ -0,0 +1,20 @@
+open Format
+open Mips
+open Ast
+open Utils
+open Closure
+
+let rec compile_expr _ = {text = [] ; data = []}
+and compile_letfuns _ = {text = [] ; data = []}
+
+let compile a ofile =
+ let a2, letfuns = replace_funcs a
+ in
+ let program = merge_programs (compile_letfuns letfuns)
+ (compile_expr a2)
+ and f = open_out ofile
+ in
+ let fmt = formatter_of_out_channel f in
+ in
+ format_program fmt program;
+ close_out f
diff --git a/mips.ml b/mips.ml
new file mode 100644
index 0000000..74a82b8
--- /dev/null
+++ b/mips.ml
@@ -0,0 +1,97 @@
+open Format
+
+type register =
+ | ZERO
+ | V0 | V1
+ | A0 | A1 | A2 | A3
+ | T0 | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9
+ | S0 | S1 | S2 | S3 | S4 | S5 | S6 | S7 | S8 | S9
+ | RA | GP | SP | FP
+
+type instruction =
+ | Move of register * register
+ | Li of register * int
+ | La of register * string
+ | Lw of register * address
+ | Sw of register * address
+ | Jal of string
+ | Jr of register
+ | Syscall
+ | Label of string
+
+type data =
+ | Asciiz of string * string
+ | Word of string * int
+
+let print_register fmt = function
+ | ZERO -> pp_print_string fmt "$zero"
+ | V0 -> pp_print_string fmt "$v0"
+ | V1 -> pp_print_string fmt "$v1"
+ | A0 -> pp_print_string fmt "$a0"
+ | A1 -> pp_print_string fmt "$a1"
+ | A2 -> pp_print_string fmt "$a2"
+ | A3 -> pp_print_string fmt "$a3"
+ | T0 -> pp_print_string fmt "$t0"
+ | T1 -> pp_print_string fmt "$t1"
+ | T2 -> pp_print_string fmt "$t2"
+ | T3 -> pp_print_string fmt "$t3"
+ | T4 -> pp_print_string fmt "$t4"
+ | T5 -> pp_print_string fmt "$t5"
+ | T6 -> pp_print_string fmt "$t6"
+ | T7 -> pp_print_string fmt "$t7"
+ | T8 -> pp_print_string fmt "$t8"
+ | T9 -> pp_print_string fmt "$t9"
+ | S0 -> pp_print_string fmt "$s0"
+ | S1 -> pp_print_string fmt "$s1"
+ | S2 -> pp_print_string fmt "$s2"
+ | S3 -> pp_print_string fmt "$s3"
+ | S4 -> pp_print_string fmt "$s4"
+ | S5 -> pp_print_string fmt "$s5"
+ | S6 -> pp_print_string fmt "$s6"
+ | S7 -> pp_print_string fmt "$s7"
+ | S8 -> pp_print_string fmt "$s8"
+ | S9 -> pp_print_string fmt "$s9"
+ | RA -> pp_print_string fmt "$ra"
+ | GP -> pp_print_string fmt "$gp"
+ | SP -> pp_print_string fmt "$sp"
+ | FP -> pp_print_string fmt "$fp"
+
+let print_instruction fmt = function
+ | Move (dst, src) ->
+ fprintf fmt "\tmove %a, %a\n" print_register dst print_register src
+ | Li (r, i) ->
+ fprintf fmt "\tli %a, %d\n" print_register r i
+ | La (r, s) ->
+ fprintf fmt "\tla %a, %s\n" print_register r s
+ | Lw (r, a) ->
+ fprintf fmt "\tlw %a, %a\n" print_register r print_address a
+ | Sw (r, a) ->
+ fprintf fmt "\tsw %a, %a\n" print_register r print_address a
+ | Jal s ->
+ fprintf fmt "\tjal %s\n" s
+ | Jr r ->
+ fprintf fmt "\tjr %a\n" print_register r
+ | Syscall ->
+ fprintf fmt "\tsyscall\n"
+ | Label s ->
+ fprintf fmt "%s:" s
+
+let print_data fmt = function
+ | Asciiz (l, s) ->
+ fprintf fmt "%s:\t.asciiz %S\n" l s
+ | Word (l, n) ->
+ fprintf fmt "%s:\t.word %d\n" l n
+
+let format_program fmt p = ""
+ fprintf fmt "\t.text\n";
+ List.iter (print_instruction fmt) p.text;
+ fprintf fmt "\t.data\n";
+ List.iter (print_data fmt) p.data
+
+type program =
+ { text : instruction list ;
+ data : data list }
+
+let merge_programs p1 p2 =
+ { text = p1.text @ p2.text ; data = p1.data @ p2.data }
+