snapshot of simonmar's experiments
authorSimon Marlow <marlowsd@gmail.com>
Thu, 19 Jan 2012 10:54:41 +0000 (10:54 +0000)
committerSimon Marlow <marlowsd@gmail.com>
Thu, 19 Jan 2012 10:54:41 +0000 (10:54 +0000)
16 files changed:
hoopl.cabal
src/Compiler/Hoopl.hs
src/Compiler/Hoopl/Collections.hs
src/Compiler/Hoopl/Dataflow.hs
src/Compiler/Hoopl/Graph.hs
src/Compiler/Hoopl/GraphUtil.hs
src/Compiler/Hoopl/Label.hs
src/Compiler/Hoopl/MkGraph.hs
src/Compiler/Hoopl/Show.hs
src/Compiler/Hoopl/Unique.hs
src/Compiler/Hoopl/Util.hs
src/Compiler/Hoopl/XUtil.hs
testing/EvalMonad.hs
testing/Main.hs
testing/Test.hs
testing/tests/ExpectedOutput

index 8ef5ee6..3aba6ae 100644 (file)
@@ -26,8 +26,8 @@ Library
                      Compiler.Hoopl.Passes.DList,
 --                     Compiler.Hoopl.DataflowFold,
 --                     Compiler.Hoopl.OldDataflow,
-                     Compiler.Hoopl.GHC
-  Other-Modules:     Compiler.Hoopl.GraphUtil,
+                     Compiler.Hoopl.GHC,
+                     Compiler.Hoopl.GraphUtil,
                      -- GraphUtil should *never* be seen by clients.
                      -- The remaining modules are hidden *provisionally*
                      Compiler.Hoopl.Checkpoint,
index 1e78856..954033d 100644 (file)
@@ -26,10 +26,10 @@ import Compiler.Hoopl.Combinators
 import Compiler.Hoopl.Dataflow hiding ( wrapFR, wrapFR2, wrapBR, wrapBR2
                                       )
 import Compiler.Hoopl.Debug
-import Compiler.Hoopl.Fuel hiding (withFuel, getFuel, setFuel, runWithFuel)
+import Compiler.Hoopl.Fuel hiding (withFuel, getFuel, setFuel)
 import Compiler.Hoopl.Graph hiding 
    ( Body
-   , BCat, BHead, BTail, BClosed -- OK to expose BFirst, BMiddle, BLast
+   , BCat, BHead, BTail -- expose some other bits of Block
    )
 import Compiler.Hoopl.Graph (Body)
 import Compiler.Hoopl.Label hiding (uniqueToLbl, lblToUnique)
index 45e42c3..e7b1755 100644 (file)
@@ -59,6 +59,7 @@ class IsMap map where
   mapEmpty :: map a
   mapSingleton :: KeyOf map -> a -> map a
   mapInsert :: KeyOf map -> a -> map a -> map a
+  mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a
   mapDelete :: KeyOf map -> map a -> map a
 
   mapUnion :: map a -> map a -> map a
@@ -76,6 +77,7 @@ class IsMap map where
   mapKeys :: map a -> [KeyOf map]
   mapToList :: map a -> [(KeyOf map, a)]
   mapFromList :: [(KeyOf map, a)] -> map a
+  mapFromListWith :: (a -> a -> a) -> [(KeyOf map,a)] -> map a
 
 -- Helper functions for IsMap class
 mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a
index 3053cc3..199404d 100644 (file)
@@ -1,21 +1,31 @@
 {-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, MultiParamTypeClasses #-}
+#if __GLASGOW_HASKELL__ >= 703
+{- OPTIONS_GHC -fprof-auto #-}
+#endif
 #if __GLASGOW_HASKELL__ >= 701
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
 #endif
 
 module Compiler.Hoopl.Dataflow
   ( DataflowLattice(..), JoinFun, OldFact(..), NewFact(..), Fact, mkFactBase
+
   , ChangeFlag(..), changeIf
-  , FwdPass(..), FwdTransfer, mkFTransfer, mkFTransfer3, getFTransfer3
-  -- * Respecting Fuel
 
-  -- $fuel
-  , FwdRewrite,  mkFRewrite,  mkFRewrite3,  getFRewrite3, noFwdRewrite
+  , FwdPass(..)
+  , FwdTransfer(..), mkFTransfer, mkFTransfer3, getFTransfer3
+  , FwdRewrite(..),  mkFRewrite,  mkFRewrite3,  getFRewrite3, noFwdRewrite
   , wrapFR, wrapFR2
-  , BwdPass(..), BwdTransfer, mkBTransfer, mkBTransfer3, getBTransfer3
+
+  , BwdPass(..)
+  , BwdTransfer(..), mkBTransfer, mkBTransfer3, getBTransfer3
   , wrapBR, wrapBR2
-  , BwdRewrite,  mkBRewrite,  mkBRewrite3,  getBRewrite3, noBwdRewrite
+  , BwdRewrite(..),  mkBRewrite,  mkBRewrite3,  getBRewrite3, noBwdRewrite
+
   , analyzeAndRewriteFwd,  analyzeAndRewriteBwd
+
+  -- * Respecting Fuel
+
+  -- $fuel
   )
 where
 
@@ -31,6 +41,8 @@ import qualified Compiler.Hoopl.GraphUtil as U
 import Compiler.Hoopl.Label
 import Compiler.Hoopl.Util
 
+import Debug.Trace
+
 -----------------------------------------------------------------------------
 --              DataflowLattice
 -----------------------------------------------------------------------------
@@ -93,6 +105,7 @@ newtype FwdRewrite m n f   -- see Note [Respects Fuel]
                     , n O C -> f -> m (Maybe (Graph n O C, FwdRewrite m n f))
                     ) }
 
+{-# INLINE wrapFR #-}
 wrapFR :: (forall e x. (n  e x -> f  -> m  (Maybe (Graph n  e x, FwdRewrite m  n  f )))
                     -> (n' e x -> f' -> m' (Maybe (Graph n' e x, FwdRewrite m' n' f')))
           )
@@ -101,7 +114,9 @@ wrapFR :: (forall e x. (n  e x -> f  -> m  (Maybe (Graph n  e x, FwdRewrite m  n
        -> FwdRewrite m  n  f 
        -> FwdRewrite m' n' f'      -- see Note [Respects Fuel]
 wrapFR wrap (FwdRewrite3 (f, m, l)) = FwdRewrite3 (wrap f, wrap m, wrap l)
-wrapFR2 
+
+{-# INLINE wrapFR2 #-}
+wrapFR2
   :: (forall e x . (n1 e x -> f1 -> m1 (Maybe (Graph n1 e x, FwdRewrite m1 n1 f1))) ->
                    (n2 e x -> f2 -> m2 (Maybe (Graph n2 e x, FwdRewrite m2 n2 f2))) ->
                    (n3 e x -> f3 -> m3 (Maybe (Graph n3 e x, FwdRewrite m3 n3 f3)))
@@ -186,7 +201,9 @@ type Entries e = MaybeC e [Label]
 arfGraph :: forall m n f e x .
             (NonLocal n, CheckpointMonad m) => FwdPass m n f -> 
             Entries e -> Graph n e x -> Fact e f -> m (DG f n e x, Fact x f)
-arfGraph pass entries = graph
+arfGraph pass@FwdPass { fp_lattice = lattice,
+                        fp_transfer = transfer @ (FwdTransfer3 (ftr, mtr, ltr)),
+                        fp_rewrite  = rewrite @ (FwdRewrite3 (frw, mrw, lrw)) } entries = graph
   where
     {- nested type synonyms would be so lovely here 
     type ARF  thing = forall e x . thing e x -> f        -> m (DG f n e x, Fact x f)
@@ -232,26 +249,39 @@ arfGraph pass entries = graph
 
     -- Lift from nodes to blocks
 -- @ start block.tex -2
-    block (BFirst  n)  = node n
+    block BNil          = \f -> return (dgnil, f)
+    block (BlockCO l b)   = node l `cat` block b
+    block (BlockCC l b n) = node l `cat` block b `cat` node n
+    block (BlockOC   b n) =              block b `cat` node n
+
     block (BMiddle n)  = node n
-    block (BLast   n)  = node n
     block (BCat b1 b2) = block b1 `cat` block b2
 -- @ end block.tex
     block (BHead h n)  = block h  `cat` node n
     block (BTail n t)  = node  n  `cat` block t
-    block (BClosed h t)= block h  `cat` block t
 
 -- @ start node.tex -4
     node n f
-     = do { grw <- frewrite pass n f
+     = do { grw <- frewrite rewrite n f
           ; case grw of
               Nothing -> return ( singletonDG f n
-                                , ftransfer pass n f )
+                                , ftransfer transfer n f )
               Just (g, rw) ->
                   let pass' = pass { fp_rewrite = rw }
                       f'    = fwdEntryFact n f
                   in  arfGraph pass' (fwdEntryLabel n) g f' }
 
+    mnode :: n O O -> f -> m (DG f n O O, Fact O f)
+    mnode n f
+     = do { grw <- mrw n f
+          ; case grw of
+              Nothing -> let g  = singletonDG f n
+                             f' = mtr n f
+                         in g `seq` f' `seq` return (g,f')
+              Just (g, rw) ->
+                  let pass' = pass { fp_rewrite = rw }
+                  in  arfGraph pass' NothingC g f }
+
 -- @ end node.tex
 
     -- | Compose fact transformers and concatenate the resulting
@@ -268,7 +298,6 @@ arfGraph pass entries = graph
          -> (thing C x -> Fact C f -> m (DG f n C x, Fact x f))
     arfx arf thing fb = 
       arf thing $ fromJust $ lookupFact (entryLabel thing) $ joinInFacts lattice fb
-     where lattice = fp_lattice pass
      -- joinInFacts adds debugging information
 
 
@@ -277,11 +306,11 @@ arfGraph pass entries = graph
                     -- the Body are in the 'DG f n C C'
 -- @ start bodyfun.tex
     body entries blockmap init_fbase
-      = fixpoint Fwd lattice do_block blocks init_fbase
+      = fixpoint Fwd lattice do_block entries blockmap init_fbase
       where
-        blocks  = forwardBlockList entries blockmap
         lattice = fp_lattice pass
-        do_block :: forall x. Block n C x -> FactBase f -> m (DG f n C x, Fact x f)
+        do_block :: forall x. Block n C x -> FactBase f
+                 -> m (DG f n C x, Fact x f)
         do_block b fb = block b entryFact
           where entryFact = getFact lattice (entryLabel b) fb
 -- @ end bodyfun.tex
@@ -323,6 +352,7 @@ newtype BwdRewrite m n f
                     , n O C -> FactBase f -> m (Maybe (Graph n O C, BwdRewrite m n f))
                     ) }
 
+{-# INLINE wrapBR #-}
 wrapBR :: (forall e x .
                 Shape x 
              -> (n  e x -> Fact x f  -> m  (Maybe (Graph n  e x, BwdRewrite m  n  f )))
@@ -335,6 +365,7 @@ wrapBR :: (forall e x .
 wrapBR wrap (BwdRewrite3 (f, m, l)) = 
   BwdRewrite3 (wrap Open f, wrap Open m, wrap Closed l)
 
+{-# INLINE wrapBR2 #-}
 wrapBR2 :: (forall e x . Shape x
             -> (n1 e x -> Fact x f1 -> m1 (Maybe (Graph n1 e x, BwdRewrite m1 n1 f1)))
             -> (n2 e x -> Fact x f2 -> m2 (Maybe (Graph n2 e x, BwdRewrite m2 n2 f2)))
@@ -387,7 +418,9 @@ mkBRewrite f = mkBRewrite3 f f f
 arbGraph :: forall m n f e x .
             (NonLocal n, CheckpointMonad m) => BwdPass m n f -> 
             Entries e -> Graph n e x -> Fact x f -> m (DG f n e x, Fact e f)
-arbGraph pass entries = graph
+arbGraph pass@BwdPass { bp_lattice  = lattice,
+                        bp_transfer = transfer,
+                        bp_rewrite  = rewrite } entries = graph
   where
     {- nested type synonyms would be so lovely here 
     type ARB  thing = forall e x . thing e x -> Fact x f -> m (DG f n e x, f)
@@ -419,19 +452,21 @@ arbGraph pass entries = graph
              c _ _ = error "bogus GADT pattern match failure"
 
     -- Lift from nodes to blocks
-    block (BFirst  n)  = node n
+    block BNil          = \f -> return (dgnil, f)
+    block (BlockCO l b)   = node l `cat` block b
+    block (BlockCC l b n) = node l `cat` block b `cat` node n
+    block (BlockOC   b n) =              block b `cat` node n
+
     block (BMiddle n)  = node n
-    block (BLast   n)  = node n
     block (BCat b1 b2) = block b1 `cat` block b2
     block (BHead h n)  = block h  `cat` node n
     block (BTail n t)  = node  n  `cat` block t
-    block (BClosed h t)= block h  `cat` block t
 
     node n f
-      = do { bwdres <- brewrite pass n f
+      = do { bwdres <- brewrite rewrite n f
            ; case bwdres of
                Nothing -> return (singletonDG entry_f n, entry_f)
-                            where entry_f = btransfer pass n f
+                            where entry_f = btransfer transfer n f
                Just (g, rw) ->
                           do { let pass' = pass { bp_rewrite = rw }
                              ; (g, f) <- arbGraph pass' (fwdEntryLabel n) g f
@@ -459,14 +494,14 @@ arbGraph pass entries = graph
                     -- in the Body; the facts for Labels *in*
                     -- the Body are in the 'DG f n C C'
     body entries blockmap init_fbase
-      = fixpoint Bwd (bp_lattice pass) do_block blocks init_fbase
+      = fixpoint Bwd (bp_lattice pass) do_block (map entryLabel (backwardBlockList entries blockmap)) blockmap init_fbase
       where
-        blocks = backwardBlockList entries blockmap
         do_block :: forall x. Block n C x -> Fact x f -> m (DG f n C x, LabelMap f)
         do_block b f = do (g, f) <- block b f
                           return (g, mapSingleton (entryLabel b) f)
 
 
+
 backwardBlockList :: (LabelsPtr entries, NonLocal n) => entries -> Body n -> [Block n C C]
 -- This produces a list of blocks in order suitable for backward analysis,
 -- along with the list of Labels it may depend on for facts.
@@ -510,23 +545,18 @@ distinguishedEntryFact g f = maybe g
 -----------------------------------------------------------------------------
 --      fixpoint: finding fixed points
 -----------------------------------------------------------------------------
--- @ start txfb.tex
-data TxFactBase n f
-  = TxFB { tfb_fbase :: FactBase f
-         , tfb_rg    :: DG f n C C -- Transformed blocks
-         , tfb_cha   :: ChangeFlag
-         , tfb_lbls  :: LabelSet }
--- @ end txfb.tex
+
      -- See Note [TxFactBase invariants]
--- @ start update.tex
-updateFact :: DataflowLattice f -> LabelSet
-           -> Label -> f -> (ChangeFlag, FactBase f)
-           -> (ChangeFlag, FactBase f)
+
+updateFact :: DataflowLattice f
+           -> LabelMap (DBlock f n C C)
+           -> Label -> f       -- out fact
+           -> ([Label], FactBase f)
+           -> ([Label], FactBase f)
 -- See Note [TxFactBase change flag]
-updateFact lat lbls lbl new_fact (cha, fbase)
-  | NoChange <- cha2     = (cha,        fbase)
-  | lbl `setMember` lbls = (SomeChange, new_fbase)
-  | otherwise            = (cha,        new_fbase)
+updateFact lat newblocks lbl new_fact (cha, fbase)
+  | NoChange <- cha2, lbl `mapMember` newblocks  = (cha,     fbase)
+  | otherwise         = (lbl:cha, mapInsert lbl res_fact fbase)
   where
     (cha2, res_fact) -- Note [Unreachable blocks]
        = case lookupFact lbl fbase of
@@ -536,8 +566,6 @@ updateFact lat lbls lbl new_fact (cha, fbase)
                  fact_join lat lbl
                    (OldFact old_fact) (NewFact new_fact)
                (_, new_fact_debug) = join (fact_bot lat)
-    new_fbase = mapInsert lbl res_fact fbase
--- @ end update.tex
 
 
 {-
@@ -552,73 +580,61 @@ fixpoint :: forall m n f. (CheckpointMonad m, NonLocal n)
  => Direction
  -> DataflowLattice f
  -> (Block n C C -> Fact C f -> m (DG f n C C, Fact C f))
- -> [Block n C C]
+ -> [Label]
+ -> LabelMap (Block n C C)
  -> (Fact C f -> m (DG f n C C, Fact C f))
 -- @ end fptype.tex
 -- @ start fpimp.tex
-fixpoint direction lat do_block blocks init_fbase
-  = do { tx_fb <- loop init_fbase
-       ; return (tfb_rg tx_fb, 
-                 map (fst . fst) tagged_blocks 
-                    `mapDeleteList` tfb_fbase tx_fb ) }
-    -- The successors of the Graph are the the Labels 
+fixpoint direction lat do_block entries blockmap init_fbase
+  = do
+        -- trace ("fixpoint: " ++ show (case direction of Fwd -> True; Bwd -> False) ++ " " ++ show (mapKeys blockmap) ++ show entries ++ " " ++ show (mapKeys init_fbase)) $ return()
+        (fbase, newblocks) <- loop init_fbase entries mapEmpty
+        -- trace ("fixpoint DONE: " ++ show (mapKeys fbase) ++ show (mapKeys newblocks)) $ return()
+        return (GMany NothingO newblocks NothingO,
+                mapDeleteList (mapKeys blockmap) fbase)
+    -- The successors of the Graph are the the Labels
     -- for which we have facts and which are *not* in
     -- the blocks of the graph
   where
-    tagged_blocks = map tag blocks
-    is_fwd = case direction of { Fwd -> True; 
-                                 Bwd -> False }
-    tag :: NonLocal t => t C C -> ((Label, t C C), [Label])
-    tag b = ((entryLabel b, b), 
-             if is_fwd then [entryLabel b] 
-                        else successors b)
-     -- 'tag' adds the in-labels of the block; 
-     -- see Note [TxFactBase invairants]
-
-    tx_blocks :: [((Label, Block n C C), [Label])]   -- I do not understand this type
-              -> TxFactBase n f -> m (TxFactBase n f)
-    tx_blocks []              tx_fb = return tx_fb
-    tx_blocks (((lbl,blk), in_lbls):bs) tx_fb 
-      = tx_block lbl blk in_lbls tx_fb >>= tx_blocks bs
-     -- "in_lbls" == Labels the block may 
-     --                 _depend_ upon for facts
-
-    tx_block :: Label -> Block n C C -> [Label]
-             -> TxFactBase n f -> m (TxFactBase n f)
-    tx_block lbl blk in_lbls 
-        tx_fb@(TxFB { tfb_fbase = fbase, tfb_lbls = lbls
-                    , tfb_rg = blks, tfb_cha = cha })
-      | is_fwd && not (lbl `mapMember` fbase)
-      = return (tx_fb {tfb_lbls = lbls'})       -- Note [Unreachable blocks]
-      | otherwise
-      = do { (rg, out_facts) <- do_block blk fbase
-           ; let (cha', fbase') = mapFoldWithKey
-                                  (updateFact lat lbls')
-                                  (cha,fbase) out_facts
-           ; return $
-               TxFB { tfb_lbls  = lbls'
-                    , tfb_rg    = rg `dgSplice` blks
-                    , tfb_fbase = fbase'
-                    , tfb_cha = cha' } }
-      where
-        lbls' = lbls `setUnion` setFromList in_lbls
-        
-
-    loop :: FactBase f -> m (TxFactBase n f)
-    loop fbase 
-      = do { s <- checkpoint
-           ; let init_tx :: TxFactBase n f
-                 init_tx = TxFB { tfb_fbase = fbase
-                                , tfb_cha   = NoChange
-                                , tfb_rg    = dgnilC
-                                , tfb_lbls  = setEmpty }
-           ; tx_fb <- tx_blocks tagged_blocks init_tx
-           ; case tfb_cha tx_fb of
-               NoChange   -> return tx_fb
-               SomeChange 
-                 -> do { restart s
-                       ; loop (tfb_fbase tx_fb) } }
--- @ end fpimp.tex           
+    -- mapping from L -> Ls.  If the fact for L changes, re-analyse Ls.
+    dep_blocks :: LabelMap [Label]
+    dep_blocks = mapFromListWith (++)
+                        [ (l, [entryLabel b])
+                        | b <- mapElems blockmap
+                        , l <- case direction of
+                                 Fwd -> [entryLabel b]
+                                 Bwd -> successors b
+                        ]
+
+    loop
+       :: FactBase f  -- current factbase (increases monotonically)
+       -> [Label]     -- blocks still to analyse (Todo: use a better rep)
+       -> LabelMap (DBlock f n C C)  -- transformed graph
+       -> m (FactBase f, LabelMap (DBlock f n C C))
+
+    loop fbase []         newblocks = return (fbase, newblocks)
+    loop fbase (lbl:todo) newblocks = do
+      case mapLookup lbl blockmap of
+         Nothing  -> loop fbase todo newblocks
+         Just blk -> do
+           -- trace ("analysing: " ++ show lbl) $ return ()
+           (rg, out_facts) <- do_block blk fbase
+           let (changed, fbase') = mapFoldWithKey
+                                     (updateFact lat newblocks)
+                                     ([],fbase) out_facts
+           -- trace ("fbase': " ++ show (mapKeys fbase')) $ return ()
+           -- trace ("changed: " ++ show changed) $ return ()
+     
+           let to_analyse
+                 = filter (`notElem` todo) $
+                   concatMap (\l -> mapFindWithDefault [] l dep_blocks) changed
+
+           -- trace ("to analyse: " ++ show to_analyse) $ return ()
+
+           let newblocks' = case rg of
+                              GMany _ blks _ -> mapUnion blks newblocks
+     
+           loop fbase' (todo ++ to_analyse) newblocks'
 
 
 {-  Note [TxFactBase invariants]
@@ -712,12 +728,11 @@ dgSplice  :: NonLocal n => DG f n e a -> DG f n a x -> DG f n e x
 
 ---- observers
 
-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
-
 normalizeGraph :: forall n f e x .
-                  NonLocal n => DG f n e x -> GraphWithFacts n f e x
+                  NonLocal n => DG f n 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
 
 normalizeGraph g = (graphMapBlocks dropFact g, facts g)
     where dropFact :: DBlock t t1 t2 t3 -> Block t1 t2 t3
@@ -730,9 +745,9 @@ normalizeGraph g = (graphMapBlocks dropFact g, facts g)
           exitFacts NothingO = noFacts
           exitFacts (JustO (DBlock f b)) = mapSingleton (entryLabel b) f
           bodyFacts :: LabelMap (DBlock f n C C) -> FactBase f
-          bodyFacts body = mapFold f noFacts body
-            where f :: forall t a x. (NonLocal t) => DBlock a t C x -> LabelMap a -> LabelMap a
-                  f (DBlock f b) fb = mapInsert (entryLabel b) f fb
+          bodyFacts body = mapFoldWithKey f noFacts body
+            where f :: forall t a x. (NonLocal t) => Label -> DBlock a t C x -> LabelMap a -> LabelMap a
+                  f lbl (DBlock f b) fb = mapInsert lbl f fb
 
 --- implementation of the constructors (boring)
 
@@ -758,43 +773,43 @@ class ShapeLifter e x where
  singletonDG   :: f -> n e x -> DG f n e x
  fwdEntryFact  :: NonLocal n => n e x -> f -> Fact e f
  fwdEntryLabel :: NonLocal n => n e x -> MaybeC e [Label]
- ftransfer :: FwdPass m n f -> n e x -> f -> Fact x f
- frewrite  :: FwdPass m n f -> n e x 
+ ftransfer :: FwdTransfer n f -> n e x -> f -> Fact x f
+ frewrite  :: FwdRewrite m n f -> n e x
            -> f -> m (Maybe (Graph n e x, FwdRewrite m n f))
 -- @ end node.tex
  bwdEntryFact :: NonLocal n => DataflowLattice f -> n e x -> Fact e f -> f
- btransfer    :: BwdPass m n f -> n e x -> Fact x f -> f
- brewrite     :: BwdPass m n f -> n e x
+ btransfer    :: BwdTransfer n f -> n e x -> Fact x f -> f
+ brewrite     :: BwdRewrite m n f -> n e x
               -> Fact x f -> m (Maybe (Graph n e x, BwdRewrite m n f))
 
 instance ShapeLifter C O where
-  singletonDG f = gUnitCO . DBlock f . BFirst
+  singletonDG f n = gUnitCO (DBlock f (BlockCO n BNil))
   fwdEntryFact     n f  = mapSingleton (entryLabel n) f
   bwdEntryFact lat n fb = getFact lat (entryLabel n) fb
-  ftransfer (FwdPass {fp_transfer = FwdTransfer3 (ft, _, _)}) n f = ft n f
-  btransfer (BwdPass {bp_transfer = BwdTransfer3 (bt, _, _)}) n f = bt n f
-  frewrite  (FwdPass {fp_rewrite  = FwdRewrite3  (fr, _, _)}) n f = fr n f
-  brewrite  (BwdPass {bp_rewrite  = BwdRewrite3  (br, _, _)}) n f = br n f
+  ftransfer (FwdTransfer3 (ft, _, _)) n f = ft n f
+  btransfer (BwdTransfer3 (bt, _, _)) n f = bt n f
+  frewrite  (FwdRewrite3  (fr, _, _)) n f = fr n f
+  brewrite  (BwdRewrite3  (br, _, _)) n f = br n f
   fwdEntryLabel n = JustC [entryLabel n]
 
 instance ShapeLifter O O where
   singletonDG f = gUnitOO . DBlock f . BMiddle
   fwdEntryFact   _ f = f
   bwdEntryFact _ _ f = f
-  ftransfer (FwdPass {fp_transfer = FwdTransfer3 (_, ft, _)}) n f = ft n f
-  btransfer (BwdPass {bp_transfer = BwdTransfer3 (_, bt, _)}) n f = bt n f
-  frewrite  (FwdPass {fp_rewrite  = FwdRewrite3  (_, fr, _)}) n f = fr n f
-  brewrite  (BwdPass {bp_rewrite  = BwdRewrite3  (_, br, _)}) n f = br n f
+  ftransfer (FwdTransfer3 (_, ft, _)) n f = ft n f
+  btransfer (BwdTransfer3 (_, bt, _)) n f = bt n f
+  frewrite  (FwdRewrite3  (_, fr, _)) n f = fr n f
+  brewrite  (BwdRewrite3  (_, br, _)) n f = br n f
   fwdEntryLabel _ = NothingC
 
 instance ShapeLifter O C where
-  singletonDG f = gUnitOC . DBlock f . BLast
+  singletonDG f n = gUnitOC (DBlock f (BlockOC BNil n))
   fwdEntryFact   _ f = f
   bwdEntryFact _ _ f = f
-  ftransfer (FwdPass {fp_transfer = FwdTransfer3 (_, _, ft)}) n f = ft n f
-  btransfer (BwdPass {bp_transfer = BwdTransfer3 (_, _, bt)}) n f = bt n f
-  frewrite  (FwdPass {fp_rewrite  = FwdRewrite3  (_, _, fr)}) n f = fr n f
-  brewrite  (BwdPass {bp_rewrite  = BwdRewrite3  (_, _, br)}) n f = br n f
+  ftransfer (FwdTransfer3 (_, _, ft)) n f = ft n f
+  btransfer (BwdTransfer3 (_, _, bt)) n f = bt n f
+  frewrite  (FwdRewrite3  (_, _, fr)) n f = fr n f
+  brewrite  (BwdRewrite3  (_, _, br)) n f = br n f
   fwdEntryLabel _ = NothingC
 
 -- Fact lookup: the fact `orelse` bottom
index 27c00ea..f2cb5bc 100644 (file)
@@ -37,17 +37,16 @@ data C
 -- Clients should avoid manipulating blocks and should stick to either nodes
 -- or graphs.
 data Block n e x where
-  -- nodes
-  BFirst  :: n C O                 -> Block n C O -- x^ block holds a single first node
-  BMiddle :: n O O                 -> Block n O O -- x^ block holds a single middle node
-  BLast   :: n O C                 -> Block n O C -- x^ block holds a single last node
+  BlockCO  :: n C O -> Block n O O          -> Block n C O
+  BlockCC  :: n C O -> Block n O O -> n O C -> Block n C C
+  BlockOC  ::          Block n O O -> n O C -> Block n O C
 
-  -- concatenation operations
-  BCat    :: Block n O O -> Block n O O -> Block n O O -- non-list-like
-  BHead   :: Block n C O -> n O O       -> Block n C O
-  BTail   :: n O O       -> Block n O C -> Block n O C  
+  BNil    :: Block n O O
+  BMiddle :: n O O                      -> Block n O O
+  BCat    :: Block n O O -> Block n O O -> Block n O O
+  BHead   :: Block n O O -> n O O       -> Block n O O
+  BTail   :: n O O       -> Block n O O -> Block n O O
 
-  BClosed :: Block n C O -> Block n O C -> Block n C C -- the zipper
 
 -- | A (possibly empty) collection of closed/closed blocks
 type Body n = LabelMap (Block n C C)
@@ -60,7 +59,7 @@ type Graph = Graph' Block
 data Graph' block (n :: * -> * -> *) e x where
   GNil  :: Graph' block n O O
   GUnit :: block n O O -> Graph' block n O O
-  GMany :: MaybeO e (block n O C) 
+  GMany :: MaybeO e (block n O C)
         -> LabelMap (block n C C)
         -> MaybeO x (block n C O)
         -> Graph' block n e x
@@ -101,23 +100,23 @@ class NonLocal thing where
   successors :: thing e C -> [Label] -- ^ Gives control-flow successors
 
 instance NonLocal n => NonLocal (Block n) where
-  entryLabel (BFirst n)    = entryLabel n
-  entryLabel (BHead h _)   = entryLabel h
-  entryLabel (BClosed h _) = entryLabel h
-  successors (BLast n)     = successors n
-  successors (BTail _ t)   = successors t
-  successors (BClosed _ t) = successors t
+  entryLabel (BlockCO f _)   = entryLabel f
+  entryLabel (BlockCC f _ _) = entryLabel f
+
+  successors (BlockOC   _ n) = successors n
+  successors (BlockCC _ _ n) = successors n
 
 ------------------------------
 emptyBody :: LabelMap (thing C C)
 emptyBody = mapEmpty
 
-addBlock :: NonLocal thing => thing C C -> LabelMap (thing C C) -> LabelMap (thing C C)
-addBlock b body = nodupsInsert (entryLabel b) b body
-  where nodupsInsert l b body = if mapMember l body then
-                                    error $ "duplicate label " ++ show l ++ " in graph"
-                                else
-                                    mapInsert l b body
+addBlock :: NonLocal thing
+         => thing C C -> LabelMap (thing C C)
+         -> LabelMap (thing C C)
+addBlock b body
+  | mapMember lbl body = error $ "duplicate label " ++ show lbl ++ " in graph"
+  | otherwise          = mapInsert lbl b body
+  where lbl = entryLabel b
 
 bodyList :: NonLocal (block n) => Body' block n -> [(Label,block n C C)]
 bodyList (Body body) = mapToList body
@@ -127,23 +126,26 @@ mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x
 mapGraph _ GNil = GNil
 mapGraph f (GUnit b) = GUnit (mapBlock f b)
 mapGraph f (GMany x y z)
-    = GMany (mapMaybeO f x)
+    = GMany (mapMaybeO (mapBlock f) x)
             (mapMap (mapBlock f) y)
-            (mapMaybeO f z)
+            (mapMaybeO (mapBlock f) z)
 
-mapMaybeO :: (forall e x. n e x -> n' e x) -> MaybeO ex (Block n e x) -> MaybeO ex (Block n' e x)
+mapMaybeO :: (a -> b) -> MaybeO ex a -> MaybeO ex b
 mapMaybeO _  NothingO = NothingO
-mapMaybeO f (JustO b) = JustO (mapBlock f b)
+mapMaybeO f (JustO b) = JustO (f b)
 
-mapMaybeC :: (forall e x. n e x -> n' e x) -> MaybeC ex (Block n e x) -> MaybeC ex (Block n' e x)
+mapMaybeC :: (forall e x. n e x -> n' e x)
+          -> MaybeC ex (Block n  e x)
+          -> MaybeC ex (Block n' e x)
 mapMaybeC _  NothingC = NothingC
 mapMaybeC f (JustC b) = JustC (mapBlock f b)
 
 mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x
-mapBlock f (BFirst n)      = BFirst  (f n)
+mapBlock f (BlockCO n b  ) = BlockCO (f n) (mapBlock f b)
+mapBlock f (BlockOC   b n) = BlockOC       (mapBlock f b) (f n)
+mapBlock f (BlockCC n b m) = BlockCC (f n) (mapBlock f b) (f m)
+mapBlock _  BNil           = BNil
 mapBlock f (BMiddle n)     = BMiddle (f n)
-mapBlock f (BLast n)       = BLast   (f n)
 mapBlock f (BCat b1 b2)    = BCat    (mapBlock f b1) (mapBlock f b2)
 mapBlock f (BHead b n)     = BHead   (mapBlock f b)  (f n)
 mapBlock f (BTail n b)     = BTail   (f n)  (mapBlock f b)
-mapBlock f (BClosed b1 b2) = BClosed (mapBlock f b1) (mapBlock f b2)
index 06904ef..50e5a7e 100644 (file)
@@ -29,18 +29,18 @@ splice bcat = sp
         sp GNil g2 = g2
         sp g1 GNil = g1
 
-        sp (GUnit b1) (GUnit b2) = GUnit (b1 `bcat` b2)
+        sp (GUnit b1) (GUnit b2) = {-# SCC "sp1" #-} GUnit $! b1 `bcat` b2
 
-        sp (GUnit b) (GMany (JustO e) bs x) = GMany (JustO (b `bcat` e)) bs x
+        sp (GUnit b) (GMany (JustO e) bs x) = {-# SCC "sp2" #-} GMany (JustO (b `bcat` e)) bs x
 
-        sp (GMany e bs (JustO x)) (GUnit b2) = GMany e bs (JustO (x `bcat` b2))
+        sp (GMany e bs (JustO x)) (GUnit b2) = {-# SCC "sp3" #-} GMany e bs (JustO (x `bcat` b2))
 
         sp (GMany e1 bs1 (JustO x1)) (GMany (JustO e2) b2 x2)
-          = GMany e1 (b1 `bodyUnion` b2) x2
+          = {-# SCC "sp4" #-} GMany e1 (b1 `bodyUnion` b2) x2
           where b1 = addBlock (x1 `bcat` e2) bs1
 
         sp (GMany e1 b1 NothingO) (GMany NothingO b2 x2)
-          = GMany e1 (b1 `bodyUnion` b2) x2
+          = {-# SCC "sp5" #-} GMany e1 (b1 `bodyUnion` b2) x2
 
         sp _ _ = error "bogus GADT match failure"
 
@@ -52,23 +52,49 @@ gSplice :: NonLocal n => Graph n e a -> Graph n a x -> Graph n e x
 gSplice = splice cat
 
 cat :: Block n e O -> Block n O x -> Block n e x
-cat b1@(BFirst {})     (BMiddle n)  = BHead   b1 n
-cat b1@(BFirst {})  b2@(BLast{})    = BClosed b1 b2
-cat b1@(BFirst {})  b2@(BTail{})    = BClosed b1 b2
-cat b1@(BFirst {})     (BCat b2 b3) = (b1 `cat` b2) `cat` b3
-cat b1@(BHead {})      (BCat b2 b3) = (b1 `cat` b2) `cat` b3
-cat b1@(BHead {})      (BMiddle n)  = BHead   b1 n
-cat b1@(BHead {})   b2@(BLast{})    = BClosed b1 b2
-cat b1@(BHead {})   b2@(BTail{})    = BClosed b1 b2
-cat b1@(BMiddle {}) b2@(BMiddle{})  = BCat    b1 b2
-cat    (BMiddle n)  b2@(BLast{})    = BTail    n b2
-cat b1@(BMiddle {}) b2@(BCat{})     = BCat    b1 b2
-cat    (BMiddle n)  b2@(BTail{})    = BTail    n b2
-cat    (BCat b1 b2) b3@(BLast{})    = b1 `cat` (b2 `cat` b3)
-cat    (BCat b1 b2) b3@(BTail{})    = b1 `cat` (b2 `cat` b3)
-cat b1@(BCat {})    b2@(BCat{})     = BCat    b1 b2
-cat b1@(BCat {})    b2@(BMiddle{})  = BCat    b1 b2
-
+cat x y = case x of
+  BNil -> y
+
+  BlockCO l b1 -> case y of
+                   BlockOC b2 n -> BlockCC l (b1 `cat` b2) n
+                   BNil         -> x
+                   BMiddle n    -> BlockCO l (b1 `BHead` n)
+                   BCat{}       -> BlockCO l (b1 `BCat` y)
+                   BHead{}      -> BlockCO l (b1 `BCat` y)
+                   BTail{}      -> BlockCO l (b1 `BCat` y)
+
+  BMiddle n -> case y of
+                   BlockOC b2 n2 -> BlockOC (n `BTail` b2) n2
+                   BNil          -> x
+                   BMiddle{}     -> BTail n y
+                   BCat{}        -> BTail n y
+                   BHead{}       -> BTail n y
+                   BTail{}       -> BTail n y
+
+  BCat{} -> case y of
+                   BlockOC b3 n2 -> BlockOC (x `cat` b3) n2
+                   BNil          -> x
+                   BMiddle n     -> BHead x n
+                   BCat{}        -> BCat x y
+                   BHead{}       -> BCat x y
+                   BTail{}       -> BCat x y
+
+  BHead{} -> case y of
+                   BlockOC b2 n2 -> BlockOC (x `cat` b2) n2
+                   BNil          -> x
+                   BMiddle n     -> BHead x n
+                   BCat{}        -> BCat x y
+                   BHead{}       -> BCat x y
+                   BTail{}       -> BCat x y
+
+
+  BTail{} -> case y of
+                   BlockOC b2 n2 -> BlockOC (x `BCat` b2) n2
+                   BNil          -> x
+                   BMiddle n     -> BHead x n
+                   BCat{}        -> BCat x y
+                   BHead{}       -> BCat x y
+                   BTail{}       -> BCat x y
 
 ----------------------------------------------------------------
 
@@ -80,24 +106,22 @@ cat b1@(BCat {})    b2@(BMiddle{})  = BCat    b1 b2
 -- can be front-biased; a closed/open block is inherently back-biased.
 
 frontBiasBlock :: Block n e x -> Block n e x
-frontBiasBlock b@(BFirst  {}) = b
-frontBiasBlock b@(BMiddle {}) = b
-frontBiasBlock b@(BLast   {}) = b
-frontBiasBlock b@(BCat {}) = rotate b
-  where -- rotate and append ensure every left child of ZCat is ZMiddle
-        -- provided 2nd argument to append already has this property
-    rotate :: Block n O O -> Block n O O
-    append :: Block n O O -> Block n O O -> Block n O O
-    rotate (BCat h t)     = append h (rotate t)
-    rotate b@(BMiddle {}) = b
-    append b@(BMiddle {}) t = b `BCat` t
-    append (BCat b1 b2) b3 = b1 `append` (b2 `append` b3)
-frontBiasBlock b@(BHead {})    = b -- back-biased by nature; cannot fix
-frontBiasBlock b@(BTail {})    = b -- statically front-biased
-frontBiasBlock   (BClosed h t) = shiftRight h t
-    where shiftRight :: Block n C O -> Block n O C -> Block n C C
-          shiftRight (BHead b1 b2)  b3 = shiftRight b1 (BTail b2 b3)
-          shiftRight b1@(BFirst {}) b2 = BClosed b1 b2
+frontBiasBlock blk = case blk of
+   BlockCO f b   -> BlockCO f (fb b BNil)
+   BlockOC   b n -> BlockOC   (fb b BNil) n
+   BlockCC f b n -> BlockCC f (fb b BNil) n
+   b@BNil{}      -> fb b BNil
+   b@BMiddle{}   -> fb b BNil
+   b@BCat{}      -> fb b BNil
+   b@BHead{}     -> fb b BNil
+   b@BTail{}     -> fb b BNil
+ where
+   fb :: Block n O O -> Block n O O -> Block n O O
+   fb BNil        rest = rest
+   fb (BMiddle n) rest = BTail n rest
+   fb (BCat l r)  rest = fb l (fb r rest)
+   fb (BTail n b) rest = BTail n (fb b rest)
+   fb (BHead b n) rest = fb b (BTail n rest)
 
 -- | A block is "back biased" if the right child of every
 -- concatenation operation is a node, not a general block; a
@@ -107,21 +131,19 @@ frontBiasBlock   (BClosed h t) = shiftRight h t
 -- can be back-biased; an open/closed block is inherently front-biased.
 
 backBiasBlock :: Block n e x -> Block n e x
-backBiasBlock b@(BFirst  {}) = b
-backBiasBlock b@(BMiddle {}) = b
-backBiasBlock b@(BLast   {}) = b
-backBiasBlock b@(BCat {}) = rotate b
-  where -- rotate and append ensure every right child of Cat is Middle
-        -- provided 1st argument to append already has this property
-    rotate :: Block n O O -> Block n O O
-    append :: Block n O O -> Block n O O -> Block n O O
-    rotate (BCat h t)     = append (rotate h) t
-    rotate b@(BMiddle {}) = b
-    append h b@(BMiddle {}) = h `BCat` b
-    append b1 (BCat b2 b3) = (b1 `append` b2) `append` b3
-backBiasBlock b@(BHead {}) = b -- statically back-biased
-backBiasBlock b@(BTail {}) = b -- front-biased by nature; cannot fix
-backBiasBlock (BClosed h t) = shiftLeft h t
-    where shiftLeft :: Block n C O -> Block n O C -> Block n C C
-          shiftLeft b1 (BTail b2 b3) = shiftLeft (BHead b1 b2) b3
-          shiftLeft b1 b2@(BLast {}) = BClosed b1 b2
+backBiasBlock blk = case blk of
+   BlockCO f b   -> BlockCO f (bb BNil b)
+   BlockOC   b n -> BlockOC   (bb BNil b) n
+   BlockCC f b n -> BlockCC f (bb BNil b) n
+   b@BNil{}      -> bb BNil b
+   b@BMiddle{}   -> bb BNil b
+   b@BCat{}      -> bb BNil b
+   b@BHead{}     -> bb BNil b
+   b@BTail{}     -> bb BNil b
+ where
+   bb :: Block n O O -> Block n O O -> Block n O O
+   bb rest BNil = rest
+   bb rest (BMiddle n) = BHead rest n
+   bb rest (BCat l r) = bb (bb rest l) r
+   bb rest (BTail n b) = bb (BHead rest n) b
+   bb rest (BHead b n) = BHead (bb rest b) n
index a8d40ea..e8a7f0b 100644 (file)
@@ -78,6 +78,7 @@ instance IsMap LabelMap where
   mapEmpty = LM mapEmpty
   mapSingleton (Label k) v = LM (mapSingleton k v)
   mapInsert (Label k) v (LM m) = LM (mapInsert k v m)
+  mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)
   mapDelete (Label k) (LM m) = LM (mapDelete k m)
 
   mapUnion (LM x) (LM y) = LM (mapUnion x y)
@@ -95,6 +96,7 @@ instance IsMap LabelMap where
   mapKeys (LM m) = map uniqueToLbl (mapKeys m)
   mapToList (LM m) = [(uniqueToLbl k, v) | (k, v) <- mapToList m]
   mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])
+  mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])
 
 -----------------------------------------------------------------------------
 -- FactBase
index 6efbd83..d20a327 100644 (file)
@@ -70,8 +70,8 @@ class GraphRep g where
   mkMiddle :: n O O -> g n O O
   -- | Create a graph from a last node
   mkLast   :: n O C -> g n O C
-  mkFirst = mkExit  . BFirst
-  mkLast  = mkEntry . BLast
+  mkFirst n = mkExit (BlockCO n BNil)
+  mkLast  n = mkEntry (BlockOC BNil n)
   infixl 3 <*>
   infixl 2 |*><*| 
   -- | Concatenate two graphs; control flows from left to right.
index 383727f..e3015e1 100644 (file)
@@ -28,13 +28,14 @@ showGraph node = g
             open b g_entry ++ body g_blocks ++ open b g_exit
         body blocks = concatMap b (mapElems blocks)
         b :: forall e x . Block n e x -> String
-        b (BFirst  n)     = node n
-        b (BMiddle n)     = node n
-        b (BLast   n)     = node n ++ "\n"
+        b (BlockCO l b1)   = node l ++ "\n" ++ b b1
+        b (BlockCC l b1 n) = node l ++ "\n" ++ b b1 ++ node n ++ "\n"
+        b (BlockOC   b1 n) =           b b1 ++ node n ++ "\n"
+        b (BNil)          = ""
+        b (BMiddle n)     = node n ++ "\n"
         b (BCat b1 b2)    = b b1   ++ b b2
         b (BHead b1 n)    = b b1   ++ node n ++ "\n"
-        b (BTail n b1)    = node n ++ b b1
-        b (BClosed b1 b2) = b b1   ++ b b2
+        b (BTail n b1)    = node n ++ "\n" ++ b b1
 
 open :: (a -> String) -> MaybeO z a -> String
 open _ NothingO  = ""
index 6b4a570..99c3b45 100644 (file)
@@ -78,6 +78,7 @@ instance IsMap UniqueMap where
   mapEmpty = UM M.empty
   mapSingleton (Unique k) v = UM (M.singleton k v)
   mapInsert (Unique k) v (UM m) = UM (M.insert k v m)
+  mapInsertWith f (Unique k) v (UM m) = UM (M.insertWith f k v m)
   mapDelete (Unique k) (UM m) = UM (M.delete k m)
 
   mapUnion (UM x) (UM y) = UM (M.union x y)
@@ -95,6 +96,7 @@ instance IsMap UniqueMap where
   mapKeys (UM m) = map intToUnique (M.keys m)
   mapToList (UM m) = [(intToUnique k, v) | (k, v) <- M.toList m]
   mapFromList assocs = UM (M.fromList [(uniqueToInt k, v) | (k, v) <- assocs])
+  mapFromListWith f assocs = UM (M.fromListWith f [(uniqueToInt k, v) | (k, v) <- assocs])
 
 ----------------------------------------------------------------
 -- Monads
index 94dd8d1..e4f9cbe 100644 (file)
@@ -33,7 +33,7 @@ gUnitCC :: NonLocal (block n) => block n C C -> Graph' block n C C
 gUnitOO b = GUnit b
 gUnitOC b = GMany (JustO b) emptyBody  NothingO
 gUnitCO b = GMany NothingO  emptyBody (JustO b)
-gUnitCC b = GMany NothingO  (addBlock b emptyBody) NothingO
+gUnitCC b = GMany NothingO (addBlock b emptyBody) NothingO
 
 
 catGraphNodeOO ::            Graph n e O -> n O O -> Graph n e O
@@ -42,41 +42,33 @@ catNodeOOGraph ::            n O O -> Graph n O x -> Graph n O x
 catNodeCOGraph :: NonLocal n => n C O -> Graph n O x -> Graph n C x
 
 catGraphNodeOO GNil                     n = gUnitOO $ BMiddle n
-catGraphNodeOO (GUnit b)                n = gUnitOO $ b `BCat` BMiddle n
-catGraphNodeOO (GMany e body (JustO x)) n = GMany e body (JustO $ x `BHead` n)
+catGraphNodeOO (GUnit b)                n = gUnitOO $ BHead b n
+catGraphNodeOO (GMany e body (JustO (BlockCO f b))) n
+  = GMany e body (JustO (BlockCO f (BHead b n)))
 
-catGraphNodeOC GNil                     n = gUnitOC $ BLast n
-catGraphNodeOC (GUnit b)                n = gUnitOC $ addToLeft b $ BLast n
-  where addToLeft :: Block n O O -> Block n O C -> Block n O C
-        addToLeft (BMiddle m)    g = m `BTail` g
-        addToLeft (b1 `BCat` b2) g = addToLeft b1 $ addToLeft b2 g
-catGraphNodeOC (GMany e body (JustO x)) n = GMany e body' NothingO
-  where body' = addBlock (x `BClosed` BLast n) body
+catGraphNodeOC GNil                     n = gUnitOC $ BlockOC BNil n
+catGraphNodeOC (GUnit b)                n = gUnitOC $ BlockOC b n
+catGraphNodeOC (GMany e body (JustO (BlockCO f x))) n
+  = GMany e (addBlock (BlockCC f x n) body) NothingO
 
 catNodeOOGraph n GNil                     = gUnitOO $ BMiddle n
-catNodeOOGraph n (GUnit b)                = gUnitOO $ BMiddle n `BCat` b
-catNodeOOGraph n (GMany (JustO e) body x) = GMany (JustO $ n `BTail` e) body x
+catNodeOOGraph n (GUnit b)                = gUnitOO $ BTail n b
+catNodeOOGraph n (GMany (JustO (BlockOC b l)) body x)
+   = GMany (JustO (BlockOC (n `BTail` b) l)) body x
 
-catNodeCOGraph n GNil                     = gUnitCO $ BFirst n
-catNodeCOGraph n (GUnit b)                = gUnitCO $ addToRight (BFirst n) b
-  where addToRight :: Block n C O -> Block n O O -> Block n C O
-        addToRight g (BMiddle m)    = g `BHead` m
-        addToRight g (b1 `BCat` b2) = addToRight (addToRight g b1) b2
-catNodeCOGraph n (GMany (JustO e) body x) = GMany NothingO body' x
-  where body' = addBlock (BFirst n `BClosed` e) body
+catNodeCOGraph f GNil                     = gUnitCO (BlockCO f BNil)
+catNodeCOGraph f (GUnit b)                = gUnitCO (BlockCO f b)
+catNodeCOGraph f (GMany (JustO (BlockOC b n)) body x)
+  = GMany NothingO (addBlock (BlockCC f b n) body) x
 
 
-
-
-
-blockGraph :: NonLocal n => Block n e x -> Graph n e x
-blockGraph b@(BFirst  {}) = gUnitCO b
+blockGraph :: NonLocal n => Block n O x -> Graph n O x
+blockGraph b@(BlockOC {}) = gUnitOC b
+blockGraph   (BNil  {})   = GNil
 blockGraph b@(BMiddle {}) = gUnitOO b
-blockGraph b@(BLast   {}) = gUnitOC b
 blockGraph b@(BCat {})    = gUnitOO b
-blockGraph b@(BHead {})   = gUnitCO b
-blockGraph b@(BTail {})   = gUnitOC b
-blockGraph b@(BClosed {}) = gUnitCC b
+blockGraph b@(BHead {})   = gUnitOO b
+blockGraph b@(BTail {})   = gUnitOO b
 
 
 -- | Function 'graphMapBlocks' enables a change of representation of blocks,
@@ -94,17 +86,21 @@ graphMapBlocks f = map
         map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x)
 
 -- | Function 'blockMapNodes' enables a change of nodes in a block.
-blockMapNodes3 :: ( n C O -> n' C O
-                  , n O O -> n' O O
-                  , n O C -> n' O C)
+blockMapNodes3 :: forall n n' e x .
+                  ( n C O -> n' C O
+                  , n O O -> n' O O,
+                    n O C -> n' O C)
                -> Block n e x -> Block n' e x
-blockMapNodes3 (f, _, _) (BFirst n)     = BFirst (f n)
-blockMapNodes3 (_, m, _) (BMiddle n)    = BMiddle (m n)
-blockMapNodes3 (_, _, l) (BLast n)      = BLast (l n)
-blockMapNodes3 fs (BCat x y)            = BCat (blockMapNodes3 fs x) (blockMapNodes3 fs y)
-blockMapNodes3 fs@(_, m, _) (BHead x n) = BHead (blockMapNodes3 fs x) (m n)
-blockMapNodes3 fs@(_, m, _) (BTail n x) = BTail (m n) (blockMapNodes3 fs x)
-blockMapNodes3 fs (BClosed x y)         = BClosed (blockMapNodes3 fs x) (blockMapNodes3 fs y)
+blockMapNodes3 (f, m, l) b = go b
+  where go :: forall e x . Block n e x -> Block n' e x
+        go (BlockOC b y)   = (BlockOC $! go b) $! l y
+        go (BlockCO x b)   = (BlockCO $! f x) $! (go b)
+        go (BlockCC x b y) = ((BlockCC $! f x) $! go b) $! (l y)
+        go BNil            = BNil
+        go (BMiddle n)     = BMiddle $! m n
+        go (BCat x y)      = (BCat $! go x) $! (go y)
+        go (BHead x n)     = (BHead $! go x) $! (m n)
+        go (BTail n x)     = (BTail $! m n) $! (go x)
 
 blockMapNodes :: (forall e x. n e x -> n' e x)
               -> (Block n e x -> Block n' e x)
@@ -233,6 +229,7 @@ preorder_dfs_from_except blocks b visited =
                               return $ b `cons` bs
         get_children :: forall l. LabelsPtr l => l -> [block C C]
         get_children block = foldr add_id [] $ targetLabels block
+
         add_id id rst = case lookupFact id blocks of
                           Just b -> b : rst
                           Nothing -> rst
@@ -243,7 +240,8 @@ cons a as tail = a : as tail
 
 ----------------------------------------------------------------
 
-labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x -> LabelSet
+labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x
+              -> LabelSet
 labelsDefined GNil      = setEmpty
 labelsDefined (GUnit{}) = setEmpty
 labelsDefined (GMany _ body x) = mapFoldWithKey addEntry (exitLabel x) body
@@ -253,7 +251,8 @@ labelsDefined (GMany _ body x) = mapFoldWithKey addEntry (exitLabel x) body
         exitLabel NothingO  = setEmpty
         exitLabel (JustO b) = setSingleton (entryLabel b)
 
-labelsUsed :: forall block n e x. NonLocal (block n) => Graph' block n e x -> LabelSet
+labelsUsed :: forall block n e x. NonLocal (block n) => Graph' block n e x
+           -> LabelSet
 labelsUsed GNil      = setEmpty
 labelsUsed (GUnit{}) = setEmpty
 labelsUsed (GMany e body _) = mapFold addTargets (entryTargets e) body 
index 25e4866..2f06aba 100644 (file)
@@ -6,25 +6,40 @@
 -- | Utilities for clients of Hoopl, not used internally.
 
 module Compiler.Hoopl.XUtil
-  ( firstXfer, distributeXfer
-  , distributeFact, distributeFactBwd
+  (
+    -- * Utilities for clients
+
+    -- ** Simple operations on blocks
+    isEmptyBlock
+  , firstNode, lastNode, endNodes
+  , blockSplitHead, blockSplitTail, blockSplit
+  , blockJoinHead, blockJoinTail, blockJoin
+  , blockAppend
+  , replaceFirstNode, replaceLastNode
+  , blockToList, blockFromList
+
+    -- ** Other operations
+  , {- firstXfer, distributeXfer
+  , -} distributeFact, distributeFactBwd
   , successorFacts
   , joinFacts
   , joinOutFacts -- deprecated
   , joinMaps
   , foldGraphNodes
   , foldBlockNodesF, foldBlockNodesB, foldBlockNodesF3, foldBlockNodesB3
+  {-
   , tfFoldBlock
   , ScottBlock(ScottBlock), scottFoldBlock
   , fbnf3
+  -}
   , blockToNodeList, blockOfNodeList
   , blockToNodeList'   -- alternate version using fold
-  , blockToNodeList''  -- alternate version using scottFoldBlock
+  {-, blockToNodeList''  -- alternate version using scottFoldBlock
   , blockToNodeList''' -- alternate version using tfFoldBlock
   , analyzeAndRewriteFwdBody, analyzeAndRewriteBwdBody
   , analyzeAndRewriteFwdOx, analyzeAndRewriteBwdOx
   , noEntries
-  , BlockResult(..), lookupBlock
+  , BlockResult(..), lookupBlock-}
   )
 where
 
@@ -35,9 +50,80 @@ import Compiler.Hoopl.Checkpoint
 import Compiler.Hoopl.Collections
 import Compiler.Hoopl.Dataflow
 import Compiler.Hoopl.Graph
+import Compiler.Hoopl.GraphUtil
 import Compiler.Hoopl.Label
 import Compiler.Hoopl.Util
 
+-- -----------------------------------------------------------------------------
+-- Simple operations on Blocks
+
+isEmptyBlock :: Block n e x -> Bool
+isEmptyBlock BNil       = True
+isEmptyBlock (BCat l r) = isEmptyBlock l && isEmptyBlock r
+isEmptyBlock _          = False
+
+
+firstNode :: Block n C x -> n C O
+firstNode (BlockCO n _)   = n
+firstNode (BlockCC n _ _) = n
+
+lastNode :: Block n x C -> n O C
+lastNode (BlockOC   _ n) = n
+lastNode (BlockCC _ _ n) = n
+
+endNodes :: Block n C C -> (n C O, n O C)
+endNodes (BlockCC f _ l) = (f,l)
+
+
+blockSplitHead :: Block n C x -> (n C O, Block n O x)
+blockSplitHead (BlockCO n b)   = (n, b)
+blockSplitHead (BlockCC n b t) = (n, BlockOC b t)
+
+blockSplitTail :: Block n e C -> (Block n e O, n O C)
+blockSplitTail (BlockOC b n)   = (b, n)
+blockSplitTail (BlockCC f b t) = (BlockCO f b, t)
+
+blockSplit :: Block n C C -> (n C O, Block n O O, n O C)
+blockSplit (BlockCC f b t) = (f, b, t)
+
+blockJoinHead :: n C O -> Block n O x -> Block n C x
+blockJoinHead f (BlockOC b l) = BlockCC f b l
+blockJoinHead f b = BlockCO f BNil `cat` b
+
+blockJoinTail :: Block n e O -> n O C -> Block n e C
+blockJoinTail (BlockCO f b) t = BlockCC f b t
+blockJoinTail b t = b `cat` BlockOC BNil t
+
+blockJoin :: n C O -> Block n O O -> n O C -> Block n C C
+blockJoin f b t = BlockCC f b t
+
+blockAppend :: Block n e O -> Block n O x -> Block n e x
+blockAppend = cat
+
+replaceFirstNode :: Block n C x -> n C O -> Block n C x
+replaceFirstNode (BlockCO _ b)   f = BlockCO f b
+replaceFirstNode (BlockCC _ b n) f = BlockCC f b n
+
+replaceLastNode :: Block n x C -> n O C -> Block n x C
+replaceLastNode (BlockOC   b _) n = BlockOC b n
+replaceLastNode (BlockCC l b _) n = BlockCC l b n
+
+
+blockToList :: Block n O O -> [n O O]
+blockToList b = go b []
+   where go :: Block n O O -> [n O O] -> [n O O]
+         go BNil         r = r
+         go (BMiddle n)  r = n : r
+         go (BCat b1 b2) r = go b1 $! go b2 r
+         go (BHead b1 n) r = go b1 (n:r)
+         go (BTail n b1) r = n : go b1 r
+
+blockFromList :: [n O O] -> Block n O O
+blockFromList = foldr BTail BNil
+
+-----------------------------------------------------------------------------
+
+{-
 
 -- | Forward dataflow analysis and rewriting for the special case of a Body.
 -- A set of entry points must be supplied; blocks not reachable from
@@ -127,6 +213,7 @@ distributeXfer :: NonLocal n
 distributeXfer lattice xfer n f =
     mkFactBase lattice [ (l, xfer n f) | l <- successors n ]
 
+-}
 -- | This utility function handles a common case in which a transfer function
 -- for a last node takes the incoming fact unchanged and simply distributes
 -- that fact over the outgoing edges.
@@ -173,6 +260,7 @@ joinMaps eltJoin l (OldFact old) (NewFact new) = M.foldrWithKey add (NoChange, o
                         (NoChange,   _)  -> (ch, joinmap)
 
 
+{-
 
 -- | A fold function that relies on the IndexedCO type function.
 --   Note that the type parameter e is available to the functions
@@ -314,6 +402,7 @@ blockToNodeList'' = finish . unList . scottFoldBlock (ScottBlock f m l cat)
           finish (e, ms, x) = (e, ms [], x)
 
 
+-}
 
 blockToNodeList' :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C))
 blockToNodeList' b = unFNL $ foldBlockNodesF3''' ff fm fl b ()
@@ -334,27 +423,28 @@ foldBlockNodesF3''' :: forall n a b c .
                     -> (forall e x . MaybeC x (n O C) -> b e -> c e x)
                     -> (forall e x . Block n e x      -> a   -> c e x)
 foldBlockNodesF3''' ff fm fl = block
-  where block   :: forall e x . Block n e x -> a   -> c e x
-        blockCO ::              Block n C O -> a   -> b C
-        blockOO :: forall e .   Block n O O -> b e -> b e
-        blockOC :: forall e .   Block n O C -> b e -> c e C
-        block (b1 `BClosed` b2) = blockCO b1       `cat` blockOC b2
-        block (BFirst  node)    = ff (JustC node)  `cat` fl NothingC
-        block (b @ BHead {})    = blockCO b        `cat` fl NothingC
-        block (BMiddle node)    = ff NothingC `cat` fm node   `cat` fl NothingC
-        block (b @ BCat {})     = ff NothingC `cat` blockOO b `cat` fl NothingC
-        block (BLast   node)    = ff NothingC `cat` fl (JustC node)
-        block (b @ BTail {})    = ff NothingC `cat` blockOC b
-        blockCO (BFirst n)      = ff (JustC n)
-        blockCO (BHead b n)     = blockCO b `cat` fm n
-        blockOO (BMiddle n)     = fm n
-        blockOO (BCat b1 b2)    = blockOO b1 `cat` blockOO b2
-        blockOC (BLast n)       = fl (JustC n)
-        blockOC (BTail n b)     = fm n `cat` blockOC b
+  where
+        block   :: forall e x . Block n e x -> a   -> c e x
+        block (BlockCO f b)   = ff (JustC f) `cat` blockOO b `cat` fl NothingC
+        block (BlockCC f b l) = ff (JustC f) `cat` blockOO b `cat` fl (JustC l)
+        block (BlockOC   b l) = ff NothingC  `cat` blockOO b `cat` fl (JustC l)
+        block BNil            = ff NothingC  `cat`                 fl NothingC
+        block (BMiddle n)     = ff NothingC  `cat` fm n      `cat` fl NothingC
+        block b@BCat{}        = ff NothingC  `cat` blockOO b `cat` fl NothingC
+        block b@BHead{}       = ff NothingC  `cat` blockOO b `cat` fl NothingC
+        block b@BTail{}       = ff NothingC  `cat` blockOO b `cat` fl NothingC
+
+        blockOO :: forall e . Block n O O -> b e -> b e
+        blockOO BNil = id
+        blockOO (BMiddle n)  = fm n
+        blockOO (BCat b1 b2) = blockOO b1 `cat` blockOO b2
+        blockOO (BHead b1 n) = blockOO b1 `cat` fm n
+        blockOO (BTail n b1) = fm n `cat` blockOO b1
+
         cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
         f `cat` g = g . f 
 
-
+{-
 -- | The following function is easy enough to define but maybe not so useful
 foldBlockNodesF3' :: forall n a b c .
                    ( n C O -> a -> b
@@ -383,6 +473,7 @@ foldBlockNodesF3' (ff, fm, fl) missingFirst missingLast = block
         blockOC (BTail n b)  = fm n `cat` blockOC b
         cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
         f `cat` g = g . f 
+-}
 
 -- | Fold a function over every node in a block, forward or backward.
 -- The fold function must be polymorphic in the shape of the nodes.
@@ -412,30 +503,33 @@ foldGraphNodes :: forall n a .
 
 foldBlockNodesF3 (ff, fm, fl) = block
   where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b
-        block (BFirst  node)    = ff node
+        block (BlockCO f b  )   = ff f `cat` block b
+        block (BlockCC f b l)   = ff f `cat` block b `cat` fl l
+        block (BlockOC   b l)   =            block b `cat` fl l
+        block BNil              = id
         block (BMiddle node)    = fm node
-        block (BLast   node)    = fl node
         block (b1 `BCat`    b2) = block b1 `cat` block b2
-        block (b1 `BClosed` b2) = block b1 `cat` block b2
         block (b1 `BHead` n)    = block b1 `cat` fm n
         block (n `BTail` b2)    = fm n `cat` block b2
         cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
         cat f f' = f' . f
+
 foldBlockNodesF f = foldBlockNodesF3 (f, f, f)
 
 foldBlockNodesB3 (ff, fm, fl) = block
   where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b
-        block (BFirst  node)    = ff node
+        block (BlockCO f b  )   = ff f `cat` block b
+        block (BlockCC f b l)   = ff f `cat` block b `cat` fl l
+        block (BlockOC   b l)   =            block b `cat` fl l
+        block BNil              = id
         block (BMiddle node)    = fm node
-        block (BLast   node)    = fl node
         block (b1 `BCat`    b2) = block b1 `cat` block b2
-        block (b1 `BClosed` b2) = block b1 `cat` block b2
         block (b1 `BHead` n)    = block b1 `cat` fm n
         block (n `BTail` b2)    = fm n `cat` block b2
         cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c
         cat f f' = f . f'
-foldBlockNodesB f = foldBlockNodesB3 (f, f, f)
 
+foldBlockNodesB f = foldBlockNodesB3 (f, f, f)
 
 foldGraphNodes f = graph
     where graph :: forall e x . Graph n e x -> a -> a
@@ -452,9 +546,10 @@ foldGraphNodes f = graph
           block :: Block n e x -> IndexedCO e a a -> IndexedCO x a a
           block = foldBlockNodesF f
 
-{-# DEPRECATED blockToNodeList, blockOfNodeList 
+{-
+{-# DEPRECATED blockToNodeList, blockOfNodeList
   "What justifies these functions?  Can they be eliminated?  Replaced with folds?" #-}
-
+-}
 
 
 -- | Convert a block to a list of nodes. The entry and exit node
@@ -467,34 +562,24 @@ foldGraphNodes f = graph
 -- on the shape of the block entry *and* exit.
 blockToNodeList :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C))
 blockToNodeList block = case block of
-  BFirst n    -> (JustC n, [], NothingC)
-  BMiddle n   -> (NothingC, [n], NothingC)
-  BLast n     -> (NothingC, [], JustC n)
-  BCat {}     -> (NothingC, foldOO block [], NothingC)
-  BHead x n   -> case foldCO x [n] of (f, m) -> (f, m, NothingC)
-  BTail n x   -> case foldOC x of (m, l) -> (NothingC, n : m, l)
-  BClosed x y -> case foldOC y of (m, l) -> case foldCO x m of (f, m') -> (f, m', l)
-  where foldCO :: Block n C O -> [n O O] -> (MaybeC C (n C O), [n O O])
-        foldCO (BFirst n) m  = (JustC n, m)
-        foldCO (BHead x n) m = foldCO x (n : m)
-
-        foldOO :: Block n O O -> [n O O] -> [n O O]
-        foldOO (BMiddle n) acc = n : acc
-        foldOO (BCat x y) acc  = foldOO x $ foldOO y acc
-
-        foldOC :: Block n O C -> ([n O O], MaybeC C (n O C))
-        foldOC (BLast n)   = ([], JustC n)
-        foldOC (BTail n x) = case foldOC x of (m, l) -> (n : m, l)
+  BlockCO f b   -> (JustC f,  blockToList b, NothingC)
+  BlockCC f b l -> (JustC f,  blockToList b, JustC l)
+  BlockOC   b l -> (NothingC, blockToList b, JustC l)
+  BNil          -> (NothingC, [],        NothingC)
+  BMiddle n     -> (NothingC, [n],       NothingC)
+  b@BCat{}      -> (NothingC, blockToList b, NothingC)
+  b@BTail{}     -> (NothingC, blockToList b, NothingC)
+  b@BHead{}     -> (NothingC, blockToList b, NothingC)
 
 -- | Convert a list of nodes to a block. The entry and exit node
 -- must or must not be present depending on the shape of the block.
 blockOfNodeList :: (MaybeC e (n C O), [n O O], MaybeC x (n O C)) -> Block n e x
 blockOfNodeList (NothingC, [], NothingC) = error "No nodes to created block from in blockOfNodeList"
-blockOfNodeList (NothingC, m, NothingC)  = foldr1 BCat (map BMiddle m)
-blockOfNodeList (NothingC, m, JustC l)   = foldr BTail (BLast l) m
-blockOfNodeList (JustC f, m, NothingC)   = foldl BHead (BFirst f) m
-blockOfNodeList (JustC f, m, JustC l)    = BClosed (BFirst f) $ foldr BTail (BLast l) m
-
+blockOfNodeList (NothingC, m, NothingC)  = blockFromList m
+blockOfNodeList (NothingC, m, JustC l)   = BlockOC   (blockFromList m) l
+blockOfNodeList (JustC f, m, NothingC)   = BlockCO f (blockFromList m)
+blockOfNodeList (JustC f, m, JustC l)    = BlockCC f (blockFromList m) l
+{-
 data BlockResult n x where
   NoBlock   :: BlockResult n x
   BodyBlock :: Block n C C -> BlockResult n x
@@ -509,3 +594,4 @@ lookupBlock (GMany _ body _) lbl =
     Nothing -> NoBlock
 lookupBlock GNil      _ = NoBlock
 lookupBlock (GUnit _) _ = NoBlock
+-}
index c2f78cd..024d585 100644 (file)
@@ -131,7 +131,7 @@ mlookup blame k m =
     Nothing -> throwError ("unknown lookup for " ++ blame)
 
 blookup :: String -> G -> Label -> EvalM v B
-blookup blame g lbl = 
-  case lookupBlock g lbl of
-    BodyBlock b -> return b
-    NoBlock     -> throwError ("unknown lookup for " ++ blame)
+blookup blame (GMany _ blks _) lbl =
+  case mapLookup lbl blks of
+    Just b  -> return b
+    Nothing -> throwError ("unknown lookup for " ++ blame)
index 72a5b14..6db804b 100644 (file)
@@ -1,6 +1,7 @@
 module Main (main) where
 
 import Test
+import System.IO
 
 -- Hardcoding test locations for now
 tests = map (\t -> "tests" ++ "/" ++ t)
@@ -8,5 +9,7 @@ tests = map (\t -> "tests" ++ "/" ++ t)
              ["if-test", "if-test2", "if-test3", "if-test4"])
 
 main :: IO ()
-main = do mapM (\x -> putStrLn ("Test:" ++ x) >> parseTest x >> optTest x) tests
+main = do hSetBuffering stdout NoBuffering
+          hSetBuffering stderr NoBuffering
+          mapM (\x -> putStrLn ("Test:" ++ x) >> parseTest x >> optTest x) tests
           return ()
index ea443f3..8c34b1c 100644 (file)
@@ -12,6 +12,7 @@ import IR
 import Live
 import Parse (parseCode)
 import Simplify
+import Debug.Trace
 
 parse :: String -> String -> ErrorM (M [Proc])
 parse file text =
@@ -52,6 +53,7 @@ optTest' file text =
     optProc proc@(Proc {entry, body, args}) =
       do { (body',  _, _) <- analyzeAndRewriteFwd fwd (JustC [entry]) body
                              (mapSingleton entry (initFact args))
+         ; trace (showProc (proc {body=body'})) $ return ()
          ; (body'', _, _) <- analyzeAndRewriteBwd bwd (JustC [entry]) body' mapEmpty
          ; return $ proc { body = body'' } }
     -- With debugging info: 
index 6c8869f..9ee7ffc 100644 (file)
@@ -1,3 +1,4 @@
+Test:tests/test1
 f(a, b) {
 L1:
   r0 = 3
@@ -11,6 +12,7 @@ L1:
   ret (7)
 }
 
+Test:tests/test2
 f(a, b) {
 L1:
   x = 5
@@ -33,14 +35,15 @@ L1:
   goto L2
 L2:
   if x > 0 then goto L3 else goto L4
-L4:
-  ret (y)
 L3:
   y = y + x
   x = x - 1
   goto L2
+L4:
+  ret (y)
 }
 
+Test:tests/test3
 f(x, y) {
 L1:
   goto L2
@@ -48,12 +51,12 @@ L2:
   if x > 0 then goto L3 else goto L4
 L3:
   (z) = f(x - 1, y - 1) goto L5
+L4:
+  ret (y)
 L5:
   y = y + z
   x = x - 1
   goto L2
-L4:
-  ret (y)
 }
 
 f(x, y) {
@@ -61,16 +64,17 @@ L1:
   goto L2
 L2:
   if x > 0 then goto L3 else goto L4
-L4:
-  ret (y)
 L3:
   (z) = f(x - 1, y - 1) goto L5
+L4:
+  ret (y)
 L5:
   y = y + z
   x = x - 1
   goto L2
 }
 
+Test:tests/test4
 f(x) {
 L1:
   y = 5
@@ -93,6 +97,7 @@ L4:
   ret ((x + 5) + 4)
 }
 
+Test:tests/if-test
 f() {
 L1:
   x = 3 + 4
@@ -111,6 +116,7 @@ L2:
   ret (1)
 }
 
+Test:tests/if-test2
 f(a) {
 L1:
   x = 3 + 4
@@ -122,6 +128,8 @@ L3:
   a = a - 1
   res = res + x
   if x > 5 then goto L5 else goto L6
+L4:
+  ret (res)
 L5:
   goto L7
 L6:
@@ -129,8 +137,6 @@ L6:
   goto L7
 L7:
   goto L2
-L4:
-  ret (res)
 }
 
 f(a) {
@@ -139,18 +145,19 @@ L1:
   goto L2
 L2:
   if a > 0 then goto L3 else goto L4
-L4:
-  ret (res)
 L3:
   a = a - 1
   res = res + 7
   goto L5
+L4:
+  ret (res)
 L5:
   goto L7
 L7:
   goto L2
 }
 
+Test:tests/if-test3
 f(x) {
 L1:
   if x > 5 then goto L2 else goto L3
@@ -167,14 +174,15 @@ L4:
 f(x) {
 L1:
   if x > 5 then goto L2 else goto L3
-L3:
-  goto L4
 L2:
   goto L4
+L3:
+  goto L4
 L4:
   ret (1)
 }
 
+Test:tests/if-test4
 f(x) {
 L1:
   if x > 5 then goto L2 else goto L3
@@ -191,12 +199,12 @@ L4:
 f(x) {
 L1:
   if x > 5 then goto L2 else goto L3
-L3:
-  z = 2
-  goto L4
 L2:
   z = 1
   goto L4
+L3:
+  z = 2
+  goto L4
 L4:
   ret (z)
 }