lustrec / src / delay.ml @ 0cbf0839
History | View | Annotate | Download (3.3 KB)
1 |
(* ---------------------------------------------------------------------------- |
---|---|
2 |
* SchedMCore - A MultiCore Scheduling Framework |
3 |
* Copyright (C) 2009-2011, ONERA, Toulouse, FRANCE - LIFL, Lille, FRANCE |
4 |
* |
5 |
* This file is part of Prelude |
6 |
* |
7 |
* Prelude is free software; you can redistribute it and/or |
8 |
* modify it under the terms of the GNU Lesser General Public License |
9 |
* as published by the Free Software Foundation ; either version 2 of |
10 |
* the License, or (at your option) any later version. |
11 |
* |
12 |
* Prelude is distributed in the hope that it will be useful, but |
13 |
* WITHOUT ANY WARRANTY ; without even the implied warranty of |
14 |
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
15 |
* Lesser General Public License for more details. |
16 |
* |
17 |
* You should have received a copy of the GNU Lesser General Public |
18 |
* License along with this program ; if not, write to the Free Software |
19 |
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 |
20 |
* USA |
21 |
*---------------------------------------------------------------------------- *) |
22 |
|
23 |
(** Types definitions and a few utility functions on delay types. *) |
24 |
(** Delay analysis by type polymorphism instead of constraints *) |
25 |
open Utils |
26 |
|
27 |
type delay_expr = |
28 |
{mutable ddesc: delay_desc; |
29 |
did: int} |
30 |
|
31 |
and delay_desc = |
32 |
| Dvar (* Monomorphic type variable *) |
33 |
| Dundef |
34 |
| Darrow of delay_expr * delay_expr |
35 |
| Dtuple of delay_expr list |
36 |
| Dlink of delay_expr (* During unification, make links instead of substitutions *) |
37 |
| Dunivar (* Polymorphic type variable *) |
38 |
type error = |
39 |
| Delay_clash of delay_expr * delay_expr |
40 |
|
41 |
exception Unify of delay_expr * delay_expr |
42 |
exception Error of Location.t * error |
43 |
|
44 |
let new_id = ref (-1) |
45 |
|
46 |
let new_delay desc = |
47 |
incr new_id; {ddesc = desc; did = !new_id } |
48 |
|
49 |
let new_var () = |
50 |
new_delay Dvar |
51 |
|
52 |
let new_univar () = |
53 |
new_delay Dunivar |
54 |
|
55 |
let rec repr = |
56 |
function |
57 |
{ddesc = Dlink i'} -> |
58 |
repr i' |
59 |
| i -> i |
60 |
|
61 |
(** Splits [ty] into the [lhs,rhs] of an arrow type. Expects an arrow type |
62 |
(ensured by language syntax) *) |
63 |
let split_arrow de = |
64 |
match (repr de).ddesc with |
65 |
| Darrow (din,dout) -> din,dout |
66 |
(* Functions are not first order, I don't think the var case |
67 |
needs to be considered here *) |
68 |
| _ -> failwith "Internal error: not an arrow type" |
69 |
|
70 |
(** Returns the type corresponding to a type list. *) |
71 |
let delay_of_delay_list de = |
72 |
if (List.length de) > 1 then |
73 |
new_delay (Dtuple de) |
74 |
else |
75 |
List.hd de |
76 |
|
77 |
(** [is_polymorphic de] returns true if [de] is polymorphic. *) |
78 |
let rec is_polymorphic de = |
79 |
match de.ddesc with |
80 |
| Dvar -> false |
81 |
| Dundef -> false |
82 |
| Darrow (de1,de2) -> (is_polymorphic de1) || (is_polymorphic de2) |
83 |
| Dtuple dl -> List.exists is_polymorphic dl |
84 |
| Dlink d' -> is_polymorphic d' |
85 |
| Dunivar -> true |
86 |
|
87 |
(* Pretty-print*) |
88 |
open Format |
89 |
|
90 |
let rec print_delay fmt de = |
91 |
match de.ddesc with |
92 |
| Dvar -> |
93 |
fprintf fmt "'_%s" (name_of_type de.did) |
94 |
| Dundef -> |
95 |
fprintf fmt "1" |
96 |
| Darrow (de1,de2) -> |
97 |
fprintf fmt "%a->%a" print_delay de1 print_delay de2 |
98 |
| Dtuple delist -> |
99 |
fprintf fmt "(%a)" |
100 |
(Utils.fprintf_list ~sep:"*" print_delay) delist |
101 |
| Dlink de -> |
102 |
print_delay fmt de |
103 |
| Dunivar -> |
104 |
fprintf fmt "'%s" (name_of_delay de.did) |
105 |
|
106 |
let pp_error fmt = function |
107 |
| Delay_clash (de1,de2) -> |
108 |
Utils.reset_names (); |
109 |
fprintf fmt "Expected delay %a, got delay %a@." print_delay de1 print_delay de2 |