memoizer.ml

   1 (*
   2   This module defines a wrapper builder which given a function
   3   and creates its memoized version. The hashtable used to memoize
   4   results is given as argument of the module, the keys of the table
   5   are the argument of the function we want to wrap.
   6   The tricky part is to do this also for recursive function where
   7   each call can be memoized.
   8
   9   See the technical report:
  10
  11   "That About Wraps it Up: Using FIX to Handle Errors Without
  12   Exceptions, and Other Programming Tricks"
  13
  14   Bruce J. McAdam
  15
  16   http://www.lfcs.inf.ed.ac.uk/reports/97/ECS-LFCS-97-375/
  17
  18   we give two wrapper builders:
  19   - make , which builds a new function, memoized only at toplevel. The only
  20   penalty here is the single look-up, which is supposed to be negligeble w.r.t
  21   the actual computation (other wise there is little point in memoizing)
  22
  23   - make_rec which acts as a fixpoint combinator and memoized each recursive call
  24   of the function. The penalty is twofold:
  25    1) a look-up for every recursive call.
  26    2) the function has to be written in CPS, and is therefore compiled less
  27       efficiently than its recursive non memoized function.
  28
  29    Again, it is assumed that the same expensive computation will occur many time
  30    to amortise these penalties.
  31
  32 *)
  33
  34 INCLUDE "utils.ml"
  35
  36
  37 module Make ( H : Hashtbl.S ) =
  38 struct
  39
  40
  41   let make f =
  42     let tbl = H.create BIG_H_SIZE in
  43       fun arg ->
  44         try
  45           H.find tbl arg
  46         with Not_found ->
  47           let r = f arg in H.add tbl arg r;r
  48
  49
  50   type 'a fix = Fix of ('a fix -> 'a)
  51
  52   let make_rec f =
  53     let tbl = H.create BIG_H_SIZE in
  54     let unboxed =
  55       function ((Fix f')as fix) ->
  56         f (fun arg ->
  57              try
  58                H.find tbl arg
  59              with
  60                  Not_found -> let r = f' fix arg
  61                  in H.add tbl arg r;r)
  62     in unboxed (Fix unboxed)
  63
  64 end
  65 ;;