Commit b51c79e8 authored by Pietro Abate's avatar Pietro Abate

Add Empty slot in the enviroment to implement delayed evaluation

parent 6dce4b88
......@@ -16,7 +16,7 @@ let global_size env = env.global_size
let mk cu = {
cu = cu;
vars = Env.empty;
sigma = List [];
sigma = Lambda.Identity;
gamma = IdMap.empty;
stack_size = 0;
max_stack = ref 0;
......@@ -59,17 +59,13 @@ let enter_global_cu cu env x =
global_size = env.global_size + 1 }
let rec domain = function
|Identity -> []
|List l -> Types.Tallying.domain l
|Comp (s1,s2) -> Var.Set.union (domain s1) (domain s2)
|Sel(_,_,s) -> (domain s)
let count_name = ref 0
let fresh_arg () =
incr count_name;
let s = ("__abstr_arg" ^ (string_of_int !count_name)) in
(0,Ns.U.mk s)
|Sel(_,sigma) -> (domain sigma)
(* from intermediate explicitely typed language to Evaluation language (lambda) *)
(* Typed -> Lambda *)
let rec compile env e = compile_aux env e.Typed.exp_descr
and compile_aux env = function
| Typed.Forget (e,_) -> compile env e
......@@ -133,9 +129,8 @@ and compile_abstr env a =
| Some x -> Env.add x (Env 0) Env.empty, [x, Types.cons a.Typed.fun_typ]
| None -> Env.empty, []
in
(* here is were we add a fresh variable to compture the argument of an abstraction *)
let fun_env = Env.add (fresh_arg ()) (Env 1) fun_env in
(* we add a nameless empty slot for the argument *)
let fun_env = Env.add (0,U.mk "") (Env 1) fun_env in
let (slots,nb_slots,fun_env) =
List.fold_left
......@@ -151,20 +146,18 @@ and compile_abstr env a =
Env.add x p fun_env
| Dummy -> assert false
)
([Dummy],2,fun_env) (IdSet.get a.Typed.fun_fv)
([Dummy;Dummy],2,fun_env) (IdSet.get a.Typed.fun_fv)
in
let slots = Array.of_list (List.rev slots) in
let env =
let env =
{ env with vars = fun_env;
gamma = IdMap.merge (fun _ v2 -> v2) env.gamma fun_name;
stack_size = 0;
max_stack = ref 0 }
in
let body = compile_branches env a.Typed.fun_body in
(* we add a fresh variable to this abstraction *)
let argvar = Local 1 in
let sigma = Sel(argvar,a.Typed.fun_iface,env.sigma) in
let sigma = Sel(List.map snd a.Typed.fun_iface,env.sigma) in
let polyvars =
let vs =
List.fold_left (fun acc (t1,t2) ->
......@@ -176,9 +169,9 @@ and compile_abstr env a =
Var.Set.inter (domain(env.sigma)) vs
in
if Var.Set.is_empty polyvars then
Abstraction (slots, a.Typed.fun_iface, body, !(env.max_stack), false, sigma, argvar)
Abstraction (slots, a.Typed.fun_iface, body, !(env.max_stack), false, sigma)
else
Abstraction (slots, a.Typed.fun_iface, body, !(env.max_stack), true, sigma, argvar)
Abstraction (slots, a.Typed.fun_iface, body, !(env.max_stack), true, sigma)
and compile_branches env (brs : Typed.branches) =
(* Don't compile unused branches, because they have not been type checked. *)
......
......@@ -25,16 +25,17 @@ type var_loc =
(* only TVar (polymorphic type variable) and Abstraction have
* a sigma annotation *)
type sigma =
| Identity
| List of Types.Tallying.CS.sl
| Comp of (sigma * sigma)
| Sel of (var_loc * (Types.t * Types.t) list * sigma)
| Sel of (Types.t list * sigma)
type expr =
| Var of var_loc
| TVar of (var_loc * sigma)
| Apply of expr * expr
| Abstraction of var_loc array * (Types.t * Types.t) list * branches * int * bool * sigma * var_loc
(* environment, interface, branches, size of locals, eval flag, substitutions, variable *)
| Abstraction of var_loc array * (Types.t * Types.t) list * branches * int * bool * sigma
(* environment, interface, branches, size of locals *)
| Check of expr * Auto_pat.state
| Const of Value.t
| Pair of expr * expr
......@@ -69,5 +70,4 @@ type code_item =
(* expression, size of locals, dispatcher, number of globals to set *)
| LetDecl of expr * int
type code = code_item list
......@@ -25,15 +25,16 @@ type var_loc =
(* only TVar (polymorphic type variable) and Abstraction have
* a sigma annotation *)
type sigma =
| Identity
| List of Types.Tallying.CS.sl
| Comp of (sigma * sigma)
| Sel of (var_loc * (Types.t * Types.t) list * sigma)
| Sel of (Types.t list * sigma)
type expr =
| Var of var_loc
| TVar of (var_loc * sigma)
| Apply of expr * expr
| Abstraction of var_loc array * (Types.t * Types.t) list * branches * int * bool * sigma * var_loc
| Abstraction of var_loc array * (Types.t * Types.t) list * branches * int * bool * sigma
(* environment, interface, branches, size of locals *)
| Check of expr * Auto_pat.state
| Const of Value.t
......
......@@ -65,7 +65,7 @@ let tag_const = Obj.tag (Obj.repr (Const (Obj.magic 0)))
let apply_sigma sigma = function
|Value.Pair(v1,v2,sigma') -> Value.Pair(v1,v2,Value.Comp(sigma,sigma'))
|Value.Abstraction(iface,f,sigma') -> Value.Abstraction(iface,f,Value.Comp(sigma,sigma'))
|Value.Abstraction(sI,f,sigma') -> Value.Abstraction(sI,f,Value.Comp(sigma,sigma'))
|Value.Xml(v1,v2,v3,sigma') -> Value.Xml(v1,v2,v3,Value.Comp(sigma,sigma'))
|Value.XmlNs(v1,v2,v3,ns,sigma') -> Value.XmlNs(v1,v2,v3,ns,Value.Comp(sigma,sigma'))
|Value.Record(m,sigma') -> Value.Record(m,Value.Comp(sigma,sigma'))
......@@ -74,8 +74,9 @@ let apply_sigma sigma = function
let rec eval_sigma env locals = function
|Lambda.Comp(s1,s2) -> Value.Comp(eval_sigma env locals s1,eval_sigma env locals s2)
|Lambda.Identity -> Value.Identity
|Lambda.List l -> Value.List l
|Lambda.Sel(x,iface,sigma) -> Value.Sel(eval_var env locals x,iface,eval_sigma env locals sigma)
|Lambda.Sel(sI,sigma) -> Value.Sel(sI,eval_sigma env locals sigma)
(* env is an array implementing de bruines indexes *)
(* Evaluation rules : Lamda -> Value *)
......@@ -86,8 +87,8 @@ let rec eval env locals = function
Obj.set_tag (Obj.repr e) tag_const;
v
(* variable evaluation will be split in PEnv and Env.
* PEnv and Env belong to the runtime lambda language
* from the parsing ast + typing information *)
* PEnv and Env belong to the runtime lambda language
* from the parsing ast + typing information *)
| Var x -> eval_var env locals x
| TVar (x,sigma) -> (* delayed sigma application *)
let sigma' = eval_sigma env locals sigma in
......@@ -96,7 +97,7 @@ let rec eval env locals = function
let v1 = eval env locals e1 in
let v2 = eval env locals e2 in
eval_apply v1 v2
| Abstraction (slots,iface,body,lsize,flag,sigma,var) ->
| Abstraction (slots,iface,body,lsize,flag,sigma) ->
let sigma' = eval_sigma env locals sigma in
eval_abstraction env locals slots iface body lsize sigma'
| Const c -> c
......@@ -145,15 +146,17 @@ and eval_check env locals e d =
and eval_abstraction env locals slots iface body lsize sigma =
let clousure = Array.map (eval_var env locals) slots in
let f arg = eval_branches clousure (Array.create lsize Value.Absent) body arg in
let a = Value.Abstraction (Some iface,f,sigma) in
let a = Value.Abstraction (Some iface,f,sigma) in
clousure.(0) <- a;
a
and eval_apply f arg = match f with
| Value.Abstraction (_,f,sigma) -> f arg
| Value.Abstraction (_,f,_) -> f arg
| _ -> assert false
and eval_branches env locals brs arg =
(* \Epsilon, x -> v0 *)
env.(1) <- arg;
let (code, bindings) = Run_dispatch.run_dispatcher brs.brs_disp arg in
match brs.brs_rhs.(code) with
| Auto_pat.Match (n,e) ->
......
......@@ -82,7 +82,6 @@ let make_result_basic v (code,r,_) =
done);
code
let make_result_char ch (code,r,_) =
let n = Array.length r in
if n > 0 then (
......@@ -196,9 +195,38 @@ let (@@) v sigma =
|Abstraction (iface,t,s) -> Value.Abstraction (iface,t,Value.Comp(sigma,s))
|_ -> v
let rec eval_sigma env = function
|Value.Identity -> []
|Value.List l -> l
|Value.Comp(s1,s2) -> (eval_sigma env s1) @ (eval_sigma env s2)
|Value.Sel(sI,sigma) ->
List.fold_left (fun acc sigma_j ->
(* we always put the argument in env(1) and we call eval only with
* a clousure from an abstraction *)
if List.exists (fun s_i ->
inzero env env.(1) (Types.Tallying.(s_i @@ sigma_j))
) sI
then sigma_j::acc
else acc
) [] (eval_sigma env sigma)
and inzero env v t = match v with (* XXX I should chech p1(t) and p2(t) or \Omega *)
| Value.Pair (v1,v2,sigma) -> (inzero env (v1 @@ sigma) t) && (inzero env (v2 @@ sigma) t)
| XmlNs (v1,v2,v3,_,sigma)
| Xml (v1,v2,v3,sigma) -> (inzero env (v1 @@ sigma) t) && (inzero env ((Pair (v2,v3,sigma)) @@ sigma) t)
| Record (r,sigma) -> true (* XXX !!!! apply sigma here *)
| Abstraction (None,_,_) -> failwith "Run-time inspection of external abstraction"
| Abstraction (Some iface,_,Value.Identity) -> Types.Arrow.check_iface iface t
| Abstraction (Some iface,_,sigma) ->
let s = List.fold_left (fun acc t -> Types.cap acc (snd t)) Types.any iface in
List.for_all (fun si ->
Types.subtype (Types.Tallying.(s @@ si)) t
) (eval_sigma env sigma)
| _ -> true
let rec run_dispatcher d v =
(* Format.fprintf Format.std_formatter "Matching (%a) with:@." Value.print v;
Patterns.Compile.print_dispatcher Format.std_formatter d; *)
(* Format.fprintf Format.std_formatter "Matching (%a) with:@." Value.print v;
Patterns.Compile.print_dispatcher Format.std_formatter d; *)
match d.actions with
| AIgnore r -> make_result_basic v r
| AKind k -> run_disp_kind k v
......@@ -209,11 +237,9 @@ and run_disp_kind actions v =
| Xml (v1,v2,v3,sigma)
| XmlNs (v1,v2,v3,_,sigma) -> run_disp_prod v (v1 @@ sigma) ((Pair (v2,v3,sigma)) @@ sigma) actions.xml
| Record (r,sigma) -> run_disp_record 0 v r actions.record (* XXX !!!! apply sigma here *)
| String_latin1 (i,j,s,q) ->
(* run_disp_kind actions (Value.normalize v) *)
| String_latin1 (i,j,s,q) -> (* run_disp_kind actions (Value.normalize v) *)
run_disp_string_latin1 i j s q actions
| String_utf8 (i,j,s,q) ->
(* run_disp_kind actions (Value.normalize v) *)
| String_utf8 (i,j,s,q) -> (* run_disp_kind actions (Value.normalize v) *)
run_disp_string_utf8 i j s q actions
| Atom q -> make_result_basic v (Atoms.get_map q actions.atoms)
| Char c -> make_result_basic v (Chars.get_map c actions.chars)
......@@ -227,7 +253,7 @@ and run_disp_kind actions v =
actions.basic
| Abstract (abs,_) ->
run_disp_basic v (fun t -> Types.Abstract.contains abs (Types.get_abstract t))
actions.basic
actions.basic
| Absent ->
run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
| Concat (_,_) as v -> run_disp_kind actions (Value.normalize v)
......@@ -239,7 +265,6 @@ and run_disp_prod v v1 v2 = function
| Dispatch (d1,b1) ->
let code1 = run_dispatcher d1 v1 in
run_disp_prod2 v1 v v2 b1.(code1)
and run_disp_prod2 v1 v v2 = function
| Impossible -> assert false
| Ignore r -> make_result_prod v1 v2 v r
......@@ -259,7 +284,6 @@ and run_disp_record n v fields = function
match r with
| Some r -> make_result_basic v r
| None -> assert false
and run_disp_record1 v n v1 rem = function
| Impossible -> assert false
| TailCall d1 -> run_dispatcher d1 v1
......@@ -267,7 +291,6 @@ and run_disp_record1 v n v1 rem = function
| Dispatch (d1,b1) ->
let code1 = run_dispatcher d1 v1 in
run_disp_record2 v n v1 rem b1.(code1)
and run_disp_record2 v n v1 rem = function
| Impossible -> assert false
| Ignore r -> make_result_prod v1 Absent v r
......@@ -275,13 +298,11 @@ and run_disp_record2 v n v1 rem = function
| Dispatch (d2,b2) ->
let code2 = run_disp_record_loop v n rem d2 in
make_result_prod v1 Absent v b2.(code2)
and run_disp_record_loop v n rem d =
match d.actions with
| AIgnore r -> make_result_basic v r
| AKind k -> run_disp_record n v rem k.record
and run_disp_string_latin1 i j s q actions =
if i == j then run_disp_kind actions q
else match actions.prod with
......
......@@ -4,7 +4,7 @@ open Encodings
type sigma =
| List of Types.Tallying.CS.sl
| Comp of (sigma * sigma)
| Sel of (t * (Types.t * Types.t) list * sigma)
| Sel of (Types.t list * sigma)
| Identity
and t =
......
......@@ -4,7 +4,7 @@ open Encodings
type sigma =
| List of Types.Tallying.CS.sl
| Comp of (sigma * sigma)
| Sel of (t * (Types.t * Types.t) list * sigma)
| Sel of (Types.t list * sigma)
| Identity
and t =
......
......@@ -142,11 +142,10 @@ and pp_pattern ppf = function
*)
and pp_fv ppf fv =
let f ppf (id, name) =
Format.fprintf ppf "(%d, %s)" (Upool.int id) (Encodings.Utf8.to_string name)
in
print_lst f ppf fv
and pp_v ppf (id, name) =
Format.fprintf ppf "(%d, %s)" (Upool.int id) (Encodings.Utf8.to_string name)
and pp_fv ppf fv = print_lst pp_v ppf fv
let pp_vloc ppf = function
| Lambda.Local(i) -> Format.fprintf ppf "Local(%d)" i
......@@ -181,7 +180,7 @@ let rec pp_sigma ppf =
function
|Value.List ll -> Types.Tallying.CS.pp_sl ppf ll
|Value.Comp(s1,s2) -> Format.fprintf ppf "Comp(%a,%a)" pp_sigma s1 pp_sigma s2
|Value.Sel(x,tl,s) -> Format.fprintf ppf "Sel(%a,%a,%a)" pp_value x pp_aux tl pp_sigma s
|Value.Sel(x,tl,s) -> Format.fprintf ppf "Sel(%a,%a,%a)" pp_v x pp_aux tl pp_sigma s
|Value.Identity -> Format.fprintf ppf "Id"
and pp_value ppf = function
......@@ -222,7 +221,7 @@ let rec pp_lambda_sigma ppf =
function
|Lambda.List ll -> Types.Tallying.CS.pp_sl ppf ll
|Lambda.Comp(s1,s2) -> Format.fprintf ppf "Comp(%a,%a)" pp_lambda_sigma s1 pp_lambda_sigma s2
|Lambda.Sel(x,tl,s) -> Format.fprintf ppf "Sel(%a,%a,%a)" pp_vloc x pp_aux tl pp_lambda_sigma s
|Lambda.Sel(x,tl,s) -> Format.fprintf ppf "Sel(%a,%a,%a)" pp_v x pp_aux tl pp_lambda_sigma s
and pp_lambda ppf =
let open Lambda in function
......
......@@ -322,16 +322,16 @@ let test_tallying =
(print_test l) >:: (fun _ ->
try
let l = List.map (fun (s,t) -> (parse_typ s,parse_typ t)) l in
let result = Tallying.tallying l in
let sigma = Tallying.tallying l in
List.iter (fun (s,t) ->
List.iter (fun sigma ->
let s_sigma = Tallying.apply_subst s sigma in
let t_sigma = Tallying.apply_subst t sigma in
List.iter (fun si ->
let s_sigma = Tallying.(s @@ si) in
let t_sigma = Tallying.(t @@ si) in
assert_equal ~pp_diff:(fun fmt _ ->
Format.fprintf fmt "s @ sigma_i = %a\n" Types.Print.print s_sigma;
Format.fprintf fmt "t @ sigma_i = %a\n" Types.Print.print t_sigma
) (Types.subtype s_sigma t_sigma) true
) result
) sigma
) l
(*
let elem s = SubStSet.of_list (List.map (fun l -> ESet.of_list l) s) in
......
This diff is collapsed.
......@@ -2238,6 +2238,8 @@ struct
(List.for_all (fun (a,b) -> not (check_simple_iface iface a b)) n))
|| (aux rem)
in
(* considering only arrows here and not poly variables is correct as
* the iface is just an intersection of arrows *)
aux (Pair.get (BoolPair.leafconj s.arrow))
type t = descr * (descr * descr) list list
......@@ -3228,8 +3230,10 @@ module Tallying = struct
let el = CS.ES.fold (fun e acc -> CS.ES.add (unify e) acc) m CS.ES.empty in
(* List.map (CS.E.bindings) *) (CS.ES.elements el)
let apply_subst t subl =
CS.E.fold (fun var subst acc -> Positive.substitute acc (var,subst)) subl t
let (@@) t si =
CS.E.fold (fun var subst acc ->
Positive.substitute acc (var,subst)
) si t
let domain ll =
List.fold_left (fun acc e ->
......@@ -3267,13 +3271,8 @@ let apply_raw s t =
let t = arrow (cons (get aj j)) cgamma in
let sl = Tallying.tallying [ (s,t) ] in
let new_res =
List.fold_left (fun tacc e ->
let res =
Tallying.CS.E.fold (fun var subst acc ->
Positive.substitute acc (var,subst)
) e gamma
in
cap tacc res
List.fold_left (fun tacc si ->
cap tacc (Tallying.( gamma @@ si))
) any sl
in
(* Uncomment only if we are looking for the most-precise solution *)
......
......@@ -420,7 +420,7 @@ module Tallying : sig
val solve : CS.s -> CS.es
val unify : CS.sigma -> CS.sigma
val tallying : (t * t) list -> CS.sl
val apply_subst : t -> CS.sigma -> t
val (@@) : t -> CS.sigma -> t
val domain : CS.sl -> Var.Set.t
end
......
......@@ -63,7 +63,6 @@ let set_ns_table_for_printer env =
let get_ns_table tenv = tenv.ns
let type_keep_ns env k =
{ env with keep_ns = k }
......@@ -91,8 +90,6 @@ let parse_record env loc f r =
let r = List.map (fun (l,x) -> (parse_label env loc l, f x)) r in
LabelMap.from_list (fun _ _ -> raise_loc_generic loc "Duplicated record field") r
let load_schema = ref (fun _ _ -> assert false)
let from_comp_unit = ref (fun _ -> assert false)
let load_comp_unit = ref (fun _ -> assert false)
......@@ -493,6 +490,11 @@ let fun_name env a =
| None -> None
| Some (loc,s) -> Some (ident env loc s)
let count_arg_name = ref 0
let fresh_arg_name () =
incr count_arg_name;
"__abstr_arg" ^ (string_of_int !count_arg_name)
let is_op env s =
if (Env.mem s env.ids) then None
else
......@@ -667,7 +669,6 @@ and var env loc s =
| _ -> error loc "This identifier does not refer to a value"
with Not_found -> error loc "Unbound identifier"
and abstraction env loc a =
let iface =
List.map
......
......@@ -17,7 +17,6 @@ val empty_env: t
val register_types : string -> t -> unit
(* Register types of the environment for the pretty-printer *)
val find_value: id -> t -> Types.t
val enter_type: id -> Types.t -> t -> t
val iter_values: t -> (id -> Types.t -> unit) -> unit
......@@ -29,7 +28,6 @@ val dump_types: Format.formatter -> t -> unit
val dump_ns: Format.formatter -> t -> unit
val set_ns_table_for_printer: t -> unit
val type_using: t -> Cduce_loc.loc -> U.t -> U.t -> t
val type_schema: t -> Cduce_loc.loc -> U.t -> string -> t
val type_ns : t -> Cduce_loc.loc -> U.t -> Ast.ns_expr -> t
......@@ -48,8 +46,6 @@ val type_let_funs: t -> Ast.pexpr list ->
t * Typed.texpr list * (id * Types.t) list
(* Assume that all the expressions are Abstractions *)
(* Operators *)
type type_fun = Types.t -> bool -> Types.t
......@@ -66,6 +62,5 @@ val load_comp_unit: (U.t -> Compunit.t) ref
val has_ocaml_unit: (U.t -> bool) ref
val has_static_external: (string -> bool) ref
val load_schema:
(string -> string -> Ns.Uri.t * (Types.t * Schema_validator.t) Ident.Env.t) ref
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