From db5468bc9e04ba36085ccb756de8db5c7f1a035a Mon Sep 17 00:00:00 2001 From: marcpouzet Date: Mon, 21 Oct 2024 19:02:38 +0200 Subject: [PATCH] Cleaning --- compiler/.ocp-indent | 130 -- compiler/analysis/causal.ml | 817 ----------- compiler/analysis/causality.ml | 745 ---------- compiler/analysis/init.ml | 549 -------- compiler/analysis/initialization.ml | 629 --------- compiler/dune | 29 - compiler/gencode/inout.ml | 462 ------ compiler/gencode/oaux.ml | 86 -- compiler/gencode/obc.ml | 204 --- compiler/gencode/ocamlprinter.ml | 616 -------- compiler/gencode/oprinter.ml | 401 ------ compiler/gencode/translate.ml | 730 ---------- compiler/global/defcaus.ml | 57 - compiler/global/definit.ml | 65 - compiler/global/deftypes.ml | 181 --- compiler/global/deps_tools.ml | 210 --- compiler/global/global.ml | 89 -- compiler/global/graph.ml | 151 -- compiler/global/initial.ml | 151 -- compiler/global/lident.ml | 34 - compiler/global/modules.ml | 151 -- compiler/global/pcaus.ml | 117 -- compiler/global/pinit.ml | 87 -- compiler/global/pp_tools.ml | 74 - compiler/global/printer.ml | 571 -------- compiler/global/ptypes.ml | 172 --- compiler/global/scoping.ml | 970 ------------- compiler/global/vars.ml | 146 -- compiler/global/zaux.ml | 230 --- compiler/global/zelus.ml | 304 ---- compiler/global/zident.ml | 89 -- compiler/global/zlocation.ml | 151 -- compiler/global/zmisc.ml | 286 ---- compiler/main/compiler.ml | 286 ---- compiler/main/fixstep.ml | 25 - compiler/main/simulator.ml | 450 ------ compiler/main/zeluc.ml | 165 --- compiler/parsing/zdepend.ml | 201 --- compiler/parsing/zlexer.mll | 313 ----- compiler/parsing/zparser.mly | 1181 ---------------- compiler/parsing/zparsetree.ml | 282 ---- compiler/rewrite/activate.ml | 181 --- compiler/rewrite/add_copy_for_last.ml | 261 ---- compiler/rewrite/aform.ml | 250 ---- compiler/rewrite/automata.ml | 530 ------- compiler/rewrite/complete.ml | 164 --- compiler/rewrite/control.ml | 82 -- compiler/rewrite/copy.ml | 201 --- compiler/rewrite/cost.ml | 133 -- compiler/rewrite/cse.ml | 169 --- compiler/rewrite/dependences.ml | 159 --- compiler/rewrite/disc.ml | 147 -- compiler/rewrite/encore.ml | 134 -- compiler/rewrite/horizon.ml | 122 -- compiler/rewrite/inline.ml | 400 ------ compiler/rewrite/letin.ml | 257 ---- compiler/rewrite/markfunctions.ml | 354 ----- compiler/rewrite/period.ml | 248 ---- compiler/rewrite/pre.ml | 242 ---- compiler/rewrite/present.ml | 404 ------ compiler/rewrite/proba.ml | 178 --- compiler/rewrite/reduce.ml | 641 --------- compiler/rewrite/remove_last_in_patterns.ml | 290 ---- compiler/rewrite/reset.ml | 137 -- compiler/rewrite/schedule.ml | 140 -- compiler/rewrite/shared.ml | 171 --- compiler/rewrite/static.ml | 215 --- compiler/rewrite/unsafe.ml | 71 - compiler/rewrite/write.ml | 196 --- compiler/rewrite/zdeadcode.ml | 344 ----- compiler/rewrite/zopt.ml | 235 ---- compiler/typing/interface.ml | 375 ----- compiler/typing/patternsig.ml | 234 ---- compiler/typing/total.ml | 246 ---- compiler/typing/typerrors.ml | 303 ---- compiler/typing/typing.ml | 1395 ------------------- compiler/typing/zmatching.ml | 306 ---- compiler/typing/ztypes.ml | 663 --------- compiler/verif/lmm.ml | 100 -- compiler/verif/match2condition.ml | 208 --- compiler/verif/plmm.ml | 153 -- compiler/verif/tuple2record.orphan.ml | 166 --- compiler/verif/zlus2lmm.ml | 345 ----- 83 files changed, 24137 deletions(-) delete mode 100644 compiler/.ocp-indent delete mode 100644 compiler/analysis/causal.ml delete mode 100644 compiler/analysis/causality.ml delete mode 100644 compiler/analysis/init.ml delete mode 100644 compiler/analysis/initialization.ml delete mode 100644 compiler/dune delete mode 100644 compiler/gencode/inout.ml delete mode 100644 compiler/gencode/oaux.ml delete mode 100644 compiler/gencode/obc.ml delete mode 100644 compiler/gencode/ocamlprinter.ml delete mode 100644 compiler/gencode/oprinter.ml delete mode 100644 compiler/gencode/translate.ml delete mode 100644 compiler/global/defcaus.ml delete mode 100644 compiler/global/definit.ml delete mode 100644 compiler/global/deftypes.ml delete mode 100644 compiler/global/deps_tools.ml delete mode 100644 compiler/global/global.ml delete mode 100644 compiler/global/graph.ml delete mode 100644 compiler/global/initial.ml delete mode 100644 compiler/global/lident.ml delete mode 100644 compiler/global/modules.ml delete mode 100644 compiler/global/pcaus.ml delete mode 100644 compiler/global/pinit.ml delete mode 100644 compiler/global/pp_tools.ml delete mode 100644 compiler/global/printer.ml delete mode 100644 compiler/global/ptypes.ml delete mode 100644 compiler/global/scoping.ml delete mode 100644 compiler/global/vars.ml delete mode 100644 compiler/global/zaux.ml delete mode 100644 compiler/global/zelus.ml delete mode 100644 compiler/global/zident.ml delete mode 100644 compiler/global/zlocation.ml delete mode 100644 compiler/global/zmisc.ml delete mode 100644 compiler/main/compiler.ml delete mode 100644 compiler/main/fixstep.ml delete mode 100644 compiler/main/simulator.ml delete mode 100644 compiler/main/zeluc.ml delete mode 100644 compiler/parsing/zdepend.ml delete mode 100644 compiler/parsing/zlexer.mll delete mode 100644 compiler/parsing/zparser.mly delete mode 100644 compiler/parsing/zparsetree.ml delete mode 100644 compiler/rewrite/activate.ml delete mode 100644 compiler/rewrite/add_copy_for_last.ml delete mode 100644 compiler/rewrite/aform.ml delete mode 100644 compiler/rewrite/automata.ml delete mode 100644 compiler/rewrite/complete.ml delete mode 100644 compiler/rewrite/control.ml delete mode 100644 compiler/rewrite/copy.ml delete mode 100644 compiler/rewrite/cost.ml delete mode 100644 compiler/rewrite/cse.ml delete mode 100644 compiler/rewrite/dependences.ml delete mode 100644 compiler/rewrite/disc.ml delete mode 100644 compiler/rewrite/encore.ml delete mode 100644 compiler/rewrite/horizon.ml delete mode 100644 compiler/rewrite/inline.ml delete mode 100644 compiler/rewrite/letin.ml delete mode 100644 compiler/rewrite/markfunctions.ml delete mode 100644 compiler/rewrite/period.ml delete mode 100644 compiler/rewrite/pre.ml delete mode 100644 compiler/rewrite/present.ml delete mode 100644 compiler/rewrite/proba.ml delete mode 100644 compiler/rewrite/reduce.ml delete mode 100644 compiler/rewrite/remove_last_in_patterns.ml delete mode 100644 compiler/rewrite/reset.ml delete mode 100644 compiler/rewrite/schedule.ml delete mode 100644 compiler/rewrite/shared.ml delete mode 100644 compiler/rewrite/static.ml delete mode 100644 compiler/rewrite/unsafe.ml delete mode 100644 compiler/rewrite/write.ml delete mode 100644 compiler/rewrite/zdeadcode.ml delete mode 100644 compiler/rewrite/zopt.ml delete mode 100644 compiler/typing/interface.ml delete mode 100644 compiler/typing/patternsig.ml delete mode 100644 compiler/typing/total.ml delete mode 100644 compiler/typing/typerrors.ml delete mode 100644 compiler/typing/typing.ml delete mode 100644 compiler/typing/zmatching.ml delete mode 100644 compiler/typing/ztypes.ml delete mode 100644 compiler/verif/lmm.ml delete mode 100644 compiler/verif/match2condition.ml delete mode 100644 compiler/verif/plmm.ml delete mode 100644 compiler/verif/tuple2record.orphan.ml delete mode 100644 compiler/verif/zlus2lmm.ml diff --git a/compiler/.ocp-indent b/compiler/.ocp-indent deleted file mode 100644 index 451637b83..000000000 --- a/compiler/.ocp-indent +++ /dev/null @@ -1,130 +0,0 @@ -# -*- conf -*- -# This is an example configuration file for ocp-indent -# -# Copy to the root of your project with name ".ocp-indent", customise, and -# transparently get consistent indentation on all your ocaml source files. - -# Starting the configuration file with a preset ensures you won't fallback to -# definitions from "~/.ocp/ocp-indent.conf". -# These are `normal`, `apprentice` and `JaneStreet` and set different defaults. -normal - -# -# INDENTATION VALUES -# - -# Number of spaces used in all base cases, for example: -# let foo = -# ^^bar -base = 2 - -# Indent for type definitions: -# type t = -# ^^int -type = 2 - -# Indent after `let in` (unless followed by another `let`): -# let foo = () in -# ^^bar -in = 0 - -# Indent after `match/try with` or `function`: -# match foo with -# ^^| _ -> bar -with = 0 - -# Indent for clauses inside a pattern-match (after the arrow): -# match foo with -# | _ -> -# ^^^^bar -# the default is 2, which aligns the pattern and the expression -match_clause = 4 # this is non-default - -# Indentation for items inside extension nodes: -# [%% id.id -# ^^^^contents ] -# [@@id -# ^^^^foo -# ] -ppx_stritem_ext = 2 - -# When nesting expressions on the same line, their indentation are in -# some cases stacked, so that it remains correct if you close them one -# at a line. This may lead to large indents in complex code though, so -# this parameter can be used to set a maximum value. Note that it only -# affects indentation after function arrows and opening parens at end -# of line. -# -# for example (left: `none`; right: `4`) -# let f = g (h (i (fun x -> # let f = g (h (i (fun x -> -# x) # x) -# ) # ) -# ) # ) -max_indent = 4 - - -# -# INDENTATION TOGGLES -# - -# Wether the `with` parameter should be applied even when in a sub-block. -# Can be `always`, `never` or `auto`. -# if `always`, there are no exceptions -# if `auto`, the `with` parameter is superseded when seen fit (most of the time, -# but not after `begin match` for example) -# if `never`, `with` is only applied if the match block starts a line. -# -# For example, the following is not indented if set to `always`: -# let f = function -# ^^| Foo -> bar -strict_with = never - -# Controls indentation after the `else` keyword. `always` indents after the -# `else` keyword normally, like after `then`. -# If set to `never', the `else` keyword won't indent when followed by a newline. -# `auto` indents after `else` unless in a few "unclosable" cases (`let in`, -# `match`...). -# -# For example, with `strict_else=never`: -# if cond then -# foo -# else -# bar; -# baz -# `never` is discouraged if you may encounter code like this example, -# because it hides the scoping error (`baz` is always executed) -strict_else = always - -# Ocp-indent will normally try to preserve your in-comment indentation, as long -# as it respects the left-margin or starts with `(*\n`. Setting this to `true` -# forces alignment within comments. -strict_comments = false - -# Toggles preference of column-alignment over line indentation for most -# of the common operators and after mid-line opening parentheses. -# -# for example (left: `false'; right: `true') -# let f x = x # let f x = x -# + y # + y -align_ops = true - -# Function parameters are normally indented one level from the line containing -# the function. This option can be used to have them align relative to the -# column of the function body instead. -# if set to `always`, always align below the function -# if `auto`, only do that when seen fit (mainly, after arrows) -# if `never`, no alignment whatsoever -# -# for example (left: `never`; right: `always or `auto) -# match foo with # match foo with -# | _ -> some_fun # | _ -> some_fun -# ^^parameter # ^^parameter -align_params = auto - - -# -# SYNTAX EXTENSIONS -# - -# You can also add syntax extensions (as per the --syntax command-line option): -# syntax = mll lwt diff --git a/compiler/analysis/causal.ml b/compiler/analysis/causal.ml deleted file mode 100644 index fec2db26e..000000000 --- a/compiler/analysis/causal.ml +++ /dev/null @@ -1,817 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* Causality types and basic operations over these types *) - -open Zmisc -open Zident -open Deftypes -open Defcaus -open Global -open Zelus - -(** a set of causality names *) -module S = struct - include (Set.Make(Defcaus)) - let fprint_t ff s = - Format.fprintf ff "@[{@ "; - iter (fun e -> Format.fprintf ff "%a@ " Pcaus.caus e) s; - Format.fprintf ff "}@]" -end - -(* a module to represent values associated to a causality name *) -module M = struct - include (Map.Make(Defcaus)) - let fprint_t fprint_v ff s = - Format.fprintf ff "@[{@ "; - iter (fun k v -> Format.fprintf ff "%a->%a@ " Pcaus.caus k fprint_v v) s; - Format.fprintf ff "}@]" -end - -(* a module to represent values associated to sets of causality names *) -module K = Map.Make(S) - -let fprint_t = S.fprint_t -let fprint_tt = M.fprint_t S.fprint_t - -type cycle = Defcaus.t list - -type error = cycle - -(* typing errors *) -exception Clash of error - -let new_var () = - { c_desc = Cvar; c_index = symbol#name; c_level = !binding_level; - c_inf = []; c_sup = []; c_useful = false; - c_polarity = Punknown; c_info = None; c_visited = -1 } -let new_var_with_info { c_info = i } = { (new_var ()) with c_info = i } -let new_gen_var () = - { c_desc = Cvar; c_index = symbol#name; c_level = !binding_level + 1; - c_inf = []; c_sup = []; c_useful = false; - c_polarity = Punknown; c_info = None; c_visited = -1 } -let product l = Cproduct(l) -let funtype tc1 tc2 = Cfun(tc1, tc2) -let rec funtype_list tc_arg_list tc_res = - match tc_arg_list with - | [] -> tc_res - | [tc] -> funtype tc tc_res - | tc :: tc_arg_list -> - funtype tc (funtype_list tc_arg_list tc_res) -let atom c = Catom(c) - -(* path compression *) -let rec crepr c = - match c.c_desc with - | Clink(c_son) -> - let c_son = crepr c_son in - c.c_desc <- Clink(c_son); - c_son - | _ -> c - -(* equality of two causality tags *) -(* must not physically change types ! *) -let rec equal c1 c2 = - match c1.c_desc, c2.c_desc with - | Cvar, Cvar -> c1.c_index = c2.c_index - | Clink(c1), _ -> equal c1 c2 - | _, Clink(c2) -> equal c1 c2 - -let rec add c l = - match l with - | [] -> [c] - | c1 :: l1 -> if equal c c1 then l else c1 :: (add c l1) - -let rec remove c l = - match l with - | [] -> [] - | c1 :: l1 -> if equal c c1 then l1 else c1 :: (remove c l1) - -let rec mem c l = - match l with | [] -> false | c1 :: l -> (equal c c1) || (mem c l) - -let rec union l1 l2 = - match l1, l2 with - | [], l2 -> l2 | l1, [] -> l1 - | c :: l1, l2 -> if mem c l2 then union l1 l2 else c :: union l1 l2 - -let set l = List.fold_left (fun acc c -> add c acc) [] l - -(* sups *) -let sups c = let c = crepr c in c.c_sup -let allsups acc c = - let rec allsups acc c = add c (all_sups_list acc c.c_sup) - and all_sups_list acc l = List.fold_left allsups acc l in - all_sups_list acc (sups c) - -let rec annotate n = function - | Catom(c) -> atom(cannotate n c) - | Cproduct(ty_list) -> product(List.map (annotate n) ty_list) - | Cfun _ as ty -> ty -and cannotate n c = - let c = crepr c in - c.c_info <- Some(n); c - -(* The set of variables of a causality type *) -let rec vars acc = function - | Catom(c) -> vars_c acc c - | Cproduct(ty_list) -> List.fold_left vars acc ty_list - | Cfun(ty_arg, ty_res) -> vars (vars acc ty_arg) ty_res - -and vars_c acc c = S.add (crepr c) acc - -(** Sets the polarity of a type. *) -let rec polarity right tc = - match tc with - | Cfun(tc1, tc2) -> - polarity (not right) tc1; polarity right tc2 - | Cproduct(tc_list) -> List.iter (polarity right) tc_list - | Catom(c) -> polarity_c right c - -and polarity_c right c = - let c = crepr c in - match c.c_polarity, right with - | Punknown, true -> c.c_polarity <- Pplus - | Punknown, false -> c.c_polarity <- Pminus - | Pminus, true | Pplus, false -> c.c_polarity <- Pplusminus - | _ -> () - -let increase_polarity p c = - match p with - | Punknown -> c.c_polarity <- p - | _ -> if p <> c.c_polarity then c.c_polarity <- Pplusminus - -(** check for cycles. Does [left_c] appears in [right_c] and its *) -(* greater elements *) -let rec occur_check ({ c_level = level; c_index = index } as c_left) c_right = - let rec check path c_right = - match c_right.c_desc with - | Cvar -> - if c_right.c_level > level then c_right.c_level <- level; - if c_right.c_index = index - then raise (Clash(List.rev path)) - else List.iter (check (c_right :: path)) c_right.c_sup - | Clink(link) -> check path link - in check [c_left] c_right - -(* For debug purpose only *) -let rec check_type tc = - match tc with - | Cproduct(tc_list) -> List.iter check_type tc_list - | Catom(c) -> - let c = crepr c in - List.iter (occur_check c) c.c_inf; - List.iter (occur_check c) c.c_sup - | Cfun(tc_arg, tc_res) -> check_type tc_arg; check_type tc_res - -(** order < between types *) -let rec less left_tc right_tc = - match left_tc, right_tc with - | Cproduct(l1), Cproduct(l2) -> List.iter2 less l1 l2 - | Catom(c1), Catom(c2) -> less_c c1 c2 - | Cfun(tc_arg1, tc_res1), Cfun(tc_arg2, tc_res2) -> - less tc_res1 tc_res2; less tc_arg2 tc_arg1 - | _ -> assert false - -and less_c left_c right_c = - let left_c = crepr left_c in - let right_c = crepr right_c in - match left_c.c_desc, right_c.c_desc with - | Cvar, Cvar -> - occur_check left_c right_c; - (* [left_c < .... set ...] with [left_c not in set] *) - (* Now [left_c < ... set + { right_c } *) - right_c.c_inf <- add left_c right_c.c_inf; - left_c.c_sup <- add right_c left_c.c_sup - | _ -> assert false - -let intro_less_c right_c = - let left_c = new_var () in less_c left_c right_c; left_c - -(* does it exist a strict path from [c1] to [c2]? *) -let rec strict_path c1 c2 = List.exists (fun c1 -> path c1 c2) (sups c1) -and path c1 c2 = (equal c1 c2) || (strict_path c1 c2) - - -(* Copy of a causality type *) -let rec fresh tc = - match tc with - | Cfun(tc1, tc2) -> Cfun(fresh tc1, fresh tc2) - | Cproduct(l) -> Cproduct(List.map fresh l) - | Catom(c) -> Catom(new_var_with_info c) - -let rec fresh_on_c c tc = - match tc with - | Cfun(tc1, tc2) -> - let c_left = new_var () in - less_c c_left c; - Cfun(fresh_on_c c_left tc1, fresh_on_c c tc2) - | Cproduct(l) -> Cproduct(List.map (fresh_on_c c) l) - | Catom _ -> Catom(c) - -(* Compute the sup of two causality types *) -let rec suptype is_right left_tc right_tc = - match left_tc, right_tc with - | Cproduct(l1), Cproduct(l2) -> - let tc_list = - try List.map2 (suptype is_right) l1 l2 - with Invalid_argument _ -> assert false in - Cproduct(tc_list) - | Catom(c1), Catom(c2) -> Catom(sup_c is_right c1 c2) - | Cfun(left_tc1, left_tc2), Cfun(right_tc1, right_tc2) -> - Cfun(suptype (not is_right) left_tc1 right_tc1, - suptype is_right left_tc2 right_tc2) - | _ -> assert false - -and sup_c is_right left_c right_c = - let left_c = crepr left_c in - let right_c = crepr right_c in - let c = new_var () in - if is_right then - begin less_c left_c c; less_c right_c c end - else - begin less_c c left_c; less_c c right_c end; - c - -let suptype_list is_right tc_list = - match tc_list with - | [] -> assert false - | hd :: tl -> List.fold_left (suptype is_right) hd tl - -(** Computing a causality type from a type *) -let rec skeleton ty = - match ty.t_desc with - | Tvar -> atom (new_var ()) - | Tproduct(ty_list) -> product (List.map skeleton ty_list) - | Tfun(_, _, ty_arg, ty) -> - funtype (skeleton ty_arg) (skeleton ty) - | Tconstr(_, _, _) | Tvec _ -> atom (new_var ()) - | Tlink(ty) -> skeleton ty - -(* the type is synchronised on [c] *) -let skeleton_on_c c ty = - let rec skeleton_on_c is_right c_right ty = - match ty.t_desc with - | Tvar | Tconstr(_, _, _) | Tvec _ -> atom c_right - | Tproduct(ty_list) -> - product (List.map (skeleton_on_c is_right c_right) ty_list) - | Tfun(_, _, ty_arg, ty) -> - let c_left = new_var () in - (* if is_right then *) less_c c_left c_right; - funtype - (skeleton_on_c (not is_right) c_left ty_arg) - (skeleton_on_c is_right c_right ty) - | Tlink(ty) -> skeleton_on_c is_right c_right ty in - skeleton_on_c true c ty - -(* the skeleton for the type of a variable. no constraint for function types *) -(* only for other types *) -let skeleton_for_variables ty = - let c = new_var () in - let rec skeleton_rec ty = - match ty.t_desc with - | Tvar | Tconstr(_, _, _) | Tvec _ -> atom c - | Tproduct(ty_list) -> product (List.map skeleton_rec ty_list) - | Tfun _ -> skeleton ty - | Tlink(ty) -> skeleton_rec ty in - skeleton_rec ty - -(* Returns a causality type that is structurally like [tc] but *) -(* also depend on variables in [cset] *) -let rec on_c is_right cset tc = - match tc with - | Cproduct(l) -> Cproduct(List.map (on_c is_right cset) l) - | Cfun(tc1, tc2) -> - Cfun(on_c (not is_right) cset tc1, on_c is_right cset tc2) - | Catom(left_c) -> - let right_c = new_var () in - let cset = S.add left_c cset in - if is_right then S.iter (fun c -> less_c c right_c) cset - else S.iter (fun c -> less_c right_c c) cset; - Catom(right_c) - -let on_c tc c = on_c true (S.singleton c) tc - -(** Simplification of types *) -(* Mark useful variables *) -let rec mark tc = - match tc with - | Cfun(tc1, tc2) -> - mark tc1; mark tc2 - | Cproduct(tc_list) -> List.iter mark tc_list - | Catom(c) -> mark_c c - -and mark_c c = - let c = crepr c in - match c.c_desc with - | Cvar -> - c.c_useful <- true; - | Clink(link) -> mark_c link - -let mark_and_polarity is_right tc = mark tc; polarity is_right tc - -(* we compute IO sets [see Pouzet and Raymond, EMSOFT'09] *) -(* IO(c) = { i / i in I /\ i <_O c } and i <_O c iff O(c) subset O(i) *) -(* Partition according to IO, i.e., two variables with the same IO *) -(* get the same representative *) - -let is_an_output c = - c.c_useful && ((c.c_polarity = Pplus) || (c.c_polarity = Pplusminus)) - -(* compute the set of inputs and outputs *) -let rec ins_and_outs c (inputs, outputs) = - match c.c_desc with - | Clink(link) -> ins_and_outs link (inputs, outputs) - | Cvar -> - match c.c_polarity with - | Pplus -> inputs, S.add c outputs - | Pminus -> S.add c inputs, outputs - | Pplusminus -> S.add c inputs, S.add c outputs - | _ -> inputs, outputs - -let ins_and_outs c_set = S.fold ins_and_outs c_set (S.empty, S.empty) - -let rec ins_and_outs_of_a_type is_right (inputs, outputs) tc = - match tc with - | Cfun(tc1, tc2) -> - let inputs, outputs = - ins_and_outs_of_a_type (not is_right) (inputs, outputs) tc1 in - (* (* do an extra step *) - let inputs, outputs = - if is_right then inputs, outputs - else ins_and_outs_of_a_type is_right (inputs, outputs) tc1 in *) - ins_and_outs_of_a_type is_right (inputs, outputs) tc2 - | Cproduct(tc_list) -> - List.fold_left - (ins_and_outs_of_a_type is_right) (inputs, outputs) tc_list - | Catom(c) -> - let c = crepr c in - if is_right then inputs, S.add c outputs else S.add c inputs, outputs - -(* build O(c) *) -let rec outrec acc c = - let c = crepr c in - match c.c_desc with - | Clink(link) -> outrec acc link - | Cvar -> - let acc = if is_an_output c then S.add c acc else acc in - List.fold_left outrec acc c.c_sup - -let out c = outrec S.empty c -let outset cset = S.fold (fun c acc -> outrec acc c) cset S.empty - -(* compute io(c) *) -(* io(c) = {i in I / O(c) subseteq O(i) } *) -let rec io inputs o_table c = - let o = M.find c o_table in - S.fold - (fun i' acc -> - let o' = M.find i' o_table in - if S.subset o o' then S.add i' acc else acc) - inputs S.empty - -(* build a table [c -> O(c)] *) -let build_o_table c_set o_table = - S.fold (fun i acc -> M.add i (out i) acc) c_set o_table - -(* build a table [c -> IO(c)] *) -let build_io_table inputs o_table c_set io_table = - S.fold (fun i acc -> M.add i (io inputs o_table i) acc) c_set io_table - -(* build a ki table [io -> c] with a unique variable per io set *) -(* and for every [c] the set of greater elements *) -let build_ki_table io_table = - let ki_table = - M.fold - (fun i io acc -> - if K.mem io acc then acc - else K.add io (new_gen_var ()) acc) - io_table K.empty in - (* then add relation between them according to io. *) - (* if ki(io1) = c1 and ki(io2) = c2, c1 < c2 iff (io(c1) subset io(c2)) *) - let dep = - K.fold - (fun io_i ki_i acc -> - K.fold - (fun io_j ki_j acc -> - let c = S.compare io_i io_j in - if c = 0 then acc - else - if S.subset io_i io_j then - try - let c_set = M.find ki_i acc in - M.add ki_i (S.add ki_j c_set) acc - with Not_found -> M.add ki_i (S.singleton ki_j) acc - else acc) - ki_table acc) - ki_table M.empty in - ki_table, dep - -(* Given a dependence relation [ai < ai1,..., ain] *) -(* keep only dependences [a-k < b+k'] *) -let filter dep = - (* only keep a dependence a-k < b+k' *) - let keep c_left c_right = - let c_left = crepr c_left in - let c_right = crepr c_right in - match c_left.c_polarity, c_right.c_polarity with - | (Pminus | Pplusminus), (Pplus | Pplusminus) -> true | _ -> false in - M.fold - (fun c_left c_set acc -> M.add c_left (S.filter (keep c_left) c_set) acc) - dep M.empty - -(* simplifies a causality type *) -let simplify_by_io tc = - let inputs, outputs = - ins_and_outs_of_a_type true (S.empty, S.empty) tc in - let inputs_outputs = S.union inputs outputs in - - (* build the association table [i, O(i)] for every i in I and O *) - let o_table = build_o_table inputs_outputs M.empty in - - (* then the table of io for every input/output *) - let io_table = build_io_table inputs o_table inputs_outputs M.empty in - - (* the ki table associates a unique variable per io set *) - let ki_table, dep = build_ki_table io_table in - - (* computes a type where every variable is replaced by its ki *) - let rec copy tc = - match tc with - | Cfun(tc1, tc2) -> Cfun(copy tc1, copy tc2) - | Cproduct(tc_list) -> Cproduct(List.map copy tc_list) - | Catom(c) -> Catom(K.find (M.find c io_table) ki_table) in - - let tc = copy tc in - (* computes polarities *) - polarity true tc; - (* final clean: only keep dependences [a-k < b+k'] *) - let dep = filter dep in - - (* physically apply the dependences *) - M.iter - (fun c_left c_set -> - S.iter (fun c_right -> less_c c_left c_right) c_set) dep; - tc - - -(* An other simplification method *) -(* Garbage collection: only keep dependences of the form a- < b+ *) -(* this step is done after having called the function mark *) -let rec shorten ty = - match ty with - | Cfun(tc1, tc2) -> shorten tc1; shorten tc2 - | Cproduct(tc_list) -> List.iter shorten tc_list - | Catom(c) -> shorten_c c - -and shorten_c c = - let c = crepr c in - match c.c_desc with - | Clink(c) -> shorten_c c - | Cvar -> - c.c_visited <- 0; - (* only keep a dependence a- < b+ *) - let inf, sup = - match c.c_polarity with - | Punknown -> assert false - | Pplus -> remove_polarity Pplus (short_list false [] c.c_inf), [] - | Pminus -> [], remove_polarity Pminus (short_list true [] c.c_sup) - | Pplusminus -> - short_list false [] c.c_inf, short_list true [] c.c_sup in - c.c_inf <- inf; - c.c_sup <- sup; - c.c_visited <- 1 - -and short_list is_right acc c_list = - List.fold_left (short is_right) acc c_list - -(* only keep a dependence a- < b+ *) -and remove_polarity p c_list = - let clear acc c_right = - match p, c_right.c_polarity with - | (Pplus, Pplus) | (Pminus, Pminus) -> acc - | _ -> c_right :: acc in - List.fold_left clear [] c_list - -and short is_right acc c = - match c.c_desc with - | Clink(c) -> short is_right acc c - | Cvar -> - match c.c_visited with - | -1 -> (* never visited *) - c.c_visited <- 0; - let acc = - short_list is_right acc (if is_right then c.c_sup else c.c_inf) in - let acc = if c.c_useful then add c acc else acc in - c.c_visited <- -1; - acc - | 0 -> (* currently visited *) - acc - | _ -> (* visited in a previous pass *) - (* the variable is added only if it is useful *) - if c.c_useful then add c acc else union c.c_inf acc - - -(* Final simplification. *) -(*- if a- has a single sup. b+, it can be replaced by it - *- if a+ has a single inf. b-, it can be replaced by it. *) -let rec simplify right tc = - match tc with - | Cfun(tc1, tc2) -> funtype (simplify (not right) tc1) (simplify right tc2) - | Cproduct(tc_list) -> product(List.map (simplify right) tc_list) - | Catom(c) -> Catom(csimplify right c) - -and csimplify right c = - let c = crepr c in - match c.c_desc with - | Clink _ -> c - | Cvar -> - if right then - match c.c_inf, c.c_polarity with - | [c_inf], Pplus -> - increase_polarity Pplus c_inf; - c.c_useful <- false; c_inf - | _ -> c - else - match c.c_sup, c.c_polarity with - | [c_sup], Pminus -> - increase_polarity Pminus c_sup; - c.c_useful <- false; c_sup - | _ -> c - -let simplify is_right tc = - shorten tc; - let tc = simplify is_right tc in - mark_and_polarity is_right tc; - shorten tc; - tc - -(* Shrink a cycle by keeping only names in [cset] *) -let shrink_cycle cset c_list = - let shrink c = S.mem c cset in - List.filter shrink c_list - -(* Keep explicit names in a causality cycle *) -let keep_names_in_cycle c_set c_list = - let keep_name c = - let c = crepr c in - match c.c_info with - | None -> false | Some(info) -> true in - let keep_var c = S.mem c c_set in - let c_filtered_list = List.filter keep_name c_list in - match c_filtered_list with - | [] -> List.filter keep_var c_list - | _ -> c_filtered_list - -(* Compute the transitive reduction of the dependence relation *) -let reduce cset = - (* build the graph *) - let c_to_i, g, _ = - S.fold (fun c (c_to_i, g, i) -> M.add c i c_to_i, Graph.add i c g, i+1) - cset (M.empty, Graph.empty, 0) in - (* Format.printf "%a" (Graph.print Pcaus.caus) g; *) - let g = - S.fold - (fun c g -> - let i = M.find c c_to_i in - let sups = - List.fold_left - (fun acc c -> Graph.S.add (M.find c c_to_i) acc) - Graph.S.empty c.c_sup in - Graph.add_before (Graph.S.singleton i) sups g) cset g in - let g = Graph.outputs g in - (* compute the transitive reduction *) - (* Format.printf "%a" (Graph.print Pcaus.caus) g; *) - let g = Graph.transitive_reduction g in - (* Format.printf "%a" (Graph.print Pcaus.caus) g; *) - (* reconstruct the relation *) - S.iter - (fun c -> - let i = M.find c c_to_i in - let sups = - Graph.S.fold (fun j acc -> (Graph.containt j g) :: acc) - (Graph.successors i g) [] in - c.c_sup <- sups) - cset - - -(** Computes the dependence relation from a list of causality variables *) -(* variables in [already] are disgarded *) -let relation (already, rel) cset = - let rec relation (already, rel) c = - let c = crepr c in - if S.mem c already then already, rel - else if c.c_sup = [] then already, rel - else List.fold_left - relation (S.add c already, (c, set c.c_sup) :: rel) c.c_sup in - S.fold (fun c acc -> relation acc c) cset (already, []) - -(** Generalisation of a type *) -(* the level of generalised type variables *) -(* is set to [generic]. Returns [generic] when a sub-term can be generalised *) -let list_of_vars = ref [] - -let rec gen tc = - match tc with - | Cproduct(tc_list) -> List.iter gen tc_list - | Cfun(tc1, tc2) -> gen tc1; gen tc2 - | Catom(c) -> ignore (cgen c) - -and cgen c = - let c = crepr c in - match c.c_desc with - | Cvar -> - c.c_useful <- false; - if c.c_level > !binding_level - then - begin - c.c_level <- generic; - let level = gen_set c.c_sup in - c.c_level <- level; - if level = generic then list_of_vars := c :: !list_of_vars - end; - c.c_level - | Clink(link) -> cgen link - -and gen_set l = List.fold_left (fun acc c -> max (cgen c) acc) generic l - -(** Main generalisation function *) -let generalise tc = - list_of_vars := []; - (* we compute useful variables *) - mark_and_polarity true tc; - (* type simplification *) - (* let tc = simplify true tc in *) - let tc = - if !Zmisc.no_simplify_causality_type then tc else simplify_by_io tc in - (* check_type tc; *) - gen tc; - let c_set = vars S.empty tc in - if not !Zmisc.no_simplify_causality_type then reduce c_set; - let _, rel = relation (S.empty, []) c_set in - { typ_vars = !list_of_vars; typ_rel = rel; typ = tc } - -(** Instantiation of a type *) -(* save and cleanup links *) -let links = ref [] - -let save link = links := link :: !links -let cleanup () = List.iter (fun c -> c.c_desc <- Cvar) !links; links := [] - -(* makes a copy of the type scheme *) -let rec copy tc ty = - let rec ccopy c = - match c.c_desc with - | Cvar -> - if c.c_level = generic - then - let sup_list = List.map ccopy c.c_sup in - let v = { (new_var ()) with c_sup = sup_list } in - c.c_desc <- Clink(v); - save c; - v - else c - | Clink(link) -> if c.c_level = generic then link else ccopy link in - - let { t_desc = t_desc } as ty = Ztypes.typ_repr ty in - match tc, t_desc with - | Cfun(tc1, tc2), Tfun(_, _, ty1, ty2) -> - funtype (copy tc1 ty1) (copy tc2 ty2) - | Cproduct(tc_list), Tproduct(ty_list) -> - begin try product (List.map2 copy tc_list ty_list) - with | Invalid_argument _ -> assert false end - | Catom(c), _ -> skeleton_on_c (ccopy c) ty - | _ -> assert false - -(* makes a copy of the type scheme *) -let rec copy tc = - let rec ccopy c = - match c.c_desc with - | Cvar -> - if c.c_level = generic - then - let sup_list = List.map ccopy c.c_sup in - let v = { (new_var ()) with c_sup = sup_list } in - c.c_desc <- Clink(v); - save c; - v - else c - | Clink(link) -> if c.c_level = generic then link else ccopy link in - - match tc with - | Cfun(tc1, tc2) -> funtype (copy tc1) (copy tc2) - | Cproduct(tc_list) -> product (List.map copy tc_list) - | Catom(c) -> atom (ccopy c) - -(* instanciate the causality type according to the type *) -let rec instance tc ty = - let { t_desc = t_desc } as ty = Ztypes.typ_repr ty in - match tc, t_desc with - | Cfun(tc1, tc2), Tfun(_, _, ty1, ty2) -> - funtype (instance tc1 ty1) (instance tc2 ty2) - | Cproduct(tc_list), Tproduct(ty_list) -> - begin try product (List.map2 instance tc_list ty_list) - with | Invalid_argument _ -> assert false end - | Catom(c), _ -> skeleton_on_c c ty - | _ -> assert false - -(* subtyping *) -let rec subtype right tc = - match tc with - | Cfun(tc1, tc2) -> - funtype (subtype (not right) tc1) (subtype right tc2) - | Cproduct(tc_list) -> - begin try product (List.map (subtype right) tc_list) - with | Invalid_argument _ -> assert false end - | Catom(c) -> - let new_c = new_var () in - if right then less_c c new_c else less_c new_c c; - atom new_c - -let instance { typ = tc } ty = - let tc = copy tc in - cleanup (); - let tc = subtype true tc in - instance tc ty - -(** Type instance *) -let instance { value_caus = tcs_opt } ty = - (* build a default signature *) - let default ty = - let c = new_var () in - skeleton_on_c c ty in - match tcs_opt with - | None -> - (* if no causality signature is declared, a default one is built *) - (* from the type signature *) - subtype true (default ty) - | Some(tcs) -> instance tcs ty - -(* check that [tc] is of the form [tc1;...;tc_arity] *) -let filter_product arity tc = - match tc with - | Cproduct(l) when List.length l = arity -> l - | _ -> assert false - -(* check that [tc] is a function type *) -let filter_arrow tc = - match tc with - | Cfun(tc1, tc2) -> tc1, tc2 - | _ -> assert false - -(* Environment for causality types *) -type tentry = - { t_typ: tc; (* the causality type of x *) - t_last_typ: tc option; (* [last x] is allowed *) - } - -(* simplifies a typing environment *) -let simplify_by_io_env env expected_tc actual_tc = - let mark_env _ { t_typ = tc; t_last_typ = ltc_opt } = - mark_and_polarity true tc; - Zmisc.optional_unit mark_and_polarity true ltc_opt in - let simplify_env { t_typ = tc; t_last_typ = ltc_opt } = - let tc = simplify_by_io tc in - let ltc_opt = Zmisc.optional_map simplify_by_io ltc_opt in - { t_typ = tc; t_last_typ = ltc_opt } in - Env.iter mark_env env; - mark_and_polarity true expected_tc; - mark_and_polarity true actual_tc; - let env = Env.map simplify_env env in - (* Computes the set of free variables and dependence relations *) - let cset = - Env.fold - (fun _ { t_typ = tc; t_last_typ = ltc_opt } acc -> - Zmisc.optional vars (vars acc tc) ltc_opt) env S.empty in - let cset = vars (vars cset expected_tc) actual_tc in - let already, rel = relation (S.empty, []) cset in - env, cset, rel, simplify_by_io expected_tc, simplify_by_io actual_tc - -(* compute the dependence relations *) -let prel ff rel = - match rel with - | [] -> () - | _ -> Format.fprintf ff "@[@ with@ @[%a@]@]" Pcaus.relation rel - -(* prints the typing environment *) -let penv ff env = - (* print every entry in the typing environment *) - let pentry ff (n, { t_typ = tc; t_last_typ = ltc_opt }) = - match ltc_opt with - | None -> Format.fprintf ff "@[%a: %a@]" Printer.source_name n Pcaus.ptype tc - | Some(ltc) -> - Format.fprintf ff "@[%a: %a | %a@]" - Printer.source_name n Pcaus.ptype tc Pcaus.ptype ltc in - let env = Env.bindings env in - Pp_tools.print_list_r pentry "{" ";" "}" ff env diff --git a/compiler/analysis/causality.ml b/compiler/analysis/causality.ml deleted file mode 100644 index 52d0fa1ce..000000000 --- a/compiler/analysis/causality.ml +++ /dev/null @@ -1,745 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* causality check *) - -(* C | H |-cfree e: ct *) -(* [C] is a constraint and [H] is an environment *) - -(* There are two kind of types. c is a causality tag (or time stamp). *) -(* ct is a type whose leaves are causality tags. *) -(* causality tags are associated to a strict partial order. *) -(* The relation c1 < c2 with |-cfree e1: c1 and |-cfree e2: c2 *) -(* means that e1 must be computed strictly before c2 *) -(* The causality analysis is able to express that a block executes atomically, *) -(* that is, it is considered as iff all output would depend on all input *) -(* For that purpose, cfree is a causality tag greater than that of all the *) -(* free variables in e *) - -open Zmisc -open Zident -open Global -open Zelus -open Zlocation -open Deftypes -open Defcaus -open Pcaus -open Causal - -let print x = Zmisc.internal_error "unbound" Printer.name x - -(* Main error message *) -type error = - { kind: kind; - cycle: cycle; - env: Causal.tentry Env.t } - - and kind = - | Cless_than of tc * tc - | Cless_than_name of Zident.t * tc * tc - -(* dependence cycle and the current typing environment *) -exception Error of location * error - -let error loc kind = raise (Error(loc, kind)) - -(* let message loc kind = - begin - match kind with - | Cless_than(left_tc, right_tc, env, cycle) -> - let env, cset, rel, left_tc, right_tc = - Causal.simplify_by_io_env env left_tc right_tc in - let cycle = Causal.shrink_cycle cset cycle in - Format.eprintf - "@[%aCausality error: This expression has causality type@ %a,@ \ - whereas it should be less than@ %a@.\ - Here is an example of a cycle:@.%a@.\ - in the current typing environment:@.%a%a@.@]" - output_location loc - Pcaus.ptype left_tc - Pcaus.ptype right_tc - (Pcaus.cycle false) cycle - Causal.penv env - Causal.prel rel - end; - raise Zmisc.Error *) - -let message loc { kind; cycle } = - begin - match kind with - | Cless_than(left_tc, right_tc) -> - let c_set = vars (vars S.empty left_tc) right_tc in - let cycle = Causal.keep_names_in_cycle c_set cycle in - Format.eprintf - "@[%aCausality error: This expression has causality type@ %a,\ - @ whereas it should be less than@ %a@.\ - Here is an example of a cycle:@.%a@.@]" - output_location loc - Pcaus.ptype left_tc - Pcaus.ptype right_tc - (Pcaus.cycle true) cycle - | Cless_than_name(name, left_tc, right_tc) -> - let c_set = vars (vars S.empty left_tc) right_tc in - let cycle = Causal.keep_names_in_cycle c_set cycle in - Format.eprintf - "@[%aCausality error: The variable %s has causality type@ %a,\ - @ whereas it should be less than@ %a@.\ - Here is an example of a cycle:@.%a@.@]" - output_location loc - (Zident.source name) - Pcaus.ptype left_tc - Pcaus.ptype right_tc - (Pcaus.cycle true) cycle - end; - raise Zmisc.Error - -let less_than loc env actual_tc expected_tc = - try - Causal.less actual_tc expected_tc - with - | Causal.Clash(cycle) -> - error loc - { kind = Cless_than(actual_tc, expected_tc); env = env; cycle = cycle } - -let less_than_name loc env name actual_tc expected_tc = - try - Causal.less actual_tc expected_tc - with - | Causal.Clash(cycle) -> - error loc - { kind = Cless_than_name(name, actual_tc, expected_tc); - env = env; cycle = cycle } - -let less_than_c loc env actual_c expected_c = - try - Causal.less_c actual_c expected_c - with - | Causal.Clash(cycle) -> - error loc - { kind = Cless_than(atom actual_c, atom expected_c); - env = env; cycle = cycle } - -(** Typing a pattern. [pattern env p = tc] where [tc] is the type *) -(* of pattern [p] in [env] *) -let pattern env pat = - (* check that the type of pat is less than a type synchronised on [c] *) - let rec pattern_less_than_on_c pat c = - let actual_tc = pattern pat in - let expected_tc = Causal.skeleton_on_c c pat.p_typ in - (* the order [expected_tc < actual_tc] is mandatory, *) - (* not the converse *) - less_than pat.p_loc env expected_tc actual_tc - - and pattern ({ p_desc = desc; p_loc = loc; p_typ = ty } as pat) = - let tc = match desc with - | Ewildpat | Econstpat _ | Econstr0pat _ -> - Causal.skeleton_on_c (Causal.new_var ()) ty - | Evarpat(x) -> - let { t_typ = actual_tc } = - try Env.find x env with | Not_found -> print x in - (* every variable that is not a function has an atomic type *) - let expected_tc = Causal.skeleton_for_variables pat.p_typ in - less_than loc env expected_tc actual_tc; - expected_tc - | Econstr1pat(_, pat_list) -> - let c = Causal.new_var () in - List.iter (fun pat -> pattern_less_than_on_c pat c) pat_list; - Causal.skeleton_on_c c ty - | Etuplepat(pat_list) -> - product(List.map pattern pat_list) - | Erecordpat(l) -> - (* from the causality point of view, a record is considered to be *) - (* atomic *) - let c = Causal.new_var () in - List.iter (fun (_, p) -> pattern_less_than_on_c p c) l; - Causal.skeleton_on_c c ty - | Etypeconstraintpat(p, _) -> pattern p - | Eorpat(p1, p2) -> - let tc1 = pattern p1 in - let tc2 = pattern p2 in - Causal.suptype true tc1 tc2 - | Ealiaspat(p, x) -> - let tc_p = pattern p in - let tc_n = - let { t_typ = actual_tc } = - try Env.find x env with | Not_found -> print x in - (* every variable that is not a function has an atomic type *) - let expected_tc = Causal.skeleton_for_variables pat.p_typ in - less_than loc env expected_tc actual_tc; - expected_tc in - less_than p.p_loc env tc_n tc_p; - tc_p in - (* annotate the pattern with the causality type *) - pat.p_caus <- tc; - tc in - pattern pat - -(** Build an environment from a typing environment. *) -let build_env l_env env = - let entry n { Deftypes.t_typ = ty; Deftypes.t_sort = sort } acc = - let cur_tc = Causal.annotate (Cname n) (Causal.skeleton ty) in - let last_tc_opt = - match sort with - | Smem { m_previous = true } -> - Some(Causal.annotate (Clast n) (Causal.skeleton ty)) - | _ -> None in - Env.add n { t_typ = cur_tc; t_last_typ = last_tc_opt } acc in - Env.append (Env.fold entry l_env Env.empty) env - -(** Build an environment with all entries synchronised on [c] *) -let build_env_on_c c l_env env = - let entry n { Deftypes.t_typ = ty; Deftypes.t_sort = sort } acc = - let cur_tc = Causal.annotate (Cname n) (Causal.skeleton_on_c c ty) in - let last_tc_opt = - match sort with - | Smem { m_previous = true } -> - Some(Causal.annotate (Clast n) (Causal.skeleton_on_c c ty)) - | _ -> None in - Env.add n { t_typ = cur_tc; t_last_typ = last_tc_opt } acc in - Env.append (Env.fold entry l_env Env.empty) env - -(** Build an environment for a set of written variables *) -(* [x1:ct1;...; xn:tcn] with [cti < ct'i] where [env(xi) = ct'i] *) -let def_env loc defnames env = - let add x acc = - let { t_typ = tc } as tentry = Env.find x env in - let ltc = Causal.fresh tc in - less_than_name loc env x ltc tc; - Env.add x { tentry with t_typ = ltc } acc in - let env_defnames = - Zident.S.fold add (Deftypes.cur_names Zident.S.empty defnames) Env.empty in - Env.append env_defnames env - -(** Build an environment for a set of written variables *) -(* such that their causality types are *) -(* [x1:ct1[c];...; xn:tcn[c]] where [cti[c] < ct'i] *) -(* for all xi such that [env(xi) = ct'i] *) -let def_env_on_c loc defnames env c = - let add x acc = - let { t_typ = tc } as tentry = Env.find x env in - let ltc = Causal.fresh_on_c c tc in - less_than_name loc env x ltc tc; - Env.add x { tentry with t_typ = ltc } acc in - let shared = Deftypes.cur_names Zident.S.empty defnames in - let env_defnames = Zident.S.fold add shared Env.empty in - shared, Env.append env_defnames env - -(** Build an environment from [env] by replacing the causality *) -(* of [x] by its last causality for all [x in [shared\defnames]] *) -(* E.g., [match e with P1 -> x = ... | P2 -> y = ...] *) -(* with [x:a|b; y:c|d]; then [x:a|b; y:d|d] for the left branch *) -(* which means that it is analysed as if [x = ... and y = last y] *) -(* was written. *) -let last_env shared defnames env = - let add x acc = - let { t_typ = tc; t_last_typ = ltc_opt } = Env.find x env in - let tc, ltc_opt = - match ltc_opt with - | None -> Causal.fresh tc, None | Some(ltc) -> ltc, Some(ltc) in - Env.add x { t_typ = tc; t_last_typ = ltc_opt } acc in - let names = Deftypes.cur_names Zident.S.empty defnames in - let env_defnames = - Zident.S.fold add (Zident.S.diff shared names) Env.empty in - Env.append env_defnames env - -(** Causality analysis of a match handler.*) -(* free variables must have a causality tag less than [c_body] *) -let match_handlers body env c_body c_e m_h_list = - let handler { m_pat = p; m_body = b; m_env = m_env } = - let env = build_env_on_c c_e m_env env in - let _ = pattern env p in - body env c_body b in - List.map handler m_h_list - -(** Causality analysis of a present handler *) -let present_handlers - scondpat body env c_free c_e c_body p_h_list h_opt = - let handler { p_cond = scpat; p_body = b; p_env = p_env } = - (* computations in [scpat] must have a tag less than [c_e] *) - let env = build_env p_env env in - let actual_c = scondpat env c_free scpat in - less_than_c scpat.loc env actual_c c_e; - (* computations in [body] must have a tag less than [c_body] *) - body env c_body b in - let res_list = List.map handler p_h_list in - match h_opt with - | None -> res_list - | Some(h) -> (body env c_body h) :: res_list - -(** causality of an expression. [C | H |-cfree e: ct] *) -let rec exp env c_free ({ e_desc = desc; e_typ = ty; e_loc = loc } as e) = - let tc = match desc with - | Econst _ | Econstr0 _ | Eperiod _ -> Causal.skeleton ty - | Eglobal { lname = lname } -> - let { info = info } = Modules.find_value lname in - Causal.instance info ty - | Elocal(x) -> - let { t_typ = tc } = try Env.find x env with Not_found -> print x in - let tc = subtype true tc in - let cset = Causal.vars S.empty tc in - (* all elements [ci in cset] are such that [ci < c_free] *) - S.iter (fun ci -> less_than_c loc env ci c_free) cset; - tc - | Elast(x) -> - let { t_last_typ = tc_opt } = - try Env.find x env with Not_found -> print x in - let tc = match tc_opt with | None -> assert false | Some(tc) -> tc in - let cset = Causal.vars S.empty tc in - (* all elements [ci in cset] are such that [ci < c_free] *) - S.iter (fun ci -> less_than_c loc env ci c_free) cset; - tc - | Econstr1(_, e_list) -> - let c = Causal.new_var () in - List.iter (fun e -> exp_less_than_on_c env c_free e c) e_list; - Causal.skeleton_on_c c ty - | Etuple(e_list) -> - product (List.map (exp env c_free) e_list) - | Eop(op, e_list) -> - operator env op c_free ty e_list - | Eapp(_, e, e_list) -> - app env c_free (exp env c_free e) e_list - | Erecord_access(e_record, _) -> - let c_record = Causal.new_var () in - exp_less_than_on_c env c_free e_record c_record; - Causal.skeleton_on_c c_record ty - | Erecord(l) -> - let c_record = Causal.new_var () in - List.iter - (fun (_, e) -> exp_less_than_on_c env c_free e c_record) l; - Causal.skeleton_on_c c_record ty - | Erecord_with(e_record, l) -> - let c_record = Causal.new_var () in - exp_less_than_on_c env c_free e_record c_record; - List.iter - (fun (_, e) -> exp_less_than_on_c env c_free e c_record) l; - Causal.skeleton_on_c c_record ty - | Etypeconstraint(e, _) -> exp env c_free e - | Elet(l, e_let) -> - let new_env = local env c_free l in - let tc = exp new_env c_free e_let in - tc - | Eblock(b, e_block) -> - let env = block_eq_list Zident.S.empty env c_free b in - let tc = exp env c_free e_block in - tc - | Eseq(e1, e2) -> - ignore (exp env c_free e1); - exp env c_free e2 - | Epresent(h_e_list, e_opt) -> - let c_body = Causal.intro_less_c c_free in - let c_scpat = Causal.intro_less_c c_body in - let actual_tc = - present_handler_exp_list - env c_free c_body c_scpat h_e_list e_opt in - (* the result control depend on the signal patterns [scpat] *) - on_c actual_tc c_body - | Ematch(_, e, h_e_list) -> - let c_body = Causal.intro_less_c c_free in - let c_e = Causal.intro_less_c c_body in - exp_less_than_on_c env c_free e c_e; - let actual_tc = match_handler_exp_list env c_body c_e h_e_list in - (* the result control depend on [e] *) - on_c actual_tc c_body in - (* annotate [e] with the causality type *) - e.e_caus <- tc; - tc - -(** Typing an application *) -and app env c_free tc_fct arg_list = - (* typing the list of arguments *) - let rec args tc_fct = function - | [] -> subtype true tc_fct - | arg :: arg_list -> - let tc1, tc2 = Causal.filter_arrow tc_fct in - exp_less_than env c_free arg tc1; - args tc2 arg_list in - args tc_fct arg_list - -(** Typing an operator *) -and operator env op c_free ty e_list = - (* the type of the result *) - let c_res = Causal.intro_less_c c_free in - match op, e_list with - | Eunarypre, [e] -> - exp_less_than_on_c env c_free e (Causal.new_var ()); - Causal.skeleton_on_c c_res ty - | Efby, [e1;e2] -> - exp_less_than_on_c env c_free e2 (Causal.new_var ()); - exp_less_than_on_c env c_free e1 c_res; - Causal.skeleton_on_c c_res ty - | Eminusgreater, [e1;e2] -> - exp_less_than_on_c env c_free e1 c_res; - exp_less_than_on_c env c_free e2 c_res; - Causal.skeleton_on_c c_res ty - | Eifthenelse, [e1; e2; e3] -> - exp_less_than_on_c env c_free e1 c_res; - exp_less_than_on_c env c_free e2 c_res; - exp_less_than_on_c env c_free e3 c_res; - Causal.skeleton_on_c c_res ty - | Eup, [e] -> - (* [up(e)] does not depend instantaneously of itself *) - exp_less_than_on_c env c_free e (Causal.new_var ()); - Causal.skeleton_on_c c_res ty - | Einitial, [] -> - Causal.skeleton_on_c c_res ty - | (Etest | Edisc | Ehorizon), [e] -> - exp_less_than_on_c env c_free e c_res; - Causal.skeleton_on_c c_res ty - | Eaccess, [e1; e2] -> - exp_less_than_on_c env c_free e1 c_res; - exp_less_than_on_c env c_free e2 c_res; - Causal.skeleton_on_c c_res ty - | Eupdate, [e1; i; e2] -> - exp_less_than_on_c env c_free e1 c_res; - exp_less_than_on_c env c_free i c_res; - exp_less_than_on_c env c_free e1 c_res; - Causal.skeleton_on_c c_res ty - | Eslice _, [e] -> - exp_less_than_on_c env c_free e c_res; - Causal.skeleton_on_c c_res ty - | Econcat, [e1; e2] -> - exp_less_than_on_c env c_free e1 c_res; - exp_less_than_on_c env c_free e2 c_res; - Causal.skeleton_on_c c_res ty - | Eatomic, [e] -> - let c_arg = Causal.intro_less_c c_res in - exp_less_than_on_c env c_free e c_arg; - Causal.skeleton_on_c c_res ty - | _ -> assert false - - -(** Typing an expression with an expected causality *) -(* The causality tag of [e] must be less than [expected_c] *) -(* free variables in [e] must have a tag less than [c_free] *) -and exp_less_than_on_c env c_free e expected_c = - let actual_tc = exp env c_free e in - let expected_tc = Causal.skeleton_on_c expected_c e.e_typ in - less_than e.e_loc env actual_tc expected_tc; - (* annotate [e] with the causality type *) - e.e_caus <- expected_tc - -and exp_less_than env c_free e expected_tc = - let actual_tc = exp env c_free e in - less_than e.e_loc env actual_tc expected_tc; - (* annotate [e] with the causality type *) - e.e_caus <- expected_tc - -(** Typing a list of equations [env |-c eq list] *) -and equation_list env c_free eq_list = List.iter (equation env c_free) eq_list - -(** Typing of an equation. [env |-cfree eq] *) -and equation env c_free { eq_desc = desc; eq_write = defnames; eq_loc = loc } = - match desc with - | EQeq(p, e) -> - let tc_p = pattern env p in - exp_less_than env c_free e tc_p - | EQpluseq(n, e) -> - let tc_n = - try let { t_typ = tc } = Env.find n env in tc - with Not_found -> print n in - exp_less_than env c_free e tc_n - | EQder(n, e, e0_opt, h_e_list) -> - let { t_typ = expected_tc; t_last_typ = ltc_opt } = - try Env.find n env with | Not_found -> print n in - let _ = exp env c_free e in - (match h_e_list, e0_opt with - | [], None -> () - | _ -> - let c_body = Causal.intro_less_c c_free in - let c_e = Causal.intro_less_c c_body in - let actual_tc = - present_handler_exp_list env c_free c_e c_body h_e_list e0_opt in - let actual_tc = on_c actual_tc c_body in - less_than loc env actual_tc expected_tc; - match e0_opt, ltc_opt with - | Some(e0), Some(ltc) -> - let actual_ltc = exp env c_body e0 in - less_than e0.e_loc env actual_ltc ltc - | _ -> ()) - | EQinit(n, e0) -> - let { t_typ = tc_n; t_last_typ = ltc_opt } = - try Env.find n env with | Not_found -> print n in - let actual_tc = exp env c_free e0 in - less_than e0.e_loc env actual_tc tc_n; - (match ltc_opt with - | None -> () | Some(ltc) -> less_than e0.e_loc env actual_tc ltc) - | EQnext(n, e, e0_opt) -> - (* [e] does not impose a causality constraint on [n] *) - let _ = exp env c_free e in - let { t_typ = tc } = try Env.find n env with Not_found -> print n in - Zmisc.optional_unit (fun _ e0 -> exp_less_than env c_free e0 tc) () e0_opt - | EQautomaton(is_weak, s_h_list, se_opt) -> - (* Typing a state expression *) - let state env c_free c_e { desc = desc } = - match desc with - | Estate0 _ -> () - | Estate1(_, e_list) -> - List.iter (fun e -> exp_less_than_on_c env c_free e c_e) e_list in - (* Compute the set of names defined by a state *) - let cur_names_in_state b trans = - let block acc { b_write = w } = Deftypes.cur_names acc w in - let escape acc { e_block = b_opt } = Zmisc.optional block acc b_opt in - block (List.fold_left escape Zident.S.empty trans) b in - (* Typing of handlers *) - (* scheduling is done this way: *) - (* - Automata with strong preemption: *) - (* 1. compute unless conditions; *) - (* 2. execute the corresponding handler. *) - (* - Automata with weak preemption: *) - (* 1. compute the body; 2. compute the next active state. *) - (* the causality constraints must reproduce this scheduling *) - let escape shared env c_free c_spat - { e_cond = sc; e_block = b_opt; e_next_state = ns; e_env = e_env } = - let env = build_env e_env env in - let actual_c = scondpat env c_free sc in - less_than_c sc.loc env actual_c c_spat; - let env = - Zmisc.optional - (fun env b -> block_eq_list shared env c_free b) env b_opt in - state env c_free c_spat ns in - let weak shared env c_body c_trans c_scpat - { s_body = b; s_trans = trans; s_env = s_env } = - (* remove from [shared] names defined in the current state *) - let shared = Zident.S.diff shared (cur_names_in_state b trans) in - let env = build_env s_env env in - let env = block_eq_list shared env c_body b in - List.iter (escape shared env c_trans c_scpat) trans in - let strong shared env c_body c_trans c_scpat - { s_body = b; s_trans = trans; s_env = s_env } = - (* remove from [shared] names defined in the current state *) - let shared = Zident.S.diff shared (cur_names_in_state b trans) in - let env = build_env s_env env in - List.iter (escape shared env c_trans c_scpat) trans; - ignore (block_eq_list shared env c_body b) in - let c_automaton = Causal.intro_less_c c_free in - Zmisc.optional_unit (state env c_free) c_automaton se_opt; - (* Every branch of the automaton is considered to be executed atomically *) - let shared, env = def_env_on_c loc defnames env c_automaton in - (* the causality tag for the transition conditions *) - if is_weak then - (* first the body; then the escape condition *) - let c_trans = Causal.intro_less_c c_automaton in - let c_scpat = Causal.intro_less_c c_trans in - let c_body = Causal.intro_less_c c_scpat in - List.iter (weak shared env c_body c_body c_scpat) s_h_list - else - (* first the escape condition; then the body *) - let c_body = Causal.intro_less_c c_automaton in - let c_trans = Causal.intro_less_c c_body in - let c_scpat = Causal.intro_less_c c_trans in - List.iter (strong shared env c_body c_body c_scpat) s_h_list - | EQmatch(_, e, m_h_list) -> - let c_body = Causal.intro_less_c c_free in - let c_e = Causal.intro_less_c c_body in - exp_less_than_on_c env c_free e c_e; - let shared, env = def_env_on_c loc defnames env c_body in - (* the [match/with] is considered to be atomic, i.e., all of *) - (* its outputs depend on all of its free variable. *) - (* This is done by typing the body in an environment where *) - (* [x1:ct1[cbody];...;xn:ctn[cbody]] where [cti[cbody] < ct'i] *) - (* where env(xi) = ct'i *) - match_handler_block_eq_list env shared c_body c_e m_h_list - | EQpresent(p_h_list, b_opt) -> - let c_body = Causal.intro_less_c c_free in - let c_scpat = Causal.intro_less_c c_body in - (* the [present/with] is considered to be executed atomically *) - let shared, env = def_env_on_c loc defnames env c_body in - present_handler_block_eq_list - env shared c_free c_scpat c_body p_h_list b_opt - | EQreset(eq_list, e) -> - let c_e = Causal.intro_less_c c_free in - exp_less_than_on_c env c_free e c_e; - (* the [reset] block is considered to be executed atomically *) - let _, env = def_env_on_c loc defnames env c_e in - (* do it one more so that the causality tag of defined variables *) - (* is strictly less than [c_e] *) - let env = def_env loc defnames env in - equation_list env c_e eq_list - | EQand(and_eq_list) -> - equation_list env c_free and_eq_list - | EQbefore(before_eq_list) -> - equation_list env c_free before_eq_list - | EQemit(n, e_opt) -> - let c_res = Causal.new_var () in - Zmisc.optional_unit - (fun _ e -> exp_less_than_on_c env c_free e c_res) () e_opt; - let { t_typ = expected_tc } = - try Env.find n env with Not_found -> print n in - let actual_tc = Causal.annotate (Cname n) (atom c_res) in - less_than loc env actual_tc expected_tc - | EQblock(b_eq_list) -> - ignore (block_eq_list Zident.S.empty env c_free b_eq_list) - | EQforall { for_index = i_list; for_init = init_list; for_body = b_eq_list; - for_out_env = o_env } -> - (* Build the typing environment for inputs/outputs *) - (* and build an association table [oi out o] for all output pairs *) - let index (io_env, oi2o) { desc = desc } = - match desc with - | Einput(x, e) -> - let in_c = Causal.new_var () in - exp_less_than_on_c env c_free e in_c; - let tc_arg, _ = Ztypes.filter_vec e.e_typ in - let tc = Causal.skeleton_on_c in_c tc_arg in - Env.add x { t_typ = tc; t_last_typ = Some(fresh tc) } io_env, - oi2o - | Eindex(x, e1, e2) -> - let in_c = Causal.new_var () in - exp_less_than_on_c env c_free e1 in_c; - exp_less_than_on_c env c_free e2 in_c; - let tc = Causal.skeleton_on_c in_c e1.e_typ in - Env.add x { t_typ = tc; t_last_typ = Some(fresh tc) } io_env, - oi2o - | Eoutput(oi, o) -> - let out_c = Causal.new_var () in - let { Deftypes.t_typ = ty } = Env.find oi o_env in - let tc = Causal.skeleton_on_c out_c ty in - Env.add oi { t_typ = tc; t_last_typ = Some(fresh tc) } io_env, - Env.add oi o oi2o in - - (* typing the initialization *) - let init init_env { desc = desc } = - match desc with - | Einit_last(x, e) -> - let tc = exp env c_free e in - Env.add x { t_typ = fresh tc; t_last_typ = Some(tc) } init_env in - - (* build the typing environment for read variables from the header *) - let io_env, oi2o = - List.fold_left index (Env.empty, Env.empty) i_list in - - (* build the typing environment for accummulation variables *) - let init_env = List.fold_left init Env.empty init_list in - - (* build the typing environment *) - let env = Env.append io_env env in - let env = Env.append init_env env in - - (* type the body *) - ignore (block_eq_list Zident.S.empty env c_free b_eq_list) - -(* Typing a present handler for expressions *) -(* The handler list must be non empty or [e_opt] not none *) -and present_handler_exp_list env c_free c_e c_body p_h_list e_opt = - (* [spat -> e]: the result both depend on [spat] and [e] *) - let tc_list = - present_handlers scondpat exp env c_free c_e c_body p_h_list e_opt in - Causal.suptype_list true tc_list - -(* Typing a present handler for blocks *) -and present_handler_block_eq_list - env shared c_free c_e c_body p_h_list p_h_opt = - (* [spat -> body]: all outputs from [body] depend on [spat] *) - ignore - (present_handlers - scondpat (block_eq_list shared) env c_free c_e c_body p_h_list p_h_opt) - -(* Typing a match handler for expressions *) -(* The handler list must be not empty *) -and match_handler_exp_list env c_body c_e m_h_list = - let tc_list = match_handlers exp env c_body c_e m_h_list in - Causal.suptype_list true tc_list - -(* Typing a match handler for blocks. *) -and match_handler_block_eq_list env shared c_body c_e m_h_list = - ignore (match_handlers (block_eq_list shared) env c_body c_e m_h_list) - -(* Typing a block with a set of equations in its body. *) -(* if [defnames = {x1,..., xn} with x1:ct'1;...;xn:ct'n in env *) -(* add [x1:ct1;...;xn:ctn] st ct1 < ct'1,..., ctn < ct'n *) -(* if [x in shared\defnames, then the block is implicitly *) -(* completed with a default value. This is achieved by considering that *) -(* the causality of [x] is that of [last x] *) -and block_eq_list shared env c_free - { b_locals = l_list; b_body = eq_list; - b_env = b_env; b_write = defnames; b_loc = loc } = - (* shared variables depend on their last causality *) - let env = last_env shared defnames env in - (* typing local definitions *) - let env = List.fold_left (fun env l -> local env c_free l) env l_list in - (* Build the typing environment for names introduced by a *) - (* [local x1,..., xn in ...] *) - let env = build_env b_env env in - let env = def_env loc defnames env in - equation_list env c_free eq_list; - env - - -(* Typing a local declaration. Returns the extended environment *) -and local env c_free { l_eq = eq_list; l_env = l_env; l_loc = loc } = - (* First extend the typing environment *) - let env = build_env l_env env in - (* Then type the body *) - List.iter (equation env c_free) eq_list; - env - -(* Typing a signal pattern. *) -and scondpat env c_free sc = - let rec scondpat { desc = desc; loc = loc } expected_c = - match desc with - | Econdand(sc1, sc2) | Econdor(sc1, sc2) -> - scondpat sc1 expected_c; scondpat sc2 expected_c - | Econdon(sc1, e) -> - exp_less_than_on_c env c_free e expected_c; - scondpat sc1 expected_c - | Econdexp(e) -> - exp_less_than_on_c env c_free e expected_c - | Econdpat(e, p) -> - exp_less_than_on_c env c_free e expected_c; - let actual_tc = pattern env p in - let expected_tc = Causal.skeleton_on_c expected_c p.p_typ in - less_than p.p_loc env actual_tc expected_tc in - let expected_c = Causal.new_var () in - scondpat sc expected_c; - expected_c - -(* The main function *) -let implementation ff { desc = desc; loc = loc } = - try - match desc with - | Eopen _ | Etypedecl _ -> () - | Econstdecl(f, _, e) -> - Zmisc.push_binding_level (); - let tc = exp Env.empty (Causal.new_var ()) e in - Zmisc.pop_binding_level (); - let tcs = generalise tc in - Global.set_causality (Modules.find_value (Lident.Name(f))) tcs; - (* output the signature *) - if !Zmisc.print_causality_types then Pcaus.declaration ff f tcs - | Efundecl (f, { f_kind = k; f_atomic = atomic; - f_args = p_list; f_body = e; f_env = h0 }) -> - Zmisc.push_binding_level (); - let env = build_env h0 Env.empty in - let actual_tc_list = List.map (pattern env) p_list in - let actual_tc_res = exp env (Causal.new_var ()) e in - let actual_tc = Causal.funtype_list actual_tc_list actual_tc_res in - (* for an atomic node, all outputs depend on all inputs *) - let actual_tc = - if atomic then - let c_res = Causal.new_var () in - let expected_tc = Causal.fresh_on_c c_res actual_tc in - less_than loc env actual_tc expected_tc; - expected_tc - else actual_tc in - Zmisc.pop_binding_level (); - let tcs = generalise actual_tc in - (* then add the current entries in the global environment *) - Global.set_causality (Modules.find_value (Lident.Name(f))) tcs; - (* output the signature *) - if !Zmisc.print_causality_types then Pcaus.declaration ff f tcs - with - | Error(loc, kind) -> message loc kind - -let implementation_list ff impl_list = - List.iter (implementation ff) impl_list; - impl_list diff --git a/compiler/analysis/init.ml b/compiler/analysis/init.ml deleted file mode 100644 index 83c7d4dc5..000000000 --- a/compiler/analysis/init.ml +++ /dev/null @@ -1,549 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* initialization types and basic operations over these types *) - -open Zmisc -open Deftypes -open Definit -open Global - -(** a set of initialization names *) -module S = struct - include (Set.Make(Definit)) - let fprint_t ff s = - Format.fprintf ff "@[{@ "; - iter (fun e -> Format.fprintf ff "%a@ " Pinit.init e) s; - Format.fprintf ff "}@]" -end - -(* a module to represent the set of predecessors/successors of a variable *) -module M = struct - include (Map.Make(Definit)) - let fprint_t fprint_v ff s = - Format.fprintf ff "@[{@ "; - iter (fun k v -> Format.fprintf ff "%a->%a@ " Pinit.init k fprint_v v) s; - Format.fprintf ff "}@]" -end - -let fprint_t = S.fprint_t -let fprint_tt = M.fprint_t S.fprint_t - -(* typing errors *) -type error = Iless_than - -exception Clash of error - -let new_var () = - { i_desc = Ivar; i_index = symbol#name; i_level = !binding_level; - i_inf = []; i_sup = []; i_visited = -1; - i_useful = false; i_polarity = Punknown; i_min = Izero } -let ivalue v = - { i_desc = Ivalue(v); i_index = symbol#name; i_level = generic; - i_inf = []; i_sup = []; - i_visited = -1; i_useful = false; i_polarity = Punknown; i_min = Izero } -let ione = ivalue Ione -let ihalf = ivalue Ihalf -let izero = ivalue Izero -let funtype ti1 ti2 = Ifun(ti1, ti2) -let rec funtype_list ti_arg_list ti_res = - match ti_arg_list with - | [] -> ti_res - | [ti] -> funtype ti ti_res - | ti :: ti_arg_list -> funtype ti (funtype_list ti_arg_list ti_res) -let product l = Iproduct(l) -let atom i = Iatom(i) - -(* basic operation on initialization values *) -let rec irepr i = - match i.i_desc with - | Ilink(i_son) -> - let i_son = irepr i_son in - i.i_desc <- Ilink(i_son); - i_son - | _ -> i - -(* equality of two initialization tags *) -let equal i1 i2 = - let i1 = irepr i1 in - let i2 = irepr i2 in - if i1 == i2 then true - else match i1.i_desc, i2.i_desc with - | Ivalue(v1), Ivalue(v2) -> v1 = v2 - | Ivar, Ivar -> i1.i_index = i2.i_index - | _ -> false - -let rec add i l = - match l with - | [] -> [i] - | i1 :: l1 -> if equal i i1 then l else i1 :: (add i l1) - -let rec remove i l = - match l with - | [] -> [] - | i1 :: l1 -> if equal i i1 then l1 else i1 :: (remove i l1) - -let rec union l1 l2 = - let rec mem i l = - match l with | [] -> false | i1 :: l -> (equal i i1) || (mem i l) in - match l1, l2 with - | [], l2 -> l2 | l1, [] -> l1 - | i :: l1, l2 -> if mem i l2 then union l1 l2 else i :: union l1 l2 - -let set l = List.fold_left (fun acc c -> add c acc) [] l - -(** Sets the polarity of a type. *) -let polarity_c i right = - match i.i_polarity, right with - | Punknown, true -> i.i_polarity <- Pplus - | Punknown, false -> i.i_polarity <- Pminus - | Pminus, true | Pplus, false -> i.i_polarity <- Pplusminus - | _ -> () - -let increase_polarity p i = - match p with - | Punknown -> i.i_polarity <- p - | _ -> if p <> i.i_polarity then i.i_polarity <- Pplusminus - -(* saturate an initialization type [i]. *) -(* on the right, [i] and all types [j] such that [i < j] are replaced by 1. *) -(* on the left, [i] and all types [j] such that [j < i] are replaced *) -(* by 0 if the min of [i] is 0. If it is 1/2, [i < 1/2] *) -let rec saturate_i is_right i = - let i = irepr i in - let iv = if is_right then Ione else Izero in - match i.i_desc with - | Ivalue(i) when i = iv -> () - | Ivar -> - if i.i_min = Ihalf && not is_right then i.i_sup <- add ihalf i.i_sup - else begin - i.i_desc <- Ilink(ivalue iv); - List.iter - (saturate_i is_right) (if is_right then i.i_sup else i.i_inf) - end - | Ilink(i) -> saturate_i is_right i - | _ -> raise (Clash(Iless_than)) - -and less_v v1 v2 = - match v1, v2 with - | (Izero, _) | (_, Ione) | (Ihalf, Ihalf) -> true - | _ -> false - -(** Sub-typing *) -let rec less left_ti right_ti = - if left_ti == right_ti then () - else - match left_ti, right_ti with - | Ifun(ti1, ti2), Ifun(ti3, ti4) -> - less ti2 ti4; less ti3 ti1 - | Iproduct(l1), Iproduct(l2) -> List.iter2 less l1 l2 - | Iatom(i1), Iatom(i2) -> less_i i1 i2 - | _ -> raise (Clash(Iless_than)) - -and less_i left_i right_i = - if left_i == right_i then () - else - let left_i = irepr left_i in - let right_i = irepr right_i in - if left_i == right_i then () - else - match left_i.i_desc, right_i.i_desc with - | (Ivalue(Izero), _) | (_, Ivalue(Ione)) - | (Ivalue(Ihalf), Ivalue(Ihalf)) -> () - | Ivalue(Ihalf), Ivar -> - right_i.i_inf <- add left_i right_i.i_inf - | Ivar, Ivalue(Ihalf) -> - left_i.i_sup <- add right_i left_i.i_sup - | Ivalue(Ione), Ivar -> saturate_i true right_i - | Ivar, Ivalue(Izero) -> saturate_i false left_i - | Ivar, Ivar -> - (* i1,...,in < i < j1,...,jk with *) - (* l1,...,lm < r < s1,...,sr *) - right_i.i_inf <- add left_i right_i.i_inf; - left_i.i_sup <- add right_i left_i.i_sup - | _ -> raise (Clash(Iless_than)) - -(** Computing an initialization type from a type *) -let rec skeleton { t_desc = desc } = - match desc with - | Tvar -> atom (new_var ()) - | Tfun(_, _, ti1, ti2) -> funtype (skeleton ti1) (skeleton ti2) - | Tproduct(ti_list) -> product (List.map skeleton ti_list) - | Tconstr(_, _, _) | Tvec _ -> atom (new_var ()) - | Tlink(ti) -> skeleton ti - -let rec skeleton_on_i i { t_desc = desc } = - match desc with - | Tvar -> atom i - | Tfun(_, _, ti1, ti2) -> - funtype (skeleton_on_i i ti1) (skeleton_on_i i ti2) - | Tproduct(ti_list) -> product (List.map (skeleton_on_i i) ti_list) - | Tconstr(_, _, _) | Tvec _ -> atom i - | Tlink(ti) -> skeleton_on_i i ti - -(* For external values, the skeleton type is over constrained *) -(* only combinatorial function get a polymorphic type signature. *) -(* others must have all their inputs/outputs initialized *) -(* This function is not used for the moment as it would *) -(* prevent to write [x = pre(x)] *) -(* -let skeleton_for_external_values ty = - let rec skeleton_on_i i { t_desc = desc } = - match desc with - | Tvar -> atom i - | Tfun(k, _, ti1, ti2) -> - let i = match k with Tany | Tstatic _ -> i | _ -> izero in - funtype (skeleton_on_i i ti1) (skeleton_on_i i ti2) - | Tproduct(ti_list) -> product (List.map (skeleton_on_i i) ti_list) - | Tconstr(_, _, _) | Tvec _ -> atom i - | Tlink(ti) -> skeleton_on_i i ti in - let i = new_var () in - skeleton_on_i i ty -*) - -let rec fresh_on_i i ti = - match ti with - | Ifun(left_ti, right_ti) -> - funtype (fresh_on_i i left_ti) (fresh_on_i i right_ti) - | Iproduct(ti_list) -> product (List.map (fresh_on_i i) ti_list) - | Iatom _ -> atom i - -(* Compute the infimum/supremum of two types *) -let rec suptype is_right ti1 ti2 = - match ti1, ti2 with - | Ifun(left_ti1, right_ti1), Ifun(left_ti2, right_ti2) -> - Ifun(suptype (not is_right) left_ti1 left_ti2, - suptype is_right right_ti1 right_ti2) - | Iproduct(ti_list1), Iproduct(ti_list2) -> - let ti_list = - try List.map2 (suptype is_right) ti_list1 ti_list2 - with Invalid_argument _ -> assert false in - Iproduct(ti_list) - | Iatom(i1), Iatom(i2) -> Iatom(sup_i is_right i1 i2) - | _ -> assert false - -and sup_i is_right i1 i2 = - let i1 = irepr i1 in - let i2 = irepr i2 in - if i1 == i2 then i1 - else - match i1.i_desc, i2.i_desc, is_right with - | Ivalue(Izero), _, true -> i2 | _, Ivalue(Izero), true -> i1 - | (Ivalue(Ione), _, true) | (_, Ivalue(Ione), true) -> ione - | Ivalue(Ione), _, false -> i2 | _, Ivalue(Ione), false -> i1 - | (Ivalue(Izero), _, false) | (_, Ivalue(Izero), false) -> izero - | (Ivalue(Ihalf), Ivalue(Ihalf), _) -> ihalf - | Ilink(i1), _ , _ -> sup_i is_right i1 i2 - | _, Ilink(i2), _ -> sup_i is_right i1 i2 - | _ -> let i = new_var () in - if is_right then i.i_inf <- [i1; i2] else i.i_sup <- [i1; i2]; i - -(* visit a type; [visit v ti] recursively mark *) -(* all nodes with value [v] *) -let rec visit v ti = - match ti with - | Ifun(ti1, ti2) -> visit v ti1; visit v ti2 - | Iproduct(ti_list) -> List.iter (visit v) ti_list - | Iatom(i) -> visit_i v i - -and visit_i v i = - match i.i_desc with - | Ivar -> - i.i_visited <- v; - List.iter (visit_i v) i.i_inf; - List.iter (visit_i v) i.i_sup - | Ivalue _ -> () - | Ilink(i) -> visit_i v i - -(** Mark useful/useless types and sets the polarity *) -(* reduces dependences by eliminating intermediate variables *) -(* we first mark useful variables (variables which appear in *) -(* the final type. We also compute polarities *) -let rec mark right ti = - match ti with - | Ifun(ti1, ti2) -> mark right ti2; mark (not right) ti1 - | Iproduct(ti_list) -> List.iter (mark right) ti_list - | Iatom(i) -> imark right i - -and imark right i = - let i = irepr i in - match i.i_desc with - | Ivar -> - i.i_useful <- true; - polarity_c i right - | Ivalue _ | Ilink _ -> () - -(* Garbage collection: only keep dependences of the form a- < b+ *) -(* this step is done after having called the function mark *) -let rec shorten ti = - match ti with - | Ifun(ti1, ti2) -> shorten ti1; shorten ti2 - | Iproduct(ti_list) -> List.iter shorten ti_list - | Iatom(i) -> shorten_i i - -and shorten_i i = - let i = irepr i in - match i.i_desc with - | Ivalue _ -> () - | Ilink(i) -> shorten_i i - | Ivar -> - i.i_visited <- 0; - (* only keep a dependence a- < b+ *) - let inf, sup = - match i.i_polarity with - | Punknown -> assert false - | Pplus -> remove_polarity Pplus (short_list false [] i.i_inf), [] - | Pminus -> [], remove_polarity Pminus (short_list true [] i.i_sup) - | Pplusminus -> - short_list false [] i.i_inf, short_list true [] i.i_sup in - i.i_inf <- inf; - i.i_sup <- sup; - i.i_visited <- 1 - - -and short_list is_right acc i_list = - List.fold_left (short is_right) acc i_list - -(* only keep a dependence a- < b+ *) -and remove_polarity p i_list = - let clear acc i_right = - match p, i_right.i_polarity with - | (Pplus, Pplus) | (Pminus, Pminus) -> acc - | _ -> i_right :: acc in - List.fold_left clear [] i_list - -and short is_right acc i = - match i.i_desc with - | Ivalue(Izero | Ione) -> acc - | Ivalue _ -> add i acc - | Ilink(i) -> short is_right acc i - | Ivar -> - match i.i_visited with - | -1 -> (* never visited *) - i.i_visited <- 0; - let acc = - short_list is_right acc (if is_right then i.i_sup else i.i_inf) in - let acc = if i.i_useful then add i acc else acc in - i.i_visited <- -1; - acc - | 0 -> (* currently visited *) - acc - | _ -> (* visited in a previous pass *) - (* the variable is added only if it is useful *) - if i.i_useful then add i acc else union i.i_inf acc - - -(* Final simplification. *) -(*- a variable a+ which has no inf. can be replaced by 0; - *- a variable a- which has no sup. can be replaced by 1; - *- if a- has a single sup. b+, it can be replaced by it - *- if a+ has a single inf. b-, it can be replaced by it. *) -let rec simplify right ti = - match ti with - | Ifun(ti1, ti2) -> funtype (simplify (not right) ti1) (simplify right ti2) - | Iproduct(ti_list) -> product(List.map (simplify right) ti_list) - | Iatom(i) -> Iatom(isimplify right i) - -and isimplify right i = - let i = irepr i in - match i.i_desc with - | Ivalue _ | Ilink _ -> i - | Ivar -> - if right then - match i.i_inf, i.i_polarity with - | [], Pplus -> izero - | [i_inf], Pplus -> - increase_polarity Pplus i_inf; - i.i_useful <- false; i_inf - | _ -> i - else - match i.i_sup, i.i_polarity with - | [], Pminus -> ione - | [i_sup], Pminus -> - increase_polarity Pminus i_sup; - i.i_useful <- false; i_sup - | _ -> i - -(** Generalisation of a type *) -(* the level of generalised type variables *) -(* is set to [generic]. Returns [generic] when a sub-term *) -(* can be generalised *) -let list_of_vars = ref [] - -let rec gen ti = - match ti with - | Ifun(ti1, ti2) -> gen ti1; gen ti2 - | Iproduct(ti_list) -> List.iter gen ti_list - | Iatom(i) -> ignore (igen i) - -and igen i = - let i = irepr i in - match i.i_desc with - | Ivalue _ -> i.i_level - | Ivar -> - if i.i_level > !binding_level - then - begin - i.i_level <- generic; - let level1 = gen_set i.i_inf in - let level2 = gen_set i.i_sup in - let level = min level1 level2 in - i.i_level <- level; - if level = generic then list_of_vars := i :: !list_of_vars - end; - i.i_level - | Ilink(link) -> igen link - -and gen_set l = List.fold_left (fun acc i -> max (igen i) acc) generic l - -(** Computes the dependence relation from a list of initialisation variables *) -(* variables in [already] are disgarded *) -let relation i_list = - let rec relation (already, rel) i = - let i = irepr i in - if S.mem i already then already, rel - else if i.i_sup = [] then already, rel - else List.fold_left - relation (S.add i already, (i, set i.i_sup) :: rel) i.i_sup in - let _, rel = - List.fold_left (fun acc i -> relation acc i) (S.empty, []) i_list in - rel - -(** Main generalisation function *) -let generalise ti = - list_of_vars := []; - (* we mark useful variables *) - mark true ti; - (* garbage collect dependences *) - shorten ti; - let ti = simplify true ti in - mark true ti; - shorten ti; - gen ti; - let rel = relation !list_of_vars in - { typ_vars = !list_of_vars; typ_rel = rel; typ = ti } - -(** Instantiation of a type *) -(* save and cleanup links *) -let links = ref [] - -let save link = links := link :: !links -let cleanup () = List.iter (fun i -> i.i_desc <- Ivar) !links; links := [] - -(* makes a copy of the type scheme *) -let rec copy ti = - match ti with - | Ifun(ti1, ti2) -> funtype (copy ti1) (copy ti2) - | Iproduct(ti_list) -> product (List.map copy ti_list) - | Iatom(i) -> atom (icopy i) - -and icopy i = - match i.i_desc with - | Ivar -> - if i.i_level = generic - then - let sup_list = List.map icopy i.i_sup in - let v = { (new_var ()) with i_sup = sup_list } in - i.i_desc <- Ilink(v); - save i; - v - else i - | Ilink(link) -> - if i.i_level = generic then link else icopy link - | Ivalue(v) -> - if i.i_level = generic then ivalue v else i - -(* instanciate the initialisation type according to the type *) -let rec instance ti ty = - let { t_desc = t_desc } as ty = Ztypes.typ_repr ty in - match ti, t_desc with - | Ifun(ti1, ti2), Tfun(_, _, ty1, ty2) -> - funtype (instance ti1 ty1) (instance ti2 ty2) - | Iproduct(ti_list), Tproduct(ty_list) -> - begin try product (List.map2 instance ti_list ty_list) - with | Invalid_argument _ -> assert false end - | Iatom(i), _ -> skeleton_on_i i ty - | _ -> assert false - -(* subtyping. [subtype right ti = tj] with ti < tj if right, else tj < ti *) -let rec subtype right ti = - match ti with - | Ifun(ti1, ti2) -> - funtype (subtype (not right) ti1) (subtype right ti2) - | Iproduct(ti_list) -> - begin try product (List.map (subtype right) ti_list) - with | Invalid_argument _ -> assert false end - | Iatom(i) -> - let new_i = new_var () in - if right then less_i i new_i else less_i new_i i; - atom new_i - -(* subtyping but the right one gets minimal bound 1/2 instead of 0 *) -let rec halftype right ti = - match ti with - | Ifun(ti1, ti2) -> - funtype (halftype (not right) ti1) (halftype right ti2) - | Iproduct(ti_list) -> - begin try product (List.map (halftype right) ti_list) - with | Invalid_argument _ -> assert false end - | Iatom(i) -> - atom (half_i right i) - -and half_i right i = - let new_i = { (new_var ()) with i_min = Ihalf } in - if right then less_i i new_i else less_i new_i i; new_i - -(* instanciation *) -let instance { typ = ti } ty = - let ti = copy ti in - cleanup (); - let ti = subtype true ti in - instance ti ty - -(* type instance *) -let instance { value_init = tis_opt } ty = - (* build a default signature *) - let default ty = - skeleton_on_i (new_var ()) ty in - match tis_opt with - | None -> - (* if no initialization signature is declared, *) - (* a default one is built from the type signature *) - subtype true (default ty) - | Some(tis) -> instance tis ty - -let filter_arrow ti = - match ti with - | Ifun(ti1, ti2) -> ti1, ti2 - | _ -> assert false - -let filter_product ti = - match ti with - | Iproduct(ti_list) -> ti_list - | _ -> assert false - -(** An entry in the type environment *) -type tentry = - { t_typ: Definit.ti; (* the init type [ty] of x *) - t_last: Definit.t; (* v in [0, 1/2, 1] so that last x: ty[v] *) - } - -(* prints the typing environment *) -let penv ff env = - (* print every entry in the typing environment *) - let pentry ff (n, { t_typ = ti; t_last = i }) = - Format.fprintf ff "@[%a: %a | %a@]" - Printer.source_name n Pinit.ptype ti Pinit.init i in - let env = Zident.Env.bindings env in - Pp_tools.print_list_r pentry "{" ";" "}" ff env diff --git a/compiler/analysis/initialization.ml b/compiler/analysis/initialization.ml deleted file mode 100644 index a517d5436..000000000 --- a/compiler/analysis/initialization.ml +++ /dev/null @@ -1,629 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* initialization check *) - -(* we do very simple check, following STTT'04, with a simple extension *) -(* for constraining the left limit (last x) in continuous systems. - *- E.g., [init x = e] and [pre(e)] are - *- valid if [e] is initialized. - *- when x is declared with [init x = e], then last x is - *- marked to be initialized with type 0 if [x = ...] at discrete instants; - *- 1/2 otherwise. if x is not explicitly initialized, it gets type 1 *) -open Zmisc -open Zident -open Global -open Zelus -open Zlocation -open Deftypes -open Definit -open Init - -(* Main error message *) -type error = - | Iless_than of ti * ti (* not (expected_ty < actual_ty) *) - | Iless_than_i of t * t (* not (expected_i < actual_i) *) - | Ilast of Zident.t (* [last x] is un-initialized *) - | Ivar of Zident.t (* [x] is un-initialized *) - | Ider of Zident.t (* equation [der x = ...] appear with no initialisation *) -exception Error of location * error - -let error loc kind = raise (Error(loc, kind)) - -let message loc kind = - begin - match kind with - | Iless_than(expected_ti, actual_ti) -> - Format.eprintf - "%aInitialization error: this expression \ - has type %a@ which should be less than@ %a.@." - output_location loc - Pinit.ptype expected_ti Pinit.ptype actual_ti - | Iless_than_i(expected_i, actual_i) -> - Format.eprintf - "%aInitialization error: this expression \ - has type@ %a which should be less than@ %a.@." - output_location loc - Pinit.init expected_i Pinit.init actual_i - | Ilast(n) -> - Format.eprintf - "%aInitialization error: the last value of %s \ - may not be well initialized.@." - output_location loc - (Zident.source n) - | Ivar(n) -> - Format.eprintf - "%aInitialization error: the value of %s \ - may not be well initialized.@." - output_location loc - (Zident.source n) - | Ider(n) -> - Format.eprintf - "%aInitialization error: the derivative of %s \ - is given but it is not initialized.@." - output_location loc - (Zident.source n) - end; - raise Zmisc.Error - -let less_than loc actual_ti expected_ti = - try - Init.less actual_ti expected_ti - with - | Init.Clash _ -> error loc (Iless_than(actual_ti, expected_ti)) - -let less_for_last loc n actual_i expected_i = - try - Init.less_i actual_i expected_i - with - | Init.Clash _ -> error loc (Ilast(n)) - -let less_for_var loc n actual_ti expected_ti = - try - Init.less actual_ti expected_ti - with - | Init.Clash _ -> error loc (Ivar(n)) - -(** Build an environment from a typing environment *) -(* if [x] is defined by [init x = e] then - *- [x] is initialized; [last x: 0] if [x] declared in a discrete - *- context; [last x: a] otherwise. - *- when [x = e] then [1/2 < a] if the equation is activated in continuous time *) -let build_env loc is_continuous l_env env = - let entry x { Deftypes.t_sort = sort; Deftypes.t_typ = ty } = - match sort with - | Smem { m_kind = Some(Cont); m_init = Noinit; m_next = None } -> - (* if an equation [der x = ...] is given but no initialisation *) - (* either through [init x = ...] or [x = ...], [x] is not initialized *) - error loc (Ider(x)) - | Smem { m_init = Noinit; m_next = Some true } -> - (* no initialization and [next x = ...]. [t_last] is useless. *) - { t_last = ione; t_typ = Init.skeleton_on_i ione ty } - | Smem { m_init = (InitEq | InitDecl _) } -> - (* [x] and [last x] or [x] and [next x] *) - (* are well initialized *) - let lv, iv = - if is_continuous then Init.new_var (), izero else izero, izero in - { t_last = lv; t_typ = Init.skeleton_on_i iv ty } - | Svar { v_default = Some _ } -> - (* [t_last] is useless. *) - { t_last = ione; t_typ = Init.skeleton_on_i (Init.new_var ()) ty } - | Svar _ -> - { t_last = izero; t_typ = Init.skeleton_on_i (Init.new_var ()) ty } - | Smem { m_previous = true } -> - (* [x] initialized; [last x] uninitialized *) - { t_last = ione; t_typ = Init.skeleton_on_i izero ty } - | Sstatic | Sval | Smem _ -> - (* no constraint *) - let lv = if is_continuous then ihalf else izero in - { t_last = lv; t_typ = Init.skeleton ty } in - Env.fold (fun n tentry acc -> Env.add n (entry n tentry) acc) l_env env - -(* Given an environment [env], returns a new one where every entry type *) -(* [ti] is subtyped into [tj] which gets 1/2 as its minimum type *) -let half env = - let half { t_last = lv; t_typ = ti } = - { t_last = Init.half_i true lv; t_typ = Init.halftype true ti } in - Env.map half env - -(** Build an environment from [env] by replacing the initialization *) -(* type of [x] by the initialization of its last value for all *) -(* [x in [shared\defnames] *) -(* this is because an absent definition for [x] in the current branch *) -(* is interpreted as if there were an equation [x = last x] *) -(* or [x = default_x] if [x] is declared with a default value *) -let last_env shared defnames env = - let add n acc = - let { t_typ = ti; t_last = i } = Env.find n env in - Env.add n { t_typ = Init.fresh_on_i izero ti; t_last = Init.new_var () } - acc in - let names = Deftypes.cur_names Zident.S.empty defnames in - let env_defnames = - Zident.S.fold add (Zident.S.diff shared names) Env.empty in - Env.append env_defnames env - -(* Names from the set [last_names] are considered to be initialized *) -let add_last_to_env is_continuous env last_names = - let add n acc = - let { t_typ = ti } = Env.find n env in - let lv = if is_continuous then Init.new_var () else izero in - Env.add n { t_typ = Init.fresh_on_i izero ti; t_last = lv } acc in - let env_last_names = - Zident.S.fold add last_names Env.empty in - Env.append env_last_names env - -(* find the initial handler from an automaton. Returns it with its complement *) -let split se_opt s_h_list = - let statepat { desc = desc } = - match desc with - | Estate0pat(id) | Estate1pat(id, _) -> id in - let state { desc = desc } = - match desc with - | Estate0(id) | Estate1(id, _) -> id in - let rec splitrec s s_h_list = - match s_h_list with - | [] -> assert false - | { s_state = spat } as s_h :: s_h_list -> - if s = statepat spat then s_h, s_h_list - else - let s_h0, s_h_list = splitrec s s_h_list in - s_h0, s_h :: s_h_list in - match se_opt with - | None -> (* the starting state is the first in the list *) - List.hd s_h_list, List.tl s_h_list - | Some(se) -> splitrec (state se) s_h_list - -let print x = Zmisc.internal_error "unbound" Printer.name x - -(** Check that partially defined names have a last value which is initialized *) -let initialized loc env shared = - (* check that shared variable are initialialized *) - let check n = - let { t_typ = ti } = try Env.find n env with Not_found -> assert false in - less_for_var loc n ti (Init.fresh_on_i izero ti) in - Zident.S.iter check shared - -(** Patterns *) -(* [pattern env p expected_ty] means that the type of [p] must be less *) -(* than [expected_ty] *) -let rec pattern is_continuous env - ({ p_desc = desc; p_loc = loc; p_typ = ty } as p) expected_ti = - (* annotate the pattern with the initialization type *) - p.p_init <- expected_ti; - match desc with - | Ewildpat | Econstpat _ | Econstr0pat _ -> () - | Evarpat(x) -> - let ti1, last = - try let { t_typ = ti1; t_last = last } = Env.find x env in ti1, last - with | Not_found -> assert false in - less_than loc expected_ti ti1; - (* an equation [x = e] in a continuous context is correct *) - (* if x and e have the same type and [last x: t] with [1/2 <= t] *) - if is_continuous then less_for_last loc x ihalf last - | Econstr1pat(_, pat_list) -> - let i = Init.new_var () in - less_than loc expected_ti (Init.skeleton_on_i i ty); - List.iter - (fun p -> pattern_less_than_on_i is_continuous env p i) pat_list - | Etuplepat(pat_list) -> - let ty_list = Init.filter_product expected_ti in - List.iter2 (pattern is_continuous env) pat_list ty_list - | Erecordpat(l) -> - let i = Init.new_var () in - List.iter - (fun (_, p) -> pattern_less_than_on_i is_continuous env p i) l - | Etypeconstraintpat(p, _) -> pattern is_continuous env p expected_ti - | Eorpat(p1, p2) -> - pattern is_continuous env p1 expected_ti; - pattern is_continuous env p2 expected_ti - | Ealiaspat(p, n) -> - pattern is_continuous env p expected_ti; - let ti_n, last = - try let { t_typ = ti1; t_last = last } = Env.find n env in ti1, last - with | Not_found -> assert false in - less_than loc expected_ti ti_n; - if is_continuous then less_for_last loc n ihalf last - -and pattern_less_than_on_i is_continuous env pat i = - let expected_ti = Init.skeleton_on_i i pat.p_typ in - pattern is_continuous env pat expected_ti - -(** Match handler *) -let match_handlers is_continuous body env m_h_list = - let handler { m_pat = pat; m_env = m_env; m_body = b } = - let env = build_env pat.p_loc is_continuous m_env env in - ignore (body is_continuous env b) in - List.iter handler m_h_list - -(** Present handler *) -let present_handlers is_continuous scondpat body env p_h_list = - let handler { p_cond = scpat; p_body = b; p_env = p_env } = - let env = build_env scpat.loc is_continuous p_env env in - scondpat is_continuous env scpat; - let env = if is_continuous then half env else env in - ignore (body false env b) in - List.iter handler p_h_list - -(** Initialization of an expression *) -let rec exp is_continuous env ({ e_desc = desc; e_typ = ty } as e) = - let ti = - match desc with - | Econst _ | Econstr0 _ - | Eperiod _ -> Init.skeleton_on_i (Init.new_var ()) ty - | Eglobal { lname = lname } -> - let { info = info } = - try Modules.find_value lname with | Not_found -> assert false in - Init.instance info ty - | Elocal(x) -> - begin try let { t_typ = ti1 } = Env.find x env in ti1 - with | Not_found -> print x - end - | Elast(x) -> - begin try - (* [last x] is initialized only if an equation [init x = e] *) - (* appears and [e] is also initialized *) - let { t_typ = ti; t_last = last } = Env.find x env in - Init.fresh_on_i last ti - with - | Not_found -> Init.skeleton_on_i ione ty end - | Etuple(e_list) -> - product (List.map (exp is_continuous env) e_list) - | Econstr1(_, e_list) -> - let i = Init.new_var () in - List.iter (fun e -> exp_less_than_on_i is_continuous env e i) e_list; - Init.skeleton_on_i i ty - | Eop(op, e_list) -> operator is_continuous env op ty e_list - | Eapp(_, e, e_list) -> - app is_continuous env (exp is_continuous env e) e_list - | Erecord_access(e_record, _) -> - let i = Init.new_var () in - exp_less_than_on_i is_continuous env e_record i; - Init.skeleton_on_i i ty - | Erecord(l) -> - let i = Init.new_var () in - List.iter (fun (_, e) -> exp_less_than_on_i is_continuous env e i) l; - Init.skeleton_on_i i ty - | Erecord_with(e_record, l) -> - let i = Init.new_var () in - exp_less_than_on_i is_continuous env e_record i; - List.iter (fun (_, e) -> exp_less_than_on_i is_continuous env e i) l; - Init.skeleton_on_i i ty - | Etypeconstraint(e, _) -> exp is_continuous env e - | Elet(l, e_let) -> - let env = local is_continuous env l in - exp is_continuous env e_let - | Eblock(b, e_block) -> - let env = block_eq_list Zident.S.empty is_continuous env b in - exp is_continuous env e_block - | Eseq(e1, e2) -> - ignore (exp is_continuous env e1); - exp is_continuous env e2 - | Epresent(p_h_list, e_opt) -> - (* if [e] returns a tuple, all type element are synchronised, i.e., *) - (* if one is un-initialized, the whole is un-initialized *) - let ti = Init.skeleton_on_i (Init.new_var ()) ty in - let _ = - Zmisc.optional_map - (fun e -> exp_less_than is_continuous env e ti) e_opt in - present_handler_exp_list is_continuous env p_h_list ti; - ti - | Ematch(_, e, m_h_list) -> - (* we force [e] to be always initialized. This is overly constraining *) - (* but correct and simpler to justify *) - exp_less_than_on_i is_continuous env e izero; - let ti = Init.skeleton_on_i (Init.new_var ()) ty in - match_handler_exp_list is_continuous env m_h_list ti; - ti in - (* annotate the expression with the initialization type *) - e.e_init <- ti; - ti - -(** Typing an operator *) -and operator is_continuous env op ty e_list = - match op, e_list with - | Eunarypre, [e] -> - (* input of a unit delay must be of type 0 *) - exp_less_than_on_i is_continuous env e izero; - Init.skeleton_on_i ione ty - | Efby, [e1;e2] -> - (* right input of a initialized delay must be of type 0 *) - exp_less_than_on_i is_continuous env e2 izero; - exp is_continuous env e1 - | Eminusgreater, [e1;e2] -> - let t1 = exp is_continuous env e1 in - let _ = exp is_continuous env e2 in - t1 - | Eifthenelse, [e1; e2; e3] -> - (* a conditional does not force all element to be initialized *) - let i = Init.new_var () in - exp_less_than_on_i is_continuous env e1 i; - exp_less_than_on_i is_continuous env e2 i; - exp_less_than_on_i is_continuous env e3 i; - Init.skeleton_on_i i ty - | (Einitial | Eup | Etest | Edisc - | Eaccess | Eupdate | Eslice _ | Econcat), e_list -> - (* here, we force the argument to be always initialized *) - (* this is necessary for [up(x)] and access functions to arrays; not *) - (* for the others *) - let iv = izero in - List.iter (fun e -> exp_less_than_on_i is_continuous env e iv) e_list; - Init.skeleton_on_i iv ty - | Eatomic, [e] -> - let i = Init.new_var () in - exp_less_than_on_i is_continuous env e i; - Init.skeleton_on_i i ty - | _ -> assert false - - -(** Typing an application *) -and app is_continuous env ti_fct arg_list = - (* typing the list of arguments *) - let rec args ti_fct = function - | [] -> ti_fct - | arg :: arg_list -> - let ti1, ti2 = Init.filter_arrow ti_fct in - exp_less_than is_continuous env arg ti1; - args ti2 arg_list in - args ti_fct arg_list - -and exp_less_than_on_i is_continuous env e expected_i = - let actual_ti = exp is_continuous env e in - less_than e.e_loc actual_ti (Init.skeleton_on_i expected_i e.e_typ); - -and opt_exp_less_than_on_i is_continuous env e_opt expected_i = - match e_opt with - | None -> () - | Some(e) -> exp_less_than_on_i is_continuous env e expected_i - -and exp_less_than is_continuous env e expected_ti = - let actual_ty = exp is_continuous env e in - less_than e.e_loc actual_ty expected_ti; - (* annotate the expression with the type *) - - -(** Checking equations *) -and equation_list is_continuous env eq_list = - List.iter (equation is_continuous env) eq_list - -and equation is_continuous env - { eq_desc = eq_desc; eq_loc = loc; eq_write = defnames } = - match eq_desc with - | EQeq(p, e) -> - let ti = exp is_continuous env e in - pattern is_continuous env p ti - | EQpluseq(n, e) -> - let ti_n = - try let { t_typ = ti } = Env.find n env in ti - with Not_found -> assert false in - exp_less_than is_continuous env e ti_n - | EQder(n, e, e0_opt, p_h_e_list) -> - (* e must be of type 0 *) - let ti_n, last = - try let { t_typ = ti1; t_last = last1 } = Env.find n env in - ti1, last1 - with | Not_found -> assert false in - exp_less_than is_continuous env e ti_n; - less_than loc ti_n (Init.skeleton_on_i Init.izero e.e_typ); - (match e0_opt with - | Some(e0) -> exp_less_than_on_i false env e0 ihalf - | None -> ()); (* less_for_last loc n last izero); *) - present_handler_exp_list is_continuous env p_h_e_list ti_n - | EQinit(n, e0) -> - exp_less_than_on_i false env e0 ihalf - | EQnext(n, e, e0_opt) -> - (* [e] must always be well initialized *) - exp_less_than_on_i is_continuous env e izero; - (match e0_opt with - | Some(e0) -> exp_less_than_on_i false env e0 ihalf - | None -> ()) - | EQautomaton(is_weak, s_h_list, se_opt) -> - (* state *) - let state env { desc = desc } = - match desc with - | Estate0 _ -> () - | Estate1(_, e_list) -> - List.iter - (fun e -> exp_less_than_on_i false env e izero) e_list in - (* Compute the set of names defined by a state *) - let cur_names_in_state b trans = - let block acc { b_write = w } = Deftypes.cur_names acc w in - let escape acc { e_block = b_opt } = Zmisc.optional block acc b_opt in - block (List.fold_left escape Zident.S.empty trans) b in - (* transitions *) - let escape shared env - { e_cond = sc; e_block = b_opt; e_next_state = ns; e_env = e_env } = - let env = build_env sc.loc is_continuous e_env env in - scondpat is_continuous env sc; - let env = - match b_opt with - | None -> env | Some(b) -> block_eq_list shared false env b in - state env ns in - (* handler *) - let handler shared env - { s_state = state; s_body = b; s_trans = trans; s_env = s_env } = - (* remove from [shared] names defined in the current state *) - let shared = Zident.S.diff shared (cur_names_in_state b trans) in - let env = build_env state.loc is_continuous s_env env in - let env = block_eq_list shared is_continuous env b in - List.iter (escape shared env) trans in - (* compute the set of shared names *) - let shared = Deftypes.cur_names Zident.S.empty defnames in - (* do a special treatment for the initial state *) - let first_s_h, remaining_s_h_list = split se_opt s_h_list in - (* first type the initial branch *) - handler shared env first_s_h; - (* if the initial state has only weak transition then all *) - (* variables from [defined_names] do have a last value *) - (* in this version of the language, weak and strong cannot be mixed *) - let last_names = - Deftypes.cur_names Zident.S.empty first_s_h.s_body.b_write in - let env = - if is_weak then add_last_to_env is_continuous env last_names else env in - List.iter (handler shared env) remaining_s_h_list; - (* every defined variable must be initialized *) - initialized loc env shared; - (* finaly check the initialisation *) - ignore (Zmisc.optional_map (state env) se_opt) - | EQmatch(total, e, m_h_list) -> - exp_less_than_on_i is_continuous env e izero; - let shared = Deftypes.cur_names Zident.S.empty defnames in - match_handler_block_eq_list is_continuous shared env defnames m_h_list; - (* every defined variable must be initialized *) - initialized loc env shared - | EQpresent(p_h_list, b_opt) -> - let shared = Deftypes.cur_names Zident.S.empty defnames in - ignore - (Zmisc.optional_map - (fun b -> ignore (block_eq_list shared is_continuous env b)) b_opt); - present_handler_block_eq_list is_continuous shared env defnames p_h_list; - (* every defined variable must be initialized *) - initialized loc env shared - | EQreset(eq_list, e) -> - exp_less_than_on_i is_continuous env e izero; - equation_list is_continuous env eq_list - | EQand(eq_list) - | EQbefore(eq_list) -> equation_list is_continuous env eq_list - | EQemit(n, e_opt) -> - let ti_n = - try let { t_typ = ti1 } = Env.find n env in ti1 - with | Not_found -> assert false in - less_than loc ti_n (Init.atom izero); - ignore - (Zmisc.optional_map - (fun e -> exp_less_than_on_i is_continuous env e izero) e_opt) - | EQblock(b_eq_list) -> - ignore (block_eq_list Zident.S.empty is_continuous env b_eq_list) - | EQforall { for_index = i_list; for_init = init_list; for_body = b_eq_list; - for_in_env = i_env; for_out_env = o_env; for_loc = loc } -> - (* typing the declaration of indexes *) - (* all bounds must be initialized *) - let index env { desc = desc; loc = loc } = - match desc with - | Einput(_, e) -> exp_less_than_on_i is_continuous env e izero - | Eindex(_, e1, e2) -> - exp_less_than_on_i is_continuous env e1 izero; - exp_less_than_on_i is_continuous env e2 izero - | Eoutput(x, xout) -> - let ti = - try - let { t_typ = ti } = Env.find xout env in ti - with | Not_found -> assert false in - less_than loc ti (Init.atom izero) in - (* typing the initialization *) - (* all right hand-side expressions must be initialized *) - let init init_env { desc = desc } = - match desc with - | Einit_last(x, e) -> - let ti = exp is_continuous env e in - let tzero = Init.skeleton_on_i izero e.e_typ in - less_than e.e_loc ti tzero; - Env.add x { t_last = izero; t_typ = tzero } init_env in - List.iter (index env) i_list; - let init_env = List.fold_left init Env.empty init_list in - let env = build_env loc is_continuous i_env env in - let env = build_env loc is_continuous o_env env in - let env = Env.append init_env env in - ignore (block_eq_list Zident.S.empty is_continuous env b_eq_list) - -(* typing rule for a present statement where the body is an expression - *- if [is_continuous = true] this means that every handler [ze -> body] - *- is necessarily activated on a zero-crossing instant, thus discretely. - *- in that case, it is enough that the body has type 1/2 and the whole - *- present expression will get type 0 *) -and present_handler_exp_list is_continuous env p_h_list ty = - present_handlers is_continuous scondpat - (fun is_continuous env e -> exp_less_than is_continuous env e ty) - env p_h_list - -(* typing of a block of equations *) -and present_handler_block_eq_list is_continuous shared env defnames p_h_list = - present_handlers is_continuous scondpat - (block_eq_list shared) env p_h_list - -and match_handler_block_eq_list is_continuous shared env defnames m_h_list = - match_handlers is_continuous - (block_eq_list shared) env m_h_list - -and match_handler_exp_list is_continuous env m_h_list ty = - match_handlers is_continuous - (fun is_continuous env e -> exp_less_than is_continuous env e ty) - env m_h_list - -and block_eq_list shared is_continuous env - { b_loc = loc; b_locals = l_list; b_body = eq_list; - b_env = b_env; b_write = defnames } = - (* shared variables depend on their last causality *) - let env = last_env shared defnames env in - let env = List.fold_left (local is_continuous) env l_list in - let env = build_env loc is_continuous b_env env in - equation_list is_continuous env eq_list; - env - - -and local is_continuous env { l_eq = eq_list; l_loc = loc; l_env = l_env } = - (* First extend the typing environment *) - let env = build_env loc is_continuous l_env env in - (* then type the body *) - List.iter (equation is_continuous env) eq_list; env - -(* we force that the signal pattern be initialized. E.g., -*- [present s(x) -> ...] gives the type 0 to s and x *) -and scondpat is_continuous env { desc = desc } = - match desc with - | Econdand(sc1, sc2) | Econdor(sc1, sc2) -> - scondpat is_continuous env sc1; scondpat is_continuous env sc2 - | Econdon(sc1, e) -> - scondpat is_continuous env sc1; - exp_less_than_on_i is_continuous env e izero - | Econdexp(e) | Econdpat(e, _) -> - exp_less_than_on_i is_continuous env e izero - -let implementation ff impl = - try - match impl.desc with - | Eopen _ | Etypedecl _ -> () - | Econstdecl(f, _, e) -> - (* the expression [e] must be initialized *) - let ti_zero = Init.skeleton_on_i izero e.e_typ in - Zmisc.push_binding_level (); - exp_less_than false Env.empty e ti_zero; - Zmisc.pop_binding_level (); - let tis = generalise ti_zero in - Global.set_init (Modules.find_value (Lident.Name(f))) tis; - (* output the signature *) - if !Zmisc.print_initialization_types then Pinit.declaration ff f tis - | Efundecl(f, { f_kind = k; f_atomic = atomic; f_args = p_list; - f_body = e; f_env = h0; f_loc = loc }) -> - let is_continuous = match k with | C -> true | _ -> false in - Zmisc.push_binding_level (); - let env = build_env loc is_continuous h0 Env.empty in - let ti_list = List.map (fun p -> Init.skeleton p.p_typ) p_list in - List.iter2 (pattern is_continuous env) p_list ti_list; - let ti_res = exp is_continuous env e in - let actual_ti = funtype_list ti_list ti_res in - (* for an atomic node, all outputs depend on all inputs *) - let expected_ti = - funtype_list (List.map (fun p -> Init.skeleton p.p_typ) p_list) - (Init.skeleton e.e_typ) in - less_than impl.loc actual_ti expected_ti; - Zmisc.pop_binding_level (); - let tis = generalise actual_ti in - Global.set_init (Modules.find_value (Lident.Name(f))) tis; - (* output the signature *) - if !Zmisc.print_initialization_types then Pinit.declaration ff f tis - with - | Error(loc, kind) -> message loc kind - -let implementation_list ff impl_list = - List.iter (implementation ff) impl_list; impl_list diff --git a/compiler/dune b/compiler/dune deleted file mode 100644 index a9719b907..000000000 --- a/compiler/dune +++ /dev/null @@ -1,29 +0,0 @@ -(include_subdirs unqualified) - -(rule - (copy %{project_root}/zconfig.ml zconfig.ml)) - -(subdir parsing - (ocamllex zlexer)) - -(subdir parsing - (menhir (modules zparser) (infer true) (flags --explain --table))) - -(library - (name zlcompilerlibs) - (public_name zelus.zlcompilerlibs) - (wrapped false) - (modules :standard \ zeluc) - (libraries menhirLib)) - -(executable - (name zeluc) - (modes (byte exe)) - (libraries unix menhirLib zlcompilerlibs) - (modules zeluc) - (promote (until-clean))) - -(install - (package zelus) - (section bin) - (files (zeluc.exe as zeluc))) diff --git a/compiler/gencode/inout.ml b/compiler/gencode/inout.ml deleted file mode 100644 index ee20842ae..000000000 --- a/compiler/gencode/inout.ml +++ /dev/null @@ -1,462 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* add extra code for in-place modification of the continuous state vector *) -(* see Ztypes.ml *) - -(* A continuous machine of the form *) -(* machine m s1 ... = *) -(* memories (k_i m_k: t_i)_{i in I} *) -(* instance (discrete (j_i: f_i)_{i in J} *) -(* instance (continuous (j_i: f'_i)_{i in J'} *) -(* method (meth_l p_l = e_l)_{l in L} *) -(* *) -(* where s1... are static parameters *) -(* is translated into *) -(* machine m s1 ... cstate = *) -(* memories (k_i m_k: t_i)_{i in I} *) -(* instance (discrete (j_i: f_i)_{i in J} *) -(* instance (continuous (j_i: f'_i cstate)_{i in J'} *) -(* method (meth_l p_l = e_l')_{l in L} *) -(* *) -(* the body of the step method is extended to read/write *) -(* entries from the following data-structure *) -(* on the global parameter cstate *) -(* type cstate = - *- { mutable dvec : float array; - *- mutable cvec : float array; - *- mutable zinvec : bool array; - *- mutable zoutvec : float array; - *- mutable cindex : int; - *- mutable zindex : int; - *- mutable cend : int; - *- mutable zend : int; - *- mutable cmax : int; - *- mutable zmax : int; - *- mutable horizon : float; - *- mutable major : bool } *) - -(* The main class takes an extra static argument - *- suppose that [csize] is the length of the state vector of the current block; - *- x1:float[size1],..., xn:float[sizen] are the continuous state variables; - *- m1:zero[size'1],..., mk:zero[size'k] are the zero-crossing variables; - *- method step(arg1,...,argl) = ...body... is the step method. - *- - *- rewrite it into: - *- - *- method step(arg1,...,argl) = - *- let c_start = cstate.cindex in (* current position of the cvector *) - *- var cpos = c_start in - *- let z_start = cstate.zindex in (* current position of the zvector *) - *- cstate.cindex <- cstate.cindex + csize; - *- cstate.zindex <- cstate.zindex + zsize; - *- m <- cstate.major; - *- var zpos = z_start in - *- if cstate.major then - *- dzero cstate.dvec c_start csize (* set all speeds to 0.0 *) - *- else ((* copy the value of the continuous state vector of the solver *) - *- (* into the local continuous state variables *) - *- cin cstate x1 ci;...; cin xn (ci+size1+...+size(n-1))); - *- ... cpos is incremented - *- let result = ...body... in - *- cpos <- c_start; - *- if cstate.major then - *- ((* copy the local continuous state variables into *) - *- (* the continuous state vector of the solver *) - *- cout cstate x1 ci;...; cout cstate ck (zi+size'1+...+size'(n-1)); - *- ... cpos is incremented - *- (* h is the horizon of the block *) - *- cstate.horizon <- min cstate.horizon h - *- (* the zero-crossing variables are set to false *) - *- m1 <- false; ...; mk <- false; - *- ... zpos is incremented) - *- else ((* copy the zero-crossing vector of the solver into the local *) - *- (* zero-crossing variables *) - *- zin cstate m1 zi;...; zin cstate mk (zi+size'1+...+size'(k-1)); - *- ... zpos is incremented - *- zpos <- z_start; - *- (* copy the local zero-crossing variables into the *) - *- (* zero-crossing vector of the solver *) - *- zout cstate m1 zi;...; zout cstate mk (zi+size'1+...+size'(k-1)); - *- ... zpos is incremented - *- (* copy the local derivatives into the vector of derivative *) - *- (* of the solver *) - *- dout cstate x1 ci;...; dout cstate ck (zi+size'1+...+size'(n-1)); - *- ... cpos is incremented); - *- result - *- - *- Add to the initialization code: - *- cmax csize; - *- zmax zsize - *- which increments the size of the continuous state and zero-crossing vectors *) - -open Zmisc -open Zident -open Lident -open Deftypes -open Obc -open Oaux - -let typ_cstate = Otypeconstr(Modname {qual = "Ztypes"; id = "cstate" }, []) - -let varpat x ty = Ovarpat(x, Translate.type_expression_of_typ ty) -let modname x = Lident.Modname { Lident.qual = "Zls"; Lident.id = x } - -let i = Zident.fresh "i" - -(* Convert a size into an expression *) -let rec size s = - match s with - | Sconst(i) -> Oconst(Oint(i)) - | Sglobal(ln) -> Oglobal(ln) - | Sname n -> Olocal(n) - | Sop(op, s1, s2) -> - let s1 = size s1 in - let s2 = size s2 in - match op with - | Splus -> plus_opt s1 s2 - | Sminus -> minus_opt s1 s2 - -let set_horizon cstate h = - Oassign(Oleft_record_access(Oleft_name(cstate), Name "horizon"), - min (Orecord_access(varmut cstate, Name "horizon")) - (Ostate(Oleft_state_name h))) - -let set_major cstate m = - Oassign_state(Oleft_state_name(m), Orecord_access(varmut cstate, Name "major")) - -(* [x := !x + 1] *) -let incr_pos x = Oassign(Oleft_name x, Oaux.plus_opt (var x) one) -let set_pos x e = Oassign(Oleft_name x, e) - -(* [cstate.field <- cstate.field + i] *) -let incr cstate field ie = - Oassign(Oleft_record_access(Oleft_name cstate, Name(field)), - Oaux.plus_opt (Orecord_access(Olocal(cstate), Name(field))) ie) - -let cmax cstate ie = incr cstate "cmax" ie -let zmax cstate ie = incr cstate "zmax" ie -let cincr cstate ie = incr cstate "cindex" ie -let zincr cstate ie = incr cstate "zindex" ie - -let major cstate = Orecord_access(varmut cstate, Name("major")) - -(* [x.cont.(i1)....(in).(j1)...(jk) <- cstate.cvec.(pos)] *) -(* [x.zero_in.(i1)...(in).(j1)...(jk) <- cstate.zin.(pos)] *) - -let write_into_internal_state (x, cont) i_list j_list get pos = - Oassign_state - (left_state_access - (left_state_access - (Oleft_state_primitive_access(Oleft_state_name(x), cont)) - i_list) j_list, get (var pos)) - -let app f args = Oapp(global(modname f), args) -let getc cstate pos = - app "get" [Orecord_access(varmut cstate, Name("cvec")); pos] -let get_zin cstate pos = - app "get_zin" [Orecord_access(varmut cstate, Name("zinvec")); pos] -let setc cstate pos e = - app "set" [Orecord_access(varmut cstate, Name("cvec")); pos; e] -let setd cstate pos e = - app "set" [Orecord_access(varmut cstate, Name("dvec")); pos; e] -let set_zout cstate pos e = - app "set" [Orecord_access(varmut cstate, Name("zoutvec")); pos; e] - -let cin cstate x i_list j_list pos = - let getc pos = getc cstate pos in - write_into_internal_state (x, Ocont) i_list j_list getc pos - -let zin cstate x i_list j_list pos = - let get_zin pos = get_zin cstate pos in - write_into_internal_state (x, Ozero_in) i_list j_list get_zin pos - -(* [cstate.cvec.(pos) <- (x.cont.(i1)....(in)).(j1)...(jk)] *) -(* [cstate.dvec.(pos) <- (x.der.(i1)....(in)).(j1)...(jk)] *) -(* [cstate.zout.(pos) <- (x.zout.(i1)....(in)).(j1)...(jk)] *) -let write_from_internal_state set (x, cont) i_list j_list pos = - Oexp - (set (var pos) - (Ostate - (left_state_access - (left_state_access - (Oleft_state_primitive_access(Oleft_state_name(x), cont)) - i_list) j_list))) -let cout cstate x i_list j_list pos = - let setc pos e = setc cstate pos e in - write_from_internal_state setc (x, Ocont) i_list j_list pos -let dout cstate x i_list j_list pos = - let setd pos e = setd cstate pos e in - write_from_internal_state setd (x, Oder) i_list j_list pos -let zout cstate x i_list j_list pos = - let set_zout pos e = set_zout cstate pos e in - write_from_internal_state set_zout (x, Ozero_out) i_list j_list pos -let set_zin_to_false x i_list j_list pos = - Oassign_state - (left_state_access - (left_state_access - (Oleft_state_primitive_access(Oleft_state_name(x), Ozero_in)) - i_list) j_list, - ffalse) - -let set_dvec_to_zero cstate c_start csize = - if is_zero csize then Oexp(void) - else Ofor(true, i, local c_start, minus_opt csize one, - Oexp(setd cstate (local i) (float_const 0.0))) - -(** Compute the index associated to a state variable [x] in the current block *) -(* [build_index m_list = (ctable, csize), (ztable, zsize), h_opt, major_opt] *) -let build_index m_list = - (* [increase size typ e_list = size'] such that - *- size' = size + (size_of typ) * s1 * ... * sn. - *- E.g., cont x[e1]...[en]: t is a vector of dimension n of a value t - *- t can itself be a floatting point vector of dimension k - (size m1 * ... * mk). - *- In that case (size_of t = [m1]...[mk] - *- for cont x[]: t, the size is that of t - build two tables. The table [ctable] associates a pair - *- ([m1]...[mk], [e1]...[en]) to every continuous state variable; - *- [ztable] do the same for zero-crossings - *- the variable [h_opt] which defines the next horizon - *- the variable [major_opt] which is true in a discrete mode *) - let size s = size (Translate.size_of_type s) in - let build (ctable, ztable, h_opt, major_opt) - { m_typ = typ; m_name = n; m_kind = m; m_size = e_list } = - let add_opt v opt = - match opt with - | None -> Some(v) - | Some(w) -> Zmisc.internal_error "Inout" Printer.name w in - match m with - | None -> ctable, ztable, h_opt, major_opt - | Some(k) -> - match k with - | Horizon -> ctable, ztable, add_opt n h_opt, major_opt - | Period | Encore -> ctable, ztable, h_opt, major_opt - | Zero -> - let s_list = Ztypes.size_of typ in - ctable, Env.add n (List.map size s_list, e_list) ztable, - h_opt, major_opt - | Cont -> - let s_list = Ztypes.size_of typ in - Env.add n (List.map size s_list, e_list) ctable, ztable, - h_opt, major_opt - | Major -> ctable, ztable, h_opt, add_opt n major_opt in - let ctable, ztable, h_opt, major_opt = - List.fold_left build (Env.empty, Env.empty, None, None) m_list in - ctable, ztable, h_opt, major_opt - -(* Compute the size of a table *) -let size_of table = - let size _ (s_list, e_list) acc = - let s1 = - List.fold_left (fun acc s -> mult_opt acc s) one s_list in - let s2 = List.fold_left mult_opt s1 e_list in - plus_opt acc s2 in - Env.fold size table zero - -(** Add a method to copy back and forth the internal representation - *- of the continuous state vector to the external flat representation - *- This function is generic: table contains the association table - *- [name, ([s1]...[sn], [e1]...[ek]). *) -let cinout table call pos incr = - (* For every input x associated to ([s1]...[sn], [e1]...[ek])) from [table] *) - (* for i1 = 0 to s1 - 1 do - *- ... - *- for in = 0 to sn - 1 do - *- for j1 = 0 to e1 do - *- ... - *- for jk = 0 to ek - 1 do - *- call (local x) i1...in j1...jk pos; incr pos - *- done - *- done - *- done - *- done *) - let rec copy i_list e_list body = - match i_list, e_list with - | [], [] -> body - | i :: i_list, e :: e_list -> - Ofor(true, i, int_const 0, e, copy i_list e_list body) - | _ -> assert false in - - let add x (s_list, e_list) acc = - let i_list = List.map (fun _ -> Zident.fresh "i") s_list in - let j_list = List.map (fun _ -> Zident.fresh "j") e_list in - (copy i_list s_list - (copy j_list e_list - (sequence [call x i_list j_list pos; incr pos]))) :: acc in - let c_list = Env.fold add table [] in - sequence(c_list) - -let cin table cstate pos = - let call x i_list j_list pos = cin cstate x i_list j_list pos in - cinout table call pos incr_pos - -let cout table cstate pos = - let call x i_list j_list pos = cout cstate x i_list j_list pos in - cinout table call pos incr_pos - -let dout table cstate pos = - let call x i_list j_list pos = dout cstate x i_list j_list pos in - cinout table call pos incr_pos - -let zin table cstate pos = - let call x i_list j_list pos = zin cstate x i_list j_list pos in - cinout table call pos incr_pos - -let zout table cstate pos = - let call x i_list j_list pos = zout cstate x i_list j_list pos in - cinout table call pos incr_pos - -let set_zin_to_false table pos = - let call x i_list j_list pos = set_zin_to_false x i_list j_list pos in - cinout table call pos (fun _ -> Oexp(void)) - -(* increments the maximum size of the continuous state vector and that of *) -(* the zero-crossing vector *) -let maxsize call size i_opt = - if is_zero size then i_opt - else let i = call size in - match i_opt with - | None -> Some(i) | Some(i_old) -> Some(sequence [i; i_old]) - -(* If the current block contains an horizon state variable *) -(* for every horizon state variable *) -let set_horizon cstate h_opt = - match h_opt with - | None -> Oexp(Oconst(Ovoid)) | Some(h) -> set_horizon cstate h - -(* If the current block contains a major state variable *) -let set_major cstate major_opt = - match major_opt with - | None -> Oexp(Oconst(Ovoid)) | Some(m) -> set_major cstate m - -(** Translate a continuous-time machine *) -let machine f - ({ ma_params = params; ma_initialize = i_opt; ma_memories = m_list; - ma_instances = mi_list; ma_methods = method_list } as mach) cstate = - (* auxiliary function. Find the method "step" in the list of methods *) - let rec find_step method_list = - match method_list with - | [] -> raise Not_found - | { me_name = m } as mdesc :: method_list -> - if m = Oaux.step then mdesc, method_list - else let step, method_list = find_step method_list in - step, mdesc :: method_list in - (* for every instance of a continuous machine () *) - (* pass the extra argument [cstate] *) - let add_extra_param ({ i_kind = k; i_params = params } as ientry) = - match k with - | Tcont -> { ientry with i_params = (varmut cstate) :: params } - | _ -> ientry in - try - let { me_body = body; me_typ = ty } as mdesc, method_list = - find_step method_list in - (* associate an integer index to every continuous state *) - (* variable and zero-crossing *) - let ctable, ztable, h_opt, major_opt = build_index m_list in - - let csize = size_of ctable in - let zsize = size_of ztable in - - let c_is_not_zero = not (is_zero csize) in - let z_is_not_zero = not (is_zero zsize) in - let h_is_not_zero = not (h_opt = None) in - let major_is_not_zero = not (major_opt = None) in - - (* add initialization code to [e_opt] *) - let i_opt = - maxsize (cmax cstate) csize (maxsize (zmax cstate) zsize i_opt) in - - let c_start = Zident.fresh "cindex" in - let z_start = Zident.fresh "zindex" in - let cstate_cpos = Orecord_access(varmut cstate, Name("cindex")) in - let cstate_zpos = Orecord_access(varmut cstate, Name("zindex")) in - - let cpos = Zident.fresh "cpos" in - let zpos = Zident.fresh "zpos" in - let result = Zident.fresh "result" in - - let letin_only cond pat e body = - if cond then letin pat e body else body in - let letvar_only cond v ty e body = - if cond then letvar v ty e body else body in - let only cond inst = if cond then inst else Oexp(void) in - let only_else cond inst1 inst2 = if cond then inst1 else inst2 in - - let body = - letin_only c_is_not_zero - (* compute the current position of the cvector *) - (varpat c_start Initial.typ_int) cstate_cpos - (letvar_only - c_is_not_zero cpos Initial.typ_int (local c_start) - (* compute the current position of the zvector *) - (letin_only - z_is_not_zero (varpat z_start Initial.typ_int) cstate_zpos - (letvar_only - z_is_not_zero zpos Initial.typ_int (local z_start) - (sequence - [only c_is_not_zero (incr cstate "cindex" csize); - only z_is_not_zero (incr cstate "zindex" zsize); - only major_is_not_zero (set_major cstate major_opt); - ifthenelse - (major cstate) (set_dvec_to_zero cstate c_start csize) - (only c_is_not_zero (cin ctable cstate cpos)); - (only_else - (c_is_not_zero || z_is_not_zero || h_is_not_zero) - (letin - (varpat result ty) (Oinst(body)) - (sequence - [set_horizon cstate h_opt; - only - c_is_not_zero (set_pos cpos (local c_start)); - ifthenelse - (major cstate) - (sequence - [only - c_is_not_zero (cout ctable cstate cpos); - only - z_is_not_zero - (set_zin_to_false ztable zpos)]) - (sequence - [only - z_is_not_zero (zin ztable cstate zpos); - only - z_is_not_zero - (set_pos zpos (local z_start)); - only - z_is_not_zero (zout ztable cstate zpos); - only - c_is_not_zero (dout ctable cstate cpos)]); - Oexp (local result)])) - body)])))) in - { mach with ma_params = (Ovarpat(cstate, typ_cstate)) :: params; - ma_initialize = i_opt; - ma_methods = { mdesc with me_body = body } :: method_list; - ma_instances = List.map add_extra_param mi_list } - with - (* no step method is present *) - Not_found -> mach - - -(** The main entry. Add new methods to copy the continuous state vector *) -(** back and forth into the internal state *) -let implementation impl = - match impl with - | Oletmachine(f, ({ ma_kind = Deftypes.Tcont } as mach)) -> - (* only continuous machines are concerned *) - let cstate = Zident.fresh "cstate" in - Oletmachine(f, machine f mach cstate) - | Oletmachine _ | Oletvalue _ | Oletfun _ | Oopen _ | Otypedecl _ -> impl - -let implementation_list impl_list = Zmisc.iter implementation impl_list diff --git a/compiler/gencode/oaux.ml b/compiler/gencode/oaux.ml deleted file mode 100644 index 8acd6c2e5..000000000 --- a/compiler/gencode/oaux.ml +++ /dev/null @@ -1,86 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* auxiliary functions *) - -open Obc - -(* the list of methods *) -let step = "step" (* computes values and possible changes of states *) -let reset = "reset" (* resets the discrete state *) -let copy = "copy" (* copy the discrete state *) -let derivative = "derivative" (* computes the values of derivatives *) -let crossing = "crossing" (* computes the zero-crossing functions *) -let horizon = "horizon" (* compute the next time horizon *) - -(* auxiliary functions *) -let letin p e1 i2 = Olet(p, e1, i2) -let letvar x ty e1 i2 = Oletvar(x, false, ty, Some(e1), i2) -let bool v = Oconst(Obool(v)) -let int_const v = Oconst(Oint(v)) -let float_const v = Oconst(Ofloat(v)) -let operator op = Oglobal(Modname (Initial.stdlib_name op)) -let plus e1 e2 = Oapp(operator "+", [e1; e2]) -let mult e1 e2 = Oapp(operator "*", [e1; e2]) -let minus e1 e2 = Oapp(operator "-", [e1; e2]) -let min e1 e2 = Oapp(operator "min", [e1; e2]) -let zero = int_const 0 -let one = int_const 1 -let ffalse = bool false -let void = Oconst(Ovoid) -let is_zero e = match e with Oconst(Oint(0)) -> true | _ -> false -let plus_opt e1 e2 = - match e1, e2 with - | Oconst(Oint(0)), _ -> e2 - | _, Oconst(Oint(0)) -> e1 - | Oconst(Oint(v1)), Oconst(Oint(v2)) -> Oconst(Oint(v1 + v2)) - | _ -> plus e1 e2 -let minus_opt e1 e2 = - match e1, e2 with - | _, Oconst(Oint(0)) -> e1 - | Oconst(Oint(v1)), Oconst(Oint(v2)) -> Oconst(Oint(v1 - v2)) - | _ -> minus e1 e2 -let mult_opt e1 e2 = - match e1, e2 with - | Oconst(Oint(1)), _ -> e2 - | _, Oconst(Oint(1)) -> e1 - | Oconst(Oint(v1)), Oconst(Oint(v2)) -> Oconst(Oint(v1 * v2)) - | _ -> mult e1 e2 - -let local x = Olocal(x) -let global x = Oglobal(x) -let var x = Ovar(false, x) -let varmut x = Ovar(true, x) - -let ifthenelse c i1 i2 = - match i1, i2 with - | Oexp(Oconst(Ovoid)), Oexp(Oconst(Ovoid)) -> Oexp(Oconst(Ovoid)) - | _, Oexp(Oconst(Ovoid)) -> Oif(c, i1, None) - | _ -> Oif(c, i1, Some(i2)) - -let sequence i_list = - let seq i i_list = - match i, i_list with - | Oexp(Oconst(Ovoid)), _ -> i_list - | _, [] -> [i] - | _ -> i :: i_list in - let i_list = List.fold_right seq i_list [] in - match i_list with - | [] -> Oexp(void) - | _ -> Osequence i_list - -let rec left_state_access lv i_list = - match i_list with - | [] -> lv - | i :: i_list -> left_state_access (Oleft_state_index(lv, local i)) i_list diff --git a/compiler/gencode/obc.ml b/compiler/gencode/obc.ml deleted file mode 100644 index 841c48277..000000000 --- a/compiler/gencode/obc.ml +++ /dev/null @@ -1,204 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* abstract syntax tree of the object code *) - -open Zlocation -open Zmisc -open Zident - -type name = string - -(* a continuous state variable [x] is a pair *) -(* with two fields: [x.der] for its derivative. [x.pos] *) -(* for its current value. *) -(* a zero-crossing variable [x] has two field: [x.zin] is true when *) -(* the solver has detected a zero-crossing. [x.zout] is the value *) -(* to be observed for a zero-crossing *) - -(* expressions are expected to be safe; unsafe ones must be put *) -(* into instructions *) -type exp = - | Oconst of immediate (* immediate constant *) - | Oconstr0 of Lident.t (* 0-ary and 1-ary constructor *) - | Oconstr1 of Lident.t * exp list - | Oglobal of Lident.t (* global variable *) - | Olocal of Zident.t (* read of local value *) - | Ovar of is_mutable * Zident.t (* read of local variable *) - | Ostate of left_state_value (* read of a state variable *) - | Oaccess of exp * exp (* access in an array *) - | Oupdate of size * exp * exp * exp (* update of an array of size [s1] *) - | Oslice of exp * size * size (* e{s1..s2} *) - | Oconcat of exp * size * exp * size (* { e1 | e2 } *) - | Ovec of exp * size (* e1[e2] build an array of size [s2] with value [e1] *) - | Otuple of exp list (* tuples *) - | Oapp of exp * exp list (* function application *) - | Orecord of (Lident.t * exp) list (* record *) - | Orecord_access of exp * Lident.t (* access to a record field *) - | Orecord_with of exp * (Lident.t * exp) list (* record with copy *) - | Otypeconstraint of exp * type_expression (* type constraint *) - | Oifthenelse of exp * exp * exp - | Omethodcall of method_call - | Oinst of inst - - (* when [is_mutable = true] a variable [x] is mutable which means that *) - (* x <- ... and ...x... are valid expression; otherwise a ref will be *) - (* added when translated into OCaml **) - and is_mutable = bool - - (* instructions *) -and inst = - | Olet of pattern * exp * inst - | Oletvar of Zident.t * is_mutable * Deftypes.typ * exp option * inst - | Ofor of bool * Zident.t * exp * exp * inst - | Owhile of exp * inst - | Omatch of exp * inst match_handler list - | Oif of exp * inst * inst option - | Oassign of left_value * exp - | Oassign_state of left_state_value * exp - | Osequence of inst list - | Oexp of exp - -and is_shared = bool - -and left_value = - | Oleft_name of Zident.t - | Oleft_record_access of left_value * Lident.t - | Oleft_index of left_value * exp - -and left_state_value = - | Oself - | Oleft_state_global of Lident.t - | Oleft_instance_name of Zident.t - | Oleft_state_name of Zident.t - | Oleft_state_record_access of left_state_value * Lident.t - | Oleft_state_index of left_state_value * exp - | Oleft_state_primitive_access of left_state_value * primitive_access - -(* a machine provides certain fields for reading/writting special values *) -and primitive_access = - | Oder (* x.der.(i) <- ... *) - | Ocont (* x.pos.(i) <- ... *) - | Ozero_out (* x.zero_out.(i) <-... *) - | Ozero_in (* ... x.zero_in.(i) ... *) - -and immediate = - | Oint of int - | Oint32 of int - | Obool of bool - | Ofloat of float - | Ochar of char - | Ostring of string - | Ovoid - | Oany - -and pattern = - | Owildpat - | Otuplepat of pattern list - | Ovarpat of Zident.t * type_expression - | Oconstpat of immediate - | Oaliaspat of pattern * Zident.t - | Oconstr0pat of Lident.t - | Oconstr1pat of Lident.t * pattern list - | Oorpat of pattern * pattern - | Otypeconstraintpat of pattern * type_expression - | Orecordpat of (Lident.t * pattern) list - -and 'a match_handler = - { w_pat : pattern; - w_body : 'a; } - -(* implementation of a machine *) -and machine = - { ma_kind: Deftypes.kind; (* combinatorial, continuous-time or discrete-time *) - ma_params: pattern list; (* list of static parameters *) - ma_initialize: inst option; - (* code to execute at the creation of the machine *) - ma_memories: mentry list;(* memories *) - ma_instances: ientry list; (* instances *) - ma_methods: method_desc list; (* methods *) - } - -and mentry = - { m_name: Zident.t; (* its name *) - m_value: exp option; (* its possible initial value *) - m_typ: Deftypes.typ; (* its type *) - m_kind: Deftypes.mkind option; (* the kind of the memory *) - m_size: exp path; (* it may be an array *) - } - -and ientry = - { i_name: Zident.t; (* its name *) - i_machine: exp; (* the machine it belongs to *) - i_kind: Deftypes.kind; (* the kind of the machine *) - i_params: exp path; (* static parameters used at instance creation *) - i_size: exp list; (* it is possibly an array of instances *) - } - -and method_desc = - { me_name: method_name; (* name of the method *) - me_params: pattern list; (* list of input arguments *) - me_body: inst; (* body *) - me_typ: Deftypes.typ; (* type of the result *) - } - -and method_call = - { met_machine: Lident.t option; (* the class of the method *) - met_name: method_name; (* the name of the method *) - met_instance: (Zident.t * exp path) option; - (* either a call to self (None) or to *) - (* one instance o.(index_1)...(index_n).m(e_1,...,e_k) *) - met_args: exp list } - -and method_name = name - -and 'a path = 'a list - -and implementation_list = implementation list - -and implementation = - | Oletvalue of name * inst - | Oletfun of name * pattern list * inst - | Oletmachine of name * machine - | Oopen of string - | Otypedecl of (string * string list * type_decl) list - -(* type declaration *) -and type_expression = - | Otypevar of string - | Otypefun of kind * Zident.t option * type_expression * type_expression - | Otypetuple of type_expression list - | Otypeconstr of Lident.t * type_expression list - | Otypevec of type_expression * size - -and size = - | Sconst of int - | Sname of Zident.t - | Sglobal of Lident.t - | Sop of size_op * size * size - -and size_op = Splus | Sminus - -and kind = Ofun | Onode - -and type_decl = - | Oabstract_type - | Oabbrev of type_expression - | Ovariant_type of constr_decl list - | Orecord_type of (string * type_expression) list - -and constr_decl = - | Oconstr0decl of string - | Oconstr1decl of string * type_expression list - diff --git a/compiler/gencode/ocamlprinter.ml b/compiler/gencode/ocamlprinter.ml deleted file mode 100644 index ab2eeddb7..000000000 --- a/compiler/gencode/ocamlprinter.ml +++ /dev/null @@ -1,616 +0,0 @@ -(**************************************************************************) -(* *) -(* Zelus *) -(* A synchronous language for hybrid systems *) -(* http://zelus.di.ens.fr *) -(* *) -(* Marc Pouzet and Timothy Bourke *) -(* *) -(* Copyright 2012 - 2019. All rights reserved. *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(* Zelus is developed in the INRIA PARKAS team. *) -(* *) -(**************************************************************************) - -(* print object code as OCaml functions *) - -open Zmisc -open Zlocation -open Zident -open Obc -open Format -open Pp_tools -open Printer -open Oprinter - - -let immediate ff = function - | Oint i -> - if i < 0 then fprintf ff "(%a)" pp_print_int i else pp_print_int ff i - | Oint32 i -> - if i < 0 - then fprintf ff "(%al)" pp_print_int i - else fprintf ff "%al" pp_print_int i - | Ofloat f -> - if f < 0.0 then fprintf ff "(%a)" pp_print_float f - else pp_print_float ff f - | Obool b -> if b then fprintf ff "true" else fprintf ff "false" - | Ostring s -> fprintf ff "%S" s - | Ochar c -> fprintf ff "'%c'" c - | Ovoid -> pp_print_string ff "()" - | Oany -> fprintf ff "Obj.magic ()" - - -let default_list_of_methods = [Oaux.step; Oaux.reset] - -let constructor_for_kind = function - | Deftypes.Tcont - | Deftypes.Tdiscrete(true) - | Deftypes.Tproba -> if !Zmisc.with_copy then "Cnode" else "Node" - | _ -> assert false -let extra_methods m_list = - if !Zmisc.with_copy then Oaux.copy :: m_list else m_list -let expected_list_of_methods = function - | Deftypes.Tcont - | Deftypes.Tdiscrete(true) - | Deftypes.Tproba -> extra_methods default_list_of_methods - | _ -> assert false - -let print_concrete_type ff ty = - let priority = - function | Otypevar _ | Otypeconstr _ | Otypevec _ -> 2 - | Otypetuple _ -> 2 | Otypefun _ -> 1 in - let rec ptype prio ff ty = - let prio_ty = priority ty in - if prio_ty < prio then fprintf ff "("; - begin match ty with - | Otypevar(s) -> fprintf ff "%s" s - | Otypefun(k, _, ty_arg, ty) -> - begin match k with - | Ofun -> - fprintf ff "@[%a ->@ %a@]" - (ptype (prio_ty+1)) ty_arg (ptype prio_ty) ty - | Onode -> - fprintf ff "@[(%a, %a) node@]" - (ptype (prio_ty+1)) ty_arg (ptype prio_ty) ty - end - | Otypetuple(ty_list) -> - fprintf ff - "@[%a@]" (print_list_r (ptype prio_ty) "("" *"")") ty_list - | Otypeconstr(ln, ty_list) -> - fprintf ff "@[%a@]%a" - (print_list_r_empty (ptype 2) "("","")") ty_list longname ln - | Otypevec(ty_arg, _) -> - fprintf ff "@[%a %a@]" (ptype prio_ty) ty_arg - longname (Lident.Modname Initial.array_ident) - end; - if prio_ty < prio then fprintf ff ")" in - ptype 0 ff ty - -let ptype ff ty = - let ty = Ztypes.remove_dependences ty in - Ptypes.output ff ty - -let rec pattern ff pat = match pat with - | Owildpat -> fprintf ff "_" - | Oconstpat(i) -> immediate ff i - | Oconstr0pat(lname) -> longname ff lname - | Oconstr1pat(lname, pat_list) -> - fprintf ff "@[%a%a@]" - longname lname (print_list_r pattern "("","")") pat_list - | Ovarpat(n, ty_exp) -> - fprintf ff "@[(%a:%a)@]" name n print_concrete_type ty_exp - | Otuplepat(pat_list) -> - pattern_comma_list ff pat_list - | Oaliaspat(p, n) -> fprintf ff "@[%a as %a@]" pattern p name n - | Oorpat(pat1, pat2) -> fprintf ff "@[%a | %a@]" pattern pat1 pattern pat2 - | Otypeconstraintpat(p, ty_exp) -> - fprintf ff "@[(%a: %a)@]" pattern p print_concrete_type ty_exp - | Orecordpat(n_pat_list) -> - print_record (print_couple longname pattern """ =""") ff n_pat_list - -and pattern_list ff pat_list = - print_list_r pattern """""" ff pat_list - -and pattern_comma_list ff pat_list = - print_list_r pattern "("","")" ff pat_list - -(** Print the call to a method *) -and method_call ff { met_name = m; met_instance = i_opt; met_args = e_list } = - let m = method_name m in - let instance_name ff i_opt = - match i_opt with - | None -> fprintf ff "self" | Some(o, _) -> name ff o in - let instance ff i_opt = - match i_opt with - | None -> (* a call to the self machine *) fprintf ff "self" - | Some(o, e_list) -> - match e_list with - | [] -> fprintf ff "self.%a" name o - | e_list -> - fprintf ff "self.%a.%a" name o - (print_list_no_space - (print_with_braces (exp 3) "(" ")") "" "." "") - e_list in - fprintf ff "@[%a_%s %a@ %a@]" - instance_name i_opt m instance i_opt - (print_list_r (exp 3) "" "" "") e_list - -and var ff left = - match left with - | Oleft_name(n) -> fprintf ff "@[!%a@]" name n - | _ -> left_value ff left - -and left_state_value ff left = - match left with - | Oself -> fprintf ff "self." - | Oleft_instance_name(n) -> fprintf ff "self.%a" name n - | Oleft_state_global(ln) -> longname ff ln - | Oleft_state_name(n) -> fprintf ff "self.%a" name n - | Oleft_state_record_access(left, n) -> - fprintf ff "@[%a.%a@]" left_state_value left longname n - | Oleft_state_index(left, idx) -> - fprintf ff "@[%a.(%a)@]" left_state_value left (exp 0) idx - | Oleft_state_primitive_access(left, a) -> - fprintf ff "@[%a.%a@]" left_state_value left access a - -and assign ff left e = - match left with - | Oleft_name(n) -> - fprintf ff "@[%a := %a@]" name n (exp 2) e - | _ -> - fprintf ff "@[%a <- %a@]" left_value left (exp 2) e - -and assign_state ff left e = - match left with - | Oleft_state_global(gname) -> - fprintf ff "@[%a := %a@]" longname gname (exp 2) e - | _ -> fprintf ff "@[%a <- %a@]" left_state_value left (exp 2) e - -and letvar ff n is_mutable ty e_opt i = - let s = if is_mutable then "" else "ref " in - match e_opt with - | None -> - fprintf ff "@[let %a = %s(Obj.magic (): %a) in@ %a@]" - name n s ptype ty (inst 0) i - | Some(e0) -> - fprintf ff "@[let %a = %s(%a:%a) in@ %a@]" - name n s (exp 0) e0 ptype ty (inst 0) i - -and exp prio ff e = - let prio_e = priority_exp e in - if prio_e < prio then fprintf ff "("; - begin match e with - | Oconst(i) -> immediate ff i - | Oconstr0(lname) -> longname ff lname - | Oconstr1(lname, e_list) -> - fprintf ff "@[%a%a@]" - longname lname (print_list_r (exp prio_e) "("","")") e_list - | Oglobal(ln) -> longname ff ln - | Olocal(n) -> local ff n - | Ovar(is_mutable, n) -> - fprintf ff "@[%s%a@]" (if is_mutable then "" else "!") local n - | Ostate(l) -> left_state_value ff l - | Oaccess(e, eidx) -> - fprintf ff "%a.(@[%a@])" (exp prio_e) e (exp prio_e) eidx - | Ovec(e, se) -> - (* make a vector *) - let print_vec ff e se = - match e with - | Oconst _ -> - fprintf ff "@[Array.make@ (%a)@ (%a)@]" - (psize prio_e) se (exp prio_e) e - | Ovec(e1, s2) -> - fprintf ff "@[Array.make_matrix@ (%a)@ (%a)@ (%a)@]" - (psize prio_e) se (psize prio_e) s2 (exp prio_e) e1 - | _ -> fprintf ff "@[Array.init@ @[(%a)@]@ @[(fun _ -> %a)@]@]" - (psize prio_e) se (exp prio_e) e in - print_vec ff e se - | Oupdate(se, e1, i, e2) -> - (* returns a fresh vector [_t] of size [se] equal to [e2] except at *) - (* [i] where it is equal to [e2] *) - fprintf ff "@[(let _t = Array.copy (%a) in@ _t.(%a) <- %a; _t)@]" - (exp 0) e1 (exp 0) i (exp 0) e2 - | Oslice(e, s1, s2) -> - (* returns a fresh vector [_t] of size [s1+s2] *) - (* with _t.(i) = e.(i + s1) for all i in [0..s2-1] *) - fprintf ff "@[(let _t = Array.make %a %a.(0) in @ \ - for i = 0 to %a - 1 do @ \ - _t.(i) <- %a.(i+%a) done; @ \ - _t)@]" - (psize 2) s1 (exp 2) e - (psize 0) s2 - (exp 2) e (psize 0) s1 - | Oconcat(e1, s1, e2, s2) -> - (* returns a fresh vector [_t] of size [s1+s2] *) - (* with _t.(i) = e1.(i) forall i in [0..s1-1] and *) - (* _t.(i+s1) = e2.(i) forall i in [0..s2-1] *) - fprintf ff "@[(let _t = Array.make (%a+%a) %a.(0) in @ \ - Array.blit %a 0 _t 0 %a; @ \ - Array.blit %a 0 _t %a; @ \ - _t)@]" - (psize 0) s1 (psize 0) s2 (exp 2) e1 - (exp 2) e1 (psize 0) s1 - (exp 2) e2 (psize 0) s2 - | Otuple(e_list) -> - fprintf ff "@[%a@]" (print_list_r (exp prio_e) "("","")") e_list - | Oapp(e, e_list) -> - fprintf ff "@[%a %a@]" - (exp (prio_e + 1)) e (print_list_r (exp (prio_e + 1)) """""") e_list - | Omethodcall m -> method_call ff m - | Orecord(r) -> - print_record (print_couple longname (exp prio_e) """ =""") ff r - | Orecord_access(e_record, lname) -> - fprintf ff "%a.%a" (exp prio_e) e_record longname lname - | Orecord_with(e_record, r) -> - fprintf ff "@[{ %a with %a }@]" - (exp prio_e) e_record - (print_list_r - (print_couple longname (exp prio_e) """ =""") "" ";" "") r - | Otypeconstraint(e, ty_e) -> - fprintf ff "@[(%a : %a)@]" (exp prio_e) e print_concrete_type ty_e - | Oifthenelse(e, e1, e2) -> - fprintf ff "@[if %a@ @[then@ %a@]@ @[else@ %a@]@]" - (exp 0) e (exp prio_e) e1 (exp prio_e) e2 - | Oinst(i) -> inst prio ff i - end; - if prio_e < prio then fprintf ff ")" - -and inst prio ff i = - let prio_i = priority_inst i in - if prio_i < prio then fprintf ff "("; - begin - match i with - | Olet(p, e, i) -> - fprintf ff "@[let %a in@ %a@]" pat_exp (p, e) (inst (prio_i-1)) i - | Oletvar(x, is_mutable, ty, e_opt, i) -> letvar ff x is_mutable ty e_opt i - | Omatch(e, match_handler_l) -> - fprintf ff "@[begin @[match %a with@ @[%a@]@] end@]" - (exp 0) e - (print_list_l match_handler """""") match_handler_l - | Ofor(is_to, n, e1, e2, i3) -> - fprintf ff "@[for %a = %a %s %a@ @[do@ %a@ done@]@]" - name n (exp 0) e1 (if is_to then "to" else "downto") - (exp 0) e2 (inst 0) i3 - | Owhile(e1, i2) -> - fprintf ff "@[while %a do %a done@]@]" - (exp 0) e1 (inst 0) i2 - | Oassign(left, e) -> assign ff left e - | Oassign_state(left, e) -> assign_state ff left e - | Osequence(i_list) -> - if i_list = [] - then fprintf ff "()" - else fprintf - ff "@[%a@]" (print_list_r (inst (prio_i + 1)) "" ";" "") i_list - | Oexp(e) -> exp prio ff e - | Oif(e, i1, None) -> - fprintf ff "@[if %a@ then@ %a@]" (exp 0) e sinst i1 - | Oif(e, i1, Some(i2)) -> - fprintf ff "@[if %a@ then@ %a@ else %a@]" - (exp 0) e sinst i1 sinst i2 - end; - if prio_i < prio then fprintf ff ")" - -(* special treatment to add an extra parenthesis if [i] is a sequence *) -and sinst ff i = - match i with - | Osequence(i_list) -> - if i_list = [] then fprintf ff "()" - else fprintf ff - "@[%a@]" (print_list_r (inst 1) "(" ";" ")") i_list - | _ -> inst 0 ff i - -and pat_exp ff (p, e) = - fprintf ff "@[@[%a@] =@ @[%a@]@]" pattern p (exp 0) e - -and exp_with_typ ff (e, ty) = - fprintf ff "(%a:%a)" (exp 2) e ptype ty - -and match_handler ff { w_pat = pat; w_body = b } = - fprintf ff "@[| %a ->@ %a@]" pattern pat (inst 0) b - - -let print_memory ff { m_name = n; m_value = e_opt; m_typ = ty; - m_kind = k_opt; m_size = m_size } = - let mem = function - | None -> "" - | Some(k) -> (Printer.kind k) ^ " " in - match e_opt with - | None -> fprintf ff "%s%a%a : %a" - (mem k_opt) name n - (print_list_no_space (print_with_braces (exp 0) - "[" "]") "" "" "") - m_size ptype ty - | Some(e) -> - fprintf ff "%s%a%a : %a = %a" (mem k_opt) name n - (print_list_no_space (print_with_braces (exp 0) "[" "]") "" "" "") - m_size ptype ty (exp 0) e - -(** Define the data-type for the internal state of a machine *) -(* A prefix "_" is added to the name of the machine to avoid *) -(* name conflicts *) -let def_type_for_a_machine ff f memories instances = - let one_entry ff (n, m) = - fprintf ff "@[mutable %a : '%s@]" name n m in - let i, params, entries = - List.fold_right - (fun { m_name = n } (i, params, entries) -> - let m = Zmisc.int_to_alpha i in (i+1, m :: params, (n, m) :: entries)) - memories (0, [], []) in - let i, params, entries = - List.fold_right - (fun { i_name = n } (i, params, entries) -> - let m = Zmisc.int_to_alpha i in (i+1, m :: params, (n, m) :: entries)) - instances (i, params, entries) in - (* if the state is empty, produce the dummy state type [unit] *) - if entries = [] - then fprintf ff "@[type _%s = unit@.@.@]" f - else - fprintf ff "@[type @[%a@] _%s =@ { @[%a@] }@.@.@]" - (print_list_r (fun ff s -> fprintf ff "'%s" s) "("","")") params - f - (print_list_r one_entry """;""") entries - - -(** Print the method as a function *) -let pmethod f ff { me_name = me_name; me_params = pat_list; - me_body = i; me_typ = ty } = - fprintf ff "@[let %s_%s self %a =@ (%a:%a) in@]" - f (method_name me_name) pattern_list pat_list (inst 2) i ptype ty - -(* create an array of type t[n_1]...[n_k] *) -let array_make print arg ff ie_size = - let rec array_rec ff = function - | [] -> fprintf ff "%a" print arg - | ie :: ie_size -> - fprintf ff "@[Array.init %a@ (fun _ -> %a)@]" - (exp 3) ie array_rec ie_size in - array_rec ff ie_size - -let rec array_of e_opt ty ff ie_size = - let exp_of ff (e_opt, ty) = - match e_opt, ty with - | Some(e), _ -> exp 2 ff e - | _ -> fprintf ff "(Obj.magic (): %a)" ptype ty in - match ie_size with - | [] -> exp_of ff (e_opt, ty) - | [ie] -> fprintf ff "Array.make %a %a" (exp 3) ie exp_of (e_opt, ty) - | ie :: ie_list -> - fprintf ff - "@[Array.init %a@ (fun _ -> %a)@]" (exp 3) ie - (array_of e_opt ty) ie_list - -(* Print initialization code *) -let print_initialize ff i_opt = - match i_opt with - | None -> fprintf ff "()" | Some(i) -> fprintf ff "%a" (inst 0) i - -(** Print the allocation function *) -let palloc f i_opt memories ff instances = - let print_memory ff { m_name = n; m_value = e_opt; - m_typ = ty; m_kind = k_opt; m_size = m_size } = - match k_opt with - | None -> - (* discrete state variable *) - begin - match e_opt with - | None -> - fprintf ff "@[%a = %a@]" name n - (array_make (fun ff _ -> fprintf ff "(Obj.magic (): %a)" - ptype ty) ()) - m_size - | Some(e) -> - fprintf ff "@[%a = %a@]" name n - (array_make exp_with_typ (e, ty)) m_size - end - | Some(m) -> - match m with - | Deftypes.Zero -> - fprintf ff "@[%a = @[{ zin = %a;@ zout = %a }@]@]" - name n (array_of e_opt Initial.typ_bool) m_size - (array_of (Some(Oconst(Ofloat(1.0)))) Initial.typ_float) - m_size - | Deftypes.Cont -> - fprintf ff "@[%a = @[{ pos = %a; der = %a }@]@]" - name n (array_of e_opt ty) m_size - (* the default value of a derivative must be zero *) - (array_of (Some(Oconst(Ofloat(0.0)))) ty) m_size - | Deftypes.Horizon | Deftypes.Period - | Deftypes.Encore | Deftypes.Major -> - fprintf ff "%a = %a" name n (array_of e_opt ty) m_size in - - let print_instance ff { i_name = n; i_machine = ei; - i_kind = k; i_params = e_list; i_size = ie_size } = - fprintf ff "@[%a = %a (* %s *)@ @]" name n - (array_make (fun ff n -> fprintf ff "%a_alloc ()" name n) n) - ie_size (kind k) in - if memories = [] - then if instances = [] - then fprintf ff "@[let %s_alloc _ = %a in@]" f print_initialize i_opt - else - fprintf ff "@[let %s_alloc _ =@ @[%a;@,%a@] in@]" - f print_initialize i_opt - (print_record print_instance) instances - else if instances = [] - then - fprintf ff "@[let %s_alloc _ =@ @[%a;@,%a@] in@]" - f print_initialize i_opt (print_record print_memory) memories - else - fprintf ff "@[let %s_alloc _ =@ @[%a;@,{ @[%a@,%a@] }@] in@]" - f - print_initialize i_opt - (print_list_r print_memory """;"";") memories - (print_list_r print_instance """;""") instances - -(* A copy method that recursively copy an internal state. *) -(* This solution does not work at the moment when the program has *) -(* forall loops. *) -(* [copy source dest] recursively copies the containt of [source] into [dest] *) -let pcopy f memories ff instances = - (* copy a memory [n] which is an array t[s1]...[sn] *) - let array_copy print ff ie_size = - let rec array_rec print ff = function - | [] -> print ff () - | _ :: ie_size -> - fprintf ff "@[Array.map (fun xi -> %a) %a@]" - (array_rec (fun ff _ -> fprintf ff "xi")) ie_size print () in - match ie_size with - | [] -> print ff () - | _ -> array_rec print ff ie_size in - - let copy_memory ff - { m_name = n; m_kind = k_opt; m_typ = ty; m_size = m_size } = - match k_opt with - | None -> - (* discrete state variable *) - fprintf ff "@[dest.%a <- %a@]" name n - (array_copy (fun ff _ -> fprintf ff "source.%a" name n)) m_size - | Some(m) -> - match m with - | Deftypes.Zero -> - fprintf ff "@[dest.%a.zin <- %a;@,dest.%a.zout <- %a @]" - name n - (array_copy (fun ff _ -> fprintf ff "source.%a.zin" name n)) - m_size - name n - (array_copy (fun ff _ -> fprintf ff "source.%a.zout" name n)) - m_size - | Deftypes.Cont -> - fprintf ff "@[dest.%a.pos <- %a;@,dest.%a.der <- %a @]" - name n - (array_copy (fun ff _ -> fprintf ff "source.%a.pos" name n)) - m_size - name n - (array_copy (fun ff _ -> fprintf ff "source.%a.der" name n)) - m_size - | Deftypes.Horizon | Deftypes.Period - | Deftypes.Encore | Deftypes.Major -> - fprintf ff "@[dest.%a <- source.%a@]" name n name n in - let copy_instance ff { i_name = n; i_machine = ei; - i_kind = k; i_params = e_list; i_size = ie_size } = - fprintf ff "@[%a (* %s *)@]" - (array_make - (fun ff n -> - fprintf ff "@[%a_copy source.%a dest.%a@]" name n name n name n) - n) - ie_size (kind k) in - if memories = [] - then if instances = [] - then fprintf ff "@[let %s_copy source dest = () in@]" f - else - fprintf ff "@[let %s_copy source dest =@ @[%a@] in@]" - f (print_list_r copy_instance "" ";" "") instances - else if instances = [] - then - fprintf ff "@[let %s_copy source dest =@ @[%a@] in@]" - f (print_list_r copy_memory "" ";" "") memories - else - fprintf ff "@[let %s_copy source dest =@ @[%a@,%a@] in@]" - f - (print_list_r copy_memory "" ";" ";") memories - (print_list_r copy_instance "" ";" "") instances - - -(* print an entry [let n_alloc, n_step, n_reset, ... = f ... in] *) -(* for every instance *) -let def_instance_function ff { i_name = n; i_machine = ei; i_kind = k; - i_params = e_list; i_size = ie_size } = - (** Define the method *) - let method_name ff me_name = - let m = method_name me_name in - fprintf ff "%s = %a_%s" m name n m in - - let list_of_methods ff m_list = print_list_r method_name """;""" ff m_list in - - match k with - | Deftypes.Tstatic _ | Deftypes.Tany | Deftypes.Tdiscrete(false) -> () - | _ -> let m_name_list = expected_list_of_methods k in - let k = constructor_for_kind k in - fprintf ff - "@[let %s { alloc = %a_alloc; %a } = %a %a in@]" - k name n list_of_methods m_name_list - (exp 0) ei (print_list_r (exp 1) "" " " "") e_list - -(** Print a machine as pieces with a type definition for the state *) -(** and a collection of functions *) -(* The general form is: - * type ('a1, ...) f = { ... } - * let f x1 ... xn = - * let { alloc = o1_alloc; step = o1_step; reset = o1_reset, ... } = f1 ... in - * ... - * let { alloc = om_alloc; step = om_step; reset = om_reset, ... } = fm ... in - * let f_alloc () = ... in - * let f_step y = ... in - * let f_reset = ... in - * { alloc = f_alloc; step = f_step; reset = f_reset, ... } *) -let machine f ff { ma_kind = k; - ma_params = pat_list; - ma_initialize = i_opt; - ma_memories = memories; - ma_instances = instances; - ma_methods = m_list } = - (* print either [(f)] *) - (* or [k { alloc = f_alloc; m1 = f_m1; ...; mn = f_mn }] *) - let tuple_of_methods ff m_name_list = - match k with - | Deftypes.Tstatic _ | Deftypes.Tany -> fprintf ff "%s" f - | Deftypes.Tdiscrete _ - | Deftypes.Tcont - | Deftypes.Tproba -> - let method_name ff me_name = - let m = method_name me_name in - fprintf ff "@[%s = %s_%s@]" m f m in - let k = constructor_for_kind k in - let m_name_list = - List.map (fun { me_name = me_name } -> me_name) m_list in - let m_name_list = extra_methods m_name_list in - fprintf ff "@[%s { alloc = %s_alloc; %a }@]" - k f (print_list_r method_name "" ";" "") m_name_list in - - (* print the type for [f] *) - def_type_for_a_machine ff f memories instances; - (* print the code for [f] *) - if !Zmisc.with_copy then - fprintf ff - "@[let %s %a = @ @[@[%a@]@ @[%a@]@ @[%a@]@ @[%a@]@ %a@]@.@]" - f - pattern_list pat_list - (print_list_r def_instance_function "" "" "") instances - (palloc f i_opt memories) instances - (pcopy f memories) instances - (print_list_r (pmethod f) """""") m_list - tuple_of_methods m_list - else - fprintf ff "@[let %s %a = @ @[@[%a@]@ @[%a@]@ @[%a@]@ %a@]@.@]" - f - pattern_list pat_list - (print_list_r def_instance_function "" "" "") instances - (palloc f i_opt memories) instances - (print_list_r (pmethod f) """""") m_list - tuple_of_methods m_list - -let implementation ff impl = match impl with - | Oletvalue(n, i) -> - fprintf ff "@[let %a = %a@.@.@]" shortname n (inst 0) i - | Oletfun(n, pat_list, i) -> - fprintf ff "@[let %a %a =@ %a@.@.@]" - shortname n pattern_list pat_list (inst 0) i - | Oletmachine(n, m) -> machine n ff m - | Oopen(s) -> - fprintf ff "@[open %s@.@]" s - | Otypedecl(l) -> - fprintf ff "@[%a@.@]" - (print_list_l - (fun ff (s, s_list, ty_decl) -> - fprintf ff "%a%s =@ %a" - Ptypes.print_type_params s_list - s type_decl ty_decl) - "type ""and """) - l - -let implementation_list ff impl_list = - fprintf ff "@[(* %s *)@.@]" header_in_file; - fprintf ff "@[open Ztypes@.@]"; - List.iter (implementation ff) impl_list diff --git a/compiler/gencode/oprinter.ml b/compiler/gencode/oprinter.ml deleted file mode 100644 index 79a69481c..000000000 --- a/compiler/gencode/oprinter.ml +++ /dev/null @@ -1,401 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* print object code *) - -open Zmisc -open Zlocation -open Zident -open Obc -open Format -open Pp_tools -open Printer - -(** Priorities *) -let rec priority_exp = function - | Oconst _ | Oconstr0 _| Oglobal _ | Olocal _ | Ovar _ | Ostate _ | Oaccess _ - | Orecord _ | Orecord_access _ | Orecord_with _ - | Otypeconstraint _ | Otuple _ -> 3 - | Oconstr1 _ | Oapp _ | Omethodcall _ - | Ovec _ | Oupdate _ | Oslice _ | Oconcat _ -> 2 - | Oifthenelse _ -> 0 | Oinst i -> priority_inst i - -and priority_inst = function - | Olet _ - | Oletvar _ -> 0 - | Ofor _ | Owhile _ -> 3 - | Omatch _ -> 0 - | Oif _ -> 0 - | Oassign _ -> 2 - | Oassign_state _ -> 2 - | Osequence _ -> 0 - | Oexp(e) -> priority_exp e - -let kind = function - | Deftypes.Tstatic _ | Deftypes.Tany | Deftypes.Tdiscrete _ -> "discrete" - | Deftypes.Tcont -> "continuous" | Deftypes.Tproba -> "proba" - -let rec psize prio ff si = - let operator = function Splus -> "+" | Sminus -> "-" in - let priority = function Splus -> 0 | Sminus -> 1 in - match si with - | Sconst(i) -> fprintf ff "%d" i - | Sglobal(ln) -> longname ff ln - | Sname(n) -> name ff n - | Sop(op, e1, e2) -> - let prio_op = priority op in - if prio > prio_op then fprintf ff "("; - fprintf ff "@[%a %s %a@]" - (psize prio_op) e1 (operator op) (psize prio_op) e2; - if prio > prio_op then fprintf ff ")" - -let print_concrete_type ff ty = - let priority = - function | Otypevar _ | Otypeconstr _ | Otypevec _ -> 2 - | Otypetuple _ -> 2 | Otypefun _ -> 1 in - let rec ptype prio ff ty = - let prio_ty = priority ty in - if prio_ty < prio then fprintf ff "("; - begin match ty with - | Otypevar(s) -> fprintf ff "'%s" s - | Otypefun(k, opt_name, ty_arg, ty) -> - let arg prio ff (opt_name, ty) = - match opt_name with - | None -> ptype prio ff ty - | Some(n) -> fprintf ff "@[(%a : %a)@]" name n (ptype 0) ty in - let k = match k with Ofun -> "->" | Onode -> "=>" in - fprintf ff "@[%a %s@ %a@]" - (arg prio_ty) (opt_name, ty_arg) k (ptype prio_ty) ty - | Otypetuple(ty_list) -> - fprintf ff - "@[%a@]" (print_list_r (ptype prio_ty) "("" *"")") ty_list - | Otypeconstr(ln, ty_list) -> - fprintf ff "@[%a@]%a" - (print_list_r_empty (ptype 2) "("","")") ty_list longname ln - | Otypevec(ty_arg, si) -> - fprintf ff "@[%a[%a]@]" (ptype prio_ty) ty_arg (psize 0) si - end; - if prio_ty < prio then fprintf ff ")" in - ptype 0 ff ty - -let ptype ff ty = Ptypes.output ff ty - -let immediate ff = function - | Oint i -> - if i < 0 then fprintf ff "(%a)" pp_print_int i else pp_print_int ff i - | Oint32 i -> - if i < 0 - then fprintf ff "(%al)" pp_print_int i - else fprintf ff "%al" pp_print_int i - | Ofloat f -> - if f < 0.0 then fprintf ff "(%a)" pp_print_float f - else pp_print_float ff f - | Obool b -> if b then fprintf ff "true" else fprintf ff "false" - | Ostring s -> fprintf ff "%S" s - | Ochar c -> fprintf ff "'%c'" c - | Ovoid -> pp_print_string ff "()" - | Oany -> fprintf ff "any" - -let rec pattern ff pat = match pat with - | Owildpat -> fprintf ff "_" - | Oconstpat(i) -> immediate ff i - | Oconstr0pat(lname) -> longname ff lname - | Oconstr1pat(lname, pat_list) -> - fprintf ff "@[%a%a@]" - longname lname (print_list_r pattern "("","")") pat_list - | Ovarpat(n, ty_exp) -> - fprintf ff "@[(%a:%a)@]" name n print_concrete_type ty_exp - | Otuplepat(pat_list) -> - pattern_comma_list ff pat_list - | Oaliaspat(p, n) -> fprintf ff "@[%a as %a@]" pattern p name n - | Oorpat(pat1, pat2) -> fprintf ff "@[%a | %a@]" pattern pat1 pattern pat2 - | Otypeconstraintpat(p, ty_exp) -> - fprintf ff "@[(%a: %a)@]" pattern p print_concrete_type ty_exp - | Orecordpat(n_pat_list) -> - print_record (print_couple longname pattern """ =""") ff n_pat_list - -and pattern_list ff pat_list = - print_list_r pattern """""" ff pat_list - -and pattern_comma_list ff pat_list = - print_list_r pattern "("","")" ff pat_list - -and method_name m_name = m_name - -(** Print the call to a method *) -and method_call ff { met_name = m; met_instance = i_opt; met_args = e_list } = - let m = method_name m in - let instance ff i_opt = - match i_opt with - | None -> (* a call to the self machine *) fprintf ff "self" - | Some(o, e_list) -> - match e_list with - | [] -> fprintf ff "self.%a" name o - | e_list -> - fprintf ff "self.%a.%a" name o - (print_list_no_space - (print_with_braces (exp 3) "(" ")") "" "." "") e_list in - fprintf ff "@[%a.%s @ %a@]" - instance i_opt m - (print_list_r (exp 3) "" "" "") e_list - -and left_value ff left = - match left with - | Oleft_name(n) -> name ff n - | Oleft_record_access(left, n) -> - fprintf ff "@[%a.%a@]" left_value left longname n - | Oleft_index(left, idx) -> - fprintf ff "@[%a.(%a)@]" left_value left (exp 0) idx - -and left_state_value ff left = - match left with - | Oself -> fprintf ff "self." - | Oleft_instance_name(n) -> name ff n - | Oleft_state_global(ln) -> longname ff ln - | Oleft_state_name(n) -> name ff n - | Oleft_state_record_access(left, n) -> - fprintf ff "@[%a.%a@]" left_state_value left longname n - | Oleft_state_index(left, idx) -> - fprintf ff "@[%a.(%a)@]" left_state_value left (exp 0) idx - | Oleft_state_primitive_access(left, a) -> - fprintf ff "@[%a.%a@]" left_state_value left access a - -and assign ff left e = - match left with - | Oleft_name(n) -> - fprintf ff "@[%a := %a@]" name n (exp 2) e - | _ -> - fprintf ff "@[%a <- %a@]" left_value left (exp 2) e - -and assign_state ff left e = - match left with - | Oleft_state_global(gname) -> - fprintf ff "@[%a := %a@]" longname gname (exp 2) e - | _ -> fprintf ff "@[%a <- %a@]" left_state_value left (exp 2) e - -and access ff a = - let s = - match a with - | Oder -> "der" | Ocont -> "pos" - | Ozero_out -> "zout" | Ozero_in -> "zin" in - fprintf ff "%s" s - -and local ff n = name ff n - -and var ff n = name ff n - -and letvar ff n ty e_opt i = - match e_opt with - | None -> - fprintf ff "@[var %a: %a in@ %a@]" name n ptype ty (inst 0) i - | Some(e0) -> - fprintf ff "@[var %a: %a = %a in@ %a@]" - name n ptype ty (exp 0) e0 (inst 0) i - -and exp prio ff e = - let prio_e = priority_exp e in - if prio_e < prio then fprintf ff "("; - begin match e with - | Oconst(i) -> immediate ff i - | Oconstr0(lname) -> longname ff lname - | Oconstr1(lname, e_list) -> - fprintf ff "@[%a%a@]" - longname lname (print_list_r (exp prio_e) "("","")") e_list - | Oglobal(ln) -> longname ff ln - | Olocal(n) -> local ff n - | Ovar(_, n) -> local ff n - | Ostate(l) -> left_state_value ff l - | Oaccess(e, eidx) -> - fprintf ff "%a.(@[%a@])" (exp prio_e) e (exp prio_e) eidx - | Ovec(e, se) -> - fprintf ff "%a[%a]" (exp prio_e) e (psize 0) se - | Oupdate(se, e1, i, e2) -> - fprintf ff "@[{%a:%a with@ %a = %a}@]" - (exp prio_e) e1 (psize prio_e) se (exp 0) i (exp 0) e2 - | Oslice(e, s1, s2) -> - fprintf ff "%a{%a..%a}" - (exp prio_e) e (psize 0) s1 (psize 0) s2 - | Oconcat(e1, s1, e2, s2) -> - fprintf ff "{%a:%a | %a:%a}" - (exp 0) e1 (psize 0) s1 (exp 0) e2 (psize 0) s2 - | Otuple(e_list) -> - fprintf ff "@[%a@]" (print_list_r (exp prio_e) "("","")") e_list - | Oapp(e, e_list) -> - fprintf ff "@[%a %a@]" - (exp (prio_e + 1)) e (print_list_r (exp (prio_e + 1)) """""") - e_list - | Omethodcall m -> method_call ff m - | Orecord(r) -> - print_record (print_couple longname (exp prio_e) """ =""") ff r - | Orecord_access(e_record, lname) -> - fprintf ff "%a.%a" (exp prio_e) e_record longname lname - | Orecord_with(e_record, r) -> - fprintf ff "@[{ %a with %a }@]" - (exp prio_e) e_record - (print_list_r - (print_couple longname (exp prio_e) """ =""") "" ";" "") r - | Otypeconstraint(e, ty_e) -> - fprintf ff "@[(%a : %a)@]" (exp prio_e) e print_concrete_type ty_e - | Oifthenelse(e, e1, e2) -> - fprintf ff "@[if %a@ @[then@ %a@]@ @[else@ %a@]@]" - (exp 0) e (exp 1) e1 (exp 1) e2 - | Oinst(i) -> inst prio ff i - end; - if prio_e < prio then fprintf ff ")" - -and inst prio ff i = - let prio_i = priority_inst i in - if prio_i < prio then fprintf ff "("; - begin - match i with - | Olet(p, e, i) -> - fprintf ff "@[let %a in@ %a@]" pat_exp (p, e) (inst (prio_i-1)) i - | Oletvar(x, _, ty, e_opt, i) -> letvar ff x ty e_opt i - | Omatch(e, match_handler_l) -> - fprintf ff "@[match %a with@ @[%a@]@]" - (exp 0) e - (print_list_l match_handler """""") match_handler_l - | Ofor(is_to, n, e1, e2, i3) -> - fprintf ff "@[for %a = %a %s %a@ @[do@ %a@ done@]@]" - name n (exp 0) e1 (if is_to then "to" else "downto") - (exp 0) e2 (inst 0) i3 - | Owhile(e1, i2) -> - fprintf ff "@[while %a do %a done@]@]" - (exp 0) e1 (inst 0) i2 - | Oassign(left, e) -> assign ff left e - | Oassign_state(left, e) -> assign_state ff left e - | Osequence(i_list) -> - if i_list = [] - then fprintf ff "()" - else - fprintf ff - "@[%a@]" (print_list_r (inst 1) "" ";" "") i_list - | Oexp(e) -> exp prio ff e - | Oif(e, i1, None) -> - fprintf ff "@[if %a@ then@ %a@]" (exp 0) e sinst i1 - | Oif(e, i1, Some(i2)) -> - fprintf ff "@[if %a@ then@ %a@ else %a@]" - (exp 0) e sinst i1 sinst i2 - end; - if prio_i < prio then fprintf ff ")" - -(* special treatment to add an extra parenthesis if [i] is a sequence *) -and sinst ff i = - match i with - | Osequence(i_list) -> - if i_list = [] then fprintf ff "()" - else fprintf ff - "@[%a@]" (print_list_r (inst 1) "(" ";" ")") i_list - | _ -> inst 0 ff i - -and pat_exp ff (p, e) = - fprintf ff "@[@[%a@] =@ @[%a@]@]" pattern p (exp 0) e - -and exp_with_typ ff (e, ty) = - fprintf ff "(%a:%a)" (exp 2) e ptype ty - -and expression ff e = exp 0 ff e - -and match_handler ff { w_pat = pat; w_body = b } = - fprintf ff "@[| %a ->@ %a@]" pattern pat (inst 0) b - -(** The main entry functions for expressions and instructions *) -let rec type_decl ff = function - | Oabstract_type -> () - | Oabbrev(ty) -> print_concrete_type ff ty - | Ovariant_type(constr_decl_list) -> - print_list_l constr_decl """| """ ff constr_decl_list - | Orecord_type(s_ty_list) -> - print_record - (print_couple pp_print_string print_concrete_type """ :""") ff s_ty_list - -and constr_decl ff = function - | Oconstr0decl(s) -> fprintf ff "%s" s - | Oconstr1decl(s, ty_list) -> - fprintf ff "%s of %a" s (print_list_l print_concrete_type """ *""") ty_list - -let memory ff { m_name = n; m_value = e_opt; m_typ = ty; - m_kind = k_opt; m_size = m_size } = - let mem = function - | None -> "" - | Some(k) -> (Printer.kind k) ^ " " in - match e_opt with - | None -> fprintf ff "%s%a%a : %a" - (mem k_opt) name n - (print_list_no_space (print_with_braces (exp 0) - "[" "]") "" "" "") - m_size ptype ty - | Some(e) -> - fprintf ff "%s%a%a : %a = %a" (mem k_opt) name n - (print_list_no_space (print_with_braces (exp 0) "[" "]") "" "" "") - m_size ptype ty (exp 0) e - -let instance ff { i_name = n; i_machine = ei; i_kind = k; - i_params = e_list; i_size = i_size } = - fprintf ff "@[%a : %s(%a)%a%a@]" name n (kind k) (exp 0) ei - (print_list_no_space - (print_with_braces (exp 0) "(" ")") "" "" "") - e_list - (print_list_no_space - (print_with_braces (exp 0) "[" "]") "" "" "") - i_size - -let pmethod ff - { me_name = m_name; me_params = p_list; me_body = i; me_typ = ty } = - fprintf ff "@[method %s %a@ =@ (%a:%a)@]" - (method_name m_name) pattern_list p_list (inst 2) i ptype ty - -let pinitialize ff i_opt = - match i_opt with - | None -> () - | Some(e) -> fprintf ff "@[initialize@;%a@]" (inst 0) e - -(** Print a machine *) -let machine f ff { ma_kind = k; ma_params = pat_list; ma_initialize = i_opt; - ma_memories = memories; ma_instances = instances; - ma_methods = m_list } = - fprintf ff - "@[let %s = machine(%s)%a@ \ - {@, %a@,@[memories@ @[%a@]@]@;@[instances@ @[%a@]@]@;@[%a@]@]]}@.@]" - f - (kind k) - pattern_list pat_list - pinitialize i_opt - (print_list_r_empty memory """;""") memories - (print_list_r_empty instance """;""") instances - (print_list_r pmethod """""") m_list - -let implementation ff impl = match impl with - | Oletvalue(n, i) -> - fprintf ff "@[let %a = %a@.@.@]" shortname n (inst 0) i - | Oletfun(n, pat_list, i) -> - fprintf ff "@[let %a %a =@ %a@.@.@]" - shortname n pattern_list pat_list (inst 0) i - | Oletmachine(n, m) -> machine n ff m - | Oopen(s) -> - fprintf ff "@[open %s@.@]" s - | Otypedecl(l) -> - fprintf ff "@[%a@.@]" - (print_list_l - (fun ff (s, s_list, ty_decl) -> - fprintf ff "%a%s =@ %a" - Ptypes.print_type_params s_list - s type_decl ty_decl) - "type ""and """) - l - -let implementation_list ff impl_list = - fprintf ff "@[(* %s *)@.@]" header_in_file; - fprintf ff "@[open Ztypes@.@]"; - List.iter (implementation ff) impl_list diff --git a/compiler/gencode/translate.ml b/compiler/gencode/translate.ml deleted file mode 100644 index de5e1f726..000000000 --- a/compiler/gencode/translate.ml +++ /dev/null @@ -1,730 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* translation from zelus code to obc *) -(* applied to normalized and scheduled code *) -open Zmisc -open Zident -open Global -open Deftypes -open Obc - -(* application *) -let app e_fun e_list = - match e_list with | [] -> e_fun | _ -> Oapp(e_fun, e_list) - -let sequence inst1 inst2 = - match inst1, inst2 with - | (Osequence [], inst) | (inst, Osequence []) -> inst - | Osequence(l1), Osequence(l2) -> Osequence(l1 @ l2) - | _, Osequence(l2) -> Osequence(inst1 :: l2) - | _ -> Osequence [inst1; inst2] - -(** Translation of the kind *) -let kind = function - | Zelus.S | Zelus.A | Zelus.AD | Zelus.AS -> Ofun - | Zelus.C | Zelus.D -> Onode | Zelus.P -> Onode - -(** Translating type expressions. *) -let rec type_expression { Zelus.desc = desc } = - match desc with - | Zelus.Etypevar(s) -> Otypevar(s) - | Zelus.Etypeconstr(ln, ty_list) -> - Otypeconstr(ln, List.map type_expression ty_list) - | Zelus.Etypetuple(ty_list) -> - Otypetuple(List.map type_expression ty_list) - | Zelus.Etypevec(ty, s) -> - Otypevec(type_expression ty, size s) - | Zelus.Etypefun(k, opt_name, ty_arg, ty_res) -> - Otypefun(kind k, opt_name, type_expression ty_arg, type_expression ty_res) - -and type_of_type_decl { Zelus.desc = desc } = - match desc with - | Zelus.Eabstract_type -> Oabstract_type - | Zelus.Eabbrev(ty) -> Oabbrev(type_expression ty) - | Zelus.Evariant_type(constr_decl_list) -> - Ovariant_type(List.map constr_decl constr_decl_list) - | Zelus.Erecord_type(n_ty_list) -> - Orecord_type(List.map (fun (n, ty) -> (n, type_expression ty)) n_ty_list) - -and constr_decl { desc = desc } = - match desc with - | Econstr0decl(n) -> Oconstr0decl(n) - | Econstr1decl(n, ty_list) -> - Oconstr1decl(n, List.map type_expression ty_list) - -and size { Zelus.desc = desc } = - match desc with - | Zelus.Sconst(i) -> Sconst(i) - | Zelus.Sglobal(ln) -> Sglobal(ln) - | Zelus.Sname(n) -> Sname(n) - | Zelus.Sop(op, s1, s2) -> - let operator = function Zelus.Splus -> Splus | Zelus.Sminus -> Sminus in - Sop(operator op, size s1, size s2) - -(* is-it a mutable value? Only vectors are considered at the moment *) -let rec is_mutable { t_desc = desc } = - match desc with - | Tvec _ -> true - | Tlink(link) -> is_mutable link - | _ -> false - -(* translating an internal type into a type expression *) -let type_expression_of_typ ty = - let ty_exp = Interface.type_expression_of_typ ty in - type_expression ty_exp - -(* The translation uses an environment to store information about identifiers *) -type env = entry Env.t (* the symbol table *) - and entry = - { e_typ: Deftypes.typ; - e_sort: sort; - e_size: loop_path; (* [e.(i_1)...(i_n)] *) - } - and sort = - | In of exp - (* the variable [x] is implemented by [e.(i_1)...(i_n)]; e.g., [x in e] *) - | Out of Zident.t * Deftypes.tsort - (* the variable [x] is stored into [y.(i_1)...(i_n); e.g. [x out y]] *) - - and loop_path = Zident.t list - -type code = - { mem: mentry State.t; (* set of state variables *) - init: Obc.inst; (* sequence of initializations for [mem] *) - instances: ientry State.t; (* set of instances *) - reset: Obc.inst; (* sequence of equations for resetting the block *) - step: inst; (* body *) - } - -let fprint ff (env: entry Env.t) = - let fprint_entry ff { e_typ = ty; e_sort = sort; e_size = size } = - Format.fprintf ff "@[{ typ = %a;@,size = %a}@]" - Ptypes.output ty - (Pp_tools.print_list_r Printer.name "[" "," "]") size in - Zident.Env.fprint_t fprint_entry ff env - -let empty_code = { mem = State.empty; init = Osequence []; - instances = State.empty; - reset = Osequence []; step = Osequence [] } - -let seq { mem = m1; init = i1; instances = j1; reset = r1; step = s1 } - { mem = m2; init = i2; instances = j2; reset = r2; step = s2 } = - { mem = State.seq m1 m2; init = sequence i1 i2; instances = State.par j1 j2; - reset = sequence r1 r2; step = sequence s1 s2 } - -let empty_path = [] - -(** Look for an entry in the environment *) -let entry_of n env = - try - Env.find n env - with Not_found -> - Zmisc.internal_error "Unbound variable" Printer.name n - - -(** Translation of immediate values *) -let immediate = function - | Deftypes.Eint(i) -> Oint(i) - | Deftypes.Efloat(f) -> Ofloat(f) - | Deftypes.Ebool(b) -> Obool(b) - | Deftypes.Echar(c) -> Ochar(c) - | Deftypes.Estring(s) -> Ostring(s) - | Deftypes.Evoid -> Ovoid - -let constant = function - | Deftypes.Cimmediate(i) -> Oconst(immediate i) - | Deftypes.Cglobal(ln) -> Oglobal(ln) - -(* read/write of a state variable. *) -let state is_read n k = - match k with - | None -> Oleft_state_name(n) - | Some(k) -> - match k with - | Deftypes.Cont -> - Oleft_state_primitive_access (Oleft_state_name(n), Ocont) - | Deftypes.Zero -> - Oleft_state_primitive_access - (Oleft_state_name(n), if is_read then Ozero_in else Ozero_out) - | Deftypes.Horizon | Deftypes.Period - | Deftypes.Encore | Deftypes.Major -> Oleft_state_name(n) - -(* index in an array *) -let rec index e = - function [] -> e | ei :: ei_list -> Oaccess(index e ei_list, Olocal(ei)) - -let rec left_value_index lv = - function - | [] -> lv - | ei :: ei_list -> Oleft_index(left_value_index lv ei_list, Olocal(ei)) - -let rec left_state_value_index lv = function - | [] -> lv - | ei :: ei_list -> - Oleft_state_index(left_state_value_index lv ei_list, Olocal(ei)) - -(* read of a variable *) -let var { e_sort = sort; e_typ = ty; e_size = ei_list } = - match sort with - | In(e) -> index e ei_list - | Out(n, sort) -> - match sort with - | Sstatic | Sval -> index (Olocal(n)) ei_list - | Svar _ -> - index (Ovar(is_mutable ty, n)) ei_list - | Smem { m_kind = k } -> - Ostate(left_state_value_index (state true n k) ei_list) - -(** Make an assignment according to the sort of a variable [n] *) -let assign { e_sort = sort; e_size = ei_list } e = - match sort with - | In _ -> assert false - | Out(n, sort) -> - match sort with - | Sstatic | Sval -> assert false - | Svar _ -> Oassign(left_value_index (Oleft_name n) ei_list, e) - | Smem { m_kind = k } -> - Oassign_state(left_state_value_index (state false n k) ei_list, e) - -(** Generate the code for a definition *) -let def { e_typ = ty; e_sort = sort; e_size = ei_list } e - ({ step = s } as code) = - match sort with - | In _ -> assert false - | Out(n, sort) -> - match sort with - | Sstatic | Sval -> - { code with step = - Olet(Ovarpat(n, type_expression_of_typ ty), e, s) } - | Svar _ -> - { code with step = - sequence - (Oassign(left_value_index (Oleft_name n) ei_list, e)) - s } - | Smem { m_kind = k } -> - { code with step = sequence - (Oassign_state(left_state_value_index - (state false n k) ei_list, e)) s } - -(** Generate the code for [der x = e] *) -let der { e_sort = sort; e_size = ei_list } e ({ step = s } as code) = - match sort with - | In _ -> assert false - | Out(n, sort) -> - { code with step = - sequence - (Oassign_state(left_state_value_index - (Oleft_state_primitive_access - (Oleft_state_name(n), Oder)) ei_list, - e)) - s } - -(** Generate an if/then *) -let ifthen r_e i_code s = sequence (Oif(r_e, i_code, None)) s - -(** Generate a for loop *) -let for_loop direction ix e1 e2 i_body = - match i_body with - | Osequence [] -> Osequence [] - | _ -> Ofor(direction, ix, e1, e2, i_body) - -(** Generate the code for the definition of a value *) -let letpat p e ({ step = s } as code) = - { code with step = Olet(p, e, s) } - -(** Generate the code for initializing shared variables *) -let rec letvar l s = - match l with - | [] -> s - | (n, is_mutable, ty, v_opt) :: l -> - Oletvar(n, is_mutable, ty, v_opt, letvar l s) - -(** Compile an equation [n += e] *) -let pluseq ({ e_sort = sort; e_size = ei_list } as entry) - e ({ step = s } as code) = - let ln = - match sort with - | In _ -> assert false - | Out(n, sort) -> - match sort with - | Svar { v_combine = Some(ln) } | Smem { m_combine = Some(ln) } -> ln - | _ -> Zmisc.internal_error "Unbound variable" Printer.name n in - { code with step = - sequence (assign entry - (Oapp(Oglobal(ln), [var entry; e]))) s } - -let out_of n env = - let { e_typ = ty; e_sort = sort; e_size = ix_list } = entry_of n env in - match sort with - | In _ -> assert false - | Out(x, sort) -> x, ty, sort, ix_list - -(** Translate size expressions *) -let rec size_of_type = function - | Tconst(i) -> Sconst(i) - | Tglobal(q) -> Sglobal(Lident.Modname(q)) - | Tname(n) -> Sname(n) - | Top(op, s1, s2) -> - let e1 = size_of_type s1 in - let e2 = size_of_type s2 in - match op with - | Tplus -> Sop(Splus, e1, e2) - | Tminus -> Sop(Sminus, e1, e2) - -(** Translate size expressions *) -let rec size { Zelus.desc = desc } = - match desc with - | Zelus.Sconst(i) -> Sconst(i) - | Zelus.Sglobal(ln) -> Sglobal(ln) - | Zelus.Sname n -> Sname(n) - | Zelus.Sop(op, s1, s2) -> - let s1 = size s1 in - let s2 = size s2 in - match op with - | Zelus.Splus -> Sop(Splus, s1, s2) - | Zelus.Sminus -> Sop(Sminus, s1, s2) - -(* makes an initial value from a type. returns None when it fails *) -let choose env ty = - let tuple l = Otuple(l) in - let efalse = Oconst(Obool(false)) in - let echar0 = Oconst(Ochar('a')) in - (* on purpose, take an initial value different from zero *) - let ezero = Oconst(Oint(42)) in - let efzero = Oconst(Ofloat(42.0)) in - let estring0 = Oconst(Ostring("aaaaaaa")) in - let evoid = Oconst(Ovoid) in - let eany = Oconst(Oany) in - let vec e s = Ovec(e, s) in - let rec value_from_deftype id = - try - let { info = { type_desc = ty_c } } = - Modules.find_type (Lident.Modname(id)) in - match ty_c with - | Variant_type(g_list) -> value_from_variant_list g_list - | Abstract_type -> eany - | Record_type(l_list) -> - Orecord( - List.map - (fun { qualid = qualid; info = { label_res = ty } } -> - (Lident.Modname(qualid), value ty)) l_list) - | Abbrev(_, ty) -> value ty - with - | Not_found -> eany - and value ty = - match ty.t_desc with - | Tvar -> eany - | Tproduct(ty_l) -> tuple (List.map value ty_l) - | Tfun _ -> eany - | Tvec(ty, s) -> vec (value ty) (size_of_type s) - | Tconstr(id, _, _) -> - if id = Initial.int_ident then ezero - else if id = Initial.bool_ident then efalse - else if id = Initial.char_ident then echar0 - else if id = Initial.float_ident then efzero - else if id = Initial.string_ident then estring0 - else if id = Initial.unit_ident then evoid - else if id = Initial.zero_ident then efalse - else - (* try to find a value from its type definition *) - (* we do not consider type instantiation here *) - value_from_deftype id - | Tlink(link) -> value link - and value_from_variant_list g_list = - let rec findrec g_list = - match g_list with - | [] -> raise Not_found - | { qualid = qualid; info = { constr_arity = arity } } :: g_list -> - if arity = 0 then Oconstr0(Lident.Modname(qualid)) - else findrec g_list in - try - (* look for a constructor with arity 0 *) - findrec g_list - with - | Not_found -> - (* otherwise, pick one *) - let { qualid = qualid; info = { constr_arg = ty_list } } = - List.hd g_list in - Oconstr1(Lident.Modname(qualid), List.map value ty_list) in - Some(value ty) - -(** Computes a default value *) -let default env ty v_opt = - match v_opt with - | None -> choose env ty - | Some(v) -> Some(constant v) - -(** Extension of an environment *) -(* The access to a state variable [x] is turned into the access on an *) -(* array access x.(i1)...(in) if loop_path = [i1;...;in] *) -let append loop_path l_env env = - (* add a memory variable for every state variable in [l_env] *) - (* and a [letvar] declaration for every shared variable *) - let addrec n { t_sort = k; t_typ = ty } (env_acc, mem_acc, var_acc) = - match k with - | Sstatic - | Sval -> - Env.add n { e_typ = ty; e_sort = Out(n, k); e_size = [] } env_acc, - mem_acc, var_acc - | Svar { v_default = v_opt } -> - Env.add n { e_typ = ty; e_sort = Out(n, k); e_size = [] } env_acc, - mem_acc, (n, is_mutable ty, ty, default env ty v_opt) :: var_acc - | Smem { m_kind = k_opt } -> - Env.add n - { e_typ = ty; e_sort = Out(n, k); e_size = loop_path } env_acc, - State.cons { m_name = n; m_value = choose env ty; m_typ = ty; - m_kind = k_opt; m_size = [] } mem_acc, - var_acc in - Env.fold addrec l_env (env, State.empty, []) - - -(** Translation of a stateful function application [f se1 ... sen e] *) -(* if [loop_path = [i1;...;ik] - * instance o = f se1 ... sen - * call o.(i1)...(ik).step(e) - * reset with o.(i1)...(ik).reset *) -let apply k env loop_path e e_list - ({ mem = m; init = i; instances = j; reset = r; step = s } as code) = - match k with - | Deftypes.Tstatic _ - | Deftypes.Tany | Deftypes.Tdiscrete(false) -> Oapp(e, e_list), code - | Deftypes.Tdiscrete(true) - | Deftypes.Tcont - | Deftypes.Tproba -> - (* the first [n-1] arguments are static *) - let se_list, arg = Zmisc.firsts e_list in - let f_opt = match e with | Oglobal(g) -> Some(g) | _ -> None in - let loop_path = List.map (fun ix -> Olocal(ix)) loop_path in - (* create an instance *) - let o = Zident.fresh "i" in - let j_code = { i_name = o; i_machine = e; i_kind = k; - i_params = se_list; i_size = [] } in - let reset_code = - Omethodcall({ met_machine = f_opt; met_name = Oaux.reset; - met_instance = Some(o, loop_path); met_args = [] }) in - let step_code = - Omethodcall({ met_machine = f_opt; met_name = Oaux.step; - met_instance = Some(o, loop_path); met_args = [arg] }) in - step_code, - { code with instances = State.cons j_code j; - init = sequence (Oexp(reset_code)) i; - reset = sequence (Oexp(reset_code)) r } - -(** Translation of expressions under an environment [env] *) -(* [code] is the code already generated in the context. *) -(* [exp env e code = e', code'] where [code'] extends [code] with new *) -(* memory, instantiation and reset. The step field is untouched *) -(* [loop_path = [i1;...;in]] is the loop path if [e] appears in *) -(* a nested loop forall in ... forall i1 do ... e ... *) -let rec exp env loop_path code { Zelus.e_desc = desc } = - match desc with - | Zelus.Econst(i) -> Oconst(immediate i), code - | Zelus.Elocal(n) - | Zelus.Elast(n) -> var (entry_of n env), code - | Zelus.Eglobal { lname = ln } -> Oglobal(ln), code - | Zelus.Econstr0(ln) -> Oconstr0(ln), code - | Zelus.Econstr1(ln, e_list) -> - let e_list, code = Zmisc.map_fold (exp env loop_path) code e_list in - Oconstr1(ln, e_list), code - | Zelus.Etuple(e_list) -> - let e_list, code = Zmisc.map_fold (exp env loop_path) code e_list in - Otuple(e_list), code - | Zelus.Erecord(label_e_list) -> - let label_e_list, code = - Zmisc.map_fold - (fun code (l, e) -> let e, code = exp env loop_path code e in - (l, e), code) code label_e_list in - Orecord(label_e_list), code - | Zelus.Erecord_access(e_record, longname) -> - let e_record, code = - exp env loop_path code e_record in - Orecord_access(e_record, longname), code - | Zelus.Erecord_with(e_record, label_e_list) -> - let e_record, code = - exp env loop_path code e_record in - let label_e_list, code = - Zmisc.map_fold - (fun code (l, e) -> let e, code = exp env loop_path code e in - (l, e), code) code label_e_list in - Orecord_with(e_record, label_e_list), code - | Zelus.Etypeconstraint(e, ty_exp) -> - let e, code = exp env loop_path code e in - let ty_exp = type_expression ty_exp in - Otypeconstraint(e, ty_exp), code - | Zelus.Eop(Zelus.Eup, [e]) -> - (* implement the zero-crossing up(x) by up(if x >=0 then 1 else -1) *) - let e = if !Zmisc.zsign then Zaux.sgn e else e in - exp env loop_path code e - | Zelus.Eop(Zelus.Ehorizon, [e]) -> - exp env loop_path code e - | Zelus.Eop(Zelus.Eifthenelse, [e1; e2; e3]) -> - let e1, code = exp env loop_path code e1 in - let e2, code = exp env loop_path code e2 in - let e3, code = exp env loop_path code e3 in - Oifthenelse(e1, e2, e3), code - | Zelus.Eop(Zelus.Eaccess, [e1; e2]) -> - let e1, code = exp env loop_path code e1 in - let e2, code = exp env loop_path code e2 in - Oaccess(e1, e2), code - | Zelus.Eop(Zelus.Eupdate, [e1; i; e2]) -> - let _, se = Ztypes.filter_vec e1.Zelus.e_typ in - let se = size_of_type se in - let e1, code = exp env loop_path code e1 in - let i, code = exp env loop_path code i in - let e2, code = exp env loop_path code e2 in - Oupdate(se, e1, i, e2), code - | Zelus.Eop(Zelus.Eslice(s1, s2), [e]) -> - let s1 = size s1 in - let s2 = size s2 in - let e, code = exp env loop_path code e in - Oslice(e, s1, s2), code - | Zelus.Eop(Zelus.Econcat, [e1; e2]) -> - let _, s1 = Ztypes.filter_vec e1.Zelus.e_typ in - let _, s2 = Ztypes.filter_vec e2.Zelus.e_typ in - let s1 = size_of_type s1 in - let s2 = size_of_type s2 in - let e1, code = exp env loop_path code e1 in - let e2, code = exp env loop_path code e2 in - Oconcat(e1, s1, e2, s2), code - | Zelus.Eop(Zelus.Eatomic, [e]) -> - exp env loop_path code e - | Zelus.Elet _ | Zelus.Eseq _ | Zelus.Eperiod _ - | Zelus.Eop _ | Zelus.Epresent _ - | Zelus.Ematch _ | Zelus.Eblock _ -> assert false - | Zelus.Eapp(_, e_fun, e_list) -> - (* compute the sequence of static arguments and non static ones *) - let se_list, ne_list, ty_res = - Ztypes.split_arguments e_fun.Zelus.e_typ e_list in - let e_fun, code = exp env loop_path code e_fun in - let se_list, code = Zmisc.map_fold (exp env loop_path) code se_list in - let ne_list, code = Zmisc.map_fold (exp env loop_path) code ne_list in - let e_fun = app e_fun se_list in - match ne_list with - | [] -> e_fun, code - | _ -> let k = Ztypes.kind_of_funtype ty_res in - apply k env loop_path e_fun ne_list code - -(** Patterns *) -and pattern { Zelus.p_desc = desc; Zelus.p_typ = ty } = - match desc with - | Zelus.Ewildpat -> Owildpat - | Zelus.Econstpat(im) -> Oconstpat(immediate im) - | Zelus.Econstr0pat(c0) -> Oconstr0pat(c0) - | Zelus.Econstr1pat(c1, p_list) -> - Oconstr1pat(c1, List.map pattern p_list) - | Zelus.Etuplepat(p_list) -> Otuplepat(List.map pattern p_list) - | Zelus.Evarpat(n) -> Ovarpat(n, type_expression_of_typ ty) - | Zelus.Erecordpat(label_pat_list) -> - Orecordpat(List.map (fun (label, pat) -> (label, pattern pat)) - label_pat_list) - | Zelus.Etypeconstraintpat(p, ty) -> - Otypeconstraintpat(pattern p, type_expression ty) - | Zelus.Ealiaspat(p, n) -> Oaliaspat(pattern p, n) - | Zelus.Eorpat(p1, p2) -> Oorpat(pattern p1, pattern p2) - -(** Equations *) -let rec equation env loop_path { Zelus.eq_desc = desc } code = - match desc with - | Zelus.EQeq({ Zelus.p_desc = Zelus.Evarpat(n) }, e) -> - let e, code = exp env loop_path code e in - def (entry_of n env) e code - | Zelus.EQeq(p, e) -> - let e, code = exp env loop_path code e in - letpat (pattern p) e code - | Zelus.EQpluseq(n, e) -> - let e, code = exp env loop_path code e in - pluseq (entry_of n env) e code - | Zelus.EQder(n, e, None, []) -> - let e, code = exp env loop_path code e in - der (entry_of n env) e code - | Zelus.EQmatch(_, e, p_h_list) -> - let e, code = exp env loop_path code e in - let p_step_h_list, p_h_code = match_handlers env loop_path p_h_list in - seq { p_h_code with step = Omatch(e, p_step_h_list) } code - | Zelus.EQreset([{ Zelus.eq_desc = Zelus.EQinit(x, e) }], r_e) - when not (Reset.static e) -> - let r_e, code = exp env loop_path code r_e in - let e, ({ init = i_code } as e_code) = exp env loop_path empty_code e in - let { step = s } as code = seq e_code code in - { code with step = - ifthen r_e (sequence (assign (entry_of x env) e) i_code) s } - | Zelus.EQreset(eq_list, r_e) -> - let { init = i_code } = code in - let { init = ri_code } as r_code = - equation_list env loop_path eq_list { code with init = Osequence [] } in - let r_e, r_code = exp env loop_path r_code r_e in - (* execute the initialization code when [e] is true *) - let { step = s } as code = seq r_code { empty_code with init = i_code } in - { code with step = ifthen r_e ri_code s } - | Zelus.EQinit(x, e) -> - let e_c, code = exp env loop_path code e in - let x_e = assign (entry_of x env) e_c in - (* initialization of a state variable with a static value *) - if Reset.static e - then seq { empty_code with init = x_e; reset = x_e } code - else seq { empty_code with step = x_e } code - | Zelus.EQforall { Zelus.for_index = i_list; Zelus.for_init = init_list; - Zelus.for_body = b_eq_list } -> - (* [forall i in e1..e2, xi in ei,..., oi in o,... do body done] - * is translated into: - * for i = e1 to e2 do - ... - * with xi into ei.(i), oi into o.(i) - * - every instance o from the body must be an array - * - every state variable m from the body must be an array *) - (* look for the index [i in e1..e2] *) - let rec index code = function - | [] -> let id = Zident.fresh "i" in - (id, Oconst(Oint(0)), Oconst(Oint(0))), code - | { Zelus.desc = desc } :: i_list -> - match desc with - | Zelus.Eindex(x, e1, e2) -> - let e1, code = exp env loop_path code e1 in - let e2, code = exp env loop_path code e2 in - (x, e1, e2), code - | Zelus.Einput _ | Zelus.Eoutput _ -> index code i_list in - (* extend the environment for in/out variables *) - (* [ix] is the index of the loop *) - let in_out ix (env_acc, code) { Zelus.desc = desc } = - match desc with - | Zelus.Einput(x, ({ Zelus.e_typ = ty } as e)) -> - let e, code = exp env loop_path code e in - Env.add x { e_typ = ty; e_sort = In(e); e_size = [ix] } env_acc, code - | Zelus.Eoutput(x, y) -> - let y, ty, sort, ix_list = out_of y env in - Env.add x { e_typ = ty; e_sort = Out(y, sort); - e_size = ix :: ix_list } env_acc, code - | Zelus.Eindex(i, { Zelus.e_typ = ty }, _) -> - Env.add i { e_typ = ty; e_sort = Out(i, Deftypes.Sval); - e_size = [] } env_acc, code in - (* transforms an instance into an array of instances *) - let array_of_instance size ({ i_size } as ientry) = - { ientry with i_size = size :: i_size } in - let array_of_memory size ({ m_size } as mentry) = - { mentry with m_size = size :: m_size } in - (* generate the code for the initialization part of the for loop *) - let init code { Zelus.desc = desc } = - match desc with - | Zelus.Einit_last(x, e) -> - let e, code = exp env loop_path code e in - assign (entry_of x env) e, code in - (* first compute the index [i in e1 .. e2] *) - let (ix, e1, e2), code = index code i_list in - (* extend the environment [env] with input and output variables *) - let env, code = List.fold_left (in_out ix) (env, code) i_list in - let { mem = m_code; init = i_code; instances = j_code; - reset = r_code; step = s_code } = - block env (ix :: loop_path) b_eq_list in - (* transforms instances into arrays *) - let j_code = - State.map - (array_of_instance (Oaux.plus (Oaux.minus e2 e1) Oaux.one)) j_code in - let m_code = - State.map - (array_of_memory (Oaux.plus (Oaux.minus e2 e1) Oaux.one)) m_code in - (* generate the initialization code *) - let initialization_list, - { mem = m; instances = j; init = i; reset = r; step = s } = - Zmisc.map_fold init code init_list in - { mem = State.seq m_code m; instances = State.seq j_code j; - init = sequence (for_loop true ix e1 e2 i_code) i; - reset = sequence (for_loop true ix e1 e2 r_code) r; - step = sequence (Osequence initialization_list) - (sequence (for_loop true ix e1 e2 s_code) s) } - | Zelus.EQbefore(before_eq_list) -> - equation_list env loop_path before_eq_list code - | Zelus.EQand _ | Zelus.EQblock _ | Zelus.EQnext _ - | Zelus.EQder _ | Zelus.EQemit _ | Zelus.EQautomaton _ - | Zelus.EQpresent _ -> assert false - -and equation_list env loop_path eq_list code = - List.fold_right (fun eq code -> equation env loop_path eq code) eq_list code - -(* Translation of a math/with handler. *) -and match_handlers env loop_path p_h_list = - let body code { Zelus.m_pat = p; Zelus.m_body = b; Zelus.m_env = m_env } = - let env, mem_acc, var_acc = append loop_path m_env env in - let { mem = m_code; step = s_code } as b_code = block env loop_path b in - { w_pat = pattern p; w_body = letvar var_acc s_code }, - seq code - { b_code with step = Osequence []; mem = State.seq mem_acc m_code } in - Zmisc.map_fold body empty_code p_h_list - -and local env loop_path { Zelus.l_eq = eq_list; Zelus.l_env = l_env } e = - let env, mem_acc, var_acc = append loop_path l_env env in - let e, code = exp env loop_path empty_code e in - let eq_code = - equation_list env loop_path eq_list { code with step = Oexp(e) } in - add_mem_vars_to_code eq_code mem_acc var_acc - -and block env loop_path { Zelus.b_body = eq_list; Zelus.b_env = n_env } = - let env, mem_acc, var_acc = append loop_path n_env env in - let eq_code = equation_list env loop_path eq_list empty_code in - add_mem_vars_to_code eq_code mem_acc var_acc - -and add_mem_vars_to_code ({ mem; step } as code) mem_acc var_acc = - { code with mem = State.seq mem_acc mem; step = letvar var_acc step } - -(* Define a function or a machine according to a kind [k] *) -let machine n k pat_list { mem = m; instances = j; reset = r; step = s } - ty_res = - let k = Interface.kindtype k in - match k with - | Deftypes.Tstatic _ | Deftypes.Tany - | Deftypes.Tdiscrete(false) -> Oletfun(n, pat_list, s) - | Deftypes.Tdiscrete(true) | Deftypes.Tcont | Deftypes.Tproba -> - (* the [n-1] parameters are static *) - let pat_list, p = Zmisc.firsts pat_list in - let body = - { ma_kind = k; - ma_params = pat_list; - ma_initialize = None; - ma_memories = State.list [] m; - ma_instances = State.list [] j; - ma_methods = - [ { me_name = Oaux.reset; me_params = []; me_body = r; - me_typ = Initial.typ_unit }; - { me_name = Oaux.step; me_params = [p]; me_body = s; - me_typ = ty_res } ] } in - Oletmachine(n, body) - -(* Translation of an expression. After normalisation *) -(* the body of a function is either of the form [e] with [e] stateless *) -(* or [let Eq in e] with [e] stateless *) -let expression env ({ Zelus.e_desc = desc } as e) = - match desc with - | Zelus.Elet(l, e_let) -> local env empty_path l e_let - | _ -> let e, code = exp env empty_path empty_code e in - { code with step = Oexp(e) } - -(** Translation of a declaration *) -let implementation { Zelus.desc = desc } = - match desc with - | Zelus.Eopen(n) -> Oopen(n) - | Zelus.Etypedecl(n, params, ty_decl) -> - Otypedecl([n, params, type_of_type_decl ty_decl]) - | Zelus.Econstdecl(n, _, e) -> - (* There should be no memory allocated by [e] *) - let { step = s } = expression Env.empty e in - Oletvalue(n, s) - | Zelus.Efundecl(n, { Zelus.f_kind = k; Zelus.f_args = pat_list; - Zelus.f_body = e; Zelus.f_env = f_env }) -> - let pat_list = List.map pattern pat_list in - let env, mem_acc, var_acc = append empty_path f_env Env.empty in - let code = expression env e in - let code = add_mem_vars_to_code code mem_acc var_acc in - machine n k pat_list code e.Zelus.e_typ - -let implementation_list impl_list = Zmisc.iter implementation impl_list diff --git a/compiler/global/defcaus.ml b/compiler/global/defcaus.ml deleted file mode 100644 index 7d9554898..000000000 --- a/compiler/global/defcaus.ml +++ /dev/null @@ -1,57 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* causality types *) - -(** Type definitions. *) - -(* type scheme *) -type tc_scheme = - { typ_vars: t list; (* list of type variables *) - typ_rel: (t * t list) list; (* the relation between variables *) - typ: tc; (* type *) - } - -and tc = - | Cfun of tc * tc - | Cproduct of tc list (* products *) - | Catom of t (* dependences *) - -(* a causality variable points to its predecessors and successors *) -and t = - { mutable c_desc: desc; (* its descriptor *) - mutable c_level: int; (* its level *) - mutable c_index: int; (* a unique ident associated to the variable *) - mutable c_inf: t list; (* infimum *) - mutable c_sup: t list; (* supremum *) - mutable c_useful: bool; (* is-it an intermediate variable ? *) - mutable c_polarity: polarity; (* its polarity *) - mutable c_info: info option; (* a possible concrete name *) - mutable c_visited: int; (* is-it visited already ? *) - } - -and desc = - | Cvar - | Clink of t - -and info = - | Cname of Zident.t - | Clast of Zident.t - -and polarity = Punknown | Pplus | Pminus | Pplusminus - -(* only compare indexes. *) -let rec compare c1 c2 = Stdlib.compare c1.c_index c2.c_index - -let no_typ = Cproduct [] diff --git a/compiler/global/definit.ml b/compiler/global/definit.ml deleted file mode 100644 index 013630755..000000000 --- a/compiler/global/definit.ml +++ /dev/null @@ -1,65 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* initialization types *) -(* based on Colaco and Pouzet (STTT'04) *) -(* base types 0 and 1 are extended with 1/2, with (non-strict) *) -(* order 0 < 1/2 < 1 *) -(* 0 means non nil at any instant >= 0 *) -(* 1 means non nil at any instant >= 1 *) -(* 1/2 means non nil at any instant >= 1/2; denotes a major step instant *) - -(** Type definitions. *) - -(* type scheme *) -type ti_scheme = - { typ_vars: t list; (* list of type variables *) - typ_rel: (t * t list) list; (* the relation between variables *) - typ: ti; (* type of the result *) - } - - and ti = - | Ifun of ti * ti - | Iproduct of ti list - | Iatom of t - -(* an initialization type t is associated to its left types t_infs *) -(* and right types t_sups such that t_infs < t < t_sups *) -(* when t is minimal, alls its infimum can be replaced by itself *) -(* when t is maximal, all its supremum can be replaced by itself *) - -and t = - { mutable i_desc: desc; (* its descriptor *) - mutable i_level: int; (* its level *) - mutable i_index: int; (* a unique ident associated to the variable *) - mutable i_inf: t list; (* infimun *) - mutable i_sup: t list; (* supremum *) - mutable i_min: value; (* the minimum value *) - mutable i_useful: bool; (* is-it an intermediate variable ? *) - mutable i_polarity: polarity; (* its polarity *) - mutable i_visited: int; (* is-it visited already ? *) - } - -and desc = - | Ivalue of value - | Ivar - | Ilink of t - -and value = | Izero | Ione | Ihalf - -and polarity = Punknown | Pplus | Pminus | Pplusminus - -let compare i1 i2 = Stdlib.compare i1.i_index i2.i_index - -let no_typ = Iproduct [] diff --git a/compiler/global/deftypes.ml b/compiler/global/deftypes.ml deleted file mode 100644 index 60a6e8693..000000000 --- a/compiler/global/deftypes.ml +++ /dev/null @@ -1,181 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* type definition *) - -open Zmisc -open Lident - -type immediate = - | Eint of int - | Efloat of float - | Ebool of bool - | Echar of char - | Estring of string - | Evoid - -type name = string - -(* types *) -type 'a loc = - { mutable t_desc: 'a; (* descriptor *) - mutable t_index: int; (* a number for debugging purpose *) - mutable t_level: int; (* level for generalisation *) - } - -type typ = typ_desc loc - - and typ_desc = - | Tvar - | Tproduct of typ list - | Tconstr of Lident.qualident * typ list * abbrev ref - | Tvec of typ * size - | Tfun of kind * Zident.t option * typ * typ - | Tlink of typ - -and size = - | Tconst of int - | Tglobal of Lident.qualident - | Tname of Zident.t - | Top of op * size * size - -and op = Tplus | Tminus - -and abbrev = - | Tnil - | Tcons of typ list * typ - -(* type scheme *) -and typ_scheme = - { typ_vars: typ list; - mutable typ_body: typ } - -and typ_instance = { typ_instance : typ list } - -and kind = - | Tstatic of bool (* the argument can be static or not *) - | Tany | Tcont | Tdiscrete of bool (* statefull or stateless *) - | Tproba - -(* entry in the typing environment *) -type tentry = - { mutable t_sort: tsort; (* its sort *) - mutable t_typ: typ (* its type *) - } - -(* variables are defined by local x [[default e | init e ] with op] in ... *) -and tsort = - | Sstatic (* a static value *) - | Sval (* a let value *) - | Svar of var (* a shared variable *) - | Smem of mem (* a state variable *) - -and var = - { v_combine: Lident.t option; (* combination function *) - v_default: constant option; (* default value *) - } - -and mem = - { m_kind: mkind option; - m_next: bool option; (* None when not set *) - (* Some(false) when [... x... = ...] *) - (* Some(true) when [next x = ...] *) - m_previous: bool; (* [last x] or [x] is used *) - m_init: minit; (* is-it initialized? *) - m_combine: Lident.t option; (* combination function *) - } - -(* the different kinds of internal state variables *) -and mkind = - | Cont (* continous state variable; position + derivative *) - | Zero (* zero-crossing *) - | Horizon (* an event defined as an horizon *) - | Period (* an event defined as a period *) - | Encore (* a cascade event *) - | Major (* true in discrete mode; could we use Encore instead? *) - -and minit = - | Noinit (* no initialisation given *) - | InitEq (* the initial value is given in the body of equations *) - | InitDecl of constant (* it is given at the declaration point *) - -and constant = - | Cimmediate of immediate - | Cglobal of Lident.t - -(** Names written in a block *) -type defnames = - { dv: Zident.S.t; (* [x = ...] *) - nv: Zident.S.t; (* [next x = ...] *) - mv: Zident.S.t; (* [ x += ...] *) - di: Zident.S.t; (* [init x = ...],[x = ... init ...], *) - (* [x = present ... init ...]*) - der: Zident.S.t; (* [der x = ...] *) - } - -(* set of names. *) -let names acc { dv = dv; di = di; der = der; nv = nv; mv = mv } = - let acc = Zident.S.union dv acc in - let acc = Zident.S.union di acc in - let acc = Zident.S.union der acc in - let acc = Zident.S.union nv acc in - Zident.S.union mv acc - -let cur_names acc { dv = dv; di = di } = - Zident.S.union (Zident.S.union acc di) dv - - -(* empty set of defined names *) -(** Making values *) -let empty = - { dv = Zident.S.empty; di = Zident.S.empty; der = Zident.S.empty; - nv = Zident.S.empty; mv = Zident.S.empty } - -(* introduced names in the [initialization] phase are fully generalized *) -let make desc = - { t_desc = desc; t_index = - 1; t_level = generic } -let make_realtime desc = - { t_desc = desc; t_index = - 1; t_level = generic } -let no_typ = make (Tproduct []) -let rec is_no_typ { t_desc = desc } = - match desc with - | Tproduct [] -> true | Tlink(link) -> is_no_typ link | _ -> false -let no_typ_scheme = { typ_vars = []; typ_body = no_typ } -let no_typ_instance = { typ_instance = [] } -let no_abbrev () = ref Tnil - -(* basic entries for variables *) -let static = Sstatic -let value = Sval -let variable = Svar { v_combine = None; v_default = None } -let empty_mem = { m_kind = None; m_next = None; m_previous = false; - m_init = Noinit; m_combine = None } -let initialized mem = { mem with m_init = InitEq } -let previous mem = { mem with m_next = Some(false); m_previous = true } -let next mem = { mem with m_next = Some(true); m_previous = false } -let zero mem = Smem { mem with m_kind = Some Zero } -let horizon mem = Smem (previous { mem with m_kind = Some Horizon }) -let major () = Smem { empty_mem with m_kind = Some Major } -let default v_opt c_opt = Svar { v_combine = c_opt; v_default = v_opt } -let imem = initialized empty_mem -let cmem c_opt mem = { mem with m_combine = c_opt } -let mem = previous imem -let memory = Smem mem -let imemory = Smem imem - -let entry sort ty = { t_sort = sort; t_typ = ty } - -let desc ty = ty.t_desc -let index ty = ty.t_index - diff --git a/compiler/global/deps_tools.ml b/compiler/global/deps_tools.ml deleted file mode 100644 index f21775bb6..000000000 --- a/compiler/global/deps_tools.ml +++ /dev/null @@ -1,210 +0,0 @@ -(* Warning: *) -(* This file is based on the original version of ocamldep.ml *) -(* from the Objective Caml 3.12 distribution, INRIA *) - -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Format -open Zlocation -open Zparsetree -open Zmisc -open Compiler - -(* Print the dependencies *) - -let load_path = ref ([] : (string * string array) list) -let force_slash = ref false -let error_occurred = ref false - -(* Fix path to use '/' as directory separator instead of '\'. - Only under Windows. *) - -let fix_slash s = - if Sys.os_type = "Unix" then s else begin - let r = Bytes.of_string s in - for i = 0 to Bytes.length r - 1 do - if Bytes.get r i = '\\' then Bytes.set r i '/' - done; - Bytes.to_string r - end - -let expand_directory alt s = - if String.length s > 0 && s.[0] = '+' - then Filename.concat alt - (String.sub s 1 (String.length s - 1)) - else s - -let remove_file filename = - try - Sys.remove filename - with Sys_error msg -> - () - -let add_to_load_path dir = - try - let contents = Sys.readdir dir in - load_path := !load_path @ [dir, contents] - with Sys_error msg -> - fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg; - error_occurred := true - -let add_to_synonym_list synonyms suffix = - if (String.length suffix) > 1 && suffix.[0] = '.' then - synonyms := suffix :: !synonyms - else begin - fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix; - error_occurred := true - end - -let find_file name = - let uname = String.uncapitalize_ascii name in - let rec find_in_array a pos = - if pos >= Array.length a then None else begin - let s = a.(pos) in - if s = name || s = uname then Some s else find_in_array a (pos + 1) - end in - let rec find_in_path = function - [] -> raise Not_found - | (dir, contents) :: rem -> - match find_in_array contents 0 with - Some truename -> - if dir = "." then truename else Filename.concat dir truename - | None -> find_in_path rem in - find_in_path !load_path - - -let find_dependency modname acc = - try - let candidate = modname ^ ".zli" in - let filename = find_file candidate in - let basename = Filename.chop_extension filename in - if Sys.file_exists (basename ^ ".zls") - then (basename ^ ".zls") :: acc else (basename ^ ".zli") :: acc - with Not_found -> - try - let candidate = modname ^ ".zls" in - let filename = find_file candidate in - let basename = Filename.chop_extension filename in - (basename ^ ".zls") :: acc - with Not_found -> - acc - -let (depends_on, escaped_eol) = (":", " \\\n ") - -let print_filename s = - let s = if !force_slash then fix_slash s else s in - if not (String.contains s ' ') then begin - print_string s; - end else begin - let rec count n i = - if i >= String.length s then n - else if s.[i] = ' ' then count (n+1) (i+1) - else count n (i+1) - in - let spaces = count 0 0 in - let result = Bytes.create (String.length s + spaces) in - let rec loop i j = - if i >= String.length s then () - else if s.[i] = ' ' then begin - Bytes.set result j '\\'; - Bytes.set result (j+1) ' '; - loop (i+1) (j+2); - end else begin - Bytes.set result j (s.[i]); - loop (i+1) (j+1); - end - in - let result = Bytes.to_string result in - loop 0 0; - print_string result; - end -;; - -let print_dependencies target_file deps = - print_filename target_file; print_string depends_on; - let deps = List.map (fun x -> (Filename.chop_extension x)^".zci") deps in - let rec print_items pos = function - [] -> print_string "\n" - | dep :: rem -> - if pos + 1 + String.length dep <= 77 then begin - print_string " "; print_filename dep; - print_items (pos + String.length dep + 1) rem - end else begin - print_string escaped_eol; print_filename dep; - print_items (String.length dep + 4) rem - end in - print_items (String.length target_file + 1) deps - - -(* Optionally preprocess a source file *) - -let preprocessor = ref None - -exception Preprocessing_error - -let preprocess sourcefile = - match !preprocessor with - None -> sourcefile - | Some pp -> - flush Stdlib.stdout; - let tmpfile = Filename.temp_file "camlpp" "" in - let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in - if Sys.command comm <> 0 then begin - remove_file tmpfile; - raise Preprocessing_error - end; - tmpfile - -let remove_preprocessed inputfile = - match !preprocessor with - None -> () - | Some _ -> remove_file inputfile - - -(* Process one file *) - -let zls_dependencies source_file = - Zlocation.initialize source_file; - let input_file = preprocess source_file in - try - let ast = Compiler.parse_implementation_file input_file in - let free_structure_names = Zdepend.source_file ast in - remove_preprocessed input_file; - Zdepend.StringSet.fold find_dependency free_structure_names [] - with x -> - remove_preprocessed input_file; - raise x - -let zli_dependencies source_file = - Zlocation.initialize source_file; - let input_file = preprocess source_file in - try - let ast = Compiler.parse_interface_file input_file in - let free_structure_names = Zdepend.interface_file ast in - remove_preprocessed input_file; - Zdepend.StringSet.fold find_dependency free_structure_names [] - with x -> - remove_preprocessed input_file; - raise x - -let zls_file_dependencies source_file = - let target = (Filename.chop_extension source_file) ^ ".zci" in - let deps = zls_dependencies source_file in - print_dependencies target deps - -let zli_file_dependencies source_file = - let target = (Filename.chop_extension source_file) ^ ".zci" in - let deps = zli_dependencies source_file in - print_dependencies target deps diff --git a/compiler/global/global.ml b/compiler/global/global.ml deleted file mode 100644 index 935f29cdd..000000000 --- a/compiler/global/global.ml +++ /dev/null @@ -1,89 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* global data in the symbol tables *) -open Zmisc -open Zident -open Zelus -open Deftypes -open Defcaus -open Definit - - -type 'a info = { qualid : Lident.qualident; info : 'a } - -(* values in the symbol table *) -type value_desc = - { mutable value_typ: typ_scheme; (* its type scheme *) - mutable value_static: bool; (* is-it a static value? *) - mutable value_caus: tc_scheme option; (* its causality scheme *) - mutable value_init: ti_scheme option; (* its init. scheme *) - mutable value_code: value_code; (* source code *) - } - -(** The type of values *) -and value_exp = - | Vconst of immediate (* constant *) - | Vconstr0 of Lident.qualident (* constructor *) - | Vconstr1 of Lident.qualident * value_code list (* constructor *) - | Vtuple of value_code list (* tuple *) - | Vrecord of (Lident.qualident * value_code) list (* record *) - | Vperiod of value_code period (* period *) - | Vfun of funexp * value_code Env.t - (* a closure: the function body; the environment of values *) - | Vabstract of Lident.qualident (* no implementation is given *) - -and value_code = - { value_exp: value_exp; (* the value descriptor *) - value_name: Lident.qualident option; - (* when the value is defined globally *) } - -(* Value constructors *) -type constr_desc = { constr_arg: Deftypes.typ list; - constr_res: Deftypes.typ; - constr_arity: int } - -and label_desc = - { label_arg: Deftypes.typ; (* if x:arg then x.m: res *) - label_res: Deftypes.typ; } - -type type_desc = - { mutable type_desc: type_components; - mutable type_parameters: int list; - } - -and type_components = - | Abstract_type - | Variant_type of constr_desc info list - | Record_type of label_desc info list - | Abbrev of Deftypes.typ list * Deftypes.typ - (* type ('a1,...,'an) t = ty *) - -let value_code value_exp = { value_exp = value_exp; value_name = None } -let value_name n ({ value_exp = value_exp; value_name = opt_name } as v) = - match opt_name with - | None -> { v with value_name = Some(n) } - | Some _ -> v -let value_desc is_static typs qualident = - { value_typ = typs; value_static = is_static; value_caus = None; - value_init = None; value_code = value_code (Vabstract(qualident)) } -let set_type { info = ({ value_typ = _ } as v) } tys = - v.value_typ <- tys -let set_causality { info = ({ value_caus = _ } as v) } tys = - v.value_caus <- Some(tys) -let set_init { info = ({ value_init = _ } as v) } tys = - v.value_init <- Some(tys) -let set_value_code { info = ({ value_code = _ } as v)} value_code = - v.value_code <- value_code - diff --git a/compiler/global/graph.ml b/compiler/global/graph.ml deleted file mode 100644 index 7350acebb..000000000 --- a/compiler/global/graph.ml +++ /dev/null @@ -1,151 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* acyclic graph manipulations *) - -(* a node is a unique integer; precedence/successor is defined with it *) -(* a association table associates a containt to an index *) -(* a graph is well formed if the graph is acyclic; *) -(* nodes in [outputs] have no successors; *) -(* [succ] and [prec] are inverse of each other; [nodes] is the set of nodes *) -type index = int - -module S = Set.Make(struct type t = int let compare = compare end) -module E = Map.Make(struct type t = int let compare = compare end) - -type 'a graph = - { outputs: S.t ; (* the exits of a data-flow graph *) - succ: S.t E.t; (* the successor of a node *) - prec: S.t E.t; (* the predecessor of a node *) - containt: 'a E.t; (* the value associated to a node *) - nodes: S.t; (* the set of nodes *) } - -type error = Cycle of index list - -exception Error of error - -let empty = { outputs = S.empty; succ = E.empty; prec = E.empty; - containt = E.empty; nodes = S.empty } - -(* add a node to a graph *) -let add n v ({ nodes; containt } as g) = - { g with nodes = S.add n nodes; containt = E.add n v containt } - -(* given [n1 in set1] and [n2 in set2], add (n1, n2) to succ; *) -(* (n2, n1) to prec *) -let add_before set1 set2 ({ succ; prec } as g) = - let update set x rel = - E.update x - (function | None -> Some(set) | Some(set0) -> Some(S.union set0 set)) - rel in - { g with succ = S.fold (update set2) set1 succ; - prec = S.fold (update set1) set2 prec } - -(* [n1] is before [n2] *) -let is_before { succ } n1 n2 = S.mem n2 (E.find n1 succ) - -(* successors *) -let successors n { succ } = try E.find n succ with Not_found -> S.empty - -(* containt *) -let containt n { containt } = E.find n containt - -(* computes outputs = nodes that have no successors *) -(* warning: the graph must be acyclic. In case it is cyclic *) -(* nodes on a cycle are not considered to be outputs *) -let outputs ({ nodes; succ } as g) = - let outputs = - S.filter - (fun n -> try S.is_empty (E.find n succ) with Not_found -> true) nodes in - { g with outputs = outputs } - -(** Well formation of a graph *) -(* the graph must be a partial order, i.e., acyclic *) -let acyclic { succ; prec } = - (* check that a graph has no cycle; in case of error, return a path. *) - (* [grey] is the set of currently visited nodes; if the current *) - (* node is grey, then a path has been found *) - (* [black] is the set of nodes visited in the past *) - let rec cycle n (black, grey) = - if S.mem n grey then raise (Error(Cycle(S.elements grey))) - else if S.mem n black then black, grey - else - let black, grey = - S.fold cycle (E.find n prec) (black, S.add n grey) in - S.add n black, S.remove n grey in - ignore (E.fold (fun n _ acc -> cycle n acc) prec (S.empty, S.empty)) - -(** Topological sort. Must be applied to a well-formed graph *) -let topological { outputs; prec } = - let rec sortrec n (visited, seq) = - if S.mem n visited then visited, seq - else - let n_set = try E.find n prec with Not_found -> S.empty in - let visited, seq = S.fold sortrec n_set (visited, seq) in - S.add n visited, n :: seq in - let _, seq = S.fold sortrec outputs (S.empty, []) in - List.rev seq - -(** transitive reduction for an acyclic graph *) -(* returns the same acyclic graph where *) -(* [prec] and [succ] are reduced *) -let transitive_reduction ({ outputs; nodes; prec; succ } as g) = - (* three steps: the first step computes a topological sort *) - let l = topological g in - (* the second computes the longest path value [v] for every node *) - let length length_table n = - let v = - S.fold - (fun m acc -> max acc (E.find m length_table)) - (try E.find n prec with Not_found -> S.empty) 0 in - E.add n (v+1) length_table in - let length_table = List.fold_left length E.empty l in - (* the third step keeps the link from [source] to [target] *) - (* if length_table[target] = length_table[source] + 1 *) - let reduce (new_prec, new_succ) n = - let v = E.find n length_table in - let l_prec = try E.find n prec with Not_found -> S.empty in - let l_prec = S.filter (fun m -> (E.find m length_table) = v - 1) l_prec in - let l_succ = try E.find n succ with Not_found -> S.empty in - let l_succ = S.filter (fun m -> (E.find m length_table) = v + 1) l_succ in - let new_prec = - if S.is_empty l_prec then new_prec else E.add n l_prec new_prec in - let new_succ = - if S.is_empty l_succ then new_succ else E.add n l_succ new_succ in - new_prec, new_succ in - let new_prec, new_succ = List.fold_left reduce (E.empty, E.empty) l in - { g with prec = new_prec; succ = new_succ } - -let topological ({ containt } as g) = - let seq = topological g in - List.map (fun n -> E.find n containt) seq - -(** Print *) -let print p ff { nodes; succ; outputs; containt } = - let o_list = S.elements outputs in - let l = - S.fold - (fun n acc -> - try - (n, E.find n containt, S.elements (E.find n succ)) :: acc - with - Not_found -> acc) - nodes [] in - let one ff (n, v, n_list) = - Format.fprintf ff "%d: %a before %a" - n p v (Pp_tools.print_list_r Format.pp_print_int "" "," "") n_list in - Format.fprintf ff - "@[<0>@[dependences:@,%a@]@,@[outputs:@,%a@.@]" - (Pp_tools.print_list_l one "" "" "") l - (Pp_tools.print_list_r Format.pp_print_int "" "," "") o_list diff --git a/compiler/global/initial.ml b/compiler/global/initial.ml deleted file mode 100644 index 62acae935..000000000 --- a/compiler/global/initial.ml +++ /dev/null @@ -1,151 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* the initial module *) - -open Zmisc -open Lident -open Global -open Deftypes -open Modules - -let stdlib_module = Zmisc.name_of_stdlib_module - -let abstract_type params = - { type_desc = Abstract_type; type_parameters = params } -let abstract_type qualident arity = - { qualid = qualident; info = abstract_type arity } -let abbrev_type params (ty_parameters, ty) = - { type_desc = Abbrev(ty_parameters, ty); type_parameters = params } -let abbrev_type qualident params (ty_parameters, ty) = - { qualid = qualident; info = abbrev_type params (ty_parameters, ty)} -let value qualident tys = - { qualid = qualident; info = value_desc false tys qualident } - -let stdlib_name id = { qual = stdlib_module;id = id } - -let int_ident = stdlib_name "int" -let int32_ident = stdlib_name "int32" -let int64_ident = stdlib_name "int64" -let bool_ident = stdlib_name "bool" -let zero_ident = stdlib_name "zero" -let float_ident = stdlib_name "float" -let char_ident = stdlib_name "char" -let string_ident = stdlib_name "string" -let sig_ident = stdlib_name "signal" -let unit_ident = stdlib_name "unit" -let list_ident = stdlib_name "list" - -let type_desc_int = abstract_type int_ident [] -let type_desc_int32 = abstract_type int32_ident [] -let type_desc_int64 = abstract_type int64_ident [] -let type_desc_zero = abstract_type zero_ident [] -let type_desc_bool = abstract_type bool_ident [] -let type_desc_float = abstract_type float_ident [] -let type_desc_char = abstract_type char_ident [] -let type_desc_string = abstract_type string_ident [] -let type_desc_unit = abstract_type unit_ident [] -let type_desc_signal = abstract_type sig_ident [generic] -let type_desc_list = abstract_type list_ident [generic] - -let constr id ty_list = make (Tconstr(id, ty_list, ref Tnil)) - -(* the [array] type *) -let array_ident = stdlib_name "array" -let type_desc_array = abstract_type array_ident [generic] -let empty_array_ident = stdlib_name "[||]" - -let typ_int = constr int_ident [] -and typ_int32 = constr int32_ident [] -and typ_int64 = constr int64_ident [] -and typ_bool = constr bool_ident [] -and typ_zero = constr zero_ident [] -and typ_char = constr char_ident [] -and typ_string = constr string_ident [] -and typ_float = constr float_ident [] -and typ_unit = constr unit_ident [] -and typ_signal ty = constr sig_ident [ty] -and typ_array ty = constr array_ident [ty] -and typ_list ty = constr list_ident [ty] - -(* global types loaded initially *) -let tglobal = - [ type_desc_int; - type_desc_int32; - type_desc_int64; - type_desc_bool; - type_desc_zero; - type_desc_float; - type_desc_char; - type_desc_string; - type_desc_unit; - type_desc_signal; - type_desc_array; - type_desc_list ] - -let nil_name = "[]" -let cons_name = "::" - -let nil_ident = stdlib_name nil_name -let cons_ident = stdlib_name cons_name - -let value_desc_nil = - let ta = make Tvar in - value nil_ident { typ_vars = [ta]; typ_body = typ_list ta } - -let value_desc_cons = - let ta = make Tvar in - let ta_list = typ_list ta in - value cons_ident - { typ_vars = [ta]; - typ_body = make (Tfun(Tany, None, make (Tproduct [ta; ta_list]), ta_list)) - } - -(* global constructed values loaded initially *) -let cglobal = [] - -(* global values loaded initially *) -let vglobal = - [ value_desc_nil; - value_desc_cons ] - -(* some names from the initial module can be used shortly *) -let short = - let module StrSet = Set.Make(String) in - let table = - List.fold_right - StrSet.add - ["int"; "int32"; "int64"; - "bool"; "zero"; "float"; "char"; "string"; "signal"; "unit"; - "array"; "[||]"; "list"; "[]"; "::"; "Some"; "None"] - StrSet.empty in - function - | Modname({ qual = m; id = s }) as modname -> - (* [Stdlib.s] is printed [s] when [s] is unbound *) - if m = stdlib_module then if StrSet.mem s table then Name(s) - else - try let { qualid = { qual = m } } = Modules.find_value (Name(s)) in - if m = stdlib_module then Name(s) else modname - with | Not_found -> modname - else modname - | Name _ as name -> name - -let set_no_stdlib () = - default_used_modules := []; - (* build the initial environment *) - List.iter (fun x -> add_type x.qualid.id x.info) tglobal; - List.iter (fun x -> add_constr x.qualid.id x.info) cglobal; - List.iter (fun x -> add_value x.qualid.id x.info) vglobal - - diff --git a/compiler/global/lident.ml b/compiler/global/lident.ml deleted file mode 100644 index dde0556f2..000000000 --- a/compiler/global/lident.ml +++ /dev/null @@ -1,34 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* long identifiers *) -type t = - | Name of string - | Modname of qualident - -and qualident = { qual: string; id: string } - -let qualidname { qual = m; id = id } = m ^ "." ^ id - -let modname = function - | Name(n) -> n - | Modname(qualid) -> qualidname qualid - -let source = function - | Name(n) -> n - | Modname(qualid) -> qualid.id - -let fprint_t ff id = Format.fprintf ff "%s" (modname id) - -let compare = compare diff --git a/compiler/global/modules.ml b/compiler/global/modules.ml deleted file mode 100644 index 61dbb267c..000000000 --- a/compiler/global/modules.ml +++ /dev/null @@ -1,151 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* global symbol tables *) -open Zmisc -open Lident -open Deftypes -open Global - -module E = Map.Make (struct type t = string let compare = compare end) - -exception Already_defined of string - -exception Cannot_find_file of string - -type env = - { mutable name: string; - mutable values: Global.value_desc E.t; - mutable types: Global.type_desc E.t; - mutable constr: Global.constr_desc E.t; - mutable label: Global.label_desc E.t; - } - -type modules = - { current: env; (* associated symbol table *) - mutable opened: env list; (* opened tables *) - mutable modules: env E.t; (* tables loaded in memory *) - } - -let current = - { name = ""; values = E.empty; types = E.empty; - constr = E.empty; label = E.empty } - -let modules = - { current = current; opened = []; modules = E.empty } - -let clear () = - current.values <- E.empty; current.types <- E.empty; - current.constr <- E.empty; current.label <- E.empty - -let findfile filename = - if Sys.file_exists filename then - filename - else if not(Filename.is_implicit filename) then - raise(Cannot_find_file filename) - else - let rec find = function - [] -> - raise(Cannot_find_file filename) - | a::rest -> - let b = Filename.concat a filename in - if Sys.file_exists b then b else find rest - in find !load_path - -let load_module modname = - let name = String.uncapitalize_ascii modname in - try - let filename = findfile (name ^ ".zci") in - let ic = open_in_bin filename in - try - let m = input_value ic in - close_in ic; - m - with - | End_of_file | Failure _ -> - close_in ic; - Printf.eprintf "Corrupted compiled interface file %s.\n\ - Please recompile module %s first.\n" filename modname; - raise Error - with - | Cannot_find_file(filename) -> - Printf.eprintf "Cannot find the compiled interface file %s.\n" - filename; - raise Error - -let find_module modname = - try - E.find modname modules.modules - with - Not_found -> - let m = load_module modname in - modules.modules <- E.add modname m modules.modules; - m - -let find where qualname = - let rec findrec ident = function - | [] -> raise Not_found - | m :: l -> - try { qualid = { qual = m.name; id = ident }; - info = where ident m } - with Not_found -> findrec ident l in - - match qualname with - | Modname({ qual = m; id = ident } as q) -> - let current = if current.name = m then current else find_module m in - { qualid = q; info = where ident current } - | Name(ident) -> findrec ident (current :: modules.opened) - -(* exported functions *) -let open_module modname = - let m = find_module modname in - modules.opened <- m :: modules.opened - -let initialize modname = - current.name <- modname; - List.iter open_module !default_used_modules - -let add_value f signature = - if E.mem f current.values then raise (Already_defined f); - current.values <- E.add f signature current.values - -let add_type f typ_desc = - if E.mem f current.types then raise (Already_defined f); - current.types <- E.add f typ_desc current.types -let add_constr f ty_res = - if E.mem f current.constr then raise (Already_defined f); - current.constr <- E.add f ty_res current.constr -let add_label f label_desc = - if E.mem f current.label then raise (Already_defined f); - current.label <- E.add f label_desc current.label - -let find_value = find (fun ident m -> E.find ident m.values) -let find_type = find (fun ident m -> E.find ident m.types) -let find_constr = find (fun ident m -> E.find ident m.constr) -let find_label = find (fun ident m -> E.find ident m.label) - -let write oc = output_value oc current - -let qualify n = { qual = current.name; id = n } -let longname n = Modname({ qual = current.name; id = n }) -let shortname { id = n } = n -let currentname longname = - match longname with - | Name(n) -> longname - | Modname{ qual = q; id = id} -> - if current.name = q then Name(id) else longname -let qualident longname = - match longname with | Name(n) -> qualify n | Modname(qid) -> qid -let current_module () = current.name - diff --git a/compiler/global/pcaus.ml b/compiler/global/pcaus.ml deleted file mode 100644 index 1e0512943..000000000 --- a/compiler/global/pcaus.ml +++ /dev/null @@ -1,117 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* Printing a causality type expression *) - -open Format -open Pp_tools -open Zmisc -open Zident -open Defcaus - -(** a set of causality names *) -module S = Set.Make(Defcaus) -(** and a module to represent the successors of a causality variable *) -module M = Map.Make(Defcaus) - -(* type variables are printed 'a, 'b,... *) -let type_name = new name_assoc_table int_to_alpha - -let info i = - match i with - | Cname(n) -> Zident.source n - | Clast(n) -> "last " ^ (Zident.source n) - -let polarity = - function Punknown -> "" | Pplus -> "+" | Pminus -> "-" | Pplusminus -> "+-" -let useful u = if u then "u" else "" -let level l = string_of_int l - -let extra { c_polarity = p; c_useful = u; c_level = l; c_index = i } = - if !Zmisc.verbose - then polarity p ^ useful u ^ level l ^ "(" ^ (string_of_int i) ^ ")" else "" - - -(* Print the causality *) -let rec caus ff c = - match c.c_desc with - | Clink(link) -> caus ff link - | Cvar -> - Format.fprintf ff "%s'%s" (extra c) (type_name#name c.c_index) - -let caus_list ff c_list = print_list_r_empty caus "" "" "" ff c_list - -(* Print the causality with the source name *) -let rec caus_by_name ff c = - match c.c_desc with - | Clink(link) -> caus_by_name ff link - | Cvar -> - let index = c.c_index in - match c.c_info with - | None -> Format.fprintf ff "%s" (type_name#name index) - | Some(i) -> Format.fprintf ff "%s at '%s" (info i) (type_name#name index) - -let rec ptype prio ff tc = - let priority = function | Catom _ -> 3 | Cproduct _ -> 2 | Cfun _ -> 1 in - let prio_current = priority tc in - if prio_current < prio then fprintf ff "("; - begin - match tc with - | Catom(c) -> caus ff c - | Cfun(ty_arg, ty_res) -> - Format.fprintf ff - "@[%a ->@ %a@]" (ptype (prio_current + 1)) ty_arg - (ptype prio_current) ty_res - | Cproduct(ty_list) -> - print_list_r (ptype (prio_current + 1)) "" " *" "" ff ty_list - end; - if prio_current < prio then fprintf ff ")" - -let ptype ff tc = ptype 0 ff tc - -(* print a set of dependences *) -let set ff s = Format.fprintf ff "@[{%a}@]" (fun ff s -> S.iter (caus ff) s) s - -(* Print the list of dependences ['a < 'b,...] *) -(* doublons have normally be removed by the type generalisation *) -let relation ff rel = - let print ff (c, c_sup) = - Format.fprintf - ff "@[%a < %a@]" caus c (print_list_r caus "" "," "") c_sup in - print_list_r print "{" ";" "}" ff rel - -(* print a causality type signature *) -let scheme ff { typ_rel = rel; typ = ty } = - Format.fprintf ff "@[%a.@ %a@]" relation rel ptype ty - -(* prints a dependence cycle *) -let cycle with_info ff c_list = - let caus = if with_info then caus_by_name else caus in - let rec print first ff l = - match l with - | [] -> Format.fprintf ff "@[%a < %a@]" caus first caus first - | [c] -> Format.fprintf ff "@[%a < %a@]" caus c caus first - | c1 :: ((c2 :: _) as l) -> - Format.fprintf - ff - "@[%a < %a;@ %a@]" caus c1 caus c2 (print first) l in - match c_list with - | [] -> () (* assert false *) - | (first :: _) as l -> print first ff l - -(* printing a declaration *) -let declaration ff f tys = - type_name#reset; - Format.fprintf ff "@[val %s :@ @[%a@]@.@]" f scheme tys - diff --git a/compiler/global/pinit.ml b/compiler/global/pinit.ml deleted file mode 100644 index 9310cfd57..000000000 --- a/compiler/global/pinit.ml +++ /dev/null @@ -1,87 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* Printing an initialization type expression *) - -open Format -open Pp_tools -open Zmisc -open Zident -open Definit - -(* type variables are printed 'a, 'b,... *) -let type_name = new name_assoc_table int_to_alpha - -(* print extra information *) -let polarity = - function Punknown -> "" | Pplus -> "+" | Pminus -> "-" | Pplusminus -> "+-" -let useful u = if u then "u" else "" -let level l = string_of_int l -let min = function Ihalf -> "1/2" | _ -> "" - -let extra - { i_polarity = p; i_useful = u; i_level = l; i_index = i; i_min = m } = - if !Zmisc.verbose then polarity p ^ useful u ^ level l ^ - "(" ^ (string_of_int i) ^ min m ^ ")" else "" - -(* Print the causality *) -let rec init ff i = - match i.i_desc with - | Ivalue(v) -> - begin match v with - | Izero -> fprintf ff "0" - | Ione -> fprintf ff "1" - | Ihalf -> fprintf ff "1/2" - end - | Ilink(link) -> init ff link - | Ivar -> - Format.fprintf - ff "%s'%s" (extra i) (type_name#name i.i_index) - -let rec ptype prio ff ti = - let priority = function | Iatom _ -> 3 | Iproduct _ -> 2 | Ifun _ -> 1 in - let prio_current = priority ti in - if prio_current < prio then fprintf ff "("; - begin - match ti with - | Iatom(i) -> init ff i - | Ifun(ty_arg, ty_res) -> - Format.fprintf - ff - "@[%a ->@ %a@]" (ptype (prio_current + 1)) ty_arg - (ptype prio_current) ty_res - | Iproduct(ty_list) -> - print_list_r (ptype (prio_current + 1)) "" " *" "" ff ty_list - end; - if prio_current < prio then fprintf ff ")" - -let ptype ff ti = ptype 0 ff ti - -let prelation ff rel = - let print ff (i, i_list) = - Format.fprintf - ff "@[%a < %a@]" init i (print_list_r init "" "," "") i_list in - print_list_r print "{" ";" "}" ff rel - -(* print a type scheme *) -(* { a1 < a2,...,ak; ...; }. ti *) -let scheme ff { typ_rel = rel; typ = ty } = - match rel with - | [] -> ptype ff ty - | _ -> Format.fprintf ff "@[%a.@ %a@]" prelation rel ptype ty - -(* printing a declaration *) -let declaration ff f tys = - type_name#reset; - Format.fprintf ff "@[val %s :@ @[%a@]@.@]" f scheme tys diff --git a/compiler/global/pp_tools.ml b/compiler/global/pp_tools.ml deleted file mode 100644 index 11b9daffd..000000000 --- a/compiler/global/pp_tools.ml +++ /dev/null @@ -1,74 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* useful stuff for printing *) - -open Format - -let print_if_not_empty print ff = function | [] -> () | l -> print ff l - -let print_list_no_space print po sep pf ff l = - let rec printrec ff l = - match l with - | [] -> () - | [x] -> print ff x - | x :: l -> - fprintf ff "@[%a%s%a@]" print x sep printrec l in - fprintf ff "@[%s%a%s@]" po printrec l pf - -(* prints [po body [sep body]+ pf] *) -let print_list_r print po sep pf ff l = - let rec printrec ff l = - match l with - | [] -> () - | [x] -> print ff x - | x :: l -> - fprintf ff "@[%a@ %s@ @[%a@]@]" print x sep printrec l in - fprintf ff "@[%s%a%s@]" po printrec l pf - -(* prints in a row a [po body [sep body]+ pf] *) -let print_list_l print po sep pf ff l = - let rec printrec ff l = - match l with - | [] -> () - | x :: l -> fprintf ff "@[%s%a@ %a@]" sep print x printrec l in - match l with - | [] -> fprintf ff "%s%s" po pf - | [x] -> fprintf ff "%s%a%s" po print x pf - | x :: l -> fprintf ff "@[%s%a@ %a%s@]" po print x printrec l pf - - -let print_list_r_empty print po sep pf ff l = - print_if_not_empty (print_list_r print po sep pf) ff l - - -let print_couple print1 print2 po sep pf ff (c1, c2) = - fprintf ff "@[%s@[%a@]%s@ @[%a@]%s@]" po print1 c1 sep print2 c2 pf - -let print_couple2 print1 print2 po sep1 sep2 pf ff (c1, c2) = - fprintf ff - "@[%s@[%a@]%s@ %s@[%a@]%s@]" po print1 c1 sep1 sep2 print2 c2 pf - -let print_record print ff r = - fprintf ff "@[%a@]" (print_list_r print "{ "";"" }") r - -let print_with_braces print po pf ff p = fprintf ff "@[%s%a%s@]" po print p pf - -let print_opt print ff = function - | None -> () - | Some(s) -> print ff s - -let print_opt2 print sep ff = function - | None -> () - | Some(s) -> fprintf ff "@[%s%a@]" sep print s diff --git a/compiler/global/printer.ml b/compiler/global/printer.ml deleted file mode 100644 index 569348247..000000000 --- a/compiler/global/printer.ml +++ /dev/null @@ -1,571 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* the printer *) - -open Zlocation -open Zmisc -open Zelus -open Deftypes -open Ptypes -open Global -open Modules -open Pp_tools -open Format - -let no_op ff _ = () - -(* Infix chars are surrounded by parenthesis *) -let is_infix = - let module StrSet = Set.Make(String) in - let set_infix = - List.fold_right - StrSet.add - ["or"; "quo"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"] - StrSet.empty in - fun s -> StrSet.mem s set_infix - -let parenthesis s = - let c = String.get s 0 in - if is_infix s then "(" ^ s ^ ")" - else match c with - | 'a' .. 'z' | 'A' .. 'Z' | '_' | '`' -> s - | '*' -> "( " ^ s ^ " )" - | _ -> if s = "()" then s else "(" ^ s ^ ")" - -let shortname ff s = fprintf ff "%s" (parenthesis s) - -let qualident ff { Lident.qual = m; Lident.id = s } = - fprintf ff "%s.%s" m (parenthesis s) - -let longname ff ln = - let ln = Initial.short (currentname ln) in - match ln with - | Lident.Name(m) -> shortname ff m - | Lident.Modname(qual) -> qualident ff qual - -let name ff n = shortname ff (Zident.name n) - -let source_name ff n = shortname ff (Zident.source n) - -let immediate ff = function - | Eint i -> fprintf ff "%d" i - | Efloat f -> fprintf ff "%f" f - | Ebool b -> if b then fprintf ff "true" else fprintf ff "false" - | Estring s -> fprintf ff "%S" s - | Echar c -> fprintf ff "'%c'" c - | Evoid -> fprintf ff "()" - -let constant ff = function - | Cimmediate(i) -> immediate ff i - | Cglobal(ln) -> longname ff ln - -let print_opt_magic print ff = function - | None -> pp_print_string ff "Obj.magic ()" - | Some(e) -> print ff e - - - -let rec pattern ff ({ p_typ = ty; p_caus = caus_list } as pat) = - let rec pattern ff pat = - match pat.p_desc with - | Evarpat(n) -> fprintf ff "@[(%a : %a)@]" name n Ptypes.output ty - | Ewildpat -> fprintf ff "_" - | Econstpat(im) -> immediate ff im - | Econstr0pat(ln) -> longname ff ln - | Econstr1pat(ln, pat_list) -> - fprintf ff "@[%a%a@]" longname ln (pattern_list "(" "," ")") pat_list - | Etuplepat(pat_list) -> pattern_list "(" "," ")" ff pat_list - | Etypeconstraintpat(p, ty_exp) -> - fprintf ff "@[(%a:%a)@]" pattern p ptype ty_exp - | Erecordpat(n_pat_list) -> - print_record (print_couple longname pattern """ =""") ff n_pat_list - | Ealiaspat(p, n) -> - fprintf ff "%a as %a" pattern p name n - | Eorpat(pat1, pat2) -> - fprintf ff "%a | %a" pattern pat1 pattern pat2 in -(* fprintf ff "@[%a (* caus: %a *)@]" pattern pat Pcaus.caus_list caus_list *) - pattern ff pat - - -and pattern_list po sep pf ff pat_list = - fprintf ff "@[%a@]" (print_list_r pattern po sep pf) pat_list - -and ptype ff ty = - let operator = function Splus -> "+" | Sminus -> "-" in - let priority = function Splus -> 0 | Sminus -> 1 in - let rec psize prio ff { desc = desc } = - match desc with - | Sconst(i) -> fprintf ff "%d" i - | Sglobal(ln) -> longname ff ln - | Sname(n) -> name ff n - | Sop(op, e1, e2) -> - let prio_op = priority op in - if prio > prio_op then fprintf ff "("; - fprintf ff "@[%a %s %a@]" - (psize prio_op) e1 (operator op) (psize prio_op) e2; - if prio > prio_op then fprintf ff ")" in - match ty.desc with - | Etypevar(s) -> fprintf ff "'%s" s - | Etypeconstr(ln, ty_list) -> - fprintf ff "@[%a@]%a" - (print_list_r_empty ptype "("","")") ty_list - longname ln - | Etypetuple(ty_list) -> - fprintf ff "@[%a@]" (print_list_r ptype "(""*"")") ty_list - | Etypefun(k, n_opt, ty_arg, ty_res) -> - let pas ff (n_opt, ty_arg) = - match n_opt with - | None -> () | Some(n) -> fprintf ff "(%a : %a)" name n ptype ty_arg in - let s = match k with - | S -> "-S->" | A -> "-A->" | AD -> "-AD->" | D -> "-D->" - | C -> "-C->" | AS -> "-AS->" | P -> "~D~>" in - fprintf ff "@[%a %s %a@]" pas (n_opt, ty_arg) s ptype ty_res - | Etypevec(ty_arg, size) -> - fprintf ff "@[%a[%a]@]" ptype ty_arg (psize 0) size - -let default ff = function - | Init(v) -> fprintf ff " init %a" constant v - | Default(v) -> fprintf ff " default %a" constant v - -let combine ff v = fprintf ff " with %a" longname v - -let print_vardec_list ff vardec_list = - let vardec ff - { vardec_name = n; vardec_default = d_opt; vardec_combine = c_opt } = - fprintf ff "@[%a%a%a@]" name n - (Zmisc.optional_unit default) d_opt (Zmisc.optional_unit combine) c_opt in - if vardec_list <> [] - then fprintf ff "@[%a@ @]" - (print_list_r vardec "local " "," "") vardec_list - -let kind k = - match k with - | Cont -> "cont" | Zero -> "zero" - | Period -> "period" | Horizon -> "horizon" - | Encore -> "encore" | Major -> "major" - -let print_binding ff (n, { t_sort = sort; t_typ = typ }) = - let default ff v = fprintf ff " default %a" constant v in - let combine ff v = fprintf ff " with %a" longname v in - let init ff i_opt = - match i_opt with - | Noinit -> () - | InitEq -> fprintf ff " init" - | InitDecl(c) -> fprintf ff " init %a" constant c in - let next ff is_n = fprintf ff "%s" (if is_n then "next " else "cur ") in - let previous p = if p then "last " else "" in - let kind ff k = fprintf ff "%s" (kind k) in - match sort with - | Sstatic -> fprintf ff "@[static %a: %a@,@]" name n Ptypes.output typ - | Sval -> fprintf ff "@[val %a: %a@,@]" name n Ptypes.output typ - | Svar { v_combine = c_opt; v_default = d_opt } -> - fprintf ff "@[var %a: %a%a%a@,@]" name n Ptypes.output typ - (Zmisc.optional_unit default) d_opt - (Zmisc.optional_unit combine) c_opt - | Smem { m_kind = k; m_next = n_opt; m_previous = p; - m_init = i_opt; m_combine = c_opt } -> - fprintf ff "@[%a%s%a mem %a: %a%a%a@,@]" - (Zmisc.optional_unit next) n_opt (previous p) - (Zmisc.optional_unit kind) k name n Ptypes.output typ - init i_opt - (Zmisc.optional_unit combine) c_opt - -let print_env ff env = - if !vverbose then begin - let env = Zident.Env.bindings env in - if env <> [] then - fprintf ff "@[(* defs: %a *)@,@]" - (print_list_r print_binding """;""") env - end -let print_writes ff { dv = dv; di = di; der = der; nv = nv; mv = mv } = - if !vverbose then begin - let dv = Zident.S.elements dv in - let di = Zident.S.elements di in - let der = Zident.S.elements der in - let nv = Zident.S.elements nv in - let mv = Zident.S.elements mv in - open_box 0; - if dv <> [] then - fprintf ff - "@[(* dv = {@[%a@]} *)@ @]" (print_list_r name "" "," "") dv; - if di <> [] then - fprintf ff - "@[(* di = {@[%a@]} *)@ @]" (print_list_r name "" "," "") di; - if der <> [] then - fprintf ff - "@[(* der = {@[%a@]} *)@ @]" (print_list_r name "" "," "") der; - if nv <> [] then - fprintf ff - "@[(* next = {@[%a@]} *)@ @]" (print_list_r name "" "," "") nv; - if mv <> [] then - fprintf ff - "@[(* der = {@[%a@]} *)@ @]" (print_list_r name "" "," "") mv; - close_box () - end - -let print_eq_info ff { eq_write = w; eq_safe = s; eq_index = i } = - print_writes ff w - -(* print a block surrounded by two braces [po] and [pf] *) -let block locals body po pf ff - { b_vars = vardec_list; b_locals = l; b_body = b; - b_write = w; b_env = n_env } = - fprintf ff "@[@[%a@]@[%a@]@[%a@]@[%a@]@[%a@]@]" - print_vardec_list vardec_list - print_writes w - print_env n_env - locals l - (body po pf) b - -let match_handler body ff { m_pat = pat; m_body = b; m_env = env; - m_reset = r; m_zero = z } = - fprintf ff "@[| %a -> %s%s@,%a%a@]" - pattern pat (if r then "(* reset *)" else "") - (if z then "(* zero *)" else "") - print_env env body b - -let present_handler scondpat body ff { p_cond = scpat; p_body = b; p_env = env } = - fprintf ff "@[| (%a) ->@ @[%a%a@]@]" - scondpat scpat print_env env body b - -let period expression ff { p_phase = opt_phase; p_period = p } = - match opt_phase with - | None -> fprintf ff "@[(%a)@]" expression p - | Some(phase) -> fprintf ff "@[(%a|%a)@]" expression phase expression p - -let rec expression ff e = - if Deftypes.is_no_typ e.e_typ && !vverbose then - fprintf ff "@[(* %a *)@]" Ptypes.output e.e_typ; - match e.e_desc with - | Elocal n -> name ff n - | Eglobal { lname = ln } -> longname ff ln - | Eop(op, e_list) -> operator ff op e_list - | Elast x -> fprintf ff "last %a" name x - | Econstr0(ln) -> longname ff ln - | Econst c -> immediate ff c - | Eapp({ app_inline = i; app_statefull = r }, e, e_list) -> - fprintf ff "@[(%s%s%a %a)@]" - (if i then "inline " else "") (if r then "run " else "") - expression e (print_list_r expression "" "" "") e_list - | Econstr1(ln, e_list) -> - fprintf ff "@[%a%a@]" - longname ln (print_list_r expression "("","")") e_list - | Etuple(e_list) -> - fprintf ff "@[%a@]" (print_list_r expression "("","")") e_list - | Erecord_access(e, field) -> - fprintf ff "@[%a.%a@]" expression e longname field - | Erecord(ln_e_list) -> - print_record (print_couple longname expression """ =""") ff ln_e_list - | Erecord_with(e, ln_e_list) -> - fprintf ff "@[{ %a with %a }@]" - expression e - (print_list_r - (print_couple longname expression """ =""") "" ";" "") - ln_e_list - | Elet(l, e) -> - fprintf ff "@[%a@ %a@]" local l expression e - | Eblock(b, e) -> - fprintf ff "@[%a in@ %a@]" - (block_equation_list "do " "") b expression e - | Etypeconstraint(e, typ) -> - fprintf ff "@[(%a: %a)@]" expression e ptype typ - | Eseq(e1, e2) -> - fprintf ff "@[%a;@,%a@]" expression e1 expression e2 - | Eperiod(p) -> - fprintf ff "@[period %a@]" (period expression) p - | Ematch(total, e, match_handler_list) -> - fprintf ff "@[@[%smatch %a with@ @[%a@]@]@]" - (if !total then "total " else "") - expression e (print_list_l (match_handler expression) """""") - match_handler_list - | Epresent(present_handler_list, opt_e) -> - fprintf ff "@[@[present@ @[%a@]@]@ @[%a@]@]" - (print_list_l (present_handler scondpat expression) - """""") present_handler_list - (print_opt2 expression "else ") opt_e - -and operator ff op e_list = - match op, e_list with - | Eunarypre, [e] -> fprintf ff "pre %a" expression e - | Efby, [e1;e2] -> - fprintf ff "%a fby %a" expression e1 expression e2 - | Eminusgreater, [e1;e2] -> - fprintf ff "%a -> %a" expression e1 expression e2 - | Eifthenelse,[e1;e2;e3] -> - fprintf ff "@[(if %a then %a@ else %a)@]" - expression e1 expression e2 expression e3 - | Eup, [e] -> - fprintf ff "up %a" expression e - | Etest, [e] -> - fprintf ff "? %a" expression e - | Edisc, [e] -> - fprintf ff "disc %a" expression e - | Ehorizon, [e] -> - fprintf ff "@[horizon@ @[%a@]@]" expression e - | Einitial, [] -> - fprintf ff "init" - | Eaccess, [e1; e2] -> - fprintf ff "@[%a.(%a)@]" expression e1 expression e2 - | Eupdate, [e1; i; e2] -> - fprintf ff "@[{%a with@ (%a) = %a}@]" - expression e1 expression i expression e2 - | Eatomic, [e] -> - fprintf ff "atomic %a" expression e - | _ -> assert false - -and equation ff ({ eq_desc = desc } as eq) = - print_eq_info ff eq; - match desc with - | EQeq(p, e) -> - fprintf ff "@[%a =@ %a@]" pattern p expression e - | EQder(n, e, e0_opt, []) -> - fprintf ff "@[der %a =@ %a %a@]" - name n expression e - (optional_unit - (fun ff e -> fprintf ff "init %a " expression e)) e0_opt - | EQder(n, e, e0_opt, present_handler_list) -> - fprintf ff "@[der %a =@ %a %a@ @[reset@ @[%a@]@]@]" - name n expression e - (optional_unit - (fun ff e -> fprintf ff "init %a " expression e)) e0_opt - (print_list_l (present_handler scondpat expression) """""") - present_handler_list - | EQinit(n, e0) -> - fprintf ff "@[init %a =@ %a@]" name n expression e0 - | EQpluseq(n, e) -> - fprintf ff "@[%a +=@ %a@]" name n expression e - | EQnext(n, e, None) -> - fprintf ff "@[next %a =@ %a@]" - name n expression e - | EQnext(n, e, Some(e0)) -> - fprintf ff "@[next %a =@ @[%a@ init %a@]@]" - name n expression e expression e0 - | EQautomaton(is_weak, s_h_list, e_opt) -> - fprintf ff "@[automaton%s@ @[%a@]@,%a@]" - (if is_weak then "(* weak *)" else "(* strong *)") - (state_handler_list is_weak) s_h_list - (print_opt (print_with_braces state " init" "")) e_opt - | EQmatch(total, e, match_handler_list) -> - fprintf ff "@[%smatch %a with@ @[%a@]@]" - (if !total then "total " else "") - expression e - (print_list_l - (match_handler (block_equation_list "do " " done")) """""") - match_handler_list - | EQpresent(present_handler_list, None) -> - fprintf ff "@[present@ @[%a@]@]" - (print_list_l - (present_handler scondpat (block_equation_list "do " " done")) - """""") present_handler_list - | EQpresent(present_handler_list, Some(b)) -> - fprintf ff "@[present@ @[%a@]@ else @[%a@]@]" - (print_list_l - (present_handler scondpat (block_equation_list "do " " done")) - """""") present_handler_list - (block_equation_list "do " " done") b - | EQreset(eq_list, e) -> - fprintf ff "@[reset@ @[%a@]@ @[every@ %a@]@]" - (equation_list "" "") eq_list expression e - | EQemit(n, opt_e) -> - begin match opt_e with - | None -> fprintf ff "@[emit %a@]" name n - | Some(e) -> - fprintf ff "@[emit %a = %a@]" name n expression e - end - | EQblock(b_eq_list) -> block_equation_list "do " " done" ff b_eq_list - | EQand(and_eq_list) -> - print_list_l equation "do " "and " " done" ff and_eq_list - | EQbefore(before_eq_list) -> - print_list_l equation "" "before " "" ff before_eq_list - | EQforall { for_index = i_list; for_init = init_list; for_body = b_eq_list; - for_in_env = in_env; for_out_env = out_env } -> - let index ff { desc = desc } = - match desc with - | Einput(i, e) -> - fprintf ff "@[%a in %a@]" name i expression e - | Eoutput(i, j) -> - fprintf ff "@[%a out %a@]" name i name j - | Eindex(i, e1, e2) -> - fprintf ff - "@[%a in %a .. %a@]" name i expression e1 expression e2 in - let init ff { desc = desc } = - match desc with - | Einit_last(i, e) -> - fprintf ff "@[last %a = %a@]" name i expression e in - fprintf ff - "@[forall %a@,@[%a@,%a@,%a@ \ - @[initialize@ @[%a@]@]@ done @]@]" - (print_list_r index "" "," "") i_list - print_env in_env - print_env out_env - (block_equation_list "do " "") b_eq_list - (print_list_l init "" "and " "") init_list - - -and block_equation_list po pf ff b = block locals equation_list po pf ff b - -and equation_list po pf ff eq_list = - match eq_list with - | [] -> fprintf ff "%s%s" po pf - | [eq] -> equation ff eq - | _ -> print_list_l equation po "and " pf ff eq_list - -and state_handler_list is_weak ff s_h_list = - print_list_l (state_handler is_weak) """""" ff s_h_list - -and state_handler is_weak ff - { s_state = s; s_body = b; s_trans = trans; s_env = env } = - let print ff trans = - if trans = [] then fprintf ff "done" - else - print_list_r escape - (if is_weak then "until " else "unless ") "" "" ff trans in - fprintf ff "@[| %a ->@ %a@[%a@,%a@]@]" - statepat s print_env env (block_equation_list "do " "") b print trans - - -and escape ff { e_cond = scpat; e_reset = r; e_block = b_opt; - e_next_state = ns; e_env = env } = - match b_opt with - | None -> - fprintf ff "@[| %a %a%s@ %a@]" - scondpat scpat print_env env (if r then "then" else "continue") state ns - | Some(b) -> - fprintf ff "@[| %a %a%s@ %a in %a@]" - scondpat scpat print_env env (if r then "then" else "continue") - (block_equation_list "do " "") b state ns - -and scondpat ff scpat = match scpat.desc with - | Econdand(scpat1, scpat2) -> - fprintf ff "@[%a &@ %a@]" scondpat scpat1 scondpat scpat2 - | Econdor(scpat1, scpat2) -> - fprintf ff "@[%a |@ %a@]" scondpat scpat1 scondpat scpat2 - | Econdexp(e) -> expression ff e - | Econdpat(e, pat) -> fprintf ff "%a(%a)" expression e pattern pat - | Econdon(scpat1, e) -> - fprintf ff "@[%a on@ %a@]" scondpat scpat1 expression e - - -and statepat ff spat = match spat.desc with - | Estate0pat(n) -> name ff n - | Estate1pat(n, n_list) -> - fprintf ff "%a%a" name n (print_list_r name "("","")") n_list - -and state ff se = match se.desc with - | Estate0(n) -> name ff n - | Estate1(n, e_list) -> - fprintf ff "%a%a" name n (print_list_r expression "("","")") e_list - -and locals ff l = - if l <> [] then fprintf ff "@[%a@]" (print_list_l local """""") l - -and local ff { l_rec = is_rec; l_eq = eq_list; l_env = env } = - let s = if is_rec then "rec " else "" in - fprintf ff "@[%alet %a@]" - print_env env (equation_list s " in") eq_list - -let constr_decl ff { desc = desc } = - match desc with - | Econstr0decl(n) -> fprintf ff "%s" n - | Econstr1decl(n, ty_list) -> - fprintf ff "@[%s of %a@]" n (print_list_l ptype "(" "* " ")") ty_list - -let type_decl ff { desc = desc } = - match desc with - | Eabstract_type -> () - | Eabbrev(ty) -> - fprintf ff " = %a" ptype ty - | Evariant_type(constr_decl_list) -> - fprintf - ff " = %a" (print_list_l constr_decl "" "|" "") constr_decl_list - | Erecord_type(n_ty_list) -> - fprintf ff " = %a" - (print_record (print_couple shortname ptype """ :""")) n_ty_list - -(* Debug printer for (Zident.t * Deftypes.typ) Zlmisc.State.t *) -let state_ident_typ = - let fprint_v ff (id, ty) = - fprintf ff "@[%a:%a@]" Zident.fprint_t id Ptypes.output ty in - Zmisc.State.fprint_t fprint_v - -(* Debug printer for Hybrid.eq Zmisc.State.t *) -let state_eq = Zmisc.State.fprint_t equation - -let open_module ff n = - fprintf ff "@[open "; - shortname ff n; - fprintf ff "@.@]" - -let funexp ff { f_kind = k; f_args = p_list; f_body = e; f_env = env } = - fprintf ff "@[%s %a . @ %a%a@]" - (match k with - | S -> "sfun" | A -> "fun" | AD -> "dfun" | AS -> "asfun" - | D -> "node" | C -> "hybrid" | P -> "proba") - (pattern_list "" "" "") p_list print_env env expression e - -let implementation ff impl = - match impl.desc with - | Eopen(n) -> open_module ff n - | Etypedecl(n, params, ty_decl) -> - fprintf ff "@[type %a%s %a@.@.@]" - Ptypes.print_type_params params - n type_decl ty_decl - | Econstdecl(n, is_static, e) -> - fprintf ff "@[let %s%a =@ %a@.@.@]" - (if is_static then "static " else "") shortname n expression e - | Efundecl(n, body) -> - fprintf ff "@[let %a =@ %a@.@]" shortname n funexp body - -let implementation_list ff imp_list = - List.iter (implementation ff) imp_list - -let interface ff inter = - match inter.desc with - | Einter_open(n) -> open_module ff n - | Einter_typedecl(n, params, ty_decl) -> - fprintf ff "@[type %a%s %a@.@.@]" - Ptypes.print_type_params params - n type_decl ty_decl - | Einter_constdecl(n, ty) -> - fprintf ff "@[val %a : %a@.@.@]" - shortname n ptype ty - -let interface_list ff int_list = - List.iter (interface ff) int_list - -(* Print a value from the global environment *) -let rec print_value_code ff { value_exp = ve; value_name = vn } = - match vn with - | None -> print_value ff ve - | Some(qual) -> - Format.fprintf ff "@[{%a is %a}@]" print_value ve qualident qual - -and print_value ff ve = - match ve with - | Vconst(i) -> immediate ff i - | Vconstr0(qual) -> qualident ff qual - | Vconstr1(qual, vc_list) -> - fprintf ff "@[%a%a@]" - qualident qual (print_list_r print_value_code "("","")") vc_list - | Vtuple(vc_list) -> - fprintf ff "@[%a@]" (print_list_r print_value_code "("","")") vc_list - | Vrecord(ln_vc_list) -> - print_record - (print_couple qualident print_value_code """ =""") ff ln_vc_list - | Vperiod(p) -> fprintf ff "@[period %a@]" (period print_value_code) p - | Vfun(body, venv) -> - fprintf ff "@[<%a,@,%a>@]" - funexp body (Zident.Env.fprint_t print_value_code) venv - | Vabstract(qual) -> qualident ff qual diff --git a/compiler/global/ptypes.ml b/compiler/global/ptypes.ml deleted file mode 100644 index 1e38bee37..000000000 --- a/compiler/global/ptypes.ml +++ /dev/null @@ -1,172 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* Printing a type expression *) - -open Format -open Pp_tools -open Zmisc -open Lident -open Global -open Modules -open Deftypes - -(* the long name of an ident is printed *) -(* if it is different from the current module *) -let print_qualid ff qualid = - Lident.fprint_t ff (Initial.short (currentname (Modname(qualid)))) - -(* type variables are printed 'a, 'b,... *) -let type_name = new name_assoc_table int_to_alpha - -(* generic printing of a list *) -let print_list print_el sep ff l = - let rec printrec ff l = - match l with - [] -> () - | [x] -> print_el ff x - | x::l -> fprintf ff "@[%a%s@ %a@]" print_el x sep printrec l - in - printrec ff l - -let arrow_tostring = function - | Tstatic(true) -> "-S->" | Tstatic(false) -> "-AS->" - | Tany -> "->" | Tcont -> "-C->" - | Tdiscrete(s) -> if s then "-D->" else "-AD->" - | Tproba -> "~D~>" - -let print_size ff si = - let operator = function Tplus -> "+" | Tminus -> "-" in - let priority = function Tplus -> 0 | Tminus -> 1 in - let rec printrec prio ff si = - match si with - | Tconst(i) -> fprintf ff "%d" i - | Tglobal(qualid) -> print_qualid ff qualid - | Tname(x) -> fprintf ff "%s" (Zident.name x) - | Top(op, si1, si2) -> - let prio_op = priority op in - if prio > prio_op then fprintf ff "("; - fprintf ff "@[%a %s %a@]" - (printrec prio_op) si1 (operator op) (printrec prio_op) si2; - if prio > prio_op then fprintf ff ")" in - printrec 0 ff si - -let rec print prio ff ({ t_desc = desc } as ty) = - let priority = function - | Tvar -> 3 | Tproduct _ -> 2 | Tconstr _ -> 3 | Tfun _ -> 1 - | Tvec _ -> 3 | Tlink _ -> prio in - let prio_current = priority desc in - if prio_current < prio then fprintf ff "("; - begin match desc with - | Tvar -> - (* prefix non generalized type variables with "_" *) - let p = if ty.t_level <> Zmisc.notgeneric then "" else "_" in - fprintf ff "@['%s%s@]" p (type_name#name ty.t_index) - | Tproduct [] -> - (* this situation should not happen after typing *) - fprintf ff "ERROR" - | Tproduct(ty_list) -> print_list (print (prio_current + 1)) " *" ff ty_list - | Tconstr(name, ty_list, _) -> - let n = List.length ty_list in - if n = 1 then - fprintf ff "@[%a@ %a@]" (print prio_current) - (List.hd ty_list) print_qualid name - else if n > 1 - then fprintf ff "@[(%a)@ %a@]" (print_list (print 0) ",") ty_list - print_qualid name - else fprintf ff "@[%a@]" print_qualid name - | Tfun(k, name_opt, ty_arg, ty_res) -> - let print_arg ff ty = - match name_opt with - | None -> print (prio_current + 1) ff ty - | Some(n) -> fprintf ff "(%s:%a)" (Zident.name n) (print 0) ty in - fprintf ff "@[%a@ %s@ %a@]" - print_arg ty_arg (arrow_tostring k) (print prio_current) ty_res - | Tvec(ty, e) -> - fprintf ff "@[%a[%a]@]" (print prio_current) ty print_size e - | Tlink(link) -> print prio ff link - end; - if prio_current < prio then fprintf ff ")" - -let print_scheme ff { typ_body = typ } = print 0 ff typ - -let print_type_params ff pl = - print_list_r_empty (fun ff s -> fprintf ff "'%s" s) "("","") " ff pl - -let print_one_type_variable ff i = - fprintf ff "'%s" (type_name#name i) - -(* printing type declarations *) -let print_type_name ff (tc,ta) = match ta with - | [] -> print_qualid ff tc - | [i] -> fprintf ff "%a %a" print_one_type_variable i print_qualid tc - | l -> fprintf ff "(%a)@ %a" - (print_list print_one_type_variable ",") l - print_qualid tc - -(* prints one variant *) -let print_one_variant ff { qualid = qualid; info = constr_desc } = - if constr_desc.constr_arity = 0 - then fprintf ff "@ |@[<3>@ %a@]" print_qualid qualid - else fprintf ff "@ |@[<3>@ %a of@,%a@]" - print_qualid qualid - (print_list_l (print 1) "(" "* " ")") constr_desc.constr_arg - - -(* prints one label *) -let print_one_label ff { qualid = qualid; info = label_desc } = - fprintf ff "@ @[<2>%a:@ %a@]" - print_qualid qualid - (print 0) label_desc.label_res - -let print_type_desc ff = function - | Abstract_type -> () - | Abbrev(_, ty) -> fprintf ff " = %a" (print 2) ty - | Variant_type global_list -> - fprintf ff " = %a" - (print_list_r print_one_variant """""") global_list - | Record_type global_list -> - fprintf ff " = %a" - (print_record print_one_label) global_list - -let print_type_declaration ff { qualid = qualid; info = typ_desc } = - type_name#reset; - fprintf ff "%a @ %a" - print_type_name (qualid, typ_desc.type_parameters) - print_type_desc typ_desc.type_desc - -let print_value_type_declaration ff { qualid = qualid; info = ty_scheme } = - type_name#reset; - fprintf ff "%a :@ %a" print_qualid qualid print_scheme ty_scheme - - -(* the main printing functions *) -let output ff ty = - fprintf ff "%a" (print 0) ty - -let output_size ff si = print_size ff si - -let output_type_declaration ff global_list = - fprintf ff "@[%a@.@]" - (print_list_l print_type_declaration "type ""and """) - global_list - -let output_value_type_declaration ff global_list = - fprintf ff "@[%a@.@]" - (print_list_l print_value_type_declaration "val ""val """) - global_list - - - - diff --git a/compiler/global/scoping.ml b/compiler/global/scoping.ml deleted file mode 100644 index 5a4d8cd6c..000000000 --- a/compiler/global/scoping.ml +++ /dev/null @@ -1,970 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* scoping. introduces unique indexes for local names and replace global *) -(* names by qualified names *) -(* the module checks the following: *) -(* - every pattern and record must be linear *) -(* - name states in automata must be defined once. *) -(* - a local name must be binded to a binded. *) - -open Zmisc -open Zlocation -open Zparsetree -open Zident -open Deftypes -open Format - -module Error = -struct - type error = - | Evar of string - | Enon_linear_pat of string - | Enon_linear_record of string - | Enon_linear_automaton of string - | Enon_linear_forall of string - | Eautomaton_with_mixed_transitions - | Emissing_in_orpat of string - - exception Error of location * error - - let error loc kind = raise (Error(loc, kind)) - - let message loc kind = - begin match kind with - | Evar(name) -> - eprintf "%aScoping error: The value identifier %s is unbound.@." - output_location loc name - | Enon_linear_pat(name) -> - eprintf "%aScoping error: The variable %s is bound several \ - times in this pattern.@." - output_location loc name - | Emissing_in_orpat(name) -> - eprintf - "%aScoping error: The variable %s must occur on both sides of \ - this pattern.@." - output_location loc name - | Enon_linear_record(name) -> - eprintf "%aScoping error: The label %s is defined several times.@." - output_location loc name - | Enon_linear_automaton(name) -> - eprintf - "%aScoping error: the state %s is defined several times in \ - this automaton.@." - output_location loc name - | Enon_linear_forall(name) -> - eprintf - "%aScoping error: The variable %s is bound several times in the loop.@." - output_location loc name - | Eautomaton_with_mixed_transitions -> - eprintf - "%aScoping error: this automaton mixes weak and strong transitions.@." - output_location loc - end; - raise Zmisc.Error -end - -module S = Set.Make (struct type t = string let compare = String.compare end) - -(* set of names defined in an equation. *) -type defnames = S.t - -module Rename = -struct - (* the sort of names *) - type initialized = bool (* [init x = ...] appear *) - - (* the renaming environment associates a fresh name and a sort *) - type value = { name: Zident.t; mutable initialized: initialized } - include (Map.Make (struct type t = string let compare = String.compare end)) - - (* an entry *) - let entry n = { name = n; initialized = false } - - let initialize ({ initialized = s } as v) = v.initialized <- true - - (* flat an environment into a list *) - let list env = - fold (fun key v acc -> (key, v) :: acc) env [] - let print ff env = - List.iter - (fun (key, { name = n; initialized = sort }) -> - fprintf ff "@[%s%s@]" (if sort then "init " else "") key) - (list env) - - (* build a renaming from a set of names *) - let make names = - S.fold - (fun elt acc -> - let n = Zident.fresh elt in add elt (entry n) acc) names empty - - (* append env0 in front of env *) - let append env0 env = fold (fun key v env -> add key v env) env0 env - - (* build a typing environment from a renaming environment *) - (* when [init x = ...] occurs, [x] is considered to be initialized memory *) - let typ_env env = - let init is_init = - if is_init then Deftypes.imemory else Deftypes.variable in - fold - (fun key { name = n; initialized = is_init } acc -> - Env.add n { t_sort = init is_init; t_typ = no_typ } acc) - env Env.empty -end - -(* making a local declaration and a block producing a [result] *) -let emake loc desc = { (Zaux.emake desc no_typ) with Zelus.e_loc = loc } -let eqmake loc desc = { (Zaux.eqmake desc) with Zelus.eq_loc = loc } -let pmake loc desc = { (Zaux.pmake desc no_typ) with Zelus.p_loc = loc } - -let var loc x = emake loc (Zelus.Elocal(x)) -let varpat loc x = pmake loc (Zelus.Evarpat(x)) - -let eblock eq_list = - { Zelus.b_vars = []; Zelus.b_locals = []; Zelus.b_body = eq_list; - Zelus.b_loc = no_location; Zelus.b_write = empty; - Zelus.b_env = Env.empty; } - -let block_with_emit emit ({ Zelus.e_loc = loc } as e) = - { Zelus.b_vars = []; - Zelus.b_locals = []; - Zelus.b_body = [emit e]; - Zelus.b_loc = loc; - Zelus.b_write = empty; - Zelus.b_env = Env.empty; } - -let block_with_result x eq_list = - let loc = (List.hd eq_list).Zelus.eq_loc in - { Zelus.b_vars = [{ Zelus.vardec_name = x; Zelus.vardec_default = None; - Zelus.vardec_combine = None; Zelus.vardec_loc = loc } ]; - Zelus.b_locals = []; Zelus.b_body = eq_list; - Zelus.b_loc = loc; Zelus.b_write = empty; Zelus.b_env = Env.empty } - -let name_with_sort initialize loc env n = - try - let { Rename.name = m } as v = Rename.find n env in - if initialize then v.Rename.initialized <- true; - m - with - | Not_found -> Error.error loc (Error.Evar(n)) - -let name loc env n = name_with_sort false loc env n - -let shortname = function | Name(n) -> n | Modname({ id = id }) -> id - -let longname = function - | Name(n) -> Lident.Name(n) - | Modname({ qual = q; id = id }) -> - Lident.Modname({ Lident.qual = q; Lident.id = id }) - -let immediate = function - | Zparsetree.Eint(i) -> Deftypes.Eint(i) - | Zparsetree.Ebool(b) -> Deftypes.Ebool(b) - | Zparsetree.Efloat(f) -> Deftypes.Efloat(f) - | Zparsetree.Echar(c) -> Deftypes.Echar(c) - | Zparsetree.Estring(s) -> Deftypes.Estring(s) - | Zparsetree.Evoid -> Deftypes.Evoid - -let constant = function - | Zparsetree.Cimmediate(i) -> Deftypes.Cimmediate(immediate i) - | Zparsetree.Cglobal(ln) -> Deftypes.Cglobal(longname ln) - -let default = function - | Zparsetree.Init(c) -> Zelus.Init(constant c) - | Zparsetree.Default(c) -> Zelus.Default(constant c) - -let kind = function - | S -> Zelus.S | A -> Zelus.A | AS -> Zelus.AS - | AD -> Zelus.AD | C -> Zelus.C | D -> Zelus.D - | P -> Zelus.P - -(* translate types. [env] is used to renames dependent variables *) -let rec types env ty = - let desc = match ty.desc with - | Etypevar(n) -> Zelus.Etypevar(n) - | Etypetuple(ty_list) -> Zelus.Etypetuple(List.map (types env) ty_list) - | Etypeconstr(lname, ty_list) -> - Zelus.Etypeconstr(longname lname, List.map (types env) ty_list) - | Etypefun(k, n_opt, ty_arg, ty_res) -> - let ty_arg = types env ty_arg in - let env = - match n_opt with - | None -> env - | Some(n) -> Rename.append (Rename.make (S.singleton n)) env in - let ty_res = types env ty_res in - Zelus.Etypefun(kind k, None, ty_arg, ty_res) - | Etypevec(ty_arg, si) -> Zelus.Etypevec(types env ty_arg, size env si) in - { Zelus.desc = desc; Zelus.loc = ty.loc } - -and size env si = - let desc = match si.desc with - | Sconst(i) -> Zelus.Sconst(i) - | Sname(Name(n)) -> - begin try - let { Rename.name = m } = Rename.find n env in Zelus.Sname(m) - with Not_found -> Zelus.Sglobal(Lident.Name(n)) - end - | Sname(lname) -> Zelus.Sglobal(longname lname) - | Sop(s_op, si1, si2) -> - let operator = function Splus -> Zelus.Splus | Sminus -> Zelus.Sminus in - Zelus.Sop(operator s_op, size env si1, size env si2) in - { Zelus.desc = desc; Zelus.loc = si.loc } - -let operator loc env = function - | Eunarypre -> Zelus.Eunarypre - | Efby -> Zelus.Efby - | Eminusgreater -> Zelus.Eminusgreater - | Eifthenelse -> Zelus.Eifthenelse - | Eup -> Zelus.Eup - | Einitial -> Zelus.Einitial - | Edisc -> Zelus.Edisc - | Etest -> Zelus.Etest - | Eaccess -> Zelus.Eaccess - | Eupdate -> Zelus.Eupdate - | Eslice(s1, s2) -> Zelus.Eslice(size env s1, size env s2) - | Econcat -> Zelus.Econcat - | Eatomic -> Zelus.Eatomic - - -(** Build a renaming environment *) -(** the list of names present in a pattern *) -(** if [check_linear = true], stop when the same name appears twice *) -let rec build check_linear acc p = - let rec build acc p = - match p.desc with - | Ewildpat | Econstpat _ | Econstr0pat _ -> acc - | Econstr1pat(_, p_list) | Etuplepat(p_list) -> - build_list check_linear acc p_list - | Evarpat(n) -> - if S.mem n acc then - if check_linear - then Error.error p.loc (Error.Enon_linear_pat(n)) else acc - else S.add n acc - | Ealiaspat(p, n) -> - let acc = build acc p in S.add n acc - | Eorpat(p1, p2) -> - let orpat loc acc0 acc1 acc = - let one key acc = - if S.mem key acc1 then - if S.mem key acc then - if check_linear - then Error.error loc (Error.Enon_linear_pat(key)) else acc - else S.add key acc - else - Error.error loc (Error.Emissing_in_orpat(key)) in - S.fold one acc0 acc in - let acc1 = build S.empty p1 in - let acc2 = build S.empty p2 in - let acc = orpat p.loc acc1 acc2 acc in acc - | Etypeconstraintpat(p, ty) -> build acc p - | Erecordpat(l_p_list) -> build_record_list p.loc acc l_p_list - - and build_record_list loc acc label_pat_list = - let rec buildrec acc labels label_pat_list = - match label_pat_list with - | [] -> acc - | (lname, pat_label) :: label_pat_list -> - (* checks that the label appears only once *) - let label = shortname lname in - if S.mem label labels - then Error.error loc (Error.Enon_linear_record(label)) - else - buildrec (build acc pat_label) (S.add label labels) - label_pat_list in - buildrec acc S.empty label_pat_list in - - build acc p - -and build_list check_linear acc p_list = - List.fold_left (build check_linear) acc p_list - -(** Builds the set of names defined in a list of equations *) -let rec build_equation_list defnames eq_list = - List.fold_left build_equation defnames eq_list - -and build_equation defnames eq = - match eq.desc with - | EQeq(pat, _) -> build false defnames pat - | EQemit(n, _) | EQder(n, _, _, _) | EQinit(n, _) - | EQnext(n, _, _) | EQpluseq(n, _) -> - if S.mem n defnames then defnames else S.add n defnames - | EQautomaton(s_h_list, _) -> - List.fold_left - (fun acc - { desc = { s_block = b; s_until = until; s_unless = unless } } -> - build_automaton_handler acc b until unless) defnames s_h_list - | EQmatch(_, m_h_list) -> - List.fold_left - (fun acc { m_body = b } -> snd (build_block_equation_list acc b)) - defnames m_h_list - | EQifthenelse(_, b1, b2_opt) -> - let acc = snd (build_block_equation_list defnames b1) in - let acc = - match b2_opt with - | None -> acc | Some(b2) -> snd (build_block_equation_list acc b2) in - acc - | EQpresent(p_h_list, b_opt) -> - let defnames = - List.fold_left - (fun acc { p_body = b } -> snd (build_block_equation_list acc b)) - defnames p_h_list in - Zmisc.optional - (fun defnames b -> snd (build_block_equation_list defnames b)) - defnames b_opt - | EQreset(eq_list, e) -> - build_equation_list defnames eq_list - | EQand(eq_list) | EQbefore(eq_list) -> - build_equation_list defnames eq_list - | EQblock(b) -> - snd (build_block_equation_list defnames b) - | EQforall - { for_indexes = index_list; for_init = init_list; - for_body = b_eq_list } -> - (* check that input names, output names and initialization names *) - (* are pairwise different *) - let index (in_names, out_left, out_right) { desc = desc; loc = loc } = - match desc with - | Einput(n, _) | Eindex(n, _, _) -> - (if (S.mem n in_names) || (S.mem n out_left) - then Error.error loc (Error.Enon_linear_forall(n)) - else S.add n in_names), out_left, out_right - | Eoutput(n, m) -> - (if (S.mem n in_names) || (S.mem n out_left) - then Error.error loc (Error.Enon_linear_forall(n)) - else S.add n in_names), - (if S.mem n out_left - then Error.error loc (Error.Enon_linear_forall(n)) - else S.add n out_left), - (if S.mem m out_right - then Error.error loc (Error.Enon_linear_forall(m)) - else S.add m out_right) in - let in_names, out_left, out_right = - List.fold_left index (S.empty, S.empty, S.empty) index_list in - let init acc { desc = desc; loc = loc } = - match desc with - | Einit_last(n, _) -> - if (S.mem n acc) || (S.mem n in_names) || - (S.mem n out_left) || (S.mem n out_right) - then Error.error loc (Error.Enon_linear_forall(n)) - else S.add n acc in - let defnames = List.fold_left init defnames init_list in - let _, defnames_in_b_eq_list = - build_block_equation_list defnames b_eq_list in - S.union defnames (S.union (S.diff defnames_in_b_eq_list out_left) - out_right) - -and build_block_equation_list defnames - { desc = { b_vars = vardec_list; b_locals = l_list; b_body = eq_list }; - loc = loc } = - (* bounded names [local x1 [init v1| default v1][with op1],...,xn in ...] *) - let bounded_names = - List.fold_left - (fun acc { desc = { vardec_name = n }; loc = loc } -> - if S.mem n acc then Error.error loc (Error.Enon_linear_pat(n)) - else S.add n acc) S.empty vardec_list in - let defnames1 = build_equation_list S.empty eq_list in - bounded_names, S.union defnames (S.diff defnames1 bounded_names) - -and build_automaton_handler defnames b until unless = - let escape defnames { e_block = b_opt } = - Zmisc.optional - (fun defnames b -> - snd (build_block_equation_list defnames b)) defnames b_opt in - let def_in_until = List.fold_left escape S.empty until in - let def_in_unless = List.fold_left escape S.empty unless in - let bounded_names, defnames = build_block_equation_list defnames b in - S.union defnames - (S.union (S.diff def_in_until bounded_names) def_in_unless) - -(** Renaming of a pattern *) -let rec check_pattern env p = - let desc = match p.desc with - | Ewildpat -> Zelus.Ewildpat - | Econstpat(im) -> Zelus.Econstpat(immediate im) - | Econstr0pat(ln) -> Zelus.Econstr0pat(longname ln) - | Econstr1pat(ln, p_list) -> - Zelus.Econstr1pat(longname ln, check_pattern_list env p_list) - | Etuplepat(p_list) -> Zelus.Etuplepat(check_pattern_list env p_list) - | Evarpat(n) -> Zelus.Evarpat(name p.loc env n) - | Ealiaspat(p, n) -> - Zelus.Ealiaspat(check_pattern env p, name p.loc env n) - | Eorpat(p1, p2) -> - Zelus.Eorpat(check_pattern env p1, check_pattern env p2) - | Etypeconstraintpat(p, ty) -> - Zelus.Etypeconstraintpat(check_pattern env p, types env ty) - | Erecordpat(l_p_list) -> - Zelus.Erecordpat - (List.map (fun (lname, p) -> (longname lname, check_pattern env p)) - l_p_list) in - pmake p.loc desc - -and check_pattern_list env p_list = List.map (check_pattern env) p_list - -(* renaming a pattern. Build the renaming environment then rename *) -(* the pattern *) -let pattern env p = - let acc = build true S.empty p in - let env0 = Rename.make acc in - let env = Rename.append env0 env in - env0, env, check_pattern env p - -and pattern_list env p_list = - let acc = build_list true S.empty p_list in - let env0 = Rename.make acc in - let env = Rename.append env0 env in - let p_list = List.map (check_pattern env) p_list in - env0, env, p_list - -(** Two generic functions for control blocks (present/match) *) -let match_handler_list body env_pat env m_h_list = - (* treat one handler *) - let handler { m_pat = p; m_body = b } = - let env_p, env, p = pattern env p in - let b = body env_pat env b in - { Zelus.m_pat = p; Zelus.m_body = b; - Zelus.m_env = Rename.typ_env env_p; - Zelus.m_reset = false; Zelus.m_zero = false } in - List.map handler m_h_list - -let present_handler_list scondpat body env_pat env p_h_list = - (* treat one handler *) - let handler { p_cond = scpat; p_body = b } = - let env_scpat, env, scpat = scondpat env scpat in - let b = body env_pat env b in - { Zelus.p_cond = scpat; Zelus.p_body = b; - Zelus.p_env = Rename.typ_env env_scpat; Zelus.p_zero = false } in - List.map handler p_h_list - -(** Translate automata *) -let state_handler_list - loc scondpat block_body block_in_escape expression env_pat env s_h_list se_opt = - (* build the environment of states and check that states *) - (* are not defined twice *) - let addname acc { desc = { s_state = statepat } } = - match statepat.desc with - | Estate0pat(n) | Estate1pat(n, _) -> - let m = Zident.fresh n in - if Rename.mem n acc then - Error.error statepat.loc (Error.Enon_linear_automaton(n)) - else Rename.add n (Rename.entry m) acc in - let env_for_states = List.fold_left addname Rename.empty s_h_list in - - let statepat env spat = - let env_scpat, env, desc = match spat.desc with - | Estate0pat(n) -> - Rename.empty, env, Zelus.Estate0pat(name spat.loc env_for_states n) - | Estate1pat(n, n_list) -> - let build acc n = - if S.mem n acc then Error.error spat.loc (Error.Enon_linear_pat(n)) - else S.add n acc in - let acc = List.fold_left build S.empty n_list in - let env0 = Rename.make acc in - let n_list = List.map (fun n -> name spat.loc env0 n) n_list in - let env = Rename.append env0 env in - env0, env, Zelus.Estate1pat(name spat.loc env_for_states n, n_list) in - env_scpat, env, { Zelus.desc = desc; Zelus.loc = spat.loc } in - - (* one state expression *) - let state env se = - let desc = match se.desc with - | Estate0(n) -> Zelus.Estate0(name se.loc env_for_states n) - | Estate1(n, e_list) -> Zelus.Estate1(name se.loc env_for_states n, - List.map (expression env) e_list) in - { Zelus.desc = desc; Zelus.loc = se.loc } in - - (* one escape *) - let escape env - { e_cond = scpat; e_reset = r; e_block = b_opt; e_next_state = se } = - let env_scpat, env, scpat = scondpat env scpat in - let env, b_opt = - match b_opt with - | None -> env, None - | Some(b) -> - let env, b = block_in_escape env_pat env b in env, Some(b) in - let se = state env se in - { Zelus.e_cond = scpat; Zelus.e_reset = r; Zelus.e_block = b_opt; - Zelus.e_next_state = se; Zelus.e_env = Rename.typ_env env_scpat; - Zelus.e_zero = false } in - - (* We forbid until and unless transitions to be mixed *) - let is_weak, is_strong = - List.fold_left - (fun (is_weak, is_strong) - { desc = { s_until = until; s_unless = unless } } -> - is_weak || (until <> []), is_strong || (unless <> [])) - (false, false) s_h_list in - if is_weak && is_strong - then Error.error loc (Error.Eautomaton_with_mixed_transitions); - (* treat one handler *) - let handler - { desc = { s_state = spat; s_block = b; - s_until = until; s_unless = unless }; loc = loc } = - let env_spat, env, spat = statepat env spat in - let new_env, b = block_body env_pat env b in - let unless = List.map (escape env) unless in - let until = List.map (escape new_env) until in - { Zelus.s_loc = loc; Zelus.s_state = spat; Zelus.s_body = b; - Zelus.s_trans = until @ unless; - Zelus.s_env = Rename.typ_env env_spat; - Zelus.s_reset = false } in - - (* in case there is no transition, the automaton is weak *) - let is_weak = not is_strong in - is_weak, List.map handler s_h_list, Zmisc.optional_map (state env) se_opt - -let vardec (env_n_m_list, vardec_list) - { desc = { vardec_name = n; vardec_default = d_opt; - vardec_combine = c_opt }; loc = loc } = - let m = Zident.fresh n in - let d_opt = Zmisc.optional_map default d_opt in - let c_opt = Zmisc.optional_map longname c_opt in - let vardec = - { Zelus.vardec_name = m; - Zelus.vardec_default = d_opt; Zelus.vardec_combine = c_opt; - Zelus.vardec_loc = loc } in - Rename.add n (Rename.entry m) env_n_m_list, - vardec :: vardec_list - -(* A block [b] appears in a context of the form [pat -> b] *) -(* [env_pat] is the environment for [pat]; [env] is the global environment *) -let block locals body env_pat env - { desc = { b_vars = vardec_list; b_locals = l_list; b_body = b }; - loc = loc } = - (* hide [vardec_list] in [env_pat] as it is local *) - let env_n_m_list, vardec_list = - List.fold_left vardec (Rename.empty, []) vardec_list in - let env_pat = Rename.append env_n_m_list env_pat in - let env = Rename.append env_n_m_list env in - let vardec_list = List.rev vardec_list in - (* renames local lets *) - let env, l_list = locals env l_list in - let b = body env_pat env b in - env, { Zelus.b_vars = vardec_list; Zelus.b_locals = l_list; Zelus.b_body = b; - Zelus.b_loc = loc; Zelus.b_write = empty; - Zelus.b_env = Rename.typ_env env_n_m_list } - -(** Scoping an expression *) -let rec expression env { desc = desc; loc = loc } = - let desc = match desc with - | Econst(i) -> Zelus.Econst (immediate i) - | Econstr0(lname) -> Zelus.Econstr0(longname lname) - | Evar(Name(n)) -> - begin try - let { Rename.name = m } = Rename.find n env in Zelus.Elocal(m) - with - | Not_found -> Zaux.global (Lident.Name(n)) - end - | Evar(lname) -> Zaux.global (longname lname) - | Elast(n) -> Zelus.Elast(name loc env n) - | Etuple(e_list) -> Zelus.Etuple(List.map (expression env) e_list) - | Econstr1(lname, e_list) -> - Zelus.Econstr1(longname lname, List.map (expression env) e_list) - | Eop(op, e_list) -> - Zelus.Eop(operator loc env op, List.map (expression env) e_list) - | Eapp({ app_inline = i; app_statefull = r }, e, e_list) -> - Zelus.Eapp({ Zelus.app_inline = i; Zelus.app_statefull = r }, - expression env e, List.map (expression env) e_list) - | Erecord(label_e_list) -> - Zelus.Erecord(recordrec loc env label_e_list) - | Erecord_access(e1, lname) -> - Zelus.Erecord_access(expression env e1, longname lname) - | Erecord_with(e, label_e_list) -> - Zelus.Erecord_with(expression env e, recordrec loc env label_e_list) - | Etypeconstraint(e, ty) -> - Zelus.Etypeconstraint(expression env e, types env ty) - | Elet(is_rec, eq_list, e_let) -> - let env_p, env, eq_list = letin is_rec env eq_list in - Zelus.Elet({ Zelus.l_rec = is_rec; - Zelus.l_eq = eq_list; - Zelus.l_loc = loc; - Zelus.l_env = Rename.typ_env env_p }, - expression env e_let) - | Eseq(e1, e2) -> - Zelus.Eseq(expression env e1, expression env e2) - | Eperiod(p) -> - Zelus.Eperiod(period env p) - (* control structures are turned into equations *) - | Ematch(e1, handlers) -> - (* match e with P -> e1 => - local result do match e with P -> do result = e1 done in result *) - let result = Zident.fresh "result" in - let emit e = - eqmake e.Zelus.e_loc (Zelus.EQeq(varpat e.Zelus.e_loc result, e)) in - let e1 = expression env e1 in - let handlers = - match_handler_list - (fun _ env e -> let e = expression env e in block_with_emit emit e) - Rename.empty env handlers in - let eq = eqmake loc (Zelus.EQmatch(ref false, e1, handlers)) in - Zelus.Eblock(block_with_result result [eq], var loc result) - | Epresent(handlers, e_opt) -> - (* Translate a present expression into a present equation *) - (* [present sc1 -> e1 | ... else e] into *) - (* [local res do present sc1 -> do res = e1 done *) - (* |... else do res = e in res]*) - (* [present sc1 -> e1 | ... init e] into *) - (* [local res do present sc1 -> do res = e1 done *) - (* | ...and init res = e in res]*) - (* [present sc1 -> e1 ...] into *) - (* [local res do present sc1 -> do emit res = e1 done] *) - (* [emit e] returns either [emit x = e] or [x = e] according to *) - (* the completeness of the definition. A signal is emitted when the *) - (* present handler is not complete. *) - let result = Zident.fresh "result" in - let emit e = - match e_opt with - | None -> - eqmake e.Zelus.e_loc (Zelus.EQemit(result, Some(e))) - | Some(Init _) - | Some(Default _) -> - eqmake e.Zelus.e_loc - (Zelus.EQeq(varpat e.Zelus.e_loc result, e)) in - let handlers = - present_handler_list - scondpat - (fun _ env e -> let e = expression env e in block_with_emit emit e) - Rename.empty env handlers in - let b_opt, eq_init, is_mem = - match e_opt with - | None -> None, [], false - | Some(Init(e)) -> None, - [eqmake loc (Zelus.EQinit(result, expression env e))], - true - | Some(Default(e)) -> - Some(block_with_emit emit (expression env e)), [], false in - let eq_list = - eqmake loc (Zelus.EQpresent(handlers, b_opt)) :: eq_init in - Zelus.Eblock(block_with_result result eq_list, var loc result) - | Ereset(e_body, r) -> - let e_body = expression env e_body in - let r = expression env r in - let result = Zident.fresh "result" in - let eq = - eqmake e_body.Zelus.e_loc - (Zelus.EQeq(varpat e_body.Zelus.e_loc result, e_body)) in - let eq = eqmake loc (Zelus.EQreset([eq], r)) in - Zelus.Eblock(block_with_result result [eq], var loc result) - | Eautomaton(handlers, e_opt) -> - let result = Zident.fresh "result" in - let emit e = - eqmake e.Zelus.e_loc (Zelus.EQeq(varpat e.Zelus.e_loc result, e)) in - let is_weak, handlers, e_opt = - state_handler_list loc scondpat - (block locals - (fun _ env e -> let e = expression env e in [emit e])) - (block locals equation_list) - expression - Rename.empty env handlers e_opt in - let eq = eqmake loc (Zelus.EQautomaton(is_weak, handlers, e_opt)) in - Zelus.Eblock(block_with_result result [eq], var loc result) - | Eblock(b, e) -> - let env, b = block_eq_list Rename.empty env b in - let e = expression env e in - Zelus.Eblock(b, e) in - emake loc desc - -and recordrec loc env label_e_list = - (* check that a label name appear only once *) - let rec recordrec labels label_e_list = - match label_e_list with - | [] -> [] - | (lname, e) :: label_e_list -> - (* check that labels are all different *) - let label = shortname lname in - if S.mem label labels - then Error.error loc (Error.Enon_linear_record(label)) - else (longname lname, expression env e) :: - recordrec (S.add label labels) label_e_list in - recordrec S.empty label_e_list - -and period env { p_phase = p1; p_period = p2 } = - { Zelus.p_phase = Zmisc.optional_map (expression env) p1; - Zelus.p_period = expression env p2 } - -(* renaming an equation. [env_pat] is used for renamming names *) -(* appearing in patterns while [env] is used for right-hand side expressions *) -and equation env_pat env eq_list { desc = desc; loc = loc } = - match desc with - | EQeq(pat, e) -> - eqmake loc - (Zelus.EQeq(check_pattern env_pat pat, expression env e)) :: eq_list - | EQder(n, e, e0_opt, p_h_e_list) -> - let e = expression env e in - let e0_opt = Zmisc.optional_map (expression env) e0_opt in - let p_h_e_list = - present_handler_exp_list env_pat env p_h_e_list in - let initialized = match e0_opt with | None -> false | Some _ -> true in - let n = name_with_sort initialized loc env_pat n in - eqmake loc (Zelus.EQder(n, e, e0_opt, p_h_e_list)) :: eq_list - | EQinit(n, e0) -> - let n = name_with_sort true loc env_pat n in - let e0 = expression env e0 in - eqmake loc (Zelus.EQinit(n, e0)) :: eq_list - | EQpluseq(n, e) -> - let n = name_with_sort false loc env_pat n in - let e = expression env e in - eqmake loc (Zelus.EQpluseq(n, e)) :: eq_list - | EQnext(n, e, e0_opt) -> - let initialized = match e0_opt with | None -> false | Some _ -> true in - let n = name_with_sort initialized loc env_pat n in - let e = expression env e in - let e0_opt = Zmisc.optional_map (expression env) e0_opt in - eqmake loc (Zelus.EQnext(n, e, e0_opt)) :: eq_list - | EQemit(n, e_opt) -> - eqmake loc - (Zelus.EQemit(name loc env_pat n, - optional_map (expression env) e_opt)) :: eq_list - | EQautomaton(s_h_list, se_opt) -> - let is_weak, s_h_list, st_opt = - state_handler_eq_list loc env_pat env s_h_list se_opt in - eqmake loc (Zelus.EQautomaton(is_weak, s_h_list, st_opt)) :: eq_list - | EQmatch(e, m_h_list) -> - eqmake loc - (Zelus.EQmatch(ref false, expression env e, - match_handler_block_eq_list env_pat env m_h_list)) - :: eq_list - | EQifthenelse(e, b1, b2_opt) -> - let ptrue = - pmake Zlocation.no_location (Zelus.Econstpat(Deftypes.Ebool(true))) in - let pfalse = - pmake Zlocation.no_location (Zelus.Econstpat(Deftypes.Ebool(false))) in - let e = expression env e in - let true_handler = { Zelus.m_pat = ptrue; - Zelus.m_body = snd (block_eq_list env_pat env b1); - Zelus.m_env = Env.empty; - Zelus.m_reset = false; Zelus.m_zero = false } in - let total, handlers = - match b2_opt with - | None -> false, [true_handler] - | Some(b2) -> - let false_handler = - { Zelus.m_pat = pfalse; - Zelus.m_body = snd (block_eq_list env_pat env b2); - Zelus.m_env = Env.empty; - Zelus.m_reset = false; Zelus.m_zero = false } in - true, [true_handler; false_handler] in - eqmake loc (Zelus.EQmatch(ref total, e, handlers)) :: eq_list - | EQpresent(p_h_list, b_opt) -> - let b_opt = - optional_map (fun b -> snd (block_eq_list env_pat env b)) b_opt in - eqmake loc - (Zelus.EQpresent(present_handler_block_eq_list env_pat env p_h_list, - b_opt)) - :: eq_list - | EQreset(eq_r_list, e) -> - eqmake loc - (Zelus.EQreset(equation_list env_pat env eq_r_list, - expression env e)) :: eq_list - | EQand(and_eq_list) -> - eqmake loc - (Zelus.EQand(equation_list env_pat env and_eq_list)) :: eq_list - | EQbefore(before_eq_list) -> - eqmake loc - (Zelus.EQbefore(equation_list env_pat env before_eq_list)) - :: eq_list - | EQblock(b) -> - eqmake loc (Zelus.EQblock(snd (block_eq_list env_pat env b))) :: eq_list - | EQforall - { for_indexes = i_list; for_init = init_list; - for_body = b_eq_forall_list } -> - let build (in_names, out_left, out_right) { desc = desc; loc = loc } = - match desc with - | Einput(n, _) | Eindex(n, _, _) -> S.add n in_names, out_left, out_right - | Eoutput(n, m) -> in_names, S.add n out_left, S.add m out_right in - let in_names, out_left, out_right = - List.fold_left build (S.empty, S.empty, S.empty) i_list in - let env_in_names = Rename.make in_names in - let env_out_left = Rename.make out_left in - let index { desc = desc; loc = loc } = - let desc = match desc with - | Einput(n, e) -> Zelus.Einput(name loc env_in_names n, expression env e) - | Eindex(n, e1, e2) -> - Zelus.Eindex(name loc env_in_names n, - expression env e1, expression env e2) - | Eoutput(n, m) -> - Zelus.Eoutput(name loc env_out_left n, name loc env_pat m) in - { Zelus.desc = desc; Zelus.loc = loc } in - let init { desc = desc; loc = loc } = - let desc = match desc with - | Einit_last(n, e) -> - Zelus.Einit_last(name loc env_pat n, expression env e) in - { Zelus.desc = desc; Zelus.loc = loc } in - let i_list = List.map index i_list in - let init_list = List.map init init_list in - let env_pat = Rename.append env_out_left env_pat in - let env = Rename.append env_in_names (Rename.append env_out_left env) in - let _, b_eq_forall_list = block_eq_list env_pat env b_eq_forall_list in - eqmake loc (Zelus.EQforall - { Zelus.for_index = i_list; Zelus.for_init = init_list; - Zelus.for_body = b_eq_forall_list; - Zelus.for_in_env = Rename.typ_env env_in_names; - Zelus.for_out_env = Rename.typ_env env_out_left; - Zelus.for_loc = loc }) - :: eq_list - -and equation_list env_pat env eq_list = - List.rev (List.fold_left (equation env_pat env) [] eq_list) - -(** Translating a sequence of local declarations *) -and local env { desc = (is_rec, eq_list); loc = loc } = - let env_let, env, eq_list = letin is_rec env eq_list in - env, - { Zelus.l_rec = is_rec; Zelus.l_eq = eq_list; Zelus.l_loc = loc; - Zelus.l_env = Rename.typ_env env_let } - -and locals env l = - match l with - | [] -> env, [] - | lo :: l -> - let env, lo = local env lo in - let env, l = locals env l in - env, lo :: l - -and letin is_rec env eq_list = - let env_let = Rename.make (build_equation_list S.empty eq_list) in - let new_env = Rename.append env_let env in - let env_local = if is_rec then new_env else env in - env_let, new_env, equation_list env_let env_local eq_list - - -(** Translate a present and match when handlers are expressions or equations *) -and present_handler_exp_list env_pat env p_h_e_list = - present_handler_list scondpat - (fun _ env e -> expression env e) env_pat env p_h_e_list - -and present_handler_block_eq_list env_pat env p_h_b_eq_list = - present_handler_list scondpat - (fun env_pat env b -> snd (block_eq_list env_pat env b)) - env_pat env p_h_b_eq_list - -and match_handler_block_eq_list env_pat env m_h_b_eq_list = - match_handler_list - (fun env_pat env b -> snd (block_eq_list env_pat env b)) - env_pat env m_h_b_eq_list - -(** Translate a block when the body is a list of equations *) -and block_eq_list env_pat env b = block locals equation_list env_pat env b - -(** Translate an automaton *) -and state_handler_eq_list loc env_pat env s_h_list se_opt = - state_handler_list loc scondpat - (block locals equation_list) (block locals equation_list) expression - env_pat env s_h_list se_opt - -and scondpat env scpat = - (* first build the set of names *) - let rec build_scondpat acc { desc = desc; loc = loc } = - match desc with - | Econdand(scpat1, scpat2) -> - build_scondpat (build_scondpat acc scpat1) scpat2 - | Econdor(scpat1, scpat2) -> - let orcond loc acc0 acc1 acc = - let one key acc = - if S.mem key acc1 then - if S.mem key acc then - Error.error loc (Error.Enon_linear_pat(key)) - else S.add key acc - else - Error.error loc (Error.Emissing_in_orpat(key)) in - S.fold one acc0 acc in - let acc1 = build_scondpat S.empty scpat1 in - let acc2 = build_scondpat S.empty scpat2 in - let acc = orcond loc acc1 acc2 acc in - acc - | Econdexp _ -> acc - | Econdpat(_, p) -> build true acc p - | Econdon(scpat, _) -> build_scondpat acc scpat in - (* rename *) - let scondpat env_scpat env scpat = - let rec scondpat { desc = desc; loc = loc } = - let desc = match desc with - | Econdand(scpat1, scpat2) -> - Zelus.Econdand(scondpat scpat1, scondpat scpat2) - | Econdor(scpat1, scpat2) -> - Zelus.Econdor(scondpat scpat1, scondpat scpat2) - | Econdexp(e) -> - Zelus.Econdexp(expression env e) - | Econdpat(e, p) -> - Zelus.Econdpat(expression env e, check_pattern env_scpat p) - | Econdon(scpat, e) -> - Zelus.Econdon(scondpat scpat, expression env e) in - { Zelus.desc = desc; Zelus.loc = loc } in - scondpat scpat in - (* first build the environment for pattern variables *) - let acc_scpat = build_scondpat S.empty scpat in - let env_scpat = Rename.make acc_scpat in - (* rename *) - let scpat = scondpat env_scpat env scpat in - let env = Rename.append env_scpat env in - env_scpat, env, scpat - -(* type declarations. *) -let rec type_decl { desc = desc; loc = loc } = - let desc = match desc with - | Eabstract_type -> Zelus.Eabstract_type - | Eabbrev(ty) -> Zelus.Eabbrev(types Rename.empty ty) - | Evariant_type(constr_decl_list) -> - Zelus.Evariant_type(List.map constr_decl constr_decl_list) - | Erecord_type(n_ty_list) -> - Zelus.Erecord_type - (List.map (fun (n, ty) -> (n, types Rename.empty ty)) n_ty_list) in - { Zelus.desc = desc; Zelus.loc = loc } - -and constr_decl { desc = desc; loc = loc } = - let desc = match desc with - | Econstr0decl(n) -> Zelus.Econstr0decl(n) - | Econstr1decl(n, ty_list) -> - Zelus.Econstr1decl(n, List.map (types Rename.empty) ty_list) in - { Zelus.desc = desc; Zelus.loc = loc } - -let type_decls n_params_typdecl_list = - List.map (fun (n, pars, typdecl) -> (n, pars, type_decl typdecl)) - n_params_typdecl_list - -(* main entry functions *) -let implementation imp = - try - let desc = match imp.desc with - | Econstdecl(n, is_static, e) -> - Zelus.Econstdecl(n, is_static, expression Rename.empty e) - | Efundecl(n, { f_kind = k; f_atomic = is_atomic; f_args = p_list; - f_body = e; f_loc = loc }) -> - let _, env, p_list = pattern_list Rename.empty p_list in - Zelus.Efundecl(n, { Zelus.f_kind = kind k; Zelus.f_atomic = is_atomic; - Zelus.f_args = p_list; - Zelus.f_body = expression env e; - Zelus.f_env = Rename.typ_env env; - Zelus.f_loc = loc }) - | Eopen(n) -> Zelus.Eopen(n) - | Etypedecl(n, params, tydecl) -> - Zelus.Etypedecl(n, params, type_decl tydecl) in - { Zelus.desc = desc; Zelus.loc = imp.loc } - with - | Error.Error(loc, err) -> Error.message loc err - -let implementation_list imp_list = Zmisc.iter implementation imp_list - -let interface interf = - try - let desc = match interf.desc with - | Einter_open(n) -> Zelus.Einter_open(n) - | Einter_typedecl(n, params, tydecl) -> - Zelus.Einter_typedecl(n, params, type_decl tydecl) - | Einter_constdecl(n, typ) -> - Zelus.Einter_constdecl(n, types Rename.empty typ) in - { Zelus.desc = desc; Zelus.loc = interf.loc } - with - | Error.Error(loc, err) -> Error.message loc err - -let interface_list inter_list = Zmisc.iter interface inter_list diff --git a/compiler/global/vars.ml b/compiler/global/vars.ml deleted file mode 100644 index 1387abba6..000000000 --- a/compiler/global/vars.ml +++ /dev/null @@ -1,146 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* free variables, defined variables *) - -open Zmisc -open Zident -open Zelus - -(* defined names in an environment *) -let names bounded env = Env.fold (fun n _ bounded -> S.add n bounded) env bounded - -let rec fv_pat bounded acc p = - match p.p_desc with - | Ewildpat | Econstr0pat _ | Econstpat _ -> acc - | Evarpat(x) -> - if (S.mem x acc) || (S.mem x bounded) then acc else S.add x acc - | Econstr1pat(_, pat_list) | Etuplepat(pat_list) -> - List.fold_left (fv_pat bounded) acc pat_list - | Erecordpat(label_pat_list) -> - List.fold_left - (fun acc (_, p) -> fv_pat bounded acc p) acc label_pat_list - | Ealiaspat(p, name) -> - let acc = - if (S.mem name acc) || (S.mem name bounded) - then acc else S.add name acc in - fv_pat bounded acc p - | Eorpat(p1, _) -> fv_pat bounded acc p1 - | Etypeconstraintpat(p, _) -> fv_pat bounded acc p - -let fv_block fv_local fv_body bounded acc - { b_env = b_env; b_locals = l_list; b_body = body; b_write = defnames } = - let bounded = names bounded b_env in - let bounded, acc = List.fold_left fv_local (bounded, acc) l_list in - bounded, fv_body bounded acc body - -let fv_match_handler fv_body m_h_list bounded acc = - List.fold_left - (fun acc { m_pat = pat; m_body = b; m_env = env } -> - fv_body (names bounded env) acc b) - acc m_h_list - -let rec size acc { desc = desc } = - match desc with - | Sconst _ | Sglobal _ -> acc - | Sname(n) -> S.add n acc - | Sop(_, s1, s2) -> size (size acc s1) s2 - -let operator acc = function - | Efby | Eunarypre | Eifthenelse | Etest - | Eminusgreater | Eup | Einitial | Edisc - | Ehorizon | Eaccess | Eupdate | Econcat | Eatomic -> acc - | Eslice(s1, s2) -> size (size acc s1) s2 - -let rec fv bounded (last_acc, acc) e = - match e.e_desc with - | Eop(op, e_list) -> - let last_acc, acc = List.fold_left (fv bounded) (last_acc, acc) e_list in - last_acc, operator acc op - | Econstr1(_, e_list) | Etuple(e_list) -> - List.fold_left (fv bounded) (last_acc, acc) e_list - | Eapp(_, e, e_list) -> - List.fold_left (fv bounded) (fv bounded (last_acc, acc) e) e_list - | Elocal(n) -> - last_acc, if (S.mem n acc) || (S.mem n bounded) then acc else S.add n acc - | Elast(n) -> - (if (S.mem n last_acc) || (S.mem n bounded) - then last_acc else S.add n last_acc), acc - | Erecord_access(e, _) | Etypeconstraint(e, _) -> - fv bounded (last_acc, acc) e - | Erecord(f_e_list) -> - List.fold_left - (fun acc (_, e) -> fv bounded acc e) (last_acc, acc) f_e_list - | Erecord_with(e, f_e_list) -> - let last_acc, acc = fv bounded (last_acc, acc) e in - List.fold_left - (fun acc (_, e) -> fv bounded acc e) (last_acc, acc) f_e_list - | Elet(local, e) -> - let bounded, acc = fv_local (bounded, (last_acc, acc)) local in - fv bounded acc e - | Eblock(b, e) -> - let acc = fv_block_eq_list bounded (last_acc, acc) b in fv bounded acc e - | Eseq(e1, e2) -> fv bounded (fv bounded (last_acc, acc) e1) e2 - | Econst _ | Econstr0 _ | Eglobal _ | Eperiod _ -> last_acc, acc - | Epresent _ | Ematch _ -> assert false - -and fv_eq bounded (last_acc, acc) { eq_desc = desc } = - match desc with - | EQeq(_, e) | EQinit(_, e) | EQpluseq(_, e) -> - fv bounded (last_acc, acc) e - | EQmatch(_, e, m_h_list) -> - fv_match_handler fv_block_eq_list m_h_list bounded - (fv bounded (last_acc, acc) e) - | EQreset(eq_list, r) -> - fv bounded (fv_eq_list bounded (last_acc, acc) eq_list) r - | EQder(_, e, None, []) -> fv bounded (last_acc, acc) e - | EQblock(b) -> fv_block_eq_list bounded (last_acc, acc) b - | EQand(eq_list) - | EQbefore(eq_list) -> fv_eq_list bounded (last_acc, acc) eq_list - | EQforall { for_index = i_list; for_init = init_list; - for_body = b_eq_list } -> - (* read variables from the expression in the list of indexes *) - (* [i in e0 .. e1], [xi in e], [xo out e] *) - let index (last_acc, acc) { desc = desc } = - match desc with - | Einput(_, e) -> fv bounded (last_acc, acc) e - | Eindex(_, e1, e2) -> - fv bounded (fv bounded (last_acc, acc) e1) e2 - | Eoutput _ -> last_acc, acc in - (* read variables from the initialized variables *) - (* last x = e removes last x from the list of read variables *) - let init (bounded, last_acc, acc) { desc = desc } = - match desc with - | Einit_last(x, e) -> - let last_acc, acc = fv bounded (last_acc, acc) e in - (S.add x bounded, last_acc, acc) in - let last_acc, acc = List.fold_left index (last_acc, acc) i_list in - let bounded, last_acc, acc = - List.fold_left init (bounded, last_acc, acc) init_list in - fv_block_eq_list bounded (last_acc, acc) b_eq_list - | EQder _ | EQemit _ | EQpresent _ - | EQautomaton _ | EQnext _ -> assert false - -and fv_eq_list bounded acc eq_list = List.fold_left (fv_eq bounded) acc eq_list - -and fv_local (bounded, acc) { l_eq = eq_list; l_env = l_env } = - let bounded = names bounded l_env in - let acc = List.fold_left (fv_eq bounded) acc eq_list in - (bounded, acc) - -and fv_block_eq_list bounded acc b = - let _, acc = fv_block fv_local fv_eq_list bounded acc b in acc - -let fve acc e = - let acc_last, acc = fv S.empty (S.empty, acc) e in S.union acc_last acc diff --git a/compiler/global/zaux.ml b/compiler/global/zaux.ml deleted file mode 100644 index 36aec7f1f..000000000 --- a/compiler/global/zaux.ml +++ /dev/null @@ -1,230 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* Functions to build expressions *) - -open Zmisc -open Zlocation -open Initial -open Deftypes -open Zelus -open Zident -open Lident - - -let desc e = e.desc -let make x = { desc = x; loc = no_location } - -let prime_app = { app_inline = false; app_statefull = false } - -let emake desc ty = - { e_desc = desc; e_loc = no_location; - e_typ = ty; e_caus = Defcaus.no_typ; e_init = Definit.no_typ } -let pmake desc ty = - { p_desc = desc; p_loc = no_location; - p_typ = ty; p_caus = Defcaus.no_typ; p_init = Definit.no_typ } -let eqmake desc = - { eq_desc = desc; eq_loc = no_location; eq_write = Deftypes.empty; - eq_safe = false; eq_index = -1 } - -let global lname = - Eglobal { lname = lname; typ_instance = Deftypes.no_typ_instance } - -let const c ty = emake (Econst c) ty -let constr0 ln ty = emake (Econstr0 ln) ty -let evoid = const Evoid typ_unit -let efalse = const (Ebool(false)) typ_bool -let etrue = const (Ebool(true)) typ_bool -let truepat = pmake (Econstpat(Ebool(true))) typ_bool -let falsepat = pmake (Econstpat(Ebool(false))) typ_bool -let wildpat = pmake (Ewildpat) Deftypes.no_typ -let zero = emake (Econst(Efloat(0.0))) Initial.typ_float -let one = emake (Econst(Efloat(1.0))) Initial.typ_float -let minus_one = emake (Econst(Efloat(-1.0))) Initial.typ_float -let infinity = - emake (global (Modname(Initial.stdlib_name "infinity"))) typ_float -let tproduct ty_list = Deftypes.make (Tproduct(ty_list)) -let tuplepat pat_list = - let ty_list = List.map (fun { p_typ = ty } -> ty) pat_list in - pmake (Etuplepat(pat_list)) (tproduct ty_list) -let tuple e_list = - let ty_list = List.map (fun { e_typ = ty } -> ty) e_list in - emake (Etuple(e_list)) (tproduct ty_list) -let record l_list e_list ty = - emake (Erecord(List.map2 (fun l e -> (l, e)) l_list e_list)) ty - -let rec orpat pat_list = - match pat_list with - | [] -> assert false - | [pat] -> pat - | pat :: pat_list -> pmake (Eorpat(pat, orpat pat_list)) pat.p_typ - -let varpat name ty = pmake (Evarpat(name)) ty -let var name ty = emake (Elocal(name)) ty - -let pair e1 e2 = emake (Etuple([e1; e2])) (tproduct [e1.e_typ; e2.e_typ]) -let pairpat p1 p2 = pmake (Etuplepat([p1; p2])) (tproduct [p1.p_typ; p2.p_typ]) - -let patalias p n ty = pmake (Ealiaspat(p, n)) ty -let last x ty = emake (Elast(x)) ty -let float v = emake (Econst(Efloat(v))) Initial.typ_float -let bool v = emake (Econst(Ebool(v))) Initial.typ_bool - -let float_varpat x = varpat x Initial.typ_float -let bool_varpat x = varpat x Initial.typ_bool -let float_var x = var x Initial.typ_float -let bool_var x = var x Initial.typ_bool - -let float_last x = last x Initial.typ_float -let bool_last x = last x Initial.typ_bool - -let global_in_stdlib lname ty = - emake (global (Modname(Initial.stdlib_name lname))) ty - -let maketype ty_arg_list ty_res = - let make ty = { t_desc = ty; t_level = generic; t_index = symbol#name } in - make (Tfun(Tany, None, make (Tproduct(ty_arg_list)), ty_res)) - -let rec funtype ty_arg_list ty_res = - let make ty = { t_desc = ty; t_level = generic; t_index = symbol#name } in - match ty_arg_list with - | [] -> ty_res - | ty_arg :: ty_arg_list -> - make (Tfun(Tany, None, ty_arg, funtype ty_arg_list ty_res)) - -let unop op e ty = - emake (Eapp(prime_app, - global_in_stdlib op (maketype [e.e_typ] ty), [e])) ty -let binop op e1 e2 ty = - emake (Eapp(prime_app, - global_in_stdlib op (maketype [e1.e_typ; e2.e_typ] ty), - [e1;e2])) ty - -let plus e1 e2 = binop "+." e1 e2 Initial.typ_float -let minus e1 e2 = binop "-." e1 e2 Initial.typ_float -let diff e1 e2 = binop "<>" e1 e2 Initial.typ_bool -let or_op e1 e2 = binop "||" e1 e2 Initial.typ_bool -let and_op e1 e2 = binop "&&" e1 e2 Initial.typ_bool -let on_op e1 e2 = binop "on" e1 e2 Initial.typ_zero -let min_op e1 e2 = binop "min" e1 e2 Initial.typ_float -let greater_or_equal e1 e2 = binop ">=" e1 e2 Initial.typ_bool -let greater e1 e2 = binop ">" e1 e2 Initial.typ_bool -let up e = emake (Eop(Eup, [e])) Initial.typ_zero -let pre e = emake (Eop(Eunarypre, [e])) e.e_typ -let minusgreater e1 e2 = emake (Eop(Eminusgreater, [e1;e2])) e1.e_typ -let fby e1 e2 = emake (Eop(Efby, [e1;e2])) e1.e_typ -let ifthenelse e1 e2 e3 = - emake (Eop(Eifthenelse, [e1;e2;e3])) e2.e_typ -let sgn e = - ifthenelse (greater e zero) one minus_one -let record_access e l ty = emake (Erecord_access(e, l)) ty - -let extend_local env eq_list ({ l_eq = l_eq_list; l_env = l_env } as l) = - { l with l_eq = eq_list @ l_eq_list; l_env = Env.append env l_env } -let make_local env eq_list = - extend_local env eq_list - { l_rec = true; l_eq = []; - l_env = Env.empty; l_loc = Zlocation.no_location } -let make_let env eq_list e = - match eq_list with - | [] -> e | _ -> emake (Elet(make_local env eq_list, e)) e.e_typ - -let vardec i = - { vardec_name = i; vardec_default = None; - vardec_combine = None; vardec_loc = no_location } - -let vardec_from_entry i { t_sort = sort } = - let d_opt, c_opt = - match sort with - | Sstatic -> None, None - | Sval -> None, None - | Svar { v_default = None; v_combine = c_opt } - | Smem { m_init = (Noinit | InitEq); m_combine = c_opt } -> - None, c_opt - | Smem { m_init = InitDecl(c); m_combine = c_opt } -> - Some(Init(c)), c_opt - | Svar { v_default = Some(c); v_combine = c_opt } -> - Some(Default(c)), c_opt in - { vardec_name = i; vardec_default = d_opt; - vardec_combine = c_opt; vardec_loc = no_location } - -let extend_block env eq_list - ({ b_vars = b_vars; b_env = b_env; b_body = body_eq_list } as b) = - let b_vars = - Env.fold (fun i entry acc -> vardec_from_entry i entry :: acc) - env b_vars in - { b with b_vars = b_vars; b_body = eq_list @ body_eq_list; - b_env = Env.append env b_env } - -let make_block env eq_list = - extend_block env eq_list - { b_vars = []; b_env = Env.empty; b_locals = []; - b_body = []; b_loc = Zlocation.no_location; b_write = Deftypes.empty } - -let eq_make n e = eqmake (EQeq(varpat n e.e_typ, e)) -let eq_next n e = eqmake (EQnext(n, e, None)) -let eq_init n e = eqmake (EQinit(n, e)) -let pluseq_make n e = eqmake (EQpluseq(n, e)) - -let eq_reset eq_list e = eqmake (EQreset(eq_list, e)) -let eq_match e l = eqmake (EQmatch(ref true, e, l)) -let eq_block b = eqmake (EQblock(b)) -let eq_der x e = eqmake (EQder(x, e, None, [])) - - -let handler p b = - { m_pat = p; m_body = b; m_env = Env.empty; - m_reset = false; m_zero = false } - -let eq_ifthenelse e b1 b2 = - eq_match e [handler truepat b1; handler falsepat b2] - -let eq_ifthen e b = eqmake (EQmatch(ref false, e, [handler truepat b])) - -let before eq_list = - match eq_list with - | [] -> assert false - | [eq] -> eq - | _ -> eqmake (EQbefore(eq_list)) -let par eq_list = - match eq_list with - | [] -> assert false - | [eq] -> eq - | _ -> eqmake (EQand(eq_list)) - -let init i eq_list = (eq_init i etrue) :: (eq_make i efalse) :: eq_list - -(* find the major step in the current environment *) -(* If it already exist in the environment *) -(* returns it. Otherwise, create one *) -let new_major env = - let m = Zident.fresh "major" in - let env = - Env.add m { t_sort = Deftypes.major (); t_typ = Initial.typ_bool } env in - let major = var m Initial.typ_bool in - env, major - -let major env = - let exception Return of Zelus.exp in - let find x t = - match t with - | { t_sort = Smem { m_kind = Some(Major) }; t_typ = typ } -> - raise (Return(var x typ)) - | _ -> () in - try - Env.iter find env; - new_major env - with - | Return(x) -> env, x - diff --git a/compiler/global/zelus.ml b/compiler/global/zelus.ml deleted file mode 100644 index 7ba3f9f1f..000000000 --- a/compiler/global/zelus.ml +++ /dev/null @@ -1,304 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* Abstract syntax tree after scoping *) - -open Zlocation -open Zmisc - -type kind = S | A | C | D | AD | AS | P -type name = string - -type 'a localized = { desc: 'a; loc: Zlocation.location } - - -(** Types *) -type type_expression = type_expression_desc localized - -and type_expression_desc = - | Etypevar of string - | Etypeconstr of Lident.t * type_expression list - | Etypetuple of type_expression list - | Etypevec of type_expression * size - | Etypefun of kind * Zident.t option * type_expression * type_expression - -and size = size_desc localized - -and size_desc = - | Sconst of int - | Sglobal of Lident.t - | Sname of Zident.t - | Sop of size_op * size * size - -and size_op = Splus | Sminus - -(** Declarations and expressions *) -type interface = interface_desc localized - -and interface_desc = - | Einter_open of name - | Einter_typedecl of name * name list * type_decl - | Einter_constdecl of name * type_expression - -and type_decl = type_decl_desc localized - -and type_decl_desc = - | Eabstract_type - | Eabbrev of type_expression - | Evariant_type of constr_decl list - | Erecord_type of (name * type_expression) list - -and constr_decl = constr_decl_desc localized - -and constr_decl_desc = - | Econstr0decl of name - | Econstr1decl of name * type_expression list - -and implementation = implementation_desc localized - -and implementation_desc = - | Eopen of name - | Etypedecl of name * name list * type_decl - | Econstdecl of name * is_static * exp - | Efundecl of name * funexp - -and funexp = - { f_kind: kind; - f_atomic: is_atomic; - f_args: pattern list; - f_body: exp; - mutable f_env: Deftypes.tentry Zident.Env.t; - f_loc: location } - -and is_atomic = bool - -and is_static = bool - -and exp = - { mutable e_desc: desc; (* descriptor *) - e_loc: location; (* location in the source code *) - mutable e_typ: Deftypes.typ; (* its type *) - mutable e_caus: Defcaus.tc; (* its causality type *) - mutable e_init: Definit.ti; (* its initialization type *) - } - -and desc = - | Elocal of Zident.t - | Eglobal of { lname : Lident.t; typ_instance : Deftypes.typ_instance } - | Econst of immediate - | Econstr0 of Lident.t - | Econstr1 of Lident.t * exp list - | Elast of Zident.t - | Eapp of app * exp * exp list - | Eop of op * exp list - | Etuple of exp list - | Erecord_access of exp * Lident.t - | Erecord of (Lident.t * exp) list - | Erecord_with of exp * (Lident.t * exp) list - | Etypeconstraint of exp * type_expression - | Epresent of exp present_handler list * exp option - | Ematch of total ref * exp * exp match_handler list - | Elet of local * exp - | Eseq of exp * exp - | Eperiod of exp period - | Eblock of eq list block * exp - -and is_rec = bool - -and op = - | Efby | Eunarypre (* unit delay *) - | Eifthenelse (* mux *) - | Eminusgreater (* initialization *) - | Eup (* zero-crossing detection *) - | Einitial (* true at the very first instant *) - | Edisc (* discontinuity of a flow *) - | Ehorizon (* generate an event at a given horizon *) - | Etest (* test the present of a signal *) - | Eaccess (* access in an array: e.(e2) *) - | Eupdate (* array update: [| e1 with i = e2 |] *) - | Eslice of size * size (* array slice: e{s0..s1} *) - | Econcat (* array concatenation: [| t{0..42} | t'{2..25} |] *) - | Eatomic (* force its argument to be atomic *) - -and immediate = Deftypes.immediate - -and app = { app_inline: bool; app_statefull: bool} - -(* a period is of the form period(v1) or period(v1|v2) where v1 is the phase *) -(* v1 and v2 two static expressions. v1 and v2 of type float. *) -(* E.g., period (0.2|3.4) *) -and 'a period = - { p_phase: 'a option; (* the two expressions must be static *) - p_period: 'a } - -and pattern = - { mutable p_desc: pdesc; (* its descriptor *) - p_loc: location; (* where it is in the source code *) - mutable p_typ: Deftypes.typ; (* its type *) - mutable p_caus: Defcaus.tc; (* its causality type *) - mutable p_init: Definit.ti; (* its initialization type *) - } - -and pdesc = - | Ewildpat - | Econstpat of immediate - | Econstr0pat of Lident.t - | Econstr1pat of Lident.t * pattern list - | Etuplepat of pattern list - | Evarpat of Zident.t - | Ealiaspat of pattern * Zident.t - | Eorpat of pattern * pattern - | Erecordpat of (Lident.t * pattern) list - | Etypeconstraintpat of pattern * type_expression - -and eq = - { eq_desc: eqdesc; (* its descriptor *) - eq_loc: location; (* its location in the source file *) - eq_index: int; (* a unique index; used to build a partial order *) - eq_safe: bool; (* does it have a side effect *) - mutable eq_write: Deftypes.defnames; (* the set of names it defines *) } - -and eqdesc = - | EQeq of pattern * exp - (* [p = e] *) - | EQder of Zident.t * exp * exp option * exp present_handler list - (* [der n = e [init e0] [reset p1 -> e1 | ... | pn -> en]] *) - | EQinit of Zident.t * exp - (* [init n = e0 *) - | EQnext of Zident.t * exp * exp option - (* [next n = e] *) - | EQpluseq of Zident.t * exp - (* [n += e] *) - | EQautomaton of is_weak * state_handler list * state_exp option - | EQpresent of eq list block present_handler list * eq list block option - | EQmatch of total ref * exp * eq list block match_handler list - | EQreset of eq list * exp - | EQemit of Zident.t * exp option - | EQblock of eq list block - | EQand of eq list (* eq1 and ... and eqn *) - | EQbefore of eq list (* eq1 before ... before eqn *) - | EQforall of forall_handler (* forall i in ... do ... initialize ... done *) - -and total = bool - -and is_next = bool - -and is_weak = bool - -and 'a block = - { b_vars: vardec list; - b_locals: local list; - b_body: 'a; - b_loc: location; - mutable b_env: Deftypes.tentry Zident.Env.t; - mutable b_write: Deftypes.defnames } - -and vardec = - { vardec_name: Zident.t; (* its name *) - vardec_default: Deftypes.constant default option; - (* either an initial or a default value *) - vardec_combine: Lident.t option; (* an optional combination function *) - vardec_loc: location; - } - -and 'a default = - | Init of 'a | Default of 'a - - -and local = - { l_rec: is_rec; (* is-it recursive *) - l_eq: eq list; (* the set of parallel equations *) - mutable l_env: Deftypes.tentry Zident.Env.t; - l_loc: location } - -and state_handler = - { s_loc: location; - s_state: statepat; - s_body: eq list block; - s_trans: escape list; - mutable s_env: Deftypes.tentry Zident.Env.t; - mutable s_reset: bool } - -and statepat = statepatdesc localized - -and statepatdesc = - | Estate0pat of Zident.t - | Estate1pat of Zident.t * Zident.t list - -and state_exp = state_exdesc localized - -and state_exdesc = - | Estate0 of Zident.t - | Estate1 of Zident.t * exp list - -and escape = - { e_cond: scondpat; - e_reset: bool; - e_block: eq list block option; - e_next_state: state_exp; - mutable e_env: Deftypes.tentry Zident.Env.t; - mutable e_zero: bool } - -and scondpat = scondpat_desc localized - -and scondpat_desc = - | Econdand of scondpat * scondpat - | Econdor of scondpat * scondpat - | Econdexp of exp - | Econdpat of exp * pattern - | Econdon of scondpat * exp - -and 'a match_handler = - { m_pat: pattern; - m_body: 'a; - mutable m_env: Deftypes.tentry Zident.Env.t; - m_reset: bool; (* the handler is reset on entry *) - mutable m_zero: bool; (* the handler is done at a zero-crossing instant *) - } - -(* the body of a present handler *) -and 'a present_handler = - { p_cond: scondpat; - p_body: 'a; - mutable p_env: Deftypes.tentry Zident.Env.t; - mutable p_zero: bool } - -(* the body of a for loop *) -(* for(all|seq) [id in e..e | id in e[at id] | id out id]+ - * local id [and id]* - * do eq and ... and eq - * [init - * [[id = e with g] | [last id = e]] - * [and [[id = e with g] | [last id = e]]]* - * done *) -and forall_handler = - { for_index: indexes_desc localized list; - for_init: init_desc localized list; - for_body: eq list block; - mutable for_in_env: Deftypes.tentry Zident.Env.t; - (* def names from [id in e | id in e1..e2] *) - mutable for_out_env: Deftypes.tentry Zident.Env.t; - (* def (left) names from [id out id'] *) - for_loc: location } - -and indexes_desc = - | Einput of Zident.t * exp (* xi in t_input *) - | Eoutput of Zident.t * Zident.t (* xi out t_output *) - | Eindex of Zident.t * exp * exp (* i in e1 .. e2 *) - -and init_desc = - | Einit_last of Zident.t * exp - - - diff --git a/compiler/global/zident.ml b/compiler/global/zident.ml deleted file mode 100644 index 77c46a1ba..000000000 --- a/compiler/global/zident.ml +++ /dev/null @@ -1,89 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* naming and local environment *) - -type t = - { num : int; (* a unique index *) - source : string; (* the original name in the source *) - } - -and element_t = - { arrnm : string; (* global array name *) - index : t; (* index into the array*) - } - -type t_alias = t - -let compare id1 id2 = compare id1.num id2.num - -let name id = id.source ^ "_" ^ (string_of_int id.num) - -let source id = id.source - -let num = ref 0 -let fresh s = num := !num + 1; { num = !num; source = s } - -let fprint_t ff id = Format.fprintf ff "%s" (name id) - -module M = struct - type t = t_alias - let compare = compare - let fprint = fprint_t -end - -module Env = -struct - include (Map.Make(M)) - - let singleton i tentry = add i tentry empty - - let fprint_t fprint_v ff s = - Format.fprintf ff "@[{@ "; - iter (fun k v -> Format.fprintf ff "@[%a: %a@]" M.fprint k fprint_v v) s; - Format.fprintf ff "}@]" - - (* debugging printer for (Zident.t * Zident.t * Zident.t) Zident.Env.t *) - let fprint_3ident ff s = - let fprint_v ff (id1, id2, id3) = - Format.fprintf ff "@[%a@]" - (Pp_tools.print_list_r M.fprint "("","")") [id1; id2; id3] in - fprint_t fprint_v ff s - - (* let append env0 env = fold add env0 env *) - let append env0 env = - fold (fun x v acc -> update x (function _ -> Some(v)) acc) - env0 env -end - -module S = struct - include (Set.Make(M)) - let fprint_t ff s = - Format.fprintf ff "@[{@ "; - iter (fun e -> Format.fprintf ff "%a@ " M.fprint e) s; - Format.fprintf ff "}@]" - - let fresh s ss = - let add_fresh id m = Env.add id (fresh s) m in - fold add_fresh ss Env.empty - - let domain acc env = - Env.fold (fun k _ set -> add k set) env acc - - let range acc env = - Env.fold (fun _ v set -> add v set) env acc - - let map f s = fold (fun e rs -> add (f e) rs) s empty -end - diff --git a/compiler/global/zlocation.ml b/compiler/global/zlocation.ml deleted file mode 100644 index a123e0a3a..000000000 --- a/compiler/global/zlocation.ml +++ /dev/null @@ -1,151 +0,0 @@ -(* Printing a location in the source program *) -(* taken from the source of the Caml Light 0.73 compiler *) - - -open Format - -(* two important global variables: [input_name] and [input_chan] *) -type location = - Loc of int (* Position of the first character *) - * int (* Position of the next character following the last one *) - - - -let input_name = ref "" (* Input file name. *) - -let input_chan = ref stdin - -let initialize iname = - input_name := iname; - input_chan := open_in iname - - -let no_location = Loc(0,0) - - -let error_prompt = ">" - -let output_lines ff char1 char2 charline1 line1 line2 = - let n1 = char1 - charline1 - and n2 = char2 - charline1 in - if line2 > line1 then - fprintf ff - ", line %d-%d, characters %d-%d:\n" line1 line2 n1 n2 - else - fprintf ff ", line %d, characters %d-%d:\n" line1 n1 n2; - () - - -let output_loc ff input seek line_flag (Loc(pos1, pos2)) = - let pr_chars n c = - for i = 1 to n do pp_print_char ff c done in - let skip_line () = - try - while input() != '\n' do () done - with End_of_file -> () in - let copy_line () = - let c = ref ' ' in - begin try - while c := input(); !c != '\n' do pp_print_char ff !c done - with End_of_file -> - pp_print_string ff "" - end; - pp_print_char ff '\n' in - let pr_line first len ch = - let c = ref ' ' - and f = ref first - and l = ref len in - try - while c := input (); !c != '\n' do - if !f > 0 then begin - f := !f - 1; - pp_print_char ff (if !c == '\t' then !c else ' ') - end - else if !l > 0 then begin - l := !l - 1; - pp_print_char ff (if !c == '\t' then !c else ch) - end - else () - done - with End_of_file -> - if !f = 0 && !l > 0 then pr_chars 5 ch in - let pos = ref 0 - and line1 = ref 1 - and line1_pos = ref 0 - and line2 = ref 1 - and line2_pos = ref 0 in - seek 0; - begin try - while !pos < pos1 do - incr pos; - if input() == '\n' then begin incr line1; line1_pos := !pos; () end - done - with End_of_file -> () - end; - line2 := !line1; - line2_pos := !line1_pos; - begin try - while !pos < pos2 do - incr pos; - if input() == '\n' then - begin incr line2; line2_pos := !pos; () end - done - with End_of_file -> () - end; - if line_flag then output_lines ff pos1 pos2 !line1_pos !line1 !line2; - if !line1 == !line2 then begin - seek !line1_pos; - pp_print_string ff error_prompt; - copy_line (); - seek !line1_pos; - pp_print_string ff error_prompt; - pr_line (pos1 - !line1_pos) (pos2 - pos1) '^'; - pp_print_char ff '\n' - end else begin - seek !line1_pos; - pp_print_string ff error_prompt; - pr_line 0 (pos1 - !line1_pos) '.'; - seek pos1; - copy_line(); - if !line2 - !line1 <= 8 then - for i = !line1 + 1 to !line2 - 1 do - pp_print_string ff error_prompt; - copy_line() - done - else - begin - for i = !line1 + 1 to !line1 + 3 do - pp_print_string ff error_prompt; - copy_line() - done; - pp_print_string ff error_prompt; pp_print_string ff "..........\n"; - for i = !line1 + 4 to !line2 - 4 do skip_line() done; - for i = !line2 - 3 to !line2 - 1 do - pp_print_string ff error_prompt; - copy_line() - done - end; - begin try - pp_print_string ff error_prompt; - for i = !line2_pos to pos2 - 1 do - pp_print_char ff (input()) - done; - pr_line 0 100 '.' - with End_of_file -> pp_print_string ff "" - end; - pp_print_char ff '\n' - end - - -let output_location ff loc = - let p = pos_in !input_chan in - fprintf ff "File \"%s\"" !input_name; - output_loc - ff (fun () -> input_char !input_chan) (seek_in !input_chan) true - loc; - seek_in !input_chan p - - -let output_input_name ff = - fprintf ff "File \"%s\", line 1:\n" !input_name - diff --git a/compiler/global/zmisc.ml b/compiler/global/zmisc.ml deleted file mode 100644 index 8a4bc9651..000000000 --- a/compiler/global/zmisc.ml +++ /dev/null @@ -1,286 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* useful stuff *) - -let header_in_file = - let open Zconfig in - "The Zelus compiler, version " ^ version ^ "-" ^subversion ^ "\n\ (" ^ date ^ ")" - -(* generic data-structres for sets and symbol tables *) -module S = Set.Make (struct type t = string let compare = compare end) -module Env = Map.Make (struct type t = string let compare = compare end) - - -(* standard module *) -let name_of_stdlib_module = "Stdlib" - -let standard_lib = Zconfig.stdlib - -(* list of modules initially opened *) -let default_used_modules = ref [name_of_stdlib_module] - -(* load paths *) -let load_path = ref ([standard_lib]) - -let set_stdlib p = - load_path := [p] - -(* where is the standard library *) -let locate_stdlib () = - Printf.printf "%s\n" standard_lib - -let show_version () = - let open Zconfig in - Printf.printf "The Zelus compiler, version %s-%s (%s)\n" - version subversion date; - Printf.printf "Std lib: "; locate_stdlib (); - Printf.printf "\n"; - () - -(* sets the main simulation node *) -let simulation_node = ref None -let set_simulation_node (n:string) = simulation_node := Some(n) - -(* sets the output filepath *) -let outname = ref None -let set_outname (n:string) = outname := Some(n) - -(* sets the output filepath for nodes *) -let node_outname = ref None -let set_node_outname (n:string) = node_outname := Some(n) - -(* sets the checking flag *) -let number_of_checks = ref 0 -let set_check (n: int) = number_of_checks := n - -(* sampling the main loop on a real timer *) -let sampling_period = ref 0.0 -let set_sampling_period p = sampling_period := p - -(* level of inlining *) -let inlining_level = ref 10 -let set_inlining_level l = inlining_level := l -let inline_all = ref false - -(* turn on the discrete zero-crossing detection *) -let dzero = ref false - -(* other options of the compiler *) -let verbose = ref false -let vverbose = ref false -let print_types = ref false -let print_causality_types = ref false -let print_initialization_types = ref false -let typeonly = ref false -let use_gtk = ref false -let no_stdlib = ref false -let no_causality = ref false -let no_initialisation = ref false -let no_opt = ref false -let no_deadcode = ref false -let no_simplify_causality_type = ref false -let no_reduce = ref false -let no_warning = ref false -let zsign = ref false -let with_copy = ref false -let use_rif = ref false -let build_deps = ref false - -let lmm_nodes = ref S.empty -let set_lmm_nodes (n: string) = - lmm_nodes := S.add n !lmm_nodes - -(* variable creation *) -(* generating names *) -class name_generator = - object - val mutable counter = 0 - method name = - counter <- counter + 1; - counter - method reset = - counter <- 0 - method init i = - counter <- i - end - -let symbol = new name_generator - -(* association table with memoization *) -class name_assoc_table f = - object - val mutable counter = 0 - val mutable assoc_table: (int * string) list = [] - method name var = - try - List.assq var assoc_table - with - not_found -> - let n = f counter in - counter <- counter + 1; - assoc_table <- (var,n) :: assoc_table; - n - method reset = - counter <- 0; - assoc_table <- [] - end - -(* converting integers into variable names *) -(* variables are printed 'a, 'b *) -let int_to_letter bound i = - if i < 26 - then String.make 1 (Char.chr (i+bound)) - else String.make 1 (Char.chr ((i mod 26) + bound)) ^ string_of_int (i/26) - -let int_to_alpha i = int_to_letter 97 i - -(* generic and non generic variables in the various type systems *) -let generic = -1 -let notgeneric = 0 -let maxlevel = max_int - -let binding_level = ref 0 -let top_binding_level () = !binding_level = 0 - -let push_binding_level () = binding_level := !binding_level + 1 -let pop_binding_level () = - binding_level := !binding_level - 1; - assert (!binding_level > generic) -let reset_binding_level () = binding_level := 0 - -(* general iterators and functions *) -let optional f acc = function - | None -> acc - | Some x -> f acc x - -let optional_unit f acc = function - | None -> () - | Some x -> f acc x - -let optional_map f = function - | None -> None - | Some(x) -> Some(f x) - -let optional_with_map f acc = function - | None -> None, acc - | Some(x) -> let x, acc = f acc x in Some(x), acc - -let optional_get = function - | Some x -> x - | None -> assert false - -let rec iter f = function - | [] -> [] - | x :: l -> let y = f x in y :: iter f l - -let fold f l = List.rev (List.fold_left f [] l) - -let from i = - let rec fromrec acc i = - match i with - | 0 -> acc - | _ -> fromrec ( i :: acc) (i - 1) in - fromrec [] i - -let map_fold f acc l = - let rec maprec acc = function - | [] -> [], acc - | x :: l -> - let y, acc = f acc x in - let l, acc = maprec acc l in - y :: l, acc in - maprec acc l - -(* takes the first patterns of the list, except the last one *) -let rec firsts = function - | [] -> assert false - | [p] -> [], p - | p :: l -> let head, tail = firsts l in p :: head, tail - -(** The data-structure to represent a state *) -module State = - struct - type 'a t = (* ' *) - | Empty - | Cons of 'a * 'a t - | Par of 'a t * 'a t - | Seq of 'a t * 'a t - let singleton x = Cons(x, Empty) - let cons x s = Cons(x, s) - let seq s1 s2 = - match s1, s2 with - | (Empty, s) | (s, Empty) -> s - | _ -> Seq(s1, s2) - let par s1 s2 = - match s1, s2 with - | (Empty, s) | (s, Empty) -> s - | _ -> Par(s1, s2) - let empty = Empty - let is_empty s = (s = empty) - let rec fold f s acc = match s with - | Empty -> acc - | Cons(x, l) -> f x (fold f l acc) - | Par(l1, l2) -> fold f l1 (fold f l2 acc) - | Seq(l1, l2) -> fold f l1 (fold f l2 acc) - let list acc s = fold (fun l ls -> l :: ls) s acc - - let cons_list xs s = List.fold_left (fun s x -> Cons (x, s)) s (List.rev xs) - - let rec map f s = match s with - | Empty -> Empty - | Cons(x, l) -> Cons(f x, map f l) - | Par(l1, l2) -> Par(map f l1, map f l2) - | Seq(l1, l2) -> Seq(map f l1, map f l2) - - let rec iter f s = match s with - | Empty -> () - | Cons(x, l) -> (f x; iter f l) - | Par(l1, l2) | Seq(l1, l2) -> (iter f l1; iter f l2) - - let rec partition f s = - match s with - | Empty -> Empty, Empty - | Cons(x, l) -> - let left, right = partition f l in - if f x then Cons(x, left), right else left, Cons(x, right) - | Par(l1, l2) -> - let left1, right1 = partition f l1 in - let left2, right2 = partition f l2 in - Par(left1, left2), Par(right1, right2) - | Seq(l1, l2) -> - let left1, right1 = partition f l1 in - let left2, right2 = partition f l2 in - Seq(left1, left2), Seq(right1, right2) - - let fprint_t fprint_v ff s = - let rec print ff s = - match s with - | Empty -> Format.fprintf ff "{}" - | Cons(x, s) -> - Format.fprintf ff "@[Cons(%a,@ %a)@]" fprint_v x print s - | Par(s1, s2) -> - Format.fprintf ff "@[Par(%a,@ %a)@]" print s1 print s2 - | Seq(s1, s2) -> - Format.fprintf ff "@[Seq(%a,@ %a)@]" print s1 print s2 in - Format.fprintf ff "@[%a@]" print s - end - -(* error during the whole process *) -exception Error - -(* Internal error in the compiler. *) -let internal_error message printer input = - Format.eprintf "@[Internal error (%s)@. %a@.@]" message printer input; - raise Error diff --git a/compiler/main/compiler.ml b/compiler/main/compiler.ml deleted file mode 100644 index 2169ecaf7..000000000 --- a/compiler/main/compiler.ml +++ /dev/null @@ -1,286 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(** The compiler *) -open Zlocation -open Zmisc -open Global -open Zelus -open Format - -let lexical_error err loc = - eprintf "%aIllegal character.@." output_location loc; - raise Error - -let syntax_error loc = - eprintf "%aSyntax error.@." output_location loc; - raise Error - -let parse parsing_fun lexing_fun source_name = - let ic = open_in source_name in - let lexbuf = Lexing.from_channel ic in - lexbuf.Lexing.lex_curr_p <- - { lexbuf.Lexing.lex_curr_p with Lexing.pos_fname = source_name }; - try - parsing_fun lexing_fun lexbuf - with - | Zlexer.Lexical_error(err, loc) -> - close_in ic; lexical_error err loc - | Zparser.Error -> - close_in ic; - syntax_error - (Loc(Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) - -let parse_implementation_file source_name = - parse Zparser.implementation_file Zlexer.main source_name - -let parse_interface_file source_name = - parse Zparser.interface_file Zlexer.main source_name - -let parse_scalar_interface_file source_name = - parse Zparser.scalar_interface_file Zlexer.main source_name - -let compile_interface parse modname filename suffix = - (* input and outputs *) - let source_name = filename ^ suffix - and obj_interf_name = filename ^ ".zci" in - let itc = open_out_bin obj_interf_name in - let info_ff = Format.formatter_of_out_channel stdout in - pp_set_max_boxes info_ff max_int; - - let close_all_files () = - close_out itc in - - try - Modules.initialize modname; - Zlocation.initialize source_name; - - (* Parsing of the file *) - let l = parse source_name in - (* Scoping *) - let l = Scoping.interface_list l in - Interface.interface_list info_ff l; - (* Write the symbol table into the interface file *) - Modules.write itc; - close_all_files () - with - | x -> close_all_files (); raise x - -(* compiling a scalar interface *) -let scalar_interface modname filename = - compile_interface parse_scalar_interface_file modname filename ".mli" - -(* compiling a Zelus interface *) -let interface modname filename = - compile_interface parse_interface_file modname filename ".zli" - -let apply_with_close_out f o = - try - f o; - close_out o - with x -> close_out o; raise x - -(** The main function for compiling a program *) -let compile modname filename = - (* input and output files *) - let source_name = filename ^ ".zls" - and obj_interf_name = filename ^ ".zci" - and ml_name = filename ^ ".ml" - and lmm_name = filename ^ ".lmm" in - - (* standard output for printing types and clocks *) - let info_ff = Format.formatter_of_out_channel stdout in - pp_set_max_boxes info_ff max_int; - - let write_implementation_list obc_list mlc = - let mlc_ff = Format.formatter_of_out_channel mlc in - pp_set_max_boxes mlc_ff max_int; - Ocamlprinter.implementation_list mlc_ff obc_list in - - let write_lmm_list impl_list lmmc = - let lmm_ff = Format.formatter_of_out_channel lmmc in - pp_set_max_boxes lmm_ff max_int; - Plmm.implementation_list lmm_ff impl_list in - - Modules.initialize modname; - Zlocation.initialize source_name; - - let comment c = - let sep = - "----------------------------------------------------------------------------"in - fprintf info_ff "%s@\n%s@\n%s@." sep c sep in - - (* execute a rewrite step *) - let step com step impl_list = - let impl_list = step impl_list in - if !verbose then - begin comment com; Printer.implementation_list info_ff impl_list end; - impl_list in - - (* Parsing of the file *) - let impl_list = parse_implementation_file source_name in - if !verbose then comment "Parsing done. See below:"; - - let impl_list = - step "Scoping done. See below:" Scoping.implementation_list impl_list in - let impl_list = - step "Typing done." (Typing.implementation_list info_ff true) impl_list in - let impl_list = - if not !no_causality - then step "Causality check done" - (Causality.implementation_list info_ff) impl_list - else impl_list in - let impl_list = - if not !no_initialisation - then step "Initialization check done" - (Initialization.implementation_list info_ff) impl_list - else impl_list in - if not !typeonly then - begin - (* continue if [typeonly = false] *) - (* Start of source-to-source translation *) - let impl_list = - step "Mark functions calls to be inlined. See below:" - Markfunctions.implementation_list impl_list in - let impl_list = - step "Reduce static expressions for global values \ - that have no more static parameter. See below:" - (Reduce.implementation_list info_ff) impl_list in - let impl_list = - step "Inlining of annotated and small function calls. See below:" - Inline.implementation_list impl_list in - let impl_list = - step "Re-typing done. See below:" - (Typing.implementation_list info_ff false) impl_list in - let impl_list = - step "Remove last in pattern. See below:" - Remove_last_in_patterns.implementation_list impl_list in - let impl_list = - step "Add a copy for [last x] to remore false cycles. See below:" - Add_copy_for_last.implementation_list impl_list in - let impl_list = - step "Translation of automata done. See below:" - Automata.implementation_list impl_list in - let impl_list = - step "Translation of activations done. See below:" - Activate.implementation_list impl_list in - let impl_list = - step "Translation of present done. See below:" - Present.implementation_list impl_list in - let impl_list = - step "Translation of periods done. See below:" - Period.implementation_list impl_list in - let impl_list = - step "Translation of disc done. See below:" - Disc.implementation_list impl_list in - let impl_list = - step "Translation of probabilistic nodes. See below:" - Proba.implementation_list impl_list in - let impl_list = - step - "Compilation of memories (fby/pre/next) into (init/last). See below:" - Pre.implementation_list impl_list in - let impl_list = - step "Un-nest let/in blocks. See below:" - Letin.implementation_list impl_list in - let impl_list = - step "Compilation of initialization and resets done. See below:" - Reset.implementation_list impl_list in - let impl_list = - step "Actualize write variables in blocks. See below:" - Write.implementation_list impl_list in - let impl_list = - step "Complete equations with [der x = 0.0]. See below:" - Complete.implementation_list impl_list in - let impl_list = - step "Add an extra discrete step for weak transitions. See below:" - Encore.implementation_list impl_list in - let impl_list = - step "Gather all horizons into a single one per function. See below:" - Horizon.implementation_list impl_list in - let impl_list = - step "Translation into A-normal form. See below:" - Aform.implementation_list impl_list in - let impl_list = - step "Actualize write variables in blocks. See below:" - Write.implementation_list impl_list in - let impl_list = - step "Naming shared variables and memories done. See below:" - Shared.implementation_list impl_list in - let impl_list = - step "Common sub-expression elimination. See below:" - Cse.implementation_list impl_list in - let impl_list = - step "Sharing of zero-crossings. See below:" - Zopt.implementation_list impl_list in - let impl_list = - step "Actualize write variables in blocks. See below:" - Write.implementation_list impl_list in - let impl_list = - if not !no_opt && not !no_deadcode - then step "Deadcode removal. See below:" - Zdeadcode.implementation_list impl_list - else impl_list in - let impl_list = - step "Static scheduling done. See below:" - Schedule.implementation_list impl_list in - let impl_list = - if not !no_opt && not !no_deadcode - then - let impl_list = - step "Removing of copy variables done. See below:" - Copy.implementation_list impl_list in - step "Deadcode removal. See below:" - Zdeadcode.implementation_list impl_list - else impl_list in - (* start of translation into sequential code *) - let obc_list = - Translate.implementation_list impl_list in - if !verbose - then begin - comment "Translation done. See below:"; - Oprinter.implementation_list info_ff obc_list - end; - let obc_list = Inout.implementation_list obc_list in - if !verbose - then begin - comment "Add code to read/write continuous states and zero-crossings \ - vectors. See below:"; - Oprinter.implementation_list info_ff obc_list - end; - (* print OCaml code *) - if !verbose - then begin - comment "Print OCaml code. See below:"; - Ocamlprinter.implementation_list info_ff obc_list - end; - (* write OCaml code in the appropriate file *) - let mlc = open_out ml_name in - apply_with_close_out (write_implementation_list obc_list) mlc; - (* Write the symbol table into the interface file *) - let itc = open_out_bin obj_interf_name in - apply_with_close_out Modules.write itc; - - (* translate into L-- if asked for *) - if Zmisc.S.is_empty !Zmisc.lmm_nodes then () - else - let impl_list = - step "Rewrite of pattern matchings into primitive ones done. See below:" - Match2condition.implementation_list impl_list in - let lmm_list = - Zlus2lmm.implementation_list !Zmisc.lmm_nodes impl_list in - if lmm_list <> [] then - let lmm = open_out lmm_name in - apply_with_close_out (write_lmm_list lmm_list) lmm - end diff --git a/compiler/main/fixstep.ml b/compiler/main/fixstep.ml deleted file mode 100644 index 0df296975..000000000 --- a/compiler/main/fixstep.ml +++ /dev/null @@ -1,25 +0,0 @@ -(* Fix step simulation with a Euler 0 method *) -(* Only used for debugging *) - -(* Euler 0 *) -let euler f step n_lastx n_upz = - let lastx = Array.make n_lastx 0.0 in - let dx = Array.make n_lastx 0.0 in - let pre_upz = Array.make n_upz 0.0 in - let upz = Array.make n_upz 0.0 in - let z = Array.make n_upz false in - let ok = ref false in - while true do - f lastx dx upz z; - ok := false; - for i = 0 to n_upz do - z.(i) <- (pre_upz.(i) < 0.0) && (upz.(i) >= 0.0); - ok := !ok || z.(i); - pre_upz.(i) <- upz.(i) - done; - if !ok then () - else - for i = 0 to n_lastx do - lastx.(i) <- lastx.(i) +. dx.(i) *. step - done - done diff --git a/compiler/main/simulator.ml b/compiler/main/simulator.ml deleted file mode 100644 index fe11184a5..000000000 --- a/compiler/main/simulator.ml +++ /dev/null @@ -1,450 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* glue code for simulating a main node *) -open Deftypes -open Global -open Format -open Zmisc - -(* - Generating a main .ml file in order to simulate a node. - - - in sampling mode, the simulated node should be of type - [unit -> unit] - - otherwise, generates an instantiated transition function *) - -(* check if [name] is defined *) -let find name = - try - Modules.find_value (Lident.Name(name)) - with - | Not_found -> - eprintf "The name %s is unbound.@." name; - raise Zmisc.Error - -(* the main node must be of type [expected_ty_arg_list] and the result of *) -(* type [expected_ty_res_list] *) -let check_type_of_main_node name - { qualid = qualid; info = { value_typ = tys } } - opt_name expected_ty_arg expected_ty_res = - let actual_ty = Ztypes.instance_of_type tys in - let actual_k, opt_name, actual_ty_arg, actual_ty_res = - try - Ztypes.filter_actual_arrow actual_ty - with - | _ -> eprintf "@[The name %s must define a function.@.@]" name; - raise Zmisc.Error in - let expected_k = - match actual_k with | Tproba -> Tdiscrete(true) | _ -> actual_k in - let expected_ty = - Ztypes.funtype expected_k opt_name actual_ty_arg actual_ty_res in - try - Ztypes.unify expected_ty actual_ty; qualid, expected_k - with - | Ztypes.Unify -> - eprintf "@[The name %s has type@ %a,@ \ - but is expected to have type@ %a.@.@]" - name - Ptypes.output actual_ty - Ptypes.output expected_ty; - raise Zmisc.Error - -(* the main node must be of type [unit -> unit] *) -(* in case of sampled simulation *) -let check_unit_unit name info = - check_type_of_main_node name info None Initial.typ_unit Initial.typ_unit - -(* the main node must be of type [unit -> bool] in case of bounded testing *) -let check_unit_bool name info = - check_type_of_main_node name info None Initial.typ_unit Initial.typ_bool - -let rec is_unit ty = - match ty.t_desc with - | Tlink ty -> is_unit ty - | Tconstr (id, _, _) -> id.id = "unit" - | _ -> false - -let allowed_types = Initial.(Lident.(List.map (fun qualid -> qualid.id) - [int_ident; bool_ident; float_ident; unit_ident])) -let unit_id = Initial.unit_ident.Lident.id - -let rec check_simple_ty ty = - match ty.t_desc with - | Tvar -> - eprintf "Undefined type variables are not supported by Luciole.@."; - raise Zmisc.Error - | Tfun _ -> - eprintf "Higher order functions are not supported by Luciole.@."; - raise Zmisc.Error - | Tvec _ -> - eprintf "Vectors are not supported by Luciole.@."; - raise Zmisc.Error - | Tproduct ty -> List.iter check_simple_ty ty - | Tconstr (id, _, _) -> - if List.mem id.id allowed_types then () else begin - eprintf "Type %s is not allowed.@." id.id; - raise Zmisc.Error - end - | Tlink ty -> check_simple_ty ty - -let rec flatten ty = - match ty.t_desc with - | Tproduct ty -> List.concat (List.map flatten ty) - | Tconstr (id, _, _) -> [id.id] - | Tlink ty -> flatten ty - | Tvar | Tfun _ | Tvec _ -> assert false - -let rec flatten_patt patt = - match patt.Zelus.p_desc with - | Etuplepat p_l -> List.concat (List.map flatten_patt p_l) - | Ealiaspat (p, id) -> flatten_patt p - | Evarpat id -> [id.source] - | Etypeconstraintpat (p, _) -> flatten_patt p - | Econstpat Evoid -> ["unit"] - | Econstr0pat _ | Econstr1pat _ | Ewildpat | Econstpat _ | Eorpat _ - | Erecordpat _ -> assert false - -let print_string_of_ty ff ty = - Format.fprintf ff "string_of_%s" ty - -let print_ty_of_string ff ty = - Format.fprintf ff "%s_of_string" ty - -let rec type_size ty = - match ty.t_desc with - | Tproduct ty -> - List.fold_left ( + ) 0 (List.map type_size ty) - | Tconstr (_, _, _) -> 1 - | Tlink ty -> type_size ty - | Tvec _ | Tfun _ | Tvar -> assert false - -let format_names names ty = - let rec aux i0 ty = - match ty.t_desc with - | Tproduct ty -> Printf.sprintf "(%s)" (aux_list i0 ty) - | Tconstr (id, _, _) -> - if id.id = unit_id then "()" else names.(i0) - | Tlink ty -> aux i0 ty - | Tvar | Tfun _ | Tvec _ -> assert false - and aux_list i0 ty_list = - match ty_list with - | [] -> assert false - | ty :: q -> - let names1 = aux i0 ty in - let ofst1 = type_size ty in - let (_, names) = - List.fold_left (fun (ofst, names) ty -> - let names = Printf.sprintf "%s, %s" names (aux (i0 + ofst) ty) in - let ofst = ofst + (type_size ty) in - (ofst, names)) (ofst1, names1) q - in names - in aux 0 ty - -let emit_open ff open_list = - List.iter (fprintf ff "@[%s@]@.") open_list - -let emit_discrete_main k ff name = - match k with - | Deftypes.Tstatic _ | Deftypes.Tany | Deftypes.Tdiscrete(false) -> - fprintf ff - "@[@[(* simulation (any) function *)@]@;\ - @[let main x = %s x@]@]" name - | Deftypes.Tdiscrete(true) -> - fprintf ff - "@[@[(* simulation (discrete) function *)@]@;\ - @[@[let main =@]@;\ - @[let open Ztypes in@]@;\ - @[let %s { alloc = alloc; step = step; reset = reset } = %s in@]@;\ - @[let mem = alloc () in@]@;\ - @[reset mem;@]@;\ - @[(fun x -> step mem x)@]@]@]" - (if !Zmisc.with_copy then "Cnode" else "Node") name - | Deftypes.Tcont | Deftypes.Tproba -> assert false - -let emit_prelude ff ({ Lident.id = id } as qualid) info k = - (* the prelude *) - let s = Lident.qualidname qualid in - match k with - | Deftypes.Tstatic _ | Deftypes.Tany | Deftypes.Tdiscrete(false) - | Deftypes.Tdiscrete(true) -> - if !use_rif then begin - let ({ typ_vars; typ_body } as scheme) = info.info.value_typ in - let t1, t2, inp_patt = - begin match typ_body.t_desc with - | Tfun (_, _, t1, t2) -> - begin match info.info.value_code.value_exp with - | Global.Vfun (fexp, _) -> - let inp_patt = List.hd fexp.f_args in - t1, t2, inp_patt - | _ -> assert false - end - | _ -> assert false - end - in - check_simple_ty t1; - check_simple_ty t2; - - let flat_t1 = flatten t1 in - let flat_t2 = flatten t2 in - - let inp_names = - List.map2 (fun name ty -> if ty = unit_id then "_" else name) - (flatten_patt inp_patt) flat_t1 in - let out_names = List.mapi (fun i ty -> if ty = unit_id then "_" else "o" ^ (string_of_int i)) flat_t2 in - - let filtered_inp_names = - List.filter_map (fun n -> if n = "_" then None else Some n) inp_names - in - let filtered_out_names = - List.filter_map (fun n -> if n = "_" then None else Some n) out_names - in - - let formatted_inp_names = format_names (Array.of_list inp_names) t1 in - let formatted_out_names = format_names (Array.of_list out_names) t2 in - - let inp_pragma = - Printf.sprintf "#inputs %s" - (String.concat " " - (List.map2 (fun id ty_id -> - if ty_id <> unit_id then - Printf.sprintf "\\\"%s\\\":%s" id ty_id - else "") - inp_names flat_t1)) - in - let out_pragma = - Printf.sprintf "#outputs %s" - (String.concat "" - (List.map2 (fun id ty_id -> - if ty_id <> unit_id then - Printf.sprintf "\\\"%s\\\":%s " id ty_id - else "") - out_names flat_t2)) - in - fprintf ff - "@[@[let main =@]@;\ - @[%a@;@[in@]@]@;\ - @;\ - @[@[let bool_of_string s =@]@;@[s = \"T\" || s = \"t\"@]@;@[in@]@]@;\ - @;\ - @[@[let string_of_bool b =@]@;@[if b then \"T\" else \"F\"@]@;@[in@]@]@;\ - @;\ - @[@[let header =@]@;\ - @[@[\"# File produced by Luciole_zls\\n\\@]@;\ - @[# Node: %s\\n\\@]@;\ - @[%s\\n\\@]@;\ - @[%s\"@]@]@,\ - @[in@]@]@;\ - @;\ - @[let step_no = ref 1 in@]@;\ - @;\ - @[Printf.printf \"%%s\\n\" header; flush stdout;@]@;\ - @[@[(fun () ->@]@;\ - @[Printf.printf \"#step %%d\\n\" !step_no; flush stdout;@]@;\ - @[let inputs = input_line stdin in@]@;\ - %a\ - %a\ - @[let %s = main %s in@]@;\ - %a\ - @[Printf.printf \"%s\\n\" %s; flush stdout;@]@;\ - @[step_no := !step_no + 1@])@]@;\ - @];;@]@." - (emit_discrete_main k) s - s inp_pragma out_pragma - (fun ff _ -> - if List.length filtered_inp_names = 0 then () else - fprintf ff "@[let [%s] = String.split_on_char ' ' (String.trim inputs) in@]@;" - (String.concat "; " filtered_inp_names)) () - (fun ff (inps, tys) -> - List.iter2 - (fun inp ty -> - if ty <> unit_id then - Format.fprintf ff "@[let %s = %a %s in@]@;" - inp print_ty_of_string ty inp) - inps tys) (inp_names, flat_t1) - formatted_out_names formatted_inp_names - (fun ff (inps, tys) -> - List.iter2 - (fun inp ty -> - if ty <> unit_id then - Format.fprintf ff "@[let %s = %a %s in@]@;" - inp print_string_of_ty ty inp) - inps tys) (out_names, flat_t2) - (String.concat " " (List.map (fun _ -> "%s") filtered_out_names)) - (String.concat " " (List.filter_map (fun n -> if n = "_" then None else Some n) out_names)); - end else - fprintf ff "@[%a;;@]@." (emit_discrete_main k) s - | Deftypes.Tcont -> - if !use_rif then begin - eprintf "Cannot use option -rif with hybrid main node.@."; - raise Zmisc.Error - end else - fprintf ff - "@[@[open Ztypes@]@;\ - @[open Zls@]@;\ - @;\ - @[(* simulation (continuous) function *)@.\ - @[let main = @,\ - @[\ - @[let cstate = @,\ - @[{ dvec = cmake 0; cvec = cmake 0; @,\ - zinvec = zmake 0; zoutvec = cmake 0; @,\ - cindex = 0; zindex = 0; @,\ - cend = 0; zend = 0; @,\ - cmax = 0; zmax = 0; @,\ - major = false; horizon = 0.0 }@] in@] @,\ - @[let %s \ - { alloc = alloc; step = hstep; reset = reset } = \ - %s cstate in@] @,\ - @[let step mem cvec dvec zin t = @,\ - @[cstate.major <- true; @,\ - cstate.cvec <- cvec; @,\ - cstate.dvec <- dvec; @,\ - cstate.cindex <- 0; @,\ - cstate.zindex <- 0; @,\ - cstate.horizon <- infinity; @,\ - hstep mem (t, ()) in@]@]@,\ - @[let derivative mem cvec dvec zin zout t = @,\ - @[cstate.major <- false; @,\ - cstate.cvec <- cvec; @,\ - cstate.dvec <- dvec; @,\ - cstate.zinvec <- zin; @,\ - cstate.zoutvec <- zout; @,\ - cstate.cindex <- 0; @,\ - cstate.zindex <- 0; @,\ - ignore (hstep mem (t, ())) in@]@]@,\ - @[let crossings mem cvec zin zout t = @ \ - @[cstate.major <- false; @,\ - cstate.cvec <- cvec; @,\ - cstate.zinvec <- zin; @,\ - cstate.zoutvec <- zout; @,\ - cstate.cindex <- 0; @,\ - cstate.zindex <- 0; @,\ - ignore (hstep mem (t, ())) in@]@]@,\ - @[let maxsize mem = cstate.cmax, cstate.zmax in@]@,\ - @[let csize mem = cstate.cend in@]@,\ - @[let zsize mem = cstate.zend in@]@,\ - @[let horizon mem = cstate.horizon in@]@,\ - @[Hsim @[{ alloc;@ step;@ reset;@ derivative; @,\ - crossings; @,\ - maxsize; @ csize; @ zsize; @,\ - horizon }@]@]@];;@]@.@]@]" - (if !Zmisc.with_copy then "Cnode" else "Node") s - | Tproba -> assert false - -(* emited code for control-driven programs: the transition function *) -(* is executed at full speed *) -let emit_simulation_code ff k = - match k with - | Deftypes.Tstatic _ | Deftypes.Tany | Deftypes.Tdiscrete _ -> - fprintf ff - "@[(* (discrete) simulation loop *)\n\ - while true do main () done;\n\ - exit(0);;@.@]" - | Deftypes.Tcont -> - fprintf ff "@[(* instantiate a numeric solver *)\n\ - module Runtime = Zlsrun.Make (Defaultsolver)\n\ - let _ = Runtime.go main@.@]" - | Deftypes.Tproba -> assert false - -(* emited code for bounded checking. Check that the function returns [true] *) -(* during [n] steps *) -let emit_checked_code ff k n = - match k with - | Deftypes.Tstatic _ | Deftypes.Tany | Deftypes.Tdiscrete _ -> - fprintf ff - "@[(* (discrete) simulation loop *) - let ok = ref true in - for i = 0 to %d - 1 do - let r = main () in - if not r then begin - print_string (\"error(\" ^ (string_of_int i) ^ \")\\n\"); - exit(2) - end - else ok := r - done; - exit(0)@.@]" n - - | Deftypes.Tcont -> - fprintf ff "@[(* instantiate a numeric solver *)\n\ - module Runtime = Zlsrun.Make (Defaultsolver)\n\ - let _ = Runtime.check main %d@.@]" n - | Deftypes.Tproba -> assert false - -let emit_gtkmain_code ff k sampling = - match k with - | Deftypes.Tstatic _ | Deftypes.Tany | Deftypes.Tdiscrete _ -> - fprintf ff - "@[(* simulation loop: sampled on period %f Hz *)\n@.@]" sampling; - fprintf ff "@[(* instantiate the discrete interface *)\n\ - module Runtime = Zlsrungtk.MakeDiscrete ()\n\ - let _ = Runtime.go %f main@.@]" sampling - | Deftypes.Tcont -> - fprintf ff "@[(* instantiate a numeric solver *)\n\ - module Runtime = Zlsrungtk.Make (Defaultsolver)\n\ - let _ = Runtime.go main@.@]" - | Deftypes.Tproba -> assert false - -(* emited code for event-driven programs: the transition function *) -(* is executed every [1/sampling] seconds *) -let emit_periodic_code ff k sampling = - match k with - | Deftypes.Tstatic _ | Deftypes.Tany - | Deftypes.Tdiscrete _ -> - fprintf ff - "@[(* simulation loop: sampled on period %f *)\n\ - (* compiles with -custom unix.cma *)@.@]" sampling; - fprintf ff - "@[let periodic() = - let _x = Unix.setitimer Unix.ITIMER_REAL - {Unix.it_interval = %f ; Unix.it_value = 1.0 } - in Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ -> main ())); - while true do Unix.sleep 1 done;; - periodic();exit(0)@.@]" sampling - | Deftypes.Tcont -> - fprintf ff "@[(* instantiate a numeric solver *) - let _ = Zlsrun.go main@.@]" - | Deftypes.Tproba -> assert false - -(** The main entry function. Simulation of a main function *) -let main outname name sampling number_of_checks use_gtk = - (* - open the module where main occurs - - makes a module of that name - - instanciate main inside it - - compile it *) - let outname = match outname with None -> name | Some s -> s in - let filename = outname ^ ".ml" in - let info = find name in - let qualid, k = - if number_of_checks > 0 then check_unit_bool name info - else check_unit_unit name info in - let oc = open_out filename in - let ff = Format.formatter_of_out_channel oc in - emit_prelude ff qualid info k; - if number_of_checks > 0 then - if sampling <> 0.0 then - begin - eprintf "Do not use -sampling when checking node %s.@." name; - raise Zmisc.Error - end - else - emit_checked_code ff k number_of_checks - else - if sampling < 0.0 then - eprintf "Do not use -sampling with a negative argument.@." - else if use_gtk then emit_gtkmain_code ff k 1. - else - if sampling = 0.0 then emit_simulation_code ff k - else emit_periodic_code ff k sampling; - close_out oc diff --git a/compiler/main/zeluc.ml b/compiler/main/zeluc.ml deleted file mode 100644 index 16cdbeb36..000000000 --- a/compiler/main/zeluc.ml +++ /dev/null @@ -1,165 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* the main *) -open Zmisc -open Initial -open Compiler - -let compile file = - Modules.clear(); - if !no_stdlib then set_no_stdlib(); - if Filename.check_suffix file ".zls" || Filename.check_suffix file ".zlus" - then - let filename = Filename.chop_extension file in - let modname = String.capitalize_ascii (Filename.basename filename) in - compile modname filename - else if Filename.check_suffix file ".zli" - then - let filename = Filename.chop_suffix file ".zli" in - let modname = String.capitalize_ascii (Filename.basename filename) in - interface modname filename - else if Filename.check_suffix file ".mli" - then - let filename = Filename.chop_suffix file ".mli" in - let modname = String.capitalize_ascii (Filename.basename filename) in - scalar_interface modname filename - else - raise (Arg.Bad ("don't know what to do with " ^ file)) - -module SS = Zdepend.StringSet -let build file = - Deps_tools.add_to_load_path Filename.current_dir_name; - let rec _build acc file = - let deps = - match (Filename.extension file) with - | ".zls" -> Deps_tools.zls_dependencies file - | ".zli" -> Deps_tools.zli_dependencies file - | _ -> raise (Arg.Bad ("don't know what to do with " ^ file)) - in - let acc = List.fold_left _build acc deps in - let basename = Filename.chop_extension file in - if not (SS.mem basename acc) then begin - compile file; - SS.add basename acc - end else - acc - in - ignore (_build (SS.empty) file) - -let doc_verbose = "\t Set verbose mode" -let doc_vverbose = "\t Set even more verbose mode" -and doc_version = "\t The version of the compiler" -and doc_outname = " \t Simulation file name " -and doc_print_types = "\t Print types" -and doc_print_causality_types = "\t Print causality types" -and doc_print_initialization_types = "\t Print initialization types" -and doc_include = " \t Add to the list of include directories" -and doc_stdlib = " \t Directory for the standard library" -and doc_locate_stdlib = "\t Locate standard libray" -and doc_no_stdlib = "\t Do not load the stdlib module" -and doc_no_zlstdlib = "\t Do not load the zlstdlib module" -and doc_typeonly = "\t Stop after typing" -and doc_hybrid = "\t Select hybrid translation" -and doc_simulation = - " \t Simulates the node and generates a file .ml\n\ - \t\t where is equal to the argument of -o if the flag\n\ - \t\t has been set, or otherwise" -and doc_sampling = "

\t Sets the sampling period to p (float <= 1.0)" -and doc_check = " \t Check that the simulated node returns true for n steps" -and doc_use_gtk = - "\t Use lablgtk2 interface." -and doc_inlining_level = " \t Level of inlining" -and doc_inline_all = "\t Inline all function calls" -and doc_dzero = "\t Turn on discrete zero-crossing detection" -and doc_nocausality = "\t (undocumented)" -and doc_no_opt = "\t (undocumented)" -and doc_no_deadcode = "\t (undocumented)" -and doc_noinitialisation = "\t (undocumented)" -and doc_nosimplify = "\t (undocumented)" -and doc_noreduce = "\t (undocumented)" -and doc_lmm = "\t Translate the node into Lustre--" -and doc_red_name = "\t Static reduction for" -and doc_zsign = "\t Use the sign function for the zero-crossing argument" -and doc_with_copy = "\t Add of a copy method for the state" -and doc_rif = "\t Use RIF format over stdin and stdout to communicate I/O to the node being simulated" -and doc_deps = "\t Recursively compile dependencies" -let errmsg = "Options are:" - -let set_verbose () = - verbose := true; - Printexc.record_backtrace true - -let set_vverbose () = - vverbose := true; - set_verbose () - -let add_include d = - Deps_tools.add_to_load_path d; - load_path := d :: !load_path - -let set_gtk () = - use_gtk := true; - match !load_path with - | [stdlib] -> add_include (stdlib ^ "-gtk") - | _ -> () - -let main () = - try - Arg.parse - (Arg.align [ - "-v", Arg.Unit set_verbose, doc_verbose; - "-vv", Arg.Unit set_vverbose, doc_vverbose; - "-version", Arg.Unit show_version, doc_version; - "-o", Arg.String set_outname, doc_outname; - "-I", Arg.String add_include, doc_include; - "-i", Arg.Set print_types, doc_print_types; - "-ic", Arg.Set print_causality_types, doc_print_causality_types; - "-ii", Arg.Set print_initialization_types, doc_print_initialization_types; - "-where", Arg.Unit locate_stdlib, doc_locate_stdlib; - "-stdlib", Arg.String set_stdlib, doc_stdlib; - "-nostdlib", Arg.Set no_stdlib, doc_no_stdlib; - "-typeonly", Arg.Set typeonly, doc_typeonly; - "-s", Arg.String set_simulation_node, doc_simulation; - "-sampling", Arg.Float set_sampling_period, doc_sampling; - "-check", Arg.Int set_check, doc_check; - "-gtk2", Arg.Unit set_gtk, doc_use_gtk; - "-dzero", Arg.Set dzero, doc_dzero; - "-nocausality", Arg.Set no_causality, doc_nocausality; - "-nopt", Arg.Set no_opt, doc_no_opt; - "-nodeadcode", Arg.Set no_deadcode, doc_no_deadcode; - "-noinit", Arg.Set no_initialisation, doc_noinitialisation; - "-inline", Arg.Int set_inlining_level, doc_inlining_level; - "-inlineall", Arg.Set inline_all, doc_inline_all; - "-nosimplify", Arg.Set no_simplify_causality_type, doc_nosimplify; - "-noreduce", Arg.Set no_reduce, doc_noreduce; - "-zsign", Arg.Set zsign, doc_zsign; - "-copy", Arg.Set with_copy, doc_with_copy; - "-lmm", Arg.String set_lmm_nodes, doc_lmm; - "-rif", Arg.Set use_rif, doc_rif; - "-deps", Arg.Set build_deps, doc_deps; - ]) - (fun filename -> if !build_deps then build filename else compile filename) - errmsg; - begin - match !simulation_node with - | Some(name) -> - Simulator.main !outname name !sampling_period !number_of_checks !use_gtk - | _ -> () - end - with - | Zmisc.Error -> exit 2;; - -main ();; -exit 0;; diff --git a/compiler/parsing/zdepend.ml b/compiler/parsing/zdepend.ml deleted file mode 100644 index bd0d6b305..000000000 --- a/compiler/parsing/zdepend.ml +++ /dev/null @@ -1,201 +0,0 @@ -open Format -open Zlocation -open Zparsetree - -module StringSet = Set.Make(struct type t = string let compare = compare end) - -(* Collect free module identifiers in the a.s.t. *) - -let add bv ln = - match ln with - | Modname {qual= s; id = _ } -> - if not (StringSet.mem s !bv) - then bv := StringSet.add s !bv - | Name _ -> () - -let add_opt add_fn bv = function - | None -> () - | Some x -> add_fn bv x - -let add_default add_fn bv = function - | Init v | Default v -> add_fn bv v - -let rec add_size bv s = - match s.desc with - | Sconst _ -> () - | Sname id -> add bv id - | Sop (_, s1, s2) -> add_size bv s1; add_size bv s2 - -let rec add_type_expr bv ty = - match ty.desc with - | Etypevar _ -> () - | Etypeconstr (id, tel) -> add bv id; List.iter (add_type_expr bv) tel - | Etypetuple tl -> List.iter (add_type_expr bv) tl - | Etypevec (ty, s) -> add_type_expr bv ty; add_size bv s - | Etypefun (_, _, ty1, ty2) -> add_type_expr bv ty1; add_type_expr bv ty2 - -let rec add_interface bv i = - match i.desc with - | Einter_open s -> - if not (StringSet.mem s !bv) then bv := StringSet.add s !bv - | Einter_typedecl (_, _, tdl) -> add_type_decl bv tdl - | Einter_constdecl (_, te) -> add_type_expr bv te - -and add_type_decl bv td = - match td.desc with - | Eabstract_type -> () - | Eabbrev te -> add_type_expr bv te - | Evariant_type _ -> () - | Erecord_type l -> List.iter (fun (_, te) -> add_type_expr bv te) l - -and add_implem bv i = - match i.desc with - | Eopen s -> - if not (StringSet.mem s !bv) then bv := StringSet.add s !bv; - | Etypedecl (_, _, td) -> add_type_decl bv td - | Econstdecl (_, _, e) -> add_exp bv e - | Efundecl (_, { f_args; f_body; _ }) -> - List.iter (add_pattern bv) f_args; - add_exp bv f_body - -and add_exp bv exp = - match exp.desc with - | Evar l -> add bv l - | Econst _ -> () - | Econstr0 c -> add bv c - | Econstr1 (c, el) -> add bv c; List.iter (add_exp bv) el - | Elast _ -> () - | Eapp (_, e, el) -> add_exp bv e; List.iter (add_exp bv) el - | Eop (op, el) -> add_op bv op; List.iter (add_exp bv) el - | Etuple el -> List.iter (add_exp bv) el - | Erecord_access (e, id) -> add_exp bv e; add bv id - | Erecord fields -> List.iter (add_field bv) fields - | Erecord_with (e, fields) -> add_exp bv e; List.iter (add_field bv) fields - | Etypeconstraint (e, ty) -> add_exp bv e; add_type_expr bv ty - | Elet (_, pel, e) -> List.iter (add_eq bv) pel; add_exp bv e - | Eseq (e1, e2) -> add_exp bv e1; add_exp bv e2 - | Eperiod _ -> () - | Ematch (e, mhl) -> add_exp bv e; List.iter (add_match_handler add_exp bv) mhl - | Epresent (phl, edo) -> List.iter (add_present_handler add_exp bv) phl; add_opt (add_default add_exp) bv edo - | Eautomaton (shl, seo) -> List.iter (add_state_handler add_exp bv) shl; add_opt add_state_exp bv seo - | Ereset (e1,e2) -> add_exp bv e1; add_exp bv e2 - | Eblock (eqsb, body) -> add_block add_eq_list bv eqsb; add_exp bv body - -and add_op bv op = - match op with - | Efby | Eunarypre | Eifthenelse | Eminusgreater | Eup | Einitial | Edisc - | Etest | Eaccess | Eupdate | Econcat | Eatomic -> () - | Eslice (s1, s2) -> add_size bv s1; add_size bv s2 - -and add_field bv (lbl, e) = add bv lbl; add_exp bv e - -and add_pattern bv pat = - match pat.desc with - | Etuplepat pl -> List.iter (add_pattern bv) pl - | Evarpat _ -> () - | Ewildpat -> () - | Econstpat _ -> () - | Econstr0pat c -> add bv c - | Econstr1pat (c, pl) -> add bv c; List.iter (add_pattern bv) pl - | Ealiaspat (p, _) -> add_pattern bv p - | Eorpat (p1, p2) -> add_pattern bv p1; add_pattern bv p2 - | Erecordpat pl -> List.iter (fun (lbl, p) -> add bv lbl; add_pattern bv p) pl - | Etypeconstraintpat (p, ty) -> add_pattern bv p; add_type_expr bv ty - -and add_eq bv eq = - match eq.desc with - | EQeq (p,e) -> add_pattern bv p; add_exp bv e - | EQder (_, e, eo, phl) -> add_exp bv e; add_opt add_exp bv eo; List.iter (add_present_handler add_exp bv) phl - | EQinit (_, e) | EQpluseq (_, e) -> add_exp bv e - | EQnext (_, e, eo) -> add_exp bv e; add_opt add_exp bv eo - | EQemit (_, eo) -> add_opt add_exp bv eo - | EQautomaton (shl, seo) -> List.iter (add_state_handler add_eq_list bv) shl; add_opt add_state_exp bv seo - | EQpresent (phl, bo) -> List.iter (add_present_handler (add_block add_eq_list) bv) phl; add_opt (add_block add_eq_list) bv bo - | EQmatch (e, mhl) -> add_exp bv e; List.iter (add_match_handler (add_block add_eq_list) bv) mhl - | EQifthenelse (e, bl, elsebl) -> - add_exp bv e; - add_block add_eq_list bv bl; - add_opt (add_block add_eq_list) bv elsebl - | EQand eqs | EQbefore eqs -> add_eq_list bv eqs - | EQreset (eql, e) -> List.iter (add_eq bv) eql; add_exp bv e - | EQblock block -> add_block add_eq_list bv block - | EQforall handler -> add_forall_handler bv handler - -and add_eq_list bv le = - List.iter (add_eq bv) le - -and add_block: 'a. ('b -> 'a -> unit) -> 'b -> 'a block -> unit = - fun a bv b -> - let bb = b.desc in - List.iter (add_local bv) bb.b_locals; - a bv bb.b_body - -and add_local bv l = - let (_, eql) = l.desc in - List.iter (add_eq bv) eql - -and add_statepat _bv sp = - match sp.desc with - | Estate0pat _ -> () - | Estate1pat _ -> () - -and add_state_exp bv se = - match se.desc with - | Estate0 _ -> () - | Estate1 (_, el) -> List.iter (add_exp bv) el - -and add_escape bv e = - add_scondpat bv e.e_cond; - add_opt (add_block add_eq_list) bv e.e_block; - add_state_exp bv e.e_next_state - -and add_scondpat bv scp = - match scp.desc with - | Econdand (s1, s2) -> add_scondpat bv s1; add_scondpat bv s2 - | Econdor (s1, s2) -> add_scondpat bv s1; add_scondpat bv s2 - | Econdexp e -> add_exp bv e - | Econdon (s, e) -> add_scondpat bv s; add_exp bv e - | Econdpat (e, p) -> add_exp bv e; add_pattern bv p - -and add_match_handler: 'a. ('b -> 'a -> unit) -> 'b -> 'a match_handler -> unit = - fun a bv h -> - add_pattern bv h.m_pat; - a bv h.m_body - -and add_present_handler: 'a. ('b -> 'a -> unit) -> 'b -> 'a present_handler -> unit = - fun a bv h -> - add_scondpat bv h.p_cond; - a bv h.p_body - -and add_state_handler: 'a. ('b -> 'a -> unit) -> 'b -> 'a state_handler -> unit = - fun a bv { desc = h; _ } -> - add_statepat bv h.s_state; - add_block a bv h.s_block; - List.iter (add_escape bv) h.s_until; - List.iter (add_escape bv) h.s_unless - -and add_forall_handler bv { for_indexes; for_init; for_body; } = - List.iter (add_index bv) for_indexes; - List.iter (add_init bv) for_init; - add_block add_eq_list bv for_body - -and add_index bv index = - match index.desc with - | Einput (_, e) -> add_exp bv e - | Eoutput (_, _) -> () - | Eindex (_, e1, e2) -> add_exp bv e1; add_exp bv e2 - -and add_init bv init = - match init.desc with - | Einit_last (_, e) -> add_exp bv e - -let file traverse initial_structures file = - let bv = ref initial_structures in - List.iter (traverse bv) file; - !bv - -let source_file ?(initial_structures = StringSet.empty) source = - file add_implem initial_structures source - -let interface_file ?(initial_structures = StringSet.empty) interface = - file add_interface initial_structures interface diff --git a/compiler/parsing/zlexer.mll b/compiler/parsing/zlexer.mll deleted file mode 100644 index 19bed3724..000000000 --- a/compiler/parsing/zlexer.mll +++ /dev/null @@ -1,313 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* lexer.mll *) - -{ -open Lexing -open Zparser -open Zlocation - -type lexical_error = - Illegal_character - | Unterminated_comment - | Bad_char_constant - | Unterminated_string;; - -exception Lexical_error of lexical_error * location - -let comment_depth = ref 0 - -let keyword_table = ((Hashtbl.create 149) : (string, token) Hashtbl.t);; - -List.iter (fun (str,tok) -> Hashtbl.add keyword_table str tok) [ - "as", AS; - "forall", FORALL; - "automaton", AUTOMATON; - "atomic", ATOMIC; - "inline", INLINE; - "continue", CONTINUE; - "disc", DISC; - "do", DO; - "done", DONE; - "until", UNTIL; - "unless", UNLESS; - "emit", EMIT; - "present", PRESENT; - "match", MATCH; - "period", PERIOD; - "with", WITH; - "end", END; - "exception", EXCEPTION; - "external", EXTERNAL; - "static", STATIC; - "fun", FUN; - "node", NODE; - "hybrid", HYBRID; - "discrete", DISCRETE; - "proba", PROBA; - "init", INIT; - "initialize", INITIALIZE; - "default", DEFAULT; - "in", IN; - "before", BEFORE; - "out", OUT; - "and", AND; - "open", OPEN; - "val", VAL; - "local", LOCAL; - "let", LET; - "rec", REC; - "where", WHERE; - "open", OPEN; - "fby", FBY; - "next", NEXT; - "up", UP; - "der", DER; - "reset", RESET; - "pre", PRE; - "type", TYPE; - "every", EVERY; - "true", BOOL(true); - "false", BOOL(false); - "or", OR; - "of", OF; - "on", ON; - "last", LAST; - "run", RUN; - "if", IF; - "then", THEN; - "else", ELSE; - "quo", INFIX3("quo"); - "mod", INFIX3("mod"); - "land", INFIX3("land"); - "lor", INFIX2("lor"); - "lxor", INFIX2("lxor"); - "lsl", INFIX4("lsl"); - "lsr", INFIX4("lsr"); - "asr", INFIX4("asr") -] - - -(* To buffer string literals *) - -let initial_string_buffer = Bytes.create 256 -let string_buff = ref initial_string_buffer -let string_index = ref 0 - -let reset_string_buffer () = - string_buff := initial_string_buffer; - string_index := 0; - () - -(* -let incr_linenum lexbuf = - let pos = lexbuf.Lexing.lex_curr_p in - lexbuf.Lexing.lex_curr_p <- { pos with - Lexing.pos_lnum = pos.Lexing.pos_lnum + 1; - Lexing.pos_bol = pos.Lexing.pos_cnum; - } -*) - -let store_string_char c = - if !string_index >= Bytes.length (!string_buff) then begin - let new_buff = Bytes.create (Bytes.length (!string_buff) * 2) in - Bytes.blit (!string_buff) 0 new_buff 0 (Bytes.length (!string_buff)); - string_buff := new_buff - end; - Bytes.set (!string_buff) (!string_index) c; - incr string_index - - -let get_stored_string () = - let s = Bytes.sub (!string_buff) 0 (!string_index) in - string_buff := initial_string_buffer; - s - -let char_for_backslash = function - | 'n' -> '\010' - | 'r' -> '\013' - | 'b' -> '\008' - | 't' -> '\009' - | c -> c - -let char_for_decimal_code lexbuf i = - let c = - 100 * (int_of_char(Lexing.lexeme_char lexbuf i) - 48) + - 10 * (int_of_char(Lexing.lexeme_char lexbuf (i+1)) - 48) + - (int_of_char(Lexing.lexeme_char lexbuf (i+2)) - 48) in - char_of_int(c land 0xFF) - - -} - -rule main = parse - | [' ' '\010' '\013' '\009' '\012'] + { main lexbuf } - | "." { DOT } - | ".." { DOTDOT } - | "(" { LPAREN } - | ")" { RPAREN } - | "[" { LBRACKET } - | "]" { RBRACKET } - | "[|" { LBRACKETBAR } - | "|]" { RBRACKETBAR } - | "*" { STAR } - | "{" { LBRACE } - | "}" { RBRACE } - | ":" { COLON } - | "::" { COLONCOLON } - | "=" { EQUAL } - | "==" { EQUALEQUAL } - | "+=" { PLUSEQUAL } - | "&" { AMPERSAND } - | "'" { QUOTE } - | "&&" { AMPERAMPER } - | "||" { BARBAR } - | "," { COMMA } - | ";" { SEMI } - | ";;" { SEMISEMI } - | "->" { MINUSGREATER } - | "-A->" { AFUN } - | "-D->" { DFUN } - | "-AD->" { ADFUN } - | "-AS->" { ASFUN } - | "-C->" { CFUN } - | "-S->" { SFUN } - | "~D~>" { PFUN } - | "|" { BAR } - | "-" { MINUS } - | "+" { PLUS } - | "-." { SUBTRACTIVE "-." } - | "_" { UNDERSCORE } - | "?" { TEST } - | (['A'-'Z']('_' ? ['A'-'Z' 'a'-'z' ''' '0'-'9']) * as id) - {CONSTRUCTOR id} - | (['A'-'Z' 'a'-'z'](['_' 'A'-'Z' 'a'-'z' ''' '0'-'9']) * as id) - { let s = Lexing.lexeme lexbuf in - try - Hashtbl.find keyword_table s - with Not_found -> - IDENT id } - | ['0'-'9']+ - | '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+ - | '0' ['o' 'O'] ['0'-'7']+ - | '0' ['b' 'B'] ['0'-'1']+ - { INT (int_of_string(Lexing.lexeme lexbuf)) } - | ['0'-'9']+ ('.' ['0'-'9']*)? (['e' 'E'] ['+' '-']? ['0'-'9']+)? - { FLOAT (float_of_string(Lexing.lexeme lexbuf)) } - | "\"" - { reset_string_buffer(); - let string_start = lexbuf.lex_start_pos + lexbuf.lex_abs_pos in - begin try - string lexbuf - with Lexical_error(Unterminated_string, Loc(_, string_end)) -> - raise(Lexical_error(Unterminated_string, - Loc(string_start, string_end))) - end; - lexbuf.lex_start_pos <- string_start - lexbuf.lex_abs_pos; - STRING (Bytes.to_string(get_stored_string())) } - | "'" [^ '\\' '\''] "'" - { CHAR(Lexing.lexeme_char lexbuf 1) } - | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" - { CHAR(char_for_backslash (Lexing.lexeme_char lexbuf 2)) } - | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" - { CHAR(char_for_decimal_code lexbuf 2) } - | "(*" - { let comment_start = lexbuf.lex_start_pos + lexbuf.lex_abs_pos in - comment_depth := 1; - begin try - comment lexbuf - with Lexical_error(Unterminated_comment, Loc(_, comment_end)) -> - raise(Lexical_error(Unterminated_comment, - Loc(comment_start, comment_end))) - end; - main lexbuf } - | ['!' '?' '~'] - ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' - '<' '=' '>' '?' '@' '^' '|' '~'] * - { PREFIX(Lexing.lexeme lexbuf) } - | ['=' '<' '>' '&' '|' '&' '$'] - ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' - '?' '@' '^' '|' '~'] * - { INFIX0(Lexing.lexeme lexbuf) } - | ['@' '^'] - ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' - '?' '@' '^' '|' '~'] * - { INFIX1(Lexing.lexeme lexbuf) } - | ['+' '-'] - ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' - '?' '@' '^' '|' '~'] * - { INFIX2(Lexing.lexeme lexbuf) } - | "**" - ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' - '?' '@' '^' '|' '~'] * - { INFIX4(Lexing.lexeme lexbuf) } - | ['*' '/' '%'] - ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' - '?' '@' '^' '|' '~'] * - { INFIX3(Lexing.lexeme lexbuf) } - | eof {EOF} - | _ {raise (Lexical_error (Illegal_character, - Loc(Lexing.lexeme_start lexbuf, - Lexing.lexeme_end lexbuf)))} - -and comment = parse - "(*" - { comment_depth := succ !comment_depth; comment lexbuf } - | "*)" - { comment_depth := pred !comment_depth; - if !comment_depth > 0 then comment lexbuf } - | "\"" - { reset_string_buffer(); - let string_start = lexbuf.lex_start_pos + lexbuf.lex_abs_pos in - begin try - string lexbuf - with Lexical_error(Unterminated_string, Loc(_, string_end)) -> - raise(Lexical_error(Unterminated_string, - Loc(string_start, string_end))) - end; - comment lexbuf } - | "''" - { comment lexbuf } - | "'" [^ '\\' '\''] "'" - { comment lexbuf } - | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" - { comment lexbuf } - | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" - { comment lexbuf } - | eof - { raise(Lexical_error(Unterminated_comment, - Loc(0,Lexing.lexeme_start lexbuf))) } - | _ - { comment lexbuf } - -and string = parse - '"' - { () } - | '\\' ("\010" | "\013" | "\013\010") [' ' '\009'] * - { string lexbuf } - | '\\' ['\\' '"' 'n' 't' 'b' 'r'] - { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); - string lexbuf } - | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] - { store_string_char(char_for_decimal_code lexbuf 1); - string lexbuf } - | eof - { raise (Lexical_error - (Unterminated_string, Loc(0, Lexing.lexeme_start lexbuf))) } - | _ - { store_string_char(Lexing.lexeme_char lexbuf 0); - string lexbuf } - -(* eof *) diff --git a/compiler/parsing/zparser.mly b/compiler/parsing/zparser.mly deleted file mode 100644 index 93e285ed8..000000000 --- a/compiler/parsing/zparser.mly +++ /dev/null @@ -1,1181 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -%{ - -open Lexing -open Zlocation -open Zparsetree - -let localise start_pos end_pos = Loc(start_pos.pos_cnum, end_pos.pos_cnum) - -let make desc start_pos end_pos = - { desc = desc; loc = localise start_pos end_pos } - -let make_name op start_pos end_pos = - make (Evar(Name(op))) start_pos end_pos - -let unop op e start_pos end_pos = - Eapp({ app_inline = false; app_statefull = false}, - make_name op start_pos end_pos, [e]) -let binop op e1 e2 start_pos end_pos = - Eapp({ app_inline = false; app_statefull = false}, - make_name op start_pos end_pos, [e1; e2]) - -let unary_minus op e start_pos end_pos = - match op, e.desc with - | "-", Econst(Eint v) -> Econst(Eint(-v)) - | ("-" | "_."), Econst(Efloat v) -> Econst(Efloat(-.v)) - | _ -> unop ("~" ^ op) e start_pos end_pos - -let unary_minus_int x = -x -and unary_minus_float x = -.x - -(* Representation of lists. [] for Pervasives.[] *) -(* [e1;...;en] for Pervasives.(::) e1 (... Pervasives.[]) *) -let list_name n = Modname { qual = Initial.stdlib_module; id = n } - -let nil_desc = Evar(list_name Initial.nil_name) - -let cons_desc x l start_pos end_pos = - Eapp({ app_inline = false; app_statefull = false }, - make (Evar(list_name Initial.cons_name)) start_pos end_pos, - [make (Etuple [x; l]) start_pos end_pos]) - -let rec cons_list_desc l start_pos end_pos = - match l with - | [] -> nil_desc - | x :: l -> cons_desc x (cons_list l start_pos end_pos) start_pos end_pos - -and cons_list l start_pos end_pos = - make (cons_list_desc l start_pos end_pos) start_pos end_pos - -let scond_true start_pos end_pos = - make (Econdexp(make (Econst(Ebool(true))) start_pos end_pos)) - start_pos end_pos - -(* constructors with arguments *) -let app f l = - match f.desc, l with - | Econstr0(id), [{ desc = Etuple(arg_list) }] -> - (* C(e1,...,en) *) Econstr1(id, arg_list) - | Econstr0(id), [arg] -> - (* C(e) *) Econstr1(id, [arg]) - | _ -> Eapp({ app_inline = false; app_statefull = false}, f, l) - -let constr c p = - match p with - | { desc = Etuplepat(arg_list) } -> - (* C(p1,...,pn) *) Econstr1pat(c, arg_list) - | _ -> (* C(e) *) Econstr1pat(c, [p]) - -let block l lo eq_list startpos endpos = - make { b_locals = l; b_vars = lo; b_body = eq_list } startpos endpos - -%} - -%token EQUAL /* "=" */ -%token EQUALEQUAL /* "==" */ -%token PLUSEQUAL /* "+=" */ -%token AMPERSAND /* "&" */ -%token AMPERAMPER /* "&&" */ -%token BARBAR /* "||" */ -%token QUOTE /* "'" */ -%token LPAREN /* "(" */ -%token RPAREN /* ")" */ -%token LBRACKET /* "[" */ -%token RBRACKET /* "]" */ -%token STAR /* "*" */ -%token PLUS /* "+" */ -%token MINUS /* "-" */ -%token COMMA /* "," */ -%token SEMI /* ";" */ -%token SEMISEMI /* ";;" */ -%token MINUSGREATER /* "->" */ -%token AFUN /* "-A->" */ -%token ADFUN /* "-AD->" */ -%token ASFUN /* "-AS->" */ -%token DFUN /* "-D->" */ -%token CFUN /* "-C->" */ -%token SFUN /* "-S->" */ -%token PFUN /* "~D~>" */ -%token DOT /* "." */ -%token DOTDOT /* ".." */ -%token COLON /* ":" */ -%token COLONCOLON /* "::" */ -%token LBRACE /* "{" */ -%token BAR /* "|" */ -%token RBRACE /* "}" */ -%token LBRACKETBAR /* "[|" */ -%token RBRACKETBAR /* "|]" */ -%token UNDERSCORE /* "_" */ -%token TEST /* "?" */ -%token CONSTRUCTOR -%token IDENT -%token INT -%token FLOAT -%token BOOL -%token CHAR -%token STRING -%token AS /* "as" */ -%token FORALL /* "forall" */ -%token AUTOMATON /* "automaton" */ -%token ATOMIC /* "atomic" */ -%token INLINE /* "inline" */ -%token CONTINUE /* "continue" */ -%token DO /* "do" */ -%token DONE /* "done" */ -%token UNTIL /* "until" */ -%token UNLESS /* "unless" */ -%token MATCH /* "match" */ -%token WITH /* "with" */ -%token EMIT /* "emit" */ -%token PRESENT /* "present" */ -%token PERIOD /* "period" */ -%token END /* "end" */ -%token EXCEPTION /* "exception" */ -%token EXTERNAL /* "external" */ -%token IN /* "in" */ -%token BEFORE /* "before" */ -%token OUT /* "out" */ -%token LET /* "let" */ -%token REC /* "rec" */ -%token DER /* "der" */ -%token INIT /* "init" */ -%token INITIALIZE /* "initialize" */ -%token DEFAULT /* "default" */ -%token LOCAL /* "local" */ -%token WHERE /* "where" */ -%token AND /* "and" */ -%token TYPE /* "type" */ -%token STATIC /* "static" */ -%token OF /* "of" */ -%token FUN /* "fun" */ -%token NODE /* "node" */ -%token HYBRID /* "hybrid" */ -%token PROBA /* "proba" */ -%token DISCRETE /* "discrete" */ -%token FBY /* "fby" */ -%token NEXT /* "next" */ -%token PRE /* "pre" */ -%token UP /* "up" */ -%token DISC /* "disc" */ -%token EVERY /* "every" */ -%token OR /* "or" */ -%token ON /* "on" */ -%token RESET /* "reset" */ -%token LAST /* "last" */ -%token IF /* "if" */ -%token THEN /* "then" */ -%token ELSE /* "else" */ -%token OPEN /* "open" */ -%token VAL /* "val" */ -%token RUN /* "run" */ -%token PREFIX -%token INFIX0 -%token INFIX1 -%token INFIX2 -%token SUBTRACTIVE -%token INFIX3 -%token INFIX4 -%token EOF - -%nonassoc prec_no_end -%nonassoc END -%right IN -%right prec_seq -%right SEMI -%nonassoc prec_ident -%right prec_list -%left EVERY -%left AUTOMATON -%left INIT -%left UNTIL -%left UNLESS -%nonassoc ELSE -%right BEFORE -%left AS -%left BAR -%left COMMA -%left RPAREN -%right MINUSGREATER SFUN DFUN CFUN AFUN ADFUN ASFUN PFUN -%left OR BARBAR -%left AMPERSAND AMPERAMPER -%left INFIX0 EQUAL -%right INFIX1 -%right COLONCOLON -%left INFIX2 PLUS SUBTRACTIVE MINUS -%left STAR INFIX3 -%left ON -%left INFIX4 -%right prec_uminus -%right FBY -%right PRE UP DISC TEST ATOMIC -%right PREFIX -%left DOT - -%start implementation_file -%type implementation_file - -%start interface_file -%type interface_file - -%start scalar_interface_file -%type scalar_interface_file - -%% - -/** Tools **/ - -/* Separated list */ -list_aux(S, X): -| x = X { [x] } -| r = list_aux(S, X) S x = X { x :: r } -; - -%inline list_of(S, X): - r = list_aux(S, X) { List.rev r } -; - -/* Non separated list */ -list_aux_no_sep(X): -| x = X { [x] } -| r = list_aux_no_sep(X) x = X { x :: r } -; - -%inline list_no_sep_of(X): - r = list_aux_no_sep(X) { List.rev r } -; - -/* Localization */ -localized(X): -| x = X { make x $startpos $endpos } -; - -%inline optional(X): - | /* empty */ - { None } - | x = X - { Some(x) } -; - -implementation_file: - | EOF - { [] } - | i = decl_list(localized(implementation)) EOF - { List.rev i } -; - -decl_list(X): - | dl = decl_list(X) x = X opt_semi_semi - { x :: dl } - | x = X opt_semi_semi - { [x] } -; - -opt_semi_semi: - | /* empty */ {} - | SEMISEMI {} -; - -implementation: - | OPEN c = CONSTRUCTOR - { Eopen c } - | TYPE tp = type_params id = IDENT td = localized(type_declaration_desc) - { Etypedecl(id, tp, td) } - | LET ide = ide EQUAL seq = seq_expression - { Econstdecl(ide, false, seq) } - | LET STATIC ide = ide EQUAL seq = seq_expression - { Econstdecl(ide, true, seq) } - | LET ide = ide fn = simple_pattern_list EQUAL seq = seq_expression - { Efundecl(ide, { f_kind = A; f_atomic = false; - f_args = fn; f_body = seq; - f_loc = localise $startpos(fn) $endpos(seq) }) } - | LET ide = ide fn = simple_pattern_list EQUAL - seq = seq_expression WHERE r = is_rec eqs = equation_list - { Efundecl(ide, { f_kind = A; f_atomic = false; f_args = fn; - f_body = make(Elet(r, eqs, seq)) - $startpos(seq) $endpos(eqs); - f_loc = localise $startpos(fn) $endpos(eqs) }) } - | is_let a = is_atomic k = kind ide = ide fn = simple_pattern_list - EQUAL seq = seq_expression - { Efundecl(ide, - { f_kind = k; f_atomic = a; f_args = fn; f_body = seq; - f_loc = localise $startpos(fn) $endpos(seq) }) } - | is_let a = is_atomic k = kind ide = ide - fn = simple_pattern_list EQUAL seq = seq_expression - WHERE r = is_rec eqs = equation_list - { Efundecl(ide, { f_kind = k; f_atomic = a; f_args = fn; - f_body = make(Elet(r, eqs, seq)) - $startpos(seq) $endpos(eqs); - f_loc = localise $startpos(fn) $endpos(eqs) }) } -; - -%inline is_rec: - | REC { true } - | { false } -; - -%inline is_atomic: - | ATOMIC { true } - | { false } -; - -%inline is_let: - | LET { } - | { } -; - -simple_pattern_list: - | p = simple_pattern - { [ p ] } - | p = simple_pattern sp = simple_pattern_list - { p :: sp } -; - -/* Interface */ -interface_file: - | EOF - { [] } - | il = decl_list(localized(interface)) EOF - { List.rev il } -; - -interface: - | OPEN c = CONSTRUCTOR - { Einter_open(c) } - | TYPE tp = type_params i = IDENT td = localized(type_declaration_desc) - { Einter_typedecl(i, tp, td) } - | VAL i = ide COLON t = type_expression - { Einter_constdecl(i, t) } -; - -/* Scalar interface */ -scalar_interface_file: - | EOF - { [] } - | il = decl_list(scalar_interface) EOF - { List.rev (List.flatten il) } - ; - -scalar_interface : - | OPEN c = CONSTRUCTOR - { [make (Einter_open(c)) $startpos $endpos] } - | TYPE tp = type_params i = IDENT td = localized(type_declaration_desc) - { [make (Einter_typedecl(i, tp, td)) $startpos $endpos] } - | VAL i = ide COLON t = type_expression - { [make (Einter_constdecl(i, t)) $startpos $endpos] } - | EXTERNAL i = ide COLON t = type_expression EQUAL list_no_sep_of(STRING) - { [make (Einter_constdecl(i, t)) $startpos $endpos] } - | EXCEPTION constructor - { [] } - | EXCEPTION constructor OF type_expression - { [] } -; - -type_declaration_desc: - | /* empty */ - { Eabstract_type } - | EQUAL l = list_of(BAR, localized(constr_decl_desc)) - { Evariant_type (l) } - | EQUAL BAR l = list_of(BAR, localized(constr_decl_desc)) - { Evariant_type (l) } - | EQUAL LBRACE s = label_list(label_type) RBRACE - { Erecord_type (s) } - | EQUAL t = type_expression - { Eabbrev(t) } -; - -type_params : - | LPAREN tvl = list_of(COMMA, type_var) RPAREN - { tvl } - | tv = type_var - { [tv] } - | - { [] } -; - -label_list(X): - | x = X - { [x] } - | x = X SEMI - { [x] } - | x = X SEMI ll = label_list(X) - { x :: ll } -; - -label_type: - i = IDENT COLON t = type_expression - { (i, t) } -; - -constr_decl_desc: - | c = CONSTRUCTOR - { Econstr0decl(c) } - | c = CONSTRUCTOR OF l = list_of(STAR, simple_type) - { Econstr1decl(c, l) } -; - -equation_empty_list: - | /* empty */ - { [] } - | eq_list = equation_list - { eq_list } -; - -optional_init: - | /* empty */ - { None } - | INIT e = expression - { Some(e) } -; - -%inline equation_list: - | l = list_of(AND, equation) { l } -; - -%inline equation: - eq = localized(equation_desc) { eq } -; - -equation_desc: - | AUTOMATON opt_bar a = automaton_handlers(equation_empty_list) opt_end - { EQautomaton(List.rev a, None) } - | AUTOMATON opt_bar a = automaton_handlers(equation_empty_list) - INIT s = state - { EQautomaton(List.rev a, Some(s)) } - | MATCH e = seq_expression WITH opt_bar - m = match_handlers(block_of_equation_list) opt_end - { EQmatch(e, List.rev m) } - | IF e = seq_expression THEN b1 = block_of_equation_list - ELSE b2 = block_of_equation_list opt_end - { EQifthenelse(e, b1, Some b2) } - | IF e = seq_expression THEN b1 = block_of_equation_list - { EQifthenelse(e, b1, None) } - | PRESENT opt_bar p = present_handlers(block_of_equation_list) opt_end - { EQpresent(List.rev p, None) } - | PRESENT opt_bar p = present_handlers(block_of_equation_list) - ELSE b = block_of_equation_list opt_end - { EQpresent(List.rev p, Some(b)) } - | RESET eq = equation_list EVERY e = expression - { EQreset(eq, e) } - | l = let_list lo = local_list DO eq_list = equation_empty_list DONE - { EQblock(block l lo eq_list $startpos $endpos) } - | FORALL i = index_list bo = block(equation_list) - INITIALIZE inits = init_equation_list DONE - { EQforall - { for_indexes = i; for_init = inits; for_body = bo } } - | FORALL i = index_list bo = block(equation_list) DONE - { EQforall - { for_indexes = i; for_init = []; for_body = bo } } - | p = pattern EQUAL e = seq_expression - { EQeq(p, e) } - | i = ide PLUSEQUAL e = seq_expression - { EQpluseq(i, e) } - | PERIOD p = pattern EQUAL e = period_expression - { EQeq(p, make (Eperiod(e)) $startpos(e) $endpos(e)) } - | DER i = ide EQUAL e = seq_expression opt = optional_init - { EQder(i, e, opt, []) } - | DER i = ide EQUAL e = seq_expression opt = optional_init - RESET opt_bar pe = present_handlers(expression) - { EQder(i, e, opt, List.rev pe) } - | NEXT i = ide EQUAL e = seq_expression - { EQnext(i, e, None) } - | NEXT i = ide EQUAL e = seq_expression INIT e0 = seq_expression - { EQnext(i, e, Some(e0)) } - | INIT i = ide EQUAL e = seq_expression - { EQinit(i, e) } - | EMIT i = ide - { EQemit(i, None) } - | EMIT i = ide EQUAL e = seq_expression - { EQemit(i, Some(e)) } - | eq1 = equation BEFORE eq2 = equation - { EQbefore [eq1; eq2] } -; - -opt_end: - | { () } %prec prec_no_end - | END { () } -; - -%inline simple_equation: - eq = localized(simple_equation_desc) { eq } -; - -simple_equation_desc: - | AUTOMATON opt_bar a = automaton_handlers(equation_empty_list) END - { EQautomaton(List.rev a, None) } - | AUTOMATON opt_bar a = automaton_handlers(equation_empty_list) - INIT s = state - { EQautomaton(List.rev a, Some(s)) } - | MATCH e = seq_expression WITH opt_bar - m = match_handlers(block_of_equation_list) END - { EQmatch(e, List.rev m) } - | PRESENT opt_bar p = present_handlers(block_of_equation_list) END - { EQpresent(List.rev p, None) } - | PRESENT opt_bar p = present_handlers(block_of_equation_list) - ELSE b = block_of_equation_list END - { EQpresent(List.rev p, Some(b)) } - | RESET eq = equation_list EVERY e = expression - { EQreset(eq, e) } - | FORALL i = index_list bo = block(equation_list) - INITIALIZE inits = init_equation_list DONE - { EQforall - { for_indexes = i; for_init = inits; for_body = bo } } - | FORALL i = index_list bo = block(equation_list) DONE - { EQforall - { for_indexes = i; for_init = []; for_body = bo } } -; - -/* initialization in a for loop */ -%inline init_equation_list: - | l = list_of(AND, localized(init_equation_desc)) { l } -; - -init_equation_desc: - | LAST i = ide EQUAL e = expression - { Einit_last(i, e) } - ; - -/* indexes in a for loop */ -%inline index_list: - | l = list_of(COMMA, localized(index_desc)) { l } -; - -index_desc: - | i = ide IN e = simple_expression - { Einput(i, e) } - | i = ide OUT o = ide - { Eoutput(i, o) } - | i = ide IN e1 = simple_expression DOTDOT e2 = simple_expression - { Eindex(i, e1, e2) } -; - - -/* states of an automaton in an equation*/ -automaton_handlers(X) : - | a = automaton_handler(X) - { [a] } - | ahs = automaton_handlers(X) BAR a = automaton_handler(X) - { a :: ahs } -; - -automaton_handler(X): - | sp = state_pat MINUSGREATER b = block(X) DONE - { make { s_state = sp; s_block = b; s_until = []; s_unless = [] } - $startpos $endpos} - | sp = state_pat MINUSGREATER b = block(X) THEN st = state - { make { s_state = sp; s_block = b; - s_until = - [{ e_cond = scond_true $endpos(b) $startpos(st); - e_reset = true; e_block = None; e_next_state = st }]; - s_unless = [] } - $startpos $endpos} - | sp = state_pat MINUSGREATER b = block(X) CONTINUE st = state - { make { s_state = sp; - s_block = b; - s_until = - [{ e_cond = scond_true $endpos(b) $startpos(st); - e_reset = false; - e_block = None; e_next_state = st }]; - s_unless = [] } $startpos $endpos } - | sp = state_pat MINUSGREATER b = block(X) THEN emit = emission st = state - { make { s_state = sp; s_block = b; - s_until = - [{ e_cond = scond_true $endpos(b) $startpos(emit); - e_reset = true; e_block = Some(emit); e_next_state = st}]; - s_unless = [] } $startpos $endpos } - | sp = state_pat MINUSGREATER b = block(X) CONTINUE emit = emission - st = state - { make { s_state = sp; - s_block = b; - s_until = [{ e_cond = scond_true $endpos(b) $startpos(emit); - e_reset = false; e_block = Some(emit); - e_next_state = st}]; - s_unless = [] } $startpos $endpos } - | sp = state_pat MINUSGREATER b = block(X) UNTIL e_until = escape_list - { make - { s_state = sp; s_block = b; s_until = List.rev e_until; s_unless = [] } - $startpos $endpos } - | sp = state_pat MINUSGREATER b = block(X) UNLESS e_unless = escape_list - { make - { s_state = sp; s_block = b; s_until = []; s_unless = List.rev e_unless } - $startpos $endpos } - | sp = state_pat MINUSGREATER b = block(X) UNTIL e_until = escape_list - UNLESS e_unless = escape_list - { make { s_state = sp; s_block = b; - s_until = List.rev e_until; s_unless = List.rev e_unless } - $startpos $endpos } -; - -escape : - | scondpat THEN state - { { e_cond = $1; e_reset = true; e_block = None; e_next_state = $3 } } - | scondpat CONTINUE state - { { e_cond = $1; e_reset = false; e_block = None; e_next_state = $3 } } - | scondpat THEN emission state - { { e_cond = $1; e_reset = true; e_block = Some($3); e_next_state = $4 } } - | scondpat CONTINUE emission state - { { e_cond = $1; e_reset = false; e_block = Some($3); e_next_state = $4 } } -; - -escape_list : - | e = escape - { [e] } - | el = escape_list ELSE e = escape - { e :: el } -; - -state : - | c = CONSTRUCTOR - { make (Estate0(c)) $startpos $endpos } - | c = CONSTRUCTOR LPAREN e = expression RPAREN - { make (Estate1(c, [e])) $startpos $endpos } - | c = CONSTRUCTOR LPAREN l = expression_comma_list RPAREN - { make (Estate1(c, List.rev l)) $startpos $endpos } -; - -state_pat : - | c = CONSTRUCTOR - { make (Estate0pat(c)) $startpos $endpos } - | c = CONSTRUCTOR LPAREN l = list_of(COMMA, IDENT) RPAREN - { make (Estate1pat(c, l)) $startpos $endpos } -; - -/* Pattern on a signal */ -scondpat : - | sc = localized(scondpat_desc) { sc } -; - -scondpat_desc : - | e = simple_expression p = simple_pattern - { Econdpat(e, p) } - | e = simple_expression - { Econdexp(e) } - | UP e = simple_expression - { Econdexp (make (Eop(Eup, [e])) $startpos $endpos) } - | scpat1 = scondpat AMPERSAND scpat2 = scondpat - { Econdand(scpat1, scpat2) } - | scpat1 = scondpat BAR scpat2 = scondpat - { Econdor(scpat1, scpat2) } - | scpat1 = scondpat ON e = simple_expression - { Econdon(scpat1, e) } -; - -/* Block */ -block(X): - | l = let_list lo = local_list DO x = X - { make { b_locals = l; b_vars = lo; b_body = x } $startpos $endpos } -; - -block_of_equation_list: - | eq = simple_equation - { block [] [] [eq] $startpos $endpos } - | l = let_list lo = local_list DO eq_list = equation_empty_list DONE - { block l lo eq_list $startpos $endpos } -; - - -emission: - | l1 = one_let IN l2 = let_list - { make { b_vars = []; b_locals = l1 :: l2; b_body = [] } $startpos $endpos } - | l = let_list lo = local_list DO eq = equation_empty_list IN - { make { b_vars = lo; b_locals = l; b_body = eq } $startpos $endpos } -; - -let_list: - | /* empty */ - { [] } - | o = one_let IN l = let_list - { o :: l } -; - -one_let: - | LET eq = equation_list - { make (false, eq) $startpos $endpos } - | LET REC eq = equation_list - { make (true, eq) $startpos $endpos } -; - -local_list: - | /* empty */ - { [] } - | LOCAL o = list_of(COMMA, one_local) opt_in l = local_list - { o @ l } -; - -opt_in: - /* epsilon */ - | {} - | IN { () } -; - -one_local: - | i = ide v = optional(default_or_init) c = opt_combine - { make { vardec_name = i; vardec_default = v; vardec_combine = c } - $startpos $endpos } -; - -default_or_init: - | DEFAULT c = constant - { Default(c) } - | INIT c = constant - { Init(c) } -; - -opt_combine: - | /* empty */ - { None } - | WITH i = ext_ident - { Some(i) } -; - -constant: - | i = atomic_constant - { Cimmediate(i) } - | i = ext_ident - { Cglobal(i) } -; - - -opt_bar: - | BAR { () } - | /*epsilon*/ { () } -; - - -/* Testing the presence of a signals */ -present_handlers(X): - | p = present_handler(X) - { [p ] } - | ps = present_handlers(X) BAR p = present_handler(X) - { p :: ps } -; - -present_handler(X): - | sc = scondpat MINUSGREATER x = X - { { p_cond = sc; p_body = x } } -; - -/* Pattern matching in an equation */ -match_handlers(X): - | m = match_handler(X) - { [m ] } - | mh = match_handlers(X) BAR m = match_handler(X) - { m :: mh } -; - -match_handler(X): - | p = pattern MINUSGREATER x = X - { { m_pat = p; m_body = x } } -; - -/* Patterns */ -pattern: - | p = simple_pattern - { p } - | p = pattern AS i = IDENT - { make (Ealiaspat(p, i)) $startpos $endpos } - | p1 = pattern BAR p2 = pattern - { make (Eorpat(p1, p2)) $startpos $endpos } - | p = pattern_comma_list %prec prec_list - { make (Etuplepat(List.rev p)) $startpos $endpos } - | c = constructor p = simple_pattern - { make (constr c p) $startpos $endpos } -; - -simple_pattern: - | a = atomic_constant - { make (Econstpat a) $startpos $endpos } - | MINUS i = INT - { make (Econstpat(Eint(unary_minus_int i))) $startpos $endpos } - | MINUS f = FLOAT - { make (Econstpat(Efloat(unary_minus_float f))) $startpos $endpos } - | c = constructor - { make (Econstr0pat(c)) $startpos $endpos } - | i = ide - { make (Evarpat i) $startpos $endpos } - | LPAREN p = pattern RPAREN - { p } - | LPAREN p = pattern_comma_list RPAREN - { make (Etuplepat (List.rev p)) $startpos $endpos } - | LPAREN RPAREN - { make (Econstpat(Evoid)) $startpos $endpos } - | UNDERSCORE - { make Ewildpat $startpos $endpos } - | LPAREN p = pattern COLON t = type_expression RPAREN - { make (Etypeconstraintpat(p, t)) $startpos $endpos } - | LBRACE p = pattern_label_list RBRACE - { make (Erecordpat(p)) $startpos $endpos } -; - -pattern_comma_list: - | p1 = pattern COMMA p2 = pattern - { [p2; p1] } - | pc = pattern_comma_list COMMA p = pattern - { p :: pc } -; - -pattern_label_list : - | p = pattern_label SEMI pl = pattern_label_list - { p :: pl } - | p = pattern_label - { [p] } - | UNDERSCORE - { [] } - | /*epsilon*/ - { [] } -; - -pattern_label : - | ei = ext_ident EQUAL p = pattern - { (ei, p) } -; - -/* Expressions */ -seq_expression : - | e = expression SEMI seq = seq_expression - { make (Eseq(e, seq)) $startpos $endpos } - | e = expression %prec prec_seq - { e } -; - -simple_expression: - | desc = simple_expression_desc - { make desc $startpos $endpos } -; - -simple_expression_desc: - | c = constructor - { Econstr0(c) } - | i = ext_ident - { Evar i } - | LBRACKET RBRACKET - { nil_desc } - | LBRACKET l = list_of(SEMI, expression) RBRACKET - { cons_list_desc l ($startpos($1)) ($endpos($3)) } - | LAST i = ide - { Elast(i) } - | a = atomic_constant - { Econst a } - | LBRACE l = label_expression_list RBRACE - { Erecord(l) } - | LBRACE e = simple_expression WITH l = label_expression_list RBRACE - { Erecord_with(e, l) } - | LPAREN RPAREN - { Econst Evoid } - | LPAREN e = expression_comma_list RPAREN - { Etuple (List.rev e) } - | LPAREN e = seq_expression RPAREN - { e.desc } - | LPAREN e = simple_expression COLON t = type_expression RPAREN - { Etypeconstraint(e, t) } - | e = simple_expression DOT i = ext_ident - { Erecord_access(e, i) } - | LBRACKETBAR e1 = simple_expression BAR e2 = simple_expression RBRACKETBAR - { Eop(Econcat, [e1; e2]) } - | LBRACKETBAR e1 = simple_expression WITH i = simple_expression - EQUAL e2 = expression RBRACKETBAR - { Eop(Eupdate, [e1; i; e2]) } -; - -simple_expression_list : - | e = simple_expression - { [e] } - | l = simple_expression_list e = simple_expression - { e :: l } - ; - -expression_comma_list : - | ecl = expression_comma_list COMMA e = expression - { e :: ecl } - | e1 = expression COMMA e2 = expression - { [e2; e1] } -; - -expression: - | x = localized(expression_desc) - { x } -; - -expression_desc: - | e = simple_expression_desc - { e } - | e = expression_comma_list %prec prec_list - { Etuple(List.rev e) } - | e1 = simple_expression COLONCOLON e2 = expression - { cons_desc e1 e2 ($startpos(e1)) ($endpos(e2)) } - | e1 = expression FBY e2 = expression - { Eop(Efby, [e1; e2]) } - | f = simple_expression l = simple_expression_list - { app f (List.rev l) } - | INLINE f = simple_expression l = simple_expression_list - { Eapp({ app_inline = true; app_statefull = false}, f, List.rev l) } - | RUN f = simple_expression l = simple_expression_list - { Eapp({ app_inline = false; app_statefull = true}, f, List.rev l) } - | INLINE RUN f = simple_expression l = simple_expression_list - { Eapp({ app_inline = true; app_statefull = true}, f, List.rev l) } - /* | RUN f = simple_expression e = simple_expression { Eop(Erun, [f; e]) } */ - | ATOMIC e = expression - { Eop(Eatomic, [e]) } - | PRE e = expression - { Eop(Eunarypre, [e]) } - | INIT - { Eop(Einitial, []) } - | UP e = expression - { Eop(Eup, [e]) } - | TEST e = expression - { Eop(Etest, [e]) } - | DISC e = expression - { Eop(Edisc, [e]) } - | IF e1 = seq_expression THEN e2 = seq_expression ELSE e3 = expression - { Eop(Eifthenelse, [e1; e2; e3]) } - | e1 = expression MINUSGREATER e2 = expression - { Eop(Eminusgreater, [e1; e2]) } - | MINUS e = expression %prec prec_uminus - { unary_minus "-" e ($startpos($1)) ($endpos($1)) } - | s = SUBTRACTIVE e = expression %prec prec_uminus - { unary_minus s e ($startpos(s)) ($endpos(s)) } - | e1 = expression i = INFIX4 e2 = expression - { binop i e1 e2 ($startpos(i)) ($endpos(i)) } - | e1 = expression i = INFIX3 e2 = expression - { binop i e1 e2 ($startpos(i)) ($endpos(i)) } - | e1 = expression i = INFIX2 e2 = expression - { binop i e1 e2 ($startpos(i)) ($endpos(i)) } - | e1 = expression PLUS e2 = expression - { binop "+" e1 e2 ($startpos($2)) ($endpos($2)) } - | e1 = expression i = INFIX1 e2 = expression - { binop i e1 e2 ($startpos(i)) ($endpos(i)) } - | e1 = expression i = INFIX0 e2 = expression - { binop i e1 e2 ($startpos(i)) ($endpos(i)) } - | e1 = expression EQUAL e2 = expression - { binop "=" e1 e2 ($startpos($2)) ($endpos($2)) } - | e1 = expression OR e2 = expression - { binop "or" e1 e2 ($startpos($2)) ($endpos($2)) } - | e1 = expression STAR e2 = expression - { binop "*" e1 e2 ($startpos($2)) ($endpos($2)) } - | e1 = expression AMPERSAND e2 = expression - { binop "&" e1 e2 ($startpos($2)) ($endpos($2)) } - | e1 = expression MINUS e2 = expression - { binop "-" e1 e2 ($startpos($2)) ($endpos($2)) } - | e1 = expression s = SUBTRACTIVE e2 = expression - { binop s e1 e2 ($startpos(s)) ($endpos(s)) } - | e1 = expression AMPERAMPER e2 = expression - { binop "&&" e1 e2 ($startpos($2)) ($endpos($2)) } - | e1 = expression BARBAR e2 = expression - { binop "||" e1 e2 ($startpos($2)) ($endpos($2)) } - | p = PREFIX e = expression - { unop p e ($startpos(p)) ($endpos(p)) } - | e = simple_expression - LBRACE s1 = size_expression DOTDOT s2 = size_expression RBRACE - { Eop(Eslice(s1, s2), [e]) } - | e1 = simple_expression DOT LPAREN e2 = expression RPAREN - { Eop(Eaccess, [e1; e2]) } - | LET defs = equation_list IN e = seq_expression - { Elet(false, defs, e) } - | LET REC defs = equation_list IN e = seq_expression - { Elet(true, defs, e) } - | PERIOD p = period_expression - { Eperiod(p) } - | AUTOMATON opt_bar a = automaton_handlers(seq_expression) - { Eautomaton(List.rev a, None) } - | AUTOMATON opt_bar a = automaton_handlers(seq_expression) INIT s = state - { Eautomaton(List.rev a, Some(s)) } - | MATCH e = seq_expression WITH opt_bar m = match_handlers(expression) opt_end - { Ematch(e, List.rev m) } - | PRESENT opt_bar pe = present_handlers(expression) opt_end - { Epresent(List.rev pe, None) } - | PRESENT opt_bar pe = present_handlers(expression) INIT e = expression - { Epresent(List.rev pe, Some(Init(e))) } - | PRESENT opt_bar pe = present_handlers(expression) ELSE e = seq_expression opt_end - { Epresent(List.rev pe, Some(Default(e))) } - | RESET e = seq_expression EVERY r = expression - { Ereset(e, r) } - | lo = local_list DO eqs = equation_list IN r = expression - { Eblock(make { b_locals = []; b_vars = lo; b_body = eqs } - $startpos $endpos, r) } -; - -/* Periods */ -period_expression: - | LPAREN per = expression RPAREN /* period */ - { { p_phase = None; p_period = per } } - | LPAREN ph = expression BAR per = expression RPAREN /* period */ - { { p_phase = Some(ph); p_period = per } } -; - -constructor: - | c = CONSTRUCTOR - { Name(c) } %prec prec_ident - | c1 = CONSTRUCTOR DOT c2 = CONSTRUCTOR - { Modname({qual = c1; id = c2}) } -; - -qual_ident: - | c = CONSTRUCTOR DOT i = ide - { {qual = c; id = i} } -; - -/* Constants */ - -atomic_constant: - | i = INT - { Eint(i) } - | f = FLOAT - { Efloat(f) } - | s = STRING - { Estring s } - | c = CHAR - { Echar c } - | b = BOOL - { Ebool b } -; - -label_expression_list: - | l = label_expression - { [l] } - | l = label_expression SEMI - { [l] } - | l = label_expression SEMI ll = label_expression_list - { l :: ll } - -label_expression: - | i = ext_ident EQUAL e = expression - { (i, e) } -; - -/* identifiers */ -ide: - | i = IDENT - { i } - | LPAREN i = infx RPAREN - { i } -; - -ext_ident : - | q = qual_ident - { Modname(q) } - | i = ide - { Name(i) } -; - -infx: - | INFIX0 { $1 } - | INFIX1 { $1 } | INFIX2 { $1 } - | INFIX3 { $1 } | INFIX4 { $1 } - | STAR { "*" } - | PLUS { "+" } - | MINUS { "-" } - | EQUAL { "=" } - | EQUALEQUAL { "==" } - | SUBTRACTIVE { $1 } | PREFIX { $1 } - | AMPERSAND { "&" } | AMPERAMPER { "&&" } - | OR { "or" } | BARBAR { "||" } - | ON { "on" } -; - -%inline arrow: - | MINUSGREATER - { Zparsetree.A } - | AFUN - { Zparsetree.A } - | ADFUN - { Zparsetree.AD } - | DFUN - { Zparsetree.D } - | CFUN - { Zparsetree.C } - | SFUN - { Zparsetree.S } - | ASFUN - { Zparsetree.AS } - | PFUN - { Zparsetree.P } -; - -size_expression: - s = localized(size_expression_desc) { s } -; - -size_expression_desc: - | v = INT - { Sconst(v) } - | s = ext_ident - { Sname(s) } - | s1 = size_expression PLUS s2 = size_expression - { Sop(Splus, s1, s2) } - | s1 = size_expression MINUS s2 = size_expression - { Sop(Sminus, s1, s2) } -; - -type_expression: - | t = simple_type - { t } - | tl = type_star_list - { make(Etypetuple(List.rev tl)) $startpos $endpos} - | t_arg = type_expression a = arrow t_res = type_expression - { make(Etypefun(a, None, t_arg, t_res)) $startpos $endpos} - | LPAREN id = IDENT COLON t_arg = type_expression RPAREN - a = arrow t_res = type_expression - { make(Etypefun(a, Some(id), t_arg, t_res)) $startpos $endpos} -; - -simple_type: - | t = type_var - { make (Etypevar t) $startpos $endpos } - | i = ext_ident - { make (Etypeconstr(i, [])) $startpos $endpos } - | t = simple_type i = ext_ident - { make (Etypeconstr(i, [t])) $startpos $endpos } - | LPAREN t = type_expression COMMA tl = type_comma_list RPAREN i = ext_ident - { make (Etypeconstr(i, t :: tl)) $startpos $endpos } - | t_arg = simple_type LBRACKET s = size_expression RBRACKET - { make(Etypevec(t_arg, s)) $startpos $endpos} - | LPAREN t = type_expression RPAREN - { t } -; - -type_star_list: - | t1 = simple_type STAR t2 = simple_type - { [t2; t1] } - | tsl = type_star_list STAR t = simple_type - { t :: tsl } -; - -type_var : - | QUOTE i = IDENT - { i } -; - -type_comma_list : - | te = type_expression COMMA tl = type_comma_list - { te :: tl } - | te = type_expression - { [te] } -; - -%inline kind: - | NODE - { D } - | HYBRID - { C } - | DISCRETE - { AD } - | FUN - { A } - | STATIC - { S } - | PROBA - { P } -; diff --git a/compiler/parsing/zparsetree.ml b/compiler/parsing/zparsetree.ml deleted file mode 100644 index 5b4555ea6..000000000 --- a/compiler/parsing/zparsetree.ml +++ /dev/null @@ -1,282 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* Abstract syntax tree after parsing *) - -open Zlocation - -type kind = | S | AS | A | C | AD | D | P - -(* P - | - D C - \ / - A S - \ / - AS - *) - - -type name = string - -type qualident = { qual: name; id: name } -type longname = - | Name of name - | Modname of qualident - -type 'a localized = { desc: 'a; loc: Zlocation.location } - -(** Types *) -type type_expression = type_expression_desc localized - -and type_expression_desc = - | Etypevar of name - | Etypeconstr of longname * type_expression list - | Etypetuple of type_expression list - | Etypevec of type_expression * size - | Etypefun of kind * string option * type_expression * type_expression - -and size = size_desc localized - -and size_desc = - | Sconst of int - | Sname of longname - | Sop of size_op * size * size - -and size_op = Splus | Sminus - - -(** Declarations and expressions *) -type interface = interface_desc localized - -and interface_desc = - | Einter_open of name - | Einter_typedecl of name * name list * type_decl - | Einter_constdecl of name * type_expression - -and type_decl = type_decl_desc localized - -and type_decl_desc = - | Eabstract_type - | Eabbrev of type_expression - | Evariant_type of constr_decl list - | Erecord_type of (name * type_expression) list - -and constr_decl = constr_decl_desc localized - -and constr_decl_desc = - | Econstr0decl of name - | Econstr1decl of name * type_expression list - -and implementation = implementation_desc localized - -and implementation_desc = - | Eopen of name - | Etypedecl of name * name list * type_decl - | Econstdecl of name * is_static * exp - | Efundecl of name * funexp - -and funexp = - { f_kind: kind; - f_atomic: is_atomic; - f_args: pattern list; - f_body: exp; - f_loc: location } - -and is_atomic = bool - -and is_static = bool - -and exp = desc localized - -and desc = - | Evar of longname - | Econst of immediate - | Econstr0 of constr - | Econstr1 of constr * exp list - | Elast of name - | Eapp of app * exp * exp list - | Eop of op * exp list - | Etuple of exp list - | Erecord_access of exp * longname - | Erecord of (longname * exp) list - | Erecord_with of exp * (longname * exp) list - | Etypeconstraint of exp * type_expression - | Elet of is_rec * eq list * exp - | Eseq of exp * exp - | Eperiod of period - | Ematch of exp * exp match_handler list - | Epresent of exp present_handler list * exp default option - | Eautomaton of exp state_handler list * state_exp option - | Ereset of exp * exp - | Eblock of eq list block * exp - -and is_rec = bool - -and app = { app_inline: bool; app_statefull: bool} - -and 'a default = - | Init of 'a | Default of 'a - -and op = - | Efby | Eunarypre | Eifthenelse | Eminusgreater - | Eup | Einitial | Edisc | Etest | Eaccess | Eupdate - | Eslice of size * size | Econcat | Eatomic - - -and immediate = - | Eint of int - | Efloat of float - | Ebool of bool - | Echar of char - | Estring of string - | Evoid - -and constant = - | Cimmediate of immediate - | Cglobal of longname - -(* a period is of the form period (v1) or period (v1|v2) *) -(* where v1 is the phase. v1 and v2 two static expressions *) -and period = - { p_phase: exp option; (* the two expressions must be static *) - p_period: exp } - -and constr = longname - -and pattern = pdesc localized - -and pdesc = - | Etuplepat of pattern list - | Evarpat of name - | Ewildpat - | Econstpat of immediate - | Econstr0pat of longname - | Econstr1pat of longname * pattern list - | Ealiaspat of pattern * name - | Eorpat of pattern * pattern - | Erecordpat of (longname * pattern) list - | Etypeconstraintpat of pattern * type_expression - -and eq = eqdesc localized - -and eqdesc = - | EQeq of pattern * exp - (* [p = e] *) - | EQder of name * exp * exp option * exp present_handler list - (* [der n = e [init e0] [reset p1 -> e1 | ... | pn -> en]] *) - | EQinit of name * exp - (* [init n = e0] *) - | EQnext of name * exp * exp option - (* [next n = e] or [next n = e init e0] *) - | EQemit of name * exp option - (* [emit n = e] *) - | EQpluseq of name * exp - (* [n += e] *) - | EQautomaton of eq list state_handler list * state_exp option - | EQpresent of eq list block present_handler list * eq list block option - | EQmatch of exp * eq list block match_handler list - | EQifthenelse of exp * eq list block * eq list block option - | EQreset of eq list * exp - | EQand of eq list - | EQbefore of eq list - | EQblock of eq list block - | EQforall of forall_handler - -and 'a block = 'a block_desc localized - -and 'a block_desc = - { b_vars: vardec list; - b_locals: local list; - b_body: 'a } - -and vardec = vardecdesc localized - -and vardecdesc = - { vardec_name: name; (* its name *) - vardec_default: constant default option; - (* either an initial or a default value *) - vardec_combine: longname option; (* an optional combination function *) - } - -and local = local_desc localized - -and local_desc = is_rec * eq list - -and statepat = statepatdesc localized - -and statepatdesc = - | Estate0pat of name - | Estate1pat of name * name list - -and state_exp = state_exp_desc localized - -and state_exp_desc = - | Estate0 of name - | Estate1 of name * exp list - -and escape = - { e_cond: scondpat; (* condition to escape *) - e_reset: bool; (* is-it a reset or not *) - e_block: eq list block option; (* values emited on the transition *) - e_next_state: state_exp; (* next active state *) } - -and scondpat = scondpat_desc localized - -and scondpat_desc = - | Econdand of scondpat * scondpat - | Econdor of scondpat * scondpat - | Econdexp of exp - | Econdon of scondpat * exp - | Econdpat of exp * pattern - -and is_on = bool - -and 'a match_handler = - { m_pat: pattern; - m_body: 'a; } - -and 'a present_handler = - { p_cond: scondpat; - p_body: 'a; } - -and 'a state_handler_desc = - { s_state : statepat; - s_block : 'a block; - s_until : escape list; - s_unless : escape list } - -and 'a state_handler = 'a state_handler_desc localized - -(* the body of a for loop *) -(* for(all|seq) [id in e..e | id in e | id out id]+ - * local id [and id]* - * do eq and ... and eq - * [init - * [[id = e with g] | [last id = e]] - * [and [[id = e with g] | [last id = e]]]* - * done *) -and forall_handler = - { for_indexes: indexes_desc localized list; - for_init: init_desc localized list; - for_body: eq list block} - -and indexes_desc = - | Einput of name * exp - | Eoutput of name * name - | Eindex of name * exp * exp - -and init_desc = - | Einit_last of name * exp - diff --git a/compiler/rewrite/activate.ml b/compiler/rewrite/activate.ml deleted file mode 100644 index 572cad1eb..000000000 --- a/compiler/rewrite/activate.ml +++ /dev/null @@ -1,181 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* removing equations [der x = e init e0 reset z1 -> e1 | ... | zn -> en] *) - -open Zmisc -open Zlocation -open Zident -open Global -open Zelus -open Zaux -open Initial -open Ztypes -open Deftypes - -(* An equation: [der x = e1 init e0 reset z1 -> e1 | ... | zn -> en] *) -(* into: [init x = e0 *) -(* and present (z1) -> do x = e1 done | ... end and der x = e] *) - -let block_of_eq s pat e = - { b_vars = []; b_locals = []; b_body = [eqmake (EQeq(pat, e))]; - b_loc = no_location; b_write = { Deftypes.empty with dv = s }; - b_env = Env.empty } - -let block_of_der s x e = - { b_vars = []; b_locals = []; b_body = [eqmake (EQder(x, e, None, []))]; - b_loc = no_location; - b_write = { Deftypes.empty with der = s }; b_env = Env.empty } - -let block_spat_e_list s pat spat_e_list = - List.map - (fun { p_cond = spat; p_body = e; p_env = env; p_zero = zero } -> - { p_cond = spat; - p_body = block_of_eq s pat e; - p_env = env; p_zero = zero }) spat_e_list - -let present s x spat_e_list e eq_list = - let spat_b_list = - block_spat_e_list s (varpat x Initial.typ_float) spat_e_list in - (* only generate a present if [spat_b_list] is not empty *) - match spat_b_list with - | [] -> (eq_der x e) :: eq_list - | _ -> (eqmake (EQpresent(spat_b_list, None))) :: (eq_der x e) :: eq_list - -let der_present x e e0_opt spat_e_list eq_list = - (* present z1 -> do x = e1 done | ... | zn -> do x = en done - and der x = e and init x = e0 *) - let eq_list = - match e0_opt with - | None -> eq_list - | Some(e0) -> (eq_init x e0) :: eq_list in - present (S.singleton x) x spat_e_list e eq_list - -let rec exp e = - let desc = match e.e_desc with - | Econst(i) -> Econst(i) - | Econstr0(longname) -> Econstr0(longname) - | Eglobal(longname) -> Eglobal(longname) - | Eop(op, e_list) -> Eop(op, List.map exp e_list) - | Elocal(name) -> Elocal(name) - | Elast(name) -> Elast(name) - | Etuple(e_list) -> Etuple(List.map exp e_list) - | Econstr1(c, e_list) -> Econstr1(c, List.map exp e_list) - | Eapp(app, e, e_list) -> - Eapp(app, exp e, List.map exp e_list) - | Erecord(label_e_list) -> - Erecord(List.map (fun (label, e) -> (label, exp e)) label_e_list) - | Erecord_access(e_record, longname) -> - Erecord_access(exp e_record, longname) - | Erecord_with(e_record, label_e_list) -> - Erecord_with(exp e_record, - List.map (fun (label, e) -> (label, exp e)) label_e_list) - | Etypeconstraint(e, ty) -> Etypeconstraint(exp e, ty) - | Eseq(e1, e2) -> Eseq(exp e1, exp e2) - | Eperiod { p_phase = p1; p_period = p2 } -> - Eperiod { p_phase = Zmisc.optional_map exp p1; p_period = exp p2 } - | Elet(l, e) -> Elet(local l, exp e) - | Eblock(b, e) -> Eblock(block b, exp e) - | Epresent _ | Ematch _ -> assert false in - { e with e_desc = desc } - -and local ({ l_eq = eq_list } as l) = - { l with l_eq = equation_list eq_list } - -and equation_list eq_list = List.fold_left equation [] eq_list - -and equation eq_list ({ eq_desc = desc } as eq) = - match desc with - | EQeq(pat, e) -> - { eq with eq_desc = EQeq(pat, exp e) } :: eq_list - | EQpluseq(n, e) -> - { eq with eq_desc = EQpluseq(n, exp e) } :: eq_list - | EQinit(n, e) -> - { eq with eq_desc = EQinit(n, exp e) } :: eq_list - | EQnext(n, e, e0_opt) -> - { eq with eq_desc = - EQnext(n, exp e, optional_map exp e0_opt) } :: eq_list - | EQder(n, e, e0_opt, p_h_e_list) -> - der_present n e e0_opt p_h_e_list eq_list - | EQemit(name, e_opt) -> - { eq with eq_desc = - EQemit(name, Zmisc.optional_map exp e_opt) } :: eq_list - | EQmatch(total, e, m_h_list) -> - { eq with eq_desc = - EQmatch(total, exp e, - List.map - (fun ({ m_body = b } as m) -> { m with m_body = block b }) - m_h_list) } :: eq_list - | EQpresent(p_h_list, b_opt) -> - { eq with eq_desc = - EQpresent - (List.map (fun ({ p_cond = c; p_body = b } as p) -> - { p with p_cond = scondpat c; p_body = block b }) - p_h_list, - Zmisc.optional_map block b_opt) } :: eq_list - | EQreset(res_eq_list, e) -> - { eq with eq_desc = - EQreset(equation_list res_eq_list, exp e) } :: eq_list - | EQand(and_eq_list) -> - { eq with eq_desc = EQand(equation_list and_eq_list) } :: eq_list - | EQbefore(before_eq_list) -> - { eq with eq_desc = EQbefore(equation_list before_eq_list) } :: eq_list - | EQblock(b_eq_list) -> - { eq with eq_desc = EQblock(block b_eq_list) } :: eq_list - | EQforall ({ for_index = i_list; for_init = init_list; - for_body = b_eq_list } as body) -> - let index ({ desc = desc } as ind) = - let desc = match desc with - | Einput(x, e) -> Einput(x, exp e) - | Eoutput _ -> desc - | Eindex(x, e1, e2) -> Eindex(x, exp e1, exp e2) in - { ind with desc = desc } in - let init ({ desc = desc } as ini) = - let desc = match desc with - | Einit_last(x, e) -> Einit_last(x, exp e) in - { ini with desc = desc } in - let i_list = List.map index i_list in - let init_list = List.map init init_list in - let b_eq_list = block b_eq_list in - { eq with eq_desc = EQforall { body with for_index = i_list; - for_init = init_list; - for_body = b_eq_list } } :: - eq_list - | EQautomaton _ -> assert false - -and block ({ b_locals = locals; b_body = eq_list } as b) = - { b with b_locals = List.map local locals; b_body = equation_list eq_list } - -and scondpat ({ desc = desc } as scpat) = - match desc with - | Econdand(scpat1, scpat2) -> - { scpat with desc = Econdand(scondpat scpat1, scondpat scpat2) } - | Econdor(scpat1, scpat2) -> - { scpat with desc = Econdor(scondpat scpat1, scpat2) } - | Econdexp(e) -> - { scpat with desc = Econdexp(exp e) } - | Econdpat(e, p) -> - { scpat with desc = Econdpat(exp e, p) } - | Econdon(scpat, e) -> - { scpat with desc = Econdon(scondpat scpat, exp e) } - -let implementation impl = - match impl.desc with - | Eopen _ | Etypedecl _ -> impl - | Econstdecl(n, is_static, e) -> - { impl with desc = Econstdecl(n, is_static, exp e) } - | Efundecl(n, ({ f_body = e } as body)) -> - { impl with desc = Efundecl(n, { body with f_body = exp e }) } - -let implementation_list impl_list = Zmisc.iter implementation impl_list diff --git a/compiler/rewrite/add_copy_for_last.ml b/compiler/rewrite/add_copy_for_last.ml deleted file mode 100644 index f1fc35a7a..000000000 --- a/compiler/rewrite/add_copy_for_last.ml +++ /dev/null @@ -1,261 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* add an equation [lx = last x] for every variable declared in block *) -(* of equations and replace [last x] by lx *) -(* this step is necessary to make static scheduling possible. It may *) -(* introduce useless copies and is not idempotent. We may add a graph *) -(* argument later to prevent from introducing copies for equations of *) -(* the form [lx = last x] *) - -open Zmisc -open Zlocation -open Deftypes -open Zelus -open Zident -open Zaux - -(* Make an equation [lx = last x] *) -let eq_last lx x ty = eqmake (EQeq(pmake (Evarpat(lx)) ty, emake (Elast(x)) ty)) - -let add x ty (env, subst, eq_list) = - let lx = Zident.fresh "l" in - Env.add lx { t_typ = ty; t_sort = Deftypes.variable } env, - Env.add x lx subst, - (eq_last lx x ty) :: eq_list - -(* Computes the set of variables [last x] from [b_env] *) -let env subst b_env = - let last x { t_typ = ty; t_sort = sort } (env, subst, eq_list) = - match sort with - | Smem { m_previous = true } -> add x ty (env, subst, eq_list) - | Sstatic | Sval | Svar _ | Smem _ -> env, subst, eq_list in - Env.fold last b_env (Env.empty, subst, []) - -(* [extend_block b env eq_list] returns a block in which [env] and [eq_list] *) -(* are added to the environment and the set of equations *) -let extend_block - ({ b_vars = b_vars; b_env = b_env; b_body = body_eq_list } as b) - env eq_list = - let b_vars = - Env.fold (fun i entry acc -> Zaux.vardec_from_entry i entry :: acc) - env b_vars in - { b with b_vars = b_vars; b_env = Env.append env b_env; - b_body = eq_list @ body_eq_list } - -(* translating a present statement *) -let present_handlers scondpat body p_h_list = - List.map - (fun ({ p_cond = scpat; p_body = b } as handler) -> - { handler with p_cond = scondpat scpat; p_body = body b }) - p_h_list - -(* replace some occurrences of [last x] by [lx]. [subst(x) = lx] *) -let rec exp subst ({ e_desc } as e) = - let e_desc = match e_desc with - | Elast(x) -> - begin try Elocal(Env.find x subst) with Not_found -> e_desc end - | Elocal _ | Econst _ | Econstr0 _ | Eglobal _ -> e_desc - | Etuple(e_list) -> - Etuple (List.map (exp subst) e_list) - | Econstr1(c, e_list) -> Econstr1(c, List.map (exp subst) e_list) - | Eop(op, e_list) -> Eop(op, List.map (exp subst) e_list) - | Eapp(app, e_op, e_list) -> - let e_list = List.map (exp subst) e_list in - Eapp(app, exp subst e_op, e_list) - | Erecord(label_e_list) -> - let label_e_list = - List.map (fun (l, e) -> (l, exp subst e)) label_e_list in - Erecord(label_e_list) - | Erecord_access(e_record, longname) -> - Erecord_access(exp subst e_record, longname) - | Erecord_with(e_record, label_e_list) -> - let label_e_list = - List.map (fun (l, e) -> (l, exp subst e)) label_e_list in - Erecord_with(exp subst e_record, label_e_list) - | Etypeconstraint(e1, ty) -> - Etypeconstraint(exp subst e1, ty) - | Elet(l, e) -> - let l, subst = local subst l in Elet(l, exp subst e) - | Eseq(e1, e2) -> - Eseq(exp subst e1, exp subst e2) - | Epresent(p_h_list, e_opt) -> - let e_opt = Zmisc.optional_map (exp subst) e_opt in - let p_h_list = present_handler_exp_list subst p_h_list in - Epresent(p_h_list, e_opt) - | Ematch(total, e, m_h_list) -> - let e = exp subst e in - let m_h_list = match_handler_exp_list subst m_h_list in - Ematch(total, e, m_h_list) - | Eblock(b, e) -> - let subst, b = block_eq_list_with_substitution subst b in - Eblock(b, exp subst e) - | Eperiod { p_phase = p1; p_period = p2 } -> - Eperiod { p_phase = Zmisc.optional_map (exp subst) p1; - p_period = exp subst p2 } in - { e with e_desc = e_desc } - -(** Translation of equations. *) -and equation subst ({ eq_desc } as eq) = - match eq_desc with - | EQeq(p, e) -> - { eq with eq_desc = EQeq(p, exp subst e) } - | EQpluseq(x, e) -> - { eq with eq_desc = EQpluseq(x, exp subst e) } - | EQinit(x, e0) -> - { eq with eq_desc = EQinit(x, exp subst e0) } - | EQnext(n, e, e0_opt) -> - { eq with eq_desc = EQnext(n, exp subst e, - optional_map (exp subst) e0_opt) } - | EQder(x, e, e0_opt, p_h_e_list) -> - { eq with eq_desc = EQder(x, exp subst e, optional_map (exp subst) e0_opt, - present_handler_exp_list subst p_h_e_list) } - | EQmatch(total, e, p_h_list) -> - let p_h_list = - List.map - (fun ({ m_body = b } as h) -> - { h with m_body = block_eq_list subst b }) - p_h_list in - { eq with eq_desc = EQmatch(total, exp subst e, p_h_list) } - | EQreset(res_eq_list, e) -> - let res_eq_list = equation_list subst res_eq_list in - { eq with eq_desc = EQreset(res_eq_list, exp subst e) } - | EQand(and_eq_list) -> - { eq with eq_desc = EQand(equation_list subst and_eq_list) } - | EQbefore(before_eq_list) -> - { eq with eq_desc = - EQbefore(equation_list subst before_eq_list) } - | EQblock(b) -> { eq with eq_desc = EQblock(block_eq_list subst b) } - | EQforall ({ for_index = i_list; for_init = init_list; - for_body = b_eq_list } as body) -> - let index ({ desc = desc } as ind) = - let desc = match desc with - | Einput(x, e) -> Einput(x, exp subst e) - | Eoutput _ -> desc - | Eindex(x, e1, e2) -> - Eindex(x, exp subst e1, exp subst e2) in - { ind with desc = desc } in - (* any use of [last x] where [x] is an accumulated value is renammed *) - (* in [lx] with [lx] a local variable and [lx = last x] added *) - let init acc ({ desc = desc } as ini) = - let desc, acc = match desc with - | Einit_last(x, e) -> - Einit_last(x, exp subst e), add x e.e_typ acc in - { ini with desc = desc }, acc in - let i_list = List.map index i_list in - let init_list, (env, subst, eq_list) = - Zmisc.map_fold init (Env.empty, subst, []) init_list in - let b_eq_list = - extend_block (block_eq_list subst b_eq_list) env eq_list in - { eq with eq_desc = - EQforall { body with for_index = i_list; - for_init = init_list; - for_body = b_eq_list } } - | EQpresent(p_h_b_eq_list, b_opt) -> - let p_h_b_eq_list = present_handler_block_eq_list subst p_h_b_eq_list in - let b_opt = - match b_opt with - | None -> None | Some(b) -> Some(block_eq_list subst b) in - { eq with eq_desc = EQpresent(p_h_b_eq_list, b_opt) } - | EQautomaton(is_weak, state_handler_list, se_opt) -> - (* translating a state *) - let state subst ({ desc = desc; loc = loc } as se) = - match desc with - | Estate0 _ -> se - | Estate1(n, e_list) -> - { se with desc = Estate1(n, List.map (exp subst) e_list) } in - let escape subst - ({ e_cond = scpat; e_block = b_opt; - e_next_state = se } as esc) = - let scpat = scondpat subst scpat in - let b_opt = Zmisc.optional_map (block_eq_list subst) b_opt in - let se = state subst se in - { esc with e_cond = scpat; e_block = b_opt; e_next_state = se } in - let handler subst ({ s_body = b; s_trans = trans } as h) = - { h with s_body = block_eq_list subst b; - s_trans = List.map (escape subst) trans } in - { eq with eq_desc = - EQautomaton(is_weak, - List.map (handler subst) state_handler_list, - Zmisc.optional_map (state subst) se_opt) } - | EQemit(name, e_opt) -> - { eq with eq_desc = EQemit(name, optional_map (exp subst) e_opt) } - - -and equation_list subst eq_list = List.map (equation subst) eq_list - -(* Translate a generic block *) -and block_eq_list_with_substitution subst - ({ b_vars = vardec_list; - b_locals = l_list; b_body = eq_list; - b_env = b_env } as b) = - (* Identify variables [last x] in [b_env] *) - let b_env_last_list, subst, eq_last_list = env subst b_env in - let l_list, subst = locals subst l_list in - (* translate the body. *) - let eq_list = equation_list subst eq_list in - subst, - extend_block { b with b_locals = l_list; b_body = eq_list } - b_env_last_list eq_last_list - -and block_eq_list subst b = - let _, b = block_eq_list_with_substitution subst b in b - -and present_handler_exp_list subst p_h_e_list = - present_handlers (scondpat subst) (exp subst) p_h_e_list - -and present_handler_block_eq_list subst p_h_b_eq_list = - present_handlers (scondpat subst) (block_eq_list subst) p_h_b_eq_list - -and match_handler_exp_list subst m_h_list = - List.map (fun ({ m_body = e } as handler) -> - { handler with m_body = exp subst e }) m_h_list - -and match_handler_block_eq_list subst m_h_list = - List.map (fun ({ m_body = b } as handler) -> - { handler with m_body = block_eq_list subst b }) m_h_list - -and local subst ({ l_eq = l_eq_list; l_env = l_env } as l) = - let l_env_last_list, subst, eq_last_list = env subst l_env in - let l_eq_list = equation_list subst l_eq_list in - { l with l_eq = eq_last_list @ l_eq_list; - l_env = Env.append l_env_last_list l_env }, subst - -and locals subst l_list = - match l_list with - | [] -> [], subst - | l :: l_list -> - let l, subst = local subst l in - let l_list, subst = locals subst l_list in - l :: l_list, subst - -and scondpat subst ({ desc = desc } as scpat) = - let desc = match desc with - | Econdand(scpat1, scpat2) -> - Econdand(scondpat subst scpat1, scondpat subst scpat2) - | Econdor(scpat1, scpat2) -> - Econdor(scondpat subst scpat1, scondpat subst scpat2) - | Econdexp(e) -> Econdexp(exp subst e) - | Econdpat(e, p) -> Econdpat(exp subst e, p) - | Econdon(scpat, e) -> Econdon(scondpat subst scpat, exp subst e) in - { scpat with desc = desc } - -let implementation impl = - match impl.desc with - | Eopen _ | Etypedecl _ | Econstdecl _ - | Efundecl(_, { f_kind = S | A }) -> impl - | Efundecl(n, ({ f_body = e } as body)) -> - { impl with desc = Efundecl(n, { body with f_body = exp Env.empty e }) } - -let implementation_list impl_list = Zmisc.iter implementation impl_list diff --git a/compiler/rewrite/aform.ml b/compiler/rewrite/aform.ml deleted file mode 100644 index d378af82a..000000000 --- a/compiler/rewrite/aform.ml +++ /dev/null @@ -1,250 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* A-normal form: distribution of tuples *) -(* for any variable [x: t1 *...* t2n, introduce fresh names *) -(* [x1:t1,...,xn:tn] so that [x = (x1,...,xn)] *) -(* distribute pattern matchings [(p1,...,pn) = (e1,...,en)] into *) -(* p1 = e1 and ... pn = en] *) -open Zident -open Zelus -open Deftypes - -let find x subst = - try - Env.find x subst - with Not_found -> - Zmisc.internal_error "Aform: unbound name" Printer.name x - -let exp_of_name x subst = - let _, e = find x subst in e - -let pat_of_name x subst = - let p, _ = find x subst in p - -let name_of_name x subst = - let p, _ = find x subst in - match p.p_desc with - | Evarpat(m) -> m - | _ -> Zmisc.internal_error "Aform: should be a name" Printer.name x - -(* associate a pattern and an expression to a variable according to its type *) -let build l_env subst = - (* returns a pair [spat, se] with [spat] a pattern, [se] an expression *) - let result acc { source = s } ty sort = - let id = Zident.fresh s in - (Zaux.varpat id ty, Zaux.var id ty), - Env.add id { t_typ = ty; t_sort = sort } acc in - let rec value s sort acc ty = - match ty.t_desc with - | Tvar | Tfun _ | Tvec _ | Tconstr _ -> result acc s ty sort - | Tproduct(ty_list) -> - let p_e_list, acc = Zmisc.map_fold (value s sort) acc ty_list in - let p_list, e_list = List.split p_e_list in - (Zaux.tuplepat p_list, Zaux.tuple e_list), acc - | Tlink(ty_link) -> value s sort acc ty_link in - let add n { t_typ; t_sort } (subst_acc, env_acc) = - match t_sort with - | Sval | Sstatic -> - let r, env_acc = value n t_sort env_acc t_typ in - Env.add n r subst_acc, env_acc - | _ -> - (* state variables are not splitted but renamed *) - let r, env_acc = result env_acc n t_typ t_sort in - Env.add n r subst_acc, env_acc in - Env.fold add l_env (subst, Env.empty) - -(* matching. Translate [(p1,...,pn) = (e1,...,en)] into the set of *) -(* equations [p1 = e1 and ... and pn = en] *) -(* [compose] defines the type of equation: [init p = e] or [p = e] *) -let rec matching compose eq_list p e = - match p.p_desc, e.e_desc with - | Etuplepat(p_list), Etuple(e_list) -> - matching_list compose eq_list p_list e_list - | _ -> (compose p e) :: eq_list - -and matching_list compose eq_list p_list e_list = - List.fold_left2 (matching compose) eq_list p_list e_list - -(** expressions *) -let rec expression subst ({ e_desc = desc } as e) = - match desc with - | Econst _ | Econstr0 _ | Eglobal _ -> e - | Elast(x) -> { e with e_desc = Elast(name_of_name x subst) } - | Elocal(x) -> - let ename = exp_of_name x subst in - { e with e_desc = ename.e_desc } - | Etuple(e_list) -> - { e with e_desc = Etuple(List.map (expression subst) e_list) } - | Econstr1(c, e_list) -> - { e with e_desc = Econstr1(c, List.map (expression subst) e_list) } - | Erecord(n_e_list) -> - { e with e_desc = - Erecord(List.map (fun (ln, e) -> - (ln, expression subst e)) n_e_list) } - | Erecord_access(e_record, ln) -> - { e with e_desc = Erecord_access(expression subst e_record, ln) } - | Erecord_with(e_record, n_e_list) -> - { e with e_desc = - Erecord_with(expression subst e_record, - List.map (fun (ln, e) -> - (ln, expression subst e)) n_e_list) } - | Eop(op, e_list) -> - { e with e_desc = Eop(op, List.map (expression subst) e_list) } - | Eapp(app, e_op, e_list) -> - let e_op = expression subst e_op in - let e_list = List.map (expression subst) e_list in - { e with e_desc = Eapp(app, e_op, e_list) } - | Etypeconstraint(e1, ty) -> - { e with e_desc = Etypeconstraint(expression subst e1, ty) } - | Eseq(e1, e2) -> - { e with e_desc = Eseq(expression subst e1, expression subst e2) } - | Elet(l, e_let) -> - let subst, l = local subst l in - { e with e_desc = Elet(l, expression subst e_let) } - | Eperiod _ | Epresent _ | Ematch _ | Eblock _ -> assert false - -(** Local declarations *) -and local subst ({ l_eq = eq_list; l_env = l_env } as l) = - let subst, l_env = build l_env subst in - let eq_list = equation_list subst eq_list in - subst, { l with l_eq = eq_list; l_env = l_env } - -and pattern subst p = - match p.p_desc with - | Ewildpat | Econstpat _ | Econstr0pat _ -> p - | Etuplepat(p_list) -> - { p with p_desc = Etuplepat(List.map (pattern subst) p_list) } - | Econstr1pat(c, p_list) -> - { p with p_desc = Econstr1pat(c, List.map (pattern subst) p_list) } - | Evarpat(x) -> - let pname = pat_of_name x subst in - { p with p_desc = pname.p_desc } - | Ealiaspat(p1, n) -> - { p with p_desc = Ealiaspat(pattern subst p1, name_of_name n subst) } - | Eorpat(p1, p2) -> - { p with p_desc = Eorpat(pattern subst p1, pattern subst p2) } - | Erecordpat(l_p_list) -> - let l_p_list = - List.map (fun (l, p) -> (l, pattern subst p)) l_p_list in - { p with p_desc = Erecordpat(l_p_list) } - | Etypeconstraintpat(p1, ty) -> - { p with p_desc = Etypeconstraintpat(pattern subst p1, ty) } - -and equation subst eq_list ({ eq_desc = desc } as eq) = - let returns eq eq_desc eq_list = - { eq with eq_desc = eq_desc; eq_write = Deftypes.empty } :: eq_list in - match desc with - | EQeq(p, e) -> - let p = pattern subst p in - let e = expression subst e in - matching (fun p e -> Zaux.eqmake (EQeq(p, e))) eq_list p e - | EQder(x, e, e_opt, []) -> - returns eq (EQder(name_of_name x subst, expression subst e, - Zmisc.optional_map (expression subst) e_opt, [])) eq_list - | EQinit(x, e) -> - (* [x] should not be renamed as it is a state variable *) - returns eq (EQinit(name_of_name x subst, - expression subst e)) eq_list - | EQnext(x, e, e_opt) -> - (* [x] should not be renamed as it is a state variable *) - returns eq (EQnext(name_of_name x subst, expression subst e, - Zmisc.optional_map (expression subst) e_opt)) eq_list - | EQpluseq(x, e) -> - (* [x] should not be renamed as it is a multi-write variable *) - returns eq (EQpluseq(name_of_name x subst, - expression subst e)) eq_list - | EQreset(reset_eq_list, e) -> - returns eq (EQreset(equation_list subst reset_eq_list, - expression subst e)) eq_list - | EQmatch(total, e, m_h_list) -> - returns eq (EQmatch(total, expression subst e, - List.map (handler subst) m_h_list)) eq_list - | EQblock(b) -> - returns eq (EQblock(block subst b)) eq_list - | EQand(and_eq_list) -> - returns eq (EQand(equation_list subst and_eq_list)) eq_list - | EQbefore(before_eq_list) -> - returns eq (EQbefore(equation_list subst before_eq_list)) eq_list - | EQforall ({ for_index = i_list; for_init = init_list; - for_body = b_eq_list; - for_in_env = fi_env; for_out_env = fo_env } as b) -> - let subst, fi_env = build fi_env subst in - let subst, fo_env = build fo_env subst in - let index ({ desc = desc } as ind) = - let desc = match desc with - | Einput(i, e) -> Einput(name_of_name i subst, expression subst e) - | Eoutput(oi, o) -> - Eoutput(name_of_name oi subst, name_of_name o subst) - | Eindex(i, e1, e2) -> - Eindex(name_of_name i subst, - expression subst e1, expression subst e2) in - { ind with desc = desc } in - let init ({ desc = desc } as ini) = - let desc = match desc with - | Einit_last(i, e) -> - Einit_last(name_of_name i subst, expression subst e) in - { ini with desc = desc } in - let i_list = List.map index i_list in - let init_list = List.map init init_list in - let b_eq_list = block subst b_eq_list in - returns eq - (EQforall - { b with for_index = i_list; for_init = init_list; - for_body = b_eq_list; for_in_env = fi_env; - for_out_env = fo_env }) eq_list - | EQautomaton _ | EQpresent _ | EQder _ | EQemit _ -> assert false - -and equation_list subst eq_list = - let eq_list = List.fold_left (equation subst) [] eq_list in List.rev eq_list - -and handler subst ({ m_pat = p; m_body = b; m_env = m_env } as m_h) = - let subst, m_env = build m_env subst in - let p = pattern subst p in - { m_h with m_pat = p; m_body = block subst b; m_env = m_env } - - -and block subst ({ b_vars = v_list; b_body = eq_list; b_env = b_env } as b) = - (* the field [b.b_locals] must be [] as this compilation step is done *) - (* after normalisation *) - let vardec_list subst v_list = - (* Warning. if [n] is a state variable or associated with a *) - (* default value of combine function, it is not split into a tuple *) - (* but a single name. The code below makes this assumption. *) - let vardec acc ({ vardec_name = n} as v) = - let p = pat_of_name n subst in - let nset = Vars.fv_pat S.empty S.empty p in - S.fold (fun n acc -> { v with vardec_name = n } :: acc) nset acc in - List.fold_left vardec [] v_list in - - let subst, b_env = build b_env subst in - let v_list = vardec_list subst v_list in - { b with b_vars = v_list; b_body = equation_list subst eq_list; - b_env = b_env; b_write = Deftypes.empty } - -let implementation impl = - match impl.desc with - | Eopen _ | Etypedecl _ -> impl - | Econstdecl(n, is_static, e) -> - { impl with desc = Econstdecl(n, is_static, expression Env.empty e) } - | Efundecl(n, ({ f_body = e; f_env = f_env; f_args = p_list } as body)) -> - let subst, f_env = build f_env Env.empty in - let p_list = List.map (pattern subst) p_list in - let e = expression subst e in - { impl with desc = - Efundecl(n, { body with f_body = e; - f_env = f_env; f_args = p_list }) } - -let implementation_list impl_list = Zmisc.iter implementation impl_list - diff --git a/compiler/rewrite/automata.ml b/compiler/rewrite/automata.ml deleted file mode 100644 index eab98dbcd..000000000 --- a/compiler/rewrite/automata.ml +++ /dev/null @@ -1,530 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* removing automata statements *) -open Zmisc -open Zlocation -open Zident -open Global -open Deftypes -open Zaux -open Zelus -open Initial - -(* Translation of automata. *) -(* Strong transitions: *) -(* automaton - | S1 -> locals in - do eq_list - unless | c'1 then do eq_list''1 in S''1(e'1) | ... - | S2(p) -> ...p... | c2 then ...p... - ... - end - -is translated into: - - local state, res in - do init state = S1 - and init res = false - and - match last state with - | S1 -> reset - present - | c'1 -> eq_list''1 - and state = S''1 and p1 = e'1 and res = true - | ... - else res = false - every last res - | S2 -> ... last p ... - end - and - match state with - | S1 -> reset - locals in do eq_list - every res - | S2 -> ...p... *) - -(* Weak transitions: *) -(* automaton - | S1 -> locals in - do eq_list - until | c1 then do eq_list'1 in S'1(e1) | ... | ck then S'k(ek) - | S2(p) -> ...p... | c2 then ... - ... - end - -is translated into: - - local state, res in - do init state = S1 in - do init res = false in - match last state with - | S1 -> reset - locals - and - present - | c1 -> eq_list1 and - state = S'1 and next p1 = e1 and res = true - | ... - else res = false - every last res - | S2 -> ...last p... - end - -2. Builds a local table table_of_types for every new type -*) - -let moduleident n = - { n with source = (Modules.current_module ()) ^ "_" ^ n.source } - -let eblock eq_list = - { b_vars = []; b_locals = []; b_body = eq_list; b_loc = no_location; - b_write = Deftypes.empty; b_env = Env.empty } -let eq_present l_true l_false = - match l_true, l_false with - | [], _ -> l_false - | _, [] -> [eqmake (EQpresent(l_true, None))] - | _ -> [eqmake (EQpresent(l_true, Some(eblock l_false)))] - -let extend_block eq_list b_opt = - match b_opt with - | None -> eblock eq_list - | Some(b) -> { b with b_body = eq_list @ b.b_body } - - -module TableOfTypes = -struct - let table_of_types = ref [] - let add tyname ty_desc = - table_of_types := (tyname, ty_desc) :: !table_of_types - let make desc = { Zelus.desc = desc; Zelus.loc = no_location } - let flush continuation = - let translate (tyname, ty_desc) continuation = - let n, params, ty_desc = - Interface.type_decl_of_type_desc tyname ty_desc in - make (Etypedecl(n, params, ty_desc)) :: continuation - in - let continuation = - List.fold_right translate !table_of_types continuation in - table_of_types := []; - continuation -end - -let constr c ty_list = - Deftypes.make - (Deftypes.Tconstr(Modules.qualify c, ty_list, Deftypes.no_abbrev())) - -(* introduce a new type for an enumerated type. This should be a sum type *) -(* type ('a1,...,'ak) state_k = St1 [of 'a1] | ... | Stm [of 'an] *) -(* as it was in Lucid Synchrone. *) -(* Since the language only has 0-arity constructors, we take the following *) -(* type state_k = St1 | ... | Stm *) -(* we use state variables to store the parameters of a state *) -(* this is bad in term of execution time and memory as we allocate the *) -(* sum of variables used in parameters instead of the max *) -let intro_type s_h_list = - - (* we introduce a new type *) - let name = "state__" ^ (string_of_int(symbol#name)) in - - (* introduce a new name for every parameterized state. *) - (* for the moment, we do not share them *) - (* [states] is a set of names [n1;...;nk] and *) - (* [n_to_parameters] associate a list of parameters to a state name *) - let states_and_variables_for_parameters s_h_list = - let variable (states, n_to_parameters) { s_state = statepat } = - match statepat.desc with - | Estate0pat(n) -> (moduleident n) :: states, n_to_parameters - | Estate1pat(n, n_list) -> - (moduleident n) :: states, Env.add n n_list n_to_parameters in - List.fold_left variable ([], Env.empty) s_h_list in - - (* build variants *) - let variants states type_res = - let variant n = - { qualid = Modules.qualify (Zident.name n); - info = { constr_arg = []; constr_res = type_res; - constr_arity = 0 } } in - List.map variant states in - - (* build the result type *) - let type_res = constr name [] in - let states, n_to_parameters = states_and_variables_for_parameters s_h_list in - let v_list = variants states type_res in - let typ_desc = { type_desc = Variant_type(v_list); type_parameters = [] } in - (* we add it to the global environment *) - Modules.add_type name typ_desc; - List.iter2 - (fun n { info = v } -> Modules.add_constr (Zident.name n) v) states v_list; - (* and the environment of state types *) - TableOfTypes.add name typ_desc; - (* compute the set of variables needed for storing parameters *) - type_res, n_to_parameters - -let state_value ty = - let mem = Deftypes.previous Deftypes.empty_mem in - { Deftypes.t_sort = Deftypes.Smem (Deftypes.initialized mem); - Deftypes.t_typ = ty } - -let state_parameter is_init ty = - let mem = Deftypes.previous Deftypes.empty_mem in - { Deftypes.t_sort = - Deftypes.Smem (if is_init then Deftypes.initialized mem else mem); - Deftypes.t_typ = ty } - -(** Adds variables used for state parameters to the environment *) -(** we consider that a parameter variable can be both modified/red with *) -(** [p = ...], [...p...], [...last p...] *) -let env_of_parameters n_to_parameters s_h_list se_opt = - (* test whether or not a state equals [se_opt] *) - let equalstate se_opt { desc = desc } = - match se_opt, desc with - Some({ desc = Estate1(s1, _)}), Estate1pat(s2, _) when s1 = s2 -> true - | _ -> false in - (* extends the global environment [env] with parameters of the *) - (* different state handlers. Every parameter becomes a state variable *) - let entry is_init n { Deftypes.t_typ = ty } acc = - Env.add n (state_parameter is_init ty) acc in - let add acc { s_state = statepat; s_env = env } = - let is_init = equalstate se_opt statepat in - Env.fold (entry is_init) env acc in - (* define an environment *) - let env = List.fold_left add Env.empty s_h_list in - - (* if an initial state [Sk(e1,...,en)] is given *) - (* add equations [init p1 = e1 and ... and pn = en] *) - let eq_list = - match se_opt with - | None | Some({ desc = Estate0 _ }) -> - (* the initial state is the first one or has no parameter *) - [] - | Some({ desc = Estate1(n, e_list) }) -> - let n_list = Env.find n n_to_parameters in - List.map2 (fun n e -> eq_init n e) n_list e_list in - env, eq_list - -(* Translate a generic block *) -let block locals body ({ b_locals = l_list; b_body = bo } as b) = - let l_list = locals l_list in - (* translate the body. *) - let bo = body bo in - { b with b_locals = l_list; b_body = bo } - -(* translating a present statement *) -let present_handlers scondpat body p_h_list = - List.map - (fun ({ p_cond = scpat; p_body = b } as handler) -> - { handler with p_cond = scondpat scpat; p_body = body b }) - p_h_list - -(* translating an expression. [lnames] define state names [x] that must *) -(* be renamed into [last x] *) -let rec exp lnames ({ e_desc = desc } as e) = - let desc = match desc with - | Econst(i) -> Econst(i) - | Econstr0(longname) -> Econstr0(longname) - | Eglobal(longname) -> Eglobal(longname) - | Eop(op, e_list) -> Eop(op, List.map (exp lnames) e_list) - | Elocal(name) -> - (* if [name] belong to [lnames], it is a state parameter *) - (* that must be turn into [last name] *) - if S.mem name lnames then Elast(name) else desc - | Elast(name) -> Elast(name) - | Etuple(e_list) -> Etuple(List.map (exp lnames) e_list) - | Econstr1(c, e_list) -> Econstr1(c, List.map (exp lnames) e_list) - | Eapp(app, e, e_list) -> - Eapp(app, exp lnames e, List.map (exp lnames) e_list) - | Erecord(label_e_list) -> - Erecord(List.map - (fun (label, e) -> (label, exp lnames e)) label_e_list) - | Erecord_access(e_record, longname) -> - Erecord_access(exp lnames e_record, longname) - | Erecord_with(e_record, label_e_list) -> - Erecord_with(exp lnames e_record, - List.map - (fun (label, e) -> (label, exp lnames e)) label_e_list) - | Etypeconstraint(e, ty) -> Etypeconstraint(exp lnames e, ty) - | Eseq(e1, e2) -> Eseq(exp lnames e1, exp lnames e2) - | Eperiod { p_phase = p1; p_period = p2 } -> - Eperiod { p_phase = Zmisc.optional_map (exp lnames) p1; - p_period = exp lnames p2 } - | Elet(l, e) -> Elet(local lnames l, exp lnames e) - | Eblock(b, e) -> Eblock(block_eq_list lnames b, exp lnames e) - | Epresent(p_h_list, e_opt) -> - let e_opt = Zmisc.optional_map (exp lnames) e_opt in - let p_h_list = present_handler_exp_list lnames p_h_list in - Epresent(p_h_list, e_opt) - | Ematch(total, e, m_h_list) -> - let e = exp lnames e in - let m_h_list = match_handler_exp_list lnames m_h_list in - Ematch(total, e, m_h_list) in - { e with e_desc = desc } - -(** Translating an equation. [lnames] defines names [x] that must be *) -(* renamed into [last x] *) -and equation lnames ({ eq_desc = desc } as eq) = - match desc with - | EQeq(pat, e) -> { eq with eq_desc = EQeq(pat, exp lnames e) } - | EQpluseq(n, e) -> { eq with eq_desc = EQpluseq(n, exp lnames e) } - | EQinit(n, e0) -> - { eq with eq_desc = EQinit(n, exp lnames e0) } - | EQnext(n, e, e0_opt) -> - { eq with eq_desc = EQnext(n, exp lnames e, - optional_map (exp lnames) e0_opt) } - | EQder(n, e, e0_opt, p_h_e_list) -> - { eq with eq_desc = - EQder(n, exp lnames e, optional_map (exp lnames) e0_opt, - present_handler_exp_list lnames p_h_e_list) } - | EQemit(name, e_opt) -> - { eq with eq_desc = EQemit(name, optional_map (exp lnames) e_opt) } - | EQmatch(total, e, m_h_list) -> - let m_h_list = match_handler_block_eq_list lnames m_h_list in - { eq with eq_desc = EQmatch(total, exp lnames e, m_h_list) } - | EQpresent(p_h_b_eq_list, b_opt) -> - let p_h_b_eq_list = - present_handler_block_eq_list lnames p_h_b_eq_list in - let b_opt = - match b_opt with - | None -> None | Some(b) -> Some(block_eq_list lnames b) in - { eq with eq_desc = EQpresent(p_h_b_eq_list, b_opt) } - | EQautomaton(is_weak, state_handler_list, se_opt) -> - automaton lnames is_weak state_handler_list se_opt - | EQreset(res_eq_list, e) -> - let res_eq_list = equation_list lnames res_eq_list in - { eq with eq_desc = EQreset(res_eq_list, exp lnames e) } - | EQand(and_eq_list) -> - let and_eq_list = equation_list lnames and_eq_list in - { eq with eq_desc = EQand(and_eq_list) } - | EQbefore(before_eq_list) -> - let before_eq_list = equation_list lnames before_eq_list in - { eq with eq_desc = EQbefore(before_eq_list) } - | EQblock(b_eq_list) -> - { eq with eq_desc = EQblock(block_eq_list lnames b_eq_list) } - | EQforall ({ for_index = i_list; for_init = init_list; - for_body = b_eq_list } as body) -> - let index ({ desc = desc } as ind) = - let desc = match desc with - | Einput(x, e) -> Einput(x, exp lnames e) - | Eoutput _ -> desc - | Eindex(x, e1, e2) -> Eindex(x, exp lnames e1, exp lnames e2) in - { ind with desc = desc } in - let init ({ desc = desc } as ini) = - let desc = match desc with - | Einit_last(x, e) -> Einit_last(x, exp lnames e) in - { ini with desc = desc } in - let i_list = List.map index i_list in - let init_list = List.map init init_list in - let b_eq_list = block_eq_list lnames b_eq_list in - { eq with eq_desc = EQforall { body with for_index = i_list; - for_init = init_list; - for_body = b_eq_list } } - -and equation_list lnames eq_list = List.map (equation lnames) eq_list - -and block_eq_list lnames b = - let locals l_list = List.map (local lnames) l_list in - let body eq_list = equation_list lnames eq_list in - block locals body b - -and present_handler_exp_list lnames p_h_e_list = - present_handlers (scondpat lnames) (exp lnames) p_h_e_list - -and present_handler_block_eq_list lnames p_h_b_eq_list = - present_handlers (scondpat lnames) (block_eq_list lnames) p_h_b_eq_list - -and match_handler_exp_list lnames m_h_list = - List.map - (fun ({ m_body = e } as handler) -> - { handler with m_body = exp lnames e }) m_h_list - -and match_handler_block_eq_list lnames m_h_list = - List.map - (fun ({ m_body = b } as handler) -> - { handler with m_body = block_eq_list lnames b }) m_h_list - -and local lnames ({ l_eq = eq_list } as l) = - { l with l_eq = equation_list lnames eq_list } - -and scondpat lnames ({ desc = desc } as scpat) = - let desc = match desc with - | Econdand(scpat1, scpat2) -> - Econdand(scondpat lnames scpat1, scondpat lnames scpat2) - | Econdor(scpat1, scpat2) -> - Econdor(scondpat lnames scpat1, scondpat lnames scpat2) - | Econdexp(e) -> Econdexp(exp lnames e) - | Econdpat(e, p) -> Econdpat(exp lnames e, p) - | Econdon(scpat, e) -> Econdon(scondpat lnames scpat, exp lnames e) in - { scpat with desc = desc } - -(** Translating an automaton *) -(** [eq_list] is a list of equations. The translation returns *) -(** an extended list containing [eq_list] and new equations *) -and automaton lnames is_weak handler_list se_opt = - (* introduce a sum type to represent states and *) - (* build an environment which associate parameters to states *) - let statetype, n_to_parameters = intro_type handler_list in - - (* for a parameterized state, generate [n = e] when calling the state *) - (* adds equations [init n_1 = e_1 and ... and init n_k = e_k] *) - (* for the initial state if it is entered with an initial value *) - let env, eq_list = - env_of_parameters n_to_parameters handler_list se_opt in - - let longident n = Modules.longname (Zident.name (moduleident n)) in - - (* the name of the initial state *) - let initial = - match se_opt with - | None -> - (* the initial state is the first in the list *) - begin match (List.hd handler_list).s_state.desc with - | Estate0pat(n) -> longident n | _ -> assert false - end - | Some({ desc = Estate0(n) } | { desc = Estate1(n, _) }) -> longident n in - - (* translate states *) - let translate_statepat lnames statepat = - let desc, lnames = - match statepat.desc with - | Estate0pat(n) -> Econstr0pat(longident n), lnames - | Estate1pat(n, l) -> - Econstr0pat(longident n), - List.fold_left (fun acc m -> S.add m acc) lnames l in - { p_desc = desc; p_loc = statepat.loc; - p_typ = statetype; p_caus = Defcaus.no_typ; p_init = Definit.no_typ }, - lnames in - - (* translating a state *) - let translate_state lnames { desc = desc; loc = loc } = - (* make an equation [n = e] *) - let eqmake n e = - eqmake (EQeq(varpat n e.e_typ, exp lnames e)) in - match desc with - | Estate0(n) -> - { e_desc = Econstr0(longident n); - e_loc = loc; - e_typ = statetype; - e_caus = Defcaus.no_typ; - e_init = Definit.no_typ }, [] - | Estate1(n, e_list) -> - let n_list = Env.find n n_to_parameters in - { e_desc = Econstr0(longident n); - e_loc = loc; - e_typ = statetype; - e_caus = Defcaus.no_typ; - e_init = Definit.no_typ }, - List.map2 eqmake n_list e_list in - - (* [state_name] is the target state computed in the current step *) - (* [reset_name] is the target reset bit computed in the current step *) - let state_name = Zident.fresh "s" in - let reset_name = Zident.fresh "r" in - - let state_var n = var n statetype in - let bool_var n = var n typ_bool in - let state_last n = last n statetype in - let bool_last n = last n typ_bool in - - (* Translation of an escape handler *) - let escape lnames { e_cond = e; e_reset = r; e_block = b_opt; - e_next_state = se; e_env = h0; e_zero = zero } = - let e = scondpat lnames e in - let b_opt = Zmisc.optional_map (block_eq_list lnames) b_opt in - let se, eq_list_se = translate_state lnames se in - { p_cond = e; p_env = h0; - p_body = - extend_block - ((eq_make state_name se) :: - (eq_make reset_name (bool r)) :: eq_list_se) b_opt; - p_zero = zero } in - - (* Translation of strong transitions *) - let strong lnames { s_state = statepat; s_body = b; s_trans = trans } = - let pat, snames = translate_statepat lnames statepat in - (* translate the escape expression in which a state parameter [x] *) - (* becomes [last x] *) - let p_h_list = List.map (escape snames) trans in - let handler_to_compute_current_state = - eblock [eq_reset (eq_present p_h_list - [eq_make reset_name efalse]) - (bool_last reset_name)] in - let handler_for_current_active_state = - let b = block_eq_list lnames b in - eblock [eq_reset [eq_block b] (bool_var reset_name)] in - (pat, handler_to_compute_current_state), - (pat, handler_for_current_active_state) in - - (* This function computes what to do with a automaton with weak transitions *) - (* a single match/with is generated *) - let weak lnames { s_state = statepat; s_body = b; s_trans = trans } = - let pat, lnames = translate_statepat lnames statepat in - let p_h_list = List.map (escape lnames) trans in - let b = block_eq_list lnames b in - let eq_next_state = - eq_present p_h_list [eq_make reset_name efalse] in - let b = { b with b_body = eq_next_state @ b.b_body } in - pat, eblock [eq_reset [eq_block b] (bool_last reset_name)] in - - (* the code generated for automata with strong transitions *) - let strong_automaton lnames handler_list eq_list = - let handlers = List.map (strong lnames) handler_list in - let handler_to_compute_current_state_list, - handler_for_current_active_state_list = List.split handlers in - (eq_match (state_last state_name) - (List.map - (fun (pat, body) -> - { m_pat = pat; m_body = body; m_env = Env.empty; - m_reset = false; m_zero = false }) - handler_to_compute_current_state_list)) :: - (eq_match (state_var state_name) - (List.map (fun (pat, body) -> - { m_pat = pat; m_body = body; m_env = Env.empty; - m_reset = false; m_zero = false }) - handler_for_current_active_state_list)) :: eq_list in - (* the code for automatama with weak transitions *) - let weak_automaton lnames handler_list eq_list = - let handlers = List.map (weak lnames) handler_list in - (eq_match (state_last state_name) - (List.map - (fun (pat, body) -> - { m_pat = pat; m_body = body; m_env = Env.empty; - m_reset = false; m_zero = false }) handlers)) :: eq_list in - (* the result *) - let statetype_entry = state_value statetype in - let typ_bool_entry = state_value typ_bool in - let env = - Env.add state_name statetype_entry - (Env.add reset_name typ_bool_entry env) in - (* translate the automaton *) - let eq_list = - if is_weak then weak_automaton lnames handler_list eq_list - else strong_automaton lnames handler_list eq_list in - (* initial state and reset value *) - let eq_list = - (eq_init state_name (emake (Econstr0(initial)) statetype)) :: - (eq_init reset_name efalse) :: eq_list in - Zaux.eq_block (Zaux.make_block env eq_list) - -let implementation impl = - match impl.desc with - | Eopen _ | Etypedecl _ -> impl - | Econstdecl(n, is_static, e) -> - let e = exp S.empty e in - { impl with desc = Econstdecl(n, is_static, e) } - | Efundecl(n, ({ f_body = e } as body)) -> - { impl with desc = Efundecl(n, { body with f_body = exp S.empty e }) } - -let implementation_list impl_list = - let impl_list = Zmisc.iter implementation impl_list in - TableOfTypes.flush impl_list diff --git a/compiler/rewrite/complete.ml b/compiler/rewrite/complete.ml deleted file mode 100644 index 61af79857..000000000 --- a/compiler/rewrite/complete.ml +++ /dev/null @@ -1,164 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* complete branches with a default value [der x = 0.0] for state variables *) -(* This step is applied to normalised equations for which *) -(* read/write information is up-to-date *) - -open Zmisc -open Zlocation -open Deftypes -open Zelus -open Zident -open Zaux - -(* Make an equation [x = e] *) -let eq x e = eqmake (EQeq(pmake (Evarpat(x)) e.e_typ, e)) - -let der_eq_zero x = eqmake (EQder(x, Zaux.zero, None, [])) - -(* complete a set of equations with default equations for every *) -(* variable from [eq_write] which is not defined in [eq_write_block] *) -let complete_eq_list { der = der } ({ der = der_l } as b_write_local) eq_list = - let l = S.diff der der_l in - let eq_list = S.fold (fun x acc -> (der_eq_zero x) :: acc) l eq_list in - eq_list, { b_write_local with der = der } - -let rec exp ({ e_desc } as e) = - let e_desc = match e_desc with - | Elast _ | Elocal _ | Econst _ | Econstr0 _ | Eglobal _ -> e_desc - | Etuple(e_list) -> - Etuple (List.map exp e_list) - | Econstr1(c, e_list) -> Econstr1(c, List.map exp e_list) - | Eop(op, e_list) -> Eop(op, List.map exp e_list) - | Eapp(app, e_op, e_list) -> - let e_list = List.map exp e_list in - Eapp(app, exp e_op, e_list) - | Erecord(label_e_list) -> - let label_e_list = - List.map (fun (l, e) -> (l, exp e)) label_e_list in - Erecord(label_e_list) - | Erecord_access(e_record, longname) -> - Erecord_access(exp e_record, longname) - | Erecord_with(e_record, label_e_list) -> - let label_e_list = - List.map (fun (l, e) -> (l, exp e)) label_e_list in - Erecord_with(exp e_record, label_e_list) - | Etypeconstraint(e1, ty) -> - Etypeconstraint(exp e1, ty) - | Elet(l, e) -> - let l = local l in Elet(l, exp e) - | Eseq(e1, e2) -> - Eseq(exp e1, exp e2) - | Ematch(total, e, m_h_list) -> - let e = exp e in - let m_h_list = match_handler_exp_list m_h_list in - Ematch(total, e, m_h_list) - | Eblock(b, e) -> - let b = block_eq_list b in - Eblock(b, exp e) - | Eperiod _ | Epresent _ -> assert false in - { e with e_desc = e_desc } - -(** Translation of equations. *) -and equation ({ eq_desc; eq_write } as eq) = - match eq_desc with - | EQeq(p, e) -> - { eq with eq_desc = EQeq(p, exp e) } - | EQpluseq(x, e) -> - { eq with eq_desc = EQpluseq(x, exp e) } - | EQinit(x, e0) -> - { eq with eq_desc = EQinit(x, exp e0) } - | EQnext(n, e, e0_opt) -> - { eq with eq_desc = EQnext(n, exp e, optional_map exp e0_opt) } - | EQder(x, e, e0_opt, []) -> - { eq with eq_desc = EQder(x, exp e, optional_map exp e0_opt, []) } - | EQmatch(total, e, p_h_list) -> - let p_h_list = match_handler_block_eq_list eq_write p_h_list in - { eq with eq_desc = EQmatch(total, exp e, p_h_list) } - | EQreset(res_eq_list, e) -> - let res_eq_list = equation_list res_eq_list in - { eq with eq_desc = EQreset(res_eq_list, exp e) } - | EQand(and_eq_list) -> - { eq with eq_desc = EQand(equation_list and_eq_list) } - | EQbefore(before_eq_list) -> - { eq with eq_desc = - EQbefore(equation_list before_eq_list) } - | EQblock(b) -> { eq with eq_desc = EQblock(block_eq_list b) } - | EQforall ({ for_index = i_list; for_init = init_list; - for_body = b_eq_list } as body) -> - let index ({ desc = desc } as ind) = - let desc = match desc with - | Einput(x, e) -> Einput(x, exp e) - | Eoutput _ -> desc - | Eindex(x, e1, e2) -> - Eindex(x, exp e1, exp e2) in - { ind with desc = desc } in - let init ({ desc = desc } as ini) = - let desc = match desc with - | Einit_last(x, e) -> Einit_last(x, exp e) in - { ini with desc = desc } in - let i_list = List.map index i_list in - let init_list = List.map init init_list in - let b_eq_list = block_eq_list b_eq_list in - { eq with eq_desc = - EQforall { body with for_index = i_list; - for_init = init_list; - for_body = b_eq_list } } - | EQder _ | EQpresent _ | EQautomaton _ | EQemit _ -> assert false - -and equation_list eq_list = List.map equation eq_list - -(* Translate a block of equation. [eq_write] is the set of globally *) -(* written variable. The block is completed with missing equations *) -and block_eq_list ({ b_locals = l_list; b_body = eq_list } as b) = - let l_list = locals l_list in - (* translate the body. *) - let eq_list = equation_list eq_list in - { b with b_locals = l_list; b_body = eq_list } - -and complete eq_write ({ b_body = eq_list; b_write = eq_write_block } as b) = - let eq_list, eq_write_block = - complete_eq_list eq_write eq_write_block eq_list in - { b with b_body = eq_list; b_write = eq_write_block } - -and match_handler_exp_list m_h_list = - List.map (fun ({ m_body = e } as handler) -> - { handler with m_body = exp e }) m_h_list - -and match_handler_block_eq_list eq_write m_h_list = - List.map (fun ({ m_zero = zero; m_body = b } as handler) -> - let b = block_eq_list b in - let b = if zero then b else complete eq_write b in - { handler with m_body = b }) m_h_list - -and local ({ l_eq = l_eq_list; l_env = l_env } as l) = - let l_eq_list = equation_list l_eq_list in - { l with l_eq = l_eq_list; l_env = l_env } - -and locals l_list = - match l_list with - | [] -> [] - | l :: l_list -> - let l = local l in - let l_list = locals l_list in - l :: l_list - -let implementation impl = - match impl.desc with - | Efundecl(n, ({ f_kind = C; f_body = e } as body)) -> - { impl with desc = Efundecl(n, { body with f_body = exp e }) } - | Eopen _ | Etypedecl _ | Econstdecl _ | Efundecl _ -> impl - -let implementation_list impl_list = Zmisc.iter implementation impl_list diff --git a/compiler/rewrite/control.ml b/compiler/rewrite/control.ml deleted file mode 100644 index 1df7a8ef0..000000000 --- a/compiler/rewrite/control.ml +++ /dev/null @@ -1,82 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* control optimization. Fusion of conditionals *) -open Zelus -open Deftypes - -(* equality *) -let equal e1 e2 = - match e1.e_desc, e2.e_desc with - | Econst(i), Econst(j) when i = j -> true - | Elocal(i), Elocal(j) when i = j -> true - | Elast(i), Elast(j) when i = j -> true - | _ -> false - -let static_patterns h = - let pattern { p_desc = desc } = - match desc with - | Econstpat _ | Econstr0pat _ -> true | _ -> false in - let handler { m_pat = p } = pattern p in - List.for_all handler h - -(* Candidate for fusion *) -let candidate (e1, m_h_list1) (e2, m_h_list2) = - (equal e1 e2) && (static_patterns m_h_list1) && (static_patterns m_h_list2) - -let equalpat p1 p2 = - match p1.p_desc, p2.p_desc with - | Econstpat(i), Econstpat(j) when i = j -> true - | Econstr0pat(i), Econstr0pat(j) when i = j -> true - | _ -> p1 = p2 - -let rec find p = function - | [] -> raise Not_found - | ({ m_pat = po; m_body = b } as m_h) :: m_h_list -> - if equalpat p po then b, m_h_list - else let b, m_h_list = find p m_h_list in b, m_h :: m_h_list - -let rec join eq1 eq_list = - match eq1, eq_list with - | { eq_desc = EQmatch(is_total1, e1, m_h_list1) }, - { eq_desc = EQmatch(is_total2, e2, m_h_list2) } :: eq_list - when (candidate (e1, m_h_list1) (e2, m_h_list2)) -> - { eq1 with eq_desc = EQmatch(ref (!is_total1 && !is_total2), e1, - joinhandlers m_h_list1 m_h_list2) } :: - eq_list - | eq1, _ -> eq1 :: eq_list - -and joinhandlers m_h_list1 m_h_list2 = - match m_h_list1 with - | [] -> m_h_list2 - | ({ m_pat = po; m_body = bo } as m_h) :: m_h_list1 -> - let m_h, m_h_list2 = - try - let b, m_h_list2 = find po m_h_list2 in - { m_h with m_body = joinblock bo b }, m_h_list2 - with Not_found -> m_h, m_h_list2 in - m_h :: joinhandlers m_h_list1 m_h_list2 - -and joinblock - ({ b_vars = n_list1; b_locals = l1; b_body = eq_list1; - b_env = b_env1; b_write = { dv = w1 } } as b1) - { b_vars = n_list2; b_locals = l2; b_body = eq_list2; - b_env = b_env2; b_write = { dv = w2 } } = - { b1 with b_vars = n_list1 @ n_list2; - b_locals = l1 @ l2; b_body = eq_list1 @ eq_list2; - b_write = { Deftypes.empty with dv = Zident.S.union w1 w2 } } - -let rec joinlist = function - | [] -> [] - | eq :: eq_list -> join eq (joinlist eq_list) diff --git a/compiler/rewrite/copy.ml b/compiler/rewrite/copy.ml deleted file mode 100644 index 461c0774e..000000000 --- a/compiler/rewrite/copy.ml +++ /dev/null @@ -1,201 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* Elimination of atomic values copy variables [x = y], constants, globals *) -(* The transformation is applied after static scheduling and before *) -(* translation into sequential code *) - -open Zmisc -open Zident -open Zelus -open Deftypes - -(** atomic expressions - either immediate constants or variables *) -type value = | Vlocal of Zident.t | Vlast of Zident.t | Vconst of Zelus.desc - -type renaming = - { rel: value Env.t; (* the substitution *) - defs: S.t; (* names after which the substitution cannot be applied *) - } - -let empty = { rel = Env.empty; defs = S.empty } - -(** Append a renaming with a new relation *) -let append new_rel ({ rel = rel } as renaming) = - { renaming with rel = Env.append new_rel rel } - -(** Apply the renaming recursively. If [rel = [n\n1, n1\n2]], then *) -(** [rename n rel] = n2 *) -(** A substitution [n\last m] is not performed when [m] belongs to [defs] *) -let rename n { rel = rel; defs = defs } = - let rec rename n = - try - let m = Env.find n rel in - begin - match m with - | Vlocal m -> rename m - | Vlast m -> if S.mem m defs then raise Not_found else Elast m - | Vconst(edesc) -> edesc - end - with Not_found -> Elocal n in - rename n - -let rec size ({ rel = rel } as renaming) ({ desc = desc } as s) = - try - let s = - match desc with - | Sconst _ | Sglobal _ -> s - | Sname(n) -> - let n = Env.find n rel in - begin match n with - | Vlocal n -> { s with desc = Sname(n) } - | _ -> raise Not_found - end - | Sop(op, s1, s2) -> - { s with desc = Sop(op, size renaming s1, size renaming s2) } in - s - with - Not_found -> s - -let operator renaming op = - match op with - | Efby | Eunarypre | Eifthenelse - | Eminusgreater | Eup | Einitial | Edisc - | Ehorizon | Etest | Eaccess | Eupdate | Econcat | Eatomic -> op - | Eslice(s1, s2) -> Eslice(size renaming s1, size renaming s2) - -(** Build a substitution [x1\v1,...,xn\vn]. *) -let rec build rel { eq_desc = desc } = - match desc with - | EQeq({ p_desc = Evarpat(x) }, { e_desc = desc }) -> - let rel = - match desc with - | Elocal m -> Env.add x (Vlocal(m)) rel - | Eglobal _ | Econst _ -> Env.add x (Vconst(desc)) rel - | Elast m -> Env.add x (Vlast(m)) rel - | _ -> rel in - rel - | EQreset(eq_list, _) - | EQand(eq_list) - | EQbefore(eq_list) -> List.fold_left build rel eq_list - | EQeq _ | EQpluseq _ | EQnext _ | EQinit _ | EQmatch _ - | EQder(_, _, None, []) - | EQforall _ | EQblock _ -> rel - | EQautomaton _ | EQpresent _ | EQemit _ | EQder _ -> assert false - -(** Expressions. Apply [renaming] to every sub-expression *) -let rec expression renaming ({ e_desc = desc } as e) = - match desc with - | Econst _ | Econstr0 _ | Eglobal _ | Elast _ -> e - | Elocal(x) -> { e with e_desc = rename x renaming } - | Etuple(e_list) -> - { e with e_desc = Etuple(List.map (expression renaming) e_list) } - | Econstr1(c, e_list) -> - { e with e_desc = Econstr1(c, List.map (expression renaming) e_list) } - | Erecord(n_e_list) -> - { e with e_desc = - Erecord(List.map (fun (ln, e) -> - (ln, expression renaming e)) n_e_list) } - | Erecord_access(e_record, ln) -> - { e with e_desc = Erecord_access(expression renaming e_record, ln) } - | Erecord_with(e_record, n_e_list) -> - { e with e_desc = - Erecord_with(expression renaming e_record, - List.map (fun (ln, e) -> - (ln, expression renaming e)) n_e_list) } - | Eop(op, e_list) -> - { e with e_desc = Eop(operator renaming op, - List.map (expression renaming) e_list) } - | Eapp(app, e_op, e_list) -> - let e_op = expression renaming e_op in - let e_list = List.map (expression renaming) e_list in - { e with e_desc = Eapp(app, e_op, e_list) } - | Etypeconstraint(e1, ty) -> - { e with e_desc = Etypeconstraint(expression renaming e1, ty) } - | Eseq(e1, e2) -> - { e with e_desc = Eseq(expression renaming e1, expression renaming e2) } - | Elet(l, e_let) -> - let renaming, l = local renaming l in - { e with e_desc = Elet(l, expression renaming e_let) } - | Eperiod _ | Epresent _ | Ematch _ | Eblock _ -> assert false - -(** Local declarations *) -and local renaming ({ l_eq = eq_list } as l) = - let rel = List.fold_left build Env.empty eq_list in - let renaming = append rel renaming in - let renaming, eq_list = equation_list renaming eq_list in - renaming, { l with l_eq = eq_list } - -(** renaming of equations *) -and equation ({ defs = defs } as renaming, eq_list) - ({ eq_desc = desc; eq_write = w } as eq) = - let desc = match desc with - | EQeq(p, e) -> EQeq(p, expression renaming e) - | EQpluseq(x, e) -> EQpluseq(x, expression renaming e) - | EQinit(x, e0) -> EQinit(x, expression renaming e0) - | EQmatch(total, e, m_b_list) -> - let rename ({ m_body = b } as m_h) = - { m_h with m_body = block renaming b } in - EQmatch(total, expression renaming e, List.map rename m_b_list) - | EQder(x, e, None, []) -> - EQder(x, expression renaming e, None, []) - | EQreset(res_eq_list, e) -> - let e = expression renaming e in - let _, eq_list = equation_list renaming res_eq_list in - EQreset(eq_list, e) - | EQforall ({ for_index = i_list; for_init = init_list; - for_body = b_eq_list } as b) -> - let index ({ desc = desc } as ind) = - let desc = match desc with - | Einput(i, e) -> Einput(i, expression renaming e) - | Eoutput _ -> desc - | Eindex(i, e1, e2) -> - Eindex(i, expression renaming e1, expression renaming e2) in - { ind with desc = desc } in - let init ({ desc = desc } as i) = - let desc = match desc with - | Einit_last(i, e) -> Einit_last(i, expression renaming e) in - { i with desc = desc } in - let i_list = List.map index i_list in - let init_list = List.map init init_list in - let b_eq_list = block renaming b_eq_list in - EQforall { b with for_index = i_list; for_init = init_list; - for_body = b_eq_list } - | EQbefore(before_eq_list) -> - let _, before_eq_list = equation_list renaming before_eq_list in - EQbefore(before_eq_list) - | EQand _ | EQblock _ | EQautomaton _ | EQpresent _ - | EQemit _ | EQder _ | EQnext _ -> assert false in - { renaming with defs = Deftypes.cur_names defs w }, - { eq with eq_desc = desc } :: eq_list - -and equation_list renaming eq_list = - let renaming, eq_list = List.fold_left equation (renaming, []) eq_list in - renaming, List.rev eq_list - -and block renaming ({ b_body = eq_list } as b) = - let rel = List.fold_left build Env.empty eq_list in - let renaming = append rel renaming in - let _, eq_list = equation_list renaming eq_list in - { b with b_body = eq_list } - -let implementation impl = - match impl.desc with - | Efundecl(f, ({ f_body = e } as body)) -> - let e = expression empty e in - let body = { body with f_body = e } in - { impl with desc = Efundecl(f, body) } - | _ -> impl - -let implementation_list impl_list = Zmisc.iter implementation impl_list diff --git a/compiler/rewrite/cost.ml b/compiler/rewrite/cost.ml deleted file mode 100644 index d594d48ec..000000000 --- a/compiler/rewrite/cost.ml +++ /dev/null @@ -1,133 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(** Simple cost function for an expression *) -(** [max] is the maximum allowed cost of [e] *) -(** raise Exit if the cost is greater than [max] *) -(** continuous operators (up/der) reduce the local cost *) -(** since calling a function with continuous state need extra copy code *) - -open Zmisc -open Zident -open Lident -open Global -open Zelus -open Zaux - -let expression e max = - let c = ref 0 in - let incr n = - let c' = !c + n in - if c' >= max then raise Exit - else c := !c + n in - let rec cost e = - match e.e_desc with - | Elocal _ | Elast _ | Econst _ | Econstr0 _ | Eglobal _ -> () - | Eapp(_, e, e_list) -> - incr (1 + List.length e_list); - List.iter cost e_list; cost e - | Econstr1(_, e_list) | Etuple(e_list) -> incr 1; List.iter cost e_list - | Eop(op, e_list) -> incr (cost_op op); List.iter cost e_list - | Erecord(n_e_list) -> - incr 1; List.iter (fun (label, e) -> cost e) n_e_list - | Erecord_access(e, _) -> cost e - | Erecord_with(e, n_e_list) -> - cost e; incr 1; List.iter (fun (label, e) -> cost e) n_e_list - | Eseq(e1, e2) -> cost e1; cost e2 - | Eperiod({ p_phase = p1_opt; p_period = p2 }) -> - incr 1; ignore (Zmisc.optional_map cost p1_opt); cost p2 - | Etypeconstraint(e, _) -> cost e - | Elet(local, e_let) -> - cost_local local; cost e_let - | Eblock(b, e_block) -> - cost_block b; cost e_block - | Epresent _ | Ematch _ -> assert false - and cost_op op = - match op with - | Efby | Eunarypre | Eminusgreater -> 2 - | Edisc -> 4 - | Einitial -> 2 - | Eup -> -2 - | Eifthenelse - | Etest - | Eaccess -> 1 - | Ehorizon -> 1 - | Eupdate | Eslice _ | Econcat -> 1 - | Eatomic -> 0 - (* this is rough: after specialization, the size is known *) - and cost_block { b_locals = l_list; b_body = eq_list } = - List.iter cost_local l_list; List.iter cost_eq eq_list - and cost_local { l_eq = eq_list } = - List.iter cost_eq eq_list - and cost_eq eq = - match eq.eq_desc with - | EQeq(_, e) | EQinit(_, e) | EQpluseq(_, e) -> incr 1; cost e - | EQnext(_, e0, e_opt) -> - incr 1; cost e0; Zmisc.optional_unit (fun _ e -> cost e) () e_opt - | EQmatch(_, e, p_h_list) -> - cost e; - List.iter (fun { m_body = b } -> cost_block b) p_h_list - | EQder(n, e, e0_opt, h) -> - incr (-2); - Zmisc.optional_unit (fun _ e -> cost e) () e0_opt; - List.iter (fun { p_body = e } -> cost e) h; - cost e - | EQreset(eq_list, e) -> incr 1; List.iter cost_eq eq_list - | EQand(eq_list) - | EQbefore(eq_list) -> List.iter cost_eq eq_list - | EQpresent(p_h_list, b_opt) -> - List.iter (fun { p_body = b } -> cost_block b) p_h_list; - Zmisc.optional_unit (fun _ b -> cost_block b) () b_opt - | EQemit(_, e_opt) -> - Zmisc.optional_unit (fun _ e -> cost e) () e_opt - | EQblock(b) -> cost_block b - | EQforall { for_index = i_list; for_init = init_list; - for_body = b_eq_list } -> - let index { desc = desc } = - match desc with - | Einput(_, e) -> incr 1; cost e - | Eoutput _ -> incr 1 - | Eindex(_, e1, e2) -> incr 1; cost e1; cost e2 in - let init { desc = desc } = - match desc with - | Einit_last(_, e) -> incr 1; cost e in - List.iter index i_list; - List.iter init init_list; - incr (List.length i_list); - cost_block b_eq_list - | EQautomaton(_, s_h_list, se_opt) -> - List.iter cost_state_handler s_h_list; - Zmisc.optional_unit (fun _ se -> cost_state_exp se) () se_opt - and cost_state_handler { s_body = b; s_trans = esc_list } = - cost_block b; List.iter cost_escape esc_list - and cost_escape { e_cond = scpat; e_block = b_opt; e_next_state = se } = - cost_scpat scpat; - Zmisc.optional_unit (fun _ b -> cost_block b) () b_opt; - cost_state_exp se - and cost_state_exp { desc = desc } = - match desc with - | Estate0 _ -> incr 1 - | Estate1(_, e_list) -> List.iter cost e_list - and cost_scpat { desc = desc } = - match desc with - | Econdand(scpat1, scpat2) - | Econdor(scpat1, scpat2) -> cost_scpat scpat1; cost_scpat scpat2 - | Econdexp(e) | Econdpat(e, _) -> cost e - | Econdon(scpat, e) -> cost_scpat scpat; cost e - - in - try - cost e; true - with - | Exit -> false diff --git a/compiler/rewrite/cse.ml b/compiler/rewrite/cse.ml deleted file mode 100644 index 304c5ec41..000000000 --- a/compiler/rewrite/cse.ml +++ /dev/null @@ -1,169 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* common sub-expression for registers. Very simple things. *) -(* For the moment, only equations of the form *) -(* [init x = e0 ... x = e] are shared *) - -open Zmisc -open Zident -open Zelus - -(** Build the association table [pre(n) -> x] and substitution [x\y] *) -(** every time some equation [y = pre(n)] already exists *) -let build_table subst eq_list = - let rec equation (table, subst, eq_list) eq = - match eq.eq_desc with - | EQeq({ p_desc = Evarpat(x) } as p, - ({ e_desc = Eop(Eunarypre, [{ e_desc = Elocal(n) }]) } as e)) -> - begin try - let y = Env.find n table in - table, - (* extends the substitution *) - Env.add x y subst, - { eq with eq_desc = EQeq(p, { e with e_desc = Elocal(y) }) } - :: eq_list - with - | Not_found -> - (* build [pre(n) -> x] if it does not exist already *) - Env.add n x table, subst, eq :: eq_list - end - | EQand(and_eq_list) -> - let table, subst, and_eq_list = equation_list table subst and_eq_list in - table, subst, { eq with eq_desc = EQand(and_eq_list) } :: eq_list - | EQbefore(and_eq_list) -> - let table, subst, and_eq_list = equation_list table subst and_eq_list in - table, subst, { eq with eq_desc = EQbefore(and_eq_list) } :: eq_list - | EQeq _ | EQpluseq _ | EQinit _ | EQnext _ - | EQmatch _ | EQreset _ | EQder _ | EQblock _ | EQforall _ -> - table, subst, eq :: eq_list - | EQemit _ | EQautomaton _ | EQpresent _ -> assert false - and equation_list table subst eq_list = - let table, subst, eq_list = - List.fold_left equation (table, subst, []) eq_list in - table, subst, List.rev eq_list in - let table, subst, eq_list = equation_list Env.empty subst eq_list in - subst, eq_list - -(* substitution *) -let rec exp subst e = - match e.e_desc with - | Econst _ | Econstr0 _ | Eglobal _ | Elast _ -> e - | Elocal(n) -> - begin try { e with e_desc = Elocal(Env.find n subst) } - with Not_found -> e end - | Etuple(e_list) -> - { e with e_desc = Etuple(List.map (exp subst) e_list) } - | Econstr1(c, e_list) -> - { e with e_desc = Econstr1(c, List.map (exp subst) e_list) } - | Eop(op, e_list) -> - let e_list = List.map (exp subst) e_list in - { e with e_desc = Eop(op, e_list) } - | Eapp(app, e_op, e_list) -> - { e with e_desc = - Eapp(app, exp subst e_op, List.map (exp subst) e_list) } - | Erecord(label_e_list) -> - { e with e_desc = - Erecord(List.map (fun (l, e) -> l, exp subst e) label_e_list) } - | Erecord_access(e_record, longname) -> - { e with e_desc = Erecord_access(exp subst e_record, longname) } - | Erecord_with(e_record,label_e_list) -> - { e with e_desc = - Erecord_with(exp subst e_record, - List.map - (fun (l, e) -> l, exp subst e) label_e_list) } - | Etypeconstraint(e1, ty) -> - { e with e_desc = Etypeconstraint(exp subst e1, ty) } - | Eseq(e1, e2) -> - { e with e_desc = Eseq(exp subst e1, exp subst e2) } - | Eperiod _ | Epresent _ | Ematch _ | Elet _ | Eblock _ -> assert false - -(* [equation subst eq = eq'] apply a substitution to eq. *) -and equation subst eq = - match eq.eq_desc with - | EQeq(pat, e) -> { eq with eq_desc = EQeq(pat, exp subst e) } - | EQpluseq(n, e) -> { eq with eq_desc = EQpluseq(n, exp subst e) } - | EQinit(n, e0) -> - { eq with eq_desc = EQinit(n, exp subst e0) } - | EQnext(n, e, e_opt) -> - { eq with eq_desc = EQnext(n, exp subst e, - Zmisc.optional_map (exp subst) e_opt) } - | EQmatch(total, e, m_h_list) -> - let e = exp subst e in - let m_h_list = - List.map - (fun ({ m_body = b} as h) -> { h with m_body = block subst b }) - m_h_list in - { eq with eq_desc = EQmatch(total, e, m_h_list) } - | EQreset(res_eq_list, e) -> - { eq with eq_desc = - EQreset(List.map (equation subst) res_eq_list, - exp subst e) } - | EQand(and_eq_list) -> - { eq with eq_desc = EQand(List.map (equation subst) and_eq_list) } - | EQbefore(before_eq_list) -> - { eq with eq_desc = EQbefore(List.map (equation subst) before_eq_list) } - | EQder(n, e, None, []) -> - { eq with eq_desc = EQder(n, exp subst e, None, []) } - | EQblock(b) -> { eq with eq_desc= EQblock(block subst b) } - | EQforall ({ for_index = i_list; for_init = init_list; - for_body = b_eq_list } as body) -> - let index ({ desc = desc } as ind) = - let desc = match desc with - | Einput(x, e) -> Einput(x, exp subst e) - | Eoutput _ -> desc - | Eindex(x, e1, e2) -> Eindex(x, exp subst e1, exp subst e2) in - { ind with desc = desc } in - let init ({ desc = desc } as ini) = - let desc = match desc with - | Einit_last(x, e) -> Einit_last(x, exp subst e) in - { ini with desc = desc } in - let i_list = List.map index i_list in - let init_list = List.map init init_list in - let b_eq_list = block subst b_eq_list in - { eq with eq_desc = - EQforall { body with for_index = i_list; - for_init = init_list; - for_body = b_eq_list } } - | EQder _ | EQemit _ | EQautomaton _ | EQpresent _ -> assert false - -and local subst ({ l_eq = eq_list } as l) = - (* extends the association table *) - let subst, eq_list = build_table subst eq_list in - (* apply the substitution *) - let eq_list = List.map (equation subst) eq_list in - { l with l_eq = eq_list } - -and block subst ({ b_body = eq_list } as b) = - let subst, eq_list = build_table subst eq_list in - let eq_list = List.map (equation subst) eq_list in - { b with b_body = eq_list } - -(** the main entry for expressions. Warning: [e] must be in normal form *) -let exp subst e = - match e.e_desc with - | Elet(l, e1) -> - let l = local subst l in - let e1 = exp subst e1 in - { e with e_desc = Elet(l, e1) } - | _ -> exp subst e - -let implementation impl = - match impl.desc with - | Eopen _ | Etypedecl _ | Econstdecl _ -> impl - | Efundecl(n, ({ f_body = e } as body)) -> - { impl with desc = - Efundecl(n, { body with f_body = exp Env.empty e }) } - -let implementation_list impl_list = Zmisc.iter implementation impl_list diff --git a/compiler/rewrite/dependences.ml b/compiler/rewrite/dependences.ml deleted file mode 100644 index 9b0ea7091..000000000 --- a/compiler/rewrite/dependences.ml +++ /dev/null @@ -1,159 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* dependences between equations *) -open Zelus -open Graph - -type 'a collection = - | And of 'a collection list (* parallel set of equations *) - | Before of 'a collection list (* sequentiel set of equations *) - | Leaf of 'a - - -(** Read/writes of an equation. *) -(* Control structures are treated as atomic blocks. Their set of write *) -(* variables is removed the set of read variables *) -let read ({ eq_write; eq_desc } as eq) = - let last_acc, acc = - Vars.fv_eq Zident.S.empty (Zident.S.empty, Zident.S.empty) eq in - match eq_desc with - | EQmatch(_, e, _) | EQreset(_, e) -> - let w = Deftypes.names Zident.S.empty eq_write in - let last_acc = Zident.S.diff last_acc w in - let acc = Zident.S.diff acc w in - Vars.fv Zident.S.empty (last_acc, acc) e - | _ -> last_acc, acc - -let def { eq_write = { Deftypes.dv = dv; Deftypes.di = di } } = - (* derivatives are not taken into account *) - Zident.S.union dv di - -(** Initialization equations [init x = e] and *) -(* reset [init x = e]... every ...] *) -let rec init { eq_desc = desc } = - match desc with - | EQinit _ -> true - | EQreset(eq_list, _) -> List.exists init eq_list - | _ -> false - -let nodep ({ eq_desc }) = - match eq_desc with - | EQeq(_, { e_desc = Eop(Eup, _) }) - | EQder(_, _, None, []) -> true | _ -> false - -let index { eq_index = i } = i -let unsafe = Unsafe.equation - -(* associate a fresh index to every equation *) -let rec fresh i eqs = - match eqs with - | Leaf(eq) -> Leaf { eq with eq_index = i }, i+1 - | Before(eqs_list) -> - let eqs_list, i = Zmisc.map_fold fresh i eqs_list in - Before(eqs_list), i - | And(eqs_list) -> - let eqs_list, i = Zmisc.map_fold fresh i eqs_list in - And(eqs_list), i - -(* Given a collection of equations, computes the associations *) -(* [xtable] associates the set of equation indexes [...x... = e] to [x] *) -(* [itable] associates the set of equations indexes [init x = e] to [x] *) -(* [eq_info_list] builds the list [index, eq, defs(eq), read(eq), last(eq)] *) -let rec name_to_index (xtable, itable, eq_info_list) eqs = - match eqs with - | Leaf(eq) -> - let i = index eq in - let w = def eq in - let lv, v = read eq in - let eq_info_list = (i, eq, w, v, lv) :: eq_info_list in - if nodep eq then xtable, itable, eq_info_list - else - let update x t = - Zident.Env.update x - (function None -> Some (S.singleton i) - | Some(set) -> Some(S.add i set)) t in - let xtable, itable = - Zident.S.fold - (fun x (xtable, itable) -> - if init eq then xtable, update x itable - else update x xtable, itable) w (xtable, itable) in - xtable, itable, eq_info_list - | Before(eq_list) | And(eq_list) -> - List.fold_left name_to_index (xtable, itable, eq_info_list) eq_list - -(* Build the dependence graph according to read/writes *) -let make_read_write xtable itable eq_info_list = - (* find nodes according to a variable *) - let find x table = try Zident.Env.find x table with Not_found -> S.empty in - (* add dependences according to equation with index [n] *) - let rec make g (n, eq, w, v, lv) = - let g = Graph.add n eq g in - (* equation with index [n] must be scheduled *) - (* - after an equation [init x = e] where [x in w], excluding itself *) - let l = - S.remove n - (Zident.S.fold (fun x iw -> S.union (find x itable) iw) w S.empty) in - let g = Graph.add_before l (S.singleton n) g in - (* - after an equation [...x... = e] or [init x = e] where [x in v] *) - let l = - Zident.S.fold - (fun x iw -> S.union (find x xtable) (S.union (find x itable) iw)) - v S.empty in - let g = Graph.add_before l (S.singleton n) g in - (* - before an equation [...x... = e] where [x in lv] excluding itself *) - let l = - S.remove n - (Zident.S.fold (fun x iw -> S.union (find x xtable) iw) lv S.empty) in - let g = Graph.add_before (S.singleton n) l g in - (* - after an equation [init x = e] where [x in lv] excluding itself *) - let l = - S.remove n - (Zident.S.fold (fun x iw -> S.union (find x itable) iw) lv S.empty) in - let g = Graph.add_before l (S.singleton n) g in - g in - List.fold_left make Graph.empty eq_info_list - -(* Add extra dependences due to unsafe operations *) -let make_unsafes xtable itable g eqs = - let rec unsafes (g, uset) eqs = - match eqs with - | Leaf(eq) -> g, if unsafe eq then S.add (index eq) uset else uset - | And(eqs_list) -> - List.fold_left unsafes (g, uset) eqs_list - | Before(eqs_list) -> - let g, uset_of_eqs_list = - List.fold_left - (fun (g, uset) eqs -> - let g, uset_of_eqs = unsafes (g, S.empty) eqs in - Graph.add_before uset uset_of_eqs g, - if S.is_empty uset_of_eqs then uset - else uset_of_eqs) (g, S.empty) eqs_list in - g, S.union uset uset_of_eqs_list in - let g, _ = unsafes (g, S.empty) eqs in - g - -(* The main entry function. Build the dependence graph from a *) -(* set of equations *) -let make eqs = - let eqs, _ = fresh 0 eqs in - let xtable, itable, eq_info_list = - name_to_index (Zident.Env.empty, Zident.Env.empty, []) eqs in - let g = make_read_write xtable itable eq_info_list in - let g = make_unsafes xtable itable g eqs in - Graph.outputs g - -(* Print a graph of equations *) -let print ff g = Graph.print Printer.equation ff g - diff --git a/compiler/rewrite/disc.ml b/compiler/rewrite/disc.ml deleted file mode 100644 index e283213ac..000000000 --- a/compiler/rewrite/disc.ml +++ /dev/null @@ -1,147 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* Elimation of disc. This construction may be removed *) - -(* [disc(e)] is translated into [false -> major on (e <> last e)] *) - -open Zmisc -open Zlocation -open Zident -open Lident -open Initial -open Deftypes -open Zelus -open Zaux - -(* [disc(x)] is translated into [let x = e in major on (x <> (x fby x)] *) - -let disc major e = - let on_op z e = Zaux.and_op z e in - if Unsafe.exp e - then (* disc(e)] = [let x = e in major on (x <> (x fby x))] *) - let x = Zident.fresh "x" in - let env = Env.singleton x { t_sort = Deftypes.value; - t_typ = e.e_typ } in - let xv = var x e.e_typ in - make_let env [eq_make x e] (on_op major (diff xv (fby xv xv))) - else on_op major (diff e (fby e e)) - -(** Translation of expressions. *) -let rec expression major ({ e_desc = e_desc } as e) = - match e_desc with - | Eop(Edisc, [e]) -> disc major (expression major e) - | Eop(op, e_list) -> - { e with e_desc = Eop(op, List.map (expression major) e_list) } - | Eapp(app, op, e_list) -> - let op = expression major op in - let e_list = List.map (expression major) e_list in - { e with e_desc = Eapp(app, op, e_list) } - | Etuple(e_list) -> - { e with e_desc = Etuple(List.map (expression major) e_list) } - | Econstr1(c, e_list) -> - { e with e_desc = Econstr1(c, List.map (expression major) e_list) } - | Erecord_access(e_record, x) -> - { e with e_desc = Erecord_access(expression major e_record, x) } - | Erecord(l_e_list) -> - let l_e_list = List.map (fun (l, e) -> (l, expression major e)) l_e_list in - { e with e_desc = Erecord(l_e_list) } - | Erecord_with(e_record, l_e_list) -> - let l_e_list = List.map (fun (l, e) -> (l, expression major e)) l_e_list in - { e with e_desc = Erecord_with(expression major e_record, l_e_list) } - | Etypeconstraint(e, ty) -> - { e with e_desc = Etypeconstraint(expression major e, ty) } - | Elet(l, e) -> - { e with e_desc = Elet(local major l, expression major e) } - | Eblock(b, e) -> - { e with e_desc = Eblock(block major b, expression major e) } - | Eseq(e1, e2) -> - { e with e_desc = Eseq(expression major e1, expression major e2) } - | Elocal _ | Eglobal _ | Econst _ | Econstr0 _ | Elast _ -> e - | Epresent _ | Ematch _ | Eperiod _ -> assert false - -(* Translation of equations *) -(* [major] is the current major. [eq_list] is a list of equations and *) -(* [env] the current environment *) -and equation major ({ eq_desc = desc } as eq) = - match desc with - | EQeq(p, e) -> { eq with eq_desc = EQeq(p, expression major e) } - | EQpluseq(x, e) -> { eq with eq_desc = EQpluseq(x, expression major e) } - | EQmatch(total, e, m_h_list) -> - let m_h_list = - List.map - (fun ({ m_body = b } as m_h) -> { m_h with m_body = block major b }) - m_h_list in - { eq with eq_desc = EQmatch(total, expression major e, m_h_list) } - | EQreset(res_eq_list, e) -> - let e = expression major e in - let res_eq_list = equation_list major res_eq_list in - { eq with eq_desc = EQreset(res_eq_list, e) } - | EQand(and_eq_list) -> - { eq with eq_desc = EQand(equation_list major and_eq_list) } - | EQbefore(before_eq_list) -> - { eq with eq_desc = EQbefore(equation_list major before_eq_list) } - | EQinit(x, e) -> - { eq with eq_desc = EQinit(x, expression major e) } - | EQder(x, e, None, []) -> - { eq with eq_desc = EQder(x, expression major e, None, []) } - | EQnext(x, e, e_opt) -> - let e_opt = Zmisc.optional_map (expression major) e_opt in - { eq with eq_desc = EQnext(x, expression major e, e_opt) } - | EQblock(b) -> { eq with eq_desc = EQblock(block major b) } - | EQforall ({ for_index = i_list; for_init = init_list; - for_body = b_eq_list } as body) -> - let index ({ desc = desc } as ind) = - let desc = match desc with - | Einput(x, e) -> Einput(x, expression major e) - | Eoutput _ -> desc - | Eindex(x, e1, e2) -> - Eindex(x, expression major e1, expression major e2) in - { ind with desc = desc } in - let init ({ desc = desc } as ini) = - let desc = match desc with - | Einit_last(x, e) -> Einit_last(x, expression major e) in - { ini with desc = desc } in - let i_list = List.map index i_list in - let init_list = List.map init init_list in - let b_eq_list = block major b_eq_list in - { eq with eq_desc = EQforall { body with for_index = i_list; - for_init = init_list; - for_body = b_eq_list } } - | EQautomaton _ | EQpresent _ | EQemit _ - | EQder _ -> assert false - -and equation_list major eq_list = List.map (equation major) eq_list - -(** Translate a block *) -and block major ({ b_locals = l_list; b_body = eq_list } as b) = - let l_list = List.map (local major) l_list in - let eq_list = equation_list major eq_list in - { b with b_locals = l_list; b_body = eq_list } - -and local major ({ l_eq = eq_list } as l) = - { l with l_eq = equation_list major eq_list } - -let implementation impl = - match impl.desc with - | Eopen _ | Etypedecl _ | Econstdecl _ - | Efundecl(_, { f_kind = (S | AS | A | AD | D | P) }) -> impl - | Efundecl(n, ({ f_kind = C; f_body = e; f_env = f_env } as body)) -> - let f_env, major = Zaux.major f_env in - let e = expression major e in - { impl with desc = - Efundecl(n, { body with f_body = e; f_env = f_env }) } - -let implementation_list impl_list = Zmisc.iter implementation impl_list - diff --git a/compiler/rewrite/encore.ml b/compiler/rewrite/encore.ml deleted file mode 100644 index fa4688e83..000000000 --- a/compiler/rewrite/encore.ml +++ /dev/null @@ -1,134 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* applied to normalised equations and expressions *) -(* add of an horizon [h = if encore then 0.0 else infinity] to *) -(* every function body and the declaration of a variable [encore] *) -(* with default value [false] *) -(* An equation [encore = true] is added in a block activated on *) -(* a zero-crossing and which writes a non local state variable *) -(* match e with | P1 -> (* zero *) x = ... | Pn -> ... *) -(* into: match e with | P1 -> do encore = true and x = ... | ... *) - -open Zmisc -open Zlocation -open Zident -open Lident -open Initial -open Deftypes -open Zelus -open Zaux - -(* Does the block contains an equation [x = e] on a last variable? *) -let encore env { dv = dv } = - let write_on_last x = - let { t_sort = sort } = - try Env.find x env - with Not_found -> - Zmisc.internal_error "Encore: unbound name" Printer.name x in - match sort with - | Smem { m_previous = previous } -> previous | _ -> false in - S.exists write_on_last dv - -(** Add an equation [encore = true] *) -let with_zero env encore_opt ({ b_body = eq_list; b_write = w } as b) = - if encore env w then - let encore = - match encore_opt with - | None -> Zident.fresh "encore" | Some(encore) -> encore in - { b with b_body = (Zaux.eq_make encore Zaux.etrue) :: eq_list }, Some(encore) - else b, encore_opt - -(* Translation of equations *) -let rec equation env encore_opt ({ eq_desc = desc } as eq) = - match desc with - | EQeq _ | EQpluseq _ | EQder _ | EQinit _ -> eq, encore_opt - | EQreset(eq_list, e) -> - let eq_list, encore_opt = equation_list env encore_opt eq_list in - { eq with eq_desc = EQreset(eq_list, e) }, encore_opt - | EQand(and_eq_list) -> - let and_eq_list, encore_opt = equation_list env encore_opt and_eq_list in - { eq with eq_desc = EQand(and_eq_list) }, encore_opt - | EQbefore(before_eq_list) -> - let before_eq_list, encore_opt = - equation_list env encore_opt before_eq_list in - { eq with eq_desc = EQbefore(before_eq_list) }, encore_opt - | EQmatch(total, e, m_h_list) -> - (* add an equation [encore = true] if a branch is activated *) - (* on a zero-crossing and changes a non local state variable *) - (* whose last value is read outside *) - let m_h_list, encore_opt = - Zmisc.map_fold - (fun encore_opt ({ m_zero = zero; m_body = b } as m_h) -> - let b, encore_opt = - if zero then with_zero env encore_opt b - else block env encore_opt b in - { m_h with m_body = b }, encore_opt) - encore_opt m_h_list in - { eq with eq_desc = EQmatch(total, e, m_h_list) }, encore_opt - | EQforall ({ for_body = b_eq_list } as body) -> - let b_eq_list, encore_opt = block env encore_opt b_eq_list in - { eq with eq_desc = EQforall { body with for_body = b_eq_list }}, - encore_opt - | EQautomaton _ | EQpresent _ | EQemit _ - | EQnext _ | EQblock _ -> assert false - -and equation_list env encore_opt eq_list = - Zmisc.map_fold (equation env) encore_opt eq_list - -(** Translate a block *) -and block env encore_opt ({ b_body = eq_list; b_env = n_env } as b) = - let env = Env.append n_env env in - let eq_list, encore_opt = equation_list env encore_opt eq_list in - { b with b_body = eq_list }, encore_opt - -(** Translate an expression. Add two declarations if an extra step *) -(** is needed. [encore] is a local variable with default value [false]; *) -(** [h] is an horizon such that [h = if encore then 0.0 else infinity] *) -let expression env ({ e_desc = desc } as e) = - match desc with - | Elet({ l_eq = eq_list; l_env = l_env } as l, e) -> - let env = Env.append l_env env in - let eq_list, encore_opt = equation_list env None eq_list in - let l = - match encore_opt with - | None -> { l with l_eq = eq_list; l_env = l_env } - | Some(encore) -> - (* declaration of [encore: bool default false] *) - let sort = - Deftypes.default - (Some(Deftypes.Cimmediate(Deftypes.Ebool(false)))) None in - let l_env = - Env.add encore (Deftypes.entry sort Initial.typ_bool) l_env in - (* declaration of [horizon h] *) - let h = Zident.fresh "h" in - let sort = Deftypes.horizon Deftypes.empty_mem in - let l_env = - Env.add h (Deftypes.entry sort Initial.typ_float) l_env in - (* add equation [h = if encore then 0.0 else infinity] *) - let eq_list = - Zaux.eq_make h (ifthenelse (Zaux.var encore Initial.typ_bool) - Zaux.zero Zaux.infinity) :: eq_list in - { l with l_eq = eq_list; l_env = l_env } in - { e with e_desc = Elet(l, e) } - | _ -> e - -let implementation impl = - match impl.desc with - | Eopen _ | Etypedecl _ | Econstdecl _ - | Efundecl(_, { f_kind = (S | AS | A | AD | D | P) }) -> impl - | Efundecl(n, ({ f_kind = C; f_body = e; f_env = f_env } as body)) -> - { impl with desc = Efundecl(n, { body with f_body = expression f_env e }) } - -let implementation_list impl_list = Zmisc.iter implementation impl_list diff --git a/compiler/rewrite/horizon.ml b/compiler/rewrite/horizon.ml deleted file mode 100644 index 1f1b4a6ad..000000000 --- a/compiler/rewrite/horizon.ml +++ /dev/null @@ -1,122 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* gather all horizons into a single one per function. Applied on *) -(* normalised expressions and equations *) - -open Zmisc -open Zident -open Lident -open Deftypes -open Zelus -open Zaux - -(* Compute the list of horizons and remove their kind in the environment *) -let gather_horizons env = - let gather n ({ t_sort = sort } as entry) (h_list, env) = - match sort with - | Smem ({ m_kind = Some Horizon } as mem) -> - n :: h_list, - Env.add n { entry with t_sort = Smem { mem with m_kind = None } } env - | _ -> h_list, Env.add n entry env in - Env.fold gather env ([], Env.empty) - -let horizon h_opt h_list eq_list = - match h_list with - | [] -> eq_list, h_opt - | [x] -> - let h = match h_opt with | None -> Zident.fresh "h" | Some(h) -> h in - (pluseq_make h (float_var x)) :: eq_list, Some(h) - | x :: l -> - let h = match h_opt with | None -> Zident.fresh "h" | Some(h) -> h in - let e = - List.fold_left (fun acc y -> min_op acc (float_var y)) (float_var x) l in - (pluseq_make h e) :: eq_list, Some(h) - -(* Translation of equations. The function returns a new equation *) -(* and a possible horizon [h] *) -let rec equation h_opt ({ eq_desc = desc } as eq) = - match desc with - | EQmatch(total, e, m_h_list) -> - let m_h_list, h_opt = - Zmisc.map_fold - (fun h_opt ({ m_body = b } as m_h) -> - let b, h_opt = block h_opt b in - { m_h with m_body = b }, h_opt) h_opt m_h_list in - { eq with eq_desc = EQmatch(total, e, m_h_list) }, h_opt - | EQreset(eq_list, e) -> - let eq_list, h_opt = equation_list h_opt eq_list in - { eq with eq_desc = EQreset(eq_list, e) }, h_opt - | EQand(and_eq_list) -> - let and_eq_list, h_opt = equation_list h_opt and_eq_list in - { eq with eq_desc = EQand(and_eq_list) }, h_opt - | EQbefore(before_eq_list) -> - let before_eq_list, h_opt = equation_list h_opt before_eq_list in - { eq with eq_desc = EQbefore(before_eq_list) }, h_opt - | EQinit _ | EQder _ | EQeq _ - | EQpluseq _ -> eq, h_opt - | EQforall ({ for_body = b_eq_list } as body) -> - let b_eq_list, h_opt = block h_opt b_eq_list in - { eq with eq_desc = EQforall { body with for_body = b_eq_list } }, h_opt - | EQblock _ | EQautomaton _ - | EQpresent _ | EQemit _ | EQnext _ -> assert false - -and equation_list h_opt eq_list = Zmisc.map_fold equation h_opt eq_list - -and equation_list_with_horizon h_opt n_env eq_list = - let h_list, n_env = gather_horizons n_env in - let eq_list, h_opt = equation_list h_opt eq_list in - let eq_list, h_opt = horizon h_opt h_list eq_list in - n_env, eq_list, h_opt - -(** Translate a block *) -and block h_opt ({ b_body = eq_list; b_env = n_env } as b) = - let n_env, eq_list, h_opt = equation_list_with_horizon h_opt n_env eq_list in - { b with b_body = eq_list; b_env = n_env }, h_opt - -let expression ({ e_desc = desc } as e) = - match desc with - | Elet({ l_eq = eq_list; l_env = l_env } as l, e) -> - let l_env, eq_list, h_opt = - equation_list_with_horizon None l_env eq_list in - let l, e = - match h_opt with - | None -> { l with l_eq = eq_list; l_env = l_env }, e - | Some(h) -> - (* declaration of [h: float default infinity with (min)] *) - let sort = - Deftypes.default - (Some(Deftypes.Cglobal(Modname(Initial.stdlib_name - "infinity")))) - (Some(Modname(Initial.stdlib_name "min"))) in - let l_env = - Env.add h (Deftypes.entry sort Initial.typ_float) l_env in - let hor = Zident.fresh "h" in - let sort = Deftypes.horizon Deftypes.empty_mem in - let l_env = - Env.add hor (Deftypes.entry sort Initial.typ_float) l_env in - let eq_list = - Zaux.eq_make hor (Zaux.var h Initial.typ_float) :: eq_list in - { l with l_eq = eq_list; l_env = l_env }, e in - { e with e_desc = Elet(l, e) } - | _ -> e - -let implementation impl = - match impl.desc with - | Eopen _ | Etypedecl _ | Econstdecl _ - | Efundecl(_, { f_kind = (S | A | AS | AD | D | P) }) -> impl - | Efundecl(n, ({ f_kind = C; f_body = e } as body)) -> - { impl with desc = Efundecl(n, { body with f_body = expression e }) } - -let implementation_list impl_list = Zmisc.iter implementation impl_list diff --git a/compiler/rewrite/inline.ml b/compiler/rewrite/inline.ml deleted file mode 100644 index aa71ee64a..000000000 --- a/compiler/rewrite/inline.ml +++ /dev/null @@ -1,400 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* static expansion of function calls (inlining) *) -(* input: source code *) -(* output: source code *) -(* inlining is done according to the following: *) -(* - calls to atomic functions are not inlined. *) -(* - function calls annotated with [inline] are systematically inlined *) -(* - small functions (according to a cost function) are statically expanded *) -(* we compute an estimated cost for every function definition [f x = e] *) -(* functions whose cost body is less than [inline + cost f(x)] *) -(* are inlined *) -(* the cost depends on the number of parameters and the size of its body *) -(* the inlining function preserves typing, i.e., if e is well typed *) -(* (e itself and any of its subterms) e is inlined into e', then e' *) -(* is also well typed *) -open Zmisc -open Zident -open Lident -open Global -open Zelus -open Zaux - -exception No_inline;; - -inlining_level := -100000 - -(** Decide whether a global function has to be inlined or not *) -(** A function is inlined either because [is_inline = true] *) -(** or it is small enough *) -let inline is_inline lname = - let { info = { value_code = { Global.value_exp = v }; - value_typ = { Deftypes.typ_vars = l } } } = - Modules.find_value lname in - match v with - | Global.Vfun({ f_args = p_list; f_body = e } as body, _) -> - if is_inline then body - else if Cost.expression e (!inlining_level + List.length p_list) then body - else raise No_inline - | _ -> raise No_inline - -(** Building an expression [let reset res = e every r in res] *) -let reset e e_reset = - let res = Zident.fresh "r" in - let eq = eqmake (EQreset([eqmake (EQeq(varpat res e.e_typ, e))], e_reset)) in - let env = - Env.singleton res - { Deftypes.t_sort = Deftypes.value; - Deftypes.t_typ = e.e_typ } in - { e with e_desc = - Elet({ l_rec = false; l_env = env; l_eq = [eq]; - l_loc = Zlocation.no_location }, var res e.e_typ) } - -(** Build a renaming from an environment *) -let build env = - let buildrec n entry (env, renaming) = - let m = Zident.fresh (Zident.source n) in - Env.add m entry env, - Env.add n m renaming in - Env.fold buildrec env (Env.empty, Env.empty) - -(** rename a variable *) -let rename x renaming = - try Env.find x renaming - with Not_found -> - Zmisc.internal_error "Inline: unbound name" Printer.name x - -(** Renaming of type expressions *) -let rec type_expression renaming ({ desc = desc } as ty_e) = - match desc with - | Etypevar _ -> ty_e - | Etypeconstr(g, ty_list) -> - { ty_e with desc = - Etypeconstr(g, List.map (type_expression renaming) ty_list) } - | Etypetuple(ty_list) -> - { ty_e with desc = - Etypetuple(List.map (type_expression renaming) ty_list) } - | Etypevec(ty_vec, s) -> - { ty_e with desc = - Etypevec(type_expression renaming ty_vec, size renaming s) } - | Etypefun(k, opt_name, ty_arg, ty_res) -> - let ty_arg = type_expression renaming ty_arg in - let opt_name, renaming = - match opt_name with - | None -> opt_name, renaming - | Some(n) -> - let m = Zident.fresh (Zident.source n) in - Some(m), Env.add n m renaming in - let ty_res = type_expression renaming ty_res in - { ty_e with desc = Etypefun(k, opt_name, ty_arg, ty_res) } - -and size renaming ({ desc = desc } as s) = - match desc with - | Sconst _ | Sglobal _ -> s - | Sname(n) -> { s with desc = Sname(rename n renaming) } - | Sop(op, s1, s2) -> - { s with desc = Sop(op, size renaming s1, size renaming s2) } - -(** Rename an operator *) -let operator renaming op = - match op with - | Eunarypre | Efby | Eminusgreater | Eifthenelse - | Eup | Etest | Edisc | Ehorizon | Einitial | Eaccess - | Eupdate | Econcat | Eatomic -> op - | Eslice(s1, s2) -> Eslice(size renaming s1, size renaming s2) - -(** Renaming of patterns *) -let rec pattern renaming ({ p_desc = desc } as p) = - match desc with - | Ewildpat | Econstpat _ | Econstr0pat _ -> p - | Evarpat(n) -> { p with p_desc = Evarpat(rename n renaming) } - | Econstr1pat(c, p_list) -> - { p with p_desc = Econstr1pat(c, List.map (pattern renaming) p_list) } - | Etuplepat(p_list) -> - { p with p_desc = Etuplepat(List.map (pattern renaming) p_list) } - | Erecordpat(n_p_list) -> - { p with p_desc = - Erecordpat(List.map (fun (ln, p) -> (ln, pattern renaming p)) - n_p_list) } - | Ealiaspat(p1, n) -> - let n = rename n renaming in - { p with p_desc = Ealiaspat(pattern renaming p1, n) } - | Eorpat(p1, p2) -> - { p with p_desc = Eorpat(pattern renaming p1, pattern renaming p2) } - | Etypeconstraintpat(p1, ty) -> - { p with p_desc = Etypeconstraintpat(pattern renaming p1, - type_expression renaming ty) } - - -(** Renaming of expressions *) -let rec expression renaming ({ e_desc = desc } as e) = - match desc with - | Econst _ | Econstr0 _ | Eglobal _ -> e - | Elocal(n) -> { e with e_desc = Elocal(rename n renaming) } - | Elast(n) -> { e with e_desc = Elast(rename n renaming) } - | Etuple(e_list) -> - { e with e_desc = Etuple(List.map (expression renaming) e_list) } - | Econstr1(c, e_list) -> - { e with e_desc = Econstr1(c, List.map (expression renaming) e_list) } - | Erecord(n_e_list) -> - { e with e_desc = - Erecord(List.map (fun (ln, e) -> (ln, expression renaming e)) - n_e_list) } - | Erecord_access(e_record, ln) -> - { e with e_desc = Erecord_access(expression renaming e_record, ln) } - | Erecord_with(e_record, n_e_list) -> - { e with e_desc = - Erecord_with(expression renaming e_record, - List.map - (fun (ln, e) -> (ln, expression renaming e)) - n_e_list) } - | Eop(op, e_list) -> - { e with e_desc = Eop(operator renaming op, - List.map (expression renaming) e_list) } - | Eapp({ app_inline = i } as app, - ({ e_desc = Eglobal { lname = f } } as op), e_list) -> - let e_list = List.map (expression renaming) e_list in - begin try - let { f_args = p_list; f_body = e; f_env = env } = - inline (!Zmisc.inline_all || i) f in - letin renaming env p_list e_list e - with - | No_inline -> - (* the body of [f] is not visible or the gain of the inlining *) - (* threshold is not enough *) - { e with e_desc = Eapp(app, op, e_list) } - end - | Eapp(app, e, e_list) -> - { e with e_desc = - Eapp(app, expression renaming e, - List.map (expression renaming) e_list) } - | Etypeconstraint(e1, ty) -> - { e with e_desc = Etypeconstraint(expression renaming e1, ty) } - | Eseq(e1, e2) -> - { e with e_desc = Eseq(expression renaming e1, expression renaming e2) } - | Eperiod { p_phase = p1; p_period = p2 } -> - { e with e_desc = Eperiod { p_phase = Zmisc.optional_map (expression renaming) p1; - p_period = expression renaming p2 } } - | Elet(l, e_let) -> - let renaming, l = local renaming l in - { e with e_desc = Elet(l, expression renaming e_let) } - | Eblock(b, e_block) -> - let renaming, b = block renaming b in - { e with e_desc = Eblock(b, expression renaming e_block) } - | Epresent _ | Ematch _ -> assert false - -(** Renaming a local declaration *) -and local renaming ({ l_eq = eq_list; l_env = env } as l) = - let env, renaming0 = build env in - let renaming = Env.append renaming0 renaming in - let eq_list = List.map (equation renaming) eq_list in - renaming, - { l with l_eq = eq_list; l_env = env } - -and equation renaming ({ eq_desc = desc } as eq) = - let desc = match desc with - | EQeq(p, e) -> - EQeq(pattern renaming p, expression renaming e) - | EQpluseq(x, e) -> - EQpluseq(rename x renaming, expression renaming e) - | EQinit(x, e0) -> - EQinit(rename x renaming, expression renaming e0) - | EQnext(x, e, e0_opt) -> - EQnext(rename x renaming, expression renaming e, - Zmisc.optional_map (expression renaming) e0_opt) - | EQder(x, e, e0_opt, p_e_list) -> - let body { p_cond = sc; p_body = e; p_env = env; p_zero = zero } = - let env, renaming0 = build env in - let renaming = Env.append renaming0 renaming in - { p_cond = scondpat renaming sc; - p_body = expression renaming e; - p_env = env; - p_zero = zero } in - let e = expression renaming e in - let e0_opt = Zmisc.optional_map (expression renaming) e0_opt in - EQder(rename x renaming, e, e0_opt, List.map body p_e_list) - | EQmatch(total, e, m_b_list) -> - let body ({ m_pat = p; m_body = b; m_env = env } as m_h) = - let env, renaming0 = build env in - let renaming = Env.append renaming0 renaming in - let _, b = block renaming b in - { m_h with m_pat = pattern renaming p; - m_body = b; m_env = env } in - let e = expression renaming e in - EQmatch(total, e, List.map body m_b_list) - | EQreset(res_eq_list, e) -> - EQreset(List.map (equation renaming) res_eq_list, expression renaming e) - | EQand(and_eq_list) -> - EQand(List.map (equation renaming) and_eq_list) - | EQbefore(before_eq_list) -> - EQbefore(List.map (equation renaming) before_eq_list) - | EQpresent(p_h_list, b_opt) -> - let body { p_cond = sc; p_body = b; p_env = env; p_zero = zero } = - let env, renaming0 = build env in - let renaming = Env.append renaming0 renaming in - let _, b = block renaming b in - { p_cond = scondpat renaming sc; - p_body = b; p_env = env; p_zero = zero } in - let b_opt = - Zmisc.optional_map (fun b -> let _, b = block renaming b in b) b_opt in - EQpresent(List.map body p_h_list, b_opt) - | EQemit(x, e_opt) -> - EQemit(rename x renaming, Zmisc.optional_map (expression renaming) e_opt) - | EQblock(b) -> - let _, b = block renaming b in EQblock(b) - | EQautomaton(is_weak, s_h_list, se_opt) -> - let build_state_names renaming { s_state = { desc = desc } } = - match desc with - | Estate0pat(n) | Estate1pat(n, _) -> - let m = Zident.fresh (Zident.source n) in - Env.add n m renaming in - let statepat renaming ({ desc = desc } as spat) = - match desc with - | Estate0pat(x) -> { spat with desc = Estate0pat(rename x renaming) } - | Estate1pat(x, x_list) -> - let x = rename x renaming in - let x_list = List.map (fun x -> rename x renaming) x_list in - { spat with desc = Estate1pat(x, x_list) } in - let state_exp renaming ({ desc = desc } as se) = - match desc with - | Estate0(x) -> { se with desc = Estate0(rename x renaming) } - | Estate1(x, e_list) -> - { se with desc = - Estate1(rename x renaming, - List.map (expression renaming) e_list) } in - let escape renaming ({ e_cond = scpat; e_block = b_opt; - e_next_state = se; e_env = env } as esc) = - let env, renaming0 = build env in - let renaming = Env.append renaming0 renaming in - let renaming, b_opt = - match b_opt with - | None -> renaming, None - | Some(b) -> - let renaming, b = block renaming b in renaming, Some(b) in - { esc with e_cond = scondpat renaming scpat; - e_block = b_opt; - e_next_state = state_exp renaming se; - e_env = env } in - let body renaming - ({ s_state = spat; s_body = b; s_trans = esc_list; - s_env = env } as h) = - let env, renaming0 = build env in - let renaming = Env.append renaming0 renaming in - let spat = statepat renaming spat in - let renaming, b = block renaming b in - { h with s_state = spat; - s_body = b; - s_trans = List.map (escape renaming) esc_list; - s_env = env } in - let renaming = - List.fold_left build_state_names renaming s_h_list in - let se_opt = Zmisc.optional_map (state_exp renaming) se_opt in - EQautomaton(is_weak, List.map (body renaming) s_h_list, se_opt) - | EQforall({ for_index = i_list; for_init = init_list; - for_body = b_eq_list; - for_in_env = in_env; for_out_env = out_env } as f_body) -> - let in_env, renaming0 = build in_env in - let out_env, renaming1 = build out_env in - let renaming = Env.append renaming0 (Env.append renaming1 renaming) in - let index ({ desc = desc } as ind) = - let desc = match desc with - | Einput(x, e) -> Einput(rename x renaming, - expression renaming e) - | Eoutput(x, xout) -> Eoutput(rename x renaming, - rename xout renaming) - | Eindex(x, e1, e2) -> Eindex(rename x renaming, - expression renaming e1, - expression renaming e2) in - { ind with desc = desc } in - let init ({ desc = desc } as ini) = - let desc = match desc with - | Einit_last(x, e) -> Einit_last(rename x renaming, - expression renaming e) in - { ini with desc = desc } in - let _, b_eq_list = block renaming b_eq_list in - EQforall { f_body with - for_index = List.map index i_list; - for_init = List.map init init_list; - for_body = b_eq_list; - for_in_env = in_env; for_out_env = out_env } in - { eq with eq_desc = desc; eq_write = Deftypes.empty } - -and scondpat renaming ({ desc = desc } as sc) = - match desc with - | Econdand(sc1, sc2) -> - { sc with desc = - Econdand(scondpat renaming sc1, scondpat renaming sc2) } - | Econdor(sc1, sc2) -> - { sc with desc = Econdor(scondpat renaming sc1, scondpat renaming sc2) } - | Econdexp(e) -> - { sc with desc = Econdexp(expression renaming e) } - | Econdon(sc1, e) -> - { sc with desc = - Econdon(scondpat renaming sc1, expression renaming e) } - | Econdpat(e, p) -> - { sc with desc = Econdpat(expression renaming e, pattern renaming p) } - -and vardec renaming ({ vardec_name = n } as v) = - { v with vardec_name = rename n renaming } - -and block renaming - ({ b_vars = n_list; b_locals = l_list; b_body = eq_list; - b_env = n_env } as b) = - let rec local_list renaming l_list = - match l_list with - | [] -> renaming, [] - | l :: l_list -> - let renaming, l = local renaming l in - let renaming, l_list = local_list renaming l_list in - renaming, l :: l_list in - - let n_env, renaming0 = build n_env in - let renaming = Env.append renaming0 renaming in - let n_list = List.map (vardec renaming) n_list in - let renaming_l, l_list = local_list renaming l_list in - renaming_l, - { b with b_vars = n_list; b_locals = l_list; - b_body = List.map (equation renaming_l) eq_list; - b_write = Deftypes.empty; - b_env = n_env } - -(* returns [let p1' = e1 and ... and pn' = en in e[p1'/p1,...,p'n/pn] *) -(* in which [p1,...,pn] are renamed into [p1',...,pn'] and [e] is *) -(* recursively inlined *) -and letin renaming env p_list e_list e = - let eqmake p e = eqmake (EQeq(p, e)) in - - let env, renaming0 = build env in - let renaming = Env.append renaming0 renaming in - let p_list = List.map (pattern renaming) p_list in - { e with e_desc = - Elet({ l_rec = false; l_env = env; l_eq = List.map2 eqmake p_list e_list; - l_loc = Zlocation.no_location }, expression renaming e) } - -let implementation acc impl = - match impl.desc with - | Econstdecl(f, is_static, e) -> - let e = expression Env.empty e in - { impl with desc = Econstdecl(f, is_static, e) } :: acc - | Efundecl(f, ({ f_args = p_list; f_body = e; f_env = f_env } as body)) -> - let f_env, renaming = build f_env in - let p_list = List.map (pattern renaming) p_list in - let e = expression renaming e in - let body = { body with f_args = p_list; f_body = e; f_env = f_env } in - { impl with desc = Efundecl(f, body) } :: acc - | _ -> impl :: acc - -let implementation_list impl_list = Zmisc.fold implementation impl_list diff --git a/compiler/rewrite/letin.ml b/compiler/rewrite/letin.ml deleted file mode 100644 index 426ae2b7b..000000000 --- a/compiler/rewrite/letin.ml +++ /dev/null @@ -1,257 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* Remove nested declaration of variables *) -(* Preserves the sequential order defined by a let/in *) -(* declaration and, thus, possible side effects in them *) -(* E.g., in [let x = e1 in e2], all side effects in [e1] are done before *) -(* those of [e2] *) -(* [let x = e1 in e2] has the behavior of [let x = e1 before y = e2 in y] *) - -open Zmisc -open Zlocation -open Zident -open Lident -open Deftypes -open Zelus -open Zaux - -(* a structure to represent nested equations before they are turned into *) -(* valid Zelus equations *) -type ctx = { env: Deftypes.tentry Env.t State.t; eqs: eq State.t } - -let empty = { env = State.empty; eqs = State.empty } -let par { env = env1; eqs = eqs1 } { env = env2; eqs = eqs2 } = - { env = State.par env1 env2; eqs = State.par eqs1 eqs2 } -let seq { env = env1; eqs = eqs1 } { env = env2; eqs = eqs2 } = - { env = State.seq env1 env2; eqs = State.seq eqs1 eqs2 } -let add eq ({ eqs = eqs } as ctx) = - { ctx with eqs = State.par (State.singleton eq) eqs } - -let optional f e_opt = - match e_opt with - | None -> None, { env = State.Empty; eqs = State.Empty } - | Some(e) -> let e, ctx = f e in Some(e), ctx - -let par_fold f l = - Zmisc.map_fold - (fun { env = env; eqs = eqs } x -> - let y, { env = env_y; eqs = eqs_y } = f x in - y, { env = State.par env env_y; eqs = State.par eqs eqs_y }) - { env = State.Empty; eqs = State.Empty } l - -(* translate a context [ctx] into an environment and an equation *) -let equations eqs = - (* computes the set of sequential equations *) - let rec seq eqs eq_list = - match eqs with - | State.Empty -> eq_list - | State.Cons(eq, eqs) -> eq :: seq eqs eq_list - | State.Seq(eqs1, eqs2) -> - seq eqs1 (seq eqs2 eq_list) - | State.Par(eqs1, eqs2) -> - let par_eq_list = par [] eqs1 in - let par_eq_list = par par_eq_list eqs2 in - Zaux.par par_eq_list :: eq_list - (* and the set of parallel equations *) - and par eq_list eqs = - match eqs with - | State.Empty -> eq_list - | State.Cons(eq, eqs) -> par (eq :: eq_list) eqs - | State.Seq(eqs1, eqs2) -> - let seq_eq_list = seq eqs2 [] in - let seq_eq_list = seq eqs1 seq_eq_list in - Zaux.before seq_eq_list :: eq_list - | State.Par(eqs1, eqs2) -> - par (par eq_list eqs1) eqs2 in - par [] eqs - -(* every variable from [ctx] becomes a local variable *) -let add_locals n_list l_env { env = env; eqs = eqs } = - let eq_list = equations eqs in - let l_env = State.fold (fun env acc -> Env.append env acc) env l_env in - let n_list = - State.fold (fun env acc -> - Env.fold - (fun n entry acc -> (Zaux.vardec_from_entry n entry) :: acc) - env acc) env n_list in - n_list, l_env, eq_list - -(** Translation of expressions *) -let rec expression ({ e_desc = desc } as e) = - match desc with - | Elocal _ | Eglobal _ | Econst _ - | Econstr0 _ | Elast _ -> e, empty - | Eop(op, e_list) -> - let e_list, ctx = par_fold expression e_list in - { e with e_desc = Eop(op, e_list) }, ctx - | Eapp(app, e_op, e_list) -> - let e_op, ctx_e_op = expression e_op in - let e_list, ctx = par_fold expression e_list in - { e with e_desc = Eapp(app, e_op, e_list) }, - par ctx_e_op ctx - | Etuple(e_list) -> - let e_list, ctx = par_fold expression e_list in - { e with e_desc = Etuple(e_list) }, ctx - | Econstr1(c, e_list) -> - let e_list, ctx = par_fold expression e_list in - { e with e_desc = Econstr1(c, e_list) }, ctx - | Erecord_access(e_record, l) -> - let e_record, ctx = expression e_record in - { e with e_desc = Erecord_access(e_record, l) }, ctx - | Erecord(l_e_list) -> - let l_e_list, ctx = - par_fold - (fun (l, e) -> let e, ctx = expression e in (l, e), ctx) l_e_list in - { e with e_desc = Erecord(l_e_list) }, ctx - | Erecord_with(e_record, l_e_list) -> - let e_record, ctx_record = expression e_record in - let l_e_list, ctx = - par_fold - (fun (l, e) -> let e, ctx = expression e in (l, e), ctx) l_e_list in - { e with e_desc = Erecord_with(e_record, l_e_list) }, - par ctx_record ctx - | Etypeconstraint(e1, ty) -> - let e1, ctx = expression e1 in - { e with e_desc = Etypeconstraint(e1, ty) }, ctx - | Elet(l, e_let) -> - let ctx = local l in - let e_let, ctx_let = expression e_let in - e_let, seq ctx ctx_let - | Eblock({ b_locals = l_list; b_env = b_env; b_body = eq_list }, e) -> - let l_ctx = local_list l_list in - let eq_list_ctx = par_equation_list eq_list in - let e, ctx_e = expression e in - e, seq { empty with env = State.singleton b_env } - (seq l_ctx (seq eq_list_ctx ctx_e)) - | Eseq(e1, e2) -> - (* [e1; e2] is a short-cut for [let _ = e1 in e2] *) - let e1, ctx1 = expression e1 in - let e2, ctx2 = expression e2 in - let _e1 = - Zaux.eqmake (EQeq({ Zaux.wildpat with p_typ = e1.e_typ }, e1)) in - e2, seq ctx1 (seq { empty with eqs = State.singleton _e1 } ctx2) - | Epresent _ | Ematch _ | Eperiod _ -> assert false - -(** Translate an equation. *) -and equation ({ eq_desc = desc } as eq) = - match desc with - | EQeq(p, e) -> - let e, ctx = expression e in - add { eq with eq_desc = EQeq(p, e) } ctx - | EQpluseq(n, e) -> - let e, ctx_e = expression e in - add { eq with eq_desc = EQpluseq(n, e) } ctx_e - | EQder(n, e, e0_opt, []) -> - let e, ctx = expression e in - let e0_opt, ctx0 = optional expression e0_opt in - let eq = { eq with eq_desc = EQder(n, e, e0_opt, []) } in - add eq (par ctx ctx0) - | EQinit(n, e0) -> - let e0, ctx_e0 = expression e0 in - add { eq with eq_desc = EQinit(n, e0) } ctx_e0 - | EQmatch(total, e, p_h_list) -> - let e, ctx_e = expression e in - let p_h_list = - List.map - (fun ({ m_body = b } as p_h) -> - let b = block b in - { p_h with m_body = b }) - p_h_list in - add { eq with eq_desc = EQmatch(total, e, p_h_list) } ctx_e - | EQreset(res_eq_list, e) -> - let e, ctx_e = expression e in - let { env = env; eqs = eqs } = par_equation_list res_eq_list in - let res_eq_list = equations eqs in - par ctx_e (add { eq with eq_desc = EQreset(res_eq_list, e) } - { empty with env = env }) - | EQand(and_eq_list) -> par_equation_list and_eq_list - | EQbefore(before_eq_list) -> - seq_equation_list before_eq_list - | EQblock { b_locals = l_list; b_env = b_env; b_body = eq_list } -> - let l_ctx = local_list l_list in - let eq_list_ctx = par_equation_list eq_list in - par (seq l_ctx eq_list_ctx) { empty with env = State.singleton b_env } - | EQforall ({ for_index = ind_list; for_init = i_list; - for_body = b_eq_list } as body) -> - let index ({ desc = desc } as ind) = - match desc with - | Einput(x, e) -> - let e, ctx_e = expression e in - { ind with desc = Einput(x, e) }, ctx_e - | Eoutput _ -> ind, empty - | Eindex(x, e1, e2) -> - let e1, ctx_e1 = expression e1 in - let e2, ctx_e2 = expression e2 in - { ind with desc = Eindex(x, e1, e2) }, par ctx_e1 ctx_e2 in - let init ({ desc = desc } as i) = - match desc with - | Einit_last(x, e) -> - let e, ctx_e = expression e in - { i with desc = Einit_last(x, e) }, ctx_e in - let ind_list, ind_ctx = par_fold index ind_list in - let i_list, i_ctx = par_fold init i_list in - let b_eq_list = block b_eq_list in - add { eq with eq_desc = - EQforall { body with for_index = ind_list; - for_init = i_list; - for_body = b_eq_list } } - (par ind_ctx i_ctx) - | EQder _ | EQautomaton _ | EQpresent _ | EQemit _ | EQnext _ -> assert false - -and par_equation_list eq_list = - List.fold_left (fun acc eq -> par (equation eq) acc) empty eq_list - -and seq_equation_list eq_list = - List.fold_left (fun acc eq -> seq acc (equation eq)) empty eq_list - -(** Translating a block *) -(* Once normalized, a block is of the form *) -(* local x1,..., xn in do eq1 and ... and eqn *) -and block ({ b_vars = n_list; b_locals = l_list; - b_body = eq_list; b_env = b_env } as b) = - (* first translate local declarations *) - let l_ctx = local_list l_list in - (* then the set of equations *) - let ctx = par_equation_list eq_list in - let ctx = seq l_ctx ctx in - (* all local variables from [l_ctx] and [ctx] are now *) - (* declared in that block *) - let n_list, b_env, eq_list = add_locals n_list b_env ctx in - { b with b_vars = n_list; b_locals = []; b_body = eq_list; b_env = b_env } - -and local { l_eq = eq_list; l_env = l_env } = - let ctx = par_equation_list eq_list in - seq { empty with env = State.singleton l_env } ctx - -and local_list = function - | [] -> empty - | l :: l_list -> - let l_ctx = local l in - let ctx = local_list l_list in - seq l_ctx ctx - -let implementation impl = - let make_let e = - let e, ctx = expression e in - let _, env, eq_list = add_locals [] Env.empty ctx in - Zaux.make_let env eq_list e in - match impl.desc with - | Eopen _ | Etypedecl _ -> impl - | Econstdecl(n, is_static, e) -> - { impl with desc = Econstdecl(n, is_static, make_let e) } - | Efundecl(n, ({ f_kind = k; f_body = e } as body)) -> - { impl with desc = Efundecl(n, { body with f_body = make_let e }) } - -let implementation_list impl_list = Zmisc.iter implementation impl_list diff --git a/compiler/rewrite/markfunctions.ml b/compiler/rewrite/markfunctions.ml deleted file mode 100644 index 48fd23f37..000000000 --- a/compiler/rewrite/markfunctions.ml +++ /dev/null @@ -1,354 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* Mark functions to be inlined. The analysis is based on the *) -(* causality type system and use the causality tags to decide whether *) -(* a function must be inlined or not *) - -open Zelus - -type info = - { inputs: Causal.S.t; (* the causality tags of inputs of the function *) - outputs: Causal.S.t; (* the causality tags of outputs *) - o_table: Causal.S.t Causal.M.t; (* outputs of a causality tag *) - io_table: Causal.S.t Causal.M.t; (* the IO relation for all *) - (* accessible causality tags in the body *) - } - -(* For that purpose: - *- 1/ a first pass computes the set of causality tags - *- that appear in the body of a function; - *- 2/ then the IO for all of them; - *- 3/ if a function call [f arg1...argn] has to be inlined, it - *- is rewritten into [inline f arg1...argn]. - *- the decision is made according to the causality type. - *- (see the [to_inline] function) - *- Intuition: - *- let [f: tc0; arg1: tc1;...; argn: tcn] and [f arg1...argn : tc_res] - *- The function call is not inlined - *- if forall ai, bj st ai in Out tcj, bj in tc_res. - *- (io(bj) subseteq io(ai) or io(ai) subseteq io(bj)) and not bj <* ai - *- <* is the reflexive/transitive closure of <; - *- io(a) is the input/dependences of a, with i(a) a subset of names - *- from vars tc_in_list and o(a) a subset of names from vars tc_out - *- otherwise, the function is inlined - *- In such a case, the function call is strict, that is, - *- all outputs of the function call already depend - *- on all of its inputs *) - -(* compute the set of causality tags that appear as input/outputs *) -(* of function applications *) -let funexp_info { f_args = p_list; f_body = ({ e_caus = tc } as e) } = - let rec exp c_set { e_desc = desc; e_caus = tc } = - match desc with - | Elocal _ | Eglobal _ | Econst _ - | Econstr0 _ | Elast _ -> c_set - | Eapp(_, op, arg_list) -> - let c_set = List.fold_left exp (exp c_set op) arg_list in - (* compute the set of causality tags *) - let tc_list = List.map (fun { e_caus = tc } -> tc) (op :: arg_list) in - List.fold_left Causal.vars (Causal.vars c_set tc) tc_list - | Eop(_, e_list) | Etuple(e_list) - | Econstr1(_, e_list) -> List.fold_left exp c_set e_list - | Erecord_access(e, _) | Etypeconstraint(e, _) -> exp c_set e - | Erecord(m_e_list) -> - List.fold_left (fun acc (_, e) -> exp acc e) c_set m_e_list - | Erecord_with(e_record, m_e_list) -> - List.fold_left (fun acc (_, e) -> exp acc e) - (exp c_set e_record) m_e_list - | Epresent(p_h_list, e_opt) -> - let c_set = - List.fold_left - (fun acc { p_body = e } -> exp acc e) c_set p_h_list in - Zmisc.optional exp c_set e_opt - | Ematch(_, e, m_h_list) -> - List.fold_left - (fun acc { m_body = e } -> exp acc e) (exp c_set e) m_h_list - | Elet(l, e) -> exp (local c_set l) e - | Eblock(b, e) -> exp (block_eq_list c_set b) e - | Eseq(e1, e2) -> exp (exp c_set e1) e2 - | Eperiod { p_phase = p1; p_period = p2 } -> - let c_set = Zmisc.optional exp c_set p1 in - exp c_set p2 - - and local c_set { l_eq = eq_list } = List.fold_left equation c_set eq_list - - and equation c_set { eq_desc = desc } = - match desc with - | EQeq(_, e) | EQpluseq(_, e) | EQinit(_, e) -> exp c_set e - | EQder(_, e, e_opt, p_h_list) -> - let c_set = Zmisc.optional exp (exp c_set e) e_opt in - List.fold_left (fun acc { p_body = e } -> exp acc e) c_set p_h_list - | EQnext(n, e, e_opt) -> - Zmisc.optional exp (exp c_set e) e_opt - | EQautomaton(_, s_h_list, se_opt) -> - let c_set = - List.fold_left - (fun acc { s_body = b_eq_list; s_trans = s_trans } -> - let acc = block_eq_list acc b_eq_list in - List.fold_left - (fun acc - { e_cond = scpat; e_block = b_opt; e_next_state = se } -> - let c_set = scondpat acc scpat in - let c_set = Zmisc.optional block_eq_list c_set b_opt in - state c_set se) - acc s_trans) - c_set s_h_list in - Zmisc.optional state c_set se_opt - | EQpresent(p_h_list, b_opt) -> - let c_set = - List.fold_left - (fun acc { p_cond = scpat; p_body = b_eq_list } -> - let acc = scondpat acc scpat in - block_eq_list acc b_eq_list) c_set p_h_list in - Zmisc.optional block_eq_list c_set b_opt - | EQmatch(_, e, m_h_list) -> - List.fold_left - (fun acc { m_body = b_eq_list } -> block_eq_list acc b_eq_list) - (exp c_set e) m_h_list - | EQreset(res_eq_list, e) -> - List.fold_left equation (exp c_set e) res_eq_list - | EQand(eq_list) | EQbefore(eq_list) -> - List.fold_left equation c_set eq_list - | EQemit(_, e_opt) -> Zmisc.optional exp c_set e_opt - | EQblock(b) -> block_eq_list c_set b - | EQforall({ for_index = i_list; for_init = init_list; - for_body = b_eq_list }) -> - let index c_set { desc = desc } = - match desc with - | Einput(_, e) -> exp c_set e - | Eindex(_, e1, e2) -> exp (exp c_set e1) e2 - | Eoutput _ -> c_set in - let init c_set { desc = desc } = - match desc with - | Einit_last(_, e) -> exp c_set e in - let c_set = List.fold_left index c_set i_list in - let c_set = List.fold_left init c_set init_list in - block_eq_list c_set b_eq_list - - and scondpat c_set { desc = desc } = - match desc with - | Econdand(sc1, sc2) | Econdor(sc1, sc2) -> - scondpat (scondpat c_set sc1) sc2 - | Econdexp(e) | Econdpat(e, _) -> exp c_set e - | Econdon(sc, e) -> scondpat (exp c_set e) sc - - and state c_set { desc = desc } = - match desc with - | Estate0 _ -> c_set - | Estate1(_, e_list) -> List.fold_left exp c_set e_list - - and block_eq_list c_set { b_locals = l_list; b_body = eq_list } = - let c_set = List.fold_left local c_set l_list in - List.fold_left equation c_set eq_list in - - (* First: compute the inputs/outputs of the main function *) - let tc_list = List.map (fun { p_caus = tc } -> tc) p_list in - - (* mark inputs/outputs *) - List.iter (Causal.mark_and_polarity false) tc_list; - Causal.mark_and_polarity true tc; - let c_set = - Causal.vars (List.fold_left Causal.vars Causal.S.empty tc_list) tc in - let inputs, outputs = Causal.ins_and_outs c_set in - (* computes the set of causality tags that appear in [e] *) - let c_set = exp c_set e in - - (* compute the table of outputs for all the variables *) - let o_table = Causal.build_o_table c_set Causal.M.empty in - - (* then the table of io for every causality tag *) - let io_table = Causal.build_io_table inputs o_table c_set Causal.M.empty in - { inputs = inputs; - outputs = outputs; - io_table = io_table; - o_table = o_table } - -(* The function which decides whether or not a function call *) -(* [f(arg1,...,argn) must be inlined *) -let to_inline { io_table = io_table; o_table = o_table } tc_arg_list tc_res = - let _, out_of_inputs = - List.fold_left - (Causal.ins_and_outs_of_a_type true) (Causal.S.empty, Causal.S.empty) - tc_arg_list in - let _, out_of_result = - Causal.ins_and_outs_of_a_type true (Causal.S.empty, Causal.S.empty) - tc_res in - (* inline if not [\/_{i in out_of_inputs} IO(i) - subset /\_{j in out_of_result} IO(j)] *) - (* or exists o in out_of_result, i in out_of_inputs. path o i *) - (* if [inline = false], add extra dependences so that all output of the *) - (* result depends on all inputs. *) - let inline = - not (Causal.S.for_all - (fun i -> - let io_of_i = - try Causal.M.find i io_table with Not_found -> Causal.S.empty in - Causal.S.for_all - (fun o -> - try - let io_of_o = Causal.M.find o io_table in - not (Causal.strict_path o i) && - (Causal.S.subset io_of_i io_of_o) - with Not_found -> true) - out_of_result) - out_of_inputs) in - try - if not inline then - Causal.S.iter - (fun i -> - Causal.S.iter - (fun o -> if not (Causal.equal i o) then Causal.less_c i o) - out_of_result) - out_of_inputs; - inline - with - | Causal.Clash _ -> assert false - -(* Mark function calls to be inlined *) -let funexp_mark_to_inline info ({ f_body = e } as funexp) = - (* generic translation for match handlers *) - let match_handler body ({ m_body = b } as m_h) = - { m_h with m_body = body b } in - - (* generic translation function for present handlers *) - let present_handler scondpat body ({ p_cond = sc; p_body = b } as p_h) = - { p_h with p_cond = scondpat sc; p_body = body b } in - - (* expressions *) - let rec exp ({ e_desc = desc; e_caus = tc } as e) = - let desc = match desc with - | Elocal _ | Eglobal _ | Econst _ - | Econstr0 _ | Elast _ | Eperiod _ -> desc - | Eop(op, e_list) -> Eop(op, List.map exp e_list) - | Eapp({ app_inline = i } as app, op, arg_list) -> - (* only fully applied functions can be inlined *) - let op = exp op in - let arg_list = List.map exp arg_list in - let i = - if i then true - else let tc_arg_list = - List.map (fun { e_caus = tc } -> tc) (op :: arg_list) in - to_inline info tc_arg_list tc in - Eapp({ app with app_inline = i }, op, arg_list) - | Etuple(e_list) -> Etuple(List.map exp e_list) - | Econstr1(c, e_list) -> Econstr1(c, List.map exp e_list) - | Erecord_access(e_record, m) -> Erecord_access(exp e_record, m) - | Erecord(m_e_list) -> - Erecord(List.map (fun (m, e) -> (m, exp e)) m_e_list) - | Erecord_with(e_record, m_e_list) -> - Erecord_with(exp e_record, - List.map (fun (m, e) -> (m, exp e)) m_e_list) - | Etypeconstraint(e, ty) -> Etypeconstraint(exp e, ty) - | Epresent(p_h_list, e_opt) -> - Epresent(List.map (present_handler scondpat exp) p_h_list, - Zmisc.optional_map exp e_opt) - | Ematch(total, e, m_h_list) -> - Ematch(total, exp e, List.map (match_handler exp) m_h_list) - | Elet(l, e) -> Elet(local l, exp e) - | Eblock(b, e) -> Eblock(block_eq_list b, exp e) - | Eseq(e1, e2) -> Eseq(exp e1, exp e2) in - { e with e_desc = desc } - - and local ({ l_eq = eq_list } as l) = - { l with l_eq = List.map equation eq_list } - - and equation ({ eq_desc = desc } as eq) = - let desc = match desc with - | EQeq(p, e) -> EQeq(p, exp e) - | EQpluseq(n, e) -> EQpluseq(n, exp e) - | EQder(n, e, e_opt, p_h_list) -> - EQder(n, exp e, Zmisc.optional_map exp e_opt, - List.map (present_handler scondpat exp) p_h_list) - | EQinit(n, e) -> EQinit(n, exp e) - | EQnext(n, e, e_opt) -> - EQnext(n, exp e, Zmisc.optional_map exp e_opt) - | EQautomaton(is_weak, s_h_list, se_opt) -> - EQautomaton(is_weak, List.map state_handler s_h_list, - Zmisc.optional_map state se_opt) - | EQpresent(p_h_list, b_opt) -> - EQpresent(List.map (present_handler scondpat block_eq_list) p_h_list, - Zmisc.optional_map block_eq_list b_opt) - | EQmatch(total, e, m_h_list) -> - EQmatch(total, exp e, - List.map (match_handler block_eq_list) m_h_list) - | EQreset(res_eq_list, e) -> - EQreset(List.map equation res_eq_list, exp e) - | EQand(and_eq_list) -> - EQand(List.map equation and_eq_list) - | EQbefore(before_eq_list) -> - EQbefore(List.map equation before_eq_list) - | EQemit(n, e_opt) -> - EQemit(n, Zmisc.optional_map exp e_opt) - | EQblock(b) -> EQblock(block_eq_list b) - | EQforall({ for_index = i_list; for_init = init_list; - for_body = b_eq_list } as body) -> - let index ({ desc = desc } as ind) = - let desc = match desc with - | Einput(x, e) -> Einput(x, exp e) - | Eindex(x, e1, e2) -> - Eindex(x, exp e1, exp e2) - | Eoutput _ -> desc in - { ind with desc = desc } in - let init ({ desc = desc } as ini) = - let desc = match desc with - | Einit_last(x, e) -> Einit_last(x, exp e) in - { ini with desc = desc } in - let i_list = List.map index i_list in - let init_list = List.map init init_list in - let b_eq_list = block_eq_list b_eq_list in - EQforall { body with for_index = i_list; for_init = init_list; - for_body = b_eq_list } in - { eq with eq_desc = desc } - - and scondpat ({ desc = desc } as sc) = - let desc = match desc with - | Econdand(sc1, sc2) -> Econdand(scondpat sc1, scondpat sc2) - | Econdor(sc1, sc2) -> Econdor(scondpat sc1, scondpat sc2) - | Econdexp(e) -> Econdexp(exp e) - | Econdpat(e, p) -> Econdpat(exp e, p) - | Econdon(sc, e) -> Econdon(scondpat sc, exp e) in - { sc with desc = desc } - - and state_handler ({ s_body = b; s_trans = trans } as sh) = - { sh with s_body = block_eq_list b; s_trans = List.map escape trans } - - and state ({ desc = desc } as se) = - let desc = match desc with - | Estate0 _ -> desc - | Estate1(id, e_list) -> - Estate1(id, List.map exp e_list) in - { se with desc = desc } - - and block_eq_list ({ b_locals = l_list; b_body = eq_list } as b) = - { b with b_locals = List.map local l_list; - b_body = List.map equation eq_list } - - and escape ({ e_cond = sc; e_block = b_opt; e_next_state = se } as esc) = - { esc with e_cond = scondpat sc; - e_block = Zmisc.optional_map block_eq_list b_opt; - e_next_state = state se } in - - { funexp with f_body = exp e } - -let implementation impl = - match impl.desc with - | Eopen _ | Etypedecl _ | Econstdecl _ -> impl - | Efundecl(n, funexp) -> - let info = funexp_info funexp in - let funexp = funexp_mark_to_inline info funexp in - { impl with desc = Efundecl(n, funexp) } - -let implementation_list impl_list = - Zmisc.iter implementation impl_list diff --git a/compiler/rewrite/period.ml b/compiler/rewrite/period.ml deleted file mode 100644 index 3371bdf4f..000000000 --- a/compiler/rewrite/period.ml +++ /dev/null @@ -1,248 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* elimation of periods. *) - -(* For every function, an extra input [time] is added. Every period *) -(* is translated into the computation of an horizon *) - -(* [period(v1(v2))] is translated into *) -(* [local [horizon] h, z *) -(* do init h = time + v1 *) -(* and h = if z then last h + v2 else last h + (time - last time) *) -(* and z = major && (time >= last h) in *) -(* z *) - -(* [timer(v)] is translated into *) -(* [local [horizon] h, z *) -(* do init h = time + v *) -(* and h = if z then infinity else last h + (time - last time) *) -(* and z = major && (time >= last h) *) -(* in z] *) - -(* An other possible interpretation is to consider that periods and timers *) -(* and taken on absolute time. This is not what is implemented currently. *) -(* The implementation becomes: *) - -(* [period(v1(v2))] is translated into: *) -(* [local [horizon] h, cpt, z *) -(* do cpt = 0 -> if z then pre cpt + 1 else pre cpt *) -(* and h = cpt * v2 + v1 and z = major && (mod_float time v2 = v1) *) -(* in z] *) - -(* [timer(v)] is translated into: *) -(* [local [horizon] h, z *) -(* do init h = v and h = if z then infinity else last h *) -(* and z = major && (time = v) in z] *) - -(* finally, it is possible to consider that timers and period are taken on *) -(* absolute time but with a starting date which is local. *) - -(* [period(v1(v2))] is translated into: *) -(* local [horizon] h *) -(* do init h = time and z = major && (mod_float (time - last h) v2 = v1) *) -(* and h = if z then time + v2 else last h in z *) - -(* A zero-crossing cannot be true twice without time passing *) -(* up(x) => - let rec init ztime = -1.0 - and ztime = if z then time else last ztime - and z = up(if time > last ztime then x else 1.0) in - z *) - -open Zmisc -open Zlocation -open Zident -open Lident -open Initial -open Deftypes -open Zelus -open Zaux - - -let new_time () = Zident.fresh "time" - -(* The main translation function for periods *) -let period major time { p_phase = p1_opt; p_period = p2 } = - (* let rec [horizon] h = if z then last h + v2 else last h *) - (* and init h = time + p1 and z = major && (time >= last h) in z *) - let horizon = Deftypes.horizon Deftypes.imem in - let h = Zident.fresh "h" in - let z = Zident.fresh "z" in - let p1 = match p1_opt with | None -> Zaux.zero | Some(p1) -> p1 in - let env = - Env.add h (Deftypes.entry horizon Initial.typ_float) - (Env.add z { t_sort = Deftypes.value; - t_typ = Initial.typ_bool } Env.empty) in - let eq_list = - [eq_make h (ifthenelse (bool_var z) (plus (float_last h) p2) - (float_last h)); - eq_init h (plus (float_var time) p1); - eq_make z (and_op major - (greater_or_equal (float_var time) (float_last h)))] in - make_let env eq_list (bool_var z) - -(* Ensure that a zero-crossing cannot be done *) -(* twice without time passing *) -let up major time e = - let z = Zident.fresh "z" in - let ztime = Zident.fresh "ztime" in - let env = - Env.add ztime (Deftypes.entry imemory Initial.typ_float) - (Env.add z (Deftypes.entry Sval Initial.typ_float) - Env.empty) in - let eq_list = - [eq_init ztime minus_one; - eq_make ztime - (ifthenelse (float_var z) (float_var time) (float_last ztime)); - eq_make z - (Zaux.up (ifthenelse (greater (float_var time) (float_last ztime)) - e one))] in - make_let env eq_list (float_var z) - -let up major time e = e - -(* Add the extra input parameter "time" for hybrid nodes *) -let extra_input time env pat = - Env.add time { t_sort = Deftypes.value; t_typ = Initial.typ_float } env, - Zaux.pairpat (float_varpat time) pat - -(** Translation of expressions. *) -let rec expression major time ({ e_desc = e_desc } as e) = - match e_desc with - | Eperiod({ p_phase = opt_p1; p_period = p2 }) -> - period major time - { p_phase = Zmisc.optional_map (expression major time) opt_p1; - p_period = expression major time p2 } - | Eop(Eup, [e_arg]) -> - { e with e_desc = Eop(Eup, [expression major time e_arg]) } - | Eop(op, e_list) -> - { e with e_desc = Eop(op, List.map (expression major time) e_list) } - | Eapp(app, op, e_list) -> - (* for hybrid nodes, add the extra input [time] *) - let op = expression major time op in - let e_list = List.map (expression major time) e_list in - let e_list = - if Ztypes.is_hybrid (List.length e_list - 1) op.e_typ then - let head, tail = Zmisc.firsts e_list in - head @ [Zaux.pair (float_var time) tail] - else e_list in - { e with e_desc = Eapp(app, op, e_list) } - | Etuple(e_list) -> - { e with e_desc = Etuple(List.map (expression major time) e_list) } - | Econstr1(c, e_list) -> - { e with e_desc = Econstr1(c, List.map (expression major time) e_list) } - | Erecord_access(e_record, x) -> - { e with e_desc = Erecord_access(expression major time e_record, x) } - | Erecord(l_e_list) -> - let l_e_list = - List.map (fun (l, e) -> (l, expression major time e)) l_e_list in - { e with e_desc = Erecord(l_e_list) } - | Erecord_with(e_record, l_e_list) -> - let l_e_list = - List.map (fun (l, e) -> (l, expression major time e)) l_e_list in - { e with e_desc = Erecord_with(expression major time e_record, l_e_list) } - | Etypeconstraint(e, ty) -> - { e with e_desc = Etypeconstraint(expression major time e, ty) } - | Elet(l, e) -> - { e with e_desc = Elet(local major time l, expression major time e) } - | Eblock(b, e) -> - { e with e_desc = Eblock(block major time b, expression major time e) } - | Eseq(e1, e2) -> - { e with e_desc = - Eseq(expression major time e1, expression major time e2) } - | Elocal _ | Eglobal _ | Econst _ | Econstr0 _ | Elast _ -> e - | Epresent _ | Ematch _ -> assert false - -(* Translation of equations *) -(* [time] is the current time. [eq_list] is a list of equations and *) -(* [env] the current environment *) -and equation major time ({ eq_desc = desc } as eq) = - match desc with - | EQeq(p, e) -> { eq with eq_desc = EQeq(p, expression major time e) } - | EQpluseq(x, e) -> { eq with eq_desc = EQpluseq(x, expression major time e) } - | EQmatch(total, e, m_h_list) -> - let m_h_list = - List.map - (fun ({ m_body = b } as m_h) -> - { m_h with m_body = block major time b }) - m_h_list in - { eq with eq_desc = EQmatch(total, expression major time e, m_h_list) } - | EQreset(res_eq_list, e) -> - let e = expression major time e in - let res_eq_list = equation_list major time res_eq_list in - { eq with eq_desc = EQreset(res_eq_list, e) } - | EQand(and_eq_list) -> - { eq with eq_desc = EQand(equation_list major time and_eq_list) } - | EQbefore(before_eq_list) -> - { eq with eq_desc = EQbefore(equation_list major time before_eq_list) } - | EQinit(x, e) -> - { eq with eq_desc = EQinit(x, expression major time e) } - | EQder(x, e, None, []) -> - { eq with eq_desc = EQder(x, expression major time e, None, []) } - | EQnext(x, e, e_opt) -> - let e_opt = Zmisc.optional_map (expression major time) e_opt in - { eq with eq_desc = EQnext(x, expression major time e, e_opt) } - | EQblock(b) -> { eq with eq_desc = EQblock(block major time b) } - | EQforall ({ for_index = i_list; for_init = init_list; - for_body = b_eq_list } as body) -> - let index ({ desc = desc } as ind) = - let desc = match desc with - | Einput(x, e) -> Einput(x, expression major time e) - | Eoutput _ -> desc - | Eindex(x, e1, e2) -> - Eindex(x, expression major time e1, expression major time e2) in - { ind with desc = desc } in - let init ({ desc = desc } as ini) = - let desc = match desc with - | Einit_last(x, e) -> Einit_last(x, expression major time e) in - { ini with desc = desc } in - let i_list = List.map index i_list in - let init_list = List.map init init_list in - let b_eq_list = block major time b_eq_list in - { eq with eq_desc = EQforall { body with for_index = i_list; - for_init = init_list; - for_body = b_eq_list } } - | EQautomaton _ | EQpresent _ | EQemit _ - | EQder _ -> assert false - -and equation_list major time eq_list = List.map (equation major time) eq_list - -(** Translate a block *) -and block major time ({ b_locals = l_list; b_body = eq_list } as b) = - let l_list = List.map (local major time) l_list in - let eq_list = equation_list major time eq_list in - { b with b_locals = l_list; b_body = eq_list } - -and local major time ({ l_eq = eq_list } as l) = - { l with l_eq = equation_list major time eq_list } - -let implementation impl = - match impl.desc with - | Eopen _ | Etypedecl _ | Econstdecl _ - | Efundecl(_, { f_kind = (S | AS | A | AD | D | P) }) -> impl - | Efundecl(n, ({ f_kind = C; f_args = pat_list; - f_body = e; f_env = f_env } as body)) -> - let time = new_time () in - let f_env, major = Zaux.major f_env in - let e = expression major time e in - let head, tail = Zmisc.firsts pat_list in - let f_env, tail = extra_input time f_env tail in - { impl with desc = - Efundecl(n, { body with f_args = head @ [tail]; - f_body = e; f_env = f_env }) } - -let implementation_list impl_list = Zmisc.iter implementation impl_list - - diff --git a/compiler/rewrite/pre.ml b/compiler/rewrite/pre.ml deleted file mode 100644 index f6db0d084..000000000 --- a/compiler/rewrite/pre.ml +++ /dev/null @@ -1,242 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* Translation of fby/pre/next/up into init/last *) -(* After this pass equations are of the form: *) -(* eq ::= x = e | x = e | der x = e | x = up(e) | y = f(e) *) -(* | init x = e *) -(* | match e with P1 -> b1 | ... Pn -> bn *) -(* - [e1 fby e2] => [let rec init x = e1 and x = e2 and r = last x in r] - - [pre(e)] => [let rec m = e and x = last m in x] - - [next x = e] => [nx = e], replace all occ. of [init x = e0] - by [init nx = e0 and add an equation - [x = last nx] - - [up(e)] => [let x = up(e) in x] - - [e1 -> e2] => [let x = e1 -> e2 in x] - - [horizon(e)] => [let x = horizon(e) in x] - - [f(e)] => let x = f(e) in x -*) - -open Zmisc -open Zlocation -open Deftypes -open Zelus -open Zident -open Zaux - -(* Defines a value [let x = e in e_let] *) -let let_value e = - let x = Zident.fresh "x" in - let l_env = Env.singleton x (Deftypes.entry Sval e.e_typ) in - Zaux.make_let l_env [Zaux.eq_make x e] (var x e.e_typ) - -let let_value e = - let x = Zident.fresh "x" in - let l_env = Env.singleton x (Deftypes.entry Sval e.e_typ) in - Zaux.make_let l_env [Zaux.eq_make x e] (var x e.e_typ) - -(* Defines a state variable with initialization or not *) -(* [let init m = e0 and m = e and x = last m in x] *) -let let_last_value e0_opt e = - let m = Zident.fresh "m" in - let x = Zident.fresh "x" in - let mem = Deftypes.previous Deftypes.empty_mem in - let eq_list = [eq_make m e; eq_make x (last m e.e_typ)] in - let mem, eq_list = - match e0_opt with - | None -> mem, eq_list - | Some(e0) -> Deftypes.initialized mem, (eq_init m e0) :: eq_list in - Zaux.make_let - (Env.add x (Deftypes.entry Sval e.e_typ) - (Env.singleton m (Deftypes.entry (Smem mem) e.e_typ))) eq_list - (var x e.e_typ) - -(* Define a zero-crossing *) -let let_zero_value e = - let x = Zident.fresh "x" in - let mem = Deftypes.zero Deftypes.empty_mem in - let l_env = Env.singleton x (Deftypes.entry mem e.e_typ) in - Zaux.make_let l_env [Zaux.eq_make x e] (var x e.e_typ) - -(* Computes the set of variables defined by a "next". Change the *) -(* environment *) -let env subst b_env = - let change x ({ t_typ = ty; t_sort = sort } as entry) - (env, subst, x_lx_eq_list) = - match sort with - | Smem ({ m_next = Some(true) } as m) -> - let nx = Zident.fresh "nx" in - Env.add x { entry with t_sort = Sval } - (Env.add nx { entry with t_sort = - Smem { m with m_next = Some(false); - m_previous = true } } env), - Env.add x nx subst, (eq_make x (last nx ty)) :: x_lx_eq_list - | Sstatic | Sval | Svar _ | Smem _ -> - Env.add x entry env, subst, x_lx_eq_list in - Env.fold change b_env (Env.empty, subst, []) - - -(** Translation of expressions. *) -let rec exp e = - match e.e_desc with - | Elocal _ | Econst _ | Econstr0 _ | Eglobal _ | Elast _ -> e - | Etuple(e_list) -> - { e with e_desc = Etuple (List.map exp e_list) } - | Econstr1(c, e_list) -> - { e with e_desc = Econstr1(c, List.map exp e_list) } - | Eop(Efby, [e1; e2]) -> - let e1 = exp e1 in - let e2 = exp e2 in - (* translate into [let rec init m = e1 and m = e2 and x = last m in x] *) - let_last_value (Some(e1)) e2 - | Eop(Eminusgreater | Einitial | Ehorizon as op, e_list) -> - let e_list = List.map exp e_list in - (* turns it into [let m = op(e1,...,en) in x] *) - let_value { e with e_desc = Eop(op, e_list) } - | Eop(Eifthenelse, [e1; e2; e3]) -> - let e1 = exp e1 in - let e2 = exp e2 in - let e3 = exp e3 in - (* if [e2] (and [e3]) is stateful, name the result *) - { e with e_desc = - Eop(Eifthenelse, - [e1; if Unsafe.exp e2 then let_value e2 else e2; - if Unsafe.exp e3 then let_value e3 else e3]) } - | Eop(Eunarypre, [e1]) -> - let e1 = exp e1 in - (* turns it into [let rec m = e1 and x = last m in x] *) - let_last_value None e1 - | Eop(Eup, [e1]) -> - let e1 = exp e1 in - (* turns it into [let x = up(e1) in x] *) - let_zero_value { e with e_desc = Eop(Eup, [e1]) } - | Eop(op, e_list) -> { e with e_desc = Eop(op, List.map exp e_list) } - | Eapp(app, e_op, e_list) -> - let e_op = exp e_op in - let e_list = List.map exp e_list in - { e with e_desc = Eapp(app, e_op, e_list) } - | Erecord(label_e_list) -> - let label_e_list = - List.map (fun (l, e) -> (l, exp e)) label_e_list in - { e with e_desc = Erecord(label_e_list) } - | Erecord_access(e_record, longname) -> - { e with e_desc = Erecord_access(exp e_record, longname) } - | Erecord_with(e_record, label_e_list) -> - let label_e_list = - List.map (fun (l, e) -> (l, exp e)) label_e_list in - { e with e_desc = Erecord_with(exp e_record, label_e_list) } - | Etypeconstraint(e1, ty) -> - { e with e_desc = Etypeconstraint(exp e1, ty) } - | Elet(l, e) -> - let l = local l in { e with e_desc = Elet(l, exp e) } - | Eblock(b, e) -> - let b = block Env.empty b in { e with e_desc = Eblock(b, exp e) } - | Eseq(e1, e2) -> - { e with e_desc = Eseq(exp e1, exp e2) } - | Eperiod { p_phase = p1; p_period = p2 } -> - { e with e_desc = Eperiod - { p_phase = Zmisc.optional_map exp p1; p_period = exp p2 } } - | Epresent _ | Ematch _ -> assert false - -(** Translation of equations. *) -and equation subst eq_list ({ eq_desc = desc } as eq) = - match desc with - | EQeq(p, e) -> - { eq with eq_desc = EQeq(p, exp e) } :: eq_list - | EQpluseq(x, e) -> - { eq with eq_desc = EQpluseq(x, exp e) } :: eq_list - | EQnext(x, e, None) -> - let nx = try Env.find x subst with Not_found -> assert false in - { eq with eq_desc = EQeq(varpat nx e.e_typ, exp e) } :: eq_list - | EQnext(x, e, Some(e0)) -> - let e = exp e in - let e0 = exp e0 in - let nx = try Env.find x subst with Not_found -> assert false in - { eq with eq_desc = EQinit(nx, e0) } :: - { eq with eq_desc = EQeq(varpat nx e.e_typ, e) } :: eq_list - | EQinit(x, e0) -> - let nx = try Env.find x subst with Not_found -> x in - { eq with eq_desc = EQinit(nx, exp e0) } :: eq_list - | EQmatch(total, e, p_h_list) -> - let p_h_list = - List.map (fun ({ m_body = b } as h) -> let b = block subst b in - { h with m_body = b }) - p_h_list in - { eq with eq_desc = EQmatch(total, exp e, p_h_list) } :: eq_list - | EQreset(res_eq_list, e) -> - let res_eq_list = equation_list subst [] res_eq_list in - { eq with eq_desc = EQreset(res_eq_list, exp e) } :: eq_list - | EQand(and_eq_list) -> - { eq with eq_desc = EQand(equation_list subst [] and_eq_list) } :: eq_list - | EQbefore(before_eq_list) -> - { eq with eq_desc = - EQbefore(equation_list subst [] before_eq_list) } :: eq_list - | EQder(x, e, None, []) -> - let nx = try Env.find x subst with Not_found -> x in - { eq with eq_desc = EQder(nx, exp e, None, []) } :: eq_list - | EQblock(b) -> let b = block subst b in - { eq with eq_desc = EQblock(b) } :: eq_list - | EQforall ({ for_index = i_list; for_init = init_list; - for_body = b_eq_list } as body) -> - let index ({ desc = desc } as ind) = - let desc = match desc with - | Einput(x, e) -> Einput(x, exp e) - | Eoutput _ -> desc - | Eindex(x, e1, e2) -> - Eindex(x, exp e1, exp e2) in - { ind with desc = desc } in - let init ({ desc = desc } as ini) = - let desc = match desc with - | Einit_last(x, e) -> Einit_last(x, exp e) in - { ini with desc = desc } in - let i_list = List.map index i_list in - let init_list = List.map init init_list in - let b_eq_list = block subst b_eq_list in - { eq with eq_desc = - EQforall { body with for_index = i_list; - for_init = init_list; - for_body = b_eq_list } } - :: eq_list - | EQpresent _ | EQautomaton _ | EQder _ | EQemit _ -> assert false - -and equation_list subst new_eq_list eq_list = - List.fold_left (equation subst) new_eq_list eq_list - -and block subst ({ b_locals = l_list; b_body = eq_list; b_env = b_env } as b) = - (* Identify variables defined by a "next". Renames them and *) - (* add a copy *) - let b_env, subst, x_lx_eq_list = env subst b_env in - let l_list = List.map local l_list in - let eq_list = equation_list subst x_lx_eq_list eq_list in - { b with b_locals = l_list; b_body = eq_list; b_env = b_env } - -and local ({ l_eq = l_eq_list; l_env = l_env } as l) = - let l_env, subst, x_lx_eq_list = env Env.empty l_env in - let l_eq_list = equation_list subst x_lx_eq_list l_eq_list in - { l with l_eq = l_eq_list; l_env = l_env } - -let implementation impl = - match impl.desc with - | Eopen _ | Etypedecl _ | Econstdecl _ | Efundecl(_, { f_kind = A }) -> impl - | Efundecl(n, ({ f_body = e; f_env = f_env } as body)) -> - { impl with desc = Efundecl(n, { body with f_body = exp e }) } - -let implementation_list impl_list = Zmisc.iter implementation impl_list diff --git a/compiler/rewrite/present.ml b/compiler/rewrite/present.ml deleted file mode 100644 index 3bc99fff0..000000000 --- a/compiler/rewrite/present.ml +++ /dev/null @@ -1,404 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* removing present statements *) -open Zmisc -open Zlocation -open Zident -open Lident -open Global -open Zelus -open Zaux -open Initial -open Ztypes -open Deftypes - -(* compilation of signal pattern matching *) -(* present *) -(* | x1(p1) & ... & -> do ... done *) -(* | x2(p2) & x1(p3) & ... *) -(* end *) -(* *) -(* - rewrite the pattern matching such a signal name is assigned to *) -(* a column. Boolean conditions are put in an extra column. *) -(* *) -(* present *) -(* | x1(p1) & ... & cond1 -> do ... done *) -(* | x1(p3) & ... & cond2 -> ... *) -(* end *) -(* *) -(* - then produce a regular pattern matching construct *) -(* every handler is marked to be activated on an event *) -(* *) -(* match x1, ... cond1, ..., condn with *) -(* | Present(p1), ..., true, ... -> (* zero = true *) ... *) -(* | Present(p3), ..., _, true -> (* zero = true *) ... *) -(* end *) -(* the bit [zero] indicates that the branch corresponds to a *) -(* zero-crossing. It is set to [true] only when the context is continuous *) -(* *) -(* *) -(* a signal x is represented by a pair (bit, value) *) - - -(** representation of signals *) -(* a [signal] is a pair made of a value and a boolean *) -let emit e = e, etrue -let presentpat pat = - { pat with p_desc = Etuplepat[pat; truepat]; - p_typ = tproduct [pat.p_typ; typ_bool] } - -(* implementation of the presence test ? of a signal *) -let test e = Eapp(Zaux.prime_app, - Zaux.global_in_stdlib "snd" - (maketype [e.e_typ] Initial.typ_bool), - [e]) - -let eq_match total e l = - let block_do_done = - { b_vars = []; b_locals = []; b_body = []; b_loc = no_location; - b_env = Env.empty; - b_write = Deftypes.empty } in - (* if [total = false] complete with an empty block [do done] *) - let l = if total then l - else l @ [{ m_pat = { Zaux.wildpat with p_typ = e.e_typ }; - m_body = block_do_done; m_env = Env.empty; - m_reset = false; m_zero = false }] in - eqmake (EQmatch(ref true, e, l)) - -(* build the environment for signals from a typing environment *) -(* every signal [x: t sig] is associated to a pair [xv, xp] of two fresh *) -(* names. [xv: t] and [xp: bool] *) -let build signals l_env = - let make n ({ t_typ = ty; t_sort = sort } as tentry) - (signals, n_list, new_env) = - match Ztypes.is_a_signal ty with - | Some(ty) -> - let xv = Zident.fresh ((Zident.source n) ^ "v") in - let xp = Zident.fresh ((Zident.source n) ^ "p") in - let sort_v, sort_p = - match sort with - | Sstatic -> Sstatic, Sstatic - | Sval -> Sval, Sval - | Svar _ - | Smem _ -> Deftypes.variable, - Svar { v_combine = None; - v_default = Some(Cimmediate(Ebool(false))) } in - Env.add n (xv, xp, ty) signals, - (Zaux.vardec xv) :: (Zaux.vardec xp) :: n_list, - Env.add xv { t_typ = ty; t_sort = sort_v } - (Env.add xp { t_typ = typ_bool; t_sort = sort_p } new_env) - | None -> - signals, (Zaux.vardec_from_entry n tentry) :: n_list, - Env.add n tentry new_env in - Env.fold make l_env (signals, [], Env.empty) - -(* equality between expressions. for efficiency purpose *) -(* we restrict to simple cases *) -let equal e1 e2 = - match e1.e_desc, e2.e_desc with - | Econst(i), Econst(j) when (i = j) -> true - | Elocal(i), Elocal(j) when (i = j) -> true - | Elast(i), Elast(j) when (i = j) -> true - | _ -> false - -(* the member function *) -let mem e exps = List.exists (equal e) exps - -(* rename written variables [w] according to a substitution [signals] *) -(* the field [w.dr] is not concerned *) -let defnames signals ({ dv = dv; di = di } as w) = - let defname n acc = - try let nv, np, _ = Env.find n signals in S.add nv (S.add np acc) - with Not_found -> S.add n acc in - { w with dv = S.fold defname dv S.empty; di = S.fold defname di S.empty } - -(* separate signal testing from boolean condition in a signal pattern *) -let split spat = - let rec split (se_list, pat_list, cond_list) spat = - match spat.desc with - | Econdand(sp1, sp2) | Econdor(sp1, sp2) -> - split (split (se_list, pat_list, cond_list) sp2) sp1 - | Econdexp(e) -> - se_list, pat_list, e :: cond_list - | Econdon(sp1, e) -> - let se_list, pat_list, cond_list = - split (se_list, pat_list, cond_list) sp1 in - se_list, pat_list, e :: cond_list - | Econdpat(e, pat) -> - e :: se_list, pat :: pat_list, cond_list in - split ([], [], []) spat - -let rec pattern signals p = - match p.p_desc with - | Ewildpat | Econstpat _ | Econstr0pat _ -> p - | Etuplepat(p_list) -> - { p with p_desc = Etuplepat(List.map (pattern signals) p_list) } - | Econstr1pat(c, p_list) -> - { p with p_desc = Econstr1pat(c, List.map (pattern signals) p_list) } - | Evarpat(n) -> - begin try - let nv, np, ty = Env.find n signals in - { p with p_desc = Etuplepat [varpat nv ty; varpat np typ_bool] } - with - | Not_found -> p - end - | Ealiaspat(p1, n) -> - { p with p_desc = Ealiaspat(pattern signals p1, n) } - | Eorpat(p1, p2) -> - { p with p_desc = Eorpat(pattern signals p1, pattern signals p2) } - | Erecordpat(l_p_list) -> - let l_p_list = - List.map (fun (l, p) -> (l, pattern signals p)) l_p_list in - { p with p_desc = Erecordpat(l_p_list) } - | Etypeconstraintpat(p1, ty) -> - { p with p_desc = Etypeconstraintpat(pattern signals p1, ty) } - -let rec exp signals ({ e_desc = desc } as e) = - let desc = match desc with - | Econst _ | Econstr0 _ | Eglobal _ -> desc - | Elast(name) -> - begin try - let nv, np, ty = Env.find name signals in - Etuple [last nv ty; last np typ_bool] - with - | Not_found -> desc - end - | Elocal(name)-> - begin try - let nv, np, ty = Env.find name signals in - Etuple [var nv ty; var np typ_bool] - with - | Not_found -> desc - end - | Etuple(e_list) -> Etuple(List.map (exp signals) e_list) - | Econstr1(c, e_list) -> Econstr1(c, List.map (exp signals) e_list) - | Eop(Etest, [e]) -> test (exp signals e) - | Eop(op, e_list) -> - Eop(op, List.map (exp signals) e_list) - | Eapp(app, e, e_list) -> - Eapp(app, exp signals e, List.map (exp signals) e_list) - | Erecord(label_e_list) -> - Erecord(List.map - (fun (label, e) -> (label, exp signals e)) label_e_list) - | Erecord_access(e_record, longname) -> - Erecord_access(exp signals e_record, longname) - | Erecord_with(e_record, label_e_list) -> - Erecord_with(exp signals e_record, - List.map - (fun (label, e) -> (label, exp signals e)) label_e_list) - | Etypeconstraint(e, ty) -> Etypeconstraint(exp signals e, ty) - | Eseq(e1, e2) -> Eseq(exp signals e1, exp signals e2) - | Eperiod { p_phase = p1; p_period = p2 } -> - Eperiod { p_phase = Zmisc.optional_map (exp signals) p1; - p_period = exp signals p2 } - | Elet(l, e) -> - let signals, l = local signals l in Elet(l, exp signals e) - | Eblock(b, e) -> - let signals, b = block signals b in - Eblock(b, exp signals e) - | Epresent _ | Ematch _ -> assert false in - { e with e_desc = desc } - -and equation signals eq_list eq = - match eq.eq_desc with - | EQeq(pat, e) -> - { eq with eq_desc = - EQeq(pattern signals pat, exp signals e) } :: eq_list - | EQpluseq(x, e) -> - { eq with eq_desc = EQpluseq(x, exp signals e) } :: eq_list - | EQinit(x, e0) -> - { eq with eq_desc = EQinit(x, exp signals e0) } :: eq_list - | EQnext(x, e, e0_opt) -> - { eq with eq_desc = - EQnext(x, exp signals e, - optional_map (exp signals) e0_opt) } :: eq_list - | EQder(x, e, None, []) -> - { eq with eq_desc = EQder(x, exp signals e, None, []) } :: eq_list - | EQemit(name, e_opt) -> - (* essentially translate to [(namev,namep) = e] *) - let e = match e_opt with | None -> evoid | Some(e) -> exp signals e in - let nv, np, ty = Env.find name signals in - let ev, ep = emit e in - { eq with eq_desc = EQeq(varpat nv ty, ev) } :: - { eq with eq_desc = EQeq(varpat np typ_bool, ep) } :: eq_list - | EQmatch(total, e, match_handler_list) -> - { eq with eq_desc = - EQmatch(total, exp signals e, - List.map (match_handler signals) match_handler_list) } - :: eq_list - | EQpresent(present_handler_list, b_opt) -> - present_handlers signals eq_list present_handler_list b_opt - | EQreset(res_eq_list, e) -> - let res_eq_list = equation_list signals res_eq_list in - { eq with eq_desc = EQreset(res_eq_list, exp signals e) } :: eq_list - | EQand(and_eq_list) -> - { eq with eq_desc = EQand(equation_list signals and_eq_list) } :: eq_list - | EQbefore(before_eq_list) -> - { eq with eq_desc = - EQbefore(equation_list signals before_eq_list) } :: eq_list - | EQblock(b) -> - let _, b = block signals b in - { eq with eq_desc = EQblock(b) } :: eq_list - | EQforall ({ for_index = i_list; for_init = init_list; - for_body = b_eq_list } as body) -> - let index ({ desc = desc } as ind) = - let desc = match desc with - | Einput(x, e) -> Einput(x, exp signals e) - | Eoutput _ -> desc - | Eindex(x, e1, e2) -> Eindex(x, exp signals e1, exp signals e2) in - { ind with desc = desc } in - let init ({ desc = desc } as ini) = - let desc = match desc with - | Einit_last(x, e) -> Einit_last(x, exp signals e) in - { ini with desc = desc } in - let _, b_eq_list = block signals b_eq_list in - { eq with eq_desc = - EQforall - { body with for_index = List.map index i_list; - for_init = List.map init init_list; - for_body = b_eq_list } } - :: eq_list - | EQautomaton _ | EQder _ -> assert false - -and equation_list signals eq_list = - List.fold_left (equation signals) [] eq_list - -and local signals ({ l_eq = eq_list; l_env = l_env } as l) = - (* for every signal [s] declared in [env], we introduce *) - (* a pair of names [sv, sp] for the value and presence *) - let signals, _, l_env = build signals l_env in - let eq_list = equation_list signals eq_list in - signals, { l with l_eq = eq_list; l_env = l_env } - -and locals signals l_list = - match l_list with - | [] -> signals, [] - | l :: l_list -> - let signals, l = local signals l in - let signals, l_list = locals signals l_list in - signals, l :: l_list - -and block signals - ({ b_vars = n_list; b_locals = l_list; - b_body = eq_list; b_env = b_env; b_write = w } as b) = - (* for every signal [s] declared in [b_env], we introduce *) - (* a pair of names [sv, sp] for the value and presence *) - let signals, n_list, b_env = build signals b_env in - let signals, l_list = locals signals l_list in - let eq_list = equation_list signals eq_list in - (* rename variables in [w] *) - let w = defnames signals w in - signals, { b with b_vars = n_list; b_locals = l_list; - b_body = eq_list; b_write = w; b_env = b_env } - -and match_handler signals ({ m_body = b } as handler) = - let _, b = block signals b in { handler with m_body = b } - -(* Translating a present statement *) -(* a present statement is translated into a pattern-matching statement *) -(* [is_cont = true] means that the present constructs run in a continuous context *) -and present_handlers signals eq_list handler_list b_opt = - (* compute the set of expressions from a signal pattern matching *) - (* expressions appearing more than once are shared *) - let rec unique exps spat = - match spat.desc with - | Econdand(spat1, spat2) | Econdor(spat1, spat2) -> - unique (unique exps spat1) spat2 - | Econdexp(e) | Econdpat(e, _) -> - if mem e exps then exps - else e :: exps - | Econdon(spat1, e) -> - unique (if mem e exps then exps else e :: exps) spat1 in - - let unique handler_list = - List.fold_left - (fun exps { p_cond = spat } -> unique exps spat) [] handler_list in - - (* normalize a signal pattern *) - let rec norm spat acc = - match spat.desc with - | Econdor(spat1, spat2) -> norm spat1 (norm spat2 acc) - | Econdpat _ | Econdexp _ | Econdand _ | Econdon _ -> spat :: acc in - - (* find the pattern associated to a signal in a signal pattern *) - let pat spat se cont = - let rec patrec spat = - match spat.desc with - | Econdand(spat1, spat2) -> - begin try patrec spat1 with Not_found -> patrec spat2 end - | Econdpat(e, pat) when (equal e se) || (e == se) -> presentpat pat - | Econdexp(e) when (equal e se) || (e == se) -> truepat - | Econdon(_, e) when (equal e se) || (e == se) -> truepat - | Econdon(spat1, _) -> patrec spat1 - | _ -> raise Not_found in - try - (patrec spat) :: cont - with - Not_found -> - { Zaux.wildpat with p_typ = se.e_typ } :: cont in - - (* build the pattern *) - let pattern exps { p_cond = spat; p_body = b; p_env = h0 } = - let pattern spat = - let pat_list = List.fold_right (pat spat) exps [] in - match pat_list with - | [] -> assert false - | [pat] -> pat - | _ -> tuplepat(pat_list) in - (* extract the list of simple signals patterns without "|" (or) *) - let spat_list = norm spat [] in - let pat_list = List.map pattern spat_list in - let pat = orpat pat_list in - (* the flag [zero] is true when [is_cont] is true *) - let _, b = block signals b in - { m_pat = pat; m_body = b; m_env = h0; - m_reset = false; m_zero = true } in - - (* first build the two association tables *) - let exps = unique handler_list in - (* compile each of them *) - (* produces the expression to match *) - let e = match exps with - | [e] -> exp signals e | _ -> tuple (List.map (exp signals) exps) in - (* produces the handlers *) - let pat_block_list = List.map (pattern exps) handler_list in - (* treat the optional default handler *) - let total, pat_block_list = - match b_opt with - | None -> false, pat_block_list - | Some(b) -> - let _, b = block signals b in - true, pat_block_list @ - [{ m_pat = { Zaux.wildpat with p_typ = e.e_typ }; m_body = b; - m_env = Env.empty; m_reset = false; m_zero = false }] in - (eq_match total e pat_block_list) :: eq_list - -let implementation impl = - match impl.desc with - | Eopen _ | Etypedecl _ -> impl - | Econstdecl(n, is_static, e) -> - let e = exp Env.empty e in - { impl with desc = Econstdecl(n, is_static, e) } - | Efundecl(n, ({ f_args = p_list; f_body = e; f_env = f_env } as body)) -> - let signals, _, f_env = build Env.empty f_env in - let p_list = List.map (pattern signals) p_list in - let e = exp signals e in - { impl with desc = - Efundecl(n, { body with f_args = p_list; - f_body = e; - f_env = f_env }) } - -let implementation_list impl_list = Zmisc.iter implementation impl_list - diff --git a/compiler/rewrite/proba.ml b/compiler/rewrite/proba.ml deleted file mode 100644 index 579a4d41a..000000000 --- a/compiler/rewrite/proba.ml +++ /dev/null @@ -1,178 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* translation of a probabilistic node into a node. *) -(* the translation is applied to normalised programs *) - -(* every probabilistic node: - - [let proba f x1 ... xn = ...] - -is translated into: - - [let node f x1 ... prob xn = ...] - -and every application of a probabilistic node: - - [f e1 ... en] - -into: - - [f e1 ... prob en] - *) - -open Zelus -open Deftypes -open Lident -open Zident - -let new_prob () = Zident.fresh "prob" - -(* If the extra parameter [prob] is given a type, say [prob] *) -(* this type but be bind to an actual module or interface. This makes *) -(* the translation dependent on the infer function. This is why we *) -(* chose to give it a type variable. *) -let typ_prob = Ztypes.make (Deftypes.Tvar) -let prob_varpat x = Zaux.varpat x typ_prob -let prob_var x = Zaux.var x typ_prob - -(* Add the extra input parameter "time" for hybrid nodes *) -let extra_input prob env = - Env.add prob { t_sort = Deftypes.value; t_typ = typ_prob } env, - (prob_varpat prob) - -(** Translation of expressions. *) -let rec expression prob ({ e_desc = e_desc } as e) = - match e_desc with - | Eperiod({ p_phase = opt_p1; p_period = p2 }) -> - { e with e_desc = - Eperiod({ p_phase = - Zmisc.optional_map (expression prob) opt_p1; - p_period = expression prob p2 }) } - | Eop(op, e_list) -> - { e with e_desc = Eop(op, List.map (expression prob) e_list) } - | Eapp(app, op, e_list) -> - let op = expression prob op in - let e_list = List.map (expression prob) e_list in - let e_list = - if Ztypes.is_probabilistic (List.length e_list - 1) op.e_typ then - let head, tail = Zmisc.firsts e_list in - head @ [Zaux.pair (prob_var prob) tail] - else e_list in - { e with e_desc = Eapp(app, op, e_list) } - | Etuple(e_list) -> - { e with e_desc = Etuple(List.map (expression prob) e_list) } - | Econstr1(c, e_list) -> - { e with e_desc = Econstr1(c, List.map (expression prob) e_list) } - | Erecord_access(e_record, x) -> - { e with e_desc = Erecord_access(expression prob e_record, x) } - | Erecord(l_e_list) -> - let l_e_list = - List.map (fun (l, e) -> (l, expression prob e)) l_e_list in - { e with e_desc = Erecord(l_e_list) } - | Erecord_with(e_record, l_e_list) -> - let l_e_list = - List.map (fun (l, e) -> (l, expression prob e)) l_e_list in - { e with e_desc = Erecord_with(expression prob e_record, l_e_list) } - | Etypeconstraint(e, ty) -> - { e with e_desc = Etypeconstraint(expression prob e, ty) } - | Elet(l, e) -> - { e with e_desc = Elet(local prob l, expression prob e) } - | Eblock(b, e) -> - { e with e_desc = Eblock(block prob b, expression prob e) } - | Eseq(e1, e2) -> - { e with e_desc = - Eseq(expression prob e1, expression prob e2) } - | Elocal _ | Eglobal _ | Econst _ | Econstr0 _ | Elast _ -> e - | Epresent _ | Ematch _ -> assert false - -(* Translation of equations *) -and equation prob ({ eq_desc = desc } as eq) = - match desc with - | EQeq(p, e) -> { eq with eq_desc = EQeq(p, expression prob e) } - | EQpluseq(x, e) -> { eq with eq_desc = EQpluseq(x, expression prob e) } - | EQmatch(total, e, m_h_list) -> - let m_h_list = - List.map - (fun ({ m_body = b } as m_h) -> - { m_h with m_body = block prob b }) - m_h_list in - { eq with eq_desc = EQmatch(total, expression prob e, m_h_list) } - | EQreset(res_eq_list, e) -> - let e = expression prob e in - let res_eq_list = equation_list prob res_eq_list in - { eq with eq_desc = EQreset(res_eq_list, e) } - | EQand(and_eq_list) -> - { eq with eq_desc = EQand(equation_list prob and_eq_list) } - | EQbefore(before_eq_list) -> - { eq with eq_desc = EQbefore(equation_list prob before_eq_list) } - | EQinit(x, e) -> - { eq with eq_desc = EQinit(x, expression prob e) } - | EQder(x, e, None, []) -> - { eq with eq_desc = EQder(x, expression prob e, None, []) } - | EQnext(x, e, e_opt) -> - let e_opt = Zmisc.optional_map (expression prob) e_opt in - { eq with eq_desc = EQnext(x, expression prob e, e_opt) } - | EQblock(b) -> { eq with eq_desc = EQblock(block prob b) } - | EQforall ({ for_index = i_list; for_init = init_list; - for_body = b_eq_list } as body) -> - let index ({ desc = desc } as ind) = - let desc = match desc with - | Einput(x, e) -> Einput(x, expression prob e) - | Eoutput _ -> desc - | Eindex(x, e1, e2) -> - Eindex(x, expression prob e1, expression prob e2) in - { ind with desc = desc } in - let init ({ desc = desc } as ini) = - let desc = match desc with - | Einit_last(x, e) -> Einit_last(x, expression prob e) in - { ini with desc = desc } in - let i_list = List.map index i_list in - let init_list = List.map init init_list in - let b_eq_list = block prob b_eq_list in - { eq with eq_desc = EQforall { body with for_index = i_list; - for_init = init_list; - for_body = b_eq_list } } - | EQautomaton _ | EQpresent _ | EQemit _ - | EQder _ -> assert false - -and equation_list prob eq_list = List.map (equation prob) eq_list - -(** Translate a block *) -and block prob ({ b_locals = l_list; b_body = eq_list } as b) = - let l_list = List.map (local prob) l_list in - let eq_list = equation_list prob eq_list in - { b with b_locals = l_list; b_body = eq_list } - -and local prob ({ l_eq = eq_list } as l) = - { l with l_eq = equation_list prob eq_list } - -let implementation impl = - match impl.desc with - | Eopen _ | Etypedecl _ | Econstdecl _ - | Efundecl(_, { f_kind = (S | AS | A | AD | D | C) }) -> impl - | Efundecl(n, ({ f_kind = P; f_args = pat_list; - f_body = e; f_env = f_env } as body)) -> - let prob = new_prob () in - let e = expression prob e in - let head, tail = Zmisc.firsts pat_list in - let f_env, prob = extra_input prob f_env in - { impl with desc = - Efundecl(n, - { body with f_kind = D; - f_args = - head @ [Zaux.pairpat prob tail]; - f_body = e; f_env = f_env }) } - -let implementation_list impl_list = Zmisc.iter implementation impl_list diff --git a/compiler/rewrite/reduce.ml b/compiler/rewrite/reduce.ml deleted file mode 100644 index 730afe3cb..000000000 --- a/compiler/rewrite/reduce.ml +++ /dev/null @@ -1,641 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(** reduce expressions that are tagged to be static; leave other unchanged *) - -open Zmisc -open Zident -open Lident -open Global -open Zelus -open Zaux -open Static -open Deftypes -open Ztypes - - -(* the list of functions introduced during the reduction *) -type fun_defs = { fundefs : (name * funexp) list } - -let empty = { fundefs =[] } - -(* Generate fresh symbol names for global values introduced during *) -(* the reduction *) -let num = ref 0 -let gfresh () = num := !num + 1; "__" ^ (string_of_int !num) - -(** Build a renaming from an environment *) -let build env = - let buildrec n entry (env, renaming) = - let m = Zident.fresh (Zident.source n) in - Env.add m entry env, - Env.add n m renaming in - Env.fold buildrec env (Env.empty, Env.empty) - -(** rename a variable *) -let rename x renaming = - try Env.find x renaming - with Not_found -> Zmisc.internal_error "Reduce: unbound name" Printer.name x - -(** Remove entries in [venv] that are defined in [renaming] *) -let remove rename venv = - Env.filter (fun x _ -> not (Env.mem x rename)) venv - -(** type expressions *) -let rec type_expression venv renaming ({ desc = desc } as ty_e) = - match desc with - | Etypevar _ -> ty_e - | Etypeconstr(g, ty_list) -> - let ty_list = List.map (type_expression venv renaming) ty_list in - { ty_e with desc = Etypeconstr(g, ty_list) } - | Etypetuple(ty_list) -> - let ty_list = List.map (type_expression venv renaming) ty_list in - { ty_e with desc = Etypetuple(ty_list) } - | Etypevec(ty_vec, s) -> - let ty_vec = type_expression venv renaming ty_vec in - { ty_e with desc = Etypevec(ty_vec, size venv renaming s) } - | Etypefun(k, opt_name, ty_arg, ty_res) -> - let ty_arg = type_expression venv renaming ty_arg in - let opt_name, renaming = - match opt_name with - | None -> opt_name, renaming - | Some(n) -> - let m = Zident.fresh (Zident.source n) in - Some(m), Env.add n m renaming in - let ty_res = type_expression venv renaming ty_res in - { ty_e with desc = Etypefun(k, opt_name, ty_arg, ty_res) } - -and size venv renaming ({ desc = desc } as s) = - let operator op i1 i2 = - match op with - | Splus -> i1 + i2 - | Sminus -> i1 - i2 in - - match desc with - | Sconst _ | Sglobal _ -> s - | Sname(n) -> - let desc = - try - let { value_exp = v } = Env.find n venv in - match v with - | Vconst(Eint(i)) -> Sconst(i) - | _ -> desc - with - Not_found -> Sname(rename n renaming) in - { s with desc = desc } - | Sop(op, s1, s2) -> - let s1 = size venv renaming s1 in - let s2 = size venv renaming s2 in - let desc = - match s1.desc, s2.desc with - | Sconst(i1), Sconst(i2) -> Sconst(operator op i1 i2) - | _ -> Sop(op, s1, s2) in - { s with desc = desc } - -(** Rename an operator *) -let operator venv renaming op = - match op with - | Eunarypre | Efby | Eminusgreater | Eifthenelse - | Eup | Etest | Edisc | Ehorizon | Einitial | Eaccess - | Eupdate | Econcat | Eatomic -> op - | Eslice(s1, s2) -> Eslice(size venv renaming s1, size venv renaming s2) - -(** Renaming of patterns *) -let rec pattern venv renaming ({ p_desc = desc } as p) = - match desc with - | Ewildpat | Econstpat _ | Econstr0pat _ -> p - | Evarpat(n) -> { p with p_desc = Evarpat(rename n renaming) } - | Etuplepat(p_list) -> - { p with p_desc = Etuplepat(List.map (pattern venv renaming) p_list) } - | Econstr1pat(c, p_list) -> - { p with p_desc = - Econstr1pat(c, List.map (pattern venv renaming) p_list) } - | Erecordpat(n_p_list) -> - let n_p_list = - List.map (fun (ln, p) -> (ln, pattern venv renaming p)) n_p_list in - { p with p_desc = Erecordpat(n_p_list) } - | Ealiaspat(p1, n) -> - let n = rename n renaming in - { p with p_desc = Ealiaspat(pattern venv renaming p1, n) } - | Eorpat(p1, p2) -> - { p with p_desc = - Eorpat(pattern venv renaming p1, pattern venv renaming p2) } - | Etypeconstraintpat(p1, ty) -> - { p with p_desc = Etypeconstraintpat(pattern venv renaming p1, - type_expression venv renaming ty) } - -(** Simplify an expression. *) -(* [expression venv renaming fun_defs e = e', fun_defs'] *) -(* - venv an environment of values; - *- renaming is a renaming of variables; - *- e and e' are expressions; - *- fun_defs and fun_defs' are list of the functions introduced - *- during the simplification -*) -let rec expression venv renaming fun_defs ({ e_desc = desc } as e) = - match desc with - | Econst _ | Econstr0 _ | Eglobal _ -> e, fun_defs - | Elocal(x) -> - (* fist search in the environment of values *) - (* other wise, rename [x] into [x'] *) - begin try exp_of_value fun_defs (Env.find x venv) - with Not_found -> - { e with e_desc = Elocal(rename x renaming) }, fun_defs - end - | Elast(x) -> { e with e_desc = Elast(rename x renaming) }, fun_defs - | Eperiod { p_phase = p1; p_period = p2 } -> - let p1, fun_defs = Zmisc.optional_with_map (expression venv renaming) fun_defs p1 in - let p2, fun_defs = expression venv renaming fun_defs p2 in - { e with e_desc = Eperiod { p_phase = p1; p_period = p2 } }, fun_defs - | Etuple(e_list) -> - let e_list, fun_defs = - Zmisc.map_fold (expression venv renaming) fun_defs e_list in - { e with e_desc = Etuple(e_list) }, fun_defs - | Econstr1(c, e_list) -> - let e_list, fun_defs = - Zmisc.map_fold (expression venv renaming) fun_defs e_list in - { e with e_desc = Econstr1(c, e_list) }, fun_defs - | Erecord(l_e_list) -> - let l_e_list, fun_defs = - Zmisc.map_fold - (fun fun_defs (ln, e) -> - let e, fun_defs = expression venv renaming fun_defs e in - (ln, e), fun_defs) fun_defs l_e_list in - { e with e_desc = Erecord(l_e_list) }, fun_defs - | Erecord_access(e_record, ln) -> - let e_record, fun_defs = - expression venv renaming fun_defs e_record in - { e_record with e_desc = Erecord_access(e_record, ln) }, fun_defs - | Erecord_with(e_record, l_e_list) -> - let e_record, fun_defs = - expression venv renaming fun_defs e_record in - let l_e_list, fun_defs = - Zmisc.map_fold - (fun fun_defs (ln, e) -> - let e, fun_defs = expression venv renaming fun_defs e in - (ln, e), fun_defs) fun_defs l_e_list in - { e with e_desc = Erecord_with(e_record, l_e_list) }, fun_defs - | Eapp({ app_inline = inline } as app, e_fun, e_list) -> - (* [e_fun] is necessarily static. It needs to be a compile-time *) - (* non opaque value only when [inline] is true *) - (* [e_list] decomposes into (a possibly empty) sequence of - *- static arguments [s_list] and non static ones [ne_list] *) - let e, fun_defs = - let s_list, ne_list, ty_res = - Ztypes.split_arguments e_fun.e_typ e_list in - let ne_list, fun_defs = - Zmisc.map_fold (expression venv renaming) fun_defs ne_list in - try - let v_fun = Static.expression venv e_fun in - let { value_exp = v; value_name = opt_name } as v_fun = - Static.app v_fun (List.map (Static.expression venv) s_list) in - match ne_list with - | [] -> - let e, fun_defs = exp_of_value fun_defs v_fun in - { e with e_typ = ty_res }, fun_defs - | _ -> - (* two solutions are possible. Either we introduce a fresh *) - (* function [f] for the result of [v_fun s1...sn] *) - (* and return [f ne1...nek]. [f] could then be shared in case *) - (* several instance of [v_fun s1...sn] exist *) - (* Or we directly inline the body of [f]. We take this solution *) - (* for the moment *) - match opt_name, v with - | None, - Vfun({ f_args = p_list; f_body = e; f_env = f_env }, - venv_closure) -> - (* [p_list] should now be a list of non static parameters *) - let f_env, renaming0 = build f_env in - let venv = remove renaming0 venv in - let renaming = Env.append renaming0 renaming in - let p_list = List.map (pattern venv renaming) p_list in - let e, fun_defs = - expression venv_closure renaming fun_defs e in - (* return [let p1 = ne1 in ... in pk = nek in e] *) - Zaux.make_let f_env - (List.map2 - (fun p ne -> Zaux.eqmake (EQeq(p, ne))) p_list ne_list) e, - fun_defs - | _ -> (* returns an application *) - let e_fun, fundefs = exp_of_value fun_defs v_fun in - let e_fun = { e_fun with e_typ = ty_res } in - { e with e_desc = Eapp(app, e_fun, ne_list) }, fun_defs - with - Static.Error _ -> - let e_fun, fun_defs = expression venv renaming fun_defs e_fun in - let s_list, fun_defs = - Zmisc.map_fold (expression venv renaming) fun_defs s_list in - { e with e_desc = Eapp(app, e_fun, s_list @ ne_list) }, fun_defs in - e, fun_defs - | Eop(op, e_list) -> - let e_list, fun_defs = - Zmisc.map_fold (expression venv renaming) fun_defs e_list in - { e with e_desc = Eop(op, e_list) }, fun_defs - | Etypeconstraint(e_ty, ty) -> - let e_ty, fun_defs = - expression venv renaming fun_defs e_ty in - let ty = type_expression venv renaming ty in - { e with e_desc = Etypeconstraint(e_ty, ty) }, fun_defs - | Eseq(e1, e2) -> - let e1, fun_defs = - expression venv renaming fun_defs e1 in - let e2, fun_defs = - expression venv renaming fun_defs e2 in - { e with e_desc = Eseq(e1, e2) }, fun_defs - | Elet(l, e_let) -> - let l, (renaming, fun_defs) = local venv (renaming, fun_defs) l in - let e_let, fun_defs = - expression venv renaming fun_defs e_let in - { e with e_desc = Elet(l, e_let) }, fun_defs - | Eblock(b, e_block) -> - let b, (renaming, fun_defs) = block venv (renaming, fun_defs) b in - let e_block, fun_defs = expression venv renaming fun_defs e_block in - { e with e_desc = Eblock(b, e_block) }, fun_defs - | Epresent _ | Ematch _ -> assert false - -(* evaluate a static expression [e] at compile-time if possible *) -(* and turn it into an expression. Otherwise, returns [e] *) -(* preserve the type of [e]. *) -and static venv fun_defs e = - try - let v = Static.expression venv e in - let { e_desc = desc }, fun_defs = exp_of_value fun_defs v in - { e with e_desc = desc }, fun_defs - with - Static.Error _ -> e, fun_defs - -(** Simplify a local declaration *) -and local venv (renaming, fun_defs) ({ l_eq = eq_list; l_env = env } as l) = - let env, renaming0 = build env in - let venv = remove renaming0 venv in - let renaming = Env.append renaming0 renaming in - let eq_list, fun_defs = - Zmisc.map_fold (equation venv renaming) fun_defs eq_list in - { l with l_eq = eq_list; l_env = env }, (renaming, fun_defs) - -(** Simplify an equation. *) -and equation venv renaming fun_defs ({ eq_desc = desc } as eq) = - let desc, fun_defs = - match desc with - | EQeq(p, e) -> - let p = pattern venv renaming p in - let e, fun_defs = expression venv renaming fun_defs e in - EQeq(p, e), fun_defs - | EQpluseq(x, e) -> - let e, fun_defs = expression venv renaming fun_defs e in - EQpluseq(rename x renaming, e), fun_defs - | EQinit(x, e) -> - let e, fun_defs = - expression venv renaming fun_defs e in - EQinit(rename x renaming, e), fun_defs - | EQnext(x, e, e_opt) -> - let e, fun_defs = expression venv renaming fun_defs e in - let e_opt, fun_defs = - Zmisc.optional_with_map (expression venv renaming) fun_defs e_opt in - EQnext(rename x renaming, e, e_opt), fun_defs - | EQder(x, e, e_opt, p_e_list) -> - let body fun_defs ({ p_cond = scpat; p_body = e; p_env = env } as p_e) = - let env, renaming0 = build env in - let venv = remove renaming0 venv in - let renaming = Env.append renaming0 renaming in - let scpat, fun_defs = scondpat venv renaming fun_defs scpat in - let e, fun_defs = expression venv renaming fun_defs e in - { p_e with p_cond = scpat; p_body = e; p_env = env }, fun_defs in - let e, fun_defs = expression venv renaming fun_defs e in - let e_opt, fun_defs = - Zmisc.optional_with_map (expression venv renaming) fun_defs e_opt in - let p_e_list, fun_defs = Zmisc.map_fold body fun_defs p_e_list in - EQder(rename x renaming, e, e_opt, p_e_list), fun_defs - | EQmatch(total, e, m_b_list) -> - let body venv fun_defs ({ m_pat = p; m_body = b; m_env = env } as m_h) = - let env, renaming0 = build env in - let venv = remove renaming0 venv in - let renaming = Env.append renaming0 renaming in - let b, (_, fun_defs) = block venv (renaming, fun_defs) b in - { m_h with m_pat = pattern venv renaming p; - m_body = b; m_env = env }, fun_defs in - let e, fun_defs = expression venv renaming fun_defs e in - let m_b_list, fun_defs = - Zmisc.map_fold (body venv) fun_defs m_b_list in - EQmatch(total, e, m_b_list), fun_defs - | EQblock(b) -> - let b, (_, fun_defs) = block venv (renaming, fun_defs) b in - EQblock(b), fun_defs - | EQreset(eq_list, e) -> - let e, fun_defs = expression venv renaming fun_defs e in - let eq_list, fun_defs = - Zmisc.map_fold (equation venv renaming) fun_defs eq_list in - EQreset(eq_list, e), fun_defs - | EQand(and_eq_list) -> - let and_eq_list, fun_defs = - Zmisc.map_fold (equation venv renaming) fun_defs and_eq_list in - EQand(and_eq_list), fun_defs - | EQbefore(before_eq_list) -> - let before_eq_list, fun_defs = - Zmisc.map_fold (equation venv renaming) fun_defs before_eq_list in - EQbefore(before_eq_list), fun_defs - | EQpresent(p_h_list, b_opt) -> - let body fun_defs ({ p_cond = scpat; p_body = b; p_env = env } as p_b) = - let env, renaming0 = build env in - let venv = remove renaming0 venv in - let renaming = Env.append renaming0 renaming in - let scpat, fun_defs = scondpat venv renaming fun_defs scpat in - let b, (renaming, fun_defs) = block venv (renaming, fun_defs) b in - { p_b with p_cond = scpat; p_body = b; p_env = env }, fun_defs in - let p_h_list, fun_defs = Zmisc.map_fold body fun_defs p_h_list in - let b_opt, (_, fun_defs) = - Zmisc.optional_with_map (block venv) (renaming, fun_defs) b_opt in - EQpresent(p_h_list, b_opt), fun_defs - | EQemit(x, e_opt) -> - let e_opt, fun_defs = - Zmisc.optional_with_map (expression venv renaming) fun_defs e_opt in - EQemit(rename x renaming, e_opt), fun_defs - | EQautomaton(is_weak, s_h_list, se_opt) -> - let build_state_names renaming { s_state = { desc = desc } } = - match desc with - | Estate0pat(n) | Estate1pat(n, _) -> - let m = Zident.fresh (Zident.source n) in - Env.add n m renaming in - let statepat renaming ({ desc = desc } as spat) = - match desc with - | Estate0pat(x) -> { spat with desc = Estate0pat(rename x renaming) } - | Estate1pat(x, x_list) -> - let x = rename x renaming in - let x_list = List.map (fun x -> rename x renaming) x_list in - { spat with desc = Estate1pat(x, x_list) } in - let state_exp venv renaming fun_defs ({ desc = desc } as se) = - match desc with - | Estate0(x) -> { se with desc = Estate0(rename x renaming) }, fun_defs - | Estate1(x, e_list) -> - let e_list, fun_defs = - Zmisc.map_fold (expression venv renaming) fun_defs e_list in - { se with desc = Estate1(rename x renaming, e_list) }, fun_defs in - let escape venv renaming fun_defs - ({ e_cond = scpat; e_block = b_opt; - e_next_state = se; e_env = env } as esc) = - let env, renaming0 = build env in - let venv = remove renaming0 venv in - let renaming = Env.append renaming0 renaming in - let renaming, fun_defs, b_opt = - match b_opt with - | None -> renaming, fun_defs, None - | Some(b) -> - let b, (renaming, fun_defs) = block venv (renaming, fun_defs) b - in renaming, fun_defs, Some(b) in - let scpat, fun_defs = scondpat venv renaming fun_defs scpat in - let se, fun_defs = state_exp venv renaming fun_defs se in - { esc with e_cond = scpat; e_block = b_opt; e_next_state = se; - e_env = env }, - fun_defs in - let body venv renaming fun_defs - ({ s_state = spat; s_body = b; s_trans = esc_list; - s_env = env } as h) = - let env, renaming0 = build env in - let venv = remove renaming0 venv in - let renaming = Env.append renaming0 renaming in - let spat = statepat renaming spat in - let b, (renaming, fun_defs) = block venv (renaming, fun_defs) b in - let esc_list, fun_defs = - Zmisc.map_fold (escape venv renaming) fun_defs esc_list in - { h with s_state = spat; s_body = b; s_trans = esc_list; s_env = env }, - fun_defs in - let renaming = - List.fold_left build_state_names renaming s_h_list in - let s_h_list, fun_defs = - Zmisc.map_fold (body venv renaming) fun_defs s_h_list in - let se_opt, fun_defs = - Zmisc.optional_with_map (state_exp venv renaming) fun_defs se_opt in - EQautomaton(is_weak, s_h_list, se_opt), fun_defs - | EQforall({ for_index = i_list; for_init = init_list; - for_body = b_eq_list; - for_in_env = in_env; for_out_env = out_env } as f_body ) -> - let in_env, renaming0 = build in_env in - let venv = remove renaming0 venv in - let out_env, renaming1 = build out_env in - let venv = remove renaming1 venv in - let renaming = Env.append renaming0 (Env.append renaming1 renaming) in - let index fun_defs ({ desc = desc } as ind) = - let desc, fun_defs = - match desc with - | Einput(x, e) -> - let e, fun_defs = expression venv renaming fun_defs e in - Einput(rename x renaming, e), fun_defs - | Eoutput(x, xout) -> - Eoutput(rename x renaming, rename xout renaming), fun_defs - | Eindex(x, e1, e2) -> - let e1, fun_defs = static venv fun_defs e1 in - let e2, fun_defs = static venv fun_defs e2 in - Eindex(rename x renaming, e1, e2), fun_defs in - { ind with desc = desc }, fun_defs in - let init fun_defs ({ desc = desc } as ini) = - let desc, fun_defs = - match desc with - | Einit_last(x, e) -> - let e, fun_defs = expression venv renaming fun_defs e in - Einit_last(rename x renaming, e), fun_defs in - { ini with desc = desc }, fun_defs in - let i_list, fun_defs = - Zmisc.map_fold index fun_defs i_list in - let init_list, fun_defs = - Zmisc.map_fold init fun_defs init_list in - let b_eq_list, (_, fun_defs) = block venv (renaming, fun_defs) b_eq_list in - EQforall { f_body with - for_index = i_list; - for_init = init_list; - for_body = b_eq_list; - for_in_env = in_env; - for_out_env = out_env }, fun_defs in - { eq with eq_desc = desc; eq_write = Deftypes.empty }, fun_defs - -and scondpat venv renaming fun_defs ({ desc = desc } as scpat) = - match desc with - | Econdand(scpat1, scpat2) -> - let scpat1, fun_defs = scondpat venv renaming fun_defs scpat1 in - let scpat2, fun_defs = scondpat venv renaming fun_defs scpat2 in - { scpat with desc = Econdand(scpat1, scpat2) }, fun_defs - | Econdor(scpat1, scpat2) -> - let scpat1, fun_defs = scondpat venv renaming fun_defs scpat1 in - let scpat2, fun_defs = scondpat venv renaming fun_defs scpat2 in - { scpat with desc = Econdor(scpat1, scpat2) }, fun_defs - | Econdexp(e) -> - let e, fun_defs = expression venv renaming fun_defs e in - { scpat with desc = Econdexp(e) }, fun_defs - | Econdpat(e, p) -> - let e, fun_defs = expression venv renaming fun_defs e in - { scpat with desc = Econdpat(e, pattern venv renaming p) }, fun_defs - | Econdon(scpat, e) -> - let scpat, fun_defs = scondpat venv renaming fun_defs scpat in - let e, fun_defs = expression venv renaming fun_defs e in - { scpat with desc = Econdon(scpat, e) }, fun_defs - -and vardec renaming ({ vardec_name = n } as v) = - { v with vardec_name = rename n renaming } - -and block venv (renaming, fun_defs) - ({ b_vars = n_list; b_locals = l_list; b_body = eq_list; - b_env = n_env } as b) = - let n_env, renaming0 = build n_env in - let venv = remove renaming0 venv in - let renaming = Env.append renaming0 renaming in - let n_list = List.map (vardec renaming) n_list in - let l_list, (renaming, fun_defs) = - Zmisc.map_fold (local venv) (renaming, fun_defs) l_list in - let eq_list, fun_defs = - Zmisc. map_fold (equation venv renaming) fun_defs eq_list in - { b with b_vars = n_list; b_locals = l_list; - b_body = eq_list; b_write = Deftypes.empty; b_env = n_env }, - (renaming, fun_defs) - -(** Convert a value into an expression. *) -(* [exp_of_value fun_defs v = acc', e] where - * - fun_defs is a set of global function declarations; - * - v is a value; - * - e is the corresponding expression for v *) -and exp_of_value fun_defs { value_exp = v; value_name = opt_name } = - let desc, fun_defs = - match v with - | Vconst(i) -> Econst(i), fun_defs - | Vconstr0(qualident) -> - Econstr0(Lident.Modname(qualident)), fun_defs - | Vtuple(v_list) -> - let v_list, fun_defs = - Zmisc.map_fold exp_of_value fun_defs v_list in - Etuple(v_list), fun_defs - | Vconstr1(qualident, v_list) -> - let v_list, fun_defs = - Zmisc.map_fold exp_of_value fun_defs v_list in - Econstr1(Lident.Modname(qualident), v_list), fun_defs - | Vrecord(l_v_list) -> - let l_e_list, fun_defs = - Zmisc.map_fold - (fun fun_defs (qid, v) -> - let v, fun_defs = exp_of_value fun_defs v in - (Lident.Modname(qid), v), fun_defs) - fun_defs l_v_list in - Erecord(l_e_list), fun_defs - | Vperiod { p_phase = p1; p_period = p2 } -> - let p1, fun_defs = - Zmisc.optional_with_map exp_of_value fun_defs p1 in - let p2, fun_defs = exp_of_value fun_defs p2 in - Eperiod { p_phase = p1; p_period = p2 }, fun_defs - | Vabstract(qualident) -> - Zaux.global (Lident.Modname(qualident)), fun_defs - | Vfun(funexp, venv) -> - (* if the function already exist, return its name *) - match opt_name with - | Some(qualident) -> - Zaux.global (Lident.Modname(qualident)), fun_defs - | None -> - let funexp, fun_defs = lambda venv fun_defs funexp in - (* introduce a new function *) - let name = gfresh () in - Zaux.global (Lident.Name(name)), - { fundefs = (name, funexp) :: fun_defs.fundefs } in - Zaux.emake desc Deftypes.no_typ, fun_defs - -(* Reduction under a function body. *) -and lambda venv fun_defs - ({ f_args = p_list; f_body = e; f_env = env } as funexp) = - let env, renaming = build env in - let venv = remove renaming venv in - let p_list = List.map (pattern venv renaming) p_list in - let e, fun_defs = expression venv renaming fun_defs e in - { funexp with f_args = p_list; f_body = e; f_env = env }, fun_defs - -(* The main function. Reduce every definition *) -let implementation_list ff impl_list = - let set_value_code name v = - let ({ info = info } as entry) = - try Modules.find_value (Lident.Name(name)) - with Not_found -> - let qualname = Modules.qualify name in - let info = Global.value_desc false Deftypes.no_typ_scheme qualname in - Modules.add_value name info; { qualid = qualname; info = info } in - Global.set_value_code entry v in - - (* convert a function declaration into an implementation phrase *) - (* add every entry in the global symbol table once it has been typed *) - let make (name, funexp) impl_defs = - set_value_code name (value_code (Vfun(funexp, Env.empty))); - Zaux.make (Efundecl(name, funexp)) :: impl_defs in - - (* [fun_defs] is the list of extra functions that have been introduced *) - let implementation impl_defs impl = - match impl.desc with - | Econstdecl(f, is_static, e) -> - (* is [is_static = true], f is a compile-time constant *) - let e, { fundefs = fun_defs } = - if is_static then - try - let v = Static.expression Env.empty e in - (* add [f \ v] in the global symbol table *) - let v = Global.value_name (Modules.qualify f) v in - set_value_code f v; - exp_of_value empty v - with - Static.Error _ -> expression Env.empty Env.empty empty e - else expression Env.empty Env.empty empty e in - { impl with desc = Econstdecl(f, is_static, e) } :: - List.fold_right make fun_defs impl_defs - | Efundecl(f, funexp) -> - let ({ info = { value_typ = tys } } as entry) = - try Modules.find_value (Lident.Name(f)) - with Not_found -> assert false in - let no_parameter = Ztypes.noparameters tys in - (* strong reduction (under the lambda) when [no_parameter] *) - if !Zmisc.no_reduce then - (* no reduction is done; use it carefully as the compilation steps *) - (* done after like static scheduling may fail. *) - (* This flag is very temporary *) - let v = Global.value_code (Global.Vfun(funexp, Env.empty)) in - let v = Global.value_name (Modules.qualify f) v in - set_value_code f v; - impl :: impl_defs - else - let funexp, impl_defs = - if no_parameter then - let funexp, { fundefs = fun_defs } = lambda Env.empty empty funexp in - funexp, { impl with desc = Efundecl(f, funexp) } :: - List.fold_right make fun_defs impl_defs - else - (* funexp is removed from the list of defs. to be compiled *) - funexp, impl_defs in - let v = Global.value_code (Global.Vfun(funexp, Env.empty)) in - let v = Global.value_name (Modules.qualify f) v in - set_value_code f v; - impl_defs - | _ -> impl :: impl_defs in - try - let impl_list = List.fold_left implementation [] impl_list in - List.rev impl_list - with - | Static.Error(error) -> - match error with - | TypeError -> - Format.eprintf - "@[Internal error (static reduction):@,\ - the expression to be reduced is not static.@.@]"; - raise Zmisc.Error - | NotStaticExp(e) -> - Format.eprintf - "@[%aInternal error (static reduction):@,\ - static evaluation failed because the expression is not static.@.@]" - Printer.expression e; - raise Zmisc.Error - | NotStaticEq(eq) -> - Format.eprintf - "@[%aInternal error (static reduction):@,\ - static evaluation failed because the equation is not static.@.@]" - Printer.equation eq; - raise Zmisc.Error diff --git a/compiler/rewrite/remove_last_in_patterns.ml b/compiler/rewrite/remove_last_in_patterns.ml deleted file mode 100644 index edc784f20..000000000 --- a/compiler/rewrite/remove_last_in_patterns.ml +++ /dev/null @@ -1,290 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* All variables in patterns must be values only *) -(* e.g., function parameters, patterns in pattern matching handlers, etc. *) -(* Any expression [last x] where [x] is expected to be a value *) -(* is rewritten [lx] and equations [lx = last m and m = x] are introduced *) - -(* Example: - *- [let node f(x) = ... last x...] is rewritten - *- [let node f(x) = let m = x and lx = last m in ... lx ...] - *- [match e with P(...x...) -> - let d1 in ... last x ... let dn in do ... last x ... done] - *- [match e with P(...x...) -> - let lx = last m and m = x in - let d1 in ... lx ... let dn in do ... lx ... done] - *- [present - e(...x...) -> - let d1 in ... last x ... let dn in do ... last x ... done] - *- [present - e(...x...) -> - let lx = last m and m = x in - ... lx ... let dn in do ... lx ... done] - *) - -open Zmisc -open Zlocation -open Deftypes -open Zelus -open Zident -open Zaux - -(* Make equations [lx = last m and m = x] *) -let eq_lx_last_m_m_x lx m x ty eq_list = - (eqmake (EQeq(pmake (Evarpat(lx)) ty, emake (Elast(m)) ty))) :: - (eqmake (EQeq(pmake (Evarpat(m)) ty, emake (Elocal(x)) ty))) :: - eq_list - -let add x ty sort (env, new_env, subst, eq_list) = - let lx = Zident.fresh "l" in - let m = Zident.fresh "m" in - Env.add x { t_typ = ty; t_sort = Deftypes.value } env, - Env.add lx { t_typ = ty; t_sort = Deftypes.value } - (Env.add m { t_typ = ty; t_sort = sort } new_env), - Env.add x lx subst, - eq_lx_last_m_m_x lx m x ty eq_list - -(* Computes the set of variables [last x] from [b_env] *) -(* turns all values in [b_env] to values *) -let valenv subst b_env = - let last x ({ t_typ = ty; t_sort = sort } as entry) - (env, new_env, subst, eq_list) = - match sort with - | Smem { m_previous = true } -> - add x ty sort (env, new_env, subst, eq_list) - | Smem { m_previous = false } -> - Env.add x { entry with t_sort = Sval } env, new_env, subst, eq_list - | Sstatic | Sval | Svar _ -> - Env.add x entry env, new_env, subst, eq_list in - Env.fold last b_env (Env.empty, Env.empty, subst, []) - -(* [extend_block b env eq_list] returns a block *) -(* with an extra set of local declarations [eq_list] in front of it *) -let extend_block ({ b_locals = l_list } as b) env eq_list = - { b with b_locals = (Zaux.make_local env eq_list) :: l_list } - -(* translating a present statement *) -let present_handlers subst scondpat body p_h_list = - List.map - (fun ({ p_cond = scpat; p_body = b; p_env = p_env } as handler) -> - let p_env, new_env, subst, eq_list = valenv subst p_env in - let b = body subst b new_env eq_list in - { handler with p_cond = scondpat subst scpat; p_env = p_env; p_body = b}) - p_h_list - -(* replace some occurrences of [last x] by [lx]. [subst(x) = lx] *) -let rec exp subst ({ e_desc } as e) = - let e_desc = match e_desc with - | Elast(x) -> - begin try Elocal(Env.find x subst) with Not_found -> e_desc end - | Elocal _ | Econst _ | Econstr0 _ | Eglobal _ -> e_desc - | Etuple(e_list) -> - Etuple (List.map (exp subst) e_list) - | Econstr1(c, e_list) -> Econstr1(c, List.map (exp subst) e_list) - | Eop(op, e_list) -> Eop(op, List.map (exp subst) e_list) - | Eapp(app, e_op, e_list) -> - let e_list = List.map (exp subst) e_list in - Eapp(app, exp subst e_op, e_list) - | Erecord(label_e_list) -> - let label_e_list = - List.map (fun (l, e) -> (l, exp subst e)) label_e_list in - Erecord(label_e_list) - | Erecord_access(e_record, longname) -> - Erecord_access(exp subst e_record, longname) - | Erecord_with(e_record, label_e_list) -> - let label_e_list = - List.map (fun (l, e) -> (l, exp subst e)) label_e_list in - Erecord_with(exp subst e_record, label_e_list) - | Etypeconstraint(e1, ty) -> - Etypeconstraint(exp subst e1, ty) - | Elet(l, e) -> - let l = local subst l in Elet(l, exp subst e) - | Eseq(e1, e2) -> - Eseq(exp subst e1, exp subst e2) - | Epresent(p_h_list, e_opt) -> - let e_opt = Zmisc.optional_map (exp subst) e_opt in - let p_h_list = present_handler_exp_list subst p_h_list in - Epresent(p_h_list, e_opt) - | Ematch(total, e, m_h_list) -> - let e = exp subst e in - let m_h_list = match_handler_exp_list subst m_h_list in - Ematch(total, e, m_h_list) - | Eblock(b_eq_list, e) -> - Eblock(block_eq_list subst b_eq_list, exp subst e) - | Eperiod { p_phase = p1; p_period = p2 } -> - Eperiod { p_phase = Zmisc.optional_map (exp subst) p1; - p_period = exp subst p2 } in - { e with e_desc = e_desc } - -(** Translation of equations. *) -and equation subst ({ eq_desc } as eq) = - match eq_desc with - | EQeq(p, e) -> - { eq with eq_desc = EQeq(p, exp subst e) } - | EQpluseq(x, e) -> - { eq with eq_desc = EQpluseq(x, exp subst e) } - | EQinit(x, e0) -> - { eq with eq_desc = EQinit(x, exp subst e0) } - | EQnext(n, e, e0_opt) -> - { eq with eq_desc = EQnext(n, exp subst e, - optional_map (exp subst) e0_opt) } - | EQder(x, e, e0_opt, p_h_e_list) -> - { eq with eq_desc = EQder(x, exp subst e, optional_map (exp subst) e0_opt, - present_handler_exp_list subst p_h_e_list) } - | EQmatch(total, e, p_h_list) -> - let p_h_list = match_handler_block_eq_list subst p_h_list in - { eq with eq_desc = EQmatch(total, exp subst e, p_h_list) } - | EQreset(res_eq_list, e) -> - let res_eq_list = equation_list subst res_eq_list in - { eq with eq_desc = EQreset(res_eq_list, exp subst e) } - | EQand(and_eq_list) -> - { eq with eq_desc = EQand(equation_list subst and_eq_list) } - | EQbefore(before_eq_list) -> - { eq with eq_desc = - EQbefore(equation_list subst before_eq_list) } - | EQblock(b) -> { eq with eq_desc = EQblock(block_eq_list subst b) } - | EQforall ({ for_index = i_list; for_init = init_list; - for_body = b_eq_list; for_in_env = for_in_env; - for_out_env = for_out_env } as body) -> - let for_in_env, new_in_env, subst, eq_in_list = valenv subst for_in_env in - let for_out_env, new_out_env, subst, eq_out_list = valenv subst for_in_env in - let index ({ desc = desc } as ind) = - let desc = match desc with - | Einput(x, e) -> Einput(x, exp subst e) - | Eoutput _ -> desc - | Eindex(x, e1, e2) -> - Eindex(x, exp subst e1, exp subst e2) in - { ind with desc = desc } in - (* any use of [last x] where [x] is an accumulated value is renammed *) - (* in [lx] with [lx] a local variable and [lx = last x] added *) - let init ({ desc = desc } as ini) = - let desc = match desc with - | Einit_last(x, e) -> Einit_last(x, exp subst e) in - { ini with desc = desc } in - let i_list = List.map index i_list in - let init_list = List.map init init_list in - let b_eq_list = block_eq_list subst b_eq_list in - let b_eq_list = extend_block b_eq_list new_in_env eq_in_list in - let b_eq_list = extend_block b_eq_list new_out_env eq_out_list in - { eq with eq_desc = - EQforall { body with for_index = i_list; - for_init = init_list; - for_body = b_eq_list } } - | EQpresent(p_h_b_eq_list, b_opt) -> - let p_h_b_eq_list = present_handler_block_eq_list subst p_h_b_eq_list in - let b_opt = - match b_opt with - | None -> None | Some(b) -> Some(block_eq_list subst b) in - { eq with eq_desc = EQpresent(p_h_b_eq_list, b_opt) } - | EQautomaton(is_weak, state_handler_list, se_opt) -> - (* translating a state *) - let state subst ({ desc = desc; loc = loc } as se) = - match desc with - | Estate0 _ -> se - | Estate1(n, e_list) -> - { se with desc = Estate1(n, List.map (exp subst) e_list) } in - let escape subst - ({ e_cond = scpat; e_block = b_opt; - e_next_state = se; e_env = e_env } as esc) = - let e_env, new_env, subst, eq_list = valenv subst e_env in - let scpat = scondpat subst scpat in - let b_opt = - match b_opt with - | None -> if Env.is_empty new_env then None - else Some (Zaux.make_block new_env eq_list) - | Some(b_eq_list) -> - let b_eq_list = block_eq_list subst b_eq_list in - let b_eq_list = extend_block b_eq_list new_env eq_list in - Some(b_eq_list) in - let se = state subst se in - { esc with e_cond = scpat; e_block = b_opt; e_next_state = se; - e_env = e_env } in - let handler subst ({ s_body = b; s_trans = trans; s_env = s_env } as h) = - let s_env, new_env, subst, eq_list = valenv subst s_env in - let b = block_eq_list subst b in - let b = extend_block b new_env eq_list in - { h with s_body = b; - s_trans = List.map (escape subst) trans } in - { eq with eq_desc = - EQautomaton(is_weak, - List.map (handler subst) state_handler_list, - Zmisc.optional_map (state subst) se_opt) } - | EQemit(name, e_opt) -> - { eq with eq_desc = EQemit(name, optional_map (exp subst) e_opt) } - - -and equation_list subst eq_list = List.map (equation subst) eq_list - -(* Translate a generic block *) -and block_eq_list subst ({ b_locals = l_list; b_body = eq_list } as b) = - let l_list = locals subst l_list in - (* translate the body. *) - let eq_list = equation_list subst eq_list in - { b with b_locals = l_list; b_body = eq_list } - -and present_handler_exp_list subst p_h_e_list = - let exp subst e new_env eq_list = - let e = exp subst e in - Zaux.make_let new_env eq_list e in - present_handlers subst scondpat exp p_h_e_list - -and present_handler_block_eq_list subst p_h_b_eq_list = - let block_eq_list subst b new_env eq_list = - let b = block_eq_list subst b in - extend_block b new_env eq_list in - present_handlers subst scondpat block_eq_list p_h_b_eq_list - -and match_handler_exp_list subst m_h_list = - List.map (fun ({ m_body = e; m_env = m_env } as handler) -> - let m_env, new_env, subst, eq_list = valenv subst m_env in - let e = exp subst e in - let e = Zaux.make_let new_env eq_list e in - { handler with m_body = e; m_env = m_env }) m_h_list - -and match_handler_block_eq_list subst m_h_list = - List.map (fun ({ m_body = b; m_env = m_env } as handler) -> - let m_env, new_env, subst, eq_list = valenv subst m_env in - let b = block_eq_list subst b in - let b = extend_block b new_env eq_list in - { handler with m_body = b; m_env = m_env }) m_h_list - -and local subst ({ l_eq = l_eq_list } as l) = - let l_eq_list = equation_list subst l_eq_list in - { l with l_eq = l_eq_list } - -and locals subst l_list = List.map (local subst) l_list - -and scondpat subst ({ desc = desc } as scpat) = - let desc = match desc with - | Econdand(scpat1, scpat2) -> - Econdand(scondpat subst scpat1, scondpat subst scpat2) - | Econdor(scpat1, scpat2) -> - Econdor(scondpat subst scpat1, scondpat subst scpat2) - | Econdexp(e) -> Econdexp(exp subst e) - | Econdpat(e, p) -> Econdpat(exp subst e, p) - | Econdon(scpat, e) -> Econdon(scondpat subst scpat, exp subst e) in - { scpat with desc = desc } - -let implementation impl = - match impl.desc with - | Eopen _ | Etypedecl _ | Econstdecl _ - | Efundecl(_, { f_kind = S | A }) -> impl - | Efundecl(n, ({ f_body = e; f_env = f_env } as body)) -> - let f_env, new_env, subst, eq_list = valenv Env.empty f_env in - let e = exp subst e in - let e = Zaux.make_let new_env eq_list e in - { impl with desc = Efundecl(n, { body with f_env = f_env; f_body = e }) } - -let implementation_list impl_list = Zmisc.iter implementation impl_list diff --git a/compiler/rewrite/reset.ml b/compiler/rewrite/reset.ml deleted file mode 100644 index ad3c24eb8..000000000 --- a/compiler/rewrite/reset.ml +++ /dev/null @@ -1,137 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* Applied to normalized expressions and equations *) -(* compiling the initialization [->], [initial clock] and [init x = ...] *) -(* Introduce an initialization bit [init i = true and i = false] *) -(* per control block when the block contains [init x = e] and *) -(* [e] is not static *) - -open Zmisc -open Zlocation -open Deftypes -open Zelus -open Zaux -open Zident - -(** Static expressions *) -let rec static { e_desc = desc } = - match desc with - | Econst _ | Econstr0 _ -> true - | Etuple(e_list) -> List.for_all static e_list - | Erecord(qual_e_list) -> List.for_all (fun (_, e) -> static e) qual_e_list - | Erecord_access(e, _) -> static e - | _ -> false - -let intro = function None -> Zident.fresh "i" | Some(i) -> i - -(* Surround an equation by a reset *) -let reset i_opt eq = - let equation i = - { eq with eq_desc = EQreset([eq], last i Initial.typ_bool) } in - let i = intro i_opt in - equation i, Some(i) - -(* Build a boolean condition from the initialization bit. *) -let condition i_opt = let i = intro i_opt in last i Initial.typ_bool, Some(i) - -(* Introduce an equation [init i = true and i = false] *) -let intro_equation (i_names, i_opt) eq_list = - match i_opt with - | None -> eq_list, i_names - | Some(i) -> Zaux.init i eq_list, i :: i_names - -(* Introduce the declaration for every name in [i_names] *) -let intro (i_names, i_opt) n_list env eq_list = - let add (acc_n_list, acc_env_list) i = - (Zaux.vardec i) :: acc_n_list, - Env.add i (Deftypes.entry Deftypes.memory Initial.typ_bool) acc_env_list in - let eq_list, i_names = intro_equation (i_names, i_opt) eq_list in - let n_list, env = List.fold_left add (n_list, env) i_names in - n_list, env, eq_list - -(** Translation of equations. *) -(* If the equation contains an initialization with an non static *) -(* value, introduce a fresh initialization variable [i] *) -let rec equation (i_names, i_opt) ({ eq_desc = desc } as eq) = - match desc with - | EQeq(p, ({ e_desc = Eop(Eminusgreater, [e1; e2]) } as e)) -> - (* [e1 -> e2 = if last i then e1 else e2] *) - let cond, i_opt = condition i_opt in - { eq with eq_desc = - EQeq(p, - { e with e_desc = Eop(Eifthenelse, [cond; e1; e2]) }) }, - (i_names, i_opt) - | EQeq({ p_desc = Evarpat(x) } as p, { e_desc = Eop(Einitial, []) }) - -> (* [initial = true fby false] *) - let cond, i_opt = condition i_opt in - { eq with eq_desc = EQeq(p, cond) }, (i_names, i_opt) - | EQeq _ | EQpluseq _ | EQder _ -> eq, (i_names, i_opt) - | EQinit(x, e) -> - if static e then eq, (i_names, i_opt) - else let eq, i_opt = reset i_opt eq in eq, (i_names, i_opt) - | EQmatch(total, e, m_h_list) -> - let m_h_list = - List.map (fun ({ m_body = b } as m_h) -> { m_h with m_body = block b }) - m_h_list in - { eq with eq_desc = EQmatch(total, e, m_h_list) }, (i_names, i_opt) - | EQreset(res_eq_list, e) -> - let res_eq_list, i_names_i_opt = - equation_list (i_names, None) res_eq_list in - let res_eq_list, i_names = intro_equation i_names_i_opt res_eq_list in - { eq with eq_desc = EQreset(res_eq_list, e) }, (i_names, i_opt) - | EQand(and_eq_list) -> - let and_eq_list, i_names_i_opt = - equation_list (i_names, i_opt) and_eq_list in - { eq with eq_desc = EQand(and_eq_list) }, i_names_i_opt - | EQbefore(before_eq_list) -> - let before_eq_list, i_names_i_opt = - equation_list (i_names, i_opt) before_eq_list in - { eq with eq_desc = EQbefore(before_eq_list) }, i_names_i_opt - | EQforall ({ for_body = b_eq_list } as body) -> - let b_eq_list = block b_eq_list in - { eq with eq_desc = EQforall { body with for_body = b_eq_list } }, - (i_names, i_opt) - | EQblock _ | EQemit _ | EQnext _ | EQautomaton _ | EQpresent _ -> - assert false - -and equation_list i_names_i_opt eq_list = - Zmisc.map_fold equation i_names_i_opt eq_list - -and local ({ l_eq = eq_list; l_env = l_env } as l) = - let eq_list, i_names_i_opt = equation_list ([], None) eq_list in - let _, l_env, eq_list = intro i_names_i_opt [] l_env eq_list in - { l with l_eq = eq_list; l_env = l_env } - -(** Translation of blocks *) -and block ({ b_vars = n_list; b_body = eq_list; b_env = n_env } as b) = - let eq_list, i_names_i_opt = equation_list ([], None) eq_list in - let n_list, n_env, eq_list = intro i_names_i_opt n_list n_env eq_list in - { b with b_vars = n_list; b_body = eq_list; b_env = n_env } - -(** Expressions. *) -let exp ({ e_desc = desc } as e) = - let desc = - match desc with - | Elet(l, e) -> Elet(local l, e) - | _ -> desc in - { e with e_desc = desc } - -let implementation impl = - match impl.desc with - | Efundecl(n, ({ f_kind = D | C; f_body = e } as body)) -> - { impl with desc = Efundecl(n, { body with f_body = exp e }) } - | Eopen _ | Etypedecl _ | Econstdecl _ | Efundecl _ -> impl - -let implementation_list impl_list = Zmisc.iter implementation impl_list diff --git a/compiler/rewrite/schedule.ml b/compiler/rewrite/schedule.ml deleted file mode 100644 index 0546be35d..000000000 --- a/compiler/rewrite/schedule.ml +++ /dev/null @@ -1,140 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* static scheduling. Applied to normalized expressions and equations *) - -open Zelus -open Graph -open Dependences - -(* builds a collection from an equation *) -let collection eq_list = - let rec collection ({ eq_desc } as eq) = - match eq_desc with - | EQand(and_eq_list) -> And(List.map collection and_eq_list) - | EQbefore(before_eq_list) -> Before(List.map collection before_eq_list) - | _ -> Leaf(eq) in - And(List.map collection eq_list) - -(* scheduling *) -let schedule eq_list = - let fusion g eq_list = - (* possible overlapping between conditions *) - let join eq1 eq2 = - match eq1.eq_desc, eq2.eq_desc with - | EQmatch(_, e1, m_h_list1), EQmatch(_, e2, m_h_list2) - when Control.candidate (e1, m_h_list1) (e2, m_h_list2) -> true - | _ -> false in - - (* precedence relation *) - let relation { eq_index = n1} { eq_index = n2 } = - (Graph.is_before g n1 n2) || (Graph.is_before g n2 n1) in - - let rec recook = function - | [] -> [] - | eq :: eq_list -> eq >> (recook eq_list) - - and (>>) eq eq_list = - try - insert eq eq_list - with - | Not_found -> eq :: eq_list - - and insert eq = function - | [] -> raise Not_found - | eq1 :: eq_list -> - if relation eq eq1 then raise Not_found - else - try - eq1 :: (insert eq eq_list) - with - | Not_found -> - if join eq eq1 then eq :: eq1 :: eq_list - else raise Not_found in - recook eq_list in - - (* build the dependence graph *) - let g = Dependences.make (collection eq_list) in - try - (* check that there is no cycle. This situation should not arrive *) - Graph.acyclic g; - (* schedule it *) - let eq_list = Graph.topological g in - let eq_list = List.rev (fusion g (List.rev (fusion g eq_list))) in - Control.joinlist eq_list - with - Graph.Error(Cycle(n_list)) -> - Zmisc.internal_error - "Unexpected cycle: equations cannot be scheduled" - (Printer.equation_list "" "") eq_list - - -let rec equation ({ eq_desc } as eq) = - match eq_desc with - | EQeq _ | EQpluseq _ | EQinit _ | EQnext _ | EQder _ -> eq - | EQmatch(total, e, p_h_list) -> - { eq with eq_desc = match_eq total e p_h_list } - | EQreset(res_eq_list, e) -> - { eq with eq_desc = reset_eq res_eq_list e } - | EQand(and_eq_list) -> - { eq with eq_desc = EQand(List.map equation and_eq_list) } - | EQbefore(before_eq_list) -> - { eq with eq_desc = EQbefore(List.map equation before_eq_list) } - | EQforall(body) -> - { eq with eq_desc = forall_eq body } - | EQemit _ | EQautomaton _ | EQpresent _ | EQblock _ -> assert false - -and match_eq total e p_h_list = - EQmatch(total, e, - List.map (fun ({ m_body = b } as m_h) -> - { m_h with m_body = block b }) p_h_list) - -and reset_eq res_eq_list e = - let res_eq_list = List.map equation res_eq_list in - EQreset(schedule res_eq_list, e) - -and forall_eq ({ for_body = b_eq_list } as body) = - let b_eq_list = block b_eq_list in - EQforall { body with for_body = b_eq_list } - -and block ({ b_body = eq_list } as b) = - (* schedule every nested equation *) - let eq_list = List.map equation eq_list in - (* schedule the set of equations *) - let eq_list = schedule eq_list in - { b with b_body = eq_list } - -and local ({ l_eq = eq_list } as l) = - (* translate and schedule the set of equations *) - let eq_list = List.map equation eq_list in - let eq_list = schedule eq_list in - { l with l_eq = eq_list } - -(** Top level expressions *) -let exp ({ e_desc = desc } as e) = - let desc = - match desc with - | Elet(l, e) -> Elet(local l, e) - | _ -> desc in - { e with e_desc = desc } - -let implementation impl = - match impl.desc with - | Eopen _ | Etypedecl _ | Econstdecl _ -> impl - | Efundecl(n, ({ f_body = e } as body)) -> - { impl with desc = Efundecl(n, { body with f_body = exp e }) } - -let implementation_list impl_list = Zmisc.iter implementation impl_list - - diff --git a/compiler/rewrite/shared.ml b/compiler/rewrite/shared.ml deleted file mode 100644 index 61926cad7..000000000 --- a/compiler/rewrite/shared.ml +++ /dev/null @@ -1,171 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* Identify assignments to shared variables and memories. *) -(* Applied on normalized expressions and equations *) - -(* After this transformation, equations on structured patterns *) -(* like [pat = e] are such that no variable in [pat] *) -(* is shared nor a memory. All equations on those variables *) -(* are then of the form [x = e] *) - -open Zlocation -open Zident -open Zelus -open Deftypes -open Zaux - -(* Computes the set of shared memories and state variables. *) -(* add them to [dv] *) -let shared dv l_env = - let add x sort acc = - match sort with | Sstatic | Sval -> acc | Svar _ | Smem _ -> S.add x acc in - Env.fold (fun x { t_sort = sort } acc -> add x sort acc) l_env dv - -(* Remove the flag [is_copy] from a environment of copies *) -let remove_is_copy copies = - Env.map (fun (x_copy, _, ty) -> (x_copy, false, ty)) copies - -(* Makes a list of copy equations [x = x_copy] for every entry in [env] *) -(* when the [is_copy] flag is true *) -let add_equations_for_copies eq_list copies = - (* makes a value for [x_copy] *) - Env.fold - (fun x (x_copy, is_copy, ty) acc -> - if is_copy then - (eqmake (EQeq(varpat x ty, var x_copy ty))) :: acc - else acc) copies eq_list - -(* Extends the local environment with definitions for the [x_copy] *) -let add_locals_for_copies n_list n_env copies = - let value ty = { t_sort = Deftypes.value; t_typ = ty } in - let n_env = - Env.fold - (fun x (x_copy, _, ty) acc -> - Env.add x_copy (value ty) acc) copies n_env in - let n_copy_list = - Env.fold - (fun _ (x_copy, _, ty) acc -> - (Zaux.vardec_from_entry x_copy { t_sort = Sval; t_typ = ty }) :: acc) - copies n_list in - n_copy_list, n_env - -(* Makes a copy of a pattern if it contains a shared variable [x] *) -(* introduce auxilary equations [x = x_copy] in [copies] for every name *) -(* in [dv] *) -let rec pattern dv copies pat = - match pat.p_desc with - | Ewildpat | Econstpat _ | Econstr0pat _ -> pat, copies - | Etuplepat(p_list) -> - let p_list, copies = Zmisc.map_fold (pattern dv) copies p_list in - { pat with p_desc = Etuplepat(p_list) }, copies - | Econstr1pat(c, p_list) -> - let p_list, copies = Zmisc.map_fold (pattern dv) copies p_list in - { pat with p_desc = Econstr1pat(c, p_list) }, copies - | Evarpat(n) -> - if S.mem n dv then - let ncopy = Zident.fresh "copy" in - { pat with p_desc = Evarpat(ncopy) }, - Env.add n (ncopy, true, pat.p_typ) copies - else pat, copies - | Erecordpat(label_pat_list) -> - let label_pat_list, copies = - Zmisc.map_fold - (fun copies (label, p) -> - let p, copies = pattern dv copies p in - (label, p), copies) copies label_pat_list in - { pat with p_desc = Erecordpat(label_pat_list) }, copies - | Etypeconstraintpat(p, ty) -> - let p, copies = pattern dv copies p in - { pat with p_desc = Etypeconstraintpat(p, ty) }, copies - | Ealiaspat(p, n) -> - let p, copies = pattern dv copies p in - let n, copies = - if S.mem n dv then - let ncopy = Zident.fresh "copy" in - ncopy, Env.add n (ncopy, true, p.p_typ) copies - else n, copies in - { pat with p_desc = Ealiaspat(p, n) }, copies - | Eorpat _ -> assert false - -(* [dv] is the set of names possibly written in [eq] which are visible *) -(* outside of the block or are memories *) -let rec equation dv copies ({ eq_desc = desc } as eq) = - match desc with - | EQeq({ p_desc = Evarpat(n) }, _) -> eq, copies - | EQeq(pat, e) -> - (* if some variable from [pat] are shared, [pat] is renamed into [pat'] *) - (* and auxiliary equations [x1 = x_copy1 and ... and xn = x_copyn] *) - (* are added *) - let pat, copies = pattern dv copies pat in - { eq with eq_desc = EQeq(pat, e) }, copies - | EQpluseq _ | EQder _ | EQinit _ -> eq, copies - | EQmatch(total, e, m_h_list) -> - let m_h_list = - List.map - (fun ({ m_body = b } as h) -> { h with m_body = block dv b } ) - m_h_list in - { eq with eq_desc = EQmatch(total, e, m_h_list) }, copies - | EQreset(res_eq_list, e) -> - let res_eq_list, copies = equation_list dv copies res_eq_list in - { eq with eq_desc = EQreset(res_eq_list, e) }, copies - | EQand(and_eq_list) -> - let and_eq_list, copies = equation_list dv copies and_eq_list in - { eq with eq_desc = EQand(and_eq_list) }, copies - | EQbefore(before_eq_list) -> - let before_eq_list, copies = equation_list dv copies before_eq_list in - { eq with eq_desc = EQbefore(before_eq_list) }, copies - | EQforall _ -> eq, copies - | EQemit _ | EQautomaton _ | EQpresent _ - | EQnext _ | EQblock _ -> assert false - -(* [dv] defines names modified by [eq_list] but visible outside of the block *) -and equation_list dv copies eq_list = - let eq_list, copies_eq_list = Zmisc.map_fold (equation dv) Env.empty eq_list in - let eq_list = add_equations_for_copies eq_list copies_eq_list in - eq_list, Env.append (remove_is_copy copies_eq_list) copies - -and local ({ l_eq = eq_list; l_env = l_env } as l) = - let dv = shared S.empty l_env in - let eq_list, copies = equation_list dv Env.empty eq_list in - let _, l_env = add_locals_for_copies [] l_env copies in - { l with l_eq = eq_list; l_env = l_env } - -(* A variable [x] written by a block [b] is considered to be shared *) -(* when it is visible outside of the block, i.e., [x in dv_b] *) -(* Those variables and memories must be modified with equations of the *) -(* form [x = e] only. *) -and block dv ({ b_vars = n_list; b_body = eq_list; b_env = n_env; - b_write = { dv = dv_b } } as b) = - (* written variables [dv] are considered to be shared *) - let dv = shared (S.union dv dv_b) n_env in - let eq_list, copies = equation_list dv Env.empty eq_list in - let n_list, n_env = add_locals_for_copies n_list n_env copies in - { b with b_vars = n_list; b_body = eq_list; b_env = n_env } - -(* Expressions. *) -let exp ({ e_desc = desc } as e) = - let desc = - match desc with - | Elet(l, e_let) -> Elet(local l, e_let) - | _ -> desc in - { e with e_desc = desc } - -let implementation impl = - match impl.desc with - | Eopen _ | Etypedecl _ | Econstdecl _ -> impl - | Efundecl(n, ({ f_body = e } as body)) -> - { impl with desc = Efundecl(n, { body with f_body = exp e }) } - -let implementation_list impl_list = Zmisc.iter implementation impl_list diff --git a/compiler/rewrite/static.ml b/compiler/rewrite/static.ml deleted file mode 100644 index 359d3cb9d..000000000 --- a/compiler/rewrite/static.ml +++ /dev/null @@ -1,215 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(** static evaluation of expressions *) - -open Zident -open Deftypes -open Global -open Zelus -open Zaux - -type error = - | NotStaticEq of eq - | NotStaticExp of exp - | TypeError - -exception Error of error - -(** Remove entries in the type environment of a block *) -(* for names that appear in the evaluation environment *) -let remove tenv env_closure = - Env.filter (fun n _ -> not (Env.mem n env_closure)) tenv - -(** Pattern matching *) -let record_access { value_exp = value_exp } ln = - try - match value_exp with - | Vrecord(l_v_list) -> List.assoc (Modules.qualident ln) l_v_list - | _ -> raise (Error(TypeError)) - with - | _ -> raise (Error(TypeError)) - -(** Pattern matching. [matches env p v = env'] returns an extended *) -(* environment [env'] such that [env'(p) = v] *) -let rec matches env { p_desc = desc } ({ value_exp = v_exp } as v) = - (* find the value associated to a label *) - let rec find qid = function - | [] -> raise (Error(TypeError)) - | (qid_v, v) :: p_v_list -> - if qid = qid_v then v else find qid p_v_list in - match desc, v_exp with - | Ewildpat, _ -> env - | Econstpat(i), Vconst(j) when i = j -> env - | Econstr0pat(c1), Vconstr0(qid) when (Modules.qualident c1) = qid -> env - | Etuplepat(p_list), Vtuple(v_list) -> - begin try List.fold_left2 matches env p_list v_list - with _ -> raise (Error(TypeError)) - end - | Econstr1pat(c1, p_list), Vconstr1(qid, v_list) - when (Modules.qualident c1) = qid -> - begin try List.fold_left2 matches env p_list v_list - with _ -> raise (Error(TypeError)) - end - | Evarpat(n), _ -> Env.add n v env - | Ealiaspat(p, n), _ -> matches (Env.add n v env) p v - | Eorpat(p1, p2), _ -> - begin try matches env p1 v with Error(TypeError) -> matches env p2 v end - | Erecordpat(l_p_list), Vrecord(p_v_list) -> - begin try - List.fold_left - (fun env (ln, p) -> - matches env p (find (Modules.qualident ln) p_v_list)) env l_p_list - with _ -> raise (Error(TypeError)) - end - | Etypeconstraintpat(p, _), _ -> matches env p v - | _ -> raise (Error(TypeError)) - -(** [select env v m_b_list = b] where - * - env is a environment; - * - v a value; - * - m_b_list a list of pattern * block; - * - b a block whose pattern matches v and is the first in the list *) -let select env v m_b_list = - let rec loop = function - | [] -> raise (Error(TypeError)) - | { m_pat = p; m_body = b } :: m_b_list -> - try - let env = matches env p v in env, b - with - | Error(TypeError) -> loop m_b_list in - loop m_b_list - -(** Evaluate an expression. [expression env e = v] *) -(* - e is a static expression; - * - env an environment; - * - v a value *) -let rec expression env ({ e_desc = desc; e_loc = loc } as e) = - match desc with - | Econst(i) -> Global.value_code (Vconst(i)) - | Econstr0(c) -> Global.value_code (Vconstr0(Modules.qualident c)) - | Eglobal { lname = lname } -> - let { info = { value_code = v } } = - try Modules.find_value lname - with Not_found -> raise (Error (NotStaticExp e)) in - v - | Elocal(n) -> - let v = - try Env.find n env with Not_found -> raise (Error(NotStaticExp e)) in v - | Etuple(e_list) -> - Global.value_code (Vtuple(List.map (expression env) e_list)) - | Econstr1(c, e_list) -> - Global.value_code (Vconstr1(Modules.qualident c, - List.map (expression env) e_list)) - | Erecord(n_e_list) -> - let v_exp = - Vrecord(List.map - (fun (ln, e) -> (Modules.qualident ln, expression env e)) - n_e_list) in - Global.value_code v_exp - | Erecord_with(e_record, n_e_list) -> - let { value_exp = v_exp } = expression env e_record in - let n_v_list = - List.map - (fun (ln, e) -> (Modules.qualident ln, expression env e)) n_e_list in - let v_exp = - match v_exp with - | Vrecord(l_v_list) -> - Vrecord(List.map - (fun (ln, v) -> - (ln, - try - List.assoc ln n_v_list - with - | Not_found -> v)) - l_v_list) - | _ -> raise (Error(TypeError)) in - Global.value_code v_exp - | Erecord_access(e_record, ln) -> - record_access (expression env e_record) ln - | Eop _ | Elast _ -> raise (Error (NotStaticExp e)) - | Eapp(_, e, e_list) -> - let v = expression env e in - let v_list = List.map (expression env) e_list in - app v v_list - | Etypeconstraint(e, _) -> expression env e - | Eseq(e1, e2) -> - ignore (expression env e1); expression env e2 - | Eperiod { p_phase = p1; p_period = p2 } -> - Global.value_code - (Vperiod { p_phase = Zmisc.optional_map (expression env) p1; - p_period = expression env p2 }) - | Elet(l, e_let) -> - let env = local env l in - expression env e_let - | Eblock _ -> raise (Error (NotStaticExp e)) - | Epresent _ | Ematch _ -> assert false - -(** Evaluate an application *) -and app ({ value_exp = value_exp } as v) v_list = - (* [arguments env_closure p_list v_list = p_list', env'] *) - (* returns the environment for evaluating the body *) - (* and the list of patterns that have not been consummed *) - let rec arguments env_closure p_list v_list = - match p_list, v_list with - | [], [] -> [], env_closure - | p :: p_list, v :: v_list -> - arguments (matches env_closure p v) p_list v_list - | [], _ -> raise (Error(TypeError)) - | p_list, [] -> p_list, env_closure in - match value_exp, v_list with - | _, [] -> - (* if [v_list = []], the result is [v] *) - v - | Vfun({ f_args = p_list; f_body = e; f_env = fenv } as funexp, env_closure), - _ -> - let p_list, env_closure = arguments env_closure p_list v_list in - if p_list = [] then expression env_closure e - else - (* remove entries from [fenv] that are in the environment of values *) - let fenv = remove fenv env_closure in - Global.value_code - (Vfun({ funexp with f_args = p_list; f_env = fenv }, env_closure)) - | (* two integer arithmetic operations are implemented: *) - (* addition and subtraction are used in array size expressions *) - Vabstract(op), - [{ value_exp = Vconst(Eint(i1)) }; { value_exp = Vconst(Eint(i2)) }] -> - let i = if op = Initial.stdlib_name "+" then i1 + i2 - else if op = Initial.stdlib_name "-" then i1 - i2 - else raise (Error(TypeError)) in - value_code (Vconst(Eint(i))) - | _ -> raise (Error(TypeError)) - -(** Evaluate all the definitions and returns an environment *) -and local env { l_eq = eq_list } = - List.fold_left equation env eq_list - -(** Reduce an equation. *) -and equation env ({ eq_desc = desc; eq_loc = loc } as eq) = - match desc with - | EQeq(p, e) -> matches env p (expression env e) - | EQmatch(total, e, m_b_list) -> - let v = expression env e in - let env, b = select env v m_b_list in - block env b - | EQblock(b) -> block env b - | EQand(eq_list) - | EQbefore(eq_list) -> List.fold_left equation env eq_list - | EQpluseq _ | EQinit _ | EQnext _ - | EQder _ | EQreset _ | EQpresent _ - | EQemit _ | EQautomaton _ | EQforall _ -> raise (Error(NotStaticEq eq)) - -and block env { b_locals = l_list; b_body = eq_list } = - let env = List.fold_left local env l_list in - List.fold_left equation env eq_list diff --git a/compiler/rewrite/unsafe.ml b/compiler/rewrite/unsafe.ml deleted file mode 100644 index 0058f813a..000000000 --- a/compiler/rewrite/unsafe.ml +++ /dev/null @@ -1,71 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* safe/unsafe expressions and equations. *) -(* A computation is safe when it is combinatorial, that is, it *) -(* has no side effect, total and no state *) -open Zelus -open Zident -open Deftypes -open Zaux - -(** An expression or equation is unsafe if it contains an unsafe operation. *) -let rec exp { e_desc = desc } = - match desc with - | Eapp(_, e, e_list) -> - (* look if (e e1...en) is combinatorial *) - (not (Ztypes.is_combinatorial (List.length e_list) e.e_typ)) - || (exp e) || (List.exists exp e_list) - | Erecord_access(e, _) | Etypeconstraint(e, _) -> exp e - | Erecord(f_e_list) -> - List.exists (fun (_, e) -> exp e) f_e_list - | Erecord_with(e, f_e_list) -> - exp e || List.exists (fun (_, e) -> exp e) f_e_list - | Eseq(e1, e2) -> (exp e1) || (exp e2) - | Elocal _ | Elast _ | Econst _ | Econstr0 _ - | Eglobal _ | Eperiod _ | Eop _ -> false - | Elet _ | Eblock _ -> true - | Econstr1(_, e_list) | Etuple(e_list) -> List.exists exp e_list - | Epresent _ | Ematch _ -> assert false - -let rec equation { eq_desc = desc } = - match desc with - | EQeq(_, e) | EQinit(_, e) | EQder(_, e, None, []) | EQpluseq(_, e) -> exp e - | EQmatch(_, e, m_h_list) -> - exp e - || List.exists - (fun { m_body = b_eq_list } -> block_eq_list b_eq_list) m_h_list - | EQreset(eq_list, e) -> - exp e || List.exists equation eq_list - | EQand(eq_list) - | EQbefore(eq_list) -> List.exists equation eq_list - | EQforall - { for_index = i_list; for_init = init_list; for_body = b_eq_list } -> - let index { desc = desc } = - match desc with - | Einput(_, e) -> exp e - | Eoutput _ -> false - | Eindex(_, e1, e2) -> exp e1 || exp e2 in - let init { desc = desc } = - match desc with - | Einit_last(_, e) -> exp e in - List.exists index i_list || - List.exists init init_list || - block_eq_list b_eq_list - | EQder _ | EQnext _ | EQautomaton _ - | EQpresent _ | EQemit _ | EQblock _ -> assert false - -and block_eq_list { b_locals = l_list; b_body = eq_list } = - (List.exists (fun { l_eq = eq_list } -> List.exists equation eq_list) l_list) - || List.exists equation eq_list diff --git a/compiler/rewrite/write.ml b/compiler/rewrite/write.ml deleted file mode 100644 index 720c2a320..000000000 --- a/compiler/rewrite/write.ml +++ /dev/null @@ -1,196 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* compute write variables for every equation and block. Variables which *) -(* are written only once and stay local to the block where they appear *) -(* get kind [Sval]. Otherwise, they get kind Svar or Smem *) - -open Zident -open Zelus -open Deftypes - -(* merge of two sets of defined names. If a name appears in one branch only *) -(* it must be a shared variable *) -let merge ({ dv = dv1 } as def1, s1) ({ dv = dv2 } as def2, s2) = - Total.union def1 def2, S.union dv1 (S.union dv2 (S.union s1 s2)) - -(* union of two sets of defined names. If a name appears twice, it must *) -(* be a shared variable *) -let union ({ dv = dv1 } as def1, s1) ({ dv = dv2 } as def2, s2) = - Total.union def1 def2, - S.union (S.inter dv1 dv2) (S.union s1 s2) - -(* given [b_env], returns the set of defined names and a *) -(* new env., equal to [b_env] but where the kind of variables not in the *) -(* set of shared variables [shared_set] is turned to [Sval] *) -let filter_env shared_set b_env = - let filter n ({ t_sort = sort } as entry) (bounded, env) = - let entry = - match sort with - | (Svar { v_combine = None; v_default = None } - | Smem { m_kind = None; m_init = Noinit; m_previous = false; - m_combine = None }) - when not (S.mem n shared_set) -> { entry with t_sort = Sval } - | _ -> entry in - S.add n bounded, Env.add n entry env in - Env.fold filter b_env (S.empty, Env.empty) - -let rec equation ({ eq_desc = desc } as eq) = - let eq, defnames, shared_set = match desc with - | EQeq(pat, e) -> - { eq with eq_desc = EQeq(pat, expression e) }, - { Deftypes.empty with dv = Vars.fv_pat S.empty S.empty pat }, S.empty - | EQpluseq(n, e) -> - { eq with eq_desc = EQpluseq(n, expression e) }, - { Deftypes.empty with dv = S.singleton n }, S.empty - | EQder(n, e, None, []) -> - { eq with eq_desc = EQder(n, expression e, None, []) }, - { Deftypes.empty with der = S.singleton n }, S.empty - | EQinit(n, e) -> - { eq with eq_desc = EQinit(n, expression e) }, - { Deftypes.empty with di = S.singleton n }, S.empty - | EQmatch(total, e, m_h_list) -> - let m_h_list, (defnames, shared_set) = - Zmisc.map_fold - (fun acc ({ m_body = b } as m_h) -> - let b, defnames, shared_set = block b in - { m_h with m_body = b }, merge (defnames, shared_set) acc) - (Deftypes.empty, S.empty) m_h_list in - { eq with eq_desc = EQmatch(total, expression e, m_h_list) }, - defnames, shared_set - | EQreset(eq_list, e) -> - let eq_list, (defnames, shared_set) = - equation_list (Deftypes.empty, S.empty) eq_list in - let defnames, shared_set = - merge (defnames, shared_set) (Deftypes.empty, S.empty) in - { eq with eq_desc = EQreset(eq_list, expression e) }, - defnames, shared_set - | EQand(and_eq_list) -> - let and_eq_list, (defnames, shared_set) = - equation_list (Deftypes.empty, S.empty) and_eq_list in - { eq with eq_desc = EQand(and_eq_list) }, defnames, shared_set - | EQbefore(before_eq_list) -> - let before_eq_list, (defnames, shared_set) = - equation_list (Deftypes.empty, S.empty) before_eq_list in - { eq with eq_desc = EQbefore(before_eq_list) }, defnames, shared_set - | EQblock(b) -> - let b, defnames, shared_set = block b in - { eq with eq_desc = EQblock(b) }, defnames, shared_set - | EQforall ({ for_index = i_list; for_init = init_list; - for_body = b_eq_list } as body) -> - (* compute the association table [xi_out_x] from the *) - (* list of [xi out x] pairs *) - let index xi_out_x ({ desc = desc } as ind) = - match desc with - | Einput(i, e) -> - { ind with desc = Einput(i, expression e) }, xi_out_x - | Eindex(i, e1, e2) -> - { ind with desc = Eindex(i, expression e1, expression e2) }, - xi_out_x - | Eoutput(xi, x) -> - ind, Env.add xi x xi_out_x in - (* computes the set of initialized names [i_set] *) - let init acc ({ desc = desc } as ini) = - match desc with - | Einit_last(i, e) -> - { ini with desc = Einit_last(i, expression e) }, S.add i acc in - let i_list, xi_out_x = Zmisc.map_fold index Env.empty i_list in - let init_list, i_set = Zmisc.map_fold init S.empty init_list in - let b_eq_list, { dv = dv; di = di; der = der; nv = nv; mv = mv }, - shared_set = block b_eq_list in - (* if [xi in defnames_in_body] and [xi out x] then [x in defnames] *) - (* if [xi in shared_set] and [xi out x] or [x in shared_set] *) - let x_of_xi xi = - try Env.find xi xi_out_x with Not_found -> xi in - let defnames = - { dv = S.map x_of_xi dv; di = S.map x_of_xi di; - der = S.map x_of_xi der; nv = S.map x_of_xi nv; - mv = S.map x_of_xi mv } in - let shared_set = S.map x_of_xi shared_set in - (* all variables defined in the body of the loop are shared *) - let defnames, shared_set = - merge (defnames, shared_set) (Deftypes.empty, S.empty) in - { eq with eq_desc = - EQforall { body with for_index = i_list; for_init = init_list; - for_body = b_eq_list } }, - defnames, shared_set - | EQpresent _ | EQautomaton _ | EQder _ - | EQnext _ | EQemit _ -> assert false in - (* set the names defined in the equation *) - { eq with eq_write = defnames }, defnames, shared_set - -and equation_list acc eq_list = - Zmisc.map_fold - (fun acc eq -> let eq, defnames, shared_set = equation eq in - eq, union (defnames, shared_set) acc) acc eq_list - -and block ({ b_env = b_env; b_locals = l_list; b_body = eq_list } as b) = - let l_list = List.map local l_list in - let eq_list, ({ dv = dv; der = der; di = di; nv = nv; mv = mv }, shared_set) = - equation_list (Deftypes.empty, S.empty) eq_list in - let bounded, b_env = filter_env shared_set b_env in - let dv = S.diff dv bounded in - let di = S.diff di bounded in - let der = S.diff der bounded in - let nv = S.diff nv bounded in - let mv = S.diff mv bounded in - let shared_set = S.diff shared_set bounded in - let local_defnames = { dv = dv; der = der; di = di; nv = nv; mv = mv } in - { b with b_write = local_defnames; b_locals = l_list; - b_env = b_env; b_body = eq_list }, - local_defnames, shared_set - - -and local ({ l_eq = eq_list; l_env = l_env } as l) = - let eq_list, (_, shared_set) = - equation_list (Deftypes.empty, S.empty) eq_list in - let _, l_env = filter_env shared_set l_env in - { l with l_eq = eq_list; l_env = l_env } - -and expression ({ e_desc = desc } as e) = - let desc = - match desc with - | Elocal _ | Eglobal _ - | Econst _ | Econstr0 _ | Elast _ -> desc - | Eop(op, e_list) -> - Eop(op, List.map expression e_list) - | Eapp(app, op, e_list) -> - Eapp(app, op, List.map expression e_list) - | Etuple(e_list) -> Etuple(List.map expression e_list) - | Econstr1(c, e_list) -> Econstr1(c, List.map expression e_list) - | Erecord_access(e_record, ln) -> Erecord_access(expression e_record, ln) - | Erecord(l_e_list) -> - Erecord(List.map (fun (l, e) -> (l, expression e)) l_e_list) - | Erecord_with(e_record, l_e_list) -> - Erecord_with(expression e_record, - List.map (fun (l, e) -> (l, expression e)) l_e_list) - | Etypeconstraint(e, ty) -> Etypeconstraint(expression e, ty) - | Elet(l, e) -> Elet(local l, expression e) - | Eblock(b, e) -> let b, _, _ = block b in Eblock(b, expression e) - | Eseq(e1, e2) -> Eseq(expression e1, expression e2) - | Eperiod { p_phase = p1; p_period = p2 } -> - Eperiod - { p_phase = Zmisc.optional_map expression p1; p_period = expression p2 } - | Epresent _ | Ematch _ -> assert false in - { e with e_desc = desc } - -let implementation impl = - match impl.desc with - | Econstdecl(n, is_static, e) -> - { impl with desc = Econstdecl(n, is_static, expression e) } - | Efundecl(n, ({ f_body = e } as body)) -> - { impl with desc = Efundecl(n, { body with f_body = expression e }) } - | _ -> impl - -let implementation_list impl_list = Zmisc.iter implementation impl_list diff --git a/compiler/rewrite/zdeadcode.ml b/compiler/rewrite/zdeadcode.ml deleted file mode 100644 index 490c62294..000000000 --- a/compiler/rewrite/zdeadcode.ml +++ /dev/null @@ -1,344 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* dead-code removal. *) -(* this is applied to normalized code *) - -open Zmisc -open Zident -open Vars -open Zelus -open Deftypes - -(** Dead-code removal. First build a table [yn -> {x1,...,xk}] wich associate *) -(** the list of read variables used to produce yn *) -(** then recursively mark all useful variable according to *) -(** read-in dependences *) -(** An equation [eq] is marked useful when it may be unsafe, that *) -(** is, it has side effets and/or is non total *) -(** For the moment, only combinatorial functions *) -(** are considered safe. *) -(** finally, only keep equations and name defs. for useful variables *) -(** horizons are considered to be useful *) -type table = cont Env.t - and cont = - { mutable c_vars: S.t; (* set of variables *) - mutable c_useful: bool; (* is-it a useful variable? *) - mutable c_visited: bool; (* has it been visited already? *) } - -(** Useful function. For debugging purpose. *) -let print ff table = - let names ff l = - Pp_tools.print_list_r Printer.name "{" "," "}" ff (S.elements l) in - let entry x { c_vars = l; c_useful = u } = - Format.fprintf ff "@[%a -> {c_vars = %a; c_useful = %s}@]@ " - Printer.name x - names l (if u then "true" else "false") in - Env.iter entry table - -(* Add the entries [x_j <- x1; ...; x_j <- xn] in the table. *) -(* for any variable [x_j in w] *) -(* if [x_j] already, extends the set of variables on which it depends. *) -(* Otherwise, add the new entry *) -(* when [is_useful = true], mark all read and write variables to be useful *) -let add is_useful w r table = - (* mark all names in [set] to be useful *) - let mark_useful set table = - let mark x table = - try - let { c_useful = u } as cont = Env.find x table in - cont.c_useful <- true; - table - with - | Not_found -> - Env.add x - { c_vars = S.empty; c_useful = true; - c_visited = false } table in - S.fold mark set table in - - let add x table = - try - let { c_vars = l; c_useful = u } as cont = Env.find x table in - cont.c_vars <- S.union r l; - cont.c_useful <- u || is_useful; - table - with - | Not_found -> - Env.add x - { c_vars = r; c_useful = is_useful; c_visited = false } table in - (* mark all vars. in [r] to be useful *) - let table = if is_useful then mark_useful r table else table in - (* add dependences *) - S.fold add w table - - -(** Extend [table] where every entry [y -> {x1,...,xn}] *) -(** is marked to also depend on names in [names] *) -let extend table names = - Env.map - (fun ({ c_vars = l } as cont) -> { cont with c_vars = S.union l names }) - table - -(** Fusion of two tables *) -let merge table1 table2 = - let add x ({ c_vars = l1; c_useful = u1 } as cont1) table = - try - let ({ c_vars = l2; c_useful = u2 } as cont2) = Env.find x table in - cont2.c_vars <- S.union l1 l2; cont2.c_useful <- u1 || u2; - table - with - | Not_found -> Env.add x cont1 table in - Env.fold add table2 table1 - -(** Build the association table [yk -> { x1,..., xn}] *) -let rec build_equation table { eq_desc = desc } = - match desc with - | EQeq(p, e) -> - let w = fv_pat S.empty S.empty p in - (* for every [x in w], add the link [x -> {x1, ..., xn }] to table *) - let r = fve S.empty e in - add (Unsafe.exp e) w r table - | EQpluseq(n, e) | EQinit(n, e) - | EQder(n, e, None, []) -> - let r = fve S.empty e in - add (Unsafe.exp e) (S.singleton n) r table - | EQmatch(_, e, m_h_list) -> - let r = fve S.empty e in - let u = Unsafe.exp e in - (* mark read variables to be useful when [e] is potentially unsafe *) - let table = add u S.empty r table in - let table_b = - List.fold_left - (fun table { m_body = b } -> build_block table b) - Env.empty m_h_list in - merge table (extend table_b r) - | EQreset(res_eq_list, e) -> - let r = fve S.empty e in - let u = Unsafe.exp e in - (* mark read variables to be useful when [e] is potentially unsafe *) - let table = add u S.empty r table in - let table_res = build_equation_list Env.empty res_eq_list in - merge table (extend table_res r) - | EQforall { for_index = i_list; for_init = init_list; - for_body = b_eq_list } -> - let index table { desc = desc } = - match desc with - | Einput(i, e) -> - add (Unsafe.exp e) (S.singleton i) (fve S.empty e) table - | Eoutput(i, j) -> - add false (S.singleton j) (S.singleton i) table - | Eindex(i, e1, e2) -> - add ((Unsafe.exp e1) || (Unsafe.exp e2)) - (S.singleton i) (fve (fve S.empty e1) e2) table in - let init table { desc = desc } = - match desc with - | Einit_last(i, e) -> - add (Unsafe.exp e) (S.singleton i) (fve S.empty e) table in - let table = List.fold_left index table i_list in - let table = List.fold_left init table init_list in - build_block table b_eq_list - | EQand(eq_list) | EQbefore(eq_list) -> build_equation_list table eq_list - | EQblock _ | EQder _ | EQnext _ | EQautomaton _ - | EQpresent _ | EQemit _ -> assert false - -and build_block table { b_body = eq_list } = build_equation_list table eq_list - -and build_local table { l_eq = eq_list } = build_equation_list table eq_list - -and build_equation_list table eq_list = - List.fold_left build_equation table eq_list - -(** Visit the table: recursively mark all useful variables *) -(** returns the set of useful variables *) -(** [read] is a set of variables *) -let visit read table = - let useful = ref S.empty in - (* recursively mark visited nodes which are useful *) - let rec visit x ({ c_vars = l; c_useful = u; c_visited = v } as entry) = - if not v then - begin - entry.c_visited <- true; - entry.c_useful <- true; - useful := S.add x !useful; - S.iter visit_fathers l - end - and visit_fathers x = - useful := S.add x !useful; - try - let entry = Env.find x table in - visit x entry - with - Not_found -> () - (* look for an entry in the table that is not marked but useful *) - and visit_table x ({ c_useful = u; c_visited = v } as entry) = - if not v && u then visit x entry in - (* recursively mark nodes and their predecessors *) - S.iter visit_fathers read; - Env.iter visit_table table; - !useful - -(** Empty block *) -let is_empty_block { b_locals = l; b_body = eq_list } = - (l = []) && (eq_list = []) - -(** remove useless names in write names *) -let writes useful { dv = dv; di = di; der = der; nv = nv; mv = mv } = - let filter set = S.filter (fun x -> S.mem x useful) set in - { dv = filter dv; di = filter di; der = filter der; - nv = filter nv; mv = filter mv } - -(* remove useless names in a pattern *) -let rec pattern useful ({ p_desc = desc } as p) = - match desc with - | Ewildpat | Econstpat _ | Econstr0pat _ -> p - | Etuplepat(p_list) -> - { p with p_desc = Etuplepat(List.map (pattern useful) p_list) } - | Econstr1pat(c, p_list) -> - { p with p_desc = Econstr1pat(c, List.map (pattern useful) p_list) } - | Evarpat(x) -> if S.mem x useful then p else { p with p_desc = Ewildpat } - | Ealiaspat(p_alias, x) -> - let p_alias = pattern useful p_alias in - if S.mem x useful then { p with p_desc = Ealiaspat(p_alias, x) } - else p_alias - | Eorpat(p1, p2) -> - { p with p_desc = Eorpat(pattern useful p1, pattern useful p2) } - | Erecordpat(ln_pat_list) -> - { p with p_desc = - Erecordpat(List.map (fun (ln, p) -> - (ln, pattern useful p)) ln_pat_list) } - | Etypeconstraintpat(p, ty_exp) -> - let p = pattern useful p in - { p with p_desc = Etypeconstraintpat(p, ty_exp) } - -(** Remove useless equations. [useful] is the set of useful names *) -let rec remove_equation useful - ({ eq_desc = desc; eq_write = w } as eq) eq_list = - match desc with - | EQeq(p, e) -> - let w = fv_pat S.empty S.empty p in - if Unsafe.exp e || S.exists (fun x -> S.mem x useful) w - then (* the equation is useful *) - { eq with eq_desc = EQeq(pattern useful p, e) } :: eq_list else eq_list - | EQpluseq(n, e) | EQder(n, e, None, []) - | EQinit(n, e) -> - if Unsafe.exp e || S.mem n useful then eq :: eq_list else eq_list - | EQmatch(total, e, m_h_list) -> - let m_h_list = - List.map - (fun ({ m_body = b } as m_h) -> - { m_h with m_body = remove_block useful b }) m_h_list in - (* remove the equation if all handlers are empty *) - if not (Unsafe.exp e) - && List.for_all (fun { m_body = b} -> is_empty_block b) m_h_list - then eq_list - else { eq with eq_desc = EQmatch(total, e, m_h_list); - eq_write = writes useful w } :: eq_list - | EQreset(res_eq_list, e) -> - let res_eq_list = remove_equation_list useful res_eq_list in - (* remove the equation if the body is empty *) - if not (Unsafe.exp e) && res_eq_list = [] then eq_list - else { eq with eq_desc = EQreset(res_eq_list, e); - eq_write = writes useful w } :: eq_list - | EQforall({ for_index = i_list; for_init = init_list; for_body = b_eq_list; - for_in_env = in_env; for_out_env = out_env } as f_body) -> - let index acc ({ desc = desc } as ind) = - match desc with - | Einput(i, e) -> - if (Unsafe.exp e) || (S.mem i useful) then ind :: acc else acc - | Eoutput(xo, o) -> - if (S.mem xo useful) || (S.mem o useful) then ind :: acc else acc - | Eindex _ -> - (* the index i in [e1 .. e2] is kept *) - ind :: acc in - let init acc ({ desc = desc } as ini) = - match desc with - | Einit_last(i, e) -> - if (Unsafe.exp e) || (S.mem i useful) then ini :: acc else acc in - let i_list = List.fold_left index [] i_list in - let init_list = List.fold_left init [] init_list in - let b_eq_list = remove_block useful b_eq_list in - let in_env = Env.filter (fun x entry -> S.mem x useful) in_env in - let out_env = Env.filter (fun x entry -> S.mem x useful) out_env in - if is_empty_block b_eq_list then eq_list - else { eq with eq_desc = - EQforall { f_body with - for_index = i_list; - for_init = init_list; - for_body = b_eq_list; - for_in_env = in_env; - for_out_env = out_env } } :: eq_list - | EQbefore(before_eq_list) -> - let before_eq_list = remove_equation_list useful before_eq_list in - (* remove the equation if the body is empty *) - if before_eq_list = [] then eq_list - else (Zaux.before before_eq_list) :: eq_list - | EQand(and_eq_list) -> - let and_eq_list = remove_equation_list useful and_eq_list in - (* remove the equation if the body is empty *) - if and_eq_list = [] then eq_list - else (Zaux.par and_eq_list) :: eq_list - | EQnext _ | EQder _ | EQautomaton _ | EQblock _ - | EQpresent _ | EQemit _ -> assert false - -and remove_equation_list useful eq_list = - List.fold_right (remove_equation useful) eq_list [] - -and remove_block useful - ({ b_vars = n_list; b_locals = l_list; - b_body = eq_list; - b_write = ({ dv = w } as defnames); - b_env = n_env } as b) = - let l_list = List.map (remove_local useful) l_list in - let eq_list = remove_equation_list useful eq_list in - let n_list = - List.filter (fun { vardec_name = x } -> S.mem x useful) n_list in - let n_env = Env.filter (fun x entry -> S.mem x useful) n_env in - let w = S.filter (fun x -> S.mem x useful) w in - { b with b_vars = n_list; b_locals = l_list; b_body = eq_list; - b_write = { defnames with dv = w }; b_env = n_env } - -and remove_local useful ({ l_eq = eq_list; l_env = l_env } as l) = - let eq_list = remove_equation_list useful eq_list in - let l_env = Env.filter (fun x entry -> S.mem x useful) l_env in - { l with l_eq = eq_list; l_env = l_env } - -(** Compute the set of horizons *) -let horizon read { l_env = l_env } = - let take h { t_sort = sort } acc = - match sort with - | Smem { m_kind = Some(Horizon) } -> S.add h acc | _ -> acc in - Env.fold take l_env read - -(** the main entry for expressions. Warning: [e] must be in normal form *) -let exp ({ e_desc = desc } as e) = - match desc with - | Elet(l, e_let) -> - let read = fve S.empty e_let in - (* horizons are considered as outputs *) - let read = horizon read l in - let table = build_local Env.empty l in - (* Format.printf "%a@.@." print table; *) - let useful = visit read table in - (* Format.printf "%a@." print table; flush stdout; *) - let { l_eq = eq_list } as l = remove_local useful l in - if eq_list = [] then e_let else { e with e_desc = Elet(l, e_let) } - | _ -> e - -let implementation impl = - match impl.desc with - | Eopen _ | Etypedecl _ | Econstdecl _ -> impl - | Efundecl(n, ({ f_body = e } as body)) -> - { impl with desc = Efundecl(n, { body with f_body = exp e }) } - -let implementation_list impl_list = Zmisc.iter implementation impl_list diff --git a/compiler/rewrite/zopt.ml b/compiler/rewrite/zopt.ml deleted file mode 100644 index d86de31ab..000000000 --- a/compiler/rewrite/zopt.ml +++ /dev/null @@ -1,235 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* sharing of zero-crossings *) -(* Zero-crossing that appear in exclusive control branches are shared *) -(* This transformation is applied to normalized equations and expressions *) -(* [z1 = up(e1) # z2 = up(e2)] becomes [z1 = up(e1) # z1 = up(e2)] *) -(* Two phases algorithm: - * one phase computes zero-crossing variables and a substitution; - * the second one applies the subsitution *) -open Zident -open Zelus -open Deftypes - -(* an environment { env, size, subst } - * env: the environment of zero-crossings; - * ren: Zident.t -> Zident.t defines the renaming of zero-crossings - * size: number of entries in env *) -type zenv = { env: Deftypes.tentry Env.t; ren: Zident.t Env.t; size: int } - -let zempty = { env = Env.empty; ren = Env.empty; size = 0 } - -(* Partition an environment into an environment of zero-crossing variables *) -(* and its complement *) -let zero_from_env env = - let select key { t_sort = s } = - match s with - | Smem { m_kind = Some(Zero) } -> true | _ -> false in - Env.partition select env - -let vars_of_env vars env = - List.filter (fun { vardec_name = x } -> Env.mem x env) vars - -(* Make a renaming from two environment *) -(* [make env2 env1 = ren] where - * ren = [x1\y1,..., xn\yn] with [x1,...,xn] = Dom(env2) - * and [y1,...,yn] in Dom(env1) *) -let make env2 env1 = - (* [one key entry (l, acc) = acc + [key \ key'], l'] - * renames key into key' if [l = [key', entry'].l'] *) - let one key _ (l, acc) = - match l with - | [] -> assert false (* env1 is supposed to be bigger than env2 *) - | (key', _) :: l -> l, Env.add key key' acc in - let l1 = Env.bindings env1 in - let _, ren = Env.fold one env2 (l1, Env.empty) in - ren - -(* Compose two renamings. *) -(* [compose r2_by_1 r2 = r] returns an environment [r] such that: - * r(x) = r2_by_1 (r2(x)) *) -let compose r2_by_1 r2 = - Env.map (fun n2 -> try Env.find n2 r2_by_1 with Not_found -> assert false) r2 - -(* Composition of two environment *) -let parallel - { env = env1; ren = r1; size = s1 } { env = env2; ren = r2; size = s2 } = - { env = Env.append env1 env2; ren = Env.append r1 r2; size = s1 + s2 } - -let sharp - { env = env1; ren = r1; size = s1 } { env = env2; ren = r2; size = s2 } = - (* all names of env2 are renamed by those from env1 if s1 >= s2 *) - if s1 >= s2 - then let r2_by_1 = make env2 env1 in - let r = Env.append r1 (Env.append r2_by_1 (compose r2_by_1 r2)) in - { env = env1; ren = r; size = s1 } - else let r1_by_2 = make env1 env2 in - let r = Env.append r2 (Env.append r1_by_2 (compose r1_by_2 r1)) in - { env = env2; ren = r; size = s2 } - -(* [equation eq = eq', zenv] where - * eq': the new equation in which zero-crossing variables have been removed - * zenv.env: the set of zero-crossing variables defined in eq - * zenv.rename: Zident.t -> Zident.t, the substitution of zero-crossing variables *) -let rec equation ({ eq_desc = desc } as eq) = - match desc with - | EQeq _ | EQpluseq _ | EQder _ | EQinit _ -> eq, zempty - | EQmatch(total, e, m_h_list) -> - let m_h_list, zenv = - Zmisc.map_fold (fun acc ({ m_body = b } as m_h) -> - let b, zenv = block b in - { m_h with m_body = b }, - sharp acc zenv) - zempty m_h_list in - { eq with eq_desc = EQmatch(total, e, m_h_list) }, zenv - | EQreset(eq_list, e) -> - let eq_list, zenv = equation_list eq_list in - { eq with eq_desc = EQreset(eq_list, e) }, zenv - | EQand(and_eq_list) -> - let and_eq_list, zenv = equation_list and_eq_list in - { eq with eq_desc = EQand(and_eq_list) }, zenv - | EQbefore(before_eq_list) -> - let before_eq_list, zenv = equation_list before_eq_list in - { eq with eq_desc = EQbefore(before_eq_list) }, zenv - | EQforall _ -> eq, zempty - | EQblock _ | EQpresent _ | EQautomaton _ | EQnext _ | EQemit _ -> - assert false - -and equation_list eq_list = - Zmisc.map_fold (fun acc eq -> let eq, zenv = equation eq in - eq, parallel acc zenv) - zempty eq_list - -and block ({ b_vars = vars; b_env = b_env; b_body = eq_list } as b) = - let zero_env, b_env = zero_from_env b_env in - let eq_list, zenv = equation_list eq_list in - { b with b_vars = vars_of_env vars b_env; b_env = b_env; b_body = eq_list }, - parallel { env = zero_env; ren = Env.empty; size = Env.cardinal zero_env } zenv - -(* renaming *) -let rec rename_expression ren ({ e_desc = desc } as e) = - match desc with - | Econst _ | Econstr0 _ | Eglobal _ -> e - | Elocal(x) -> { e with e_desc = Elocal(apply x ren) } - | Elast(x) -> { e with e_desc = Elast(apply x ren) } - | Etuple(e_list) -> - { e with e_desc = Etuple(List.map (rename_expression ren) e_list) } - | Econstr1(c, e_list) -> - { e with e_desc = Econstr1(c, List.map (rename_expression ren) e_list) } - | Erecord(n_e_list) -> - { e with e_desc = - Erecord(List.map (fun (ln, e) -> - (ln, rename_expression ren e)) n_e_list) } - | Erecord_access(e_record, ln) -> - { e with e_desc = Erecord_access(rename_expression ren e_record, ln) } - | Erecord_with(e_record, n_e_list) -> - { e with e_desc = - Erecord_with(rename_expression ren e_record, - List.map - (fun (ln, e) -> - (ln, rename_expression ren e)) n_e_list) } - | Eop(op, e_list) -> - { e with e_desc = Eop(op, List.map (rename_expression ren) e_list) } - | Eapp(app, e_op, e_list) -> - let e_op = rename_expression ren e_op in - let e_list = List.map (rename_expression ren) e_list in - { e with e_desc = Eapp(app, e_op, e_list) } - | Etypeconstraint(e1, ty) -> - { e with e_desc = Etypeconstraint(rename_expression ren e1, ty) } - | Eseq(e1, e2) -> - { e with e_desc = Eseq(rename_expression ren e1, rename_expression ren e2) } - | Eperiod _ | Epresent _ | Ematch _ | Elet _ | Eblock _ -> assert false - -and rename_local ren ({ l_eq = eq_list } as l) = - let eq_list = rename_equation_list ren eq_list in - { l with l_eq = eq_list } - -and rename_equation ren ({ eq_desc = desc } as eq) = - let desc = match desc with - (* zero-crossing definitions must be of the form [x = up(e)] *) - | EQeq({ p_desc = Evarpat(x) } as p, e) -> - EQeq( { p with p_desc = Evarpat(apply x ren) }, rename_expression ren e) - | EQeq(p, e) -> EQeq(p, rename_expression ren e) - | EQpluseq(x, e) -> EQpluseq(apply x ren, rename_expression ren e) - | EQinit(x, e0) -> EQinit(apply x ren, rename_expression ren e0) - | EQmatch(total, e, m_h_list) -> - let m_h_list = - List.map - (fun ({ m_body = b } as m_h) -> - { m_h with m_body = rename_block ren b }) - m_h_list in - EQmatch(total, rename_expression ren e, m_h_list) - | EQder(x, e, None, []) -> EQder(x, rename_expression ren e, None, []) - | EQreset(res_eq_list, e) -> - let e = rename_expression ren e in - let res_eq_list = rename_equation_list ren res_eq_list in - EQreset(res_eq_list, e) - | EQand(and_eq_list) -> - EQand(rename_equation_list ren and_eq_list) - | EQbefore(before_eq_list) -> - EQbefore(rename_equation_list ren before_eq_list) - | EQforall ({ for_index = i_list; for_init = init_list; - for_body = b_eq_list } as body) -> - let index ({ desc = desc } as ind) = - let desc = match desc with - | Einput(x, e) -> Einput(x, rename_expression ren e) - | Eoutput _ -> desc - | Eindex(x, e1, e2) -> Eindex(x, rename_expression ren e1, - rename_expression ren e2) in - { ind with desc = desc } in - let init ({ desc = desc } as ini) = - let desc = match desc with - | Einit_last(x, e) -> Einit_last(x, rename_expression ren e) in - { ini with desc = desc } in - let i_list = List.map index i_list in - let init_list = List.map init init_list in - let b_eq_list = rename_block ren b_eq_list in - EQforall { body with for_index = i_list; for_init = init_list; - for_body = b_eq_list } - | EQblock _ | EQautomaton _ | EQpresent _ - | EQemit _ | EQder _ | EQnext _ -> assert false in - { eq with eq_desc = desc } - -and rename_equation_list ren eq_list = List.map (rename_equation ren) eq_list - -and rename_block ren ({ b_body = eq_list } as b) = - let eq_list = rename_equation_list ren eq_list in - { b with b_body = eq_list } - -and apply x ren = - try Env.find x ren with | Not_found -> x - -(* The main functions *) -let local ({ l_eq = eq_list; l_env = l_env } as l) = - let eq_list, { env = env; ren = ren } = equation_list eq_list in - let eq_list = rename_equation_list ren eq_list in - { l with l_eq = eq_list; l_env = Env.append env l_env } - -let expression ({ e_desc = desc } as e) = - let desc = - match desc with - | Elet(l, e) -> Elet(local l, e) - | _ -> desc in - { e with e_desc = desc } - -let implementation impl = - match impl.desc with - | Econstdecl(n, is_static, e) -> - { impl with desc = Econstdecl(n, is_static, expression e) } - | Efundecl(n, ({ f_body = e } as body)) -> - { impl with desc = Efundecl(n, { body with f_body = expression e }) } - | _ -> impl - -let implementation_list impl_list = Zmisc.iter implementation impl_list diff --git a/compiler/typing/interface.ml b/compiler/typing/interface.ml deleted file mode 100644 index 8b95d0952..000000000 --- a/compiler/typing/interface.ml +++ /dev/null @@ -1,375 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* read an interface *) - -open Zlocation -open Lident -open Zelus -open Global -open Deftypes -open Modules -open Ztypes -open Format - -(* types of errors *) -type error = - | Eunbound_type_constr of Lident.t - | Eunbound_global_value of Lident.t - | Etype_constr_arity of Lident.t * int * int - | Eunbound_type_var of string - | Erepeated_type_param of string - | Erepeated_constructor of string - | Erepeated_label of string - | Ealready_defined_type of string - | Ealready_defined_constr of string - | Ealready_defined_label of string - | Ealready_defined_value of string - | Ecyclic_abbreviation - -exception Error of location * error - -let error loc e = raise(Error(loc, e)) - -(* printing error messages *) -let message loc kind = - begin - match kind with - | Eunbound_type_constr(longname) -> - eprintf "%aType error: The type constructor %s is unbound.@." - output_location loc (modname longname) - | Eunbound_global_value(longname) -> - eprintf "%aType error: The global value %s is unbound.@." - output_location loc (modname longname) - | Etype_constr_arity(longname, arit, arit') -> - eprintf "%aType error: The type constructor %s expects %d argument(s),@ \ - but is here given %d argument(s).@." - output_location loc - (modname longname) arit arit' - | Eunbound_type_var(n) -> - eprintf "%aType error: The type variable %s is unbound.@." - output_location loc - n - | Erepeated_type_param(n) -> - eprintf "%aType error: Repeated parameter in type declaration.@." - output_location loc - | Erepeated_constructor(n) -> - eprintf "%aType error: Two constructors are named %s@." - output_location loc n - | Erepeated_label(n) -> - eprintf "%aType error: Two labels are named %s@." - output_location loc n - | Ealready_defined_type(n) -> - eprintf - "%aType error: The type %s already exists in the current module.@." - output_location loc n - | Ealready_defined_constr(n) -> - eprintf - "%aType error: The constructor %s already exists in \ - the current module.@." - output_location loc n - | Ealready_defined_label(n) -> - eprintf - "%aType error: The label %s already exists in the current module.@." - output_location loc n - | Ealready_defined_value(n) -> - eprintf - "%aType error: The value %s already exists in the current module.@." - output_location loc n - | Ecyclic_abbreviation -> - eprintf "%aType error: This definition is cyclic.@." - output_location loc - end; - raise Zmisc.Error - -let make desc = { desc = desc; loc = no_location } - -(* type checking of type declarations *) -let global n desc = { qualid = Modules.qualify n; info = desc } - -let rec free_of_type v ty = - match ty.desc with - | Etypevar(x) -> if List.mem x v then v else x :: v - | Etypetuple(ty_list) -> - List.fold_left free_of_type v ty_list - | Etypeconstr(_,ty_list) -> - List.fold_left free_of_type v ty_list - | Etypefun(_, _, ty_arg, ty_res) -> - free_of_type (free_of_type v ty_arg) ty_res - | Etypevec(ty_arg, _) -> free_of_type v ty_arg - -(* checks that every type is defined *) -(* and used with the correct arity *) -let constr_name loc s arity = - let { qualid = name; info = desc } = - try - Modules.find_type s - with - | Not_found -> error loc (Eunbound_type_constr(s)) in - let arity' = List.length desc.type_parameters in - if arity' <> arity - then error loc (Etype_constr_arity(s, arity', arity)); - name - -let kindtype = function - | S -> Tstatic(true) | A -> Tany | C -> Tcont - | AD -> Tdiscrete(false) | D -> Tdiscrete(true) - | AS -> Tstatic(false) | P -> Tproba - -let kindoftype = function - | Tstatic(s) -> if s then S else AS - | Tany -> A | Tcont -> C - | Tdiscrete(s) -> if s then D else AD - | Tproba -> P - -let typ_of_type_expression typ_vars typ = - let rec typrec typ = - match typ.desc with - | Etypevar(s) -> - begin try - List.assoc s typ_vars - with - Not_found -> error typ.loc (Eunbound_type_var(s)) - end - | Etypetuple(l) -> - Ztypes.product (List.map typrec l) - | Etypeconstr(s, ty_list) -> - let name = constr_name typ.loc s (List.length ty_list) in - Ztypes.nconstr name (List.map typrec ty_list) - | Etypefun(k, n_opt, ty_arg, ty_res) -> - Ztypes.funtype (kindtype k) n_opt (typrec ty_arg) (typrec ty_res) - | Etypevec(ty_arg, si) -> Ztypes.vec (typrec ty_arg) (size si) - and size si = - match si.desc with - | Sconst(i) -> Deftypes.Tconst(i) - | Sglobal(ln) -> - let { qualid = qualid } = - try Modules.find_value ln - with | Not_found -> error si.loc (Eunbound_global_value ln) in - Deftypes.Tglobal(qualid) - | Sname(n) -> Deftypes.Tname(n) - | Sop(s_op, si1, si2) -> - let operator = - function | Splus -> Deftypes.Tplus | Sminus -> Deftypes.Tminus in - Deftypes.Top(operator s_op, size si1, size si2) - in typrec typ - -let rec type_expression_of_typ typ = - let rec size si = - match si with - | Tconst(i) -> make (Sconst(i)) - | Tglobal(ln) -> make (Sglobal(Modname(ln))) - | Tname(n) -> make (Sname(n)) - | Top(s_op, si1, si2) -> - let operator = - function | Tplus -> Splus | Tminus -> Sminus in - make (Sop(operator s_op, size si1, size si2)) in - match typ.t_desc with - | Tvar -> make (Etypevar("'a" ^ (string_of_int typ.t_index))) - | Tproduct(l) -> - make (Etypetuple(List.map type_expression_of_typ l)) - | Tconstr(s, ty_list, _) -> - make (Etypeconstr(Modules.currentname (Lident.Modname(s)), - List.map type_expression_of_typ ty_list)) - | Tfun(k, n_opt, ty_arg, ty_res) -> - make (Etypefun(kindoftype k, n_opt, type_expression_of_typ ty_arg, - type_expression_of_typ ty_res)) - | Tvec(ty_arg, si) -> - make (Etypevec(type_expression_of_typ ty_arg, size si)) - | Tlink(typ) -> type_expression_of_typ typ - -(* translate the internal representation of a type into a type definition *) -let type_decl_of_type_desc tyname - { type_desc = ty_desc; type_parameters = ty_param } = - (* variant types *) - let variant_type - { qualid = qualid; info = { constr_arg = arg_l; constr_arity = arit } } = - let desc = - if arit = 0 then - Econstr0decl(Modules.shortname qualid) - else Econstr1decl(Modules.shortname qualid, - List.map type_expression_of_typ arg_l) in - make desc in - (* record types *) - let record_type { qualid = qualid; info = { label_arg = arg } } = - Modules.shortname qualid, type_expression_of_typ arg in - - let params = List.map (fun i -> "'a" ^ (string_of_int i)) ty_param in - let type_decl_desc = - match ty_desc with - | Abstract_type -> Eabstract_type - | Variant_type(c_list) -> Evariant_type(List.map variant_type c_list) - | Record_type(l_list) -> Erecord_type(List.map record_type l_list) - | Abbrev(_, ty) -> Eabbrev(type_expression_of_typ ty) in - (tyname, params, make type_decl_desc) - - -(* translating a declared type into an internal type *) -let scheme_of_type typ = - let lv = free_of_type [] typ in - let typ_vars = List.map (fun v -> (v, new_generic_var ())) lv in - let typ = typ_of_type_expression typ_vars typ in - { typ_vars = List.map snd typ_vars; - typ_body = typ } - -(* analysing a type declaration *) -let check_no_repeated_type_param loc typ_params = - let rec checkrec tp = - match tp with - | [] -> () - | x :: tp -> - if List.mem x tp then error loc (Erepeated_type_param(x)) - else checkrec tp in - checkrec typ_params - -let check_no_repeated_constructor loc l = - let rec checkrec cont l = - match l with - | [] -> () - | ({ desc = Econstr0decl(s) } | { desc = Econstr1decl(s, _) }) :: l -> - if List.mem s cont then error loc (Erepeated_constructor(s)) - else checkrec (s :: cont) l in - checkrec [] l - -let check_no_repeated_label loc l = - let rec checkrec cont l = - match l with - [] -> () - | (s,_) :: l -> - if List.mem s cont then error loc (Erepeated_label(s)) - else checkrec (s :: cont) l in - checkrec [] l - -(* typing type definitions *) -let type_variant_type typ_vars constr_decl_list final_typ = - let type_one_variant { desc = desc } = - match desc with - | Econstr0decl(s) -> - global s { constr_arg = []; constr_res = final_typ; constr_arity = 0 } - | Econstr1decl(s, te_list) -> - let ty_list = List.map (typ_of_type_expression typ_vars) te_list in - global s { constr_arg = ty_list; constr_res = final_typ; - constr_arity = List.length ty_list } in - List.fold_left - (fun l constr_decl -> (type_one_variant constr_decl) :: l) - [] constr_decl_list - -let type_record_type typ_vars label_type_list final_typ = - let type_one_label (s, typ_expr) = - let typ_arg = typ_of_type_expression typ_vars typ_expr in - (global s { label_arg = final_typ; label_res = typ_arg }) in - List.fold_left (fun l one_label -> (type_one_label one_label) :: l) - [] label_type_list - -(* first makes an initial type environnement *) -let make_initial_typ_environment loc typ_name typ_params = - check_no_repeated_type_param loc typ_params; - let typ_desc = { type_parameters = List.map (fun _ -> 0) typ_params; - type_desc = Abstract_type } in - try - add_type typ_name typ_desc; - global typ_name typ_desc - with - | Already_defined(name) -> - error loc (Ealready_defined_type name) - -let type_one_typedecl loc gtype (typ_name, typ_params, typ) = - let typ_vars = List.map (fun v -> (v, new_generic_var ())) typ_params in - let final_typ = - Ztypes.nconstr (Modules.qualify typ_name) - (List.map (fun v -> List.assoc v typ_vars) typ_params) in - - let type_desc = - match typ.desc with - | Eabstract_type -> Abstract_type - | Eabbrev(ty) -> - Abbrev(List.map (fun (_, v) -> v) typ_vars, - typ_of_type_expression typ_vars ty) - | Evariant_type constr_decl_list -> - check_no_repeated_constructor loc constr_decl_list; - let l = type_variant_type typ_vars constr_decl_list final_typ in - (* add the list of constructors to the symbol table *) - begin try - List.iter (fun g -> add_constr g.qualid.id g.info) l; - Variant_type l - with - | Modules.Already_defined (name) -> - error loc (Ealready_defined_constr name) - end - | Erecord_type label_decl_list -> - check_no_repeated_label loc label_decl_list; - let l = type_record_type typ_vars label_decl_list final_typ in - (* add the list of record fields to the symbol table *) - begin try - List.iter (fun g -> add_label g.qualid.id g.info) l; - Record_type l - with - | Modules.Already_defined (name) -> - error loc (Ealready_defined_label name) - end - in - - (* modify the description associated to the declared type *) - gtype.info.type_desc <- type_desc; - gtype.info.type_parameters <- - List.map (fun (_, ty) -> Deftypes.index ty) typ_vars; - gtype - -(* the main functions *) -let typedecl ff loc ty_name ty_params typ = - try - let gtype = make_initial_typ_environment loc ty_name ty_params in - let gtype = type_one_typedecl loc gtype (ty_name, ty_params, typ) in - if !Zmisc.print_types then - Ptypes.output_type_declaration ff [gtype] - with - | Error(loc, k) -> message loc k - -(* analysing a value declaration *) -let add_type_of_value ff loc name is_static ty_scheme = - try - add_value name (value_desc is_static ty_scheme (Modules.qualify name)); - if !Zmisc.print_types then - Ptypes.output_value_type_declaration ff [global name ty_scheme] - with - | Already_defined(x) -> message loc (Ealready_defined_value(x)) - -let update_type_of_value ff loc name is_static ty_scheme = - try - let info = Modules.find_value (Lident.Name(name)) in - set_type info ty_scheme - with - | Not_found -> add_type_of_value ff loc name is_static ty_scheme - -(* adding the type signature for a constant and a function. *) -(* [is_static = true] means that the identifier defines a compile-time value *) -let constdecl ff loc name typ = - add_type_of_value ff loc name true (scheme_of_type typ) - -let fundecl ff loc name typ = - add_type_of_value ff loc name true (scheme_of_type typ) - -let interface ff inter = - match inter.desc with - | Einter_open(modname) -> Modules.open_module modname - | Einter_typedecl(name, params, typ) -> - typedecl ff inter.loc name params typ - | Einter_constdecl(x, typ) -> - constdecl ff inter.loc x typ - -let interface_list ff p_list = - try - List.iter (interface ff) p_list - with Error (loc, err) -> message loc err - diff --git a/compiler/typing/patternsig.ml b/compiler/typing/patternsig.ml deleted file mode 100644 index 44a98447f..000000000 --- a/compiler/typing/patternsig.ml +++ /dev/null @@ -1,234 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* A generic pattern-matching verifier based on Luc Maranget's paper at JFLA *) -(* Author: Adrien Guatto 2009 *) -(* See http://pauillac.inria.fr/~maranget/papers/warn/index.html *) -(* Implemented originally in the Lucid Synchrone compiler, V4 by A.Guatto *) - -open Zelus -open Global -open Lident -open Zmatching -open Printf -open Zlocation -open Deftypes -open Zmisc - -module LANG = - struct - (* Never use the pattern's description on more than one-level! *) - type tag = - | Ttuple of int (* arity *) - | Tconst of immediate - (* name * arity * all variants (name/arity) *) - | Tconstr of string * int * (string * int) list - (* fields *) - | Trecord of string list - - let compare = Stdlib.compare - - let pdescs = List.map (fun p -> p.p_desc) - - let arity t = match t with - | Ttuple i -> i - | Tconst _ -> 0 - | Tconstr (_, i, _) -> i - | Trecord l -> List.length l - - let extract_tags l : string list = - List.map (function - | Tconstr (id, _, _) -> id - | _ -> assert false) l - - let is_complete tl = match tl with - | [Ttuple _] -> true - | [Trecord _] -> true - | [Tconst (Ebool false); Tconst (Ebool true)] -> true - | [Tconst Evoid] -> true - (* Well... those cannot realistically be complete. *) - | Tconst (Eint _) :: _ -> false - | Tconst (Efloat _) :: _ -> false - | Tconst (Estring _) :: _ -> false - | Tconst (Echar _) :: _ -> false (* unsure about this one. TODO:ask *) - | Tconstr (_, _, l) :: _ -> - (List.map fst l) = extract_tags tl - (* In all other cases... *) - | _ -> false - - let rec fix f x = let r = f x in if r = x then r else fix f r - - let not_in tl = - (* Returns e if is not in l, or next e if it is. Iterated with Zmisc.fix, - eventually returns a value absent from l. *) - let rec try_search_absent comp next l e = - match l with - | [] -> e - | h :: t -> - if comp e h = 0 - then next e - else begin - if comp e h < 0 - then e (* do not walk all the list! *) - else try_search_absent comp next t e - end in - match tl with (* Remember: we know tl is incomplete and well-typed ! *) - - | [Tconst (Ebool b)] -> Tconst (Ebool (not b)) - - | Tconst (Eint _) :: _ -> - let next p = match p with - | Tconst (Eint i) -> Tconst (Eint (i + 1)) - | _ -> assert false in - fix (try_search_absent compare next tl) (Tconst (Eint 0)) - - | Tconst (Efloat _) :: _ -> - let next p = match p with - | Tconst (Efloat f) -> Tconst (Efloat (f +. 1.)) - | _ -> assert false in - fix (try_search_absent compare next tl) (Tconst (Efloat 0.)) - - | Tconst (Estring _) :: _ -> - let next p = match p with - | Tconst (Estring s) -> Tconst (Estring (s ^ "*")) - | _ -> assert false in - fix (try_search_absent compare next tl) (Tconst (Estring "")) - - | Tconst (Echar c) :: _ -> - let next p = match p with - | Tconst (Echar c) -> - Tconst (Echar (Char.chr (Char.code c + 1))) - | _ -> assert false in - fix (try_search_absent compare next tl) (Tconst (Echar 'a')) - - | Tconstr (_, _, l) :: _ -> - let next l = List.tl l - and cmp l x = Stdlib.compare (fst (List.hd l)) x - and heads = extract_tags tl in - let (name, ar) = - List.hd (fix (try_search_absent cmp next heads) l) in - Tconstr (name, ar, l) - - | _ -> assert false - - - type pattern_ast = Zelus.pattern - - (* Translation to tagged patterns is pretty easy, we just have to look for - each possible constructors for constructed patterns, and sort fields for - record patterns. *) - let rec inject p = - let rec find_variant_type_idents s = - match (Modules.find_type s).info.type_desc with - | Variant_type cdi -> - let extract_name_and_arity cd = - (cd.qualid.id, List.length cd.info.constr_arg) in - List.sort Stdlib.compare (List.map extract_name_and_arity cdi) - | _ -> assert false - and find_record_type_fields typ = - let { t_desc = desc } = Ztypes.typ_repr typ in - match desc with - | Deftypes.Tconstr (s, _, _) -> - begin match (Modules.find_type (Modname s)).info.type_desc with - | Record_type cdi -> - let extract_name ldi = ldi.qualid.id in - List.sort Stdlib.compare (List.map extract_name cdi) - | _ -> assert false - end - | Deftypes.Tlink typ -> find_record_type_fields typ - | _ -> assert false in - match p.p_desc with - | Ewildpat -> Pany - | Etuplepat l -> Pconstr (Ttuple (List.length l), List.map inject l) - | Evarpat _ -> Pany - | Econstpat i -> Pconstr (Tconst i, []) - | Eorpat (l, r) -> Por (inject l, inject r) - | Ealiaspat (p, _) -> inject p - | Econstr0pat s -> - let variants = - let { t_desc = desc } = Ztypes.typ_repr p.p_typ in - match desc with - | Deftypes.Tconstr(id, _, _) -> - find_variant_type_idents (Modname id) - | _ -> assert false in - Pconstr (Tconstr (source s, 0, variants), []) - | Econstr1pat(s, l) -> - let { t_desc = desc } = Ztypes.typ_repr p.p_typ in - Pconstr (Tconstr(source s, List.length l, - match desc with - | Deftypes.Tconstr(id, _, _) -> - find_variant_type_idents (Modname id) - | _ -> assert false), - List.map inject l) - | Etypeconstraintpat (p, _) -> inject p - | Erecordpat l -> - let ll = find_record_type_fields p.p_typ in - let l' = List.map (fun (id, p) -> (source id, p)) l in - (* Find the name of each field using type information *) - let args = List.map - (fun (id : string) -> - try let pat = List.assoc id l' in inject pat - with Not_found -> Pany) ll in - Pconstr (Trecord ll, args) - - (* /!\ You should NEVER EVER use the result of eject for anything other than - pretty-printing are other type-independent operations. Types are erased - by the inject - eject pass, resulting one are bogus. /!\ *) - (* Translation from tagged patterns is trivial. *) - let rec eject internal_pat = - let sensible_default pdesc = (* TODO: ask Marc *) - { p_desc = pdesc; p_loc = Loc (0, 0); - p_typ = { t_desc = Tvar; t_index = 0; t_level = 0 }; - p_caus = Defcaus.no_typ; p_init = Definit.no_typ } in - match internal_pat with - | Pany -> sensible_default Ewildpat - | Por (l, r) -> sensible_default (Eorpat (eject l, eject r)) - | Pconstr (Ttuple _, l) -> - sensible_default (Etuplepat (List.map eject l)) - | Pconstr (Tconst i, []) -> - sensible_default (Econstpat i) - | Pconstr (Tconstr (id, 0, _), []) -> - sensible_default (Econstr0pat (Name id)) - | Pconstr (Tconstr (id, n, _), l) -> - sensible_default (Econstr1pat (Name id, List.map eject l)) - | Pconstr (Trecord fl, l) -> - let l = - List.combine (List.map (fun s -> Name s) fl) (List.map eject l) in - sensible_default (Erecordpat l) - | _ -> assert false (* illformed pattern *) - - end - -module C = PATTERN_CHECKER(LANG) - -(** The main entry. Checks that pattern matching are exhaustive and warns *) -(** about redundancy. Returns [true] if the pattern matching is exhaustive *) -let check_match_handlers loc match_handlers = - let partial_matching loc p = - Typerrors.warning loc (Typerrors.Wpartial_matching(p)) in - let display_redundant p = - Typerrors.warning loc (Typerrors.Wmatch_unused(p)) in - - let patterns = List.map (fun { m_pat = pat } -> pat) match_handlers in - let r = C.check patterns in - - Zmisc.optional_unit partial_matching loc r.C.not_matched; - List.iter display_redundant r.C.redundant_patterns; - match r.C.not_matched with | None -> true | Some _ -> false - -(* check that a pattern is total. *) -let check_activate loc pat = - let r = C.check [pat] in - match r.C.not_matched with | None -> true | Some _ -> false - diff --git a/compiler/typing/total.ml b/compiler/typing/total.ml deleted file mode 100644 index 93584b2a5..000000000 --- a/compiler/typing/total.ml +++ /dev/null @@ -1,246 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* checks totality of definitions *) -(* when a variable is declared [last x = e] then each branch is *) -(* implicitely complemented with [x = last x] *) -(* otherwise, [x] must be defined in every branch *) - -open Zlocation -open Zident -open Zelus -open Typerrors -open Deftypes -open Ztypes - -(** Names written in a block *) -let union - { dv = dv1; di = di1; der = der1; nv = nv1; mv = mv1 } - { dv = dv2; di = di2; der = der2; nv = nv2; mv = mv2 } = - { dv = S.union dv1 dv2; di = S.union di1 di2; - der = S.union der1 der2; nv = S.union nv1 nv2; mv = S.union mv1 mv2 } - -(* add two sets of names provided they are distinct *) -let add loc - { dv = dv1; di = di1; der = der1; nv = nv1; mv = mv1} - { dv = dv2; di = di2; der = der2; nv = nv2; mv = mv2 } = - let add k set1 set2 = - S.fold - (fun elt set -> - if not (S.mem elt set) then S.add elt set - else error loc (Ealready(k, elt))) set1 set2 in - { dv = add Current dv1 dv2; di = add Initial di1 di2; - der = add Derivative der1 der2; nv = add Next nv1 nv2; - mv = S.union mv1 mv2; } - - -(* checks that every partial name defined at this level *) -(* has a last value or a default value *) -let all_last loc h set = - let check elt = - let ({ t_sort = sort; t_typ = ty } as tentry) = - try Env.find elt h with | Not_found -> assert false in - match sort with - | Smem { m_init = (InitEq | InitDecl _); m_next = Some(true) } -> () - | Smem ({ m_init = (InitEq | InitDecl _) } as m) -> - tentry.t_sort <- Smem { m with m_previous = true } - | Svar { v_default = Some _ } -> () - | Sstatic | Sval | Svar { v_default = None } - | Smem _ -> - try - ignore (Ztypes.filter_signal ty); - tentry.t_sort <- variable - with Ztypes.Unify -> error loc (Eshould_be_a_signal(elt, ty)) in - S.iter check set - -(* [merge [set1;...;setn]] returns a set of names defined in every seti *) -(* and the set of names only defined partially *) -let rec merge local_names_list = - let two s1 s2 = - let total, partial = S.partition (fun elt -> S.mem elt s2) s1 in - let partial = - S.fold (fun elt set -> if not (S.mem elt total) then S.add elt set - else set) - s2 partial in - total, partial in - match local_names_list with - | [] -> S.empty, S.empty - | [s] -> s, S.empty - | s :: local_names_list -> - let total, partial1 = merge local_names_list in - let total, partial2 = two s total in - total, S.union partial1 partial2 - -let merge_defnames_list defnames_list = - let split (acc_dv, acc_di, acc_der, acc_nv, acc_mv) - { dv = dv; di = di; der = der; nv = nv; mv = mv } = - dv :: acc_dv, di :: acc_di, der :: acc_der, nv :: acc_nv, mv :: acc_mv in - let dv, di, der, nv, mv = - List.fold_left split ([], [], [], [], []) defnames_list in - let dv_total, dv_partial = merge dv in - let di_total, di_partial = merge di in - let der_total, der_partial = merge der in - let nv_total, nv_partial = merge nv in - let mv_total, mv_partial = merge mv in - (dv_total, dv_partial), (di_total, di_partial), - (der_total, der_partial), (nv_total, nv_partial), (mv_total, mv_total) - -(* The main entry. Identify variables which are partially defined *) -let merge loc h defnames_list = - let - (dv_total, dv_partial), (di_total, di_partial), - (der_total, der_partial), (nv_total, nv_partial), (mv_total, mv_partial) = - merge_defnames_list defnames_list in - (* every partial variable must be defined as a memory or declared with *) - (* a default value *) - all_last loc h (S.diff dv_partial di_total); - (* for initialized values, all branches must give a definition *) - if not (S.is_empty di_partial) - then error loc (Einit_undefined(S.choose(di_partial))); - (* the default equation for a derivative is [der x = 0] so nothing *) - (* has to be done *) - add loc - { dv = dv_partial; di = di_partial; der = der_partial; - nv = nv_partial; mv = mv_partial } - { dv = dv_total; di = di_total; der = der_total; - nv = nv_total; mv = mv_total } - -(* Join two sets of names in a parallel composition. Check that names *) -(* are only defined once. Moreover, reject [der x = ...] and [x = ...] *) -let join loc - { dv = dv1; di = di1; der = der1; nv = nv1; mv = mv1 } - { dv = dv2; di = di2; der = der2; nv = nv2; mv = mv2 } = - let join k names1 names2 = - let joinrec n acc = - if S.mem n names1 then error loc (Ealready(k, n)) else S.add n acc in - S.fold joinrec names2 names1 in - let disjoint k1 k2 names1 names2 = - let disjointrec n = - if S.mem n names1 then - error loc (Ealready_with_different_kinds(k1, k2, n)) in - S.iter disjointrec names2 in - disjoint Current Derivative dv1 der2; - disjoint Current Derivative dv2 der1; - disjoint Next Derivative nv1 der2; - disjoint Next Derivative nv2 der1; - disjoint Multi Derivative mv1 der2; - disjoint Multi Derivative mv2 der1; - { dv = join Current dv1 dv2; di = join Initial di1 di2; - der = join Derivative der1 der2; nv = join Next nv1 nv2; - mv = S.union mv1 mv2 } - -(** Check that every variable defined in an automaton *) -(* has a definition or is a signal or its value can be implicitly kept *) -module Automaton = - struct - let statepatname statepat = - match statepat.desc with - | Estate0pat(n) | Estate1pat(n, _) -> n - - let statename state = - match state.desc with - | Estate0(n) | Estate1(n, _) -> n - - (* build an initial table associating set of names to every state *) - type entry = - { e_loc: location;(* location in the source for the current block *) - mutable e_state: Deftypes.defnames; - (* set of names defined in the current block *) - mutable e_until: Deftypes.defnames; - (* set of names defined in until transitions *) - mutable e_unless: Deftypes.defnames; - (* set of names defined in unless transitions *) - } - - (* the initial state is particular depending on whether or not *) - (* it is only left with a weak transition *) - type table = { t_initial: Zident.t * entry; t_remaining: entry Env.t } - - let table state_handlers = - let add acc { s_state = statepat; s_loc = loc } = - Env.add (statepatname statepat) - { e_loc = loc; - e_state = empty; - e_until = empty; - e_unless = empty } acc in - let { s_state = statepat; s_loc = loc } = List.hd state_handlers in - let remaining_handlers = List.tl state_handlers in - { t_initial = - statepatname statepat, - { e_loc = loc; e_state = empty; e_until = empty; e_unless = empty }; - t_remaining = List.fold_left add Env.empty remaining_handlers } - - let add_state state_name defined_names - { t_initial = (name, entry); t_remaining = rtable } = - let { e_loc = loc; e_unless = trans } as e = - if state_name = name then entry else Env.find state_name rtable in - let _ = add loc defined_names trans in - e.e_state <- defined_names - - let add_transition is_until h state_name defined_names - { t_initial = (name, entry); t_remaining = rtable } = - let {e_loc = loc;e_state = state;e_until = until;e_unless = unless} as e = - if state_name = name then entry else Env.find state_name rtable in - if is_until then - let _ = add loc defined_names state in - e.e_until <- merge loc h [until; defined_names] - else - e.e_unless <- merge loc h [unless; defined_names] - - let check loc h { t_initial = (name, entry); t_remaining = rtable } = - let defined_names_list_in_states = - Env.fold (fun _ { e_state = defined_names } acc -> defined_names :: acc) - rtable [] in - (* check that variables which are defined in some state only are *) - (* either signals or have a last value *) - let defined_names_in_states = - merge loc h (entry.e_state :: defined_names_list_in_states) in - - (* do the same for variables defined in transitions *) - let defined_names_list_in_transitions = - Env.fold - (fun _ { e_until = until; e_unless = unless } acc -> - (add loc until unless) :: acc) - rtable [] in - let defined_names_in_transitions = - merge loc h - ((add loc entry.e_until entry.e_unless) :: - defined_names_list_in_transitions) in - union defined_names_in_states defined_names_in_transitions - - (* check that all states of the automaton are potentially accessible *) - let check_all_states_are_accessible loc state_handlers = - (* the name defined by the state declaration *) - let def_states acc { s_state = spat } = - let statepat { desc = desc } = - match desc with | Estate0pat(n) | Estate1pat(n, _) -> n in - S.add (statepat spat) acc in - - (* the name defined by the call to a state *) - let called_states acc { s_trans = escape_list } = - let sexp { desc = desc } = - match desc with | Estate0(n) | Estate1(n, _) -> n in - let escape acc { e_next_state = se } = S.add (sexp se) acc in - List.fold_left escape acc escape_list in - - (* the initial state is reachable *) - let init_state = def_states S.empty (List.hd state_handlers) in - let called_states = - List.fold_left called_states init_state state_handlers in - let def_states = List.fold_left def_states S.empty state_handlers in - - let unreachable_states = S.diff def_states called_states in - if not (S.is_empty unreachable_states) - then warning loc (Wunreachable_state (S.choose unreachable_states)) - end diff --git a/compiler/typing/typerrors.ml b/compiler/typing/typerrors.ml deleted file mode 100644 index 869165788..000000000 --- a/compiler/typing/typerrors.ml +++ /dev/null @@ -1,303 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* Printing of error messages during typing *) -(* messages are displayed on the standard error output *) - -open Zmisc -open Zident -open Zlocation -open Modules -open Deftypes -open Ptypes -open Format - -type kind_of_global_ident = Value | Type | Constr | Label - -type kind_of_ident = - | Current | Initial | Next | Multi | Derivative - -type error = - | Evar_undefined of Zident.t - | Emissing of Zident.t - | Eglobal_undefined of kind_of_global_ident * Lident.t - | Eglobal_already of kind_of_global_ident * string - | Ealready of kind_of_ident * Zident.t - | Ealready_with_different_kinds of kind_of_ident * kind_of_ident * Zident.t - | Eis_a_value of Zident.t - | Ealready_in_forall of Zident.t - | Einit_undefined of Zident.t - | Elast_forbidden of Zident.t - | Eder_forbidden of Zident.t - | Enext_forbidden of Zident.t - | Eshould_be_a_signal of Zident.t * typ - | Ecannot_be_set of bool * Zident.t - | Etype_clash of typ * typ - | Etype_kind_clash of kind * typ - | Earity_clash of int * int - | Estate_arity_clash of Zident.t * int * int - | Estate_unbound of Zident.t - | Estate_initial - | Ekind_not_combinatorial - | Ekind_clash of kind * kind - | Esome_labels_are_missing - | Eequation_is_missing of Zident.t - | Eglobal_is_a_function of Lident.t - | Eapplication_of_non_function - | Epattern_not_total - | Ecombination_function of Zident.t - | Esize_parameter_must_be_a_name - | Enot_a_size_expression - | Esize_of_vec_is_undetermined - | Esize_clash of size * size - | Esize_parameter_cannot_be_generalized of Zident.t * typ - | Econstr_arity of Lident.t * int * int -exception Error of location * error - -let error loc kind = raise (Error(loc, kind)) - -type warning = - | Wpartial_matching of Zelus.pattern - | Wunreachable_state of Zident.t - | Wmatch_unused of Zelus.pattern - | Wequation_does_not_define_a_name - | Wreset_target_state of bool * bool - -let kind_of_global_ident k = match k with - | Value -> "value" | Type -> "type" - | Constr -> "constructor" | Label -> "label" - -let kind_of_ident k = - match k with - | Current -> "value" - | Derivative -> "derivative" - | Initial -> "initial value" - | Multi -> "multi emitted value" - | Next -> "next value" - -let kind_message kind = - match kind with - | Tstatic _ -> "static" - | Tcont -> "continuous" - | Tany -> "combinatorial" - | Tdiscrete(s) -> if s then "discrete" else "stateless discrete" - | Tproba -> "probabilistic" - -let message loc kind = - begin match kind with - | Evar_undefined(name) -> - eprintf "@[%aTyping error: The value identifier %s is unbound.@.@]" - output_location loc (Zident.source name) - | Emissing(s) -> - eprintf "@[%aType error: no equation is given for name %s.@.@]" - output_location loc - (Zident.source s); - | Eglobal_undefined(k, lname) -> - eprintf "@[%aType error: the global value identifier %s %s is unbound.@.@]" - output_location loc (kind_of_global_ident k) - (Lident.modname lname) - | Eglobal_already(k, s) -> - eprintf "@[%aType error: the %s name %s is already defined.@.@]" - output_location loc (kind_of_global_ident k) s - | Ealready(k, s) -> - let k = kind_of_ident k in - eprintf - "@[%aType error: the %s of %s is defined twice in a parallel branch.@.@]" - output_location loc k (Zident.source s) - | Ealready_with_different_kinds(k1, k2, s) -> - let k1 = kind_of_ident k1 in - let k2 = kind_of_ident k2 in - eprintf - "@[%aType error: %s is defined twice in a parallel branch,@,\ - once with as a %s, once as a %s.@.@]" - output_location loc (Zident.source s) k1 k2 - | Ealready_in_forall(s) -> - eprintf - "@[%aType error: %s is defined twice in a parallel branch.@.@]" - output_location loc (Zident.source s) - | Einit_undefined(s) -> - eprintf "@[%aType error: %s must be initialized in every branch.@.@]" - output_location loc - (Zident.source s) - | Eis_a_value(s) -> - eprintf "@[%aType error: last %s is forbidden as %s is a value.@.@]" - output_location loc - (Zident.source s) (Zident.source s) - | Elast_forbidden(s) -> - eprintf - "@[%aType error: last %s is forbidden. This is either @,\ - because %s is not a state variable or next %s is defined.@.@]" - output_location loc - (Zident.source s) (Zident.source s) (Zident.source s) - | Eder_forbidden(s) -> - eprintf - "@[%aType error: der %s is forbidden because \ - %s is not a state variable.@.@]" - output_location loc - (Zident.source s) (Zident.source s) - | Enext_forbidden(s) -> - eprintf - "@[%aType error: next %s is forbidden. This is either @,\ - because %s is not a state variable or last %s is used.@.@]" - output_location loc - (Zident.source s) (Zident.source s) (Zident.source s) - | Eshould_be_a_signal(s, expected_ty) -> - eprintf "@[%aType error: %s is a value of type %a,@ \ - but is expected to be a signal @,\ - (maybe a default value or initialization is missing).@.@]" - output_location loc - (Zident.source s) - Ptypes.output expected_ty - | Ecannot_be_set(is_next, s) -> - eprintf "@[%aType error: the %s value of %s cannot be set. @,\ - This is either because the %s value is set or @,\ - the last value is used.@.@]" - output_location loc - (if is_next then "next" else "current") - (Zident.source s) - (if is_next then "current" else "next") - | Etype_clash(actual_ty, expected_ty) -> - eprintf "@[%aType error: this expression has type@ %a,@ \ - but is expected to have type@ %a.@.@]" - output_location loc - Ptypes.output actual_ty - Ptypes.output expected_ty - | Etype_kind_clash(k, actual_ty) -> - eprintf "@[%aType error: this expression has type@ %a,@ \ - which does not belong to the %s kind.@.@]" - output_location loc - Ptypes.output actual_ty - (kind_message k) - | Earity_clash(actual_arit, expected_arit) -> - eprintf "@[%aType error: the function expects %d arguments,@ \ - but is given %d arguments.@.@]" - output_location loc - expected_arit actual_arit - | Estate_arity_clash(name, actual_arit, expected_arit) -> - eprintf "@[%aType error: the state %s expects %d arguments,@ \ - but is given %d arguments.@.@]" - output_location loc - (Zident.source name) - expected_arit actual_arit - | Estate_unbound(name) -> - eprintf - "@[%aType error: the state %s is unbound in the current automaton.@.@]" - output_location loc - (Zident.source name) - | Estate_initial -> - eprintf - "@[%aType error: the initial state cannot be parameterized.@.@]" - output_location loc - | Ekind_not_combinatorial -> - eprintf - "@[%aType error: this expression should be combinatorial.@.@]" - output_location loc - | Ekind_clash(actual_kind, expected_kind) -> - eprintf - "@[%aType error: this is a %s expression and is expected to be %s.@.@]" - output_location loc - (kind_message actual_kind) (kind_message expected_kind) - | Esome_labels_are_missing -> - eprintf - "@[%aType error: some fields are missing.@.@]" - output_location loc - | Eequation_is_missing(name) -> - eprintf - "@[%aType error: the variable %s must be defined in an equation.@.@]" - output_location loc - (Zident.source name) - | Eglobal_is_a_function(lname) -> - eprintf "@[%aType error: the global name %s must not be a function.@.@]" - output_location loc - (Lident.modname lname) - | Eapplication_of_non_function -> - eprintf "@[%aType error: this is not a function.@.@]" - output_location loc - | Epattern_not_total -> - eprintf - "@[%aType error: this pattern must be total.@.@]" - output_location loc - | Ecombination_function(n) -> - eprintf - "@[%aType error: a combination function for %s must be given.@.@]" - output_location loc (Zident.source n) - | Esize_parameter_must_be_a_name -> - eprintf - "@[%aType error: the type of the result depend on some variables \ - from this pattern. This pattern must be a variable.@.@]" - output_location loc - | Esize_of_vec_is_undetermined -> - eprintf - "@[%aType error: this expression is either not a vector@ or its \ - size cannot be determined at that point.@.@]" - output_location loc - | Enot_a_size_expression -> - eprintf - "@[%aType error: this is not a valid size expression.@.@]" - output_location loc - | Esize_clash(actual_size, expected_size) -> - eprintf "@[%aType error: this expression is equal to@ %a,@ \ - but is expected to have equal to@ %a.@.@]" - output_location loc - Ptypes.output_size actual_size - Ptypes.output_size expected_size - | Esize_parameter_cannot_be_generalized(n, ty) -> - eprintf - "@[%aType error: this pattern has type@ %a,@ \ - which contains the variable %s that is bounded later or never.@.@]" - output_location loc - Ptypes.output ty - (Zident.name n) - | Econstr_arity(ln, expected_arity, actual_arity) -> - eprintf - "@[%aType error: the type constructor %a expects %d argument(s),@ \ - but is here given %d arguments(s).\n" - output_location loc - Printer.longname ln - expected_arity - actual_arity - end; - raise Zmisc.Error - -let warning loc w = - if not !Zmisc.no_warning then - match w with - | Wpartial_matching(p) -> - Format.eprintf - "@[%aType warning: this pattern-matching is not exhaustive.@.@]" - output_location loc; - Format.eprintf - "@[Here is an example of a value that is not matched:@.%a@.@]" - Printer.pattern p - | Wunreachable_state(s) -> - eprintf - "@[%aType warning: the state %s in this automaton is unreachable.@.@]" - output_location loc - (Zident.source s) - | Wmatch_unused(p) -> - Format.eprintf - "@[Type warning: match case \"%a\" is unused.@.@]" Printer.pattern p - | Wequation_does_not_define_a_name -> - eprintf - "@[%aType warning: this equation does not define a name. \ - This looks like deadcode.@.@]" - output_location loc - | Wreset_target_state(actual_reset, expected_reset) -> - eprintf - "@[%aType warning: the target state is expected to be %s,@,\ - but is entered by %s.@.@]" - output_location loc - (if expected_reset then "reset" else "on history") - (if actual_reset then "reset" else "history") - diff --git a/compiler/typing/typing.ml b/compiler/typing/typing.ml deleted file mode 100644 index be8a61be2..000000000 --- a/compiler/typing/typing.ml +++ /dev/null @@ -1,1395 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* type checking *) - -(* H |-{k} e : t and H, W |-{k} D *) -(* H : typing environment *) -(* D : set of variables written by D *) -(* k : either any, discrete, continuous *) -(* e : expression with type t *) -(* input: H, e, k - output: t, W *) - -open Zident -open Global -open Modules -open Zelus -open Deftypes -open Ztypes -open Typerrors - -(* accesses in symbol tables for global identifiers *) -let find_value loc f = - try find_value f - with Not_found -> error loc (Eglobal_undefined(Value, f)) -let find_type loc f = - try find_type f - with Not_found -> error loc (Eglobal_undefined(Type, f)) -let find_constr loc c = - try find_constr c - with Not_found -> error loc (Eglobal_undefined(Constr, c)) -let find_label loc l = - try find_label l - with Not_found -> error loc (Eglobal_undefined(Label, l)) - - -(** The main unification functions *) -let unify loc expected_ty actual_ty = - try - Ztypes.unify expected_ty actual_ty - with - | Ztypes.Unify -> error loc (Etype_clash(actual_ty, expected_ty)) - -let equal_sizes loc expected_size actual_size = - try - Ztypes.equal_sizes expected_size actual_size - with - | Ztypes.Unify -> error loc (Esize_clash(actual_size, expected_size)) - -let unify_expr expr expected_ty actual_ty = - try - Ztypes.unify expected_ty actual_ty - with - | Ztypes.Unify -> error expr.e_loc (Etype_clash(actual_ty, expected_ty)) - -let unify_pat pat expected_ty actual_ty = - try - Ztypes.unify expected_ty actual_ty - with - | Ztypes.Unify -> error pat.p_loc (Etype_clash(actual_ty, expected_ty)) - -let less_than loc actual_k expected_k = - try - Ztypes.less_than actual_k expected_k - with - | Ztypes.Unify -> error loc (Ekind_clash(actual_k, expected_k)) - -let type_is_in_kind loc expected_k ty = - try - Ztypes.kind expected_k ty - with - | Ztypes.Unify -> error loc (Etype_kind_clash(expected_k, ty)) - -let lift loc left_k right_k = - try - Ztypes.lift left_k right_k - with - | Ztypes.Unify -> error loc (Ekind_clash(right_k, left_k)) - -let sort_less_than loc sort expected_k = - match expected_k, sort with - | Tstatic _, Sstatic -> () - | Tstatic _, _ -> error loc (Ekind_clash(Deftypes.Tany, expected_k)) - | _ -> () - -let check_is_vec loc actual_ty = - try - let ty_arg, size = Ztypes.filter_vec actual_ty in ty_arg, size - with - | Ztypes.Unify -> error loc Esize_of_vec_is_undetermined - -(* An expression is expansive if it is an application *) -let rec expansive { e_desc = desc } = - match desc with - | Elocal _ | Eglobal _ | Econst _ | Econstr0 _ -> false - | Etuple(e_list) -> List.exists expansive e_list - | Erecord(l_e_list) -> List.exists (fun (_, e) -> expansive e) l_e_list - | Erecord_access(e, _) | Etypeconstraint(e, _) -> expansive e - | Erecord_with(e, l_e_list) -> - expansive e || List.exists (fun (_, e) -> expansive e) l_e_list - | _ -> true - -let check_statefull loc expected_k = - if not (Ztypes.is_statefull_kind expected_k) - then error loc Ekind_not_combinatorial - -(** The type of states in automata *) -(** We emit a warning when a state is entered both by reset and history *) -type state = { mutable s_reset: bool option; s_parameters: typ list } - -let check_target_state loc expected_reset actual_reset = - match expected_reset with - | None -> Some(actual_reset) - | Some(expected_reset) -> - if expected_reset <> actual_reset then - warning loc (Wreset_target_state(actual_reset, expected_reset)); - Some(expected_reset) - -(* Every shared variable defined in the initial state of an automaton *) -(* left weakly is considered to be an initialized state variable. *) -let turn_vars_into_memories h { dv = dv } = - let add n acc = - let ({ t_sort = sort; t_typ = typ } as tentry) = Env.find n h in - match sort with - | Smem({ m_init = Noinit } as m) -> - Env.add n { tentry with t_sort = Smem { m with m_init = InitEq } } acc - | Sstatic | Sval | Svar _ | Smem _ -> acc in - let first_h = S.fold add dv Env.empty in - first_h, Env.append first_h h - -(** Typing immediate values *) -let immediate = function - | Ebool _ -> Initial.typ_bool - | Eint(i) -> Initial.typ_int - | Efloat(i) -> Initial.typ_float - | Echar(c) -> Initial.typ_char - | Estring(c) -> Initial.typ_string - | Evoid -> Initial.typ_unit - -(* once all branch of the automaton has been typed *) -(* incorporate the information computed about variables from *) -(* the initial environment into the global one *) -let incorporate_into_env first_h h = - let mark n { t_sort = sort } = - let tentry = Env.find n h in - match sort with - | Smem({ m_init = InitEq } as m) -> - tentry.t_sort <- Smem { m with m_init = Noinit } - | _ -> () in - Env.iter mark first_h - -(** Variables in a pattern *) -let vars pat = Vars.fv_pat S.empty S.empty pat - -(** Types for local identifiers *) -let var loc h n = - try Env.find n h - with Not_found -> error loc (Evar_undefined(n)) - -let typ_of_var loc h n = let { t_typ = typ } = var loc h n in typ - -(* Typing [last n] *) -let last loc h n = - let { t_sort = sort; t_typ = typ } as entry = var loc h n in - (* [last n] is allowed only if [n] is a state variable *) - begin match sort with - | Sstatic | Sval | Svar _ | Smem { m_next = Some(true) } -> - error loc (Elast_forbidden(n)) - | Smem (m) -> - entry.t_sort <- Smem { m with m_previous = true } - end; typ - -(* Typing [der n = ...] *) -let derivative loc h n = - let { t_typ = typ; t_sort = sort } as entry = var loc h n in - (* [der n] is allowed only if [n] is a state variable *) - match sort with - | Sstatic | Sval | Svar _ -> - error loc (Eder_forbidden(n)) - | Smem(m) -> entry.t_sort <- Smem { m with m_kind = Some(Cont) }; typ - -(* Typing [n += ...] *) -let pluseq loc h n = - (* check that a name [n] is declared with a combination function *) - let ({ t_typ = typ; t_sort = sort } as entry) = var loc h n in - match sort with - | Svar { v_combine = Some _ } -> typ - | Sstatic | Sval | Svar { v_combine = None } | Smem { m_combine = None } -> - error loc (Ecombination_function(n)) - | Smem ({ m_next = n_opt } as m) -> - match n_opt with - | None -> entry.t_sort <- Smem { m with m_next = Some(false) }; typ - | Some(false) -> typ - | Some(true) -> error loc (Ealready_with_different_kinds(Next, Multi, n)) - -(* Typing [init n = ...] *) -let init loc h n = - (* set that [n] is initialized if it is not already at the definition point *) - let { t_typ = typ; t_sort = sort } as entry = var loc h n in - match sort with - | Sstatic | Sval | Svar _ -> assert false - | Smem ({ m_init = i } as m) -> - match i with - | Noinit -> entry.t_sort <- Smem { m with m_init = InitEq }; typ - | InitEq -> typ - | InitDecl _ -> error loc (Ealready(Initial, n)) - -(* Typing [next n = ...] *) -let next loc h n = - let { t_typ = typ; t_sort = sort } as entry = var loc h n in - match sort with - | Sstatic | Sval | Svar _ -> assert false - | Smem { m_previous = true } -> error loc (Enext_forbidden(n)) - | Smem ({ m_next = n_opt } as m) -> - match n_opt with - | None -> entry.t_sort <- Smem { m with m_next = Some(true) }; typ - | Some(true) -> typ - | Some(false) -> - error loc (Ealready_with_different_kinds(Current, Next, n)) - -(* Typing [n = ...] *) -let def loc h n = - let { t_sort = sort } as entry = var loc h n in - match sort with - | Sstatic | Sval | Svar _ -> () - | Smem ({ m_next = n_opt } as m) -> - match n_opt with - | None -> entry.t_sort <- Smem { m with m_next = Some(false) } - | Some(false) -> () - | Some(true) -> - error loc (Ealready_with_different_kinds(Next, Current, n)) - -(** Types for global identifiers *) -let global loc expected_k lname = - let { qualid = qualid; - info = { value_static = is_static; - value_typ = tys } } = find_value loc lname in - less_than loc (if is_static then Tstatic true else expected_k) expected_k; - qualid, Ztypes.instance_of_type tys - -let global_with_instance loc expected_k lname = - let { qualid = qualid; - info = { value_static = is_static; - value_typ = tys } } = find_value loc lname in - less_than loc (if is_static then Tstatic true else expected_k) expected_k; - let typ_instance, typ_body = Ztypes.instance_and_vars_of_type tys in - qualid, typ_instance, typ_body - -let label loc l = - let { qualid = qualid; info = tys_label } = find_label loc l in - qualid, Ztypes.label_instance tys_label - -let constr loc c = - let { qualid = qualid; info = tys_c } = find_constr loc c in - qualid, Ztypes.constr_instance tys_c - -let rec get_all_labels loc ty = - match ty.t_desc with - | Tconstr(qual, _, _) -> - let { info = { type_desc = ty_c } } = - find_type loc (Lident.Modname(qual)) in - begin match ty_c with - Record_type(l) -> l - | _ -> assert false - end - | Tlink(link) -> get_all_labels loc link - | _ -> assert false - -(** Check that every declared name is associated to a *) -(** defining equation and that an initialized state variable is *) -(** not initialized again in the body *) -(** Returns a new [defined_names] where names from [n_list] *) -(** have been removed *) -let check_definitions_for_every_name defined_names n_list = - List.fold_left - (fun { dv = dv; di = di; der = der; nv = nv; mv = mv } - { vardec_name = n; vardec_default = d_opt; vardec_loc = loc } -> - let in_dv = S.mem n dv in - let in_di = S.mem n di in - let in_der = S.mem n der in - let in_nv = S.mem n nv in - let in_mv = S.mem n mv in - (* check that n is defined by an equation *) - if not (in_dv || in_di || in_der || in_nv || in_mv) - then error loc (Eequation_is_missing(n)); - (* remove local names *) - { dv = if in_dv then S.remove n dv else dv; - di = if in_di then S.remove n di else di; - der = if in_der then S.remove n der else der; - nv = if in_nv then S.remove n nv else nv; - mv = if in_mv then S.remove n mv else mv }) - defined_names n_list - -(** Typing a declaration *) - -(* type checking of the combination function *) -let combine loc expected_ty lname = - let { qualid = qualid; info = { value_typ = tys } } = - find_value loc lname in - let ty = Ztypes.instance_of_type tys in - (* Its signature must be [expected_ty * expected_ty -A-> expected_ty] *) - let ty_combine = Ztypes.type_of_combine () in - unify loc ty_combine ty - -(* type checking of the declared default/init value *) -let constant loc expected_k expected_ty = function - | Cimmediate(i) -> - let actual_ty = immediate(i) in - unify loc expected_ty actual_ty - | Cglobal(lname) -> - let qualid, actual_ty = global loc expected_k lname in - unify loc expected_ty actual_ty - -(* Typing the declaration of variables. The result is a typing environment *) -(* [inames] is the set of initialized variables, that is, variable *) -(* which appear in an [init x = e] equation *) -let vardec_list expected_k n_list inames = - let default loc expected_ty c_opt = function - | Init(v) -> - (* the initialization must appear in a statefull function *) - if not (Ztypes.is_statefull_kind expected_k) - then error loc Ekind_not_combinatorial; - constant loc expected_k expected_ty v; - Deftypes.Smem - (Deftypes.cmem c_opt { empty_mem with m_init = InitDecl(v) }) - | Default(v) -> - constant loc expected_k expected_ty v; - Deftypes.default (Some(v)) c_opt in - (* typing every declaration *) - let vardec h0 - { vardec_name = n; vardec_default = d_opt; vardec_combine = c_opt; - vardec_loc = loc } = - let expected_ty = Ztypes.new_var () in - Zmisc.optional_unit (combine loc) expected_ty c_opt; - let sort = - match d_opt with - | Some(d) -> default loc expected_ty c_opt d - | None -> - match expected_k with - | Tstatic _ -> Deftypes.static - | Tany | Tdiscrete false -> Deftypes.default None c_opt - | Tdiscrete true - | Tcont - | Tproba -> - Deftypes.Smem (Deftypes.cmem c_opt - (if S.mem n inames then Deftypes.imem - else Deftypes.empty_mem)) in - Env.add n { t_typ = expected_ty; t_sort = sort } h0 in - List.fold_left vardec Env.empty n_list - -(** Computes the set of names defined in a list of definitions *) -let rec build (names, inames) { eq_desc = desc } = - (* block *) - let block_with_bounded (names, inames) - { b_vars = b_vars; b_body = eq_list } = - let vardec acc { vardec_name = n } = S.add n acc in - let bounded = List.fold_left vardec S.empty b_vars in - let (local_names, local_inames) = build_list (S.empty, S.empty) eq_list in - bounded, (S.union names (S.diff local_names bounded), - S.union inames (S.diff local_inames bounded)) in - let block (names, inames) b = snd (block_with_bounded (names, inames) b) in - match desc with - | EQeq(p, _) -> Vars.fv_pat S.empty names p, inames - | EQder(n, _, _, _) - | EQpluseq(n, _) | EQnext(n, _, _) - | EQemit(n, _) -> S.add n names, inames - | EQinit(n, _) -> S.add n names, S.add n inames - | EQreset(eq_list, _) - | EQand(eq_list) - | EQbefore(eq_list) -> build_list (names, inames) eq_list - | EQblock(b) -> block (names, inames) b - | EQpresent(ph_list, b_opt) -> - (* present handler *) - let handler (names, inames) { p_body = b } = block (names, inames) b in - let names, inames = - List.fold_left handler (names, inames) ph_list in - Zmisc.optional block (names, inames) b_opt - | EQmatch(_, _, mh_list) -> - (* match handler *) - let handler (names, inames) { m_body = b } = block (names, inames) b in - List.fold_left handler (names, inames) mh_list - | EQautomaton(is_weak, sh_list, _) -> - (* escape handler *) - let escape (names, inames) { e_block = b_opt } = - Zmisc.optional block (names, inames) b_opt in - (* automaton handler *) - let handler (names, inames) { s_body = b; s_trans = esc_list } = - let bounded, (names, inames) = - block_with_bounded (names, inames) b in - let esc_names, esc_inames = - List.fold_left escape (names, inames) esc_list in - S.union names (if is_weak then S.diff esc_names bounded else esc_names), - S.union inames - (if is_weak then S.diff esc_inames bounded else esc_inames) - in - List.fold_left handler (names, inames) sh_list - | EQforall { for_index = in_list; for_init = init_list } -> - let index (names, inames) { desc = desc } = - match desc with - | Einput _ | Eindex _ -> names, inames - | Eoutput(_, n) -> S.add n names, inames in - let init (names, inames) { desc = desc } = - match desc with - | Einit_last(n, _) -> S.add n names, inames in - let names, inames = List.fold_left index (names, inames) in_list in - List.fold_left init (names, inames) init_list - -and build_list (names, inames) eq_list = - List.fold_left build (names, inames) eq_list - -let env_of_eq_list expected_k eq_list = - let names, inames = build_list (S.empty, S.empty) eq_list in - S.fold - (fun n acc -> - let sort = - match expected_k with - | Deftypes.Tstatic _ -> Deftypes.static - | Deftypes.Tany | Deftypes.Tdiscrete false -> Deftypes.variable - | Deftypes.Tcont - | Deftypes.Tdiscrete true - | Deftypes.Tproba -> - if S.mem n inames then Deftypes.imemory - else Deftypes.Smem (Deftypes.empty_mem) in - Env.add n { t_typ = Ztypes.new_var (); t_sort = sort } acc) names Env.empty - -(* introduce a variable with the proper kind *) -(* [last x] is only be possible when [expected_k] is statefull *) -let intro_sort_of_var expected_k = - match expected_k with - | Deftypes.Tstatic _ -> Deftypes.static - | Deftypes.Tany | Deftypes.Tdiscrete false -> Deftypes.Sval - | Deftypes. Tcont - | Deftypes.Tdiscrete true - | Deftypes.Tproba -> Deftypes.Smem (Deftypes.empty_mem) - -let env_of_scondpat expected_k scpat = - let rec env_of acc { desc = desc } = - match desc with - | Econdand(sc1, sc2) -> env_of (env_of acc sc1) sc2 - | Econdor(sc, _) | Econdon(sc, _) -> env_of acc sc - | Econdexp _ -> acc - | Econdpat(_, pat) -> Vars.fv_pat S.empty acc pat in - let acc = env_of S.empty scpat in - S.fold - (fun n acc -> - Env.add n - { t_typ = Ztypes.new_var (); t_sort = intro_sort_of_var expected_k } acc) - acc Env.empty - -let env_of_statepat expected_k spat = - let rec env_of acc { desc = desc } = - match desc with - | Estate0pat _ -> acc - | Estate1pat(_, l) -> List.fold_left (fun acc n -> S.add n acc) acc l in - let acc = env_of S.empty spat in - S.fold - (fun n acc -> - Env.add n - { t_typ = Ztypes.new_var (); t_sort = intro_sort_of_var expected_k } acc) - acc Env.empty - -let env_of_pattern expected_k h0 pat = - let acc = Vars.fv_pat S.empty S.empty pat in - S.fold - (fun n acc -> - Env.add n - { t_typ = Ztypes.new_var (); t_sort = intro_sort_of_var expected_k } acc) - acc h0 - -(* the [n-1] first arguments are static. If [expected_k] is static *) -(* the last one too *) -let env_of_pattern_list expected_k env p_list = - let p_list, p = Zmisc.firsts p_list in - let env = List.fold_left (env_of_pattern (Deftypes.Tstatic true)) env p_list in - env_of_pattern expected_k env p - -let env_of_pattern expected_k pat = env_of_pattern expected_k Env.empty pat - -(** Typing patterns *) -(* the kind of variables in [p] must be equal to [expected_k] *) -let rec pattern h ({ p_desc = desc; p_loc = loc } as pat) ty = - match desc with - | Ewildpat -> - (* type annotation *) - pat.p_typ <- ty - | Econstpat(im) -> - unify_pat pat ty (immediate im); - (* type annotation *) - pat.p_typ <- ty - | Econstr0pat(c0) -> - let qualid, { constr_res = ty_res; constr_arity = n } = constr loc c0 in - (* check the arity *) - if n <> 0 then error loc (Econstr_arity(c0, n, 0)); - unify_pat pat ty ty_res; - pat.p_desc <- Econstr0pat(Lident.Modname(qualid)); - (* type annotation *) - pat.p_typ <- ty - | Econstr1pat(c1, pat_list) -> - let qualid, - { constr_arg = ty_list; constr_res = ty_res; constr_arity = n } = - constr loc c1 in - (* check the arity *) - let actual_n = List.length pat_list in - if n <> actual_n then error loc (Econstr_arity(c1, n, actual_n)); - unify_pat pat ty ty_res; - pat.p_desc <- Econstr1pat(Lident.Modname(qualid), pat_list); - (* type annotation *) - pat.p_typ <- ty; - List.iter2 (pattern h) pat_list ty_list - | Evarpat(x) -> - unify_pat pat ty (typ_of_var loc h x); - (* type annotation *) - pat.p_typ <- ty - | Etuplepat(pat_list) -> - let ty_list = List.map (fun _ -> new_var ()) pat_list in - unify_pat pat ty (product ty_list); - (* type annotation *) - pat.p_typ <- ty; - List.iter2 (pattern h) pat_list ty_list - | Etypeconstraintpat(p, typ_expr) -> - let expected_typ = - Ztypes.instance_of_type(Interface.scheme_of_type typ_expr) in - unify_pat pat expected_typ ty; - (* type annotation *) - pat.p_typ <- ty; - pattern h p ty - | Erecordpat(label_pat_list) -> - (* type annotation *) - pat.p_typ <- ty; - let label_pat_list = - List.map - (fun (lab, pat_label) -> - let qualid, { label_arg = ty_arg; label_res = ty_res } = - label pat.p_loc lab in - unify_pat pat_label ty ty_arg; - pattern h pat_label ty_res; - Lident.Modname(qualid), pat_label) label_pat_list in - pat.p_desc <- Erecordpat(label_pat_list) - | Ealiaspat(p, x) -> - unify_pat pat ty (typ_of_var loc h x); - (* type annotation *) - pat.p_typ <- ty; - pattern h p ty - | Eorpat(p1, p2) -> - (* type annotation *) - pat.p_typ <- ty; - pattern h p1 ty; - pattern h p2 ty - -(* typing a list of patterns. The first [n-1] patterns define static *) -(* values; the [n]-th one has no constraint *) -let pattern_list h pat_list ty_list = List.iter2 (pattern h) pat_list ty_list - -(* check that a pattern is total *) -let check_total_pattern p = - let is_exhaustive = Patternsig.check_activate p.p_loc p in - if not is_exhaustive then error p.p_loc Epattern_not_total - -let check_total_pattern_list p_list = List.iter check_total_pattern p_list - -(** Typing a pattern matching. Returns defined names *) -let match_handlers body loc expected_k h total m_handlers pat_ty ty = - let handler ({ m_pat = pat; m_body = b } as mh) = - let h0 = env_of_pattern expected_k pat in - pattern h0 pat pat_ty; - mh.m_env <- h0; - let h = Env.append h0 h in - body expected_k h b ty in - let defined_names_list = List.map handler m_handlers in - (* check partiality/redundancy of the pattern matching *) - - let is_exhaustive = - !total || (Patternsig.check_match_handlers loc m_handlers) in - - let defined_names_list = - if is_exhaustive then defined_names_list - else Deftypes.empty :: defined_names_list in - (* set total to the right value *) - total := is_exhaustive; - (* identify variables which are defined partially *) - Total.merge loc h defined_names_list - -(** Typing a present handler. Returns defined names *) -(** for every branch the expected kind is discrete. For the default case *) -(** it is the kind of the context. *) -let present_handlers scondpat body loc expected_k h p_h_list b_opt expected_ty = - let handler ({ p_cond = scpat; p_body = b } as ph) = - (* local variables from [scpat] cannot be accessed through a last *) - let h0 = env_of_scondpat expected_k scpat in - let h = Env.append h0 h in - let is_zero = Ztypes.is_continuous_kind expected_k in - scondpat expected_k is_zero h scpat; - (* sets [zero = true] is [expected_k = Tcont] *) - ph.p_zero <- is_zero; - ph.p_env <- h0; - body (Ztypes.lift_to_discrete expected_k) h b expected_ty in - - let defined_names_list = List.map handler p_h_list in - - (* treat the optional default case *) - let defined_names_list = - match b_opt with - | None -> Deftypes.empty :: defined_names_list - | Some(b) -> let defined_names = body expected_k h b expected_ty in - defined_names :: defined_names_list in - - (* identify variables which are defined partially *) - Total.merge loc h defined_names_list - - -(* [expression expected_k h e] returns the type for [e] *) -let rec expression expected_k h ({ e_desc = desc; e_loc = loc } as e) = - let ty = match desc with - | Econst(i) -> immediate i - | Elocal(x) -> - let { t_typ = typ; t_sort = sort } = var loc h x in - sort_less_than loc sort expected_k; - typ - | Eglobal { lname = lname } -> - let qualid, typ_instance, ty = - global_with_instance loc expected_k lname in - e.e_desc <- Eglobal { lname = Lident.Modname(qualid); - typ_instance = typ_instance }; ty - | Elast(x) -> last loc h x - | Etuple(e_list) -> - product (List.map (expression expected_k h) e_list) - | Eop(Eaccess, [e1; e2]) -> - (* Special typing for [e1.(e2)]. [e1] must be of type [ty[size]] *) - (* with [size] a known expression at that point *) - let ty = expression expected_k h e1 in - let ty_arg, _ = check_is_vec e1.e_loc ty in - expect expected_k h e2 Initial.typ_int; ty_arg - | Eop(Eupdate, [e1; i; e2]) -> - (* Special typing for [{ e1 with (i) = e2 }]. *) - (* [e1] must be of type [ty[size]] *) - (* with [size] a known expression at that point *) - let ty = expression expected_k h e1 in - let ty_arg,_ = check_is_vec e1.e_loc ty in - expect expected_k h i Initial.typ_int; - expect expected_k h e2 ty_arg; ty - | Eop(Eslice(s1, s2), [e]) -> - (* Special typing for [e{ e1 .. e2}] *) - (* [e1] and [e2] must be size expressions *) - let s1 = size h s1 in - let s2 = size h s2 in - let ty = expression expected_k h e in - let ty_arg, _ = check_is_vec e.e_loc ty in - Ztypes.vec ty_arg (Ztypes.plus (Ztypes.minus s2 s1) (Ztypes.const 1)) - | Eop(Econcat, [e1; e2]) -> - let ty1 = expression expected_k h e1 in - let ty_arg1, s1 = check_is_vec e1.e_loc ty1 in - let ty2 = expression expected_k h e2 in - let ty_arg2, s2 = check_is_vec e2.e_loc ty2 in - unify_expr e2 ty_arg1 ty_arg2; - Ztypes.vec ty_arg1 (Ztypes.plus s1 s2) - | Eop(op, e_list) -> - operator expected_k h loc op e_list - | Eapp({ app_statefull = is_statefull }, e, e_list) -> - apply loc is_statefull expected_k h e e_list - | Econstr0(c0) -> - let qualid, { constr_res = ty_res; constr_arity = n } = - constr loc c0 in - if n <> 0 then error loc (Econstr_arity(c0, n, 0)); - e.e_desc <- Econstr0(Lident.Modname(qualid)); ty_res - | Econstr1(c1, e_list) -> - let qualid, - { constr_arg = ty_list; constr_res = ty_res; constr_arity = n } = - constr loc c1 in - let actual_arity = List.length e_list in - if n <> actual_arity then - error loc (Econstr_arity(c1, n, actual_arity)); - List.iter2 (expect expected_k h) e_list ty_list; - e.e_desc <- Econstr1(Lident.Modname(qualid), e_list); ty_res - | Erecord_access(e1, lab) -> - let qualid, { label_arg = ty_arg; label_res = ty_res } = - label loc lab in - expect expected_k h e1 ty_arg; - e.e_desc <- Erecord_access(e1, Lident.Modname(qualid)); ty_res - | Erecord(label_e_list) -> - let ty = new_var () in - let label_e_list = - List.map - (fun (lab, e_label) -> - let qualid, { label_arg = ty_arg; label_res = ty_res } = - label loc lab in - unify_expr e ty ty_arg; - expect expected_k h e_label ty_res; - (Lident.Modname(qualid), e_label)) label_e_list in - e.e_desc <- Erecord(label_e_list); - (* check that no field is missing *) - let label_desc_list = get_all_labels loc ty in - if List.length label_e_list <> List.length label_desc_list - then error loc Esome_labels_are_missing; - ty - | Erecord_with(e1, label_e_list) -> - let ty = new_var () in - let label_e_list = - List.map - (fun (lab, e_label) -> - let qualid, { label_arg = ty_arg; label_res = ty_res } = - label loc lab in - unify_expr e ty ty_arg; - expect expected_k h e_label ty_res; - (Lident.Modname(qualid), e_label)) label_e_list in - expect expected_k h e1 ty; - e.e_desc <- Erecord_with(e1, label_e_list); - ty - | Etypeconstraint(exp, typ_expr) -> - let expected_typ = - Ztypes.instance_of_type (Interface.scheme_of_type typ_expr) in - expect expected_k h exp expected_typ; - expected_typ - | Elet(l, e) -> - let h = local expected_k h l in - expression expected_k h e - | Eblock(b, e) -> - let h, _ = block_eq_list expected_k h b in - expression expected_k h e - | Eseq(e1, e2) -> - ignore (expression expected_k h e1); - expression expected_k h e2 - | Eperiod(p) -> - (* periods are only valid in a continuous context *) - less_than loc Tcont expected_k; - (* a period must be a static expression *) - period (Tstatic(true)) h p; - Ztypes.zero_type expected_k - | Ematch(total, e, m_h_list) -> - let expected_pat_ty = expression expected_k h e in - let expected_ty = new_var () in - ignore - (match_handler_exp_list - loc expected_k h total m_h_list expected_pat_ty expected_ty); - expected_ty - | Epresent(p_h_list, e_opt) -> - let expected_ty = new_var () in - ignore - (present_handler_exp_list loc expected_k h p_h_list e_opt expected_ty); - expected_ty in - (* check that ty belongs to kind expected_k *) - type_is_in_kind loc expected_k ty; - (* type annotation *) - e.e_typ <- ty; - ty - -(** Typing a size expression *) -and size h { desc = desc; loc = loc } = - match desc with - | Sconst(i) -> Ztypes.const i - | Sglobal(ln) -> - let qualid, _, typ_body = global_with_instance loc (Tstatic(true)) ln in - unify loc Initial.typ_int typ_body; - Ztypes.global(qualid) - | Sname(x) -> - let { t_typ = typ; t_sort = sort } = var loc h x in - sort_less_than loc sort (Tstatic(true)); - unify loc Initial.typ_int typ; - Ztypes.name x - | Sop(Splus, s1, s2) -> - let s1 = size h s1 in - let s2 = size h s2 in - Ztypes.plus s1 s2 - | Sop(Sminus, s1, s2) -> - let s1 = size h s1 in - let s2 = size h s2 in - Ztypes.minus s1 s2 - - -(** Convert an expression into a size expression *) -and size_of_exp { e_desc = desc; e_loc = loc } = - match desc with - | Econst(Eint(i)) -> Tconst(i) - | Elocal(n) -> Tname(n) - | Eglobal { lname = Lident.Modname(qualid) } -> Tglobal(qualid) - | Eapp(_, { e_desc = Eglobal { lname = Lident.Modname(qualid) } }, [e1; e2]) - when qualid = Initial.stdlib_name "+" -> - Top(Tplus, size_of_exp e1, size_of_exp e2) - | Eapp(_, { e_desc = Eglobal { lname = Lident.Modname(qualid) } }, [e1; e2]) - when qualid = Initial.stdlib_name "-" -> - Top(Tminus, size_of_exp e1, size_of_exp e2) - | _ -> error loc Enot_a_size_expression - -(** The type of primitives and imported functions *) -and operator expected_k h loc op e_list = - let actual_k, ty_args, ty_res = - match op with - | Eifthenelse -> - let ty = new_var () in - Tany, [Initial.typ_bool; ty; ty], ty - | Eunarypre -> - let ty = new_var () in - Tdiscrete(true), [ty], ty - | (Eminusgreater | Efby) -> - let ty = new_var () in - Tdiscrete(true), [ty; ty], ty - | (Eup | Ehorizon) -> - Tcont, [Initial.typ_float], Initial.typ_zero - | Etest -> - let ty = new_var () in - Tany, [Initial.typ_signal ty], Initial.typ_bool - | Edisc -> - let ty = new_var () in - Tcont, [ty], Initial.typ_zero - | Einitial -> - Tcont, [], Initial.typ_zero - | Eatomic -> - let ty = new_var () in - expected_k, [ty], ty - | Eaccess | Eupdate | Eslice _ | Econcat -> assert false in - less_than loc actual_k expected_k; - List.iter2 (expect expected_k h) e_list ty_args; - ty_res - - -and period expected_k h { p_phase = p1_opt; p_period = p2 } = - expect expected_k h p2 Initial.typ_float; - match p1_opt with None -> () | Some(p1) -> expect expected_k h p1 Initial.typ_float - -(** Typing an expression with expected type [expected_type] *) -and expect expected_k h e expected_ty = - let actual_ty = expression expected_k h e in - unify_expr e expected_ty actual_ty - -and apply loc is_statefull expected_k h e arg_list = - (* the function [e] must be static *) - let ty_fct = expression (Tstatic(true)) h e in - (* [run f e] forces [f] to be of type [t1 -expected_k-> t2] *) - (* and [k] to be either [D] or [C] *) - if is_statefull then - begin - check_statefull loc expected_k; - unify_expr e (Ztypes.run_type expected_k) ty_fct - end; - let intro_k = Ztypes.intro expected_k in - (* typing the list of arguments *) - (* the [n-1] arguments must be static; the [nth] is of kind [expected_k] *) - let rec args ty_fct = function - | [] -> ty_fct - | arg :: arg_list -> - let actual_k, n_opt, ty1, ty2 = - try Ztypes.filter_arrow intro_k ty_fct - with Unify -> error loc (Eapplication_of_non_function) in - let expected_k = lift loc expected_k actual_k in - expect expected_k h arg ty1; - let ty2 = - match n_opt with - | None -> ty2 - | Some(n) -> subst_in_type (Env.singleton n (size_of_exp arg)) ty2 in - args ty2 arg_list in - args ty_fct arg_list - -(** Typing an equation. Returns the set of defined names *) -and equation expected_k h ({ eq_desc = desc; eq_loc = loc } as eq) = - let defnames = match desc with - | EQeq(p, e) -> - let ty_e = expression expected_k h e in - pattern h p ty_e; - (* check that the pattern is total *) - check_total_pattern p; - let dv = vars p in - S.iter (def loc h) dv; - { Deftypes.empty with dv = dv } - | EQpluseq(n, e) -> - let actual_ty = expression expected_k h e in - let expected_ty = pluseq loc h n in - unify loc expected_ty actual_ty; - { Deftypes.empty with mv = S.singleton n } - | EQinit(n, e0) -> - (* an initialization is valid only in a continuous or discrete context *) - check_statefull loc expected_k; - let actual_ty = init loc h n in - expect (Ztypes.lift_to_discrete expected_k) h e0 actual_ty; - (* sets that every variable from [di] is initialized *) - { Deftypes.empty with di = S.singleton n } - | EQnext(n, e, e0_opt) -> - (* a next is valid only in a discrete context *) - less_than loc (Tdiscrete(true)) expected_k; - let actual_ty = next loc h n in - expect expected_k h e actual_ty; - let di = - match e0_opt with - | None -> S.empty - | Some(e) -> - expect expected_k h e actual_ty; ignore (init loc h n); - S.singleton n - in - { Deftypes.empty with nv = S.singleton n; di = di } - | EQder(n, e, e0_opt, p_h_e_list) -> - (* integration is only valid in a continuous context *) - less_than loc Tcont expected_k; - let actual_ty = derivative loc h n in - unify loc Initial.typ_float actual_ty; - expect expected_k h e actual_ty; - let di = - match e0_opt with - | None -> S.empty - | Some(e) -> - expect (Ztypes.lift_to_discrete expected_k) h e Initial.typ_float; - ignore (init loc h n); S.singleton n in - ignore (present_handler_exp_list - loc expected_k h p_h_e_list None Initial.typ_float); - { Deftypes.empty with di = di; der = S.singleton n } - | EQautomaton(is_weak, s_h_list, se_opt) -> - (* automata are only valid in continuous or discrete context *) - check_statefull loc expected_k; - automaton_handlers is_weak loc expected_k h s_h_list se_opt - | EQmatch(total, e, m_h_list) -> - let expected_pat_ty = expression expected_k h e in - match_handler_block_eq_list - loc expected_k h total m_h_list expected_pat_ty - | EQpresent(p_h_list, b_opt) -> - present_handler_block_eq_list loc expected_k h p_h_list b_opt - | EQreset(eq_list, e) -> - expect expected_k h e (Ztypes.zero_type expected_k); - equation_list expected_k h eq_list - | EQand(eq_list) - | EQbefore(eq_list) -> equation_list expected_k h eq_list - | EQemit(n, e_opt) -> - less_than loc expected_k (Ztypes.lift_to_discrete expected_k); - let ty_e = new_var () in - let ty_name = typ_of_var loc h n in - begin match e_opt with - | None -> unify loc (Initial.typ_signal Initial.typ_unit) ty_name - | Some(e) -> - unify loc (Initial.typ_signal ty_e) ty_name; - expect expected_k h e ty_e - end; - { Deftypes.empty with dv = S.singleton n } - | EQblock(b_eq_list) -> - snd (block_eq_list expected_k h b_eq_list) - | EQforall - ({ for_index = i_list; for_init = init_list; for_body = b_eq_list } - as body) -> - (* all output variables [xi] such that [xi ou x] *) - (* must have a declaration in the body *) - (* A non local variable [xi] defined in the body of the loop must be *) - (* either declared in the initialization part [initialize ...] *) - (* or used to define an output array [xi out x] *) - (* returns a new set [{ dv; di; der; nv; mv }] *) - (* where [xi] is replaced by [x] *) - let merge ({ dv = dv; di = di; der = der; nv = nv; mv = mv } as defnames) - h init_h out_h xi_out_x = - (* check that all names in [out_h] are defined in defnames *) - let out_set = Env.fold (fun x _ acc -> S.add x acc) out_h S.empty in - let out_not_defined = - S.diff out_set (Deftypes.names S.empty defnames) in - if not (S.is_empty out_not_defined) - then error loc (Eequation_is_missing(S.choose out_not_defined)); - (* rename [xi] into [x] if [xi out x] appears in [xi_out_x] *) - let x_of_xi xi = - try Env.find xi xi_out_x with Not_found -> xi in - let out xi acc = - try S.add (Env.find xi xi_out_x) acc with Not_found -> acc in - (* all variables in [dv], [der] must appear either *) - (* in [init_h] or [out_h] or as combined variables in [h] *) - (* all variables in [di] must appear in [out_h] and not in [init_h] *) - let belong_to_init_out xi = - if not ((Env.mem xi init_h) || (Env.mem xi out_h)) - then error loc (Ealready_in_forall(xi)) in - let belong_to_out_not_init xi = - if not (Env.mem xi out_h) || (Env.mem xi init_h) - then error loc (Ealready_in_forall(xi)) in - S.iter belong_to_init_out dv; - S.iter belong_to_init_out nv; - S.iter belong_to_init_out der; - S.iter belong_to_out_not_init di; - (* change the sort of [x] so that it is equal to that of [xi] *) - S.iter (def loc h) (S.fold out dv S.empty); - S.iter (fun n -> ignore (init loc h n)) (S.fold out di S.empty); - S.iter - (fun n -> ignore (derivative loc h n)) (S.fold out der S.empty); - - (* all name [xi] from [defnames] such that [xi out x] *) - (* is replaced by [x] in the new [defnames] *) - { dv = S.map x_of_xi dv; di = S.map x_of_xi di; - der = S.map x_of_xi der; nv = S.map x_of_xi nv; - mv = S.map x_of_xi mv } in - - (* outputs are either shared or state variables *) - let sort = if Ztypes.is_statefull_kind expected_k - then Deftypes.Smem Deftypes.empty_mem - else Deftypes.variable in - - (* bounds for loops must be static *) - (* computes the set of array names returned by the loop *) - (* declarations are red from left to right. For [i in e0..e1], *) - (* compute the size [(e1 - e0) + 1)] for the arrays *) - let index (in_h, out_h, xi_out_x, size_opt) - { desc = desc; loc = loc } = - let size_of loc size_opt = - match size_opt with - | None -> error loc Esize_of_vec_is_undetermined - | Some(actual_size) -> actual_size in - match desc with - | Einput(xi, e) -> - let ty = Ztypes.new_var () in - let si = size_of loc size_opt in - expect Tany h e (Ztypes.vec ty si); - Env.add xi { t_typ = ty; t_sort = Sval } in_h, - out_h, xi_out_x, size_opt - | Eoutput(xi, x) -> - let ty_xi = Ztypes.new_var () in - let ty_x = typ_of_var loc h x in - let si = size_of loc size_opt in - unify loc (Ztypes.vec ty_xi si) ty_x; - in_h, Env.add xi { t_typ = ty_xi; t_sort = sort } out_h, - Env.add xi x xi_out_x, size_opt - | Eindex(i, e0, e1) -> - expect (Tstatic(true)) h e0 Initial.typ_int; - expect (Tstatic(true)) h e1 Initial.typ_int; - (* check that the size [(e1 - e0) + 1)] is the same for *) - (* all indices *) - let e0 = size_of_exp e0 in - let e1 = size_of_exp e1 in - let actual_size = - Ztypes.plus (Ztypes.minus e1 e0) (Ztypes.const 1) in - let size_opt = - match size_opt with - | None -> Some(actual_size) - | Some(expected_size) -> - equal_sizes loc expected_size actual_size; size_opt in - Env.add i { t_typ = Initial.typ_int; t_sort = Sval } in_h, - out_h, xi_out_x, size_opt in - - (* returns the set of names defined by the loop body *) - let init init_h { desc = desc; loc = loc } = - match desc with - | Einit_last(i, e) -> - let ty = typ_of_var loc h i in - expect expected_k h e ty; - Env.add i { t_typ = ty; t_sort = Deftypes.memory } init_h in - let init_h = List.fold_left init Env.empty init_list in - - let in_h, out_h, xi_out_x, _ = - List.fold_left index (Env.empty, Env.empty, Env.empty, None) i_list in - body.for_in_env <- in_h; - body.for_out_env <- out_h; - - (* the environment [h] is extended with [in_h], [out_h] and [init_h] *) - let h_eq_list = - Env.append in_h (Env.append out_h (Env.append init_h h)) in - let _, defnames = - block_eq_list expected_k h_eq_list b_eq_list in - (* check that every name in defnames is either declared *) - (* in the initialize branch, an output or a multi-emitted value *) - merge defnames h init_h out_h xi_out_x in - (* set the names defined in the current equation *) - eq.eq_write <- defnames; - (* every equation must define at least a name *) - (* if S.is_empty (Deftypes.names S.empty defnames) *) - (* then warning loc Wequation_does_not_define_a_name; *) - defnames - -and equation_list expected_k h eq_list = - List.fold_left - (fun defined_names eq -> - Total.join eq.eq_loc (equation expected_k h eq) defined_names) - Deftypes.empty eq_list - -(** Type a present handler when the body is an expression *) -and present_handler_exp_list loc expected_k h p_h_list e0_opt expected_ty = - present_handlers scondpat - (fun expected_k h e expected_ty -> - expect expected_k h e expected_ty; Deftypes.empty) - loc expected_k h p_h_list e0_opt expected_ty - -and present_handler_block_eq_list loc expected_k h p_h_list b_opt = - present_handlers scondpat - (fun expected_k h b _ -> snd (block_eq_list expected_k h b)) - loc expected_k h p_h_list b_opt Initial.typ_unit - -and match_handler_block_eq_list loc expected_k h total m_h_list pat_ty = - match_handlers - (fun expected_k h b _ -> snd (block_eq_list expected_k h b)) - loc expected_k h total m_h_list pat_ty Initial.typ_unit - -and match_handler_exp_list loc expected_k h total m_h_list pat_ty ty = - match_handlers - (fun expected_k h e expected_ty -> - expect expected_k h e expected_ty; Deftypes.empty) - loc expected_k h total m_h_list pat_ty ty - -and block_eq_list expected_k h - ({ b_vars = n_list; b_locals = l_list; - b_body = eq_list } as b) = - (* initialize the local environment *) - let _, inames = build_list (S.empty, S.empty) eq_list in - let h0 = vardec_list expected_k n_list inames in - let h = Env.append h0 h in - let new_h = List.fold_left (local expected_k) h l_list in - let defined_names = equation_list expected_k new_h eq_list in - (* check that every local variable from [l_list] appears in *) - (* [defined_variable] and that initialized state variables are not *) - (* re-initialized in the body *) - let defined_names = - check_definitions_for_every_name defined_names n_list in - (* annotate the block with the set of written variables and environment *) - b.b_write <- defined_names; - b.b_env <- h0; - new_h, defined_names - -and local expected_k h ({ l_eq = eq_list } as l) = - (* decide whether [last x] is allowed or not on every [x] from [h0] *) - let h0 = env_of_eq_list expected_k eq_list in - l.l_env <- h0; - let new_h = Env.append h0 h in - ignore (equation_list expected_k new_h eq_list); - Env.append h0 h - -(** Typing a signal condition *) -(* when [is_zero_type = true], [scpat] must be either of type *) -(* [zero] or [t signal]. [h] is the typing environment *) -(* Under a kind [k = Any], [sc on e] is correct if [e] is of kind [AD] *) -(* The reason is that the possible discontinuity of [e] only effect *) -(* when [sc] is true *) -and scondpat expected_k is_zero_type h scpat = - let rec typrec expected_k is_zero_type scpat = - match scpat.desc with - | Econdand(sc1, sc2) -> - typrec expected_k is_zero_type sc1; - typrec expected_k is_zero_type sc2 - | Econdor(sc1, sc2) -> - typrec expected_k is_zero_type sc1; - typrec expected_k is_zero_type sc2 - | Econdexp(e) -> - let expected_ty = - if is_zero_type then Initial.typ_zero else Initial.typ_bool in - ignore (expect expected_k h e expected_ty) - | Econdpat(e_cond, pat) -> - (* check that e is a signal *) - let ty = new_var () in - ignore (expect expected_k h e_cond (Initial.typ_signal ty)); - pattern h pat ty - | Econdon(sc1, e) -> - typrec expected_k is_zero_type sc1; - ignore - (expect (Ztypes.on_type expected_k) h e Initial.typ_bool) - in - typrec expected_k is_zero_type scpat - - -(* typing state expressions. [state] must be a stateless expression *) -(* [actual_reset = true] if [state] is entered by reset *) -and typing_state h def_states actual_reset state = - match state.desc with - | Estate0(s) -> - begin try - let ({ s_reset = expected_reset; s_parameters = args } as r) = - Env.find s def_states in - if args <> [] - then error state.loc (Estate_arity_clash(s, 0, List.length args)); - r.s_reset <- - check_target_state state.loc expected_reset actual_reset - with - | Not_found -> error state.loc (Estate_unbound s) - end - | Estate1(s, l) -> - let ({ s_reset = expected_reset; s_parameters = args } as r) = - try - Env.find s def_states - with - | Not_found -> error state.loc (Estate_unbound s) in - begin try - List.iter2 - (fun e expected_ty -> ignore (expect Tany h e expected_ty)) - l args; - r.s_reset <- - check_target_state state.loc expected_reset actual_reset - with - | Invalid_argument _ -> - error state.loc - (Estate_arity_clash(s, List.length l, List.length args)) - end - -(* Once the body of an automaton has been typed, indicate for every *) -(* handler if it is always entered by reset or not *) -and mark_reset_state def_states state_handlers = - let mark ({ s_state = statepat } as handler) = - let { s_reset = r } = - Env.find (Total.Automaton.statepatname statepat) def_states in - let v = match r with | None | Some(false) -> false | Some(true) -> true in - handler.Zelus.s_reset <- v in - List.iter mark state_handlers - -(** Typing an automaton. Returns defined names *) -and automaton_handlers is_weak loc expected_k h state_handlers se_opt = - (* check that all declared states are accessible *) - Total.Automaton.check_all_states_are_accessible loc state_handlers; - - (* global table which associate the set of defined_names for every state *) - let t = Total.Automaton.table state_handlers in - - (* build the environment of states. *) - let addname acc { s_state = statepat } = - match statepat.desc with - | Estate0pat(s) -> Env.add s { s_reset = None; s_parameters = [] } acc - | Estate1pat(s, l) -> - Env.add s { s_reset = None; - s_parameters = (List.map (fun _ -> new_var ()) l)} acc in - let def_states = List.fold_left addname Env.empty state_handlers in - - (* in case [se_opt = None], checks that the initial state is a non *) - (* parameterised state. *) - let { s_state = statepat } = List.hd state_handlers in - begin match se_opt with - | None -> - begin match statepat.desc with - | Estate1pat _ -> error statepat.loc Estate_initial - | Estate0pat _ -> () - end - | Some(se) -> typing_state h def_states true se - end; - - (* the type for conditions on transitions *) - let is_zero_type = Ztypes.is_continuous_kind expected_k in - - (* typing the body of the automaton *) - let typing_handler h - ({ s_state = statepat; s_body = b; s_trans = trans } as s) = - let escape source_state h expected_k - ({ e_cond = scpat; e_reset = r; e_block = b_opt; - e_next_state = state } as esc) = - (* type one escape condition *) - let h0 = env_of_scondpat expected_k scpat in - let h = Env.append h0 h in - scondpat expected_k is_zero_type h scpat; - (* sets flag [zero = true] when [is_zero_type = true] *) - esc.e_zero <- is_zero_type; - esc.e_env <- h0; - let h, defined_names = - match b_opt with - | None -> h, Deftypes.empty - | Some(b) -> block_eq_list (Tdiscrete(true)) h b in - (* checks that [state] belond to the current set of [states] *) - typing_state h def_states r state; - (* checks that names are not defined twice in a state *) - let statename = - if is_weak then source_state else Total.Automaton.statename state in - Total.Automaton.add_transition is_weak h statename defined_names t in - - (* typing the state pattern *) - let h0 = env_of_statepat expected_k statepat in - s.s_env <- h0; - begin match statepat.desc with - | Estate0pat _ -> () - | Estate1pat(s, n_list) -> - let { s_parameters = ty_list } = Env.find s def_states in - List.iter2 - (fun n ty -> - unify statepat.loc - (typ_of_var statepat.loc h0 n) ty) n_list ty_list; - end; - let h = Env.append h0 h in - (* typing the body *) - let new_h, defined_names = block_eq_list expected_k h b in - (* add the list of defined_names to the current state *) - let source_state = Total.Automaton.statepatname statepat in - Total.Automaton.add_state source_state defined_names t; - List.iter (escape source_state new_h expected_k) trans; - defined_names in - - let first_handler = List.hd state_handlers in - let remaining_handlers = List.tl state_handlers in - - (* first type the initial branch *) - let defined_names = typing_handler h first_handler in - (* if the initial state has only weak transition then all *) - (* variables from [defined_names] do have a last value *) - let first_h, new_h = if is_weak then turn_vars_into_memories h defined_names - else Env.empty, h in - - let defined_names_list = - List.map (typing_handler new_h) remaining_handlers in - - (* identify variables which are partially defined in some states *) - (* and/or transitions *) - let defined_names = Total.Automaton.check loc new_h t in - (* write defined_names in every handler *) - List.iter2 - (fun { s_body = { b_write = _ } as b } defined_names -> - b.b_write <- defined_names) - state_handlers (defined_names :: defined_names_list); - - (* incorporate all the information computed concerning variables *) - (* from the initial handler into the global one *) - incorporate_into_env first_h h; - - (* finally, indicate for every state handler if it is entered *) - (* by reset or not *) - mark_reset_state def_states state_handlers; - defined_names - -(** Check that size variables are all bounded *) -let no_unbounded_name loc free_in_ty ty = - if not (S.is_empty free_in_ty) - then let n = S.choose free_in_ty in - error loc (Esize_parameter_cannot_be_generalized(n, ty)) - else ty - -(* make a function type from a function definition. *) -(* remove useless dependences: - * - (n:ty_arg) -k-> ty_res => ty_arg -k-> ty_res if n not in fv_size(ty_res) - * - if some name stay unbounded, raise an error *) -let funtype loc expected_k pat_list ty_list ty_res = - let rec arg pat_list ty_list fv_in_ty_res = - match pat_list, ty_list with - | [], [] -> [], fv_in_ty_res - | pat :: pat_list, ty_arg :: ty_list -> - let ty_res_list, fv_in_ty_res = - arg pat_list ty_list fv_in_ty_res in - let fv_pat = Vars.fv_pat S.empty S.empty pat in - let opt_name, fv_in_ty_res = - let fv_inter = S.inter fv_pat fv_in_ty_res in - if S.is_empty fv_inter then None, fv_in_ty_res - else match pat.p_desc with - | Evarpat(n) -> Some(n), S.remove n fv_in_ty_res - | _ -> error pat.p_loc Esize_parameter_must_be_a_name in - (opt_name, ty_arg) :: ty_res_list, fv fv_in_ty_res ty_arg - | _ -> assert false in - let ty_arg_list, fv_in_ty_res = arg pat_list ty_list (fv S.empty ty_res) in - let ty_res = funtype_list expected_k ty_arg_list ty_res in - no_unbounded_name loc fv_in_ty_res ty_res - -(* The main entry functions *) -let constdecl f is_static e = - let expected_k = if is_static then Tstatic(true) else Tdiscrete(false) in - Zmisc.push_binding_level (); - let ty = expression expected_k Env.empty e in - Zmisc.pop_binding_level (); - let tys = Ztypes.gen (not (expansive e)) ty in - tys - -let fundecl loc f ({ f_kind = k; f_atomic = is_atomic; - f_args = pat_list; f_body = e } as body) = - Zmisc.push_binding_level (); - let expected_k = Interface.kindtype k in - (* sets the kind of variables according to [k] *) - (* vars in [pat_list] are values, i.e., *) - (* they cannot be accessed with a last *) - let h0 = env_of_pattern_list expected_k Env.empty pat_list in - body.f_env <- h0; - (* first type the body *) - let ty_p_list = List.map (fun _ -> new_var ()) pat_list in - pattern_list h0 pat_list ty_p_list; - (* check that the pattern is total *) - check_total_pattern_list pat_list; - let ty_res = expression expected_k h0 e in - Zmisc.pop_binding_level (); - let ty_res = funtype loc expected_k pat_list ty_p_list ty_res in - let tys = Ztypes.gen true ty_res in - tys - -let implementation ff is_first impl = - try - match impl.desc with - | Econstdecl(f, is_static, e) -> - let tys = constdecl f is_static e in - if is_first then Interface.add_type_of_value ff impl.loc f is_static tys - else Interface.update_type_of_value ff impl.loc f is_static tys - | Efundecl(f, body) -> - let tys = fundecl impl.loc f body in - if is_first then Interface.add_type_of_value ff impl.loc f true tys - else Interface.update_type_of_value ff impl.loc f true tys - | Eopen(modname) -> - if is_first then Modules.open_module modname - | Etypedecl(f, params, ty) -> - if is_first then Interface.typedecl ff impl.loc f params ty - with - | Typerrors.Error(loc, err) -> - if is_first then Typerrors.message loc err - else - begin - Format.eprintf - "@[Internal error: type error during the second step \n\ - after static reduction and inlining\n\ - Be carreful, the localisation of errors is misleading@.@.@]"; - Typerrors.message loc err - end - -(* the main entry function *) -let implementation_list ff is_first impl_list = - Zmisc.no_warning := not is_first; - List.iter (implementation ff is_first) impl_list; - Zmisc.no_warning := not is_first; - impl_list diff --git a/compiler/typing/zmatching.ml b/compiler/typing/zmatching.ml deleted file mode 100644 index 06d93e516..000000000 --- a/compiler/typing/zmatching.ml +++ /dev/null @@ -1,306 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* A generic pattern-matching verifier based on Luc Maranget's paper at JFLA *) -(* Author: Adrien Guatto 2009 *) -(* See http://pauillac.inria.fr/~maranget/papers/warn/index.html *) -(* Implemented originally in the Lucid Synchrone compiler, V4 by A.Guatto *) - -(** Useful functions *) -let rec repeat n a = match n with | 0 -> [] | n -> a :: (repeat (n - 1) a) - -(* keep l n returns the rest l' such that l = p @ l' with p of size n *) -let rec keep l n = match (l, n) with - | (_, 0) -> invalid_arg "keep" - | (h :: _, 1) -> h - | (_ :: t, n) -> keep t (n - 1) - | _ -> invalid_arg "keep" - -(* keep l n returns the prefix p of size n such that l = p @ l' *) -let rec drop l n = match (l, n) with - | (_, 0) -> invalid_arg "drop" - | (_ :: t, 1) -> t - | (h :: t, n) -> h :: (drop t (n - 1)) - | _ -> invalid_arg "drop" - -let rec range n m = if n > m then [] else n :: (range (n + 1) m) - -(* split l into p and l' such that l = p @ l with p of size n *) -let separate n l = - let rec f acc n l = match (n, l) with - | (0, _) -> (acc, l) - | (n, h :: t) -> f (h :: acc) (n - 1) t - | _ -> assert false in - if n > List.length l - then invalid_arg "separate" - else - let (p, l) = f [] n l in - (List.rev p, l) - -(* Syntax for patterns, and pretty-printers *) - -(** Generic pattern, basically constructors with holes and alternation, - tagged with any type. *) -type 'a pattern = - | Pany - | Por of 'a pattern * 'a pattern - | Pconstr of 'a * 'a pattern list -and 'a patt_vec = 'a pattern list -(* Row vectors *) -and 'a patt_matrix = 'a patt_vec list - -(* Module type for constructor signatures *) - -(** Module type for pattern signatures. *) -module type SIG = -sig - type tag - val compare : tag -> tag -> int - val arity : tag -> int - val is_complete : tag list -> bool - val not_in : tag list -> tag - - type pattern_ast - val inject : pattern_ast -> tag pattern - val eject : tag pattern -> pattern_ast -end - -(* The algorithm itself, parametrized over signatures *) - -module PATTERN_CHECKER = functor (S : SIG) -> -struct - module SSet = - Set.Make(struct - type t = S.tag - let compare = S.compare - end) - (* Used for signature management. *) - let uniq l = SSet.elements (List.fold_right SSet.add l SSet.empty) - - (* Wrappers for S's signature functions. Well, we should switch to something - more efficient than sorting at each call. *) - let is_complete sigma = S.is_complete (uniq sigma) - let not_in sigma = S.not_in (uniq sigma) - - (** Extract constructors from pattern. *) - let rec head_constrs h = match h with - | Pconstr (c, q) -> [(c, List.length q)] - | Por (l, r) -> head_constrs l @ head_constrs r - | Pany -> [] - - (** Implementation of S(c,p) as described in the paper's first part. *) - let rec matS c ar p = - let vecS pv = match pv with - | [] -> assert false - | Pconstr (c', r') :: pv' -> if S.compare c c' = 0 then [r' @ pv'] else [] - | Pany :: pv' -> [repeat ar Pany @ pv'] - | Por (t1, t2) :: pv' -> matS c ar [t1 :: pv'; t2 :: pv'] in - List.concat (List.map vecS p) - - (** Implementation of D(p) as described in the paper's first part. *) - let rec matD p = - let vecD pv = match pv with - | Pconstr _ :: _ -> [] - | Pany :: pv' -> [pv'] - | Por (t1, t2) :: pv' -> matD [t1 :: pv'; t2 :: pv'] - | _ -> assert false in - List.concat (List.map vecD p) - - (** U(p,q) from the paper. Most important function, called by higher level - ones. Tests the usefulness of q relatively to p. *) - let rec algU p q = - match (p, q) with - | ([], _) -> true (* p has no lines *) - | (_ :: _, []) -> false (* p has no columns *) - - | (h :: t, Pconstr (c, r) :: q') -> - let p' = matS c (List.length r) p in - algU p' (r @ q') - - | (h :: t, Por (r1, r2) :: q') -> - algU p (r1 :: q') || algU p (r2 :: q') - - | (h :: t, Pany :: q') -> - let sigma = - List.concat (List.map (fun v -> head_constrs (List.hd v)) p) in - let algU_constr (c_k, ar_k) = - let p' = matS c_k ar_k p in - algU p' (repeat ar_k Pany @ q') in - let sigma_used = List.exists algU_constr sigma in - sigma_used || (if not (is_complete (List.map fst sigma)) - then algU (matD p) q' else false) - - - (** Type used for efficient testing of usefulness and redundancy of - pattern-matching cases. *) - type 'a trivec = { p : 'a patt_vec; - q : 'a patt_vec; - r : 'a patt_vec } - and 'a trimat = 'a trivec list - - - (** Second de finition of S(c,p) for tri-matrices. *) - let rec trimatS c arity mv = - let filter_line l = match l.p with - | Pconstr (c', t) :: p' -> - if S.compare c c' = 0 then [{ l with p = t @ p' }] else [] - | Pany :: p' -> - [{ l with p = repeat arity Pany @ p' }] - | Por (t1, t2) :: p' -> - trimatS c arity [{ l with p = t1 :: p' }; { l with p = t2 :: p' }] - | _ -> assert false in - List.concat (List.map filter_line mv) - - (** {i shift1 l} shifts an element from {i l.p} to {i l.q}. *) - let shift1 l = match l.p with - | p :: p' -> { l with p = p'; q = p :: l.q } - | _ -> assert false - - (** {i shift2 l} shifts an element from {i l.p} to {i l.r}. *) - let shift2 l = match l.p with - | p :: p' -> { l with p = p'; r = p :: l.r } - | _ -> assert false - - (** {i S.tag pattern list option} is used for results of usefulness testing - for Or(r1,r2) patterns. Some [] means that r1 and r2 are both useful, - Some [r1] (resp. Some [r2]) means that r1 (resp. r2) is useless, and - None means that both are. *) - - (** The following functions implement useful shortcuts. *) - - let simple_union e e' = match (e, e') with - | (Some l, Some l') -> Some (l @ l') - | (None, _) | (_, None) -> None - - let union r1 r2 e' e'' = match (e', e'') with - | (Some [], Some []) -> Some [] - | (None, None) -> None - | (Some [], None) -> Some [r2] - | (None, Some []) -> Some [r1] - - | (Some [], Some (_ :: _)) -> e'' - | (Some (_ :: _), Some []) -> e' - - | (None, Some ((_ :: _) as t)) -> Some (r1 :: t) - | (Some ((_ :: _) as t), None) -> Some (r2 :: t) - - | (Some ((_ :: _) as t'), Some ((_ :: _) as t'')) -> Some (t' @ t'') - - (** Efficient usefulness check with special Or pattern management. *) - let rec algU' m v = - match v.p with - (* Phase one *) - | Pconstr (c, t) :: p' -> - algU' (trimatS c (List.length t) m) { v with p = t @ p' } - | Pany :: _ -> - algU' (List.map shift1 m) (shift1 v) - | Por _ :: _ -> - algU' (List.map shift2 m) (shift2 v) - | [] -> - (* Phase two *) - begin match v.r with - | [] -> - let qm = List.map (fun l -> l.q) m in - if algU qm v.q then Some [] else None - | _ :: _ -> - let rec compute_Ej j = - begin match List.nth v.r (j - 1) with - | Por (t1, t2) -> - let f l = - let r_j = keep l.r j - and r_woj = drop l.r j in - { p = [r_j]; q = r_woj @ l.q; r = [] } in - let rv_woj = drop v.r j in - let m' = List.map f m in - let m'' = - m' @ [{ p = [t1]; q = drop v.r j @ v.q; r = [] }] in - let r1 = algU' m' - { p = [t1]; q = rv_woj @ v.q; r = [] } - and r2 = algU' m'' - { p = [t2]; q = rv_woj @ v.q; r = [] } in - union t1 t2 r1 r2 - | _ -> assert false - end in - let j_list = range 1 (List.length (List.hd m).r) in - let computed_Ej = List.map compute_Ej j_list in - List.fold_left simple_union (Some []) computed_Ej - end - - (** Completely construct a non-matched pattern. If none is returned, - this matrix is exhaustive. *) - let rec algI m n = match (m, n) with - | ([], 0) -> Some [] - | ([] :: _, 0) -> None - | (m, n) -> - let sigma = - List.concat (List.map (fun v -> head_constrs (List.hd v)) m) in - let sigma_c = List.map fst sigma in - let default = - if is_complete sigma_c - then None - else algI (matD m) (n - 1) in - begin match default with - | Some p -> - begin match sigma with - | [] -> Some (Pany :: p) - | _ :: _ -> - let c' = not_in sigma_c in - Some (Pconstr (c', repeat (S.arity c') Pany) :: p) - end - | None -> - let rec traverse_sigma sigma = match sigma with - | [] -> None - | (c, ar) :: sigma' -> - let res = - algI (matS c ar m) (ar + n - 1) in - begin match res with - | None -> traverse_sigma sigma' - | Some v -> - let (r, p) = separate ar v in - Some (Pconstr (c, r) :: p) - end in - traverse_sigma sigma - end - - type result = { not_matched : S.pattern_ast option; - redundant_patterns : S.pattern_ast list; } - - let check m = - let m' = List.map (fun v -> [S.inject v]) m in - match m' with - | [] -> invalid_arg "check" - | v :: _ -> - { not_matched = - begin - let n = List.length v in - match algI m' n with - | None -> None - | Some [p] -> Some (S.eject p) - | _ -> assert false - end; - redundant_patterns = - begin - let make_trivec v = { p = v; q = []; r = [] } in - let make_trimat m = List.map make_trivec m in - let check_line (m, red) v = - let r = algU' (make_trimat m) (make_trivec v) in - (m @ [v], match r with - | Some [] -> red - | Some r -> List.map S.eject r @ red - | None -> List.map S.eject v @ red) in - let (_, red) = List.fold_left - check_line ([(List.hd m')], []) (List.tl m') in - red; - end } - end diff --git a/compiler/typing/ztypes.ml b/compiler/typing/ztypes.ml deleted file mode 100644 index 941859357..000000000 --- a/compiler/typing/ztypes.ml +++ /dev/null @@ -1,663 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* types.ml : basic operations over types *) - -open Zmisc -open Zident -open Lident -open Deftypes -open Global -open Modules -open Zelus - -(* making types *) -let make ty = - { t_desc = ty; t_level = generic; t_index = symbol#name } -let product ty_list = - make (Tproduct(ty_list)) -let vec ty e = make (Tvec(ty, e)) -let funtype k n_opt ty_arg ty_res = - make (Tfun(k, n_opt, ty_arg, ty_res)) -let rec funtype_list k ty_arg_list ty_res = - match ty_arg_list with - | [] -> ty_res - | [n_opt, ty] -> funtype k n_opt ty ty_res - | (n_opt, ty) :: ty_arg_list -> - funtype (Tstatic(true)) n_opt ty (funtype_list k ty_arg_list ty_res) - -(** Make size expressions. Apply simple simplification rules *) -let plus si1 si2 = - match si1, si2 with - | Tconst(0), _ -> si2 - | _, Tconst(0) -> si1 - | Top(Tminus, si1, Tconst(1)), Tconst(1) -> - (* (si1 - 1) + 1 = si1 *) si1 - | _ -> Top(Tplus, si1, si2) -let minus si1 si2 = - match si1, si2 with - | _, Tconst(0) -> si1 - | _ -> Top(Tminus, si1, si2) -let const i = Tconst i -let global ln = Tglobal(ln) -let name n = Tname(n) - -let constr name ty_list abbrev = make (Tconstr(name, ty_list, abbrev)) -let nconstr name ty_list = constr name ty_list (ref Tnil) - -let new_discrete_var () = - { t_desc = Tvar; t_level = !binding_level; t_index = symbol#name } -let new_var () = - { t_desc = Tvar; t_level = !binding_level; t_index = symbol#name } -let new_generic_var () = - { t_desc = Tvar; t_level = generic; t_index = symbol#name } -let rec new_var_list n = - match n with - 0 -> [] - | n -> (new_var ()) :: new_var_list (n - 1) -let forall l typ_body = { typ_vars = l; typ_body = typ_body } - -(** Set of free size variables in a type *) -let rec fv acc { t_desc = desc } = - match desc with - | Tvar -> acc - | Tproduct(ty_list) | Tconstr(_, ty_list, _) -> List.fold_left fv acc ty_list - | Tvec(ty_arg, size) -> fv (fv_size acc size) ty_arg - | Tfun(_, _, ty_arg, ty_res) -> fv (fv acc ty_arg) ty_res - | Tlink(ty_link) -> fv acc ty_link - -and fv_size acc si = - match si with - | Tconst _ | Tglobal _ -> acc - | Tname(n) -> S.add n acc - | Top(_, si1, si2) -> fv_size (fv_size acc si1) si2 - -(* replace size variables in [ty] by their value in the environment [senv] *) -let rec subst_in_type senv ({ t_desc = desc; t_index = index } as ty) = - match desc with - | Tvar -> ty - | Tproduct(ty_list) -> product (List.map (subst_in_type senv) ty_list) - | Tconstr(gl, ty_list, abbrev) -> - constr gl (List.map (subst_in_type senv) ty_list) abbrev - | Tvec(ty_arg, si) -> - vec (subst_in_type senv ty_arg) (subst_in_size senv si) - | Tlink(ty_link) -> subst_in_type senv ty_link - | Tfun(k, n_opt, ty_arg, ty_res) -> - let ty_arg = subst_in_type senv ty_arg in - let n_opt, ty_res = - match n_opt with - | None -> n_opt, subst_in_type senv ty_res - | Some(n) -> - let m = Zident.fresh (Zident.source n) in - Some(m), subst_in_type (Env.add n (Tname(m)) senv) ty_res in - funtype k n_opt ty_arg ty_res - -and subst_in_size senv si = - match si with - | Tconst _ | Tglobal _ -> si - | Top(op, si1, si2) -> - Top(op, subst_in_size senv si1, subst_in_size senv si2) - | Tname(n) -> - try Env.find n senv with | Not_found -> Tname(n) - -(** Remove dependences from a type *) -(* [t1 -A-> t2] becomes [t1 -> t2]; - - [t1 -D-> t2] becomes [(t1, t2) node]; - - [t1 -C-> t2] becomes [(t1, t2) hybrid]; - - [(n: t1) -k-> t2] is treated as [t1 -k-> t2] - - [t[si]] becomes [t] *) -let rec remove_dependences ({ t_desc = desc } as ty) = - let typ_node ty_arg ty_res = - Initial.constr { qual = current_module (); id = "node" } [ty_arg; ty_res] in - let typ_hybrid ty_arg ty_res = - Initial.constr { qual = current_module (); id = "hybrid" } - [ty_arg; ty_res] in - let typ_proba ty_arg ty_res = - Initial.constr { qual = current_module (); id = "proba" } - [ty_arg; ty_res] in - let abbrev = function - | Tnil -> Tnil - | Tcons(ty_list, ty) -> - Tcons(List.map remove_dependences ty_list, remove_dependences ty) in - match desc with - | Tvar -> ty - | Tproduct(ty_list) -> product(List.map remove_dependences ty_list) - | Tconstr(gl, ty_list, a) -> - constr gl (List.map remove_dependences ty_list) (ref (abbrev !a)) - | Tvec(ty_arg, _) -> Initial.typ_array (remove_dependences ty_arg) - | Tlink(ty_link) -> remove_dependences ty_link - | Tfun(k, _, ty_arg, ty_res) -> - let ty_arg = remove_dependences ty_arg in - let ty_res = remove_dependences ty_res in - match k with - | Tany | Tstatic _ | Tdiscrete false -> - funtype Tany None ty_arg ty_res - | Tdiscrete true -> typ_node ty_arg ty_res - | Tcont -> typ_hybrid ty_arg ty_res - | Tproba -> typ_proba ty_arg ty_res - -(* typing errors *) -exception Unify - -(* comparing statefull and stateless expressions. A stateless one *) -(* is allowed in a context where a statefull one is expected *) -let less_than actual_k expected_k = - match actual_k, expected_k with - | (Tstatic(true), _) - | (Tany, (Tany | Tdiscrete _ | Tcont | Tproba)) - | (Tcont, Tcont) -> () - | (Tdiscrete(s1), Tdiscrete(s2)) -> if not (s1 <= s2) then raise Unify - | (Tdiscrete _, Tproba) | (Tproba, Tproba) -> () - | _ -> raise Unify - -(* If a function with type t1 -k2-> t2 is used in a context with kind k1 *) -(* then, its argument must be of kind k1 ^ k2 *) -let lift k1 k2 = - match k1, k2 with - | _, Tstatic(false) -> k1 - | _, Tstatic(true) -> Tstatic(true) - | _ -> less_than k2 k1; k1 - -(* function types introduced in a context [k] must be combinatorial *) -let intro = function - | (Tstatic _ | Tany) as k -> k | Tdiscrete _ | Tcont | Tproba -> Tany - -let run_type expected_k = - let ty_arg = new_var () in - let ty_res = new_var () in - funtype expected_k None ty_arg ty_res - - -(* Check that a type has itself kind k. *) -(***** removed the constraint: it forbids function unless k = S *) -let rec kind k { t_desc = desc } = - match desc with - | Tvar -> () - | Tproduct(ty_list) | Tconstr(_, ty_list, _) -> List.iter (kind k) ty_list - | Tvec(ty_arg, _) -> kind k ty_arg - | Tlink(ty_link) -> kind k ty_link - | Tfun _ -> () -(***** when (k = Tstatic(true)) -> () | _ -> raise Unify *) - -let fully_applied ty = try kind Tany ty; true with Unify -> false - -(** The type of zero-crossing condition. [zero] when under a continuous *) -(** context. [bool] otherwise. *) -let zero_type expected_k = - match expected_k with - | Tstatic _ | Tany | Tdiscrete _ | Tproba -> Initial.typ_bool - | Tcont -> Initial.typ_zero - -(* The kind on the right of a [scpat on e] signal pattern. *) -(* When [expected_k = Tcont] or [expected_k = Tany] *) -(* then [e] can be of kind [Tdiscrete(false)]. As [e] is aligned *) -(* with either a zero-crossing or combinatorial function, it cannot introduce *) -(* a discontinuity *) -let on_type expected_k = - match expected_k with - | Tcont | Tany -> Tdiscrete(false) - | _ -> expected_k - -let is_combinatorial_kind expected_k = - match expected_k with - | Tany -> true | Tstatic _ | Tcont | Tdiscrete _ | Tproba -> false - -let is_discrete_kind expected_k = - match expected_k with - | Tdiscrete(true) | Tproba -> true - | Tcont | Tdiscrete(false) | Tany | Tstatic _ -> false - -let is_continuous_kind expected_k = - match expected_k with - | Tstatic _ | Tany | Tdiscrete _ | Tproba -> false | Tcont -> true - -let is_statefull_kind expected_k = - match expected_k with - | Tdiscrete(true) | Tcont | Tproba -> true - | Tdiscrete false | Tstatic _ | Tany -> false - -(** Make a discrete sort. *) -let lift_to_discrete expected_k = - match expected_k with - | Tcont | Tdiscrete(true) -> Tdiscrete(true) - | Tproba -> Tproba - | Tstatic _ | Tany | Tdiscrete _ -> expected_k - -(* shortening types *) -let rec typ_repr ty = - match ty.t_desc with - | Tlink(ty_son) -> - let ty_son = typ_repr ty_son in - ty.t_desc <- Tlink(ty_son); - ty_son - | _ -> ty - -(* occur check and level modification *) -let rec occur_check level index ty = - let rec check ty = - match ty.t_desc with - | Tvar -> - if ty == index - then raise Unify - else if ty.t_level > level then ty.t_level <- level - | Tproduct(ty_list) -> List.iter check ty_list - | Tconstr(name, ty_list, _) -> - List.iter check ty_list - | Tfun(_, _, ty_arg, ty_res) -> check ty_arg; check ty_res - | Tvec(ty_arg, _) -> check ty_arg - | Tlink(link) -> check link - in check ty - -(* remove useless dependence names from a type *) -(* Invariant: (n: t1) -k-> t2 => t1 -k-> t2 if n not in fv(t2) *) -let rec clear acc ({ t_desc = desc } as ty) = - match desc with - | Tvar -> ty, acc - | Tproduct(ty_list) -> - let ty_list, acc = Zmisc.map_fold clear acc ty_list in - product(ty_list), acc - | Tvec(ty_arg, size) -> - let ty_arg, acc = clear acc ty_arg in - let acc = fv_size acc size in - vec ty_arg size, acc - | Tfun(k, n_opt, ty_arg, ty_res) -> - let ty_res, acc = clear acc ty_res in - let n_opt, acc = - match n_opt with - | None -> None, acc - | Some(n) -> - if S.mem n acc then Some(n), acc else None, S.remove n acc in - let ty_arg, acc = clear acc ty_arg in - funtype k n_opt ty_arg ty_res, acc - | Tlink(ty_link) -> clear acc ty_link - | Tconstr(gl, ty_list, abbrev) -> - let clear_abbrev acc = function - | Tnil -> Tnil, acc - | Tcons(ty_list, ty) -> - let ty_list, acc = Zmisc.map_fold clear acc ty_list in - let ty, acc = clear acc ty in - Tcons(ty_list, ty), acc in - let ty_list, acc = Zmisc.map_fold clear acc ty_list in - let abbrev, acc = clear_abbrev acc !abbrev in - constr gl ty_list (ref abbrev), acc - -(* generalisation and non generalisation of a type. *) -(* the level of generalised type variables *) -(* is set to [generic] when the flag [is_gen] is true *) -(* and set to [!binding_level] when the flag is false *) -(* returns [generic] when a sub-term can be generalised *) -let list_of_typ_vars = ref [] - -let rec gen_ty is_gen ty = - let ty = typ_repr ty in - begin - match ty.t_desc with - | Tvar -> - if ty.t_level > !binding_level - then if is_gen - then (ty.t_level <- generic; - list_of_typ_vars := ty :: !list_of_typ_vars) - else ty.t_level <- !binding_level - | Tproduct(ty_list) -> - ty.t_level <- - List.fold_left (fun level ty -> min level (gen_ty is_gen ty)) - notgeneric ty_list - | Tconstr(name, ty_list, _) -> - ty.t_level <- List.fold_left - (fun level ty -> min level (gen_ty is_gen ty)) - notgeneric ty_list - | Tfun(_, _, ty_arg, ty_res) -> - ty.t_level <- - min (gen_ty is_gen ty_arg) (gen_ty is_gen ty_res) - | Tvec(ty_arg, _) -> - ty.t_level <- gen_ty is_gen ty_arg - | Tlink(link) -> - ty.t_level <- gen_ty is_gen link - end; - ty.t_level - -(* main generalisation function *) -let gen non_expensive typ_body = - list_of_typ_vars := []; - ignore (gen_ty non_expensive typ_body); - { typ_vars = !list_of_typ_vars; typ_body = typ_body } - -let s = ref [] -let save v = s := v :: !s -let cleanup () = List.iter (fun ty -> ty.t_desc <- Tvar) !s; - s := [] - -(* makes a copy of a type *) -let rec copy ty = - let level = ty.t_level in - match ty.t_desc with - | Tvar -> - if level = generic - then - let v = new_var () in - ty.t_desc <- Tlink(v); - save ty; - v - else ty - | Tlink(link) -> - if level = generic - then link - else copy link - | Tproduct(ty_list) -> - if level = generic - then - product (List.map copy ty_list) - else ty - | Tconstr(name, ty_list, abbrev) -> - if level = generic - then - constr name (List.map copy ty_list) abbrev - else ty - | Tfun(k, n_opt, ty_arg, ty_res) -> - if level = generic - then funtype k n_opt (copy ty_arg) (copy ty_res) - else ty - | Tvec(ty_arg, e) -> - if level = generic - then vec (copy ty_arg) e - else ty - -(** Compute the size of an array type [t]. *) -(* [t] is either a basic type float/int/bool or an nested *) -(* array of that *) -let size_of ty = - let rec size_of ty = - match ty.t_desc with - | Tvar | Tproduct _ | Tfun _ -> assert false - | Tlink(link) -> size_of link - | Tconstr _ -> [] - | Tvec(ty, s) -> - s :: (size_of ty) in - List.rev (size_of ty) - -(* instanciation *) -let instance_of_type { typ_body = typ_body } = - let typ_body = copy typ_body in - cleanup (); - typ_body - -let instance_and_vars_of_type { typ_vars = typ_vars; typ_body = typ_body } = - let typ_body = copy typ_body in - let typ_vars = List.map typ_repr typ_vars in - cleanup (); - { typ_instance = typ_vars }, typ_body - -let constr_instance - { constr_arg = ty_list; constr_res = ty_res; constr_arity = n } = - let ty_list = List.map copy ty_list in - let ty_res = copy ty_res in - cleanup (); - { constr_arg = ty_list; constr_res = ty_res; constr_arity = n } - -let label_instance { label_arg = ty_arg; label_res = ty_res } = - let ty_arg = copy ty_arg in - let ty_res = copy ty_res in - cleanup (); - { label_arg = ty_arg; label_res = ty_res } - -let subst ty_var ty = - match ty_var.t_desc with - | Tvar -> ty_var.t_desc <- Tlink(ty) - | _ -> assert false - -let abbreviation q abbrev ty_list = - let { info = ty_desc } = find_type (Modname q) in - let find q = - match ty_desc.type_desc with - | Abbrev(ty_list, ty) -> ty_list, ty - | _ -> raise Not_found in - let arg_list, ty = - match !abbrev with - | Tnil -> - let (arg_list, ty) = find q in - abbrev := Tcons(arg_list, ty); - (arg_list, ty) - | Tcons(arg_list, ty) -> arg_list, ty in - - let new_arg_list = List.map copy arg_list in - let new_ty = copy ty in - cleanup (); - List.iter2 subst new_arg_list ty_list; - new_ty - - -(* same constructed types *) -let same_types n1 n2 = (n1 = n2) - -(* unification *) -let rec unify expected_ty actual_ty = - if expected_ty == actual_ty then () - else - let expected_ty = typ_repr expected_ty in - let actual_ty = typ_repr actual_ty in - if expected_ty == actual_ty then () - else - match expected_ty.t_desc, actual_ty.t_desc with - | Tvar, _ -> - occur_check expected_ty.t_level expected_ty actual_ty; - expected_ty.t_desc <- Tlink(actual_ty) - | _, Tvar -> - occur_check actual_ty.t_level actual_ty expected_ty; - actual_ty.t_desc <- Tlink(expected_ty) - | Tproduct(l1), Tproduct(l2) -> - begin try - List.iter2 unify l1 l2 - with - | Invalid_argument _ -> raise Unify - end - | Tconstr(n1, ty_l1, _), Tconstr(n2, ty_l2, _) when same_types n1 n2 -> - begin try - List.iter2 unify ty_l1 ty_l2 - with - | Invalid_argument _ -> raise Unify - end - | Tconstr(n1, ty_l1, abbrev1), Tconstr(n2, ty_l2, abbrev2) -> - begin try - let expected_ty = abbreviation n1 abbrev1 ty_l1 in - unify expected_ty actual_ty - with Not_found -> - try let actual_ty = abbreviation n2 abbrev2 ty_l2 in - unify expected_ty actual_ty - with Not_found -> raise Unify - end - | Tfun(k1, None, ty_arg1, ty_res1), - Tfun(k2, None, ty_arg2, ty_res2) -> - if k1 = k2 then - begin unify ty_arg1 ty_arg2; unify ty_res1 ty_res2 end - else raise Unify - | Tfun(k1, Some(n1), ty_arg1, ty_res1), - Tfun(k2, Some(n2), ty_arg2, ty_res2) -> - unify ty_arg1 ty_arg2; - if k1 = k2 then - if Zident.compare n1 n2 = 0 then unify ty_res1 ty_res2 - else - let m = Zident.fresh (Zident.source n1) in - let ty_res1 = - subst_in_type - (Env.singleton n1 (Tname(m))) ty_res1 in - let ty_res2 = - subst_in_type - (Env.singleton n1 (Tname(m))) ty_res2 in - unify ty_res1 ty_res2 - else raise Unify - | Tvec(ty1, si1), Tvec(ty2, si2) -> - unify ty1 ty2; equal_sizes si1 si2 - | _ -> raise Unify - -and equal_sizes si1 si2 = - match si1, si2 with - | Tconst i1, Tconst i2 when i1 = i2 -> () - | Tname(n1), Tname(n2) when Zident.compare n1 n2 = 0 -> () - | Tglobal(gn1), Tglobal(gn2) when Lident.compare gn1 gn2 = 0 -> () - | Top(op1, si11, si12), Top(op2, si21, si22) when op1 = op2 -> - equal_sizes si11 si21; equal_sizes si12 si22 - | _ -> raise Unify - -let filter_product arity ty = - let ty = typ_repr ty in - match ty.t_desc with - | Tproduct(l) -> - if List.length l = arity then l else raise Unify - | _ -> - let ty_list = new_var_list arity in - unify ty (product ty_list); - ty_list - -let filter_signal ty = - let ty_arg = new_var () in - unify ty (Initial.typ_signal ty_arg); ty_arg - -let filter_arrow expected_k ty = - let ty = typ_repr ty in - match ty.t_desc with - | Tfun(actual_k, n_opt, ty_arg, ty_res) -> - actual_k, n_opt, ty_arg, ty_res - | _ -> - let ty_arg = new_var () in - let ty_res = new_var () in - unify ty (funtype expected_k None ty_arg ty_res); - expected_k, None, ty_arg, ty_res - -let filter_actual_arrow ty = - let ty = typ_repr ty in - match ty.t_desc with - | Tfun(actual_k, n_opt, ty_arg, ty_res) -> - actual_k, n_opt, ty_arg, ty_res - | _ -> assert false - -(* Splits the list of arguments of a function application *) -(* if [f e1 ... en] is an application with [f] of type - * - t1 -S-> ... -S-> ti-1 -k1-> ... -kn-> tn+1 - * - returns [e1,...,ei] as static arguments; [ei+1;...; en] as non static - * - and the type of the result of the application *) -let rec split_arguments ty_fun e_list = - match e_list with - | [] -> [], [], ty_fun - | e :: e_rest_list -> - let k, _, _, ty_res = filter_actual_arrow ty_fun in - match k with - | Tstatic(true) -> - let se_list, ne_list, ty_res = split_arguments ty_res e_rest_list in - e :: se_list, ne_list, ty_res - | _ -> [], e_list, ty_fun - -let filter_vec ty = - let ty = typ_repr ty in - match ty.t_desc with - | Tvec(ty_arg, si) -> ty_arg, si - | _ -> raise Unify - -let type_of_combine () = - funtype (Tstatic(false)) None - (new_var ()) - (funtype (Tstatic(false)) None (new_var ()) (new_var ())) - -(** All the function below are pure. They do not modify the internal *) -(** representation of types. This is mandatory for them to be used once *) -(** static typing is performed *) - - -(** A function which returns either the type argument of a signal *) -(** or nothing. *) -let rec is_a_signal { t_desc = desc } = - match desc with - | Tconstr(id, [ty], _) when id = Initial.sig_ident -> Some(ty) - | Tlink(link) -> is_a_signal link - | _ -> None - -(** Is-it a combinatorial function? *) -let rec is_combinatorial n ty = - if n = 0 then true - else - let ty = typ_repr ty in - match ty.t_desc with - | Tfun((Tdiscrete _ | Tcont | Tproba), _, _, _) -> false - | Tfun(_, _, _, ty_res) -> is_combinatorial (n-1) ty_res - | _ -> true - -let rec res_type n ty = - if n = 0 then ty - else - let ty = typ_repr ty in - match ty.t_desc with - | Tfun(_, _, _, ty_res) -> res_type (n-1) ty_res - | _ -> assert false - -let is_hybrid n ty = - let ty = res_type n ty in - let ty = typ_repr ty in - match ty.t_desc with - | Tfun(Tcont, _, _, _) -> true - | _ -> false - -let is_probabilistic n ty = - let ty = res_type n ty in - let ty = typ_repr ty in - match ty.t_desc with - | Tfun(Tproba, _, _, _) -> true - | _ -> false - -(** Is-it a node ? *) -let is_a_node_name lname = - let { info = { value_typ = { typ_body = typ_body } } } = - Modules.find_value lname in - match typ_body.t_desc with - | Tfun((Tdiscrete(true) | Tcont), _, _, _) -> true | _ -> false - -(** Is-it a function? *) -let is_a_function_name lname = - let { info = { value_typ = { typ_body = ty } } } = - Modules.find_value lname in - let ty = typ_repr ty in - match ty.t_desc with - | Tfun(Tany, _, _, _) -> true | _ -> false - -(** Is-it a hybrid function? *) -let is_a_hybrid_node_name lname = - let { info = { value_typ = { typ_body = ty } } } = - Modules.find_value lname in - let ty = typ_repr ty in - match ty.t_desc with - | Tfun(Tcont, _, _, _) -> true | _ -> false - -(* kind of a function type *) -let rec kind_of_funtype ty = - let ty = typ_repr ty in - match ty.t_desc with - | Tfun(k, _, _, _) -> k | _ -> assert false - -let kind_of_node_name lname = - let { info = { value_typ = { typ_body = ty } } } = - Modules.find_value lname in - kind_of_funtype ty - -(* Does a type scheme contains static parameters *) -let noparameters { typ_vars = lvars; typ_body = typ_body } = - let rec static { t_desc = desc } = - match desc with - | Tvar -> true - | Tproduct(ty_list)| Tconstr(_, ty_list, _) -> List.for_all static ty_list - | Tvec(ty_arg, _) -> static ty_arg - | Tlink(ty_link) -> static ty_link - | Tfun(Tstatic _, _, _, _) | Tfun(_, Some _, _, _) -> false - | Tfun(_, _, ty_arg, ty_res) -> (static ty_arg) && (static ty_res) in - static typ_body - -(* Does a type scheme contains type variables *) -let nopolymorphism { typ_vars = lvars } = lvars = [] diff --git a/compiler/verif/lmm.ml b/compiler/verif/lmm.ml deleted file mode 100644 index e19251e66..000000000 --- a/compiler/verif/lmm.ml +++ /dev/null @@ -1,100 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* Abstract syntax tree for a basic Lustre used for formal *) -(* verification. No node instance; no constrol structure. *) -(* clocks are kept in case of a translation into Lustre but are *) -(* only necessary for the change of state variables *) - -open Zlocation -open Zident - -type name = string - -type op = - | Lunarypre (* un-initialized unit delay *) - | Lfby (* initialized unit delay *) - | Lminusgreater (* initialization *) - | Lifthenelse (* strict conditional *) - | Lsharp (* n-ary, pairwise xor *) - | Lop of Lident.t (* call of a combinatorial function *) - -type immediate = - | Lint of int - | Lfloat of float - | Lbool of bool - | Lchar of char - | Lstring of string - | Lvoid - -type constr0pat = - | Lconstr0pat of Lident.t - | Lboolpat of bool - -type exp = - | Llocal of Zident.t - | Llast of Zident.t - | Lglobal of Lident.t - | Lconst of immediate - | Lconstr0 of Lident.t - | Lapp of op * exp list - | Lrecord_access of exp * Lident.t - | Lrecord of (Lident.t * exp) list - | Ltuple of exp list - | Lget of exp * int - | Lmerge of exp * (constr0pat * exp) list - | Lwhen of exp * constr0pat * exp - -type clock = - | Ck_base (* true *) - | Ck_on of clock * constr0pat * exp (* ck on C(c) *) - -type reset = - | Res_never - | Res_else of reset * exp - -type eq = - { eq_kind: kind; - eq_ident: Zident.t; - eq_exp: exp; - eq_clock: clock } - -and kind = - | Def - | Init of reset - | Next - -type funexp = - { f_inputs: Zident.t list; - f_output: Zident.t; - f_env: tentry Env.t; - f_body: eq list; - f_assert: exp list; } - -and tentry = - { t_typ: typ } - -and implementation = - | Lconstdecl of name * exp - | Lfundecl of name * funexp - | Ltypedecl of name * type_decl - -and type_decl = - | Labstract_type - | Lvariant_type of name list - | Lrecord_type of (name * typ) list - -and typ = - | Tint | Tbool | Tfloat | Tchar | Tstring | Tunit - | Tconstr of Lident.qualident | Tproduct of typ list diff --git a/compiler/verif/match2condition.ml b/compiler/verif/match2condition.ml deleted file mode 100644 index 1e157a83b..000000000 --- a/compiler/verif/match2condition.ml +++ /dev/null @@ -1,208 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* Rewriting of pattern matching into boolean conditions. *) -(* Warning: this is not what should be done to compile *) -(* pattern matching into sequential code; the result is inefficient. *) -(* For that, read Xavier Leroy's notes *) -(* at https://xavierleroy.org/dea/compil/matching.txt *) -(* or the ICFP'01 paper by Le Fessant and Maranget *) - -(* Entry is: -match e1,...,en with - p11,...,p1n -> a1 -| ... -| pM1,...,pMn -> aM - -Output is: let eqs in if c1 then ... else ... -*) - -open Zmisc -open Zelus -open Zaux -open Zident -open Deftypes - -type return = { eqs: eq State.t; env: tentry Env.t State.t } - -let empty = { eqs = State.empty; env = State.empty } - -let with_env env ({ env = env0 } as return) = - { return with env = State.cons env env0 } - -let with_eq eq ({ eqs = eqs } as return) = - { return with eqs = State.cons eq eqs } - -let and_op e1 e2 = - if e1 = etrue then e2 else if e2 = etrue then e1 - else Zaux.and_op e1 e2 -let or_op e1 e2 = - if e1 = efalse then e2 else if e2 = efalse then e1 - else Zaux.or_op e1 e2 - -(* for a pair [pat, e] computes the equation [pat_v = e] and boolean *) -(* condition c where [pat_v] is only made of variables and [c] *) -(* is true when [pat] matches [e] *) -let rec filter return ({ p_desc = p_desc; p_typ = ty } as p) ({ e_desc } as e) = - match p_desc, e_desc with - | Ewildpat, _ -> Zaux.etrue, return - | Evarpat(id), _ -> - Zaux.etrue, with_eq (Zaux.eqmake (EQeq(p, e))) return - | Econstpat(c), _ -> or_op (Zaux.const c ty) e, return - | Econstr0pat(c), _ -> or_op (Zaux.constr0 c ty) e, return - | Econstr1pat _, _ -> assert false - | Etuplepat(p_list), Etuple(e_list) -> filter_list return p_list e_list - | Etuplepat(p_list), _ -> - (* filter (p1,...,pn) e *) - (* has the meaning of filter p1 (get e 0) ... filter pn (get e n) *) - (* introduce n fresh names *) - let n_ty_list = - List.map (fun { p_typ = ty } -> Zident.fresh "", ty) p_list in - let env = - List.fold_left - (fun acc (n, ty) -> Env.add n (Deftypes.entry Deftypes.value ty) acc) - Env.empty n_ty_list in - let e_list = List.map (fun (n, ty) -> Zaux.var n ty) n_ty_list in - let v_list = List.map (fun (n, ty) -> Zaux.varpat n ty) n_ty_list in - let cond, return = filter_list return p_list e_list in - cond, - with_env env - (with_eq (Zaux.eqmake (EQeq(Zaux.tuplepat v_list, e))) return) - | Ealiaspat(p, id), _ -> - let cond, return = filter return p e in - cond, with_eq (Zaux.eqmake (EQeq(Zaux.varpat id ty, e))) return - | Etypeconstraintpat(p, _), _ -> filter return p e - | Eorpat(p1, p2), _ -> - let cond1, return = filter return p1 e in - let cond2, return = filter return p2 e in - or_op cond1 cond2, return - | Erecordpat(l_p_list), _ -> - (* { l1 = p1; ...; ln = pn } = e *) - (* has the meaning of p1 = e.l1 ... pn = e.ln *) - let cond, return = - List.fold_left - (fun (cond, return) (l, p) -> - let cond_l_p, return = - filter return p (Zaux.record_access e l p.p_typ) in - and_op cond cond_l_p, return) - (etrue, return) l_p_list in - cond, return - -and filter_list return p_list e_list = - List.fold_left2 - (fun (cond, return) p e -> - let cond_p_e, return = filter return p e in - and_op cond cond_p_e, return) (Zaux.etrue, return) - p_list e_list - -(** In case a pattern matching is "simple", that is, *) -(* it is of the form P1 -> B1 | ... | Pn where the Pi are constructors *) -let is_a_case_statement p_h_list = - let is_constr0pat { m_pat = { p_desc = p_desc } } = - match p_desc with | Econstr0pat _ -> true | _ -> false in - List.for_all is_constr0pat p_h_list - -(** Translate a pattern matching construct into a conditional *) -(*- [match e with p1 -> B1 | ... | pn -> Bn] => - *- [c1 -> local ... B1 | ... | cn -> local ... Bn] *) -let match_into_condition total return e p_h_list = - let rec conditional return p_h_list = - match p_h_list with - | [] -> assert false - | [{ m_pat = p; m_body = b; m_env = env }] -> - let cond, return = filter (with_env env return) p e in - if !total then Zaux.eq_block b, return - else Zaux.eq_ifthen cond b, return - | { m_pat = p; m_body = b; m_env = env } :: p_h_list -> - let cond, return = filter (with_env env return) p e in - let b_else, return = conditional return p_h_list in - Zaux.eq_ifthenelse cond b - (Zaux.make_block Zident.Env.empty [b_else]), return in - conditional return p_h_list - - -(* translate expressions *) -let rec expression ({ e_desc = desc } as e) = - match desc with - | Elocal _ | Eglobal _ | Econst _ | Econstr0 _ | Elast _ -> e - | Eapp(app, e_arg, e_list) -> - { e with e_desc = Eapp(app, expression e_arg, - List.map expression e_list) } - | Eop(op, e_list) -> { e with e_desc = Eop(op, List.map expression e_list) } - | Erecord_access(e, lid) -> - { e with e_desc = Erecord_access(expression e, lid) } - | Erecord(l_e_list) -> - { e with e_desc = - Erecord (List.map (fun (l, e) -> (l, expression e)) l_e_list) } - | Etypeconstraint(e, ty) -> - { e with e_desc = Etypeconstraint(expression e, ty) } - | Etuple(e_list) -> - { e with e_desc = Etuple(List.map expression e_list) } - | Econstr1 _ | Ematch _ | Eseq _ | Elet _ | Eperiod _ | Eblock _ | Epresent _ - -> assert false - -let rec equation return ({ eq_desc = desc } as eq) = - match desc with - | EQeq(p, e) -> - { eq with eq_desc = EQeq(p, expression e) }, return - | EQinit(x, e) -> - { eq with eq_desc = EQinit(x, expression e) }, return - | EQreset(eq_list, e) -> - let eq_list, return = Zmisc.map_fold equation return eq_list in - { eq with eq_desc= EQreset(eq_list, expression e) }, return - | EQmatch(total, e, p_h_list) -> - let e = expression e in - let p_h_list = - List.map - (fun ({ m_body = b } as h) -> { h with m_body = block b }) - p_h_list in - if is_a_case_statement p_h_list - then { eq with eq_desc = EQmatch(total, e, p_h_list) }, return - else match_into_condition total return e p_h_list - | EQnext _ | EQblock _ | EQemit _ | EQautomaton _ - | EQpresent _ | EQder _ | EQpluseq _ - | EQand _| EQbefore _| EQforall _-> assert false - -and block ({ b_body = eq_list; b_env = b_env } as b) = - let eq_list, { eqs = eqs; env = env } = - Zmisc.map_fold equation empty eq_list in - let env = - State.fold - (fun env acc -> Env.append env acc) env b_env in - let eq_list = State.list eq_list eqs in - Zaux.extend_block env eq_list b - -let local ({ l_eq = eq_list; l_env = l_env } as l) = - let eq_list, { eqs = eqs; env = env } = - Zmisc.map_fold equation empty eq_list in - let env = - State.fold - (fun env acc -> Env.append env acc) env l_env in - let eq_list = State.list eq_list eqs in - Zaux.extend_local env eq_list l - -(* translate a top level expression *) -let let_expression ({ e_desc = desc } as e) = - match desc with - | Elet(l, e) -> { e with e_desc = Elet(local l, expression e) } - | _ -> expression e - -let implementation impl = - match impl.desc with - | Eopen _ | Etypedecl _ | Econstdecl _ -> impl - | Efundecl(n, ({ f_body = e } as body)) -> - { impl with desc = Efundecl(n, { body with f_body = let_expression e }) } - -let implementation_list impl_list = List.map implementation impl_list - diff --git a/compiler/verif/plmm.ml b/compiler/verif/plmm.ml deleted file mode 100644 index 98fb8b43b..000000000 --- a/compiler/verif/plmm.ml +++ /dev/null @@ -1,153 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* Printer for lmm *) - -open Zlocation -open Format -open Pp_tools -open Zident -open Lident -open Lmm - -let longname = Printer.longname -let name = Printer.name -let shortname = Printer.shortname - -let immediate ff = function - | Lint i -> fprintf ff "%d" i - | Lfloat f -> fprintf ff "%f" f - | Lbool b -> if b then fprintf ff "true" else fprintf ff "false" - | Lstring s -> fprintf ff "%S" s - | Lchar c -> fprintf ff "'%c'" c - | Lvoid -> fprintf ff "()" - -let constr0pat ff = function - | Lboolpat(b) -> fprintf ff "%s" (if b then "true" else "false") - | Lconstr0pat(ln) -> longname ff ln - -let rec expression ff e = - match e with - | Llocal(n) -> name ff n - | Llast(n) -> fprintf ff "@[(last %a)@]" name n - | Lglobal(ln) -> longname ff ln - | Lconst(i) -> immediate ff i - | Lconstr0(ln) -> longname ff ln - | Lapp(op, e_list) -> - fprintf ff "@[(%a %a)@]" operator op expression_list e_list - | Lrecord_access(e, ln) -> fprintf ff "@[%a.%a@]" expression e longname ln - | Lrecord(ln_e_list) -> - let handler ff (ln, e) = - fprintf ff "@[%a %a@]" longname ln expression e in - fprintf ff "@[(record@ %a)@]" (print_list_r handler "" "" "") ln_e_list - | Ltuple(e_list) -> - fprintf ff "@[(tuple@ %a)@]" (print_list_r expression "" "" "") e_list - | Lget(e, i) -> - fprintf ff "@[(get@ %a %d)@]" expression e i - | Lmerge(e, ln_e_list) -> - let handler ff (cpat, e) = - fprintf ff "@[%a %a@]" constr0pat cpat expression e in - fprintf ff "@[(merge@ %a@ %a)@]" expression e - (print_list_r handler "" "" "") ln_e_list - | Lwhen(e1, cpat, e2) -> - fprintf ff - "@[(when@ %a@ %a(%a)@]" expression e1 constr0pat cpat expression e2 - -and expression_list ff e_list = print_list_r expression "" " " "" ff e_list - -and kind ff k = - match k with - | Def -> fprintf ff "def" - | Init(r) -> fprintf ff "init%a" reset_opt r - | Next -> fprintf ff "next" - -and reset ff r = - match r with - | Res_never -> fprintf ff "false" - | Res_else(r, e) -> fprintf ff "@[(else %a %a)@]" reset r expression e - -and reset_opt ff r = - match r with - | Res_never -> () - | Res_else(Res_never, e) -> fprintf ff "@[(%a)@]" expression e - | Res_else(r, e) -> fprintf ff "@[(%a || %a)@]" reset_opt r expression e - -and clock ff ck = - match ck with - | Ck_base -> fprintf ff "true" - | Ck_on(ck, cpat, e) -> - fprintf ff "@[(on %a %a(%a))@]" clock ck constr0pat cpat expression e - -and clock_opt ff ck = - match ck with - | Ck_base -> () | _ -> fprintf ff "@[ on %a@]" clock ck - -and operator ff op = - match op with - | Lunarypre -> fprintf ff "pre" - | Lfby -> fprintf ff "fby" - | Lminusgreater -> fprintf ff "->" - | Lifthenelse -> fprintf ff "if" - | Lsharp -> fprintf ff "#" - | Lop(ln) -> longname ff ln - -let equation ff { eq_kind = k; eq_ident = x; eq_exp = e; eq_clock = ck } = - fprintf ff "@[(%a %a = %a%a)@]" kind k name x expression e clock_opt ck - -let rec ptype ff ty = - match ty with - | Tint -> fprintf ff "int" - | Tbool -> fprintf ff "bool" - | Tfloat -> fprintf ff "float" - | Tunit -> fprintf ff "unit" - | Tchar -> fprintf ff "char" - | Tstring -> fprintf ff "string" - | Tconstr(qualid) -> Ptypes.print_qualid ff qualid - | Tproduct(ty_list) -> Pp_tools.print_list_r ptype "(" " * " ")" ff ty_list - -let print_env ff env = - print_list_r - (fun ff (n,{ t_typ = ty }) -> fprintf ff "@[(%a %a)@]" name n ptype ty) - "(environment " "" ")" ff (Env.bindings env) - -let fundecl ff n { f_inputs = inputs; f_output = output; - f_env = env; f_body = eq_list; f_assert = e_list } = - fprintf ff "@[(property %s%a(%a)@,@[(%a@,%a@,%a))@]@]" - n - (print_list_l name "(" " " ")") inputs - name output - print_env env - (print_list_l expression "(assert " " " ")") e_list - (print_list_l equation "(equation " " " ")") eq_list - -let type_decl ff ty_decl = - match ty_decl with - | Labstract_type -> () - | Lvariant_type(tag_name_list) -> - fprintf ff "@[(sum %a)@]" (print_list_l shortname "" " " "") tag_name_list - | Lrecord_type(n_ty_list) -> - let handler ff (n, ty) = - fprintf ff "@[%a %a@]" shortname n ptype ty in - fprintf ff "@[(record %a)@]" (print_list_l handler "" "" "") n_ty_list - -let implementation ff impl = - match impl with - | Lconstdecl(n, e) -> fprintf ff "@[(const %s %a)@]\n@." n expression e - | Lfundecl(n, f) -> fundecl ff n f - | Ltypedecl(n, ty_decl) -> - fprintf ff "@[(type %s@, %a)@.@]" n type_decl ty_decl - -let implementation_list ff imp_list = - print_list_l implementation "" " " "" ff imp_list - diff --git a/compiler/verif/tuple2record.orphan.ml b/compiler/verif/tuple2record.orphan.ml deleted file mode 100644 index fe4951bb0..000000000 --- a/compiler/verif/tuple2record.orphan.ml +++ /dev/null @@ -1,166 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* Rewrite tuples into records. *) - -open Zmisc -open Zelus -open Zaux -open Zident -open Deftypes - -(* a memoization table which associates a type name to a list of types names *) -(* used to avoid creating several definition of the same type *) -(* very limited stuff here: (t1 * t2) and (t2 * t1) will be associated to *) -(* two different type definitions. To be improved ! *) -module T = - Map.Make - (struct - type t = name list - let compare t1 t2 = Pervasives.compare t1 t2 - end) - -type result = { ty_name: name; - ty_labels: name list; } - -type return = - { def_types: (name * typ) Zmisc.Env.t; - (* the list of declared record types: type t = { l1: t1;...; ln: tn } *) - table: result T.t; - (* inverse table: the type name and the list of labels *) - (* associated to a tuple type (t1,..., tn) *) - } - -let empty = { def_types = Zmisc.Env.empty; table = T.empty } - -(** Return the record type associated to the tuple type [ty_list] *) -let recordtype ({ def_types = dtypes; table = table } as return) ty_list = - let (ty, l_list), return = - try - .find ty_list table, return - with - | Not_found -> - (* add a new type *) - let l_list = List.map (fun _ -> Zident.fresh "l") ty_list in - let l_ty_list = - List.map2 (fun l ty -> (l, ty)) l_list ty_list in - let ty_name = Zident.fresh "ty" in - let dtypes = Zmisc.Env.add ty_name l_ty_list dtypes in - let table = (ty_list, ty, l_list) :: table in - ty_name, l_list, { def_types = dtypes; table = table } in - Zaux.record l_list e_list ty - -(* Translate a tuple into a record *) -let tuple_into_record return e_list = - let ty_list = List.map (fun e -> e.e_typ) e_list in - recordtype return ty_list - -(* Translate a tuple into a record *) -let tuplepat_into_record return e_list = - recordtype return ty_list - -let rec pattern return ({ p_desc = desc } as p) = - match desc with - | Ewildpat | Econstpat _ | Econstr0pat _ | Evarpat _ -> p, return - | Etuplepat(p_list) -> - let p_list, return = Zmisc.map_fold pattern return p_list in - tuplepat_into_recordpat return p_list - | Etypeconstraintpat(p, ty) -> - let p, return = pattern return p in - { p with p_desc = Etypeconstraintpat(p, ty) }, return - | Eorpat _ | Erecordpat _ -> assert false - -(* translate expressions *) -let rec expression return ({ e_desc = desc } as e) = - match desc with - | Elocal _ | Eglobal _ | Econst _ | Econstr0 _ | Elast _ -> e, return - | Eapp(app, e_arg, e_list) -> - let e_arg, return = expression return e_arg in - let e_list, return = Zmisc.map_fold expression return e_list in - { e with e_desc = Eapp(app, e_arg, e_list) }, return - | Eop(op, e_list) -> - let e_list, return = Zmisc.map_fold expression return e_list in - { e with e_desc = Eop(op, e_list) }, return - | Erecord_access(e, lid) -> - let e, return = expression return e in - { e with e_desc = Erecord_access(e, lid) }, return - | Erecord(l_e_list) -> - let l_e_list, return = - Zmisc.map_fold - (fun return (l, e) -> - let e, return = expression return e in (l, e), return) - return l_e_list in - { e with e_desc = Erecord (l_e_list) }, return - | Etypeconstraint(e, ty) -> - let e, return = expression return e in - { e with e_desc = Etypeconstraint(e, ty) }, return - | Etuple(e_list) -> - let e_list, return = Zmisc.map_fold expression return e_list in - tuple_into_record return e_list - | Ematch _ | Eseq _ | Elet _ | Eperiod _ | Eblock _ | Epresent _ - -> assert false - -let rec equation return ({ eq_desc = desc } as eq) = - match desc with - | EQeq(p, e) -> - let return, e = expression return e in - { eq with eq_desc = EQeq(p, e ) }, return - | EQinit(x, e) -> - let return, e = expression return e in - { eq with eq_desc = EQinit(x, e) }, return - | EQreset(eq_list, e) -> - let eq_list, return = Zmisc.map_fold equation return eq_list in - let return, e = expression return e in - { eq with eq_desc= EQreset(eq_list, e) }, return - | EQmatch(total, e, p_h_list) -> - let p_h_list, return = - Zmisc.map_fold - (fun return ({ m_body = b } as h) -> - let return, b = block return b in - { h with m_body = b }, return) - return p_h_list in - let e, return = expression return e in - { eq with eq_desc = EQmatch(total, e, p_h_list) }, return - | EQnext _ | EQblock _ | EQemit _ | EQautomaton _ - | EQpresent _ | EQder _ | EQpluseq _ - | EQand _| EQbefore _| EQforall _-> assert false - -and block return ({ b_body = eq_list; b_env = b_env } as b) = - let eq_list, return = Zmisc.map_fold equation return eq_list in - { b with b_body = eq_list }, return - -let local return ({ l_eq = eq_list; l_env = l_env } as l) = - let eq_list, return = Zmisc.map_fold equation return eq_list in - { l with l_eq = eq_list }, return - -(* translate a top level expression *) -let let_expression return ({ e_desc = desc } as e) = - match desc with - | Elet(l, e) -> - let l, return = local return l in - let e, return = expression return e in - { e with e_desc = Elet(l, e) }, return - | _ -> expression return e - -let implementation return impl = - match impl.desc with - | Eopen _ | Etypedecl _ | Econstdecl _ -> impl, return - | Efundecl(n, ({ f_body = e } as body)) -> - let e, return = expression return e in - { impl with desc = Efundecl(n, { body with f_body = e }) }, return - -let implementation_list impl_list = - let impl_list, return = Zmisc.map_fold implementation empty impl_list in - impl_list - diff --git a/compiler/verif/zlus2lmm.ml b/compiler/verif/zlus2lmm.ml deleted file mode 100644 index 1860800a7..000000000 --- a/compiler/verif/zlus2lmm.ml +++ /dev/null @@ -1,345 +0,0 @@ -(***********************************************************************) -(* *) -(* *) -(* Zelus, a synchronous language for hybrid systems *) -(* *) -(* (c) 2020 Inria Paris (see the AUTHORS file) *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed under *) -(* the terms of the INRIA Non-Commercial License Agreement (see the *) -(* LICENSE file). *) -(* *) -(* *********************************************************************) - -(* Translation into Lmm. This is applied after complex pattern matchings *) -(* have been turned into primitive pattern matchings on an enumerated *) -(* set of values (in particular booleans) *) - -(* no automaton, no present, no pre/fby/->. All names must be *) -(* pair-wise differents; no complex pattern matchings *) - -(* Tr(ck)(res)(match e with - | p1 -> E1 | ... | pn -> En) = - - with one defined variable y (defnames = {y}) and used variable x - (example: E1 = local t in do t = x + 3 and y = t + 2 done) - -becomes: - - local c in - do - c = Tr(ck)(e) - and - Tr(c on c1)(E1)[y_1/y] - and - ... - and - Tr(c on cn)(En)[y_n/y] - and - c1 = test(p1)(c) and ... and cn = test(pn)(c) - and - pat(p1) = c and ... and pat(pn) = c - and - y = if c1 then y_1 else ... if cn then y_n [else pre y] - -where: - - test(p)(c) returns an expression testing that the pattern p matches c - pat(p) returns a pattern with variables only - -Tr(ck)(x = e) = x = if ck then Tr(ck)(e) else pre x - with the special case that if base then e else e' = e - -*) - -open Zlocation -open Zmisc -open Zident -open Deftypes -open Zelus -open Lmm -open List -open Format - -type error = - | Etype - | Ehybrid_operator - | Earray_operator - | Eapplication - -exception Error of location * error - -let error loc kind = raise (Error(loc, kind)) - -let message loc kind = - begin match kind with - | Etype -> - eprintf "@[%aTranslation to L--: This type cannot be translated.@.@]" - output_location loc - | Ehybrid_operator -> - eprintf "@[%aTranslation to L--: Hybrid operators are not treated.@.@]" - output_location loc - | Earray_operator -> - eprintf "@[%aTranslation to L--: Array operators are not treated.@.@]" - output_location loc - | Eapplication -> - eprintf "@[%aTranslation to L--: \ - Application must be of the form f(e1,...,en).@.@]" - output_location loc - end - -(* The translation function takes and returns a set *) -(* of equations, assertions and environment *) -type return = - { eqs: eq State.t; - env: tentry Env.t State.t; - assertion: exp State.t } - -let empty = - { eqs = State.empty; env = State.empty; assertion = State.empty } - -let with_env ({ env = env0 } as return) env = - { return with env = State.cons env env0 } - -let with_eq ({ eqs = eqs } as return) eq = - { return with eqs = State.cons eq eqs } - -let par { eqs = eqs1; env = env1; assertion = as1 } - { eqs = eqs2; env = env2; assertion = as2 } = - { eqs = State.par eqs1 eqs2; env = State.par env1 env2; - assertion = State.par as1 as2 } - -let eq_make k x e ck = - { eq_kind = k; eq_ident = x; - eq_exp = e; eq_clock = ck } - -let on ck ln c = Ck_on(ck, ln, c) -let relse res c = Res_else(res, c) - -(* immediate values *) -let immediate = function - | Eint(i) -> Lint(i) - | Efloat(f) -> Lfloat(f) - | Ebool(b) -> Lbool(b) - | Echar(c) -> Lchar(c) - | Estring(s) -> Lstring(s) - | Evoid -> Lvoid - -(** Translation of a pattern. *) -(* It must be either a constructor or a boolean value. Otherwise, *) -(* the translation fails. *) -let constr0pat { p_desc = p_desc } = - match p_desc with - | Econstpat(Ebool(b)) -> Lboolpat(b) - | Econstr0pat(c) -> Lconstr0pat(c) - | _ -> assert false - -(* Translation of a type. For the moment, only a small set of *) -(* basic types are translated *) -let rec type_of loc { t_desc = ty } = - match ty with - | Deftypes.Tconstr(q, [], _) -> - if q = Initial.int_ident then Tint - else if q = Initial.int32_ident then Tint - else if q = Initial.int64_ident then Tint - else if q = Initial.bool_ident then Tbool - else if q = Initial.zero_ident then Tbool - else if q = Initial.float_ident then Tfloat - else if q = Initial.char_ident then Tchar - else if q = Initial.string_ident then Tstring - else if q = Initial.unit_ident then Tunit - else Lmm.Tconstr(q) - | Tconstr _ -> error loc Etype - | Tproduct(ty_list) -> Lmm.Tproduct(List.map (type_of loc) ty_list) - | Tvar | Tvec _ | Tfun _ -> error loc Etype - | Tlink(ty) -> type_of loc ty - -let type_expression loc ty_e = - let { typ_body = ty } = Interface.scheme_of_type ty_e in - type_of loc ty - -let env_of_env loc env = - Env.map (fun { Deftypes.t_typ = ty } -> { t_typ = type_of loc ty }) env - -(* translate an operator *) -let operator loc op e_list = - match op with - | Eifthenelse -> Lapp(Lifthenelse, e_list) - | Eunarypre -> Lapp(Lunarypre, e_list) - | Eminusgreater -> Lapp(Lminusgreater, e_list) - | Efby -> Lapp(Lfby, e_list) - | Eup | Einitial | Edisc | Ehorizon -> error loc Ehybrid_operator - | Eaccess | Eupdate | Econcat | Eslice _ -> error loc Earray_operator - | Etest | Eatomic -> assert false - -(* the set of shared variables from a set of defined names *) -let shared_variables { dv = dv } = dv - -(* returns the expression associated to [x] in a substitution [name_to_exp] *) -(* if [x] is unbound, returns [last x] *) -let get x name_to_exp = - try - Env.find x name_to_exp - with - | Not_found -> Llast(x) - -(* translate expressions *) -let rec expression ck { e_desc = desc; e_loc = loc } = - match desc with - | Elocal(id) -> Llocal(id) - | Eglobal { lname = lid } -> Lglobal(lid) - | Econst(im) -> Lconst(immediate im) - | Econstr0(lid) -> Lconstr0(lid) - | Econstr1 _ -> assert false - | Elast(x) -> Llast(x) - | Eapp(_, { e_desc = Eglobal { lname = lid } }, e_list) -> - Lapp(Lop(lid), List.map (expression ck) e_list) - | Eapp _ -> error loc Eapplication - | Eop(op, e_list) -> - operator loc op (map (expression ck) e_list) - | Erecord_access(e, lid) -> - Lrecord_access(expression ck e, lid) - | Erecord(l_e_list) -> - Lrecord - (map (fun (l, e) -> (l, expression ck e)) l_e_list) - | Etypeconstraint(e, _) -> expression ck e - | Etuple(e_list) -> Ltuple(List.map (expression ck) e_list) - | Ematch _ | Eseq _ | Elet _ - | Eperiod _ | Eblock _ | Epresent _ -> assert false - - -(* [split s_set ({ eqs } as return) = name_to_exp, return'] splits eqs into *) -(* two complementary sets of equations *) -(* [name_to_exp] associates an expression to any names from [s_set] *) -let split s_set ({ eqs = eqs } as return) = - let eq_name_exp, eqs = - State.partition (fun { eq_ident = id } -> S.mem id s_set) eqs in - let name_to_exp = - State.fold (fun { eq_ident = id; eq_exp = e } acc -> Env.add id e acc) - eq_name_exp Env.empty in - name_to_exp, { return with eqs = eqs } - -(* [equation ck res eq = return] *) -let rec equation ck res { eq_desc = desc; eq_write = defnames } = - match desc with - | EQeq({ p_desc = Evarpat(x) }, e) -> - with_eq empty (eq_make Def x (expression ck e) ck) - | EQinit(x, e) -> - let e = expression ck e in - with_eq empty (eq_make (Init(res)) x e ck) - | EQreset(eq_list, e) -> - let e = expression ck e in - equation_list ck (relse res e) eq_list - | EQmatch(total, e, p_h_list) -> - (* the conditional is necessary of the form: - *- match e with P1 -> B1 | ... | Pn -> Bn - *- with P1 | ... | Pn are the element of a sum type *) - (* first translate [e] *) - let e = expression ck e in - (* then compute the set of shared variables *) - let s_set = shared_variables defnames in - - (* translate the list of handlers *) - let equations_from_handler e p b = - let co = constr0pat p in - let return = block (on ck co e) res b in - let name_to_exp, return = split s_set return in - co, name_to_exp, return in - - let constrpat_to_exp_list, return = - Zmisc.map_fold - (fun return { m_pat = p; m_body = b } -> - let co, name_to_exp, return_name_to_exp = - equations_from_handler e p b in - (co, name_to_exp), par return return_name_to_exp) - empty p_h_list in - - (* merge results for every shared variable. Returns *) - (* merge x (P1 -> e1) ... (Pn -> en) *) - let merge e x constrpat_name_to_exp_list = - let p_e_list = - List.map - (fun (co, name_to_exp) -> co, get x name_to_exp) - constrpat_name_to_exp_list in - Lmerge(e, p_e_list) in - let eq_list = - S.fold - (fun x eq_list -> - (eq_make Def x (merge e x constrpat_to_exp_list) ck) :: eq_list) - s_set [] in - List.fold_left with_eq empty eq_list - | EQeq _ | EQnext _ | EQblock _ | EQemit _ | EQautomaton _ - | EQpresent _ | EQder _ | EQpluseq _ - | EQand _| EQbefore _| EQforall _-> assert false - -and equation_list ck res eq_list = - fold_left (fun acc eq -> par acc (equation ck res eq)) empty eq_list - -and block ck res { b_body = body_eq_list; b_env = n_env; b_loc = loc } = - let return = equation_list ck res body_eq_list in - with_env return (env_of_env loc n_env) - -let local ck res { l_eq = eq_list; l_env = l_env; l_loc = loc } = - let return = equation_list ck res eq_list in - with_env return (env_of_env loc l_env) - -(* translate a top level expression *) -let let_expression ck res n_output ({ e_desc = desc } as e) = - match desc with - | Elet(l, e) -> - let return = local ck res l in - let e = expression ck e in - with_eq return (eq_make Def n_output e ck) - | _ -> - let e = expression ck e in - with_eq empty (eq_make Def n_output e ck) - -let kind = function | S | AS | A | AD -> A | D -> D | C -> assert false - -(* translation of a type declaration *) -let typedecl loc n params td = - let decl { desc = desc } = - match desc with - | Eabstract_type -> Labstract_type - | Evariant_type _ -> assert false - | Erecord_type(n_ty_list) -> - Lrecord_type - (List.map (fun (n, ty) -> (n, type_expression loc ty)) n_ty_list) - | Eabbrev _ -> assert false in - match params with - | [] -> Ltypedecl(n, decl td) - | _ -> assert false - -let implementation lmm_nodes lmm_list impl = - match impl.desc with - | Eopen _ -> lmm_list - | Etypedecl(n, params, td) -> - typedecl impl.loc n params td :: lmm_list - | Econstdecl(n, _, e) -> - if Zmisc.S.mem n lmm_nodes - then Lconstdecl(n, expression Ck_base e) :: lmm_list - else lmm_list - | Efundecl(n, { f_kind = k; f_args = p_list; f_env = f_env; f_body = e }) -> - if Zmisc.S.mem n lmm_nodes then - let iset = List.fold_left (Vars.fv_pat S.empty) S.empty p_list in - let i_list = S.elements iset in - let n_output = Zident.fresh "out" in - let { eqs = eqs; env = env; assertion = assertion } = - let_expression Ck_base Res_never n_output e in - let env = - State.fold - (fun env acc -> Env.append env acc) env (env_of_env impl.loc f_env) in - let eq_list = State.list [] eqs in - let assertion = - State.fold (fun e acc -> e :: acc) assertion [] in - Lfundecl(n, { f_inputs = i_list; - f_output = n_output; - f_env = env; - f_body = eq_list; - f_assert = assertion }) :: lmm_list - else lmm_list - -let implementation_list lmm_nodes impl_list = - rev (fold_left (implementation lmm_nodes) [] impl_list) -