diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,10 @@ +3.8.7.0 + Works with GHC 7 (thanks Edward Yang) + cabal sdist now sort of works (and is added to validate) + +3.8.6.0 + Matches the camera-ready Haskell'10 paper + 3.8.1.0 Major reorganization per simonpj visit to Tufts 20 April 2010 diff --git a/Compiler/Hoopl.hs b/Compiler/Hoopl.hs deleted file mode 100644 --- a/Compiler/Hoopl.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Compiler.Hoopl - ( module Compiler.Hoopl.Graph - , module Compiler.Hoopl.MkGraph - , module Compiler.Hoopl.XUtil - , module Compiler.Hoopl.Collections - , module Compiler.Hoopl.Checkpoint - , module Compiler.Hoopl.Dataflow - , module Compiler.Hoopl.Label - , module Compiler.Hoopl.Pointed - , module Compiler.Hoopl.Combinators - , module Compiler.Hoopl.Fuel - , module Compiler.Hoopl.Unique - , module Compiler.Hoopl.Util - , module Compiler.Hoopl.Debug - , module Compiler.Hoopl.Show - ) -where - -import Compiler.Hoopl.Checkpoint -import Compiler.Hoopl.Collections -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, FuelMonadT) -import Compiler.Hoopl.Graph hiding - ( Body - , BCat, BHead, BTail, BClosed -- OK to expose BFirst, BMiddle, BLast - ) -import Compiler.Hoopl.Graph (Body) -import Compiler.Hoopl.Label hiding (uniqueToLbl, lblToUnique) -import Compiler.Hoopl.MkGraph -import Compiler.Hoopl.Pointed -import Compiler.Hoopl.Show -import Compiler.Hoopl.Util -import Compiler.Hoopl.Unique hiding (uniqueToInt) -import Compiler.Hoopl.XUtil diff --git a/Compiler/Hoopl/Checkpoint.hs b/Compiler/Hoopl/Checkpoint.hs deleted file mode 100644 --- a/Compiler/Hoopl/Checkpoint.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module Compiler.Hoopl.Checkpoint - ( CheckpointMonad(..) - ) -where - --- | Obeys the following law: --- for all @m@ --- @ --- do { s <- checkpoint; m; restart s } == return () --- @ -class Monad m => CheckpointMonad m where - type Checkpoint m - checkpoint :: m (Checkpoint m) - restart :: Checkpoint m -> m () - diff --git a/Compiler/Hoopl/Collections.hs b/Compiler/Hoopl/Collections.hs deleted file mode 100644 --- a/Compiler/Hoopl/Collections.hs +++ /dev/null @@ -1,85 +0,0 @@ -{- Baseclasses for Map-like and Set-like collections inspired by containers. -} - -{-# LANGUAGE TypeFamilies #-} -module Compiler.Hoopl.Collections ( IsSet(..) - , setInsertList, setDeleteList, setUnions - , IsMap(..) - , mapInsertList, mapDeleteList, mapUnions - ) where - -import Data.List (foldl', foldl1') - -class IsSet set where - type ElemOf set - - setNull :: set -> Bool - setSize :: set -> Int - setMember :: ElemOf set -> set -> Bool - - setEmpty :: set - setSingleton :: ElemOf set -> set - setInsert :: ElemOf set -> set -> set - setDelete :: ElemOf set -> set -> set - - setUnion :: set -> set -> set - setDifference :: set -> set -> set - setIntersection :: set -> set -> set - setIsSubsetOf :: set -> set -> Bool - - setFold :: (ElemOf set -> b -> b) -> b -> set -> b - - setElems :: set -> [ElemOf set] - setFromList :: [ElemOf set] -> set - --- Helper functions for IsSet class -setInsertList :: IsSet set => [ElemOf set] -> set -> set -setInsertList keys set = foldl' (flip setInsert) set keys - -setDeleteList :: IsSet set => [ElemOf set] -> set -> set -setDeleteList keys set = foldl' (flip setDelete) set keys - -setUnions :: IsSet set => [set] -> set -setUnions [] = setEmpty -setUnions sets = foldl1' setUnion sets - - -class IsMap map where - type KeyOf map - - mapNull :: map a -> Bool - mapSize :: map a -> Int - mapMember :: KeyOf map -> map a -> Bool - mapLookup :: KeyOf map -> map a -> Maybe a - mapFindWithDefault :: a -> KeyOf map -> map a -> a - - mapEmpty :: map a - mapSingleton :: KeyOf map -> a -> map a - mapInsert :: KeyOf map -> a -> map a -> map a - mapDelete :: KeyOf map -> map a -> map a - - mapUnion :: map a -> map a -> map a - mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a - mapDifference :: map a -> map a -> map a - mapIntersection :: map a -> map a -> map a - mapIsSubmapOf :: Eq a => map a -> map a -> Bool - - mapMap :: (a -> b) -> map a -> map b - mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b - mapFold :: (a -> b -> b) -> b -> map a -> b - mapFoldWithKey :: (KeyOf map -> a -> b -> b) -> b -> map a -> b - - mapElems :: map a -> [a] - mapKeys :: map a -> [KeyOf map] - mapToList :: map a -> [(KeyOf map, a)] - mapFromList :: [(KeyOf map, a)] -> map a - --- Helper functions for IsMap class -mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a -mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs - -mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a -mapDeleteList keys map = foldl' (flip mapDelete) map keys - -mapUnions :: IsMap map => [map a] -> map a -mapUnions [] = mapEmpty -mapUnions maps = foldl1' mapUnion maps diff --git a/Compiler/Hoopl/Combinators.hs b/Compiler/Hoopl/Combinators.hs deleted file mode 100644 --- a/Compiler/Hoopl/Combinators.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# LANGUAGE RankNTypes, LiberalTypeSynonyms, ScopedTypeVariables, GADTs #-} - -module Compiler.Hoopl.Combinators - ( thenFwdRw - , deepFwdRw3, deepFwdRw, iterFwdRw - , thenBwdRw - , deepBwdRw3, deepBwdRw, iterBwdRw - , pairFwd, pairBwd, pairLattice - ) - -where - -import Control.Monad -import Data.Maybe - -import Compiler.Hoopl.Collections -import Compiler.Hoopl.Dataflow -import Compiler.Hoopl.Fuel -import Compiler.Hoopl.Graph (Graph, C, O, Shape(..)) -import Compiler.Hoopl.Label - ----------------------------------------------------------------- - -deepFwdRw3 :: FuelMonad m - => (n C O -> f -> m (Maybe (Graph n C O))) - -> (n O O -> f -> m (Maybe (Graph n O O))) - -> (n O C -> f -> m (Maybe (Graph n O C))) - -> (FwdRewrite m n f) -deepFwdRw :: FuelMonad m - => (forall e x . n e x -> f -> m (Maybe (Graph n e x))) -> FwdRewrite m n f -deepFwdRw3 f m l = iterFwdRw $ mkFRewrite3 f m l -deepFwdRw f = deepFwdRw3 f f f - --- N.B. rw3, rw3', and rw3a are triples of functions. --- But rw and rw' are single functions. --- @ start comb1.tex -thenFwdRw :: Monad m - => FwdRewrite m n f - -> FwdRewrite m n f - -> FwdRewrite m n f --- @ end comb1.tex -thenFwdRw rw3 rw3' = wrapFR2 thenrw rw3 rw3' - where - thenrw rw rw' n f = rw n f >>= fwdRes - where fwdRes Nothing = rw' n f - fwdRes (Just gr) = return $ Just $ fadd_rw rw3' gr - --- @ start iterf.tex -iterFwdRw :: Monad m - => FwdRewrite m n f - -> FwdRewrite m n f --- @ end iterf.tex -iterFwdRw rw3 = wrapFR iter rw3 - where iter rw n = (liftM $ liftM $ fadd_rw (iterFwdRw rw3)) . rw n - _iter = frewrite_cps (return . Just . fadd_rw (iterFwdRw rw3)) (return Nothing) - --- | Function inspired by 'rew' in the paper -frewrite_cps :: Monad m - => ((Graph n e x, FwdRewrite m n f) -> m a) - -> m a - -> (forall e x . n e x -> f -> m (Maybe (Graph n e x, FwdRewrite m n f))) - -> n e x - -> f - -> m a -frewrite_cps j n rw node f = - do mg <- rw node f - case mg of Nothing -> n - Just gr -> j gr - - - --- | Function inspired by 'add' in the paper -fadd_rw :: Monad m - => FwdRewrite m n f - -> (Graph n e x, FwdRewrite m n f) - -> (Graph n e x, FwdRewrite m n f) -fadd_rw rw2 (g, rw1) = (g, rw1 `thenFwdRw` rw2) - ----------------------------------------------------------------- - -deepBwdRw3 :: FuelMonad m - => (n C O -> f -> m (Maybe (Graph n C O))) - -> (n O O -> f -> m (Maybe (Graph n O O))) - -> (n O C -> FactBase f -> m (Maybe (Graph n O C))) - -> (BwdRewrite m n f) -deepBwdRw :: FuelMonad m - => (forall e x . n e x -> Fact x f -> m (Maybe (Graph n e x))) - -> BwdRewrite m n f -deepBwdRw3 f m l = iterBwdRw $ mkBRewrite3 f m l -deepBwdRw f = deepBwdRw3 f f f - - -thenBwdRw :: Monad m => BwdRewrite m n f -> BwdRewrite m n f -> BwdRewrite m n f -thenBwdRw rw1 rw2 = wrapBR2 f rw1 rw2 - where f _ rw1 rw2' n f = do - res1 <- rw1 n f - case res1 of - Nothing -> rw2' n f - Just gr -> return $ Just $ badd_rw rw2 gr - -iterBwdRw :: Monad m => BwdRewrite m n f -> BwdRewrite m n f -iterBwdRw rw = wrapBR f rw - where f _ rw' n f = liftM (liftM (badd_rw (iterBwdRw rw))) (rw' n f) - --- | Function inspired by 'add' in the paper -badd_rw :: Monad m - => BwdRewrite m n f - -> (Graph n e x, BwdRewrite m n f) - -> (Graph n e x, BwdRewrite m n f) -badd_rw rw2 (g, rw1) = (g, rw1 `thenBwdRw` rw2) - - --- @ start pairf.tex -pairFwd :: Monad m - => FwdPass m n f - -> FwdPass m n f' - -> FwdPass m n (f, f') --- @ end pairf.tex -pairFwd pass1 pass2 = FwdPass lattice transfer rewrite - where - lattice = pairLattice (fp_lattice pass1) (fp_lattice pass2) - transfer = mkFTransfer3 (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2) - where - tf t1 t2 n (f1, f2) = (t1 n f1, t2 n f2) - tfb t1 t2 n (f1, f2) = mapMapWithKey withfb2 fb1 - where fb1 = t1 n f1 - fb2 = t2 n f2 - withfb2 l f = (f, fromMaybe bot2 $ lookupFact l fb2) - bot2 = fact_bot (fp_lattice pass2) - (tf1, tm1, tl1) = getFTransfer3 (fp_transfer pass1) - (tf2, tm2, tl2) = getFTransfer3 (fp_transfer pass2) - rewrite = lift fst (fp_rewrite pass1) `thenFwdRw` lift snd (fp_rewrite pass2) - where - lift proj = wrapFR project - where project rw = \n pair -> liftM (liftM repair) $ rw n (proj pair) - repair (g, rw') = (g, lift proj rw') - -pairBwd :: forall m n f f' . - Monad m => BwdPass m n f -> BwdPass m n f' -> BwdPass m n (f, f') -pairBwd pass1 pass2 = BwdPass lattice transfer rewrite - where - lattice = pairLattice (bp_lattice pass1) (bp_lattice pass2) - transfer = mkBTransfer3 (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2) - where - tf t1 t2 n (f1, f2) = (t1 n f1, t2 n f2) - tfb t1 t2 n fb = (t1 n $ mapMap fst fb, t2 n $ mapMap snd fb) - (tf1, tm1, tl1) = getBTransfer3 (bp_transfer pass1) - (tf2, tm2, tl2) = getBTransfer3 (bp_transfer pass2) - rewrite = lift fst (bp_rewrite pass1) `thenBwdRw` lift snd (bp_rewrite pass2) - where - lift :: forall f1 . - ((f, f') -> f1) -> BwdRewrite m n f1 -> BwdRewrite m n (f, f') - lift proj = wrapBR project - where project :: forall e x . Shape x - -> (n e x -> - Fact x f1 -> m (Maybe (Graph n e x, BwdRewrite m n f1))) - -> (n e x -> - Fact x (f,f') -> m (Maybe (Graph n e x, BwdRewrite m n (f,f')))) - project Open = - \rw n pair -> liftM (liftM repair) $ rw n ( proj pair) - project Closed = - \rw n pair -> liftM (liftM repair) $ rw n (mapMap proj pair) - repair (g, rw') = (g, lift proj rw') - -- XXX specialize repair so that the cost - -- of discriminating is one per combinator not one - -- per rewrite - -pairLattice :: forall f f' . - DataflowLattice f -> DataflowLattice f' -> DataflowLattice (f, f') -pairLattice l1 l2 = - DataflowLattice - { fact_name = fact_name l1 ++ " x " ++ fact_name l2 - , fact_bot = (fact_bot l1, fact_bot l2) - , fact_join = join - } - where - join lbl (OldFact (o1, o2)) (NewFact (n1, n2)) = (c', (f1, f2)) - where (c1, f1) = fact_join l1 lbl (OldFact o1) (NewFact n1) - (c2, f2) = fact_join l2 lbl (OldFact o2) (NewFact n2) - c' = case (c1, c2) of - (NoChange, NoChange) -> NoChange - _ -> SomeChange diff --git a/Compiler/Hoopl/Dataflow.hs b/Compiler/Hoopl/Dataflow.hs deleted file mode 100644 --- a/Compiler/Hoopl/Dataflow.hs +++ /dev/null @@ -1,809 +0,0 @@ -{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, MultiParamTypeClasses #-} - -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 - , wrapFR, wrapFR2 - , BwdPass(..), BwdTransfer, mkBTransfer, mkBTransfer3, getBTransfer3 - , wrapBR, wrapBR2 - , BwdRewrite, mkBRewrite, mkBRewrite3, getBRewrite3, noBwdRewrite - , analyzeAndRewriteFwd, analyzeAndRewriteBwd - ) -where - -import Control.Monad -import Data.Maybe - -import Compiler.Hoopl.Checkpoint -import Compiler.Hoopl.Collections -import Compiler.Hoopl.Fuel -import Compiler.Hoopl.Graph hiding (Graph) -- hiding so we can redefine - -- and include definition in paper -import qualified Compiler.Hoopl.GraphUtil as U -import Compiler.Hoopl.Label -import Compiler.Hoopl.Util - ------------------------------------------------------------------------------ --- DataflowLattice ------------------------------------------------------------------------------ - -data DataflowLattice a = DataflowLattice - { fact_name :: String -- Documentation - , fact_bot :: a -- Lattice bottom element - , fact_join :: JoinFun a -- Lattice join plus change flag - -- (changes iff result > old fact) - } --- ^ A transfer function might want to use the logging flag --- to control debugging, as in for example, it updates just one element --- in a big finite map. We don't want Hoopl to show the whole fact, --- and only the transfer function knows exactly what changed. - -type JoinFun a = Label -> OldFact a -> NewFact a -> (ChangeFlag, a) - -- the label argument is for debugging purposes only -newtype OldFact a = OldFact a -newtype NewFact a = NewFact a - -data ChangeFlag = NoChange | SomeChange deriving (Eq, Ord) -changeIf :: Bool -> ChangeFlag -changeIf changed = if changed then SomeChange else NoChange - - --- | 'mkFactBase' creates a 'FactBase' from a list of ('Label', fact) --- pairs. If the same label appears more than once, the relevant facts --- are joined. - -mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f -mkFactBase lattice = foldl add mapEmpty - where add map (lbl, f) = mapInsert lbl newFact map - where newFact = case mapLookup lbl map of - Nothing -> f - Just f' -> snd $ join lbl (OldFact f') (NewFact f) - join = fact_join lattice - - ------------------------------------------------------------------------------ --- Analyze and rewrite forward: the interface ------------------------------------------------------------------------------ - -data FwdPass m n f - = FwdPass { fp_lattice :: DataflowLattice f - , fp_transfer :: FwdTransfer n f - , fp_rewrite :: FwdRewrite m n f } - -newtype FwdTransfer n f - = FwdTransfer3 { getFTransfer3 :: - ( n C O -> f -> f - , n O O -> f -> f - , n O C -> f -> FactBase f - ) } - -newtype FwdRewrite m n f -- see Note [Respects Fuel] - = FwdRewrite3 { getFRewrite3 :: - ( n C O -> f -> m (Maybe (Graph n C O, FwdRewrite m n f)) - , n O O -> f -> m (Maybe (Graph n O O, FwdRewrite m n f)) - , n O C -> f -> m (Maybe (Graph n O C, FwdRewrite m n f)) - ) } - -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'))) - ) - -- ^ This argument may assume that any function passed to it - -- respects fuel, and it must return a result that respects fuel. - -> 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 - :: (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))) - ) - -- ^ This argument may assume that any function passed to it - -- respects fuel, and it must return a result that respects fuel. - -> FwdRewrite m1 n1 f1 - -> FwdRewrite m2 n2 f2 - -> FwdRewrite m3 n3 f3 -- see Note [Respects Fuel] -wrapFR2 wrap2 (FwdRewrite3 (f1, m1, l1)) (FwdRewrite3 (f2, m2, l2)) = - FwdRewrite3 (wrap2 f1 f2, wrap2 m1 m2, wrap2 l1 l2) - - -mkFTransfer3 :: (n C O -> f -> f) - -> (n O O -> f -> f) - -> (n O C -> f -> FactBase f) - -> FwdTransfer n f -mkFTransfer3 f m l = FwdTransfer3 (f, m, l) - -mkFTransfer :: (forall e x . n e x -> f -> Fact x f) -> FwdTransfer n f -mkFTransfer f = FwdTransfer3 (f, f, f) - --- | Functions passed to 'mkFRewrite3' should not be aware of the fuel supply. --- The result returned by 'mkFRewrite3' respects fuel. -mkFRewrite3 :: FuelMonad m - => (n C O -> f -> m (Maybe (Graph n C O))) - -> (n O O -> f -> m (Maybe (Graph n O O))) - -> (n O C -> f -> m (Maybe (Graph n O C))) - -> FwdRewrite m n f -mkFRewrite3 f m l = FwdRewrite3 (lift f, lift m, lift l) - where lift rw node fact = liftM (liftM asRew) (withFuel =<< rw node fact) - asRew g = (g, noFwdRewrite) - -noFwdRewrite :: Monad m => FwdRewrite m n f -noFwdRewrite = FwdRewrite3 (noRewrite, noRewrite, noRewrite) - -noRewrite :: Monad m => a -> b -> m (Maybe c) -noRewrite _ _ = return Nothing - - - --- | Functions passed to 'mkFRewrite' should not be aware of the fuel supply. --- The result returned by 'mkFRewrite' respects fuel. -mkFRewrite :: FuelMonad m => (forall e x . n e x -> f -> m (Maybe (Graph n e x))) - -> FwdRewrite m n f -mkFRewrite f = mkFRewrite3 f f f - - -type family Fact x f :: * -type instance Fact C f = FactBase f -type instance Fact O f = f - --- | if the graph being analyzed is open at the entry, there must --- be no other entry point, or all goes horribly wrong... -analyzeAndRewriteFwd - :: forall m n f e x entries. (CheckpointMonad m, NonLocal n, LabelsPtr entries) - => FwdPass m n f - -> MaybeC e entries - -> Graph n e x -> Fact e f - -> m (Graph n e x, FactBase f, MaybeO x f) -analyzeAndRewriteFwd pass entries g f = - do (rg, fout) <- arfGraph pass (fmap targetLabels entries) g f - let (g', fb) = normalizeGraph rg - return (g', fb, distinguishedExitFact g' fout) - -distinguishedExitFact :: forall n e x f . Graph n e x -> Fact x f -> MaybeO x f -distinguishedExitFact g f = maybe g - where maybe :: Graph n e x -> MaybeO x f - maybe GNil = JustO f - maybe (GUnit {}) = JustO f - maybe (GMany _ _ x) = case x of NothingO -> NothingO - JustO _ -> JustO f - ----------------------------------------------------------------- --- Forward Implementation ----------------------------------------------------------------- - -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 - 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) - type ARFX thing = forall e x . thing e x -> Fact e f -> m (DG f n e x, Fact x f) - -} - graph :: Graph n e x -> Fact e f -> m (DG f n e x, Fact x f) --- @ start block.tex -2 - block :: forall e x . - Block n e x -> f -> m (DG f n e x, Fact x f) --- @ end block.tex --- @ start node.tex -4 - node :: forall e x . (ShapeLifter e x) - => n e x -> f -> m (DG f n e x, Fact x f) --- @ end node.tex --- @ start bodyfun.tex - body :: [Label] -> LabelMap (Block n C C) - -> Fact C f -> m (DG f n C C, Fact C f) --- @ end bodyfun.tex - -- Outgoing factbase is restricted to Labels *not* in - -- in the Body; the facts for Labels *in* - -- the Body are in the 'DG f n C C' --- @ start cat.tex -2 - cat :: forall e a x f1 f2 f3. - (f1 -> m (DG f n e a, f2)) - -> (f2 -> m (DG f n a x, f3)) - -> (f1 -> m (DG f n e x, f3)) --- @ end cat.tex - - graph GNil = \f -> return (dgnil, f) - graph (GUnit blk) = block blk - graph (GMany e bdy x) = (e `ebcat` bdy) `cat` exit x - where - ebcat :: MaybeO e (Block n O C) -> Body n -> Fact e f -> m (DG f n e C, Fact C f) - exit :: MaybeO x (Block n C O) -> Fact C f -> m (DG f n C x, Fact x f) - exit (JustO blk) = arfx block blk - exit NothingO = \fb -> return (dgnilC, fb) - ebcat entry bdy = c entries entry - where c :: MaybeC e [Label] -> MaybeO e (Block n O C) - -> Fact e f -> m (DG f n e C, Fact C f) - c NothingC (JustO entry) = block entry `cat` body (successors entry) bdy - c (JustC entries) NothingO = body entries bdy - c _ _ = error "bogus GADT pattern match failure" - - -- Lift from nodes to blocks --- @ start block.tex -2 - block (BFirst n) = 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 - ; case grw of - Nothing -> return ( singletonDG f n - , ftransfer pass n f ) - Just (g, rw) -> - let pass' = pass { fp_rewrite = rw } - f' = fwdEntryFact n f - in arfGraph pass' (fwdEntryLabel n) g f' } - --- @ end node.tex - - -- | Compose fact transformers and concatenate the resulting - -- rewritten graphs. - {-# INLINE cat #-} --- @ start cat.tex -2 - cat ft1 ft2 f = do { (g1,f1) <- ft1 f - ; (g2,f2) <- ft2 f1 - ; return (g1 `dgSplice` g2, f2) } --- @ end cat.tex - arfx :: forall thing x . - NonLocal thing - => (thing C x -> f -> m (DG f n C x, Fact x f)) - -> (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 - - - -- Outgoing factbase is restricted to Labels *not* in - -- in the Body; the facts for Labels *in* - -- 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 - where - blocks = forwardBlockList entries blockmap - lattice = fp_lattice pass - do_block b fb = block b entryFact - where entryFact = getFact lattice (entryLabel b) fb --- @ end bodyfun.tex - - --- Join all the incoming facts with bottom. --- We know the results _shouldn't change_, but the transfer --- functions might, for example, generate some debugging traces. -joinInFacts :: DataflowLattice f -> FactBase f -> FactBase f -joinInFacts (lattice @ DataflowLattice {fact_bot = bot, fact_join = fj}) fb = - mkFactBase lattice $ map botJoin $ mapToList fb - where botJoin (l, f) = (l, snd $ fj l (OldFact bot) (NewFact f)) - -forwardBlockList :: (NonLocal n, LabelsPtr entry) - => entry -> Body n -> [Block n C C] --- This produces a list of blocks in order suitable for forward analysis, --- along with the list of Labels it may depend on for facts. -forwardBlockList entries blks = postorder_dfs_from blks entries - ------------------------------------------------------------------------------ --- Backward analysis and rewriting: the interface ------------------------------------------------------------------------------ - -data BwdPass m n f - = BwdPass { bp_lattice :: DataflowLattice f - , bp_transfer :: BwdTransfer n f - , bp_rewrite :: BwdRewrite m n f } - -newtype BwdTransfer n f - = BwdTransfer3 { getBTransfer3 :: - ( n C O -> f -> f - , n O O -> f -> f - , n O C -> FactBase f -> f - ) } -newtype BwdRewrite m n f - = BwdRewrite3 { getBRewrite3 :: - ( n C O -> f -> m (Maybe (Graph n C O, BwdRewrite m n f)) - , n O O -> f -> m (Maybe (Graph n O O, BwdRewrite m n f)) - , n O C -> FactBase f -> m (Maybe (Graph n O C, BwdRewrite m n f)) - ) } - -wrapBR :: (forall e x . - Shape x - -> (n e x -> Fact x f -> m (Maybe (Graph n e x, BwdRewrite m n f ))) - -> (n' e x -> Fact x f' -> m' (Maybe (Graph n' e x, BwdRewrite m' n' f'))) - ) - -- ^ This argument may assume that any function passed to it - -- respects fuel, and it must return a result that respects fuel. - -> BwdRewrite m n f - -> BwdRewrite m' n' f' -- see Note [Respects Fuel] -wrapBR wrap (BwdRewrite3 (f, m, l)) = - BwdRewrite3 (wrap Open f, wrap Open m, wrap Closed l) - -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))) - -> (n3 e x -> Fact x f3 -> m3 (Maybe (Graph n3 e x, BwdRewrite m3 n3 f3)))) - -- ^ This argument may assume that any function passed to it - -- respects fuel, and it must return a result that respects fuel. - -> BwdRewrite m1 n1 f1 - -> BwdRewrite m2 n2 f2 - -> BwdRewrite m3 n3 f3 -- see Note [Respects Fuel] -wrapBR2 wrap2 (BwdRewrite3 (f1, m1, l1)) (BwdRewrite3 (f2, m2, l2)) = - BwdRewrite3 (wrap2 Open f1 f2, wrap2 Open m1 m2, wrap2 Closed l1 l2) - - - -mkBTransfer3 :: (n C O -> f -> f) -> (n O O -> f -> f) -> - (n O C -> FactBase f -> f) -> BwdTransfer n f -mkBTransfer3 f m l = BwdTransfer3 (f, m, l) - -mkBTransfer :: (forall e x . n e x -> Fact x f -> f) -> BwdTransfer n f -mkBTransfer f = BwdTransfer3 (f, f, f) - --- | Functions passed to 'mkBRewrite3' should not be aware of the fuel supply. --- The result returned by 'mkBRewrite3' respects fuel. -mkBRewrite3 :: FuelMonad m - => (n C O -> f -> m (Maybe (Graph n C O))) - -> (n O O -> f -> m (Maybe (Graph n O O))) - -> (n O C -> FactBase f -> m (Maybe (Graph n O C))) - -> BwdRewrite m n f -mkBRewrite3 f m l = BwdRewrite3 (lift f, lift m, lift l) - where lift rw node fact = liftM (liftM asRew) (withFuel =<< rw node fact) - asRew g = (g, noBwdRewrite) - -noBwdRewrite :: Monad m => BwdRewrite m n f -noBwdRewrite = BwdRewrite3 (noRewrite, noRewrite, noRewrite) - --- | Functions passed to 'mkBRewrite' should not be aware of the fuel supply. --- The result returned by 'mkBRewrite' respects fuel. -mkBRewrite :: FuelMonad m - => (forall e x . n e x -> Fact x f -> m (Maybe (Graph n e x))) - -> BwdRewrite m n f -mkBRewrite f = mkBRewrite3 f f f - - ------------------------------------------------------------------------------ --- Backward implementation ------------------------------------------------------------------------------ - -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 - 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) - type ARBX thing = forall e x . thing e x -> Fact x f -> m (DG f n e x, Fact e f) - -} - graph :: Graph n e x -> Fact x f -> m (DG f n e x, Fact e f) - block :: forall e x . Block n e x -> Fact x f -> m (DG f n e x, f) - node :: forall e x . (ShapeLifter e x) - => n e x -> Fact x f -> m (DG f n e x, f) - body :: [Label] -> Body n -> Fact C f -> m (DG f n C C, Fact C f) - cat :: forall e a x info info' info''. - (info' -> m (DG f n e a, info'')) - -> (info -> m (DG f n a x, info')) - -> (info -> m (DG f n e x, info'')) - - graph GNil = \f -> return (dgnil, f) - graph (GUnit blk) = block blk - graph (GMany e bdy x) = (e `ebcat` bdy) `cat` exit x - where - ebcat :: MaybeO e (Block n O C) -> Body n -> Fact C f -> m (DG f n e C, Fact e f) - exit :: MaybeO x (Block n C O) -> Fact x f -> m (DG f n C x, Fact C f) - exit (JustO blk) = arbx block blk - exit NothingO = \fb -> return (dgnilC, fb) - ebcat entry bdy = c entries entry - where c :: MaybeC e [Label] -> MaybeO e (Block n O C) - -> Fact C f -> m (DG f n e C, Fact e f) - c NothingC (JustO entry) = block entry `cat` body (successors entry) bdy - c (JustC entries) NothingO = body entries bdy - c _ _ = error "bogus GADT pattern match failure" - - -- Lift from nodes to blocks - block (BFirst n) = 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 - ; case bwdres of - Nothing -> return (singletonDG entry_f n, entry_f) - where entry_f = btransfer pass n f - Just (g, rw) -> - do { let pass' = pass { bp_rewrite = rw } - ; (g, f) <- arbGraph pass' (fwdEntryLabel n) g f - ; return (g, bwdEntryFact (bp_lattice pass) n f)} } - - -- | Compose fact transformers and concatenate the resulting - -- rewritten graphs. - {-# INLINE cat #-} - cat ft1 ft2 f = do { (g2,f2) <- ft2 f - ; (g1,f1) <- ft1 f2 - ; return (g1 `dgSplice` g2, f1) } - - arbx :: forall thing x . - NonLocal thing - => (thing C x -> Fact x f -> m (DG f n C x, f)) - -> (thing C x -> Fact x f -> m (DG f n C x, Fact C f)) - - arbx arb thing f = do { (rg, f) <- arb thing f - ; let fb = joinInFacts (bp_lattice pass) $ - mapSingleton (entryLabel thing) f - ; return (rg, fb) } - -- joinInFacts adds debugging information - - -- Outgoing factbase is restricted to Labels *not* in - -- 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 - where - blocks = backwardBlockList entries blockmap - 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. -backwardBlockList entries body = reverse $ forwardBlockList entries body - -{- - -The forward and backward cases are not dual. In the forward case, the -entry points are known, and one simply traverses the body blocks from -those points. In the backward case, something is known about the exit -points, but this information is essentially useless, because we don't -actually have a dual graph (that is, one with edges reversed) to -compute with. (Even if we did have a dual graph, it would not avail -us---a backward analysis must include reachable blocks that don't -reach the exit, as in a procedure that loops forever and has side -effects.) - --} - - --- | if the graph being analyzed is open at the exit, I don't --- quite understand the implications of possible other exits -analyzeAndRewriteBwd - :: (CheckpointMonad m, NonLocal n, LabelsPtr entries) - => BwdPass m n f - -> MaybeC e entries -> Graph n e x -> Fact x f - -> m (Graph n e x, FactBase f, MaybeO e f) -analyzeAndRewriteBwd pass entries g f = - do (rg, fout) <- arbGraph pass (fmap targetLabels entries) g f - let (g', fb) = normalizeGraph rg - return (g', fb, distinguishedEntryFact g' fout) - -distinguishedEntryFact :: forall n e x f . Graph n e x -> Fact e f -> MaybeO e f -distinguishedEntryFact g f = maybe g - where maybe :: Graph n e x -> MaybeO e f - maybe GNil = JustO f - maybe (GUnit {}) = JustO f - maybe (GMany e _ _) = case e of NothingO -> NothingO - JustO _ -> JustO f - ------------------------------------------------------------------------------ --- 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) --- 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) - where - (cha2, res_fact) -- Note [Unreachable blocks] - = case lookupFact lbl fbase of - Nothing -> (SomeChange, new_fact_debug) -- Note [Unreachable blocks] - Just old_fact -> join old_fact - where join old_fact = - 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 - - -{- --- this doesn't work because it can't be implemented -class Monad m => FixpointMonad m where - observeChangedFactBase :: m (Maybe (FactBase f)) -> Maybe (FactBase f) --} - --- @ start fptype.tex -data Direction = Fwd | Bwd -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] - -> (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 - -- 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 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 = 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 - - -{- Note [TxFactBase invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The TxFactBase is used only during a fixpoint iteration (or "sweep"), -and accumulates facts (and the transformed code) during the fixpoint -iteration. - -* tfb_fbase increases monotonically, across all sweeps - -* At the beginning of each sweep - tfb_cha = NoChange - tfb_lbls = {} - -* During each sweep we process each block in turn. Processing a block - is done thus: - 1. Read from tfb_fbase the facts for its entry label (forward) - or successors labels (backward) - 2. Transform those facts into new facts for its successors (forward) - or entry label (backward) - 3. Augment tfb_fbase with that info - We call the labels read in step (1) the "in-labels" of the sweep - -* The field tfb_lbls is the set of in-labels of all blocks that have - been processed so far this sweep, including the block that is - currently being processed. tfb_lbls is initialised to {}. It is a - subset of the Labels of the *original* (not transformed) blocks. - -* The tfb_cha field is set to SomeChange iff we decide we need to - perform another iteration of the fixpoint loop. It is initialsed to NoChange. - - Specifically, we set tfb_cha to SomeChange in step (3) iff - (a) The fact in tfb_fbase for a block L changes - (b) L is in tfb_lbls - Reason: until a label enters the in-labels its accumuated fact in tfb_fbase - has not been read, hence cannot affect the outcome - -Note [Unreachable blocks] -~~~~~~~~~~~~~~~~~~~~~~~~~ -A block that is not in the domain of tfb_fbase is "currently unreachable". -A currently-unreachable block is not even analyzed. 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 analyzed, 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 - -* Even if the fact is going from UNR to bottom, we still call the - client's fact_join function because it might give the client - some useful debugging information. - -* 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. --} - ------------------------------------------------------------------------------ --- DG: an internal data type for 'decorated graphs' --- TOTALLY internal to Hoopl; each block is decorated with a fact ------------------------------------------------------------------------------ - --- @ start dg.tex -type Graph = Graph' Block -type DG f = Graph' (DBlock f) -data DBlock f n e x = DBlock f (Block n e x) -- ^ block decorated with fact --- @ end dg.tex -instance NonLocal n => NonLocal (DBlock f n) where - entryLabel (DBlock _ b) = entryLabel b - successors (DBlock _ b) = successors b - ---- constructors - -dgnil :: DG f n O O -dgnilC :: DG f n C C -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 - -normalizeGraph g = (graphMapBlocks dropFact g, facts g) - where dropFact (DBlock _ b) = b - facts :: DG f n e x -> FactBase f - facts GNil = noFacts - facts (GUnit _) = noFacts - facts (GMany _ body exit) = bodyFacts body `mapUnion` exitFacts exit - exitFacts :: MaybeO x (DBlock f n C O) -> FactBase f - 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 (DBlock f b) fb = mapInsert (entryLabel b) f fb - ---- implementation of the constructors (boring) - -dgnil = GNil -dgnilC = GMany NothingO emptyBody NothingO - -dgSplice = U.splice fzCat - where fzCat (DBlock f b1) (DBlock _ b2) = DBlock f (b1 `U.cat` b2) - ----------------------------------------------------------------- --- Utilities ----------------------------------------------------------------- - --- Lifting based on shape: --- - from nodes to blocks --- - from facts to fact-like things --- Lowering back: --- - from fact-like things to facts --- Note that the latter two functions depend only on the entry shape. --- @ start node.tex -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 - -> 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 - -> Fact x f -> m (Maybe (Graph n e x, BwdRewrite m n f)) - -instance ShapeLifter C O where - singletonDG f = gUnitCO . DBlock f . BFirst - 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 - 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 - fwdEntryLabel _ = NothingC - -instance ShapeLifter O C where - singletonDG f = gUnitOC . DBlock f . BLast - 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 - fwdEntryLabel _ = NothingC - --- Fact lookup: the fact `orelse` bottom -getFact :: DataflowLattice f -> Label -> FactBase f -> f -getFact lat l fb = case lookupFact l fb of Just f -> f - Nothing -> fact_bot lat - - - -{- Note [Respects fuel] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --} --- $fuel --- A value of type 'FwdRewrite' or 'BwdRewrite' /respects fuel/ if --- any function contained within the value satisfies the following properties: --- --- * When fuel is exhausted, it always returns 'Nothing'. --- --- * When it returns @Just g rw@, it consumes /exactly/ one unit --- of fuel, and new rewrite 'rw' also respects fuel. --- --- Provided that functions passed to 'mkFRewrite', 'mkFRewrite3', --- 'mkBRewrite', and 'mkBRewrite3' are not aware of the fuel supply, --- the results respect fuel. --- --- It is an /unchecked/ run-time error for the argument passed to 'wrapFR', --- 'wrapFR2', 'wrapBR', or 'warpBR2' to return a function that does not respect fuel. diff --git a/Compiler/Hoopl/Debug.hs b/Compiler/Hoopl/Debug.hs deleted file mode 100644 --- a/Compiler/Hoopl/Debug.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables, FlexibleContexts #-} - -module Compiler.Hoopl.Debug - ( TraceFn , debugFwdJoins , debugBwdJoins - , debugFwdTransfers , debugBwdTransfers - ) -where - -import Compiler.Hoopl.Dataflow -import Compiler.Hoopl.Show - --------------------------------------------------------------------------------- --- | Debugging combinators: --- Each combinator takes a dataflow pass and produces --- a dataflow pass that can output debugging messages. --- You provide the function, we call it with the applicable message. --- --- The most common use case is probably to: --- --- 1. import 'Debug.Trace' --- --- 2. pass 'trace' as the 1st argument to the debug combinator --- --- 3. pass 'const true' as the 2nd argument to the debug combinator --- --- There are two kinds of debugging messages for a join, --- depending on whether the join is higher in the lattice than the old fact: --- 1. If the join is higher, we show: --- + Join@L: f1 `join` f2 = f' --- where: --- + indicates a change --- L is the label where the join takes place --- f1 is the old fact at the label --- f2 is the new fact we are joining to f1 --- f' is the result of the join --- 2. _ Join@L: f2 <= f1 --- where: --- _ indicates no change --- L is the label where the join takes place --- f1 is the old fact at the label (which remains unchanged) --- f2 is the new fact we joined with f1 --------------------------------------------------------------------------------- - - -debugFwdJoins :: forall m n f . Show f => TraceFn -> ChangePred -> FwdPass m n f -> FwdPass m n f -debugBwdJoins :: forall m n f . Show f => TraceFn -> ChangePred -> BwdPass m n f -> BwdPass m n f - -type TraceFn = forall a . String -> a -> a -type ChangePred = ChangeFlag -> Bool - -debugFwdJoins trace pred p = p { fp_lattice = debugJoins trace pred $ fp_lattice p } -debugBwdJoins trace pred p = p { bp_lattice = debugJoins trace pred $ bp_lattice p } - -debugJoins :: Show f => TraceFn -> ChangePred -> DataflowLattice f -> DataflowLattice f -debugJoins trace showPred l@(DataflowLattice {fact_join = join}) = l {fact_join = join'} - where - join' l f1@(OldFact of1) f2@(NewFact nf2) = - if showPred c then trace output res else res - where res@(c, f') = join l f1 f2 - output = case c of - SomeChange -> "+ Join@" ++ show l ++ ": " ++ show of1 ++ " `join` " - ++ show nf2 ++ " = " ++ show f' - NoChange -> "_ Join@" ++ show l ++ ": " ++ show nf2 ++ " <= " ++ show of1 - --------------------------------------------------------------------------------- --- Functions we'd like to have, but don't know how to implement generically: --------------------------------------------------------------------------------- - -type ShowN n = forall e x . n e x -> String -type FPred n f = forall e x . n e x -> f -> Bool -type BPred n f = forall e x . n e x -> Fact x f -> Bool -debugFwdTransfers:: - forall m n f . Show f => TraceFn -> ShowN n -> FPred n f -> FwdPass m n f -> FwdPass m n f -debugFwdTransfers trace showN showPred pass = pass { fp_transfer = transfers' } - where - (f, m, l) = getFTransfer3 $ fp_transfer pass - transfers' = mkFTransfer3 (wrap show f) (wrap show m) (wrap showFactBase l) - wrap :: forall e x . (Fact x f -> String) -> (n e x -> f -> Fact x f) -> n e x -> f -> Fact x f - wrap showOutF ft n f = if showPred n f then trace output res else res - where - res = ft n f - output = name ++ " transfer: " ++ show f ++ " -> " ++ showN n ++ " -> " ++ showOutF res - name = fact_name (fp_lattice pass) - -debugBwdTransfers:: - forall m n f . Show f => TraceFn -> ShowN n -> BPred n f -> BwdPass m n f -> BwdPass m n f -debugBwdTransfers trace showN showPred pass = pass { bp_transfer = transfers' } - where - (f, m, l) = getBTransfer3 $ bp_transfer pass - transfers' = mkBTransfer3 (wrap show f) (wrap show m) (wrap showFactBase l) - wrap :: forall e x . (Fact x f -> String) -> (n e x -> Fact x f -> f) -> n e x -> Fact x f -> f - wrap showInF ft n f = if showPred n f then trace output res else res - where - res = ft n f - output = name ++ " transfer: " ++ showInF f ++ " -> " ++ showN n ++ " -> " ++ show res - name = fact_name (bp_lattice pass) - - --- debugFwdTransfers, debugFwdRewrites, debugFwdAll :: --- forall m n f . Show f => TraceFn -> ShowN n -> FwdPass m n f -> FwdPass m n f --- debugBwdTransfers, debugBwdRewrites, debugBwdAll :: --- forall m n f . Show f => TraceFn -> ShowN n -> BwdPass m n f -> BwdPass m n f - diff --git a/Compiler/Hoopl/Fuel.hs b/Compiler/Hoopl/Fuel.hs deleted file mode 100644 --- a/Compiler/Hoopl/Fuel.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - ------------------------------------------------------------------------------ --- The fuel monad ------------------------------------------------------------------------------ - -module Compiler.Hoopl.Fuel - ( Fuel, infiniteFuel, fuelRemaining - , withFuel - , FuelMonad(..) - , FuelMonadT(..) - , CheckingFuelMonad - , InfiniteFuelMonad - , SimpleFuelMonad - ) -where - -import Compiler.Hoopl.Checkpoint -import Compiler.Hoopl.Unique - -class Monad m => FuelMonad m where - getFuel :: m Fuel - setFuel :: Fuel -> m () - --- | Find out how much fuel remains after a computation. --- Can be subtracted from initial fuel to get total consumption. -fuelRemaining :: FuelMonad m => m Fuel -fuelRemaining = getFuel - -class FuelMonadT fm where - runWithFuel :: (Monad m, FuelMonad (fm m)) => Fuel -> fm m a -> m a - - -type Fuel = Int - -withFuel :: FuelMonad m => Maybe a -> m (Maybe a) -withFuel Nothing = return Nothing -withFuel (Just a) = do f <- getFuel - if f == 0 - then return Nothing - else setFuel (f-1) >> return (Just a) - - ----------------------------------------------------------------- - -newtype CheckingFuelMonad m a = FM { unFM :: Fuel -> m (a, Fuel) } - -instance Monad m => Monad (CheckingFuelMonad m) where - return a = FM (\f -> return (a, f)) - fm >>= k = FM (\f -> do { (a, f') <- unFM fm f; unFM (k a) f' }) - -instance CheckpointMonad m => CheckpointMonad (CheckingFuelMonad m) where - type Checkpoint (CheckingFuelMonad m) = (Fuel, Checkpoint m) - checkpoint = FM $ \fuel -> do { s <- checkpoint - ; return ((fuel, s), fuel) } - restart (fuel, s) = FM $ \_ -> do { restart s; return ((), fuel) } - -instance UniqueMonad m => UniqueMonad (CheckingFuelMonad m) where - freshUnique = FM (\f -> do { l <- freshUnique; return (l, f) }) - -instance Monad m => FuelMonad (CheckingFuelMonad m) where - getFuel = FM (\f -> return (f, f)) - setFuel f = FM (\_ -> return ((),f)) - -instance FuelMonadT CheckingFuelMonad where - runWithFuel fuel m = do { (a, _) <- unFM m fuel; return a } - ----------------------------------------------------------------- - -newtype InfiniteFuelMonad m a = IFM { unIFM :: m a } -instance Monad m => Monad (InfiniteFuelMonad m) where - return a = IFM $ return a - m >>= k = IFM $ do { a <- unIFM m; unIFM (k a) } - -instance UniqueMonad m => UniqueMonad (InfiniteFuelMonad m) where - freshUnique = IFM $ freshUnique - -instance Monad m => FuelMonad (InfiniteFuelMonad m) where - getFuel = return infiniteFuel - setFuel _ = return () - -instance CheckpointMonad m => CheckpointMonad (InfiniteFuelMonad m) where - type Checkpoint (InfiniteFuelMonad m) = Checkpoint m - checkpoint = IFM checkpoint - restart s = IFM $ restart s - - - -instance FuelMonadT InfiniteFuelMonad where - runWithFuel _ = unIFM - -infiniteFuel :: Fuel -- effectively infinite, any, but subtractable -infiniteFuel = maxBound - -type SimpleFuelMonad = CheckingFuelMonad SimpleUniqueMonad - -{- -runWithFuelAndUniques :: Fuel -> [Unique] -> FuelMonad a -> a -runWithFuelAndUniques fuel uniques m = a - where (a, _, _) = unFM m fuel uniques - -freshUnique :: FuelMonad Unique -freshUnique = FM (\f (l:ls) -> (l, f, ls)) --} - diff --git a/Compiler/Hoopl/GHC.hs b/Compiler/Hoopl/GHC.hs deleted file mode 100644 --- a/Compiler/Hoopl/GHC.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE GADTs, RankNTypes #-} - -{- Exposing some internals to GHC -} -module Compiler.Hoopl.GHC - ( uniqueToInt - , uniqueToLbl, lblToUnique - , getFuel, setFuel - , bodyToBlockMap, bodyOfBlockMap - ) -where - -import Compiler.Hoopl.Fuel -import Compiler.Hoopl.Graph -import Compiler.Hoopl.Label -import Compiler.Hoopl.Unique - --- Converts Body to a map of closed/closed blocks. --- It should better be a constant-time operation --- as GHC is counting on it. -bodyToBlockMap :: Body' block n -> LabelMap (block n C C) -bodyToBlockMap (Body bodyMap) = bodyMap - -bodyOfBlockMap :: LabelMap (block n C C) -> Body' block n -bodyOfBlockMap = Body diff --git a/Compiler/Hoopl/Graph.hs b/Compiler/Hoopl/Graph.hs deleted file mode 100644 --- a/Compiler/Hoopl/Graph.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE GADTs, EmptyDataDecls, TypeFamilies #-} - -module Compiler.Hoopl.Graph - ( O, C, Block(..), Body, Body'(..), Graph, Graph'(..) - , MaybeO(..), MaybeC(..), Shape(..), IndexedCO - , NonLocal(entryLabel, successors) - , emptyBody, addBlock, bodyList - ) -where - -import Compiler.Hoopl.Collections -import Compiler.Hoopl.Label - ------------------------------------------------------------------------------ --- Graphs ------------------------------------------------------------------------------ - --- | Used at the type level to indicate an "open" structure with --- a unique, unnamed control-flow edge flowing in or out. --- "Fallthrough" and concatenation are permitted at an open point. -data O - - --- | Used at the type level to indicate a "closed" structure which --- supports control transfer only through the use of named --- labels---no "fallthrough" is permitted. The number of control-flow --- edges is unconstrained. -data C - --- | A sequence of nodes. May be any of four shapes (O/O, O/C, C/O, C/C). --- Open at the entry means single entry, mutatis mutandis for exit. --- A closed/closed block is a /basic/ block and can't be extended further. --- 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 - - -- 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 - - 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) -newtype Body' block n = Body (LabelMap (block n C C)) - --- | A control-flow graph, which may take any of four shapes (O/O, O/C, C/O, C/C). --- A graph open at the entry has a single, distinguished, anonymous entry point; --- if a graph is closed at the entry, its entry point(s) are supplied by a context. -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) - -> LabelMap (block n C C) - -> MaybeO x (block n C O) - -> Graph' block n e x - --- | Maybe type indexed by open/closed -data MaybeO ex t where - JustO :: t -> MaybeO O t - NothingO :: MaybeO C t - --- | Maybe type indexed by closed/open -data MaybeC ex t where - JustC :: t -> MaybeC C t - NothingC :: MaybeC O t - --- | Dynamic shape value -data Shape ex where - Closed :: Shape C - Open :: Shape O - --- | Either type indexed by closed/open using type families -type family IndexedCO ex a b :: * -type instance IndexedCO C a b = a -type instance IndexedCO O a b = b - -instance Functor (MaybeO ex) where - fmap _ NothingO = NothingO - fmap f (JustO a) = JustO (f a) - -instance Functor (MaybeC ex) where - fmap _ NothingC = NothingC - fmap f (JustC a) = JustC (f a) - -------------------------------- --- | Gives access to the anchor points for --- nonlocal edges as well as the edges themselves -class NonLocal thing where - entryLabel :: thing C x -> Label -- ^ The label of a first node or block - 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 - ------------------------------- -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 - -bodyList :: NonLocal (block n) => Body' block n -> [(Label,block n C C)] -bodyList (Body body) = mapToList body diff --git a/Compiler/Hoopl/GraphUtil.hs b/Compiler/Hoopl/GraphUtil.hs deleted file mode 100644 --- a/Compiler/Hoopl/GraphUtil.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-} - --- N.B. addBasicBlocks won't work on OO without a Node (branch/label) constraint - -module Compiler.Hoopl.GraphUtil - ( splice, gSplice , cat , bodyGraph, bodyUnion - , frontBiasBlock, backBiasBlock - ) - -where - -import Compiler.Hoopl.Collections -import Compiler.Hoopl.Graph -import Compiler.Hoopl.Label - -bodyGraph :: Body n -> Graph n C C -bodyGraph b = GMany NothingO b NothingO - -splice :: forall block n e a x . NonLocal (block n) => - (forall e x . block n e O -> block n O x -> block n e x) - -> (Graph' block n e a -> Graph' block n a x -> Graph' block n e x) -splice bcat = sp - where sp :: forall e a x . - Graph' block n e a -> Graph' block n a x -> Graph' block n e x - - sp GNil g2 = g2 - sp g1 GNil = g1 - - sp (GUnit b1) (GUnit b2) = GUnit (b1 `bcat` b2) - - sp (GUnit b) (GMany (JustO e) bs x) = GMany (JustO (b `bcat` e)) bs x - - sp (GMany e bs (JustO x)) (GUnit b2) = GMany e bs (JustO (x `bcat` b2)) - - sp (GMany e1 bs1 (JustO x1)) (GMany (JustO e2) b2 x2) - = 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 - - sp _ _ = error "bogus GADT match failure" - -bodyUnion :: forall a . LabelMap a -> LabelMap a -> LabelMap a -bodyUnion = mapUnionWithKey nodups - where nodups l _ _ = error $ "duplicate blocks with label " ++ show l - -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 - - ----------------------------------------------------------------- - --- | 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 :: 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 - --- | 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 :: 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 diff --git a/Compiler/Hoopl/Label.hs b/Compiler/Hoopl/Label.hs deleted file mode 100644 --- a/Compiler/Hoopl/Label.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Compiler.Hoopl.Label - ( Label - , freshLabel - , LabelSet, LabelMap - , FactBase, noFacts, lookupFact - - , uniqueToLbl -- MkGraph and GHC use only - , lblToUnique -- GHC use only - ) - -where - -import Compiler.Hoopl.Collections -import Compiler.Hoopl.Unique - ------------------------------------------------------------------------------ --- Label ------------------------------------------------------------------------------ - -newtype Label = Label { lblToUnique :: Unique } - deriving (Eq, Ord) - -uniqueToLbl :: Unique -> Label -uniqueToLbl = Label - -instance Show Label where - show (Label n) = "L" ++ show n - -freshLabel :: UniqueMonad m => m Label -freshLabel = freshUnique >>= return . uniqueToLbl - ------------------------------------------------------------------------------ --- LabelSet - -newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show) - -instance IsSet LabelSet where - type ElemOf LabelSet = Label - - setNull (LS s) = setNull s - setSize (LS s) = setSize s - setMember (Label k) (LS s) = setMember k s - - setEmpty = LS setEmpty - setSingleton (Label k) = LS (setSingleton k) - setInsert (Label k) (LS s) = LS (setInsert k s) - setDelete (Label k) (LS s) = LS (setDelete k s) - - setUnion (LS x) (LS y) = LS (setUnion x y) - setDifference (LS x) (LS y) = LS (setDifference x y) - setIntersection (LS x) (LS y) = LS (setIntersection x y) - setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y - - setFold k z (LS s) = setFold (k . uniqueToLbl) z s - - setElems (LS s) = map uniqueToLbl (setElems s) - setFromList ks = LS (setFromList (map lblToUnique ks)) - ------------------------------------------------------------------------------ --- LabelMap - -newtype LabelMap v = LM (UniqueMap v) deriving (Eq, Ord, Show) - -instance IsMap LabelMap where - type KeyOf LabelMap = Label - - mapNull (LM m) = mapNull m - mapSize (LM m) = mapSize m - mapMember (Label k) (LM m) = mapMember k m - mapLookup (Label k) (LM m) = mapLookup k m - mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m - - mapEmpty = LM mapEmpty - mapSingleton (Label k) v = LM (mapSingleton k v) - mapInsert (Label k) v (LM m) = LM (mapInsert k v m) - mapDelete (Label k) (LM m) = LM (mapDelete k m) - - mapUnion (LM x) (LM y) = LM (mapUnion x y) - mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . uniqueToLbl) x y) - mapDifference (LM x) (LM y) = LM (mapDifference x y) - mapIntersection (LM x) (LM y) = LM (mapIntersection x y) - mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y - - mapMap f (LM m) = LM (mapMap f m) - mapMapWithKey f (LM m) = LM (mapMapWithKey (f . uniqueToLbl) m) - mapFold k z (LM m) = mapFold k z m - mapFoldWithKey k z (LM m) = mapFoldWithKey (k . uniqueToLbl) z m - - mapElems (LM m) = mapElems m - 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]) - ------------------------------------------------------------------------------ --- FactBase - -type FactBase f = LabelMap f - -noFacts :: FactBase f -noFacts = mapEmpty - -lookupFact :: Label -> FactBase f -> Maybe f -lookupFact = mapLookup diff --git a/Compiler/Hoopl/MkGraph.hs b/Compiler/Hoopl/MkGraph.hs deleted file mode 100644 --- a/Compiler/Hoopl/MkGraph.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, GADTs, TypeSynonymInstances, FlexibleInstances, RankNTypes #-} -module Compiler.Hoopl.MkGraph - ( AGraph, graphOfAGraph, aGraphOfGraph - , (<*>), (|*><*|), catGraphs, addEntrySeq, addExitSeq, addBlocks, unionBlocks - , emptyGraph, emptyClosedGraph, withFresh - , mkFirst, mkMiddle, mkMiddles, mkLast, mkBranch, mkLabel, mkWhileDo - , IfThenElseable(mkIfThenElse) - , mkEntry, mkExit - , HooplNode(mkLabelNode, mkBranchNode) - ) -where - -import Compiler.Hoopl.Label (Label, uniqueToLbl) -import Compiler.Hoopl.Graph -import qualified Compiler.Hoopl.GraphUtil as U -import Compiler.Hoopl.Unique -import Control.Monad (liftM2) - -{-| -As noted in the paper, we can define a single, polymorphic type of -splicing operation with the very polymorphic type -@ - AGraph n e a -> AGraph n a x -> AGraph n e x -@ -However, we feel that this operation is a bit /too/ polymorphic, -and that it's too easy for clients to use it blindly without -thinking. We therfore split it into two operations, '<*>' and '|*><*|', -which are supplemented by other functions: - - * The '<*>' operator is true concatenation, for connecting open graphs. - Control flows from the left graph to the right graph. - - * The '|*><*|' operator splices together two graphs at a closed - point. Nothing is known about control flow. The vertical bar - stands for "closed point" just as the angle brackets above stand - for "open point". Unlike the <*> operator, the |*><*| can create - a control-flow graph with dangling outedges or unreachable blocks. - The operator must be used carefully, so we have chosen a long name - on purpose, to help call people's attention to what they're doing. - - * The operator 'addBlocks' adds a set of basic blocks (represented - as a closed/closed 'AGraph' to an existing graph, without changing - the shape of the existing graph. In some cases, it's necessary to - introduce a branch and a label to 'get around' the blocks added, - so this operator, and other functions based on it, requires a - 'HooplNode' type-class constraint and is available only on AGraph, - not Graph. - - * We have discussed a dynamic assertion about dangling outedges and - unreachable blocks, but nothing is implemented yet. - --} - - - -class GraphRep g where - -- | An empty graph that is open at entry and exit. - -- It is the left and right identity of '<*>'. - emptyGraph :: g n O O - -- | An empty graph that is closed at entry and exit. - -- It is the left and right identity of '|*><*|'. - emptyClosedGraph :: g n C C - -- | Create a graph from a first node - mkFirst :: n C O -> g n C O - -- | Create a graph from a middle node - 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 - infixl 3 <*> - infixl 2 |*><*| - -- | Concatenate two graphs; control flows from left to right. - (<*>) :: NonLocal n => g n e O -> g n O x -> g n e x - -- | Splice together two graphs at a closed point; nothing is known - -- about control flow. - (|*><*|) :: NonLocal n => g n e C -> g n C x -> g n e x - -- | Conveniently concatenate a sequence of open/open graphs using '<*>'. - catGraphs :: NonLocal n => [g n O O] -> g n O O - catGraphs = foldr (<*>) emptyGraph - - -- | Create a graph that defines a label - mkLabel :: HooplNode n => Label -> g n C O -- definition of the label - -- | Create a graph that branches to a label - mkBranch :: HooplNode n => Label -> g n O C -- unconditional branch to the label - - -- | Conveniently concatenate a sequence of middle nodes to form - -- an open/open graph. - mkMiddles :: NonLocal n => [n O O] -> g n O O - - mkLabel id = mkFirst $ mkLabelNode id - mkBranch target = mkLast $ mkBranchNode target - mkMiddles ms = catGraphs $ map mkMiddle ms - - -- | Create a graph containing only an entry sequence - mkEntry :: Block n O C -> g n O C - -- | Create a graph containing only an exit sequence - mkExit :: Block n C O -> g n C O - -instance GraphRep Graph where - emptyGraph = GNil - emptyClosedGraph = GMany NothingO emptyBody NothingO - (<*>) = U.gSplice - (|*><*|) = U.gSplice - mkMiddle = GUnit . BMiddle - mkExit block = GMany NothingO emptyBody (JustO block) - mkEntry block = GMany (JustO block) emptyBody NothingO - -instance GraphRep AGraph where - emptyGraph = aGraphOfGraph emptyGraph - emptyClosedGraph = aGraphOfGraph emptyClosedGraph - (<*>) = liftA2 (<*>) - (|*><*|) = liftA2 (|*><*|) - mkMiddle = aGraphOfGraph . mkMiddle - mkExit = aGraphOfGraph . mkExit - mkEntry = aGraphOfGraph . mkEntry - - --- | The type of abstract graphs. Offers extra "smart constructors" --- that may consume fresh labels during construction. -newtype AGraph n e x = - A { graphOfAGraph :: forall m. UniqueMonad m => - m (Graph n e x) -- ^ Take an abstract 'AGraph' - -- and make a concrete (if monadic) - -- 'Graph'. - } - --- | Take a graph and make it abstract. -aGraphOfGraph :: Graph n e x -> AGraph n e x -aGraphOfGraph g = A (return g) - - --- | The 'Labels' class defines things that can be lambda-bound --- by an argument to 'withFreshLabels'. Such an argument may --- lambda-bind a single 'Label', or if multiple labels are needed, --- it can bind a tuple. Tuples can be nested, so arbitrarily many --- fresh labels can be acquired in a single call. --- --- For example usage see implementations of 'mkIfThenElse' and 'mkWhileDo'. -class Uniques u where - withFresh :: (u -> AGraph n e x) -> AGraph n e x - -instance Uniques Unique where - withFresh f = A $ freshUnique >>= (graphOfAGraph . f) - -instance Uniques Label where - withFresh f = A $ freshUnique >>= (graphOfAGraph . f . uniqueToLbl) - --- | Lifts binary 'Graph' functions into 'AGraph' functions. -liftA2 :: (Graph n a b -> Graph n c d -> Graph n e f) - -> (AGraph n a b -> AGraph n c d -> AGraph n e f) -liftA2 f (A g) (A g') = A (liftM2 f g g') - --- | Extend an existing 'AGraph' with extra basic blocks "out of line". --- No control flow is implied. Simon PJ should give example use case. -addBlocks :: HooplNode n - => AGraph n e x -> AGraph n C C -> AGraph n e x -addBlocks (A g) (A blocks) = A $ g >>= \g -> blocks >>= add g - where add :: (UniqueMonad m, HooplNode n) - => Graph n e x -> Graph n C C -> m (Graph n e x) - add (GMany e body x) (GMany NothingO body' NothingO) = - return $ GMany e (body `U.bodyUnion` body') x - add g@GNil blocks = spliceOO g blocks - add g@(GUnit _) blocks = spliceOO g blocks - spliceOO :: (HooplNode n, UniqueMonad m) - => Graph n O O -> Graph n C C -> m (Graph n O O) - spliceOO g blocks = graphOfAGraph $ withFresh $ \l -> - A (return g) <*> mkBranch l |*><*| A (return blocks) |*><*| mkLabel l - --- | For some graph-construction operations and some optimizations, --- Hoopl must be able to create control-flow edges using a given node --- type 'n'. -class NonLocal n => HooplNode n where - -- | Create a branch node, the source of a control-flow edge. - mkBranchNode :: Label -> n O C - -- | Create a label node, the target (destination) of a control-flow edge. - mkLabelNode :: Label -> n C O - --------------------------------------------------------------- --- Shiny Things --------------------------------------------------------------- - -class IfThenElseable x where - -- | Translate a high-level if-then-else construct into an 'AGraph'. - -- The condition takes as arguments labels on the true-false branch - -- and returns a single-entry, two-exit graph which exits to - -- the two labels. - mkIfThenElse :: HooplNode n - => (Label -> Label -> AGraph n O C) -- ^ branch condition - -> AGraph n O x -- ^ code in the "then" branch - -> AGraph n O x -- ^ code in the "else" branch - -> AGraph n O x -- ^ resulting if-then-else construct - -mkWhileDo :: HooplNode n - => (Label -> Label -> AGraph n O C) -- ^ loop condition - -> AGraph n O O -- ^ body of the loop - -> AGraph n O O -- ^ the final while loop - -instance IfThenElseable O where - mkIfThenElse cbranch tbranch fbranch = withFresh $ \(endif, ltrue, lfalse) -> - cbranch ltrue lfalse |*><*| - mkLabel ltrue <*> tbranch <*> mkBranch endif |*><*| - mkLabel lfalse <*> fbranch <*> mkBranch endif |*><*| - mkLabel endif - -instance IfThenElseable C where - mkIfThenElse cbranch tbranch fbranch = withFresh $ \(ltrue, lfalse) -> - cbranch ltrue lfalse |*><*| - mkLabel ltrue <*> tbranch |*><*| - mkLabel lfalse <*> fbranch - -mkWhileDo cbranch body = withFresh $ \(test, head, endwhile) -> - -- Forrest Baskett's while-loop layout - mkBranch test |*><*| - mkLabel head <*> body <*> mkBranch test |*><*| - mkLabel test <*> cbranch head endwhile |*><*| - mkLabel endwhile - --------------------------------------------------------------- --- Boring instance declarations --------------------------------------------------------------- - - -instance (Uniques u1, Uniques u2) => Uniques (u1, u2) where - withFresh f = withFresh $ \u1 -> - withFresh $ \u2 -> - f (u1, u2) - -instance (Uniques u1, Uniques u2, Uniques u3) => Uniques (u1, u2, u3) where - withFresh f = withFresh $ \u1 -> - withFresh $ \u2 -> - withFresh $ \u3 -> - f (u1, u2, u3) - -instance (Uniques u1, Uniques u2, Uniques u3, Uniques u4) => Uniques (u1, u2, u3, u4) where - withFresh f = withFresh $ \u1 -> - withFresh $ \u2 -> - withFresh $ \u3 -> - withFresh $ \u4 -> - f (u1, u2, u3, u4) - ---------------------------------------------- --- deprecated legacy functions - -{-# DEPRECATED addEntrySeq, addExitSeq, unionBlocks "use |*><*| instead" #-} -addEntrySeq :: NonLocal n => AGraph n O C -> AGraph n C x -> AGraph n O x -addExitSeq :: NonLocal n => AGraph n e C -> AGraph n C O -> AGraph n e O -unionBlocks :: NonLocal n => AGraph n C C -> AGraph n C C -> AGraph n C C - -addEntrySeq = (|*><*|) -addExitSeq = (|*><*|) -unionBlocks = (|*><*|) diff --git a/Compiler/Hoopl/Passes/DList.hs b/Compiler/Hoopl/Passes/DList.hs deleted file mode 100644 --- a/Compiler/Hoopl/Passes/DList.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} - -module Compiler.Hoopl.Passes.DList - ( Doms, domEntry, domLattice - , domPass - ) -where - -import Compiler.Hoopl - - -type Doms = WithBot [Label] --- ^ List of labels, extended with a standard bottom element - --- | The fact that goes into the entry of a dominator analysis: the first node --- is dominated only by the entry point, which is represented by the empty list --- of labels. -domEntry :: Doms -domEntry = PElem [] - -domLattice :: DataflowLattice Doms -domLattice = addPoints "dominators" extend - -extend :: JoinFun [Label] -extend _ (OldFact l) (NewFact l') = (changeIf (l `lengthDiffers` j), j) - where j = lcs l l' - lcs :: [Label] -> [Label] -> [Label] -- longest common suffix - lcs l l' | length l > length l' = lcs (drop (length l - length l') l) l' - | length l < length l' = lcs l' l - | otherwise = dropUnlike l l' l - dropUnlike [] [] maybe_like = maybe_like - dropUnlike (x:xs) (y:ys) maybe_like = - dropUnlike xs ys (if x == y then maybe_like else xs) - dropUnlike _ _ _ = error "this can't happen" - - lengthDiffers [] [] = False - lengthDiffers (_:xs) (_:ys) = lengthDiffers xs ys - lengthDiffers [] (_:_) = True - lengthDiffers (_:_) [] = True - --- | Dominator pass -domPass :: (NonLocal n, Monad m) => FwdPass m n Doms -domPass = FwdPass domLattice (mkFTransfer3 first (const id) distributeFact) noFwdRewrite - where first n = fmap (entryLabel n:) diff --git a/Compiler/Hoopl/Passes/Dominator.hs b/Compiler/Hoopl/Passes/Dominator.hs deleted file mode 100644 --- a/Compiler/Hoopl/Passes/Dominator.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} - -module Compiler.Hoopl.Passes.Dominator - ( Doms, DPath(..), domPath, domEntry, domLattice, extendDom - , DominatorNode(..), DominatorTree(..), tree - , immediateDominators - , domPass - ) -where - -import Data.Maybe - -import Compiler.Hoopl - - -type Doms = WithBot DPath --- ^ List of labels, extended with a standard bottom element - --- | The fact that goes into the entry of a dominator analysis: the first node --- is dominated only by the entry point, which is represented by the empty list --- of labels. -domEntry :: Doms -domEntry = PElem (DPath []) - -newtype DPath = DPath [Label] - -- ^ represents part of the domination relation: each label - -- in a list is dominated by all its successors. This is a newtype only so - -- we can give it a fancy Show instance. - -instance Show DPath where - show (DPath ls) = concat (foldr (\l path -> show l : " -> " : path) ["entry"] ls) - -domPath :: Doms -> [Label] -domPath Bot = [] -- lies: an unreachable node appears to be dominated by the entry -domPath (PElem (DPath ls)) = ls - -extendDom :: Label -> DPath -> DPath -extendDom l (DPath ls) = DPath (l:ls) - -domLattice :: DataflowLattice Doms -domLattice = addPoints "dominators" extend - -extend :: JoinFun DPath -extend _ (OldFact (DPath l)) (NewFact (DPath l')) = - (changeIf (l `lengthDiffers` j), DPath j) - where j = lcs l l' - lcs :: [Label] -> [Label] -> [Label] -- longest common suffix - lcs l l' | length l > length l' = lcs (drop (length l - length l') l) l' - | length l < length l' = lcs l' l - | otherwise = dropUnlike l l' l - dropUnlike [] [] maybe_like = maybe_like - dropUnlike (x:xs) (y:ys) maybe_like = - dropUnlike xs ys (if x == y then maybe_like else xs) - dropUnlike _ _ _ = error "this can't happen" - - lengthDiffers [] [] = False - lengthDiffers (_:xs) (_:ys) = lengthDiffers xs ys - lengthDiffers [] (_:_) = True - lengthDiffers (_:_) [] = True - - - --- | Dominator pass -domPass :: (NonLocal n, Monad m) => FwdPass m n Doms -domPass = FwdPass domLattice (mkFTransfer3 first (const id) distributeFact) noFwdRewrite - where first n = fmap (extendDom $ entryLabel n) - ----------------------------------------------------------------- - -data DominatorNode = Entry | Labelled Label -data DominatorTree = Dominates DominatorNode [DominatorTree] --- ^ This data structure is a *rose tree* in which each node may have --- arbitrarily many children. Each node dominates all its descendants. - --- | Map from a FactBase for dominator lists into a --- dominator tree. -tree :: [(Label, Doms)] -> DominatorTree -tree facts = Dominates Entry $ merge $ map reverse $ map mkList facts - -- This code has been lightly tested. The key insight is this: to - -- find lists that all have the same head, convert from a list of - -- lists to a finite map, in 'children'. Then, to convert from the - -- finite map to list of dominator trees, use the invariant that - -- each key dominates all the lists of values. - where merge lists = mapTree $ children $ filter (not . null) lists - children = foldl addList noFacts - addList :: FactBase [[Label]] -> [Label] -> FactBase [[Label]] - addList map (x:xs) = mapInsert x (xs:existing) map - where existing = fromMaybe [] $ lookupFact x map - addList _ [] = error "this can't happen" - mapTree :: FactBase [[Label]] -> [DominatorTree] - mapTree map = [Dominates (Labelled x) (merge lists) | - (x, lists) <- mapToList map] - mkList (l, doms) = l : domPath doms - - -instance Show DominatorTree where - show = tree2dot - --- | Given a dominator tree, produce a string representation, in the --- input language of dot, that will enable dot to produce a --- visualization of the tree. For more info about dot see --- http://www.graphviz.org. - -tree2dot :: DominatorTree -> String -tree2dot t = concat $ "digraph {\n" : dot t ["}\n"] - where - dot :: DominatorTree -> [String] -> [String] - dot (Dominates root trees) = - (dotnode root :) . outedges trees . flip (foldl subtree) trees - where outedges [] = id - outedges (Dominates n _ : ts) = - \s -> " " : show root : " -> " : show n : "\n" : outedges ts s - dotnode Entry = " entryNode [shape=plaintext, label=\"entry\"]\n" - dotnode (Labelled l) = " " ++ show l ++ "\n" - subtree = flip dot - -instance Show DominatorNode where - show Entry = "entryNode" - show (Labelled l) = show l - ----------------------------------------------------------------- - --- | Takes FactBase from dominator analysis and returns a map from each --- label to its immediate dominator, if any -immediateDominators :: FactBase Doms -> LabelMap Label -immediateDominators = mapFoldWithKey add mapEmpty - where add l (PElem (DPath (idom:_))) = mapInsert l idom - add _ _ = id - diff --git a/Compiler/Hoopl/Pointed.hs b/Compiler/Hoopl/Pointed.hs deleted file mode 100644 --- a/Compiler/Hoopl/Pointed.hs +++ /dev/null @@ -1,147 +0,0 @@ -{-# LANGUAGE GADTs, ScopedTypeVariables #-} - --- | Possibly doubly pointed lattices - -module Compiler.Hoopl.Pointed - ( Pointed(..), addPoints, addPoints', addTop, addTop' - , liftJoinTop, extendJoinDomain - , WithTop, WithBot, WithTopAndBot - ) -where - -import Compiler.Hoopl.Graph -import Compiler.Hoopl.Label -import Compiler.Hoopl.Dataflow - --- | Adds top, bottom, or both to help form a lattice -data Pointed t b a where - Bot :: Pointed t C a - PElem :: a -> Pointed t b a - Top :: Pointed C b a - --- ^ The type parameters 't' and 'b' are used to say whether top --- and bottom elements have been added. The analogy with 'Block' --- is nearly exact: --- --- * A 'Block' is closed at the entry if and only if it has a first node; --- a 'Pointed' is closed at the top if and only if it has a top element. --- --- * A 'Block' is closed at the exit if and only if it has a last node; --- a 'Pointed' is closed at the bottom if and only if it has a bottom element. --- --- We thus have four possible types, of which three are interesting: --- --- [@Pointed C C a@] Type @a@ extended with both top and bottom elements. --- --- [@Pointed C O a@] Type @a@ extended with a top element --- only. (Presumably @a@ comes equipped with a bottom element of its own.) --- --- [@Pointed O C a@] Type @a@ extended with a bottom element only. --- --- [@Pointed O O a@] Isomorphic to @a@, and therefore not interesting. --- --- The advantage of all this GADT-ishness is that the constructors --- 'Bot', 'Top', and 'PElem' can all be used polymorphically. --- --- A 'Pointed t b' type is an instance of 'Functor' and 'Show'. - - - -type WithBot a = Pointed O C a --- ^ Type 'a' with a bottom element adjoined - -type WithTop a = Pointed C O a --- ^ Type 'a' with a top element adjoined - -type WithTopAndBot a = Pointed C C a --- ^ Type 'a' with top and bottom elements adjoined - - --- | Given a join function and a name, creates a semi lattice by --- adding a bottom element, and possibly a top element also. --- A specialized version of 'addPoints''. -addPoints :: String -> JoinFun a -> DataflowLattice (Pointed t C a) --- | A more general case for creating a new lattice -addPoints' :: forall a t . - String - -> (Label -> OldFact a -> NewFact a -> (ChangeFlag, Pointed t C a)) - -> DataflowLattice (Pointed t C a) - -addPoints name join = addPoints' name join' - where join' l o n = (change, PElem f) - where (change, f) = join l o n - -addPoints' name joinx = DataflowLattice name Bot join - where -- careful: order of cases matters for ChangeFlag - join :: JoinFun (Pointed t C a) - join _ (OldFact f) (NewFact Bot) = (NoChange, f) - join _ (OldFact Top) (NewFact _) = (NoChange, Top) - join _ (OldFact Bot) (NewFact f) = (SomeChange, f) - join _ (OldFact _) (NewFact Top) = (SomeChange, Top) - join l (OldFact (PElem old)) (NewFact (PElem new)) - = joinx l (OldFact old) (NewFact new) - - -liftJoinTop :: JoinFun a -> JoinFun (WithTop a) -extendJoinDomain :: forall a - . (Label -> OldFact a -> NewFact a -> (ChangeFlag, WithTop a)) - -> JoinFun (WithTop a) - -extendJoinDomain joinx = join - where join :: JoinFun (WithTop a) - join _ (OldFact Top) (NewFact _) = (NoChange, Top) - join _ (OldFact _) (NewFact Top) = (SomeChange, Top) - join l (OldFact (PElem old)) (NewFact (PElem new)) - = joinx l (OldFact old) (NewFact new) - -liftJoinTop joinx = extendJoinDomain (\l old new -> liftPair $ joinx l old new) - where liftPair (c, a) = (c, PElem a) - --- | Given a join function and a name, creates a semi lattice by --- adding a top element but no bottom element. Caller must supply the bottom --- element. -addTop :: DataflowLattice a -> DataflowLattice (WithTop a) --- | A more general case for creating a new lattice -addTop' :: forall a . - String - -> a - -> (Label -> OldFact a -> NewFact a -> (ChangeFlag, WithTop a)) - -> DataflowLattice (WithTop a) - -addTop lattice = addTop' name' (fact_bot lattice) join' - where name' = fact_name lattice ++ " + T" - join' l o n = (change, PElem f) - where (change, f) = fact_join lattice l o n - -addTop' name bot joinx = DataflowLattice name (PElem bot) join - where -- careful: order of cases matters for ChangeFlag - join :: JoinFun (WithTop a) - join _ (OldFact Top) (NewFact _) = (NoChange, Top) - join _ (OldFact _) (NewFact Top) = (SomeChange, Top) - join l (OldFact (PElem old)) (NewFact (PElem new)) - = joinx l (OldFact old) (NewFact new) - -instance Show a => Show (Pointed t b a) where - show Bot = "_|_" - show Top = "T" - show (PElem a) = show a - -instance Functor (Pointed t b) where - fmap _ Bot = Bot - fmap _ Top = Top - fmap f (PElem a) = PElem (f a) - -instance Eq a => Eq (Pointed t b a) where - Bot == Bot = True - Top == Top = True - (PElem a) == (PElem a') = a == a' - _ == _ = False - -instance Ord a => Ord (Pointed t b a) where - Bot `compare` Bot = EQ - Bot `compare` _ = LT - _ `compare` Bot = GT - PElem a `compare` PElem a' = a `compare` a' - Top `compare` Top = EQ - Top `compare` _ = GT - _ `compare` Top = LT diff --git a/Compiler/Hoopl/Shape.hs b/Compiler/Hoopl/Shape.hs deleted file mode 100644 --- a/Compiler/Hoopl/Shape.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE GADTs, EmptyDataDecls #-} - -module Compiler.Hoopl.Shape {-# DEPRECATED "not ready to migrate to this yet" #-} -where - --- | Used at the type level to indicate an "open" structure with --- a unique, unnamed control-flow edge flowing in or out. --- "Fallthrough" and concatenation are permitted at an open point. -data O - - --- | Used at the type level to indicate a "closed" structure which --- supports control transfer only through the use of named --- labels---no "fallthrough" is permitted. The number of control-flow --- edges is unconstrained. -data C - - -data HalfShape s where - ShapeO :: HalfShape O - ShapeC :: HalfShape C - -data Shape e x where - ShapeOO :: Shape O O - ShapeCO :: Shape C O - ShapeOC :: Shape O C - ShapeCC :: Shape C C - -class Shapely n where - shape :: n e x -> Shape e x - shapeAtEntry :: n e x -> HalfShape e - shapeAtExit :: n e x -> HalfShape x - - shapeAtEntry = entryHalfShape . shape - shapeAtExit = exitHalfShape . shape - - -entryHalfShape :: Shape e x -> HalfShape e -exitHalfShape :: Shape e x -> HalfShape x - -entryHalfShape ShapeOO = ShapeO -entryHalfShape ShapeOC = ShapeO -entryHalfShape ShapeCO = ShapeC -entryHalfShape ShapeCC = ShapeC - -exitHalfShape ShapeOO = ShapeO -exitHalfShape ShapeOC = ShapeC -exitHalfShape ShapeCO = ShapeO -exitHalfShape ShapeCC = ShapeC - diff --git a/Compiler/Hoopl/Show.hs b/Compiler/Hoopl/Show.hs deleted file mode 100644 --- a/Compiler/Hoopl/Show.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables, FlexibleContexts #-} - -module Compiler.Hoopl.Show - ( showGraph, showFactBase - ) -where - -import Compiler.Hoopl.Collections -import Compiler.Hoopl.Graph -import Compiler.Hoopl.Label - --------------------------------------------------------------------------------- --- Prettyprinting --------------------------------------------------------------------------------- - -type Showing n = forall e x . n e x -> String - - -showGraph :: forall n e x . (NonLocal n) => Showing n -> Graph n e x -> String -showGraph node = g - where g :: (NonLocal n) => Graph n e x -> String - g GNil = "" - g (GUnit block) = b block - g (GMany g_entry g_blocks g_exit) = - 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 (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 - -open :: (a -> String) -> MaybeO z a -> String -open _ NothingO = "" -open p (JustO n) = p n - -showFactBase :: Show f => FactBase f -> String -showFactBase = show . mapToList diff --git a/Compiler/Hoopl/Unique.hs b/Compiler/Hoopl/Unique.hs deleted file mode 100644 --- a/Compiler/Hoopl/Unique.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Compiler.Hoopl.Unique - ( Unique, intToUnique - , UniqueSet, UniqueMap - , UniqueMonad(..) - , SimpleUniqueMonad, runSimpleUniqueMonad - , UniqueMonadT, runUniqueMonadT - - , uniqueToInt -- exposed through GHC module only! - ) - -where - -import Compiler.Hoopl.Checkpoint -import Compiler.Hoopl.Collections - -import qualified Data.IntMap as M -import qualified Data.IntSet as S - ------------------------------------------------------------------------------ --- Unique ------------------------------------------------------------------------------ - -data Unique = Unique { uniqueToInt :: {-# UNPACK #-} !Int } - deriving (Eq, Ord) - -intToUnique :: Int -> Unique -intToUnique = Unique - -instance Show Unique where - show (Unique n) = show n - ------------------------------------------------------------------------------ --- UniqueSet - -newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show) - -instance IsSet UniqueSet where - type ElemOf UniqueSet = Unique - - setNull (US s) = S.null s - setSize (US s) = S.size s - setMember (Unique k) (US s) = S.member k s - - setEmpty = US S.empty - setSingleton (Unique k) = US (S.singleton k) - setInsert (Unique k) (US s) = US (S.insert k s) - setDelete (Unique k) (US s) = US (S.delete k s) - - setUnion (US x) (US y) = US (S.union x y) - setDifference (US x) (US y) = US (S.difference x y) - setIntersection (US x) (US y) = US (S.intersection x y) - setIsSubsetOf (US x) (US y) = S.isSubsetOf x y - - setFold k z (US s) = S.fold (k . intToUnique) z s - - setElems (US s) = map intToUnique (S.elems s) - setFromList ks = US (S.fromList (map uniqueToInt ks)) - ------------------------------------------------------------------------------ --- UniqueMap - -newtype UniqueMap v = UM (M.IntMap v) deriving (Eq, Ord, Show) - -instance IsMap UniqueMap where - type KeyOf UniqueMap = Unique - - mapNull (UM m) = M.null m - mapSize (UM m) = M.size m - mapMember (Unique k) (UM m) = M.member k m - mapLookup (Unique k) (UM m) = M.lookup k m - mapFindWithDefault def (Unique k) (UM m) = M.findWithDefault def k m - - 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) - mapDelete (Unique k) (UM m) = UM (M.delete k m) - - mapUnion (UM x) (UM y) = UM (M.union x y) - mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey (f . intToUnique) x y) - mapDifference (UM x) (UM y) = UM (M.difference x y) - mapIntersection (UM x) (UM y) = UM (M.intersection x y) - mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y - - mapMap f (UM m) = UM (M.map f m) - mapMapWithKey f (UM m) = UM (M.mapWithKey (f . intToUnique) m) - mapFold k z (UM m) = M.fold k z m - mapFoldWithKey k z (UM m) = M.foldWithKey (k . intToUnique) z m - - mapElems (UM m) = M.elems m - 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]) - ----------------------------------------------------------------- --- Monads - -class Monad m => UniqueMonad m where - freshUnique :: m Unique - -newtype SimpleUniqueMonad a = SUM { unSUM :: [Unique] -> (a, [Unique]) } - -instance Monad SimpleUniqueMonad where - return a = SUM $ \us -> (a, us) - m >>= k = SUM $ \us -> let (a, us') = unSUM m us in - unSUM (k a) us' - -instance UniqueMonad SimpleUniqueMonad where - freshUnique = SUM $ \(u:us) -> (u, us) - -instance CheckpointMonad SimpleUniqueMonad where - type Checkpoint SimpleUniqueMonad = [Unique] - checkpoint = SUM $ \us -> (us, us) - restart us = SUM $ \_ -> ((), us) - -runSimpleUniqueMonad :: SimpleUniqueMonad a -> a -runSimpleUniqueMonad m = fst (unSUM m allUniques) - ----------------------------------------------------------------- - -newtype UniqueMonadT m a = UMT { unUMT :: [Unique] -> m (a, [Unique]) } - -instance Monad m => Monad (UniqueMonadT m) where - return a = UMT $ \us -> return (a, us) - m >>= k = UMT $ \us -> do { (a, us') <- unUMT m us; unUMT (k a) us' } - -instance Monad m => UniqueMonad (UniqueMonadT m) where - freshUnique = UMT $ \(u:us) -> return (u, us) - -runUniqueMonadT :: Monad m => UniqueMonadT m a -> m a -runUniqueMonadT m = do { (a, _) <- unUMT m allUniques; return a } - -allUniques :: [Unique] -allUniques = map Unique [1..] diff --git a/Compiler/Hoopl/Util.hs b/Compiler/Hoopl/Util.hs deleted file mode 100644 --- a/Compiler/Hoopl/Util.hs +++ /dev/null @@ -1,263 +0,0 @@ -{-# LANGUAGE GADTs, ScopedTypeVariables, FlexibleInstances, RankNTypes #-} - -module Compiler.Hoopl.Util - ( gUnitOO, gUnitOC, gUnitCO, gUnitCC - , catGraphNodeOC, catGraphNodeOO - , catNodeCOGraph, catNodeOOGraph - , graphMapBlocks - , blockMapNodes, blockMapNodes3 - , blockGraph - , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except - , preorder_dfs, preorder_dfs_from_except - , labelsDefined, labelsUsed, externalEntryLabels - , LabelsPtr(..) - ) -where - -import Control.Monad - -import Compiler.Hoopl.Collections -import Compiler.Hoopl.Graph -import Compiler.Hoopl.Label - - ----------------------------------------------------------------- - -gUnitOO :: block n O O -> Graph' block n O O -gUnitOC :: block n O C -> Graph' block n O C -gUnitCO :: block n C O -> Graph' block n C O -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 - - -catGraphNodeOO :: Graph n e O -> n O O -> Graph n e O -catGraphNodeOC :: NonLocal n => Graph n e O -> n O C -> Graph n e C -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) - -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 - -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 - -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 - - - - - -blockGraph :: NonLocal n => Block n e x -> Graph n e x -blockGraph b@(BFirst {}) = gUnitCO b -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 - - --- | Function 'graphMapBlocks' enables a change of representation of blocks, --- nodes, or both. It lifts a polymorphic block transform into a polymorphic --- graph transform. When the block representation stabilizes, a similar --- function should be provided for blocks. -graphMapBlocks :: forall block n block' n' e x . - (forall e x . block n e x -> block' n' e x) - -> (Graph' block n e x -> Graph' block' n' e x) - -graphMapBlocks f = map - where map :: Graph' block n e x -> Graph' block' n' e x - map GNil = GNil - map (GUnit b) = GUnit (f b) - 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) - -> 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) - -blockMapNodes :: (forall e x. n e x -> n' e x) - -> (Block n e x -> Block n' e x) -blockMapNodes f = blockMapNodes3 (f, f, f) - ----------------------------------------------------------------- - -class LabelsPtr l where - targetLabels :: l -> [Label] - -instance NonLocal n => LabelsPtr (n e C) where - targetLabels n = successors n - -instance LabelsPtr Label where - targetLabels l = [l] - -instance LabelsPtr LabelSet where - targetLabels = setElems - -instance LabelsPtr l => LabelsPtr [l] where - targetLabels = concatMap targetLabels - - --- | Traversal: 'postorder_dfs' returns a list of blocks reachable --- from the entry of enterable graph. The entry and exit are *not* included. --- The list has the following property: --- --- Say a "back reference" exists if one of a block's --- control-flow successors precedes it in the output list --- --- Then there are as few back references as possible --- --- The output is suitable for use in --- a forward dataflow problem. For a backward problem, simply reverse --- the list. ('postorder_dfs' is sufficiently tricky to implement that --- one doesn't want to try and maintain both forward and backward --- versions.) - -postorder_dfs :: NonLocal (block n) => Graph' block n O x -> [block n C C] -preorder_dfs :: NonLocal (block n) => Graph' block n O x -> [block n C C] - --- | This is the most important traversal over this data structure. It drops --- unreachable code and puts blocks in an order that is good for solving forward --- dataflow problems quickly. The reverse order is good for solving backward --- dataflow problems quickly. The forward order is also reasonably good for --- emitting instructions, except that it will not usually exploit Forrest --- Baskett's trick of eliminating the unconditional branch from a loop. For --- that you would need a more serious analysis, probably based on dominators, to --- identify loop headers. --- --- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph' --- representation, when for most purposes the plain 'Graph' representation is --- more mathematically elegant (but results in more complicated code). --- --- Here's an easy way to go wrong! Consider --- @ --- A -> [B,C] --- B -> D --- C -> D --- @ --- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D. --- Better to get [A,B,C,D] - - -graphDfs :: (NonLocal (block n)) - => (LabelMap (block n C C) -> block n O C -> LabelSet -> [block n C C]) - -> (Graph' block n O x -> [block n C C]) -graphDfs _ (GNil) = [] -graphDfs _ (GUnit{}) = [] -graphDfs order (GMany (JustO entry) body _) = order body entry setEmpty - -postorder_dfs = graphDfs postorder_dfs_from_except -preorder_dfs = graphDfs preorder_dfs_from_except - -postorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e) - => LabelMap (block C C) -> e -> LabelSet -> [block C C] -postorder_dfs_from_except blocks b visited = - vchildren (get_children b) (\acc _visited -> acc) [] visited - where - vnode :: block C C -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a - vnode block cont acc visited = - if setMember id visited then - cont acc visited - else - let cont' acc visited = cont (block:acc) visited in - vchildren (get_children block) cont' acc (setInsert id visited) - where id = entryLabel block - vchildren bs cont acc visited = next bs acc visited - where next children acc visited = - case children of [] -> cont acc visited - (b:bs) -> vnode b (next bs) acc visited - get_children block = foldr add_id [] $ targetLabels block - add_id id rst = case lookupFact id blocks of - Just b -> b : rst - Nothing -> rst - -postorder_dfs_from - :: (NonLocal block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C] -postorder_dfs_from blocks b = postorder_dfs_from_except blocks b setEmpty - - ----------------------------------------------------------------- - -data VM a = VM { unVM :: LabelSet -> (a, LabelSet) } -marked :: Label -> VM Bool -mark :: Label -> VM () -instance Monad VM where - return a = VM $ \visited -> (a, visited) - m >>= k = VM $ \visited -> let (a, v') = unVM m visited in unVM (k a) v' -marked l = VM $ \v -> (setMember l v, v) -mark l = VM $ \v -> ((), setInsert l v) - -preorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e) - => LabelMap (block C C) -> e -> LabelSet -> [block C C] -preorder_dfs_from_except blocks b visited = - (fst $ unVM (children (get_children b)) visited) [] - where children [] = return id - children (b:bs) = liftM2 (.) (visit b) (children bs) - visit :: block C C -> VM (HL (block C C)) - visit b = do already <- marked (entryLabel b) - if already then return id - else do mark (entryLabel b) - bs <- children $ get_children b - return $ b `cons` bs - get_children block = foldr add_id [] $ targetLabels block - add_id id rst = case lookupFact id blocks of - Just b -> b : rst - Nothing -> rst - -type HL a = [a] -> [a] -- Hughes list (constant-time concatenation) -cons :: a -> HL a -> HL a -cons a as tail = a : as tail - ----------------------------------------------------------------- - -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 - where addEntry label _ labels = setInsert label labels - exitLabel :: MaybeO x (block n C O) -> LabelSet - 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 GNil = setEmpty -labelsUsed (GUnit{}) = setEmpty -labelsUsed (GMany e body _) = mapFold addTargets (entryTargets e) body - where addTargets block labels = setInsertList (successors block) labels - entryTargets :: MaybeO e (block n O C) -> LabelSet - entryTargets NothingO = setEmpty - entryTargets (JustO b) = addTargets b setEmpty - -externalEntryLabels :: forall n . - NonLocal n => LabelMap (Block n C C) -> LabelSet -externalEntryLabels body = defined `setDifference` used - where defined = labelsDefined g - used = labelsUsed g - g = GMany NothingO body NothingO diff --git a/Compiler/Hoopl/Wrappers.hs b/Compiler/Hoopl/Wrappers.hs deleted file mode 100644 --- a/Compiler/Hoopl/Wrappers.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Compiler.Hoopl.Wrappers {-# DEPRECATED "Use only if you know what you are doing and can preserve the 'respects fuel' invariant" #-} - ( wrapFR, wrapFR2, wrapBR, wrapBR2 - ) -where - -import Compiler.Hoopl.Dataflow - diff --git a/Compiler/Hoopl/XUtil.hs b/Compiler/Hoopl/XUtil.hs deleted file mode 100644 --- a/Compiler/Hoopl/XUtil.hs +++ /dev/null @@ -1,490 +0,0 @@ -{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-} - --- | Utilities for clients of Hoopl, not used internally. - -module Compiler.Hoopl.XUtil - ( 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 tfFoldBlock - , analyzeAndRewriteFwdBody, analyzeAndRewriteBwdBody - , analyzeAndRewriteFwdOx, analyzeAndRewriteBwdOx - , noEntries - , BlockResult(..), lookupBlock - ) -where - -import qualified Data.Map as M -import Data.Maybe - -import Compiler.Hoopl.Checkpoint -import Compiler.Hoopl.Collections -import Compiler.Hoopl.Dataflow -import Compiler.Hoopl.Graph -import Compiler.Hoopl.Label -import Compiler.Hoopl.Util - - --- | Forward dataflow analysis and rewriting for the special case of a Body. --- A set of entry points must be supplied; blocks not reachable from --- the set are thrown away. -analyzeAndRewriteFwdBody - :: forall m n f entries. (CheckpointMonad m, NonLocal n, LabelsPtr entries) - => FwdPass m n f - -> entries -> Body n -> FactBase f - -> m (Body n, FactBase f) - --- | Backward dataflow analysis and rewriting for the special case of a Body. --- A set of entry points must be supplied; blocks not reachable from --- the set are thrown away. -analyzeAndRewriteBwdBody - :: forall m n f entries. (CheckpointMonad m, NonLocal n, LabelsPtr entries) - => BwdPass m n f - -> entries -> Body n -> FactBase f - -> m (Body n, FactBase f) - -analyzeAndRewriteFwdBody pass en = mapBodyFacts (analyzeAndRewriteFwd pass (JustC en)) -analyzeAndRewriteBwdBody pass en = mapBodyFacts (analyzeAndRewriteBwd pass (JustC en)) - -mapBodyFacts :: (Monad m) - => (Graph n C C -> Fact C f -> m (Graph n C C, Fact C f, MaybeO C f)) - -> (Body n -> FactBase f -> m (Body n, FactBase f)) --- ^ Internal utility; should not escape -mapBodyFacts anal b f = anal (GMany NothingO b NothingO) f >>= bodyFacts - where -- the type constraint is needed for the pattern match; - -- if it were not, we would use do-notation here. - bodyFacts :: Monad m => (Graph n C C, Fact C f, MaybeO C f) -> m (Body n, Fact C f) - bodyFacts (GMany NothingO body NothingO, fb, NothingO) = return (body, fb) - -{- - Can't write: - - do (GMany NothingO body NothingO, fb, NothingO) <- anal (....) f - return (body, fb) - - because we need an explicit type signature in order to do the GADT - pattern matches on NothingO --} - - - --- | Forward dataflow analysis and rewriting for the special case of a --- graph open at the entry. This special case relieves the client --- from having to specify a type signature for 'NothingO', which beginners --- might find confusing and experts might find annoying. -analyzeAndRewriteFwdOx - :: forall m n f x. (CheckpointMonad m, NonLocal n) - => FwdPass m n f -> Graph n O x -> f -> m (Graph n O x, FactBase f, MaybeO x f) - --- | Backward dataflow analysis and rewriting for the special case of a --- graph open at the entry. This special case relieves the client --- from having to specify a type signature for 'NothingO', which beginners --- might find confusing and experts might find annoying. -analyzeAndRewriteBwdOx - :: forall m n f x. (CheckpointMonad m, NonLocal n) - => BwdPass m n f -> Graph n O x -> Fact x f -> m (Graph n O x, FactBase f, f) - --- | A value that can be used for the entry point of a graph open at the entry. -noEntries :: MaybeC O Label -noEntries = NothingC - -analyzeAndRewriteFwdOx pass g f = analyzeAndRewriteFwd pass noEntries g f -analyzeAndRewriteBwdOx pass g fb = analyzeAndRewriteBwd pass noEntries g fb >>= strip - where strip :: forall m a b c . Monad m => (a, b, MaybeO O c) -> m (a, b, c) - strip (a, b, JustO c) = return (a, b, c) - - - - - --- | A utility function so that a transfer function for a first --- node can be given just a fact; we handle the lookup. This --- function is planned to be made obsolete by changes in the dataflow --- interface. - -firstXfer :: NonLocal n => (n C O -> f -> f) -> (n C O -> FactBase f -> f) -firstXfer xfer n fb = xfer n $ fromJust $ lookupFact (entryLabel n) fb - --- | This utility function handles a common case in which a transfer function --- produces a single fact out of a last node, which is then distributed --- over the outgoing edges. -distributeXfer :: NonLocal n - => DataflowLattice f -> (n O C -> f -> f) -> (n O C -> f -> FactBase f) -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. -distributeFact :: NonLocal n => n O C -> f -> FactBase f -distributeFact n f = mapFromList [ (l, f) | l <- successors n ] - -- because the same fact goes out on every edge, - -- there's no need for 'mkFactBase' here. - --- | This utility function handles a common case in which a backward transfer --- function takes the incoming fact unchanged and tags it with the node's label. -distributeFactBwd :: NonLocal n => n C O -> f -> FactBase f -distributeFactBwd n f = mapSingleton (entryLabel n) f - --- | List of (unlabelled) facts from the successors of a last node -successorFacts :: NonLocal n => n O C -> FactBase f -> [f] -successorFacts n fb = [ f | id <- successors n, let Just f = lookupFact id fb ] - --- | Join a list of facts. -joinFacts :: DataflowLattice f -> Label -> [f] -> f -joinFacts lat inBlock = foldr extend (fact_bot lat) - where extend new old = snd $ fact_join lat inBlock (OldFact old) (NewFact new) - -{-# DEPRECATED joinOutFacts - "should be replaced by 'joinFacts lat l (successorFacts n f)'; as is, it uses the wrong Label" #-} - -joinOutFacts :: (NonLocal node) => DataflowLattice f -> node O C -> FactBase f -> f -joinOutFacts lat n f = foldr join (fact_bot lat) facts - where join (lbl, new) old = snd $ fact_join lat lbl (OldFact old) (NewFact new) - facts = [(s, fromJust fact) | s <- successors n, let fact = lookupFact s f, isJust fact] - - --- | It's common to represent dataflow facts as a map from variables --- to some fact about the locations. For these maps, the join --- operation on the map can be expressed in terms of the join on each --- element of the codomain: -joinMaps :: Ord k => JoinFun v -> JoinFun (M.Map k v) -joinMaps eltJoin l (OldFact old) (NewFact new) = M.foldWithKey add (NoChange, old) new - where - add k new_v (ch, joinmap) = - case M.lookup k joinmap of - Nothing -> (SomeChange, M.insert k new_v joinmap) - Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of - (SomeChange, v') -> (SomeChange, M.insert k v' joinmap) - (NoChange, _) -> (ch, joinmap) - - - --- | A fold function that relies on the IndexedCO type function. --- Note that the type parameter e is available to the functions --- that are applied to the middle and last nodes. -tfFoldBlock :: forall n bc bo c e x . - ( n C O -> bc - , n O O -> IndexedCO e bc bo -> IndexedCO e bc bo - , n O C -> IndexedCO e bc bo -> c) - -> (Block n e x -> bo -> IndexedCO x c (IndexedCO e bc bo)) -tfFoldBlock (f, m, l) bl bo = block bl - where block :: forall x . Block n e x -> IndexedCO x c (IndexedCO e bc bo) - block (BFirst n) = f n - block (BMiddle n) = m n bo - block (BLast n) = l n bo - block (b1 `BCat` b2) = oblock b2 $ block b1 - block (b1 `BClosed` b2) = oblock b2 $ block b1 - block (b1 `BHead` n) = m n $ block b1 - block (n `BTail` b2) = oblock b2 $ m n bo - oblock :: forall x . Block n O x -> IndexedCO e bc bo -> IndexedCO x c (IndexedCO e bc bo) - oblock (BMiddle n) = m n - oblock (BLast n) = l n - oblock (b1 `BCat` b2) = oblock b1 `cat` oblock b2 - oblock (n `BTail` b2) = m n `cat` oblock b2 - cat f f' = f' . f - - -type NodeList' e x n = (MaybeC e (n C O), [n O O], MaybeC x (n O C)) -blockToNodeList''' :: - forall n e x. ( IndexedCO e (NodeList' C O n) (NodeList' O O n) ~ NodeList' e O n - , IndexedCO x (NodeList' e C n) (NodeList' e O n) ~ NodeList' e x n) => - Block n e x -> NodeList' e x n -blockToNodeList''' b = (h, reverse ms', t) - where - (h, ms', t) = tfFoldBlock (f, m, l) b z - z :: NodeList' O O n - z = (NothingC, [], NothingC) - f :: n C O -> NodeList' C O n - f n = (JustC n, [], NothingC) - m n (h, ms', t) = (h, n : ms', t) - l n (h, ms', _) = (h, ms', JustC n) - - -{- -data EitherCO' ex a b where - LeftCO :: a -> EitherCO' C a b - RightCO :: b -> EitherCO' O a b --} - - -- should be done with a *backward* fold - --- | More general fold - -_unused :: Int -_unused = 3 - where _a = foldBlockNodesF3'' (Trips undefined undefined undefined) - _b = foldBlockNodesF3' - -data Trips n a b c = Trips { ff :: forall e . MaybeC e (n C O) -> a -> b - , fm :: n O O -> b -> b - , fl :: forall x . MaybeC x (n O C) -> b -> c - } - -foldBlockNodesF3'' :: forall n a b c . - Trips n a b c -> (forall e x . Block n e x -> a -> c) -foldBlockNodesF3'' trips = block - where block :: Block n e x -> a -> c - block (b1 `BClosed` b2) = foldCO b1 `cat` foldOC b2 - block (BFirst node) = ff trips (JustC node) `cat` missingLast - block (b @ BHead {}) = foldCO b `cat` missingLast - block (BMiddle node) = missingFirst `cat` fm trips node `cat` missingLast - block (b @ BCat {}) = missingFirst `cat` foldOO b `cat` missingLast - block (BLast node) = missingFirst `cat` fl trips (JustC node) - block (b @ BTail {}) = missingFirst `cat` foldOC b - missingLast = fl trips NothingC - missingFirst = ff trips NothingC - foldCO :: Block n C O -> a -> b - foldOO :: Block n O O -> b -> b - foldOC :: Block n O C -> b -> c - foldCO (BFirst n) = ff trips (JustC n) - foldCO (BHead b n) = foldCO b `cat` fm trips n - foldOO (BMiddle n) = fm trips n - foldOO (BCat b1 b2) = foldOO b1 `cat` foldOO b2 - foldOC (BLast n) = fl trips (JustC n) - foldOC (BTail n b) = fm trips n `cat` foldOC b - f `cat` g = g . f - -data ScottBlock n a = ScottBlock - { sb_first :: n C O -> a C O - , sb_mid :: n O O -> a O O - , sb_last :: n O C -> a O C - , sb_cat :: forall e x . a e O -> a O x -> a e x - } - -scottFoldBlock :: forall n a e x . ScottBlock n a -> Block n e x -> a e x -scottFoldBlock funs = block - where block :: forall e x . Block n e x -> a e x - block (BFirst n) = sb_first funs n - block (BMiddle n) = sb_mid funs n - block (BLast n) = sb_last funs n - block (BClosed b1 b2) = block b1 `cat` block b2 - block (BCat b1 b2) = block b1 `cat` block b2 - block (BHead b n) = block b `cat` sb_mid funs n - block (BTail n b) = sb_mid funs n `cat` block b - cat = sb_cat funs - -newtype NodeList n e x - = NL { unList :: (MaybeC e (n C O), [n O O] -> [n O O], MaybeC x (n O C)) } - -fbnf3 :: forall n a b c . - ( n C O -> a -> b - , n O O -> b -> b - , n O C -> b -> c) - -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b) -fbnf3 (ff, fm, fl) block = unFF3 $ scottFoldBlock (ScottBlock f m l cat) block - where f n = FF3 $ ff n - m n = FF3 $ fm n - l n = FF3 $ fl n - FF3 f `cat` FF3 f' = FF3 $ f' . f - -newtype FF3 a b c e x = FF3 { unFF3 :: IndexedCO e a b -> IndexedCO x c b } - -blockToNodeList'' :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C)) -blockToNodeList'' = finish . unList . scottFoldBlock (ScottBlock f m l cat) - where f n = NL (JustC n, id, NothingC) - m n = NL (NothingC, (n:), NothingC) - l n = NL (NothingC, id, JustC n) - cat :: NodeList n e O -> NodeList n O x -> NodeList n e x - NL (e, ms, NothingC) `cat` NL (NothingC, ms', x) = NL (e, ms . ms', x) - 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 () - where ff n () = PNL (n, []) - fm n (PNL (first, mids')) = PNL (first, n : mids') - fl n (PNL (first, mids')) = FNL (first, reverse mids', n) - - -- newtypes for 'partial node list' and 'final node list' -newtype PNL n e = PNL (MaybeC e (n C O), [n O O]) -newtype FNL n e x = FNL {unFNL :: (MaybeC e (n C O), [n O O], MaybeC x (n O C))} - -foldBlockNodesF3''' :: forall n a b c . - (forall e . MaybeC e (n C O) -> a -> b e) - -> (forall e . n O O -> b e -> b e) - -> (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 - 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 - , n O O -> b -> b - , n O C -> b -> c) - -> (a -> b) -- called iff there is no first node - -> (b -> c) -- called iff there is no last node - -> (forall e x . Block n e x -> a -> c) -foldBlockNodesF3' (ff, fm, fl) missingFirst missingLast = block - where block :: forall e x . Block n e x -> a -> c - blockCO :: Block n C O -> a -> b - blockOO :: Block n O O -> b -> b - blockOC :: Block n O C -> b -> c - block (b1 `BClosed` b2) = blockCO b1 `cat` blockOC b2 - block (BFirst node) = ff node `cat` missingLast - block (b @ BHead {}) = blockCO b `cat` missingLast - block (BMiddle node) = missingFirst `cat` fm node `cat` missingLast - block (b @ BCat {}) = missingFirst `cat` blockOO b `cat` missingLast - block (BLast node) = missingFirst `cat` fl node - block (b @ BTail {}) = missingFirst `cat` blockOC b - blockCO (BFirst n) = ff 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 n - blockOC (BTail n b) = fm n `cat` blockOC b - 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. -foldBlockNodesF3 :: forall n a b c . - ( n C O -> a -> b - , n O O -> b -> b - , n O C -> b -> c) - -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b) -foldBlockNodesF :: forall n a . - (forall e x . n e x -> a -> a) - -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a) -foldBlockNodesB3 :: forall n a b c . - ( n C O -> b -> c - , n O O -> b -> b - , n O C -> a -> b) - -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b) -foldBlockNodesB :: forall n a . - (forall e x . n e x -> a -> a) - -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a) --- | Fold a function over every node in a graph. --- The fold function must be polymorphic in the shape of the nodes. - -foldGraphNodes :: forall n a . - (forall e x . n e x -> a -> a) - -> (forall e x . Graph n e x -> a -> 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 (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 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 (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 f f' = f . f' -foldBlockNodesB f = foldBlockNodesB3 (f, f, f) - - -foldGraphNodes f = graph - where graph :: forall e x . Graph n e x -> a -> a - lift :: forall thing ex . (thing -> a -> a) -> (MaybeO ex thing -> a -> a) - - graph GNil = id - graph (GUnit b) = block b - graph (GMany e b x) = lift block e . body b . lift block x - body :: Body n -> a -> a - body bdy = \a -> mapFold block a bdy - lift _ NothingO = id - lift f (JustO thing) = f thing - - block = foldBlockNodesF f - -{-# 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 --- is or is not present depending on the shape of the block. --- --- The blockToNodeList function cannot be currently expressed using --- foldBlockNodesB, because it returns IndexedCO e a b, which means --- two different types depending on the shape of the block entry. --- But blockToNodeList returns one of four possible types, depending --- 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) - --- | 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 - -data BlockResult n x where - NoBlock :: BlockResult n x - BodyBlock :: Block n C C -> BlockResult n x - ExitBlock :: Block n C O -> BlockResult n O - -lookupBlock :: NonLocal n => Graph n e x -> Label -> BlockResult n x -lookupBlock (GMany _ _ (JustO exit)) lbl - | entryLabel exit == lbl = ExitBlock exit -lookupBlock (GMany _ body _) lbl = - case mapLookup lbl body of - Just b -> BodyBlock b - Nothing -> NoBlock -lookupBlock GNil _ = NoBlock -lookupBlock (GUnit _) _ = NoBlock diff --git a/README b/README --- a/README +++ b/README @@ -1,35 +1,30 @@ -This is Hoopl, a higher-order optimization library. -There are two unpublished papers describing Hoopl: +This repository contains things related to - Hoopl: Dataflow Optimization Made Simple - Hoopl: A Modular, Reusable Library for Dataflow Analysis and Transformation + Hoopl: A Higher-Order OPtimization Library -The second such paper is attached to this package. +** The closest thing we have to a SAMPLE CLIENT is in ./testing ** -The version number is split into four parts: +Directory Contents - 3. Third major body plan (phylum) - 7. Seventh iteration (roughly) of data structures - 2. Major version; changes when clients must change - 1. Minor version; changes when clients can stay the same +paper/ A paper about Hoopl +prototypes/ A sampling of prototypes and early designs +src/ The current official sources to the Cabal package +testing/ Tests, including a sample client. See ./testing/README. +To build the library, change to the src directory and run -Version 3.7.3.3 has fixed known bugs. + cabal configure --prefix=$HOME --user # we have no idea what this means + cabal build + cabal install --enable-documentation -Version 3.7.8.0 will be the last version uploaded to Hackage for some time. -This library is undergoing *very* rapid development, and we ask that you -get the most recent version from our public git repository: +You'll need a Haskell Platform, which should include appropriate +versions of Cabal and GHC. - git clone -o tufts git://ghc.cs.tufts.edu/hoopl/hoopl.git +To upload to Hackage, -If you are not familiar with git, we recommend the tutorial 'Git Magic' -by Ben Lynn. To get some ideas about how to use git effectively, + cabal sdist + cabal upload dist/something.tar.gz - http://whygitisbetterthanx.com/ -is also useful. -If you've been given an account at Tufts with write privileges to the -git repository, you'll want to use a different URL: - - git clone -o tufts linux.cs.tufts.edu:/r/ghc/www/hoopl/hoopl.git + diff --git a/hoopl.cabal b/hoopl.cabal --- a/hoopl.cabal +++ b/hoopl.cabal @@ -1,6 +1,7 @@ Name: hoopl -Version: 3.8.6.0 +Version: 3.8.7.0 -- version 3.8.6.0 is the version that goes with the camera-ready Haskell'10 paper +-- version 3.8.7.0 works with GHC 7 Description: Higher-order optimization library License: BSD3 License-file: LICENSE @@ -42,6 +43,7 @@ Compiler.Hoopl.Util Compiler.Hoopl.XUtil ghc-options: -Wall -fno-warn-name-shadowing + hs-source-dirs: src Source-repository head diff --git a/hoopl.pdf b/hoopl.pdf Binary files a/hoopl.pdf and b/hoopl.pdf differ diff --git a/src/Compiler/Hoopl.hs b/src/Compiler/Hoopl.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl.hs @@ -0,0 +1,37 @@ +module Compiler.Hoopl + ( module Compiler.Hoopl.Graph + , module Compiler.Hoopl.MkGraph + , module Compiler.Hoopl.XUtil + , module Compiler.Hoopl.Collections + , module Compiler.Hoopl.Checkpoint + , module Compiler.Hoopl.Dataflow + , module Compiler.Hoopl.Label + , module Compiler.Hoopl.Pointed + , module Compiler.Hoopl.Combinators + , module Compiler.Hoopl.Fuel + , module Compiler.Hoopl.Unique + , module Compiler.Hoopl.Util + , module Compiler.Hoopl.Debug + , module Compiler.Hoopl.Show + ) +where + +import Compiler.Hoopl.Checkpoint +import Compiler.Hoopl.Collections +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, FuelMonadT) +import Compiler.Hoopl.Graph hiding + ( Body + , BCat, BHead, BTail, BClosed -- OK to expose BFirst, BMiddle, BLast + ) +import Compiler.Hoopl.Graph (Body) +import Compiler.Hoopl.Label hiding (uniqueToLbl, lblToUnique) +import Compiler.Hoopl.MkGraph +import Compiler.Hoopl.Pointed +import Compiler.Hoopl.Show +import Compiler.Hoopl.Util +import Compiler.Hoopl.Unique hiding (uniqueToInt) +import Compiler.Hoopl.XUtil diff --git a/src/Compiler/Hoopl/Checkpoint.hs b/src/Compiler/Hoopl/Checkpoint.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl/Checkpoint.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeFamilies #-} + +module Compiler.Hoopl.Checkpoint + ( CheckpointMonad(..) + ) +where + +-- | Obeys the following law: +-- for all @m@ +-- @ +-- do { s <- checkpoint; m; restart s } == return () +-- @ +class Monad m => CheckpointMonad m where + type Checkpoint m + checkpoint :: m (Checkpoint m) + restart :: Checkpoint m -> m () + diff --git a/src/Compiler/Hoopl/Collections.hs b/src/Compiler/Hoopl/Collections.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl/Collections.hs @@ -0,0 +1,85 @@ +{- Baseclasses for Map-like and Set-like collections inspired by containers. -} + +{-# LANGUAGE TypeFamilies #-} +module Compiler.Hoopl.Collections ( IsSet(..) + , setInsertList, setDeleteList, setUnions + , IsMap(..) + , mapInsertList, mapDeleteList, mapUnions + ) where + +import Data.List (foldl', foldl1') + +class IsSet set where + type ElemOf set + + setNull :: set -> Bool + setSize :: set -> Int + setMember :: ElemOf set -> set -> Bool + + setEmpty :: set + setSingleton :: ElemOf set -> set + setInsert :: ElemOf set -> set -> set + setDelete :: ElemOf set -> set -> set + + setUnion :: set -> set -> set + setDifference :: set -> set -> set + setIntersection :: set -> set -> set + setIsSubsetOf :: set -> set -> Bool + + setFold :: (ElemOf set -> b -> b) -> b -> set -> b + + setElems :: set -> [ElemOf set] + setFromList :: [ElemOf set] -> set + +-- Helper functions for IsSet class +setInsertList :: IsSet set => [ElemOf set] -> set -> set +setInsertList keys set = foldl' (flip setInsert) set keys + +setDeleteList :: IsSet set => [ElemOf set] -> set -> set +setDeleteList keys set = foldl' (flip setDelete) set keys + +setUnions :: IsSet set => [set] -> set +setUnions [] = setEmpty +setUnions sets = foldl1' setUnion sets + + +class IsMap map where + type KeyOf map + + mapNull :: map a -> Bool + mapSize :: map a -> Int + mapMember :: KeyOf map -> map a -> Bool + mapLookup :: KeyOf map -> map a -> Maybe a + mapFindWithDefault :: a -> KeyOf map -> map a -> a + + mapEmpty :: map a + mapSingleton :: KeyOf map -> a -> map a + mapInsert :: KeyOf map -> a -> map a -> map a + mapDelete :: KeyOf map -> map a -> map a + + mapUnion :: map a -> map a -> map a + mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a + mapDifference :: map a -> map a -> map a + mapIntersection :: map a -> map a -> map a + mapIsSubmapOf :: Eq a => map a -> map a -> Bool + + mapMap :: (a -> b) -> map a -> map b + mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b + mapFold :: (a -> b -> b) -> b -> map a -> b + mapFoldWithKey :: (KeyOf map -> a -> b -> b) -> b -> map a -> b + + mapElems :: map a -> [a] + mapKeys :: map a -> [KeyOf map] + mapToList :: map a -> [(KeyOf map, a)] + mapFromList :: [(KeyOf map, a)] -> map a + +-- Helper functions for IsMap class +mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a +mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs + +mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a +mapDeleteList keys map = foldl' (flip mapDelete) map keys + +mapUnions :: IsMap map => [map a] -> map a +mapUnions [] = mapEmpty +mapUnions maps = foldl1' mapUnion maps diff --git a/src/Compiler/Hoopl/Combinators.hs b/src/Compiler/Hoopl/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl/Combinators.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE RankNTypes, LiberalTypeSynonyms, ScopedTypeVariables, GADTs #-} + +module Compiler.Hoopl.Combinators + ( thenFwdRw + , deepFwdRw3, deepFwdRw, iterFwdRw + , thenBwdRw + , deepBwdRw3, deepBwdRw, iterBwdRw + , pairFwd, pairBwd, pairLattice + ) + +where + +import Control.Monad +import Data.Maybe + +import Compiler.Hoopl.Collections +import Compiler.Hoopl.Dataflow +import Compiler.Hoopl.Fuel +import Compiler.Hoopl.Graph (Graph, C, O, Shape(..)) +import Compiler.Hoopl.Label + +---------------------------------------------------------------- + +deepFwdRw3 :: FuelMonad m + => (n C O -> f -> m (Maybe (Graph n C O))) + -> (n O O -> f -> m (Maybe (Graph n O O))) + -> (n O C -> f -> m (Maybe (Graph n O C))) + -> (FwdRewrite m n f) +deepFwdRw :: FuelMonad m + => (forall e x . n e x -> f -> m (Maybe (Graph n e x))) -> FwdRewrite m n f +deepFwdRw3 f m l = iterFwdRw $ mkFRewrite3 f m l +deepFwdRw f = deepFwdRw3 f f f + +-- N.B. rw3, rw3', and rw3a are triples of functions. +-- But rw and rw' are single functions. +-- @ start comb1.tex +thenFwdRw :: forall m n f. Monad m + => FwdRewrite m n f + -> FwdRewrite m n f + -> FwdRewrite m n f +-- @ end comb1.tex +thenFwdRw rw3 rw3' = wrapFR2 thenrw rw3 rw3' + where + thenrw :: forall m1 e x t t1. + Monad m1 => + (t -> t1 -> m1 (Maybe (Graph n e x, FwdRewrite m n f))) + -> (t -> t1 -> m1 (Maybe (Graph n e x, FwdRewrite m n f))) + -> t + -> t1 + -> m1 (Maybe (Graph n e x, FwdRewrite m n f)) + thenrw rw rw' n f = rw n f >>= fwdRes + where fwdRes Nothing = rw' n f + fwdRes (Just gr) = return $ Just $ fadd_rw rw3' gr + +-- @ start iterf.tex +iterFwdRw :: forall m n f. Monad m + => FwdRewrite m n f + -> FwdRewrite m n f +-- @ end iterf.tex +iterFwdRw rw3 = wrapFR iter rw3 + where iter :: forall a m1 m2 e x t. + (Monad m2, Monad m1) => + (t -> a -> m1 (m2 (Graph n e x, FwdRewrite m n f))) + -> t + -> a + -> m1 (m2 (Graph n e x, FwdRewrite m n f)) + iter rw n = (liftM $ liftM $ fadd_rw (iterFwdRw rw3)) . rw n + +-- | Function inspired by 'rew' in the paper +_frewrite_cps :: Monad m + => ((Graph n e x, FwdRewrite m n f) -> m a) + -> m a + -> (forall e x . n e x -> f -> m (Maybe (Graph n e x, FwdRewrite m n f))) + -> n e x + -> f + -> m a +_frewrite_cps j n rw node f = + do mg <- rw node f + case mg of Nothing -> n + Just gr -> j gr + + + +-- | Function inspired by 'add' in the paper +fadd_rw :: Monad m + => FwdRewrite m n f + -> (Graph n e x, FwdRewrite m n f) + -> (Graph n e x, FwdRewrite m n f) +fadd_rw rw2 (g, rw1) = (g, rw1 `thenFwdRw` rw2) + +---------------------------------------------------------------- + +deepBwdRw3 :: FuelMonad m + => (n C O -> f -> m (Maybe (Graph n C O))) + -> (n O O -> f -> m (Maybe (Graph n O O))) + -> (n O C -> FactBase f -> m (Maybe (Graph n O C))) + -> (BwdRewrite m n f) +deepBwdRw :: FuelMonad m + => (forall e x . n e x -> Fact x f -> m (Maybe (Graph n e x))) + -> BwdRewrite m n f +deepBwdRw3 f m l = iterBwdRw $ mkBRewrite3 f m l +deepBwdRw f = deepBwdRw3 f f f + + +thenBwdRw :: forall m n f. Monad m => BwdRewrite m n f -> BwdRewrite m n f -> BwdRewrite m n f +thenBwdRw rw1 rw2 = wrapBR2 f rw1 rw2 + where f :: forall t t1 t2 m1 e x. + Monad m1 => + t + -> (t1 -> t2 -> m1 (Maybe (Graph n e x, BwdRewrite m n f))) + -> (t1 -> t2 -> m1 (Maybe (Graph n e x, BwdRewrite m n f))) + -> t1 + -> t2 + -> m1 (Maybe (Graph n e x, BwdRewrite m n f)) + f _ rw1 rw2' n f = do + res1 <- rw1 n f + case res1 of + Nothing -> rw2' n f + Just gr -> return $ Just $ badd_rw rw2 gr + +iterBwdRw :: forall m n f. Monad m => BwdRewrite m n f -> BwdRewrite m n f +iterBwdRw rw = wrapBR f rw + where f :: forall t m1 m2 e x t1 t2. + (Monad m2, Monad m1) => + t + -> (t1 -> t2 -> m1 (m2 (Graph n e x, BwdRewrite m n f))) + -> t1 + -> t2 + -> m1 (m2 (Graph n e x, BwdRewrite m n f)) + f _ rw' n f = liftM (liftM (badd_rw (iterBwdRw rw))) (rw' n f) + +-- | Function inspired by 'add' in the paper +badd_rw :: Monad m + => BwdRewrite m n f + -> (Graph n e x, BwdRewrite m n f) + -> (Graph n e x, BwdRewrite m n f) +badd_rw rw2 (g, rw1) = (g, rw1 `thenBwdRw` rw2) + + +-- @ start pairf.tex +pairFwd :: forall m n f f'. Monad m + => FwdPass m n f + -> FwdPass m n f' + -> FwdPass m n (f, f') +-- @ end pairf.tex +pairFwd pass1 pass2 = FwdPass lattice transfer rewrite + where + lattice = pairLattice (fp_lattice pass1) (fp_lattice pass2) + transfer = mkFTransfer3 (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2) + where + tf :: forall t t1 t2 t3 t4. + (t4 -> t -> t2) -> (t4 -> t1 -> t3) -> t4 -> (t, t1) -> (t2, t3) + tf t1 t2 n (f1, f2) = (t1 n f1, t2 n f2) + tfb t1 t2 n (f1, f2) = mapMapWithKey withfb2 fb1 + where fb1 = t1 n f1 + fb2 = t2 n f2 + withfb2 :: forall t. Label -> t -> (t, f') + withfb2 l f = (f, fromMaybe bot2 $ lookupFact l fb2) + bot2 = fact_bot (fp_lattice pass2) + (tf1, tm1, tl1) = getFTransfer3 (fp_transfer pass1) + (tf2, tm2, tl2) = getFTransfer3 (fp_transfer pass2) + rewrite = lift fst (fp_rewrite pass1) `thenFwdRw` lift snd (fp_rewrite pass2) + where + lift :: forall f m' n' f'. + Monad m' => + (f' -> f) -> FwdRewrite m' n' f -> FwdRewrite m' n' f' + lift proj = wrapFR project + where project :: forall m m1 t t1. + (Monad m1, Monad m) => + (t1 -> f -> m (m1 (t, FwdRewrite m' n' f))) + -> t1 + -> f' + -> m (m1 (t, FwdRewrite m' n' f')) + project rw = \n pair -> liftM (liftM repair) $ rw n (proj pair) + repair :: forall t. + (t, FwdRewrite m' n' f) -> (t, FwdRewrite m' n' f') + repair (g, rw') = (g, lift proj rw') + +pairBwd :: forall m n f f' . + Monad m => BwdPass m n f -> BwdPass m n f' -> BwdPass m n (f, f') +pairBwd pass1 pass2 = BwdPass lattice transfer rewrite + where + lattice = pairLattice (bp_lattice pass1) (bp_lattice pass2) + transfer = mkBTransfer3 (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2) + where + tf :: (t4 -> t -> t2) -> (t4 -> t1 -> t3) -> t4 -> (t, t1) -> (t2, t3) + tf t1 t2 n (f1, f2) = (t1 n f1, t2 n f2) + tfb :: IsMap map => + (t2 -> map a -> t) + -> (t2 -> map b -> t1) + -> t2 + -> map (a, b) + -> (t, t1) + tfb t1 t2 n fb = (t1 n $ mapMap fst fb, t2 n $ mapMap snd fb) + (tf1, tm1, tl1) = getBTransfer3 (bp_transfer pass1) + (tf2, tm2, tl2) = getBTransfer3 (bp_transfer pass2) + rewrite = lift fst (bp_rewrite pass1) `thenBwdRw` lift snd (bp_rewrite pass2) + where + lift :: forall f1 . + ((f, f') -> f1) -> BwdRewrite m n f1 -> BwdRewrite m n (f, f') + lift proj = wrapBR project + where project :: forall e x . Shape x + -> (n e x -> + Fact x f1 -> m (Maybe (Graph n e x, BwdRewrite m n f1))) + -> (n e x -> + Fact x (f,f') -> m (Maybe (Graph n e x, BwdRewrite m n (f,f')))) + project Open = + \rw n pair -> liftM (liftM repair) $ rw n ( proj pair) + project Closed = + \rw n pair -> liftM (liftM repair) $ rw n (mapMap proj pair) + repair :: forall t. + (t, BwdRewrite m n f1) -> (t, BwdRewrite m n (f, f')) + repair (g, rw') = (g, lift proj rw') + -- XXX specialize repair so that the cost + -- of discriminating is one per combinator not one + -- per rewrite + +pairLattice :: forall f f' . + DataflowLattice f -> DataflowLattice f' -> DataflowLattice (f, f') +pairLattice l1 l2 = + DataflowLattice + { fact_name = fact_name l1 ++ " x " ++ fact_name l2 + , fact_bot = (fact_bot l1, fact_bot l2) + , fact_join = join + } + where + join lbl (OldFact (o1, o2)) (NewFact (n1, n2)) = (c', (f1, f2)) + where (c1, f1) = fact_join l1 lbl (OldFact o1) (NewFact n1) + (c2, f2) = fact_join l2 lbl (OldFact o2) (NewFact n2) + c' = case (c1, c2) of + (NoChange, NoChange) -> NoChange + _ -> SomeChange diff --git a/src/Compiler/Hoopl/Dataflow.hs b/src/Compiler/Hoopl/Dataflow.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl/Dataflow.hs @@ -0,0 +1,821 @@ +{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, MultiParamTypeClasses #-} + +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 + , wrapFR, wrapFR2 + , BwdPass(..), BwdTransfer, mkBTransfer, mkBTransfer3, getBTransfer3 + , wrapBR, wrapBR2 + , BwdRewrite, mkBRewrite, mkBRewrite3, getBRewrite3, noBwdRewrite + , analyzeAndRewriteFwd, analyzeAndRewriteBwd + ) +where + +import Control.Monad +import Data.Maybe + +import Compiler.Hoopl.Checkpoint +import Compiler.Hoopl.Collections +import Compiler.Hoopl.Fuel +import Compiler.Hoopl.Graph hiding (Graph) -- hiding so we can redefine + -- and include definition in paper +import qualified Compiler.Hoopl.GraphUtil as U +import Compiler.Hoopl.Label +import Compiler.Hoopl.Util + +----------------------------------------------------------------------------- +-- DataflowLattice +----------------------------------------------------------------------------- + +data DataflowLattice a = DataflowLattice + { fact_name :: String -- Documentation + , fact_bot :: a -- Lattice bottom element + , fact_join :: JoinFun a -- Lattice join plus change flag + -- (changes iff result > old fact) + } +-- ^ A transfer function might want to use the logging flag +-- to control debugging, as in for example, it updates just one element +-- in a big finite map. We don't want Hoopl to show the whole fact, +-- and only the transfer function knows exactly what changed. + +type JoinFun a = Label -> OldFact a -> NewFact a -> (ChangeFlag, a) + -- the label argument is for debugging purposes only +newtype OldFact a = OldFact a +newtype NewFact a = NewFact a + +data ChangeFlag = NoChange | SomeChange deriving (Eq, Ord) +changeIf :: Bool -> ChangeFlag +changeIf changed = if changed then SomeChange else NoChange + + +-- | 'mkFactBase' creates a 'FactBase' from a list of ('Label', fact) +-- pairs. If the same label appears more than once, the relevant facts +-- are joined. + +mkFactBase :: forall f. DataflowLattice f -> [(Label, f)] -> FactBase f +mkFactBase lattice = foldl add mapEmpty + where add :: FactBase f -> (Label, f) -> FactBase f + add map (lbl, f) = mapInsert lbl newFact map + where newFact = case mapLookup lbl map of + Nothing -> f + Just f' -> snd $ join lbl (OldFact f') (NewFact f) + join = fact_join lattice + + +----------------------------------------------------------------------------- +-- Analyze and rewrite forward: the interface +----------------------------------------------------------------------------- + +data FwdPass m n f + = FwdPass { fp_lattice :: DataflowLattice f + , fp_transfer :: FwdTransfer n f + , fp_rewrite :: FwdRewrite m n f } + +newtype FwdTransfer n f + = FwdTransfer3 { getFTransfer3 :: + ( n C O -> f -> f + , n O O -> f -> f + , n O C -> f -> FactBase f + ) } + +newtype FwdRewrite m n f -- see Note [Respects Fuel] + = FwdRewrite3 { getFRewrite3 :: + ( n C O -> f -> m (Maybe (Graph n C O, FwdRewrite m n f)) + , n O O -> f -> m (Maybe (Graph n O O, FwdRewrite m n f)) + , n O C -> f -> m (Maybe (Graph n O C, FwdRewrite m n f)) + ) } + +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'))) + ) + -- ^ This argument may assume that any function passed to it + -- respects fuel, and it must return a result that respects fuel. + -> 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 + :: (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))) + ) + -- ^ This argument may assume that any function passed to it + -- respects fuel, and it must return a result that respects fuel. + -> FwdRewrite m1 n1 f1 + -> FwdRewrite m2 n2 f2 + -> FwdRewrite m3 n3 f3 -- see Note [Respects Fuel] +wrapFR2 wrap2 (FwdRewrite3 (f1, m1, l1)) (FwdRewrite3 (f2, m2, l2)) = + FwdRewrite3 (wrap2 f1 f2, wrap2 m1 m2, wrap2 l1 l2) + + +mkFTransfer3 :: (n C O -> f -> f) + -> (n O O -> f -> f) + -> (n O C -> f -> FactBase f) + -> FwdTransfer n f +mkFTransfer3 f m l = FwdTransfer3 (f, m, l) + +mkFTransfer :: (forall e x . n e x -> f -> Fact x f) -> FwdTransfer n f +mkFTransfer f = FwdTransfer3 (f, f, f) + +-- | Functions passed to 'mkFRewrite3' should not be aware of the fuel supply. +-- The result returned by 'mkFRewrite3' respects fuel. +mkFRewrite3 :: forall m n f. FuelMonad m + => (n C O -> f -> m (Maybe (Graph n C O))) + -> (n O O -> f -> m (Maybe (Graph n O O))) + -> (n O C -> f -> m (Maybe (Graph n O C))) + -> FwdRewrite m n f +mkFRewrite3 f m l = FwdRewrite3 (lift f, lift m, lift l) + where lift :: forall t t1 a. (t -> t1 -> m (Maybe a)) -> t -> t1 -> m (Maybe (a, FwdRewrite m n f)) + lift rw node fact = liftM (liftM asRew) (withFuel =<< rw node fact) + asRew :: forall t. t -> (t, FwdRewrite m n f) + asRew g = (g, noFwdRewrite) + +noFwdRewrite :: Monad m => FwdRewrite m n f +noFwdRewrite = FwdRewrite3 (noRewrite, noRewrite, noRewrite) + +noRewrite :: Monad m => a -> b -> m (Maybe c) +noRewrite _ _ = return Nothing + + + +-- | Functions passed to 'mkFRewrite' should not be aware of the fuel supply. +-- The result returned by 'mkFRewrite' respects fuel. +mkFRewrite :: FuelMonad m => (forall e x . n e x -> f -> m (Maybe (Graph n e x))) + -> FwdRewrite m n f +mkFRewrite f = mkFRewrite3 f f f + + +type family Fact x f :: * +type instance Fact C f = FactBase f +type instance Fact O f = f + +-- | if the graph being analyzed is open at the entry, there must +-- be no other entry point, or all goes horribly wrong... +analyzeAndRewriteFwd + :: forall m n f e x entries. (CheckpointMonad m, NonLocal n, LabelsPtr entries) + => FwdPass m n f + -> MaybeC e entries + -> Graph n e x -> Fact e f + -> m (Graph n e x, FactBase f, MaybeO x f) +analyzeAndRewriteFwd pass entries g f = + do (rg, fout) <- arfGraph pass (fmap targetLabels entries) g f + let (g', fb) = normalizeGraph rg + return (g', fb, distinguishedExitFact g' fout) + +distinguishedExitFact :: forall n e x f . Graph n e x -> Fact x f -> MaybeO x f +distinguishedExitFact g f = maybe g + where maybe :: Graph n e x -> MaybeO x f + maybe GNil = JustO f + maybe (GUnit {}) = JustO f + maybe (GMany _ _ x) = case x of NothingO -> NothingO + JustO _ -> JustO f + +---------------------------------------------------------------- +-- Forward Implementation +---------------------------------------------------------------- + +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 + 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) + type ARFX thing = forall e x . thing e x -> Fact e f -> m (DG f n e x, Fact x f) + -} + graph :: Graph n e x -> Fact e f -> m (DG f n e x, Fact x f) +-- @ start block.tex -2 + block :: forall e x . + Block n e x -> f -> m (DG f n e x, Fact x f) +-- @ end block.tex +-- @ start node.tex -4 + node :: forall e x . (ShapeLifter e x) + => n e x -> f -> m (DG f n e x, Fact x f) +-- @ end node.tex +-- @ start bodyfun.tex + body :: [Label] -> LabelMap (Block n C C) + -> Fact C f -> m (DG f n C C, Fact C f) +-- @ end bodyfun.tex + -- Outgoing factbase is restricted to Labels *not* in + -- in the Body; the facts for Labels *in* + -- the Body are in the 'DG f n C C' +-- @ start cat.tex -2 + cat :: forall e a x f1 f2 f3. + (f1 -> m (DG f n e a, f2)) + -> (f2 -> m (DG f n a x, f3)) + -> (f1 -> m (DG f n e x, f3)) +-- @ end cat.tex + + graph GNil = \f -> return (dgnil, f) + graph (GUnit blk) = block blk + graph (GMany e bdy x) = (e `ebcat` bdy) `cat` exit x + where + ebcat :: MaybeO e (Block n O C) -> Body n -> Fact e f -> m (DG f n e C, Fact C f) + exit :: MaybeO x (Block n C O) -> Fact C f -> m (DG f n C x, Fact x f) + exit (JustO blk) = arfx block blk + exit NothingO = \fb -> return (dgnilC, fb) + ebcat entry bdy = c entries entry + where c :: MaybeC e [Label] -> MaybeO e (Block n O C) + -> Fact e f -> m (DG f n e C, Fact C f) + c NothingC (JustO entry) = block entry `cat` body (successors entry) bdy + c (JustC entries) NothingO = body entries bdy + c _ _ = error "bogus GADT pattern match failure" + + -- Lift from nodes to blocks +-- @ start block.tex -2 + block (BFirst n) = 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 + ; case grw of + Nothing -> return ( singletonDG f n + , ftransfer pass n f ) + Just (g, rw) -> + let pass' = pass { fp_rewrite = rw } + f' = fwdEntryFact n f + in arfGraph pass' (fwdEntryLabel n) g f' } + +-- @ end node.tex + + -- | Compose fact transformers and concatenate the resulting + -- rewritten graphs. + {-# INLINE cat #-} +-- @ start cat.tex -2 + cat ft1 ft2 f = do { (g1,f1) <- ft1 f + ; (g2,f2) <- ft2 f1 + ; return (g1 `dgSplice` g2, f2) } +-- @ end cat.tex + arfx :: forall thing x . + NonLocal thing + => (thing C x -> f -> m (DG f n C x, Fact x f)) + -> (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 + + + -- Outgoing factbase is restricted to Labels *not* in + -- in the Body; the facts for Labels *in* + -- 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 + 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 b fb = block b entryFact + where entryFact = getFact lattice (entryLabel b) fb +-- @ end bodyfun.tex + + +-- Join all the incoming facts with bottom. +-- We know the results _shouldn't change_, but the transfer +-- functions might, for example, generate some debugging traces. +joinInFacts :: DataflowLattice f -> FactBase f -> FactBase f +joinInFacts (lattice @ DataflowLattice {fact_bot = bot, fact_join = fj}) fb = + mkFactBase lattice $ map botJoin $ mapToList fb + where botJoin (l, f) = (l, snd $ fj l (OldFact bot) (NewFact f)) + +forwardBlockList :: (NonLocal n, LabelsPtr entry) + => entry -> Body n -> [Block n C C] +-- This produces a list of blocks in order suitable for forward analysis, +-- along with the list of Labels it may depend on for facts. +forwardBlockList entries blks = postorder_dfs_from blks entries + +----------------------------------------------------------------------------- +-- Backward analysis and rewriting: the interface +----------------------------------------------------------------------------- + +data BwdPass m n f + = BwdPass { bp_lattice :: DataflowLattice f + , bp_transfer :: BwdTransfer n f + , bp_rewrite :: BwdRewrite m n f } + +newtype BwdTransfer n f + = BwdTransfer3 { getBTransfer3 :: + ( n C O -> f -> f + , n O O -> f -> f + , n O C -> FactBase f -> f + ) } +newtype BwdRewrite m n f + = BwdRewrite3 { getBRewrite3 :: + ( n C O -> f -> m (Maybe (Graph n C O, BwdRewrite m n f)) + , n O O -> f -> m (Maybe (Graph n O O, BwdRewrite m n f)) + , n O C -> FactBase f -> m (Maybe (Graph n O C, BwdRewrite m n f)) + ) } + +wrapBR :: (forall e x . + Shape x + -> (n e x -> Fact x f -> m (Maybe (Graph n e x, BwdRewrite m n f ))) + -> (n' e x -> Fact x f' -> m' (Maybe (Graph n' e x, BwdRewrite m' n' f'))) + ) + -- ^ This argument may assume that any function passed to it + -- respects fuel, and it must return a result that respects fuel. + -> BwdRewrite m n f + -> BwdRewrite m' n' f' -- see Note [Respects Fuel] +wrapBR wrap (BwdRewrite3 (f, m, l)) = + BwdRewrite3 (wrap Open f, wrap Open m, wrap Closed l) + +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))) + -> (n3 e x -> Fact x f3 -> m3 (Maybe (Graph n3 e x, BwdRewrite m3 n3 f3)))) + -- ^ This argument may assume that any function passed to it + -- respects fuel, and it must return a result that respects fuel. + -> BwdRewrite m1 n1 f1 + -> BwdRewrite m2 n2 f2 + -> BwdRewrite m3 n3 f3 -- see Note [Respects Fuel] +wrapBR2 wrap2 (BwdRewrite3 (f1, m1, l1)) (BwdRewrite3 (f2, m2, l2)) = + BwdRewrite3 (wrap2 Open f1 f2, wrap2 Open m1 m2, wrap2 Closed l1 l2) + + + +mkBTransfer3 :: (n C O -> f -> f) -> (n O O -> f -> f) -> + (n O C -> FactBase f -> f) -> BwdTransfer n f +mkBTransfer3 f m l = BwdTransfer3 (f, m, l) + +mkBTransfer :: (forall e x . n e x -> Fact x f -> f) -> BwdTransfer n f +mkBTransfer f = BwdTransfer3 (f, f, f) + +-- | Functions passed to 'mkBRewrite3' should not be aware of the fuel supply. +-- The result returned by 'mkBRewrite3' respects fuel. +mkBRewrite3 :: forall m n f. FuelMonad m + => (n C O -> f -> m (Maybe (Graph n C O))) + -> (n O O -> f -> m (Maybe (Graph n O O))) + -> (n O C -> FactBase f -> m (Maybe (Graph n O C))) + -> BwdRewrite m n f +mkBRewrite3 f m l = BwdRewrite3 (lift f, lift m, lift l) + where lift :: forall t t1 a. (t -> t1 -> m (Maybe a)) -> t -> t1 -> m (Maybe (a, BwdRewrite m n f)) + lift rw node fact = liftM (liftM asRew) (withFuel =<< rw node fact) + asRew :: t -> (t, BwdRewrite m n f) + asRew g = (g, noBwdRewrite) + +noBwdRewrite :: Monad m => BwdRewrite m n f +noBwdRewrite = BwdRewrite3 (noRewrite, noRewrite, noRewrite) + +-- | Functions passed to 'mkBRewrite' should not be aware of the fuel supply. +-- The result returned by 'mkBRewrite' respects fuel. +mkBRewrite :: FuelMonad m + => (forall e x . n e x -> Fact x f -> m (Maybe (Graph n e x))) + -> BwdRewrite m n f +mkBRewrite f = mkBRewrite3 f f f + + +----------------------------------------------------------------------------- +-- Backward implementation +----------------------------------------------------------------------------- + +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 + 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) + type ARBX thing = forall e x . thing e x -> Fact x f -> m (DG f n e x, Fact e f) + -} + graph :: Graph n e x -> Fact x f -> m (DG f n e x, Fact e f) + block :: forall e x . Block n e x -> Fact x f -> m (DG f n e x, f) + node :: forall e x . (ShapeLifter e x) + => n e x -> Fact x f -> m (DG f n e x, f) + body :: [Label] -> Body n -> Fact C f -> m (DG f n C C, Fact C f) + cat :: forall e a x info info' info''. + (info' -> m (DG f n e a, info'')) + -> (info -> m (DG f n a x, info')) + -> (info -> m (DG f n e x, info'')) + + graph GNil = \f -> return (dgnil, f) + graph (GUnit blk) = block blk + graph (GMany e bdy x) = (e `ebcat` bdy) `cat` exit x + where + ebcat :: MaybeO e (Block n O C) -> Body n -> Fact C f -> m (DG f n e C, Fact e f) + exit :: MaybeO x (Block n C O) -> Fact x f -> m (DG f n C x, Fact C f) + exit (JustO blk) = arbx block blk + exit NothingO = \fb -> return (dgnilC, fb) + ebcat entry bdy = c entries entry + where c :: MaybeC e [Label] -> MaybeO e (Block n O C) + -> Fact C f -> m (DG f n e C, Fact e f) + c NothingC (JustO entry) = block entry `cat` body (successors entry) bdy + c (JustC entries) NothingO = body entries bdy + c _ _ = error "bogus GADT pattern match failure" + + -- Lift from nodes to blocks + block (BFirst n) = 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 + ; case bwdres of + Nothing -> return (singletonDG entry_f n, entry_f) + where entry_f = btransfer pass n f + Just (g, rw) -> + do { let pass' = pass { bp_rewrite = rw } + ; (g, f) <- arbGraph pass' (fwdEntryLabel n) g f + ; return (g, bwdEntryFact (bp_lattice pass) n f)} } + + -- | Compose fact transformers and concatenate the resulting + -- rewritten graphs. + {-# INLINE cat #-} + cat ft1 ft2 f = do { (g2,f2) <- ft2 f + ; (g1,f1) <- ft1 f2 + ; return (g1 `dgSplice` g2, f1) } + + arbx :: forall thing x . + NonLocal thing + => (thing C x -> Fact x f -> m (DG f n C x, f)) + -> (thing C x -> Fact x f -> m (DG f n C x, Fact C f)) + + arbx arb thing f = do { (rg, f) <- arb thing f + ; let fb = joinInFacts (bp_lattice pass) $ + mapSingleton (entryLabel thing) f + ; return (rg, fb) } + -- joinInFacts adds debugging information + + -- Outgoing factbase is restricted to Labels *not* in + -- 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 + 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. +backwardBlockList entries body = reverse $ forwardBlockList entries body + +{- + +The forward and backward cases are not dual. In the forward case, the +entry points are known, and one simply traverses the body blocks from +those points. In the backward case, something is known about the exit +points, but this information is essentially useless, because we don't +actually have a dual graph (that is, one with edges reversed) to +compute with. (Even if we did have a dual graph, it would not avail +us---a backward analysis must include reachable blocks that don't +reach the exit, as in a procedure that loops forever and has side +effects.) + +-} + + +-- | if the graph being analyzed is open at the exit, I don't +-- quite understand the implications of possible other exits +analyzeAndRewriteBwd + :: (CheckpointMonad m, NonLocal n, LabelsPtr entries) + => BwdPass m n f + -> MaybeC e entries -> Graph n e x -> Fact x f + -> m (Graph n e x, FactBase f, MaybeO e f) +analyzeAndRewriteBwd pass entries g f = + do (rg, fout) <- arbGraph pass (fmap targetLabels entries) g f + let (g', fb) = normalizeGraph rg + return (g', fb, distinguishedEntryFact g' fout) + +distinguishedEntryFact :: forall n e x f . Graph n e x -> Fact e f -> MaybeO e f +distinguishedEntryFact g f = maybe g + where maybe :: Graph n e x -> MaybeO e f + maybe GNil = JustO f + maybe (GUnit {}) = JustO f + maybe (GMany e _ _) = case e of NothingO -> NothingO + JustO _ -> JustO f + +----------------------------------------------------------------------------- +-- 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) +-- 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) + where + (cha2, res_fact) -- Note [Unreachable blocks] + = case lookupFact lbl fbase of + Nothing -> (SomeChange, new_fact_debug) -- Note [Unreachable blocks] + Just old_fact -> join old_fact + where join old_fact = + 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 + + +{- +-- this doesn't work because it can't be implemented +class Monad m => FixpointMonad m where + observeChangedFactBase :: m (Maybe (FactBase f)) -> Maybe (FactBase f) +-} + +-- @ start fptype.tex +data Direction = Fwd | Bwd +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] + -> (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 + -- 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 + + +{- Note [TxFactBase invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The TxFactBase is used only during a fixpoint iteration (or "sweep"), +and accumulates facts (and the transformed code) during the fixpoint +iteration. + +* tfb_fbase increases monotonically, across all sweeps + +* At the beginning of each sweep + tfb_cha = NoChange + tfb_lbls = {} + +* During each sweep we process each block in turn. Processing a block + is done thus: + 1. Read from tfb_fbase the facts for its entry label (forward) + or successors labels (backward) + 2. Transform those facts into new facts for its successors (forward) + or entry label (backward) + 3. Augment tfb_fbase with that info + We call the labels read in step (1) the "in-labels" of the sweep + +* The field tfb_lbls is the set of in-labels of all blocks that have + been processed so far this sweep, including the block that is + currently being processed. tfb_lbls is initialised to {}. It is a + subset of the Labels of the *original* (not transformed) blocks. + +* The tfb_cha field is set to SomeChange iff we decide we need to + perform another iteration of the fixpoint loop. It is initialsed to NoChange. + + Specifically, we set tfb_cha to SomeChange in step (3) iff + (a) The fact in tfb_fbase for a block L changes + (b) L is in tfb_lbls + Reason: until a label enters the in-labels its accumuated fact in tfb_fbase + has not been read, hence cannot affect the outcome + +Note [Unreachable blocks] +~~~~~~~~~~~~~~~~~~~~~~~~~ +A block that is not in the domain of tfb_fbase is "currently unreachable". +A currently-unreachable block is not even analyzed. 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 analyzed, 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 + +* Even if the fact is going from UNR to bottom, we still call the + client's fact_join function because it might give the client + some useful debugging information. + +* 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. +-} + +----------------------------------------------------------------------------- +-- DG: an internal data type for 'decorated graphs' +-- TOTALLY internal to Hoopl; each block is decorated with a fact +----------------------------------------------------------------------------- + +-- @ start dg.tex +type Graph = Graph' Block +type DG f = Graph' (DBlock f) +data DBlock f n e x = DBlock f (Block n e x) -- ^ block decorated with fact +-- @ end dg.tex +instance NonLocal n => NonLocal (DBlock f n) where + entryLabel (DBlock _ b) = entryLabel b + successors (DBlock _ b) = successors b + +--- constructors + +dgnil :: DG f n O O +dgnilC :: DG f n C C +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 + +normalizeGraph g = (graphMapBlocks dropFact g, facts g) + where dropFact :: DBlock t t1 t2 t3 -> Block t1 t2 t3 + dropFact (DBlock _ b) = b + facts :: DG f n e x -> FactBase f + facts GNil = noFacts + facts (GUnit _) = noFacts + facts (GMany _ body exit) = bodyFacts body `mapUnion` exitFacts exit + exitFacts :: MaybeO x (DBlock f n C O) -> FactBase f + 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 + +--- implementation of the constructors (boring) + +dgnil = GNil +dgnilC = GMany NothingO emptyBody NothingO + +dgSplice = U.splice fzCat + where fzCat :: DBlock f n e O -> DBlock t n O x -> DBlock f n e x + fzCat (DBlock f b1) (DBlock _ b2) = DBlock f (b1 `U.cat` b2) + +---------------------------------------------------------------- +-- Utilities +---------------------------------------------------------------- + +-- Lifting based on shape: +-- - from nodes to blocks +-- - from facts to fact-like things +-- Lowering back: +-- - from fact-like things to facts +-- Note that the latter two functions depend only on the entry shape. +-- @ start node.tex +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 + -> 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 + -> Fact x f -> m (Maybe (Graph n e x, BwdRewrite m n f)) + +instance ShapeLifter C O where + singletonDG f = gUnitCO . DBlock f . BFirst + 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 + 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 + fwdEntryLabel _ = NothingC + +instance ShapeLifter O C where + singletonDG f = gUnitOC . DBlock f . BLast + 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 + fwdEntryLabel _ = NothingC + +-- Fact lookup: the fact `orelse` bottom +getFact :: DataflowLattice f -> Label -> FactBase f -> f +getFact lat l fb = case lookupFact l fb of Just f -> f + Nothing -> fact_bot lat + + + +{- Note [Respects fuel] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-} +-- $fuel +-- A value of type 'FwdRewrite' or 'BwdRewrite' /respects fuel/ if +-- any function contained within the value satisfies the following properties: +-- +-- * When fuel is exhausted, it always returns 'Nothing'. +-- +-- * When it returns @Just g rw@, it consumes /exactly/ one unit +-- of fuel, and new rewrite 'rw' also respects fuel. +-- +-- Provided that functions passed to 'mkFRewrite', 'mkFRewrite3', +-- 'mkBRewrite', and 'mkBRewrite3' are not aware of the fuel supply, +-- the results respect fuel. +-- +-- It is an /unchecked/ run-time error for the argument passed to 'wrapFR', +-- 'wrapFR2', 'wrapBR', or 'warpBR2' to return a function that does not respect fuel. diff --git a/src/Compiler/Hoopl/Debug.hs b/src/Compiler/Hoopl/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl/Debug.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables, FlexibleContexts #-} + +module Compiler.Hoopl.Debug + ( TraceFn , debugFwdJoins , debugBwdJoins + , debugFwdTransfers , debugBwdTransfers + ) +where + +import Compiler.Hoopl.Dataflow +import Compiler.Hoopl.Show + +-------------------------------------------------------------------------------- +-- | Debugging combinators: +-- Each combinator takes a dataflow pass and produces +-- a dataflow pass that can output debugging messages. +-- You provide the function, we call it with the applicable message. +-- +-- The most common use case is probably to: +-- +-- 1. import 'Debug.Trace' +-- +-- 2. pass 'trace' as the 1st argument to the debug combinator +-- +-- 3. pass 'const true' as the 2nd argument to the debug combinator +-- +-- There are two kinds of debugging messages for a join, +-- depending on whether the join is higher in the lattice than the old fact: +-- 1. If the join is higher, we show: +-- + Join@L: f1 `join` f2 = f' +-- where: +-- + indicates a change +-- L is the label where the join takes place +-- f1 is the old fact at the label +-- f2 is the new fact we are joining to f1 +-- f' is the result of the join +-- 2. _ Join@L: f2 <= f1 +-- where: +-- _ indicates no change +-- L is the label where the join takes place +-- f1 is the old fact at the label (which remains unchanged) +-- f2 is the new fact we joined with f1 +-------------------------------------------------------------------------------- + + +debugFwdJoins :: forall m n f . Show f => TraceFn -> ChangePred -> FwdPass m n f -> FwdPass m n f +debugBwdJoins :: forall m n f . Show f => TraceFn -> ChangePred -> BwdPass m n f -> BwdPass m n f + +type TraceFn = forall a . String -> a -> a +type ChangePred = ChangeFlag -> Bool + +debugFwdJoins trace pred p = p { fp_lattice = debugJoins trace pred $ fp_lattice p } +debugBwdJoins trace pred p = p { bp_lattice = debugJoins trace pred $ bp_lattice p } + +debugJoins :: Show f => TraceFn -> ChangePred -> DataflowLattice f -> DataflowLattice f +debugJoins trace showPred l@(DataflowLattice {fact_join = join}) = l {fact_join = join'} + where + join' l f1@(OldFact of1) f2@(NewFact nf2) = + if showPred c then trace output res else res + where res@(c, f') = join l f1 f2 + output = case c of + SomeChange -> "+ Join@" ++ show l ++ ": " ++ show of1 ++ " `join` " + ++ show nf2 ++ " = " ++ show f' + NoChange -> "_ Join@" ++ show l ++ ": " ++ show nf2 ++ " <= " ++ show of1 + +-------------------------------------------------------------------------------- +-- Functions we'd like to have, but don't know how to implement generically: +-------------------------------------------------------------------------------- + +type ShowN n = forall e x . n e x -> String +type FPred n f = forall e x . n e x -> f -> Bool +type BPred n f = forall e x . n e x -> Fact x f -> Bool +debugFwdTransfers:: + forall m n f . Show f => TraceFn -> ShowN n -> FPred n f -> FwdPass m n f -> FwdPass m n f +debugFwdTransfers trace showN showPred pass = pass { fp_transfer = transfers' } + where + (f, m, l) = getFTransfer3 $ fp_transfer pass + transfers' = mkFTransfer3 (wrap show f) (wrap show m) (wrap showFactBase l) + wrap :: forall e x . (Fact x f -> String) -> (n e x -> f -> Fact x f) -> n e x -> f -> Fact x f + wrap showOutF ft n f = if showPred n f then trace output res else res + where + res = ft n f + output = name ++ " transfer: " ++ show f ++ " -> " ++ showN n ++ " -> " ++ showOutF res + name = fact_name (fp_lattice pass) + +debugBwdTransfers:: + forall m n f . Show f => TraceFn -> ShowN n -> BPred n f -> BwdPass m n f -> BwdPass m n f +debugBwdTransfers trace showN showPred pass = pass { bp_transfer = transfers' } + where + (f, m, l) = getBTransfer3 $ bp_transfer pass + transfers' = mkBTransfer3 (wrap show f) (wrap show m) (wrap showFactBase l) + wrap :: forall e x . (Fact x f -> String) -> (n e x -> Fact x f -> f) -> n e x -> Fact x f -> f + wrap showInF ft n f = if showPred n f then trace output res else res + where + res = ft n f + output = name ++ " transfer: " ++ showInF f ++ " -> " ++ showN n ++ " -> " ++ show res + name = fact_name (bp_lattice pass) + + +-- debugFwdTransfers, debugFwdRewrites, debugFwdAll :: +-- forall m n f . Show f => TraceFn -> ShowN n -> FwdPass m n f -> FwdPass m n f +-- debugBwdTransfers, debugBwdRewrites, debugBwdAll :: +-- forall m n f . Show f => TraceFn -> ShowN n -> BwdPass m n f -> BwdPass m n f + diff --git a/src/Compiler/Hoopl/Fuel.hs b/src/Compiler/Hoopl/Fuel.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl/Fuel.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- The fuel monad +----------------------------------------------------------------------------- + +module Compiler.Hoopl.Fuel + ( Fuel, infiniteFuel, fuelRemaining + , withFuel + , FuelMonad(..) + , FuelMonadT(..) + , CheckingFuelMonad + , InfiniteFuelMonad + , SimpleFuelMonad + ) +where + +import Compiler.Hoopl.Checkpoint +import Compiler.Hoopl.Unique + +class Monad m => FuelMonad m where + getFuel :: m Fuel + setFuel :: Fuel -> m () + +-- | Find out how much fuel remains after a computation. +-- Can be subtracted from initial fuel to get total consumption. +fuelRemaining :: FuelMonad m => m Fuel +fuelRemaining = getFuel + +class FuelMonadT fm where + runWithFuel :: (Monad m, FuelMonad (fm m)) => Fuel -> fm m a -> m a + + +type Fuel = Int + +withFuel :: FuelMonad m => Maybe a -> m (Maybe a) +withFuel Nothing = return Nothing +withFuel (Just a) = do f <- getFuel + if f == 0 + then return Nothing + else setFuel (f-1) >> return (Just a) + + +---------------------------------------------------------------- + +newtype CheckingFuelMonad m a = FM { unFM :: Fuel -> m (a, Fuel) } + +instance Monad m => Monad (CheckingFuelMonad m) where + return a = FM (\f -> return (a, f)) + fm >>= k = FM (\f -> do { (a, f') <- unFM fm f; unFM (k a) f' }) + +instance CheckpointMonad m => CheckpointMonad (CheckingFuelMonad m) where + type Checkpoint (CheckingFuelMonad m) = (Fuel, Checkpoint m) + checkpoint = FM $ \fuel -> do { s <- checkpoint + ; return ((fuel, s), fuel) } + restart (fuel, s) = FM $ \_ -> do { restart s; return ((), fuel) } + +instance UniqueMonad m => UniqueMonad (CheckingFuelMonad m) where + freshUnique = FM (\f -> do { l <- freshUnique; return (l, f) }) + +instance Monad m => FuelMonad (CheckingFuelMonad m) where + getFuel = FM (\f -> return (f, f)) + setFuel f = FM (\_ -> return ((),f)) + +instance FuelMonadT CheckingFuelMonad where + runWithFuel fuel m = do { (a, _) <- unFM m fuel; return a } + +---------------------------------------------------------------- + +newtype InfiniteFuelMonad m a = IFM { unIFM :: m a } +instance Monad m => Monad (InfiniteFuelMonad m) where + return a = IFM $ return a + m >>= k = IFM $ do { a <- unIFM m; unIFM (k a) } + +instance UniqueMonad m => UniqueMonad (InfiniteFuelMonad m) where + freshUnique = IFM $ freshUnique + +instance Monad m => FuelMonad (InfiniteFuelMonad m) where + getFuel = return infiniteFuel + setFuel _ = return () + +instance CheckpointMonad m => CheckpointMonad (InfiniteFuelMonad m) where + type Checkpoint (InfiniteFuelMonad m) = Checkpoint m + checkpoint = IFM checkpoint + restart s = IFM $ restart s + + + +instance FuelMonadT InfiniteFuelMonad where + runWithFuel _ = unIFM + +infiniteFuel :: Fuel -- effectively infinite, any, but subtractable +infiniteFuel = maxBound + +type SimpleFuelMonad = CheckingFuelMonad SimpleUniqueMonad + +{- +runWithFuelAndUniques :: Fuel -> [Unique] -> FuelMonad a -> a +runWithFuelAndUniques fuel uniques m = a + where (a, _, _) = unFM m fuel uniques + +freshUnique :: FuelMonad Unique +freshUnique = FM (\f (l:ls) -> (l, f, ls)) +-} + diff --git a/src/Compiler/Hoopl/GHC.hs b/src/Compiler/Hoopl/GHC.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl/GHC.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE GADTs, RankNTypes #-} + +{- Exposing some internals to GHC -} +module Compiler.Hoopl.GHC + ( uniqueToInt + , uniqueToLbl, lblToUnique + , getFuel, setFuel + , bodyToBlockMap, bodyOfBlockMap + ) +where + +import Compiler.Hoopl.Fuel +import Compiler.Hoopl.Graph +import Compiler.Hoopl.Label +import Compiler.Hoopl.Unique + +-- Converts Body to a map of closed/closed blocks. +-- It should better be a constant-time operation +-- as GHC is counting on it. +bodyToBlockMap :: Body' block n -> LabelMap (block n C C) +bodyToBlockMap (Body bodyMap) = bodyMap + +bodyOfBlockMap :: LabelMap (block n C C) -> Body' block n +bodyOfBlockMap = Body diff --git a/src/Compiler/Hoopl/Graph.hs b/src/Compiler/Hoopl/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl/Graph.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE GADTs, EmptyDataDecls, TypeFamilies #-} + +module Compiler.Hoopl.Graph + ( O, C, Block(..), Body, Body'(..), Graph, Graph'(..) + , MaybeO(..), MaybeC(..), Shape(..), IndexedCO + , NonLocal(entryLabel, successors) + , emptyBody, addBlock, bodyList + ) +where + +import Compiler.Hoopl.Collections +import Compiler.Hoopl.Label + +----------------------------------------------------------------------------- +-- Graphs +----------------------------------------------------------------------------- + +-- | Used at the type level to indicate an "open" structure with +-- a unique, unnamed control-flow edge flowing in or out. +-- "Fallthrough" and concatenation are permitted at an open point. +data O + + +-- | Used at the type level to indicate a "closed" structure which +-- supports control transfer only through the use of named +-- labels---no "fallthrough" is permitted. The number of control-flow +-- edges is unconstrained. +data C + +-- | A sequence of nodes. May be any of four shapes (O/O, O/C, C/O, C/C). +-- Open at the entry means single entry, mutatis mutandis for exit. +-- A closed/closed block is a /basic/ block and can't be extended further. +-- 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 + + -- 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 + + 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) +newtype Body' block n = Body (LabelMap (block n C C)) + +-- | A control-flow graph, which may take any of four shapes (O/O, O/C, C/O, C/C). +-- A graph open at the entry has a single, distinguished, anonymous entry point; +-- if a graph is closed at the entry, its entry point(s) are supplied by a context. +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) + -> LabelMap (block n C C) + -> MaybeO x (block n C O) + -> Graph' block n e x + +-- | Maybe type indexed by open/closed +data MaybeO ex t where + JustO :: t -> MaybeO O t + NothingO :: MaybeO C t + +-- | Maybe type indexed by closed/open +data MaybeC ex t where + JustC :: t -> MaybeC C t + NothingC :: MaybeC O t + +-- | Dynamic shape value +data Shape ex where + Closed :: Shape C + Open :: Shape O + +-- | Either type indexed by closed/open using type families +type family IndexedCO ex a b :: * +type instance IndexedCO C a b = a +type instance IndexedCO O a b = b + +instance Functor (MaybeO ex) where + fmap _ NothingO = NothingO + fmap f (JustO a) = JustO (f a) + +instance Functor (MaybeC ex) where + fmap _ NothingC = NothingC + fmap f (JustC a) = JustC (f a) + +------------------------------- +-- | Gives access to the anchor points for +-- nonlocal edges as well as the edges themselves +class NonLocal thing where + entryLabel :: thing C x -> Label -- ^ The label of a first node or block + 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 + +------------------------------ +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 + +bodyList :: NonLocal (block n) => Body' block n -> [(Label,block n C C)] +bodyList (Body body) = mapToList body diff --git a/src/Compiler/Hoopl/GraphUtil.hs b/src/Compiler/Hoopl/GraphUtil.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl/GraphUtil.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-} + +-- N.B. addBasicBlocks won't work on OO without a Node (branch/label) constraint + +module Compiler.Hoopl.GraphUtil + ( splice, gSplice , cat , bodyGraph, bodyUnion + , frontBiasBlock, backBiasBlock + ) + +where + +import Compiler.Hoopl.Collections +import Compiler.Hoopl.Graph +import Compiler.Hoopl.Label + +bodyGraph :: Body n -> Graph n C C +bodyGraph b = GMany NothingO b NothingO + +splice :: forall block n e a x . NonLocal (block n) => + (forall e x . block n e O -> block n O x -> block n e x) + -> (Graph' block n e a -> Graph' block n a x -> Graph' block n e x) +splice bcat = sp + where sp :: forall e a x . + Graph' block n e a -> Graph' block n a x -> Graph' block n e x + + sp GNil g2 = g2 + sp g1 GNil = g1 + + sp (GUnit b1) (GUnit b2) = GUnit (b1 `bcat` b2) + + sp (GUnit b) (GMany (JustO e) bs x) = GMany (JustO (b `bcat` e)) bs x + + sp (GMany e bs (JustO x)) (GUnit b2) = GMany e bs (JustO (x `bcat` b2)) + + sp (GMany e1 bs1 (JustO x1)) (GMany (JustO e2) b2 x2) + = 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 + + sp _ _ = error "bogus GADT match failure" + +bodyUnion :: forall a . LabelMap a -> LabelMap a -> LabelMap a +bodyUnion = mapUnionWithKey nodups + where nodups l _ _ = error $ "duplicate blocks with label " ++ show l + +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 + + +---------------------------------------------------------------- + +-- | 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 :: 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 + +-- | 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 :: 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 diff --git a/src/Compiler/Hoopl/Label.hs b/src/Compiler/Hoopl/Label.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl/Label.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE TypeFamilies #-} +module Compiler.Hoopl.Label + ( Label + , freshLabel + , LabelSet, LabelMap + , FactBase, noFacts, lookupFact + + , uniqueToLbl -- MkGraph and GHC use only + , lblToUnique -- GHC use only + ) + +where + +import Compiler.Hoopl.Collections +import Compiler.Hoopl.Unique + +----------------------------------------------------------------------------- +-- Label +----------------------------------------------------------------------------- + +newtype Label = Label { lblToUnique :: Unique } + deriving (Eq, Ord) + +uniqueToLbl :: Unique -> Label +uniqueToLbl = Label + +instance Show Label where + show (Label n) = "L" ++ show n + +freshLabel :: UniqueMonad m => m Label +freshLabel = freshUnique >>= return . uniqueToLbl + +----------------------------------------------------------------------------- +-- LabelSet + +newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show) + +instance IsSet LabelSet where + type ElemOf LabelSet = Label + + setNull (LS s) = setNull s + setSize (LS s) = setSize s + setMember (Label k) (LS s) = setMember k s + + setEmpty = LS setEmpty + setSingleton (Label k) = LS (setSingleton k) + setInsert (Label k) (LS s) = LS (setInsert k s) + setDelete (Label k) (LS s) = LS (setDelete k s) + + setUnion (LS x) (LS y) = LS (setUnion x y) + setDifference (LS x) (LS y) = LS (setDifference x y) + setIntersection (LS x) (LS y) = LS (setIntersection x y) + setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y + + setFold k z (LS s) = setFold (k . uniqueToLbl) z s + + setElems (LS s) = map uniqueToLbl (setElems s) + setFromList ks = LS (setFromList (map lblToUnique ks)) + +----------------------------------------------------------------------------- +-- LabelMap + +newtype LabelMap v = LM (UniqueMap v) deriving (Eq, Ord, Show) + +instance IsMap LabelMap where + type KeyOf LabelMap = Label + + mapNull (LM m) = mapNull m + mapSize (LM m) = mapSize m + mapMember (Label k) (LM m) = mapMember k m + mapLookup (Label k) (LM m) = mapLookup k m + mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m + + mapEmpty = LM mapEmpty + mapSingleton (Label k) v = LM (mapSingleton k v) + mapInsert (Label k) v (LM m) = LM (mapInsert k v m) + mapDelete (Label k) (LM m) = LM (mapDelete k m) + + mapUnion (LM x) (LM y) = LM (mapUnion x y) + mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . uniqueToLbl) x y) + mapDifference (LM x) (LM y) = LM (mapDifference x y) + mapIntersection (LM x) (LM y) = LM (mapIntersection x y) + mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y + + mapMap f (LM m) = LM (mapMap f m) + mapMapWithKey f (LM m) = LM (mapMapWithKey (f . uniqueToLbl) m) + mapFold k z (LM m) = mapFold k z m + mapFoldWithKey k z (LM m) = mapFoldWithKey (k . uniqueToLbl) z m + + mapElems (LM m) = mapElems m + 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]) + +----------------------------------------------------------------------------- +-- FactBase + +type FactBase f = LabelMap f + +noFacts :: FactBase f +noFacts = mapEmpty + +lookupFact :: Label -> FactBase f -> Maybe f +lookupFact = mapLookup diff --git a/src/Compiler/Hoopl/MkGraph.hs b/src/Compiler/Hoopl/MkGraph.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl/MkGraph.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE ScopedTypeVariables, GADTs, TypeSynonymInstances, FlexibleInstances, RankNTypes #-} +module Compiler.Hoopl.MkGraph + ( AGraph, graphOfAGraph, aGraphOfGraph + , (<*>), (|*><*|), catGraphs, addEntrySeq, addExitSeq, addBlocks, unionBlocks + , emptyGraph, emptyClosedGraph, withFresh + , mkFirst, mkMiddle, mkMiddles, mkLast, mkBranch, mkLabel, mkWhileDo + , IfThenElseable(mkIfThenElse) + , mkEntry, mkExit + , HooplNode(mkLabelNode, mkBranchNode) + ) +where + +import Compiler.Hoopl.Label (Label, uniqueToLbl) +import Compiler.Hoopl.Graph +import qualified Compiler.Hoopl.GraphUtil as U +import Compiler.Hoopl.Unique +import Control.Monad (liftM2) + +{-| +As noted in the paper, we can define a single, polymorphic type of +splicing operation with the very polymorphic type +@ + AGraph n e a -> AGraph n a x -> AGraph n e x +@ +However, we feel that this operation is a bit /too/ polymorphic, +and that it's too easy for clients to use it blindly without +thinking. We therfore split it into two operations, '<*>' and '|*><*|', +which are supplemented by other functions: + + * The '<*>' operator is true concatenation, for connecting open graphs. + Control flows from the left graph to the right graph. + + * The '|*><*|' operator splices together two graphs at a closed + point. Nothing is known about control flow. The vertical bar + stands for "closed point" just as the angle brackets above stand + for "open point". Unlike the <*> operator, the |*><*| can create + a control-flow graph with dangling outedges or unreachable blocks. + The operator must be used carefully, so we have chosen a long name + on purpose, to help call people's attention to what they're doing. + + * The operator 'addBlocks' adds a set of basic blocks (represented + as a closed/closed 'AGraph' to an existing graph, without changing + the shape of the existing graph. In some cases, it's necessary to + introduce a branch and a label to 'get around' the blocks added, + so this operator, and other functions based on it, requires a + 'HooplNode' type-class constraint and is available only on AGraph, + not Graph. + + * We have discussed a dynamic assertion about dangling outedges and + unreachable blocks, but nothing is implemented yet. + +-} + + + +class GraphRep g where + -- | An empty graph that is open at entry and exit. + -- It is the left and right identity of '<*>'. + emptyGraph :: g n O O + -- | An empty graph that is closed at entry and exit. + -- It is the left and right identity of '|*><*|'. + emptyClosedGraph :: g n C C + -- | Create a graph from a first node + mkFirst :: n C O -> g n C O + -- | Create a graph from a middle node + 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 + infixl 3 <*> + infixl 2 |*><*| + -- | Concatenate two graphs; control flows from left to right. + (<*>) :: NonLocal n => g n e O -> g n O x -> g n e x + -- | Splice together two graphs at a closed point; nothing is known + -- about control flow. + (|*><*|) :: NonLocal n => g n e C -> g n C x -> g n e x + -- | Conveniently concatenate a sequence of open/open graphs using '<*>'. + catGraphs :: NonLocal n => [g n O O] -> g n O O + catGraphs = foldr (<*>) emptyGraph + + -- | Create a graph that defines a label + mkLabel :: HooplNode n => Label -> g n C O -- definition of the label + -- | Create a graph that branches to a label + mkBranch :: HooplNode n => Label -> g n O C -- unconditional branch to the label + + -- | Conveniently concatenate a sequence of middle nodes to form + -- an open/open graph. + mkMiddles :: NonLocal n => [n O O] -> g n O O + + mkLabel id = mkFirst $ mkLabelNode id + mkBranch target = mkLast $ mkBranchNode target + mkMiddles ms = catGraphs $ map mkMiddle ms + + -- | Create a graph containing only an entry sequence + mkEntry :: Block n O C -> g n O C + -- | Create a graph containing only an exit sequence + mkExit :: Block n C O -> g n C O + +instance GraphRep Graph where + emptyGraph = GNil + emptyClosedGraph = GMany NothingO emptyBody NothingO + (<*>) = U.gSplice + (|*><*|) = U.gSplice + mkMiddle = GUnit . BMiddle + mkExit block = GMany NothingO emptyBody (JustO block) + mkEntry block = GMany (JustO block) emptyBody NothingO + +instance GraphRep AGraph where + emptyGraph = aGraphOfGraph emptyGraph + emptyClosedGraph = aGraphOfGraph emptyClosedGraph + (<*>) = liftA2 (<*>) + (|*><*|) = liftA2 (|*><*|) + mkMiddle = aGraphOfGraph . mkMiddle + mkExit = aGraphOfGraph . mkExit + mkEntry = aGraphOfGraph . mkEntry + + +-- | The type of abstract graphs. Offers extra "smart constructors" +-- that may consume fresh labels during construction. +newtype AGraph n e x = + A { graphOfAGraph :: forall m. UniqueMonad m => + m (Graph n e x) -- ^ Take an abstract 'AGraph' + -- and make a concrete (if monadic) + -- 'Graph'. + } + +-- | Take a graph and make it abstract. +aGraphOfGraph :: Graph n e x -> AGraph n e x +aGraphOfGraph g = A (return g) + + +-- | The 'Labels' class defines things that can be lambda-bound +-- by an argument to 'withFreshLabels'. Such an argument may +-- lambda-bind a single 'Label', or if multiple labels are needed, +-- it can bind a tuple. Tuples can be nested, so arbitrarily many +-- fresh labels can be acquired in a single call. +-- +-- For example usage see implementations of 'mkIfThenElse' and 'mkWhileDo'. +class Uniques u where + withFresh :: (u -> AGraph n e x) -> AGraph n e x + +instance Uniques Unique where + withFresh f = A $ freshUnique >>= (graphOfAGraph . f) + +instance Uniques Label where + withFresh f = A $ freshUnique >>= (graphOfAGraph . f . uniqueToLbl) + +-- | Lifts binary 'Graph' functions into 'AGraph' functions. +liftA2 :: (Graph n a b -> Graph n c d -> Graph n e f) + -> (AGraph n a b -> AGraph n c d -> AGraph n e f) +liftA2 f (A g) (A g') = A (liftM2 f g g') + +-- | Extend an existing 'AGraph' with extra basic blocks "out of line". +-- No control flow is implied. Simon PJ should give example use case. +addBlocks :: HooplNode n + => AGraph n e x -> AGraph n C C -> AGraph n e x +addBlocks (A g) (A blocks) = A $ g >>= \g -> blocks >>= add g + where add :: (UniqueMonad m, HooplNode n) + => Graph n e x -> Graph n C C -> m (Graph n e x) + add (GMany e body x) (GMany NothingO body' NothingO) = + return $ GMany e (body `U.bodyUnion` body') x + add g@GNil blocks = spliceOO g blocks + add g@(GUnit _) blocks = spliceOO g blocks + spliceOO :: (HooplNode n, UniqueMonad m) + => Graph n O O -> Graph n C C -> m (Graph n O O) + spliceOO g blocks = graphOfAGraph $ withFresh $ \l -> + A (return g) <*> mkBranch l |*><*| A (return blocks) |*><*| mkLabel l + +-- | For some graph-construction operations and some optimizations, +-- Hoopl must be able to create control-flow edges using a given node +-- type 'n'. +class NonLocal n => HooplNode n where + -- | Create a branch node, the source of a control-flow edge. + mkBranchNode :: Label -> n O C + -- | Create a label node, the target (destination) of a control-flow edge. + mkLabelNode :: Label -> n C O + +-------------------------------------------------------------- +-- Shiny Things +-------------------------------------------------------------- + +class IfThenElseable x where + -- | Translate a high-level if-then-else construct into an 'AGraph'. + -- The condition takes as arguments labels on the true-false branch + -- and returns a single-entry, two-exit graph which exits to + -- the two labels. + mkIfThenElse :: HooplNode n + => (Label -> Label -> AGraph n O C) -- ^ branch condition + -> AGraph n O x -- ^ code in the "then" branch + -> AGraph n O x -- ^ code in the "else" branch + -> AGraph n O x -- ^ resulting if-then-else construct + +mkWhileDo :: HooplNode n + => (Label -> Label -> AGraph n O C) -- ^ loop condition + -> AGraph n O O -- ^ body of the loop + -> AGraph n O O -- ^ the final while loop + +instance IfThenElseable O where + mkIfThenElse cbranch tbranch fbranch = withFresh $ \(endif, ltrue, lfalse) -> + cbranch ltrue lfalse |*><*| + mkLabel ltrue <*> tbranch <*> mkBranch endif |*><*| + mkLabel lfalse <*> fbranch <*> mkBranch endif |*><*| + mkLabel endif + +instance IfThenElseable C where + mkIfThenElse cbranch tbranch fbranch = withFresh $ \(ltrue, lfalse) -> + cbranch ltrue lfalse |*><*| + mkLabel ltrue <*> tbranch |*><*| + mkLabel lfalse <*> fbranch + +mkWhileDo cbranch body = withFresh $ \(test, head, endwhile) -> + -- Forrest Baskett's while-loop layout + mkBranch test |*><*| + mkLabel head <*> body <*> mkBranch test |*><*| + mkLabel test <*> cbranch head endwhile |*><*| + mkLabel endwhile + +-------------------------------------------------------------- +-- Boring instance declarations +-------------------------------------------------------------- + + +instance (Uniques u1, Uniques u2) => Uniques (u1, u2) where + withFresh f = withFresh $ \u1 -> + withFresh $ \u2 -> + f (u1, u2) + +instance (Uniques u1, Uniques u2, Uniques u3) => Uniques (u1, u2, u3) where + withFresh f = withFresh $ \u1 -> + withFresh $ \u2 -> + withFresh $ \u3 -> + f (u1, u2, u3) + +instance (Uniques u1, Uniques u2, Uniques u3, Uniques u4) => Uniques (u1, u2, u3, u4) where + withFresh f = withFresh $ \u1 -> + withFresh $ \u2 -> + withFresh $ \u3 -> + withFresh $ \u4 -> + f (u1, u2, u3, u4) + +--------------------------------------------- +-- deprecated legacy functions + +{-# DEPRECATED addEntrySeq, addExitSeq, unionBlocks "use |*><*| instead" #-} +addEntrySeq :: NonLocal n => AGraph n O C -> AGraph n C x -> AGraph n O x +addExitSeq :: NonLocal n => AGraph n e C -> AGraph n C O -> AGraph n e O +unionBlocks :: NonLocal n => AGraph n C C -> AGraph n C C -> AGraph n C C + +addEntrySeq = (|*><*|) +addExitSeq = (|*><*|) +unionBlocks = (|*><*|) diff --git a/src/Compiler/Hoopl/Passes/DList.hs b/src/Compiler/Hoopl/Passes/DList.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl/Passes/DList.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} + +module Compiler.Hoopl.Passes.DList + ( Doms, domEntry, domLattice + , domPass + ) +where + +import Compiler.Hoopl + + +type Doms = WithBot [Label] +-- ^ List of labels, extended with a standard bottom element + +-- | The fact that goes into the entry of a dominator analysis: the first node +-- is dominated only by the entry point, which is represented by the empty list +-- of labels. +domEntry :: Doms +domEntry = PElem [] + +domLattice :: DataflowLattice Doms +domLattice = addPoints "dominators" extend + +extend :: JoinFun [Label] +extend _ (OldFact l) (NewFact l') = (changeIf (l `lengthDiffers` j), j) + where j = lcs l l' + lcs :: [Label] -> [Label] -> [Label] -- longest common suffix + lcs l l' | length l > length l' = lcs (drop (length l - length l') l) l' + | length l < length l' = lcs l' l + | otherwise = dropUnlike l l' l + dropUnlike [] [] maybe_like = maybe_like + dropUnlike (x:xs) (y:ys) maybe_like = + dropUnlike xs ys (if x == y then maybe_like else xs) + dropUnlike _ _ _ = error "this can't happen" + + lengthDiffers [] [] = False + lengthDiffers (_:xs) (_:ys) = lengthDiffers xs ys + lengthDiffers [] (_:_) = True + lengthDiffers (_:_) [] = True + +-- | Dominator pass +domPass :: (NonLocal n, Monad m) => FwdPass m n Doms +domPass = FwdPass domLattice (mkFTransfer3 first (const id) distributeFact) noFwdRewrite + where first n = fmap (entryLabel n:) diff --git a/src/Compiler/Hoopl/Passes/Dominator.hs b/src/Compiler/Hoopl/Passes/Dominator.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl/Passes/Dominator.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} + +module Compiler.Hoopl.Passes.Dominator + ( Doms, DPath(..), domPath, domEntry, domLattice, extendDom + , DominatorNode(..), DominatorTree(..), tree + , immediateDominators + , domPass + ) +where + +import Data.Maybe + +import Compiler.Hoopl + + +type Doms = WithBot DPath +-- ^ List of labels, extended with a standard bottom element + +-- | The fact that goes into the entry of a dominator analysis: the first node +-- is dominated only by the entry point, which is represented by the empty list +-- of labels. +domEntry :: Doms +domEntry = PElem (DPath []) + +newtype DPath = DPath [Label] + -- ^ represents part of the domination relation: each label + -- in a list is dominated by all its successors. This is a newtype only so + -- we can give it a fancy Show instance. + +instance Show DPath where + show (DPath ls) = concat (foldr (\l path -> show l : " -> " : path) ["entry"] ls) + +domPath :: Doms -> [Label] +domPath Bot = [] -- lies: an unreachable node appears to be dominated by the entry +domPath (PElem (DPath ls)) = ls + +extendDom :: Label -> DPath -> DPath +extendDom l (DPath ls) = DPath (l:ls) + +domLattice :: DataflowLattice Doms +domLattice = addPoints "dominators" extend + +extend :: JoinFun DPath +extend _ (OldFact (DPath l)) (NewFact (DPath l')) = + (changeIf (l `lengthDiffers` j), DPath j) + where j = lcs l l' + lcs :: [Label] -> [Label] -> [Label] -- longest common suffix + lcs l l' | length l > length l' = lcs (drop (length l - length l') l) l' + | length l < length l' = lcs l' l + | otherwise = dropUnlike l l' l + dropUnlike [] [] maybe_like = maybe_like + dropUnlike (x:xs) (y:ys) maybe_like = + dropUnlike xs ys (if x == y then maybe_like else xs) + dropUnlike _ _ _ = error "this can't happen" + + lengthDiffers [] [] = False + lengthDiffers (_:xs) (_:ys) = lengthDiffers xs ys + lengthDiffers [] (_:_) = True + lengthDiffers (_:_) [] = True + + + +-- | Dominator pass +domPass :: (NonLocal n, Monad m) => FwdPass m n Doms +domPass = FwdPass domLattice (mkFTransfer3 first (const id) distributeFact) noFwdRewrite + where first n = fmap (extendDom $ entryLabel n) + +---------------------------------------------------------------- + +data DominatorNode = Entry | Labelled Label +data DominatorTree = Dominates DominatorNode [DominatorTree] +-- ^ This data structure is a *rose tree* in which each node may have +-- arbitrarily many children. Each node dominates all its descendants. + +-- | Map from a FactBase for dominator lists into a +-- dominator tree. +tree :: [(Label, Doms)] -> DominatorTree +tree facts = Dominates Entry $ merge $ map reverse $ map mkList facts + -- This code has been lightly tested. The key insight is this: to + -- find lists that all have the same head, convert from a list of + -- lists to a finite map, in 'children'. Then, to convert from the + -- finite map to list of dominator trees, use the invariant that + -- each key dominates all the lists of values. + where merge lists = mapTree $ children $ filter (not . null) lists + children = foldl addList noFacts + addList :: FactBase [[Label]] -> [Label] -> FactBase [[Label]] + addList map (x:xs) = mapInsert x (xs:existing) map + where existing = fromMaybe [] $ lookupFact x map + addList _ [] = error "this can't happen" + mapTree :: FactBase [[Label]] -> [DominatorTree] + mapTree map = [Dominates (Labelled x) (merge lists) | + (x, lists) <- mapToList map] + mkList (l, doms) = l : domPath doms + + +instance Show DominatorTree where + show = tree2dot + +-- | Given a dominator tree, produce a string representation, in the +-- input language of dot, that will enable dot to produce a +-- visualization of the tree. For more info about dot see +-- http://www.graphviz.org. + +tree2dot :: DominatorTree -> String +tree2dot t = concat $ "digraph {\n" : dot t ["}\n"] + where + dot :: DominatorTree -> [String] -> [String] + dot (Dominates root trees) = + (dotnode root :) . outedges trees . flip (foldl subtree) trees + where outedges [] = id + outedges (Dominates n _ : ts) = + \s -> " " : show root : " -> " : show n : "\n" : outedges ts s + dotnode Entry = " entryNode [shape=plaintext, label=\"entry\"]\n" + dotnode (Labelled l) = " " ++ show l ++ "\n" + subtree = flip dot + +instance Show DominatorNode where + show Entry = "entryNode" + show (Labelled l) = show l + +---------------------------------------------------------------- + +-- | Takes FactBase from dominator analysis and returns a map from each +-- label to its immediate dominator, if any +immediateDominators :: FactBase Doms -> LabelMap Label +immediateDominators = mapFoldWithKey add mapEmpty + where add l (PElem (DPath (idom:_))) = mapInsert l idom + add _ _ = id + diff --git a/src/Compiler/Hoopl/Pointed.hs b/src/Compiler/Hoopl/Pointed.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl/Pointed.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE GADTs, ScopedTypeVariables #-} + +-- | Possibly doubly pointed lattices + +module Compiler.Hoopl.Pointed + ( Pointed(..), addPoints, addPoints', addTop, addTop' + , liftJoinTop, extendJoinDomain + , WithTop, WithBot, WithTopAndBot + ) +where + +import Compiler.Hoopl.Graph +import Compiler.Hoopl.Label +import Compiler.Hoopl.Dataflow + +-- | Adds top, bottom, or both to help form a lattice +data Pointed t b a where + Bot :: Pointed t C a + PElem :: a -> Pointed t b a + Top :: Pointed C b a + +-- ^ The type parameters 't' and 'b' are used to say whether top +-- and bottom elements have been added. The analogy with 'Block' +-- is nearly exact: +-- +-- * A 'Block' is closed at the entry if and only if it has a first node; +-- a 'Pointed' is closed at the top if and only if it has a top element. +-- +-- * A 'Block' is closed at the exit if and only if it has a last node; +-- a 'Pointed' is closed at the bottom if and only if it has a bottom element. +-- +-- We thus have four possible types, of which three are interesting: +-- +-- [@Pointed C C a@] Type @a@ extended with both top and bottom elements. +-- +-- [@Pointed C O a@] Type @a@ extended with a top element +-- only. (Presumably @a@ comes equipped with a bottom element of its own.) +-- +-- [@Pointed O C a@] Type @a@ extended with a bottom element only. +-- +-- [@Pointed O O a@] Isomorphic to @a@, and therefore not interesting. +-- +-- The advantage of all this GADT-ishness is that the constructors +-- 'Bot', 'Top', and 'PElem' can all be used polymorphically. +-- +-- A 'Pointed t b' type is an instance of 'Functor' and 'Show'. + + + +type WithBot a = Pointed O C a +-- ^ Type 'a' with a bottom element adjoined + +type WithTop a = Pointed C O a +-- ^ Type 'a' with a top element adjoined + +type WithTopAndBot a = Pointed C C a +-- ^ Type 'a' with top and bottom elements adjoined + + +-- | Given a join function and a name, creates a semi lattice by +-- adding a bottom element, and possibly a top element also. +-- A specialized version of 'addPoints''. +addPoints :: String -> JoinFun a -> DataflowLattice (Pointed t C a) +-- | A more general case for creating a new lattice +addPoints' :: forall a t . + String + -> (Label -> OldFact a -> NewFact a -> (ChangeFlag, Pointed t C a)) + -> DataflowLattice (Pointed t C a) + +addPoints name join = addPoints' name join' + where join' l o n = (change, PElem f) + where (change, f) = join l o n + +addPoints' name joinx = DataflowLattice name Bot join + where -- careful: order of cases matters for ChangeFlag + join :: JoinFun (Pointed t C a) + join _ (OldFact f) (NewFact Bot) = (NoChange, f) + join _ (OldFact Top) (NewFact _) = (NoChange, Top) + join _ (OldFact Bot) (NewFact f) = (SomeChange, f) + join _ (OldFact _) (NewFact Top) = (SomeChange, Top) + join l (OldFact (PElem old)) (NewFact (PElem new)) + = joinx l (OldFact old) (NewFact new) + + +liftJoinTop :: JoinFun a -> JoinFun (WithTop a) +extendJoinDomain :: forall a + . (Label -> OldFact a -> NewFact a -> (ChangeFlag, WithTop a)) + -> JoinFun (WithTop a) + +extendJoinDomain joinx = join + where join :: JoinFun (WithTop a) + join _ (OldFact Top) (NewFact _) = (NoChange, Top) + join _ (OldFact _) (NewFact Top) = (SomeChange, Top) + join l (OldFact (PElem old)) (NewFact (PElem new)) + = joinx l (OldFact old) (NewFact new) + +liftJoinTop joinx = extendJoinDomain (\l old new -> liftPair $ joinx l old new) + where liftPair (c, a) = (c, PElem a) + +-- | Given a join function and a name, creates a semi lattice by +-- adding a top element but no bottom element. Caller must supply the bottom +-- element. +addTop :: DataflowLattice a -> DataflowLattice (WithTop a) +-- | A more general case for creating a new lattice +addTop' :: forall a . + String + -> a + -> (Label -> OldFact a -> NewFact a -> (ChangeFlag, WithTop a)) + -> DataflowLattice (WithTop a) + +addTop lattice = addTop' name' (fact_bot lattice) join' + where name' = fact_name lattice ++ " + T" + join' l o n = (change, PElem f) + where (change, f) = fact_join lattice l o n + +addTop' name bot joinx = DataflowLattice name (PElem bot) join + where -- careful: order of cases matters for ChangeFlag + join :: JoinFun (WithTop a) + join _ (OldFact Top) (NewFact _) = (NoChange, Top) + join _ (OldFact _) (NewFact Top) = (SomeChange, Top) + join l (OldFact (PElem old)) (NewFact (PElem new)) + = joinx l (OldFact old) (NewFact new) + +instance Show a => Show (Pointed t b a) where + show Bot = "_|_" + show Top = "T" + show (PElem a) = show a + +instance Functor (Pointed t b) where + fmap _ Bot = Bot + fmap _ Top = Top + fmap f (PElem a) = PElem (f a) + +instance Eq a => Eq (Pointed t b a) where + Bot == Bot = True + Top == Top = True + (PElem a) == (PElem a') = a == a' + _ == _ = False + +instance Ord a => Ord (Pointed t b a) where + Bot `compare` Bot = EQ + Bot `compare` _ = LT + _ `compare` Bot = GT + PElem a `compare` PElem a' = a `compare` a' + Top `compare` Top = EQ + Top `compare` _ = GT + _ `compare` Top = LT diff --git a/src/Compiler/Hoopl/Shape.hs b/src/Compiler/Hoopl/Shape.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl/Shape.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE GADTs, EmptyDataDecls #-} + +module Compiler.Hoopl.Shape {-# DEPRECATED "not ready to migrate to this yet" #-} +where + +-- | Used at the type level to indicate an "open" structure with +-- a unique, unnamed control-flow edge flowing in or out. +-- "Fallthrough" and concatenation are permitted at an open point. +data O + + +-- | Used at the type level to indicate a "closed" structure which +-- supports control transfer only through the use of named +-- labels---no "fallthrough" is permitted. The number of control-flow +-- edges is unconstrained. +data C + + +data HalfShape s where + ShapeO :: HalfShape O + ShapeC :: HalfShape C + +data Shape e x where + ShapeOO :: Shape O O + ShapeCO :: Shape C O + ShapeOC :: Shape O C + ShapeCC :: Shape C C + +class Shapely n where + shape :: n e x -> Shape e x + shapeAtEntry :: n e x -> HalfShape e + shapeAtExit :: n e x -> HalfShape x + + shapeAtEntry = entryHalfShape . shape + shapeAtExit = exitHalfShape . shape + + +entryHalfShape :: Shape e x -> HalfShape e +exitHalfShape :: Shape e x -> HalfShape x + +entryHalfShape ShapeOO = ShapeO +entryHalfShape ShapeOC = ShapeO +entryHalfShape ShapeCO = ShapeC +entryHalfShape ShapeCC = ShapeC + +exitHalfShape ShapeOO = ShapeO +exitHalfShape ShapeOC = ShapeC +exitHalfShape ShapeCO = ShapeO +exitHalfShape ShapeCC = ShapeC + diff --git a/src/Compiler/Hoopl/Show.hs b/src/Compiler/Hoopl/Show.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl/Show.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables, FlexibleContexts #-} + +module Compiler.Hoopl.Show + ( showGraph, showFactBase + ) +where + +import Compiler.Hoopl.Collections +import Compiler.Hoopl.Graph +import Compiler.Hoopl.Label + +-------------------------------------------------------------------------------- +-- Prettyprinting +-------------------------------------------------------------------------------- + +type Showing n = forall e x . n e x -> String + + +showGraph :: forall n e x . (NonLocal n) => Showing n -> Graph n e x -> String +showGraph node = g + where g :: (NonLocal n) => Graph n e x -> String + g GNil = "" + g (GUnit block) = b block + g (GMany g_entry g_blocks g_exit) = + 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 (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 + +open :: (a -> String) -> MaybeO z a -> String +open _ NothingO = "" +open p (JustO n) = p n + +showFactBase :: Show f => FactBase f -> String +showFactBase = show . mapToList diff --git a/src/Compiler/Hoopl/Unique.hs b/src/Compiler/Hoopl/Unique.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl/Unique.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE TypeFamilies #-} +module Compiler.Hoopl.Unique + ( Unique, intToUnique + , UniqueSet, UniqueMap + , UniqueMonad(..) + , SimpleUniqueMonad, runSimpleUniqueMonad + , UniqueMonadT, runUniqueMonadT + + , uniqueToInt -- exposed through GHC module only! + ) + +where + +import Compiler.Hoopl.Checkpoint +import Compiler.Hoopl.Collections + +import qualified Data.IntMap as M +import qualified Data.IntSet as S + +----------------------------------------------------------------------------- +-- Unique +----------------------------------------------------------------------------- + +data Unique = Unique { uniqueToInt :: {-# UNPACK #-} !Int } + deriving (Eq, Ord) + +intToUnique :: Int -> Unique +intToUnique = Unique + +instance Show Unique where + show (Unique n) = show n + +----------------------------------------------------------------------------- +-- UniqueSet + +newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show) + +instance IsSet UniqueSet where + type ElemOf UniqueSet = Unique + + setNull (US s) = S.null s + setSize (US s) = S.size s + setMember (Unique k) (US s) = S.member k s + + setEmpty = US S.empty + setSingleton (Unique k) = US (S.singleton k) + setInsert (Unique k) (US s) = US (S.insert k s) + setDelete (Unique k) (US s) = US (S.delete k s) + + setUnion (US x) (US y) = US (S.union x y) + setDifference (US x) (US y) = US (S.difference x y) + setIntersection (US x) (US y) = US (S.intersection x y) + setIsSubsetOf (US x) (US y) = S.isSubsetOf x y + + setFold k z (US s) = S.fold (k . intToUnique) z s + + setElems (US s) = map intToUnique (S.elems s) + setFromList ks = US (S.fromList (map uniqueToInt ks)) + +----------------------------------------------------------------------------- +-- UniqueMap + +newtype UniqueMap v = UM (M.IntMap v) deriving (Eq, Ord, Show) + +instance IsMap UniqueMap where + type KeyOf UniqueMap = Unique + + mapNull (UM m) = M.null m + mapSize (UM m) = M.size m + mapMember (Unique k) (UM m) = M.member k m + mapLookup (Unique k) (UM m) = M.lookup k m + mapFindWithDefault def (Unique k) (UM m) = M.findWithDefault def k m + + 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) + mapDelete (Unique k) (UM m) = UM (M.delete k m) + + mapUnion (UM x) (UM y) = UM (M.union x y) + mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey (f . intToUnique) x y) + mapDifference (UM x) (UM y) = UM (M.difference x y) + mapIntersection (UM x) (UM y) = UM (M.intersection x y) + mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y + + mapMap f (UM m) = UM (M.map f m) + mapMapWithKey f (UM m) = UM (M.mapWithKey (f . intToUnique) m) + mapFold k z (UM m) = M.fold k z m + mapFoldWithKey k z (UM m) = M.foldWithKey (k . intToUnique) z m + + mapElems (UM m) = M.elems m + 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]) + +---------------------------------------------------------------- +-- Monads + +class Monad m => UniqueMonad m where + freshUnique :: m Unique + +newtype SimpleUniqueMonad a = SUM { unSUM :: [Unique] -> (a, [Unique]) } + +instance Monad SimpleUniqueMonad where + return a = SUM $ \us -> (a, us) + m >>= k = SUM $ \us -> let (a, us') = unSUM m us in + unSUM (k a) us' + +instance UniqueMonad SimpleUniqueMonad where + freshUnique = SUM $ f + where f (u:us) = (u, us) + f _ = error "Unique.freshUnique(SimpleUniqueMonad): empty list" + +instance CheckpointMonad SimpleUniqueMonad where + type Checkpoint SimpleUniqueMonad = [Unique] + checkpoint = SUM $ \us -> (us, us) + restart us = SUM $ \_ -> ((), us) + +runSimpleUniqueMonad :: SimpleUniqueMonad a -> a +runSimpleUniqueMonad m = fst (unSUM m allUniques) + +---------------------------------------------------------------- + +newtype UniqueMonadT m a = UMT { unUMT :: [Unique] -> m (a, [Unique]) } + +instance Monad m => Monad (UniqueMonadT m) where + return a = UMT $ \us -> return (a, us) + m >>= k = UMT $ \us -> do { (a, us') <- unUMT m us; unUMT (k a) us' } + +instance Monad m => UniqueMonad (UniqueMonadT m) where + freshUnique = UMT $ f + where f (u:us) = return (u, us) + f _ = error "Unique.freshUnique(UniqueMonadT): empty list" + +runUniqueMonadT :: Monad m => UniqueMonadT m a -> m a +runUniqueMonadT m = do { (a, _) <- unUMT m allUniques; return a } + +allUniques :: [Unique] +allUniques = map Unique [1..] diff --git a/src/Compiler/Hoopl/Util.hs b/src/Compiler/Hoopl/Util.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl/Util.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE GADTs, ScopedTypeVariables, FlexibleInstances, RankNTypes, TypeFamilies #-} + +module Compiler.Hoopl.Util + ( gUnitOO, gUnitOC, gUnitCO, gUnitCC + , catGraphNodeOC, catGraphNodeOO + , catNodeCOGraph, catNodeOOGraph + , graphMapBlocks + , blockMapNodes, blockMapNodes3 + , blockGraph + , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except + , preorder_dfs, preorder_dfs_from_except + , labelsDefined, labelsUsed, externalEntryLabels + , LabelsPtr(..) + ) +where + +import Control.Monad + +import Compiler.Hoopl.Collections +import Compiler.Hoopl.Graph +import Compiler.Hoopl.Label + + +---------------------------------------------------------------- + +gUnitOO :: block n O O -> Graph' block n O O +gUnitOC :: block n O C -> Graph' block n O C +gUnitCO :: block n C O -> Graph' block n C O +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 + + +catGraphNodeOO :: Graph n e O -> n O O -> Graph n e O +catGraphNodeOC :: NonLocal n => Graph n e O -> n O C -> Graph n e C +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) + +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 + +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 + +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 + + + + + +blockGraph :: NonLocal n => Block n e x -> Graph n e x +blockGraph b@(BFirst {}) = gUnitCO b +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 + + +-- | Function 'graphMapBlocks' enables a change of representation of blocks, +-- nodes, or both. It lifts a polymorphic block transform into a polymorphic +-- graph transform. When the block representation stabilizes, a similar +-- function should be provided for blocks. +graphMapBlocks :: forall block n block' n' e x . + (forall e x . block n e x -> block' n' e x) + -> (Graph' block n e x -> Graph' block' n' e x) + +graphMapBlocks f = map + where map :: Graph' block n e x -> Graph' block' n' e x + map GNil = GNil + map (GUnit b) = GUnit (f b) + 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) + -> 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) + +blockMapNodes :: (forall e x. n e x -> n' e x) + -> (Block n e x -> Block n' e x) +blockMapNodes f = blockMapNodes3 (f, f, f) + +---------------------------------------------------------------- + +class LabelsPtr l where + targetLabels :: l -> [Label] + +instance NonLocal n => LabelsPtr (n e C) where + targetLabels n = successors n + +instance LabelsPtr Label where + targetLabels l = [l] + +instance LabelsPtr LabelSet where + targetLabels = setElems + +instance LabelsPtr l => LabelsPtr [l] where + targetLabels = concatMap targetLabels + + +-- | Traversal: 'postorder_dfs' returns a list of blocks reachable +-- from the entry of enterable graph. The entry and exit are *not* included. +-- The list has the following property: +-- +-- Say a "back reference" exists if one of a block's +-- control-flow successors precedes it in the output list +-- +-- Then there are as few back references as possible +-- +-- The output is suitable for use in +-- a forward dataflow problem. For a backward problem, simply reverse +-- the list. ('postorder_dfs' is sufficiently tricky to implement that +-- one doesn't want to try and maintain both forward and backward +-- versions.) + +postorder_dfs :: NonLocal (block n) => Graph' block n O x -> [block n C C] +preorder_dfs :: NonLocal (block n) => Graph' block n O x -> [block n C C] + +-- | This is the most important traversal over this data structure. It drops +-- unreachable code and puts blocks in an order that is good for solving forward +-- dataflow problems quickly. The reverse order is good for solving backward +-- dataflow problems quickly. The forward order is also reasonably good for +-- emitting instructions, except that it will not usually exploit Forrest +-- Baskett's trick of eliminating the unconditional branch from a loop. For +-- that you would need a more serious analysis, probably based on dominators, to +-- identify loop headers. +-- +-- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph' +-- representation, when for most purposes the plain 'Graph' representation is +-- more mathematically elegant (but results in more complicated code). +-- +-- Here's an easy way to go wrong! Consider +-- @ +-- A -> [B,C] +-- B -> D +-- C -> D +-- @ +-- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D. +-- Better to get [A,B,C,D] + + +graphDfs :: (NonLocal (block n)) + => (LabelMap (block n C C) -> block n O C -> LabelSet -> [block n C C]) + -> (Graph' block n O x -> [block n C C]) +graphDfs _ (GNil) = [] +graphDfs _ (GUnit{}) = [] +graphDfs order (GMany (JustO entry) body _) = order body entry setEmpty + +postorder_dfs = graphDfs postorder_dfs_from_except +preorder_dfs = graphDfs preorder_dfs_from_except + +postorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e) + => LabelMap (block C C) -> e -> LabelSet -> [block C C] +postorder_dfs_from_except blocks b visited = + vchildren (get_children b) (\acc _visited -> acc) [] visited + where + vnode :: block C C -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a + vnode block cont acc visited = + if setMember id visited then + cont acc visited + else + let cont' acc visited = cont (block:acc) visited in + vchildren (get_children block) cont' acc (setInsert id visited) + where id = entryLabel block + vchildren :: forall a. [block C C] -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a + vchildren bs cont acc visited = next bs acc visited + where next children acc visited = + case children of [] -> cont acc visited + (b:bs) -> vnode b (next bs) acc visited + 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 + +postorder_dfs_from + :: (NonLocal block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C] +postorder_dfs_from blocks b = postorder_dfs_from_except blocks b setEmpty + + +---------------------------------------------------------------- + +data VM a = VM { unVM :: LabelSet -> (a, LabelSet) } +marked :: Label -> VM Bool +mark :: Label -> VM () +instance Monad VM where + return a = VM $ \visited -> (a, visited) + m >>= k = VM $ \visited -> let (a, v') = unVM m visited in unVM (k a) v' +marked l = VM $ \v -> (setMember l v, v) +mark l = VM $ \v -> ((), setInsert l v) + +preorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e) + => LabelMap (block C C) -> e -> LabelSet -> [block C C] +preorder_dfs_from_except blocks b visited = + (fst $ unVM (children (get_children b)) visited) [] + where children [] = return id + children (b:bs) = liftM2 (.) (visit b) (children bs) + visit :: block C C -> VM (HL (block C C)) + visit b = do already <- marked (entryLabel b) + if already then return id + else do mark (entryLabel b) + bs <- children $ get_children b + 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 + +type HL a = [a] -> [a] -- Hughes list (constant-time concatenation) +cons :: a -> HL a -> HL a +cons a as tail = a : as tail + +---------------------------------------------------------------- + +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 + where addEntry :: forall a. ElemOf LabelSet -> a -> LabelSet -> LabelSet + addEntry label _ labels = setInsert label labels + exitLabel :: MaybeO x (block n C O) -> LabelSet + 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 GNil = setEmpty +labelsUsed (GUnit{}) = setEmpty +labelsUsed (GMany e body _) = mapFold addTargets (entryTargets e) body + where addTargets :: forall e. block n e C -> LabelSet -> LabelSet + addTargets block labels = setInsertList (successors block) labels + entryTargets :: MaybeO e (block n O C) -> LabelSet + entryTargets NothingO = setEmpty + entryTargets (JustO b) = addTargets b setEmpty + +externalEntryLabels :: forall n . + NonLocal n => LabelMap (Block n C C) -> LabelSet +externalEntryLabels body = defined `setDifference` used + where defined = labelsDefined g + used = labelsUsed g + g = GMany NothingO body NothingO diff --git a/src/Compiler/Hoopl/Wrappers.hs b/src/Compiler/Hoopl/Wrappers.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl/Wrappers.hs @@ -0,0 +1,7 @@ +module Compiler.Hoopl.Wrappers {-# DEPRECATED "Use only if you know what you are doing and can preserve the 'respects fuel' invariant" #-} + ( wrapFR, wrapFR2, wrapBR, wrapBR2 + ) +where + +import Compiler.Hoopl.Dataflow + diff --git a/src/Compiler/Hoopl/XUtil.hs b/src/Compiler/Hoopl/XUtil.hs new file mode 100644 --- /dev/null +++ b/src/Compiler/Hoopl/XUtil.hs @@ -0,0 +1,508 @@ +{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-} + +-- | Utilities for clients of Hoopl, not used internally. + +module Compiler.Hoopl.XUtil + ( 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 tfFoldBlock + , analyzeAndRewriteFwdBody, analyzeAndRewriteBwdBody + , analyzeAndRewriteFwdOx, analyzeAndRewriteBwdOx + , noEntries + , BlockResult(..), lookupBlock + ) +where + +import qualified Data.Map as M +import Data.Maybe + +import Compiler.Hoopl.Checkpoint +import Compiler.Hoopl.Collections +import Compiler.Hoopl.Dataflow +import Compiler.Hoopl.Graph +import Compiler.Hoopl.Label +import Compiler.Hoopl.Util + + +-- | Forward dataflow analysis and rewriting for the special case of a Body. +-- A set of entry points must be supplied; blocks not reachable from +-- the set are thrown away. +analyzeAndRewriteFwdBody + :: forall m n f entries. (CheckpointMonad m, NonLocal n, LabelsPtr entries) + => FwdPass m n f + -> entries -> Body n -> FactBase f + -> m (Body n, FactBase f) + +-- | Backward dataflow analysis and rewriting for the special case of a Body. +-- A set of entry points must be supplied; blocks not reachable from +-- the set are thrown away. +analyzeAndRewriteBwdBody + :: forall m n f entries. (CheckpointMonad m, NonLocal n, LabelsPtr entries) + => BwdPass m n f + -> entries -> Body n -> FactBase f + -> m (Body n, FactBase f) + +analyzeAndRewriteFwdBody pass en = mapBodyFacts (analyzeAndRewriteFwd pass (JustC en)) +analyzeAndRewriteBwdBody pass en = mapBodyFacts (analyzeAndRewriteBwd pass (JustC en)) + +mapBodyFacts :: (Monad m) + => (Graph n C C -> Fact C f -> m (Graph n C C, Fact C f, MaybeO C f)) + -> (Body n -> FactBase f -> m (Body n, FactBase f)) +-- ^ Internal utility; should not escape +mapBodyFacts anal b f = anal (GMany NothingO b NothingO) f >>= bodyFacts + where -- the type constraint is needed for the pattern match; + -- if it were not, we would use do-notation here. + bodyFacts :: Monad m => (Graph n C C, Fact C f, MaybeO C f) -> m (Body n, Fact C f) + bodyFacts (GMany NothingO body NothingO, fb, NothingO) = return (body, fb) + +{- + Can't write: + + do (GMany NothingO body NothingO, fb, NothingO) <- anal (....) f + return (body, fb) + + because we need an explicit type signature in order to do the GADT + pattern matches on NothingO +-} + + + +-- | Forward dataflow analysis and rewriting for the special case of a +-- graph open at the entry. This special case relieves the client +-- from having to specify a type signature for 'NothingO', which beginners +-- might find confusing and experts might find annoying. +analyzeAndRewriteFwdOx + :: forall m n f x. (CheckpointMonad m, NonLocal n) + => FwdPass m n f -> Graph n O x -> f -> m (Graph n O x, FactBase f, MaybeO x f) + +-- | Backward dataflow analysis and rewriting for the special case of a +-- graph open at the entry. This special case relieves the client +-- from having to specify a type signature for 'NothingO', which beginners +-- might find confusing and experts might find annoying. +analyzeAndRewriteBwdOx + :: forall m n f x. (CheckpointMonad m, NonLocal n) + => BwdPass m n f -> Graph n O x -> Fact x f -> m (Graph n O x, FactBase f, f) + +-- | A value that can be used for the entry point of a graph open at the entry. +noEntries :: MaybeC O Label +noEntries = NothingC + +analyzeAndRewriteFwdOx pass g f = analyzeAndRewriteFwd pass noEntries g f +analyzeAndRewriteBwdOx pass g fb = analyzeAndRewriteBwd pass noEntries g fb >>= strip + where strip :: forall m a b c . Monad m => (a, b, MaybeO O c) -> m (a, b, c) + strip (a, b, JustO c) = return (a, b, c) + + + + + +-- | A utility function so that a transfer function for a first +-- node can be given just a fact; we handle the lookup. This +-- function is planned to be made obsolete by changes in the dataflow +-- interface. + +firstXfer :: NonLocal n => (n C O -> f -> f) -> (n C O -> FactBase f -> f) +firstXfer xfer n fb = xfer n $ fromJust $ lookupFact (entryLabel n) fb + +-- | This utility function handles a common case in which a transfer function +-- produces a single fact out of a last node, which is then distributed +-- over the outgoing edges. +distributeXfer :: NonLocal n + => DataflowLattice f -> (n O C -> f -> f) -> (n O C -> f -> FactBase f) +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. +distributeFact :: NonLocal n => n O C -> f -> FactBase f +distributeFact n f = mapFromList [ (l, f) | l <- successors n ] + -- because the same fact goes out on every edge, + -- there's no need for 'mkFactBase' here. + +-- | This utility function handles a common case in which a backward transfer +-- function takes the incoming fact unchanged and tags it with the node's label. +distributeFactBwd :: NonLocal n => n C O -> f -> FactBase f +distributeFactBwd n f = mapSingleton (entryLabel n) f + +-- | List of (unlabelled) facts from the successors of a last node +successorFacts :: NonLocal n => n O C -> FactBase f -> [f] +successorFacts n fb = [ f | id <- successors n, let Just f = lookupFact id fb ] + +-- | Join a list of facts. +joinFacts :: DataflowLattice f -> Label -> [f] -> f +joinFacts lat inBlock = foldr extend (fact_bot lat) + where extend new old = snd $ fact_join lat inBlock (OldFact old) (NewFact new) + +{-# DEPRECATED joinOutFacts + "should be replaced by 'joinFacts lat l (successorFacts n f)'; as is, it uses the wrong Label" #-} + +joinOutFacts :: (NonLocal node) => DataflowLattice f -> node O C -> FactBase f -> f +joinOutFacts lat n f = foldr join (fact_bot lat) facts + where join (lbl, new) old = snd $ fact_join lat lbl (OldFact old) (NewFact new) + facts = [(s, fromJust fact) | s <- successors n, let fact = lookupFact s f, isJust fact] + + +-- | It's common to represent dataflow facts as a map from variables +-- to some fact about the locations. For these maps, the join +-- operation on the map can be expressed in terms of the join on each +-- element of the codomain: +joinMaps :: Ord k => JoinFun v -> JoinFun (M.Map k v) +joinMaps eltJoin l (OldFact old) (NewFact new) = M.foldrWithKey add (NoChange, old) new + where + add k new_v (ch, joinmap) = + case M.lookup k joinmap of + Nothing -> (SomeChange, M.insert k new_v joinmap) + Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of + (SomeChange, v') -> (SomeChange, M.insert k v' joinmap) + (NoChange, _) -> (ch, joinmap) + + + +-- | A fold function that relies on the IndexedCO type function. +-- Note that the type parameter e is available to the functions +-- that are applied to the middle and last nodes. +tfFoldBlock :: forall n bc bo c e x . + ( n C O -> bc + , n O O -> IndexedCO e bc bo -> IndexedCO e bc bo + , n O C -> IndexedCO e bc bo -> c) + -> (Block n e x -> bo -> IndexedCO x c (IndexedCO e bc bo)) +tfFoldBlock (f, m, l) bl bo = block bl + where block :: forall x . Block n e x -> IndexedCO x c (IndexedCO e bc bo) + block (BFirst n) = f n + block (BMiddle n) = m n bo + block (BLast n) = l n bo + block (b1 `BCat` b2) = oblock b2 $ block b1 + block (b1 `BClosed` b2) = oblock b2 $ block b1 + block (b1 `BHead` n) = m n $ block b1 + block (n `BTail` b2) = oblock b2 $ m n bo + oblock :: forall x . Block n O x -> IndexedCO e bc bo -> IndexedCO x c (IndexedCO e bc bo) + oblock (BMiddle n) = m n + oblock (BLast n) = l n + oblock (b1 `BCat` b2) = oblock b1 `cat` oblock b2 + oblock (n `BTail` b2) = m n `cat` oblock b2 + cat :: forall b c a. (a -> b) -> (b -> c) -> a -> c + cat f f' = f' . f + + +type NodeList' e x n = (MaybeC e (n C O), [n O O], MaybeC x (n O C)) +blockToNodeList''' :: + forall n e x. ( IndexedCO e (NodeList' C O n) (NodeList' O O n) ~ NodeList' e O n + , IndexedCO x (NodeList' e C n) (NodeList' e O n) ~ NodeList' e x n) => + Block n e x -> NodeList' e x n +blockToNodeList''' b = (h, reverse ms', t) + where + (h, ms', t) = tfFoldBlock (f, m, l) b z + z :: NodeList' O O n + z = (NothingC, [], NothingC) + f :: n C O -> NodeList' C O n + f n = (JustC n, [], NothingC) + m n (h, ms', t) = (h, n : ms', t) + l n (h, ms', _) = (h, ms', JustC n) + + +{- +data EitherCO' ex a b where + LeftCO :: a -> EitherCO' C a b + RightCO :: b -> EitherCO' O a b +-} + + -- should be done with a *backward* fold + +-- | More general fold + +_unused :: Int +_unused = 3 + where _a = foldBlockNodesF3'' (Trips undefined undefined undefined) + _b = foldBlockNodesF3' + +data Trips n a b c = Trips { ff :: forall e . MaybeC e (n C O) -> a -> b + , fm :: n O O -> b -> b + , fl :: forall x . MaybeC x (n O C) -> b -> c + } + +foldBlockNodesF3'' :: forall n a b c . + Trips n a b c -> (forall e x . Block n e x -> a -> c) +foldBlockNodesF3'' trips = block + where block :: Block n e x -> a -> c + block (b1 `BClosed` b2) = foldCO b1 `cat` foldOC b2 + block (BFirst node) = ff trips (JustC node) `cat` missingLast + block (b @ BHead {}) = foldCO b `cat` missingLast + block (BMiddle node) = missingFirst `cat` fm trips node `cat` missingLast + block (b @ BCat {}) = missingFirst `cat` foldOO b `cat` missingLast + block (BLast node) = missingFirst `cat` fl trips (JustC node) + block (b @ BTail {}) = missingFirst `cat` foldOC b + missingLast = fl trips NothingC + missingFirst = ff trips NothingC + foldCO :: Block n C O -> a -> b + foldOO :: Block n O O -> b -> b + foldOC :: Block n O C -> b -> c + foldCO (BFirst n) = ff trips (JustC n) + foldCO (BHead b n) = foldCO b `cat` fm trips n + foldOO (BMiddle n) = fm trips n + foldOO (BCat b1 b2) = foldOO b1 `cat` foldOO b2 + foldOC (BLast n) = fl trips (JustC n) + foldOC (BTail n b) = fm trips n `cat` foldOC b + cat :: forall b c a. (a -> b) -> (b -> c) -> a -> c + f `cat` g = g . f + +data ScottBlock n a = ScottBlock + { sb_first :: n C O -> a C O + , sb_mid :: n O O -> a O O + , sb_last :: n O C -> a O C + , sb_cat :: forall e x . a e O -> a O x -> a e x + } + +scottFoldBlock :: forall n a e x . ScottBlock n a -> Block n e x -> a e x +scottFoldBlock funs = block + where block :: forall e x . Block n e x -> a e x + block (BFirst n) = sb_first funs n + block (BMiddle n) = sb_mid funs n + block (BLast n) = sb_last funs n + block (BClosed b1 b2) = block b1 `cat` block b2 + block (BCat b1 b2) = block b1 `cat` block b2 + block (BHead b n) = block b `cat` sb_mid funs n + block (BTail n b) = sb_mid funs n `cat` block b + cat :: forall e x. a e O -> a O x -> a e x + cat = sb_cat funs + +newtype NodeList n e x + = NL { unList :: (MaybeC e (n C O), [n O O] -> [n O O], MaybeC x (n O C)) } + +fbnf3 :: forall n a b c . + ( n C O -> a -> b + , n O O -> b -> b + , n O C -> b -> c) + -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b) +fbnf3 (ff, fm, fl) block = unFF3 $ scottFoldBlock (ScottBlock f m l cat) block + where f n = FF3 $ ff n + m n = FF3 $ fm n + l n = FF3 $ fl n + -- XXX Ew. + cat :: forall t t1 t2 t3 t4 t5 t6 t7 t8 t9 a b c e x. + (IndexedCO x c b ~ IndexedCO t9 t7 t6, + IndexedCO t8 t5 t6 ~ IndexedCO t4 t2 t1, + IndexedCO t3 t t1 ~ IndexedCO e a b) => + FF3 t t1 t2 t3 t4 -> FF3 t5 t6 t7 t8 t9 -> FF3 a b c e x + FF3 f `cat` FF3 f' = FF3 $ f' . f + +newtype FF3 a b c e x = FF3 { unFF3 :: IndexedCO e a b -> IndexedCO x c b } + +blockToNodeList'' :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C)) +blockToNodeList'' = finish . unList . scottFoldBlock (ScottBlock f m l cat) + where f n = NL (JustC n, id, NothingC) + m n = NL (NothingC, (n:), NothingC) + l n = NL (NothingC, id, JustC n) + cat :: forall n t1 t2 t3. NodeList n t1 t2 -> NodeList n t2 t3 -> NodeList n t1 t3 + NL (e, ms, NothingC) `cat` NL (NothingC, ms', x) = NL (e, ms . ms', x) + finish :: forall t t1 t2 a. (t, [a] -> t1, t2) -> (t, t1, t2) + 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 () + where ff :: forall n e. MaybeC e (n C O) -> () -> PNL n e + fm :: forall n e. n O O -> PNL n e -> PNL n e + fl :: forall n e x. MaybeC x (n O C) -> PNL n e -> FNL n e x + ff n () = PNL (n, []) + fm n (PNL (first, mids')) = PNL (first, n : mids') + fl n (PNL (first, mids')) = FNL (first, reverse mids', n) + + -- newtypes for 'partial node list' and 'final node list' +newtype PNL n e = PNL (MaybeC e (n C O), [n O O]) +newtype FNL n e x = FNL {unFNL :: (MaybeC e (n C O), [n O O], MaybeC x (n O C))} + +foldBlockNodesF3''' :: forall n a b c . + (forall e . MaybeC e (n C O) -> a -> b e) + -> (forall e . n O O -> b e -> b e) + -> (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 + 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 + , n O O -> b -> b + , n O C -> b -> c) + -> (a -> b) -- called iff there is no first node + -> (b -> c) -- called iff there is no last node + -> (forall e x . Block n e x -> a -> c) +foldBlockNodesF3' (ff, fm, fl) missingFirst missingLast = block + where block :: forall e x . Block n e x -> a -> c + blockCO :: Block n C O -> a -> b + blockOO :: Block n O O -> b -> b + blockOC :: Block n O C -> b -> c + block (b1 `BClosed` b2) = blockCO b1 `cat` blockOC b2 + block (BFirst node) = ff node `cat` missingLast + block (b @ BHead {}) = blockCO b `cat` missingLast + block (BMiddle node) = missingFirst `cat` fm node `cat` missingLast + block (b @ BCat {}) = missingFirst `cat` blockOO b `cat` missingLast + block (BLast node) = missingFirst `cat` fl node + block (b @ BTail {}) = missingFirst `cat` blockOC b + blockCO (BFirst n) = ff 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 n + 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. +foldBlockNodesF3 :: forall n a b c . + ( n C O -> a -> b + , n O O -> b -> b + , n O C -> b -> c) + -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b) +foldBlockNodesF :: forall n a . + (forall e x . n e x -> a -> a) + -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a) +foldBlockNodesB3 :: forall n a b c . + ( n C O -> b -> c + , n O O -> b -> b + , n O C -> a -> b) + -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b) +foldBlockNodesB :: forall n a . + (forall e x . n e x -> a -> a) + -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a) +-- | Fold a function over every node in a graph. +-- The fold function must be polymorphic in the shape of the nodes. + +foldGraphNodes :: forall n a . + (forall e x . n e x -> a -> a) + -> (forall e x . Graph n e x -> a -> 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 (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 (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) + + +foldGraphNodes f = graph + where graph :: forall e x . Graph n e x -> a -> a + lift :: forall thing ex . (thing -> a -> a) -> (MaybeO ex thing -> a -> a) + + graph GNil = id + graph (GUnit b) = block b + graph (GMany e b x) = lift block e . body b . lift block x + body :: Body n -> a -> a + body bdy = \a -> mapFold block a bdy + lift _ NothingO = id + lift f (JustO thing) = f thing + + block :: Block n e x -> IndexedCO e a a -> IndexedCO x a a + block = foldBlockNodesF f + +{-# 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 +-- is or is not present depending on the shape of the block. +-- +-- The blockToNodeList function cannot be currently expressed using +-- foldBlockNodesB, because it returns IndexedCO e a b, which means +-- two different types depending on the shape of the block entry. +-- But blockToNodeList returns one of four possible types, depending +-- 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) + +-- | 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 + +data BlockResult n x where + NoBlock :: BlockResult n x + BodyBlock :: Block n C C -> BlockResult n x + ExitBlock :: Block n C O -> BlockResult n O + +lookupBlock :: NonLocal n => Graph n e x -> Label -> BlockResult n x +lookupBlock (GMany _ _ (JustO exit)) lbl + | entryLabel exit == lbl = ExitBlock exit +lookupBlock (GMany _ body _) lbl = + case mapLookup lbl body of + Just b -> BodyBlock b + Nothing -> NoBlock +lookupBlock GNil _ = NoBlock +lookupBlock (GUnit _) _ = NoBlock