Remove prototypes directory (ticket #6)
authorMichal Terepeta <michal.terepeta@gmail.com>
Fri, 29 May 2015 10:49:10 +0000 (12:49 +0200)
committerMichal Terepeta <michal.terepeta@gmail.com>
Fri, 29 May 2015 10:49:10 +0000 (12:49 +0200)
Most of the prototypes don't compile and keeping them in the
repository might be more confusing than helpful.

prototypes/.gitignore [deleted file]
prototypes/Cunning3.hs [deleted file]
prototypes/CunningTransfers.hs [deleted file]
prototypes/Hoopl.hs [deleted file]
prototypes/Hoopl1.hs [deleted file]
prototypes/Hoopl4.hs [deleted file]
prototypes/Hoopl5.hs [deleted file]
prototypes/Hoopl6.hs [deleted file]
prototypes/Hoopl7.hs [deleted file]
prototypes/RG.hs [deleted file]
prototypes/Zipper.hs [deleted file]

diff --git a/prototypes/.gitignore b/prototypes/.gitignore
deleted file mode 100644 (file)
index 2724cb2..0000000
+++ /dev/null
@@ -1,3 +0,0 @@
-*.hi
-*.hc
-*.o
diff --git a/prototypes/Cunning3.hs b/prototypes/Cunning3.hs
deleted file mode 100644 (file)
index c44083e..0000000
+++ /dev/null
@@ -1,347 +0,0 @@
-{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies #-}\r
-\r
--- This version uses type families to express the functional dependency\r
--- between the open/closed-ness of the input graph and the type of the\r
--- input fact expected for a graph of that shape\r
-\r
-module CunningTransfers( pureAnalysis, analyseAndRewrite ) where\r
-\r
-import qualified Data.IntMap as M\r
-import qualified Data.IntSet as S\r
-\r
------------------------------------------------------------------------------\r
---             Graphs\r
------------------------------------------------------------------------------\r
-\r
-data ZOpen\r
-data ZClosed\r
-\r
-type O = ZOpen\r
-type C = ZClosed\r
-\r
--- This data type is NOT MENTIONED in the rest of the code.\r
--- It's just an example to how how we can embed our existing\r
--- middle/last idea into the new story\r
-data ZNode m l e x where\r
-  ZFirst :: BlockId -> ZNode m l C O\r
-  ZMid   :: m      -> ZNode m l O O\r
-  ZLast  :: l      -> ZNode m l O C\r
-\r
-data ZBlock node e x where\r
-  ZBOne :: node e x -> ZBlock node e x\r
-  ZCat  :: ZBlock node e O -> ZBlock node O x -> ZBlock node e x\r
-\r
-type Block node = ZBlock node C C\r
-\r
-data ZGraph node e x where\r
-  ZGMany { zg_entry  :: ZBlock node e C\r
-        , zg_blocks :: BlockEnv (Block node)\r
-        , zg_exit   :: ZBlock node C x } :: ZGraph node e x\r
-  ZGOne  { zg_mids   :: ZBlock node O O } :: ZGraph node O O \r
-  ZGNil                                   :: ZGraph node O O\r
-\r
-type Graph node = ZGraph node C C\r
-\r
-forwardBlockList :: BlockEnv (Block node) -> [(BlockId, Block node)]\r
--- This produces a list of blocks in order suitable for forward analysis.\r
--- ToDo: Do a topological sort to improve convergence rate of fixpoint\r
---       This will require a (HavingSuccessors l) class constraint\r
-forwardBlockList env = M.toList env\r
-\r
------------------------------------------------------------------------------\r
---             DataflowLattice\r
------------------------------------------------------------------------------\r
-\r
-data DataflowLattice a = DataflowLattice  { \r
-  fact_name       :: String,                 -- Documentation\r
-  fact_bot        :: a,                      -- Lattice bottom element\r
-  fact_add_to     :: a -> a -> TxRes a,      -- Lattice join plus change flag\r
-  fact_do_logging :: Bool                    -- log changes\r
-}\r
-\r
------------------------------------------------------------------------------\r
---             The main Hoopl API\r
------------------------------------------------------------------------------\r
-\r
-data ForwardTransfers node f \r
-  = ForwardTransfers\r
-      { ft_trans   :: forall e x. node e x -> InT e f -> OutT x f } \r
-\r
-data ForwardRewrites node f \r
-  = ForwardRewrites\r
-      { fr_rw :: forall e x. node e x -> InT e f -> Maybe (AGraph node e x) } \r
-\r
-type family   InT e f :: *\r
-type instance InT C f = FactBase f\r
-type instance InT O f = f\r
-\r
-type family   OutT x f :: *\r
-type instance OutT C f = OutFacts f\r
-type instance OutT O f = f\r
-\r
-newtype OutFacts fact = OutFacts [(BlockId, fact)] \r
-newtype FactBase fact = FactBase (BlockEnv fact)\r
-\r
-data AGraph node e x = AGraph  -- Stub for now\r
-\r
-\r
------------------------------------------------------------------------------\r
---      TxFactBase: a FactBase with ChangeFlag information\r
------------------------------------------------------------------------------\r
-\r
--- A TxFactBase carries a ChangeFlag with it, and a set of BlockIds\r
--- to monitor. Updates to other BlockIds don't affect the ChangeFlag\r
-data TxFactBase fact \r
-  = TxFB { tfb_fbase :: FactBase fact\r
-         , tfb_cha   :: ChangeFlag\r
-         , tfb_bids  :: BlockSet  -- Update change flag iff these blocks change\r
-    }\r
-\r
-updateFact :: DataflowLattice f -> (BlockId, f)\r
-           -> TxFactBase f -> TxFactBase f\r
--- Update a TxFactBase, setting the change flag iff\r
---   a) the new fact adds information...\r
---   b) for a block in the BlockSet in the TxFactBase\r
-updateFact lat (bid, new_fact) tx_fb@(TxFB { tfb_fbase = FactBase fbase, tfb_bids = bids})\r
-  | NoChange <- cha2        = tx_fb\r
-  | bid `elemBlockSet` bids = tx_fb { tfb_fbase = new_fbase, tfb_cha = SomeChange }\r
-  | otherwise               = tx_fb { tfb_fbase = new_fbase }\r
-  where\r
-    old_fact = lookupBEnv fbase bid `orElse` fact_bot lat\r
-    TxRes cha2 res_fact = fact_add_to lat old_fact new_fact\r
-    new_fbase = FactBase (extendBEnv fbase bid res_fact)\r
-\r
-updateFacts :: DataflowLattice f -> BlockId\r
-            -> Trans (FactBase f)   (OutFacts f)\r
-            -> Trans (TxFactBase f) (TxFactBase f)\r
-updateFacts lat bid thing_inside tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids })\r
-  = do { OutFacts out_facts <- thing_inside fbase\r
-       ; let tx_fb' = tx_fb { tfb_bids = extendBlockSet bids bid }\r
-       ; return (foldr (updateFact lat) tx_fb out_facts) }\r
-\r
------------------------------------------------------------------------------\r
---             The Trans arrow\r
------------------------------------------------------------------------------\r
-\r
-type Trans a b = a -> FuelMonad b\r
- -- Transform a into b, with facts of type f\r
- -- Deals with optimsation fuel and unique supply too\r
-  \r
-(>>>) :: Trans a b -> Trans b c -> Trans a c\r
--- Compose two dataflow transfers in sequence\r
-(dft1 >>> dft2) f1 = do { f2 <- dft1 f1; dft2 f2 }\r
-\r
-liftTrans :: (a->b) -> Trans a b\r
-liftTrans f x = return (f x)\r
-\r
-idTrans :: Trans a a\r
-idTrans x = return x\r
-\r
-fixpointTrans :: forall f. Trans (TxFactBase f) (TxFactBase f) \r
-                        -> Trans (OutFacts f)   (FactBase f)\r
-fixpointTrans thing_inside (OutFacts out_facts)\r
-  = loop (FactBase (mkBlockEnv out_facts))\r
-  where\r
-    loop :: Trans (FactBase f) (FactBase f)\r
-    loop fbase = do { tx_fb <- thing_inside (TxFB { tfb_fbase = fbase\r
-                                                  , tfb_cha = NoChange\r
-                                                  , tfb_bids = emptyBlockSet })\r
-                    ; case tfb_cha tx_fb of\r
-                        NoChange   -> return fbase\r
-                        SomeChange -> loop (tfb_fbase tx_fb) }\r
-\r
------------------------------------------------------------------------------\r
---             Transfer functions\r
------------------------------------------------------------------------------\r
-\r
--- Keys to the castle: a generic transfer function for each shape\r
--- Here's the idea: we start with single-node transfer functions,\r
--- move to basic-block transfer functions (we have exactly four shapes),\r
--- then finally to graph transfer functions (which requires iteration).\r
-\r
-data GFT thing fact \r
-  = GFT { gft_trans :: forall e x. thing e x -> Trans (InT e fact) (OutT x fact) }\r
-\r
-type GFT_Node  node = GFT node\r
-type GFT_Block node = GFT (ZBlock node)\r
-type GFT_Graph node = GFT (ZGraph node)\r
-----------------------------------------------------------------------------------------------\r
-\r
-gftNode :: forall node f . ForwardTransfers node f -> GFT_Node node f\r
--- Injection from the external interface into the internal representation\r
-gftNode (ForwardTransfers { ft_trans = base_trans })\r
-  = GFT { gft_trans = node_trans }\r
-    where \r
-      node_trans :: node e x -> Trans (InT e f) (OutT x f)\r
-      node_trans node f = return (base_trans node f)\r
-\r
-gftBlock :: forall node f. GFT_Node node f -> GFT_Block node f\r
--- Lift from nodes to blocks\r
-gftBlock (GFT { gft_trans = node_trans })\r
-  = GFT { gft_trans  = block_trans }\r
-  where \r
-    block_trans :: ZBlock node e x -> Trans (InT e f) (OutT x f)\r
-    block_trans (ZBOne node)     = node_trans node\r
-    block_trans (ZCat head mids) = block_trans head >>> block_trans mids\r
-\r
-gftGraph :: forall node f. DataflowLattice f -> GFT_Block node f -> GFT_Graph node f\r
--- Lift from blocks to graphs\r
-gftGraph lattice (GFT { gft_trans = block_trans })\r
-  = GFT { gft_trans = graph_trans }\r
-  where\r
-       -- These functions are orgasmically beautiful\r
-    graph_trans :: ZGraph node e x -> Trans (InT e f) (OutT x f)\r
-    graph_trans ZGNil        = idTrans\r
-    graph_trans (ZGOne mids) = block_trans mids\r
-    graph_trans (ZGMany { zg_entry = entry, zg_blocks = blocks, zg_exit = exit })\r
-      = block_trans entry >>> ft_blocks blocks >>> block_trans exit\r
-\r
-    ft_blocks :: BlockEnv (Block node) -> Trans (OutFacts f) (FactBase f)\r
-    ft_blocks blocks = fixpointTrans (ft_blocks_once (forwardBlockList blocks))\r
-\r
-    ft_blocks_once :: [(BlockId, Block node)] -> Trans (TxFactBase f) (TxFactBase f)\r
-    ft_blocks_once blks = foldr ((>>>) . ft_block_once) idTrans blks\r
-\r
-    ft_block_once :: (BlockId, Block node)\r
-                  -> Trans (TxFactBase f) (TxFactBase f)\r
-    ft_block_once (blk_id, blk) = updateFacts lattice blk_id (block_trans blk)\r
-\r
-\r
-\r
-----------------------------------------------------------------\r
---       The pièce de resistance: cunning transfer functions\r
-----------------------------------------------------------------\r
-\r
-pureAnalysis :: DataflowLattice f -> ForwardTransfers node f -> GFT_Graph node f\r
-pureAnalysis lattice = gftGraph lattice . gftBlock . gftNode \r
-\r
-analyseAndRewrite\r
-   :: forall node f . \r
-      RewritingDepth\r
-   -> DataflowLattice f\r
-   -> ForwardTransfers node f\r
-   -> ForwardRewrites node f\r
-   -> GFT_Graph node f\r
-\r
-data RewritingDepth = RewriteShallow | RewriteDeep\r
--- When a transformation proposes to rewrite a node, \r
--- you can either ask the system to\r
---  * "shallow": accept the new graph, analyse it without further rewriting\r
---  * "deep": recursively analyse-and-rewrite the new graph\r
-\r
-analyseAndRewrite depth lattice transfers rewrites\r
-  = gft_graph_cunning\r
-  where \r
-    gft_graph_base, gft_graph_cunning, gft_graph_recurse :: GFT_Graph node f\r
-\r
-    gft_graph_base    = gftGraph lattice (gftBlock gft_node_base)\r
-    gft_graph_cunning = gftGraph lattice (gftBlock gft_node_cunning)\r
-    gft_graph_recurse = case depth of\r
-                          RewriteShallow -> gft_graph_base\r
-                          RewriteDeep    -> gft_graph_cunning\r
-\r
-    gft_node_base, gft_node_cunning :: GFT_Node node f\r
-    gft_node_base    = gftNode transfers\r
-    gft_node_cunning = GFT { gft_trans  = cunning_trans }\r
-\r
-    cunning_trans :: node e x -> Trans (InT e f) (OutT x f)\r
-    cunning_trans node = tryRewrite (fr_rw rewrites node)\r
-                                    (gft_trans gft_graph_recurse)\r
-                                    (gft_trans gft_node_base node) \r
-\r
-\r
------------------------------------------------------------------------------\r
---             Rewriting\r
------------------------------------------------------------------------------\r
-\r
-{-\r
-data GRT co oo oc cc fact \r
-  = GRT { grt_lat :: DataflowLattice fact\r
-               , grt_co  :: co -> Trans (FactBase fact) (fact, Graph C O m l)\r
-               , grt_oo  :: oo -> Trans fact            (fact, Graph O O m l)\r
-               , grt_oc  :: oc -> Trans fact            (OutFacts fact)\r
-               , gRt_cc  :: cc -> Trans (FactBase fact) (OutFacts fact) }\r
--}\r
-\r
------------------------------------------------------------------------------\r
---             BlockId, BlockEnv, BlockSet\r
------------------------------------------------------------------------------\r
-\r
-type BlockId = Int\r
-\r
-mkBlockId :: Int -> BlockId\r
-mkBlockId uniq = uniq\r
-\r
-type BlockEnv a = M.IntMap a\r
-\r
-mkBlockEnv :: [(BlockId, a)] -> BlockEnv a\r
-mkBlockEnv prs = M.fromList prs\r
-\r
-lookupBEnv :: BlockEnv f -> BlockId -> Maybe f\r
-lookupBEnv env blk_id = M.lookup blk_id env\r
-\r
-extendBEnv :: BlockEnv f -> BlockId -> f -> BlockEnv f\r
-extendBEnv env blk_id f = M.insert blk_id f env\r
-\r
-type BlockSet = S.IntSet\r
-\r
-emptyBlockSet :: BlockSet\r
-emptyBlockSet = S.empty\r
-\r
-extendBlockSet :: BlockSet -> BlockId -> BlockSet\r
-extendBlockSet bids bid = S.insert bid bids\r
-\r
-elemBlockSet :: BlockId -> BlockSet -> Bool\r
-elemBlockSet bid bids = S.member bid bids\r
-\r
------------------------------------------------------------------------------\r
---             TxRes and ChangeFlags\r
------------------------------------------------------------------------------\r
-\r
-data ChangeFlag = NoChange | SomeChange\r
-data TxRes a = TxRes ChangeFlag a\r
-\r
-\r
------------------------------------------------------------------------------\r
---             The fuel monad\r
------------------------------------------------------------------------------\r
-\r
-type Uniques = Int\r
-type Fuel    = Int\r
-\r
-newtype FuelMonad a = FM { unFM :: Fuel -> Uniques -> (a, Fuel, Uniques) }\r
-\r
-instance Monad FuelMonad where\r
-  return x = FM (\f u -> (x,f,u))\r
-  m >>= k  = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u')\r
-\r
-fuelExhausted :: FuelMonad Bool\r
-fuelExhausted = FM (\f u -> (f <= 0, f, u))\r
-\r
-decrementFuel :: FuelMonad ()\r
-decrementFuel = FM (\f u -> ((), f-1, u))\r
-\r
------------\r
-tryRewrite :: (a -> (Maybe (AGraph node e x))) -- The rewriter\r
-           -> (ZGraph node e x -> Trans a r)   -- Rewrite succeeds\r
-           -> Trans a r                                -- Rewrite fails\r
-           -> Trans a r\r
-tryRewrite rewriter do_yes do_no a\r
-  = case (rewriter a) of\r
-      Nothing -> do_no a\r
-      Just g  -> do { out <- fuelExhausted\r
-                           ; if out then do_no a\r
-                             else do { decrementFuel\r
-                                     ; g' <- graphOfAGraph g\r
-                                     ; do_yes g' a } }\r
-\r
-graphOfAGraph :: AGraph node e x -> FuelMonad (ZGraph node e x)\r
-graphOfAGraph = error "urk"    -- Stub\r
-\r
------------------------------------------------------------------------------\r
---             Utility functions\r
------------------------------------------------------------------------------\r
-\r
-orElse :: Maybe a -> a -> a\r
-orElse (Just x) _ = x\r
-orElse Nothing  y = y\r
diff --git a/prototypes/CunningTransfers.hs b/prototypes/CunningTransfers.hs
deleted file mode 100644 (file)
index e5063d7..0000000
+++ /dev/null
@@ -1,419 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards #-}\r
-\r
-module CunningTransfers where\r
-\r
-import qualified Data.IntMap as M\r
-import qualified Data.IntSet as S\r
-\r
------------------------------------------------------------------------------\r
---             BlockId, BlockEnv, BlockSet\r
------------------------------------------------------------------------------\r
-\r
-type BlockId = Int\r
-\r
-mkBlockId :: Int -> BlockId\r
-mkBlockId uniq = uniq\r
-\r
-type BlockEnv a = M.IntMap a\r
-\r
-mkBlockEnv :: [(BlockId, a)] -> BlockEnv a\r
-mkBlockEnv prs = M.fromList prs\r
-\r
-lookupBEnv :: BlockEnv f -> BlockId -> Maybe f\r
-lookupBEnv env blk_id = M.lookup blk_id env\r
-\r
-extendBEnv :: BlockEnv f -> BlockId -> f -> BlockEnv f\r
-extendBEnv env blk_id f = M.insert blk_id f env\r
-\r
-type BlockSet = S.IntSet\r
-\r
-emptyBlockSet :: BlockSet\r
-emptyBlockSet = S.empty\r
-\r
-extendBlockSet :: BlockSet -> BlockId -> BlockSet\r
-extendBlockSet bids bid = S.insert bid bids\r
-\r
-elemBlockSet :: BlockId -> BlockSet -> Bool\r
-elemBlockSet bid bids = S.member bid bids\r
-\r
------------------------------------------------------------------------------\r
---             Graphs\r
------------------------------------------------------------------------------\r
-\r
-data ZOpen\r
-data ZClosed\r
-\r
-type O = ZOpen\r
-type C = ZClosed\r
-\r
-data ZBlock e x m l where\r
-  ZFirst :: BlockId -> ZBlock C O m l\r
-  ZMid   :: m      -> ZBlock O O m l\r
-  ZLast  :: l      -> ZBlock O C m l\r
-  ZCat   :: ZBlock e O m l -> ZBlock O x m l -> ZBlock e x m l\r
-\r
-type ZHead = ZBlock C O\r
-type ZMids = ZBlock O O\r
-type ZTail = ZBlock O C\r
-type Block = ZBlock C C\r
-\r
-data ZGraph e x m l where\r
-  ZGMany { zg_entry  :: ZBlock e C m l\r
-        , zg_blocks :: BlockEnv (Block m l)\r
-        , zg_exit   :: ZBlock C x m l } :: ZGraph e x m l\r
-  ZGOne  { zg_mids :: ZMids m l }        :: ZGraph O O m l\r
-  ZGNil                                  :: ZGraph O O m l\r
-\r
-type Graph = ZGraph C C\r
-\r
-forwardBlockList :: BlockEnv (Block m l) -> [(BlockId, Block m l)]\r
--- This produces a list of blocks in order suitable for forward analysis.\r
--- ToDo: Do a topological sort to improve convergence rate of fixpoint\r
---       This will require a (HavingSuccessors l) class constraint\r
-forwardBlockList env = M.toList env\r
-\r
------------------------------------------------------------------------------\r
---             DataflowLattice\r
------------------------------------------------------------------------------\r
-\r
-data DataflowLattice a = DataflowLattice  { \r
-  fact_name       :: String,                 -- Documentation\r
-  fact_bot        :: a,                      -- Lattice bottom element\r
-  fact_add_to     :: a -> a -> TxRes a,      -- Lattice join plus change flag\r
-  fact_do_logging :: Bool                    -- log changes\r
-}\r
-\r
------------------------------------------------------------------------------\r
---             TxRes and ChangeFlags\r
------------------------------------------------------------------------------\r
-\r
-data ChangeFlag = NoChange | SomeChange\r
-data TxRes a = TxRes ChangeFlag a\r
-\r
-\r
------------------------------------------------------------------------------\r
---             The main Hoopl API\r
------------------------------------------------------------------------------\r
-\r
-data ForwardTransfers m l f \r
-  = ForwardTransfers\r
-      { ft_lattice :: DataflowLattice f\r
-      , ft_first   :: BlockId -> f -> f\r
-      , ft_middle  :: m       -> f -> f\r
-      , ft_last    :: l       -> f -> OutFacts f\r
-      } \r
-\r
-data ForwardRewrites m l f \r
-  = ForwardRewrites\r
-      { fr_first  :: BlockId -> f -> Maybe (AGraph C O m l)\r
-      , fr_middle :: m       -> f -> Maybe (AGraph O O m l)\r
-      , fr_last   :: l       -> f -> Maybe (AGraph O C m l)\r
-      , fr_exit   ::            f -> Maybe (AGraph O O m l)\r
-      } \r
-\r
-data AGraph e x m l = AGraph   -- Stub for now\r
-\r
------------------------------------------------------------------------------\r
---             The FactBase\r
------------------------------------------------------------------------------\r
-\r
-type FactBase fact = BlockEnv fact\r
-\r
-getFact :: DataflowLattice fact -> FactBase fact -> BlockId -> fact\r
-getFact lat fb id = lookupBEnv fb id `orElse` fact_bot lat\r
-\r
-\r
------------------------------------------------------------------------------\r
---      TxFactBase: a FactBase with ChangeFlag information\r
------------------------------------------------------------------------------\r
-\r
--- A TxFactBase carries a ChangeFlag with it, and a set of BlockIds\r
--- to monitor. Updates to other BlockIds don't affect the ChangeFlag\r
-data TxFactBase fact \r
-  = TxFB { tfb_fbase :: FactBase fact\r
-         , tfb_cha   :: ChangeFlag\r
-         , tfb_bids  :: BlockSet  -- Update change flag iff these blocks change\r
-    }\r
-\r
-updateFact :: DataflowLattice f -> (BlockId, f)\r
-           -> TxFactBase f -> TxFactBase f\r
--- Update a TxFactBase, setting the change flag iff\r
---   a) the new fact adds information...\r
---   b) for a block in the BlockSet in the TxFactBase\r
-updateFact lat (bid, new_fact) tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids})\r
-  | NoChange <- cha2        = tx_fb\r
-  | bid `elemBlockSet` bids = tx_fb { tfb_fbase = new_fbase, tfb_cha = SomeChange }\r
-  | otherwise               = tx_fb { tfb_fbase = new_fbase }\r
-  where\r
-    old_fact = lookupBEnv fbase bid `orElse` fact_bot lat\r
-    TxRes cha2 res_fact = fact_add_to lat old_fact new_fact\r
-    new_fbase = extendBEnv fbase bid res_fact\r
-\r
-updateFacts :: DataflowLattice f -> BlockId\r
-            -> Trans (FactBase f)   (OutFacts f)\r
-            -> Trans (TxFactBase f) (TxFactBase f)\r
-updateFacts lat bid thing_inside tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids })\r
-  = do { OutFacts out_facts <- thing_inside fbase\r
-       ; let tx_fb' = tx_fb { tfb_bids = extendBlockSet bids bid }\r
-       ; return (foldr (updateFact lat) tx_fb out_facts) }\r
-\r
------------------------------------------------------------------------------\r
---             The Trans arrow\r
------------------------------------------------------------------------------\r
-\r
-type Trans a b = a -> FuelMonad b\r
- -- Transform a into b, with facts of type f\r
- -- Deals with optimsation fuel and unique supply too\r
-  \r
-(>>>) :: Trans a b -> Trans b c -> Trans a c\r
--- Compose two dataflow transfers in sequence\r
-(dft1 >>> dft2) f1 = do { f2 <- dft1 f1; dft2 f2 }\r
-\r
-liftTrans :: (a->b) -> Trans a b\r
-liftTrans f x = return (f x)\r
-\r
-idTrans :: Trans a a\r
-idTrans x = return x\r
-\r
-fixpointTrans :: forall f. Trans (TxFactBase f) (TxFactBase f) \r
-                        -> Trans (OutFacts f)   (FactBase f)\r
-fixpointTrans thing_inside (OutFacts out_facts)\r
-  = loop (mkBlockEnv out_facts)\r
-  where\r
-    loop :: Trans (FactBase f) (FactBase f)\r
-    loop fbase = do { tx_fb <- thing_inside (TxFB { tfb_fbase = fbase\r
-                                                  , tfb_cha = NoChange\r
-                                                  , tfb_bids = emptyBlockSet })\r
-                    ; case tfb_cha tx_fb of\r
-                        NoChange   -> return fbase\r
-                        SomeChange -> loop (tfb_fbase tx_fb) }\r
-\r
------------------------------------------------------------------------------\r
---             Transfer functions\r
------------------------------------------------------------------------------\r
-\r
--- Keys to the castle: a generic transfer function for each shape\r
--- Here's the idea: we start with single-node transfer functions,\r
--- move to basic-block transfer functions (we have exactly four shapes),\r
--- then finally to graph transfer functions (which requires iteration).\r
-\r
-data GFT co oo oc cc fact \r
-  = GFT { gft_lat :: DataflowLattice fact\r
-               , gft_co  :: co -> Trans (FactBase fact) fact\r
-               , gft_oo  :: oo -> Trans fact            fact\r
-               , gft_oc  :: oc -> Trans fact            (OutFacts fact)\r
-               , gft_cc  :: cc -> Trans (FactBase fact) (OutFacts fact) }\r
-            \r
-newtype OutFacts fact = OutFacts [(BlockId, fact)] \r
-\r
-  \r
-----------------------------------------------------------------------------------------------\r
---                       closed/open      open/open        open/closed      closed/closed\r
-----------------------------------------------------------------------------------------------\r
-type GFT_Node  m l f = GFT BlockId          m                l                Void             f\r
-type GFT_Block m l f = GFT (ZHead m l)      (ZMids m l)      (ZTail m l)      (Block m l)      f\r
-type GFT_Graph m l f = GFT (ZGraph C O m l) (ZGraph O O m l) (ZGraph O C m l) (ZGraph C C m l) f\r
-----------------------------------------------------------------------------------------------\r
-\r
-data Void  -- There is no closed/closed node\r
-\r
-gftNode :: forall m l f . ForwardTransfers m l f -> GFT_Node m l f\r
--- Injection from the external interface into the internal representation\r
-gftNode (ForwardTransfers { ft_lattice = lattice\r
-                          , ft_first  = first_fn\r
-                          , ft_middle = middle_fn\r
-                          , ft_last   = last_fn })\r
-  = GFT { gft_lat = lattice\r
-        , gft_co  = ft_first\r
-        , gft_oo  = ft_middle \r
-        , gft_oc  = ft_last\r
-        , gft_cc  = error "f_cc for node is undefined" }\r
-    where \r
-      ft_first blk_id fb  = return (first_fn  blk_id (getFact lattice fb blk_id))\r
-      ft_middle node fact = return (middle_fn node fact)\r
-      ft_last node fact   = return (last_fn   node fact)\r
-\r
-gftBlock :: forall m l f. GFT_Node m l f -> GFT_Block m l f\r
--- Lift from nodes to blocks\r
-gftBlock (GFT { gft_lat = lat, gft_co = ft_first\r
-               , gft_oo = ft_middle, gft_oc = ft_last })\r
-  = GFT { gft_lat = lat\r
-               , gft_co  = ft_head \r
-               , gft_oo  = ft_mids\r
-               , gft_oc  = ft_tail\r
-               , gft_cc  = ft_block }\r
-  where \r
-    ft_head :: ZBlock C O m l -> Trans (FactBase f) f\r
-    ft_head (ZFirst blk_id)  = ft_first blk_id\r
-    ft_head (ZCat head mids) = ft_head head >>> ft_mids mids\r
-\r
-    ft_mids :: ZBlock O O m l -> Trans f f\r
-    ft_mids (ZMid node)  = ft_middle node\r
-    ft_mids (ZCat m1 m2) = ft_mids m1 >>> ft_mids m2\r
-\r
-    ft_tail :: ZBlock O C m l -> Trans f (OutFacts f)\r
-    ft_tail (ZLast node)     = ft_last node\r
-    ft_tail (ZCat mids tail) = ft_mids mids >>> ft_tail tail\r
-\r
-    ft_block :: ZBlock C C m l -> Trans (FactBase f) (OutFacts f)\r
-    ft_block (ZCat head tail) = ft_head head >>> ft_tail tail\r
-\r
-gftGraph :: forall m l f. GFT_Block m l f -> GFT_Graph m l f\r
--- Lift from blocks to graphs\r
-gftGraph (GFT { gft_lat = lat\r
-               , gft_co = ft_head, gft_oo = ft_mids\r
-               , gft_oc = ft_tail, gft_cc = ft_block })\r
-  = GFT { gft_lat = lat\r
-        , gft_co  = ft_co\r
-        , gft_oo  = ft_oo\r
-        , gft_oc  = ft_oc\r
-        , gft_cc  = ft_cc }\r
-  where\r
-       -- These functions are orgasmically beautiful\r
-    ft_co :: ZGraph C O m l -> Trans (FactBase f) f\r
-    ft_co (ZGMany { zg_entry = entry, zg_blocks = blocks, zg_exit = exit })\r
-      = ft_block entry >>> ft_blocks blocks >>> ft_head exit\r
-\r
-    ft_oo :: ZGraph O O m l -> Trans f f\r
-    ft_oo ZGNil        = idTrans\r
-    ft_oo (ZGOne mids) = ft_mids mids\r
-    ft_oo (ZGMany { zg_entry = entry, zg_blocks = blocks, zg_exit = exit })\r
-      = ft_tail entry >>> ft_blocks blocks >>> ft_head exit\r
-\r
-    ft_oc :: ZGraph O C m l -> Trans f (OutFacts f)\r
-    ft_oc (ZGMany { zg_entry = entry, zg_blocks = blocks, zg_exit = exit })\r
-      = ft_tail entry >>> ft_blocks blocks >>> ft_block exit\r
-\r
-    ft_cc :: ZGraph C C m l -> Trans (FactBase f) (OutFacts f)\r
-    ft_cc (ZGMany { zg_entry = entry, zg_blocks = blocks, zg_exit = exit })\r
-      = ft_block entry >>> ft_blocks blocks >>> ft_block exit\r
-\r
-    ft_blocks :: BlockEnv (Block m l) -> Trans (OutFacts f) (FactBase f)\r
-    ft_blocks blocks = fixpointTrans (ft_blocks_once (forwardBlockList blocks))\r
-\r
-    ft_blocks_once :: [(BlockId, Block m l)] -> Trans (TxFactBase f) (TxFactBase f)\r
-    ft_blocks_once blks = foldr ((>>>) . ft_block_once) idTrans blks\r
-\r
-    ft_block_once :: (BlockId, Block m l)\r
-                  -> Trans (TxFactBase f) (TxFactBase f)\r
-    ft_block_once (blk_id, blk) = updateFacts lat blk_id (ft_block blk)\r
-\r
-\r
------------------------------------------------------------------------------\r
---             Rewriting\r
------------------------------------------------------------------------------\r
-\r
-{-\r
-data GRT co oo oc cc fact \r
-  = GRT { grt_lat :: DataflowLattice fact\r
-               , grt_co  :: co -> Trans (FactBase fact) (fact, Graph C O m l)\r
-               , grt_oo  :: oo -> Trans fact            (fact, Graph O O m l)\r
-               , grt_oc  :: oc -> Trans fact            (OutFacts fact)\r
-               , gRt_cc  :: cc -> Trans (FactBase fact) (OutFacts fact) }\r
--}\r
-\r
------------------------------------------------------------------------------\r
---             The fuel monad\r
------------------------------------------------------------------------------\r
-\r
-type Uniques = Int\r
-type Fuel    = Int\r
-\r
-newtype FuelMonad a = FM { unFM :: Fuel -> Uniques -> (a, Fuel, Uniques) }\r
-\r
-instance Monad FuelMonad where\r
-  return x = FM (\f u -> (x,f,u))\r
-  m >>= k  = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u')\r
-\r
-fuelExhausted :: FuelMonad Bool\r
-fuelExhausted = FM (\f u -> (f <= 0, f, u))\r
-\r
-decrementFuel :: FuelMonad ()\r
-decrementFuel = FM (\f u -> ((), f-1, u))\r
-\r
-graphOfAGraph :: AGraph e x m l -> FuelMonad (ZGraph e x m l)\r
-graphOfAGraph = error "urk"    -- Stub\r
-\r
------------------------------------------------------------------------------\r
---             Utility functions\r
------------------------------------------------------------------------------\r
-\r
-orElse :: Maybe a -> a -> a\r
-orElse (Just x) _ = x\r
-orElse Nothing  y = y\r
-\r
-\r
-\r
-----------------------------------------------------------------\r
---       The pièce de resistance: cunning transfer functions\r
-----------------------------------------------------------------\r
-\r
-pureAnalysis :: ForwardTransfers m l f -> GFT_Graph m l f\r
-pureAnalysis = gftGraph . gftBlock . gftNode\r
-\r
-analyseAndRewrite\r
-   :: forall m l f . \r
-      RewritingDepth\r
-   -> ForwardTransfers m l f\r
-   -> ForwardRewrites m l f\r
-   -> GFT_Graph m l f\r
-\r
-data RewritingDepth = RewriteShallow | RewriteDeep\r
--- When a transformation proposes to rewrite a node, \r
--- you can either ask the system to\r
---  * "shallow": accept the new graph, analyse it without further rewriting\r
---  * "deep": recursively analyse-and-rewrite the new graph\r
-\r
-\r
-analyseAndRewrite depth transfers rewrites\r
-  = gft_graph_cunning\r
-  where \r
-    lat = ft_lattice transfers\r
-\r
-    gft_graph_base, gft_graph_cunning, gft_graph_recurse :: GFT_Graph m l f\r
-\r
-    gft_graph_base    = gftGraph (gftBlock gft_node_base)\r
-    gft_graph_cunning = gftGraph (gftBlock gft_node_cunning)\r
-    gft_graph_recurse = case depth of\r
-                          RewriteShallow -> gft_graph_base\r
-                          RewriteDeep    -> gft_graph_cunning\r
-\r
-    gft_node_base, gft_node_cunning :: GFT_Node m l f\r
-    gft_node_base    = gftNode transfers\r
-    gft_node_cunning = GFT { gft_lat = lat\r
-                          , gft_co  = cunning_first\r
-                          , gft_oo  = cunning_middle \r
-                          , gft_oc  = cunning_last\r
-                          , gft_cc  = error "f_cc for node is undefined" }\r
-\r
-    cunning_first :: BlockId -> Trans (FactBase f) f\r
-    cunning_first bid = tryRewrite (rw_first bid)\r
-                                   (gft_co gft_graph_recurse)\r
-                                   (gft_co gft_node_base bid) \r
-\r
-    rw_first :: BlockId -> FactBase f -> Maybe (AGraph C O m l)\r
-    rw_first bid fb = fr_first rewrites bid (getFact lat fb bid)\r
-\r
-    cunning_middle :: m -> Trans f f\r
-    cunning_middle mid = tryRewrite (fr_middle rewrites mid)\r
-                                    (gft_oo gft_graph_recurse)\r
-                                    (gft_oo gft_node_base mid)\r
-\r
-    cunning_last :: l -> Trans f (OutFacts f)\r
-    cunning_last last = tryRewrite (fr_last rewrites last)\r
-                                   (gft_oc gft_graph_recurse)\r
-                                   (gft_oc gft_node_base last)\r
-\r
------------\r
-tryRewrite :: (a -> (Maybe (AGraph e x m l)))  -- The rewriter\r
-           -> (ZGraph e x m l -> Trans a r)    -- Rewrite succeeds\r
-           -> Trans a r                                -- Rewrite fails\r
-           -> Trans a r\r
-tryRewrite rewriter do_yes do_no a\r
-  = case (rewriter a) of\r
-      Nothing -> do_no a\r
-      Just g  -> do { out <- fuelExhausted\r
-                           ; if out then do_no a\r
-                             else do { decrementFuel\r
-                                     ; g' <- graphOfAGraph g\r
-                                     ; do_yes g' a } }\r
diff --git a/prototypes/Hoopl.hs b/prototypes/Hoopl.hs
deleted file mode 100644 (file)
index 25d758c..0000000
+++ /dev/null
@@ -1,459 +0,0 @@
-{-# OPTIONS_GHC -Wall -fno-warn-incomplete-patterns #-}
--- With GHC 6.10 we get bogus incomplete-pattern warnings
--- It's fine in 6.12
-{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, 
-             PatternGuards, TypeFamilies #-}
-
--- This version uses type families to express the functional dependency
--- between the open/closed-ness of the input graph and the type of the
--- input fact expected for a graph of that shape
-
-module Hoopl where
-
-import qualified Data.IntMap as M
-import qualified Data.IntSet as S
-
------------------------------------------------------------------------------
---             Graphs
------------------------------------------------------------------------------
-
-data ZOpen
-data ZClosed
-
-type O = ZOpen
-type C = ZClosed
-
--- Blocks are always non-empty
-data Block n e x where
-  BUnit :: n e x -> Block n e x
-  BCat  :: Block n e O -> Block n O x -> Block n e x
-
-type Blocks n = [Block n C C]
-
-data Graph n e x where
-  GNil  :: Graph n O O
-  GUnit :: Block n e x -> Graph n e x
-  GMany { g_entry  :: Block n e C
-        , g_blocks :: Blocks n
-       , g_exit   :: Exit (Block n) x } :: Graph n e x
-
-   -- Invariant:  if g_entry is closed,
-   -- its BlockId cannot be a target of
-   -- branches in the blocks
-
-   -- If a graph has a Tail, then that tail is the only  
-   -- exit from the graph, even if the Tail is closed
-   -- See the definition of successors!
-
-data Exit thing x where
-  NoTail :: Exit thing C
-  Tail   :: thing C x -> Exit thing x
-
-class Edges thing where
-  blockId    :: thing C x -> BlockId
-  successors :: thing e C -> [BlockId]
-
-instance Edges n => Edges (Block n) where
-  blockId    (BUnit n)  = blockId n
-  blockId    (BCat b _) = blockId b
-  successors (BUnit n)  = successors n
-  successors (BCat _ b) = successors b
-
-instance Edges n => Edges (Graph n) where
-  blockId    (GUnit b)  = blockId b
-  blockId    (GMany b _ _) = blockId b
-  successors (GUnit b)            = successors b
-  successors (GMany _ _ (Tail b)) = successors b
-  successors (GMany b bs NoTail) 
-     = blockSetElems (all_succs `minusBlockSet` all_blk_ids)
-     where 
-       all_succs   = mkBlockSet (successors b ++ concatMap successors bs)
-       all_blk_ids = mkBlockSet (map blockId bs)
-
-
-gCat :: Graph n e O -> Graph n O x -> Graph n e x
-gCat GNil g2 = g2
-gCat g1 GNil = g1
-
-gCat (GUnit b1) (GUnit b2)             
-  = GUnit (b1 `BCat` b2)
-
-gCat (GUnit b) (GMany e bs x) 
-  = GMany (b `BCat` e) bs x
-
-gCat (GMany e bs (Tail x)) (GUnit b2) 
-   = GMany e bs (Tail (x `BCat` b2))
-
-gCat (GMany e1 bs1 (Tail x1)) (GMany e2 bs2 x2)
-   = GMany e1 (x1 `BCat` e2 : bs1 ++ bs2) x2
-
-gCatC :: Graph n e C -> Graph n C x -> Graph n e x
-gCatC (GUnit b1)               (GUnit b2)        = GMany b1 [] (Tail b2)
-gCatC (GUnit b1)               (GMany e2 bs x2)  = GMany b1 (e2:bs) x2
-gCatC (GMany e bs NoTail)      (GUnit b2)        = GMany e bs (Tail b2)
-gCatC (GMany e bs (Tail b1))   (GUnit b2)        = GMany e (b1:bs) (Tail b2)
-gCatC (GMany e1 bs1 NoTail)    (GMany e2 bs2 x2) = GMany e1 (e2 : bs1 ++ bs2) x2
-gCatC (GMany e1 bs1 (Tail x1)) (GMany e2 bs2 x2) = GMany e1 (x1 : e2 : bs1 ++ bs2) x2
-
-mkGMany :: Graph n e C -> Blocks n -> Exit (Graph n) x -> Graph n e x
-mkGMany e bs x = GMany b_e (bs_e ++ bs ++ bs_x) b_x
-  where
-     (b_e, bs_e) = mkHead e
-     (bs_x, b_x) = mkTail x
-
-mkHead :: Graph n e C -> (Block n e C, Blocks n)
-mkHead (GUnit b)             = (b, [])
-mkHead (GMany e bs NoTail)   = (e, bs)
-mkHead (GMany e bs (Tail b)) = (e, b:bs)
-
-mkTail :: Exit (Graph n) x -> (Blocks n, Exit (Block n) x)
-mkTail NoTail                = ([], NoTail)    
-mkTail (Tail (GUnit b))      = ([], Tail b)
-mkTail (Tail (GMany e bs x)) = (e:bs, x)
-
-flattenG :: Graph n C C -> Blocks n
-flattenG (GUnit b)             = [b]
-flattenG (GMany e bs NoTail)   = e:bs
-flattenG (GMany e bs (Tail x)) = e:x:bs
-
-forwardBlockList :: Blocks n -> Blocks n
--- This produces a list of blocks in order suitable for forward analysis.
--- ToDo: Do a topological sort to improve convergence rate of fixpoint
---       This will require a (HavingSuccessors l) class constraint
-forwardBlockList blks = blks
-
------------------------------------------------------------------------------
---             DataflowLattice
------------------------------------------------------------------------------
-
-data DataflowLattice a = DataflowLattice  { 
-  fact_name       :: String,                 -- Documentation
-  fact_bot        :: a,                      -- Lattice bottom element
-  fact_add_to     :: a -> a -> TxRes a,      -- Lattice join plus change flag
-  fact_do_logging :: Bool                    -- log changes
-}
-
-data ChangeFlag = NoChange | SomeChange
-data TxRes a = TxRes ChangeFlag a
-
------------------------------------------------------------------------------
---             The main Hoopl API
------------------------------------------------------------------------------
-
-type ForwardTransfers n f 
-  = forall e x. n e x -> InFact e f -> OutFact x f 
-
-type ForwardRewrites n f 
-  = forall e x. n e x -> InFact e f -> Maybe (AGraph n e x)
-
-type family   InFact e f :: *
-type instance InFact C f = InFactC f
-type instance InFact O f = f
-
-type family   OutFact x f :: *
-type instance OutFact C f = OutFactC f
-type instance OutFact O f = f
-
-type InFactC  fact = BlockId -> fact
-type OutFactC fact = [(BlockId, fact)] 
-
-data AGraph n e x = AGraph     -- Stub for now
-
-
------------------------------------------------------------------------------
---      TxFactBase: a FactBase with ChangeFlag information
------------------------------------------------------------------------------
-
--- The TxFactBase is an accumulating parameter, threaded through all
--- the analysis/transformation of each block in the g_blocks of a grpah.
--- It carries a ChangeFlag with it, and a set of BlockIds
--- to monitor. Updates to other BlockIds don't affect the ChangeFlag
-data TxFactBase n f
-  = TxFB { tfb_fbase :: FactBase f
-
-         , tfb_cha   :: ChangeFlag
-         , tfb_bids  :: BlockSet   -- Update change flag iff these blocks change
-                                   -- These are BlockIds of the *original* 
-                                   -- (not transformed) blocks
-
-         , tfb_blks  :: Blocks n   -- Transformed blocks
-    }
-
-factBaseInFacts :: DataflowLattice f -> TxFactBase n f -> InFactC f
-factBaseInFacts lattice (TxFB { tfb_fbase = fbase }) 
-  = lookupFact lattice fbase
-
-factBaseOutFacts :: TxFactBase n f -> OutFactC f
-factBaseOutFacts (TxFB { tfb_fbase = fbase, tfb_bids = bids }) 
-  = [ (bid, f) | (bid, f) <- factBaseList fbase
-               , not (bid `elemBlockSet` bids) ]
-  -- The successors of the Graph are the the BlockIds for which
-  -- we hvae facts, that are *not* in the blocks of the graph
-
-updateFact :: DataflowLattice f -> (BlockId, f)
-           -> TxFactBase n f -> TxFactBase n f
--- Update a TxFactBase, setting the change flag iff
---   a) the new fact adds information...
---   b) for a block in the BlockSet in the TxFactBase
-updateFact lat (bid, new_fact) tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids})
-  | NoChange <- cha2        = tx_fb
-  | bid `elemBlockSet` bids = tx_fb { tfb_fbase = new_fbase, tfb_cha = SomeChange }
-  | otherwise               = tx_fb { tfb_fbase = new_fbase }
-  where
-    old_fact = lookupFact lat fbase bid
-    TxRes cha2 res_fact = fact_add_to lat old_fact new_fact
-    new_fbase = extendFactBase fbase bid res_fact
-
-updateFacts :: Edges n
-            => DataflowLattice f 
-            -> GFT_Block n f
-            -> Block n C C
-            -> Trans (TxFactBase n f) (TxFactBase n f)
-updateFacts lat (GFT block_trans) blk
-    tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids, tfb_blks = blks })
-  = do { (graph, out_facts) <- block_trans blk (lookupFact lat fbase)
-       ; let tx_fb' = tx_fb { tfb_bids = extendBlockSet bids (blockId blk)
-                            , tfb_blks = flattenG graph ++ blks }
-       ; return (foldr (updateFact lat) tx_fb' out_facts) }
-
------------------------------------------------------------------------------
---             The Trans arrow
------------------------------------------------------------------------------
-
-type Trans a b = a -> FuelMonad b 
- -- Transform a into b, with facts of type f
- -- Deals with optimsation fuel and unique supply too
-  
-(>>>) :: Trans a b -> Trans b c -> Trans a c
--- Compose two dataflow transfers in sequence
-(dft1 >>> dft2) f = do { f1 <- dft1 f; f2 <- dft2 f1; return f2 }
-
-liftTrans :: (a->b) -> Trans a b
-liftTrans f x = return (f x)
-
-idTrans :: Trans a a
-idTrans x = return x
-
-fixpointTrans :: forall n f. 
-                 Trans (TxFactBase n f) (TxFactBase n f) 
-              -> Trans (OutFactC f)     (TxFactBase n f)
-fixpointTrans tx_fb_trans out_facts
-  = do { fuel <- getFuel  
-       ; loop fuel (mkFactBase out_facts) }
-  where
-    loop :: Fuel -> Trans (FactBase f) (TxFactBase n f)
-    loop fuel fbase 
-      = do { tx_fb <- tx_fb_trans (TxFB { tfb_fbase = fbase
-                                        , tfb_cha = NoChange
-                                        , tfb_blks = []
-                                        , tfb_bids = emptyBlockSet })
-           ; case tfb_cha tx_fb of
-               NoChange   -> return tx_fb
-               SomeChange -> do { setFuel fuel; loop fuel (tfb_fbase tx_fb) } }
-
------------------------------------------------------------------------------
---             Transfer functions
------------------------------------------------------------------------------
-
--- Keys to the castle: a generic transfer function for each shape
--- Here's the idea: we start with single-n transfer functions,
--- move to basic-block transfer functions (we have exactly four shapes),
--- then finally to graph transfer functions (which requires iteration).
-
-newtype GFT thing n f = GFT (GFTR thing n f)
-type GFTR thing n f = forall e x. thing e x 
-                               -> InFact e f
-                               -> FuelMonad (Graph n e x, OutFact x f)
-
-type GFT_Node  n f = GFT n         n f
-type GFT_Block n f = GFT (Block n) n f
-type GFT_Graph n f = GFT (Graph n) n f
------------------------------------------------------------------------------
-
-gftNodeTransfer :: forall n f . ForwardTransfers n f -> GFT_Node n f
--- Lifts ForwardTransfers to GFT_Node; simple transfer only
-gftNodeTransfer base_trans = GFT node_trans
-    where 
-      node_trans :: GFTR n n f
-      node_trans node f = return (GUnit (BUnit node), base_trans node f)
-
-gftNodeRewrite :: forall n f.
-                  ForwardTransfers n f
-               -> ForwardRewrites n f
-               -> GFT_Graph n f
-               -> GFT_Node n f
--- Lifts (ForwardTransfers,ForwardRewrites) to GFT_Node; 
--- this time we do rewriting as well. 
--- The GFT_Graph parameters specifies what to do with the rewritten graph
-gftNodeRewrite transfers rewrites (GFT graph_trans) 
-  = GFT node_rewrite
-  where
-    node_trans :: GFTR n n f
-    node_trans node f = return (GUnit (BUnit node), transfers node f)
-
-    node_rewrite :: GFTR n n f
-    node_rewrite node f  
-       = case rewrites node f of
-          Nothing -> node_trans node f
-          Just g  -> do { out <- fuelExhausted
-                           ; if out then 
-                              node_trans node f
-                             else do { decrementFuel
-                                     ; g' <- graphOfAGraph g
-                                     ; graph_trans g' f } }
-
-gftBlock :: forall n f. GFT_Node n f -> GFT_Block n f
--- Lift from nodes to blocks
-gftBlock (GFT node_trans) = GFT block_trans
-  where 
-    block_trans :: GFTR (Block n) n f
-    block_trans (BUnit node)   f = node_trans node f
-    block_trans (BCat hd mids) f = do { (g1,f1) <- block_trans hd f
-                                      ; (g2,f2) <- block_trans mids f1
-                                     ; return (g1 `gCat` g2, f2) }
-
-
-gftGraph :: forall n f. Edges n => DataflowLattice f -> GFT_Block n f -> GFT_Graph n f
--- Lift from blocks to graphs
-gftGraph lattice gft_block@(GFT block_trans) = GFT graph_trans
-  where
-    graph_trans :: GFTR (Graph n) n f
-    graph_trans GNil        f = return (GNil, f)
-    graph_trans (GUnit blk) f = block_trans blk f
-    graph_trans (GMany entry blocks exit) f
-      = do { (entry', f1)  <- block_trans entry f
-           ; tx_fb         <- ft_blocks blocks f1
-           ; (exit', f3)   <- ft_exit exit tx_fb 
-           ; return (mkGMany entry' (tfb_blks tx_fb) exit', f3) }
-
-       -- It's a bit disgusting that the TxFactBase has to be
-        -- preserved as far as the Exit block, becaues the TxFactBase
-        -- is really concerned with the fixpoint calculation
-        -- But I can't see any other tidy way to compute the 
-        -- LastOutFacts in the NoTail case
-    ft_exit :: Exit (Block n) x  -> Trans (TxFactBase n f) (Exit (Graph n) x, OutFact x f)
-    ft_exit (Tail blk) f = do { (blk', f1) <- block_trans blk (factBaseInFacts lattice f)
-                              ; return (Tail blk', f1) }
-    ft_exit NoTail     f = return (NoTail, factBaseOutFacts f)
-
-    ft_block_once :: Block n C C -> Trans (TxFactBase n f) (TxFactBase n f)
-    ft_block_once blk = updateFacts lattice gft_block blk
-
-    ft_blocks_once :: Blocks n -> Trans (TxFactBase n f) (TxFactBase n f)
-    ft_blocks_once blks = foldr ((>>>) . ft_block_once) idTrans blks
-
-    ft_blocks :: [Block n C C] -> Trans (OutFactC f) (TxFactBase n f)
-    ft_blocks blocks = fixpointTrans (ft_blocks_once (forwardBlockList blocks))
-
-----------------------------------------------------------------
---       The pièce de resistance: cunning transfer functions
-----------------------------------------------------------------
-
-pureAnalysis :: Edges n => DataflowLattice f -> ForwardTransfers n f -> GFT_Graph n f
-pureAnalysis lattice = gftGraph lattice . gftBlock . gftNodeTransfer
-
-analyseAndRewrite
-   :: forall n f. Edges n
-   => RewritingDepth
-   -> DataflowLattice f
-   -> ForwardTransfers n f
-   -> ForwardRewrites n f
-   -> GFT_Graph n f
-
-data RewritingDepth = RewriteShallow | RewriteDeep
--- When a transformation proposes to rewrite a node, 
--- you can either ask the system to
---  * "shallow": accept the new graph, analyse it without further rewriting
---  * "deep": recursively analyse-and-rewrite the new graph
-
-analyseAndRewrite depth lattice transfers rewrites
-  = gft_graph_cunning
-  where 
-    gft_graph_base, gft_graph_cunning, gft_graph_recurse :: GFT_Graph n f
-
-    gft_graph_base    = gftGraph lattice (gftBlock gft_node_base)
-    gft_graph_cunning = gftGraph lattice (gftBlock gft_node_cunning)
-    gft_graph_recurse = case depth of
-                          RewriteShallow -> gft_graph_base
-                          RewriteDeep    -> gft_graph_cunning
-
-    gft_node_base, gft_node_cunning :: GFT_Node n f
-    gft_node_base    = gftNodeTransfer transfers
-    gft_node_cunning = gftNodeRewrite  transfers rewrites gft_graph_recurse
-
------------------------------------------------------------------------------
---             The fuel monad
------------------------------------------------------------------------------
-
-type Uniques = Int
-type Fuel    = Int
-
-newtype FuelMonad a = FM { unFM :: Fuel -> Uniques -> (a, Fuel, Uniques) }
-
-instance Monad FuelMonad where
-  return x = FM (\f u -> (x,f,u))
-  m >>= k  = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u')
-
-fuelExhausted :: FuelMonad Bool
-fuelExhausted = FM (\f u -> (f <= 0, f, u))
-
-decrementFuel :: FuelMonad ()
-decrementFuel = FM (\f u -> ((), f-1, u))
-
-getFuel :: FuelMonad Fuel
-getFuel = FM (\f u -> (f,f,u))
-
-setFuel :: Fuel -> FuelMonad ()
-setFuel f = FM (\_ u -> ((), f, u))
-
-graphOfAGraph :: AGraph node e x -> FuelMonad (Graph node e x)
-graphOfAGraph = error "urk"    -- Stub
-
------------------------------------------------------------------------------
---             BlockId, BlockEnv, BlockSet
------------------------------------------------------------------------------
-
-type BlockId = Int
-
-mkBlockId :: Int -> BlockId
-mkBlockId uniq = uniq
-
-type FactBase a = M.IntMap a
-
-mkFactBase :: [(BlockId, f)] -> FactBase f
-mkFactBase prs = M.fromList prs
-
-lookupFact :: DataflowLattice f -> FactBase f -> BlockId -> f
-lookupFact lattice env blk_id 
-  = case M.lookup blk_id env of
-      Just f  -> f
-      Nothing -> fact_bot lattice
-
-extendFactBase :: FactBase f -> BlockId -> f -> FactBase f
-extendFactBase env blk_id f = M.insert blk_id f env
-
-unionFactBase :: FactBase f -> FactBase f -> FactBase f
-unionFactBase = M.union
-
-factBaseList :: FactBase f -> [(BlockId, f)]
-factBaseList env = M.toList env
-
-type BlockSet = S.IntSet
-
-emptyBlockSet :: BlockSet
-emptyBlockSet = S.empty
-
-extendBlockSet :: BlockSet -> BlockId -> BlockSet
-extendBlockSet bids bid = S.insert bid bids
-
-elemBlockSet :: BlockId -> BlockSet -> Bool
-elemBlockSet bid bids = S.member bid bids
-
-blockSetElems :: BlockSet -> [BlockId]
-blockSetElems = S.toList
-
-minusBlockSet :: BlockSet -> BlockSet -> BlockSet
-minusBlockSet = S.difference
-
-mkBlockSet :: [BlockId] -> BlockSet
-mkBlockSet = S.fromList
diff --git a/prototypes/Hoopl1.hs b/prototypes/Hoopl1.hs
deleted file mode 100644 (file)
index e20e13c..0000000
+++ /dev/null
@@ -1,470 +0,0 @@
-{-# OPTIONS_GHC -Wall -fno-warn-incomplete-patterns #-}
--- With GHC 6.10 we get bogus incomplete-pattern warnings
--- It's fine in 6.12
-{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, 
-             PatternGuards, TypeFamilies #-}
-
--- This version uses type families to express the functional dependency
--- between the open/closed-ness of the input graph and the type of the
--- input fact expected for a graph of that shape
-
-module Hoopl where
-
-import qualified Data.IntMap as M
-import qualified Data.IntSet as S
-
------------------------------------------------------------------------------
---             Graphs
------------------------------------------------------------------------------
-
-data ZOpen
-data ZClosed
-
-type O = ZOpen
-type C = ZClosed
-
--- Blocks are always non-empty
-data Block n e x where
-  BUnit :: n e x -> Block n e x
-  BCat  :: Block n e O -> Block n O x -> Block n e x
-
-type Blocks n = [Block n C C]
-
-data Graph n e x where
-  GNil  :: Graph n O O
-  GUnit :: Block n e x -> Graph n e x
-  GMany { g_entry  :: Block n e C
-        , g_blocks :: Blocks n
-       , g_exit   :: Exit (Block n C x) x } :: Graph n e x
-
-   -- Invariant:  if g_entry is closed,
-   -- its BlockId cannot be a target of
-   -- branches in the blocks
-
-   -- If a graph has a Tail, then that tail is the only  
-   -- exit from the graph, even if the Tail is closed
-   -- See the definition of successors!
-
-data Exit thing x where
-  NoTail :: Exit thing C
-  Tail   :: thing -> Exit thing x
-
-class Edges thing where
-  blockId    :: thing C x -> BlockId
-  successors :: thing e C -> [BlockId]
-
-instance Edges n => Edges (Block n) where
-  blockId    (BUnit n)  = blockId n
-  blockId    (BCat b _) = blockId b
-  successors (BUnit n)  = successors n
-  successors (BCat _ b) = successors b
-
-instance Edges n => Edges (Graph n) where
-  blockId    (GUnit b)  = blockId b
-  blockId    (GMany b _ _) = blockId b
-  successors (GUnit b)            = successors b
-  successors (GMany _ _ (Tail b)) = successors b
-  successors (GMany b bs NoTail) 
-     = blockSetElems (all_succs `minusBlockSet` all_blk_ids)
-     where 
-       all_succs   = mkBlockSet (successors b ++ concatMap successors bs)
-       all_blk_ids = mkBlockSet (map blockId bs)
-
-
-gCat :: Graph n e O -> Graph n O x -> Graph n e x
-gCat GNil g2 = g2
-gCat g1 GNil = g1
-
-gCat (GUnit b1) (GUnit b2)             
-  = GUnit (b1 `BCat` b2)
-
-gCat (GUnit b) (GMany e bs x) 
-  = GMany (b `BCat` e) bs x
-
-gCat (GMany e bs (Tail x)) (GUnit b2) 
-   = GMany e bs (Tail (x `BCat` b2))
-
-gCat (GMany e1 bs1 (Tail x1)) (GMany e2 bs2 x2)
-   = GMany e1 (x1 `BCat` e2 : bs1 ++ bs2) x2
-
-gCatC :: Graph n e C -> Graph n C x -> Graph n e x
-gCatC (GUnit b1)               (GUnit b2)        = GMany b1 [] (Tail b2)
-gCatC (GUnit b1)               (GMany e2 bs x2)  = GMany b1 (e2:bs) x2
-gCatC (GMany e bs NoTail)      (GUnit b2)        = GMany e bs (Tail b2)
-gCatC (GMany e bs (Tail b1))   (GUnit b2)        = GMany e (b1:bs) (Tail b2)
-gCatC (GMany e1 bs1 NoTail)    (GMany e2 bs2 x2) = GMany e1 (e2 : bs1 ++ bs2) x2
-gCatC (GMany e1 bs1 (Tail x1)) (GMany e2 bs2 x2) = GMany e1 (x1 : e2 : bs1 ++ bs2) x2
-
-type GraphWithFacts  n f e x = (Graph n e x, FactBase f)
-type BlocksWithFacts n f     = (Blocks n,    FactBase f)
-
-gwfCat :: GraphWithFacts n f e O -> GraphWithFacts n f O x -> GraphWithFacts n f e x
-gwfCat (g1,fb1) (g2,fb2) = (g1 `gCat` g2, fb1 `unionFactBase` fb2)
-
-mkGMany :: GraphWithFacts n e C f 
-        -> BlocksWithFacts n 
-        -> Exit (GraphWithFacts n f C x) x
-        -> GraphWithFacts n e x
-mkGMany (e,fb1) (bs,fb2) x = GMany b_e (bs_e ++ bs ++ bs_x) b_x
-  where
-     (b_e, bs_e) = mkHead e
-     (bs_x, b_x) = mkTail x
-
-mkHead :: Graph n e C -> (Block n e C, Blocks n)
-mkHead (GUnit b)             = (b, [])
-mkHead (GMany e bs NoTail)   = (e, bs)
-mkHead (GMany e bs (Tail b)) = (e, b:bs)
-
-mkTail :: Exit (GraphWithFacts n C x) x 
-       -> (BlocksWithFacts n, Exit (Block n C x) x)
-mkTail NoTail                = ([], NoTail)    
-mkTail (Tail (GUnit b, fb))  = ([], Tail b)
-mkTail (Tail (GMany e bs x)) = (e:bs, x)
-
-flattenG :: Graph n C C -> Blocks n
-flattenG (GUnit b)             = [b]
-flattenG (GMany e bs NoTail)   = e:bs
-flattenG (GMany e bs (Tail x)) = e:x:bs
-
-forwardBlockList :: Blocks n -> Blocks n
--- This produces a list of blocks in order suitable for forward analysis.
--- ToDo: Do a topological sort to improve convergence rate of fixpoint
---       This will require a (HavingSuccessors l) class constraint
-forwardBlockList blks = blks
-
------------------------------------------------------------------------------
---             DataflowLattice
------------------------------------------------------------------------------
-
-data DataflowLattice a = DataflowLattice  { 
-  fact_name       :: String,                 -- Documentation
-  fact_bot        :: a,                      -- Lattice bottom element
-  fact_add_to     :: a -> a -> TxRes a,      -- Lattice join plus change flag
-  fact_do_logging :: Bool                    -- log changes
-}
-
-data ChangeFlag = NoChange | SomeChange
-data TxRes a = TxRes ChangeFlag a
-
------------------------------------------------------------------------------
---             The main Hoopl API
------------------------------------------------------------------------------
-
-type ForwardTransfers n f 
-  = forall e x. n e x -> InFact e f -> OutFact x f 
-
-type ForwardRewrites n f 
-  = forall e x. n e x -> InFact e f -> Maybe (AGraph n e x)
-
-type family   InFact e f :: *
-type instance InFact C f = InFactC f
-type instance InFact O f = f
-
-type family   OutFact x f :: *
-type instance OutFact C f = OutFactC f
-type instance OutFact O f = f
-
-type InFactC  fact = BlockId -> fact
-type OutFactC fact = [(BlockId, fact)] 
-
-data AGraph n e x = AGraph     -- Stub for now
-
-
------------------------------------------------------------------------------
---      TxFactBase: a FactBase with ChangeFlag information
------------------------------------------------------------------------------
-
--- The TxFactBase is an accumulating parameter, threaded through all
--- the analysis/transformation of each block in the g_blocks of a grpah.
--- It carries a ChangeFlag with it, and a set of BlockIds
--- to monitor. Updates to other BlockIds don't affect the ChangeFlag
-data TxFactBase n f
-  = TxFB { tfb_fbase :: FactBase f
-
-         , tfb_cha   :: ChangeFlag
-         , tfb_bids  :: BlockSet   -- Update change flag iff these blocks change
-                                   -- These are BlockIds of the *original* 
-                                   -- (not transformed) blocks
-
-         , tfb_blks  :: BlocksWithFacts n f  -- Transformed blocks
-    }
-
-factBaseInFacts :: DataflowLattice f -> TxFactBase n f -> InFactC f
-factBaseInFacts lattice (TxFB { tfb_fbase = fbase }) 
-  = lookupFact lattice fbase
-
-factBaseOutFacts :: TxFactBase n f -> OutFactC f
-factBaseOutFacts (TxFB { tfb_fbase = fbase, tfb_bids = bids }) 
-  = [ (bid, f) | (bid, f) <- factBaseList fbase
-               , not (bid `elemBlockSet` bids) ]
-  -- The successors of the Graph are the the BlockIds for which
-  -- we hvae facts, that are *not* in the blocks of the graph
-
-updateFact :: DataflowLattice f -> (BlockId, f)
-           -> TxFactBase n f -> TxFactBase n f
--- Update a TxFactBase, setting the change flag iff
---   a) the new fact adds information...
---   b) for a block in the BlockSet in the TxFactBase
-updateFact lat (bid, new_fact) tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids})
-  | NoChange <- cha2        = tx_fb
-  | bid `elemBlockSet` bids = tx_fb { tfb_fbase = new_fbase, tfb_cha = SomeChange }
-  | otherwise               = tx_fb { tfb_fbase = new_fbase }
-  where
-    old_fact = lookupFact lat fbase bid
-    TxRes cha2 res_fact = fact_add_to lat old_fact new_fact
-    new_fbase = extendFactBase fbase bid res_fact
-
-updateFacts :: Edges n
-            => DataflowLattice f 
-            -> GFT_Block n f
-            -> Block n C C
-            -> Trans (TxFactBase n f) (TxFactBase n f)
-updateFacts lat (GFT block_trans) blk
-    tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids, tfb_blks = blks })
-  = do { (graph, out_facts) <- block_trans blk (lookupFact lat fbase)
-       ; let tx_fb' = tx_fb { tfb_bids = extendBlockSet bids (blockId blk)
-                            , tfb_blks = flattenG graph ++ blks }
-       ; return (foldr (updateFact lat) tx_fb' out_facts) }
-
------------------------------------------------------------------------------
---             The Trans arrow
------------------------------------------------------------------------------
-
-type Trans a b = a -> FuelMonad b 
- -- Transform a into b, with facts of type f
- -- Deals with optimsation fuel and unique supply too
-  
-(>>>) :: Trans a b -> Trans b c -> Trans a c
--- Compose two dataflow transfers in sequence
-(dft1 >>> dft2) f = do { f1 <- dft1 f; f2 <- dft2 f1; return f2 }
-
-liftTrans :: (a->b) -> Trans a b
-liftTrans f x = return (f x)
-
-idTrans :: Trans a a
-idTrans x = return x
-
-fixpointTrans :: forall n f. 
-                 Trans (TxFactBase n f) (TxFactBase n f) 
-              -> Trans (OutFactC f)     (TxFactBase n f)
-fixpointTrans tx_fb_trans out_facts
-  = do { fuel <- getFuel  
-       ; loop fuel (mkFactBase out_facts) }
-  where
-    loop :: Fuel -> Trans (FactBase f) (TxFactBase n f)
-    loop fuel fbase 
-      = do { tx_fb <- tx_fb_trans (TxFB { tfb_fbase = fbase
-                                        , tfb_cha = NoChange
-                                        , tfb_blks = []
-                                        , tfb_bids = emptyBlockSet })
-           ; case tfb_cha tx_fb of
-               NoChange   -> return tx_fb
-               SomeChange -> do { setFuel fuel; loop fuel (tfb_fbase tx_fb) } }
-
------------------------------------------------------------------------------
---             Transfer functions
------------------------------------------------------------------------------
-
--- Keys to the castle: a generic transfer function for each shape
--- Here's the idea: we start with single-n transfer functions,
--- move to basic-block transfer functions (we have exactly four shapes),
--- then finally to graph transfer functions (which requires iteration).
-
-newtype GFT thing n f = GFT (GFTR thing n f)
-type GFTR thing n f = forall e x. thing e x 
-                               -> InFact e f
-                               -> FuelMonad (GraphWithFacts n e x f, OutFact x f)
-
-type GFT_Node  n f = GFT n         n f
-type GFT_Block n f = GFT (Block n) n f
-type GFT_Graph n f = GFT (Graph n) n f
------------------------------------------------------------------------------
-
-gftNodeTransfer :: forall n f . ForwardTransfers n f -> GFT_Node n f
--- Lifts ForwardTransfers to GFT_Node; simple transfer only
-gftNodeTransfer base_trans = GFT node_trans
-    where 
-      node_trans :: GFTR n n f
-      node_trans node f = return (GUnit (BUnit node), base_trans node f)
-
-gftNodeRewrite :: forall n f.
-                  ForwardTransfers n f
-               -> ForwardRewrites n f
-               -> GFT_Graph n f
-               -> GFT_Node n f
--- Lifts (ForwardTransfers,ForwardRewrites) to GFT_Node; 
--- this time we do rewriting as well. 
--- The GFT_Graph parameters specifies what to do with the rewritten graph
-gftNodeRewrite transfers rewrites (GFT graph_trans) 
-  = GFT node_rewrite
-  where
-    node_trans :: GFTR n n f
-    node_trans node f = return (GUnit (BUnit node), transfers node f)
-
-    node_rewrite :: GFTR n n f
-    node_rewrite node f  
-       = case rewrites node f of
-          Nothing -> node_trans node f
-          Just g  -> do { out <- fuelExhausted
-                           ; if out then 
-                              node_trans node f
-                             else do { decrementFuel
-                                     ; g' <- graphOfAGraph g
-                                     ; graph_trans g' f } }
-
-gftBlock :: forall n f. GFT_Node n f -> GFT_Block n f
--- Lift from nodes to blocks
-gftBlock (GFT node_trans) = GFT block_trans
-  where 
-    block_trans :: GFTR (Block n) n f
-    block_trans (BUnit node)   f = node_trans node f
-    block_trans (BCat hd mids) f = do { (g1,f1) <- block_trans hd f
-                                      ; (g2,f2) <- block_trans mids f1
-                                     ; return (g1 `gwfCat` g2, f2) }
-
-
-gftGraph :: forall n f. Edges n => DataflowLattice f -> GFT_Block n f -> GFT_Graph n f
--- Lift from blocks to graphs
-gftGraph lattice gft_block@(GFT block_trans) = GFT graph_trans
-  where
-    graph_trans :: GFTR (Graph n) n f
-    graph_trans GNil        f = return (GNil, f)
-    graph_trans (GUnit blk) f = block_trans blk f
-    graph_trans (GMany entry blocks exit) f
-      = do { (entry', f1)  <- block_trans entry f
-           ; tx_fb         <- ft_blocks blocks f1
-           ; (exit', f3)   <- ft_exit exit tx_fb 
-           ; return (mkGMany entry' (tfb_blks tx_fb) exit', f3) }
-
-       -- It's a bit disgusting that the TxFactBase has to be
-        -- preserved as far as the Exit block, becaues the TxFactBase
-        -- is really concerned with the fixpoint calculation
-        -- But I can't see any other tidy way to compute the 
-        -- LastOutFacts in the NoTail case
-    ft_exit :: Exit (Block n C x) x  
-            -> Trans (TxFactBase n f) (Exit (Graph n C x) x, OutFact x f)
-    ft_exit (Tail blk) f = do { (blk', f1) <- block_trans blk (factBaseInFacts lattice f)
-                              ; return (Tail blk', f1) }
-    ft_exit NoTail     f = return (NoTail, factBaseOutFacts f)
-
-    ft_block_once :: Block n C C -> Trans (TxFactBase n f) (TxFactBase n f)
-    ft_block_once blk = updateFacts lattice gft_block blk
-
-    ft_blocks_once :: Blocks n -> Trans (TxFactBase n f) (TxFactBase n f)
-    ft_blocks_once blks = foldr ((>>>) . ft_block_once) idTrans blks
-
-    ft_blocks :: [Block n C C] -> Trans (OutFactC f) (TxFactBase n f)
-    ft_blocks blocks = fixpointTrans (ft_blocks_once (forwardBlockList blocks))
-
-----------------------------------------------------------------
---       The pièce de resistance: cunning transfer functions
-----------------------------------------------------------------
-
-pureAnalysis :: Edges n => DataflowLattice f -> ForwardTransfers n f -> GFT_Graph n f
-pureAnalysis lattice = gftGraph lattice . gftBlock . gftNodeTransfer
-
-analyseAndRewrite
-   :: forall n f. Edges n
-   => RewritingDepth
-   -> DataflowLattice f
-   -> ForwardTransfers n f
-   -> ForwardRewrites n f
-   -> GFT_Graph n f
-
-data RewritingDepth = RewriteShallow | RewriteDeep
--- When a transformation proposes to rewrite a node, 
--- you can either ask the system to
---  * "shallow": accept the new graph, analyse it without further rewriting
---  * "deep": recursively analyse-and-rewrite the new graph
-
-analyseAndRewrite depth lattice transfers rewrites
-  = gft_graph_cunning
-  where 
-    gft_graph_base, gft_graph_cunning, gft_graph_recurse :: GFT_Graph n f
-
-    gft_graph_base    = gftGraph lattice (gftBlock gft_node_base)
-    gft_graph_cunning = gftGraph lattice (gftBlock gft_node_cunning)
-    gft_graph_recurse = case depth of
-                          RewriteShallow -> gft_graph_base
-                          RewriteDeep    -> gft_graph_cunning
-
-    gft_node_base, gft_node_cunning :: GFT_Node n f
-    gft_node_base    = gftNodeTransfer transfers
-    gft_node_cunning = gftNodeRewrite  transfers rewrites gft_graph_recurse
-
------------------------------------------------------------------------------
---             The fuel monad
------------------------------------------------------------------------------
-
-type Uniques = Int
-type Fuel    = Int
-
-newtype FuelMonad a = FM { unFM :: Fuel -> Uniques -> (a, Fuel, Uniques) }
-
-instance Monad FuelMonad where
-  return x = FM (\f u -> (x,f,u))
-  m >>= k  = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u')
-
-fuelExhausted :: FuelMonad Bool
-fuelExhausted = FM (\f u -> (f <= 0, f, u))
-
-decrementFuel :: FuelMonad ()
-decrementFuel = FM (\f u -> ((), f-1, u))
-
-getFuel :: FuelMonad Fuel
-getFuel = FM (\f u -> (f,f,u))
-
-setFuel :: Fuel -> FuelMonad ()
-setFuel f = FM (\_ u -> ((), f, u))
-
-graphOfAGraph :: AGraph node e x -> FuelMonad (Graph node e x)
-graphOfAGraph = error "urk"    -- Stub
-
------------------------------------------------------------------------------
---             BlockId, BlockEnv, BlockSet
------------------------------------------------------------------------------
-
-type BlockId = Int
-
-mkBlockId :: Int -> BlockId
-mkBlockId uniq = uniq
-
-type FactBase a = M.IntMap a
-
-mkFactBase :: [(BlockId, f)] -> FactBase f
-mkFactBase prs = M.fromList prs
-
-lookupFact :: DataflowLattice f -> FactBase f -> BlockId -> f
-lookupFact lattice env blk_id 
-  = case M.lookup blk_id env of
-      Just f  -> f
-      Nothing -> fact_bot lattice
-
-extendFactBase :: FactBase f -> BlockId -> f -> FactBase f
-extendFactBase env blk_id f = M.insert blk_id f env
-
-unionFactBase :: FactBase f -> FactBase f -> FactBase f
-unionFactBase = M.union
-
-factBaseList :: FactBase f -> [(BlockId, f)]
-factBaseList env = M.toList env
-
-type BlockSet = S.IntSet
-
-emptyBlockSet :: BlockSet
-emptyBlockSet = S.empty
-
-extendBlockSet :: BlockSet -> BlockId -> BlockSet
-extendBlockSet bids bid = S.insert bid bids
-
-elemBlockSet :: BlockId -> BlockSet -> Bool
-elemBlockSet bid bids = S.member bid bids
-
-blockSetElems :: BlockSet -> [BlockId]
-blockSetElems = S.toList
-
-minusBlockSet :: BlockSet -> BlockSet -> BlockSet
-minusBlockSet = S.difference
-
-mkBlockSet :: [BlockId] -> BlockSet
-mkBlockSet = S.fromList
diff --git a/prototypes/Hoopl4.hs b/prototypes/Hoopl4.hs
deleted file mode 100644 (file)
index e7e059d..0000000
+++ /dev/null
@@ -1,528 +0,0 @@
-{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies #-}
-
-module Hoopl4 where
-
-import qualified Data.IntMap as M
-import qualified Data.IntSet as S
-
------------------------------------------------------------------------------
---             Graphs
------------------------------------------------------------------------------
-
-data ZOpen
-data ZClosed
-
-type O = ZOpen
-type C = ZClosed
-
--- Blocks are always non-empty
-data Block n e x where
-  BUnit :: n e x -> Block n e x
-  BCat  :: Block n e O -> Block n O x -> Block n e x
-
-type BlockGraph n = BlockMap (Block n C C)
-
-data Graph n e x where
-  GNil  :: Graph n O O
-  GUnit :: Block n e O -> Graph n e O
-  GMany :: Block n e C -> BlockGraph n
-       -> Tail n x -> Graph n e x
-
-   -- If a graph has a Tail, then that tail is the only  
-   -- exit from the graph, even if the Tail is closed
-   -- See the definition of successors!
-
-data Tail n x where
-  NoTail :: Tail n C
-  Tail   :: BlockId -> Block n C O -> Tail n O
-
-class LiftNode x where
-   liftNode :: n e x -> Graph n e x
-instance LiftNode ZClosed where
-   liftNode n = GMany (BUnit n) noBlocks NoTail
-instance LiftNode ZOpen where
-   liftNode n = GUnit (BUnit n)
-
-{-     Edges is not currently used
-class Edges thing where
-  successors :: thing e C -> [BlockId]
-
-instance Edges n => Edges (Block n) where
-  successors (BUnit n)  = successors n
-  successors (BCat _ b) = successors b
-
-instance Edges n => Edges (Graph n) where
-  successors (GMany b bs NoTail) 
-     = blockSetElems (all_succs `minusBlockSet` all_blk_ids)
-     where 
-       (bids, blks) = unzip (blocksToList bs)      
-       all_succs   = mkBlockSet (successors b ++ [bid | b <- blks, bid <- successors b])
-       all_blk_ids = mkBlockSet bids
--}
-
-ecGraph :: Graph n e C -> (Block n e C, BlockGraph n)
-ecGraph (GMany b bs NoTail) = (b, bs)
-
-cxGraph :: BlockId -> Graph n C O -> (BlockGraph n, Tail n O)
-cxGraph bid (GUnit b)          = (noBlocks, Tail bid b)
-cxGraph bid (GMany be bs tail) = (addBlock bid be bs, tail)
-
-flattenG :: BlockId -> Graph n C C -> BlockGraph n
-flattenG bid (GMany e bs NoTail) = addBlock bid e bs
-
-gCat :: Graph n e O -> Graph n O x -> Graph n e x
-gCat GNil g2 = g2
-gCat g1 GNil = g1
-
-gCat (GUnit b1) (GUnit b2)             
-  = GUnit (b1 `BCat` b2)
-
-gCat (GUnit b) (GMany e bs x) 
-  = GMany (b `BCat` e) bs x
-
-gCat (GMany e bs (Tail bid x)) (GUnit b2) 
-   = GMany e bs (Tail bid (x `BCat` b2))
-
-gCat (GMany e1 bs1 (Tail bid x1)) (GMany e2 bs2 x2)
-   = GMany e1 (addBlock bid (x1 `BCat` e2) bs1 `unionBlocks` bs2) x2
-
-forwardBlockList, backwardBlockList :: BlockGraph n -> [(BlockId,Block n C C)]
--- This produces a list of blocks in order suitable for forward analysis.
--- ToDo: Do a topological sort to improve convergence rate of fixpoint
---       This will require a (HavingSuccessors l) class constraint
-forwardBlockList blks = blocksToList blks
-backwardBlockList blks = blocksToList blks
-
------------------------------------------------------------------------------
---             DataflowLattice
------------------------------------------------------------------------------
-
-data DataflowLattice a = DataflowLattice  { 
-  fact_name       :: String,                   -- Documentation
-  fact_bot        :: a,                        -- Lattice bottom element
-  fact_extend     :: a -> a -> (ChangeFlag,a), -- Lattice join plus change flag
-  fact_do_logging :: Bool                      -- log changes
-}
-
-data ChangeFlag = NoChange | SomeChange
-
------------------------------------------------------------------------------
---             The main Hoopl API
------------------------------------------------------------------------------
-
-type ForwardTransfers n f 
-  = forall e x. f -> n e x -> TailFactF x f 
-
-type ForwardRewrites n f 
-  = forall e x. f -> n e x -> Maybe (AGraph n e x)
-
-type family   TailFactF x f :: *
-type instance TailFactF C f = [(BlockId, f)] 
-type instance TailFactF O f = f
-
-data AGraph n e x = AGraph     -- Stub for now
-
-
------------------------------------------------------------------------------
---      TxFactBase: a FactBase with ChangeFlag information
------------------------------------------------------------------------------
-
--- The TxFactBase is an accumulating parameter, threaded through all
--- the analysis/transformation of each block in the g_blocks of a grpah.
--- It carries a ChangeFlag with it, and a set of BlockIds
--- to monitor. Updates to other BlockIds don't affect the ChangeFlag
-data TxFactBase n fact 
-  = TxFB { tfb_fbase :: FactBase fact
-
-         , tfb_cha   :: ChangeFlag
-         , tfb_bids  :: BlockSet   -- Update change flag iff these blocks change
-                                   -- These are BlockIds of the *original* 
-                                   -- (not transformed) blocks
-
-         , tfb_blks  :: BlockGraph n   -- Transformed blocks
-    }
-
-factBaseInFacts :: DataflowLattice f -> TxFactBase n f -> BlockId -> f
-factBaseInFacts lattice (TxFB { tfb_fbase = fbase }) bid
-  = lookupFact lattice fbase bid
-
-factBaseOutFacts :: TxFactBase n f -> [(BlockId,f)]
-factBaseOutFacts (TxFB { tfb_fbase = fbase, tfb_bids = bids }) 
-  = [ (bid, f) | (bid, f) <- factBaseList fbase
-               , not (bid `elemBlockSet` bids) ]
-  -- The successors of the Graph are the the BlockIds for which
-  -- we hvae facts, that are *not* in the blocks of the graph
-
-updateFact :: DataflowLattice f -> (BlockId, f)
-           -> TxFactBase n f -> TxFactBase n f
--- Update a TxFactBase, setting the change flag iff
---   a) the new fact adds information...
---   b) for a block in the BlockSet in the TxFactBase
-updateFact lat (bid, new_fact) tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids})
-  | NoChange <- cha2        = tx_fb
-  | bid `elemBlockSet` bids = tx_fb { tfb_fbase = new_fbase, tfb_cha = SomeChange }
-  | otherwise               = tx_fb { tfb_fbase = new_fbase }
-  where
-    old_fact = lookupFact lat fbase bid
-    (cha2, res_fact) = fact_extend lat old_fact new_fact
-    new_fbase = extendFactBase fbase bid res_fact
-
-updateFacts :: DataflowLattice f 
-           -> BlockId
-            -> (FactBase f -> FuelMonad ([(BlockId,f)], Graph n C C))
-            -> TxFactBase n f -> FuelMonad (TxFactBase n f)
--- Works regardless of direction
-updateFacts lat bid fb_trans
-    tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids, tfb_blks = blks })
-  = do { (out_facts, graph) <- fb_trans fbase
-       ; let tx_fb' = tx_fb { tfb_bids = extendBlockSet bids bid
-                            , tfb_blks = flattenG bid graph `unionBlocks` blks }
-       ; return (foldr (updateFact lat) tx_fb' out_facts) }
-
------------------------------------------------------------------------------
---             The Trans arrow
------------------------------------------------------------------------------
-
-fixpoint :: forall n f. 
-                 (TxFactBase n f -> FuelMonad (TxFactBase n f))
-              -> (FactBase f     -> FuelMonad (TxFactBase n f))
-fixpoint tx_fb_trans init_fbase
-  = do { fuel <- getFuel  
-       ; loop fuel init_fbase }
-  where
-    loop :: Fuel -> FactBase f -> FuelMonad (TxFactBase n f)
-    loop fuel fbase 
-      = do { tx_fb <- tx_fb_trans (TxFB { tfb_fbase = fbase
-                                        , tfb_cha = NoChange
-                                        , tfb_blks = noBlocks
-                                        , tfb_bids = emptyBlockSet })
-           ; case tfb_cha tx_fb of
-               NoChange   -> return tx_fb
-               SomeChange -> do { setFuel fuel; loop fuel (tfb_fbase tx_fb) } }
-
------------------------------------------------------------------------------
---             Transfer functions
------------------------------------------------------------------------------
-
--- Keys to the castle: a generic transfer function for each shape
--- Here's the idea: we start with single-n transfer functions,
--- move to basic-block transfer functions (we have exactly four shapes),
--- then finally to graph transfer functions (which requires iteration).
-
-type ARF thing n f = forall e x. LiftNode x 
-                              => f -> thing e x
-                              -> FuelMonad (TailFactF x f, Graph n e x)
-
-type ARF_Node  n f = ARF n         n f
-type ARF_Block n f = ARF (Block n) n f
-type ARF_Graph n f = ARF (Graph n) n f
------------------------------------------------------------------------------
-
-arfNodeTransfer :: forall n f. ForwardTransfers n f -> ARF_Node n f
--- Lifts ForwardTransfers to ARF_Node; simple transfer only
-arfNodeTransfer transfer_fn f node
-  = return (transfer_fn f node, liftNode node)
-
-arfNodeRewrite :: forall n f.
-                  ForwardTransfers n f
-               -> ForwardRewrites n f
-               -> ARF_Graph n f
-               -> ARF_Node n f
--- Lifts (ForwardTransfers,ForwardRewrites) to ARF_Node; 
--- this time we do rewriting as well. 
--- The ARF_Graph parameters specifies what to do with the rewritten graph
-arfNodeRewrite transfer_fn rewrite_fn graph_trans f node
-  = do { mb_g <- withFuel (rewrite_fn f node)
-       ; case mb_g of
-           Nothing -> arfNodeTransfer transfer_fn f node
-          Just ag -> do { g <- graphOfAGraph ag
-                        ; graph_trans f g } }
-
-arfBlock :: forall n f. ARF_Node n f -> ARF_Block n f
--- Lift from nodes to blocks
-arfBlock arf_node f (BUnit node)   = arf_node f node
-arfBlock arf_node f (BCat hd mids) = do { (f1,g1) <- arfBlock arf_node f  hd
-                                        ; (f2,g2) <- arfBlock arf_node f1 mids
-                                       ; return (f2, g1 `gCat` g2) }
-
-arfGraph :: forall n f. DataflowLattice f -> ARF_Block n f -> ARF_Graph n f
--- Lift from blocks to graphs
-arfGraph lattice arf_block f GNil        = return (f, GNil)
-arfGraph lattice arf_block f (GUnit blk) = arf_block f blk
-arfGraph lattice arf_block f (GMany entry blocks exit)
-  = do { (f1, entry_g)     <- arf_block f entry
-       ; tx_fb             <- ft_blocks blocks (mkFactBase f1)
-       ; (f3, bs2, exit')  <- ft_exit tx_fb exit 
-       ; let (entry', bs1) = ecGraph entry_g
-             final_bs = bs1 `unionBlocks` tfb_blks tx_fb `unionBlocks` bs2
-       ; return (f3, GMany entry' final_bs exit') }
-  where
-       -- It's a bit disgusting that the TxFactBase has to be
-        -- preserved as far as the Tail block, becaues the TxFactBase
-        -- is really concerned with the fixpoint calculation
-        -- But I can't see any other tidy way to compute the 
-        -- LastOutFacts in the NoTail case
-    ft_exit :: TxFactBase n f -> Tail n x
-            -> FuelMonad (TailFactF x f, BlockGraph n, Tail n x)
-    ft_exit f (Tail bid blk)
-      = do { (f1, g) <- arf_block (factBaseInFacts lattice f bid) blk
-          ; let (bs, exit) = cxGraph bid g
-           ; return (f1, bs, exit) }
-    ft_exit f NoTail
-      = return (factBaseOutFacts f, noBlocks, NoTail)
-
-    ft_block_once :: (BlockId, Block n C C) -> TxFactBase n f
-                  -> FuelMonad (TxFactBase n f)
-    ft_block_once (bid, b) = updateFacts lattice bid $ \fbase ->
-                             arf_block (lookupFact lattice fbase bid) b
-
-    ft_blocks_once :: [(BlockId, Block n C C)] 
-                   -> TxFactBase n f -> FuelMonad (TxFactBase n f)
-    ft_blocks_once []     tx_fb = return tx_fb
-    ft_blocks_once (b:bs) tx_fb = do { tx_fb1 <- ft_block_once b tx_fb
-                                     ; ft_blocks_once bs tx_fb1 }
-
-    ft_blocks :: BlockGraph n -> FactBase f -> FuelMonad (TxFactBase n f)
-    ft_blocks blocks = fixpoint (ft_blocks_once (forwardBlockList blocks))
-
-----------------------------------------------------------------
---       The pièce de resistance: cunning transfer functions
-----------------------------------------------------------------
-
-pureAnalysis :: DataflowLattice f -> ForwardTransfers n f -> ARF_Graph n f
-pureAnalysis lattice f = arfGraph lattice (arfBlock (arfNodeTransfer f))
-
-analyseAndRewriteFwd
-   :: forall n f. 
-      DataflowLattice f
-   -> ForwardTransfers n f
-   -> ForwardRewrites n f
-   -> RewritingDepth
-   -> ARF_Graph n f
-
-data RewritingDepth = RewriteShallow | RewriteDeep
--- When a transformation proposes to rewrite a node, 
--- you can either ask the system to
---  * "shallow": accept the new graph, analyse it without further rewriting
---  * "deep": recursively analyse-and-rewrite the new graph
-
-analyseAndRewriteFwd lattice transfers rewrites depth
-  = anal_rewrite
-  where 
-    anal_rewrite, anal_only, arf_rec :: ARF_Graph n f
-
-    anal_rewrite = arfGraph lattice $ arfBlock $ 
-                   arfNodeRewrite transfers rewrites arf_rec
-
-    anal_only    = arfGraph lattice $ arfBlock $ 
-                   arfNodeTransfer transfers
-
-    arf_rec = case depth of
-                RewriteShallow -> anal_only
-                RewriteDeep    -> anal_rewrite
-
------------------------------------------------------------------------------
---             Backward rewriting
------------------------------------------------------------------------------
-
-type BackwardTransfers n f 
-  = forall e x. TailFactB x f -> n e x -> f 
-type BackwardRewrites n f 
-  = forall e x. TailFactB x f -> n e x -> Maybe (AGraph n e x)
-
-type ARB thing n f = forall e x. LiftNode x 
-                              => TailFactB x f -> thing e x
-                              -> FuelMonad (f, Graph n e x)
-
-type family   TailFactB x f :: *
-type instance TailFactB C f = FactBase f
-type instance TailFactB O f = f
-
-type ARB_Node  n f = ARB n         n f
-type ARB_Block n f = ARB (Block n) n f
-type ARB_Graph n f = ARB (Graph n) n f
-
-arbNodeTransfer :: forall n f . BackwardTransfers n f -> ARB_Node n f
--- Lifts BackwardTransfers to ARB_Node; simple transfer only
-arbNodeTransfer transfer_fn f node
-  = return (transfer_fn f node, liftNode node)
-
-arbNodeRewrite :: forall n f.
-                  BackwardTransfers n f
-               -> BackwardRewrites n f
-               -> ARB_Graph n f
-               -> ARB_Node n f
--- Lifts (BackwardTransfers,BackwardRewrites) to ARB_Node; 
--- this time we do rewriting as well. 
--- The ARB_Graph parameters specifies what to do with the rewritten graph
-arbNodeRewrite transfer_fn rewrite_fn graph_trans f node
-  = do { mb_g <- withFuel (rewrite_fn f node)
-       ; case mb_g of
-           Nothing -> arbNodeTransfer transfer_fn f node
-          Just ag -> do { g <- graphOfAGraph ag
-                        ; graph_trans f g } }
-
-arbBlock :: forall n f. ARB_Node n f -> ARB_Block n f
--- Lift from nodes to blocks
-arbBlock arb_node f (BUnit node) = arb_node f node
-arbBlock arb_node f (BCat b1 b2) = do { (f2,g2) <- arbBlock arb_node f  b2
-                                      ; (f1,g1) <- arbBlock arb_node f2 b1
-                                     ; return (f1, g1 `gCat` g2) }
-
-arbGraph :: forall n f. DataflowLattice f -> ARB_Block n f -> ARB_Graph n f
-arbGraph lattice arb_block f GNil        = return (f, GNil)
-arbGraph lattice arb_block f (GUnit blk) = arb_block f blk
-arbGraph lattice arb_block f (GMany entry blocks exit)
-  = do { (f1, bs2, exit')  <- bt_exit f exit
-       ; tx_fb             <- bt_blocks blocks f1
-       ; (f3, entry_g)     <- arb_block (tfb_fbase tx_fb) entry 
-       ; let (entry', bs1) = ecGraph entry_g
-             final_bs = bs1 `unionBlocks` tfb_blks tx_fb `unionBlocks` bs2
-       ; return (f3, GMany entry' final_bs exit') }
-  where
-       -- It's a bit disgusting that the TxFactBase has to be
-        -- preserved as far as the Tail block, becaues the TxFactBase
-        -- is really concerned with the fixpoint calculation
-        -- But I can't see any other tidy way to compute the 
-        -- LastOutFacts in the NoTail case
-    bt_exit :: TailFactB x f -> Tail n x
-            -> FuelMonad (FactBase f, BlockGraph n, Tail n x)
-    bt_exit f (Tail bid blk)
-      = do { (f1, g) <- arb_block f blk
-          ; let (bs, exit) = cxGraph bid g
-           ; return (mkFactBase [(bid,f1)], bs, exit) }
-    bt_exit f NoTail
-      = return (f, noBlocks, NoTail)
-
-    bt_block_once :: (BlockId, Block n C C) -> TxFactBase n f
-                  -> FuelMonad (TxFactBase n f)
-    bt_block_once (bid, b) = updateFacts lattice bid $ \fbase ->
-                             do { (f, g) <- arb_block fbase b
-                                ; return ([(bid,f)], g) }
-
-    bt_blocks_once :: [(BlockId,Block n C C)] 
-                   -> TxFactBase n f -> FuelMonad (TxFactBase n f)
-    bt_blocks_once []     tx_fb = return tx_fb
-    bt_blocks_once (b:bs) tx_fb = do { tx_fb' <- bt_block_once b tx_fb
-                                     ; bt_blocks_once bs tx_fb' }
-
-    bt_blocks :: BlockGraph n -> FactBase f -> FuelMonad (TxFactBase n f)
-    bt_blocks blocks = fixpoint (bt_blocks_once (backwardBlockList blocks))
-
-analyseAndRewriteBwd
-   :: forall n f. 
-      DataflowLattice f
-   -> BackwardTransfers n f
-   -> BackwardRewrites n f
-   -> RewritingDepth
-   -> ARB_Graph n f
-
-analyseAndRewriteBwd lattice transfers rewrites depth
-  = anal_rewrite
-  where 
-    anal_rewrite, anal_only, arb_rec :: ARB_Graph n f
-
-    anal_rewrite = arbGraph lattice $ arbBlock $ 
-                   arbNodeRewrite transfers rewrites arb_rec
-
-    anal_only    = arbGraph lattice $ arbBlock $ 
-                   arbNodeTransfer transfers
-
-    arb_rec = case depth of
-                RewriteShallow -> anal_only
-                RewriteDeep    -> anal_rewrite
-
-
------------------------------------------------------------------------------
---             The fuel monad
------------------------------------------------------------------------------
-
-type Uniques = Int
-type Fuel    = Int
-
-newtype FuelMonad a = FM { unFM :: Fuel -> Uniques -> (a, Fuel, Uniques) }
-
-instance Monad FuelMonad where
-  return x = FM (\f u -> (x,f,u))
-  m >>= k  = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u')
-
-withFuel :: Maybe a -> FuelMonad (Maybe a)
-withFuel Nothing  = return Nothing
-withFuel (Just r) = FM (\f u -> if f==0 then (Nothing, f, u)
-                                else (Just r, f-1, u))
-
-getFuel :: FuelMonad Fuel
-getFuel = FM (\f u -> (f,f,u))
-
-setFuel :: Fuel -> FuelMonad ()
-setFuel f = FM (\_ u -> ((), f, u))
-
-graphOfAGraph :: AGraph node e x -> FuelMonad (Graph node e x)
-graphOfAGraph = error "urk"    -- Stub
-
------------------------------------------------------------------------------
---             BlockId, FactBase, BlockSet
------------------------------------------------------------------------------
-
-type BlockId = Int
-
-mkBlockId :: Int -> BlockId
-mkBlockId uniq = uniq
-
-----------------------
-type BlockMap a = M.IntMap a
-
-noBlocks :: BlockGraph n
-noBlocks = M.empty
-
-addBlock :: BlockId -> Block n C C -> BlockGraph n -> BlockGraph n
-addBlock = M.insert
-
-unionBlocks :: BlockGraph n -> BlockGraph n -> BlockGraph n
-unionBlocks = M.union
-
-blocksToList :: BlockGraph n -> [(BlockId,Block n C C)]
-blocksToList = M.toList
-
-----------------------
-type FactBase a = M.IntMap a
-
-mkFactBase :: [(BlockId, f)] -> FactBase f
-mkFactBase prs = M.fromList prs
-
-lookupFact :: DataflowLattice f -> FactBase f -> BlockId -> f
-lookupFact lattice env blk_id 
-  = case M.lookup blk_id env of
-      Just f  -> f
-      Nothing -> fact_bot lattice
-
-extendFactBase :: FactBase f -> BlockId -> f -> FactBase f
-extendFactBase env blk_id f = M.insert blk_id f env
-
-unionFactBase :: FactBase f -> FactBase f -> FactBase f
-unionFactBase = M.union
-
-factBaseList :: FactBase f -> [(BlockId, f)]
-factBaseList env = M.toList env
-
-
-----------------------
-type BlockSet = S.IntSet
-
-emptyBlockSet :: BlockSet
-emptyBlockSet = S.empty
-
-extendBlockSet :: BlockSet -> BlockId -> BlockSet
-extendBlockSet bids bid = S.insert bid bids
-
-elemBlockSet :: BlockId -> BlockSet -> Bool
-elemBlockSet bid bids = S.member bid bids
-
-blockSetElems :: BlockSet -> [BlockId]
-blockSetElems = S.toList
-
-minusBlockSet :: BlockSet -> BlockSet -> BlockSet
-minusBlockSet = S.difference
-
-mkBlockSet :: [BlockId] -> BlockSet
-mkBlockSet = S.fromList
diff --git a/prototypes/Hoopl5.hs b/prototypes/Hoopl5.hs
deleted file mode 100644 (file)
index 7b67a7f..0000000
+++ /dev/null
@@ -1,739 +0,0 @@
-{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies #-}
-
-{- Notes about the genesis of Hoopl5
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-As well as addressing your concerns I had some of my own:
-
-* In Hoopl4, a closed/closed graph starts with a distinguished
-  closed/closed block (the entry block).  But this block is
-  *un-labelled*.  That means that there is no way to branch back to
-  the entry point of a procedure, which seems a bit unclean.
-
-* In general I have to admit that it does seem a bit unintuitive to
-  have block that is
-       a) closed on entry, but
-       b) does not have a label
-
-* If you look at MkZipCfgCmm you'll see stuff like this:
-     mkCmmIfThen e tbranch
-       = withFreshLabel "end of if"     $ \endif ->
-         withFreshLabel "start of then" $ \tid ->
-         mkCbranch e tid endif <*>
-         mkLabel tid   <*> tbranch <*> mkBranch endif <*>
-         mkLabel endif
-
-   We are trying to present a user model *graphs* as
-       a sequence, connected by <*>,
-       of little graphs
-   Moreover, one of the little graphs is (mkLabel BlockId), and I
-   don't see how to make a graph for that in Hoopl4.
-
-   (Norman I know that this may be what you have been trying to say
-   about "graphs under construction" for some time, but looking at
-   MkZipCfgCmm made it far more concrete for me.)
-
-
-Specifically, in Hoopl5:
-
-* The ARF type is no longer overloaded over the LiftNode class.  
-  It has a simple and beautiful type.
-
-* I put the BlockId back in a first node, as John wanted.
-
-* To make it possible to branch to the label of the entry block of a
-  Body it does make sense to put that block in the Body that is
-  the main payload of the graph
-
-* That militates in favour of a Maybe-kind-of-thing on entry to a
-  Body, just as Norman wanted.  It's called Entry, dual to Exit.
-
-* However I am Very Very Keen to maintain the similar properties of
-  nodes, blocks, graphs; and in particular the single point of entry.
-  (For a multi-entry procedure, the procedure can be represented by a
-  Body plus a bunch of BlockIds, rather than a Body.)  So I
-  made the Entry contain the BlockId of the entry point.
-
-* The Body in a Body is a finite map, as you wanted.  Notice
-  that this embodies an invariant: a BlockId must map to a block whose
-  entry point is that BlockId.
-
-* I've added a layer, using arfBody/arbBlocks.  Admittedly the
-  type doesn't fit the same pattern, but it's useful structuring
-
-* You should think of a Body as a user-visible type; perhaps
-  this is the kind of graph that might form the body of a procedure.
-  Moreover, perhaps rewriteAndAnlyseForward should take a Body
-  rather than a Body, and call arbBlocks.
-
-* With that in mind I was happy to introduce the analogous invariant
-  for the exit block in Exit; it is very very convenient to have that
-  BlockId (cached though it may be) to hand.
-
-* Because graphs are made out of blocks, it's easy to have a
-  constructor for the empty ggraph, and we don't need any stinkikng
-  smart constructor to keep nil in its place.  But if we moved nil to
-  blocks, we'd need a smart constructor for graphs *and* one for
-  blocks.  (Because unlike graphs, blocks *are* made from other
-  blocks.
-
--}
-
-module Hoopl5 where
-
-import qualified Data.IntMap as M
-import qualified Data.IntSet as S
-
------------------------------------------------------------------------------
---             Graphs
------------------------------------------------------------------------------
-
-data O
-data C
-
--- Blocks are always non-empty
-data Block n e x where
-  BUnit :: n e x -> Block n e x
-  BCat  :: Block n e O -> Block n O x -> Block n e x
-
-type Body n = BlockMap (Block n C C)
-  -- Invariant: BlockId bid maps to a block whose entryBlockId is bid
-
-data Graph n e x where
-  GNil  :: Graph n O O
-  GUnit :: Block n O O -> Graph n O O
-  GMany :: Entry n e -> Body n
-        -> Exit n x -> Graph n e x
-  -- If Entry is EntryC, then Body is non-empty
-
-data Entry n e where
-  EntryC :: BlockId -> Entry n C
-  EntryO   :: Block n O C -> Entry n O
-
-data Exit n x where
-  ExitC :: Exit n C
-  ExitO   :: BlockId -> Block n C O -> Exit n O
-  -- Invariant: the BlockId is the entryBlockId of the block
-
------------------------------------------------------------------------------
---             Defined here but not used
------------------------------------------------------------------------------
-
--- Singletons
---   OO   GUnit
---   CO   GMany (EntryC l) [] (ExitO l b)
---   OC   GMany (EntryO b)   []  ExitC
---   CC   GMany (EntryC l) [b] ExitC
-
-bFilter :: forall n. (n O O -> Bool) -> Block n C C -> Block n C C
-bFilter keep (BUnit n)  = BUnit n
-bFilter keep (BCat h t) = bFilterH h (bFilterT t)
-  where
-    bFilterH :: Block n C O -> Block n O C -> Block n C C
-    bFilterH (BUnit n)    rest = BUnit n `BCat` rest
-    bFilterH (h `BCat` m) rest = bFilterH h (bFilterM m rest)
-
-    bFilterT :: Block n O C -> Block n O C
-    bFilterT (BUnit n)    = BUnit n
-    bFilterT (m `BCat` t) = bFilterM m (bFilterT t)
-
-    bFilterM :: Block n O O -> Block n O C -> Block n O C
-    bFilterM (BUnit n) rest | keep n    = BUnit n `BCat` rest
-                            | otherwise = rest 
-    bFilterM (b1 `BCat` b2) rest = bFilterM b1 (bFilterM b2 rest)
-
-gCat :: Graph n e a -> Graph n a x -> Graph n e x
-gCat GNil g2 = g2
-gCat g1 GNil = g1
-
-gCat (GUnit b1) (GUnit b2)             
-  = GUnit (b1 `BCat` b2)
-
-gCat (GUnit b) (GMany (EntryO e) bs x) 
-  = GMany (EntryO (b `BCat` e)) bs x
-
-gCat (GMany e bs (ExitO bid x)) (GUnit b2) 
-   = GMany e bs (ExitO bid (x `BCat` b2))
-
-gCat (GMany e1 bs1 (ExitO bid x1)) (GMany (EntryO e2) bs2 x2)
-   = GMany e1 (addBlock bid (x1 `BCat` e2) bs1 `unionBlocks` bs2) x2
-
-gCat (GMany e1 bs1 ExitC) (GMany (EntryC _) bs2 x2)
-   = GMany e1 (bs1 `unionBlocks` bs2) x2
-
-class Edges thing where
-  entryBlockId :: thing C x -> BlockId
-  successors :: thing e C -> [BlockId]
-
-instance Edges n => Edges (Block n) where
-  entryBlockId (BUnit n) = entryBlockId n
-  entryBlockId (b `BCat` _) = entryBlockId b
-  successors (BUnit n)   = successors n
-  successors (BCat _ b)  = successors b
-
-instance Edges n => Edges (Graph n) where
-  entryBlockId (GMany (EntryC bid) _ _) = bid
-  successors (GMany h bg ExitC) 
-     = blockSetElems (all_succs `minusBlockSet` all_blk_ids)
-     where 
-       (bids, blks) = unzip (blocksToList bg)
-       bg_succs = mkBlockSet [bid | b <- blks, bid <- successors b]
-       all_succs :: BlockSet
-       all_succs = case h of
-                     EntryC _ -> bg_succs
-                     EntryO b   -> bg_succs `unionBlockSet` mkBlockSet (successors b)
-       all_blk_ids = mkBlockSet bids
-
-data OCFlag oc where
-  IsOpen   :: OCFlag O
-  IsClosed :: OCFlag C
-
-class IsOC oc where
-  ocFlag :: OCFlag oc
-
-instance IsOC O where
-  ocFlag = IsOpen
-instance IsOC C where
-  ocFlag = IsClosed
-
-mkIfThenElse :: forall n x. IsOC x 
-             => (BlockId -> BlockId -> n O C)  -- The conditional branch instruction
-             -> (BlockId -> n C O)             -- Make a head node 
-            -> (BlockId -> n O C)              -- Make an unconditional branch
-            -> Graph n O x -> Graph n O x      -- Then and else branches
-            -> [BlockId]                       -- Block supply
-             -> Graph n O x                    -- The complete thing
-mkIfThenElse mk_cbranch mk_lbl mk_branch then_g else_g (tl:el:jl:_)
-  = case (ocFlag :: OCFlag x) of
-      IsOpen   -> gUnitOC (mk_cbranch tl el)
-                  `gCat` (mk_lbl_g tl `gCat` then_g `gCat` mk_branch_g jl)
-                  `gCat` (mk_lbl_g el `gCat` else_g `gCat` mk_branch_g jl)
-                  `gCat` (mk_lbl_g jl)
-      IsClosed -> gUnitOC (mk_cbranch tl el)
-                  `gCat` (mk_lbl_g tl `gCat` then_g)
-                  `gCat` (mk_lbl_g el `gCat` else_g)
-  where
-    mk_lbl_g :: BlockId -> Graph n C O
-    mk_lbl_g lbl = gUnitCO lbl (mk_lbl lbl)
-    mk_branch_g :: BlockId -> Graph n O C
-    mk_branch_g lbl = gUnitOC (mk_branch lbl)
-
-gUnitCO :: BlockId -> n C O -> Graph n C O
-gUnitCO lbl n = GMany (EntryC lbl) noBlocks (ExitO lbl (BUnit n))
-
-gUnitOC :: n O C -> Graph n O C
-gUnitOC n = GMany (EntryO (BUnit n)) noBlocks ExitC
-
------------------------------------------------------------------------------
---     RG: an internal data type for graphs under construction
---          TOTALLY internal to Hoopl
------------------------------------------------------------------------------
-
--- "RG" stands for "rewritten graph", and embodies
--- both the result graph and its internal facts
-
-data RL n f x where
-  RL     :: BlockId -> f -> RG n f C x -> RL n f x
-  RLMany :: GraphWithFacts n f -> RL n f C
-
-data RG n f e x where  -- Will have facts too in due course
-  RGNil   :: RG n f a a
-  RGBlock :: Block n e x -> RG n f e x
-  RGCatO  :: RG n f e O -> RG n f O x -> RG n f e x
-  RGCatC  :: RG n f e C -> RL n f x   -> RG n f e x
-
-type GraphWithFacts n f = (Body n, FactBase f)
-  -- A Body together with the facts for that graph
-  -- The domains of the two maps should be identical
-
--- 'normalise' converts a closed/closed result graph into a Body
--- It uses three auxiliary functions, 
--- specialised for various argument shapes
-normRL :: RL n f C -> GraphWithFacts n f
-normRL (RL l f b)  = normRG l f b
-normRL (RLMany bg) = bg
-
-normRL_O :: RL n f O -> RG n f O C -> GraphWithFacts n f
-normRL_O (RL l f b) rg = normRG_O l f b rg
-
-normRG :: BlockId -> f -> RG n f C C -> GraphWithFacts n f
-normRG l f (RGBlock b)      = unitBWF l f b
-normRG l f (RGCatO rg1 rg2) = normRG_O l f rg1 rg2
-normRG l f (RGCatC rg1 rg2) = normRG l f rg1 `unionBWF` normRL rg2
-
-normRG_O :: BlockId -> f -> RG n f C O -> RG n f O C -> GraphWithFacts n f
--- normalise (rg1 `RGCatO` rg2)
-normRG_O l f (RGBlock b)      rg  = normB l f b rg
-normRG_O l f (RGCatO rg1 rg2) rg3 = normRG_O l f rg1 (rg2 `RGCatO` rg3)
-normRG_O l f (RGCatC rg1 rg2) rg3 = normRG l f rg1 `unionBWF` normRL_O rg2 rg3
-
-normB :: BlockId -> f -> Block n C O -> RG n f O C -> GraphWithFacts n f
--- normalise (Block b `RGCatO` rg2)
-normB l f b1 (RGBlock b2)     = unitBWF l f (b1 `BCat` b2)
-normB l f b  (RGCatO rg1 rg2) = normB_O l f b rg1 rg2
-normB l f b  (RGCatC rg1 rg2) = normB  l f b rg1 `unionBWF` normRL rg2
-
-normB_O :: BlockId -> f -> Block n C O -> RG n f O O -> RG n f O C
-        -> GraphWithFacts n f
--- normalise (Block b `RGCatO` rg2 `RGCatO` rg3)
-normB_O l f  b  RGNil           rg  = normB l f b rg
-normB_O l f bh (RGBlock bt)     rg  = normB l f (bh `BCat` bt) rg
-normB_O l f b  (RGCatC rg1 rg2) rg3 = normB l f b rg1 `unionBWF` normRL_O rg2 rg3
-normB_O l f b  (RGCatO rg1 rg2) rg3 = normB_O l f b rg1 (rg2 `RGCatO` rg3)
-
-noBWF :: GraphWithFacts n f
-noBWF = (noBlocks, noFacts)
-
-unitBWF :: BlockId -> f -> Block n C C -> GraphWithFacts n f
-unitBWF lbl f b = (unitBlock lbl b, unitFactBase lbl f)
-
-unionBWF :: GraphWithFacts n f -> GraphWithFacts n f -> GraphWithFacts n f
-unionBWF (bg1, fb1) (bg2, fb2) = (bg1 `unionBlocks` bg2, fb1 `unionFactBase` fb2)
-
------------------------------------------------------------------------------
---             DataflowLattice
------------------------------------------------------------------------------
-
-data DataflowLattice a = DataflowLattice  { 
-  fact_name       :: String,                   -- Documentation
-  fact_bot        :: a,                        -- Lattice bottom element
-  fact_extend     :: a -> a -> (ChangeFlag,a), -- Lattice join plus change flag
-  fact_do_logging :: Bool                      -- log changes
-}
-
-data ChangeFlag = NoChange | SomeChange
-
------------------------------------------------------------------------------
---             The main Hoopl API
------------------------------------------------------------------------------
-
-type ForwardTransfer n f 
-  = forall e x. n e x -> f -> ExitFactF x f 
-
-type ForwardRewrite n f 
-  = forall e x. n e x -> f -> Maybe (AGraph n e x)
-
-type family   ExitFactF x f :: *
-type instance ExitFactF C f = [(BlockId, f)] 
-type instance ExitFactF O f = f
-
-data AGraph n e x = AGraph     -- Stub for now
-
-
------------------------------------------------------------------------------
---      TxFactBase: a FactBase with ChangeFlag information
------------------------------------------------------------------------------
-
--- The TxFactBase is an accumulating parameter, threaded through all
--- the analysis/transformation of each block in the g_blocks of a grpah.
--- It carries a ChangeFlag with it, and a set of BlockIds
--- to monitor. Updates to other BlockIds don't affect the ChangeFlag
-data TxFactBase n f
-  = TxFB { tfb_fbase :: FactBase f
-
-         , tfb_cha   :: ChangeFlag
-         , tfb_bids  :: BlockSet   -- Update change flag iff these blocks change
-                                   -- These are BlockIds of the *original* 
-                                   -- (not transformed) blocks
-
-         , tfb_blks  :: GraphWithFacts n f  -- Transformed blocks
-    }
-
-updateFact :: DataflowLattice f -> BlockSet
-           -> (BlockId, f)
-           -> (ChangeFlag, FactBase f) 
-           -> (ChangeFlag, FactBase f)
--- Update a TxFactBase, setting the change flag iff
---   a) the new fact adds information...
---   b) for a block in the BlockSet in the TxFactBase
-updateFact lat lbls (lbl, new_fact) (cha, fbase)
-  | NoChange <- cha2        = (cha,        fbase)
-  | lbl `elemBlockSet` lbls = (SomeChange, new_fbase)
-  | otherwise               = (cha,        new_fbase)
-  where
-    old_fact = lookupFact lat fbase lbl
-    (cha2, res_fact) = fact_extend lat old_fact new_fact
-    new_fbase = extendFactBase fbase lbl res_fact
-
-fixpoint :: forall n f. 
-            DataflowLattice f
-         -> (BlockId -> Block n C C -> FactBase f 
-                     -> FuelMonad ([(BlockId,f)], RL n f C))
-         -> [(BlockId, Block n C C)]
-         -> FactBase f 
-         -> FuelMonad (FactBase f, GraphWithFacts n f)
-fixpoint lat do_block blocks init_fbase
-  = do { fuel <- getFuel  
-       ; tx_fb <- loop fuel init_fbase
-       ; return (tfb_fbase tx_fb `deleteFromFactBase` blocks, tfb_blks tx_fb) }
-            -- The successors of the Graph are the the BlockIds for which
-            -- we have facts, that are *not* in the blocks of the graph
-  where
-    tx_blocks :: [(BlockId, Block n C C)] 
-              -> TxFactBase n f -> FuelMonad (TxFactBase n f)
-    tx_blocks []     tx_fb = return tx_fb
-    tx_blocks ((lbl,blk):bs) tx_fb = do { tx_fb1 <- tx_block lbl blk tx_fb
-                                        ; tx_blocks bs tx_fb1 }
-
-    tx_block :: BlockId -> Block n C C 
-             -> TxFactBase n f -> FuelMonad (TxFactBase n f)
-    tx_block lbl blk (TxFB { tfb_fbase = fbase, tfb_bids = lbls
-                           , tfb_blks = blks, tfb_cha = cha })
-      = do { (out_facts, rg) <- do_block lbl blk fbase
-           ; let (cha',fbase') = foldr (updateFact lat lbls) (cha,fbase) out_facts
-                 f = lookupFact lat fbase lbl
-               -- tfb_blks will be discarded unless we have 
-               -- reached a fixed point, so it doesn't matter
-               -- whether we get f from fbase or fbase'
-           ; return (TxFB { tfb_bids = extendBlockSet lbls lbl
-                          , tfb_blks = normRL rg `unionBWF` blks
-                          , tfb_fbase = fbase', tfb_cha = cha' }) }
-
-    loop :: Fuel -> FactBase f -> FuelMonad (TxFactBase n f)
-    loop fuel fbase 
-      = do { let init_tx_fb = TxFB { tfb_fbase = fbase
-                                   , tfb_cha   = NoChange
-                                   , tfb_blks  = noBWF
-                                   , tfb_bids  = emptyBlockSet }
-           ; tx_fb <- tx_blocks blocks init_tx_fb
-           ; case tfb_cha tx_fb of
-               NoChange   -> return tx_fb
-               SomeChange -> do { setFuel fuel; loop fuel (tfb_fbase tx_fb) } }
-
------------------------------------------------------------------------------
---             Transfer functions
------------------------------------------------------------------------------
-
--- Keys to the castle: a generic transfer function for each shape
--- Here's the idea: we start with single-n transfer functions,
--- move to basic-block transfer functions (we have exactly four shapes),
--- then finally to graph transfer functions (which requires iteration).
-
-type ARF thing n f = forall e x. f -> thing e x -> FuelMonad (ExitFactF x f, RG n f e x)
-
-type ARF_Node  n f = ARF n         n f
-type ARF_Block n f = ARF (Block n) n f
-type ARF_Graph n f = ARF (Graph n) n f
------------------------------------------------------------------------------
-
-arfNodeNoRW :: forall n f. ForwardTransfer n f -> ARF_Node n f
- -- Lifts ForwardTransfer to ARF_Node; simple transfer only
-arfNodeNoRW transfer_fn f node
-  = return (transfer_fn node f, RGBlock (BUnit node))
-
-arfNode :: forall n f.
-                 DataflowLattice f
-        -> ForwardTransfer n f
-        -> ForwardRewrite n f
-        -> ARF_Node n f
-        -> ARF_Node n f
--- Lifts (ForwardTransfer,ForwardRewrite) to ARF_Node; 
--- this time we do rewriting as well. 
--- The ARF_Graph parameters specifies what to do with the rewritten graph
-arfNode lattice transfer_fn rewrite_fn arf_node f node
-  = do { mb_g <- withFuel (rewrite_fn node f)
-       ; case mb_g of
-           Nothing -> arfNodeNoRW transfer_fn f node
-          Just ag -> do { g <- graphOfAGraph ag
-                        ; arfGraph lattice arf_node f g } }
-
-arfBlock :: forall n f. ARF_Node n f -> ARF_Block n f
--- Lift from nodes to blocks
-arfBlock arf_node f (BUnit node)   = arf_node f node
-arfBlock arf_node f (BCat hd mids) = do { (f1,g1) <- arfBlock arf_node f  hd
-                                        ; (f2,g2) <- arfBlock arf_node f1 mids
-                                       ; return (f2, g1 `RGCatO` g2) }
-
-arfBody :: forall n f. DataflowLattice f 
-          -> ARF_Node n f -> FactBase f -> Body n 
-          -> FuelMonad (FactBase f, GraphWithFacts n f)
-               -- Outgoing factbase is restricted to BlockIds *not* in
-               -- in the Body; the facts for BlockIds
-               -- *in* the Body are in the GraphWithFacts
-arfBody lattice arf_node init_fbase blocks
-  = fixpoint lattice do_block 
-             (forwardBlockList (factBaseBlockIds init_fbase) blocks) 
-             init_fbase
-  where
-    do_block :: BlockId -> Block n C C -> FactBase f
-             -> FuelMonad ([(BlockId,f)], RL n f C)
-    do_block l blk fbase = do { let f = lookupFact lattice fbase l
-                              ; (fs, rg) <- arfBlock arf_node f blk
-                             ; return (fs, RL l f rg) }
-
-arfGraph :: forall n f. DataflowLattice f -> ARF_Node n f -> ARF_Graph n f
--- Lift from blocks to graphs
-arfGraph _       _        f GNil        = return (f, RGNil)
-arfGraph _       arf_node f (GUnit blk) = arfBlock arf_node f blk
-arfGraph lattice arf_node f (GMany entry blks exit)
-  = do { (f1, entry') <- arf_entry f entry
-       ; (f2, blks')  <- arfBody lattice arf_node (mkFactBase f1) blks
-       ; (f3, exit')  <- arf_exit f2 exit 
-       ; return (f3, entry' `RGCatC` RLMany blks' `RGCatC` exit') }
-  where
-    arf_entry :: f -> Entry n e
-             -> FuelMonad ([(BlockId,f)], RG n f e C)
-    arf_entry fh (EntryC lh) = return ([(lh,fh)], RGNil)
-    arf_entry fh (EntryO b)    = arfBlock arf_node fh b
-
-    arf_exit :: FactBase f -> Exit n x
-            -> FuelMonad (ExitFactF x f, RL n f x)
-    arf_exit fb ExitC        = return (factBaseList fb, RLMany noBWF)
-    arf_exit fb (ExitO lt blk) = do { let ft = lookupFact lattice fb lt
-                                   ; (f1, rg) <- arfBlock arf_node ft blk
-                                   ; return (f1, RL lt ft rg) }
-
-forwardBlockList :: [BlockId] -> Body n -> [(BlockId,Block n C C)]
--- This produces a list of blocks in order suitable for forward analysis.
--- ToDo: Do a topological sort to improve convergence rate of fixpoint
---       This will require a (HavingSuccessors l) class constraint
-forwardBlockList  _ blks = blocksToList blks
-
-----------------------------------------------------------------
---       The pièce de resistance: cunning transfer functions
-----------------------------------------------------------------
-
-pureAnalysis :: DataflowLattice f -> ForwardTransfer n f -> ARF_Graph n f
-pureAnalysis lattice f = arfGraph lattice (arfNodeNoRW f)
-
-analyseAndRewriteFwd
-   :: forall n f. 
-      DataflowLattice f
-   -> ForwardTransfer n f
-   -> ForwardRewrite n f
-   -> RewritingDepth
-   -> FactBase f
-   -> Body n
-   -> FuelMonad (Body n, FactBase f)
-
-data RewritingDepth = RewriteShallow | RewriteDeep
--- When a transformation proposes to rewrite a node, 
--- you can either ask the system to
---  * "shallow": accept the new graph, analyse it without further rewriting
---  * "deep": recursively analyse-and-rewrite the new graph
-
-analyseAndRewriteFwd lattice transfers rewrites depth facts graph
-  = do { (_, gwf) <- arfBody lattice arf_node facts graph
-       ; return gwf }
-  where 
-    arf_node, rec_node :: ARF_Node n f
-    arf_node = arfNode lattice transfers rewrites rec_node
-
-    rec_node = case depth of
-                RewriteShallow -> arfNodeNoRW transfers
-                RewriteDeep    -> arf_node
-
------------------------------------------------------------------------------
---             Backward rewriting
------------------------------------------------------------------------------
-
-type BackwardTransfer n f 
-  = forall e x. n e x -> ExitFactB x f -> f 
-type BackwardRewrite n f 
-  = forall e x. n e x -> ExitFactB x f -> Maybe (AGraph n e x)
-
-type ARB thing n f = forall e x. ExitFactB x f -> thing e x
-                              -> FuelMonad (f, RG n f e x)
-
-type family   ExitFactB x f :: *
-type instance ExitFactB C f = FactBase f
-type instance ExitFactB O f = f
-
-type ARB_Node  n f = ARB n         n f
-type ARB_Block n f = ARB (Block n) n f
-type ARB_Graph n f = ARB (Graph n) n f
-
-arbNodeNoRW :: forall n f . BackwardTransfer n f -> ARB_Node n f
--- Lifts BackwardTransfer to ARB_Node; simple transfer only
-arbNodeNoRW transfer_fn f node
-  = return (transfer_fn node f, RGBlock (BUnit node))
-
-arbNode :: forall n f.
-           DataflowLattice f
-        -> BackwardTransfer n f
-        -> BackwardRewrite n f
-        -> ARB_Node n f
-        -> ARB_Node n f
--- Lifts (BackwardTransfer,BackwardRewrite) to ARB_Node; 
--- this time we do rewriting as well. 
--- The ARB_Graph parameters specifies what to do with the rewritten graph
-arbNode lattice transfer_fn rewrite_fn arf_node f node
-  = do { mb_g <- withFuel (rewrite_fn node f)
-       ; case mb_g of
-           Nothing -> arbNodeNoRW transfer_fn f node
-          Just ag -> do { g <- graphOfAGraph ag
-                        ; arbGraph lattice arf_node f g } }
-
-arbBlock :: forall n f. ARB_Node n f -> ARB_Block n f
--- Lift from nodes to blocks
-arbBlock arb_node f (BUnit node) = arb_node f node
-arbBlock arb_node f (BCat b1 b2) = do { (f2,g2) <- arbBlock arb_node f  b2
-                                      ; (f1,g1) <- arbBlock arb_node f2 b1
-                                     ; return (f1, g1 `RGCatO` g2) }
-
-
-arbBlocks :: forall n f. DataflowLattice f 
-          -> ARB_Node n f -> FactBase f
-          -> Body n -> FuelMonad (FactBase f, GraphWithFacts n f)
-arbBlocks lattice arb_node init_fbase blocks
-  = fixpoint lattice do_block 
-             (backwardBlockList (factBaseBlockIds init_fbase) blocks) 
-             init_fbase
-  where
-    do_block :: BlockId -> Block n C C -> FactBase f
-             -> FuelMonad ([(BlockId,f)], RL n f C)
-    do_block l b fbase = do { (fb, rg) <- arbBlock arb_node fbase b
-                           ; let f = lookupFact lattice fbase l
-                            ; return ([(l,fb)], RL l f rg) }
-
-arbGraph :: forall n f. DataflowLattice f -> ARB_Node n f -> ARB_Graph n f
-arbGraph _       _        f GNil        = return (f, RGNil)
-arbGraph _       arb_node f (GUnit blk) = arbBlock arb_node f blk
-arbGraph lattice arb_node f (GMany entry blks exit)
-  = do { (f1, exit')  <- arb_exit f exit
-       ; (f2, blks')  <- arbBlocks lattice arb_node f1 blks
-       ; (f3, entry') <- arb_entry f2 entry 
-       ; return (f3, entry' `RGCatC` RLMany blks' `RGCatC` exit') }
-  where
-    arb_entry :: FactBase f -> Entry n e
-              -> FuelMonad (f, RG n f e C)
-    arb_entry fbase (EntryC l) = return (lookupFact lattice fbase l, RGNil)
-    arb_entry fbase (EntryO b) = arbBlock arb_node fbase b
-
-    arb_exit :: ExitFactB x f -> Exit n x
-            -> FuelMonad (FactBase f, RL n f x)
-    arb_exit ft ExitC          = return (ft, RLMany noBWF)
-    arb_exit ft (ExitO lt blk) = do { (f1, rg) <- arbBlock arb_node ft blk
-                                    ; return (mkFactBase [(lt,f1)], RL lt f1 rg) }
-
-backwardBlockList :: [BlockId] -> Body n -> [(BlockId,Block n C C)]
--- This produces a list of blocks in order suitable for backward analysis.
-backwardBlockList _ blks = blocksToList blks
-
-analyseAndRewriteBwd
-   :: forall n f. 
-      DataflowLattice f
-   -> BackwardTransfer n f
-   -> BackwardRewrite n f
-   -> RewritingDepth
-   -> ARB_Graph n f
-
-analyseAndRewriteBwd lattice transfers rewrites depth
-  = arbGraph lattice arb_node
-  where 
-    arb_node, rec_node :: ARB_Node n f
-    arb_node = arbNode lattice transfers rewrites rec_node
-
-    rec_node = case depth of
-                RewriteShallow -> arbNodeNoRW transfers
-                RewriteDeep    -> arb_node
-
------------------------------------------------------------------------------
---             The fuel monad
------------------------------------------------------------------------------
-
-type Uniques = Int
-type Fuel    = Int
-
-newtype FuelMonad a = FM { unFM :: Fuel -> Uniques -> (a, Fuel, Uniques) }
-
-instance Monad FuelMonad where
-  return x = FM (\f u -> (x,f,u))
-  m >>= k  = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u')
-
-withFuel :: Maybe a -> FuelMonad (Maybe a)
-withFuel Nothing  = return Nothing
-withFuel (Just r) = FM (\f u -> if f==0 then (Nothing, f, u)
-                                else (Just r, f-1, u))
-
-getFuel :: FuelMonad Fuel
-getFuel = FM (\f u -> (f,f,u))
-
-setFuel :: Fuel -> FuelMonad ()
-setFuel f = FM (\_ u -> ((), f, u))
-
-graphOfAGraph :: AGraph node e x -> FuelMonad (Graph node e x)
-graphOfAGraph = error "urk"    -- Stub
-
------------------------------------------------------------------------------
---             BlockId, FactBase, BlockSet
------------------------------------------------------------------------------
-
-type BlockId = Int
-
-mkBlockId :: Int -> BlockId
-mkBlockId uniq = uniq
-
-----------------------
-type BlockMap a = M.IntMap a
-
-noBlocks :: Body n
-noBlocks = M.empty
-
-unitBlock :: BlockId -> Block n C C -> Body n
-unitBlock = M.singleton
-
-addBlock :: BlockId -> Block n C C -> Body n -> Body n
-addBlock = M.insert
-
-unionBlocks :: Body n -> Body n -> Body n
-unionBlocks = M.union
-
-blocksToList :: Body n -> [(BlockId,Block n C C)]
-blocksToList = M.toList
-
-----------------------
-type FactBase a = M.IntMap a
-
-noFacts :: FactBase f
-noFacts = M.empty
-
-mkFactBase :: [(BlockId, f)] -> FactBase f
-mkFactBase prs = M.fromList prs
-
-unitFactBase :: BlockId -> f -> FactBase f
-unitFactBase = M.singleton
-
-lookupFact :: DataflowLattice f -> FactBase f -> BlockId -> f
-lookupFact lattice env blk_id 
-  = case M.lookup blk_id env of
-      Just f  -> f
-      Nothing -> fact_bot lattice
-
-extendFactBase :: FactBase f -> BlockId -> f -> FactBase f
-extendFactBase env blk_id f = M.insert blk_id f env
-
-unionFactBase :: FactBase f -> FactBase f -> FactBase f
-unionFactBase = M.union
-
-factBaseBlockIds :: FactBase f -> [BlockId]
-factBaseBlockIds = M.keys
-
-factBaseList :: FactBase f -> [(BlockId, f)]
-factBaseList = M.toList 
-
-deleteFromFactBase :: FactBase f -> [(BlockId,a)] -> FactBase f
-deleteFromFactBase fb blks = foldr (M.delete . fst) fb blks
-
-----------------------
-type BlockSet = S.IntSet
-
-emptyBlockSet :: BlockSet
-emptyBlockSet = S.empty
-
-extendBlockSet :: BlockSet -> BlockId -> BlockSet
-extendBlockSet bids bid = S.insert bid bids
-
-elemBlockSet :: BlockId -> BlockSet -> Bool
-elemBlockSet bid bids = S.member bid bids
-
-blockSetElems :: BlockSet -> [BlockId]
-blockSetElems = S.toList
-
-minusBlockSet :: BlockSet -> BlockSet -> BlockSet
-minusBlockSet = S.difference
-
-unionBlockSet :: BlockSet -> BlockSet -> BlockSet
-unionBlockSet = S.union
-
-mkBlockSet :: [BlockId] -> BlockSet
-mkBlockSet = S.fromList
diff --git a/prototypes/Hoopl6.hs b/prototypes/Hoopl6.hs
deleted file mode 100644 (file)
index 15133db..0000000
+++ /dev/null
@@ -1,753 +0,0 @@
-{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies #-}
-
-{- Notes about the genesis of Hoopl5
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-As well as addressing your concerns I had some of my own:
-
-* In Hoopl4, a closed/closed graph starts with a distinguished
-  closed/closed block (the entry block).  But this block is
-  *un-labelled*.  That means that there is no way to branch back to
-  the entry point of a procedure, which seems a bit unclean.
-
-* In general I have to admit that it does seem a bit unintuitive to
-  have block that is
-       a) closed on entry, but
-       b) does not have a label
-
-* If you look at MkZipCfgCmm you'll see stuff like this:
-     mkCmmIfThen e tbranch
-       = withFreshLabel "end of if"     $ \endif ->
-         withFreshLabel "start of then" $ \tid ->
-         mkCbranch e tid endif <*>
-         mkLabel tid   <*> tbranch <*> mkBranch endif <*>
-         mkLabel endif
-
-   We are trying to present a user model *graphs* as
-       a sequence, connected by <*>,
-       of little graphs
-   Moreover, one of the little graphs is (mkLabel BlockId), and I
-   don't see how to make a graph for that in Hoopl4.
-
-   (Norman I know that this may be what you have been trying to say
-   about "graphs under construction" for some time, but looking at
-   MkZipCfgCmm made it far more concrete for me.)
-
-
-Specifically, in Hoopl5:
-
-* The ARF type is no longer overloaded over the LiftNode class.  
-  It has a simple and beautiful type.
-
-* I put the BlockId back in a first node, as John wanted.
-
-* To make it possible to branch to the label of the entry block of a
-  Graph it does make sense to put that block in the Graph that is
-  the main payload of the graph
-
-* That militates in favour of a Maybe-kind-of-thing on entry to a
-  Graph, just as Norman wanted.  It's called Head, dual to Tail.
-
-* However I am Very Very Keen to maintain the similar properties of
-  nodes, blocks, graphs; and in particular the single point of entry.
-  (For a multi-entry procedure, the procedure can be represented by a
-  Graph plus a bunch of BlockIds, rather than a Graph.)  So I
-  made the Head contain the BlockId of the entry point.
-
-* The Graph in a Graph is a finite map, as you wanted.  Notice
-  that this embodies an invariant: a BlockId must map to a block whose
-  entry point is that BlockId.
-
-* I've added a layer, using arfBlocks/arbBlocks.  Admittedly the
-  type doesn't fit the same pattern, but it's useful structuring
-
-* You should think of a Graph as a user-visible type; perhaps
-  this is the kind of graph that might form the body of a procedure.
-  Moreover, perhaps rewriteAndAnlyseForward should take a Graph
-  rather than a Graph, and call arbBlocks.
-
-* With that in mind I was happy to introduce the analogous invariant
-  for the exit block in Tail; it is very very convenient to have that
-  BlockId (cached though it may be) to hand.
-
-* Because graphs are made out of blocks, it's easy to have a
-  constructor for the empty ggraph, and we don't need any stinkikng
-  smart constructor to keep nil in its place.  But if we moved nil to
-  blocks, we'd need a smart constructor for graphs *and* one for
-  blocks.  (Because unlike graphs, blocks *are* made from other
-  blocks.
-
-
--}
-
-module Hoopl5 where
-
-import qualified Data.IntMap as M
-import qualified Data.IntSet as S
-
------------------------------------------------------------------------------
---             Graphs
------------------------------------------------------------------------------
-
-data O
-data C
-
--- Blocks are always non-empty
-data Block n e x where
-  BUnit :: n e x -> Block n e x
-  BCat  :: Block n e O -> Block n O x -> Block n e x
-
-data Graph n e x where
-  GNil  :: Graph n O O
-  GUnit :: Block n O O -> Graph n O O
-  GMany :: IfOpen e (Block n O C) -> BlockMap (Block n C C)
-        -> IfOpen x (Block n C O) -> Graph n e x
-
-data IfOpen e thing where
-  IsOpen    :: thing -> IfOpen O thing
-  IsNotOpen ::          IfOpen C thing
-
------------------------------------------------------------------------------
---             Defined here but not used
------------------------------------------------------------------------------
-
--- Singletons
---   OO   GUnit
---   CO   GMany (NoHead l) [] (Tail l b)
---   OC   GMany (Head b)   []  NoTail
---   CC   GMany (NoHead l) [b] NoTail
-
-class Edges thing where
-  closedId :: thing e x -> IfClosed e BlockId
-  successors :: thing e C -> [BlockId]
-
-instance Edges n => Edges (Block n) where
-  closedId (BUnit n) = closedId n
-  closedId (b `BCat` _) = closedId b
-  successors (BUnit n)   = successors n
-  successors (BCat _ b)  = successors b
-
-data IfClosed e thing where
-  IsClosed    :: thing -> IfClosed C thing
-  IsNotClosed ::          IfClosed O thing
-
-
------------------------------------------------------------------------------
---     RG: an internal data type for graphs under construction
---          TOTALLY internal to Hoopl
------------------------------------------------------------------------------
-
--- "RG" stands for "rewritten graph", and embodies
--- both the result graph and its internal facts
-
-data RL n f x where
-  RL     :: BlockId -> f -> RG n f C x -> RL n f x
-  RLMany :: GraphWithFacts n f -> RL n f C
-
-data RG n f e x where  -- Will have facts too in due course
-  RGNil   :: RG n f a a
-  RGBlock :: Block n e x -> RG n f e x
-  RGCatO  :: RG n f e O -> RG n f O x -> RG n f e x
-  RGCatC  :: RG n f e C -> RL n f x   -> RG n f e x
-
-type GraphWithFacts n f = (BlockMap (Block n C C), FactBase f)
-  -- A Graph together with the facts for that graph
-  -- The domains of the two maps should be identical
-
--- 'normalise' converts a closed/closed result graph into a Graph
--- It uses three auxiliary functions, 
--- specialised for various argument shapes
-normRL :: RL n f C -> GraphWithFacts n f
-normRL (RL l f b)  = normRG l f b
-normRL (RLMany bg) = bg
-
-normRL_O :: RL n f O -> RG n f O C -> GraphWithFacts n f
-normRL_O (RL l f b) rg = normRG_O l f b rg
-
-normRG :: BlockId -> f -> RG n f C C -> GraphWithFacts n f
-normRG l f (RGBlock b)      = unitBWF l f b
-normRG l f (RGCatO rg1 rg2) = normRG_O l f rg1 rg2
-normRG l f (RGCatC rg1 rg2) = normRG l f rg1 `unionBWF` normRL rg2
-
-normRG_O :: BlockId -> f -> RG n f C O -> RG n f O C -> GraphWithFacts n f
--- normalise (rg1 `RGCatO` rg2)
-normRG_O l f (RGBlock b)      rg  = normB l f b rg
-normRG_O l f (RGCatO rg1 rg2) rg3 = normRG_O l f rg1 (rg2 `RGCatO` rg3)
-normRG_O l f (RGCatC rg1 rg2) rg3 = normRG l f rg1 `unionBWF` normRL_O rg2 rg3
-
-normB :: BlockId -> f -> Block n C O -> RG n f O C -> GraphWithFacts n f
--- normalise (Block b `RGCatO` rg2)
-normB l f b1 (RGBlock b2)     = unitBWF l f (b1 `BCat` b2)
-normB l f b  (RGCatO rg1 rg2) = normB_O l f b rg1 rg2
-normB l f b  (RGCatC rg1 rg2) = normB  l f b rg1 `unionBWF` normRL rg2
-
-normB_O :: BlockId -> f -> Block n C O -> RG n f O O -> RG n f O C
-        -> GraphWithFacts n f
--- normalise (Block b `RGCatO` rg2 `RGCatO` rg3)
-normB_O l f  b  RGNil           rg  = normB l f b rg
-normB_O l f bh (RGBlock bt)     rg  = normB l f (bh `BCat` bt) rg
-normB_O l f b  (RGCatC rg1 rg2) rg3 = normB l f b rg1 `unionBWF` normRL_O rg2 rg3
-normB_O l f b  (RGCatO rg1 rg2) rg3 = normB_O l f b rg1 (rg2 `RGCatO` rg3)
-
-noBWF :: GraphWithFacts n f
-noBWF = (noBlocks, noFacts)
-
-unitBWF :: BlockId -> f -> Block n C C -> GraphWithFacts n f
-unitBWF lbl f b = (unitBlock lbl b, unitFactBase lbl f)
-
-unionBWF :: GraphWithFacts n f -> GraphWithFacts n f -> GraphWithFacts n f
-unionBWF (bg1, fb1) (bg2, fb2) = (bg1 `unionBlocks` bg2, fb1 `unionFactBase` fb2)
-
------------------------------------------------------------------------------
---             DataflowLattice
------------------------------------------------------------------------------
-
-data DataflowLattice a = DataflowLattice  { 
-  fact_name       :: String,                   -- Documentation
-  fact_bot        :: a,                        -- Lattice bottom element
-  fact_extend     :: a -> a -> (ChangeFlag,a), -- Lattice join plus change flag
-  fact_do_logging :: Bool                      -- log changes
-}
-
-data ChangeFlag = NoChange | SomeChange
-
------------------------------------------------------------------------------
---             The main Hoopl API
------------------------------------------------------------------------------
-
-type ForwardTransfer n f 
-  = forall e x. f -> n e x -> TailFactF x f 
-
-type ForwardRewrite n f 
-  = forall e x. f -> n e x -> Maybe (AGraph n e x)
-
-type family   TailFactF x f :: *
-type instance TailFactF C f = [(BlockId, f)] 
-type instance TailFactF O f = f
-
-data AGraph n e x = AGraph     -- Stub for now
-
-
------------------------------------------------------------------------------
---      TxFactBase: a FactBase with ChangeFlag information
------------------------------------------------------------------------------
-
--- The TxFactBase is an accumulating parameter, threaded through all
--- the analysis/transformation of each block in the g_blocks of a grpah.
--- It carries a ChangeFlag with it, and a set of BlockIds
--- to monitor. Updates to other BlockIds don't affect the ChangeFlag
-data TxFactBase n f
-  = TxFB { tfb_fbase :: FactBase f
-
-         , tfb_cha   :: ChangeFlag
-         , tfb_bids  :: BlockSet   -- Update change flag iff these blocks change
-                                   -- These are BlockIds of the *original* 
-                                   -- (not transformed) blocks
-
-         , tfb_blks  :: GraphWithFacts n f  -- Transformed blocks
-    }
-
-updateFact :: DataflowLattice f -> BlockSet
-           -> (BlockId, f)
-           -> (ChangeFlag, FactBase f) 
-           -> (ChangeFlag, FactBase f)
--- Update a TxFactBase, setting the change flag iff
---   a) the new fact adds information...
---   b) for a block in the BlockSet in the TxFactBase
-updateFact lat lbls (lbl, new_fact) (cha, fbase)
-  | NoChange <- cha2        = (cha,        fbase)
-  | lbl `elemBlockSet` lbls = (SomeChange, new_fbase)
-  | otherwise               = (cha,        new_fbase)
-  where
-    old_fact = lookupFact lat fbase lbl
-    (cha2, res_fact) = fact_extend lat old_fact new_fact
-    new_fbase = extendFactBase fbase lbl res_fact
-
-fixpoint :: forall n f. 
-            DataflowLattice f
-         -> (BlockId -> Block n C C -> FactBase f 
-                     -> FuelMonad ([(BlockId,f)], RL n f C))
-         -> [(BlockId, Block n C C)]
-         -> FactBase f 
-         -> FuelMonad (FactBase f, GraphWithFacts n f)
-fixpoint lat do_block blocks init_fbase
-  = do { fuel <- getFuel  
-       ; tx_fb <- loop fuel init_fbase
-       ; return (tfb_fbase tx_fb `deleteFromFactBase` blocks, tfb_blks tx_fb) }
-            -- The successors of the Graph are the the BlockIds for which
-            -- we have facts, that are *not* in the blocks of the graph
-  where
-    tx_blocks :: [(BlockId, Block n C C)] 
-              -> TxFactBase n f -> FuelMonad (TxFactBase n f)
-    tx_blocks []     tx_fb = return tx_fb
-    tx_blocks ((lbl,blk):bs) tx_fb = do { tx_fb1 <- tx_block lbl blk tx_fb
-                                        ; tx_blocks bs tx_fb1 }
-
-    tx_block :: BlockId -> Block n C C 
-             -> TxFactBase n f -> FuelMonad (TxFactBase n f)
-    tx_block lbl blk (TxFB { tfb_fbase = fbase, tfb_bids = lbls
-                           , tfb_blks = blks, tfb_cha = cha })
-      = do { (out_facts, rg) <- do_block lbl blk fbase
-           ; let (cha',fbase') = foldr (updateFact lat lbls) (cha,fbase) out_facts
-                 f = lookupFact lat fbase lbl
-               -- tfb_blks will be discarded unless we have 
-               -- reached a fixed point, so it doesn't matter
-               -- whether we get f from fbase or fbase'
-           ; return (TxFB { tfb_bids = extendBlockSet lbls lbl
-                          , tfb_blks = normRL rg `unionBWF` blks
-                          , tfb_fbase = fbase', tfb_cha = cha' }) }
-
-    loop :: Fuel -> FactBase f -> FuelMonad (TxFactBase n f)
-    loop fuel fbase 
-      = do { let init_tx_fb = TxFB { tfb_fbase = fbase
-                                   , tfb_cha   = NoChange
-                                   , tfb_blks  = noBWF
-                                   , tfb_bids  = emptyBlockSet }
-           ; tx_fb <- tx_blocks blocks init_tx_fb
-           ; case tfb_cha tx_fb of
-               NoChange   -> return tx_fb
-               SomeChange -> do { setFuel fuel; loop fuel (tfb_fbase tx_fb) } }
-
------------------------------------------------------------------------------
---             Transfer functions
------------------------------------------------------------------------------
-
--- Keys to the castle: a generic transfer function for each shape
--- Here's the idea: we start with single-n transfer functions,
--- move to basic-block transfer functions (we have exactly four shapes),
--- then finally to graph transfer functions (which requires iteration).
-
-type ARF thing n f = forall e x. f -> thing e x -> FuelMonad (TailFactF x f, RG n f e x)
-
-type ARF_Node  n f = ARF n         n f
-type ARF_Block n f = ARF (Block n) n f
-type ARF_Graph n f = ARF (Graph n) n f
------------------------------------------------------------------------------
-
-arfNodeNoRW :: forall n f. ForwardTransfer n f -> ARF_Node n f
- -- Lifts ForwardTransfer to ARF_Node; simple transfer only
-arfNodeNoRW transfer_fn f node
-  = return (transfer_fn f node, RGBlock (BUnit node))
-
-arfNode :: forall n f.
-           Edges n
-        => DataflowLattice f
-        -> ForwardTransfer n f
-        -> ForwardRewrite n f
-        -> ARF_Node n f
-        -> ARF_Node n f
--- Lifts (ForwardTransfer,ForwardRewrite) to ARF_Node; 
--- this time we do rewriting as well. 
--- The ARF_Graph parameters specifies what to do with the rewritten graph
-arfNode lattice transfer_fn rewrite_fn arf_node f node
-  = do { mb_g <- withFuel (rewrite_fn f node)
-       ; case mb_g of
-           Nothing -> arfNodeNoRW transfer_fn f node
-          Just ag -> do { g <- graphOfAGraph ag
-                        ; arfGraph lattice arf_node f g } }
-
-arfBlock :: forall n f. ARF_Node n f -> ARF_Block n f
--- Lift from nodes to blocks
-arfBlock arf_node f (BUnit node)   = arf_node f node
-arfBlock arf_node f (BCat hd mids) = do { (f1,g1) <- arfBlock arf_node f  hd
-                                        ; (f2,g2) <- arfBlock arf_node f1 mids
-                                       ; return (f2, g1 `RGCatO` g2) }
-
-arfBlocks :: forall n f. DataflowLattice f 
-          -> ARF_Node n f -> FactBase f -> BlockMap (Block n C C) 
-          -> FuelMonad (FactBase f, GraphWithFacts n f)
-               -- Outgoing factbase is restricted to BlockIds *not* in
-               -- in the Graph; the facts for BlockIds
-               -- *in* the Graph are in the GraphWithFacts
-arfBlocks lattice arf_node init_fbase blocks
-  = fixpoint lattice do_block 
-             (forwardBlockList (factBaseBlockIds init_fbase) blocks) 
-             init_fbase
-  where
-    do_block :: BlockId -> Block n C C -> FactBase f
-             -> FuelMonad ([(BlockId,f)], RL n f C)
-    do_block l blk fbase = do { let f = lookupFact lattice fbase l
-                              ; (fs, rg) <- arfBlock arf_node f blk
-                             ; return (fs, RL l f rg) }
-
-arfGraph :: forall n f. Edges n => DataflowLattice f -> ARF_Node n f -> ARF_Graph n f
--- Lift from blocks to graphs
-arfGraph _       _        f GNil        = return (f, RGNil)
-arfGraph _       arf_node f (GUnit blk) = arfBlock arf_node f blk
-arfGraph lattice arf_node f (GMany entry blks exit)
-  = do { (f1, entry') <- arf_entry f entry
-       ; (f2, blks')  <- arfBlocks lattice arf_node (mkFactBase f1) blks
-       ; (f3, exit')  <- arf_exit f2 exit 
-       ; return (f3, entry' `RGCatC` RLMany blks' `RGCatC` exit') }
-  where
-    arf_entry :: f -> IfOpen e (Block n O C)
-              -> FuelMonad ([(BlockId,f)], RG n f e C)
-    arf_entry fh IsNotOpen   = return ([], RGNil)
-    arf_entry fh (IsOpen b) = arfBlock arf_node fh b
-
-    arf_exit :: FactBase f -> IfOpen x (Block n C O)
-             -> FuelMonad (TailFactF x f, RL n f x)
-    arf_exit fb IsNotOpen    = return (factBaseList fb, RLMany noBWF)
-    arf_exit fb (IsOpen blk) = do { let ft = lookupFact lattice fb lt
-                                  ; (f1, rg) <- arfBlock arf_node ft blk
-                                  ; return (f1, RL lt ft rg) }
-      where IsClosed lt :: IfClosed C BlockId = closedId blk
-
-forwardBlockList :: [BlockId] -> BlockMap (Block n C C) -> [(BlockId,Block n C C)]
--- This produces a list of blocks in order suitable for forward analysis.
--- ToDo: Do a topological sort to improve convergence rate of fixpoint
---       This will require a (HavingSuccessors l) class constraint
-forwardBlockList  _ blks = blocksToList blks
-
-----------------------------------------------------------------
---       The pièce de resistance: cunning transfer functions
-----------------------------------------------------------------
-
-pureAnalysis :: Edges n => DataflowLattice f -> ForwardTransfer n f -> ARF_Graph n f
-pureAnalysis lattice f = arfGraph lattice (arfNodeNoRW f)
-
-analyseAndRewriteFwd
-   :: forall n f.
-      Edges n
-   => DataflowLattice f
-   -> ForwardTransfer n f
-   -> ForwardRewrite n f
-   -> RewritingDepth
-   -> FactBase f
-   -> BlockMap (Block n C C)
-   -> FuelMonad (BlockMap (Block n C C), FactBase f)
-
-data RewritingDepth = RewriteShallow | RewriteDeep
--- When a transformation proposes to rewrite a node, 
--- you can either ask the system to
---  * "shallow": accept the new graph, analyse it without further rewriting
---  * "deep": recursively analyse-and-rewrite the new graph
-
-analyseAndRewriteFwd lattice transfers rewrites depth facts graph
-  = do { (_, gwf) <- arfBlocks lattice arf_node facts graph
-       ; return gwf }
-  where 
-    arf_node, rec_node :: ARF_Node n f
-    arf_node = arfNode lattice transfers rewrites rec_node
-
-    rec_node = case depth of
-                RewriteShallow -> arfNodeNoRW transfers
-                RewriteDeep    -> arf_node
-
------------------------------------------------------------------------------
---             Backward rewriting
------------------------------------------------------------------------------
-
-type BackwardTransfer n f 
-  = forall e x. TailFactB x f -> n e x -> f 
-type BackwardRewrite n f 
-  = forall e x. TailFactB x f -> n e x -> Maybe (AGraph n e x)
-
-type ARB thing n f = forall e x. TailFactB x f -> thing e x
-                              -> FuelMonad (f, RG n f e x)
-
-type family   TailFactB x f :: *
-type instance TailFactB C f = FactBase f
-type instance TailFactB O f = f
-
-type ARB_Node  n f = ARB n         n f
-type ARB_Block n f = ARB (Block n) n f
-type ARB_Graph n f = ARB (Graph n) n f
-
-arbNodeNoRW :: forall n f . BackwardTransfer n f -> ARB_Node n f
--- Lifts BackwardTransfer to ARB_Node; simple transfer only
-arbNodeNoRW transfer_fn f node
-  = return (transfer_fn f node, RGBlock (BUnit node))
-
-arbNode :: forall n f.
-           Edges n
-        => DataflowLattice f
-        -> BackwardTransfer n f
-        -> BackwardRewrite n f
-        -> ARB_Node n f
-        -> ARB_Node n f
--- Lifts (BackwardTransfer,BackwardRewrite) to ARB_Node; 
--- this time we do rewriting as well. 
--- The ARB_Graph parameters specifies what to do with the rewritten graph
-arbNode lattice transfer_fn rewrite_fn arf_node f node
-  = do { mb_g <- withFuel (rewrite_fn f node)
-       ; case mb_g of
-           Nothing -> arbNodeNoRW transfer_fn f node
-          Just ag -> do { g <- graphOfAGraph ag
-                        ; arbGraph lattice arf_node f (closedId node) g } }
-
-arbBlock :: forall n f. ARB_Node n f -> ARB_Block n f
--- Lift from nodes to blocks
-arbBlock arb_node f (BUnit node) = arb_node f node
-arbBlock arb_node f (BCat b1 b2) = do { (f2,g2) <- arbBlock arb_node f  b2
-                                      ; (f1,g1) <- arbBlock arb_node f2 b1
-                                     ; return (f1, g1 `RGCatO` g2) }
-
-
-arbBlocks :: forall n f. DataflowLattice f 
-          -> ARB_Node n f -> FactBase f
-          -> BlockMap (Block n C C) -> FuelMonad (FactBase f, GraphWithFacts n f)
-arbBlocks lattice arb_node init_fbase blocks
-  = fixpoint lattice do_block 
-             (backwardBlockList (factBaseBlockIds init_fbase) blocks) 
-             init_fbase
-  where
-    do_block :: BlockId -> Block n C C -> FactBase f
-             -> FuelMonad ([(BlockId,f)], RL n f C)
-    do_block l b fbase = do { (fb, rg) <- arbBlock arb_node fbase b
-                           ; let f = lookupFact lattice fbase l
-                            ; return ([(l,fb)], RL l f rg) }
-
-arbGraph :: forall n f e x. 
-            Edges n
-         => DataflowLattice f
-         -> ARB_Node n f
-         -> TailFactB x f
-         -> IfClosed e BlockId
-         -> Graph n e x
-         -> FuelMonad (f, RG n f e x)
-arbGraph _       _        f _    GNil        = return (f, RGNil)
-arbGraph _       arb_node f _   (GUnit blk) = arbBlock arb_node f blk
-arbGraph lattice arb_node f eid (GMany entry blks exit)
-  = do { (f1, exit')  <- arb_exit f exit
-       ; (f2, blks')  <- arbBlocks lattice arb_node f1 blks
-       ; (f3, entry') <- arb_entry f2 eid entry 
-       ; return (f3, entry' `RGCatC` RLMany blks' `RGCatC` exit') }
-  where
-    arb_entry :: FactBase f -> IfClosed e BlockId -> IfOpen e (Block n O C) 
-              -> FuelMonad (f, RG n f e C)
-    arb_entry fbase (IsClosed eid) IsNotOpen = return (lookupFact lattice fbase eid,
-                                                       RGNil)
-    arb_entry fbase IsNotClosed (IsOpen blk) = arbBlock arb_node fbase blk
-
-    arb_exit :: TailFactB x f -> IfOpen x (Block n C O)
-             -> FuelMonad (FactBase f, RL n f x)
-    arb_exit ft IsNotOpen        = return (ft, RLMany noBWF)
-    arb_exit ft (IsOpen blk) = do { (f1, rg) <- arbBlock arb_node ft blk
-                                     ; return (mkFactBase [(lt,f1)], RL lt f1 rg) }
-      where IsClosed lt :: IfClosed C BlockId = closedId blk
-
-backwardBlockList :: [BlockId] -> BlockMap (Block n C C) -> [(BlockId,Block n C C)]
--- This produces a list of blocks in order suitable for backward analysis.
-backwardBlockList _ blks = blocksToList blks
-
-analyseAndRewriteBwd
-   :: forall n f.
-      Edges n
-   => DataflowLattice f
-   -> BackwardTransfer n f
-   -> BackwardRewrite n f
-   -> RewritingDepth
-   -> FactBase f
-   -> BlockMap (Block n C C)
-   -> FuelMonad (BlockMap (Block n C C), FactBase f)
-
-analyseAndRewriteBwd lattice transfers rewrites depth facts graph
-  = do { (_, gwf) <- arbBlocks lattice arb_node facts graph
-       ; return gwf }
-  where 
-    arb_node, rec_node :: ARB_Node n f
-    arb_node = arbNode lattice transfers rewrites rec_node
-
-    rec_node = case depth of
-                RewriteShallow -> arbNodeNoRW transfers
-                RewriteDeep    -> arb_node
-
------------------------------------------------------------------------------
---             The fuel monad
------------------------------------------------------------------------------
-
-type Uniques = Int
-type Fuel    = Int
-
-newtype FuelMonad a = FM { unFM :: Fuel -> Uniques -> (a, Fuel, Uniques) }
-
-instance Monad FuelMonad where
-  return x = FM (\f u -> (x,f,u))
-  m >>= k  = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u')
-
-withFuel :: Maybe a -> FuelMonad (Maybe a)
-withFuel Nothing  = return Nothing
-withFuel (Just r) = FM (\f u -> if f==0 then (Nothing, f, u)
-                                else (Just r, f-1, u))
-
-getFuel :: FuelMonad Fuel
-getFuel = FM (\f u -> (f,f,u))
-
-setFuel :: Fuel -> FuelMonad ()
-setFuel f = FM (\_ u -> ((), f, u))
-
-graphOfAGraph :: AGraph node e x -> FuelMonad (Graph node e x)
-graphOfAGraph = error "urk"    -- Stub
-
------------------------------------------------------------------------------
---             BlockId, FactBase, BlockSet
------------------------------------------------------------------------------
-
-type BlockId = Int
-
-mkBlockId :: Int -> BlockId
-mkBlockId uniq = uniq
-
-----------------------
-type BlockMap a = M.IntMap a
-
-noBlocks :: BlockMap (Block n C C)
-noBlocks = M.empty
-
-unitBlock :: BlockId -> Block n C C -> BlockMap (Block n C C)
-unitBlock = M.singleton
-
-addBlock :: BlockId -> Block n C C -> BlockMap (Block n C C) -> BlockMap (Block n C C)
-addBlock = M.insert
-
-unionBlocks :: BlockMap (Block n C C) -> BlockMap (Block n C C) -> BlockMap (Block n C C)
-unionBlocks = M.union
-
-blocksToList :: BlockMap (Block n C C) -> [(BlockId,Block n C C)]
-blocksToList = M.toList
-
-----------------------
-type FactBase a = M.IntMap a
-
-noFacts :: FactBase f
-noFacts = M.empty
-
-mkFactBase :: [(BlockId, f)] -> FactBase f
-mkFactBase prs = M.fromList prs
-
-unitFactBase :: BlockId -> f -> FactBase f
-unitFactBase = M.singleton
-
-lookupFact :: DataflowLattice f -> FactBase f -> BlockId -> f
-lookupFact lattice env blk_id 
-  = case M.lookup blk_id env of
-      Just f  -> f
-      Nothing -> fact_bot lattice
-
-extendFactBase :: FactBase f -> BlockId -> f -> FactBase f
-extendFactBase env blk_id f = M.insert blk_id f env
-
-unionFactBase :: FactBase f -> FactBase f -> FactBase f
-unionFactBase = M.union
-
-factBaseBlockIds :: FactBase f -> [BlockId]
-factBaseBlockIds = M.keys
-
-factBaseList :: FactBase f -> [(BlockId, f)]
-factBaseList = M.toList 
-
-deleteFromFactBase :: FactBase f -> [(BlockId,a)] -> FactBase f
-deleteFromFactBase fb blks = foldr (M.delete . fst) fb blks
-
-----------------------
-type BlockSet = S.IntSet
-
-emptyBlockSet :: BlockSet
-emptyBlockSet = S.empty
-
-extendBlockSet :: BlockSet -> BlockId -> BlockSet
-extendBlockSet bids bid = S.insert bid bids
-
-elemBlockSet :: BlockId -> BlockSet -> Bool
-elemBlockSet bid bids = S.member bid bids
-
-blockSetElems :: BlockSet -> [BlockId]
-blockSetElems = S.toList
-
-minusBlockSet :: BlockSet -> BlockSet -> BlockSet
-minusBlockSet = S.difference
-
-unionBlockSet :: BlockSet -> BlockSet -> BlockSet
-unionBlockSet = S.union
-
-mkBlockSet :: [BlockId] -> BlockSet
-mkBlockSet = S.fromList
-
-----------------------------------------------------------------
---
---   DROPPINGS follow...
---
-----------------------------------------------------------------
-{-
-
-data OCFlag oc where
-  IsOpen   :: OCFlag O
-  IsClosed :: OCFlag C
-
-class IsOC oc where
-  ocFlag :: OCFlag oc
-
-instance IsOC O where
-  ocFlag = IsOpen
-instance IsOC C where
-  ocFlag = IsClosed
-
-mkIfThenElse :: forall n x. IsOC x 
-             => (BlockId -> BlockId -> n O C)  -- The conditional branch instruction
-             -> (BlockId -> n C O)             -- Make a head node 
-            -> (BlockId -> n O C)              -- Make an unconditional branch
-            -> Graph n O x -> Graph n O x      -- Then and else branches
-            -> [BlockId]                       -- Block supply
-             -> Graph n O x                    -- The complete thing
-mkIfThenElse mk_cbranch mk_lbl mk_branch then_g else_g (tl:el:jl:_)
-  = case (ocFlag :: OCFlag x) of
-      IsOpen   -> gUnitOC (mk_cbranch tl el)
-                  `pCat` (mk_lbl_g tl `pCat` then_g `pCat` mk_branch_g jl)
-                  `pCat` (mk_lbl_g el `pCat` else_g `pCat` mk_branch_g jl)
-                  `pCat` (mk_lbl_g jl)
-      IsClosed -> gUnitOC (mk_cbranch tl el)
-                  `pCat` (mk_lbl_g tl `pCat` then_g)
-                  `pCat` (mk_lbl_g el `pCat` else_g)
-  where
-    mk_lbl_g :: BlockId -> Graph n C O
-    mk_lbl_g lbl = gUnitCO (mk_lbl lbl)
-    mk_branch_g :: BlockId -> Graph n O C
-    mk_branch_g lbl = gUnitOC (mk_branch lbl)
-
-gUnitCO :: n C O -> Graph n C O
-gUnitCO n = GMany (IsNotOpen) noBlocks (IsOpen (BUnit n))
-
-gUnitOC :: n O C -> Graph n O C
-gUnitOC n = GMany (IsOpen (BUnit n)) noBlocks IsNotOpen
--}
-
-
-
-bFilter :: forall n. (n O O -> Bool) -> Block n C C -> Block n C C
-bFilter keep (BUnit n)  = BUnit n
-bFilter keep (BCat h t) = bFilterH h (bFilterT t)
-  where
-    bFilterH :: Block n C O -> Block n O C -> Block n C C
-    bFilterH (BUnit n)    rest = BUnit n `BCat` rest
-    bFilterH (h `BCat` m) rest = bFilterH h (bFilterM m rest)
-
-    bFilterT :: Block n O C -> Block n O C
-    bFilterT (BUnit n)    = BUnit n
-    bFilterT (m `BCat` t) = bFilterM m (bFilterT t)
-
-    bFilterM :: Block n O O -> Block n O C -> Block n O C
-    bFilterM (BUnit n) rest | keep n    = BUnit n `BCat` rest
-                            | otherwise = rest 
-    bFilterM (b1 `BCat` b2) rest = bFilterM b1 (bFilterM b2 rest)
-
-
-pCat :: Edges n => Graph n e a -> Graph n a x -> Graph n e x
-pCat GNil g2 = g2
-pCat g1 GNil = g1
-
-pCat (GUnit b1) (GUnit b2)             
-  = GUnit (b1 `BCat` b2)
-
-pCat (GUnit b) (GMany (IsOpen e) bs x) 
-  = GMany (IsOpen (b `BCat` e)) bs x
-
-pCat (GMany e bs (IsOpen x)) (GUnit b2) 
-   = GMany e bs (IsOpen (x `BCat` b2))
-
-pCat (GMany e1 bs1 (IsOpen x1)) (GMany (IsOpen e2) bs2 x2)
-   = GMany e1 (add (x1 `BCat` e2) bs1 `unionBlocks` bs2) x2
-  where add b = addBlock id b
-          where IsClosed id :: IfClosed C BlockId = closedId b
-
-pCat (GMany e1 bs1 IsNotOpen) (GMany IsNotOpen bs2 x2)
-   = GMany e1 (bs1 `unionBlocks` bs2) x2
diff --git a/prototypes/Hoopl7.hs b/prototypes/Hoopl7.hs
deleted file mode 100644 (file)
index f8194fe..0000000
+++ /dev/null
@@ -1,692 +0,0 @@
-{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies #-}
-
-{- Notes about the genesis of Hoopl7
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Hoopl7 has the following major chages
-
-a) GMany has symmetric entry and exit
-b) GMany closed-entry does not record a BlockId
-c) GMany open-exit does not record a BlockId
-d) The body of a GMany is called Body
-e) A Body is just a list of blocks, not a map. I've argued
-   elsewhere that this is consistent with (c)
-
-A consequence is that Graph is no longer an instance of Edges,
-but nevertheless I managed to keep the ARF and ARB signatures
-nice and uniform.
-
-This was made possible by
-
-* ForwardTransfer looks like this:
-    type ForwardTransfer n f
-      = forall e x. n e x -> Fact e f -> Fact x f 
-    type family   Fact x f :: *
-    type instance Fact C f = FactBase f
-    type instance Fact O f = f
-
-  Note that the incoming fact is a Fact (not just 'f' as in Hoopl5,6).
-  It's up to the *transfer function* to look up the appropriate fact
-  in the FactBase for a closed-entry node.  Example:
-       constProp (Label l) fb = lookupFact fb l
-  That is how Hoopl can avoid having to know the block-id for the
-  first node: it defers to the client.
-
-  [Side note: that means the client must know about 
-  bottom, in case the looupFact returns Nothing]
-
-* Note also that ForwardTransfer *returns* a Fact too;
-  that is, the types in both directions are symmetrical.
-  Previously we returned a [(BlockId,f)] but I could not see
-  how to make everything line up if we do this.
-
-  Indeed, the main shortcoming of Hoopl7 is that we are more
-  or less forced into this uniform representation of the facts
-  flowing into or out of a closed node/block/graph, whereas
-  previously we had more flexibility.
-
-  In exchange the code is neater, with fewer distinct types.
-  And morally a FactBase is equivalent to [(BlockId,f)] and
-  nearly equivalent to (BlockId -> f).
-
-* I've realised that forwardBlockList and backwardBlockList
-  both need (Edges n), and that goes everywhere.
-
-* I renamed BlockId to Label
--}
-
-module Hoopl7 where
-
-import qualified Data.IntMap as M
-import qualified Data.IntSet as S
-
------------------------------------------------------------------------------
---             Graphs
------------------------------------------------------------------------------
-
-data O
-data C
-
--- Blocks are always non-empty
-data Block n e x where
-  BUnit :: n e x -> Block n e x
-  BCat  :: Block n e O -> Block n O x -> Block n e x
-
-data Body n where
-  BodyEmpty :: Body n
-  BodyUnit  :: Block n C C -> Body n
-  BodyCat   :: Body n -> Body n -> Body n
-
-data Graph n e x where
-  GNil  :: Graph n O O
-  GUnit :: Block n O O -> Graph n O O
-  GMany :: MaybeO e (Block n O C) 
-        -> Body n
-        -> MaybeO x (Block n C O)
-        -> Graph n e x
-
-data MaybeO ex t where
-  JustO    :: t -> MaybeO O t
-  NothingO ::      MaybeO C t
-
--------------------------------
-class Edges thing where
-  entryLabel :: thing C x -> Label
-  successors :: thing e C -> [Label]
-
-instance Edges n => Edges (Block n) where
-  entryLabel (BUnit n) = entryLabel n
-  entryLabel (b `BCat` _) = entryLabel b
-  successors (BUnit n)   = successors n
-  successors (BCat _ b)  = successors b
-
-------------------------------
-addBlock :: Block n C C -> Body n -> Body n
-addBlock b body = BodyUnit b `BodyCat` body
-
-bodyList :: Edges n => Body n -> [(Label,Block n C C)]
-bodyList body = go body []
-  where
-    go BodyEmpty       bs = bs
-    go (BodyUnit b)    bs = (entryLabel b, b) : bs
-    go (BodyCat b1 b2) bs = go b1 (go b2 bs)
-
------------------------------------------------------------------------------
---             Defined here but not used
------------------------------------------------------------------------------
-
--- Singletons
---   OO   GUnit
---   CO   GMany (NothingO l) [] (JustO b)
---   OC   GMany (JustO b)   []  NothingO
---   CC   GMany (NothingO l) [b] NothingO
-
-gCat :: Graph n e a -> Graph n a x -> Graph n e x
-gCat GNil g2 = g2
-gCat g1 GNil = g1
-
-gCat (GUnit b1) (GUnit b2)             
-  = GUnit (b1 `BCat` b2)
-
-gCat (GUnit b) (GMany (JustO e) bs x) 
-  = GMany (JustO (b `BCat` e)) bs x
-
-gCat (GMany e bs (JustO x)) (GUnit b2) 
-   = GMany e bs (JustO (x `BCat` b2))
-
-gCat (GMany e1 bs1 (JustO x1)) (GMany (JustO e2) bs2 x2)
-   = GMany e1 (addBlock (x1 `BCat` e2) bs1 `BodyCat` bs2) x2
-
-gCat (GMany e1 bs1 NothingO) (GMany NothingO bs2 x2)
-   = GMany e1 (bs1 `BodyCat` bs2) x2
-
-
-
-------------------------------
------------------------------------------------------------------------------
---     RG: an internal data type for graphs under construction
---          TOTALLY internal to Hoopl
------------------------------------------------------------------------------
-
-data RG n f e x where
-  RGNil   :: RG n f a a
-  RGUnit  :: Fact e f -> Block n e x -> RG n f e x
-  RGCatO  :: RG n f e O -> RG n f O x -> RG n f e x
-  RGCatC  :: RG n f e C -> RG n f C x -> RG n f e x
-
-type BodyWithFacts  n f     = (Body n, FactBase f)
-type GraphWithFacts n f e x = (Graph n e x, FactBase f)
-  -- A Graph together with the facts for that graph
-  -- The domains of the two maps should be identical
-
-normaliseBody :: Edges n => RG n f C C -> BodyWithFacts n f
-normaliseBody rg = (body, fact_base)
-  where
-    (GMany _ body _, fact_base) = normCC rg
-
-normOO :: Edges n => RG n f O O -> GraphWithFacts n f O O
-normOO RGNil          = (GNil, noFacts)
-normOO (RGUnit _ b)   = (GUnit b, noFacts)
-normOO (RGCatO g1 g2) = normOO g1 `gwfCat` normOO g2
-normOO (RGCatC g1 g2) = normOC g1 `gwfCat` normCO g2
-
-normOC :: Edges n => RG n f O C -> GraphWithFacts n f O C
-normOC (RGUnit _ b)   = (GMany (JustO b) BodyEmpty NothingO, noFacts)
-normOC (RGCatO g1 g2) = normOO g1 `gwfCat` normOC g2
-normOC (RGCatC g1 g2) = normOC g1 `gwfCat` normCC g2
-
-normCO :: Edges n => RG n f C O -> GraphWithFacts n f C O
-normCO (RGUnit f b) = (GMany NothingO BodyEmpty (JustO b), unitFact l f)
-                    where
-                      l = entryLabel b
-normCO (RGCatO g1 g2) = normCO g1 `gwfCat` normOO g2
-normCO (RGCatC g1 g2) = normCC g1 `gwfCat` normCO g2
-
-normCC :: Edges n => RG n f C C -> GraphWithFacts n f C C
-normCC RGNil        = (GMany NothingO BodyEmpty NothingO, noFacts)
-normCC (RGUnit f b) = (GMany NothingO (BodyUnit b) NothingO, unitFact l f)
-                    where
-                      l = entryLabel b
-normCC (RGCatO g1 g2) = normCO g1 `gwfCat` normOC g2
-normCC (RGCatC g1 g2) = normCC g1 `gwfCat` normCC g2
-
-gwfCat :: Edges n => GraphWithFacts n f e a
-                  -> GraphWithFacts n f a x 
-                  -> GraphWithFacts n f e x
-gwfCat (g1, fb1) (g2, fb2) = (g1 `gCat` g2, fb1 `unionFactBase` fb2)
-
-bwfUnion :: BodyWithFacts n f -> BodyWithFacts n f -> BodyWithFacts n f
-bwfUnion (bg1, fb1) (bg2, fb2) = (bg1 `BodyCat` bg2, fb1 `unionFactBase` fb2)
-
------------------------------------------------------------------------------
---             DataflowLattice
------------------------------------------------------------------------------
-
-data DataflowLattice a = DataflowLattice  { 
-  fact_name       :: String,                   -- Documentation
-  fact_bot        :: a,                        -- Lattice bottom element
-  fact_extend     :: a -> a -> (ChangeFlag,a), -- Lattice join plus change flag
-  fact_do_logging :: Bool                      -- log changes
-}
-
-data ChangeFlag = NoChange | SomeChange
-
------------------------------------------------------------------------------
---             Analyse and rewrite forward
------------------------------------------------------------------------------
-
-data ForwardPass n f
-  = FwdPass { fp_lattice  :: DataflowLattice f
-            , fp_transfer :: FwdTransfer n f
-            , fp_rewrite  :: FwdRewrite n f }
-
-type FwdTransfer n f 
-  = forall e x. n e x -> Fact e f -> Fact x f 
-
-type FwdRewrite n f 
-  = forall e x. n e x -> Fact e f -> Maybe (FwdRes n f e x)
-data FwdRes n f e x = FwdRes (AGraph n e x) (FwdRewrite n f)
-
-type family   Fact x f :: *
-type instance Fact C f = FactBase f
-type instance Fact O f = f
-
-type ARF thing n 
-  = forall f e x. ForwardPass n f -> thing e x 
-               -> Fact e f -> FuelMonad (RG n f e x, Fact x f)
-
-type SimpleFwdRewrite n f 
-  = forall e x. n e x -> Fact e f
-             -> Maybe (AGraph n e x)
-
-noFwdRewrite :: FwdRewrite n f
-noFwdRewrite _ _ = Nothing
-
-shallowFwdRw :: SimpleFwdRewrite n f -> FwdRewrite n f
-shallowFwdRw rw n f = case (rw n f) of
-                         Nothing -> Nothing
-                         Just ag -> Just (FwdRes ag noFwdRewrite)
-
-thenFwdRw :: FwdRewrite n f -> FwdRewrite n f -> FwdRewrite n f
-thenFwdRw rw1 rw2 n f
-  = case rw1 n f of
-      Nothing               -> rw2 n f
-      Just (FwdRes ag rw1a) -> Just (FwdRes ag (rw1a `thenFwdRw` rw2))
-
-deepFwdRw :: FwdRewrite n f -> FwdRewrite n f
-deepFwdRw rw = rw `thenFwdRw` deepFwdRw rw
-
-
-
------------------------------------------------------------------------------
-
-arfNode :: Edges n => ARF n n
-arfNode pass node f
-  = do { mb_g <- withFuel (fp_rewrite pass node f)
-       ; case mb_g of
-           Nothing -> return (RGUnit f (BUnit node),
-                              fp_transfer pass node f)
-          Just (FwdRes ag rw) -> do { g <- graphOfAGraph ag
-                                     ; let pass' = pass { fp_rewrite = rw }
-                                     ; arfGraph pass' g f } }
-
-arfBlock :: Edges n => ARF (Block n) n
--- Lift from nodes to blocks
-arfBlock pass (BUnit node)   f = arfNode pass node f
-arfBlock pass (BCat hd mids) f = do { (g1,f1) <- arfBlock pass hd   f  
-                                    ; (g2,f2) <- arfBlock pass mids f1 
-                                   ; return (g1 `RGCatO` g2, f2) }
-
-arfBody :: Edges n
-        => ForwardPass n f -> Body n -> FactBase f
-        -> FuelMonad (RG n f C C, FactBase f)
-               -- Outgoing factbase is restricted to Labels *not* in
-               -- in the Body; the facts for Labels
-               -- *in* the Body are in the BodyWithFacts
-arfBody pass blocks init_fbase
-  = fixpoint True (fp_lattice pass) (arfBlock pass) init_fbase $
-    forwardBlockList (factBaseLabels init_fbase) blocks
-
-arfGraph :: Edges n => ARF (Graph n) n
--- Lift from blocks to graphs
-arfGraph _    GNil        f = return (RGNil, f)
-arfGraph pass (GUnit blk) f = arfBlock pass blk f
-arfGraph pass (GMany NothingO body NothingO) f
-  = do { (body', fb) <- arfBody pass body f
-       ; return (body', fb) }
-arfGraph pass (GMany NothingO body (JustO exit)) f
-  = do { (body', fb) <- arfBody  pass body f
-       ; (exit', fx) <- arfBlock pass exit fb
-       ; return (body' `RGCatC` exit', fx) }
-arfGraph pass (GMany (JustO entry) body NothingO) f
-  = do { (entry', fe) <- arfBlock pass entry f
-       ; (body', fb)  <- arfBody  pass body fe
-       ; return (entry' `RGCatC` body', fb) }
-arfGraph pass (GMany (JustO entry) body (JustO exit)) f
-  = do { (entry', fe) <- arfBlock pass entry f
-       ; (body', fb)  <- arfBody  pass body fe
-       ; (exit', fx)  <- arfBlock pass exit fb
-       ; return (entry' `RGCatC` body' `RGCatC` exit', fx) }
-
-forwardBlockList :: Edges n => [Label] -> Body n -> [(Label,Block n C C)]
--- This produces a list of blocks in order suitable for forward analysis.
--- ToDo: Do a topological sort to improve convergence rate of fixpoint
---       This will require a (HavingSuccessors l) class constraint
-forwardBlockList  _ blks = bodyList blks
-
-----------------------------------------------------------------
---       The pièce de resistance: cunning transfer functions
-----------------------------------------------------------------
-
-analyseAndRewriteFwd
-   :: forall n f. Edges n
-   => ForwardPass n f
-   -> Body n -> FactBase f
-   -> FuelMonad (Body n, FactBase f)
-
-analyseAndRewriteFwd pass body facts
-  = do { (rg, _) <- arfBody pass body facts
-       ; return (normaliseBody rg) }
-
------------------------------------------------------------------------------
---             Backward rewriting
------------------------------------------------------------------------------
-
-data BackwardPass n f
-  = BwdPass { bp_lattice  :: DataflowLattice f
-            , bp_transfer :: BwdTransfer n f
-            , bp_rewrite  :: BwdRewrite n f }
-
-type BwdTransfer n f 
-  = forall e x. n e x -> Fact x f -> Fact e f 
-type BwdRewrite n f 
-  = forall e x. n e x -> Fact x f -> Maybe (BwdRes n f e x)
-data BwdRes n f e x = BwdRes (AGraph n e x) (BwdRewrite n f)
-
-type ARB thing n 
-  = forall f e x. BackwardPass n f -> thing e x
-               -> Fact x f -> FuelMonad (RG n f e x, Fact e f)
-
-arbNode :: Edges n => ARB n n
--- Lifts (BwdTransfer,BwdRewrite) to ARB_Node; 
--- this time we do rewriting as well. 
--- The ARB_Graph parameters specifies what to do with the rewritten graph
-arbNode pass node f
-  = do { mb_g <- withFuel (bp_rewrite pass node f)
-       ; case mb_g of
-           Nothing -> return (RGUnit entry_f (BUnit node), entry_f)
-                    where
-                      entry_f = bp_transfer pass node f
-          Just (BwdRes ag rw) -> do { g <- graphOfAGraph ag
-                                     ; let pass' = pass { bp_rewrite = rw }
-                                     ; arbGraph pass' g f} }
-
-arbBlock :: Edges n => ARB (Block n) n 
--- Lift from nodes to blocks
-arbBlock pass (BUnit node) f = arbNode pass node f
-arbBlock pass (BCat b1 b2) f = do { (g2,f2) <- arbBlock pass b2 f
-                                  ; (g1,f1) <- arbBlock pass b1 f2
-                                 ; return (g1 `RGCatO` g2, f1) }
-
-arbBody :: Edges n
-        => BackwardPass n f -> Body n -> FactBase f
-        -> FuelMonad (RG n f C C, FactBase f)
-arbBody pass blocks init_fbase
-  = fixpoint False (bp_lattice pass) (arbBlock pass) init_fbase $
-    backwardBlockList (factBaseLabels init_fbase) blocks 
-
-arbGraph :: Edges n => ARB (Graph n) n
-arbGraph _    GNil        f = return (RGNil, f)
-arbGraph pass (GUnit blk) f = arbBlock pass blk f
-arbGraph pass (GMany NothingO body NothingO) f
-  = do { (body', fb) <- arbBody pass body f
-       ; return (body', fb) }
-arbGraph pass (GMany NothingO body (JustO exit)) f
-  = do { (exit', fx) <- arbBlock pass exit f
-       ; (body', fb) <- arbBody  pass body fx
-       ; return (body' `RGCatC` exit', fb) }
-arbGraph pass (GMany (JustO entry) body NothingO) f
-  = do { (body', fb)  <- arbBody  pass body f
-       ; (entry', fe) <- arbBlock pass entry fb
-       ; return (entry' `RGCatC` body', fe) }
-arbGraph pass (GMany (JustO entry) body (JustO exit)) f
-  = do { (exit', fx)  <- arbBlock pass exit f
-       ; (body', fb)  <- arbBody  pass body fx
-       ; (entry', fe) <- arbBlock pass entry fb
-       ; return (entry' `RGCatC` body' `RGCatC` exit', fe) }
-
-backwardBlockList :: Edges n => [Label] -> Body n -> [(Label,Block n C C)]
--- This produces a list of blocks in order suitable for backward analysis.
-backwardBlockList _ blks = bodyList blks
-
-analyseAndRewriteBwd
-   :: forall n f. Edges n
-   => BackwardPass n f 
-   -> Body n -> FactBase f 
-   -> FuelMonad (Body n, FactBase f)
-
-analyseAndRewriteBwd pass body facts
-  = do { (rg, _) <- arbBody pass body facts
-       ; return (normaliseBody rg) }
-
-
------------------------------------------------------------------------------
---      fixpoint: finding fixed points
------------------------------------------------------------------------------
-
-data TxFactBase n f
-  = TxFB { tfb_fbase :: FactBase f
-         , tfb_rg  :: RG n f C C -- Transformed blocks
-         , tfb_cha   :: ChangeFlag
-         , tfb_lbls  :: LabelSet }
- -- Note [TxFactBase change flag]
- -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- -- Set the tfb_cha flag iff 
- --   (a) the fact in tfb_fbase for or a block L changes
- --   (b) L is in tfb_lbls.
- -- The tfb_lbls are all Labels of the *original* 
- -- (not transformed) blocks
-
-updateFact :: DataflowLattice f -> LabelSet -> (Label, f)
-           -> (ChangeFlag, FactBase f) 
-           -> (ChangeFlag, FactBase f)
--- See Note [TxFactBase change flag]
-updateFact lat lbls (lbl, new_fact) (cha, fbase)
-  | NoChange <- cha2        = (cha,        fbase)
-  | lbl `elemLabelSet` lbls = (SomeChange, new_fbase)
-  | otherwise               = (cha,        new_fbase)
-  where
-    (cha2, res_fact) 
-       = case lookupFact fbase lbl of
-           Nothing -> (SomeChange, new_fact)  -- Note [Unreachable blocks]
-           Just old_fact -> fact_extend lat old_fact new_fact
-    new_fbase = extendFactBase fbase lbl res_fact
-
-fixpoint :: forall n f. Edges n
-         => Bool       -- Going forwards?
-         -> DataflowLattice f
-         -> (Block n C C -> FactBase f
-              -> FuelMonad (RG n f C C, FactBase f))
-         -> FactBase f -> [(Label, Block n C C)]
-         -> FuelMonad (RG n f C C, FactBase f)
-fixpoint is_fwd lat do_block init_fbase blocks
-  = do { fuel <- getFuel  
-       ; tx_fb <- loop fuel init_fbase
-       ; return (tfb_rg tx_fb, 
-                 tfb_fbase tx_fb `delFromFactBase` blocks) }
-            -- The successors of the Graph are the the Labels for which
-            -- we have facts, that are *not* in the blocks of the graph
-  where
-    tx_blocks :: [(Label, Block n C C)] 
-              -> TxFactBase n f -> FuelMonad (TxFactBase n f)
-    tx_blocks []             tx_fb = return tx_fb
-    tx_blocks ((lbl,blk):bs) tx_fb = tx_block lbl blk tx_fb >>= tx_blocks bs
-
-    tx_block :: Label -> Block n C C 
-             -> TxFactBase n f -> FuelMonad (TxFactBase n f)
-    tx_block lbl blk tx_fb@(TxFB { tfb_fbase = fbase, tfb_lbls = lbls
-                                 , tfb_rg = blks, tfb_cha = cha })
-      | is_fwd && not (lbl `elemFactBase` fbase)
-      = return tx_fb   -- Note [Unreachable blocks]
-      | otherwise
-      = do { (rg, out_facts) <- do_block blk fbase
-           ; let (cha',fbase') 
-                   = foldr (updateFact lat lbls) (cha,fbase) 
-                           (factBaseList out_facts)
-           ; return (TxFB { tfb_lbls  = extendLabelSet lbls lbl
-                          , tfb_rg  = rg `RGCatC` blks
-                          , tfb_fbase = fbase', tfb_cha = cha' }) }
-
-    loop :: Fuel -> FactBase f -> FuelMonad (TxFactBase n f)
-    loop fuel fbase 
-      = do { let init_tx_fb = TxFB { tfb_fbase = fbase
-                                   , tfb_cha   = NoChange
-                                   , tfb_rg  = RGNil
-                                   , tfb_lbls  = emptyLabelSet }
-           ; tx_fb <- tx_blocks blocks init_tx_fb
-           ; case tfb_cha tx_fb of
-               NoChange   -> return tx_fb
-               SomeChange -> do { setFuel fuel
-                                ; loop fuel (tfb_fbase tx_fb) } }
-
-{- Note [Unreachable blocks]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A block that is not in the domain of tfb_fbase is "currently unreachable".
-A currently-unreachable block is not even analysed.  Reason: consider 
-constant prop and this graph, with entry point L1:
-  L1: x:=3; goto L4
-  L2: x:=4; goto L4
-  L4: if x>3 goto L2 else goto L5
-Here L2 is actually unreachable, but if we process it with bottom input fact,
-we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.
-
-* If a currently-unreachable block is not analysed, then its rewritten
-  graph will not be accumulated in tfb_rg.  And that is good:
-  unreachable blocks simply do not appear in the output.
-
-* Note that clients must be careful to provide a fact (even if bottom)
-  for each entry point. Otherwise useful blocks may be garbage collected.
-
-* Note that updateFact must set the change-flag if a label goes from
-  not-in-fbase to in-fbase, even if its fact is bottom.  In effect the
-  real fact lattice is
-       UNR
-       bottom
-       the points above bottom
-
-* All of this only applies for *forward* fixpoints.  For the backward
-  case we must treat every block as reachable; it might finish with a
-  'return', and therefore have no successors, for example.
--}
-
-
------------------------------------------------------------------------------
---             The fuel monad
------------------------------------------------------------------------------
-
-type Uniques = Int
-type Fuel    = Int
-
-newtype FuelMonad a = FM { unFM :: Fuel -> [Label] -> (a, Fuel, [Label]) }
-
-instance Monad FuelMonad where
-  return x = FM (\f u -> (x,f,u))
-  m >>= k  = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u')
-
-withFuel :: Maybe a -> FuelMonad (Maybe a)
-withFuel Nothing  = return Nothing
-withFuel (Just r) = FM (\f u -> if f==0 then (Nothing, f, u)
-                                else (Just r, f-1, u))
-
-getFuel :: FuelMonad Fuel
-getFuel = FM (\f u -> (f,f,u))
-
-setFuel :: Fuel -> FuelMonad ()
-setFuel f = FM (\_ u -> ((), f, u))
-
-graphOfAGraph :: AGraph node e x -> FuelMonad (Graph node e x)
-graphOfAGraph ag = FM (\f ls -> let (g,ls') = ag ls
-                                in (g, f, ls'))
-
------------------------------------------------------------------------------
---             Label, FactBase, LabelSet
------------------------------------------------------------------------------
-
-type Label = Int
-
-mkLabel :: Int -> Label
-mkLabel uniq = uniq
-
-----------------------
-type LabelMap a = M.IntMap a
-
-----------------------
-type FactBase a = M.IntMap a
-
-noFacts :: FactBase f
-noFacts = M.empty
-
-mkFactBase :: [(Label, f)] -> FactBase f
-mkFactBase prs = M.fromList prs
-
-unitFact :: Label -> FactBase f -> FactBase f
--- Restrict a fact base to a single fact
-unitFact l fb = case M.lookup l fb of
-                  Just f  -> M.singleton l f
-                  Nothing -> M.empty
-
-lookupFact :: FactBase f -> Label -> Maybe f
-lookupFact env blk_id = M.lookup blk_id env
-
-extendFactBase :: FactBase f -> Label -> f -> FactBase f
-extendFactBase env blk_id f = M.insert blk_id f env
-
-unionFactBase :: FactBase f -> FactBase f -> FactBase f
-unionFactBase = M.union
-
-elemFactBase :: Label -> FactBase f -> Bool
-elemFactBase = M.member
-
-factBaseLabels :: FactBase f -> [Label]
-factBaseLabels = M.keys
-
-factBaseList :: FactBase f -> [(Label, f)]
-factBaseList = M.toList 
-
-delFromFactBase :: FactBase f -> [(Label,a)] -> FactBase f
-delFromFactBase fb blks = foldr (M.delete . fst) fb blks
-
-----------------------
-type LabelSet = S.IntSet
-
-emptyLabelSet :: LabelSet
-emptyLabelSet = S.empty
-
-extendLabelSet :: LabelSet -> Label -> LabelSet
-extendLabelSet lbls bid = S.insert bid lbls
-
-elemLabelSet :: Label -> LabelSet -> Bool
-elemLabelSet bid lbls = S.member bid lbls
-
-blockSetElems :: LabelSet -> [Label]
-blockSetElems = S.toList
-
-minusLabelSet :: LabelSet -> LabelSet -> LabelSet
-minusLabelSet = S.difference
-
-unionLabelSet :: LabelSet -> LabelSet -> LabelSet
-unionLabelSet = S.union
-
-mkLabelSet :: [Label] -> LabelSet
-mkLabelSet = S.fromList
-
-----------------------------------------------------------------
---
--- Irrelevant distractions follow
-
-{-
-
-data OCFlag oc where
-  IsOpen   :: OCFlag O
-  IsClosed :: OCFlag C
-
-class IsOC oc where
-  ocFlag :: OCFlag oc
-
-instance IsOC O where
-  ocFlag = IsOpen
-instance IsOC C where
-  ocFlag = IsClosed
-
-mkIfThenElse :: forall n x. (Edges n, IsOC x)
-             => (Label -> Label -> n O C)      -- The conditional branch instruction
-             -> (Label -> n C O)               -- Make a head node 
-            -> (Label -> n O C)                -- Make an unconditional branch
-            -> Graph n O x -> Graph n O x      -- Then and else branches
-            -> [Label]                 -- Block supply
-             -> Graph n O x                    -- The complete thing
-mkIfThenElse mk_cbranch mk_lbl mk_branch then_g else_g (tl:el:jl:_)
-  = case (ocFlag :: OCFlag x) of
-      IsOpen   -> gUnitOC (mk_cbranch tl el)
-                  `gCat` (mk_lbl_g tl `gCat` then_g `gCat` mk_branch_g jl)
-                  `gCat` (mk_lbl_g el `gCat` else_g `gCat` mk_branch_g jl)
-                  `gCat` (mk_lbl_g jl)
-      IsClosed -> gUnitOC (mk_cbranch tl el)
-                  `gCat` (mk_lbl_g tl `gCat` then_g)
-                  `gCat` (mk_lbl_g el `gCat` else_g)
-  where
-    mk_lbl_g :: Label -> Graph n C O
-    mk_lbl_g lbl = gUnitCO (mk_lbl lbl)
-    mk_branch_g :: Label -> Graph n O C
-    mk_branch_g lbl = gUnitOC (mk_branch lbl)
--}
-
-type AGraph n e x = [Label] -> (Graph n e x, [Label])
-
-withLabels :: Int -> ([Label] -> AGraph n e x)
-           -> AGraph n e x
-withLabels n fn = \ls -> fn (take n ls) (drop n ls)
-
-
-gUnitCO :: n C O -> Graph n C O
-gUnitCO n = GMany NothingO BodyEmpty (JustO (BUnit n))
-
-gUnitOC :: n O C -> Graph n O C
-gUnitOC n = GMany (JustO (BUnit n)) BodyEmpty NothingO
-
-
-bFilter :: forall n. (n O O -> Bool) -> Block n C C -> Block n C C
-bFilter keep (BUnit n)  = BUnit n
-bFilter keep (BCat h t) = bFilterH h (bFilterT t)
-  where
-    bFilterH :: Block n C O -> Block n O C -> Block n C C
-    bFilterH (BUnit n)    rest = BUnit n `BCat` rest
-    bFilterH (h `BCat` m) rest = bFilterH h (bFilterM m rest)
-
-    bFilterT :: Block n O C -> Block n O C
-    bFilterT (BUnit n)    = BUnit n
-    bFilterT (m `BCat` t) = bFilterM m (bFilterT t)
-
-    bFilterM :: Block n O O -> Block n O C -> Block n O C
-    bFilterM (BUnit n) rest | keep n    = BUnit n `BCat` rest
-                            | otherwise = rest 
-    bFilterM (b1 `BCat` b2) rest = bFilterM b1 (bFilterM b2 rest)
diff --git a/prototypes/RG.hs b/prototypes/RG.hs
deleted file mode 100644 (file)
index d2b03d4..0000000
+++ /dev/null
@@ -1,21 +0,0 @@
-{-# LANGUAGE GADTs #-}
-
-module RG
-where
-
-import Data.Maybe
-
-import Compiler.Hoopl
-
--------------------------------------------------------------
--- noodling around
-
-data MaybeC ex t where
-  JustC    :: t -> MaybeC C t
-  NothingC ::      MaybeC O t
-
-data ReplacementGraph n e x = Replacement (MaybeC e Label) (Graph n e x)
-
-theFact :: Fact e f -> MaybeC e Label -> f
-theFact f NothingC = f
-theFact fb (JustC l) = fromJust $ lookupFact fb l
diff --git a/prototypes/Zipper.hs b/prototypes/Zipper.hs
deleted file mode 100644 (file)
index acd529c..0000000
+++ /dev/null
@@ -1,90 +0,0 @@
-{-# LANGUAGE GADTs #-}
-
-module Compiler.Hoopl.Zipper
-  ( ZBlock(..), ZGraph, ZBody
-  , frontBiasBlock, backBiasBlock
-  )
-where
-
-import Compiler.Hoopl.Graph
-
-data ZBlock n e x where
-  -- nodes
-  ZFirst  :: n C O                 -> ZBlock n C O
-  ZMiddle :: n O O                 -> ZBlock n O O
-  ZLast   :: n O C                 -> ZBlock n O C
-
-  -- concatenation operations
-  ZCat    :: ZBlock n O O -> ZBlock n O O -> ZBlock n O O -- non-list-like
-  ZHead   :: ZBlock n C O -> n O O        -> ZBlock n C O
-  ZTail   :: n O O        -> ZBlock n O C -> ZBlock n O C  
-
-  ZClosed :: ZBlock n C O -> ZBlock n O C -> ZBlock n C C -- the zipper
-
-type ZGraph = Graph' ZBlock
-type ZBody  = Body'  ZBlock
-
-instance Edges n => Edges (ZBlock n) where
-  entryLabel (ZFirst n)    = entryLabel n
-  entryLabel (ZHead h _)   = entryLabel h
-  entryLabel (ZClosed h _) = entryLabel h
-  successors (ZLast n)     = successors n
-  successors (ZTail _ t)   = successors t
-  successors (ZClosed _ t) = successors t
-
-
-----------------------------------------------------------------
-
--- | A block is "front biased" if the left child of every
--- concatenation operation is a node, not a general block; a
--- front-biased block is analogous to an ordinary list.  If a block is
--- front-biased, then its nodes can be traversed from front to back
--- without general recusion; tail recursion suffices.  Not all shapes
--- can be front-biased; a closed/open block is inherently back-biased.
-
-frontBiasBlock :: ZBlock n e x -> ZBlock n e x
-frontBiasBlock b@(ZFirst  {}) = b
-frontBiasBlock b@(ZMiddle {}) = b
-frontBiasBlock b@(ZLast   {}) = b
-frontBiasBlock b@(ZCat {}) = rotate b
-  where -- rotate and append ensure every left child of ZCat is ZMiddle
-        -- provided 2nd argument to append already has this property
-    rotate :: ZBlock n O O -> ZBlock n O O
-    append :: ZBlock n O O -> ZBlock n O O -> ZBlock n O O
-    rotate (ZCat h t)     = append h (rotate t)
-    rotate b@(ZMiddle {}) = b
-    append b@(ZMiddle {}) t = b `ZCat` t
-    append (ZCat b1 b2) b3 = b1 `append` (b2 `append` b3)
-frontBiasBlock b@(ZHead {}) = b -- back-biased by nature; cannot fix
-frontBiasBlock b@(ZTail {}) = b -- statically front-biased
-frontBiasBlock (ZClosed h t) = shiftRight h t
-    where shiftRight :: ZBlock n C O -> ZBlock n O C -> ZBlock n C C
-          shiftRight (ZHead b1 b2) b3 = shiftRight b1 (ZTail b2 b3)
-          shiftRight b1@(ZFirst {}) b2 = ZClosed b1 b2
-
--- | A block is "back biased" if the right child of every
--- concatenation operation is a node, not a general block; a
--- back-biased block is analogous to a snoc-list.  If a block is
--- back-biased, then its nodes can be traversed from back to back
--- without general recusion; tail recursion suffices.  Not all shapes
--- can be back-biased; an open/closed block is inherently front-biased.
-
-backBiasBlock :: ZBlock n e x -> ZBlock n e x
-backBiasBlock b@(ZFirst  {}) = b
-backBiasBlock b@(ZMiddle {}) = b
-backBiasBlock b@(ZLast   {}) = b
-backBiasBlock b@(ZCat {}) = rotate b
-  where -- rotate and append ensure every right child of ZCat is ZMiddle
-        -- provided 1st argument to append already has this property
-    rotate :: ZBlock n O O -> ZBlock n O O
-    append :: ZBlock n O O -> ZBlock n O O -> ZBlock n O O
-    rotate (ZCat h t)     = append (rotate h) t
-    rotate b@(ZMiddle {}) = b
-    append h b@(ZMiddle {}) = h `ZCat` b
-    append b1 (ZCat b2 b3) = (b1 `append` b2) `append` b3
-backBiasBlock b@(ZHead {}) = b -- statically back-biased
-backBiasBlock b@(ZTail {}) = b -- front-biased by nature; cannot fix
-backBiasBlock (ZClosed h t) = shiftLeft h t
-    where shiftLeft :: ZBlock n C O -> ZBlock n O C -> ZBlock n C C
-          shiftLeft b1 (ZTail b2 b3) = shiftLeft (ZHead b1 b2) b3
-          shiftLeft b1 b2@(ZLast {}) = ZClosed b1 b2