mlton/ssa/two-point-lattice.fun

   1 (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  * Copyright (C) 1997-2000 NEC Research Institute.
   4  *
   5  * MLton is released under a BSD-style license.
   6  * See the file MLton-LICENSE for details.
   7  *)
   8
   9 functor TwoPointLattice (S: TWO_POINT_LATTICE_STRUCTS): TWO_POINT_LATTICE =
  10 struct
  11
  12 open S
  13
  14 structure Set = DisjointSet
  15 structure List = AppendList
  16
  17 datatype t = T of value Set.t
  18 and value =
  19    Bottom of (unit -> unit) List.t ref  (* If I become Top, then run these. *)
  20   | Top
  21
  22 fun value (T s) = Set.! s
  23
  24 fun toString e =
  25    case value e of
  26       Bottom _ => bottom
  27     | Top => top
  28
  29 val layout = Layout.str o toString
  30
  31 fun new (): t = T (Set.singleton (Bottom (ref List.empty)))
  32
  33 fun equals (T s, T s') = Set.equals (s, s')
  34
  35 fun addHandler (e, h) =
  36    case value e of
  37       Bottom hs => hs := List.cons (h, !hs)
  38     | Top => h ()
  39
  40 fun isTop s =
  41    case value s of
  42       Top => true
  43     | _ => false
  44
  45 fun isBottom s =
  46    case value s of
  47       Bottom _ => true
  48     | _ => false
  49
  50 fun runHandlers hs = List.foreach (!hs, fn h => h ())
  51
  52 fun makeTop (T s) =
  53    case Set.! s of
  54       Top => ()
  55     | Bottom hs => (Set.:= (s, Top); runHandlers hs)
  56
  57 fun from <= to =
  58    if equals (from, to)
  59       then ()
  60    else
  61       case (value from, value to) of
  62          (_, Top) => ()
  63        | (Top, _) => makeTop to
  64        | (Bottom hs, _) => hs := List.cons (fn () => makeTop to, !hs)
  65
  66 fun == (T s, T s') =
  67    if Set.equals (s, s')
  68       then ()
  69    else
  70       let val e = Set.! s
  71          val e' = Set.! s'
  72          val _ = Set.union (s, s')
  73       in
  74          case (e, e') of
  75             (Top, Top) => ()
  76           | (Bottom hs, Top) => (Set.:= (s, e'); runHandlers hs)
  77           | (Top, Bottom hs) => (Set.:= (s, e); runHandlers hs)
  78           | (Bottom hs, Bottom hs') =>
  79                Set.:= (s, Bottom (ref (List.append (!hs, !hs'))))
  80       end
  81
  82 end