Commit efa14f9c authored by Michael Hanus 's avatar Michael Hanus
Browse files

Root replacement analysis added

parent d0469315
Root replacement analysis
-------------------------
This analysis returns for each function `f` all functions into which `f` can
be replaced at the root. For instance, if there are the definitions:
f x = g x
g x = h x
h x = k x : []
k x = x
then the root replacements of `f` are `[g,h]` and the
root replacements of `g` are `[h]`.
This analysis could be useful to detect simple loops, e.g., if
a function is in its own root replacement.
......@@ -129,6 +129,9 @@ usageText =
options ++
unlines ("" : "Registered analyses names:" :
"(use option `-h <analysis name>' for more documentation)" :
"" : registeredAnalysisNames)
"" : map showAnaInfo registeredAnalysisInfos)
where
maxName = foldr1 max (map (length . fst) registeredAnalysisInfos)
showAnaInfo (n,t) = n ++ take (maxName - length n) (repeat ' ') ++ ": " ++ t
--------------------------------------------------------------------------
......@@ -9,7 +9,7 @@
--------------------------------------------------------------------
module Registry
( functionAnalysisInfos, registeredAnalysisNames
( functionAnalysisInfos, registeredAnalysisNames, registeredAnalysisInfos
, lookupRegAnaWorker, runAnalysisWithWorkers, analyzeMain
) where
......@@ -42,6 +42,7 @@ import Demandedness
import Groundness
import RequiredValue
import qualified RequiredValues as RVS
import RootReplaced
--------------------------------------------------------------------
--- Each analysis used in our tool must be registered in this list
......@@ -50,6 +51,8 @@ registeredAnalysis :: [RegisteredAnalysis]
registeredAnalysis =
[cassAnalysis "Overlapping rules" overlapAnalysis showOverlap
,cassAnalysis "Deterministic operations" nondetAnalysis showDet
,cassAnalysis "Depends on non-deterministic operations"
nondetDepAnalysis showNonDetDeps
,cassAnalysis "Right-linear operations" rlinAnalysis showRightLinear
,cassAnalysis "Solution completeness" solcompAnalysis showSolComplete
,cassAnalysis "Pattern completeness" patCompAnalysis showComplete
......@@ -64,6 +67,7 @@ registeredAnalysis =
,cassAnalysis "Sibling constructors" siblingCons showSibling
,cassAnalysis "Required value" reqValueAnalysis showAFType
,cassAnalysis "Required value sets" RVS.reqValueAnalysis RVS.showAFType
,cassAnalysis "Root replacements" rootReplAnalysis showRootRepl
]
......@@ -89,7 +93,7 @@ cassAnalysis title analysis showres =
--- The components are as follows:
--- * the name of the analysis
--- * is this a function analysis?
--- * a long meaningful name of the analysis
--- * a long meaningful title of the analysis
--- * the operation used by the server to distribute analysis work
--- to the clients
--- * the worker operation to analyze a list of modules
......@@ -104,6 +108,12 @@ data RegisteredAnalysis =
regAnaName :: RegisteredAnalysis -> String
regAnaName (RegAna n _ _ _ _) = n
regAnaInfo :: RegisteredAnalysis -> (String,String)
regAnaInfo (RegAna n _ t _ _) = (n,t)
regAnaFunc :: RegisteredAnalysis -> Bool
regAnaFunc (RegAna _ fa _ _ _) = fa
regAnaServer :: RegisteredAnalysis
-> (String -> Bool -> [Handle] -> Maybe AOutFormat
-> IO (Either (ProgInfo String) String))
......@@ -116,11 +126,13 @@ regAnaWorker (RegAna _ _ _ _ a) = a
registeredAnalysisNames :: [String]
registeredAnalysisNames = map regAnaName registeredAnalysis
--- Names and titles of all registered analyses.
registeredAnalysisInfos :: [(String,String)]
registeredAnalysisInfos = map regAnaInfo registeredAnalysis
--- Names and titles of all registered function analyses.
functionAnalysisInfos :: [(String,String)]
functionAnalysisInfos =
map (\ (RegAna n _ t _ _) -> (n,t))
(filter (\ (RegAna _ fa _ _ _) -> fa) registeredAnalysis)
functionAnalysisInfos = map regAnaInfo (filter regAnaFunc registeredAnalysis)
lookupRegAna :: String -> [RegisteredAnalysis] -> Maybe RegisteredAnalysis
lookupRegAna _ [] = Nothing
......
......@@ -8,12 +8,17 @@
--- @version September 2013
------------------------------------------------------------------------------
module Deterministic(overlapAnalysis,showOverlap,showDet,
Deterministic(..),nondetAnalysis) where
module Deterministic
( overlapAnalysis, showOverlap, showDet
, Deterministic(..),nondetAnalysis
, showNonDetDeps, nondetDepAnalysis
) where
import Analysis
import FlatCurry.Types
import FlatCurry.Goodies
import List
import Sort(sort)
------------------------------------------------------------------------------
-- The overlapping analysis can be applied to individual functions.
......@@ -99,3 +104,33 @@ pre :: String -> QName
pre n = ("Prelude",n)
------------------------------------------------------------------------------
--- Data type to represent information about non-deterministic dependencies.
--- Basically, it is the set (represented as a sorted list) of
--- all function names that are defined by overlapping rules or rules
--- containing free variables which might be called.
type NonDetDeps = [QName]
-- Show determinism dependency information as a string.
showNonDetDeps :: AOutFormat -> NonDetDeps -> String
showNonDetDeps AText [] = "deterministic"
showNonDetDeps ANote [] = ""
showNonDetDeps fmt (x:xs) =
(if fmt==AText then "depends on non-deterministic operations: " else "") ++
intercalate "," (map (\ (mn,fn) -> mn++"."++fn) (x:xs))
--- Non-deterministic dependency analysis.
nondetDepAnalysis :: Analysis NonDetDeps
nondetDepAnalysis = dependencyFuncAnalysis "NonDetDependency" [] nondetDeps
-- An operation is non-deterministic if its definition is potentially
-- non-deterministic (i.e., the dependency is the operation itself)
-- or it depends on some called non-deterministic function.
-- TODO: check if non-determinism is encapsulated by set function
-- so that it is actually a deterministic function
nondetDeps :: FuncDecl -> [(QName,NonDetDeps)] -> NonDetDeps
nondetDeps func calledFuncs =
if isNondetDefined func
then [funcName func]
else sort (nub (concatMap snd calledFuncs))
------------------------------------------------------------------------------
------------------------------------------------------------------------------
--- RootReplaced analysis:
--- This analysis returns for each function f all functions to which this can
--- be replaced at the root. For instance, if there are the definitions:
---
--- f x = g x
--- g x = h x
--- h x = k x : []
---
--- then the root replacements of f are [g,h].
--- This analysis could be useful to detect simple loops, e.g., if
--- a function is in its root replacement.
---
--- @author Michael Hanus
--- @version June 2016
------------------------------------------------------------------------------
module RootReplaced
where
import Analysis
import FlatCurry.Types
import List
import Sort(sort)
------------------------------------------------------------------------------
--- Data type to represent root replacement information.
--- Basically, it is the set (represented as a sorted list) of
--- all function names to which a function can be root replaced.
type RootReplaced = [QName]
-- Show determinism information as a string.
showRootRepl :: AOutFormat -> RootReplaced -> String
showRootRepl AText [] = "no root replacements"
showRootRepl ANote [] = ""
showRootRepl fmt (x:xs) =
(if fmt==AText then "root replacements: " else "") ++
intercalate "," (map (\ (mn,fn) -> mn++"."++fn) (x:xs))
--- Root replacement analysis.
rootReplAnalysis :: Analysis RootReplaced
rootReplAnalysis = dependencyFuncAnalysis "RootReplaced" [] rrFunc
rrFunc :: FuncDecl -> [(QName,RootReplaced)] -> RootReplaced
rrFunc (Func _ _ _ _ rule) calledFuncs = rrFuncRule calledFuncs rule
rrFuncRule :: [(QName,RootReplaced)] -> Rule -> RootReplaced
rrFuncRule _ (External _) = [] -- nothing known about external functions
rrFuncRule calledFuncs (Rule _ rhs) = rrOfExp rhs
where
rrOfExp exp = case exp of
Var _ -> []
Lit _ -> []
Comb ct g _ ->
if ct == FuncCall
then maybe (error $ "Abstract value of " ++ show g ++ " not found!")
(\grrs -> if g `elem` grrs then grrs
else insertBy (<=) g grrs)
(lookup g calledFuncs)
else []
Typed e _ -> rrOfExp e
Free _ e -> rrOfExp e
Let _ e -> rrOfExp e
Or e1 e2 -> sort (union (rrOfExp e1) (rrOfExp e2))
Case _ e bs -> sort (foldr union (rrOfExp e)
(map (\ (Branch _ be) -> rrOfExp be) bs))
------------------------------------------------------------------------------
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment