2012-06-27 18:09:30 +02:00
|
|
|
(***********************************************************************)
|
|
|
|
(* *)
|
|
|
|
(* Heptagon *)
|
|
|
|
(* *)
|
|
|
|
(* Gwenael Delaval, LIG/INRIA, UJF *)
|
|
|
|
(* Leonard Gerard, Parkas, ENS *)
|
|
|
|
(* Adrien Guatto, Parkas, ENS *)
|
|
|
|
(* Cedric Pasteur, Parkas, ENS *)
|
2012-06-29 01:43:15 +02:00
|
|
|
(* Marc Pouzet, Parkas, ENS *)
|
2012-06-27 18:09:30 +02:00
|
|
|
(* *)
|
|
|
|
(* Copyright 2012 ENS, INRIA, UJF *)
|
|
|
|
(* *)
|
|
|
|
(* This file is part of the Heptagon compiler. *)
|
|
|
|
(* *)
|
|
|
|
(* Heptagon is free software: you can redistribute it and/or modify it *)
|
|
|
|
(* under the terms of the GNU General Public License as published by *)
|
|
|
|
(* the Free Software Foundation, either version 3 of the License, or *)
|
|
|
|
(* (at your option) any later version. *)
|
|
|
|
(* *)
|
|
|
|
(* Heptagon is distributed in the hope that it will be useful, *)
|
|
|
|
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
|
|
|
|
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
|
|
|
|
(* GNU General Public License for more details. *)
|
|
|
|
(* *)
|
|
|
|
(* You should have received a copy of the GNU General Public License *)
|
|
|
|
(* along with Heptagon. If not, see <http://www.gnu.org/licenses/> *)
|
|
|
|
(* *)
|
|
|
|
(***********************************************************************)
|
2010-07-09 11:33:17 +02:00
|
|
|
open Misc
|
2010-09-15 09:38:52 +02:00
|
|
|
open Errors
|
2010-07-09 11:33:17 +02:00
|
|
|
open Types
|
|
|
|
open Signature
|
2011-11-14 15:29:31 +01:00
|
|
|
open Clocks
|
|
|
|
open Idents
|
2010-07-09 11:33:17 +02:00
|
|
|
|
|
|
|
type 'a global_it_funs = {
|
2011-03-21 14:30:19 +01:00
|
|
|
static_exp : 'a global_it_funs -> 'a -> static_exp -> static_exp * 'a;
|
|
|
|
static_exp_desc : 'a global_it_funs -> 'a -> static_exp_desc -> static_exp_desc * 'a;
|
|
|
|
ty : 'a global_it_funs -> 'a -> ty -> ty * 'a;
|
2011-11-14 15:29:31 +01:00
|
|
|
ct : 'a global_it_funs -> 'a -> ct -> ct * 'a;
|
2011-03-21 14:30:19 +01:00
|
|
|
ck : 'a global_it_funs -> 'a -> ck -> ck * 'a;
|
2011-11-14 15:29:31 +01:00
|
|
|
link : 'a global_it_funs -> 'a -> link -> link * 'a;
|
|
|
|
var_ident : 'a global_it_funs -> 'a -> var_ident -> var_ident * 'a;
|
2011-03-21 14:30:19 +01:00
|
|
|
param : 'a global_it_funs -> 'a -> param -> param * 'a;
|
|
|
|
arg : 'a global_it_funs -> 'a -> arg -> arg * 'a;
|
|
|
|
node : 'a global_it_funs -> 'a -> node -> node * 'a;
|
|
|
|
structure : 'a global_it_funs -> 'a -> structure -> structure * 'a;
|
|
|
|
field : 'a global_it_funs -> 'a -> field -> field * 'a; }
|
2010-07-09 11:33:17 +02:00
|
|
|
|
|
|
|
let rec static_exp_it funs acc se = funs.static_exp funs acc se
|
|
|
|
and static_exp funs acc se =
|
|
|
|
let se_ty, acc = ty_it funs acc se.se_ty in
|
2010-08-17 18:30:37 +02:00
|
|
|
let se_desc, acc = static_exp_desc_it funs acc se.se_desc in
|
2010-07-09 11:33:17 +02:00
|
|
|
{ se with se_desc = se_desc; se_ty = se_ty }, acc
|
|
|
|
|
|
|
|
and static_exp_desc_it funs acc sd =
|
|
|
|
try funs.static_exp_desc funs acc sd
|
|
|
|
with Fallback -> static_exp_desc funs acc sd
|
|
|
|
|
|
|
|
and static_exp_desc funs acc sd = match sd with
|
2011-05-10 16:55:46 +02:00
|
|
|
| Svar _ | Sint _ | Sfloat _ | Sbool _ | Sstring _ | Sconstructor _ | Sfield _ -> sd, acc
|
2010-07-09 11:33:17 +02:00
|
|
|
| Stuple se_l ->
|
|
|
|
let se_l, acc = mapfold (static_exp_it funs) acc se_l in
|
|
|
|
Stuple se_l, acc
|
|
|
|
| Sarray se_l ->
|
|
|
|
let se_l, acc = mapfold (static_exp_it funs) acc se_l in
|
|
|
|
Sarray se_l, acc
|
|
|
|
| Sop (n, se_l) ->
|
|
|
|
let se_l, acc = mapfold (static_exp_it funs) acc se_l in
|
|
|
|
Sop (n, se_l), acc
|
2011-05-26 18:39:33 +02:00
|
|
|
| Sarray_power (se1, se_l) ->
|
2010-07-09 11:33:17 +02:00
|
|
|
let se1, acc = static_exp_it funs acc se1 in
|
2011-05-26 18:39:33 +02:00
|
|
|
let se_l, acc = mapfold (static_exp_it funs) acc se_l in
|
|
|
|
Sarray_power(se1, se_l), acc
|
2010-07-09 11:33:17 +02:00
|
|
|
| Srecord f_se_l ->
|
|
|
|
let aux acc (f,se) = let se,acc = static_exp_it funs acc se in
|
|
|
|
(f, se), acc in
|
|
|
|
let f_se_l, acc = mapfold aux acc f_se_l in
|
|
|
|
Srecord f_se_l, acc
|
|
|
|
|
2010-11-01 01:04:35 +01:00
|
|
|
|
2010-07-09 11:33:17 +02:00
|
|
|
and ty_it funs acc t = try funs.ty funs acc t with Fallback -> ty funs acc t
|
|
|
|
and ty funs acc t = match t with
|
|
|
|
| Tid _ -> t, acc
|
|
|
|
| Tprod t_l -> let t_l, acc = mapfold (ty_it funs) acc t_l in Tprod t_l, acc
|
|
|
|
| Tarray (t, se) ->
|
|
|
|
let t, acc = ty_it funs acc t in
|
|
|
|
let se, acc = static_exp_it funs acc se in
|
|
|
|
Tarray (t, se), acc
|
2011-04-14 18:06:54 +02:00
|
|
|
| Tinvalid -> t, acc
|
2011-11-14 15:29:31 +01:00
|
|
|
|
|
|
|
and ct_it funs acc c = try funs.ct funs acc c with Fallback -> ct funs acc c
|
2010-08-17 18:30:37 +02:00
|
|
|
and ct funs acc c = match c with
|
|
|
|
| Ck(ck) -> let ck, acc = ck_it funs acc ck in Ck ck, acc
|
|
|
|
| Cprod(ct_l) ->
|
|
|
|
let ct_l, acc = mapfold (ct_it funs) acc ct_l in Cprod ct_l, acc
|
|
|
|
|
|
|
|
and ck_it funs acc c = try funs.ck funs acc c with Fallback -> ck funs acc c
|
|
|
|
and ck funs acc c = match c with
|
|
|
|
| Cbase -> c, acc
|
|
|
|
| Cvar(link_ref) ->
|
|
|
|
let l, acc = link_it funs acc link_ref.contents in
|
|
|
|
Cvar {link_ref with contents = l}, acc
|
2011-11-14 15:29:31 +01:00
|
|
|
| Con(ck, constructor_name, v) ->
|
2010-08-17 18:30:37 +02:00
|
|
|
let ck, acc = ck_it funs acc ck in
|
2011-11-14 15:29:31 +01:00
|
|
|
let v, acc = var_ident_it funs acc v in
|
|
|
|
Con (ck, constructor_name, v), acc
|
2010-08-17 18:30:37 +02:00
|
|
|
|
|
|
|
and link_it funs acc c =
|
|
|
|
try funs.link funs acc c with Fallback -> link funs acc c
|
|
|
|
and link funs acc l = match l with
|
|
|
|
| Cindex _ -> l, acc
|
|
|
|
| Clink(ck) -> let ck, acc = ck_it funs acc ck in Clink ck, acc
|
2011-11-14 15:29:31 +01:00
|
|
|
|
|
|
|
|
|
|
|
and var_ident_it funs acc i = funs.var_ident funs acc i
|
|
|
|
and var_ident funs acc i = i, acc
|
2010-08-17 18:30:37 +02:00
|
|
|
|
2010-07-09 11:33:17 +02:00
|
|
|
and structure_it funs acc s = funs.structure funs acc s
|
|
|
|
and structure funs acc s =
|
|
|
|
mapfold (field_it funs) acc s
|
|
|
|
|
|
|
|
|
|
|
|
and field_it funs acc f = funs.field funs acc f
|
|
|
|
and field funs acc f =
|
|
|
|
let ty, acc = ty_it funs acc f.f_type in
|
|
|
|
{ f with f_type = ty }, acc
|
|
|
|
|
|
|
|
|
|
|
|
and param_it funs acc p = funs.param funs acc p
|
|
|
|
and param funs acc p =
|
|
|
|
let p_type, acc = ty_it funs acc p.p_type in
|
|
|
|
{ p with p_type = p_type }, acc
|
|
|
|
|
2010-07-13 13:55:29 +02:00
|
|
|
and arg_it funs acc a = funs.arg funs acc a
|
|
|
|
and arg funs acc a =
|
|
|
|
let a_type, acc = ty_it funs acc a.a_type in
|
|
|
|
{ a with a_type = a_type }, acc
|
|
|
|
|
|
|
|
|
|
|
|
and node_it funs acc n = funs.node funs acc n
|
|
|
|
and node funs acc n =
|
|
|
|
let node_params, acc = mapfold (param_it funs) acc n.node_params in
|
|
|
|
let node_inputs, acc = mapfold (arg_it funs) acc n.node_inputs in
|
|
|
|
let node_outputs, acc = mapfold (arg_it funs) acc n.node_outputs in
|
|
|
|
{ n with node_params = node_params;
|
|
|
|
node_inputs = node_inputs;
|
|
|
|
node_outputs = node_outputs }, acc
|
|
|
|
|
2010-07-09 11:33:17 +02:00
|
|
|
|
2010-07-14 00:55:14 +02:00
|
|
|
let defaults = {
|
2010-07-09 11:33:17 +02:00
|
|
|
static_exp = static_exp;
|
|
|
|
static_exp_desc = static_exp_desc;
|
|
|
|
ty = ty;
|
2011-11-14 15:29:31 +01:00
|
|
|
ct = ct;
|
|
|
|
ck = ck;
|
|
|
|
link = link;
|
|
|
|
var_ident = var_ident;
|
2010-07-09 11:33:17 +02:00
|
|
|
structure = structure;
|
|
|
|
field = field;
|
|
|
|
param = param;
|
2010-07-13 13:55:29 +02:00
|
|
|
arg = arg;
|
|
|
|
node = node;
|
2010-07-09 11:33:17 +02:00
|
|
|
}
|
2010-07-09 13:27:06 +02:00
|
|
|
|
2010-07-14 00:55:14 +02:00
|
|
|
|
2010-08-17 18:30:37 +02:00
|
|
|
(** Is used to stop the pass at this level *)
|
2010-09-14 09:39:02 +02:00
|
|
|
let stop _ acc x = x, acc
|
2010-07-14 00:55:14 +02:00
|
|
|
|
|
|
|
let defaults_stop = {
|
|
|
|
static_exp = stop;
|
|
|
|
static_exp_desc = stop;
|
|
|
|
ty = stop;
|
2011-11-14 15:29:31 +01:00
|
|
|
ct = stop;
|
|
|
|
ck = stop;
|
|
|
|
link = stop;
|
|
|
|
var_ident = stop;
|
2010-07-14 00:55:14 +02:00
|
|
|
structure = stop;
|
|
|
|
field = stop;
|
|
|
|
param = stop;
|
|
|
|
arg = stop;
|
|
|
|
node = stop;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
2010-07-09 13:27:06 +02:00
|
|
|
(** [it_gather gather f] will create a function to iterate
|
|
|
|
over a type using [f] and then use [gather] to combine
|
|
|
|
the value of the local accumulator with the one
|
|
|
|
given as argument. *)
|
|
|
|
let it_gather gather f funs acc e =
|
2010-07-14 00:55:14 +02:00
|
|
|
let e, new_acc = f funs acc e in
|
|
|
|
e, gather acc new_acc
|