{-# LANGUAGE CPP, GADTs, ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Safe #-} #endif -- | Possibly doubly pointed lattices module Compiler.Hoopl.Pointed ( Pointed(..), addPoints, addPoints', addTop, addTop' , liftJoinTop, extendJoinDomain , WithTop, WithBot, WithTopAndBot ) where import Compiler.Hoopl.Block 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