Commit 7da6a7ca authored by Michael Hanus 's avatar Michael Hanus
Browse files

Option -r (re-analyze) added to CASS, RequiredValue analysis improved

parent 1db4c461
......@@ -94,7 +94,7 @@ data RegisteredAnalysis =
RegAna String
Bool
String
(String -> [Handle] -> Maybe AOutFormat
(String -> Bool -> [Handle] -> Maybe AOutFormat
-> IO (Either (ProgInfo String) String))
([String] -> IO ())
......@@ -102,7 +102,7 @@ regAnaName :: RegisteredAnalysis -> String
regAnaName (RegAna n _ _ _ _) = n
regAnaServer :: RegisteredAnalysis
-> (String -> [Handle] -> Maybe AOutFormat
-> (String -> Bool -> [Handle] -> Maybe AOutFormat
-> IO (Either (ProgInfo String) String))
regAnaServer (RegAna _ _ _ a _) = a
......@@ -125,10 +125,10 @@ lookupRegAna aname (ra@(RegAna raname _ _ _ _) : ras) =
if aname==raname then Just ra else lookupRegAna aname ras
-- Look up a registered analysis server with a given analysis name.
lookupRegAnaServer :: String -> (String -> [Handle] -> Maybe AOutFormat
lookupRegAnaServer :: String -> (String -> Bool -> [Handle] -> Maybe AOutFormat
-> IO (Either (ProgInfo String) String))
lookupRegAnaServer aname =
maybe (\_ _ _ -> return (Right ("unknown analysis: "++aname)))
maybe (\_ _ _ _ -> return (Right ("unknown analysis: "++aname)))
regAnaServer
(lookupRegAna aname registeredAnalysis)
......@@ -145,28 +145,31 @@ debugMessage dl message =
--------------------------------------------------------------------
-- Run an analysis with a given name on a given module with a list
-- of workers identified by their handles and return the analysis results.
runAnalysisWithWorkers :: String -> AOutFormat -> [Handle] -> String
runAnalysisWithWorkers :: String -> AOutFormat -> Bool -> [Handle] -> String
-> IO (Either (ProgInfo String) String)
runAnalysisWithWorkers ananame aoutformat handles moduleName =
(lookupRegAnaServer ananame) moduleName handles (Just aoutformat)
runAnalysisWithWorkers ananame aoutformat enforce handles moduleName =
(lookupRegAnaServer ananame) moduleName enforce handles (Just aoutformat)
-- Run an analysis with a given name on a given module with a list
-- of workers identified by their handles but do not load analysis results.
runAnalysisWithWorkersNoLoad :: String -> [Handle] -> String -> IO ()
runAnalysisWithWorkersNoLoad ananame handles moduleName =
(lookupRegAnaServer ananame) moduleName handles Nothing >> done
(lookupRegAnaServer ananame) moduleName False handles Nothing >> done
--- Generic operation to analyze a module.
--- The parameters are the analysis, the show operation for analysis results,
--- the name of the main module to be analyzed, the handles for the workers,
--- the name of the main module to be analyzed,
--- a flag indicating whether the (re-)analysis should be enforced,
--- the handles for the workers,
--- and a flag indicating whether the analysis results should be loaded
--- and returned (if the flag is false, the result contains the empty
--- program information).
--- An error occurred during the analysis is returned as `(Right ...)`.
analyzeAsString :: Analysis a -> (AOutFormat->a->String) -> String -> [Handle]
-> Maybe AOutFormat -> IO (Either (ProgInfo String) String)
analyzeAsString analysis showres modname handles mbaoutformat = do
analyzeMain analysis modname handles (mbaoutformat /= Nothing) >>=
analyzeAsString :: Analysis a -> (AOutFormat->a->String) -> String -> Bool
-> [Handle] -> Maybe AOutFormat
-> IO (Either (ProgInfo String) String)
analyzeAsString analysis showres modname enforce handles mbaoutformat = do
analyzeMain analysis modname handles enforce (mbaoutformat /= Nothing) >>=
return . either (Left . mapProgInfo (showres aoutformat)) Right
where
aoutformat = maybe AText id mbaoutformat
......@@ -174,16 +177,17 @@ analyzeAsString analysis showres modname handles mbaoutformat = do
--- Generic operation to analyze a module.
--- The parameters are the analysis, the name of the main module
--- to be analyzed, the handles for the workers,
--- a flag indicating whether the (re-)analysis should be enforced,
--- and a flag indicating whether the analysis results should be loaded
--- and returned (if the flag is false, the result contains the empty
--- program information).
--- An error occurred during the analysis is returned as `(Right ...)`.
analyzeMain :: Analysis a -> String -> [Handle] -> Bool
analyzeMain :: Analysis a -> String -> [Handle] -> Bool -> Bool
-> IO (Either (ProgInfo a) String)
analyzeMain analysis modname handles load = do
analyzeMain analysis modname handles enforce load = do
let ananame = analysisName analysis
debugMessage 2 ("start analysis "++modname++"/"++ananame)
modulesToDo <- getModulesToAnalyze analysis modname
modulesToDo <- getModulesToAnalyze enforce analysis modname
let numModules = length modulesToDo
workresult <-
if numModules==0
......
......@@ -27,15 +27,17 @@ debugMessage dl message = debugMessageLevel dl ("Dependencies: "++message)
-----------------------------------------------------------------------
--- Compute the modules and their imports which must be analyzed
--- w.r.t. a given analysis and main module.
getModulesToAnalyze :: Analysis a -> String -> IO [(String,[String])]
getModulesToAnalyze analysis moduleName =
--- If the first argument is true, then the analysis is enforced
--- (even if analysis information exists).
getModulesToAnalyze :: Bool -> Analysis a -> String -> IO [(String,[String])]
getModulesToAnalyze enforce analysis moduleName =
if isSimpleAnalysis analysis
then do
ananewer <- isAnalysisFileNewer ananame moduleName
return (if ananewer then [] else [(moduleName,[])])
return (if ananewer && not enforce then [] else [(moduleName,[])])
else do
valid <- isAnalysisValid ananame moduleName
if valid
if valid && not enforce
then do
debugMessage 3 ("Analysis file for '"++moduleName++"' up-to-date")
return []
......@@ -51,7 +53,7 @@ getModulesToAnalyze analysis moduleName =
findModulesToAnalyze moduleList anaTimeList sourceTimeList ([],[])
--debugMessage 3 ("Modules up-to-date: "++ show modulesUpToDate)
withprelude <- getWithPrelude
let modulesToAnalyze =
let modulesToAnalyze = if enforce then moduleList else
if withprelude=="no"
then let reduced = reduceDependencies modulesToDo
(modulesUpToDate ++ ["Prelude"])
......@@ -64,12 +66,15 @@ getModulesToAnalyze analysis moduleName =
ananame = analysisName analysis
-- Check whether the analysis file is newer than the source file.
isAnalysisFileNewer :: String -> String -> IO Bool
isAnalysisFileNewer ananame modname = do
atime <- getAnaFileTime ananame modname
stime <- getSourceFileTime modname
return (snd atime >= Just (snd stime))
-- Read current import dependencies.
-- Read current import dependencies and checks whether the current analysis
-- file is valud.
isAnalysisValid :: String -> String -> IO Bool
isAnalysisValid ananame modname =
getImportModuleListFile modname >>= maybe
(return False)
......
......@@ -45,26 +45,27 @@ main = do
debugMessageLevel 1 systemBanner
initializeAnalysisSystem
args <- getArgs
processArgs args
processArgs False args
processArgs args = case args of
processArgs enforce args = case args of
[] -> mainServer Nothing
["-p",port] -> maybe showError
(\ (p,r) -> if all isSpace r
then mainServer (Just p)
else showError )
(readNat port)
["-h"] -> showHelp
["-?"] -> showHelp
["--help"] -> showHelp
["-p",port] -> maybe showError
(\ (p,r) -> if all isSpace r
then mainServer (Just p)
else showError )
(readNat port)
["-h"] -> showHelp
["-?"] -> showHelp
["--help"] -> showHelp
("-r":rargs) -> processArgs True rargs
(('-':'D':kvs):rargs) -> let (key,eqvalue) = break (=='=') kvs
in if null eqvalue
then showError
else do updateCurrentProperty key (tail eqvalue)
processArgs rargs
processArgs enforce rargs
[ananame,mname] ->
if ananame `elem` registeredAnalysisNames
then analyzeModule ananame (stripSuffix mname) AText >>=
then analyzeModule ananame (stripSuffix mname) enforce AText >>=
putStrLn . formatResult mname "Text" Nothing True
else showError
_ -> showError
......@@ -84,8 +85,9 @@ showHelp = putStrLn $
"Usage: cass <options> <analysis name> <module name> :\n"++
" analyze a module with a given analysis\n\n"++
"where <options> can contain:\n"++
"-Dname=val : set property (of ~/.curryanalysisrc) 'name' as 'val'\n\n"++
"Registered analyses names:\n" ++
"-Dname=val : set property (of ~/.curryanalysisrc) 'name' as 'val'\n"++
"-r : force re-analysis (i.e., ignore old analysis information)\n"++
"\nRegistered analyses names:\n" ++
unlines registeredAnalysisNames
--- Start the analysis server on a socket.
......@@ -116,7 +118,7 @@ mainServer mbport = do
--- by 'initializeAnalysisSystem'.
analyzeModuleForBrowser :: String -> String -> AOutFormat -> IO [(QName,String)]
analyzeModuleForBrowser ananame moduleName aoutformat =
analyzeModule ananame moduleName aoutformat >>=
analyzeModule ananame moduleName False aoutformat >>=
return . either pinfo2list (const [])
where
pinfo2list pinfo = let (pubinfo,privinfo) = progInfo2Lists pinfo
......@@ -128,15 +130,17 @@ analyzeModuleForBrowser ananame moduleName aoutformat =
--- by 'initializeAnalysisSystem'.
analyzeFunctionForBrowser :: String -> QName -> AOutFormat -> IO String
analyzeFunctionForBrowser ananame qn@(mname,_) aoutformat = do
analyzeModule ananame mname aoutformat >>=
analyzeModule ananame mname False aoutformat >>=
return . either (maybe "" id . lookupProgInfo qn) (const "")
--- Analyze a complete module for a given analysis result format.
--- The third argument is a flag indicating whether the
--- (re-)analysis should be enforced.
--- Note that before its first use, the analysis system must be initialized
--- by 'initializeAnalysisSystem'.
analyzeModule :: String -> String -> AOutFormat
analyzeModule :: String -> String -> Bool -> AOutFormat
-> IO (Either (ProgInfo String) String)
analyzeModule ananame moduleName aoutformat = do
analyzeModule ananame moduleName enforce aoutformat = do
let (mdir,mname) = splitDirectoryBaseName moduleName
getDefaultPath >>= setEnviron "CURRYPATH"
curdir <- getCurrentDirectory
......@@ -148,11 +152,11 @@ analyzeModule ananame moduleName aoutformat = do
serveraddress <- getServerAddress
(port,socket) <- listenOnFresh
handles <- startWorkers numworkers socket serveraddress port []
result <- runAnalysisWithWorkers ananame aoutformat handles mname
result <- runAnalysisWithWorkers ananame aoutformat enforce handles mname
stopWorkers handles
sClose socket
return result
else runAnalysisWithWorkers ananame aoutformat [] mname
else runAnalysisWithWorkers ananame aoutformat enforce [] mname
setCurrentDirectory curdir
return aresult
......@@ -174,12 +178,12 @@ analyzeGeneric analysis moduleName = do
serveraddress <- getServerAddress
(port,socket) <- listenOnFresh
handles <- startWorkers numworkers socket serveraddress port []
result <- analyzeMain analysis mname handles True
result <- analyzeMain analysis mname handles False True
stopWorkers handles
sClose socket
return result
else
analyzeMain analysis mname [] True
analyzeMain analysis mname [] False True
setCurrentDirectory curdir
return aresult
......@@ -265,6 +269,7 @@ serverLoopOnHandle socket1 whandles handle = do
else do
string <- hGetLineUntilEOF handle
debugMessageLevel 2 ("SERVER got message: "++string)
let force = False
case parseServerMessage string of
ParseError -> do
sendServerError handle ("Illegal message received: "++string)
......@@ -273,12 +278,12 @@ serverLoopOnHandle socket1 whandles handle = do
sendServerResult handle showAnalysisNamesAndFormats
serverLoopOnHandle socket1 whandles handle
AnalyzeModule ananame outForm modname public ->
catch (runAnalysisWithWorkers ananame AText whandles modname >>=
catch (runAnalysisWithWorkers ananame AText force whandles modname >>=
return . formatResult modname outForm Nothing public >>=
sendResult)
sendAnalysisError
AnalyzeEntity ananame outForm modname functionName ->
catch (runAnalysisWithWorkers ananame AText whandles modname >>=
catch (runAnalysisWithWorkers ananame AText force whandles modname >>=
return . formatResult modname outForm
(Just functionName) False >>= sendResult)
sendAnalysisError
......
......@@ -28,7 +28,7 @@ import Char(isSpace)
systemBanner =
let bannerText = "CASS: Curry Analysis Server System ("++
"version of 08/09/2014 for "++curryCompiler++")"
"version of 22/10/2014 for "++curryCompiler++")"
bannerLine = take (length bannerText) (repeat '=')
in bannerLine ++ "\n" ++ bannerText ++ "\n" ++ bannerLine
......
-----------------------------------------------------------------------------
--- Required value analysis for Curry programs
---
--- This analysis checks for each function in a Curry program whether
--- This analysis checks for each function in a Curry program whether
--- the arguments of a function must have a particular shape in order to
--- compute some value of this function.
--- For instance, the negation operation `not` requires the argument
......@@ -9,7 +9,7 @@
--- the argument `True` to compute the result `False`.
---
--- @author Michael Hanus
--- @version August 2014
--- @version October 2014
-----------------------------------------------------------------------------
module RequiredValues(AType(..),showAType,AFType(..),showAFType,lubAType,
......@@ -64,13 +64,14 @@ showAType _ (Cons (_,n)) = n --q++"."++n
showAType _ Empty = "_|_"
--- The abstract type of a function.
--- If is either `AnyFunc`, i.e., contains no information about the function,
--- It is either `EmptyFunc`, i.e., contains no information about
--- the possible result of the function,
--- or a list of possible argument/result type pairs.
data AFType = AnyFunc | AFType [([AType],AType)]
data AFType = EmptyFunc | AFType [([AType],AType)]
-- Shows an abstract value.
showAFType :: AOutFormat -> AFType -> String
showAFType _ AnyFunc = "AnyFunc"
showAFType _ EmptyFunc = "EmptyFunc"
showAFType aof (AFType fts) = intercalate " | " (map showFType fts)
where
showFType (targs,tres) =
......@@ -116,22 +117,24 @@ maxReqValues = 3
reqValueAnalysis :: Analysis AFType
reqValueAnalysis =
combinedDependencyFuncAnalysis "RequiredValue"
siblingCons AnyFunc analyseReqVal
siblingCons EmptyFunc analyseReqVal
analyseReqVal :: ProgInfo [QName] -> FuncDecl -> [(QName,AFType)] -> AFType
analyseReqVal consinfo (Func (m,f) _ _ _ rule) calledfuncs
| m==prelude = maybe anaresult id (lookup f preludeFuncs)
analyseReqVal consinfo (Func (m,f) arity _ _ rule) calledfuncs
| m==prelude = maybe (anaresult rule) id (lookup f preludeFuncs)
| otherwise = --trace ("Analyze "++f++"\n"++showCalledFuncs calledfuncs++
-- "\nRESULT: "++showAFType _ anaresult) $
anaresult
anaresult rule
where
anaresult = analyseReqValRule consinfo calledfuncs rule
anaresult (External _) = AFType [(take arity (repeat Any),Any)]
anaresult (Rule args rhs) = analyseReqValRule consinfo calledfuncs args rhs
preludeFuncs = [] -- add special results for prelude functions here
-- add special results for prelude functions here:
preludeFuncs = [("failed",AFType [([],Empty)])]
analyseReqValRule :: ProgInfo [QName] -> [(QName,AFType)] -> Rule -> AFType
analyseReqValRule _ _ (External _) = AnyFunc
analyseReqValRule consinfo calledfuncs (Rule args rhs) =
analyseReqValRule :: ProgInfo [QName] -> [(QName,AFType)] -> [Int] -> Expr
-> AFType
analyseReqValRule consinfo calledfuncs args rhs =
let initenv = extendEnv [] args
envtypes = reqValExp initenv rhs Any
rtypes = map snd envtypes
......@@ -159,24 +162,28 @@ analyseReqValRule consinfo calledfuncs (Rule args rhs) =
Lit _ -> [(env, Any)] -- too many literal constants...
Comb ConsCall c _ -> [(env, Cons c)] -- analysis of arguments superfluous
Comb FuncCall qf funargs ->
maybe [(env, Any)]
(\ftype -> case ftype of
AnyFunc -> [(env, Any)] -- no information available
AFType ftypes ->
let matchingtypes =
filter (compatibleType reqtype . snd) ftypes
-- for all matching types analyze arguments
-- where a constructor value is required:
matchingenvs =
map (\ (ts,rt) ->
let argenvs = concatMap (envForConsArg env)
(zip ts funargs)
in (foldr joinEnv env argenvs, rt))
matchingtypes
in if null matchingtypes
then [(env, Empty)]
else matchingenvs )
(lookup qf calledfuncs)
if qf==(prelude,"?") && length funargs == 2
then -- use intended definition of Prelude.? for more precise analysis:
reqValExp env (Or (head funargs) (funargs!!1)) reqtype
else
maybe [(env, Any)]
(\ftype -> case ftype of
EmptyFunc -> [(env, Empty)] -- no information available
AFType ftypes ->
let matchingtypes = filter (compatibleType reqtype . snd)
ftypes
-- for all matching types analyze arguments
-- where a constructor value is required:
matchingenvs =
map (\ (ts,rt) ->
let argenvs = concatMap (envForConsArg env)
(zip ts funargs)
in (foldr joinEnv env argenvs, rt))
matchingtypes
in if null matchingtypes
then [(env, Empty)]
else matchingenvs )
(lookup qf calledfuncs)
Comb _ _ _ -> [(env, Any)] -- no reasonable info for partial applications
Or e1 e2 -> lubEnvTypes (reqValExp env e1 reqtype)
(reqValExp env e2 reqtype)
......@@ -221,10 +228,14 @@ analyseReqValRule consinfo calledfuncs (Rule args rhs) =
caseenvs)
in map (dropEnv (length pvars)) branchenvs
--- "lub" two environment lists. All environment lists are ordered
--- by the result type.
lubEnvTypes :: [(AEnv,AType)] -> [(AEnv,AType)] -> [(AEnv,AType)]
lubEnvTypes [] ets2 = ets2
lubEnvTypes ets1@(_:_) [] = ets1
lubEnvTypes ((env1,t1):ets1) ((env2,t2):ets2)
| t1==Empty = lubEnvTypes ets1 ((env2,t2):ets2) -- ignore "empty" infos
| t2==Empty = lubEnvTypes ((env1,t1):ets1) ets2
| t1==t2 = (lubEnv env1 env2, t1) : lubEnvTypes ets1 ets2
| t1<t2 = (env1,t1) : lubEnvTypes ets1 ((env2,t2):ets2)
| otherwise = (env2,t2) : lubEnvTypes ((env1,t1):ets1) ets2
......
......@@ -201,8 +201,7 @@ transformRule lookupreqinfo tstr (Rule args rhs) =
transformExp tst (Var i) _ = (Var i, tst)
transformExp tst (Lit v) _ = (Lit v, tst)
transformExp tst0 (Comb ct qf es) reqval =
let reqtype = maybe AnyFunc id (lookupreqinfo qf)
reqargtypes = argumentTypesFor reqtype reqval
let reqargtypes = argumentTypesFor (lookupreqinfo qf) reqval
(tes,tst1) = transformExps tst0 (zip es reqargtypes)
in if (qf == pre "==" && reqval == RequiredValues.Cons (pre "True")) ||
(qf == pre "/=" && reqval == RequiredValues.Cons (pre "False"))
......@@ -270,9 +269,10 @@ caseArgType branches =
--- Compute the argument types for a given abstract function type
--- and required value.
argumentTypesFor :: AFType -> AType -> [AType]
argumentTypesFor AnyFunc _ = repeat Any
argumentTypesFor (AFType rtypes) reqval =
argumentTypesFor :: Maybe AFType -> AType -> [AType]
argumentTypesFor Nothing _ = repeat Any
argumentTypesFor (Just EmptyFunc) _ = repeat Any
argumentTypesFor (Just (AFType rtypes)) reqval =
maybe (-- no exactly matching type, look for Any type:
maybe (-- no Any type: if reqtype==Any, try lub of all other types:
if reqval==Any && not (null rtypes)
......@@ -313,7 +313,7 @@ loadPreludeBoolReqValues = do
return . either id error
return (filter (hasBoolReqValue . snd) maininfo)
where
hasBoolReqValue AnyFunc = False
hasBoolReqValue EmptyFunc = False
hasBoolReqValue (AFType rtypes) =
maybe False (const True) (find (isBoolReqValue . snd) rtypes)
......
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