incomplete start on set of intervals for stack model

diff --git a/compiler/utils/Interval.hs b/compiler/utils/Interval.hs
new file mode 100644 (file)
index 0000000..8d96b19
--- /dev/null
+++ b/compiler/utils/Interval.hs
@@ -0,0 +1,116 @@
+module Interval
+  ( Interval
+  , mkInterval, intervalToInfinityFrom
+  , integersInInterval
+
+  , DisjointIntervalSet
+  , emptyIntervalSet, extendIntervalSet, deleteFromIntervalSet
+  , subIntervals
+  ) 
+where
+
+import Panic
+
+#include "HsVersions.h"
+
+------------------------------------------------------------------ 
+-- Intervals and Sets of Intervals
+------------------------------------------------------------------ 
+
+-- This module implements intervals over the integer line and sets of
+-- disjoint intervals.  
+
+{-
+An interval $[x,y)$ over ordered points represents a half-open
+interval of points:  $\{ p \mid x \leq p < y \}$.  Half-open intervals
+have the nice property $[x,y) \cup [y,z) = [x,z)$.  Non-empty
+intervals can precede or overlap each other; an empty interval never
+overlaps or precedes any other.  The set of ordered elements contains
+a unique element $\mathit{zero}$; using it in any interval is an
+\emph{unchecked} run-time error.
+-}
+
+
+data Interval = Interval { i_min :: Int, i_lim :: Int }
+  -- width == i_lim - i_min >= 0
+
+type Width = Int
+
+mkInterval :: Int -> Width -> Interval
+mkInterval min w = ASSERT (w>=0) Interval min (min+w)
+intervalToInfinityFrom :: Int -> Interval
+intervalToInfinityFrom min = Interval min maxBound
+integersInInterval :: Interval -> [Int]
+integersInInterval (Interval min lim) = gen min lim
+    where gen min lim | min >= lim = []
+                      | otherwise = min : gen (min+1) lim
+
+precedes, overlaps, adjoins, contains :: Interval -> Interval -> Bool
+precedes (Interval m l) (Interval m' l') = l <= m' || l' <= m
+overlaps i i' = not (i `precedes` i' || i' `precedes` i)
+adjoins (Interval _ l) (Interval m _) = l == m
+contains (Interval m l) (Interval m' l') = m <= m' && l >= l'
+
+merge :: Interval -> Interval -> Interval
+merge _i@(Interval m _) _i'@(Interval _ l) = {- ASSERT (adjoins i i') -} (Interval m l)
+
+
+----------
+
+
+newtype DisjointIntervalSet = Intervals [Interval]
+ -- invariants: * No two intervals overlap
+ --             * Adjacent intervals have a gap between
+ --             * Intervals are sorted by min element
+
+emptyIntervalSet :: DisjointIntervalSet
+emptyIntervalSet = Intervals []
+extendIntervalSet :: DisjointIntervalSet -> Interval -> DisjointIntervalSet
+extendIntervalSet (Intervals l) i = Intervals (insert [] i l)
+    where insert :: [Interval] -> Interval -> [Interval] -> [Interval]
+          -- precondition: in 'insert prev' i l', every element of prev'
+          -- precedes and does not adjoin i
+          insert prev' i [] = rev_app prev' [i]
+          insert prev' i (i':is) =
+                 if i `precedes` i' then
+                     if i `adjoins` i' then
+                         insert prev' (merge i i') is
+                     else
+                         rev_app prev' (i : i' : is)
+                 else if i' `precedes` i then
+                          if i' `adjoins` i then
+                              insert prev' (merge i' i) is
+                          else
+                              insert (i' : prev') i is
+                      else
+                          panic "overlapping intervals"
+
+deleteFromIntervalSet :: DisjointIntervalSet -> Interval -> DisjointIntervalSet
+deleteFromIntervalSet (Intervals l) i = Intervals (rm [] i l)
+    where rm :: [Interval] -> Interval -> [Interval] -> [Interval]
+          -- precondition: in 'rm prev' i l', every element of prev'
+          -- precedes and does not adjoin i
+          rm _ _ [] = panic "removed interval not present in set"
+          rm prev' i (i':is) =
+                 if i `precedes` i' then
+                     panic "removed interval not present in set"
+                 else if i' `precedes` i then
+                          rm (i' : prev') i is
+                      else
+                          -- remove i from i', leaving 0, 1, or 2 leftovers
+                          undefined {-
+                          ASSERTX (i' `contains` i)
+                          let (Interval m l, Interval m' l'
+                          panic "overlapping intervals"
+                                     -}
+
+subIntervals :: DisjointIntervalSet -> Width -> [Interval]
+subIntervals = undefined
+
+rev_app :: [a] -> [a] -> [a]
+rev_app [] xs = xs
+rev_app (y:ys) xs = rev_app ys (y:xs)
+
+          
+_unused :: FS.FastString
+_unused = undefined i_min i_lim overlaps contains