src/Compiler/Hoopl/XUtil.hs

    {-# LANGUAGE CPP, GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies  #-}
    #if __GLASGOW_HASKELL__ >= 709
    {-# LANGUAGE Safe #-}
    #elif __GLASGOW_HASKELL__ >= 701
    {-# LANGUAGE Trustworthy #-}
    #endif

    -- | Utilities for clients of Hoopl, not used internally.

    module Compiler.Hoopl.XUtil
      (
        -- * Utilities for clients
        firstXfer, distributeXfer
      , distributeFact, distributeFactBwd
      , successorFacts
      , joinFacts
      , joinOutFacts -- deprecated
      , joinMaps
      , analyzeAndRewriteFwdBody, analyzeAndRewriteBwdBody
      , analyzeAndRewriteFwdOx, analyzeAndRewriteBwdOx
      )
    where

    import qualified Data.Map as M
    import Data.Maybe

    import Compiler.Hoopl.Collections
    import Compiler.Hoopl.Checkpoint
    import Compiler.Hoopl.Dataflow
    import Compiler.Hoopl.Block
    import Compiler.Hoopl.Graph
    import Compiler.Hoopl.Label

    -----------------------------------------------------------------------------

    -- | 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)