mlton/ssa/n-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 NPointLattice (S: N_POINT_LATTICE_STRUCTS): N_POINT_LATTICE =
  10 struct
  11
  12 open S
  13
  14 val N = List.length names - 1
  15
  16 structure Set = DisjointSet
  17
  18 type value = int * (unit -> unit) AppendList.t ref List.t
  19 datatype t = T of value Set.t
  20
  21 fun value (T s) = Set.! s
  22
  23 fun toString e =
  24    case value e of
  25       (n, _) => List.nth (names, n)
  26
  27 val layout = Layout.str o toString
  28
  29 fun new (): t =
  30    T (Set.singleton (0, List.duplicate (N, fn () => ref AppendList.empty)))
  31
  32 fun equals (T s, T s') = Set.equals (s, s')
  33
  34 fun whenN (s, n', h') =
  35    case value s of
  36       (n, hss) => if n' < 0 orelse n' > N
  37                      then Error.bug "NPointLattice.whenN"
  38                   else if n >= n'
  39                      then h' ()
  40                   else let
  41                          val hs = List.nth (hss, n' - n - 1)
  42                        in
  43                          hs := AppendList.cons (h', !hs)
  44                        end
  45
  46 fun isN (s, n') =
  47    case value s of
  48       (n, _) => if n' < 0 orelse n' > N
  49                    then Error.bug "NPointLattice.isN"
  50                 else n = n'
  51
  52 fun up (T s) =
  53    case Set.! s of
  54       (n, hss) => if n = N
  55                      then ()
  56                   else (Set.:= (s, (n + 1, tl hss)) ;
  57                         AppendList.foreach (!(hd hss), fn h => h ()))
  58
  59 fun makeN (s, n') =
  60    case value s of
  61       (n, _) => if n' < 0 orelse n' > N
  62                    then Error.bug "NPointLattice.makeN"
  63                 else if n >= n'
  64                    then ()
  65                 else (up s ; makeN (s, n'))
  66
  67 fun from <= to =
  68    if equals (from, to)
  69       then ()
  70    else
  71       case (value from, value to) of
  72          ((n,hss), (n',_)) =>
  73             (makeN (to, n) ;
  74              List.foreachi
  75              (hss, fn (i,hs) =>
  76               if n + i + 1 > n'
  77                 then hs := AppendList.cons (fn () => makeN (to, n + i + 1), !hs)
  78                 else ()))
  79
  80 fun == (T s, T s') =
  81    if Set.equals (s, s')
  82       then ()
  83    else
  84       let
  85          val e = Set.! s
  86          val e' = Set.! s'
  87          val _ = Set.union (s, s')
  88       in
  89          case (e, e') of
  90             ((n,hss), (n',hss')) =>
  91                let
  92                  val n'' = Int.max (n, n')
  93
  94                  fun doit (n, hss) =
  95                     let
  96                       val rec drop
  97                         = fn (hss, 0: Int.t) => hss
  98                            | (hs::hss, n) =>
  99                              (AppendList.foreach
 100                               (!hs, fn h => h ()) ;
 101                               drop (hss, n - 1))
 102                            | ([], _) => Error.bug "NPointLattice.=="
 103                     in
 104                       drop (hss, n'' - n)
 105                     end
 106                  val hss = doit (n, hss)
 107                  val hss' = doit (n', hss')
 108                  val hss''
 109                    = List.map2
 110                      (hss, hss', fn (hs, hs') =>
 111                       ref (AppendList.append (!hs, !hs')))
 112                in
 113                   Set.:= (s, (n'', hss''))
 114                end
 115       end
 116
 117 end