├── cabal.project ├── testing ├── .gitignore ├── tests │ ├── test1.expected │ ├── if-test.expected │ ├── test7.expected │ ├── test1 │ ├── test7 │ ├── test4.expected │ ├── test5 │ ├── test5.expected │ ├── if-test │ ├── if-test3.expected │ ├── if-test3 │ ├── if-test4 │ ├── if-test4.expected │ ├── test6.expected │ ├── test2 │ ├── test2.expected │ ├── test4 │ ├── test3 │ ├── test6 │ ├── test3.expected │ ├── if-test2.expected │ ├── if-test2 │ └── ExpectedOutput ├── PP.hs ├── Main.hs ├── Expr.hs ├── Simplify.hs ├── Live.hs ├── constprop-figure ├── README ├── IR.hs ├── Ast.hs ├── ConstProp.hs ├── Ast2ir.hs ├── Ir2ast.hs ├── OptSupport.hs ├── Test.hs ├── EvalMonad.hs ├── Parse.hs └── Eval.hs ├── src ├── Compiler │ ├── mkfile │ ├── Hoopl │ │ ├── mkfile │ │ ├── Passes │ │ │ ├── mkfile │ │ │ ├── DList.hs │ │ │ ├── Live.hs │ │ │ └── Dominator.hs │ │ ├── Haddock.hs │ │ ├── Wrappers.hs │ │ ├── Checkpoint.hs │ │ ├── Internals.hs │ │ ├── GHC.hs │ │ ├── Shape.hs │ │ ├── Show.hs │ │ ├── Stream.hs │ │ ├── HISTORY │ │ ├── NOTES │ │ ├── Collections.hs │ │ ├── Label.hs │ │ ├── Fuel.hs │ │ ├── Debug.hs │ │ ├── Unique.hs │ │ ├── Pointed.hs │ │ ├── XUtil.hs │ │ ├── Combinators.hs │ │ ├── MkGraph.hs │ │ ├── Block.hs │ │ └── Graph.hs │ └── Hoopl.hs └── .gitignore ├── LICENSE ├── Setup.hs ├── .gitignore ├── README.md ├── hoopl.cabal ├── .travis.yml └── changelog.md /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /testing/.gitignore: -------------------------------------------------------------------------------- 1 | *.hi 2 | *.hc 3 | *.o 4 | Main 5 | -------------------------------------------------------------------------------- /src/Compiler/mkfile: -------------------------------------------------------------------------------- 1 | TOP=.. 2 | 3 | <$TOP/subdir.mk 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell/hoopl/HEAD/LICENSE -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/mkfile: -------------------------------------------------------------------------------- 1 | TOP=../.. 2 | 3 | <$TOP/subdir.mk 4 | -------------------------------------------------------------------------------- /testing/tests/test1.expected: -------------------------------------------------------------------------------- 1 | f (a, b) { 2 | L100: 3 | ret (7) 4 | } 5 | -------------------------------------------------------------------------------- /src/.gitignore: -------------------------------------------------------------------------------- 1 | *.hi 2 | *.hc 3 | *.o 4 | dist 5 | hoopl.pdf 6 | .config.* 7 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/Passes/mkfile: -------------------------------------------------------------------------------- 1 | TOP=../../.. 2 | 3 | <$TOP/subdir.mk 4 | -------------------------------------------------------------------------------- /testing/tests/if-test.expected: -------------------------------------------------------------------------------- 1 | f() { 2 | L0: 3 | goto L1 4 | L1: 5 | ret (1) 6 | } 7 | -------------------------------------------------------------------------------- /testing/tests/test7.expected: -------------------------------------------------------------------------------- 1 | procName() { 2 | L0: 3 | reg1 = 42 / 0 4 | ret(reg1) 5 | } 6 | -------------------------------------------------------------------------------- /testing/tests/test1: -------------------------------------------------------------------------------- 1 | f (a, b) { 2 | L100: 3 | r0 = 3 4 | r1 = 4 5 | r2 = r0 + r1 6 | ret (r2) 7 | } 8 | -------------------------------------------------------------------------------- /testing/tests/test7: -------------------------------------------------------------------------------- 1 | -- Test that we don't crash on divide by zero. 2 | procName() { 3 | L0: 4 | reg1 = 42 / 0 5 | ret(reg1) 6 | } 7 | -------------------------------------------------------------------------------- /testing/tests/test4.expected: -------------------------------------------------------------------------------- 1 | f(x) { 2 | L100: 3 | goto L101 4 | L101: 5 | goto L103 6 | L103: 7 | ret ((x + 5) + 4) 8 | } 9 | 10 | -------------------------------------------------------------------------------- /testing/tests/test5: -------------------------------------------------------------------------------- 1 | -- Tests parsing of memory stores and loads. 2 | procName(mm, aa) { 3 | L0: 4 | m[aa] = m[mm] + m[aa] 5 | ret(m[aa]) 6 | } 7 | -------------------------------------------------------------------------------- /testing/tests/test5.expected: -------------------------------------------------------------------------------- 1 | -- Tests parsing of memory stores and loads. 2 | procName(mm, aa) { 3 | L0: 4 | m[aa] = m[mm] + m[aa] 5 | ret(m[aa]) 6 | } 7 | -------------------------------------------------------------------------------- /testing/tests/if-test: -------------------------------------------------------------------------------- 1 | f() { 2 | L0: 3 | x = 3 + 4 4 | z = x > 5 5 | if z then goto L1 else goto L2 6 | L1: 7 | ret (1) 8 | L2: 9 | ret (2) 10 | } 11 | -------------------------------------------------------------------------------- /testing/tests/if-test3.expected: -------------------------------------------------------------------------------- 1 | f(x) { 2 | L0: 3 | if x > 5 then goto L1 else goto L2 4 | L2: 5 | goto L3 6 | L1: 7 | goto L3 8 | L3: 9 | ret (1) 10 | } 11 | -------------------------------------------------------------------------------- /testing/tests/if-test3: -------------------------------------------------------------------------------- 1 | f(x) { 2 | L0: 3 | if x > 5 then goto L1 else goto L2 4 | L1: 5 | z = 1 6 | goto L3 7 | L2: 8 | z = 1 9 | goto L3 10 | L3: 11 | ret (z) 12 | } 13 | -------------------------------------------------------------------------------- /testing/tests/if-test4: -------------------------------------------------------------------------------- 1 | f(x) { 2 | L0: 3 | if x > 5 then goto L1 else goto L2 4 | L1: 5 | z = 1 6 | goto L3 7 | L2: 8 | z = 2 9 | goto L3 10 | L3: 11 | ret (z) 12 | } 13 | -------------------------------------------------------------------------------- /testing/tests/if-test4.expected: -------------------------------------------------------------------------------- 1 | f(x) { 2 | L0: 3 | if x > 5 then goto L1 else goto L2 4 | L1: 5 | z = 1 6 | goto L3 7 | L2: 8 | z = 2 9 | goto L3 10 | L3: 11 | ret (z) 12 | } 13 | -------------------------------------------------------------------------------- /testing/tests/test6.expected: -------------------------------------------------------------------------------- 1 | procName(var1, var2) { 2 | L0: 3 | var1 = m[var2] 4 | var1 = m[m[var1]] 5 | var1 = m[var1 + var1] 6 | var1 = m[m[var1]] - m[var1 + var1] 7 | ret(var1) 8 | } 9 | -------------------------------------------------------------------------------- /testing/tests/test2: -------------------------------------------------------------------------------- 1 | f (a, b) { 2 | L100: 3 | x = 5 4 | y = 0 5 | goto L101 6 | L101: 7 | if x > 0 then goto L102 else goto L103 8 | L102: 9 | y = y + x 10 | x = x - 1 11 | goto L101 12 | L103: 13 | ret (y) 14 | } 15 | -------------------------------------------------------------------------------- /testing/tests/test2.expected: -------------------------------------------------------------------------------- 1 | f (a, b) { 2 | L100: 3 | x = 5 4 | y = 0 5 | goto L101 6 | L101: 7 | if x > 0 then goto L102 else goto L103 8 | L102: 9 | y = y + x 10 | x = x - 1 11 | goto L101 12 | L103: 13 | ret (y) 14 | } 15 | -------------------------------------------------------------------------------- /testing/tests/test4: -------------------------------------------------------------------------------- 1 | -- Test dead-code elim: y is dead 2 | f (x) { 3 | L100: 4 | y = 5 5 | goto L101 6 | L101: 7 | if y < 0 then goto L102 else goto L103 8 | L102: 9 | y = y - 1 10 | goto L101 11 | L103: 12 | ret (x + y + 4) 13 | } 14 | -------------------------------------------------------------------------------- /testing/tests/test3: -------------------------------------------------------------------------------- 1 | f (x, y) { 2 | L100: 3 | goto L101 4 | L101: 5 | if x > 0 then goto L102 else goto L104 6 | L102: 7 | (z) = f(x-1, y-1) goto L103 8 | L103: 9 | y = y + z 10 | x = x - 1 11 | goto L101 12 | L104: 13 | ret (y) 14 | } 15 | -------------------------------------------------------------------------------- /testing/tests/test6: -------------------------------------------------------------------------------- 1 | -- Tests that we don't remove any of var1 as dead code. 2 | procName(var1, var2) { 3 | L0: 4 | var1 = m[var2] 5 | var1 = m[m[var1]] 6 | var1 = m[var1 + var1] 7 | var1 = m[m[var1]] - m[var1 + var1] 8 | ret(var1) 9 | } 10 | -------------------------------------------------------------------------------- /testing/tests/test3.expected: -------------------------------------------------------------------------------- 1 | f (x, y) { 2 | L100: 3 | goto L101 4 | L101: 5 | if x > 0 then goto L102 else goto L104 6 | L102: 7 | (z) = f(x-1, y-1) goto L103 8 | L103: 9 | y = y + z 10 | x = x - 1 11 | goto L101 12 | L104: 13 | ret (y) 14 | } 15 | -------------------------------------------------------------------------------- /testing/tests/if-test2.expected: -------------------------------------------------------------------------------- 1 | f(a) { 2 | L0: 3 | res = 0 4 | goto L1 5 | L1: 6 | if a > 0 then goto L2 else goto L6 7 | L6: 8 | ret (res) 9 | L2: 10 | a = a - 1 11 | res = res + 7 12 | goto L3 13 | L3: 14 | goto L5 15 | L5: 16 | goto L1 17 | } 18 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/Haddock.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, GADTs #-} 2 | #if __GLASGOW_HASKELL__ >= 701 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | 6 | module Haddock 7 | where 8 | 9 | data Lit a where 10 | I :: Int -> Lit Int -- ^ an integer 11 | B :: Bool -> Lit Bool -- ^ a Boolean 12 | 13 | -------------------------------------------------------------------------------- /testing/tests/if-test2: -------------------------------------------------------------------------------- 1 | f(a) { 2 | L0: 3 | x = 3 + 4 4 | res = 0 5 | goto L1 6 | L1: 7 | if a > 0 then goto L2 else goto L6 8 | L2: 9 | a = a - 1 10 | res = res + x 11 | if x > 5 then goto L3 else goto L4 12 | L3: 13 | goto L5 14 | L4: 15 | x = x - 1 16 | goto L5 17 | L5: 18 | goto L1 19 | L6: 20 | ret (res) 21 | } 22 | -------------------------------------------------------------------------------- /testing/PP.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns #-} 3 | module PP (tuple) where 4 | 5 | tuple :: [String] -> String 6 | tuple [] = "()" 7 | tuple [a] = "(" ++ a ++ ")" 8 | tuple (a:as) = "(" ++ a ++ concat (map ((++) ", ") as) ++ ")" 9 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/Wrappers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if __GLASGOW_HASKELL__ >= 701 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | 6 | module Compiler.Hoopl.Wrappers {-# DEPRECATED "Use only if you know what you are doing and can preserve the 'respects fuel' invariant" #-} 7 | ( wrapFR, wrapFR2, wrapBR, wrapBR2 8 | ) 9 | where 10 | 11 | import Compiler.Hoopl.Dataflow 12 | 13 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/Checkpoint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, TypeFamilies #-} 2 | #if __GLASGOW_HASKELL__ >= 701 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | 6 | module Compiler.Hoopl.Checkpoint 7 | ( CheckpointMonad(..) 8 | ) 9 | where 10 | 11 | -- | Obeys the following law: 12 | -- for all @m@ 13 | -- @ 14 | -- do { s <- checkpoint; m; restart s } == return () 15 | -- @ 16 | class Monad m => CheckpointMonad m where 17 | type Checkpoint m 18 | checkpoint :: m (Checkpoint m) 19 | restart :: Checkpoint m -> m () 20 | 21 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/Internals.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, GADTs, RankNTypes #-} 2 | #if __GLASGOW_HASKELL__ >= 701 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | 6 | {- Exposing some internals to friends (e.g. GHC) -} 7 | module Compiler.Hoopl.Internals 8 | ( module Compiler.Hoopl.Block 9 | , module Compiler.Hoopl.Graph 10 | , module Compiler.Hoopl.Label 11 | , module Compiler.Hoopl.Dataflow 12 | ) 13 | where 14 | 15 | import Compiler.Hoopl.Block 16 | import Compiler.Hoopl.Graph 17 | import Compiler.Hoopl.Label 18 | import Compiler.Hoopl.Dataflow 19 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .*.swp 2 | *.bak 3 | *~ 4 | 5 | # GHC build system produces these 6 | GNUmakefile 7 | 8 | dist 9 | dist-install 10 | dist-boot 11 | dist-newstyle 12 | ghc.mk 13 | .hpc 14 | 15 | # Cabal sandbox 16 | .cabal-sandbox 17 | cabal.sandbox.config 18 | 19 | # Coverage reports 20 | *.tix 21 | 22 | # Haskell build artifacts 23 | *.o 24 | *.hi 25 | *.chi 26 | *.chs.h 27 | *.dyn_o 28 | *.dyn_hi 29 | *.prof 30 | *.aux 31 | *.hp 32 | *.eventlog 33 | 34 | # cabal new-build artifacts 35 | cabal.project.local 36 | .ghc.environment.* 37 | 38 | # stack artifacts 39 | .stack-work 40 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/GHC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, GADTs, RankNTypes #-} 2 | #if __GLASGOW_HASKELL__ >= 701 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | 6 | {- Exposing some internals to GHC -} 7 | module Compiler.Hoopl.GHC 8 | ( uniqueToInt 9 | , uniqueToLbl, lblToUnique 10 | , getFuel, setFuel 11 | , bodyToBlockMap, bodyOfBlockMap 12 | ) 13 | where 14 | 15 | import Compiler.Hoopl.Fuel 16 | import Compiler.Hoopl.Graph 17 | import Compiler.Hoopl.Label 18 | import Compiler.Hoopl.Unique 19 | 20 | -- Converts Body to a map of closed/closed blocks. 21 | -- It should better be a constant-time operation 22 | -- as GHC is counting on it. 23 | bodyToBlockMap :: Body' block n -> LabelMap (block n C C) 24 | bodyToBlockMap (Body bodyMap) = bodyMap 25 | 26 | bodyOfBlockMap :: LabelMap (block n C C) -> Body' block n 27 | bodyOfBlockMap = Body 28 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if __GLASGOW_HASKELL__ >= 701 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | 6 | module Compiler.Hoopl 7 | ( module Compiler.Hoopl.Graph 8 | , module Compiler.Hoopl.Block 9 | , module Compiler.Hoopl.MkGraph 10 | , module Compiler.Hoopl.XUtil 11 | , module Compiler.Hoopl.Collections 12 | , module Compiler.Hoopl.Checkpoint 13 | , module Compiler.Hoopl.Dataflow 14 | , module Compiler.Hoopl.Label 15 | , module Compiler.Hoopl.Pointed 16 | , module Compiler.Hoopl.Combinators 17 | , module Compiler.Hoopl.Fuel 18 | , module Compiler.Hoopl.Unique 19 | , module Compiler.Hoopl.Debug 20 | , module Compiler.Hoopl.Show 21 | ) 22 | where 23 | 24 | import Compiler.Hoopl.Checkpoint 25 | import Compiler.Hoopl.Collections 26 | import Compiler.Hoopl.Combinators 27 | import Compiler.Hoopl.Dataflow hiding ( wrapFR, wrapFR2, wrapBR, wrapBR2 28 | ) 29 | import Compiler.Hoopl.Debug 30 | import Compiler.Hoopl.Fuel hiding (withFuel, getFuel, setFuel) 31 | import Compiler.Hoopl.Block 32 | import Compiler.Hoopl.Graph hiding (splice) 33 | import Compiler.Hoopl.Label hiding (uniqueToLbl, lblToUnique) 34 | import Compiler.Hoopl.MkGraph 35 | import Compiler.Hoopl.Pointed 36 | import Compiler.Hoopl.Show 37 | import Compiler.Hoopl.Unique hiding (uniqueToInt) 38 | import Compiler.Hoopl.XUtil 39 | -------------------------------------------------------------------------------- /testing/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import qualified System.FilePath as FilePath 4 | 5 | import qualified Test.Framework as Framework 6 | import qualified Test.Framework.Providers.HUnit as HUnit 7 | 8 | import qualified Test 9 | 10 | main :: IO () 11 | main = Framework.defaultMain tests 12 | 13 | tests :: [Framework.Test] 14 | tests = [goldensTests] 15 | 16 | -- | All the tests that depend on reading an input file with a simple program, 17 | -- parsing and optimizing it and then comparing with an expected output. 18 | goldensTests :: Framework.Test 19 | goldensTests = Framework.testGroup "Goldens tests" 20 | [ HUnit.testCase inputFile $ compareWithExpected inputFile expectedFile 21 | | (inputFile, expectedFile) <- zip inputFiles expectedFiles ] 22 | where 23 | compareWithExpected = Test.optTest 24 | inputFiles = [ basePath FilePath. test | test <- testFileNames ] 25 | expectedFiles = [ basePath FilePath. test FilePath.<.> "expected" 26 | | test <- testFileNames ] 27 | basePath = "testing" FilePath. "tests" 28 | testFileNames = 29 | [ "test1" 30 | , "test2" 31 | , "test3" 32 | , "test4" 33 | , "test5" 34 | , "test6" 35 | , "test7" 36 | , "if-test" 37 | , "if-test2" 38 | , "if-test3" 39 | , "if-test4" 40 | ] 41 | -------------------------------------------------------------------------------- /testing/Expr.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns #-} 3 | module Expr (Expr(..), BinOp(..), Lit(..), Var) where 4 | 5 | import PP 6 | 7 | data Expr = Lit Lit 8 | | Var Var 9 | | Load Expr 10 | | Binop BinOp Expr Expr deriving (Eq) 11 | 12 | data BinOp = Add | Sub | Mul | Div | Eq | Ne | Lt | Gt | Lte | Gte deriving Eq 13 | 14 | data Lit = Bool Bool | Int Integer deriving Eq 15 | type Var = String 16 | 17 | -------------------------------------------------------------------------------- 18 | --- Prettyprinting 19 | -------------------------------------------------------------------------------- 20 | 21 | instance Show Expr where 22 | show (Lit i) = show i 23 | show (Var v) = v 24 | show (Load e) = "m[" ++ show e ++ "]" 25 | show (Binop b e1 e2) = sub e1 ++ " " ++ show b ++ " " ++ sub e2 26 | where sub e@(Binop _ _ _) = tuple [show e] 27 | sub e = show e 28 | 29 | instance Show Lit where 30 | show (Int i) = show i 31 | show (Bool b) = show b 32 | 33 | instance Show BinOp where 34 | show Add = "+" 35 | show Sub = "-" 36 | show Mul = "*" 37 | show Div = "/" 38 | show Eq = "=" 39 | show Ne = "/=" 40 | show Gt = ">" 41 | show Lt = "<" 42 | show Gte = ">=" 43 | show Lte = "<=" 44 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/Shape.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, GADTs #-} 2 | #if __GLASGOW_HASKELL__ >= 701 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | 6 | module Compiler.Hoopl.Shape {-# DEPRECATED "not ready to migrate to this yet" #-} 7 | where 8 | 9 | -- | Used at the type level to indicate an "open" structure with 10 | -- a unique, unnamed control-flow edge flowing in or out. 11 | -- "Fallthrough" and concatenation are permitted at an open point. 12 | data O 13 | 14 | 15 | -- | Used at the type level to indicate a "closed" structure which 16 | -- supports control transfer only through the use of named 17 | -- labels---no "fallthrough" is permitted. The number of control-flow 18 | -- edges is unconstrained. 19 | data C 20 | 21 | 22 | data HalfShape s where 23 | ShapeO :: HalfShape O 24 | ShapeC :: HalfShape C 25 | 26 | data Shape e x where 27 | ShapeOO :: Shape O O 28 | ShapeCO :: Shape C O 29 | ShapeOC :: Shape O C 30 | ShapeCC :: Shape C C 31 | 32 | class Shapely n where 33 | shape :: n e x -> Shape e x 34 | shapeAtEntry :: n e x -> HalfShape e 35 | shapeAtExit :: n e x -> HalfShape x 36 | 37 | shapeAtEntry = entryHalfShape . shape 38 | shapeAtExit = exitHalfShape . shape 39 | 40 | 41 | entryHalfShape :: Shape e x -> HalfShape e 42 | exitHalfShape :: Shape e x -> HalfShape x 43 | 44 | entryHalfShape ShapeOO = ShapeO 45 | entryHalfShape ShapeOC = ShapeO 46 | entryHalfShape ShapeCO = ShapeC 47 | entryHalfShape ShapeCC = ShapeC 48 | 49 | exitHalfShape ShapeOO = ShapeO 50 | exitHalfShape ShapeOC = ShapeC 51 | exitHalfShape ShapeCO = ShapeO 52 | exitHalfShape ShapeCC = ShapeC 53 | 54 | -------------------------------------------------------------------------------- /testing/Simplify.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall -fwarn-incomplete-patterns #-} 2 | {-# LANGUAGE ScopedTypeVariables, GADTs, PatternGuards #-} 3 | module Simplify (simplify) where 4 | 5 | import Control.Monad 6 | import Compiler.Hoopl 7 | import IR 8 | import OptSupport 9 | 10 | type Node = Insn 11 | 12 | 13 | -- @ start cprop.tex 14 | 15 | -------------------------------------------------- 16 | -- Simplification ("constant folding") 17 | simplify :: forall m f. FuelMonad m => FwdRewrite m Node f 18 | simplify = deepFwdRw simp 19 | where 20 | simp :: forall e x. Node e x -> f -> m (Maybe (Graph Node e x)) 21 | simp node _ = return $ liftM insnToG $ s_node node 22 | s_node :: Node e x -> Maybe (Node e x) 23 | s_node (Cond (Lit (Bool b)) t f) 24 | = Just $ Branch (if b then t else f) 25 | s_node n = (mapEN . mapEE) s_exp n 26 | s_exp (Binop Add (Lit (Int n1)) (Lit (Int n2))) 27 | = Just $ Lit $ Int $ n1 + n2 28 | -- ... more cases for constant folding 29 | -- @ end cprop.tex 30 | s_exp (Binop Div _lhs (Lit (Int 0))) 31 | = Nothing 32 | s_exp (Binop opr e1 e2) 33 | | (Just op, Lit (Int i1), Lit (Int i2)) <- (intOp opr, e1, e2) = 34 | Just $ Lit $ Int $ op i1 i2 35 | | (Just op, Lit (Int i1), Lit (Int i2)) <- (cmpOp opr, e1, e2) = 36 | Just $ Lit $ Bool $ op i1 i2 37 | s_exp _ = Nothing 38 | intOp Add = Just (+) 39 | intOp Sub = Just (-) 40 | intOp Mul = Just (*) 41 | intOp Div = Just div 42 | intOp _ = Nothing 43 | cmpOp Eq = Just (==) 44 | cmpOp Ne = Just (/=) 45 | cmpOp Gt = Just (>) 46 | cmpOp Lt = Just (<) 47 | cmpOp Gte = Just (>=) 48 | cmpOp Lte = Just (<=) 49 | cmpOp _ = Nothing 50 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/Show.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, RankNTypes, GADTs, ScopedTypeVariables, FlexibleContexts #-} 2 | #if __GLASGOW_HASKELL__ >= 701 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | 6 | module Compiler.Hoopl.Show 7 | ( showGraph, showFactBase, Showing 8 | ) 9 | where 10 | 11 | import Compiler.Hoopl.Collections 12 | import Compiler.Hoopl.Block 13 | import Compiler.Hoopl.Graph 14 | import Compiler.Hoopl.Label 15 | 16 | -------------------------------------------------------------------------------- 17 | -- Prettyprinting 18 | -------------------------------------------------------------------------------- 19 | 20 | type Showing n = forall e x . n e x -> String 21 | 22 | 23 | showGraph :: forall n e x . Showing n -> Graph n e x -> String 24 | showGraph node = g 25 | where g :: Graph n e x -> String 26 | g GNil = "" 27 | g (GUnit block) = b block 28 | g (GMany g_entry g_blocks g_exit) = 29 | open b g_entry ++ body g_blocks ++ open b g_exit 30 | body blocks = concatMap b (mapElems blocks) 31 | b :: forall e x . Block n e x -> String 32 | b (BlockCO l b1) = node l ++ "\n" ++ b b1 33 | b (BlockCC l b1 n) = node l ++ "\n" ++ b b1 ++ node n ++ "\n" 34 | b (BlockOC b1 n) = b b1 ++ node n ++ "\n" 35 | b (BNil) = "" 36 | b (BMiddle n) = node n ++ "\n" 37 | b (BCat b1 b2) = b b1 ++ b b2 38 | b (BSnoc b1 n) = b b1 ++ node n ++ "\n" 39 | b (BCons n b1) = node n ++ "\n" ++ b b1 40 | 41 | open :: (a -> String) -> MaybeO z a -> String 42 | open _ NothingO = "" 43 | open p (JustO n) = p n 44 | 45 | showFactBase :: Show f => FactBase f -> String 46 | showFactBase = show . mapToList 47 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/Passes/DList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, GADTs #-} 2 | {-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} 3 | #if __GLASGOW_HASKELL__ >= 701 4 | {-# LANGUAGE Safe #-} 5 | #endif 6 | 7 | module Compiler.Hoopl.Passes.DList 8 | ( Doms, domEntry, domLattice 9 | , domPass 10 | ) 11 | where 12 | 13 | import Compiler.Hoopl 14 | 15 | 16 | type Doms = WithBot [Label] 17 | -- ^ List of labels, extended with a standard bottom element 18 | 19 | -- | The fact that goes into the entry of a dominator analysis: the first node 20 | -- is dominated only by the entry point, which is represented by the empty list 21 | -- of labels. 22 | domEntry :: Doms 23 | domEntry = PElem [] 24 | 25 | domLattice :: DataflowLattice Doms 26 | domLattice = addPoints "dominators" extend 27 | 28 | extend :: JoinFun [Label] 29 | extend _ (OldFact l) (NewFact l') = (changeIf (l `lengthDiffers` j), j) 30 | where j = lcs l l' 31 | lcs :: [Label] -> [Label] -> [Label] -- longest common suffix 32 | lcs l l' | length l > length l' = lcs (drop (length l - length l') l) l' 33 | | length l < length l' = lcs l' l 34 | | otherwise = dropUnlike l l' l 35 | dropUnlike [] [] maybe_like = maybe_like 36 | dropUnlike (x:xs) (y:ys) maybe_like = 37 | dropUnlike xs ys (if x == y then maybe_like else xs) 38 | dropUnlike _ _ _ = error "this can't happen" 39 | 40 | lengthDiffers [] [] = False 41 | lengthDiffers (_:xs) (_:ys) = lengthDiffers xs ys 42 | lengthDiffers [] (_:_) = True 43 | lengthDiffers (_:_) [] = True 44 | 45 | -- | Dominator pass 46 | domPass :: (NonLocal n, Monad m) => FwdPass m n Doms 47 | domPass = FwdPass domLattice (mkFTransfer3 first (const id) distributeFact) noFwdRewrite 48 | where first n = fmap (entryLabel n:) 49 | -------------------------------------------------------------------------------- /testing/Live.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall -fno-warn-incomplete-patterns #-} 2 | {-# LANGUAGE ScopedTypeVariables, GADTs #-} 3 | module Live (liveLattice, liveness, deadAsstElim) where 4 | 5 | import Data.Maybe 6 | import qualified Data.Set as S 7 | 8 | import Compiler.Hoopl 9 | import IR 10 | import OptSupport 11 | 12 | type Live = S.Set Var 13 | liveLattice :: DataflowLattice Live 14 | liveLattice = DataflowLattice 15 | { fact_name = "Live variables" 16 | , fact_bot = S.empty 17 | , fact_join = add 18 | } 19 | where add _ (OldFact old) (NewFact new) = (ch, j) 20 | where 21 | j = new `S.union` old 22 | ch = changeIf (S.size j > S.size old) 23 | 24 | liveness :: BwdTransfer Insn Live 25 | liveness = mkBTransfer live 26 | where 27 | live :: Insn e x -> Fact x Live -> Live 28 | live (Label _) f = f 29 | live n@(Assign x _) f = addUses (S.delete x f) n 30 | live n@(Store _ _) f = addUses f n 31 | live n@(Branch l) f = addUses (fact f l) n 32 | live n@(Cond _ tl fl) f = addUses (fact f tl `S.union` fact f fl) n 33 | live n@(Call vs _ _ l) f = addUses (fact f l `S.difference` S.fromList vs) n 34 | live n@(Return _) _ = addUses (fact_bot liveLattice) n 35 | 36 | fact :: FactBase (S.Set Var) -> Label -> Live 37 | fact f l = fromMaybe S.empty $ lookupFact l f 38 | 39 | addUses :: S.Set Var -> Insn e x -> Live 40 | addUses = fold_EN (fold_EE addVar) 41 | addVar s (Var v) = S.insert v s 42 | addVar s _ = s 43 | 44 | deadAsstElim :: forall m . FuelMonad m => BwdRewrite m Insn Live 45 | deadAsstElim = mkBRewrite d 46 | where 47 | d :: Insn e x -> Fact x Live -> m (Maybe (Graph Insn e x)) 48 | d (Assign x _) live 49 | | not (x `S.member` live) = return $ Just emptyGraph 50 | d _ _ = return Nothing 51 | -------------------------------------------------------------------------------- /testing/constprop-figure: -------------------------------------------------------------------------------- 1 | Changes: 2 | o - deriving 3 | o s/Var/Reg/ 4 | o s/M./Map./ 5 | o s/Lit/Const/ 6 | o outfacts are a list instead of a factbase 7 | o - Call and Return 8 | o - txToMaybe 9 | o in constProp s/changeTx and return/ -> Just and Nothing 10 | 11 | data WithTop a = Elt a | Top 12 | type ConstFact = Map Reg (WithTop Const) 13 | 14 | constLattice = DataflowLattice 15 | { fact_bot = Map.empty 16 | , fact_add_to = stdMapJoin constFactAdd 17 | , fact_name = "Const var value" } 18 | where 19 | constFactAdd new old = (ch, joined) 20 | where joined = if new == old then new else Top 21 | ch = if joined == old then NoChange else SomeChange 22 | 23 | varHasConst :: ForwardTransfers Node ConstFact 24 | varHasConst (Label bid) f = lookupFact constLattice f bid 25 | varHasConst (Assign x (Const l)) f = Map.insert x (Elt l) f 26 | varHasConst (Assign x _) f = Map.insert x Top f 27 | varHasConst (Store _ _) f = f 28 | varHasConst (Branch bid) f = [(bid, f)] 29 | varHasConst (Cond _ tid fid) f = [(tid, f), (fid, f)] 30 | 31 | -- I think the getInFacts might disappear with Hoopl4? 32 | constProp :: ForwardRewrites Node ConstFact 33 | constProp n facts = 34 | map_EN (map_EE rewriteE) n >>= return . toAGraph 35 | where 36 | rewriteE e@(Var v) = 37 | case M.lookup v (getInFacts constLattice facts n) of 38 | Just (Elt l) -> Just $ Const l 39 | _ -> Nothing 40 | rewriteE e = Nothing 41 | 42 | -- Simplification ("constant folding") 43 | simplify :: ForwardRewrites Node ConstFact 44 | simplify node _ = s node >>= return . toAGraph 45 | where 46 | s :: Node e x -> TxRes (Node e x) 47 | s (Cond (Const (Bool True)) t _) = Just $ Branch t 48 | s (Cond (Const (Bool False)) f _) = Just $ Branch f 49 | s n = map_EN (map_EE s_e) n 50 | s_e (Binop Add (Const (Int i1)) (Const (Int i2))) -> 51 | Just $ Const $ Int $ i1 + i2 52 | .... -- more cases for constant folding 53 | -------------------------------------------------------------------------------- /testing/README: -------------------------------------------------------------------------------- 1 | Here is some testing code which may also serve as a sample client. 2 | 3 | Base system 4 | ~~~~~~~~~~~ 5 | Ast.hs Abstract syntax for a language of basic blocks, 6 | instructions, and calls 7 | 8 | IR.hs Intermediate Representation of a procedure whose body is a 9 | Hoopl control-flow graph. 10 | 11 | Expr.hs Definition of expressions used in both Ast and IR 12 | 13 | Ast2ir.hs Translation from Ast to IR. The highlight is mapping 14 | the string labels in the source from the abstract Labels 15 | defined by Hoopl. 16 | 17 | Ir2Ast.hs Translated from IR to Ast. The original string Labels to the 18 | abstract Labels mappings are used to do this translation. 19 | 20 | 21 | Optimizations 22 | ~~~~~~~~~~~~~ 23 | ConstProp.hs Constant propagation as described in the paper. 24 | 25 | Live.hs Live-variable analysis and dead-assignment elimination. 26 | 27 | Simplify.s A simplifier for expressions, written as a "deep 28 | forward rewriter" for Hoopl. Used in constant 29 | propagation. 30 | 31 | OptSupport.hs Mysterious functions to support lattice computations 32 | and expression-crawling. May one day be documented. 33 | Eventually may be migrated into Hoopl in generic 34 | form, to support multiple clients. 35 | 36 | 37 | Interpreter 38 | ~~~~~~~~~~~ 39 | Eval.hs An interpreter for control-flow graphs. We'd like to 40 | make this code higher-order. 41 | 42 | EvalMonad.hs A monad that maintains the state used by the 43 | interpreter: a value for every variable, plus values 44 | on the heap. 45 | 46 | 47 | Testing 48 | ~~~~~~~ 49 | Main.hs Just hacking---there's no real testing code yet 50 | 51 | 52 | 53 | Other 54 | ~~~~~ 55 | Parse.hs A parser built using Parsec---does not depend on 56 | Hoopl at all. 57 | 58 | PP.hs A work in progress? 59 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/Stream.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances #-} 2 | #if __GLASGOW_HASKELL__ >= 701 3 | {-# LANGUAGE Trustworthy #-} 4 | #endif 5 | 6 | module Compiler.Hoopl.Stream 7 | where 8 | 9 | import Control.Monad 10 | 11 | import Test.QuickCheck 12 | 13 | type Stream s a = s -> Maybe (Pair s a) 14 | data Pair s a = Pair a (Stream s a) 15 | 16 | instance Show (s -> Maybe (Pair s a)) where 17 | show _ = "" 18 | 19 | instance (Arbitrary a, Arbitrary s, CoArbitrary s) => Arbitrary (Pair s a) where 20 | arbitrary = liftM2 Pair arbitrary arbitrary 21 | shrink (Pair a f) = [Pair a' f' | a' <- shrink a, f' <- shrink f] 22 | 23 | emptyS :: Stream s a 24 | emptyS = const Nothing 25 | 26 | thenS :: Stream s a -> Stream s a -> Stream s a 27 | s1 `thenS` s2 = \s -> case s1 s of 28 | Nothing -> s2 s 29 | Just (Pair a s1') -> Just $ Pair a (s1' `thenS` s2) 30 | 31 | iterS :: Stream s a -> Stream s a 32 | iterS stream = \s -> case stream s of 33 | Nothing -> Nothing 34 | Just (Pair a s') -> Just $ Pair a (s' `thenS` iterS stream) 35 | 36 | elems :: s -> Stream s a -> [a] 37 | elems s f = case f s of Nothing -> [] 38 | Just (Pair a f) -> a : elems s f 39 | 40 | law1 :: Eq a => Int -> s -> Stream s a -> Bool 41 | law1 n sigma stream = iterS stream `eq` (stream `thenS` iterS stream) 42 | where s `eq` s' = take n (elems sigma s) == take n (elems sigma s') 43 | 44 | law2 :: Bool 45 | law2 = iterS emptyS `eq` (emptyS :: Stream () Int) 46 | where s `eq` s' = elems () s == elems () s' 47 | 48 | ---------------------------------------------------------------- 49 | 50 | -- list analogy 51 | 52 | emptyL :: [a] 53 | emptyL = [] 54 | 55 | thenL :: [a] -> [a] -> [a] 56 | thenL = (++) 57 | 58 | iterL :: [a] -> [a] 59 | iterL [] = [] 60 | iterL (x:xs) = x : (xs `thenL` iterL (x:xs)) 61 | 62 | law1' :: Eq a => Int -> [a] -> Bool 63 | law1' n l = iterL l `eq` (l `thenL` iterL l) 64 | where xs `eq` ys = take n xs == take n ys 65 | 66 | law2' :: Bool 67 | law2' = iterL emptyL == (emptyL :: [Int]) 68 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/HISTORY: -------------------------------------------------------------------------------- 1 | 2 | {- Notes about the genesis of Hoopl7 3 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 4 | Hoopl7 has the following major chages 5 | 6 | a) GMany has symmetric entry and exit 7 | b) GMany closed-entry does not record a BlockId 8 | c) GMany open-exit does not record a BlockId 9 | d) The body of a GMany is called Body 10 | e) A Body is just a list of blocks, not a map. I've argued 11 | elsewhere that this is consistent with (c) 12 | 13 | A consequence is that Graph is no longer an instance of Edges, 14 | but nevertheless I managed to keep the ARF and ARB signatures 15 | nice and uniform. 16 | 17 | This was made possible by 18 | 19 | * FwdTransfer looks like this: 20 | type FwdTransfer n f 21 | = forall e x. n e x -> Fact e f -> Fact x f 22 | type family Fact x f :: * 23 | type instance Fact C f = FactBase f 24 | type instance Fact O f = f 25 | 26 | Note that the incoming fact is a Fact (not just 'f' as in Hoopl5,6). 27 | It's up to the *transfer function* to look up the appropriate fact 28 | in the FactBase for a closed-entry node. Example: 29 | constProp (Label l) fb = lookupFact fb l 30 | That is how Hoopl can avoid having to know the block-id for the 31 | first node: it defers to the client. 32 | 33 | [Side note: that means the client must know about 34 | bottom, in case the looupFact returns Nothing] 35 | 36 | * Note also that FwdTransfer *returns* a Fact too; 37 | that is, the types in both directions are symmetrical. 38 | Previously we returned a [(BlockId,f)] but I could not see 39 | how to make everything line up if we do this. 40 | 41 | Indeed, the main shortcoming of Hoopl7 is that we are more 42 | or less forced into this uniform representation of the facts 43 | flowing into or out of a closed node/block/graph, whereas 44 | previously we had more flexibility. 45 | 46 | In exchange the code is neater, with fewer distinct types. 47 | And morally a FactBase is equivalent to [(BlockId,f)] and 48 | nearly equivalent to (BlockId -> f). 49 | 50 | * I've realised that forwardBlockList and backwardBlockList 51 | both need (Edges n), and that goes everywhere. 52 | 53 | * I renamed BlockId to Label 54 | -} 55 | -------------------------------------------------------------------------------- /testing/IR.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns #-} 3 | module IR (Proc (..), Insn (..), Expr (..), Lit (..), Value (..), BinOp(..), Var 4 | , showProc 5 | , M) where 6 | 7 | import Prelude hiding (succ) 8 | 9 | import Compiler.Hoopl 10 | import Expr 11 | import PP 12 | 13 | type M = CheckingFuelMonad (SimpleUniqueMonad) 14 | 15 | data Value = B Bool | I Integer deriving Eq 16 | 17 | data Proc = Proc { name :: String, args :: [Var], entry :: Label, body :: Graph Insn C C } 18 | 19 | data Insn e x where 20 | Label :: Label -> Insn C O 21 | Assign :: Var -> Expr -> Insn O O 22 | Store :: Expr -> Expr -> Insn O O 23 | Branch :: Label -> Insn O C 24 | Cond :: Expr -> Label -> Label -> Insn O C 25 | Call :: [Var] -> String -> [Expr] -> Label -> Insn O C 26 | Return :: [Expr] -> Insn O C 27 | 28 | instance NonLocal Insn where 29 | entryLabel (Label l) = l 30 | successors (Branch l) = [l] 31 | successors (Cond _ t f) = [t, f] 32 | successors (Call _ _ _ l) = [l] 33 | successors (Return _) = [] 34 | 35 | -------------------------------------------------------------------------------- 36 | -- Prettyprinting 37 | -------------------------------------------------------------------------------- 38 | 39 | showProc :: Proc -> String 40 | showProc proc = name proc ++ tuple (args proc) ++ graph 41 | where 42 | graph = " {\n" ++ showGraph show (body proc) ++ "}\n" 43 | 44 | instance Show (Insn e x) where 45 | show (Label lbl) = show lbl ++ ":" 46 | show (Assign v e) = ind $ v ++ " = " ++ show e 47 | show (Store addr e) = ind $ "m[" ++ show addr ++ "] = " ++ show e 48 | show (Branch lbl) = ind $ "goto " ++ show lbl 49 | show (Cond e t f) = 50 | ind $ "if " ++ show e ++ " then goto " ++ show t ++ " else goto " ++ show f 51 | show (Call ress f cargs succ) = 52 | ind $ tuple ress ++ " = " ++ f ++ tuple (map show cargs) ++ " goto " ++ show succ 53 | show (Return rargs) = ind $ "ret " ++ tuple (map show rargs) 54 | 55 | ind :: String -> String 56 | ind x = " " ++ x 57 | 58 | instance Show Value where 59 | show (B b) = show b 60 | show (I i) = show i 61 | -------------------------------------------------------------------------------- /testing/Ast.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns #-} 3 | module Ast (Proc(..), Block(..), Insn(..), Control(..), Lbl, showProc) where 4 | 5 | import Expr 6 | import PP 7 | 8 | -- | A procedure has a name, a sequence of arguments, and a body, 9 | -- which is a sequence of basic blocks. The procedure entry 10 | -- is the first block in the body. 11 | data Proc = Proc { name :: String, args :: [Var], body :: [Block] } deriving Eq 12 | 13 | -- | A block consists of a label, a sequence of instructions, 14 | -- and a control-transfer instruction. 15 | data Block = Block { first :: Lbl, mids :: [Insn], last :: Control } deriving Eq 16 | 17 | -- | An instruction is an assignment to a variable or a store to memory. 18 | data Insn = Assign Var Expr 19 | | Store Expr Expr deriving (Eq) 20 | 21 | -- | Control transfers are branches (unconditional and conditional), 22 | -- call, and return. 23 | -- The Call instruction takes several parameters: variables to get 24 | -- values returned from the call, the name of the function, 25 | -- arguments to the function, and the label for the successor 26 | -- of the function call. 27 | data Control = Branch Lbl 28 | | Cond Expr Lbl Lbl 29 | | Call [Var] String [Expr] Lbl 30 | | Return [Expr] deriving (Eq) 31 | 32 | -- | Labels are represented as strings in an AST. 33 | type Lbl = String 34 | 35 | 36 | 37 | showProc :: Proc -> String 38 | showProc (Proc { name = n, args = as, body = blks}) 39 | = n ++ tuple as ++ graph 40 | where 41 | graph = foldl (\p b -> p ++ "\n" ++ show b) (" {") blks ++ "\n}\n" 42 | 43 | instance Show Block where 44 | show (Block f m l) = (foldl (\p e -> p ++ "\n" ++ show e) (f++":") m) ++ "\n" ++ show l 45 | 46 | instance Show Insn where 47 | show (Assign v e) = ind $ v ++ " = " ++ show e 48 | show (Store addr e) = ind $ "m[" ++ show addr ++ "] = " ++ show e 49 | 50 | instance Show Control where 51 | show (Branch lbl) = ind $ "goto " ++ lbl 52 | show (Cond e t f) = 53 | ind $ "if " ++ show e ++ " then goto " ++ t ++ " else goto " ++ f 54 | show (Call ress f cargs successor) = 55 | ind $ tuple ress ++ " = " ++ f ++ tuple (map show cargs) ++ " goto " ++ successor 56 | show (Return rargs) = ind $ "ret " ++ tuple (map show rargs) 57 | 58 | ind :: String -> String 59 | ind x = " " ++ x 60 | 61 | {- 62 | instance Show Value where 63 | show (B b) = show b 64 | show (I i) = show i 65 | -} 66 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | The `hoopl` Package [![Hackage](https://img.shields.io/hackage/v/hoopl.svg)](https://hackage.haskell.org/package/hoopl) [![Build Status](https://travis-ci.org/haskell/hoopl.svg)](https://travis-ci.org/haskell/hoopl) 2 | =================== 3 | 4 | ## Hoopl: A Higher-Order OPtimization Library 5 | 6 | API documentation can be found on 7 | [Hackage](https://hackage.haskell.org/package/hoopl). For detailed explanation 8 | of the library design see paper ["Hoopl: A Modular, Reusable Library for 9 | Dataflow Analysis and 10 | Transformation"](http://research.microsoft.com/en-us/um/people/simonpj/Papers/c--/hoopl-haskell10.pdf) 11 | 12 | | Directory | Contents 13 | | -------------- | --------- 14 | | `src/` | The current official sources to the Cabal package 15 | | `testing/` | Tests, including a sample client. See [`testing/README`](testing/README) 16 | 17 | ### Development Notes 18 | 19 | #### Building and testing 20 | 21 | To build the library run: 22 | 23 | cabal configure 24 | cabal build 25 | cabal install --enable-documentation 26 | 27 | To run the tests in the `testing/` folder run: 28 | 29 | cabal configure --enable-tests 30 | cabal test 31 | 32 | To run the tests with the test coverage report run: 33 | 34 | cabal configure --enable-tests --enable-coverage 35 | cabal test 36 | 37 | You'll need a Haskell Platform, which should include appropriate 38 | versions of Cabal and GHC. 39 | 40 | #### Coding style 41 | 42 | Please follow Johan Tibell's 43 | [Haskell Style Guide](https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md) 44 | for all new/modified code. 45 | 46 | ### Checklist for Making Releases 47 | 48 | In order to facilitate GHC development's workflow, the version in [`hoopl.cabal`](hoopl.cabal) is to be bumped as soon as a change requires a respective version bump (according to the PVP) relative to the last released `hoopl` version. 49 | 50 | 1. Make sure `hoopl` passes Travis for all GHC versions in the build-matrix 51 | 2. Update Changelog (& `git commit`) 52 | 3. Generate source tarball via `cabal sdist` and upload a candidate to Hackage (see note below), and inspect the result. 53 | 4. If everything checks out, make an annotated and GPG-signed Git release tag: `git tag -a -s v${VER} -m "hoopl ${VER}"` 54 | 5. Publish (there's a button for that on Hackage) the package candidate 55 | 6. Work on next release 56 | 57 | Note: To upload to Hackage, 58 | 59 | cabal sdist 60 | cabal upload dist/hoopl-*.tar.gz 61 | 62 | However, it's recommended use the Hackage feature for 63 | [uploading a candidate](http://hackage.haskell.org/packages/candidates/upload). 64 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/NOTES: -------------------------------------------------------------------------------- 1 | Simon and John, 2 | 3 | I've spent yet another evening on Hoopl---I implemented fold-style 4 | dataflow (as opposed to the concatMap style we have). I'm quite happy 5 | with the fold stuff---take a look at DataflowFold.hs and the 'aff' 6 | functions and see if you agree. If you like it, we will save a 7 | tremendous number of constructions and deconstructions in common cases 8 | where nodes are not rewritten. Perhaps we should keep both alive and 9 | measure? 10 | 11 | I used the insights I got doing DataflowFold.hs to tighten up John's 12 | revision of Dataflow.hs. All I did was generalize arfCat and arbCat 13 | so that I could use them more aggressively. I quite like the results. 14 | 15 | Further observations: 16 | 17 | The code for arbGraph and arfGraph is isomorphic---just substitute 'f' 18 | for 'b' and nothing else changes. Likewise for arbBlock and arfBlock. 19 | The graph functions are 11 lines apiece and the block functions are 7 20 | lines apiece, so it is not worth trying to abstract to save 18 lines, 21 | but it is interesting and maybe something that should be noted in the 22 | paper. 23 | 24 | arbNode and arfNode are fundamentally different. 25 | They could be made more similar if arbNode produced and arfNode 26 | accepted Fact e f instead of 'f', but even so a fundamental difference 27 | remains: in the forward case, the input fact goes into the RG, and in 28 | the backward case it is the output fact. 29 | 30 | It is a nuisance passing 'pass' to every function. If 'pass' goes 31 | only to analyzeAndRewrite[FB]wd', then we could simplify by putting 32 | the node, cat, block, body, and graph functions inside. We could 33 | start writing code like this: 34 | 35 | cat :: (thing1 -> info1 -> FuelMonad (RG f n e a, info1')) 36 | -> (thing2 -> info2 -> FuelMonad (RG f n a x, info1)) 37 | -> (thing1 -> thing2 -> info2 -> FuelMonad (RG f n e x, info1')) 38 | cat arb1 arb2 thing1 thing2 f = do { (g2,f2) <- arb2 thing2 f 39 | ; (g1,f1) <- arb1 thing1 f2 40 | ; return (g1 `rgCat` g2, f1) } 41 | block :: Edges n => ARB (Block n) n 42 | block (BFirst n) = node n 43 | block (BMiddle n) = node n 44 | block (BLast n) = node n 45 | block (BCat b1 b2) = (block `cat` block) b1 b2 46 | 47 | graph :: Edges n => ARBX (Graph n) n 48 | graph (GNil) = \f -> return (rgnil, f) 49 | graph (GUnit b) = block b 50 | graph (GMany NothingO b NothingO) = body b 51 | graph (GMany NothingO b (JustO x)) = (body `cat` arbx block) b x 52 | graph (GMany (JustO e) b NothingO) = (block `cat` body) e b 53 | graph (GMany (JustO e) b (JustO x)) 54 | = (uncurry (cat block body) `cat` arbx block) (e, b) x 55 | 56 | I think this would be very nice stuff to show in the paper---a lot 57 | nicer than the monadic madness in our submission---but it would 58 | require a little more explanation to make sure the reader 59 | understands where the pass comes from. 60 | 61 | Your opinions are solicited! 62 | 63 | 64 | Norman 65 | -------------------------------------------------------------------------------- /testing/ConstProp.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE ScopedTypeVariables, GADTs #-} 3 | module ConstProp (ConstFact, constLattice, initFact, varHasLit, constProp) where 4 | 5 | import Control.Monad 6 | import qualified Data.Map as Map 7 | 8 | import Compiler.Hoopl 9 | import IR 10 | import OptSupport 11 | 12 | type Node = Insn -- for paper 13 | 14 | -- ConstFact: 15 | -- Not present in map => bottom 16 | -- PElem v => variable has value v 17 | -- Top => variable's value is not constant 18 | -- @ start cprop.tex 19 | -- Type and definition of the lattice 20 | type ConstFact = Map.Map Var (WithTop Lit) 21 | constLattice :: DataflowLattice ConstFact 22 | constLattice = DataflowLattice 23 | { fact_name = "Const var value" 24 | , fact_bot = Map.empty 25 | , fact_join = joinMaps (extendJoinDomain constFactAdd) } 26 | where 27 | constFactAdd _ (OldFact old) (NewFact new) 28 | = if new == old then (NoChange, PElem new) 29 | else (SomeChange, Top) 30 | 31 | -- @ end cprop.tex 32 | -- Initially, we assume that all variable values are unknown. 33 | initFact :: [Var] -> ConstFact 34 | initFact vars = Map.fromList $ [(v, Top) | v <- vars] 35 | 36 | -- Only interesting semantic choice: values of variables are live across 37 | -- a call site. 38 | -- Note that we don't need a case for x := y, where y holds a constant. 39 | -- We can write the simplest solution and rely on the interleaved optimization. 40 | -- @ start cprop.tex 41 | -------------------------------------------------- 42 | -- Analysis: variable equals a literal constant 43 | varHasLit :: FwdTransfer Node ConstFact 44 | varHasLit = mkFTransfer ft 45 | where 46 | ft :: Node e x -> ConstFact -> Fact x ConstFact 47 | ft (Label _) f = f 48 | ft (Assign x (Lit k)) f = Map.insert x (PElem k) f 49 | ft (Assign x _) f = Map.insert x Top f 50 | ft (Store _ _) f = f 51 | ft (Branch l) f = mapSingleton l f 52 | ft (Cond (Var x) tl fl) f 53 | = mkFactBase constLattice 54 | [(tl, Map.insert x (PElem (Bool True)) f), 55 | (fl, Map.insert x (PElem (Bool False)) f)] 56 | ft (Cond _ tl fl) f 57 | = mkFactBase constLattice [(tl, f), (fl, f)] 58 | 59 | -- @ end cprop.tex 60 | ft (Call vs _ _ bid) f = mapSingleton bid (foldl toTop f vs) 61 | where toTop f v = Map.insert v Top f 62 | ft (Return _) _ = mapEmpty 63 | 64 | type MaybeChange a = a -> Maybe a 65 | -- @ start cprop.tex 66 | -------------------------------------------------- 67 | -- Rewriting: replace constant variables 68 | constProp :: forall m. FuelMonad m => FwdRewrite m Node ConstFact 69 | constProp = mkFRewrite cp 70 | where 71 | cp :: Node e x -> ConstFact -> m (Maybe (Graph Node e x)) 72 | cp node f 73 | = return $ liftM insnToG $ mapVN (lookup f) node 74 | 75 | mapVN :: (Var -> Maybe Expr) -> MaybeChange (Node e x) 76 | mapVN = mapEN . mapEE . mapVE 77 | 78 | lookup :: ConstFact -> Var -> Maybe Expr 79 | lookup f x = case Map.lookup x f of 80 | Just (PElem v) -> Just $ Lit v 81 | _ -> Nothing 82 | -- @ end cprop.tex 83 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/Collections.hs: -------------------------------------------------------------------------------- 1 | {- Baseclasses for Map-like and Set-like collections inspired by containers. -} 2 | 3 | {-# LANGUAGE CPP, TypeFamilies #-} 4 | #if __GLASGOW_HASKELL__ >= 701 5 | {-# LANGUAGE Safe #-} 6 | #endif 7 | 8 | module Compiler.Hoopl.Collections ( IsSet(..) 9 | , setInsertList, setDeleteList, setUnions 10 | , IsMap(..) 11 | , mapInsertList, mapDeleteList, mapUnions 12 | ) where 13 | 14 | import Data.List (foldl', foldl1') 15 | 16 | class IsSet set where 17 | type ElemOf set 18 | 19 | setNull :: set -> Bool 20 | setSize :: set -> Int 21 | setMember :: ElemOf set -> set -> Bool 22 | 23 | setEmpty :: set 24 | setSingleton :: ElemOf set -> set 25 | setInsert :: ElemOf set -> set -> set 26 | setDelete :: ElemOf set -> set -> set 27 | 28 | setUnion :: set -> set -> set 29 | setDifference :: set -> set -> set 30 | setIntersection :: set -> set -> set 31 | setIsSubsetOf :: set -> set -> Bool 32 | 33 | setFold :: (ElemOf set -> b -> b) -> b -> set -> b 34 | 35 | setElems :: set -> [ElemOf set] 36 | setFromList :: [ElemOf set] -> set 37 | 38 | -- Helper functions for IsSet class 39 | setInsertList :: IsSet set => [ElemOf set] -> set -> set 40 | setInsertList keys set = foldl' (flip setInsert) set keys 41 | 42 | setDeleteList :: IsSet set => [ElemOf set] -> set -> set 43 | setDeleteList keys set = foldl' (flip setDelete) set keys 44 | 45 | setUnions :: IsSet set => [set] -> set 46 | setUnions [] = setEmpty 47 | setUnions sets = foldl1' setUnion sets 48 | 49 | 50 | class IsMap map where 51 | type KeyOf map 52 | 53 | mapNull :: map a -> Bool 54 | mapSize :: map a -> Int 55 | mapMember :: KeyOf map -> map a -> Bool 56 | mapLookup :: KeyOf map -> map a -> Maybe a 57 | mapFindWithDefault :: a -> KeyOf map -> map a -> a 58 | 59 | mapEmpty :: map a 60 | mapSingleton :: KeyOf map -> a -> map a 61 | mapInsert :: KeyOf map -> a -> map a -> map a 62 | mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a 63 | mapDelete :: KeyOf map -> map a -> map a 64 | 65 | mapUnion :: map a -> map a -> map a 66 | mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a 67 | mapDifference :: map a -> map a -> map a 68 | mapIntersection :: map a -> map a -> map a 69 | mapIsSubmapOf :: Eq a => map a -> map a -> Bool 70 | 71 | mapMap :: (a -> b) -> map a -> map b 72 | mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b 73 | mapFold :: (a -> b -> b) -> b -> map a -> b 74 | mapFoldWithKey :: (KeyOf map -> a -> b -> b) -> b -> map a -> b 75 | mapFilter :: (a -> Bool) -> map a -> map a 76 | 77 | mapElems :: map a -> [a] 78 | mapKeys :: map a -> [KeyOf map] 79 | mapToList :: map a -> [(KeyOf map, a)] 80 | mapFromList :: [(KeyOf map, a)] -> map a 81 | mapFromListWith :: (a -> a -> a) -> [(KeyOf map,a)] -> map a 82 | 83 | -- Helper functions for IsMap class 84 | mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a 85 | mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs 86 | 87 | mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a 88 | mapDeleteList keys map = foldl' (flip mapDelete) map keys 89 | 90 | mapUnions :: IsMap map => [map a] -> map a 91 | mapUnions [] = mapEmpty 92 | mapUnions maps = foldl1' mapUnion maps 93 | -------------------------------------------------------------------------------- /testing/Ast2ir.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns #-} 3 | module Ast2ir (astToIR, IdLabelMap) where 4 | 5 | 6 | import Compiler.Hoopl hiding ((<*>)) 7 | import qualified Compiler.Hoopl as H ((<*>)) 8 | import Control.Monad 9 | import qualified Data.Map as M 10 | 11 | import Control.Applicative as AP (Applicative(..)) 12 | 13 | import qualified Ast as A 14 | import qualified IR as I 15 | 16 | -- For the most part, the translation from an abstract-syntax trees to a graph 17 | -- is straightforward. The one interesting complication is the translation from 18 | -- the AST representation of labels (String) to the graph representation of 19 | -- labels (Label). 20 | -- To keep the mapping from (String -> Label) consistent, we use a LabelMapM monad with 21 | -- the following operation: 22 | labelFor :: String -> LabelMapM Label 23 | getBody :: forall n. Graph n C C -> LabelMapM (Graph n C C) 24 | run :: LabelMapM a -> I.M (IdLabelMap, a) 25 | 26 | -- We proceed with the translation from AST to IR; the implementation of the monad 27 | -- is at the end of this file. 28 | 29 | astToIR :: A.Proc -> I.M (IdLabelMap, I.Proc) 30 | astToIR (A.Proc {A.name = n, A.args = as, A.body = b}) = run $ 31 | do entry <- getEntry b 32 | body <- toBody b 33 | return $ I.Proc { I.name = n, I.args = as, I.body = body, I.entry = entry } 34 | 35 | 36 | 37 | getEntry :: [A.Block] -> LabelMapM Label 38 | getEntry [] = error "Parsed procedures should not be empty" 39 | getEntry (b : _) = labelFor $ A.first b 40 | 41 | toBody :: [A.Block] -> LabelMapM (Graph I.Insn C C) 42 | toBody bs = 43 | do g <- foldl (liftM2 (|*><*|)) (return emptyClosedGraph) (map toBlock bs) 44 | getBody g 45 | 46 | toBlock :: A.Block -> LabelMapM (Graph I.Insn C C) 47 | toBlock (A.Block { A.first = f, A.mids = ms, A.last = l }) = 48 | do f' <- toFirst f 49 | ms' <- mapM toMid ms 50 | l' <- toLast l 51 | return $ mkFirst f' H.<*> mkMiddles ms' H.<*> mkLast l' 52 | 53 | toFirst :: A.Lbl -> LabelMapM (I.Insn C O) 54 | toFirst = liftM I.Label . labelFor 55 | 56 | toMid :: A.Insn -> LabelMapM (I.Insn O O) 57 | toMid (A.Assign v e) = return $ I.Assign v e 58 | toMid (A.Store a e) = return $ I.Store a e 59 | 60 | toLast :: A.Control -> LabelMapM (I.Insn O C) 61 | toLast (A.Branch l) = labelFor l >>= return . I.Branch 62 | toLast (A.Cond e t f) = labelFor t >>= \t' -> 63 | labelFor f >>= \f' -> return (I.Cond e t' f') 64 | toLast (A.Call rs f as l) = labelFor l >>= return . I.Call rs f as 65 | toLast (A.Return es) = return $ I.Return es 66 | 67 | 68 | -------------------------------------------------------------------------------- 69 | -- The LabelMapM monad 70 | -------------------------------------------------------------------------------- 71 | 72 | type IdLabelMap = M.Map String Label 73 | data LabelMapM a = LabelMapM (IdLabelMap -> I.M (IdLabelMap, a)) 74 | 75 | instance Monad LabelMapM where 76 | return = AP.pure 77 | LabelMapM f1 >>= k = LabelMapM (\m -> do (m', x) <- f1 m 78 | let (LabelMapM f2) = k x 79 | f2 m') 80 | 81 | instance Functor LabelMapM where 82 | fmap = liftM 83 | 84 | instance Applicative LabelMapM where 85 | pure x = LabelMapM (\m -> return (m, x)) 86 | (<*>) = ap 87 | 88 | labelFor l = LabelMapM f 89 | where f m = case M.lookup l m of 90 | Just l' -> return (m, l') 91 | Nothing -> do l' <- freshLabel 92 | let m' = M.insert l l' m 93 | return (m', l') 94 | 95 | getBody graph = LabelMapM f 96 | where f m = return (m, graph) 97 | 98 | run (LabelMapM f) = f M.empty -- >>= return -- . snd 99 | -------------------------------------------------------------------------------- /testing/Ir2ast.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns #-} 3 | module Ir2ast (irToAst) where 4 | 5 | import Compiler.Hoopl 6 | import Control.Monad 7 | import qualified Data.Map as M 8 | 9 | import qualified Ast as A 10 | import qualified IR as I 11 | import Control.Monad.Reader 12 | 13 | type Rm = Reader (M.Map Label A.Lbl) 14 | 15 | invertMap :: (Ord k, Ord v) => M.Map k v -> M.Map v k 16 | invertMap m = foldl (\p (k,v) -> 17 | if M.member v p 18 | then error $ "irrefutable error in invertMap, the values are not unique" 19 | else M.insert v k p 20 | ) M.empty (M.toList m) 21 | 22 | 23 | strLabelFor :: Label -> Rm String 24 | strLabelFor l = do { mp <- ask 25 | ; case M.lookup l mp of 26 | Just x -> return x 27 | Nothing -> return $ "_hoopl_generated_label_" ++ (show l) 28 | } 29 | 30 | irToAst :: M.Map String Label -> I.Proc -> A.Proc 31 | irToAst mp (I.Proc {I.name = n, I.args = as, I.body = graph, I.entry = entry }) = 32 | runReader (do { body <- fromGraph entry graph 33 | ; return $ A.Proc { A.name = n, A.args = as, A.body = body } 34 | }) (invertMap mp) 35 | 36 | fromGraph :: Label -> Graph I.Insn C C -> Rm [A.Block] 37 | fromGraph entry g = let entryNode = gUnitOC (BlockOC BNil (I.Branch entry)) 38 | blks = reverse $ postorder_dfs (gSplice entryNode g) 39 | in foldM (\p blk -> do { ablk <- fromBlock blk () 40 | ; return (ablk:p) 41 | }) [] blks 42 | 43 | 44 | 45 | type instance IndexedCO C () (Rm (A.Lbl, [A.Insn])) = () 46 | type instance IndexedCO C (Rm A.Block) (Rm (A.Lbl, [A.Insn])) = Rm A.Block 47 | 48 | fromBlock :: Block I.Insn C C -> () -> Rm A.Block 49 | fromBlock blk = foldBlockNodesF3 (fromIrInstCO, fromIrInstOO, fromIrInstOC) blk 50 | 51 | 52 | fromIrInstCO :: I.Insn C O -> () -> Rm (A.Lbl, [A.Insn]) 53 | fromIrInstCO inst _ = case inst of 54 | I.Label l -> strLabelFor l >>= \x -> return (x, []) 55 | 56 | 57 | fromIrInstOO :: I.Insn O O -> Rm (A.Lbl, [A.Insn]) -> Rm (A.Lbl, [A.Insn]) 58 | fromIrInstOO inst p = case inst of 59 | I.Assign v e -> do { (sl, insts) <- p 60 | ; return (sl, (A.Assign v e):insts) 61 | } 62 | I.Store a e -> do { (sl, insts) <- p 63 | ; return (sl, (A.Store a e):insts) 64 | } 65 | 66 | 67 | fromIrInstOC :: I.Insn e x -> Rm (A.Lbl, [A.Insn]) -> Rm A.Block 68 | fromIrInstOC inst p = case inst of 69 | I.Branch tl -> do { (l, insts) <- p 70 | ; stl <- strLabelFor tl 71 | ; return $ A.Block {A.first = l, A.mids = reverse insts 72 | , A.last = A.Branch stl} 73 | } 74 | I.Cond e tl fl -> do { (l, insts)<- p 75 | ; stl <- strLabelFor tl 76 | ; sfl <- strLabelFor fl 77 | ; return $ A.Block {A.first = l, A.mids = reverse insts 78 | , A.last = A.Cond e stl sfl} 79 | } 80 | I.Call vars name exps el -> do { (l, insts) <- p 81 | ; tel <- strLabelFor el 82 | ; return $ A.Block {A.first = l, A.mids = reverse insts 83 | , A.last = A.Call vars name exps tel} 84 | } 85 | I.Return exps -> do { (l, insts) <- p 86 | ; return $ A.Block {A.first = l, A.mids = reverse insts 87 | , A.last = A.Return exps} 88 | } 89 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/Passes/Live.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, ScopedTypeVariables, RankNTypes, TypeFamilies #-} 2 | #if __GLASGOW_HASKELL__ >= 701 3 | {-# LANGUAGE Trustworthy #-} 4 | #endif 5 | 6 | module Compiler.Hoopl.Passes.Live 7 | ( NodeWithVars(..), AssignmentNode(..) 8 | , liveLattice, liveness, -- deadAsstElim 9 | ) 10 | where 11 | 12 | import Data.Maybe 13 | import qualified Data.Set as S 14 | 15 | import Compiler.Hoopl 16 | 17 | class HooplNode n => NodeWithVars n where 18 | data Var n :: * -- ^ Variable or machine register. Unequal variables don't alias. 19 | data VarSet n :: * 20 | foldVarsUsed :: forall e x a . (Var n -> a -> a) -> n e x -> a -> a 21 | foldVarsDefd :: forall e x a . (Var n -> a -> a) -> n e x -> a -> a 22 | killsAllVars :: forall e x . n e x -> Bool 23 | emptyVarSet :: VarSet n 24 | unitVarSet :: Var n -> VarSet n 25 | insertVarSet :: Var n -> VarSet n -> VarSet n 26 | mkVarSet :: [Var n] -> VarSet n 27 | unionVarSets :: VarSet n -> VarSet n -> VarSet n 28 | unionManyVarSets :: [VarSet n] -> VarSet n 29 | minusVarSet :: VarSet n -> VarSet n -> VarSet n 30 | memberVarSet :: Var n -> VarSet n -> Bool 31 | varSetElems :: VarSet n -> [Var n] 32 | nullVarSet :: VarSet n -> Bool 33 | varSetSize :: VarSet n -> Int 34 | delFromVarSet :: Var n -> VarSet n -> VarSet n 35 | delListFromVarSet :: [Var n] -> VarSet n -> VarSet n 36 | foldVarSet :: (Var n -> b -> b) -> b -> VarSet n -> b -- ^ like Data.Set 37 | filterVarSet :: (Var n -> Bool) -> VarSet n -> VarSet n 38 | intersectVarSets :: VarSet n -> VarSet n -> VarSet n 39 | 40 | {- 41 | unitVarSet x = insertVarSet x emptyVarSet 42 | mkVarSet = foldr insertVarSet emptyVarSet 43 | unionManyVarSets = foldr unionVarSets emptyVarSet 44 | delListFromVarSet= flip (foldr delFromVarSet) 45 | -} 46 | 47 | class NodeWithVars n => AssignmentNode n where 48 | isVarAssign :: n O O -> Maybe (VarSet n) -- ^ Returns 'Just xs' if /all/ the node 49 | -- does is assign to the given variables 50 | 51 | type Live n = WithTop (VarSet n) 52 | 53 | liveLattice :: forall n . NodeWithVars n => DataflowLattice (Live n) 54 | liveLattice = addTop lat 55 | where lat :: DataflowLattice (VarSet n) 56 | lat = DataflowLattice 57 | { fact_name = "Live variables" 58 | , fact_bot = empty 59 | , fact_extend = add 60 | , fact_do_logging = False 61 | } 62 | empty :: VarSet n 63 | empty = (emptyVarSet :: VarSet n) 64 | add :: JoinFun (VarSet n) 65 | add _ (OldFact old) (NewFact new) = (change, j) 66 | where j = new `unionVarSets` old 67 | change = error "type troubles" 68 | -- change = changeIf $ varSetSize j > varSetSize old 69 | 70 | liveness :: NodeWithVars n => BwdTransfer n (VarSet n) 71 | liveness = mkBTransfer first mid last 72 | where first f = gen_kill f 73 | mid m = gen_kill m 74 | last l = gen_kill l . unionManyVarSets . successorFacts l 75 | 76 | gen_kill :: NodeWithVars n => n e x -> VarSet n -> VarSet n 77 | gen_kill n = gen n . kill n . if killsAllVars n then const emptyVarSet else id 78 | 79 | 80 | -- | The transfer equations use the traditional 'gen' and 'kill' 81 | -- notations, which should be familiar from the dragon book. 82 | gen, kill :: NodeWithVars n => n e x -> VarSet n -> VarSet n 83 | gen = foldVarsUsed insertVarSet 84 | kill = foldVarsDefd delFromVarSet 85 | 86 | {- 87 | deadAsstElim :: AssignmentNode n => BwdRewrite n (VarSet n) 88 | deadAsstElim = shallowBwdRw (noRewriteMono, dead, noRewriteMono) 89 | where dead n live 90 | | Just xs <- isVarAssign n = 91 | if nullVarSet (xs `intersectVarSets` live) then Nothing 92 | else Just emptyGraph 93 | | otherwise = Nothing 94 | -} 95 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/Label.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, TypeFamilies #-} 2 | {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} 3 | #if __GLASGOW_HASKELL__ >= 701 4 | {-# LANGUAGE Safe #-} 5 | #endif 6 | 7 | module Compiler.Hoopl.Label 8 | ( Label 9 | , freshLabel 10 | , LabelSet, LabelMap 11 | , FactBase, noFacts, lookupFact 12 | 13 | , uniqueToLbl -- MkGraph and GHC use only 14 | , lblToUnique -- GHC use only 15 | ) 16 | 17 | where 18 | 19 | import Compiler.Hoopl.Collections 20 | import Compiler.Hoopl.Unique 21 | #if !MIN_VERSION_base(4,8,0) 22 | import Data.Traversable (Traversable) 23 | import Data.Foldable (Foldable) 24 | #endif 25 | 26 | ----------------------------------------------------------------------------- 27 | -- Label 28 | ----------------------------------------------------------------------------- 29 | 30 | newtype Label = Label { lblToUnique :: Unique } 31 | deriving (Eq, Ord) 32 | 33 | uniqueToLbl :: Unique -> Label 34 | uniqueToLbl = Label 35 | 36 | instance Show Label where 37 | show (Label n) = "L" ++ show n 38 | 39 | freshLabel :: UniqueMonad m => m Label 40 | freshLabel = freshUnique >>= return . uniqueToLbl 41 | 42 | ----------------------------------------------------------------------------- 43 | -- LabelSet 44 | 45 | newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show) 46 | 47 | instance IsSet LabelSet where 48 | type ElemOf LabelSet = Label 49 | 50 | setNull (LS s) = setNull s 51 | setSize (LS s) = setSize s 52 | setMember (Label k) (LS s) = setMember k s 53 | 54 | setEmpty = LS setEmpty 55 | setSingleton (Label k) = LS (setSingleton k) 56 | setInsert (Label k) (LS s) = LS (setInsert k s) 57 | setDelete (Label k) (LS s) = LS (setDelete k s) 58 | 59 | setUnion (LS x) (LS y) = LS (setUnion x y) 60 | setDifference (LS x) (LS y) = LS (setDifference x y) 61 | setIntersection (LS x) (LS y) = LS (setIntersection x y) 62 | setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y 63 | 64 | setFold k z (LS s) = setFold (k . uniqueToLbl) z s 65 | 66 | setElems (LS s) = map uniqueToLbl (setElems s) 67 | setFromList ks = LS (setFromList (map lblToUnique ks)) 68 | 69 | ----------------------------------------------------------------------------- 70 | -- LabelMap 71 | 72 | newtype LabelMap v = LM (UniqueMap v) 73 | deriving (Eq, Ord, Show, Functor, Foldable, Traversable) 74 | 75 | instance IsMap LabelMap where 76 | type KeyOf LabelMap = Label 77 | 78 | mapNull (LM m) = mapNull m 79 | mapSize (LM m) = mapSize m 80 | mapMember (Label k) (LM m) = mapMember k m 81 | mapLookup (Label k) (LM m) = mapLookup k m 82 | mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m 83 | 84 | mapEmpty = LM mapEmpty 85 | mapSingleton (Label k) v = LM (mapSingleton k v) 86 | mapInsert (Label k) v (LM m) = LM (mapInsert k v m) 87 | mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m) 88 | mapDelete (Label k) (LM m) = LM (mapDelete k m) 89 | 90 | mapUnion (LM x) (LM y) = LM (mapUnion x y) 91 | mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . uniqueToLbl) x y) 92 | mapDifference (LM x) (LM y) = LM (mapDifference x y) 93 | mapIntersection (LM x) (LM y) = LM (mapIntersection x y) 94 | mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y 95 | 96 | mapMap f (LM m) = LM (mapMap f m) 97 | mapMapWithKey f (LM m) = LM (mapMapWithKey (f . uniqueToLbl) m) 98 | mapFold k z (LM m) = mapFold k z m 99 | mapFoldWithKey k z (LM m) = mapFoldWithKey (k . uniqueToLbl) z m 100 | mapFilter f (LM m) = LM (mapFilter f m) 101 | 102 | mapElems (LM m) = mapElems m 103 | mapKeys (LM m) = map uniqueToLbl (mapKeys m) 104 | mapToList (LM m) = [(uniqueToLbl k, v) | (k, v) <- mapToList m] 105 | mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs]) 106 | mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs]) 107 | 108 | ----------------------------------------------------------------------------- 109 | -- FactBase 110 | 111 | type FactBase f = LabelMap f 112 | 113 | noFacts :: FactBase f 114 | noFacts = mapEmpty 115 | 116 | lookupFact :: Label -> FactBase f -> Maybe f 117 | lookupFact = mapLookup 118 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/Fuel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, TypeFamilies #-} 2 | #if __GLASGOW_HASKELL__ >= 701 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | 6 | ----------------------------------------------------------------------------- 7 | -- The fuel monad 8 | ----------------------------------------------------------------------------- 9 | 10 | module Compiler.Hoopl.Fuel 11 | ( Fuel, infiniteFuel, fuelRemaining 12 | , withFuel 13 | , FuelMonad(..) 14 | , FuelMonadT(..) 15 | , CheckingFuelMonad 16 | , InfiniteFuelMonad 17 | , SimpleFuelMonad 18 | ) 19 | where 20 | 21 | import Compiler.Hoopl.Checkpoint 22 | import Compiler.Hoopl.Unique 23 | 24 | import Control.Applicative as AP (Applicative(..)) 25 | import Control.Monad (ap,liftM) 26 | 27 | class Monad m => FuelMonad m where 28 | getFuel :: m Fuel 29 | setFuel :: Fuel -> m () 30 | 31 | -- | Find out how much fuel remains after a computation. 32 | -- Can be subtracted from initial fuel to get total consumption. 33 | fuelRemaining :: FuelMonad m => m Fuel 34 | fuelRemaining = getFuel 35 | 36 | class FuelMonadT fm where 37 | runWithFuel :: (Monad m, FuelMonad (fm m)) => Fuel -> fm m a -> m a 38 | liftFuel :: (Monad m, FuelMonad (fm m)) => m a -> fm m a 39 | 40 | 41 | 42 | type Fuel = Int 43 | 44 | withFuel :: FuelMonad m => Maybe a -> m (Maybe a) 45 | withFuel Nothing = return Nothing 46 | withFuel (Just a) = do f <- getFuel 47 | if f == 0 48 | then return Nothing 49 | else setFuel (f-1) >> return (Just a) 50 | 51 | 52 | ---------------------------------------------------------------- 53 | 54 | newtype CheckingFuelMonad m a = FM { unFM :: Fuel -> m (a, Fuel) } 55 | 56 | instance Monad m => Functor (CheckingFuelMonad m) where 57 | fmap = liftM 58 | 59 | instance Monad m => Applicative (CheckingFuelMonad m) where 60 | pure a = FM (\f -> return (a, f)) 61 | (<*>) = ap 62 | 63 | instance Monad m => Monad (CheckingFuelMonad m) where 64 | return = AP.pure 65 | fm >>= k = FM (\f -> do { (a, f') <- unFM fm f; unFM (k a) f' }) 66 | 67 | instance CheckpointMonad m => CheckpointMonad (CheckingFuelMonad m) where 68 | type Checkpoint (CheckingFuelMonad m) = (Fuel, Checkpoint m) 69 | checkpoint = FM $ \fuel -> do { s <- checkpoint 70 | ; return ((fuel, s), fuel) } 71 | restart (fuel, s) = FM $ \_ -> do { restart s; return ((), fuel) } 72 | 73 | instance UniqueMonad m => UniqueMonad (CheckingFuelMonad m) where 74 | freshUnique = FM (\f -> do { l <- freshUnique; return (l, f) }) 75 | 76 | instance Monad m => FuelMonad (CheckingFuelMonad m) where 77 | getFuel = FM (\f -> return (f, f)) 78 | setFuel f = FM (\_ -> return ((),f)) 79 | 80 | instance FuelMonadT CheckingFuelMonad where 81 | runWithFuel fuel m = do { (a, _) <- unFM m fuel; return a } 82 | liftFuel m = FM $ \f -> do { a <- m; return (a, f) } 83 | 84 | ---------------------------------------------------------------- 85 | 86 | newtype InfiniteFuelMonad m a = IFM { unIFM :: m a } 87 | 88 | instance Monad m => Functor (InfiniteFuelMonad m) where 89 | fmap = liftM 90 | 91 | instance Monad m => Applicative (InfiniteFuelMonad m) where 92 | pure a = IFM $ return a 93 | (<*>) = ap 94 | 95 | instance Monad m => Monad (InfiniteFuelMonad m) where 96 | return = pure 97 | m >>= k = IFM $ do { a <- unIFM m; unIFM (k a) } 98 | 99 | instance UniqueMonad m => UniqueMonad (InfiniteFuelMonad m) where 100 | freshUnique = IFM $ freshUnique 101 | 102 | instance Monad m => FuelMonad (InfiniteFuelMonad m) where 103 | getFuel = return infiniteFuel 104 | setFuel _ = return () 105 | 106 | instance CheckpointMonad m => CheckpointMonad (InfiniteFuelMonad m) where 107 | type Checkpoint (InfiniteFuelMonad m) = Checkpoint m 108 | checkpoint = IFM checkpoint 109 | restart s = IFM $ restart s 110 | 111 | 112 | 113 | instance FuelMonadT InfiniteFuelMonad where 114 | runWithFuel _ = unIFM 115 | liftFuel = IFM 116 | 117 | infiniteFuel :: Fuel -- effectively infinite, any, but subtractable 118 | infiniteFuel = maxBound 119 | 120 | type SimpleFuelMonad = CheckingFuelMonad SimpleUniqueMonad 121 | 122 | {- 123 | runWithFuelAndUniques :: Fuel -> [Unique] -> FuelMonad a -> a 124 | runWithFuelAndUniques fuel uniques m = a 125 | where (a, _, _) = unFM m fuel uniques 126 | 127 | freshUnique :: FuelMonad Unique 128 | freshUnique = FM (\f (l:ls) -> (l, f, ls)) 129 | -} 130 | 131 | -------------------------------------------------------------------------------- /testing/tests/ExpectedOutput: -------------------------------------------------------------------------------- 1 | Test suite hoopl-test: RUNNING... 2 | Test:testing/tests/test1 3 | f(a, b) { 4 | L1: 5 | r0 = 3 6 | r1 = 4 7 | r2 = r0 + r1 8 | ret (r2) 9 | } 10 | 11 | f(a, b) { 12 | L1: 13 | r0 = 3 14 | r1 = 4 15 | r2 = 7 16 | ret (7) 17 | } 18 | 19 | f(a, b) { 20 | L1: 21 | ret (7) 22 | } 23 | 24 | Test:testing/tests/test2 25 | f(a, b) { 26 | L1: 27 | x = 5 28 | y = 0 29 | goto L2 30 | L2: 31 | if x > 0 then goto L3 else goto L4 32 | L3: 33 | y = y + x 34 | x = x - 1 35 | goto L2 36 | L4: 37 | ret (y) 38 | } 39 | 40 | f(a, b) { 41 | L1: 42 | x = 5 43 | y = 0 44 | goto L2 45 | L2: 46 | if x > 0 then goto L3 else goto L4 47 | L3: 48 | y = y + x 49 | x = x - 1 50 | goto L2 51 | L4: 52 | ret (y) 53 | } 54 | 55 | f(a, b) { 56 | L1: 57 | x = 5 58 | y = 0 59 | goto L2 60 | L2: 61 | if x > 0 then goto L3 else goto L4 62 | L3: 63 | y = y + x 64 | x = x - 1 65 | goto L2 66 | L4: 67 | ret (y) 68 | } 69 | 70 | Test:testing/tests/test3 71 | f(x, y) { 72 | L1: 73 | goto L2 74 | L2: 75 | if x > 0 then goto L3 else goto L4 76 | L3: 77 | (z) = f(x - 1, y - 1) goto L5 78 | L4: 79 | ret (y) 80 | L5: 81 | y = y + z 82 | x = x - 1 83 | goto L2 84 | } 85 | 86 | f(x, y) { 87 | L1: 88 | goto L2 89 | L2: 90 | if x > 0 then goto L3 else goto L4 91 | L3: 92 | (z) = f(x - 1, y - 1) goto L5 93 | L4: 94 | ret (y) 95 | L5: 96 | y = y + z 97 | x = x - 1 98 | goto L2 99 | } 100 | 101 | f(x, y) { 102 | L1: 103 | goto L2 104 | L2: 105 | if x > 0 then goto L3 else goto L4 106 | L3: 107 | (z) = f(x - 1, y - 1) goto L5 108 | L4: 109 | ret (y) 110 | L5: 111 | y = y + z 112 | x = x - 1 113 | goto L2 114 | } 115 | 116 | Test:testing/tests/test4 117 | f(x) { 118 | L1: 119 | y = 5 120 | goto L2 121 | L2: 122 | if y < 0 then goto L3 else goto L4 123 | L3: 124 | y = y - 1 125 | goto L2 126 | L4: 127 | ret ((x + y) + 4) 128 | } 129 | 130 | f(x) { 131 | L1: 132 | y = 5 133 | goto L2 134 | L2: 135 | goto L4 136 | L4: 137 | ret ((x + 5) + 4) 138 | } 139 | 140 | f(x) { 141 | L1: 142 | goto L2 143 | L2: 144 | goto L4 145 | L4: 146 | ret ((x + 5) + 4) 147 | } 148 | 149 | Test:testing/tests/if-test 150 | f() { 151 | L1: 152 | x = 3 + 4 153 | z = x > 5 154 | if z then goto L2 else goto L3 155 | L2: 156 | ret (1) 157 | L3: 158 | ret (2) 159 | } 160 | 161 | f() { 162 | L1: 163 | x = 7 164 | z = True 165 | goto L2 166 | L2: 167 | ret (1) 168 | } 169 | 170 | f() { 171 | L1: 172 | goto L2 173 | L2: 174 | ret (1) 175 | } 176 | 177 | Test:testing/tests/if-test2 178 | f(a) { 179 | L1: 180 | x = 3 + 4 181 | res = 0 182 | goto L2 183 | L2: 184 | if a > 0 then goto L3 else goto L4 185 | L3: 186 | a = a - 1 187 | res = res + x 188 | if x > 5 then goto L5 else goto L6 189 | L4: 190 | ret (res) 191 | L5: 192 | goto L7 193 | L6: 194 | x = x - 1 195 | goto L7 196 | L7: 197 | goto L2 198 | } 199 | 200 | f(a) { 201 | L1: 202 | x = 7 203 | res = 0 204 | goto L2 205 | L2: 206 | if a > 0 then goto L3 else goto L4 207 | L3: 208 | a = a - 1 209 | res = res + 7 210 | goto L5 211 | L4: 212 | ret (res) 213 | L5: 214 | goto L7 215 | L7: 216 | goto L2 217 | } 218 | 219 | f(a) { 220 | L1: 221 | res = 0 222 | goto L2 223 | L2: 224 | if a > 0 then goto L3 else goto L4 225 | L3: 226 | a = a - 1 227 | res = res + 7 228 | goto L5 229 | L4: 230 | ret (res) 231 | L5: 232 | goto L7 233 | L7: 234 | goto L2 235 | } 236 | 237 | Test:testing/tests/if-test3 238 | f(x) { 239 | L1: 240 | if x > 5 then goto L2 else goto L3 241 | L2: 242 | z = 1 243 | goto L4 244 | L3: 245 | z = 1 246 | goto L4 247 | L4: 248 | ret (z) 249 | } 250 | 251 | f(x) { 252 | L1: 253 | if x > 5 then goto L2 else goto L3 254 | L2: 255 | z = 1 256 | goto L4 257 | L3: 258 | z = 1 259 | goto L4 260 | L4: 261 | ret (1) 262 | } 263 | 264 | f(x) { 265 | L1: 266 | if x > 5 then goto L2 else goto L3 267 | L2: 268 | goto L4 269 | L3: 270 | goto L4 271 | L4: 272 | ret (1) 273 | } 274 | 275 | Test:testing/tests/if-test4 276 | f(x) { 277 | L1: 278 | if x > 5 then goto L2 else goto L3 279 | L2: 280 | z = 1 281 | goto L4 282 | L3: 283 | z = 2 284 | goto L4 285 | L4: 286 | ret (z) 287 | } 288 | 289 | f(x) { 290 | L1: 291 | if x > 5 then goto L2 else goto L3 292 | L2: 293 | z = 1 294 | goto L4 295 | L3: 296 | z = 2 297 | goto L4 298 | L4: 299 | ret (z) 300 | } 301 | 302 | f(x) { 303 | L1: 304 | if x > 5 then goto L2 else goto L3 305 | L2: 306 | z = 1 307 | goto L4 308 | L3: 309 | z = 2 310 | goto L4 311 | L4: 312 | ret (z) 313 | } 314 | 315 | Test suite hoopl-test: PASS 316 | Test suite logged to: dist/test/hoopl-3.10.2.1-hoopl-test.log 317 | -------------------------------------------------------------------------------- /testing/OptSupport.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, GADTs, RankNTypes #-} 2 | {-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} 3 | module OptSupport (mapVE, mapEE, mapEN, mapVN, fold_EE, fold_EN, insnToG) where 4 | 5 | import Control.Monad 6 | import Data.Maybe 7 | import Prelude hiding (succ) 8 | 9 | import Control.Applicative as AP (Applicative(..)) 10 | import Compiler.Hoopl hiding ((<*>)) 11 | import IR 12 | 13 | ---------------------------------------------- 14 | -- Map/Fold functions for expressions/insns 15 | ---------------------------------------------- 16 | 17 | type Node = Insn 18 | type MaybeChange a = a -> Maybe a 19 | mapVE :: (Var -> Maybe Expr) -> MaybeChange Expr 20 | mapEE :: MaybeChange Expr -> MaybeChange Expr 21 | mapEN :: MaybeChange Expr -> MaybeChange (Node e x) 22 | mapVN :: (Var -> Maybe Expr) -> MaybeChange (Node e x) 23 | 24 | mapVN = mapEN . mapEE . mapVE 25 | 26 | mapVE f (Var v) = f v 27 | mapVE _ _ = Nothing 28 | 29 | 30 | data Mapped a = Old a | New a 31 | 32 | instance Monad Mapped where 33 | return = AP.pure 34 | 35 | Old a >>= k = k a 36 | New a >>= k = asNew (k a) 37 | where asNew (Old a) = New a 38 | asNew m@(New _) = m 39 | 40 | instance Functor Mapped where 41 | fmap = liftM 42 | 43 | instance Applicative Mapped where 44 | pure = Old 45 | (<*>) = ap 46 | 47 | 48 | makeTotal :: (a -> Maybe a) -> (a -> Mapped a) 49 | makeTotal f a = case f a of Just a' -> New a' 50 | Nothing -> Old a 51 | makeTotalDefault :: b -> (a -> Maybe b) -> (a -> Mapped b) 52 | makeTotalDefault b f a = case f a of Just b' -> New b' 53 | Nothing -> Old b 54 | ifNew :: Mapped a -> Maybe a 55 | ifNew (New a) = Just a 56 | ifNew (Old _) = Nothing 57 | 58 | type Mapping a b = a -> Mapped b 59 | 60 | (/@/) :: Mapping b c -> Mapping a b -> Mapping a c 61 | f /@/ g = \x -> g x >>= f 62 | 63 | 64 | class HasExpressions a where 65 | mapAllSubexpressions :: Mapping Expr Expr -> Mapping a a 66 | 67 | instance HasExpressions (Insn e x) where 68 | mapAllSubexpressions = error "urk!" (mapVars, (/@/), makeTotal, ifNew) 69 | 70 | mapVars :: (Var -> Maybe Expr) -> Mapping Expr Expr 71 | mapVars f e@(Var x) = makeTotalDefault e f x 72 | mapVars _ e = return e 73 | 74 | 75 | mapEE f e@(Lit _) = f e 76 | mapEE f e@(Var _) = f e 77 | mapEE f e@(Load addr) = 78 | case mapEE f addr of 79 | Just addr' -> Just $ fromMaybe e' (f e') 80 | where e' = Load addr' 81 | Nothing -> f e 82 | mapEE f e@(Binop op e1 e2) = 83 | case (mapEE f e1, mapEE f e2) of 84 | (Nothing, Nothing) -> f e 85 | (e1', e2') -> Just $ fromMaybe e' (f e') 86 | where e' = Binop op (fromMaybe e1 e1') (fromMaybe e2 e2') 87 | 88 | mapEN _ (Label _) = Nothing 89 | mapEN f (Assign v e) = liftM (Assign v) $ f e 90 | mapEN f (Store addr e) = 91 | case (f addr, f e) of 92 | (Nothing, Nothing) -> Nothing 93 | (addr', e') -> Just $ Store (fromMaybe addr addr') (fromMaybe e e') 94 | mapEN _ (Branch _) = Nothing 95 | mapEN f (Cond e tid fid) = 96 | case f e of Just e' -> Just $ Cond e' tid fid 97 | Nothing -> Nothing 98 | mapEN f (Call rs n es succ) = 99 | if all isNothing es' then Nothing 100 | else Just $ Call rs n (map (uncurry fromMaybe) (zip es es')) succ 101 | where es' = map f es 102 | mapEN f (Return es) = 103 | if all isNothing es' then Nothing 104 | else Just $ Return (map (uncurry fromMaybe) (zip es es')) 105 | where es' = map f es 106 | 107 | fold_EE :: (a -> Expr -> a) -> a -> Expr -> a 108 | fold_EN :: (a -> Expr -> a) -> a -> Insn e x -> a 109 | 110 | fold_EE f z e@(Lit _) = f z e 111 | fold_EE f z e@(Var _) = f z e 112 | fold_EE f z e@(Load addr) = f (fold_EE f z addr) e 113 | fold_EE f z e@(Binop _ e1 e2) = 114 | let afterE1 = fold_EE f z e1 115 | afterE2 = fold_EE f afterE1 e2 116 | in f afterE2 e 117 | 118 | fold_EN _ z (Label _) = z 119 | fold_EN f z (Assign _ e) = f z e 120 | fold_EN f z (Store addr e) = f (f z e) addr 121 | fold_EN _ z (Branch _) = z 122 | fold_EN f z (Cond e _ _) = f z e 123 | fold_EN f z (Call _ _ es _) = foldl f z es 124 | fold_EN f z (Return es) = foldl f z es 125 | 126 | ---------------------------------------------- 127 | -- Lift a insn to a Graph 128 | ---------------------------------------------- 129 | 130 | insnToG :: Insn e x -> Graph Insn e x 131 | insnToG n@(Label _) = mkFirst n 132 | insnToG n@(Assign _ _) = mkMiddle n 133 | insnToG n@(Store _ _) = mkMiddle n 134 | insnToG n@(Branch _) = mkLast n 135 | insnToG n@(Cond _ _ _) = mkLast n 136 | insnToG n@(Call _ _ _ _) = mkLast n 137 | insnToG n@(Return _) = mkLast n 138 | -------------------------------------------------------------------------------- /testing/Test.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns #-} 3 | module Test (parseTest, evalTest, optTest) where 4 | 5 | import Compiler.Hoopl 6 | import Control.Monad.Except 7 | import System.Exit 8 | 9 | import qualified Ast as A 10 | import qualified Ir2ast as Ia 11 | import Ast2ir 12 | import ConstProp 13 | import Eval (evalProg, ErrorM) 14 | import IR 15 | import Live 16 | import Parse (parseCode) 17 | import Simplify 18 | parse :: String -> String -> ErrorM (M [(IdLabelMap, Proc)]) 19 | parse file text = 20 | case parseCode file text of 21 | Left err -> throwError $ show err 22 | Right ps -> return $ mapM astToIR ps 23 | 24 | parseTest :: String -> IO () 25 | parseTest file = 26 | do text <- readFile file 27 | case parse file text of 28 | Left err -> error err 29 | Right p -> mapM (putStrLn . showProc . snd) (runSimpleUniqueMonad $ runWithFuel 0 p) >> return () 30 | 31 | evalTest' :: String -> String -> ErrorM String 32 | evalTest' file text = 33 | do procs <- parse file text 34 | (_, vs) <- (testProg . snd . unzip) (runSimpleUniqueMonad $ runWithFuel 0 procs) 35 | return $ "returning: " ++ show vs 36 | where 37 | testProg procs@(Proc {name, args} : _) = evalProg procs vsupply name (toV args) 38 | testProg _ = throwError "No procedures in test program" 39 | toV args = [I n | (n, _) <- zip [3..] args] 40 | vsupply = [I x | x <- [5..]] 41 | 42 | evalTest :: String -> IO () 43 | evalTest file = 44 | do text <- readFile file 45 | case evalTest' file text of 46 | Left err -> error err 47 | Right s -> putStrLn s 48 | 49 | optTest' :: M [Proc] -> ErrorM (M [Proc]) 50 | optTest' procs = 51 | return $ procs >>= mapM optProc 52 | where 53 | optProc proc@(Proc {entry, body, args}) = 54 | do { (body', _, _) <- analyzeAndRewriteFwd fwd (JustC [entry]) body 55 | (mapSingleton entry (initFact args)) 56 | ; (body'', _, _) <- analyzeAndRewriteBwd bwd (JustC [entry]) body' mapEmpty 57 | ; return $ proc { body = body'' } } 58 | -- With debugging info: 59 | -- fwd = debugFwdJoins trace (const True) $ FwdPass { fp_lattice = constLattice, fp_transfer = varHasLit 60 | -- , fp_rewrite = constProp `thenFwdRw` simplify } 61 | fwd = constPropPass 62 | bwd = BwdPass { bp_lattice = liveLattice, bp_transfer = liveness 63 | , bp_rewrite = deadAsstElim } 64 | 65 | constPropPass :: FuelMonad m => FwdPass m Insn ConstFact 66 | -- @ start cprop.tex 67 | 68 | ---------------------------------------- 69 | -- Defining the forward dataflow pass 70 | constPropPass = FwdPass 71 | { fp_lattice = constLattice 72 | , fp_transfer = varHasLit 73 | , fp_rewrite = constProp `thenFwdRw` simplify } 74 | -- @ end cprop.tex 75 | 76 | toAst :: [(IdLabelMap, Proc)] -> [A.Proc] 77 | toAst l = fmap (uncurry Ia.irToAst) l 78 | 79 | compareAst :: [A.Proc] -> [A.Proc] -> IO () 80 | compareAst [] [] = return () 81 | compareAst (r:results) (e:expected) = 82 | if r == e 83 | then compareAst results expected 84 | else 85 | do { putStrLn "expecting" 86 | ; putStrLn $ A.showProc e 87 | ; putStrLn "resulting" 88 | ; putStrLn $ A.showProc r 89 | ; putStrLn "the result does not match the expected, abort the test!!!!" 90 | ; exitFailure 91 | } 92 | compareAst results expected = do { putStrLn "expecting" 93 | ; mapM_ (putStrLn . A.showProc) expected 94 | ; putStrLn "resulting" 95 | ; mapM_ (putStrLn . A.showProc) results 96 | ; putStrLn "the result does not match the expected, abort the test!!!!" 97 | ; exitFailure 98 | } 99 | 100 | 101 | 102 | optTest :: String -> String -> IO () 103 | optTest file expectedFile = 104 | do text <- readFile file 105 | expectedText <- readFile expectedFile 106 | case (parse file text, parse expectedFile expectedText) of 107 | (Left err, _) -> error err 108 | (_, Left err) -> error err 109 | (Right lps, Right exps) -> 110 | case optTest' (liftM (snd . unzip) lps) of 111 | Left err -> error err 112 | Right p -> do { let opted = runSimpleUniqueMonad $ runWithFuel fuel p 113 | lbmaps = runSimpleUniqueMonad $ runWithFuel fuel (liftM (fst . unzip) lps) 114 | expected = runSimpleUniqueMonad $ runWithFuel fuel exps 115 | ; compareAst (toAst (zip lbmaps opted)) (toAst expected) 116 | } 117 | where 118 | fuel = 9999 119 | 120 | 121 | 122 | {-- Properties to test: 123 | 124 | 1. Is the fixpoint complete (maps all blocks to facts)? 125 | 2. Is the computed fixpoint actually a fixpoint? 126 | 3. Random test generation. 127 | 128 | --} 129 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/Debug.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, RankNTypes, GADTs, ScopedTypeVariables, FlexibleContexts #-} 2 | #if __GLASGOW_HASKELL__ >= 701 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | 6 | module Compiler.Hoopl.Debug 7 | ( TraceFn , debugFwdJoins , debugBwdJoins 8 | , debugFwdTransfers , debugBwdTransfers 9 | ) 10 | where 11 | 12 | import Compiler.Hoopl.Dataflow 13 | import Compiler.Hoopl.Show 14 | 15 | -------------------------------------------------------------------------------- 16 | -- | Debugging combinators: 17 | -- Each combinator takes a dataflow pass and produces 18 | -- a dataflow pass that can output debugging messages. 19 | -- You provide the function, we call it with the applicable message. 20 | -- 21 | -- The most common use case is probably to: 22 | -- 23 | -- 1. import 'Debug.Trace' 24 | -- 25 | -- 2. pass 'trace' as the 1st argument to the debug combinator 26 | -- 27 | -- 3. pass 'const true' as the 2nd argument to the debug combinator 28 | -- 29 | -- There are two kinds of debugging messages for a join, 30 | -- depending on whether the join is higher in the lattice than the old fact: 31 | -- 1. If the join is higher, we show: 32 | -- + Join@L: f1 `join` f2 = f' 33 | -- where: 34 | -- + indicates a change 35 | -- L is the label where the join takes place 36 | -- f1 is the old fact at the label 37 | -- f2 is the new fact we are joining to f1 38 | -- f' is the result of the join 39 | -- 2. _ Join@L: f2 <= f1 40 | -- where: 41 | -- _ indicates no change 42 | -- L is the label where the join takes place 43 | -- f1 is the old fact at the label (which remains unchanged) 44 | -- f2 is the new fact we joined with f1 45 | -------------------------------------------------------------------------------- 46 | 47 | 48 | debugFwdJoins :: forall m n f . Show f => TraceFn -> ChangePred -> FwdPass m n f -> FwdPass m n f 49 | debugBwdJoins :: forall m n f . Show f => TraceFn -> ChangePred -> BwdPass m n f -> BwdPass m n f 50 | 51 | type TraceFn = forall a . String -> a -> a 52 | type ChangePred = ChangeFlag -> Bool 53 | 54 | debugFwdJoins trace pred p = p { fp_lattice = debugJoins trace pred $ fp_lattice p } 55 | debugBwdJoins trace pred p = p { bp_lattice = debugJoins trace pred $ bp_lattice p } 56 | 57 | debugJoins :: Show f => TraceFn -> ChangePred -> DataflowLattice f -> DataflowLattice f 58 | debugJoins trace showPred l@(DataflowLattice {fact_join = join}) = l {fact_join = join'} 59 | where 60 | join' l f1@(OldFact of1) f2@(NewFact nf2) = 61 | if showPred c then trace output res else res 62 | where res@(c, f') = join l f1 f2 63 | output = case c of 64 | SomeChange -> "+ Join@" ++ show l ++ ": " ++ show of1 ++ " `join` " 65 | ++ show nf2 ++ " = " ++ show f' 66 | NoChange -> "_ Join@" ++ show l ++ ": " ++ show nf2 ++ " <= " ++ show of1 67 | 68 | -------------------------------------------------------------------------------- 69 | -- Functions we'd like to have, but don't know how to implement generically: 70 | -------------------------------------------------------------------------------- 71 | 72 | type ShowN n = forall e x . n e x -> String 73 | type FPred n f = forall e x . n e x -> f -> Bool 74 | type BPred n f = forall e x . n e x -> Fact x f -> Bool 75 | debugFwdTransfers:: 76 | forall m n f . Show f => TraceFn -> ShowN n -> FPred n f -> FwdPass m n f -> FwdPass m n f 77 | debugFwdTransfers trace showN showPred pass = pass { fp_transfer = transfers' } 78 | where 79 | (f, m, l) = getFTransfer3 $ fp_transfer pass 80 | transfers' = mkFTransfer3 (wrap show f) (wrap show m) (wrap showFactBase l) 81 | wrap :: forall e x . (Fact x f -> String) -> (n e x -> f -> Fact x f) -> n e x -> f -> Fact x f 82 | wrap showOutF ft n f = if showPred n f then trace output res else res 83 | where 84 | res = ft n f 85 | output = name ++ " transfer: " ++ show f ++ " -> " ++ showN n ++ " -> " ++ showOutF res 86 | name = fact_name (fp_lattice pass) 87 | 88 | debugBwdTransfers:: 89 | forall m n f . Show f => TraceFn -> ShowN n -> BPred n f -> BwdPass m n f -> BwdPass m n f 90 | debugBwdTransfers trace showN showPred pass = pass { bp_transfer = transfers' } 91 | where 92 | (f, m, l) = getBTransfer3 $ bp_transfer pass 93 | transfers' = mkBTransfer3 (wrap show f) (wrap show m) (wrap showFactBase l) 94 | wrap :: forall e x . (Fact x f -> String) -> (n e x -> Fact x f -> f) -> n e x -> Fact x f -> f 95 | wrap showInF ft n f = if showPred n f then trace output res else res 96 | where 97 | res = ft n f 98 | output = name ++ " transfer: " ++ showInF f ++ " -> " ++ showN n ++ " -> " ++ show res 99 | name = fact_name (bp_lattice pass) 100 | 101 | 102 | -- debugFwdTransfers, debugFwdRewrites, debugFwdAll :: 103 | -- forall m n f . Show f => TraceFn -> ShowN n -> FwdPass m n f -> FwdPass m n f 104 | -- debugBwdTransfers, debugBwdRewrites, debugBwdAll :: 105 | -- forall m n f . Show f => TraceFn -> ShowN n -> BwdPass m n f -> BwdPass m n f 106 | 107 | -------------------------------------------------------------------------------- /hoopl.cabal: -------------------------------------------------------------------------------- 1 | Name: hoopl 2 | Version: 3.10.2.3 3 | -- NOTE: Don't forget to update ./changelog.md 4 | Description: 5 | Higher-order optimization library 6 | . 7 | See /Norman Ramsey, Joao Dias, and Simon Peyton Jones./ 8 | /(2010)/ for more details. 9 | 10 | License: BSD3 11 | License-File: LICENSE 12 | Author: Norman Ramsey, Joao Dias, Simon Marlow and Simon Peyton Jones 13 | Maintainer: Ning Wang , Michal Terepeta , Norman Ramsey 14 | Homepage: https://github.com/haskell/hoopl 15 | Bug-Reports: https://github.com/haskell/hoopl/issues/ 16 | Build-Type: Simple 17 | Cabal-Version: >=1.10 18 | Synopsis: A library to support dataflow analysis and optimization 19 | Category: Compilers/Interpreters 20 | Extra-Source-Files: README.md, changelog.md, 21 | testing/tests/if-test, testing/tests/if-test.expected, 22 | testing/tests/if-test2, testing/tests/if-test2.expected, 23 | testing/tests/if-test3, testing/tests/if-test3.expected, 24 | testing/tests/if-test4, testing/tests/if-test4.expected, 25 | testing/tests/test1, testing/tests/test1.expected, 26 | testing/tests/test2, testing/tests/test2.expected, 27 | testing/tests/test3, testing/tests/test3.expected, 28 | testing/tests/test4, testing/tests/test4.expected, 29 | testing/tests/test5, testing/tests/test5.expected, 30 | testing/tests/test6, testing/tests/test6.expected, 31 | testing/tests/test7, testing/tests/test7.expected 32 | tested-with: GHC == 7.0.4, 33 | GHC == 7.2.2, 34 | GHC == 7.4.2, 35 | GHC == 7.6.3, 36 | GHC == 7.8.4, 37 | GHC == 7.10.3, 38 | GHC == 8.0.2, 39 | GHC == 8.2.2, 40 | GHC == 8.4.3, 41 | GHC == 8.6.1 42 | 43 | Source-repository head 44 | Type: git 45 | Location: http://git.haskell.org/packages/hoopl.git 46 | 47 | Library 48 | Default-Language: Haskell2010 49 | Other-Extensions: CPP 50 | FlexibleContexts 51 | FlexibleInstances 52 | GADTs 53 | LiberalTypeSynonyms 54 | MultiParamTypeClasses 55 | RankNTypes 56 | ScopedTypeVariables 57 | TypeFamilies 58 | TypeSynonymInstances 59 | If impl(ghc>=7.2) 60 | Other-Extensions: Safe Trustworthy 61 | 62 | Hs-Source-Dirs: src 63 | Build-Depends: base >= 4.3 && < 4.13, 64 | containers >= 0.5 && < 0.7 65 | Exposed-Modules: Compiler.Hoopl, 66 | Compiler.Hoopl.Internals, 67 | Compiler.Hoopl.Wrappers, 68 | Compiler.Hoopl.Passes.Dominator, 69 | Compiler.Hoopl.Passes.DList 70 | 71 | -- The remaining modules are hidden *provisionally* 72 | Other-modules: Compiler.Hoopl.Checkpoint, 73 | Compiler.Hoopl.Collections, 74 | Compiler.Hoopl.Combinators, 75 | Compiler.Hoopl.Dataflow, 76 | Compiler.Hoopl.Debug, 77 | Compiler.Hoopl.Block, 78 | Compiler.Hoopl.Graph, 79 | Compiler.Hoopl.Label, 80 | Compiler.Hoopl.MkGraph, 81 | Compiler.Hoopl.Fuel, 82 | Compiler.Hoopl.Pointed, 83 | Compiler.Hoopl.Shape, 84 | Compiler.Hoopl.Show, 85 | Compiler.Hoopl.Unique, 86 | Compiler.Hoopl.XUtil 87 | 88 | Ghc-Options: -Wall -fno-warn-name-shadowing 89 | 90 | Test-Suite hoopl-test 91 | Default-Language: Haskell2010 92 | Type: exitcode-stdio-1.0 93 | Main-Is: Main.hs 94 | Other-modules: Ast 95 | Ast2ir 96 | ConstProp 97 | Eval 98 | EvalMonad 99 | Expr 100 | IR 101 | Ir2ast 102 | Live 103 | OptSupport 104 | Parse 105 | PP 106 | Simplify 107 | Test 108 | Hs-Source-Dirs: testing 109 | Build-Depends: base >= 4.3 && < 4.13, 110 | containers >= 0.5 && < 0.7, 111 | filepath, 112 | hoopl, 113 | mtl >= 2.1.3.1, 114 | mtl-compat, 115 | parsec >= 3.1.7, 116 | test-framework < 0.9, 117 | test-framework-hunit < 0.4 118 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/Passes/Dominator.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, GADTs #-} 2 | {-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} 3 | #if __GLASGOW_HASKELL__ >= 723 4 | {-# LANGUAGE Safe #-} 5 | #endif 6 | 7 | module Compiler.Hoopl.Passes.Dominator 8 | ( Doms, DPath(..), domPath, domEntry, domLattice, extendDom 9 | , DominatorNode(..), DominatorTree(..), tree 10 | , immediateDominators 11 | , domPass 12 | ) 13 | where 14 | 15 | import Data.Maybe 16 | import qualified Data.Set as Set 17 | 18 | import Compiler.Hoopl 19 | 20 | 21 | type Doms = WithBot DPath 22 | -- ^ List of labels, extended with a standard bottom element 23 | 24 | -- | The fact that goes into the entry of a dominator analysis: the first node 25 | -- is dominated only by the entry point, which is represented by the empty list 26 | -- of labels. 27 | domEntry :: Doms 28 | domEntry = PElem (DPath []) 29 | 30 | newtype DPath = DPath [Label] 31 | -- ^ represents part of the domination relation: each label 32 | -- in a list is dominated by all its successors. This is a newtype only so 33 | -- we can give it a fancy Show instance. 34 | 35 | instance Show DPath where 36 | show (DPath ls) = concat (foldr (\l path -> show l : " -> " : path) ["entry"] ls) 37 | 38 | domPath :: Doms -> [Label] 39 | domPath Bot = [] -- lies: an unreachable node appears to be dominated by the entry 40 | domPath (PElem (DPath ls)) = ls 41 | 42 | extendDom :: Label -> DPath -> DPath 43 | extendDom l (DPath ls) = DPath (l:ls) 44 | 45 | domLattice :: DataflowLattice Doms 46 | domLattice = addPoints "dominators" extend 47 | 48 | extend :: JoinFun DPath 49 | extend _ (OldFact (DPath l)) (NewFact (DPath l')) = 50 | (changeIf (l `lengthDiffers` j), DPath j) 51 | where lx = filter (\elem -> Set.member elem common) l 52 | rx = filter (\elem -> Set.member elem common) l' 53 | common = Set.intersection (Set.fromList l) (Set.fromList l') 54 | j = [x | (x, y) <- zip lx rx, x == y] 55 | 56 | lengthDiffers [] [] = False 57 | lengthDiffers (_:xs) (_:ys) = lengthDiffers xs ys 58 | lengthDiffers [] (_:_) = True 59 | lengthDiffers (_:_) [] = True 60 | 61 | 62 | 63 | -- | Dominator pass 64 | domPass :: (NonLocal n, Monad m) => FwdPass m n Doms 65 | domPass = FwdPass domLattice (mkFTransfer3 first (const id) distributeFact) noFwdRewrite 66 | where first n = fmap (extendDom $ entryLabel n) 67 | 68 | ---------------------------------------------------------------- 69 | 70 | data DominatorNode = Entry | Labelled Label 71 | data DominatorTree = Dominates DominatorNode [DominatorTree] 72 | -- ^ This data structure is a *rose tree* in which each node may have 73 | -- arbitrarily many children. Each node dominates all its descendants. 74 | 75 | -- | Map from a FactBase for dominator lists into a 76 | -- dominator tree. 77 | tree :: [(Label, Doms)] -> DominatorTree 78 | tree facts = Dominates Entry $ merge $ map reverse $ map mkList facts 79 | -- This code has been lightly tested. The key insight is this: to 80 | -- find lists that all have the same head, convert from a list of 81 | -- lists to a finite map, in 'children'. Then, to convert from the 82 | -- finite map to list of dominator trees, use the invariant that 83 | -- each key dominates all the lists of values. 84 | where merge lists = mapTree $ children $ filter (not . null) lists 85 | children = foldl addList noFacts 86 | addList :: FactBase [[Label]] -> [Label] -> FactBase [[Label]] 87 | addList map (x:xs) = mapInsert x (xs:existing) map 88 | where existing = fromMaybe [] $ lookupFact x map 89 | addList _ [] = error "this can't happen" 90 | mapTree :: FactBase [[Label]] -> [DominatorTree] 91 | mapTree map = [Dominates (Labelled x) (merge lists) | 92 | (x, lists) <- mapToList map] 93 | mkList (l, doms) = l : domPath doms 94 | 95 | 96 | instance Show DominatorTree where 97 | show = tree2dot 98 | 99 | -- | Given a dominator tree, produce a string representation, in the 100 | -- input language of dot, that will enable dot to produce a 101 | -- visualization of the tree. For more info about dot see 102 | -- http://www.graphviz.org. 103 | 104 | tree2dot :: DominatorTree -> String 105 | tree2dot t = concat $ "digraph {\n" : dot t ["}\n"] 106 | where 107 | dot :: DominatorTree -> [String] -> [String] 108 | dot (Dominates root trees) = 109 | (dotnode root :) . outedges trees . flip (foldl subtree) trees 110 | where outedges [] = id 111 | outedges (Dominates n _ : ts) = 112 | \s -> " " : show root : " -> " : show n : "\n" : outedges ts s 113 | dotnode Entry = " entryNode [shape=plaintext, label=\"entry\"]\n" 114 | dotnode (Labelled l) = " " ++ show l ++ "\n" 115 | subtree = flip dot 116 | 117 | instance Show DominatorNode where 118 | show Entry = "entryNode" 119 | show (Labelled l) = show l 120 | 121 | ---------------------------------------------------------------- 122 | 123 | -- | Takes FactBase from dominator analysis and returns a map from each 124 | -- label to its immediate dominator, if any 125 | immediateDominators :: FactBase Doms -> LabelMap Label 126 | immediateDominators = mapFoldWithKey add mapEmpty 127 | where add l (PElem (DPath (idom:_))) = mapInsert l idom 128 | add _ _ = id 129 | 130 | -------------------------------------------------------------------------------- /testing/EvalMonad.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns , FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} 3 | 4 | module EvalMonad (ErrorM, VarEnv, B, State, 5 | EvalM, runProg, inNewFrame, get_proc, get_block, 6 | get_var, set_var, get_heap, set_heap, 7 | Event (..), event) where 8 | 9 | import Control.Applicative as AP (Applicative(..)) 10 | import Control.Monad.Except 11 | import qualified Data.Map as M 12 | import Prelude hiding (succ) 13 | 14 | import Compiler.Hoopl hiding ((<*>)) 15 | import IR 16 | 17 | type ErrorM = Either String 18 | type InnerErrorM v = Either (State v, String) 19 | 20 | data EvalM v a = EvalM (State v -> InnerErrorM v (State v, a)) 21 | 22 | instance Monad (EvalM v) where 23 | return = AP.pure 24 | EvalM f >>= k = EvalM $ \s -> do (s', x) <- f s 25 | let EvalM f' = k x 26 | f' s' 27 | 28 | instance Functor (EvalM v) where 29 | fmap = liftM 30 | 31 | instance Applicative (EvalM v) where 32 | pure x = EvalM (\s -> return (s, x)) 33 | (<*>) = ap 34 | 35 | instance MonadError String (EvalM v) where 36 | throwError e = EvalM (\s -> throwError (s, e)) 37 | catchError (EvalM f) handler = 38 | EvalM $ \s -> f s `catchError` handler' 39 | where handler' (s', e) = let EvalM f' = handler e 40 | in f' s' 41 | 42 | -- Shorthands for frequently used types 43 | type VarEnv v = M.Map Var v 44 | type HeapEnv v = M.Map Addr v -- word addressed heap 45 | type Addr = Integer 46 | type B = Block Insn C C 47 | type PEnv = M.Map String Proc 48 | type G = Graph Insn C C 49 | 50 | runProg :: [Proc] -> [v] -> EvalM v x -> ErrorM (State v, x) 51 | runProg procs vs (EvalM f) = 52 | case f init_state of 53 | Left (_, e) -> throwError e 54 | Right x -> return x 55 | where 56 | init_state = State { frames = [], heap = M.empty, events = [], 57 | vsupply = vs, procs = procMap } 58 | procMap = M.fromList $ zip (map name procs) procs 59 | 60 | get_state :: EvalM v (State v) 61 | get_state = EvalM f 62 | where f state = return (state, state) 63 | 64 | upd_state :: (State v -> State v) -> EvalM v () 65 | upd_state upd = EvalM (\state -> return (upd state, ())) 66 | 67 | event :: Event v -> EvalM v () 68 | event e = upd_state (\s -> s {events = e : events s}) 69 | 70 | ---------------------------------- 71 | -- State of the machine 72 | data State v = State { frames :: [(VarEnv v, G)] 73 | , heap :: HeapEnv v 74 | , procs :: PEnv 75 | , vsupply :: [v] 76 | , events :: [Event v] 77 | } 78 | data Event v = CallEvt String [v] 79 | | RetEvt [v] 80 | | StoreEvt Addr v 81 | | ReadEvt Addr v 82 | 83 | get_var :: Var -> EvalM v v 84 | get_var var = get_state >>= k 85 | where k (State {frames = (vars, _):_}) = mlookup "var" var vars 86 | k _ = throwError "can't get vars from empty stack" 87 | 88 | set_var :: Var -> v -> EvalM v () 89 | set_var var val = upd_state f 90 | where f s@(State {frames = (vars, blocks):vs}) = 91 | s { frames = (M.insert var val vars, blocks):vs } 92 | f _ = error "can't set var with empty stack" 93 | 94 | -- Special treatment for the heap: 95 | -- If a heap location doesn't have a value, we give it one. 96 | get_heap :: Addr -> EvalM v v 97 | get_heap addr = 98 | do State {heap, vsupply} <- get_state 99 | (v, vs) <- case vsupply of v:vs -> return (v, vs) 100 | _ -> throwError "hlookup hit end of value supply" 101 | upd_state (\s -> s {heap = M.insert addr v heap, vsupply = vs}) 102 | event $ ReadEvt addr v 103 | return v 104 | 105 | set_heap :: Addr -> v -> EvalM v () 106 | set_heap addr val = 107 | do event $ StoreEvt addr val 108 | upd_state $ \ s -> s { heap = M.insert addr val (heap s) } 109 | 110 | get_block :: Label -> EvalM v B 111 | get_block lbl = get_state >>= k 112 | where k (State {frames = (_, graph):_}) = blookup "block" graph lbl 113 | k _ = error "can't get blocks from empty stack" 114 | 115 | get_proc :: String -> EvalM v Proc 116 | get_proc name = get_state >>= mlookup "proc" name . procs 117 | 118 | newFrame :: VarEnv v -> G -> EvalM v () 119 | newFrame vars graph = upd_state $ \s -> s { frames = (vars, graph) : frames s} 120 | 121 | popFrame :: EvalM v () 122 | popFrame = upd_state f 123 | where f s@(State {frames = _:fs}) = s { frames = fs } 124 | f _ = error "popFrame: no frame to pop..." -- implementation error 125 | 126 | inNewFrame :: VarEnv v -> G -> EvalM v x -> EvalM v x 127 | inNewFrame vars graph runFrame = 128 | do newFrame vars graph 129 | x <- runFrame 130 | popFrame 131 | return x 132 | 133 | mlookup :: Ord k => String -> k -> M.Map k v -> EvalM v' v 134 | mlookup blame k m = 135 | case M.lookup k m of 136 | Just v -> return v 137 | Nothing -> throwError ("unknown lookup for " ++ blame) 138 | 139 | blookup :: String -> G -> Label -> EvalM v B 140 | blookup blame (GMany _ blks _) lbl = 141 | case mapLookup lbl blks of 142 | Just b -> return b 143 | Nothing -> throwError ("unknown lookup for " ++ blame) 144 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/Unique.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, TypeFamilies #-} 2 | {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} 3 | #if __GLASGOW_HASKELL__ >= 709 4 | {-# LANGUAGE Safe #-} 5 | #elif __GLASGOW_HASKELL__ >= 701 6 | {-# LANGUAGE Trustworthy #-} 7 | #endif 8 | 9 | 10 | module Compiler.Hoopl.Unique 11 | ( Unique, intToUnique 12 | , UniqueSet, UniqueMap 13 | , UniqueMonad(..) 14 | , SimpleUniqueMonad, runSimpleUniqueMonad 15 | , UniqueMonadT, runUniqueMonadT 16 | 17 | , uniqueToInt -- exposed through GHC module only! 18 | ) 19 | 20 | where 21 | 22 | import Compiler.Hoopl.Checkpoint 23 | import Compiler.Hoopl.Collections 24 | 25 | import qualified Data.IntMap as M 26 | import qualified Data.IntSet as S 27 | 28 | import Control.Applicative as AP 29 | import Control.Monad (ap,liftM) 30 | #if !MIN_VERSION_base(4,8,0) 31 | import Data.Traversable (Traversable) 32 | import Data.Foldable (Foldable) 33 | #endif 34 | 35 | ----------------------------------------------------------------------------- 36 | -- Unique 37 | ----------------------------------------------------------------------------- 38 | 39 | type Unique = Int 40 | 41 | uniqueToInt :: Unique -> Int 42 | uniqueToInt = id 43 | 44 | intToUnique :: Int -> Unique 45 | intToUnique = id 46 | 47 | ----------------------------------------------------------------------------- 48 | -- UniqueSet 49 | 50 | newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show) 51 | 52 | instance IsSet UniqueSet where 53 | type ElemOf UniqueSet = Unique 54 | 55 | setNull (US s) = S.null s 56 | setSize (US s) = S.size s 57 | setMember k (US s) = S.member k s 58 | 59 | setEmpty = US S.empty 60 | setSingleton k = US (S.singleton k) 61 | setInsert k (US s) = US (S.insert k s) 62 | setDelete k (US s) = US (S.delete k s) 63 | 64 | setUnion (US x) (US y) = US (S.union x y) 65 | setDifference (US x) (US y) = US (S.difference x y) 66 | setIntersection (US x) (US y) = US (S.intersection x y) 67 | setIsSubsetOf (US x) (US y) = S.isSubsetOf x y 68 | 69 | setFold k z (US s) = S.foldr k z s 70 | 71 | setElems (US s) = S.elems s 72 | setFromList ks = US (S.fromList ks) 73 | 74 | ----------------------------------------------------------------------------- 75 | -- UniqueMap 76 | 77 | newtype UniqueMap v = UM (M.IntMap v) 78 | deriving (Eq, Ord, Show, Functor, Foldable, Traversable) 79 | 80 | instance IsMap UniqueMap where 81 | type KeyOf UniqueMap = Unique 82 | 83 | mapNull (UM m) = M.null m 84 | mapSize (UM m) = M.size m 85 | mapMember k (UM m) = M.member k m 86 | mapLookup k (UM m) = M.lookup k m 87 | mapFindWithDefault def k (UM m) = M.findWithDefault def k m 88 | 89 | mapEmpty = UM M.empty 90 | mapSingleton k v = UM (M.singleton k v) 91 | mapInsert k v (UM m) = UM (M.insert k v m) 92 | mapInsertWith f k v (UM m) = UM (M.insertWith f k v m) 93 | mapDelete k (UM m) = UM (M.delete k m) 94 | 95 | mapUnion (UM x) (UM y) = UM (M.union x y) 96 | mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey (f . intToUnique) x y) 97 | mapDifference (UM x) (UM y) = UM (M.difference x y) 98 | mapIntersection (UM x) (UM y) = UM (M.intersection x y) 99 | mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y 100 | 101 | mapMap f (UM m) = UM (M.map f m) 102 | mapMapWithKey f (UM m) = UM (M.mapWithKey (f . intToUnique) m) 103 | mapFold k z (UM m) = M.foldr k z m 104 | mapFoldWithKey k z (UM m) = M.foldrWithKey (k . intToUnique) z m 105 | mapFilter f (UM m) = UM (M.filter f m) 106 | 107 | mapElems (UM m) = M.elems m 108 | mapKeys (UM m) = M.keys m 109 | mapToList (UM m) = M.toList m 110 | mapFromList assocs = UM (M.fromList assocs) 111 | mapFromListWith f assocs = UM (M.fromListWith f assocs) 112 | 113 | ---------------------------------------------------------------- 114 | -- Monads 115 | 116 | class Monad m => UniqueMonad m where 117 | freshUnique :: m Unique 118 | 119 | newtype SimpleUniqueMonad a = SUM { unSUM :: [Unique] -> (a, [Unique]) } 120 | 121 | instance Functor SimpleUniqueMonad where 122 | fmap = liftM 123 | 124 | instance Applicative SimpleUniqueMonad where 125 | pure a = SUM $ \us -> (a, us) 126 | (<*>) = ap 127 | 128 | instance Monad SimpleUniqueMonad where 129 | return = AP.pure 130 | m >>= k = SUM $ \us -> let (a, us') = unSUM m us in 131 | unSUM (k a) us' 132 | 133 | instance UniqueMonad SimpleUniqueMonad where 134 | freshUnique = SUM $ f 135 | where f (u:us) = (u, us) 136 | f _ = error "Unique.freshUnique(SimpleUniqueMonad): empty list" 137 | 138 | instance CheckpointMonad SimpleUniqueMonad where 139 | type Checkpoint SimpleUniqueMonad = [Unique] 140 | checkpoint = SUM $ \us -> (us, us) 141 | restart us = SUM $ \_ -> ((), us) 142 | 143 | runSimpleUniqueMonad :: SimpleUniqueMonad a -> a 144 | runSimpleUniqueMonad m = fst (unSUM m allUniques) 145 | 146 | ---------------------------------------------------------------- 147 | 148 | newtype UniqueMonadT m a = UMT { unUMT :: [Unique] -> m (a, [Unique]) } 149 | 150 | instance Monad m => Functor (UniqueMonadT m) where 151 | fmap = liftM 152 | 153 | instance Monad m => Applicative (UniqueMonadT m) where 154 | pure a = UMT $ \us -> return (a, us) 155 | (<*>) = ap 156 | 157 | instance Monad m => Monad (UniqueMonadT m) where 158 | return = pure 159 | m >>= k = UMT $ \us -> do { (a, us') <- unUMT m us; unUMT (k a) us' } 160 | 161 | instance Monad m => UniqueMonad (UniqueMonadT m) where 162 | freshUnique = UMT $ f 163 | where f (u:us) = return (u, us) 164 | f _ = error "Unique.freshUnique(UniqueMonadT): empty list" 165 | 166 | runUniqueMonadT :: Monad m => UniqueMonadT m a -> m a 167 | runUniqueMonadT m = do { (a, _) <- unUMT m allUniques; return a } 168 | 169 | allUniques :: [Unique] 170 | allUniques = [1..] 171 | -------------------------------------------------------------------------------- /testing/Parse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | module Parse (parseCode) where 4 | 5 | import Control.Monad 6 | import Prelude hiding (id, last, succ) 7 | 8 | -- Note: We do not need to import Hoopl to build an AST. 9 | import Ast 10 | import Expr 11 | import Text.ParserCombinators.Parsec 12 | import Text.ParserCombinators.Parsec.Expr 13 | import Text.ParserCombinators.Parsec.Language 14 | import qualified Text.ParserCombinators.Parsec.Token as P 15 | 16 | -- I'm stealing this parser almost directly from Daan Leijen's Parsec guide. 17 | lexer :: P.TokenParser () 18 | lexer = P.makeTokenParser (haskellDef {reservedOpNames = ["+", "-", "*", "/", "=", "<"]}) 19 | 20 | -- Common lexers: 21 | lexeme, parens, braces :: CharParser () a -> CharParser () a 22 | lexeme = P.lexeme lexer 23 | parens = P.parens lexer 24 | braces = P.braces lexer 25 | 26 | commaSep :: CharParser () a -> CharParser () [a] 27 | commaSep = P.commaSep lexer 28 | 29 | reserved :: String -> CharParser () () 30 | reserved = P.reserved lexer 31 | 32 | ign :: GenParser Char st a -> GenParser Char st () 33 | ign p = p >> return () 34 | 35 | char' :: Char -> GenParser Char st () 36 | char' c = ign $ char c 37 | 38 | identifier :: CharParser () String 39 | identifier = P.identifier lexer 40 | 41 | natural :: CharParser () Integer 42 | natural = P.natural lexer 43 | 44 | reservedOp :: String -> CharParser () () 45 | reservedOp = P.reservedOp lexer 46 | 47 | whitespace :: CharParser () () 48 | whitespace = P.whiteSpace lexer 49 | 50 | brackets :: CharParser () a -> CharParser () a 51 | brackets = P.brackets lexer 52 | 53 | -- Expressions: 54 | expr :: Parser Expr 55 | expr = buildExpressionParser table factor 56 | "Expression" 57 | where 58 | table = [[op "*" (Binop Mul) AssocLeft, op "/" (Binop Div) AssocLeft], 59 | [op "+" (Binop Add) AssocLeft, op "-" (Binop Sub) AssocLeft], 60 | [op "=" (Binop Eq) AssocLeft, op "/=" (Binop Ne) AssocLeft, 61 | op ">" (Binop Gt) AssocLeft, op "<" (Binop Lt) AssocLeft, 62 | op ">=" (Binop Gte) AssocLeft, op "<=" (Binop Lte) AssocLeft]] 63 | op o f assoc = Infix (do {reservedOp o; return f} "operator") assoc 64 | factor = parens expr 65 | <|> lit 66 | <|> load 67 | <|> fetchVar 68 | "simple Expression" 69 | 70 | bool :: Parser Bool 71 | bool = (try $ lexeme (string "True") >> return True) 72 | <|> (try $ lexeme (string "False") >> return False) 73 | 74 | lit :: Parser Expr 75 | lit = (natural >>= (return . Lit . Int)) 76 | <|> (bool >>= (return . Lit . Bool)) 77 | <|> (bool >>= (return . Lit . Bool)) 78 | "lit" 79 | 80 | loc :: Char -> Parser x -> Parser x 81 | loc s addr = try (lexeme (char' s >> brackets addr)) 82 | "loc" 83 | 84 | var :: Parser String 85 | var = identifier 86 | "var" 87 | 88 | mem :: Parser Expr -- address 89 | mem = loc 'm' expr 90 | "mem" 91 | 92 | fetchVar, load :: Parser Expr 93 | fetchVar = var >>= return . Var 94 | load = mem >>= return . Load 95 | 96 | 97 | labl :: Parser Lbl 98 | labl = lexeme (do { id <- identifier 99 | ; char' ':' 100 | ; return id 101 | }) 102 | "label" 103 | 104 | mid :: Parser Insn 105 | mid = try asst 106 | <|> store 107 | "assignment or store" 108 | 109 | asst :: Parser Insn 110 | asst = do { v <- lexeme var 111 | ; lexeme (char' '=') 112 | ; e <- expr 113 | ; return $ Assign v e 114 | } 115 | "asst" 116 | 117 | store :: Parser Insn 118 | store = do { addr <- lexeme mem 119 | ; lexeme (char' '=') 120 | ; e <- expr 121 | ; return $ Store addr e 122 | } 123 | "store" 124 | 125 | control :: Parser Control 126 | control = branch 127 | <|> cond 128 | <|> call 129 | <|> ret 130 | "control-transfer" 131 | 132 | 133 | goto :: Parser Lbl 134 | goto = do { lexeme (reserved "goto") 135 | ; identifier 136 | } 137 | "goto" 138 | 139 | branch :: Parser Control 140 | branch = 141 | do { l <- goto 142 | ; return $ Branch l 143 | } 144 | "branch" 145 | 146 | cond, call, ret :: Parser Control 147 | cond = 148 | do { lexeme (reserved "if") 149 | ; cnd <- expr 150 | ; lexeme (reserved "then") 151 | ; thn <- goto 152 | ; lexeme (reserved "else") 153 | ; els <- goto 154 | ; return $ Cond cnd thn els 155 | } 156 | "cond" 157 | 158 | call = 159 | do { results <- tuple var 160 | ; lexeme (char' '=') 161 | ; f <- identifier 162 | ; params <- tuple expr 163 | ; succ <- goto 164 | ; return $ Call results f params succ 165 | } 166 | "call" 167 | 168 | ret = 169 | do { lexeme (reserved "ret") 170 | ; results <- tuple expr 171 | ; return $ Return results 172 | } 173 | "ret" 174 | 175 | block :: Parser Block 176 | block = 177 | do { f <- lexeme labl 178 | ; ms <- many $ try mid 179 | ; l <- lexeme control 180 | ; return $ Block { first = f, mids = ms, last = l } 181 | } 182 | "Expected basic block; maybe you forgot a label following a control-transfer?" 183 | 184 | tuple :: Parser a -> Parser [a] 185 | tuple = parens . commaSep 186 | 187 | proc :: Parser Proc 188 | proc = do { whitespace 189 | ; f <- identifier 190 | ; params <- tuple var 191 | ; bdy <- braces $ do { b <- block 192 | ; bs <- many block 193 | ; return (b : bs) 194 | } -- procedure must have at least one block 195 | ; return $ Proc { name = f, args = params, body = bdy } 196 | } 197 | "proc" 198 | 199 | parseCode :: String -> String -> Either ParseError [Proc] 200 | parseCode file inp = parse (many proc) file inp 201 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/Pointed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, GADTs, ScopedTypeVariables #-} 2 | #if __GLASGOW_HASKELL__ >= 701 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | 6 | -- | Possibly doubly pointed lattices 7 | 8 | module Compiler.Hoopl.Pointed 9 | ( Pointed(..), addPoints, addPoints', addTop, addTop' 10 | , liftJoinTop, extendJoinDomain 11 | , WithTop, WithBot, WithTopAndBot 12 | ) 13 | where 14 | 15 | import Compiler.Hoopl.Block 16 | import Compiler.Hoopl.Label 17 | import Compiler.Hoopl.Dataflow 18 | 19 | -- | Adds top, bottom, or both to help form a lattice 20 | data Pointed t b a where 21 | Bot :: Pointed t C a 22 | PElem :: a -> Pointed t b a 23 | Top :: Pointed C b a 24 | 25 | -- ^ The type parameters 't' and 'b' are used to say whether top 26 | -- and bottom elements have been added. The analogy with 'Block' 27 | -- is nearly exact: 28 | -- 29 | -- * A 'Block' is closed at the entry if and only if it has a first node; 30 | -- a 'Pointed' is closed at the top if and only if it has a top element. 31 | -- 32 | -- * A 'Block' is closed at the exit if and only if it has a last node; 33 | -- a 'Pointed' is closed at the bottom if and only if it has a bottom element. 34 | -- 35 | -- We thus have four possible types, of which three are interesting: 36 | -- 37 | -- [@Pointed C C a@] Type @a@ extended with both top and bottom elements. 38 | -- 39 | -- [@Pointed C O a@] Type @a@ extended with a top element 40 | -- only. (Presumably @a@ comes equipped with a bottom element of its own.) 41 | -- 42 | -- [@Pointed O C a@] Type @a@ extended with a bottom element only. 43 | -- 44 | -- [@Pointed O O a@] Isomorphic to @a@, and therefore not interesting. 45 | -- 46 | -- The advantage of all this GADT-ishness is that the constructors 47 | -- 'Bot', 'Top', and 'PElem' can all be used polymorphically. 48 | -- 49 | -- A 'Pointed t b' type is an instance of 'Functor' and 'Show'. 50 | 51 | 52 | 53 | type WithBot a = Pointed O C a 54 | -- ^ Type 'a' with a bottom element adjoined 55 | 56 | type WithTop a = Pointed C O a 57 | -- ^ Type 'a' with a top element adjoined 58 | 59 | type WithTopAndBot a = Pointed C C a 60 | -- ^ Type 'a' with top and bottom elements adjoined 61 | 62 | 63 | -- | Given a join function and a name, creates a semi lattice by 64 | -- adding a bottom element, and possibly a top element also. 65 | -- A specialized version of 'addPoints''. 66 | addPoints :: String -> JoinFun a -> DataflowLattice (Pointed t C a) 67 | -- | A more general case for creating a new lattice 68 | addPoints' :: forall a t . 69 | String 70 | -> (Label -> OldFact a -> NewFact a -> (ChangeFlag, Pointed t C a)) 71 | -> DataflowLattice (Pointed t C a) 72 | 73 | addPoints name join = addPoints' name join' 74 | where join' l o n = (change, PElem f) 75 | where (change, f) = join l o n 76 | 77 | addPoints' name joinx = DataflowLattice name Bot join 78 | where -- careful: order of cases matters for ChangeFlag 79 | join :: JoinFun (Pointed t C a) 80 | join _ (OldFact f) (NewFact Bot) = (NoChange, f) 81 | join _ (OldFact Top) (NewFact _) = (NoChange, Top) 82 | join _ (OldFact Bot) (NewFact f) = (SomeChange, f) 83 | join _ (OldFact _) (NewFact Top) = (SomeChange, Top) 84 | join l (OldFact (PElem old)) (NewFact (PElem new)) 85 | = joinx l (OldFact old) (NewFact new) 86 | 87 | 88 | liftJoinTop :: JoinFun a -> JoinFun (WithTop a) 89 | extendJoinDomain :: forall a 90 | . (Label -> OldFact a -> NewFact a -> (ChangeFlag, WithTop a)) 91 | -> JoinFun (WithTop a) 92 | 93 | extendJoinDomain joinx = join 94 | where join :: JoinFun (WithTop a) 95 | join _ (OldFact Top) (NewFact _) = (NoChange, Top) 96 | join _ (OldFact _) (NewFact Top) = (SomeChange, Top) 97 | join l (OldFact (PElem old)) (NewFact (PElem new)) 98 | = joinx l (OldFact old) (NewFact new) 99 | 100 | liftJoinTop joinx = extendJoinDomain (\l old new -> liftPair $ joinx l old new) 101 | where liftPair (c, a) = (c, PElem a) 102 | 103 | -- | Given a join function and a name, creates a semi lattice by 104 | -- adding a top element but no bottom element. Caller must supply the bottom 105 | -- element. 106 | addTop :: DataflowLattice a -> DataflowLattice (WithTop a) 107 | -- | A more general case for creating a new lattice 108 | addTop' :: forall a . 109 | String 110 | -> a 111 | -> (Label -> OldFact a -> NewFact a -> (ChangeFlag, WithTop a)) 112 | -> DataflowLattice (WithTop a) 113 | 114 | addTop lattice = addTop' name' (fact_bot lattice) join' 115 | where name' = fact_name lattice ++ " + T" 116 | join' l o n = (change, PElem f) 117 | where (change, f) = fact_join lattice l o n 118 | 119 | addTop' name bot joinx = DataflowLattice name (PElem bot) join 120 | where -- careful: order of cases matters for ChangeFlag 121 | join :: JoinFun (WithTop a) 122 | join _ (OldFact Top) (NewFact _) = (NoChange, Top) 123 | join _ (OldFact _) (NewFact Top) = (SomeChange, Top) 124 | join l (OldFact (PElem old)) (NewFact (PElem new)) 125 | = joinx l (OldFact old) (NewFact new) 126 | 127 | instance Show a => Show (Pointed t b a) where 128 | show Bot = "_|_" 129 | show Top = "T" 130 | show (PElem a) = show a 131 | 132 | instance Functor (Pointed t b) where 133 | fmap _ Bot = Bot 134 | fmap _ Top = Top 135 | fmap f (PElem a) = PElem (f a) 136 | 137 | instance Eq a => Eq (Pointed t b a) where 138 | Bot == Bot = True 139 | Top == Top = True 140 | (PElem a) == (PElem a') = a == a' 141 | _ == _ = False 142 | 143 | instance Ord a => Ord (Pointed t b a) where 144 | Bot `compare` Bot = EQ 145 | Bot `compare` _ = LT 146 | _ `compare` Bot = GT 147 | PElem a `compare` PElem a' = a `compare` a' 148 | Top `compare` Top = EQ 149 | Top `compare` _ = GT 150 | _ `compare` Top = LT 151 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # runghc make_travis_yml_2.hs '-o' '.travis.yml' 'cabal.project' 4 | # 5 | # For more information, see https://github.com/haskell-CI/haskell-ci 6 | # 7 | language: c 8 | sudo: false 9 | 10 | git: 11 | submodules: false # whether to recursively clone submodules 12 | 13 | cache: 14 | directories: 15 | - $HOME/.cabal/packages 16 | - $HOME/.cabal/store 17 | 18 | before_cache: 19 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 20 | # remove files that are regenerated by 'cabal update' 21 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* 22 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json 23 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache 24 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar 25 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx 26 | 27 | - rm -rfv $HOME/.cabal/packages/head.hackage 28 | 29 | matrix: 30 | include: 31 | - compiler: "ghc-8.6.1" 32 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 33 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.1], sources: [hvr-ghc]}} 34 | - compiler: "ghc-8.4.3" 35 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 36 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.3], sources: [hvr-ghc]}} 37 | - compiler: "ghc-8.2.2" 38 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 39 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.2.2], sources: [hvr-ghc]}} 40 | - compiler: "ghc-8.0.2" 41 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 42 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.0.2], sources: [hvr-ghc]}} 43 | - compiler: "ghc-7.10.3" 44 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 45 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.10.3], sources: [hvr-ghc]}} 46 | - compiler: "ghc-7.8.4" 47 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 48 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.8.4], sources: [hvr-ghc]}} 49 | - compiler: "ghc-7.6.3" 50 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 51 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.6.3], sources: [hvr-ghc]}} 52 | - compiler: "ghc-7.4.2" 53 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 54 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.4.2], sources: [hvr-ghc]}} 55 | - compiler: "ghc-7.2.2" 56 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 57 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.2.2], sources: [hvr-ghc]}} 58 | - compiler: "ghc-7.0.4" 59 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 60 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.0.4], sources: [hvr-ghc]}} 61 | 62 | before_install: 63 | - HC=${CC} 64 | - HCPKG=${HC/ghc/ghc-pkg} 65 | - unset CC 66 | - ROOTDIR=$(pwd) 67 | - mkdir -p $HOME/.local/bin 68 | - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" 69 | - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) 70 | - echo $HCNUMVER 71 | 72 | install: 73 | - cabal --version 74 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 75 | - BENCH=${BENCH---enable-benchmarks} 76 | - TEST=${TEST---enable-tests} 77 | - HADDOCK=${HADDOCK-true} 78 | - UNCONSTRAINED=${UNCONSTRAINED-true} 79 | - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-true} 80 | - GHCHEAD=${GHCHEAD-false} 81 | - travis_retry cabal update -v 82 | - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" 83 | - rm -fv cabal.project cabal.project.local 84 | - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' 85 | - "printf 'packages: \".\"\\n' > cabal.project" 86 | - touch cabal.project.local 87 | - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- hoopl | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi" 88 | - cat cabal.project || true 89 | - cat cabal.project.local || true 90 | - if [ -f "./configure.ac" ]; then 91 | (cd "." && autoreconf -i); 92 | fi 93 | - rm -f cabal.project.freeze 94 | - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all 95 | - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all 96 | - rm -rf .ghc.environment.* "."/dist 97 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 98 | 99 | # Here starts the actual work to be performed for the package under test; 100 | # any command which exits with a non-zero exit code causes the build to fail. 101 | script: 102 | # test that source-distributions can be generated 103 | - (cd "." && cabal sdist) 104 | - mv "."/dist/hoopl-*.tar.gz ${DISTDIR}/ 105 | - cd ${DISTDIR} || false 106 | - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; 107 | - "printf 'packages: hoopl-*/*.cabal\\n' > cabal.project" 108 | - touch cabal.project.local 109 | - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- hoopl | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi" 110 | - cat cabal.project || true 111 | - cat cabal.project.local || true 112 | # this builds all libraries and executables (without tests/benchmarks) 113 | - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all 114 | 115 | # build & run tests, build benchmarks 116 | - cabal new-build -w ${HC} ${TEST} ${BENCH} all 117 | - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi 118 | 119 | # cabal check 120 | - (cd hoopl-* && cabal check) 121 | 122 | # haddock 123 | - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi 124 | 125 | # Build without installed constraints for packages in global-db 126 | - if $UNCONSTRAINED; then rm -f cabal.project.local; echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks all; else echo "Not building without installed constraints"; fi 127 | 128 | # REGENDATA ["-o",".travis.yml","cabal.project"] 129 | # EOF 130 | -------------------------------------------------------------------------------- /testing/Eval.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns , FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, FlexibleContexts #-} 3 | 4 | module Eval (evalProg, ErrorM) where 5 | 6 | import Control.Monad.Except 7 | import qualified Data.Map as M 8 | import Prelude hiding (succ) 9 | 10 | import EvalMonad 11 | import Compiler.Hoopl 12 | import IR 13 | 14 | -- Evaluation functions 15 | evalProg :: EvalTarget v => [Proc] -> [v] -> String -> [v] -> ErrorM (State v, [v]) 16 | evalProg procs vs main args = runProg procs vs $ evalProc main args 17 | 18 | evalProc :: EvalTarget v => String -> [v] -> EvalM v [v] 19 | evalProc proc_name actuals = 20 | do event $ CallEvt proc_name actuals 21 | proc <- get_proc proc_name 22 | evalProc' proc actuals 23 | evalProc' :: EvalTarget v => Proc -> [v] -> EvalM v [v] 24 | evalProc' (Proc {name=_, args, body, entry}) actuals = 25 | if length args == length actuals then 26 | evalBody (M.fromList $ zip args actuals) body entry 27 | else throwError $ "Param/actual mismatch: " ++ show args ++ " = " ++ show actuals 28 | 29 | -- Responsible for allocating and deallocating its own stack frame. 30 | evalBody :: EvalTarget v => VarEnv v -> Graph Insn C C -> Label -> EvalM v [v] 31 | evalBody vars graph entry = inNewFrame vars graph $ get_block entry >>= evalB 32 | 33 | evalB :: forall v . EvalTarget v => Block Insn C C -> EvalM v [v] 34 | evalB b = foldBlockNodesF3 (lift evalF, lift evalM, lift evalL) b $ return () 35 | where 36 | lift :: forall e x y . (Insn e x -> EvalM v y) -> Insn e x -> EvalM v () -> EvalM v y 37 | lift f n z = z >> f n 38 | 39 | 40 | evalF :: EvalTarget v => Insn C O -> EvalM v () 41 | evalF (Label _) = return () 42 | 43 | evalM :: EvalTarget v => Insn O O -> EvalM v () 44 | evalM (Assign var e) = 45 | do v_e <- eval e 46 | set_var var v_e 47 | evalM (Store addr e) = 48 | do v_addr <- eval addr >>= toAddr 49 | v_e <- eval e 50 | -- StoreEvt recorded in set_heap 51 | set_heap v_addr v_e 52 | 53 | evalL :: EvalTarget v => Insn O C -> EvalM v [v] 54 | evalL (Branch bid) = 55 | do b <- get_block bid 56 | evalB b 57 | evalL (Cond e t f) = 58 | do v_e <- eval e >>= toBool 59 | evalL $ Branch $ if v_e then t else f 60 | evalL (Call ress f args succ) = 61 | do v_args <- mapM eval args 62 | -- event is recorded in evalProc 63 | f_ress <- evalProc f v_args 64 | if length ress == length f_ress then return () 65 | else throwError $ "function " ++ f ++ " returned unexpected # of args" 66 | _ <- mapM (uncurry set_var) $ zip ress f_ress 67 | evalL $ Branch succ 68 | evalL (Return es) = 69 | do vs <- mapM eval es 70 | event $ RetEvt vs 71 | return vs 72 | 73 | class Show v => EvalTarget v where 74 | toAddr :: v -> EvalM v Integer 75 | toBool :: v -> EvalM v Bool 76 | eval :: Expr -> EvalM v v 77 | 78 | instance EvalTarget Value where 79 | toAddr (I i) = return i 80 | toAddr (B _) = throwError "conversion to address failed" 81 | toBool (B b) = return b 82 | toBool (I _) = throwError "conversion to bool failed" 83 | eval (Lit (Int i)) = return $ I i 84 | eval (Lit (Bool b)) = return $ B b 85 | eval (Var var) = get_var var 86 | eval (Load addr) = 87 | do v_addr <- eval addr >>= toAddr 88 | get_heap v_addr 89 | eval (Binop bop e1 e2) = 90 | do v1 <- eval e1 91 | v2 <- eval e2 92 | liftBinOp bop v1 v2 93 | where 94 | liftBinOp = liftOp 95 | where liftOp Add = i (+) 96 | liftOp Sub = i (-) 97 | liftOp Mul = i (*) 98 | liftOp Div = i div 99 | liftOp Eq = b (==) 100 | liftOp Ne = b (/=) 101 | liftOp Gt = b (>) 102 | liftOp Lt = b (<) 103 | liftOp Gte = b (>=) 104 | liftOp Lte = b (<=) 105 | i = liftX I fromI 106 | b = liftX B fromB 107 | 108 | liftX :: Monad m => (a -> b) -> (b -> m a) -> (a -> a -> a) -> b -> b -> m b 109 | liftX up dwn = \ op x y -> do v_x <- dwn x 110 | v_y <- dwn y 111 | return $ up $ op v_x v_y 112 | fromI (I x) = return x 113 | fromI (B _) = throwError "fromI: got a B" 114 | 115 | fromB (I _) = throwError "fromB: got an I" 116 | fromB (B x) = return x 117 | 118 | -- I'm under no delusion that the following example is useful, 119 | -- but it demonstrates how the evaluator can use a new kind 120 | -- of evaluator. 121 | instance EvalTarget Integer where 122 | toAddr i = return i 123 | toBool i = return $ i /= 0 124 | eval (Lit (Int i)) = return i 125 | eval (Lit (Bool True)) = return 1 126 | eval (Lit (Bool False)) = return 0 127 | eval (Var var) = get_var var 128 | eval (Load addr) = 129 | do v_addr <- eval addr >>= toAddr 130 | get_heap v_addr 131 | eval (Binop bop e1 e2) = 132 | do v1 <- eval e1 133 | v2 <- eval e2 134 | return $ liftBinOp bop v1 v2 135 | where 136 | liftBinOp = liftOp 137 | where liftOp Add = i (+) 138 | liftOp Sub = i (-) 139 | liftOp Mul = i (*) 140 | liftOp Div = i div 141 | liftOp Eq = b (==) 142 | liftOp Ne = b (/=) 143 | liftOp Gt = b (>) 144 | liftOp Lt = b (<) 145 | liftOp Gte = b (>=) 146 | liftOp Lte = b (<=) 147 | i = id 148 | b opr x y = if opr x y then 1 else 0 149 | 150 | 151 | -- Symbolic evaluation. 152 | -- Hard questions: 153 | -- - how do we get heap addresses? 154 | -- - how do we get conditionals? 155 | -- - how do we compare symbolic expressions? 156 | data Sym = L Lit 157 | | In Integer -- In x indicates a value on entry to the program 158 | | Ld Sym 159 | | BO BinOp Sym Sym 160 | deriving Show 161 | -- sym_vsupply :: [Sym] 162 | -- sym_vsupply = [In n | n <- [0..]] 163 | 164 | instance EvalTarget Sym where 165 | toAddr _ = undefined 166 | toBool _ = undefined 167 | eval (Lit l) = return $ L l 168 | eval (Var var) = get_var var 169 | eval (Load addr) = 170 | do v_addr <- eval addr >>= toAddr 171 | get_heap v_addr 172 | eval (Binop bop e1 e2) = 173 | do v1 <- eval e1 174 | v2 <- eval e2 175 | return $ BO bop v1 v2 176 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/XUtil.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-} 2 | #if __GLASGOW_HASKELL__ >= 709 3 | {-# LANGUAGE Safe #-} 4 | #elif __GLASGOW_HASKELL__ >= 701 5 | {-# LANGUAGE Trustworthy #-} 6 | #endif 7 | 8 | -- | Utilities for clients of Hoopl, not used internally. 9 | 10 | module Compiler.Hoopl.XUtil 11 | ( 12 | -- * Utilities for clients 13 | firstXfer, distributeXfer 14 | , distributeFact, distributeFactBwd 15 | , successorFacts 16 | , joinFacts 17 | , joinOutFacts -- deprecated 18 | , joinMaps 19 | , analyzeAndRewriteFwdBody, analyzeAndRewriteBwdBody 20 | , analyzeAndRewriteFwdOx, analyzeAndRewriteBwdOx 21 | ) 22 | where 23 | 24 | import qualified Data.Map as M 25 | import Data.Maybe 26 | 27 | import Compiler.Hoopl.Collections 28 | import Compiler.Hoopl.Checkpoint 29 | import Compiler.Hoopl.Dataflow 30 | import Compiler.Hoopl.Block 31 | import Compiler.Hoopl.Graph 32 | import Compiler.Hoopl.Label 33 | 34 | ----------------------------------------------------------------------------- 35 | 36 | -- | Forward dataflow analysis and rewriting for the special case of a Body. 37 | -- A set of entry points must be supplied; blocks not reachable from 38 | -- the set are thrown away. 39 | analyzeAndRewriteFwdBody 40 | :: forall m n f entries. (CheckpointMonad m, NonLocal n, LabelsPtr entries) 41 | => FwdPass m n f 42 | -> entries -> Body n -> FactBase f 43 | -> m (Body n, FactBase f) 44 | 45 | -- | Backward dataflow analysis and rewriting for the special case of a Body. 46 | -- A set of entry points must be supplied; blocks not reachable from 47 | -- the set are thrown away. 48 | analyzeAndRewriteBwdBody 49 | :: forall m n f entries. (CheckpointMonad m, NonLocal n, LabelsPtr entries) 50 | => BwdPass m n f 51 | -> entries -> Body n -> FactBase f 52 | -> m (Body n, FactBase f) 53 | 54 | analyzeAndRewriteFwdBody pass en = mapBodyFacts (analyzeAndRewriteFwd pass (JustC en)) 55 | analyzeAndRewriteBwdBody pass en = mapBodyFacts (analyzeAndRewriteBwd pass (JustC en)) 56 | 57 | mapBodyFacts :: (Monad m) 58 | => (Graph n C C -> Fact C f -> m (Graph n C C, Fact C f, MaybeO C f)) 59 | -> (Body n -> FactBase f -> m (Body n, FactBase f)) 60 | -- ^ Internal utility; should not escape 61 | mapBodyFacts anal b f = anal (GMany NothingO b NothingO) f >>= bodyFacts 62 | where -- the type constraint is needed for the pattern match; 63 | -- if it were not, we would use do-notation here. 64 | bodyFacts :: Monad m => (Graph n C C, Fact C f, MaybeO C f) -> m (Body n, Fact C f) 65 | bodyFacts (GMany NothingO body NothingO, fb, NothingO) = return (body, fb) 66 | 67 | {- 68 | Can't write: 69 | 70 | do (GMany NothingO body NothingO, fb, NothingO) <- anal (....) f 71 | return (body, fb) 72 | 73 | because we need an explicit type signature in order to do the GADT 74 | pattern matches on NothingO 75 | -} 76 | 77 | 78 | 79 | -- | Forward dataflow analysis and rewriting for the special case of a 80 | -- graph open at the entry. This special case relieves the client 81 | -- from having to specify a type signature for 'NothingO', which beginners 82 | -- might find confusing and experts might find annoying. 83 | analyzeAndRewriteFwdOx 84 | :: forall m n f x. (CheckpointMonad m, NonLocal n) 85 | => FwdPass m n f -> Graph n O x -> f -> m (Graph n O x, FactBase f, MaybeO x f) 86 | 87 | -- | Backward dataflow analysis and rewriting for the special case of a 88 | -- graph open at the entry. This special case relieves the client 89 | -- from having to specify a type signature for 'NothingO', which beginners 90 | -- might find confusing and experts might find annoying. 91 | analyzeAndRewriteBwdOx 92 | :: forall m n f x. (CheckpointMonad m, NonLocal n) 93 | => BwdPass m n f -> Graph n O x -> Fact x f -> m (Graph n O x, FactBase f, f) 94 | 95 | -- | A value that can be used for the entry point of a graph open at the entry. 96 | noEntries :: MaybeC O Label 97 | noEntries = NothingC 98 | 99 | analyzeAndRewriteFwdOx pass g f = analyzeAndRewriteFwd pass noEntries g f 100 | analyzeAndRewriteBwdOx pass g fb = analyzeAndRewriteBwd pass noEntries g fb >>= strip 101 | where strip :: forall m a b c . Monad m => (a, b, MaybeO O c) -> m (a, b, c) 102 | strip (a, b, JustO c) = return (a, b, c) 103 | 104 | 105 | 106 | 107 | 108 | -- | A utility function so that a transfer function for a first 109 | -- node can be given just a fact; we handle the lookup. This 110 | -- function is planned to be made obsolete by changes in the dataflow 111 | -- interface. 112 | 113 | firstXfer :: NonLocal n => (n C O -> f -> f) -> (n C O -> FactBase f -> f) 114 | firstXfer xfer n fb = xfer n $ fromJust $ lookupFact (entryLabel n) fb 115 | 116 | -- | This utility function handles a common case in which a transfer function 117 | -- produces a single fact out of a last node, which is then distributed 118 | -- over the outgoing edges. 119 | distributeXfer :: NonLocal n 120 | => DataflowLattice f -> (n O C -> f -> f) -> (n O C -> f -> FactBase f) 121 | distributeXfer lattice xfer n f = 122 | mkFactBase lattice [ (l, xfer n f) | l <- successors n ] 123 | 124 | 125 | -- | This utility function handles a common case in which a transfer function 126 | -- for a last node takes the incoming fact unchanged and simply distributes 127 | -- that fact over the outgoing edges. 128 | distributeFact :: NonLocal n => n O C -> f -> FactBase f 129 | distributeFact n f = mapFromList [ (l, f) | l <- successors n ] 130 | -- because the same fact goes out on every edge, 131 | -- there's no need for 'mkFactBase' here. 132 | 133 | -- | This utility function handles a common case in which a backward transfer 134 | -- function takes the incoming fact unchanged and tags it with the node's label. 135 | distributeFactBwd :: NonLocal n => n C O -> f -> FactBase f 136 | distributeFactBwd n f = mapSingleton (entryLabel n) f 137 | 138 | -- | List of (unlabelled) facts from the successors of a last node 139 | successorFacts :: NonLocal n => n O C -> FactBase f -> [f] 140 | successorFacts n fb = [ f | id <- successors n, let Just f = lookupFact id fb ] 141 | 142 | -- | Join a list of facts. 143 | joinFacts :: DataflowLattice f -> Label -> [f] -> f 144 | joinFacts lat inBlock = foldr extend (fact_bot lat) 145 | where extend new old = snd $ fact_join lat inBlock (OldFact old) (NewFact new) 146 | 147 | {-# DEPRECATED joinOutFacts 148 | "should be replaced by 'joinFacts lat l (successorFacts n f)'; as is, it uses the wrong Label" #-} 149 | 150 | joinOutFacts :: (NonLocal node) => DataflowLattice f -> node O C -> FactBase f -> f 151 | joinOutFacts lat n f = foldr join (fact_bot lat) facts 152 | where join (lbl, new) old = snd $ fact_join lat lbl (OldFact old) (NewFact new) 153 | facts = [(s, fromJust fact) | s <- successors n, let fact = lookupFact s f, isJust fact] 154 | 155 | 156 | -- | It's common to represent dataflow facts as a map from variables 157 | -- to some fact about the locations. For these maps, the join 158 | -- operation on the map can be expressed in terms of the join on each 159 | -- element of the codomain: 160 | joinMaps :: Ord k => JoinFun v -> JoinFun (M.Map k v) 161 | joinMaps eltJoin l (OldFact old) (NewFact new) = M.foldrWithKey add (NoChange, old) new 162 | where 163 | add k new_v (ch, joinmap) = 164 | case M.lookup k joinmap of 165 | Nothing -> (SomeChange, M.insert k new_v joinmap) 166 | Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of 167 | (SomeChange, v') -> (SomeChange, M.insert k v' joinmap) 168 | (NoChange, _) -> (ch, joinmap) 169 | 170 | 171 | 172 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/Combinators.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, RankNTypes, LiberalTypeSynonyms, ScopedTypeVariables, GADTs #-} 2 | #if __GLASGOW_HASKELL__ >= 701 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | 6 | module Compiler.Hoopl.Combinators 7 | ( thenFwdRw 8 | , deepFwdRw3, deepFwdRw, iterFwdRw 9 | , thenBwdRw 10 | , deepBwdRw3, deepBwdRw, iterBwdRw 11 | , pairFwd, pairBwd, pairLattice 12 | ) 13 | 14 | where 15 | 16 | import Control.Monad 17 | import Data.Maybe 18 | 19 | import Compiler.Hoopl.Collections 20 | import Compiler.Hoopl.Dataflow 21 | import Compiler.Hoopl.Fuel 22 | import Compiler.Hoopl.Block 23 | import Compiler.Hoopl.Graph (Graph) 24 | import Compiler.Hoopl.Label 25 | 26 | ---------------------------------------------------------------- 27 | 28 | deepFwdRw3 :: FuelMonad m 29 | => (n C O -> f -> m (Maybe (Graph n C O))) 30 | -> (n O O -> f -> m (Maybe (Graph n O O))) 31 | -> (n O C -> f -> m (Maybe (Graph n O C))) 32 | -> (FwdRewrite m n f) 33 | deepFwdRw :: FuelMonad m 34 | => (forall e x . n e x -> f -> m (Maybe (Graph n e x))) -> FwdRewrite m n f 35 | deepFwdRw3 f m l = iterFwdRw $ mkFRewrite3 f m l 36 | deepFwdRw f = deepFwdRw3 f f f 37 | 38 | -- N.B. rw3, rw3', and rw3a are triples of functions. 39 | -- But rw and rw' are single functions. 40 | thenFwdRw :: forall m n f. Monad m 41 | => FwdRewrite m n f 42 | -> FwdRewrite m n f 43 | -> FwdRewrite m n f 44 | thenFwdRw rw3 rw3' = wrapFR2 thenrw rw3 rw3' 45 | where 46 | thenrw :: forall m1 e x t t1. 47 | Monad m1 => 48 | (t -> t1 -> m1 (Maybe (Graph n e x, FwdRewrite m n f))) 49 | -> (t -> t1 -> m1 (Maybe (Graph n e x, FwdRewrite m n f))) 50 | -> t 51 | -> t1 52 | -> m1 (Maybe (Graph n e x, FwdRewrite m n f)) 53 | thenrw rw rw' n f = rw n f >>= fwdRes 54 | where fwdRes Nothing = rw' n f 55 | fwdRes (Just gr) = return $ Just $ fadd_rw rw3' gr 56 | 57 | iterFwdRw :: forall m n f. Monad m 58 | => FwdRewrite m n f 59 | -> FwdRewrite m n f 60 | iterFwdRw rw3 = wrapFR iter rw3 61 | where iter :: forall a m1 m2 e x t. 62 | (Monad m2, Monad m1) => 63 | (t -> a -> m1 (m2 (Graph n e x, FwdRewrite m n f))) 64 | -> t 65 | -> a 66 | -> m1 (m2 (Graph n e x, FwdRewrite m n f)) 67 | iter rw n = (liftM $ liftM $ fadd_rw (iterFwdRw rw3)) . rw n 68 | 69 | -- | Function inspired by 'rew' in the paper 70 | _frewrite_cps :: Monad m 71 | => ((Graph n e x, FwdRewrite m n f) -> m a) 72 | -> m a 73 | -> (forall e x . n e x -> f -> m (Maybe (Graph n e x, FwdRewrite m n f))) 74 | -> n e x 75 | -> f 76 | -> m a 77 | _frewrite_cps j n rw node f = 78 | do mg <- rw node f 79 | case mg of Nothing -> n 80 | Just gr -> j gr 81 | 82 | 83 | 84 | -- | Function inspired by 'add' in the paper 85 | fadd_rw :: Monad m 86 | => FwdRewrite m n f 87 | -> (Graph n e x, FwdRewrite m n f) 88 | -> (Graph n e x, FwdRewrite m n f) 89 | fadd_rw rw2 (g, rw1) = (g, rw1 `thenFwdRw` rw2) 90 | 91 | ---------------------------------------------------------------- 92 | 93 | deepBwdRw3 :: FuelMonad m 94 | => (n C O -> f -> m (Maybe (Graph n C O))) 95 | -> (n O O -> f -> m (Maybe (Graph n O O))) 96 | -> (n O C -> FactBase f -> m (Maybe (Graph n O C))) 97 | -> (BwdRewrite m n f) 98 | deepBwdRw :: FuelMonad m 99 | => (forall e x . n e x -> Fact x f -> m (Maybe (Graph n e x))) 100 | -> BwdRewrite m n f 101 | deepBwdRw3 f m l = iterBwdRw $ mkBRewrite3 f m l 102 | deepBwdRw f = deepBwdRw3 f f f 103 | 104 | 105 | thenBwdRw :: forall m n f. Monad m => BwdRewrite m n f -> BwdRewrite m n f -> BwdRewrite m n f 106 | thenBwdRw rw1 rw2 = wrapBR2 f rw1 rw2 107 | where f :: forall t t1 t2 m1 e x. 108 | Monad m1 => 109 | t 110 | -> (t1 -> t2 -> m1 (Maybe (Graph n e x, BwdRewrite m n f))) 111 | -> (t1 -> t2 -> m1 (Maybe (Graph n e x, BwdRewrite m n f))) 112 | -> t1 113 | -> t2 114 | -> m1 (Maybe (Graph n e x, BwdRewrite m n f)) 115 | f _ rw1 rw2' n f = do 116 | res1 <- rw1 n f 117 | case res1 of 118 | Nothing -> rw2' n f 119 | Just gr -> return $ Just $ badd_rw rw2 gr 120 | 121 | iterBwdRw :: forall m n f. Monad m => BwdRewrite m n f -> BwdRewrite m n f 122 | iterBwdRw rw = wrapBR f rw 123 | where f :: forall t m1 m2 e x t1 t2. 124 | (Monad m2, Monad m1) => 125 | t 126 | -> (t1 -> t2 -> m1 (m2 (Graph n e x, BwdRewrite m n f))) 127 | -> t1 128 | -> t2 129 | -> m1 (m2 (Graph n e x, BwdRewrite m n f)) 130 | f _ rw' n f = liftM (liftM (badd_rw (iterBwdRw rw))) (rw' n f) 131 | 132 | -- | Function inspired by 'add' in the paper 133 | badd_rw :: Monad m 134 | => BwdRewrite m n f 135 | -> (Graph n e x, BwdRewrite m n f) 136 | -> (Graph n e x, BwdRewrite m n f) 137 | badd_rw rw2 (g, rw1) = (g, rw1 `thenBwdRw` rw2) 138 | 139 | 140 | pairFwd :: forall m n f f'. Monad m 141 | => FwdPass m n f 142 | -> FwdPass m n f' 143 | -> FwdPass m n (f, f') 144 | pairFwd pass1 pass2 = FwdPass lattice transfer rewrite 145 | where 146 | lattice = pairLattice (fp_lattice pass1) (fp_lattice pass2) 147 | transfer = mkFTransfer3 (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2) 148 | where 149 | tf :: forall t t1 t2 t3 t4. 150 | (t4 -> t -> t2) -> (t4 -> t1 -> t3) -> t4 -> (t, t1) -> (t2, t3) 151 | tf t1 t2 n (f1, f2) = (t1 n f1, t2 n f2) 152 | tfb t1 t2 n (f1, f2) = mapMapWithKey withfb2 fb1 153 | where fb1 = t1 n f1 154 | fb2 = t2 n f2 155 | withfb2 :: forall t. Label -> t -> (t, f') 156 | withfb2 l f = (f, fromMaybe bot2 $ lookupFact l fb2) 157 | bot2 = fact_bot (fp_lattice pass2) 158 | (tf1, tm1, tl1) = getFTransfer3 (fp_transfer pass1) 159 | (tf2, tm2, tl2) = getFTransfer3 (fp_transfer pass2) 160 | rewrite = lift fst (fp_rewrite pass1) `thenFwdRw` lift snd (fp_rewrite pass2) 161 | where 162 | lift :: forall f m' n' f'. 163 | Monad m' => 164 | (f' -> f) -> FwdRewrite m' n' f -> FwdRewrite m' n' f' 165 | lift proj = wrapFR project 166 | where project :: forall m m1 t t1. 167 | (Monad m1, Monad m) => 168 | (t1 -> f -> m (m1 (t, FwdRewrite m' n' f))) 169 | -> t1 170 | -> f' 171 | -> m (m1 (t, FwdRewrite m' n' f')) 172 | project rw = \n pair -> liftM (liftM repair) $ rw n (proj pair) 173 | repair :: forall t. 174 | (t, FwdRewrite m' n' f) -> (t, FwdRewrite m' n' f') 175 | repair (g, rw') = (g, lift proj rw') 176 | 177 | pairBwd :: forall m n f f' . 178 | Monad m => BwdPass m n f -> BwdPass m n f' -> BwdPass m n (f, f') 179 | pairBwd pass1 pass2 = BwdPass lattice transfer rewrite 180 | where 181 | lattice = pairLattice (bp_lattice pass1) (bp_lattice pass2) 182 | transfer = mkBTransfer3 (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2) 183 | where 184 | tf :: (t4 -> t -> t2) -> (t4 -> t1 -> t3) -> t4 -> (t, t1) -> (t2, t3) 185 | tf t1 t2 n (f1, f2) = (t1 n f1, t2 n f2) 186 | tfb :: IsMap map => 187 | (t2 -> map a -> t) 188 | -> (t2 -> map b -> t1) 189 | -> t2 190 | -> map (a, b) 191 | -> (t, t1) 192 | tfb t1 t2 n fb = (t1 n $ mapMap fst fb, t2 n $ mapMap snd fb) 193 | (tf1, tm1, tl1) = getBTransfer3 (bp_transfer pass1) 194 | (tf2, tm2, tl2) = getBTransfer3 (bp_transfer pass2) 195 | rewrite = lift fst (bp_rewrite pass1) `thenBwdRw` lift snd (bp_rewrite pass2) 196 | where 197 | lift :: forall f1 . 198 | ((f, f') -> f1) -> BwdRewrite m n f1 -> BwdRewrite m n (f, f') 199 | lift proj = wrapBR project 200 | where project :: forall e x . Shape x 201 | -> (n e x -> 202 | Fact x f1 -> m (Maybe (Graph n e x, BwdRewrite m n f1))) 203 | -> (n e x -> 204 | Fact x (f,f') -> m (Maybe (Graph n e x, BwdRewrite m n (f,f')))) 205 | project Open = 206 | \rw n pair -> liftM (liftM repair) $ rw n ( proj pair) 207 | project Closed = 208 | \rw n pair -> liftM (liftM repair) $ rw n (mapMap proj pair) 209 | repair :: forall t. 210 | (t, BwdRewrite m n f1) -> (t, BwdRewrite m n (f, f')) 211 | repair (g, rw') = (g, lift proj rw') 212 | -- XXX specialize repair so that the cost 213 | -- of discriminating is one per combinator not one 214 | -- per rewrite 215 | 216 | pairLattice :: forall f f' . 217 | DataflowLattice f -> DataflowLattice f' -> DataflowLattice (f, f') 218 | pairLattice l1 l2 = 219 | DataflowLattice 220 | { fact_name = fact_name l1 ++ " x " ++ fact_name l2 221 | , fact_bot = (fact_bot l1, fact_bot l2) 222 | , fact_join = join 223 | } 224 | where 225 | join lbl (OldFact (o1, o2)) (NewFact (n1, n2)) = (c', (f1, f2)) 226 | where (c1, f1) = fact_join l1 lbl (OldFact o1) (NewFact n1) 227 | (c2, f2) = fact_join l2 lbl (OldFact o2) (NewFact n2) 228 | c' = case (c1, c2) of 229 | (NoChange, NoChange) -> NoChange 230 | _ -> SomeChange 231 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/MkGraph.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, ScopedTypeVariables, GADTs, TypeSynonymInstances, FlexibleInstances, RankNTypes #-} 2 | #if __GLASGOW_HASKELL__ >= 701 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | 6 | module Compiler.Hoopl.MkGraph 7 | ( AGraph, graphOfAGraph, aGraphOfGraph 8 | , (<*>), (|*><*|), catGraphs, addEntrySeq, addExitSeq, addBlocks, unionBlocks 9 | , emptyGraph, emptyClosedGraph, withFresh 10 | , mkFirst, mkMiddle, mkMiddles, mkLast, mkBranch, mkLabel, mkWhileDo 11 | , IfThenElseable(mkIfThenElse) 12 | , mkEntry, mkExit 13 | , HooplNode(mkLabelNode, mkBranchNode) 14 | ) 15 | where 16 | 17 | import Compiler.Hoopl.Label (Label, uniqueToLbl) 18 | import Compiler.Hoopl.Block 19 | import Compiler.Hoopl.Graph as U 20 | import Compiler.Hoopl.Unique 21 | 22 | import Control.Monad (Monad(..),liftM2) 23 | import Prelude (($),(.),foldr,map) -- for the purpose of 'hiding ((<*>))' 24 | 25 | {-| 26 | As noted in the paper, we can define a single, polymorphic type of 27 | splicing operation with the very polymorphic type 28 | @ 29 | AGraph n e a -> AGraph n a x -> AGraph n e x 30 | @ 31 | However, we feel that this operation is a bit /too/ polymorphic, 32 | and that it's too easy for clients to use it blindly without 33 | thinking. We therfore split it into two operations, '<*>' and '|*><*|', 34 | which are supplemented by other functions: 35 | 36 | * The '<*>' operator is true concatenation, for connecting open graphs. 37 | Control flows from the left graph to the right graph. 38 | 39 | * The '|*><*|' operator splices together two graphs at a closed 40 | point. Nothing is known about control flow. The vertical bar 41 | stands for "closed point" just as the angle brackets above stand 42 | for "open point". Unlike the <*> operator, the |*><*| can create 43 | a control-flow graph with dangling outedges or unreachable blocks. 44 | The operator must be used carefully, so we have chosen a long name 45 | on purpose, to help call people's attention to what they're doing. 46 | 47 | * The operator 'addBlocks' adds a set of basic blocks (represented 48 | as a closed/closed 'AGraph' to an existing graph, without changing 49 | the shape of the existing graph. In some cases, it's necessary to 50 | introduce a branch and a label to 'get around' the blocks added, 51 | so this operator, and other functions based on it, requires a 52 | 'HooplNode' type-class constraint and is available only on AGraph, 53 | not Graph. 54 | 55 | * We have discussed a dynamic assertion about dangling outedges and 56 | unreachable blocks, but nothing is implemented yet. 57 | 58 | -} 59 | 60 | 61 | 62 | class GraphRep g where 63 | -- | An empty graph that is open at entry and exit. 64 | -- It is the left and right identity of '<*>'. 65 | emptyGraph :: g n O O 66 | -- | An empty graph that is closed at entry and exit. 67 | -- It is the left and right identity of '|*><*|'. 68 | emptyClosedGraph :: g n C C 69 | -- | Create a graph from a first node 70 | mkFirst :: n C O -> g n C O 71 | -- | Create a graph from a middle node 72 | mkMiddle :: n O O -> g n O O 73 | -- | Create a graph from a last node 74 | mkLast :: n O C -> g n O C 75 | mkFirst n = mkExit (BlockCO n BNil) 76 | mkLast n = mkEntry (BlockOC BNil n) 77 | infixl 3 <*> 78 | infixl 2 |*><*| 79 | -- | Concatenate two graphs; control flows from left to right. 80 | (<*>) :: NonLocal n => g n e O -> g n O x -> g n e x 81 | -- | Splice together two graphs at a closed point; nothing is known 82 | -- about control flow. 83 | (|*><*|) :: NonLocal n => g n e C -> g n C x -> g n e x 84 | -- | Conveniently concatenate a sequence of open/open graphs using '<*>'. 85 | catGraphs :: NonLocal n => [g n O O] -> g n O O 86 | catGraphs = foldr (<*>) emptyGraph 87 | 88 | -- | Create a graph that defines a label 89 | mkLabel :: HooplNode n => Label -> g n C O -- definition of the label 90 | -- | Create a graph that branches to a label 91 | mkBranch :: HooplNode n => Label -> g n O C -- unconditional branch to the label 92 | 93 | -- | Conveniently concatenate a sequence of middle nodes to form 94 | -- an open/open graph. 95 | mkMiddles :: NonLocal n => [n O O] -> g n O O 96 | 97 | mkLabel id = mkFirst $ mkLabelNode id 98 | mkBranch target = mkLast $ mkBranchNode target 99 | mkMiddles ms = catGraphs $ map mkMiddle ms 100 | 101 | -- | Create a graph containing only an entry sequence 102 | mkEntry :: Block n O C -> g n O C 103 | -- | Create a graph containing only an exit sequence 104 | mkExit :: Block n C O -> g n C O 105 | 106 | instance GraphRep Graph where 107 | emptyGraph = GNil 108 | emptyClosedGraph = GMany NothingO emptyBody NothingO 109 | (<*>) = U.gSplice 110 | (|*><*|) = U.gSplice 111 | mkMiddle = GUnit . BMiddle 112 | mkExit block = GMany NothingO emptyBody (JustO block) 113 | mkEntry block = GMany (JustO block) emptyBody NothingO 114 | 115 | instance GraphRep AGraph where 116 | emptyGraph = aGraphOfGraph emptyGraph 117 | emptyClosedGraph = aGraphOfGraph emptyClosedGraph 118 | (<*>) = liftA2 (<*>) 119 | (|*><*|) = liftA2 (|*><*|) 120 | mkMiddle = aGraphOfGraph . mkMiddle 121 | mkExit = aGraphOfGraph . mkExit 122 | mkEntry = aGraphOfGraph . mkEntry 123 | 124 | 125 | -- | The type of abstract graphs. Offers extra "smart constructors" 126 | -- that may consume fresh labels during construction. 127 | newtype AGraph n e x = 128 | A { graphOfAGraph :: forall m. UniqueMonad m => 129 | m (Graph n e x) -- ^ Take an abstract 'AGraph' 130 | -- and make a concrete (if monadic) 131 | -- 'Graph'. 132 | } 133 | 134 | -- | Take a graph and make it abstract. 135 | aGraphOfGraph :: Graph n e x -> AGraph n e x 136 | aGraphOfGraph g = A (return g) 137 | 138 | 139 | -- | The 'Labels' class defines things that can be lambda-bound 140 | -- by an argument to 'withFreshLabels'. Such an argument may 141 | -- lambda-bind a single 'Label', or if multiple labels are needed, 142 | -- it can bind a tuple. Tuples can be nested, so arbitrarily many 143 | -- fresh labels can be acquired in a single call. 144 | -- 145 | -- For example usage see implementations of 'mkIfThenElse' and 'mkWhileDo'. 146 | class Uniques u where 147 | withFresh :: (u -> AGraph n e x) -> AGraph n e x 148 | 149 | instance Uniques Unique where 150 | withFresh f = A $ freshUnique >>= (graphOfAGraph . f) 151 | 152 | instance Uniques Label where 153 | withFresh f = A $ freshUnique >>= (graphOfAGraph . f . uniqueToLbl) 154 | 155 | -- | Lifts binary 'Graph' functions into 'AGraph' functions. 156 | liftA2 :: (Graph n a b -> Graph n c d -> Graph n e f) 157 | -> (AGraph n a b -> AGraph n c d -> AGraph n e f) 158 | liftA2 f (A g) (A g') = A (liftM2 f g g') 159 | 160 | -- | Extend an existing 'AGraph' with extra basic blocks "out of line". 161 | -- No control flow is implied. Simon PJ should give example use case. 162 | addBlocks :: HooplNode n 163 | => AGraph n e x -> AGraph n C C -> AGraph n e x 164 | addBlocks (A g) (A blocks) = A $ g >>= \g -> blocks >>= add g 165 | where add :: (UniqueMonad m, HooplNode n) 166 | => Graph n e x -> Graph n C C -> m (Graph n e x) 167 | add (GMany e body x) (GMany NothingO body' NothingO) = 168 | return $ GMany e (body `U.bodyUnion` body') x 169 | add g@GNil blocks = spliceOO g blocks 170 | add g@(GUnit _) blocks = spliceOO g blocks 171 | spliceOO :: (HooplNode n, UniqueMonad m) 172 | => Graph n O O -> Graph n C C -> m (Graph n O O) 173 | spliceOO g blocks = graphOfAGraph $ withFresh $ \l -> 174 | A (return g) <*> mkBranch l |*><*| A (return blocks) |*><*| mkLabel l 175 | 176 | -- | For some graph-construction operations and some optimizations, 177 | -- Hoopl must be able to create control-flow edges using a given node 178 | -- type 'n'. 179 | class NonLocal n => HooplNode n where 180 | -- | Create a branch node, the source of a control-flow edge. 181 | mkBranchNode :: Label -> n O C 182 | -- | Create a label node, the target (destination) of a control-flow edge. 183 | mkLabelNode :: Label -> n C O 184 | 185 | -------------------------------------------------------------- 186 | -- Shiny Things 187 | -------------------------------------------------------------- 188 | 189 | class IfThenElseable x where 190 | -- | Translate a high-level if-then-else construct into an 'AGraph'. 191 | -- The condition takes as arguments labels on the true-false branch 192 | -- and returns a single-entry, two-exit graph which exits to 193 | -- the two labels. 194 | mkIfThenElse :: HooplNode n 195 | => (Label -> Label -> AGraph n O C) -- ^ branch condition 196 | -> AGraph n O x -- ^ code in the "then" branch 197 | -> AGraph n O x -- ^ code in the "else" branch 198 | -> AGraph n O x -- ^ resulting if-then-else construct 199 | 200 | mkWhileDo :: HooplNode n 201 | => (Label -> Label -> AGraph n O C) -- ^ loop condition 202 | -> AGraph n O O -- ^ body of the loop 203 | -> AGraph n O O -- ^ the final while loop 204 | 205 | instance IfThenElseable O where 206 | mkIfThenElse cbranch tbranch fbranch = withFresh $ \(endif, ltrue, lfalse) -> 207 | cbranch ltrue lfalse |*><*| 208 | mkLabel ltrue <*> tbranch <*> mkBranch endif |*><*| 209 | mkLabel lfalse <*> fbranch <*> mkBranch endif |*><*| 210 | mkLabel endif 211 | 212 | instance IfThenElseable C where 213 | mkIfThenElse cbranch tbranch fbranch = withFresh $ \(ltrue, lfalse) -> 214 | cbranch ltrue lfalse |*><*| 215 | mkLabel ltrue <*> tbranch |*><*| 216 | mkLabel lfalse <*> fbranch 217 | 218 | mkWhileDo cbranch body = withFresh $ \(test, head, endwhile) -> 219 | -- Forest Baskett's while-loop layout 220 | mkBranch test |*><*| 221 | mkLabel head <*> body <*> mkBranch test |*><*| 222 | mkLabel test <*> cbranch head endwhile |*><*| 223 | mkLabel endwhile 224 | 225 | -------------------------------------------------------------- 226 | -- Boring instance declarations 227 | -------------------------------------------------------------- 228 | 229 | 230 | instance (Uniques u1, Uniques u2) => Uniques (u1, u2) where 231 | withFresh f = withFresh $ \u1 -> 232 | withFresh $ \u2 -> 233 | f (u1, u2) 234 | 235 | instance (Uniques u1, Uniques u2, Uniques u3) => Uniques (u1, u2, u3) where 236 | withFresh f = withFresh $ \u1 -> 237 | withFresh $ \u2 -> 238 | withFresh $ \u3 -> 239 | f (u1, u2, u3) 240 | 241 | instance (Uniques u1, Uniques u2, Uniques u3, Uniques u4) => Uniques (u1, u2, u3, u4) where 242 | withFresh f = withFresh $ \u1 -> 243 | withFresh $ \u2 -> 244 | withFresh $ \u3 -> 245 | withFresh $ \u4 -> 246 | f (u1, u2, u3, u4) 247 | 248 | --------------------------------------------- 249 | -- deprecated legacy functions 250 | 251 | {-# DEPRECATED addEntrySeq, addExitSeq, unionBlocks "use |*><*| instead" #-} 252 | addEntrySeq :: NonLocal n => AGraph n O C -> AGraph n C x -> AGraph n O x 253 | addExitSeq :: NonLocal n => AGraph n e C -> AGraph n C O -> AGraph n e O 254 | unionBlocks :: NonLocal n => AGraph n C C -> AGraph n C C -> AGraph n C C 255 | 256 | addEntrySeq = (|*><*|) 257 | addExitSeq = (|*><*|) 258 | unionBlocks = (|*><*|) 259 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | # Changelog for [`hoopl` package](http://hackage.haskell.org/package/hoopl) 2 | 3 | ## 3.10.2.3 *Mar 2018* 4 | Update for compatibility with GHC 8.4.1 and base-4.11. 5 | 6 | ## 3.10.2.2 *Feb 2017* 7 | This release includes non-API changes. 8 | 9 | - Use cabal builtin options to enable test coverage 10 | 11 | - Move up the constraints of base and containers 12 | 13 | - Refactor the references of the fold family functions to their equivalant foldr functions. 14 | 15 | - Drop the support for 7.0.1 16 | 17 | - Fix a bug that drops out dominators when joined DPATHs have non-shared nodes in the middle. 18 | 19 | 20 | ## 3.10.2.1 *Dec 2015* 21 | This release includes only non-functional changes. 22 | 23 | - Rewrite Applicative/Monad instances into normal-form 24 | 25 | - Relax the upper bound constraint of base to include 4.9 26 | 27 | - Replace `#if CABAL` macro by no CPP at all 28 | 29 | - Wrap redudant wild card pattens in conditional compilation 30 | 31 | - Prefix unused type variables with underscores. 32 | 33 | ## 3.10.2.0 *Aug 2015* 34 | 35 | - Add #if CABAL macro to several hoopl source files such that the Cabal generated macro is not included when building in ghci 36 | 37 | - Change the test code (testing/*) to compare the converted graphs against the expected graphs in AST form 38 | 39 | - Update the cabal file to run tests and generate a test coverage report 40 | 41 | - Unhide gSplice of Hoopl.Graph 42 | 43 | - Expose Showing of Hoopl.Show 44 | 45 | - Some fixes of testing 46 | 47 | ## 3.10.1.0 *Apr 2015* 48 | 49 | - Re-export runWithFuel from Compiler.Hoopl. 50 | 51 | - Remove redundant constraints 52 | 53 | ## 3.10.0.2 *Dec 2014* 54 | 55 | - Add support for `base-4.8.0.0` package version 56 | 57 | - Mark a few modules as Safe rather than Trustworthy 58 | 59 | ## 3.10.0.1 *Mar 2014* 60 | 61 | - Remove UTF8 character from hoopl.cabal to workaround issue 62 | in GHC 7.8.1's build system 63 | 64 | ## 3.10.0.0 *Mar 2014* 65 | 66 | - Bundled with GHC 7.8.1 67 | 68 | - Define `Functor` and `Applicative` instances for 69 | - `SimpleUniqueMonad` 70 | - `CheckingFuelMonad` 71 | - `InfiniteFuelMonad` 72 | - `UniqueMonadT` 73 | - `VM` (not exported) 74 | 75 | - Update to Cabal format 1.10 76 | 77 | ## 3.9.0.0 78 | 79 | Lots of API changes; mainly a new API for working with Blocks 80 | 81 | ### Summary of refactorings: 82 | 83 | - `Compiler.Hoopl.Block` contains the `Block` datatype and all the 84 | operations on Blocks. It seemed like a good idea to collect all 85 | this stuff together in one place. 86 | 87 | - `Compiler.Hoopl.Graph` now has the operations on Graphs. 88 | 89 | - `Compiler.Hoopl.Util` and `Compiler.Hoopl.GraphUtil` are no more; their 90 | contents have been moved to other homes. (and a bit of duplicated 91 | functionality has been removed). 92 | 93 | - I removed the newtypes around `Unique` and `Label`, these are now just 94 | type synonyms. The newtype wrappers were costing some performance in 95 | GHC, because in cases like `mapToList` the newtype isn't optimised away. 96 | 97 | This change might be controversial. Feel free to complain. 98 | 99 | ### Other changes: 100 | 101 | - Optimisations to the Dataflow algorithms. I'm not actually using 102 | this implementation of Dataflow in GHC any more, instead I have a 103 | local copy specialised to our monad, for speed. Nevertheless I've 104 | put some of the optimisations I'm using in the GHC version into the 105 | generic library version too. 106 | 107 | ### Summary of API changes: 108 | 109 | #### Added 110 | 111 | - `IsMap(mapInsertWith, mapFromListWith)` 112 | 113 | - `mapGraphBlocks` 114 | (was previously called `graphMapBlocks`, and not exported) 115 | 116 | - `mapBlock'` 117 | (strict version of `mapBlock`) 118 | 119 | - New API for working with Blocks: 120 | 121 | ```haskell 122 | -- ** Predicates on Blocks 123 | , isEmptyBlock 124 | 125 | -- ** Constructing blocks 126 | , emptyBlock, blockCons, blockSnoc 127 | , blockJoinHead, blockJoinTail, blockJoin, blockJoinAny 128 | , blockAppend 129 | 130 | -- ** Deconstructing blocks 131 | , firstNode, lastNode, endNodes 132 | , blockSplitHead, blockSplitTail, blockSplit, blockSplitAny 133 | 134 | -- ** Modifying blocks 135 | , replaceFirstNode, replaceLastNode 136 | 137 | -- ** Converting to and from lists 138 | , blockToList, blockFromList 139 | 140 | -- ** Maps and folds 141 | , mapBlock, mapBlock', mapBlock3' 142 | , foldBlockNodesF, foldBlockNodesF3 143 | , foldBlockNodesB, foldBlockNodesB3 144 | ``` 145 | 146 | #### Removed 147 | 148 | - `mapMaybeO`, `mapMaybeC` 149 | (no need: we have `Functor` instances) 150 | 151 | - Block constructors are no longer exported 152 | (use the block API instead) 153 | 154 | - `blockToNodeList`, `blockToNodeList'`, `blockToNodeList''`, `blockToNodeList'''` 155 | (use the block API instead) 156 | 157 | - `tfFoldBlock`, `ScottBlock`, `scottFoldBlock`, `fbnf3`, 158 | `BlockResult(..)`, `lookupBlock`, 159 | (I don't know what any of these are for, if they're still important 160 | we could reinstate) 161 | 162 | #### Changed 163 | 164 | - Compiler.Hoopl.GHC is now Compiler.Hoopl.Internals and exports some 165 | more stuff. 166 | 167 | - Label is not a newtype; type Label = Unique 168 | - Unique is not a newtype: type Unique = Int 169 | (these newtypes were adding overhead) 170 | 171 | - blockMapNodes3 is now mapBlock3' 172 | 173 | - Lots of internal refactoring and tidying up 174 | 175 | ## 3.8.7.4 176 | 177 | - Re-export runWithFuel as per Justin Bailey 178 | 179 | ## 3.8.7.3 180 | 181 | - Uploaded to Hackage by Ian Lynagh; appears to contain updates 182 | that use Safe Haskell if GHC >= 7.2 (thanks David Terei) 183 | 184 | ## 3.8.7.2 185 | 186 | - Version changed with no record of update; never uploaded to Hackage 187 | 188 | ## 3.8.7.1 189 | 190 | - Eliminate warning about nonexhaustive pattern match (thanks Edward Yang) 191 | 192 | ## 3.8.7.0 193 | 194 | - Works with GHC 7 (thanks Edward Yang) 195 | - `cabal sdist` now sort of works (and is added to validate) 196 | 197 | ## 3.8.6.0 198 | 199 | - Matches the camera-ready Haskell'10 paper 200 | 201 | ## 3.8.1.0 202 | 203 | - Major reorganization per simonpj visit to Tufts 20 April 2010 204 | Collections 205 | 206 | ## 3.7.13.1 207 | 208 | - Added function to fold over nodes in graph. 209 | 210 | ## 3.7.13.0 211 | 212 | - Pointed type replaces WithTop and WithBot, which are now synonyms. 213 | 214 | ## 3.7.12.3 215 | 216 | ### Interface changes 217 | 218 | The type of AGraph is now abstract. 219 | It is now recommended to create AGraphs with just three functions: 220 | 221 | <*> concatenation 222 | |*><*| splicing at a closed point 223 | addBlocks add C/C blocks out of line 224 | 225 | There are new utility functions in modules Util and XUtil, all 226 | exported by Compiler.Hoopl. Here's a selection: 227 | 228 | -- | A utility function so that a transfer function for a first 229 | -- node can be given just a fact; we handle the lookup. This 230 | -- function is planned to be made obsolete by changes in the dataflow 231 | -- interface. 232 | firstXfer :: Edges n => (n C O -> f -> f) -> (n C O -> FactBase f -> f) 233 | firstXfer xfer n fb = xfer n $ fromJust $ lookupFact fb $ entryLabel n 234 | 235 | -- | This utility function handles a common case in which a transfer function 236 | -- produces a single fact out of a last node, which is then distributed 237 | -- over the outgoing edges. 238 | distributeXfer :: Edges n => (n O C -> f -> f) -> (n O C -> f -> FactBase f) 239 | distributeXfer xfer n f = mkFactBase [ (l, xfer n f) | l <- successors n ] 240 | 241 | -- | This utility function handles a common case in which a transfer function 242 | -- for a last node takes the incoming fact unchanged and simply distributes 243 | -- that fact over the outgoing edges. 244 | distributeFact :: Edges n => n O C -> f -> FactBase f 245 | 246 | -- | Function 'graphMapBlocks' enables a change of representation of blocks, 247 | -- nodes, or both. It lifts a polymorphic block transform into a polymorphic 248 | -- graph transform. When the block representation stabilizes, a similar 249 | -- function should be provided for blocks. 250 | graphMapBlocks :: forall block n block' n' e x . 251 | (forall e x . block n e x -> block' n' e x) 252 | -> (Graph' block n e x -> Graph' block' n' e x) 253 | 254 | postorder_dfs :: Edges (block n) => Graph' block n O x -> [block n C C] 255 | 256 | There are quite a few other variations related to depth-first traversal. 257 | 258 | 259 | There is a new module Compiler.Hoopl.Pointed, which uses GADTs to 260 | enable you to add a Top or Bot element to a lattice, or both, all 261 | using the same type. (Types `WithBot` and `WithTop` in XUtil, 262 | exported by Compiler.Hoopl, do similar jobs, but I think they are 263 | inferior. Your opinion is solicited.) 264 | 265 | I added a function showGraph to print Graphs. Right now it requires a 266 | polymorphic node-showing function as argument. When we change the 267 | Block representation we may get enough static type information that we 268 | can simply have an instance declaration for 269 | 270 | instance (Show n C O, Show n O O, Show n O C) => Show (Graph n e x) 271 | 272 | At present, I don't see how to achieve such a declaration. 273 | 274 | John added new functions `debugFwdJoins` and `debugBwdJoins` to extend 275 | passes with debugging information. 276 | 277 | We added primed versions of the analyzeAndRewrite functions, which 278 | operate on Graph, not Body. Recommended, at least for first-timers. 279 | 280 | Not all maps keyed by Label are FactBases, so there is now a new set 281 | of names of functions to manipulate LabelMaps that do not contain 282 | dataflow facts. 283 | 284 | ### Implementation changes 285 | 286 | Split pass and rewrite-function combinators into Compiler.Hoopl.Combinators. 287 | 288 | Changed order of blocks for forward and backward analysis. 289 | These changes have not been tested, because we don't have a true 290 | regression suite yet. 291 | 292 | Graph and Body types now have more polymorphic variants Graph' and Body'. 293 | 294 | Lots of experiments with zippers. 295 | 296 | ### Changes ahead 297 | 298 | ForwardTransfer will become an abstract type, and clients will have 299 | two ways to create ForwardTransfers: as now, with a single, 300 | polymorphic transfer function; or with a triple of monomorphic 301 | transfer functions. The implementation will use monomorphic 302 | functions, which will enable more useful combinators on passes, 303 | including adding more debugging information and enabling us to combine 304 | passes. 305 | 306 | Perhaps we should provide splicing and `addBlocks` on Graph? 307 | 308 | Change of block representation to have three monomorphic unit 309 | constructors and one polymorphic concatenation constructor. 310 | 311 | Graph body to be represented by a finite map; add functions to check 312 | for duplicate labels. 313 | 314 | ## 3.7.12.1 315 | 316 | - Added a bunch of zipper experiments. 317 | - Existing clients should not be affected. 318 | 319 | ## 3.7.12.0 320 | 321 | - More expressive debugging support 322 | - retract arfGraph and normalization; export analyzeAndRewriterFwd' 323 | 324 | ## 3.7.11.1 325 | 326 | - Expose arfGraph and normalization functions 327 | 328 | ## 3.7.11.0 329 | 330 | - Debugging support 331 | 332 | ## 3.7.8.0 333 | 334 | - Rationalized AGraph splicing functions. 335 | 336 | ## 3.7.7.0 337 | 338 | - Restrict clients so they see much less, including hiding 339 | the value constructors for Body. 340 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/Block.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, GADTs, TypeFamilies, ScopedTypeVariables, RankNTypes #-} 2 | #if __GLASGOW_HASKELL__ >= 701 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | 6 | module Compiler.Hoopl.Block ( 7 | -- * Shapes 8 | O, C 9 | , MaybeO(..), MaybeC(..) 10 | , IndexedCO 11 | , Shape(..) 12 | 13 | -- * Blocks 14 | , Block(..) 15 | 16 | -- ** Predicates on Blocks 17 | , isEmptyBlock 18 | 19 | -- ** Constructing blocks 20 | , emptyBlock, blockCons, blockSnoc 21 | , blockJoinHead, blockJoinTail, blockJoin, blockJoinAny 22 | , blockAppend 23 | 24 | -- ** Deconstructing blocks 25 | , firstNode, lastNode, endNodes 26 | , blockSplitHead, blockSplitTail, blockSplit, blockSplitAny 27 | 28 | -- ** Modifying blocks 29 | , replaceFirstNode, replaceLastNode 30 | 31 | -- ** Converting to and from lists 32 | , blockToList, blockFromList 33 | 34 | -- ** Maps and folds 35 | , mapBlock, mapBlock', mapBlock3' 36 | , foldBlockNodesF, foldBlockNodesF3 37 | , foldBlockNodesB, foldBlockNodesB3 38 | 39 | -- ** Biasing 40 | , frontBiasBlock, backBiasBlock 41 | 42 | ) where 43 | 44 | 45 | -- ----------------------------------------------------------------------------- 46 | -- Shapes: Open and Closed 47 | 48 | -- | Used at the type level to indicate an "open" structure with 49 | -- a unique, unnamed control-flow edge flowing in or out. 50 | -- "Fallthrough" and concatenation are permitted at an open point. 51 | data O 52 | 53 | -- | Used at the type level to indicate a "closed" structure which 54 | -- supports control transfer only through the use of named 55 | -- labels---no "fallthrough" is permitted. The number of control-flow 56 | -- edges is unconstrained. 57 | data C 58 | 59 | -- | Either type indexed by closed/open using type families 60 | type family IndexedCO ex a b :: * 61 | type instance IndexedCO C a _b = a 62 | type instance IndexedCO O _a b = b 63 | 64 | -- | Maybe type indexed by open/closed 65 | data MaybeO ex t where 66 | JustO :: t -> MaybeO O t 67 | NothingO :: MaybeO C t 68 | 69 | -- | Maybe type indexed by closed/open 70 | data MaybeC ex t where 71 | JustC :: t -> MaybeC C t 72 | NothingC :: MaybeC O t 73 | 74 | 75 | instance Functor (MaybeO ex) where 76 | fmap _ NothingO = NothingO 77 | fmap f (JustO a) = JustO (f a) 78 | 79 | instance Functor (MaybeC ex) where 80 | fmap _ NothingC = NothingC 81 | fmap f (JustC a) = JustC (f a) 82 | 83 | 84 | -- | Dynamic shape value 85 | data Shape ex where 86 | Closed :: Shape C 87 | Open :: Shape O 88 | 89 | 90 | -- ----------------------------------------------------------------------------- 91 | -- The Block type 92 | 93 | -- | A sequence of nodes. May be any of four shapes (O/O, O/C, C/O, C/C). 94 | -- Open at the entry means single entry, mutatis mutandis for exit. 95 | -- A closed/closed block is a /basic/ block and can't be extended further. 96 | -- Clients should avoid manipulating blocks and should stick to either nodes 97 | -- or graphs. 98 | data Block n e x where 99 | BlockCO :: n C O -> Block n O O -> Block n C O 100 | BlockCC :: n C O -> Block n O O -> n O C -> Block n C C 101 | BlockOC :: Block n O O -> n O C -> Block n O C 102 | 103 | BNil :: Block n O O 104 | BMiddle :: n O O -> Block n O O 105 | BCat :: Block n O O -> Block n O O -> Block n O O 106 | BSnoc :: Block n O O -> n O O -> Block n O O 107 | BCons :: n O O -> Block n O O -> Block n O O 108 | 109 | 110 | -- ----------------------------------------------------------------------------- 111 | -- Simple operations on Blocks 112 | 113 | -- Predicates 114 | 115 | isEmptyBlock :: Block n e x -> Bool 116 | isEmptyBlock BNil = True 117 | isEmptyBlock (BCat l r) = isEmptyBlock l && isEmptyBlock r 118 | isEmptyBlock _ = False 119 | 120 | 121 | -- Building 122 | 123 | emptyBlock :: Block n O O 124 | emptyBlock = BNil 125 | 126 | blockCons :: n O O -> Block n O x -> Block n O x 127 | blockCons n b = case b of 128 | BlockOC b l -> (BlockOC $! (n `blockCons` b)) l 129 | BNil{} -> BMiddle n 130 | BMiddle{} -> n `BCons` b 131 | BCat{} -> n `BCons` b 132 | BSnoc{} -> n `BCons` b 133 | BCons{} -> n `BCons` b 134 | 135 | blockSnoc :: Block n e O -> n O O -> Block n e O 136 | blockSnoc b n = case b of 137 | BlockCO f b -> BlockCO f $! (b `blockSnoc` n) 138 | BNil{} -> BMiddle n 139 | BMiddle{} -> b `BSnoc` n 140 | BCat{} -> b `BSnoc` n 141 | BSnoc{} -> b `BSnoc` n 142 | BCons{} -> b `BSnoc` n 143 | 144 | blockJoinHead :: n C O -> Block n O x -> Block n C x 145 | blockJoinHead f (BlockOC b l) = BlockCC f b l 146 | blockJoinHead f b = BlockCO f BNil `cat` b 147 | 148 | blockJoinTail :: Block n e O -> n O C -> Block n e C 149 | blockJoinTail (BlockCO f b) t = BlockCC f b t 150 | blockJoinTail b t = b `cat` BlockOC BNil t 151 | 152 | blockJoin :: n C O -> Block n O O -> n O C -> Block n C C 153 | blockJoin f b t = BlockCC f b t 154 | 155 | blockAppend :: Block n e O -> Block n O x -> Block n e x 156 | blockAppend = cat 157 | 158 | 159 | -- Taking apart 160 | 161 | firstNode :: Block n C x -> n C O 162 | firstNode (BlockCO n _) = n 163 | firstNode (BlockCC n _ _) = n 164 | 165 | lastNode :: Block n x C -> n O C 166 | lastNode (BlockOC _ n) = n 167 | lastNode (BlockCC _ _ n) = n 168 | 169 | endNodes :: Block n C C -> (n C O, n O C) 170 | endNodes (BlockCC f _ l) = (f,l) 171 | 172 | blockSplitHead :: Block n C x -> (n C O, Block n O x) 173 | blockSplitHead (BlockCO n b) = (n, b) 174 | blockSplitHead (BlockCC n b t) = (n, BlockOC b t) 175 | 176 | blockSplitTail :: Block n e C -> (Block n e O, n O C) 177 | blockSplitTail (BlockOC b n) = (b, n) 178 | blockSplitTail (BlockCC f b t) = (BlockCO f b, t) 179 | 180 | -- | Split a closed block into its entry node, open middle block, and 181 | -- exit node. 182 | blockSplit :: Block n C C -> (n C O, Block n O O, n O C) 183 | blockSplit (BlockCC f b t) = (f, b, t) 184 | 185 | blockSplitAny :: Block n e x 186 | -> (MaybeC e (n C O), Block n O O, MaybeC x (n O C)) 187 | blockSplitAny block = case block of 188 | BlockCO f b -> (JustC f, b, NothingC) 189 | BlockCC f b l -> (JustC f, b, JustC l) 190 | BlockOC b l -> (NothingC, b, JustC l) 191 | b@BNil -> (NothingC, b, NothingC) 192 | b@BMiddle{} -> (NothingC, b, NothingC) 193 | b@BCat{} -> (NothingC, b, NothingC) 194 | b@BCons{} -> (NothingC, b, NothingC) 195 | b@BSnoc{} -> (NothingC, b, NothingC) 196 | 197 | blockToList :: Block n O O -> [n O O] 198 | blockToList b = go b [] 199 | where go :: Block n O O -> [n O O] -> [n O O] 200 | go BNil r = r 201 | go (BMiddle n) r = n : r 202 | go (BCat b1 b2) r = go b1 $! go b2 r 203 | go (BSnoc b1 n) r = go b1 (n:r) 204 | go (BCons n b1) r = n : go b1 r 205 | 206 | blockFromList :: [n O O] -> Block n O O 207 | blockFromList = foldr BCons BNil 208 | 209 | 210 | -- | Convert a list of nodes to a block. The entry and exit node must 211 | -- or must not be present depending on the shape of the block. 212 | -- 213 | blockJoinAny :: (MaybeC e (n C O), Block n O O, MaybeC x (n O C)) -> Block n e x 214 | blockJoinAny (NothingC, m, NothingC) = m 215 | blockJoinAny (NothingC, m, JustC l) = BlockOC m l 216 | blockJoinAny (JustC f, m, NothingC) = BlockCO f m 217 | blockJoinAny (JustC f, m, JustC l) = BlockCC f m l 218 | 219 | 220 | -- Modifying 221 | 222 | replaceFirstNode :: Block n C x -> n C O -> Block n C x 223 | replaceFirstNode (BlockCO _ b) f = BlockCO f b 224 | replaceFirstNode (BlockCC _ b n) f = BlockCC f b n 225 | 226 | replaceLastNode :: Block n x C -> n O C -> Block n x C 227 | replaceLastNode (BlockOC b _) n = BlockOC b n 228 | replaceLastNode (BlockCC l b _) n = BlockCC l b n 229 | 230 | 231 | -- ----------------------------------------------------------------------------- 232 | -- General concatenation 233 | 234 | cat :: Block n e O -> Block n O x -> Block n e x 235 | cat x y = case x of 236 | BNil -> y 237 | 238 | BlockCO l b1 -> case y of 239 | BlockOC b2 n -> (BlockCC l $! (b1 `cat` b2)) n 240 | BNil -> x 241 | BMiddle _ -> BlockCO l $! (b1 `cat` y) 242 | BCat{} -> BlockCO l $! (b1 `cat` y) 243 | BSnoc{} -> BlockCO l $! (b1 `cat` y) 244 | BCons{} -> BlockCO l $! (b1 `cat` y) 245 | 246 | BMiddle n -> case y of 247 | BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2 248 | BNil -> x 249 | BMiddle{} -> BCons n y 250 | BCat{} -> BCons n y 251 | BSnoc{} -> BCons n y 252 | BCons{} -> BCons n y 253 | 254 | BCat{} -> case y of 255 | BlockOC b3 n2 -> (BlockOC $! (x `cat` b3)) n2 256 | BNil -> x 257 | BMiddle n -> BSnoc x n 258 | BCat{} -> BCat x y 259 | BSnoc{} -> BCat x y 260 | BCons{} -> BCat x y 261 | 262 | BSnoc{} -> case y of 263 | BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2 264 | BNil -> x 265 | BMiddle n -> BSnoc x n 266 | BCat{} -> BCat x y 267 | BSnoc{} -> BCat x y 268 | BCons{} -> BCat x y 269 | 270 | 271 | BCons{} -> case y of 272 | BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2 273 | BNil -> x 274 | BMiddle n -> BSnoc x n 275 | BCat{} -> BCat x y 276 | BSnoc{} -> BCat x y 277 | BCons{} -> BCat x y 278 | 279 | 280 | -- ----------------------------------------------------------------------------- 281 | -- Mapping 282 | 283 | -- | map a function over the nodes of a 'Block' 284 | mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x 285 | mapBlock f (BlockCO n b ) = BlockCO (f n) (mapBlock f b) 286 | mapBlock f (BlockOC b n) = BlockOC (mapBlock f b) (f n) 287 | mapBlock f (BlockCC n b m) = BlockCC (f n) (mapBlock f b) (f m) 288 | mapBlock _ BNil = BNil 289 | mapBlock f (BMiddle n) = BMiddle (f n) 290 | mapBlock f (BCat b1 b2) = BCat (mapBlock f b1) (mapBlock f b2) 291 | mapBlock f (BSnoc b n) = BSnoc (mapBlock f b) (f n) 292 | mapBlock f (BCons n b) = BCons (f n) (mapBlock f b) 293 | 294 | -- | A strict 'mapBlock' 295 | mapBlock' :: (forall e x. n e x -> n' e x) -> (Block n e x -> Block n' e x) 296 | mapBlock' f = mapBlock3' (f, f, f) 297 | 298 | -- | map over a block, with different functions to apply to first nodes, 299 | -- middle nodes and last nodes respectively. The map is strict. 300 | -- 301 | mapBlock3' :: forall n n' e x . 302 | ( n C O -> n' C O 303 | , n O O -> n' O O, 304 | n O C -> n' O C) 305 | -> Block n e x -> Block n' e x 306 | mapBlock3' (f, m, l) b = go b 307 | where go :: forall e x . Block n e x -> Block n' e x 308 | go (BlockOC b y) = (BlockOC $! go b) $! l y 309 | go (BlockCO x b) = (BlockCO $! f x) $! (go b) 310 | go (BlockCC x b y) = ((BlockCC $! f x) $! go b) $! (l y) 311 | go BNil = BNil 312 | go (BMiddle n) = BMiddle $! m n 313 | go (BCat x y) = (BCat $! go x) $! (go y) 314 | go (BSnoc x n) = (BSnoc $! go x) $! (m n) 315 | go (BCons n x) = (BCons $! m n) $! (go x) 316 | 317 | -- ----------------------------------------------------------------------------- 318 | -- Folding 319 | 320 | 321 | -- | Fold a function over every node in a block, forward or backward. 322 | -- The fold function must be polymorphic in the shape of the nodes. 323 | foldBlockNodesF3 :: forall n a b c . 324 | ( n C O -> a -> b 325 | , n O O -> b -> b 326 | , n O C -> b -> c) 327 | -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b) 328 | foldBlockNodesF :: forall n a . 329 | (forall e x . n e x -> a -> a) 330 | -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a) 331 | foldBlockNodesB3 :: forall n a b c . 332 | ( n C O -> b -> c 333 | , n O O -> b -> b 334 | , n O C -> a -> b) 335 | -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b) 336 | foldBlockNodesB :: forall n a . 337 | (forall e x . n e x -> a -> a) 338 | -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a) 339 | 340 | foldBlockNodesF3 (ff, fm, fl) = block 341 | where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b 342 | block (BlockCO f b ) = ff f `cat` block b 343 | block (BlockCC f b l) = ff f `cat` block b `cat` fl l 344 | block (BlockOC b l) = block b `cat` fl l 345 | block BNil = id 346 | block (BMiddle node) = fm node 347 | block (b1 `BCat` b2) = block b1 `cat` block b2 348 | block (b1 `BSnoc` n) = block b1 `cat` fm n 349 | block (n `BCons` b2) = fm n `cat` block b2 350 | cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c 351 | cat f f' = f' . f 352 | 353 | foldBlockNodesF f = foldBlockNodesF3 (f, f, f) 354 | 355 | foldBlockNodesB3 (ff, fm, fl) = block 356 | where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b 357 | block (BlockCO f b ) = ff f `cat` block b 358 | block (BlockCC f b l) = ff f `cat` block b `cat` fl l 359 | block (BlockOC b l) = block b `cat` fl l 360 | block BNil = id 361 | block (BMiddle node) = fm node 362 | block (b1 `BCat` b2) = block b1 `cat` block b2 363 | block (b1 `BSnoc` n) = block b1 `cat` fm n 364 | block (n `BCons` b2) = fm n `cat` block b2 365 | cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c 366 | cat f f' = f . f' 367 | 368 | foldBlockNodesB f = foldBlockNodesB3 (f, f, f) 369 | 370 | 371 | ---------------------------------------------------------------- 372 | 373 | -- | A block is "front biased" if the left child of every 374 | -- concatenation operation is a node, not a general block; a 375 | -- front-biased block is analogous to an ordinary list. If a block is 376 | -- front-biased, then its nodes can be traversed from front to back 377 | -- without general recursion; tail recursion suffices. Not all shapes 378 | -- can be front-biased; a closed/open block is inherently back-biased. 379 | 380 | frontBiasBlock :: Block n e x -> Block n e x 381 | frontBiasBlock blk = case blk of 382 | BlockCO f b -> BlockCO f (fb b BNil) 383 | BlockOC b n -> BlockOC (fb b BNil) n 384 | BlockCC f b n -> BlockCC f (fb b BNil) n 385 | b@BNil{} -> fb b BNil 386 | b@BMiddle{} -> fb b BNil 387 | b@BCat{} -> fb b BNil 388 | b@BSnoc{} -> fb b BNil 389 | b@BCons{} -> fb b BNil 390 | where 391 | fb :: Block n O O -> Block n O O -> Block n O O 392 | fb BNil rest = rest 393 | fb (BMiddle n) rest = BCons n rest 394 | fb (BCat l r) rest = fb l (fb r rest) 395 | fb (BCons n b) rest = BCons n (fb b rest) 396 | fb (BSnoc b n) rest = fb b (BCons n rest) 397 | 398 | -- | A block is "back biased" if the right child of every 399 | -- concatenation operation is a node, not a general block; a 400 | -- back-biased block is analogous to a snoc-list. If a block is 401 | -- back-biased, then its nodes can be traversed from back to back 402 | -- without general recursion; tail recursion suffices. Not all shapes 403 | -- can be back-biased; an open/closed block is inherently front-biased. 404 | 405 | backBiasBlock :: Block n e x -> Block n e x 406 | backBiasBlock blk = case blk of 407 | BlockCO f b -> BlockCO f (bb BNil b) 408 | BlockOC b n -> BlockOC (bb BNil b) n 409 | BlockCC f b n -> BlockCC f (bb BNil b) n 410 | b@BNil{} -> bb BNil b 411 | b@BMiddle{} -> bb BNil b 412 | b@BCat{} -> bb BNil b 413 | b@BSnoc{} -> bb BNil b 414 | b@BCons{} -> bb BNil b 415 | where 416 | bb :: Block n O O -> Block n O O -> Block n O O 417 | bb rest BNil = rest 418 | bb rest (BMiddle n) = BSnoc rest n 419 | bb rest (BCat l r) = bb (bb rest l) r 420 | bb rest (BCons n b) = bb (BSnoc rest n) b 421 | bb rest (BSnoc b n) = BSnoc (bb rest b) n 422 | -------------------------------------------------------------------------------- /src/Compiler/Hoopl/Graph.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, GADTs, TypeFamilies, ScopedTypeVariables, 2 | RankNTypes, FlexibleInstances, TypeSynonymInstances #-} 3 | #if __GLASGOW_HASKELL__ >= 701 4 | {-# LANGUAGE Safe #-} 5 | #endif 6 | #if __GLASGOW_HASKELL__ < 701 7 | {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} 8 | #endif 9 | 10 | module Compiler.Hoopl.Graph 11 | ( 12 | -- * Body 13 | Body, Body', emptyBody, bodyList, addBlock, bodyUnion 14 | 15 | -- * Graph 16 | , Graph, Graph'(..) 17 | , NonLocal(entryLabel, successors) 18 | 19 | -- ** Constructing graphs 20 | , bodyGraph 21 | , blockGraph 22 | , gUnitOO, gUnitOC, gUnitCO, gUnitCC 23 | , catGraphNodeOC, catGraphNodeOO 24 | , catNodeCOGraph, catNodeOOGraph 25 | 26 | -- ** Splicing graphs 27 | , splice, gSplice 28 | 29 | -- ** Maps 30 | , mapGraph, mapGraphBlocks 31 | 32 | -- ** Folds 33 | , foldGraphNodes 34 | 35 | -- ** Extracting Labels 36 | , labelsDefined, labelsUsed, externalEntryLabels 37 | 38 | -- ** Depth-first traversals 39 | , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except 40 | , preorder_dfs, preorder_dfs_from_except 41 | , LabelsPtr(..) 42 | ) 43 | where 44 | 45 | import Compiler.Hoopl.Collections 46 | import Compiler.Hoopl.Block 47 | import Compiler.Hoopl.Label 48 | 49 | import Control.Applicative as AP (Applicative(..)) 50 | import Control.Monad (ap,liftM,liftM2) 51 | 52 | -- ----------------------------------------------------------------------------- 53 | -- Body 54 | 55 | -- | A (possibly empty) collection of closed/closed blocks 56 | type Body n = LabelMap (Block n C C) 57 | 58 | -- | @Body@ abstracted over @block@ 59 | type Body' block (n :: * -> * -> *) = LabelMap (block n C C) 60 | 61 | emptyBody :: Body' block n 62 | emptyBody = mapEmpty 63 | 64 | bodyUnion :: forall a . LabelMap a -> LabelMap a -> LabelMap a 65 | bodyUnion = mapUnionWithKey nodups 66 | where nodups l _ _ = error $ "duplicate blocks with label " ++ show l 67 | 68 | bodyList :: Body' block n -> [(Label,block n C C)] 69 | bodyList body = mapToList body 70 | 71 | addBlock :: NonLocal thing 72 | => thing C C -> LabelMap (thing C C) 73 | -> LabelMap (thing C C) 74 | addBlock b body 75 | | mapMember lbl body = error $ "duplicate label " ++ show lbl ++ " in graph" 76 | | otherwise = mapInsert lbl b body 77 | where lbl = entryLabel b 78 | 79 | 80 | -- --------------------------------------------------------------------------- 81 | -- Graph 82 | 83 | -- | A control-flow graph, which may take any of four shapes (O/O, 84 | -- O/C, C/O, C/C). A graph open at the entry has a single, 85 | -- distinguished, anonymous entry point; if a graph is closed at the 86 | -- entry, its entry point(s) are supplied by a context. 87 | type Graph = Graph' Block 88 | 89 | -- | @Graph'@ is abstracted over the block type, so that we can build 90 | -- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow 91 | -- needs this). 92 | data Graph' block (n :: * -> * -> *) e x where 93 | GNil :: Graph' block n O O 94 | GUnit :: block n O O -> Graph' block n O O 95 | GMany :: MaybeO e (block n O C) 96 | -> Body' block n 97 | -> MaybeO x (block n C O) 98 | -> Graph' block n e x 99 | 100 | ------------------------------- 101 | -- | Gives access to the anchor points for 102 | -- nonlocal edges as well as the edges themselves 103 | class NonLocal thing where 104 | entryLabel :: thing C x -> Label -- ^ The label of a first node or block 105 | successors :: thing e C -> [Label] -- ^ Gives control-flow successors 106 | 107 | instance NonLocal n => NonLocal (Block n) where 108 | entryLabel (BlockCO f _) = entryLabel f 109 | entryLabel (BlockCC f _ _) = entryLabel f 110 | 111 | successors (BlockOC _ n) = successors n 112 | successors (BlockCC _ _ n) = successors n 113 | 114 | 115 | -- ----------------------------------------------------------------------------- 116 | -- Constructing graphs 117 | 118 | bodyGraph :: Body n -> Graph n C C 119 | bodyGraph b = GMany NothingO b NothingO 120 | 121 | gUnitOO :: block n O O -> Graph' block n O O 122 | gUnitOC :: block n O C -> Graph' block n O C 123 | gUnitCO :: block n C O -> Graph' block n C O 124 | gUnitCC :: NonLocal (block n) => block n C C -> Graph' block n C C 125 | gUnitOO b = GUnit b 126 | gUnitOC b = GMany (JustO b) emptyBody NothingO 127 | gUnitCO b = GMany NothingO emptyBody (JustO b) 128 | gUnitCC b = GMany NothingO (addBlock b emptyBody) NothingO 129 | 130 | 131 | catGraphNodeOO :: Graph n e O -> n O O -> Graph n e O 132 | catGraphNodeOC :: NonLocal n => Graph n e O -> n O C -> Graph n e C 133 | catNodeOOGraph :: n O O -> Graph n O x -> Graph n O x 134 | catNodeCOGraph :: NonLocal n => n C O -> Graph n O x -> Graph n C x 135 | 136 | catGraphNodeOO GNil n = gUnitOO $ BMiddle n 137 | catGraphNodeOO (GUnit b) n = gUnitOO $ BSnoc b n 138 | catGraphNodeOO (GMany e body (JustO (BlockCO f b))) n 139 | = GMany e body (JustO (BlockCO f (BSnoc b n))) 140 | 141 | catGraphNodeOC GNil n = gUnitOC $ BlockOC BNil n 142 | catGraphNodeOC (GUnit b) n = gUnitOC $ BlockOC b n 143 | catGraphNodeOC (GMany e body (JustO (BlockCO f x))) n 144 | = GMany e (addBlock (BlockCC f x n) body) NothingO 145 | 146 | catNodeOOGraph n GNil = gUnitOO $ BMiddle n 147 | catNodeOOGraph n (GUnit b) = gUnitOO $ BCons n b 148 | catNodeOOGraph n (GMany (JustO (BlockOC b l)) body x) 149 | = GMany (JustO (BlockOC (n `BCons` b) l)) body x 150 | 151 | catNodeCOGraph f GNil = gUnitCO (BlockCO f BNil) 152 | catNodeCOGraph f (GUnit b) = gUnitCO (BlockCO f b) 153 | catNodeCOGraph f (GMany (JustO (BlockOC b n)) body x) 154 | = GMany NothingO (addBlock (BlockCC f b n) body) x 155 | 156 | 157 | blockGraph :: NonLocal n => Block n e x -> Graph n e x 158 | blockGraph b@(BlockCO {}) = gUnitCO b 159 | blockGraph b@(BlockOC {}) = gUnitOC b 160 | blockGraph b@(BlockCC {}) = gUnitCC b 161 | blockGraph (BNil {}) = GNil 162 | blockGraph b@(BMiddle {}) = gUnitOO b 163 | blockGraph b@(BCat {}) = gUnitOO b 164 | blockGraph b@(BSnoc {}) = gUnitOO b 165 | blockGraph b@(BCons {}) = gUnitOO b 166 | 167 | 168 | -- ----------------------------------------------------------------------------- 169 | -- Splicing graphs 170 | 171 | splice :: forall block n e a x . NonLocal (block n) => 172 | (forall e x . block n e O -> block n O x -> block n e x) 173 | -> (Graph' block n e a -> Graph' block n a x -> Graph' block n e x) 174 | 175 | splice bcat = sp 176 | where sp :: forall e a x . 177 | Graph' block n e a -> Graph' block n a x -> Graph' block n e x 178 | 179 | sp GNil g2 = g2 180 | sp g1 GNil = g1 181 | 182 | sp (GUnit b1) (GUnit b2) = {-# SCC "sp1" #-} GUnit $! b1 `bcat` b2 183 | 184 | sp (GUnit b) (GMany (JustO e) bs x) = {-# SCC "sp2" #-} GMany (JustO (b `bcat` e)) bs x 185 | 186 | sp (GMany e bs (JustO x)) (GUnit b2) = {-# SCC "sp3" #-} x `seq` GMany e bs (JustO x') 187 | where x' = x `bcat` b2 188 | 189 | sp (GMany e1 bs1 (JustO x1)) (GMany (JustO e2) b2 x2) 190 | = {-# SCC "sp4" #-} (GMany e1 $! b1 `bodyUnion` b2) x2 191 | where b1 = (addBlock $! x1 `bcat` e2) bs1 192 | 193 | sp (GMany e1 b1 NothingO) (GMany NothingO b2 x2) 194 | = {-# SCC "sp5" #-} (GMany e1 $! b1 `bodyUnion` b2) x2 195 | 196 | #if __GLASGOW_HASKELL__ < 711 197 | sp _ _ = error "bogus GADT match failure" 198 | #endif 199 | 200 | gSplice :: NonLocal n => Graph n e a -> Graph n a x -> Graph n e x 201 | gSplice = splice blockAppend 202 | 203 | 204 | -- ----------------------------------------------------------------------------- 205 | -- Mapping over graphs 206 | 207 | -- | Maps over all nodes in a graph. 208 | mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x 209 | mapGraph f = mapGraphBlocks (mapBlock f) 210 | 211 | -- | Function 'mapGraphBlocks' enables a change of representation of blocks, 212 | -- nodes, or both. It lifts a polymorphic block transform into a polymorphic 213 | -- graph transform. When the block representation stabilizes, a similar 214 | -- function should be provided for blocks. 215 | mapGraphBlocks :: forall block n block' n' e x . 216 | (forall e x . block n e x -> block' n' e x) 217 | -> (Graph' block n e x -> Graph' block' n' e x) 218 | 219 | mapGraphBlocks f = map 220 | where map :: Graph' block n e x -> Graph' block' n' e x 221 | map GNil = GNil 222 | map (GUnit b) = GUnit (f b) 223 | map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x) 224 | 225 | 226 | -- ----------------------------------------------------------------------------- 227 | -- Folds 228 | 229 | -- | Fold a function over every node in a graph. 230 | -- The fold function must be polymorphic in the shape of the nodes. 231 | 232 | foldGraphNodes :: forall n a . 233 | (forall e x . n e x -> a -> a) 234 | -> (forall e x . Graph n e x -> a -> a) 235 | 236 | foldGraphNodes f = graph 237 | where graph :: forall e x . Graph n e x -> a -> a 238 | lift :: forall thing ex . (thing -> a -> a) -> (MaybeO ex thing -> a -> a) 239 | 240 | graph GNil = id 241 | graph (GUnit b) = block b 242 | graph (GMany e b x) = lift block e . body b . lift block x 243 | body :: Body n -> a -> a 244 | body bdy = \a -> mapFold block a bdy 245 | lift _ NothingO = id 246 | lift f (JustO thing) = f thing 247 | 248 | block :: Block n e x -> IndexedCO e a a -> IndexedCO x a a 249 | block = foldBlockNodesF f 250 | 251 | 252 | ---------------------------------------------------------------- 253 | 254 | class LabelsPtr l where 255 | targetLabels :: l -> [Label] 256 | 257 | instance NonLocal n => LabelsPtr (n e C) where 258 | targetLabels n = successors n 259 | 260 | instance LabelsPtr Label where 261 | targetLabels l = [l] 262 | 263 | instance LabelsPtr LabelSet where 264 | targetLabels = setElems 265 | 266 | instance LabelsPtr l => LabelsPtr [l] where 267 | targetLabels = concatMap targetLabels 268 | 269 | 270 | -- | Traversal: 'postorder_dfs' returns a list of blocks reachable 271 | -- from the entry of enterable graph. The entry and exit are *not* included. 272 | -- The list has the following property: 273 | -- 274 | -- Say a "back reference" exists if one of a block's 275 | -- control-flow successors precedes it in the output list 276 | -- 277 | -- Then there are as few back references as possible 278 | -- 279 | -- The output is suitable for use in 280 | -- a forward dataflow problem. For a backward problem, simply reverse 281 | -- the list. ('postorder_dfs' is sufficiently tricky to implement that 282 | -- one doesn't want to try and maintain both forward and backward 283 | -- versions.) 284 | 285 | postorder_dfs :: NonLocal (block n) => Graph' block n O x -> [block n C C] 286 | preorder_dfs :: NonLocal (block n) => Graph' block n O x -> [block n C C] 287 | 288 | -- | This is the most important traversal over this data structure. It drops 289 | -- unreachable code and puts blocks in an order that is good for solving forward 290 | -- dataflow problems quickly. The reverse order is good for solving backward 291 | -- dataflow problems quickly. The forward order is also reasonably good for 292 | -- emitting instructions, except that it will not usually exploit Forest 293 | -- Baskett's trick of eliminating the unconditional branch from a loop. For 294 | -- that you would need a more serious analysis, probably based on dominators, to 295 | -- identify loop headers. 296 | -- 297 | -- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph' 298 | -- representation, when for most purposes the plain 'Graph' representation is 299 | -- more mathematically elegant (but results in more complicated code). 300 | -- 301 | -- Here's an easy way to go wrong! Consider 302 | -- @ 303 | -- A -> [B,C] 304 | -- B -> D 305 | -- C -> D 306 | -- @ 307 | -- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D. 308 | -- Better to get [A,B,C,D] 309 | 310 | 311 | graphDfs :: (LabelMap (block n C C) -> block n O C -> LabelSet -> [block n C C]) 312 | -> (Graph' block n O x -> [block n C C]) 313 | graphDfs _ (GNil) = [] 314 | graphDfs _ (GUnit{}) = [] 315 | graphDfs order (GMany (JustO entry) body _) = order body entry setEmpty 316 | 317 | postorder_dfs = graphDfs postorder_dfs_from_except 318 | preorder_dfs = graphDfs preorder_dfs_from_except 319 | 320 | postorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e) 321 | => LabelMap (block C C) -> e -> LabelSet -> [block C C] 322 | postorder_dfs_from_except blocks b visited = 323 | vchildren (get_children b) (\acc _visited -> acc) [] visited 324 | where 325 | vnode :: block C C -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a 326 | vnode block cont acc visited = 327 | if setMember id visited then 328 | cont acc visited 329 | else 330 | let cont' acc visited = cont (block:acc) visited in 331 | vchildren (get_children block) cont' acc (setInsert id visited) 332 | where id = entryLabel block 333 | vchildren :: forall a. [block C C] -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a 334 | vchildren bs cont acc visited = next bs acc visited 335 | where next children acc visited = 336 | case children of [] -> cont acc visited 337 | (b:bs) -> vnode b (next bs) acc visited 338 | get_children :: forall l. LabelsPtr l => l -> [block C C] 339 | get_children block = foldr add_id [] $ targetLabels block 340 | add_id id rst = case lookupFact id blocks of 341 | Just b -> b : rst 342 | Nothing -> rst 343 | 344 | postorder_dfs_from 345 | :: (NonLocal block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C] 346 | postorder_dfs_from blocks b = postorder_dfs_from_except blocks b setEmpty 347 | 348 | 349 | ---------------------------------------------------------------- 350 | 351 | data VM a = VM { unVM :: LabelSet -> (a, LabelSet) } 352 | 353 | instance Functor VM where 354 | fmap = liftM 355 | 356 | instance Applicative VM where 357 | pure a = VM $ \visited -> (a, visited) 358 | (<*>) = ap 359 | 360 | instance Monad VM where 361 | return = AP.pure 362 | m >>= k = VM $ \visited -> let (a, v') = unVM m visited in unVM (k a) v' 363 | 364 | marked :: Label -> VM Bool 365 | marked l = VM $ \v -> (setMember l v, v) 366 | 367 | mark :: Label -> VM () 368 | mark l = VM $ \v -> ((), setInsert l v) 369 | 370 | preorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e) 371 | => LabelMap (block C C) -> e -> LabelSet -> [block C C] 372 | preorder_dfs_from_except blocks b visited = 373 | (fst $ unVM (children (get_children b)) visited) [] 374 | where children [] = return id 375 | children (b:bs) = liftM2 (.) (visit b) (children bs) 376 | visit :: block C C -> VM (HL (block C C)) 377 | visit b = do already <- marked (entryLabel b) 378 | if already then return id 379 | else do mark (entryLabel b) 380 | bs <- children $ get_children b 381 | return $ b `cons` bs 382 | get_children :: forall l. LabelsPtr l => l -> [block C C] 383 | get_children block = foldr add_id [] $ targetLabels block 384 | 385 | add_id id rst = case lookupFact id blocks of 386 | Just b -> b : rst 387 | Nothing -> rst 388 | 389 | type HL a = [a] -> [a] -- Hughes list (constant-time concatenation) 390 | cons :: a -> HL a -> HL a 391 | cons a as tail = a : as tail 392 | 393 | 394 | -- ----------------------------------------------------------------------------- 395 | -- Extracting Labels from graphs 396 | 397 | labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x 398 | -> LabelSet 399 | labelsDefined GNil = setEmpty 400 | labelsDefined (GUnit{}) = setEmpty 401 | labelsDefined (GMany _ body x) = mapFoldWithKey addEntry (exitLabel x) body 402 | where addEntry :: forall a. ElemOf LabelSet -> a -> LabelSet -> LabelSet 403 | addEntry label _ labels = setInsert label labels 404 | exitLabel :: MaybeO x (block n C O) -> LabelSet 405 | exitLabel NothingO = setEmpty 406 | exitLabel (JustO b) = setSingleton (entryLabel b) 407 | 408 | labelsUsed :: forall block n e x. NonLocal (block n) => Graph' block n e x 409 | -> LabelSet 410 | labelsUsed GNil = setEmpty 411 | labelsUsed (GUnit{}) = setEmpty 412 | labelsUsed (GMany e body _) = mapFold addTargets (entryTargets e) body 413 | where addTargets :: forall e. block n e C -> LabelSet -> LabelSet 414 | addTargets block labels = setInsertList (successors block) labels 415 | entryTargets :: MaybeO e (block n O C) -> LabelSet 416 | entryTargets NothingO = setEmpty 417 | entryTargets (JustO b) = addTargets b setEmpty 418 | 419 | externalEntryLabels :: forall n . 420 | NonLocal n => LabelMap (Block n C C) -> LabelSet 421 | externalEntryLabels body = defined `setDifference` used 422 | where defined = labelsDefined g 423 | used = labelsUsed g 424 | g = GMany NothingO body NothingO 425 | 426 | --------------------------------------------------------------------------------