Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / delay.ml @ 22fe1c93

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