New utility functions for traversing graphs and creating lattices.
authorNorman Ramsey <nr@cs.tufts.edu>
Wed, 21 Apr 2010 21:39:53 +0000 (17:39 -0400)
committerNorman Ramsey <nr@cs.tufts.edu>
Wed, 21 Apr 2010 21:39:53 +0000 (17:39 -0400)
src/Compiler/Hoopl.hs
src/Compiler/Hoopl/Util.hs
src/Compiler/Hoopl/XUtil.hs [new file with mode: 0644]
src/hoopl.cabal

index 623b2e4..74a64f7 100644 (file)
@@ -7,6 +7,8 @@ module Compiler.Hoopl
   , module Compiler.Hoopl.Label
   , module Compiler.Hoopl.MkGraph
   , module Compiler.Hoopl.Show
+  , module Compiler.Hoopl.Util
+  , module Compiler.Hoopl.XUtil
   )
 where
 
@@ -18,3 +20,5 @@ import Compiler.Hoopl.Graph hiding (BodyEmpty, BodyUnit, BodyCat)
 import Compiler.Hoopl.Label hiding (allLabels)
 import Compiler.Hoopl.MkGraph
 import Compiler.Hoopl.Show
+import Compiler.Hoopl.Util
+import Compiler.Hoopl.XUtil
index 09e06bf..faa4956 100644 (file)
@@ -17,6 +17,9 @@ import Compiler.Hoopl.Graph
 import Compiler.Hoopl.Label
 import Compiler.Hoopl.Zipper
 
+
+----------------------------------------------------------------
+
 gUnitOO :: block n O O -> Graph' block n O O
 gUnitOC :: block n O C -> Graph' block n O C
 gUnitCO :: block n C O -> Graph' block n C O
diff --git a/src/Compiler/Hoopl/XUtil.hs b/src/Compiler/Hoopl/XUtil.hs
new file mode 100644 (file)
index 0000000..cec7d71
--- /dev/null
@@ -0,0 +1,61 @@
+-- | Utilities for clients of Hoopl, not used internally.
+
+module Compiler.Hoopl.XUtil
+  ( WithBot(..), addBot, addBot'
+--  , WithTop(..), addTop, addTop
+  )
+where
+
+import Compiler.Hoopl.Label
+import Compiler.Hoopl.Dataflow
+
+-- | Adds a bottom element to a set to help form a lattice
+data WithBot a = Bot | NonBot a
+
+-- | Given a join function and a name, creates a semi lattice by
+-- adding a bottom element.  A specialized version of 'addBot''.
+addBot  :: String -> JoinFun a -> DataflowLattice (WithBot a)
+-- | A more general case for creating a new lattice
+addBot' :: String -> (Label -> OldFact a -> NewFact a -> (ChangeFlag, WithBot a))
+        -> DataflowLattice (WithBot a)
+
+addBot name join = addBot' name join'
+   where join' l o n = (change, NonBot f)
+            where (change, f) = join l o n
+
+addBot' name joinx = DataflowLattice name Bot join False
+  where -- careful: order of cases matters for ChangeFlag
+        join _ (OldFact f)            (NewFact Bot) = (NoChange, f)
+        join _ (OldFact Bot)          (NewFact f)   = (SomeChange, f)
+        join l (OldFact (NonBot old)) (NewFact (NonBot new))
+           = joinx l (OldFact old) (NewFact new)
+
+instance Show a => Show (WithBot a) where
+  show Bot = "_|_"
+  show (NonBot a) = show a
+
+
+-- | Adds a top element to a set to help form a lattice
+data WithTop a = Top | NonTop a
+
+-- | Given a join function and a name, creates a semi lattice by
+-- adding a top element.  A specialized version of 'addTop''.
+addTop  :: String -> JoinFun a -> DataflowLattice (WithTop a)
+-- | A more general case for creating a new lattice
+addTop' :: String -> (Label -> OldFact a -> NewFact a -> (ChangeFlag, WithTop a))
+        -> DataflowLattice (WithTop a)
+
+addTop name join = addTop' name join'
+   where join' l o n = (change, NonTop f)
+            where (change, f) = join l o n
+
+addTop' name joinx = DataflowLattice name Top join False
+  where  -- careful: order of cases matters for ChangeFlag
+        join _ (OldFact Top)          (NewFact f)   = (NoChange, Top)
+        join _ (OldFact f)            (NewFact Top) = (SomeChange, Top)
+        join l (OldFact (NonTop old)) (NewFact (NonTop new))
+           = joinx l (OldFact old) (NewFact new)
+
+instance Show a => Show (WithTop a) where
+  show Top = "T"
+  show (NonTop a) = show a
index ac52864..4025b27 100644 (file)
@@ -1,5 +1,5 @@
 Name:                hoopl
-Version:             3.7.12.1
+Version:             3.7.12.2
 Description:         Higher-order optimization library
 License:             BSD3
 License-file:        LICENSE
@@ -28,6 +28,7 @@ Library
                        Compiler.Hoopl.MkGraph,
                        Compiler.Hoopl.Fuel, Compiler.Hoopl.Label,
                        Compiler.Hoopl.Show, Compiler.Hoopl.Util
+                       Compiler.Hoopl.XUtil
                        Compiler.Hoopl.ZipDataflow
   ghc-options:       -Wall -fno-warn-name-shadowing