Permalink
Browse files

much more stable back-end

  • Loading branch information...
pikatchu committed Apr 26, 2011
1 parent 08141f2 commit 82232b83d672871f5ec61454c726c729cf1c4ff7
View
@@ -38,6 +38,7 @@ OBJECTS_ML = \
ist.ml\
istPp.ml\
istOfStast.ml\
+ istTail.ml\
extractFuns.ml\
est.ml\
estSubst.ml\
View
@@ -153,7 +153,7 @@ module Type = struct
and type_fun mds t ctx ty1 ty2 =
let ty1, ty2 =
- if List.length ty2 > 1
+ if List.length ty2 > Global.max_reg_return
then Tptr (Tstruct ty2) :: ty1, []
else ty1, ty2 in
let ty1 = type_args mds t ctx ty1 in
@@ -293,15 +293,14 @@ module MakeRoot = struct
| Some f -> f in
let builder = builder ctx in
let name = "main" in
- let int = Type.type_prim ctx Llst.Tint in
- let z = const_int int 0 in
- let ftype = function_type int [|int|] in
+ let voids = pointer_type (i8_type ctx) in
+ let ftype = function_type voids [|voids|] in
let fdec = declare_function name ftype md in
let bb = append_block ctx "" fdec in
position_at_end bb builder ;
- let v = build_call f [|z|] "" builder in
+ let v = build_call f [|const_null voids|] "" builder in
set_instruction_call_conv ccfast v ; (* TODO check signature etc ... *)
- let _ = build_ret z builder in
+ let _ = build_ret (const_null voids) builder in
()
end
@@ -333,6 +332,16 @@ let dump_module md_file md pm =
let optims pm =
()
; add_memory_to_register_demotion pm
+ ; add_constant_propagation pm
+ ; add_sccp pm
+ ; add_dead_store_elimination pm
+ ; add_aggressive_dce pm
+ ; add_scalar_repl_aggregation pm
+ ; add_ind_var_simplification pm
+ ; add_instruction_combination pm
+
+
+(* ; add_memory_to_register_demotion pm
; add_tail_call_elimination pm
; add_instruction_combination pm
; add_memory_to_register_promotion pm
@@ -365,7 +374,7 @@ let optims pm =
; add_scalar_repl_aggregation pm
; add_ind_var_simplification pm
; add_instruction_combination pm
-
+*)
let rec program base root no_opt dump_as mdl =
let ctx = global_context() in
@@ -421,6 +430,14 @@ and cast env ty v =
let ty2 = type_of v in
match classify_type ty1, classify_type ty2 with
| TypeKind.Pointer, TypeKind.Pointer -> build_bitcast v ty1 "" env.builder
+ | TypeKind.Pointer, TypeKind.Float
+ | TypeKind.Float, TypeKind.Pointer
+ | TypeKind.Pointer, TypeKind.Double
+ | TypeKind.Double, TypeKind.Pointer ->
+ let st = build_alloca ty2 "" env.builder in
+ let _ = build_store v st env.builder in
+ let ptr = build_bitcast st (pointer_type ty1) "" env.builder in
+ build_load ptr "" env.builder
| TypeKind.Pointer, _ -> build_inttoptr v ty1 "" env.builder
| _, TypeKind.Pointer -> build_ptrtoint v ty1 "" env.builder
| TypeKind.Integer, TypeKind.Integer ->
@@ -441,7 +458,7 @@ and function_ env df =
let params = Array.to_list params in
let ret, params =
match params with
- | ret :: params when List.length df.df_ret > 1 ->
+ | ret :: params when List.length df.df_ret > Global.max_reg_return ->
Some ret, params
| _ -> None, params in
env.ret := ret ;
@@ -526,27 +543,6 @@ and build_args acc l =
and instructions bb env acc ret l =
match l with
| [] -> return env acc ret ; acc
- | [vl1, Eapply (fk, _, f, l) as instr] ->
- (match ret with
- | Return (tail, vl2) when tail && fk = Ast.Lfun ->
- let t = build_args acc l in
- let f = find_function env acc (fst f) (snd f) in
- let v = build_call f (Array.of_list t) "" env.builder in
- set_tail_call true v ;
- set_instruction_call_conv ccfast v ;
- if vl2 = []
- then ignore (build_ret_void env.builder)
- else ignore (build_ret v env.builder) ;
- acc
- | Return (_, vl2) ->
- let acc = instruction bb env acc instr in
- return env acc ret ;
- acc
- | _ ->
- let acc = instruction bb env acc instr in
- return env acc ret ;
- acc
- )
| instr :: rl ->
let acc = instruction bb env acc instr in
instructions bb env acc ret rl
@@ -576,8 +572,8 @@ and instruction bb env acc (idl, e) =
let acc = IMap.add x1 t acc in
let acc = IMap.add x2 res acc in
acc
- | (xl, Eapply (fk, _, f, l)) ->
- apply env acc xl fk f l
+ | (xl, Eapply (tail, fk, _, f, l)) ->
+ apply env acc xl tail fk f l
| [x], e -> expr bb env acc x e
| _ -> assert false
@@ -595,13 +591,18 @@ and find_function env acc fty f =
set_function_call_conv cconv fdec ;
fdec
-and apply env acc xl fk (fty, f) argl =
+and apply env acc xl tail fk (fty, f) argl =
+ let fid = f in
let f = find_function env acc fty f in
let argl = build_args acc argl in
let ret, argl =
+ match !(env.ret) with
+ | Some r when tail ->
+ Some r, r :: argl
+ | _ ->
match fty with
- | Tfun (_, _, tyl) when List.length tyl > 1 ->
- let int = Type.type_prim env.ctx Llst.Tint in
+ | Tfun (_, _, tyl) when List.length tyl > Global.max_reg_return ->
+ let int = pointer_type (i8_type env.ctx) in
let tty = List.map (fun _ -> int) tyl in
let ty = struct_type env.ctx (Array.of_list tty) in
let st = build_alloca ty "" env.builder in
@@ -610,12 +611,14 @@ and apply env acc xl fk (fty, f) argl =
let v = build_call f (Array.of_list argl) "" env.builder in
let cconv = make_cconv fk in
set_instruction_call_conv cconv v ;
+ if tail then set_tail_call true v;
match xl with
| [] -> acc
| [_, x] -> IMap.add x v acc
| _ ->
match ret with
- | None -> extract_values env acc xl v
+ | None ->
+ extract_values env acc xl v
| Some v -> extract_struct env acc xl v
and extract_struct env acc xl st =
View
@@ -96,7 +96,7 @@ and expr =
| Efield of ty_id * id
| Ematch of ty_idl * (pat * expr) list
| Ecall of label
- | Eapply of Ast.fun_kind * ty_id * ty_idl
+ | Eapply of bool * Ast.fun_kind * ty_id * ty_idl
| Eseq of ty_id * ty_idl
| Eif of ty_id * label * label
| Eis_null of ty_id
View
@@ -438,11 +438,11 @@ and expr_ t tyl = function
let ridl = make_idl tyl in
let t = equation t ridl (Est.Eif (id1, bl1.Est.bl_id, bl2.Est.bl_id)) in
t, ridl
- | Eapply (fk, ty, x, e) ->
+ | Eapply (b, fk, ty, x, e) ->
let t, x = expr t ([ty], Ist.Eid x) in
let t, idl1 = tuple t e in
let idl2 = make_idl tyl in
- let t = equation t idl2 (Est.Eapply (fk, x, idl1)) in
+ let t = equation t idl2 (Est.Eapply (b, fk, x, idl1)) in
t, idl2
| Eseq (e1, e2) ->
let t, _ = expr t e1 in
@@ -500,7 +500,7 @@ and simpl_expr_ t ty = function
let t, idl = tuple t e in
t, Est.Epartial (f, idl)
| Efun _ -> assert false
- | (Eseq (_, _)|Eapply (_, _, _, _)|Eif (_, _, _)|Elet (_, _, _)|Ematch (_, _)
+ | (Eseq (_, _)|Eapply (_, _, _, _, _)|Eif (_, _, _)|Elet (_, _, _)|Ematch (_, _)
| Efield (_, _)|Eid _) | Eswap _ -> assert false
and field t (x, e) =
View
@@ -164,7 +164,7 @@ and expr = function
| Efield (x, y) -> tid x ; o "." ; id y
| Ematch (xl, al) ->
o "match " ; idl xl ; push() ; nl() ;List.iter action al ; pop()
- | Eapply (fk, x, l) ->
+ | Eapply (_, fk, x, l) ->
o "call[" ;
o (match fk with Ast.Cfun -> "C] " | Ast.Lfun -> "L] ") ;
tid x ; o " " ; idl l
@@ -211,6 +211,7 @@ and binop = function
| Ast.Ediv -> o "div"
| Ast.Eand -> o "and"
| Ast.Eor -> o "or"
+ | Ast.Eband -> o "&"
and unop = function
| Ast.Euminus -> o "uminus"
View
@@ -76,7 +76,7 @@ and expr t = function
| Efield (x, y) -> Efield (ty_id t x, y)
| Ematch (l, al) -> Ematch (ty_idl t l, actions t al)
| Ecall _ as e -> e
- | Eapply (fk, x, l) -> Eapply (fk, ty_id t x, ty_idl t l)
+ | Eapply (b, fk, x, l) -> Eapply (b, fk, ty_id t x, ty_idl t l)
| Eseq (x, xl) -> Eseq (ty_id t x, ty_idl t xl)
| Eif (x1, l1, l2) -> Eif (ty_id t x1, l1, l2)
| Eis_null x -> Eis_null (ty_id t x)
View
@@ -237,7 +237,7 @@ and expr_ env = function
| [Bool true] -> tuple env e1
| [Bool false] -> tuple env e2
| _ -> assert false)
- | Eapply (_, _, f, e) ->
+ | Eapply (_, _, _, f, e) ->
(match IMap.find f env with
| Fun (p, b) ->
let env = pat env p (tuple env e) in
View
@@ -94,7 +94,7 @@ module FreeVars = struct
let fv = tuple fv t1 in
let fv = tuple fv t2 in
fv
- | Eapply (_, _, _, t) ->
+ | Eapply (_, _, _, _, t) ->
let fv = tuple fv t in
fv
| Eseq (e, t) ->
@@ -188,9 +188,9 @@ and expr_ funs ty = function
let funs, t1 = tuple funs t1 in
let funs, t2 = tuple funs t2 in
funs, Eif (e, t1, t2)
- | Eapply (k, ty, x, t) ->
+ | Eapply (b, k, ty, x, t) ->
let funs, t = tuple funs t in
- funs, Eapply (k, ty, x, t)
+ funs, Eapply (b, k, ty, x, t)
| Eseq (e, t) ->
let funs, e = expr funs e in
let funs, t = tuple funs t in
View
@@ -35,4 +35,4 @@ let suffix = ".lml"
let llc_opts = " -O3 -tailcallopt "
let (@@) x l = (stdlibdir ^ x ^ suffix) :: l
let stdlib = Filename.concat stdlibdir "libliml.lmli"
-
+let max_reg_return = 1
View
@@ -104,7 +104,7 @@ and expr_ =
| Ematch of tuple * (pat * tuple) list
| Elet of pat * tuple * tuple
| Eif of expr * tuple * tuple
- | Eapply of Ast.fun_kind * type_expr * id * tuple
+ | Eapply of bool * Ast.fun_kind * type_expr * id * tuple
| Eseq of expr * tuple
| Efree of type_expr * id
| Eset of expr * expr * expr
View
@@ -118,7 +118,7 @@ and expr_ bds p = function
then aswap bds p e
else if fid = Naming.alength
then snd (alength e)
- else Ist.Eapply (fk, type_expr fty, id x, e)
+ else Ist.Eapply (false, fk, type_expr fty, id x, e)
| Eseq (e1, e2) -> Ist.Eseq (expr bds e1, (tuple bds e2))
| Eobs x -> Ist.Eid (id x)
| Efree (ty, x) -> Ist.Efree (type_expr ty, id x)
View
@@ -45,7 +45,7 @@ let nl() = o "\n"; spaces()
let rec list f sep l =
match l with
- | [] -> assert false
+ | [] -> ()
| [x] -> f x
| x :: rl -> f x; o sep; list f sep rl
@@ -232,7 +232,8 @@ and expr_ = function
o "else begin"; push(); nl(); tuple e3; nl(); o "end"; pop(); nl();
pop();
nl()
- | Eapply (_, _, x, e) ->
+ | Eapply (tail, _, _, x, e) ->
+ if tail then o "tail ";
id x; o " "; tuple e
| Eseq (e1, e2) ->
expr e1; o ";"; nl();
View
@@ -0,0 +1,58 @@
+(*
+Copyright (c) 2011, Julien Verlaguet
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+1. Redistributions of source code must retain the above copyright
+notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the
+distribution.
+
+3. Neither the name of Julien Verlaguet nor the names of
+contributors may be used to endorse or promote products derived
+from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*)
+open Utils
+open Ist
+
+let rec program mdl =
+ List.map module_ mdl
+
+and module_ md =
+ { md with md_defs = List.map def md.md_defs }
+
+and def (k, x, p, t) =
+ (k, x, p, tuple t)
+
+and tuple el =
+ match el with
+ | [e] -> [expr e]
+ | l -> l
+
+and expr (tyl, e) = tyl, expr_ e
+
+and expr_ = function
+ | Ematch (e, al) -> Ematch (e, List.map action al)
+ | Elet (p, e1, e2) -> Elet (p, e1, tuple e2)
+ | Eif (c, e1, e2) -> Eif (c, tuple e1, tuple e2)
+ | Eapply (_, k, ty, x, e) -> Eapply (true, k, ty, x, e)
+ | e -> e
+
+and action (p, e) = p, tuple e
View
@@ -101,7 +101,7 @@ and expr =
| Ebinop of Ast.bop * ty_id * ty_id
| Euop of Ast.uop * ty_id
| Efield of ty_id * int
- | Eapply of Ast.fun_kind * bool * ty_id * ty_idl
+ | Eapply of bool * Ast.fun_kind * bool * ty_id * ty_idl
| Etuple of ty_id option * (int * ty_id) list
| Egettag of ty_id
| Eproj of ty_id * int
View
@@ -87,7 +87,7 @@ module Usage = struct
| Euop (_, x) -> ty_id acc x
| Efield (x, _) -> ty_id acc x
| Epartial (_, l)
- | Eapply (_, _, _, l) -> ty_idl acc l
+ | Eapply (_, _, _, _, l) -> ty_idl acc l
| Etuple (v, l) ->
let acc = match v with None -> acc | Some v -> ty_id acc v in
let acc = List.fold_left (
View
@@ -323,7 +323,7 @@ and type_expr = function
and ftype_expr = function
| Tany | Tprim _
| Tvar _ | Tid _
- | Tapply _ | Tfun _ -> Llst.Tprim Llst.Tint
+ | Tapply _ | Tfun _ -> Llst.Tany
and ftype_expr_list l = List.map ftype_expr l
@@ -485,7 +485,7 @@ and equation t is_last ret (idl, e) acc =
let acc = ([tyv], v) :: acc in
let acc = add_casts xl vl acc in
acc
- | Eapply (fk, (ty, x), vl) ->
+ | Eapply (b, fk, (ty, x), vl) ->
let argl = List.map (fun (ty, x) -> ftype_expr ty, Ident.tmp()) vl in
let argl' = ty_idl vl in
let rty = get_rty ty in
@@ -500,7 +500,7 @@ and equation t is_last ret (idl, e) acc =
acc, xl
in
let fid = type_expr ty, x in
- let acc = (xl, Llst.Eapply (fk, false, fid, argl)) :: acc in
+ let acc = (xl, Llst.Eapply (b, fk, false, fid, argl)) :: acc in
acc
in
let acc = add_casts argl argl' acc in
Oops, something went wrong.

0 comments on commit 82232b8

Please sign in to comment.