Commit 8778a379 authored by Ning Wang's avatar Ning Wang

1. remove the dependency on mk to run the tests; 2. make Ast an instance of Eq...

1. remove the dependency on mk to run the tests; 2. make Ast an instance of Eq such that we can compare the transformed results against the expected results in Haskell; 3. add a module to convert IR back to Ast to make the above comparison possible.4. remove Norman from the maintainer field, and add Andreas and Ning as the maintainers; 5. Add #if CABAL macro to several hoop files to conditionally include the macro generated by Cabal such that we can build hoopl and all the tests in ghci
parent 1874596c
......@@ -29,4 +29,4 @@ dist
/dist-install
/dist-boot
/ghc.mk
.hpc
......@@ -17,6 +17,10 @@ To build the library, change to the src directory and run
cabal build
cabal install --enable-documentation
To run the tests in the folder testing/, change to the top level and run
cabal configure --enable-tests
cabal test
You'll need a Haskell Platform, which should include appropriate
versions of Cabal and GHC.
......
Name: hoopl
Version: 3.10.1.0
Version: 3.10.2.1
-- NOTE: Don't forget to update ./changelog.md
Description:
Higher-order optimization library
......@@ -10,7 +10,7 @@ Description:
License: BSD3
License-File: LICENSE
Author: Norman Ramsey, Joao Dias, Simon Marlow and Simon Peyton Jones
Maintainer: nr@cs.tufts.edu
Maintainer: Ning Wang <email@ningwang.org>, Andreas Voellmy <andreas.voellmy@gmail.com>
Homepage: http://ghc.cs.tufts.edu/hoopl/
Bug-Reports: http://ghc.haskell.org/trac/ghc/newticket?component=libraries/hoopl
Build-Type: Simple
......@@ -68,3 +68,13 @@ Library
Ghc-Options: -Wall -fno-warn-name-shadowing
Test-Suite hoopl-test
Default-Language: Haskell2010
Type: exitcode-stdio-1.0
Main-Is: Main.hs
Hs-Source-Dirs: testing src
Ghc-Options: -fhpc -Wall
Build-Depends: base >= 4.3 && < 4.9,
containers >= 0.4 && < 0.6,
parsec >= 3.1.7,
mtl >= 2.1.3.1
......@@ -29,7 +29,7 @@ import Compiler.Hoopl.Dataflow hiding ( wrapFR, wrapFR2, wrapBR, wrapBR2
import Compiler.Hoopl.Debug
import Compiler.Hoopl.Fuel hiding (withFuel, getFuel, setFuel)
import Compiler.Hoopl.Block
import Compiler.Hoopl.Graph hiding (splice, gSplice)
import Compiler.Hoopl.Graph hiding (splice{-, gSplice-})
import Compiler.Hoopl.Label hiding (uniqueToLbl, lblToUnique)
import Compiler.Hoopl.MkGraph
import Compiler.Hoopl.Pointed
......
......@@ -21,9 +21,14 @@ where
import Compiler.Hoopl.Checkpoint
import Compiler.Hoopl.Unique
#if CABAL
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative(..))
#endif
#else
import Control.Applicative (Applicative(..))
#endif
import Control.Monad (ap,liftM)
class Monad m => FuelMonad m where
......
......@@ -46,9 +46,13 @@ import Compiler.Hoopl.Collections
import Compiler.Hoopl.Block
import Compiler.Hoopl.Label
#if CABAL
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative(..))
#endif
#else
import Control.Applicative (Applicative(..))
#endif
import Control.Monad (ap,liftM,liftM2)
-- -----------------------------------------------------------------------------
......
......@@ -24,9 +24,14 @@ import Compiler.Hoopl.Collections
import qualified Data.IntMap as M
import qualified Data.IntSet as S
#ifdef CABAL
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
#else
import Control.Applicative
#endif
import Control.Monad (ap,liftM)
-----------------------------------------------------------------------------
......
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns #-}
module Ast (Proc(..), Block(..), Insn(..), Control(..), Lbl) where
module Ast (Proc(..), Block(..), Insn(..), Control(..), Lbl, showProc) where
import Expr
import PP
-- | A procedure has a name, a sequence of arguments, and a body,
-- which is a sequence of basic blocks. The procedure entry
-- is the first block in the body.
data Proc = Proc { name :: String, args :: [Var], body :: [Block] }
data Proc = Proc { name :: String, args :: [Var], body :: [Block] } deriving Eq
-- | A block consists of a label, a sequence of instructions,
-- and a control-transfer instruction.
data Block = Block { first :: Lbl, mids :: [Insn], last :: Control }
data Block = Block { first :: Lbl, mids :: [Insn], last :: Control } deriving Eq
-- | An instruction is an assignment to a variable or a store to memory.
data Insn = Assign Var Expr
| Store Expr Expr
| Store Expr Expr deriving (Eq)
-- | Control transfers are branches (unconditional and conditional),
-- call, and return.
......@@ -26,7 +27,39 @@ data Insn = Assign Var Expr
data Control = Branch Lbl
| Cond Expr Lbl Lbl
| Call [Var] String [Expr] Lbl
| Return [Expr]
| Return [Expr] deriving (Eq)
-- | Labels are represented as strings in an AST.
type Lbl = String
showProc :: Proc -> String
showProc (Proc { name = n, args = as, body = blks})
= n ++ tuple as ++ graph
where
graph = foldl (\p b -> p ++ "\n" ++ show b) (" {") blks ++ "\n}\n"
instance Show Block where
show (Block f m l) = (foldl (\p e -> p ++ "\n" ++ show e) (f++":") m) ++ "\n" ++ show l
instance Show Insn where
show (Assign v e) = ind $ v ++ " = " ++ show e
show (Store addr e) = ind $ "m[" ++ show addr ++ "] = " ++ show e
instance Show Control where
show (Branch lbl) = ind $ "goto " ++ lbl
show (Cond e t f) =
ind $ "if " ++ show e ++ " then goto " ++ t ++ " else goto " ++ f
show (Call ress f cargs succ) =
ind $ tuple ress ++ " = " ++ f ++ tuple (map show cargs) ++ " goto " ++ succ
show (Return rargs) = ind $ "ret " ++ tuple (map show rargs)
ind :: String -> String
ind x = " " ++ x
{-
instance Show Value where
show (B b) = show b
show (I i) = show i
-}
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns #-}
module Ast2ir (astToIR) where
module Ast2ir (astToIR, IdLabelMap) where
import Compiler.Hoopl
import Control.Monad
......@@ -17,17 +17,19 @@ import qualified IR as I
-- the following operation:
labelFor :: String -> LabelMapM Label
getBody :: forall n. Graph n C C -> LabelMapM (Graph n C C)
run :: LabelMapM a -> I.M a
run :: LabelMapM a -> I.M (IdLabelMap, a)
-- We proceed with the translation from AST to IR; the implementation of the monad
-- is at the end of this file.
astToIR :: A.Proc -> I.M I.Proc
astToIR :: A.Proc -> I.M (IdLabelMap, I.Proc)
astToIR (A.Proc {A.name = n, A.args = as, A.body = b}) = run $
do entry <- getEntry b
body <- toBody b
return $ I.Proc { I.name = n, I.args = as, I.body = body, I.entry = entry }
getEntry :: [A.Block] -> LabelMapM Label
getEntry [] = error "Parsed procedures should not be empty"
getEntry (b : _) = labelFor $ A.first b
......@@ -80,4 +82,4 @@ labelFor l = LabelMapM f
getBody graph = LabelMapM f
where f m = return (m, graph)
run (LabelMapM f) = f M.empty >>= return . snd
run (LabelMapM f) = f M.empty -- >>= return -- . snd
......@@ -7,11 +7,12 @@ import PP
data Expr = Lit Lit
| Var Var
| Load Expr
| Binop BinOp Expr Expr
data BinOp = Add | Sub | Mul | Div | Eq | Ne | Lt | Gt | Lte | Gte
| Binop BinOp Expr Expr deriving (Eq)
data BinOp = Add | Sub | Mul | Div | Eq | Ne | Lt | Gt | Lte | Gte deriving Eq
data Lit = Bool Bool | Int Integer deriving Eq
type Var = String
type Var = String
--------------------------------------------------------------------------------
--- Prettyprinting
......
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns #-}
module Ir2ast (irToAst) where
import Compiler.Hoopl
import Control.Monad
import qualified Data.Map as M
import qualified Ast as A
import qualified IR as I
import Control.Monad.Reader
type Rm = Reader (M.Map Label A.Lbl)
invertMap :: (Ord k, Ord v) => M.Map k v -> M.Map v k
invertMap m = foldl (\p (k,v) ->
if M.member v p
then error $ "irrefutable error in invertMap, the values are not unique"
else M.insert v k p
) M.empty (M.toList m)
strLabelFor :: Label -> Rm String
strLabelFor l = do { mp <- ask
; case M.lookup l mp of
Just x -> return x
Nothing -> return $ "_hoopl_generated_label_" ++ (show l)
}
irToAst :: M.Map String Label -> I.Proc -> A.Proc
irToAst mp (I.Proc {I.name = n, I.args = as, I.body = graph, I.entry = entry }) =
runReader (do { body <- fromGraph entry graph
; return $ A.Proc { A.name = n, A.args = as, A.body = body }
}) (invertMap mp)
fromGraph :: Label -> Graph I.Insn C C -> Rm [A.Block]
fromGraph entry g = let entryNode = gUnitOC (BlockOC BNil (I.Branch entry))
blks = reverse $ postorder_dfs (gSplice entryNode g)
in foldM (\p blk -> do { ablk <- fromBlock blk ()
; return (ablk:p)
}) [] blks
type instance IndexedCO C () (Rm (A.Lbl, [A.Insn])) = ()
type instance IndexedCO C (Rm A.Block) (Rm (A.Lbl, [A.Insn])) = Rm A.Block
fromBlock :: Block I.Insn C C -> () -> Rm A.Block
fromBlock blk = foldBlockNodesF3 (fromIrInstCO, fromIrInstOO, fromIrInstOC) blk
fromIrInstCO :: I.Insn C O -> () -> Rm (A.Lbl, [A.Insn])
fromIrInstCO inst p = case inst of
I.Label l -> strLabelFor l >>= \x -> return (x, [])
fromIrInstOO :: I.Insn O O -> Rm (A.Lbl, [A.Insn]) -> Rm (A.Lbl, [A.Insn])
fromIrInstOO inst p = case inst of
I.Assign v e -> do { (sl, insts) <- p
; return (sl, (A.Assign v e):insts)
}
I.Store a e -> do { (sl, insts) <- p
; return (sl, (A.Store a e):insts)
}
fromIrInstOC :: I.Insn e x -> Rm (A.Lbl, [A.Insn]) -> Rm A.Block
fromIrInstOC inst p = case inst of
I.Branch tl -> do { (l, insts) <- p
; stl <- strLabelFor tl
; return $ A.Block {A.first = l, A.mids = reverse insts
, A.last = A.Branch stl}
}
I.Cond e tl fl -> do { (l, insts)<- p
; stl <- strLabelFor tl
; sfl <- strLabelFor fl
; return $ A.Block {A.first = l, A.mids = reverse insts
, A.last = A.Cond e stl sfl}
}
I.Call vars name exps el -> do { (l, insts) <- p
; tel <- strLabelFor el
; return $ A.Block {A.first = l, A.mids = reverse insts
, A.last = A.Call vars name exps tel}
}
I.Return exps -> do { (l, insts) <- p
; return $ A.Block {A.first = l, A.mids = reverse insts
, A.last = A.Return exps}
}
......@@ -4,12 +4,17 @@ import Test
import System.IO
-- Hardcoding test locations for now
tests = map (\t -> "tests" ++ "/" ++ t)
(["test1", "test2", "test3", "test4"] ++
tests = map (\t -> "testing" ++ "/" ++ "tests" ++ "/" ++ t)
(["test1", "test2", "test3", "test4"] ++
["if-test", "if-test2", "if-test3", "if-test4"])
test_expected_results = map (\t -> "testing" ++ "/" ++ "tests" ++ "/" ++ t)
(["test1.expected", "test2.expected", "test3.expected", "test4.expected"] ++
["if-test.expected", "if-test2.expected", "if-test3.expected", "if-test4.expected"])
main :: IO ()
main = do hSetBuffering stdout NoBuffering
hSetBuffering stderr NoBuffering
mapM (\x -> putStrLn ("Test:" ++ x) >> parseTest x >> optTest x) tests
mapM (\(x, ex) -> putStrLn ("Test:" ++ x) >> parseTest x >> optTest x ex) (zip tests test_expected_results)
return ()
Here is some testing code which may also serve as a sample client.
Base system
~~~~~~~~~~~
Ast.hs Abstract syntax for a language of basic blocks,
......@@ -15,6 +14,9 @@ Base system
the string labels in the source from the abstract Labels
defined by Hoopl.
Ir2Ast.hs Translated from IR to Ast. The original string Labels to the
abstract Labels mappings are used to do this translation.
Optimizations
~~~~~~~~~~~~~
......
......@@ -4,7 +4,10 @@ module Test (parseTest, evalTest, optTest) where
import Compiler.Hoopl
import Control.Monad.Error
import System.Exit
import qualified Ast as A
import qualified Ir2ast as Ia
import Ast2ir
import ConstProp
import Eval (evalProg, ErrorM)
......@@ -14,7 +17,7 @@ import Parse (parseCode)
import Simplify
import Debug.Trace
parse :: String -> String -> ErrorM (M [Proc])
parse :: String -> String -> ErrorM (M [(IdLabelMap, Proc)])
parse file text =
case parseCode file text of
Left err -> throwError $ show err
......@@ -25,12 +28,12 @@ parseTest file =
do text <- readFile file
case parse file text of
Left err -> putStrLn err
Right p -> mapM (putStrLn . showProc) (runSimpleUniqueMonad $ runWithFuel 0 p) >> return ()
Right p -> mapM (putStrLn . showProc . snd) (runSimpleUniqueMonad $ runWithFuel 0 p) >> return ()
evalTest' :: String -> String -> ErrorM String
evalTest' file text =
do procs <- parse file text
(_, vs) <- testProg (runSimpleUniqueMonad $ runWithFuel 0 procs)
(_, vs) <- (testProg . snd . unzip) (runSimpleUniqueMonad $ runWithFuel 0 procs)
return $ "returning: " ++ show vs
where
testProg procs@(Proc {name, args} : _) = evalProg procs vsupply name (toV args)
......@@ -45,10 +48,9 @@ evalTest file =
Left err -> putStrLn err
Right s -> putStrLn s
optTest' :: String -> String -> ErrorM (M [Proc])
optTest' file text =
do procs <- parse file text
return $ procs >>= mapM optProc
optTest' :: M [Proc] -> ErrorM (M [Proc])
optTest' procs =
return $ procs >>= mapM optProc
where
optProc proc@(Proc {entry, body, args}) =
do { (body', _, _) <- analyzeAndRewriteFwd fwd (JustC [entry]) body
......@@ -74,14 +76,50 @@ constPropPass = FwdPass
, fp_rewrite = constProp `thenFwdRw` simplify }
-- @ end cprop.tex
optTest :: String -> IO ()
optTest file =
toAst :: [(IdLabelMap, Proc)] -> [A.Proc]
toAst l = fmap (uncurry Ia.irToAst) l
compareAst :: [A.Proc] -> [A.Proc] -> IO ()
compareAst [] [] = return ()
compareAst (r:results) (e:expected) =
if r == e
then compareAst results expected
else
do { putStrLn "expecting"
; putStrLn $ A.showProc e
; putStrLn "resulting"
; putStrLn $ A.showProc r
; putStrLn "the result does not match the expected, abort the test!!!!"
; exitFailure
}
compareAst results expected = do { putStrLn "expecting"
; mapM_ (putStrLn . A.showProc) expected
; putStrLn "resulting"
; mapM_ (putStrLn . A.showProc) results
; putStrLn "the result does not match the expected, abort the test!!!!"
; exitFailure
}
optTest :: String -> String -> IO ()
optTest file expectedFile =
do text <- readFile file
case optTest' file text of
Left err -> putStrLn err
Right p -> mapM_ (putStrLn . showProc) (runSimpleUniqueMonad $ runWithFuel fuel p)
expectedText <- readFile expectedFile
case (parse file text, parse expectedFile expectedText) of
(Left err, _) -> putStrLn err
(_, Left err) -> putStrLn err
(Right lps, Right exps) ->
case optTest' (liftM (snd . unzip) lps) of
Left err -> putStrLn err
Right p -> do { let opted = runSimpleUniqueMonad $ runWithFuel fuel p
lbmaps = runSimpleUniqueMonad $ runWithFuel fuel (liftM (fst . unzip) lps)
expected = runSimpleUniqueMonad $ runWithFuel fuel exps
; mapM_ (putStrLn . showProc) opted
; compareAst (toAst (zip lbmaps opted)) (toAst expected)
}
where
fuel = 99999
fuel = 9999
......
HS=`echo *.hs`
all:V: Main
clean:V:
rm -f Main
rm -f *.o *.hi *~
Main: $HS
ghc --make Main.hs
FUNSOUT=16
test:VQ:
rm -f Main
ghc --make Main.hs
if ./Main > /dev/null && [ `./Main | grep '^f.*{$' | wc -l ` -eq $FUNSOUT ]
then
echo "Passed `expr $FUNSOUT / 2` tests" >&2
else
echo "Test failed" >&2
exit 1
fi
Test:tests/test1
Test suite hoopl-test: RUNNING...
Test:testing/tests/test1
f(a, b) {
L1:
r0 = 3
......@@ -7,12 +8,20 @@ L1:
ret (r2)
}
f(a, b) {
L1:
r0 = 3
r1 = 4
r2 = 7
ret (7)
}
f(a, b) {
L1:
ret (7)
}
Test:tests/test2
Test:testing/tests/test2
f(a, b) {
L1:
x = 5
......@@ -43,7 +52,22 @@ L4:
ret (y)
}
Test:tests/test3
f(a, b) {
L1:
x = 5
y = 0
goto L2
L2:
if x > 0 then goto L3 else goto L4
L3:
y = y + x
x = x - 1
goto L2
L4:
ret (y)
}
Test:testing/tests/test3
f(x, y) {
L1:
goto L2
......@@ -74,7 +98,22 @@ L5:
goto L2
}
Test:tests/test4
f(x, y) {
L1:
goto L2
L2:
if x > 0 then goto L3 else goto L4
L3:
(z) = f(x - 1, y - 1) goto L5
L4:
ret (y)
L5:
y = y + z
x = x - 1
goto L2
}
Test:testing/tests/test4
f(x) {
L1:
y = 5
......@@ -88,6 +127,16 @@ L4:
ret ((x + y) + 4)
}
f(x) {
L1:
y = 5
goto L2
L2:
goto L4
L4:
ret ((x + 5) + 4)
}
f(x) {
L1:
goto L2
......@@ -97,7 +146,7 @@ L4:
ret ((x + 5) + 4)
}
Test:tests/if-test
Test:testing/tests/if-test
f() {
L1:
x = 3 + 4
......@@ -109,6 +158,15 @@ L3:
ret (2)
}
f() {
L1:
x = 7
z = True
goto L2
L2:
ret (1)
}
f() {
L1:
goto L2
......@@ -116,7 +174,7 @@ L2:
ret (1)
}
Test:tests/if-test2
Test:testing/tests/if-test2
f(a) {
L1:
x = 3 + 4
......@@ -141,6 +199,7 @@ L7:
f(a) {
L1:
x = 7
res = 0
goto L2
L2:
......@@ -157,7 +216,25 @@ L7:
goto L2
}
Test:tests/if-test3
f(a) {
L1:
res = 0
goto L2