scratch: sketched monadic foldTree stuff. Maybe quite senseless but given this a...

diff --git a/scratch/ScratchHS.hs b/scratch/ScratchHS.hs
index a6808b0a4758d3e99868700e37508fa2cbbe7c77..b0b60bdcdbeac16ef8065ba5f66993d485a5b97f 100644 (file)
--- a/scratch/ScratchHS.hs
+++ b/scratch/ScratchHS.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 
@@ -17,6 +18,9 @@
 module ScratchHS where
 
 import Data.Maybe
+import qualified Data.Set as Set
+import Data.Set (Set)
+import Control.Monad.State
 
 import Harpy
 import Harpy.X86Disassembler
@@ -104,3 +108,100 @@ fibBasicBlocks = do (cls,m) <- getFib
                     hmap <- parseMethod cls "ackermann"
                     printMapBB hmap
                     return ()
+
+
+{- Thoughs on types and representations 
+ - We start from constructing a CFG. What do we need here
+ - ** Fast traversal which is aware of cycles
+ - ** Fast successor, do we need predecessors?
+ - ** Find all paths to current node (including back references)
+ - ** Generic Node type in order to write mentioned operations
+ -    generically. There should be no intermediate language "lock in"
+ -    i.e. adding another IR should not kill CFG code
+ -    Furthermore operations like SSA construction should
+ -    not affect the CFG datastructure. Nodes contents should be 
+ -    interchangable in a way.
+ - ** Some form of unique naming - we would like to identify blocks
+ -    and check whether code should be produced for this node
+ - ** Should be Haskell idiomatic - should be composed with 
+ -    standard haskell infrastructure
+ - ** Convinient printing
+ -
+ - From this a inductive type should be appropriate?
+ -
+ -}
+
+data G a = Node  a (G a) (G a)
+         | Leaf  a 
+         | Nil deriving(Show)
+
+type LoopCheck a = Set a
+
+
+{- Actually i am not sure about the cata and algebra definition.
+ -
+ - check: http://dl.acm.org/citation.cfm?id=128035
+ -}
+
+type TreeAlgebra a r = (a -> r, r -> r -> r)
+
+foldG :: TreeAlgebra a r -> r -> G a -> r
+foldG (f,g) s (Leaf val)     = g (f val) s
+foldG (f,g) s (Node val l r) = g (f val) $ g (foldG (f,g) s l) (foldG (f,g) s r)
+                        
+printG = foldG ((: []), (++)) []
+
+loopCheck :: (Ord k) => G a -> (G a -> k) -> State (LoopCheck k) Bool
+loopCheck g f = do state <- get
+                   return $ Set.member (f g) state
+
+addNode :: (Ord k) => k -> State (LoopCheck k) ()
+addNode k = do s <- get 
+               put $ Set.insert k s
+               return ()
+
+foldGM :: (Ord k) => TreeAlgebra a r -> (G a -> k) -> r -> G a -> State (LoopCheck k) r
+foldGM _     _ s    Nil           = return s
+foldGM (f,g) c s k@(Leaf val)     = loopCheck k c >>= \p -> if p then return s else return $ g (f val) s
+foldGM (f,g) c s k@(Node val l r) = loopCheck k c >>= \p -> if p then return s else continue
+                                    where t        = foldGM (f,g) c s
+                                          self     = g (f val)
+                                          continue = do addNode $ c k
+                                                        left  <- t l
+                                                        right <- t r
+                                                        return $ self $ g left right
+
+diamant ::  G String
+diamant = let start = Node "a" left right
+              left  = Node "l" end Nil
+              right = Node "r" end Nil
+              end   = Node "g" start Nil
+          in start
+
+dag = Node "a" (Node "b" (Leaf "c") (Leaf "d")) (Node "b" (Leaf "c") (Leaf "d"))
+
+
+value (Node val _ _) = Just val
+value (Leaf val    ) = Just val
+value Nil            = Nothing
+                                          
+
+printG' ::  Ord k => G k -> [k]
+printG' g = evalState (foldGM ((: []), (++)) (\node -> let (Just v) = value node in v) [] g) Set.empty
+
+ 
+
+
+{- stupid sketch code -}
+
+-- actually loop check does not work properly. use monadic version instead
+foldG' :: (Ord k) => TreeAlgebra a r -> (G a -> k) -> r -> Set k -> G a -> r
+foldG' (f,g) c s s' Nil              = s
+foldG' (f,g) c s s' k@(Leaf val)     = if Set.member (c k) s' then s else g (f val) s
+foldG' (f,g) c s s' k@(Node val l r) = if Set.member (c k) s' then s 
+                                       else let newState = Set.insert (c k) s'
+                                                left  = foldG' (f,g) c s newState l
+                                                right = foldG' (f,g) c s newState r
+                                             in g (f val) $ g left right
+
+