diff options
Diffstat (limited to 'typing')
| -rw-r--r-- | typing/env.ml | 7 | ||||
| -rw-r--r-- | typing/env.mli | 2 | ||||
| -rw-r--r-- | typing/joinmatching.ml | 10 | ||||
| -rw-r--r-- | typing/joinmatching.mli | 8 | ||||
| -rw-r--r-- | typing/typecore.ml | 189 | ||||
| -rw-r--r-- | typing/typedtree.ml | 79 | ||||
| -rw-r--r-- | typing/typedtree.mli | 76 | ||||
| -rw-r--r-- | typing/types.ml | 6 | ||||
| -rw-r--r-- | typing/types.mli | 6 |
9 files changed, 144 insertions, 239 deletions
diff --git a/typing/env.ml b/typing/env.ml index 8a4fc81d89..9a2c4a2e25 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -1101,13 +1101,6 @@ and add_continuation id desc env = and remove_continuations t = {t with continuations = EnvTbl.empty} - -let do_purge ((path,d),sl as c) = match d.val_kind with - | Val_channel _|Val_alone _ -> (path,{ d with val_kind = Val_reg; }),sl - | _ -> c - -let remove_channel_info t = - { t with values = EnvTbl.map do_purge t.values ; } (*< JOCAML *) let add_local_constraint id info elv env = diff --git a/typing/env.mli b/typing/env.mli index 9f551fd367..1fa00b77d7 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -94,8 +94,6 @@ val add_signature: signature -> t -> t (*> JOCAML *) val add_continuation: Ident.t -> continuation_description -> t -> t val remove_continuations: t -> t -(* Erase channel information *) -val remove_channel_info: t -> t (*< JOCAML *) (* Insertion of all fields of a signature, relative to the given path. diff --git a/typing/joinmatching.ml b/typing/joinmatching.ml index 411f04cfe3..853ff5acf1 100644 --- a/typing/joinmatching.ml +++ b/typing/joinmatching.ml @@ -57,7 +57,7 @@ let collect cls = | Not_found -> Hashtbl.add tbl_id_args jid.jident_desc [arg] in - let collect_clause ((_, jpats, _),_) = List.iter collect_jpat jpats in + let collect_clause (_, jpats, _) = List.iter collect_jpat jpats in List.iter collect_clause cls; let f id args ls = (id,args)::ls in Hashtbl.fold f tbl_id_args [] @@ -247,7 +247,7 @@ let y auto_loc ((disp, reac, new_names) as auto) id args = yfinal auto id par dag end | _ -> - (* Compute all possible lubs of some patterns fromp pats + (* Compute all possible lubs of some patterns from pats ref. the F function in Step 1 pattern list -> pattern list *) let rec compute_lubs pats = @@ -280,15 +280,15 @@ type 'a reaction = Location.t * joinpattern list * 'a type dispatcher = Ident.t * (pattern * Ident.t) list * partial -type ('a, 'b) guard = - ('a reaction * 'b) * (* old clause *) +type 'a guard = + 'a reaction * (* old clause *) (joinpattern list list * (* new joinpattern *) (Ident.t * Typedtree.pattern) list) (* inserted matching *) let compile auto_loc cls = let name_args = collect cls and cls = - let trivial_clause (((_, jpats, _),_) as cl) = + let trivial_clause ((_, jpats, _) as cl) = cl, (jpats,[]), [] in List.map trivial_clause cls in diff --git a/typing/joinmatching.mli b/typing/joinmatching.mli index e9e6d73777..c1323d6e1f 100644 --- a/typing/joinmatching.mli +++ b/typing/joinmatching.mli @@ -27,13 +27,13 @@ type 'a reaction = Location.t * joinpattern list * 'a type dispatcher = Ident.t * (pattern * Ident.t) list * partial -type ('a, 'b) guard = - ('a reaction * 'b) * (* old clause *) +type 'a guard = + 'a reaction * (* old clause *) (joinpattern list list * (* new joinpattern *) (Ident.t * Typedtree.pattern) list) (* inserted matching *) val compile : Location.t (* location of automaton *)-> - ('a reaction * 'b) list (* clauses *) -> - (dispatcher list * ('a, 'b) guard list) * (* compiled clauses *) + 'a reaction list (* clauses *) -> + (dispatcher list * 'a guard list) * (* compiled clauses *) (Ident.t * Ident.t list) list (* new channels *) diff --git a/typing/typecore.ml b/typing/typecore.ml index c7c91ad7f6..ac816ecc2c 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -1035,7 +1035,7 @@ let reset_def scp = def_ids := [] (* All channels defined by a join definition *) -let auto_chans = ref ([] : (Ident.t * type_expr * Location.t * type_expr) list) +let auto_chans = ref ([] : (Ident.t * type_expr * string loc * type_expr) list) let reset_auto () = auto_chans := [] @@ -1058,14 +1058,14 @@ let create_channel chan = raise (Error (chan.loc, Multiply_bound_variable name)) ; let id = Ident.create name and ty = newvar() - and loc = chan.loc and ty_arg = newvar() in def_ids := id :: !def_ids ; - auto_chans := (id, ty, loc, ty_arg) :: !auto_chans ; + auto_chans := (id, ty, chan, ty_arg) :: !auto_chans ; begin match !def_scope with | None -> () - | Some s -> Stypes.record (Stypes.An_ident (loc, name, s)); + | Some s -> + Stypes.record (Stypes.An_ident (chan.loc, name, s)); end; (id, ty, ty_arg) | (id, ty, _,ty_arg)::rem -> @@ -1084,10 +1084,10 @@ let enter_channel chan = reaction_chans := name :: !reaction_chans ; create_channel chan -let mk_jident id loc ty env = +let mk_jident id orig ty env = { jident_desc = id ; - jident_loc = loc; + jident_orig = orig; jident_type = ty; jident_env = env; } @@ -1098,6 +1098,16 @@ let rec get_type id env = match env with if Ident.same id jd then ty,loc else get_type id env +type auto_partly_typed = + { apt_loc : Location.t ; + apt_names : (Ident.t * Types.type_expr) list ; + apt_desc : + ((Location.t * Typedtree.joinpattern list * Parsetree.expression) * + ((Ident.t * Types.type_expr * string Asttypes.loc * Location.t * + bool) + list * (unit -> unit) list)) + list ; } + let type_auto_lhs tenv scope {pjauto_desc=sauto ; pjauto_loc=auto_loc} = (* Type patterns *) reset_auto () ; @@ -1111,7 +1121,7 @@ let type_auto_lhs tenv scope {pjauto_desc=sauto ; pjauto_loc=auto_loc} = (fun sjpat -> let schan, sarg = sjpat.pjpat_desc in let (id, ty, ty_arg) = enter_channel schan in - let chan = mk_jident id schan.loc ty tenv + let chan = mk_jident id schan ty tenv and arg = let rtenv = ref tenv and ty_pat = newvar () in @@ -1126,65 +1136,10 @@ let type_auto_lhs tenv scope {pjauto_desc=sauto ; pjauto_loc=auto_loc} = (get_ref pattern_variables, get_ref pattern_force)) sauto in (* get orginal channel names now *) - let env = get_ref auto_chans in (* get rid of [now useless] argument types *) - let original = List.map (fun (id,_,_,_) -> id) env in -(* compile algebraic pattern in joinpatterns *) - let (disps, reacs), new_names = Joinmatching.compile auto_loc auto in + let env = get_ref auto_chans in (* collect all names *) - let env = List.map (fun (id,ty,loc,_) -> id,ty,loc) env in - let env = - List.fold_right - (fun (id, ids) r -> - let ty,loc = get_type id env in - List.fold_right (fun id r -> (id,ty,loc)::r) ids r) - new_names env in -(* allocate names for guarded processes *) - let disps = - List.map (fun disp -> Ident.create "#d#", disp) disps - and reacs, fwds = match reacs with - | [((_,[_],_),_),_ as reac] -> - [],[Ident.create "#f", reac] - | _ -> - List.map (fun reac -> Ident.create "#g#", reac) reacs, [] in - -(* collect forwarders *) - let alone_env = - List.map (fun (d_id,(id,_,_)) -> id, d_id) disps in - let alone_env = - List.fold_right - (fun fwd r -> match fwd with - | g_id,(_old,(patss,_gd)) -> - List.fold_right - (fun pats r -> - List.fold_right - (fun pat r -> - let chan,_ = pat.jpat_desc in - let id = chan.jident_desc in - (id, g_id)::r) - pats r) - patss alone_env) - fwds alone_env in - -(* automaton structure names *) - let name = Ident.create "#auto#" - and name_wrapped = Ident.create "#wrapped#" in -(* Allocate channel slots *) - let auto_count = ref 0 in - let chan_names = - List.map - (fun (id, ty, _) -> - try - let g = List.assoc id alone_env in - id,(ty, Alone g) - with Not_found -> - let num = !auto_count in - incr auto_count ; - id, (ty, Chan (name,num))) - env in - auto_loc, - (name, name_wrapped), - (!auto_count, original, chan_names), - (disps, reacs, fwds) + let env = List.map (fun (id,ty,_,_) -> id,ty) env in + { apt_loc = auto_loc; apt_names = env; apt_desc = auto; } let rec do_type_autos_lhs env scope = function | [] -> [] @@ -3471,21 +3426,9 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) (List.combine pat_list exp_list, new_env, unpacks) (*> JOCAML *) -and type_dispatcher names disp = - let d_id,(chan_id, cls, par) = disp in - - let find_channel id = - try List.assoc id names - with Not_found -> assert false in - - let chan = find_channel chan_id - and cls = - List.map (fun (p,id) -> p, find_channel id) cls in - Disp (d_id, chan, cls, par) -and type_clause env names reac = - let g_id,(old,(actual_pats, gd)) = reac in - let (loc_clause,jpats,sexp),(pat_vars,pat_force) = old in +and type_clause env names cl = + let (loc_clause,jpats,sexp),(pat_vars,pat_force) = cl in (* First build environment for guarded process *) let conts = ref [] in @@ -3498,7 +3441,8 @@ and type_clause env names reac = conts := kdesc :: !conts; Env.add_continuation kid kdesc env - and add_pat_var (id, ty, _name, loc, as_var) env = (* _name info forgotten *) + and add_pat_var (id, ty, _name, loc, as_var) env = + (* _name info forgotten *) let check = if as_var then fun s -> Warnings.Unused_var s else fun s -> Warnings.Unused_var_strict s in @@ -3526,7 +3470,7 @@ and type_clause env names reac = let chan, arg = jpat.jpat_desc in let tchan = try - let (ty,_) = List.assoc chan.jident_desc names in + let ty = List.assoc chan.jident_desc names in ty with Not_found -> assert false in let targ = arg.pat_type in @@ -3552,48 +3496,34 @@ and type_clause env names reac = with Not_found -> assert false in jpat.jpat_kont := Some cont_id) jpats !conts ; - g_id, jpats, actual_pats, gd, exp - -and type_reac env names reac = Reac (type_clause env names reac) - -and type_fwd env names reac = Fwd (type_clause env names reac) + { jclause_loc = loc_clause ; jclause_desc = jpats, exp; } -and type_auto env - (my_loc, my_names, - (nchans, original, def_names), - (disps,reacs,fwds)) = +and type_auto env {apt_loc=my_loc; apt_names=def_names; apt_desc=cls; } = let env = Env.remove_continuations env in - let reacs = List.map (type_reac env def_names) reacs - and fwds = List.map (type_fwd env def_names) fwds in + let cls = List.map (type_clause env def_names) cls in let def_names = List.map - (fun (chan, (ty, id)) -> + (fun (chan, ty) -> match (expand_head env ty).desc with | Tarrow (_, _, _, _) -> chan, {jchannel_sync=true; jchannel_env=env ; jchannel_ident=chan ; - jchannel_type=ty ; jchannel_id=id} + jchannel_type=ty ; } | Tconstr (p, _, _) (* when Path.same p Predef.path_channel *) -> chan, {jchannel_sync=false; jchannel_env=env ; jchannel_ident=chan ; - jchannel_type=ty; jchannel_id=id} + jchannel_type=ty;} | _ -> assert false) def_names in -(* type dispacher second, it needs the new def_name *) - let disps = List.map (type_dispatcher def_names) disps in - - {jauto_desc = (disps, reacs, fwds); - jauto_name = my_names ; - jauto_nchans = nchans ; - jauto_names = def_names; - jauto_original = original ; - jauto_loc = my_loc } + { jauto_desc = cls; + jauto_loc = my_loc; + jauto_names = def_names; } and generalize_auto env auto = - let _,reacs,fwds = auto.jauto_desc in + let cls = auto.jauto_desc in List.iter - (fun reac -> - let _,jpats,_,_,_ = reac in + (fun cl -> + let jpats,_ = cl.jclause_desc in let tys = ref [] in List.iter (fun jpat -> @@ -3608,31 +3538,17 @@ and generalize_auto env auto = end in iter_type_expr f chan.jident_type ; tys := !newtys @ !tys) - jpats) - (List.map (fun (Fwd r) -> r) fwds @ - List.map (fun (Reac r) -> r) reacs) ; + jpats) cls ; List.iter (fun (id,chan) -> generalize chan.jchannel_type) auto.jauto_names -and add_auto_names p env names = +and add_auto_names loc p env names = List.fold_left - (fun env (id,(ty,nat)) -> - if p id then - let kind = match nat with - | Chan (name,num)-> Val_channel (name,num) - | Alone g -> Val_alone g in - Env.add_value id - {val_type = ty; val_kind = kind; Types.val_loc = Location.none; } env - else env) - env names - -and add_auto_names_as_regular p env names = - List.fold_left - (fun env (id,(ty,_)) -> + (fun env (id,ty) -> if p id then Env.add_value id - {val_type = ty; val_kind = Val_reg; Types.val_loc = Location.none} env + {val_type = ty; val_kind = Val_reg; Types.val_loc = loc} env else env) env names @@ -3643,8 +3559,10 @@ and type_def toplevel env sautos scope = let names_lhs_list = type_autos_lhs env sautos scope in let new_env = List.fold_left - (fun env (_, _ , (_,_,names), _) -> - add_auto_names (fun _ -> true) env names) + (fun env lhs -> + let names = lhs.apt_names + and loc = lhs.apt_loc in + add_auto_names loc (fun _ -> true) env names) env names_lhs_list in let autos = List.map (type_auto new_env) names_lhs_list in @@ -3653,22 +3571,7 @@ and type_def toplevel env sautos scope = (* Generalization *) List.iter (generalize_auto env) autos ; -(* For toplevel def, should change the bindings of channels, - so as to avoid internal automaton name escaping *) - let final_env = - if toplevel then - List.fold_left - (fun env (_ , _, (_,original,names), _) -> - let p id = List.mem id original in - add_auto_names_as_regular p env names) - env names_lhs_list - else - List.fold_left - (fun env (_ , _, (_,original,names), _) -> - let p id = List.mem id original in - add_auto_names p env names) - env names_lhs_list in - autos, final_env + autos, new_env (* Got to export those *) let type_exp env e = do_type_exp E env e diff --git a/typing/typedtree.ml b/typing/typedtree.ml index cd6e6065e9..d2fac4cfd9 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -110,56 +110,32 @@ and expression_desc = | Texp_reply of expression * Ident.t | Texp_def of joinautomaton list * expression -and 'a joinautomaton_gen = - {jauto_desc : 'a ; - jauto_name : Ident.t * Ident.t ; - jauto_names : (Ident.t * joinchannel) list ; - jauto_original : Ident.t list ; - jauto_nchans : int; - (* names defined, description *) - jauto_loc : Location.t} - and joinautomaton = - (joindispatcher list * joinreaction list * joinforwarder list) - joinautomaton_gen - -and joindispatcher = - Disp of - Ident.t * joinchannel * (pattern * joinchannel) list * partial - -and joinclause = - Ident.t * joinpattern list * joinpattern list list * - (Ident.t * pattern) list * expression - -and joinreaction = Reac of joinclause - -and joinforwarder = Fwd of joinclause + {jauto_desc : joinclause list ; + jauto_loc : Location.t ; + jauto_names : (Ident.t * joinchannel) list ; (* Channel defined *) } and joinchannel = {jchannel_sync : bool ; - jchannel_id : jchannel_id ; jchannel_ident : Ident.t ; jchannel_type : type_expr; jchannel_env : Env.t;} -and jchannel_id = Chan of Ident.t * int | Alone of Ident.t +and joinclause = + { jclause_desc : joinpattern list * expression; + jclause_loc : Location.t; } and joinpattern = - { jpat_desc: joinident * pattern ; - jpat_kont : Ident.t option ref ; - jpat_loc: Location.t} + { jpat_desc: joinident * pattern ; + jpat_loc: Location.t ; + (* For synchronous channels, can be shared by several patterns *) + jpat_kont : Ident.t option ref ; } and joinident = { jident_desc : Ident.t ; - jident_loc : Location.t; + jident_orig : string loc ; (* Original ident as in source *) jident_type : type_expr; jident_env : Env.t;} - -and joinarg = - { jarg_desc : Ident.t option ; - jarg_loc : Location.t; - jarg_type : type_expr; - jarg_env : Env.t;} (*< JOCAML *) and meth = @@ -511,7 +487,8 @@ let let_bound_idents pat = List.map fst (let_bound_idents_with_loc pat) (*> JOCAML *) let do_def_bound_idents autos r = List.fold_right - (fun {jauto_original=names} r -> names@r) + (fun {jauto_names=names} r -> + List.fold_right (fun (id,_) k -> id::k) names r) autos r let def_bound_idents d = do_def_bound_idents d [] @@ -538,3 +515,33 @@ let rec alpha_pat env p = match p.pat_desc with let mkloc = Location.mkloc let mknoloc = Location.mknoloc +(*>JOCAML *) + +(* Compiled join automaton *) + +type joinchannelopt = Chan of Ident.t * int | Alone of Ident.t + +type joinchannelfull= joinchannel * joinchannelopt + +type dispatcher = + Ident.t * joinchannelfull * (pattern * joinchannelfull) list * partial + +type reaction = Ident.t * joinpattern list * joinpattern list list * + (Ident.t * pattern) list * expression + +type channel_env = (Ident.t * joinchannelfull) list + +type compiledautomaton = + { + cauto_name : Ident.t * Ident.t; (* auto name, wrapped auto name *) + (* All names defined, with sort of *) + cauto_channels : channel_env ; + cauto_nchans : int ; (* number of actual channels *) + (* Original names *) + cauto_original : channel_env ; + cauto_loc : Location.t ; + cauto_dispatchers : dispatcher list ; + cauto_forwarders : reaction list ; + cauto_reactions : reaction list ; + } +(*<JOCAML *) diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 40d0f90210..2fb7590dc6 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -109,49 +109,30 @@ and expression_desc = | Texp_reply of expression * Ident.t | Texp_def of joinautomaton list * expression - -and 'a joinautomaton_gen = - {jauto_desc : 'a ; - jauto_name : Ident.t * Ident.t; (* auto name, wrapped auto name *) - jauto_names : (Ident.t * joinchannel) list ; - jauto_original : Ident.t list ; - jauto_nchans : int; - (* names defined, description*) - jauto_loc : Location.t} - and joinautomaton = - (joindispatcher list * joinreaction list * joinforwarder list) - joinautomaton_gen - -and joindispatcher = - Disp of - Ident.t * joinchannel * (pattern * joinchannel) list * partial - -and joinclause = - Ident.t * joinpattern list * joinpattern list list * - (Ident.t * pattern) list * expression - -and joinreaction = Reac of joinclause - -and joinforwarder = Fwd of joinclause + {jauto_desc : joinclause list ; + jauto_loc : Location.t ; + jauto_names : (Ident.t * joinchannel) list ; (* Channel defined *) } and joinchannel = {jchannel_sync : bool ; - jchannel_id : jchannel_id ; jchannel_ident : Ident.t ; jchannel_type : type_expr; jchannel_env : Env.t;} -and jchannel_id = Chan of Ident.t * int | Alone of Ident.t +and joinclause = + { jclause_desc : joinpattern list * expression; + jclause_loc : Location.t; } and joinpattern = - { jpat_desc: joinident * pattern ; (* as given in source *) - jpat_kont : Ident.t option ref ; (* For synchronous channels, can be shared by several patterns *) - jpat_loc: Location.t} + { jpat_desc: joinident * pattern ; + jpat_loc: Location.t ; + (* For synchronous channels, can be shared by several patterns *) + jpat_kont : Ident.t option ref ; } and joinident = { jident_desc : Ident.t ; - jident_loc : Location.t; + jident_orig : string loc ; (* Original ident as in source *) jident_type : type_expr; jident_env : Env.t;} (*< JOCAML *) @@ -460,3 +441,38 @@ val mknoloc: 'a -> 'a Asttypes.loc val mkloc: 'a -> Location.t -> 'a Asttypes.loc val pat_bound_idents: pattern -> (Ident.t * string Asttypes.loc) list + +(*>JOCAML *) + +(* Compiled join automaton *) + +type joinchannelopt = Chan of Ident.t * int | Alone of Ident.t + +type joinchannelfull= joinchannel * joinchannelopt + +type dispatcher = + Ident.t * joinchannelfull * (pattern * joinchannelfull) list * partial + +type reaction = + Ident.t * (* Guarded process identifier *) + joinpattern list * (* Original join patterns *) + joinpattern list list * (* Compiled joinpatterns *) + (Ident.t * pattern) list * (* Added matching *) + expression (* Guarded process *) + +type channel_env = (Ident.t * joinchannelfull) list + +type compiledautomaton = + { + cauto_name : Ident.t * Ident.t; (* auto name, wrapped auto name *) + (* All names defined, with sort of *) + cauto_channels : channel_env ; + cauto_nchans : int ; (* number of actual channels *) + (* Original names *) + cauto_original : channel_env ; + cauto_loc : Location.t ; + cauto_dispatchers : dispatcher list ; + cauto_forwarders : reaction list ; + cauto_reactions : reaction list ; + } +(*<JOCAML *) diff --git a/typing/types.ml b/typing/types.ml index 00d8396f74..f53a60aed4 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -110,12 +110,6 @@ and value_kind = | Val_anc of (string * Ident.t) list * string (* Ancestor *) | Val_unbound (* Unbound variable *) -(*> JOCAML *) - | Val_channel of Ident.t * int - (* Channel: automaton, index *) - | Val_alone of Ident.t - (* Channel: guard *) -(*< JOCAML *) (* Constructor descriptions *) diff --git a/typing/types.mli b/typing/types.mli index 96b9710083..4441c91ebf 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -108,12 +108,6 @@ and value_kind = | Val_anc of (string * Ident.t) list * string (* Ancestor *) | Val_unbound (* Unbound variable *) -(*> JOCAML *) - | Val_channel of Ident.t * int - (* Channel: automaton, index *) - | Val_alone of Ident.t - (* Channel: guard *) -(*< JOCAML *) (* Constructor descriptions *) |