fortran-src-0.16.9: test/Language/Fortran/Analysis/DataFlowSpec.hs
module Language.Fortran.Analysis.DataFlowSpec where
import Test.Hspec
import TestUtil
import Language.Fortran.AST
import Language.Fortran.Analysis
import Language.Fortran.Analysis.Renaming
import Language.Fortran.Analysis.BBlocks
import Language.Fortran.Analysis.DataFlow
import qualified Language.Fortran.Parser as Parser
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import Data.Graph.Inductive hiding (version, lab')
import Data.Maybe
import Data.List
import Data.Data
import Data.Generics.Uniplate.Operations
import qualified Data.ByteString.Char8 as B
import Control.Arrow ((&&&))
data F77 = F77
data F90 = F90
class Parser t where
parser :: t -> String -> ProgramFile A0
instance Parser F77 where
parser F77 = Parser.parseUnsafe Parser.f77e . B.pack
instance Parser F90 where
parser F90 = Parser.parseUnsafe Parser.f90 . B.pack
pParser :: Parser t => t -> String -> ProgramFile (Analysis ())
pParser version source = rename . analyseBBlocks . analyseRenames . initAnalysis
. resetSrcSpan $ parser version source
withParse :: Data a => Parser t => t -> String -> (ProgramFile (Analysis A0) -> a) -> a
withParse version source f = underRenaming (f . analyseBBlocks) (parser version source)
testGraph :: Parser t => t -> String -> String -> BBGr (Analysis A0)
testGraph version f p = fromJust . M.lookup (Named f) . withParse version p $ genBBlockMap
testPfAndGraph :: Parser t => t -> String -> String -> (ProgramFile (Analysis A0), BBGr (Analysis A0))
testPfAndGraph version f p = fmap (fromJust . M.lookup (Named f)) . withParse version p $ \ pf -> (pf, genBBlockMap pf)
testGenDefMap :: Parser t => t -> String -> DefMap
testGenDefMap version = flip (withParse version) (genDefMap . genBlockMap . analyseBBlocks . initAnalysis)
testBackEdges :: Parser t => t -> String -> String -> BackEdgeMap
testBackEdges version f p = bedges
where
gr = testGraph version f p
domMap = dominators gr
bedges = genBackEdgeMap domMap $ bbgrGr gr
spec :: Spec
spec =
describe "Dataflow" $ do
describe "loop4" $ do
let pf = pParser F77 programLoop4
bm = genBlockMap pf
dm = genDefMap bm
it "genBackEdgeMap" $ do
let gr = testGraph F77 "loop4" programLoop4
testBackEdges F77 "loop4" programLoop4 `shouldBe`
IM.fromList [(findLabelBB gr 8, findLabelBB gr 10), (findLabelBB gr 7, findLabelBB gr 20)]
let gr = fromJust . M.lookup (Named "loop4") $ genBBlockMap pf
it "loopNodes" $ do
let domMap = dominators gr
bedges = genBackEdgeMap domMap $ bbgrGr gr
S.fromList (loopNodes bedges $ bbgrGr gr) `shouldBe`
S.fromList [findLabelsBB gr [5,6,7,20], IS.unions [findLabelsBB gr [4,5,6,7,8,10,20,30], findSuccsBB gr [20]]]
it "genDefMap" $
testGenDefMap F77 programLoop4 `shouldBe`
M.fromList [("i",findLabelsBl pf [3,30]),("j",findLabelsBl pf [4,6]),("r",findLabelsBl pf [2,5])]
it "reachingDefinitions" $
IM.lookup (findLabelBB gr 5) (reachingDefinitions dm gr) `shouldBe`
Just (findLabelsBl pf [2,3,4,5,6,30], findLabelsBl pf [3,4,5,6,30])
it "flowsTo" $
(S.fromList . edges . genFlowsToGraph bm dm gr $ reachingDefinitions dm gr) `shouldBe`
-- Find the flows of the assignment statements in the program.
findLabelsBlEdges pf [(2,5),(2,40) -- r = 0
,(3,5),(3,10),(3,30) -- i = 1
,(4,5),(4,6),(4,20) -- j = 1
,(5,5),(5,40) -- r = r + i * j
,(6,5),(6,6),(6,20) -- j = j + 1
,(30,5),(30,10),(30,30) -- i = i + 1
]
----------------------------------------------
describe "loop4 alt (module)" $ do
let pf = pParser F90 programLoop4Alt
sgr = genSuperBBGr (genBBlockMap pf)
bm = genBlockMap pf
dm = genDefMap bm
gr = superBBGrGraph sgr
domMap = dominators gr
bedges = genBackEdgeMap domMap $ bbgrGr gr
it "genBackEdgeMap" $ do
let gr' = testGraph F90 "loop4" programLoop4Alt
testBackEdges F90 "loop4" programLoop4Alt `shouldBe`
IM.fromList [(findLabelBB gr' 22, findLabelBB gr' 20), (findLabelBB gr' 31, findLabelBB gr' 10)]
it "loopNodes" $
S.fromList (loopNodes bedges $ bbgrGr gr) `shouldBe`
S.fromList [findLabelsBB gr [20,21,22], findLabelsBB gr [10,11,20,21,22,31,40]]
it "genDefMap" $
testGenDefMap F90 programLoop4Alt `shouldBe`
M.fromList [("i",findLabelsBl pf [2,31]),("j",findLabelsBl pf [11,22]),("r",findLabelsBl pf [1,21])]
it "reachingDefinitions" $
IM.lookup (findLabelBB gr 21) (reachingDefinitions dm gr) `shouldBe`
Just (findLabelsBl pf [1,2,11,21,22,31], findLabelsBl pf [2,11,21,22,31])
it "flowsTo" $
(S.fromList . edges . genFlowsToGraph bm dm gr $ reachingDefinitions dm gr) `shouldBe`
-- Find the flows of the assignment statements in the program.
findLabelsBlEdges pf [(1,21),(1,41) -- r = 0
,(2,10),(2,21),(2,31) -- i = 1
,(11,20),(11,21),(11,22) -- j = 1
,(21,21),(21,41) -- r = r + i * j
,(22,20),(22,21),(22,22) -- j = j + 1
,(31,10),(31,21),(31,31) -- i = i + 1
]
-----------------------------------------------
describe "rd3" $ do
let (pf, gr) = testPfAndGraph F77 "f" programRd3
bm = genBlockMap pf
dm = genDefMap bm
it "genBackEdgeMap" $ do
let gr' = testGraph F77 "f" programRd3
testBackEdges F77 "f" programRd3 `shouldBe` IM.singleton (findLabelBB gr 4) (findLabelBB gr' 1)
it "loopNodes" $ do
let domMap = dominators gr
bedges = genBackEdgeMap domMap $ bbgrGr gr
S.fromList (loopNodes bedges $ bbgrGr gr) `shouldBe`
S.fromList [findLabelsBB gr [1,2,3,4]]
it "reachingDefinitions" $
IM.lookup (findLabelBB gr 5) (reachingDefinitions dm gr) `shouldBe`
Just (IS.unions [findBBlockBl gr 0, findLabelsBl pf [1,2,3]]
,IS.unions [findBBlockBl gr 0, findLabelsBl pf [1,2,3,5]])
it "flowsTo" $
(S.fromList . edges . genFlowsToGraph bm dm gr $ reachingDefinitions dm gr) `shouldSatisfy`
-- Find the flows of the assignment statements in the program.
S.isSubsetOf (findLabelsBlEdges pf [(1,2),(1,3) -- do 4 i = 2, 10
,(2,3) -- b(i) = a(i-1) + x
,(3,2),(3,5) -- a(i) = b(i)
])
describe "rd4" $
it "ivMapByASTBlock" $ do
let (_, gr) = testPfAndGraph F77 "f" programRd4
domMap = dominators gr
bedges = genBackEdgeMap domMap $ bbgrGr gr
ivMap = genInductionVarMapByASTBlock bedges gr
(sort . map (head &&& length) . group . sort . map S.size $ IM.elems ivMap) `shouldBe` [(1,3),(2,3)]
describe "bug36" $ do
let pf = pParser F90 programBug36
sgr = genSuperBBGr (genBBlockMap pf)
gr = superBBGrGraph sgr
domMap = dominators gr
bedges = genBackEdgeMap domMap $ bbgrGr gr
it "loopNodes" $
length (loopNodes bedges $ bbgrGr gr) `shouldBe` 2
describe "funcflow1" $ do
let pf = pParser F90 programFuncFlow1
sgr = genSuperBBGr (genBBlockMap pf)
gr = superBBGrGraph sgr
bm = genBlockMap pf
dm = genDefMap bm
rDefs = reachingDefinitions dm gr
flTo = genFlowsToGraph bm dm gr rDefs
it "flowsTo" $
(S.fromList . edges . trc $ flTo) `shouldSatisfy`
-- Find the flows of the assignment statements in the program.
S.isSubsetOf (findLabelsBlEdges pf [(1,2),(1,3),(3,2)])
describe "funcflow2" $ do
let pf = pParser F90 programFuncFlow2
sgr = genSuperBBGr (genBBlockMap pf)
gr = superBBGrGraph sgr
bm = genBlockMap pf
dm = genDefMap bm
rDefs = reachingDefinitions dm gr
flTo = genFlowsToGraph bm dm gr rDefs
domMap = dominators gr
bedges = genBackEdgeMap domMap $ bbgrGr gr
diMap = genDerivedInductionMap bedges gr
(iLabel, iName):_ = [ (fromJust (insLabel a), varName e)
| e@(ExpValue a _ (ValVariable _)) <- rhsExprs pf, srcName e == "i" ]
(jLabel, _):_ = [ (fromJust (insLabel a), varName e)
| e@(ExpValue a _ (ValVariable _)) <- lhsExprs pf, srcName e == "j" ]
it "flowsTo" $
(S.fromList . edges . trc $ flTo) `shouldSatisfy`
-- Find the flows of the assignment statements in the program.
S.isSubsetOf (findLabelsBlEdges pf [(1,2),(1,3),(3,2)])
it "derivedInduction" $ do
IM.lookup iLabel diMap `shouldBe` Just (IELinear iName 1 0)
IM.lookup jLabel diMap `shouldBe` Just (IELinear iName 6 2)
describe "defUse1" $ do
let pf = pParser F90 programDefUse1
sgr = genSuperBBGr (genBBlockMap pf)
gr = superBBGrGraph sgr
bm = genBlockMap pf
dm = genDefMap bm
rDefs = reachingDefinitions dm gr
flTo = genFlowsToGraph bm dm gr rDefs
domMap = dominators gr
bedges = genBackEdgeMap domMap $ bbgrGr gr
it "backEdges" $
bedges `shouldBe` IM.fromList [(findLabelBB gr 5, findLabelBB gr 4)]
it "flowsTo" $
(S.fromList . edges $ flTo) `shouldBe`
-- Find the flows of the assignment statements in the program.
findLabelsBlEdges pf [(1,2),(1,3),(1,5),(2,3),(3,4),(4,5),(5,5)]
describe "defUse2" $ do
let pf = pParser F90 programDefUse2
sgr = genSuperBBGr (genBBlockMap pf)
gr = superBBGrGraph sgr
bm = genBlockMap pf
dm = genDefMap bm
rDefs = reachingDefinitions dm gr
flTo = genFlowsToGraph bm dm gr rDefs
domMap = dominators gr
bedges = genBackEdgeMap domMap $ bbgrGr gr
it "backEdges" $
bedges `shouldBe` IM.fromList [(findLabelBB gr 12, findLabelBB gr 11)]
it "flowsTo" $ do
(S.fromList . edges . tc $ flTo) `shouldSatisfy`
-- Find the flows of the assignment statements in the program.
S.isSubsetOf (findLabelsBlEdges pf [(1,2),(1,3),(1,12),(2,3),(3,11),(11,12),(12,12)])
describe "other" $
it "dominators on disconnected graph" $
dominators (BBGr (nmap (const []) (mkUGraph [0,1,3,4,5,6,7,8,9] [(0,3) ,(3,1) ,(5,6) ,(6,7) ,(7,4) ,(7,8) ,(8,7) ,(8,9) ,(9,8)])) [0,5] [3,9]) `shouldBe` IM.fromList [(0,IS.fromList [0]),(1,IS.fromList [0,1,3]),(3,IS.fromList [0,3]),(4,IS.fromList [4,5,6,7]),(5,IS.fromList [5]),(6,IS.fromList [5,6]),(7,IS.fromList [5,6,7]),(8,IS.fromList [5,6,7,8]),(9,IS.fromList [5,6,7,8,9])]
--------------------------------------------------
-- Label-finding helper functions to help write tests that are
-- insensitive to minor changes to the AST.
-- For each Fortran label in the list, find the corresponding basic
-- block, return as an IntSet.
findLabelsBB :: BBGr a -> [Int] -> IS.IntSet
findLabelsBB gr = IS.fromList . mapMaybe (flip findLabeledBBlock gr . show)
findLabelBB :: BBGr a -> Int -> Node
findLabelBB gr = (error "findLabelBB" `fromMaybe`) . flip findLabeledBBlock gr . show
-- For each Fortran label in the list, find the successors of the
-- corresponding basic block, return as an IntSet.
findSuccsBB :: BBGr a -> [Int] -> IS.IntSet
findSuccsBB gr = IS.fromList . concatMap (suc $ bbgrGr gr) . mapMaybe (flip findLabeledBBlock gr . show)
-- For each Fortran label in the list, find the AST-block label numbers ('insLabel') associated
findLabelsBl :: forall a. Data a => ProgramFile (Analysis a) -> [Int] -> IS.IntSet
findLabelsBl pf labs = IS.fromList [ i | b <- universeBi pf :: [Block (Analysis a)]
, ExpValue _ _ (ValInteger lab' _) <- maybeToList (getLabel b)
, lab' `elem` labsS
, let a = getAnnotation b
, i <- maybeToList (insLabel a) ]
where labsS = map show labs
-- Translate a list of edges given as Fortran labels into a set of
-- edges given as AST-block label numbers.
findLabelsBlEdges :: Data a => ProgramFile (Analysis a) -> [(Int, Int)] -> S.Set (Int, Int)
findLabelsBlEdges pf = S.fromList . map convEdge
where
convEdge (a, b)
| a':_ <- IS.toList (findLabelsBl pf [a]) -- FIXME: inefficient
, b':_ <- IS.toList (findLabelsBl pf [b]) = (a', b')
| otherwise = error $ "findLabelsBlEdges (" ++ show a ++ "," ++ show b ++ ")"
-- Get the set of AST-block labels found in a given basic block
findBBlockBl :: BBGr (Analysis a) -> Int -> IS.IntSet
findBBlockBl gr = IS.fromList . mapMaybe (insLabel . getAnnotation) . concat . maybeToList . lab (bbgrGr gr)
--------------------------------------------------
-- Test programs
programLoop4 :: String
programLoop4 = unlines [
" program loop4"
, " 1 integer r, i, j"
, ""
, " 2 r = 0"
, ""
, " 3 i = 1"
, " 10 if (i .gt. 10) goto 40"
, ""
, " 4 j = 1"
, " 20 if (j .gt. 5) goto 30"
, " 5 r = r + i * j"
, " 6 j = j + 1"
, " 7 goto 20"
, ""
, " 30 i = i + 1"
, " 8 goto 10"
, ""
, " 40 write (*,*) r"
, " end"
]
programLoop4Alt :: String
programLoop4Alt = unlines [
" module loopMod"
, " implicit none"
, " contains"
, " subroutine loop4()"
, " integer r, i, j"
, ""
, " 1 r = 0"
, ""
-- , "! outer loop"
, " 2 i = 1"
, " 10 do while (i .gt. 10)"
, ""
-- , "! inner loop"
, " 11 j = 1"
, " 20 do while (j .gt. 5)"
, " 21 r = r + i * j"
, " 22 j = j + 1"
, " end do"
-- , "! inner loop end"
, ""
, " 31 i = i + 1"
, " end do"
-- , "! outer loop end"
, ""
, " 41 write (*,*) r"
, " end subroutine"
, " end module"
]
programRd3 :: String
programRd3 = unlines [
" function f(x)"
, " integer i, a, b, x, f"
, " dimension a(10), b(10)"
, ""
, " 1 do 4 i = 2, 10"
, " 2 b(i) = a(i-1) + x"
, " 3 a(i) = b(i)"
, " 4 i=i" -- alt. to 'continue' since the latter gets eliminated now
, " 5 f = a(10)"
, " end"
, " program rd3"
, " implicit none"
, " integer f"
, ""
, " write (*,*) f(1)"
, " end"
, ""
]
programRd4 :: String
programRd4 = unlines [
" function f(x)"
, " integer i, j, a, b, x, f"
, " dimension a(10), b(10)"
, ""
, " do 10 i = 2, 10"
, " do 20 j = 2, 10"
, " b(i) = a(i-1) + x"
, " 20 j=j" -- alt. to 'continue' since the latter gets eliminated now
, " a(i) = b(i)"
, " 10 i=i" -- alt. to 'continue' since the latter gets eliminated now
, " f = a(10)"
, " end"
, " program rd3"
, " implicit none"
, " integer f"
, ""
, " write (*,*) f(1)"
, " end"
, ""
]
-- do not use line numbers
programBug36 :: String
programBug36 = unlines [
"program foo"
, " implicit none"
, " integer :: i, j"
, " real, dimension(100) :: a, b"
, " do i=1,100"
, " do j=1,100"
, " a(i) = b(i) + b(1)"
, " end do"
, " end do"
, "end program"
]
programFuncFlow1 :: String
programFuncFlow1 = unlines [
" program main"
, " integer :: i, j"
, " 1 i = 1"
, " 2 j = f(i)"
, " contains"
, " integer function f(k)"
, " integer :: k"
, " 3 f = k + 1"
, " end function f"
, " end program main"
]
programFuncFlow2 :: String
programFuncFlow2 = unlines [
" program main"
, " integer :: i, j"
, " 1 do i = 1, 10"
, " 2 j = 2*f(3*i)"
, " end do"
, " contains"
, " integer function f(k)"
, " integer :: k"
, " 3 f = k + 1"
, " end function f"
, " end program main"
]
programDefUse1 :: String
programDefUse1 = unlines [
"program defUse1"
, "1 integer :: x = 1"
, "2 integer :: y = x + 1"
, "3 integer :: z = x * y"
, "4 do y=1,z"
, "5 x = x + y"
, "6 end do"
, "end program defUse1"
]
programDefUse2 :: String
programDefUse2 = unlines [
"program defUse2"
, "1 integer :: x = 1"
, "2 integer :: y = x + 1"
, "3 integer :: z = x * y"
, "4 call s(x)"
, "contains"
, " subroutine s(a)"
, "10 integer :: a"
, "11 do y=1,z"
, "12 a = a + y"
, "13 end do"
, "end subroutine s"
, "end program defUse2"
]
-- Local variables:
-- mode: haskell
-- haskell-program-name: "cabal repl test-suite:spec"
-- End: