Skip to content

GitLab

C
cduce
Commit b51c79e8 authored by Pietro Abate's avatar Pietro Abate
Browse files
Options

Add Empty slot in the enviroment to implement delayed evaluation

parent 6dce4b88
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 386 additions and 379 deletions
compile/compile.ml
View file @ b51c79e8
......@@ -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. *)
......
compile/lambda.ml
View file @ b51c79e8
......@@ -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
compile/lambda.mli
View file @ b51c79e8
......@@ -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
......
runtime/eval.ml
View file @ b51c79e8
......@@ -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) ->
......
runtime/run_dispatch.ml
View file @ b51c79e8
......@@ -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
......
runtime/value.ml
View file @ b51c79e8
......@@ -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 =
......
runtime/value.mli
View file @ b51c79e8
......@@ -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 =
......
tests/lambda/src/printer.ml
View file @ b51c79e8
......@@ -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
......
tests/libtest/tallyingTest.ml
View file @ b51c79e8
......@@ -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
......
types/sortedList.ml
View file @ b51c79e8
This diff is collapsed.
types/types.ml
View file @ b51c79e8
......@@ -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 *)
......
types/types.mli
View file @ b51c79e8
......@@ -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
......
typing/typer.ml
View file @ b51c79e8
......@@ -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
......
typing/typer.mli
View file @ b51c79e8
......@@ -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