src/Tools/Metis/src/Sharing.sml

GPL -> BSD

(* ========================================================================= *)
(* PRESERVING SHARING OF ML VALUES                                           *)
(* Copyright (c) 2005-2006 Joe Hurd, distributed under the BSD License *)
(* ========================================================================= *)

structure Sharing :> Sharing =
struct

infix ==

(* ------------------------------------------------------------------------- *)
(* Pointer equality.                                                         *)
(* ------------------------------------------------------------------------- *)

val pointerEqual = Portable.pointerEqual;

val op== = pointerEqual;

(* ------------------------------------------------------------------------- *)
(* List operations.                                                          *)
(* ------------------------------------------------------------------------- *)

fun map f =
    let
      fun m _ a_b [] = List.revAppend a_b
        | m ys a_b (x :: xs) =
          let
            val y = f x
            val ys = y :: ys
          in
            m ys (if x == y then a_b else (ys,xs)) xs
          end
    in
      fn l => m [] ([],l) l
    end;

fun updateNth (n,x) l =
    let
      val (a,b) = Useful.revDivide l n
    in
      case b of
        [] => raise Subscript
      | h :: t => if x == h then l else List.revAppend (a, x :: t)
    end;

fun setify l =
    let
      val l' = Useful.setify l
    in
      if length l' = length l then l else l'
    end;

(* ------------------------------------------------------------------------- *)
(* Function caching.                                                         *)
(* ------------------------------------------------------------------------- *)

fun cache cmp f =
    let
      val cache = ref (Map.new cmp)
    in
      fn a =>
         case Map.peek (!cache) a of
           SOME b => b
         | NONE =>
           let
             val b = f a
             val () = cache := Map.insert (!cache) (a,b)
           in
             b
           end
    end;

(* ------------------------------------------------------------------------- *)
(* Hash consing.                                                             *)
(* ------------------------------------------------------------------------- *)

fun hashCons cmp = cache cmp Useful.I;

end