Source file `Memoize.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
(******************************************************************************)
(*                                                                            *)
(*                                    Fix                                     *)
(*                                                                            *)
(*                       François Pottier, Inria Paris                        *)
(*                                                                            *)
(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
(*  terms of the GNU Library General Public License version 2, with a         *)
(*  special exception on linking, as described in the file LICENSE.           *)
(*                                                                            *)
(******************************************************************************)

open Sigs

(* [rev_take accu n xs] is [accu @ rev (take n xs)], where [take n xs]
   takes the first [n] elements of the list [xs]. The length of [xs] must
   be at least [n]. *)

let rec rev_take accu n xs =
  match n, xs with
  | 0, _ ->
      accu
  | _, [] ->
      (* The list is too short. This cannot happen. *)
      assert false
  | _, x :: xs ->
      rev_take (x :: accu) (n - 1) xs

module Make (M : MINIMAL_IMPERATIVE_MAPS) = struct

  type key = M.key

  let add x y table =
    M.add x y table;
    y

  (* [memoize] could be defined as a special case of [fix] via the declaration
     [let memoize f = fix (fun _ x -> f x)]. The following direct definition is
     perhaps easier to understand and may give rise to more efficient code. *)

  type 'a t =
    'a M.t

  let visibly_memoize (f : key -> 'a) : (key -> 'a) * 'a t =
    let table = M.create() in
    let f x =
      try
	M.find x table
      with Not_found ->
        add x (f x) table
    in
    f, table

  let memoize (f : key -> 'a) : key -> 'a =
    let f, _table = visibly_memoize f in
    f

  let fix (ff : (key -> 'a) -> (key -> 'a)) : key -> 'a =
    let table = M.create() in
    let rec f x =
      try
	M.find x table
      with Not_found ->
	add x (ff f x) table
    in
    f

  (* In the implementation of [defensive_fix], we choose to use two tables.
     A permanent table, [table] maps keys to values. Once a pair [x, y] has
     been added to this table, it remains present forever: [x] is stable,
     and a call to [f x] returns [y] immediately. A transient table, [marked],
     is used only while a call is in progress. This table maps keys to integers:
     for each key [x], it records the depth of the stack at the time [x] was
     pushed onto the stack. Finally, [stack] is a list of the keys currently
     under examination (most recent key first), and [depth] is the length of
     the list [stack]. Recording integer depths in the table [marked] allows
     us to identify the desired cycle, a prefix of the list [stack], without
     requiring an equality test on keys. *)

  exception Cycle of key list * key

  let defensive_fix (ff : (key -> 'a) -> (key -> 'a)) : key -> 'a =
    (* Create the permanent table. *)
    let table = M.create() in
    (* Define the main recursive function. *)
    let rec f stack depth marked (x : key) : 'a =
      try
	M.find x table
      with Not_found ->
        match M.find x marked with
        | i ->
            (* [x] is marked, and was pushed onto the stack at a time when the
               stack depth was [i]. We have found a cycle. Fail. Cut a prefix
               of the reversed stack, which represents the cycle that we have
               detected, and reverse it on the fly. *)
            raise (Cycle (rev_take [] (depth - i) stack, x))
        | exception Not_found ->
           (* [x] is not marked. Mark it while we work on it. There is no need
              to unmark [x] afterwards; inserting it into [table] indicates
              that it has stabilized. There also is no need to catch and
              re-raise the exception [Cycle]; we just let it escape. *)
            M.add x depth marked;
            let stack = x :: stack
            and depth = depth + 1 in
            let y = ff (f stack depth marked) x in
	    add x y table
    in
    fun x ->
      (* Create the transient table. *)
      let marked = M.create()
      and stack = []
      and depth = 0 in
      (* Answer this query. *)
      f stack depth marked x

  (* The combinator [curried] can be used to obtain a curried version of [fix]
     or [defensive_fix] in a concrete instance where the type [key] is a
     product type. *)

  (* [curried] could be defined as a toplevel function; it does not depend on
     any of the code above. However, it seems convenient to place it here. *)

  let   curry f x y = f (x, y)
  let uncurry f (x, y) = f x y

  let curried (fix : ('a * 'b -> 'c) fix) : ('a -> 'b -> 'c) fix =
    fun ff ->
      let ff f = uncurry (ff (curry f)) in
      curry (fix ff)

end

module ForOrderedType (T : OrderedType) =
  Make(Glue.PersistentMapsToImperativeMaps(Map.Make(T)))

module ForHashedType (T : HashedType) =
  Make(Glue.HashTablesAsImperativeMaps(T))

module ForType (T : TYPE) =
  ForHashedType(Glue.TrivialHashedType(T))

module Char =
  ForType(Glue.CHAR)

module Int =
  ForType(Glue.INT)

module String =
  ForType(Glue.STRING)