Start working on Kildalldev/kildall

2 files changed, 113 insertions, 0 deletions

diff --git a/src/GSA/Kildall.hs b/src/GSA/Kildall.hs
new file mode 100644
index 0000000..5d16e8e
--- /dev/null
+++ b/src/GSA/Kildall.hs
@@ -0,0 +1,111 @@
+module GSA.Kildall where
+
+import Data.IntMap.Strict (IntMap, (!?))
+import qualified Data.IntMap.Strict as Map
+import Data.Maybe (fromMaybe)
+
+type IntMapD a = (a, IntMap a)
+
+class Eq a => SemiLattice a where
+  (=|>) :: a -> a -> Bool
+  (=|=) :: a -> a -> a
+  bot :: a
+
+class SemiLattice a => SemiLatticeTop a where
+  top :: a
+
+{-class DataflowSolver b where
+  fixpoint ::
+    SemiLattice b
+    => IntMap a
+    -> (a -> [Int])
+    -> (Int -> b -> b)
+    -> Int
+    -> b
+    -> Maybe (IntMapD b)
+
+class BackwardsDataflowSolver a where
+  bfixpoint ::
+    SemiLattice b
+    => IntMap a
+    -> (a -> [Int])
+    -> (Int -> b -> b)
+    -> Maybe (IntMapD b)-}
+
+class NodeSet a where
+  nsempty :: a
+  nsadd :: Int -> a -> a
+  nspick :: a -> Maybe (Int, a)
+  nsallNodes :: IntMap b -> a
+
+data DSState a b = DSState
+  { dssAval :: IntMap a
+  , dssWorklist :: b
+  , dssVisited :: IntMap Bool
+  }
+
+abstrValue :: SemiLattice a => Int -> DSState a b -> a
+abstrValue i d = fromMaybe bot $ dssAval d !? i
+
+propagateSucc :: (SemiLattice a, NodeSet b) => DSState a b -> a -> Int -> DSState a b
+propagateSucc s out n =
+  case dssAval s !? n of
+    Nothing -> DSState { dssAval = Map.insert n out (dssAval s)
+                       , dssWorklist = nsadd n (dssWorklist s)
+                       , dssVisited = Map.insert n True (dssVisited s) }
+    Just oldl ->
+      let newl = oldl =|= out in
+      if oldl == out
+      then s
+      else DSState { dssAval = Map.insert n newl (dssAval s)
+                   , dssWorklist = nsadd n (dssWorklist s)
+                   , dssVisited = Map.insert n True (dssVisited s) }
+
+propagateSuccList :: (SemiLattice a, NodeSet b) => DSState a b -> a -> [Int] -> DSState a b
+propagateSuccList s _ [] = s
+propagateSuccList s out (n : r) = propagateSuccList (propagateSucc s out n) out r
+
+step ::
+  (SemiLattice a, NodeSet b)
+  => IntMap a
+  -> (a -> [Int])
+  -> (Int -> a -> a)
+  -> DSState a b
+  -> Either (IntMapD a) (DSState a b)
+step code successors transf s =
+  case nspick (dssWorklist s) of
+    Nothing -> Left (bot, dssAval s)
+    Just (n, r) ->
+      case code !? n of
+        Nothing -> Right (s { dssWorklist = r })
+        Just instr ->
+          Right (propagateSuccList (s { dssWorklist = r }) (transf n (abstrValue n s)) (successors instr))
+
+iter ::
+  (SemiLattice a, NodeSet b)
+  => IntMap c
+  -> (c -> [Int])
+  -> (Int -> a -> a)
+  -> DSState a b
+  -> IntMapD a
+iter code suc transf s =
+  case step code suc transf s of
+    Left res -> res
+    Right s' -> iter code suc transf s'
+
+startState :: (SemiLattice a, NodeSet b) => Int -> a -> DSState a b
+startState enode eval =
+  DSState { dssAval = Map.insert enode eval Map.empty
+          , dssWorklist = nsadd enode nsempty
+          , dssVisited = Map.insert enode True Map.empty }
+
+fixpoint ::
+  (SemiLattice a, NodeSet b)
+  => IntMap c
+  -> (c -> [Int])
+  -> (Int -> a -> a)
+  -> Int
+  -> a
+  -> IntMapD a
+fixpoint code suc transf enode eval =
+  iter code suc transf (startState enode eval)
diff --git a/src/GSA/Parser.hs b/src/GSA/Parser.hs
index 1292609..1ce4d4a 100644
--- a/src/GSA/Parser.hs
+++ b/src/GSA/Parser.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module GSA.Parser where
 
 import Data.Char