Commit 54c2ea99 authored by Pietro Abate's avatar Pietro Abate

Change definition of Compile.env.gamma

Enrich gamma with type information from a match
parent 0c1571ee
......@@ -5,7 +5,7 @@ type env = {
cu: Compunit.t option; (* None: toplevel *)
vars: var_loc Env.t;
sigma : sigma; (* symbolic substitutions (Lambda.sigma) *)
gamma : Types.t Env.t; (* map of type variables to types *)
gamma : Types.Node.t IdMap.map; (* map of type variables to types *)
stack_size: int;
max_stack: int ref;
global_size: int
......@@ -17,7 +17,7 @@ let mk cu = {
cu = cu;
vars = Env.empty;
sigma = `List [];
gamma = Env.empty;
gamma = IdMap.empty;
stack_size = 0;
max_stack = ref 0;
global_size = 0
......@@ -73,7 +73,7 @@ and compile_aux env = function
| Typed.Var x -> Var (find x env)
| Typed.TVar x ->
let v = find x env in
let polyvars = Var.Set.inter (domain(env.sigma)) (Types.all_vars(Env.find x env.gamma)) in
let polyvars = Var.Set.inter (domain(env.sigma)) (Types.all_vars(Types.descr (IdMap.assoc x env.gamma))) in
if Var.Set.is_empty polyvars then Var (v)
else TVar(v,env.sigma)
| Typed.Subst(e,sl) -> compile { env with sigma = `Comp(env.sigma,`List sl) } e
......@@ -163,6 +163,9 @@ and compile_branches env (brs : Typed.branches) =
(* Don't compile unused branches, because they have not been type checked. *)
let used = List.filter (fun br -> br.Typed.br_used) brs.Typed.br_branches in
let b = List.map (compile_branch env) used in
(* here I need to pull type information from each pattern and then
* compute for each variable gamma(x) . I should be able to compute gamma(x)
* using the information computed in (disp,rhs) *)
let (disp,rhs) = Patterns.Compile.make_branches brs.Typed.br_typ b in
{ brs_stack_pos = env.stack_size;
brs_accept_chars = not (Types.Char.is_empty brs.Typed.br_accept);
......@@ -174,6 +177,8 @@ and compile_branches env (brs : Typed.branches) =
* p_i / t_i is used here to add elements to env.gamma *)
and compile_branch env br =
let env = List.fold_left enter_local env (Patterns.fv br.Typed.br_pat) in
let m = Patterns.filter (Types.descr (Patterns.accept br.Typed.br_pat)) br.Typed.br_pat in
let env = { env with gamma = IdMap.union_disj m env.gamma } in
(br.Typed.br_pat, compile env br.Typed.br_body )
let enter_globals env n = match env.cu with
......
......@@ -977,16 +977,17 @@ module Compile = struct
let iface = if Types.is_empty t then `None else aux t 0 0 [] in
let codes = Array.of_list (List.rev !codes) in
let state = {
uid = !cur_id;
arity = Array.map (fun (_,ar,_) -> ar) codes;
actions = dummy_actions;
fail_code = (-1);
expected_type = "";
} in
uid = !cur_id;
arity = Array.map (fun (_,ar,_) -> ar) codes;
actions = dummy_actions;
fail_code = (-1);
expected_type = ""; }
in
let disp = {
id = !cur_id;
t = t; label = lab; pl = pl;
interface = iface; codes = codes; state = state } in
id = !cur_id;
t = t; label = lab; pl = pl;
interface = iface; codes = codes; state = state }
in
incr cur_id;
Hashtbl.add dispatcher_of_state state.uid disp;
dispatchers := DispMap.add (t,pl) disp !dispatchers;
......@@ -1137,7 +1138,8 @@ module Compile = struct
let var x =
if IdSet.mem var x then Catch
else if IdSet.mem nil x then Nil
else (incr pos; srcs.(!pos)) in
else (incr pos; srcs.(!pos))
in
let srcs' = Array.of_list (List.map var (IdSet.get xs)) in
assert(succ !pos = Array.length srcs);
(code,srcs',pop) in
......@@ -1190,19 +1192,25 @@ module Compile = struct
let tp = Types.descr (accept p) in
let nnf = (Normal.NodeSet.singleton p, Types.cap !t0 tp, xs) in
t0 := Types.diff !t0 tp;
[(nnf, (xs, e))] in
[(nnf, (xs, e))]
in
let has_facto = ref false in
let res _ _ pl =
let aux r = function
| [((var,nil,res), (xs,e))] -> assert (r == Fail);
let i = ref 0 in
List.iter (fun x ->
if IdSet.mem var x || IdSet.mem nil x
then has_facto := true
else (assert (IdMap.assoc x res = !i); incr i)) xs;
Match (List.length xs, (var,nil,xs,e))
| [] -> r | _ -> assert false in
Array.fold_left aux Fail pl in
| [((var,nil,res), (xs,e))] ->
assert (r == Fail);
let i = ref 0 in
List.iter (fun x ->
if IdSet.mem var x || IdSet.mem nil x
then has_facto := true
else (assert (IdMap.assoc x res = !i); incr i)
) xs;
Match (List.length xs, (var,nil,xs,e))
| [] -> r
| _ -> assert false
in
Array.fold_left aux Fail pl
in
(* Format.fprintf Format.std_formatter
"make_branches t=%a #branches=%i@." Types.Print.print t (List.length brs); *)
let pl = Array.map aux (Array.of_list brs) in
......
......@@ -1036,8 +1036,7 @@ let getwit t = match (slot t).status with NEmpty w -> w | _ -> assert false
let witness t = if is_empty t then raise Not_found else getwit t
let non_empty d =
not (is_empty d)
let non_empty d = not (is_empty d)
let disjoint d1 d2 = is_empty (cap d1 d2)
......
......@@ -85,9 +85,6 @@ and branch = {
br_ghost : bool;
mutable br_vars_empty : fv;
br_pat : tpat;
(*
mutable br_type : Types.t; (* Type accepted by this branch *)
*)
br_body : texpr
}
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment