A minimal HOOPL example

hoopl-boilerplate.hs

{-# LANGUAGE GADTs, NoMonomorphismRestriction, StandaloneDeriving, Rank2Types #-}

import Compiler.Hoopl
import Prelude hiding ((<*>))

data Node e x where
	Entry :: Label -> Node C O
	Exit :: [Label] -> Node O C

instance NonLocal Node where
	entryLabel (Entry l) = l
	successors (Exit ll) = ll

node l dn = mkFirst (Entry l) <*> mkLast (Exit dn)

l1 = runSimpleUniqueMonad freshLabel
l2 = runSimpleUniqueMonad $ freshLabel >> freshLabel
l3 = runSimpleUniqueMonad $ freshLabel >> freshLabel >> freshLabel

n1 = node l1 [l2]
n2 = node l2 []

g :: Graph Node C C
g = node l1 [l2] |*><*| node l2 []

deriving instance Show (Node e x)

type IntFact = Int

intLattice = DataflowLattice 
	{ fact_name = "Test lattice"
	, fact_join = \_ (OldFact o) (NewFact n) -> let j = max n o in
		if j == o then (NoChange, o) else (SomeChange, j)
	, fact_bot = 0::IntFact
	}

transfer :: Node e x -> Fact x IntFact -> IntFact
transfer (Entry _) f = f
transfer (Exit _) f = fact_bot intLattice

pureBRewrite :: FuelMonad m => (forall e x . n e x -> Fact x IntFact -> Maybe (Graph n e x)) -> BwdRewrite m n IntFact
pureBRewrite ff = mkBRewrite $ \a b -> return $ ff a b

rewrite :: Node e x -> Fact x IntFact -> Maybe (Graph Node e x)
rewrite _ _ = Nothing

pass = BwdPass
	{ bp_lattice = intLattice
	, bp_transfer = mkBTransfer transfer
	, bp_rewrite = pureBRewrite rewrite
	}


foo = analyzeAndRewriteBwd pass (JustC [l1]) g noFacts

simpleRun :: SimpleFuelMonad a -> a
simpleRun = runSimpleUniqueMonad . runWithFuel infiniteFuel

main = do
	putStrLn $ "Input graph:\n\n" ++ showGraph show g
	putStrLn $ "labelsDefined: " ++ show (setElems $ labelsDefined g) ++ "\n"
	putStrLn $ "labelsUsed: " ++ show (setElems $ labelsUsed g) ++ "\n"
	let (g', _, _) = simpleRun foo
	putStrLn $ "Output graph:\n\n" ++ showGraph show g'