data-structure-inferrer (empty) → 1.0
raw patch · 36 files changed
+2146/−0 lines, 36 filesdep +ansi-terminaldep +arraydep +basesetup-changed
Dependencies added: ansi-terminal, array, base, deepseq, derive, directory, filepath, language-c, mtl, random, safe, utility-ht
Files
- .gitignore +12/−0
- 1.c +21/−0
- Advice.hs +84/−0
- AllStructures.hs +185/−0
- Analyzer.hs +151/−0
- C/Analyzer.hs +202/−0
- C/Functions.hs +42/−0
- C/tests/d1_delmax_d2_max.c +9/−0
- C/tests/d1_ins_upd_delmax_max_d2_ins_delmax.c +27/−0
- C/tests/ins_max.c +15/−0
- C/tests/ins_sea_upd_max.c +15/−0
- C/tests/rec_ins_upd_max.c +24/−0
- CompileDriver.hs +2/−0
- Defs/Common.hs +9/−0
- Defs/Structures.hs +87/−0
- Defs/Util.hs +47/−0
- Il/AST.hs +70/−0
- Il/Analyzer.hs +100/−0
- Il/Lexer.x +108/−0
- Il/Parser.y +179/−0
- Il/Typechecker.hs +181/−0
- Il/tests/d1_delmax_d2_max.il +7/−0
- Il/tests/d1_ins_upd_delmax_max_d2_ins_delmax.il +25/−0
- Il/tests/ins_max.il +12/−0
- Il/tests/ins_sea_upd_max.il +14/−0
- Il/tests/rec_ins_upd_max.il +16/−0
- LICENSE +19/−0
- Main.hs +107/−0
- Makefile +35/−0
- README.md +84/−0
- Recommend.hs +29/−0
- Setup.hs +2/−0
- Tests.hs +71/−0
- data-structure-inferrer.cabal +91/−0
- dsimp/ds.h +16/−0
- dsimp/linkedlist.c +48/−0
+ .gitignore view
@@ -0,0 +1,12 @@+cabal-dev/+dist/+doc/+*.hi+*.o+Parser.hs+Lexer.hs+grammar.log+thesis.log+dsinf+thesis.pdf+
+ 1.c view
@@ -0,0 +1,21 @@+typedef int dstype;++#include "dsimp/ds.h"++int main(int argc, const char *argv[])+{+ ds d1;+ dselem de1;+ insert_d(d1, 4);+ return 0;+}+/*+Right (CTranslUnit+[ CDeclExt (CDecl [CTypeSpec (CSUType (CStruct CStructTag (Just "ds") (Just []) [] ) )] [] )+, CDeclExt (CDecl [CStorageSpec (CExtern ),CTypeSpec (CVoidType )] [(Just (CDeclr (Just "insert") [CFunDeclr (Right ([CDecl [CTypeSpec (CSUType (CStruct CStructTag (Just "ds") Nothing [] ) )] [(Just (CDeclr Nothing [CPtrDeclr [] ] Nothing [] (OnlyPos <no file> (<no file>,-1))),Nothing,Nothing)] ,CDecl [CTypeSpec (CIntType )] [] ],False)) [] ] Nothing [] ),Nothing,Nothing)] )+, CFDefExt (CFunDef [CTypeSpec (CIntType )] (CDeclr (Just "main") [CFunDeclr (Right ([CDecl [CTypeSpec (CIntType )] [(Just (CDeclr (Just "argc") [] Nothing [] ),Nothing,Nothing)] ,CDecl [CTypeQual (CConstQual ),CTypeSpec (CCharType )] [(Just (CDeclr (Just "argv") [CArrDeclr [] (CNoArrSize False) ,CPtrDeclr [] ] Nothing [] ),Nothing,Nothing)] ],False)) [] ] Nothing [] ) [] (CCompound []+ [CBlockDecl (CDecl [CTypeSpec (CSUType (CStruct CStructTag (Just "ds") Nothing [] ) )] [(Just (CDeclr (Just "d1") [] Nothing [] ),Nothing,Nothing)] )+ ,CBlockStmt (CExpr (Just (CCall (CVar "insert" ) [CUnary CAdrOp (CVar "d1" ) ,CConst (CIntConst 4 )] )) )+ ,CBlockStmt (CReturn (Just (CConst (CIntConst 0))))]))+])+*/
+ Advice.hs view
@@ -0,0 +1,84 @@+-- | Module providing helpful tips about minimizing the complexity of the chosen data structure+module Advice+ ( adviceDS,+ printAdvice,+ adviceDS',+ printAdvice' ) where++import Defs.Util+import Defs.Structures++import Recommend++import Data.List++-- | Type for advice data+data Advice = Advice {+ advisedDS :: Structure, -- ^ Structure to be advised+ reducedOperations :: [OperationName], -- ^ Operations on which the structure is better than the recommended one+ operations :: [OperationName] -- ^ Original operations (we can get recommendations from them)+ } deriving Show++-- | Checks if structure @s1@ is not worse than structure @s2@ on operations @opns@+notWorse :: Structure -> Structure -> [OperationName] -> Bool+notWorse s1 s2 opns = compareDS s1 s2 opns /= LT++-- | Checks if the structure @s1@ is better than the structure @s2@ on operations @opns@+better :: Structure -> Structure -> [OperationName] -> Bool+better s1 s2 opns | s1 == s2 = True+ | otherwise = compareDS s1 s2 opns == GT+-- | Checks if the structure @s1@ is better than each of the structures in @ss@ on operations @opns@+betterThanEach :: Structure -> [Structure] -> [OperationName] -> Bool+betterThanEach s1 ss opns = all (\s2-> better s1 s2 opns) ss++-- | Removes already recommended data structures @recs@ from the advised structures+filterAdviceForRecommended :: [Structure] -> [Advice] -> [Advice]+filterAdviceForRecommended recs = filter (\(Advice ds _ _) -> ds `notElem` recs)++-- | Returns advice data for operations @opns@ and at most @n@ operations to forget about+adviceDS' :: Integer -> [OperationName] -> [Advice]+adviceDS' n opns = let+ recOrig = recommendAllDs opns+ opnsSeqs = sequencesOfLen opns (genericLength opns - n)+ recSeqs = concatMap (\sq -> map (\x -> Advice x sq opns) $ filter (\ds-> betterThanEach ds recOrig sq) (recommendAllDs sq)) opnsSeqs+ in filterAdviceForRecommended recOrig recSeqs++-- | Returns advice data for operations @opns@+adviceDS :: [OperationName] -> [Advice]+adviceDS = adviceDS' 1++-- | Pretty prints effects of 'adviceDS''+printAdvice' :: (String -> IO ()) -> Integer -> [OperationName] -> IO ()+printAdvice' output n opns = do+ yellowColor+ let adv = adviceDS' n opns+ let rec = recommendAllDs opns+ if length rec == 1+ then do+ output "Currently, the recommended data structure is: "+ cyanColor+ output $ (getDSName $ head rec) ++ "\n"+ yellowColor+ else do+ output "Currently, the recommended data structures are: "+ cyanColor+ output $ (foldl (\str ds -> (str ++ ", " ++ getDSName ds)) "" rec) ++ "\n"+ yellowColor+ mapM_ (printAdviceStructure output) adv+ resetColor++-- | Prints one 'Advice' element+printAdviceStructure :: (String -> IO ()) -> Advice -> IO()+printAdviceStructure output (Advice s betterOpns opns) = do+ output "You could use "+ greenColor+ output $ getDSName s+ yellowColor+ output ", if you removed the following operations:\n"+ redColor+ output $ concatMap (\opn -> "* " ++ show opn ++ "\n") (opns \\ betterOpns)+ resetColor++-- | Pretty prints effects of 'adviceDS'+printAdvice :: (String -> IO ()) -> [OperationName] -> IO ()+printAdvice output = printAdvice' output 1
+ AllStructures.hs view
@@ -0,0 +1,185 @@+-- | Module for adding possible structures and functions modifying the structures+module AllStructures+ ( allStructures,+ rbt,+ hash,+ ll,+ heap) where++import Defs.Structures++import Data.List+import Data.Maybe++-- | A function that adds an extremal element cache to a data structure+extremalElemCache :: Structure -> Structure+extremalElemCache (DS name ops) = DS (name ++ " with extreme element caching") ops' where+ extVal = fromJust $ find (\dsop -> getOpName dsop == ExtremalVal) ops+ delByRef = fromJust $ find (\dsop -> getOpName dsop == DeleteByRef) ops+ ops' = [Op DeleteByRef (max (getComplexity extVal) (getComplexity delByRef)),+ Op ExtremalVal (LinLog 0 0, N)] +++ filter (\dsop -> getOpName dsop `notElem` [ExtremalVal, DeleteByRef]) ops++-- | A function that links the elements of a data structure+linkedLeaves :: Structure -> Structure+linkedLeaves (DS name ops) = DS (name ++ " with linked leaves") ops' where+ bndByRef = fromJust $ find (\dsop -> getOpName dsop == BoundByRef) ops+ insVal = fromJust $ find (\dsop -> getOpName dsop == InsertVal) ops+ findByVal = fromJust $ find (\dsop -> getOpName dsop == InsertVal) ops+ ops' = [Op BoundByRef (LinLog 0 0, N),+ Op InsertVal (max (getComplexity bndByRef) (getComplexity insVal))] +++ filter (\dsop -> getOpName dsop `notElem` [InsertVal, BoundByRef]) ops++{-+ Op BoundByRef+ Op DecreaseValByRef+ Op DeleteByRef+ Op DeleteExtremalVal+ Op Difference+ Op Empty+ Op ExtremalVal+ Op FindByVal+ Op InsertVal+ Op Intersection+ Op Map+ Op Size+ Op SymDifference+ Op Union+ Op UpdateByRef+-}++-- | Linked list+ll :: Structure+ll = DS "Linked List" [+ Op BoundByRef (LinLog 1 0, N),+ Op DecreaseValByRef (LinLog 0 0, N),+ Op DeleteByRef (LinLog 0 0, N),+ Op DeleteExtremalVal (LinLog 1 0, N),+ Op Difference (LinLog 2 0, N),+ Op Empty (LinLog 0 0, N),+ Op ExtremalVal (LinLog 1 0, N),+ Op FindByVal (LinLog 1 0, N),+ Op InsertVal (LinLog 0 0, N),+ Op Intersection (LinLog 2 0, N),+ Op Map (LinLog 1 0, N),+ Op Size (LinLog 0 0, N),+ Op SymDifference (LinLog 2 0, N),+ Op Union (LinLog 0 0, N),+ Op UpdateByRef (LinLog 0 0, N)+ ]+-- | Red Black Trees+rbt :: Structure+rbt = DS "Red-Black Trees" [+ Op BoundByRef (LinLog 0 1, N),+ Op DecreaseValByRef (LinLog 0 1, N),+ Op DeleteByRef (LinLog 0 1, N),+ Op DeleteExtremalVal (LinLog 0 1, N),+ Op Difference (LinLog 1 1, N),+ Op Empty (LinLog 0 0, N),+ Op ExtremalVal (LinLog 1 0, N),+ Op FindByVal (LinLog 0 1, N),+ Op InsertVal (LinLog 0 1, N),+ Op Intersection (LinLog 1 1, N),+ Op Map (LinLog 1 0, N),+ Op Size (LinLog 0 0, N),+ Op SymDifference (LinLog 1 1, N),+ Op Union (LinLog 1 1, N),+ Op UpdateByRef (LinLog 0 1, N)+ ]+-- | Hashtable+hash :: Structure+hash = DS "Hashtable" [+ Op BoundByRef (LinLog 1 0, N),+ Op DecreaseValByRef (LinLog 0 0, N),+ Op DeleteByRef (LinLog 0 0, N),+ Op DeleteExtremalVal (LinLog 1 0, N),+ Op Difference (LinLog 1 0, N),+ Op Empty (LinLog 0 0, N),+ Op ExtremalVal (LinLog 1 0, N),+ Op InsertVal (LinLog 0 0, AE),+ Op Intersection (LinLog 1 0, N),+ Op Map (LinLog 1 0, N),+ Op Size (LinLog 0 0, N),+ Op SymDifference (LinLog 1 0, N),+ Op Union (LinLog 1 0, AE),+ Op UpdateByRef (LinLog 0 0, N)+ ]+-- | Heap+heap :: Structure+heap = DS "Heap" [+ Op BoundByRef (LinLog 0 0, N),+ Op DecreaseValByRef (LinLog 0 1, N),+ Op DeleteByRef (LinLog 0 1, N),+ Op DeleteExtremalVal (LinLog 0 1, N),+ Op Difference (LinLog 1 0, N),+ Op Empty (LinLog 0 0, N),+ Op ExtremalVal (LinLog 0 0, N),+ Op FindByVal (LinLog 1 0, N),+ Op InsertVal (LinLog 0 1, N),+ Op Intersection (LinLog 1 0, N),+ Op Map (LinLog 1 0, N),+ Op Size (LinLog 0 0, N),+ Op SymDifference (LinLog 1 0, N),+ Op Union (LinLog 0 0, N),+ Op UpdateByRef (LinLog 0 0, N)+ ]+{-+binom = DS "Binomial Heap" [+ Op BoundByRef+ Op DeleteByRef + Op Difference+ Op FindByVal (LinLog 1 0, N),+ Op Intersection+ Op SymDifference + Op UpdateByRef+ Op InsertVal (LinLog 0 0, A),+ Op DeleteExtremalVal (LinLog 0 1, N),+ Op DecreaseValByRef (LinLog 0 1, N),+ Op ExtremalVal (LinLog 0 0, N),+ Op Map (LinLog 1 0, N),+ Op Size (LinLog 0 0, N),+ Op Union (LinLog 0 1, N),+ Op Empty (LinLog 0 0, N)+ ]++fibo = DS "Fibonacci Heap" [+ Op BoundByRef+ Op DeleteByRef+ Op Difference+ Op FindByVal+ Op Intersection+ Op SymDifference+ Op UpdateByRef+ Op InsertVal (LinLog 0 0, A),+ Op DeleteExtremalVal (LinLog 0 1, N),+ Op DecreaseValByRef (LinLog 0 0, N),+ Op ExtremalVal (LinLog 0 0, N),+ Op Map (LinLog 1 0, N),+ Op Size (LinLog 0 0, N),+ Op Union (LinLog 0 0, A),+ Op Empty (LinLog 0 0, N)+ ]++array = DS "Array" [+ Op BoundByRef (LinLog 0 0, N),+ Op DecreaseValByRef (LinLog 0 0, N),+ Op DeleteByRef (LinLog 0 0, N),+ Op DeleteExtremalVal (LinLog 1 0, N),+ Op Difference (LinLog 2 0, N),+ Op Empty (LinLog 0 0, N),+ Op ExtremalVal (LinLog 0 0, N),+ Op FindByVal (LinLog 1 0, N),+ Op Intersection (LinLog 2 0, N),+ Op Map (LinLog 1 0, N),+ Op Size (LinLog 0 0, N),+ Op SymDifference (LinLog 2 0, N),+ Op Union (LinLog 1 0, N),+ Op UpdateByRef (LinLog 0 0, N),+ ]+-}++-- | List of all possible structures+allStructures :: [Structure]+allStructures = [rbt, hash, heap, ll] +++ map extremalElemCache [rbt, hash, ll] +++ map linkedLeaves [rbt] --, binom, array, fibo]
+ Analyzer.hs view
@@ -0,0 +1,151 @@+module Analyzer where+--TODO export list++import Data.Monoid+import Data.Maybe+import Data.Maybe.HT+import Data.List+import Data.Function+import Control.Monad.State+import Control.Arrow+import Safe++import Defs.Util+import Defs.Common+import Defs.Structures++import Advice+import Recommend++-- | Data structure use case+data DSUse = DSU {+ getDSUName :: OperationName, -- ^ Operation used+ isHeavilyUsed :: Bool, -- ^ Is it heavily used+ isUserDependent :: Bool -- ^ Is it dependent on some external input (user, network, random, signals, etc.)+ } deriving (Show, Eq)++-- | Data structure for analysis info for one data-structure (possibly in many forms of different variables in functions)+data DSInfo = DSI {+ getDSINames :: [(FunctionName, VariableName)], -- ^ Variables, used in functions, holding the analyzed data structure+ getDSIDSU :: [DSUse] -- ^ 'DSUse's of the data structure+ } deriving (Show, Eq)++instance Monoid DSInfo where+ mempty = DSI [] []+ mappend (DSI n1 d1) (DSI n2 d2) = DSI (n1 `union` n2) (d1 `union` d2)++-- | Data structure for analysis info of a function definition+data DSFun t = DSF {+ getDSFFun :: FunctionDeclaration t, -- ^ Analyzed function declaration+ getDSFCalls :: [FunctionCall], -- ^ 'FunctionCall's from the analyzed function+ getDSFDSI :: [DSInfo] -- ^ 'DSInfo' about the variables inside of the function, at this stage are not yet ready to obtain the information+ } deriving (Show)++-- | Type for function definitions+data FunctionDeclaration t = FunDecl {+ getFunName :: FunctionName, -- ^ Name of the function+ getFunType :: t, -- ^ Return type of the function+ getFunArgs :: [(VariableName, t)] -- ^ Names and types of the function arguments+ } deriving (Show)++-- | Function call - name of the function, relevant arguments+type FunctionCall = (FunctionName, [Maybe VariableName])++-- | State monad with 'TermAnalyzerState'+type TermAnalyzer a = State TermAnalyzerState a++-- | Term analyzer basic output, variables and 'DSUse's+type Output = [(VariableName, DSUse)]++-- | State of the analyzer+data TermAnalyzerState = AS {+ getStateCalls :: [FunctionCall] -- ^ 'FunctionCall's gathered through the analysis+ } deriving (Show)++instance Monoid TermAnalyzerState where+ mempty = AS []+ mappend (AS cs1) (AS cs2) = AS (cs1 `union` cs2)++-- | Name of the starting function+startingFunction :: FunctionName+startingFunction = F "main"++-- | Pretty print single 'DSInfo'+printDSI :: (String -> IO ()) -> DSInfo -> IO ()+printDSI output dsi = do+ output "The recommended structure for:\n"+ printDSINames $ getDSINames dsi+ output "is:\n"+ cyanColor+ recommendedDS >>= output . show+ output "\n"+ resetColor where+ recommendedDS = do+ let opns = map getDSUName $ getDSIDSU dsi+ recommendDS opns++ printDSINames [] = return ()+ printDSINames ((F fn,V vn):ns) = greenColor >> output vn >> resetColor >> output " in " >> greenColor >> output fn >> resetColor >> output "\n"++-- | Pretty print advice for a single 'DSInfo'+printDSIAdvice :: (String -> IO ()) -> DSInfo -> IO ()+printDSIAdvice output dsi = do+ let opns = map getDSUName $ getDSIDSU dsi+ printAdvice output opns++-- | Pretty printer for the analyzer effects+printRecommendationFromAnalysis :: (String -> IO ()) -> [DSInfo] -> IO()+printRecommendationFromAnalysis output = mapM_ (printDSI output)++-- | Pretty printer for the advisor effects+printAdviceFromAnalysis :: (String -> IO ()) -> [DSInfo] -> IO ()+printAdviceFromAnalysis output = mapM_ (printDSIAdvice output)++-- | Stupid merging of dsis --TODO remove this function, rewrite analyzeFunctions correctly+stupidMerge :: [DSInfo] -> [DSInfo]+stupidMerge (dsi:dsis) = let (same, different) = partition (\dsi' -> getDSINames dsi `intersect` getDSINames dsi' /= []) dsis in+ mconcat (dsi:same) : stupidMerge different+stupidMerge [] = []++-- | Merges the simple 'DSInfo's based on function calls from the functions+analyzeFunctions :: [DSFun t] -> [DSInfo]+analyzeFunctions dsfs = let startingDSF = lookupDSF dsfs startingFunction in+ let functions = map getDSFFun dsfs in+ let startingVars = map snd $ concatMap getDSINames $ getDSFDSI startingDSF in+ let runMain = mapMaybe (\var -> analyzeFunction functions startingDSF var []) startingVars in --update the accumulator+ concatMap (uncurry (:)) runMain where+ analyzeFunction :: [FunctionDeclaration t] -> DSFun t1 -> VariableName -> [FunctionName] -> Maybe (DSInfo, [DSInfo])+ analyzeFunction functions dsf variable accumulator = let functionName = getFunName.getDSFFun $ dsf in+ toMaybe (functionName `notElem` accumulator) (let functionCalls = getDSFCalls dsf in+ let relevantFunctionCalls = filter (\(_, funArgs) -> Just variable `elem` funArgs) functionCalls in+ let irrelevantFunctionCalls = functionCalls \\ relevantFunctionCalls in --TODO remodel so we also analyze those+ let dsis = getDSFDSI dsf in+ let thisVariableDSI = lookupDSI dsis variable functionName in+ let otherVariablesDSIs = dsis \\ [thisVariableDSI] in+ let variableBindings = map (\call@(funName, _) -> second (bindFuncall functions funName) call) relevantFunctionCalls in+ let recursiveCalls = mapMaybe (\(funName, varPairs) -> (analyzeFunction functions (lookupDSF dsfs funName) (lookupJust variable varPairs) (funName:accumulator))) variableBindings in+ let relevantRecursiveDSI = mconcat $ map fst recursiveCalls in+ let irrelevantRecursiveDSI = concatMap snd recursiveCalls in+ (thisVariableDSI `mappend` relevantRecursiveDSI, otherVariablesDSIs `union` irrelevantRecursiveDSI))++-- | Lookup 'DSFun' by 'FunctionName'+lookupDSF :: [DSFun t] -> FunctionName -> DSFun t+lookupDSF dsfs functionName = lookupJust functionName (zip (map (getFunName.getDSFFun) dsfs) dsfs)++-- | Lookup 'DSInfo' by 'FunctionName' and 'VariableName'+lookupDSI :: [DSInfo] -> VariableName -> FunctionName -> DSInfo+lookupDSI dsis variable functionName = findJust (\dsi -> (functionName, variable) `elem` getDSINames dsi) dsis++-- | Returns pairs of local variables bound to variables in a function that is called+bindFuncall :: [FunctionDeclaration t] -> FunctionName -> [Maybe VariableName] -> [(VariableName, VariableName)]+bindFuncall functions functionName vns = let+ function = findJust (\function -> getFunName function == functionName) functions in+ maybeZipWith bindZipper vns (map fst (getFunArgs function)) where+ bindZipper :: Maybe VariableName -> VariableName -> Maybe (VariableName, VariableName)+ bindZipper (Just a) b = Just (a,b)+ bindZipper Nothing _ = Nothing++-- | Generates simple 'DSInfo's without the info from function calls+generateDSI :: FunctionName -> Output -> [DSInfo]+generateDSI funName dsus = let varGroups = groupBy (on (==) fst) dsus in+ map (\g -> DSI [(funName, fst.head $ g)] (map snd g)) varGroups
+ C/Analyzer.hs view
@@ -0,0 +1,202 @@+module C.Analyzer (analyzeC) where++import Control.Monad.State+import Data.Either+import Language.C+import Language.C.Data.Ident+import Language.C.System.GCC+import Data.List++import Analyzer+import Defs.Common+import Defs.Structures+import C.Functions++-- | Name of the starting function+startingFunction :: FunctionName+startingFunction = F "main"+++analyzeC :: FilePath -> IO [DSInfo]+analyzeC file = do+ ast <- parseMyFile file+ let (eithers, s) = runState (analyzeCTranslUnit ast) (AS [])+ return $ stupidMerge $ analyzeFunctions $ rights eithers++parseMyFile :: FilePath -> IO CTranslUnit+parseMyFile input_file =+ do parse_result <- parseCFile (newGCC "gcc") Nothing [] input_file+ case parse_result of+ Left parse_err -> error (show parse_err)+ Right ast -> return ast++-- | Puts a function call into the state+putCall :: FunctionName -> [CExpr] -> TermAnalyzer ()+putCall name exprs = do+ let cleanArgs = map justifyArgs exprs+ modify $ \s -> s {getStateCalls = (name, cleanArgs) : getStateCalls s} where+ justifyArgs :: CExpr -> Maybe VariableName+ justifyArgs (CVar (Ident v _ _) _) = Just (V v)+ justifyArgs _ = Nothing -- TODO function calls returning struct ds or a pointer, not only vars++getName :: CDeclr -> String+getName (CDeclr (Just (Ident str _ _)) _ _ _ _) = str+getName (CDeclr Nothing _ _ _ _) = error "function without a name? that's just ridiculous"++getType :: [CDeclSpec] -> CTypeSpec+getType declSpecs = let (_,_,_,specs,_) = partitionDeclSpecs declSpecs in+ if length specs > 1+ then error $ show specs -- >:D+ else head specs++getArgsWithTypes :: CDeclr -> [(VariableName, CTypeSpec)]+getArgsWithTypes declr = [] --STUB++analyzeCTranslUnit :: CTranslUnit -> TermAnalyzer [Either Output (DSFun CTypeSpec)] --TODO add global variables here+analyzeCTranslUnit (CTranslUnit extDecls _) = mapM analyzeCExtDecl extDecls++analyzeCExtDecl :: CExtDecl -> TermAnalyzer (Either Output (DSFun CTypeSpec)) --TODO add global variables here+analyzeCExtDecl (CDeclExt decl) = Left `fmap` analyzeCDecl decl+analyzeCExtDecl (CFDefExt cFunDef) = Right `fmap` analyzeCFunDef cFunDef+analyzeCExtDecl a@(CAsmExt strLit dunno) = return $ Left [] --HMMM do i want to play with asm++analyzeCDecl :: CDecl -> TermAnalyzer Output+analyzeCDecl (CDecl declSpecs tripleList _) = fmcs [analyzeCDeclSpecs declSpecs, analyzeCTripleList tripleList]++analyzeCInit :: CInit -> TermAnalyzer Output+analyzeCInit (CInitExpr expr _) = analyzeCExpr expr+analyzeCInit (CInitList initList _) = analyzeCInitList initList++analyzeCInitList :: CInitList -> TermAnalyzer Output+analyzeCInitList initList = fmcs $ map (\(pds, init) -> fmcs $ analyzeCInit init : map analyzeCDesignator pds) initList++analyzeCTripleList :: [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> TermAnalyzer Output+analyzeCTripleList tripleList = fmcs $+ map (manalyzeCDeclr . (\(f,_,_) -> f)) tripleList +++ map (manalyzeCInit . (\(_,s,_) -> s)) tripleList +++ map (manalyzeCExpr . (\(_,_,t) -> t)) tripleList++analyzeCDeclSpecs :: [CDeclSpec]-> TermAnalyzer Output+analyzeCDeclSpecs declSpecs = let (_,attribs,_,_,_) = partitionDeclSpecs declSpecs in+ fmcs $ map analyzeCAttr attribs++analyzeCFunDef :: CFunDef -> TermAnalyzer (DSFun CTypeSpec)+analyzeCFunDef (CFunDef declSpecs declr declarations statement _) = do+ let funDec = FunDecl (F $ getName declr) (getType declSpecs) (getArgsWithTypes declr)+ modify $ \s -> s {getStateCalls = []}+ body <- fmcs $+ [ analyzeCDeclSpecs declSpecs+ , analyzeCDeclr declr+ , analyzeCStat statement] ++ map analyzeCDecl declarations+ s <- get+ return DSF {getDSFFun = funDec, getDSFCalls = getStateCalls s, getDSFDSI = generateDSI (getFunName funDec) body}++analyzeCDerivedDeclarator :: CDerivedDeclr -> TermAnalyzer Output+analyzeCDerivedDeclarator (CPtrDeclr qualifs _) = fmcs $ map analyzeCTypeQualifier qualifs+analyzeCDerivedDeclarator (CArrDeclr qualifs arrsize _) = fmcs $ analyzeCArraySize arrsize : map analyzeCTypeQualifier qualifs+analyzeCDerivedDeclarator (CFunDeclr eidentpair attribs _) = return [] --undefined --FIXME implement this shit++analyzeCAttr :: CAttr -> TermAnalyzer Output+analyzeCAttr (CAttr ident exprs _) = fmcs $ map analyzeCExpr exprs++analyzeCTypeQualifier :: CTypeQual -> TermAnalyzer Output+analyzeCTypeQualifier (CConstQual _) = return []+analyzeCTypeQualifier (CVolatQual _) = return []+analyzeCTypeQualifier (CRestrQual _) = return []+analyzeCTypeQualifier (CInlineQual _) = return []+analyzeCTypeQualifier (CAttrQual attrib) = analyzeCAttr attrib++analyzeCArraySize :: CArrSize -> TermAnalyzer Output+analyzeCArraySize (CNoArrSize _) = return []+analyzeCArraySize (CArrSize _ expr) = analyzeCExpr expr++analyzeCDeclr :: CDeclr -> TermAnalyzer Output+analyzeCDeclr (CDeclr mident derives mliteral attribs _) = fmcs $+ map analyzeCDerivedDeclarator derives ++ map analyzeCAttr attribs++analyzeCStat :: CStat -> TermAnalyzer Output+analyzeCStat (CLabel ident statement attribs _) = fmcs $ analyzeCStat statement : map analyzeCAttr attribs+analyzeCStat (CCase expr statement _) = fmcs [analyzeCExpr expr, analyzeCStat statement]+analyzeCStat (CCases expr1 expr2 statement _) = fmcs $ analyzeCStat statement : map analyzeCExpr [expr1, expr2]+analyzeCStat (CDefault statement _) = analyzeCStat statement+analyzeCStat (CExpr mexpr _) = manalyzeCExpr mexpr+analyzeCStat (CCompound idents compoundBlockItems _) = fmcs $ map analyzeCCompoundBlockItem compoundBlockItems+analyzeCStat (CIf expr statement mstatement _) = fmcs+ [analyzeCExpr expr+ , analyzeCStat statement+ , manalyzeCStat mstatement] --TODO fix to substitute environments for cases+analyzeCStat (CSwitch expr statement _) = fmcs [analyzeCExpr expr, analyzeCStat statement]+analyzeCStat (CWhile expr statement isdowhile _) = fmcs [analyzeCExpr expr, analyzeCStat statement]+analyzeCStat (CFor emexprdecl mexpr1 mexpr2 statement _)= fmcs $+ either manalyzeCExpr analyzeCDecl emexprdecl :+ analyzeCStat statement :+ map manalyzeCExpr [mexpr1, mexpr2]+analyzeCStat (CGoto ident _) = return [] --TODO implement goto+analyzeCStat (CGotoPtr expr _) = analyzeCExpr expr --TODO implement goto+analyzeCStat (CCont _) = return []+analyzeCStat (CBreak _) = return []+analyzeCStat (CReturn mexpr _) = manalyzeCExpr mexpr+analyzeCStat (CAsm asm _) = return [] --HMMM do i really want to care about somebody's asm?++analyzeCCompoundBlockItem :: CBlockItem -> TermAnalyzer Output+analyzeCCompoundBlockItem (CBlockStmt statement) = analyzeCStat statement+analyzeCCompoundBlockItem (CBlockDecl declaration) = analyzeCDecl declaration+analyzeCCompoundBlockItem (CNestedFunDef funDef) = return [] --TODO implement nested functions++analyzeCExpr :: CExpr -> TermAnalyzer Output+analyzeCExpr (CAlignofExpr expr _) = analyzeCExpr expr+analyzeCExpr (CAlignofType decln _) = analyzeCDecl decln+analyzeCExpr (CAssign assignop expr1 expr2 _) = fmcs $ map analyzeCExpr [expr1, expr2]+analyzeCExpr (CBinary binop expr1 expr2 _) = fmcs $ map analyzeCExpr [expr1, expr2] +analyzeCExpr (CBuiltinExpr builtin) = analyzeCBuiltin builtin+analyzeCExpr (CCall (CVar (Ident funName _ _) _) (CVar (Ident varName _ _) _:exprs) _) = do+ analysis <- fmcs $ map analyzeCExpr exprs+ case find (\(fd,_) -> getFunName fd == (F funName)) dsinfFunctions of+ Just (_,ops) -> putCall (F funName) exprs >> (return $ analysis ++ map (\op -> (V varName, DSU op False False)) ops)+ Nothing -> return analysis+analyzeCExpr (CCall expr exprs _) = fmcs $ map analyzeCExpr (expr : exprs) --TODO calling a pointer+analyzeCExpr (CCast decln expr _) = fmcs [analyzeCDecl decln, analyzeCExpr expr]+analyzeCExpr (CComma exprs _) = fmcs $ map analyzeCExpr exprs+analyzeCExpr (CComplexImag expr _) = analyzeCExpr expr+analyzeCExpr (CComplexReal expr _) = analyzeCExpr expr+analyzeCExpr (CCompoundLit decln initList _) = fmcs [analyzeCDecl decln, analyzeCInitList initList]+analyzeCExpr (CCond expr1 mexpr expr2 _) = fmcs $ manalyzeCExpr mexpr : map analyzeCExpr [expr1, expr2]+analyzeCExpr (CConst const) = return []+analyzeCExpr (CIndex expr1 expr2 _) = fmcs $ map analyzeCExpr [expr1, expr2]+analyzeCExpr (CLabAddrExpr ident _) = return []+analyzeCExpr (CMember expr ident dereferred _) = analyzeCExpr expr+analyzeCExpr (CSizeofExpr expr _) = analyzeCExpr expr+analyzeCExpr (CSizeofType decln _) = analyzeCDecl decln+analyzeCExpr (CStatExpr statement _) = analyzeCStat statement+analyzeCExpr (CUnary unop expr _) = analyzeCExpr expr+analyzeCExpr (CVar ident _) = return []++analyzeCBuiltin :: CBuiltin -> TermAnalyzer Output+analyzeCBuiltin (CBuiltinVaArg expr decl _) = fmcs [analyzeCExpr expr, analyzeCDecl decl]+analyzeCBuiltin (CBuiltinOffsetOf decl cPartDesns _) = fmcs $ analyzeCDecl decl : map analyzeCDesignator cPartDesns+analyzeCBuiltin (CBuiltinTypesCompatible decl1 decl2 _) = fmcs $ map analyzeCDecl [decl1, decl2]++analyzeCDesignator :: CDesignator -> TermAnalyzer Output+analyzeCDesignator (CArrDesig expr _) = analyzeCExpr expr+analyzeCDesignator (CMemberDesig ident _) = return []+analyzeCDesignator (CRangeDesig expr1 expr2 _) = fmcs $ map analyzeCExpr [expr1, expr2]++-- |Shortcut for 'fmap' 'concat' . 'sequence', useful in combining analysis of subterms+fmcs :: (Functor m, Monad m) => [m [a]] -> m [a]+fmcs = fmap concat . sequence++-- | Wrapper for analyzing 'Maybe' values+ma :: (a -> TermAnalyzer Output) -> Maybe a -> TermAnalyzer Output+ma = maybe (return [])++manalyzeCDeclr :: Maybe CDeclr -> TermAnalyzer Output+manalyzeCDeclr = ma analyzeCDeclr++manalyzeCStat :: Maybe CStat -> TermAnalyzer Output+manalyzeCStat = ma analyzeCStat++manalyzeCExpr :: Maybe CExpr -> TermAnalyzer Output+manalyzeCExpr = ma analyzeCExpr++manalyzeCInit :: Maybe CInit -> TermAnalyzer Output+manalyzeCInit = ma analyzeCInit
+ C/Functions.hs view
@@ -0,0 +1,42 @@+module C.Functions (dsinfFunctions) where++import Defs.Structures+import Analyzer+import Defs.Common++import Language.C+import Language.C.Data.Ident+import Language.C.Data.Position++pos :: Position+pos = position 0 "" 0 0++ni :: NodeInfo+ni = NodeInfo pos (pos,0) (Name 0)++void :: CTypeSpec+void = CVoidType ni++int :: CTypeSpec+int = CIntType ni++ds :: CTypeSpec+ds = CTypeDef (Ident "ds" 0 ni) ni++dsElem :: CTypeSpec+dsElem = CTypeDef (Ident "dselem" 0 ni) ni++-- | Basic functions for data-structure access+dsinfFunctions :: [(FunctionDeclaration CTypeSpec, [OperationName])]+dsinfFunctions = [+ (FunDecl (F "update_d") void [(V "ds", ds), (V "oldval", int), (V "newval", int)], [UpdateByRef, FindByVal]),+ (FunDecl (F "insert_d") dsElem [(V "ds", ds), (V "elem", int)] , [InsertVal]),+ (FunDecl (F "delete_d") void [(V "ds", ds), (V "elem", int)] , [DeleteByRef, FindByVal]),+ (FunDecl (F "max_d") dsElem [(V "ds", ds)] , [ExtremalVal]),+ (FunDecl (F "min_d") dsElem [(V "ds", ds)] , [ExtremalVal]), --FIXME Minmax problem+ (FunDecl (F "delete_max_d") void [(V "ds", ds)] , [DeleteExtremalVal]),+ (FunDecl (F "delete_min_d") void [(V "ds", ds)] , [DeleteExtremalVal]),+ (FunDecl (F "search_d") dsElem [(V "ds", ds), (V "elem", int)] , [FindByVal]),+ (FunDecl (F "update_de") void [(V "elem", dsElem), (V "newval", int)] , [UpdateByRef]),+ (FunDecl (F "delete_de") void [(V "elem", dsElem)] , [DeleteByRef])+ ]
+ C/tests/d1_delmax_d2_max.c view
@@ -0,0 +1,9 @@+typedef int dstype;+#include "../../dsimp/ds.h"+int main()+{+ ds d1;+ ds d2;+ delete_max_d(d1);+ printf("%d\n", max_d(d2));+}
+ C/tests/d1_ins_upd_delmax_max_d2_ins_delmax.c view
@@ -0,0 +1,27 @@+typedef int dstype;++#include "../../dsimp/ds.h"++int main()+{+ ds d1;+ ds d2;+ for(int i = 0; i < 20; i++)+ {+ insert_d(d1, i);+ }++ for(int i = 0; i < 10; i++)+ {+ insert_d(d2, i);+ update_d(d1, i, 2*i);+ }++ for(int i = 0; i < 5; i++)+ {+ delete_max_d(d1);+ delete_max_d(d2);+ }++ printf("%d\n", max_d(d1));+}
+ C/tests/ins_max.c view
@@ -0,0 +1,15 @@+typedef int dstype;++#include "../../dsimp/ds.h"++int main()+{+ ds d;++ for(int i = 0; i < 20; i++)+ {+ insert_d(d, i);+ }++ printf("%d\n", max_d(d));+}
+ C/tests/ins_sea_upd_max.c view
@@ -0,0 +1,15 @@+typedef int dstype;+#include "../../dsimp/ds.h"+int main()+{+ ds d1;++ for(int i = 0; i < 20; i++)+ {+ insert_d(d1, i);+ printf("%d\n", search_d(d1, i));+ update_d(d1, i, 2*i);+ }++ printf("%d\n", max_d(d1));+}
+ C/tests/rec_ins_upd_max.c view
@@ -0,0 +1,24 @@+struct keyval {+ int key;+ int val;+};++int main()+{+ ds d1;++ struct keyval rec, rec2;+ rec.key = 5;+ rec.val = 1337;++ rec2.key = 10;+ rec2.val = 1337;++ for(int i = 0; i < 20; i++)+ {+ insert(d1, rec);+ update(d1, rec, rec2);+ }++ printf("%d\n", max(d1));+}
+ CompileDriver.hs view
@@ -0,0 +1,2 @@+module CompileDriver where+
+ Defs/Common.hs view
@@ -0,0 +1,9 @@+module Defs.Common where+-- | Type for names+type Name = String++-- | Type for storing the variable names defined in a program+newtype VariableName = V { unV :: String } deriving (Show, Eq)+-- | Type for storing the function names defined in a program+newtype FunctionName = F { unF :: String } deriving (Show, Eq)+
+ Defs/Structures.hs view
@@ -0,0 +1,87 @@+module Defs.Structures where++import Data.Ord+import Defs.Util++-- | Data structure for keeping data structures+data Structure = DS { getDSName :: String, -- ^ name of the data structure+ getDSOps :: [DSOperation] -- ^ operations along with their complexities+ } deriving Eq++instance Show Structure where+ show = getDSName++-- | Type for operation names+data OperationName = InsertVal -- ^ Insert an element+ | DeleteByRef -- ^ Delete the element+ | FindByVal -- ^ Find the element by value+ | UpdateByRef -- ^ Update the value+ | DeleteExtremalVal -- ^ Delete the extreme value+ | ExtremalVal -- ^ Maximum or minimum+ | BoundByRef -- ^ Precedessor or successor+ | DecreaseValByRef -- ^ Update that decreases the value+ | Union -- ^ Union+ | Intersection -- ^ Intersection+ | Difference -- ^ Difference+ | SymDifference -- ^ Symmetric difference+ | Map -- ^ Map elements+ | Size -- ^ Checking the size+ | Empty -- ^ Checking the empiness+ deriving (Show, Eq)++-- | Additional complexity qualifiers+data ComplexityCharacteristics = N -- ^ Normal time+ | A -- ^ Amortized time+ | E -- ^ Expected time+ | AE -- ^ Amortized expected time+ deriving (Ord, Eq, Show)++-- | Full complexity type+type Complexity = (AsymptoticalComplexity, ComplexityCharacteristics)++-- | Asymptotical complexity type, remembered as the exponent of the @n@ and the number of stacked logarithms+data AsymptoticalComplexity = LinLog { getLin :: Integer, -- ^ exponent of @n@+ getLog :: Integer -- ^ number of the stacked logarithms+ } deriving (Eq)++-- | Greater structure is slower+instance Ord AsymptoticalComplexity where+ compare (LinLog l1 l2) (LinLog r1 r2) = case compare l1 r1 of+ EQ -> compare l2 r2+ x -> x++instance Show AsymptoticalComplexity where+ show (LinLog 0 0) = "O(1)"+ show (LinLog 1 0) = "O(n)"+ show (LinLog 0 n) = "O(" ++ logs n ++ " n)"+ show (LinLog 1 n) = "O(n " ++ logs n ++ " n)"+ show (LinLog n 0) = "O(n^" ++ show n ++ ")"+ show (LinLog n m) = "O(n^" ++ show n ++ " " ++ logs m ++ " n)"++-- | Function to pretty print stacked logarithms+logs :: Integer -> String+logs 0 = ""+logs n = "log" ++ logs (n-1)++-- | Type for operation and its complexity+data DSOperation = Op { getOpName :: OperationName, -- ^ Operation name+ getComplexity :: Complexity -- ^ Complexity of the operation+ } deriving (Show, Eq)++instance Ord DSOperation where+ compare (Op _ c1) (Op _ c2) = compare c1 c2++-- | Function to check which of the two data structures, on given operations, is better+compareDS :: Structure -> Structure -> [OperationName] -> Ordering+compareDS s1 s2 opns = let ops1 = filter (\x -> getOpName x `elem` opns) (getDSOps s1)+ ops2 = filter (\x -> getOpName x `elem` opns) (getDSOps s2) in+ case Data.Ord.comparing length ops1 ops2 of+ LT -> LT+ GT -> GT+ EQ -> if null ops1+ then EQ+ else case Data.Ord.comparing maximum ops1 ops2 of+ LT -> GT+ GT -> LT+ EQ -> let ordList = zipWith compare ops1 ops2 in+ compare (countElem GT ordList) (countElem LT ordList)
+ Defs/Util.hs view
@@ -0,0 +1,47 @@+module Defs.Util where+import System.Console.ANSI+import Data.List++-- | Changes the color of the terminal output to green+greenColor :: IO()+greenColor = setSGR [SetColor Foreground Vivid Green]+-- | Changes the color of the terminal output to blue+blueColor :: IO()+blueColor = setSGR [SetColor Foreground Vivid Blue]+-- | Changes the color of the terminal output to yellow+yellowColor :: IO()+yellowColor = setSGR [SetColor Foreground Dull Yellow]+-- | Changes the color of the terminal output to red+redColor :: IO()+redColor = setSGR [SetColor Foreground Vivid Red]+-- | Changes the color of the terminal output to cyan+cyanColor :: IO()+cyanColor = setSGR [SetColor Foreground Vivid Cyan]+-- | Resets the color of the terminal output+resetColor :: IO()+resetColor = setSGR [Reset]++-- | Count the number of occurences of a given element in the list+countElem :: Eq a => a -> [a] -> Integer+countElem y xs = genericLength $ filter (== y) xs++-- | Find all subsequences of length @n@ and longer than sequence @xs@+sequencesOfLen :: Eq a => [a] -> Integer -> [[a]]+sequencesOfLen xs n = filter (\s -> genericLength s >= n && (s /= xs)) $ subsequences xs++-- | A function inspired by python's string.split(). A list is split+-- on a separator which is itself a list (not a single element).+split :: Eq a => [a] -> [a] -> [[a]]+split tok splitme = unfoldr (sp1 tok) splitme+ where sp1 _ [] = Nothing+ sp1 t s = case find (t `isSuffixOf`) $ inits s of+ Nothing -> Just (s, [])+ Just p -> Just (take (length p - length t) p,+ drop (length p) s)++-- | Like zipWith only returns only those elements of type 'c' that were qualified with Just+maybeZipWith :: (a -> b -> Maybe c) -> [a] -> [b] -> [c]+maybeZipWith f (x:xs) (y:ys) = case f x y of+ Just z -> z : maybeZipWith f xs ys+ Nothing -> maybeZipWith f xs ys+maybeZipWith _ _ _ = []
+ Il/AST.hs view
@@ -0,0 +1,70 @@+{-# OPTIONS_GHC -pgmF derive-ghc -F #-}+-- | Module with Abstract Syntax Tree syntax+module Il.AST where++import Control.DeepSeq++import Defs.Common++-- | Type for function definitions+data Function = Function { getFunName :: FunctionName, -- ^ Name of the function+ getFunType :: Type, -- ^ Return type, Nothing when void+ getFunArgs :: [(VariableName, Type)], -- ^ Names and types of the function arguments+ getFunBody :: Term } -- ^ Body of the function+ deriving (Show, Eq)++-- | Type for language operations+data Term = And Term Term -- ^ Logical and+ | Assign VariableName Term -- ^ Variable assignment+ | Block [Term] -- ^ Block of operations+ | Dec VariableName -- ^ Decrement+ | Div Term Term -- ^ Division+ | Eq Term Term -- ^ Equality test+ | For Term Term Term Term -- ^ For loop+ | Funcall FunctionName [Term] -- ^ Function call+ | Geq Term Term -- ^ Greater or equal test+ | Gt Term Term -- ^ Greater than test+ | If Term Term Term -- ^ If-else statement+ | Inc VariableName -- ^ Increment+ | Int Int -- ^ Integer Constant+ | InitAssign VariableName Term Type -- ^ Variable declaration and assignment+ | Leq Term Term -- ^ Less or equal test+ | Lt Term Term -- ^ Less than thest+ | Mul Term Term -- ^ Multiplication+ | Not Term -- ^ Logical not+ | Or Term Term -- ^ Logical or+ | Record [(String, Term)] -- ^ Record+ | Return Term -- ^ Return a value from a function+ | Sub Term Term -- ^ Subtraction+ | Sum Term Term -- ^ Addition+ | While Term Term -- ^ While loop+ | Var VariableName -- ^ Variable+ | VarInit VariableName Type -- ^ Variable declaration+ deriving (Show, Eq)++-- | Type for the language values+data Type = TInt -- ^ Integer+ | TVoid -- ^ Void+ | TBool -- ^ Boolean+ | Ds -- ^ Data structure reference+ | DsElem -- ^ Data structure element reference+ | TRec [(String, Type)] -- ^ Record+ deriving (Show, Eq {-!, NFData !-})++-- | Basic functions for data-structure access+dsinfFunctions :: [Function]+dsinfFunctions = [+ Function (F "update") TVoid [(V "ds", Ds), (V "oldval", TInt), (V "newval", TInt)] (Block []),+ Function (F "insert") DsElem [(V "ds", Ds), (V "elem", TInt)] (Block []),+ Function (F "delete") TVoid [(V "ds", Ds), (V "elem", TInt)] (Block []),+ Function (F "max") DsElem [(V "ds", Ds)] (Block []),+ Function (F "min") DsElem [(V "ds", Ds)] (Block []),+ Function (F "delete_max") TVoid [(V "ds", Ds)] (Block []),+ Function (F "search") DsElem [(V "ds", Ds), (V "elem", TInt)] (Block []),+ Function (F "update") TVoid [(V "elem", DsElem), (V "newval", TInt)] (Block []),+ Function (F "delete") TVoid [(V "elem", DsElem)] (Block [])+ ]++-- | Functions that are easilly decomposed into 'dsinfFunctions' functions+dsinfAliasFunctions :: [Function]+dsinfAliasFunctions = []
+ Il/Analyzer.hs view
@@ -0,0 +1,100 @@+{-# OPTIONS_GHC -fno-warn-unused-binds #-} --TODO++module Il.Analyzer (analyzeIl) where++import Defs.Structures+import Defs.Common+import Il.AST++import Analyzer hiding (getFunName, getFunArgs, getFunType)++import Data.Monoid+import Control.Monad.State++-- | Runs everything that is needed to analyze a program+analyzeIl :: [Function] -> [DSInfo]+analyzeIl functions = let dsfs = map generateDSF functions in+ stupidMerge $ analyzeFunctions dsfs++-- | Start the state monad to create a 'DSFun' for function+generateDSF :: Function -> DSFun Type+generateDSF fn = let (dsus, st) = runState (sumTerms step [getFunBody fn]) (AS []) in+ let fd = FunDecl (getFunName fn) (getFunType fn) (getFunArgs fn) in+ DSF fd (getStateCalls st) (generateDSI (getFunName fn) dsus)++-- | Analyze a block of terms using the state monad+stepBlock :: [Term] -> TermAnalyzer Output+stepBlock = sumTerms step++-- | Sums the 'DSUse's using the 'step' function and concating the results+sumTerms :: (Term -> TermAnalyzer Output) -> [Term] -> TermAnalyzer Output+sumTerms f ts = fmap concat (mapM f ts)++-- | Function putting a function call in the state+putCall :: FunctionName -> [Term] -> TermAnalyzer ()+putCall name args = do+ let cleanArgs = map justifyVars args+ let call = (name, cleanArgs)+ modify $ \s -> s {getStateCalls = call:getStateCalls s} where+ justifyVars :: Term -> Maybe VariableName+ justifyVars (Var v) = Just v -- FIXME should work on function calls returning dses, not only vars+ justifyVars _ = Nothing++-- | Generate 'DSUse's for a single 'Term'+step :: Term -> TermAnalyzer Output++step (Block body) = stepBlock body++step (VarInit _ Ds) = return []+step (InitAssign _ _ Ds) = return []++step (While cond body) = stepBlock [cond,body]++step (Funcall name args) = do+ let opname = case name of -- FIXME nicer with usage of dsinfFunctions from Common+ F "insert" -> Just InsertVal+ F "find" -> Just FindByVal+ F "update" -> Just UpdateByRef+ F "max" -> Just ExtremalVal+ F "delete_max" -> Just DeleteExtremalVal+ _ -> Nothing+ -- FIXME add reading the function calls+ argDsus <- stepBlock args++ funcallDsu <- case opname of+ Nothing -> do+ putCall name args+ return []+ Just op -> case head args of -- FIXME dsinfFunctions ds argument recognition+ Var varname -> return [(varname, DSU op False False)]+ _ -> error "Not implemented yet"++ return $ argDsus ++ funcallDsu++step (If cond t1 t2) = do+ dsuCond <- step cond+ oldState <- get++ dsuT1 <- step t1+ stateT1 <- get++ put oldState++ dsuT2 <- step t2+ stateT2 <- get++ put (stateT1 `mappend` stateT2)+ return $ concat [dsuCond, dsuT1, dsuT2]++-- Dummy steps+step t = case t of+ Var _ -> return []+ VarInit _ _ -> return []+ Inc _ -> return []+ Dec _ -> return []+ Int _ -> return []++ Assign _ t -> step t+ Lt t1 t2 -> stepBlock [t1, t2]+ Mul t1 t2 -> stepBlock [t1, t2]+ s -> error $ "No step for " ++ show s
+ Il/Lexer.x view
@@ -0,0 +1,108 @@+{+{-# OPTIONS_GHC -w #-}+module Il.Lexer where+import Prelude hiding (lex)+}++%wrapper "posn"++$digit = 0-9+$alpha = [a-zA-Z]++tokens :-+ (\n)+ { \p s -> tokenWithPos p TkNewline }+ ($white # \n)+ ;+ $digit+ { \p s -> tokenWithPos p (TkInt (read s)) }+ and { \p s -> tokenWithPos p TkAnd }+ if { \p s -> tokenWithPos p TkIf }+ then { \p s -> tokenWithPos p TkThen }+ else { \p s -> tokenWithPos p TkElse }+ false { \p s -> tokenWithPos p TkFalse }+ return { \p s -> tokenWithPos p TkReturn }+ true { \p s -> tokenWithPos p TkTrue }+ for { \p s -> tokenWithPos p TkFor }+ while { \p s -> tokenWithPos p TkWhile }+ null { \p s -> tokenWithPos p TkNull }+ or { \p s -> tokenWithPos p TkOr }+ ds { \p s -> tokenWithPos p TkDs }+ dselem { \p s -> tokenWithPos p TkDsElem }+ int { \p s -> tokenWithPos p TkTInt }+ bool { \p s -> tokenWithPos p TkTBool }+ void { \p s -> tokenWithPos p TkTVoid }+ "++" { \p s -> tokenWithPos p TkInc }+ "+" { \p s -> tokenWithPos p TkPlus }+ "--" { \p s -> tokenWithPos p TkDec }+ "-" { \p s -> tokenWithPos p TkMinus }+ "*" { \p s -> tokenWithPos p TkMul }+ "/" { \p s -> tokenWithPos p TkDiv }+ "!" { \p s -> tokenWithPos p TkNot }+ "," { \p s -> tokenWithPos p TkComma }+ ";" { \p s -> tokenWithPos p TkSemicolon }+ "." { \p s -> tokenWithPos p TkDot }+ "==" { \p s -> tokenWithPos p TkEquals }+ ">=" { \p s -> tokenWithPos p TkGEqual }+ "<=" { \p s -> tokenWithPos p TkLEqual }+ "=" { \p s -> tokenWithPos p TkAssign }+ "(" { \p s -> tokenWithPos p TkLParen }+ "{" { \p s -> tokenWithPos p TkLCParen }+ "[" { \p s -> tokenWithPos p TkLSParen }+ "<" { \p s -> tokenWithPos p TkLess }+ ")" { \p s -> tokenWithPos p TkRParen }+ "}" { \p s -> tokenWithPos p TkRCParen }+ "]" { \p s -> tokenWithPos p TkRSParen }+ ">" { \p s -> tokenWithPos p TkGreater }+ $alpha (_ | $digit | $alpha)* { \p s -> tokenWithPos p (TkName s) }+{+data BaseToken = TkAnd+ | TkAssign+ | TkColon+ | TkComma+ | TkDec+ | TkDiv+ | TkDot+ | TkDs+ | TkDsElem+ | TkElse+ | TkEquals+ | TkFalse+ | TkFor+ | TkGEqual+ | TkGreater+ | TkIf+ | TkInc+ | TkInt Int+ | TkLAParen+ | TkLCParen+ | TkLSParen+ | TkLEqual+ | TkLess+ | TkLParen+ | TkMinus+ | TkMul+ | TkName String+ | TkNewline+ | TkNot+ | TkNull+ | TkOr+ | TkPlus+ | TkReturn+ | TkRAParen+ | TkRCParen+ | TkRSParen+ | TkRParen+ | TkSemicolon+ | TkThen+ | TkTrue+ | TkTInt+ | TkTBool+ | TkTVoid+ | TkWhile+ deriving (Show, Eq)++type Token = ((Int,Int), BaseToken)++tokenWithPos :: AlexPosn -> BaseToken -> Token+tokenWithPos (AlexPn _ line col) t = ((line,col),t)++lex = alexScanTokens+}
+ Il/Parser.y view
@@ -0,0 +1,179 @@+{+{-# OPTIONS_GHC -w #-}+module Il.Parser where++import Il.Lexer+import Il.AST+import Defs.Common++import Prelude+}++%name parse funlist++%tokentype { Token }+%error { parseError }++%token+ And { (_,TkAnd) }+ Assign { (_,TkAssign) }+ Comma { (_,TkComma) }+ Dec { (_,TkDec) }+ Div { (_,TkDiv) }+ Ds { (_,TkDs) }+ DsElem { (_,TkDsElem) }+ Else { (_,TkElse) }+ Equals { (_,TkEquals) }+ TFalse { (_,TkFalse) }+ For { (_,TkFor) }+ GEqual { (_,TkGEqual) }+ Greater { (_,TkGreater) }+ If { (_,TkIf) }+ Inc { (_,TkInc) }+ Int { (_,TkInt $$) }+ LCParen { (_,TkLCParen) }+ LSParen { (_,TkLSParen) }+ LEqual { (_,TkLEqual) }+ LParen { (_,TkLParen) }+ Less { (_,TkLess) }+ Minus { (_,TkMinus) }+ Mul { (_,TkMul) }+ Name { (_,TkName $$) }+ Newline { (_,TkNewline) }+ Not { (_,TkNot) }+ Null { (_,TkNull) }+ Or { (_,TkOr) }+ Plus { (_,TkPlus) }+ RCParen { (_,TkRCParen) }+ RSParen { (_,TkRSParen) }+ Return { (_,TkReturn) }+ RParen { (_,TkRParen) }+ Semicolon { (_,TkSemicolon)}+ Then { (_,TkThen) }+ TTrue { (_,TkTrue) }+ TInt { (_,TkTInt) }+ TBool { (_,TkTBool) }+ TVoid { (_,TkTVoid) }+ While { (_,TkWhile) }++%left Else RParen+%nonassoc Not+%nonassoc Assign+%left And Or+%nonassoc Less Greater GEqual LEqual Equals+%left Plus Minus+%left Mul Div+%nonassoc Inc Dec+%nonassoc Newline+%%++funlist :: { [Function] }+funlist: fundef funlist { $1:$2 }+funlist: fundef Newline funlist { $1:$3 }+ | { [] }++fundef :: { Function }+fundef: type Name LParen argdef RParen block { Function (F $2) $1 $4 $6 }+ | type Name LParen argdef RParen Newline block { Function (F $2) $1 $4 $7 }++argdef :: { [(VariableName, Type)] }+argdef: nvtype Name Comma argdef { (V $2, $1):$4 }+ | nvtype Name { [(V $2, $1)] }+ | { [] }++type :: { Type }+type: TVoid { TVoid }+ | nvtype { $1 }++nvtype :: { Type }+nvtype: TInt { TInt }+ | TBool { TBool }+ | Ds { Ds }+ | DsElem { DsElem }+ | LSParen trecordintern RSParen { TRec $2 }++trecordintern :: { [(Name, Type)] }+trecordintern: trecordpair Comma trecordintern { $1 : $3 }+ | trecordpair { [$1] }++trecordpair :: { (Name, Type) }+trecordpair: nvtype Name { ($2, $1) }++expr :: { Term }+expr: Name Assign valexpr { Assign (V $1) $3 }+ | nvtype Name Assign valexpr { InitAssign (V $2) $4 $1 }+ | nvtype Name { VarInit (V $2) $1 }+ | block { $1 }+ | If valexpr Then expr Else expr { If $2 $4 $6 }+ | If valexpr Newline Then expr Newline Else expr { If $2 $5 $8 }+ | For LParen expr Semicolon valexpr Semicolon expr RParen expr { While $5 (Block [$3, $7, $9]) }+ | For LParen expr Semicolon valexpr Semicolon expr RParen Newline expr { While $5 (Block [$3, $7, $10]) }+ | While LParen valexpr RParen expr { While $3 $5 }+ | While LParen valexpr RParen Newline expr { While $3 $6 }+ | Return valexpr { Return $2 }+ | shexpr { $1 }++shexpr :: { Term }+shexpr: Inc Name { Inc (V $2) }+ | Name Inc { Inc (V $1) }+ | Dec Name { Dec (V $2) }+ | Name Dec { Dec (V $1) }+ | Name LParen commaseparatedlist RParen { Funcall (F $1) $3 }++valexpr :: { Term }+valexpr: Name { Var (V $1) }+ | Null { Int 0 }+ | Int { Int $1 }+ | TFalse { Int 0 }+ | TTrue { Int 1 }+ | Not valexpr { Not $2 }+ | valexpr And valexpr { And $1 $3 }+ | valexpr Or valexpr { Or $1 $3 }+ | valexpr Plus valexpr { Sum $1 $3 }+ | valexpr Minus valexpr { Sub $1 $3 }+ | valexpr Mul valexpr { Mul $1 $3 }+ | valexpr Div valexpr { Div $1 $3 }+ | valexpr Equals valexpr { Eq $1 $3 }+ | valexpr LEqual valexpr { Leq $1 $3 }+ | valexpr GEqual valexpr { Geq $1 $3 }+ | valexpr Greater valexpr { Gt $1 $3 }+ | valexpr Less valexpr { Lt $1 $3 }+ | LParen valexpr RParen { $2 }+ | record { $1 }+ | shexpr { $1 }++record :: { Term }+record: LSParen RSParen { Record [] }+ | LSParen recordintern RSParen { Record $2 }++recordintern :: { [(Name, Term)] }+recordintern: recordpair Comma recordintern { $1 : $3 }+ | recordpair { [$1] }+++recordpair :: { (Name, Term) }+recordpair: Name Assign valexpr { ($1, $3) }++block :: { Term }+block: LCParen Newline exprlist RCParen { Block $3 }+ | LCParen exprlist RCParen { Block $2 }+ | LCParen RCParen { Block [] }+ | LCParen Newline RCParen { Block [] }++exprlist :: { [Term] }+exprlist: block exprlist { $1:$2 } + | expr Newline exprlist { $1:$3 }+ | expr Newline { [$1] }+ | expr { [$1] }++commaseparatedlist :: { [Term] }+commaseparatedlist: valexpr Comma commaseparatedlist { $1:$3 }+ | valexpr { [$1] }+ | { [] }+{++parseError :: [Token] -> a+parseError (((line,col),t):xs) = error $ "Parse error at line " ++ (show line) ++ ", column " ++ (show col)+parseError [] = error "Parse error at the end"++}
+ Il/Typechecker.hs view
@@ -0,0 +1,181 @@+module Il.Typechecker where++import Defs.Common+import Il.AST++import Control.Monad.State+import Data.Maybe++-- | Variables with types, return value for a function, other declared functions+data TypeState = TS {+ getStateReturn :: Type,+ getStateFunctions :: [Function],+ getStateVariables :: [(VariableName, Type)] }++-- | State monad to remember the 'TypeState'+type Typechecker a = State TypeState a++-- | Typecheck a term block+typecheckB :: [Term] -> Typechecker [Type]+typecheckB = mapM typecheckT++-- | Assert a type to a term, raise an error otherwise+assertType :: Term -> Type -> Typechecker ()+assertType t1 tp2 = do+ tp1' <- typecheckT t1+ case tp1' of+ TVoid -> error $ "Type error: " ++ show t1 ++ " does not return a value, should return " ++ show tp2+ tp1 -> when (tp1 /= tp2) (error $ "Type error: " ++ show t1 ++ " is type " ++ show tp1 ++ ", should be" ++ show tp2)++-- | Typecheck a function definition+typecheckF :: [Function] -> Function -> [Type]+typecheckF fns (Function _ tp args (Block body)) = evalState (typecheckB body) (TS tp (dsinfFunctions ++ fns) args)+typecheckF _ (Function name _ _ _) = error $ "Function definition for " ++ show name ++ " is not a code block"++-- | Typecheck a function call+typecheckFC :: FunctionName -> [Term] -> Typechecker Type+typecheckFC f ts = do+ s <- get+ tps <- typecheckB ts+ let fns = filter (\x -> getFunName x == f && tps == map snd (getFunArgs x)) (getStateFunctions s) --FIXME add safe lookup+ case fns of+ [] -> error $ "No matching function: " ++ show f+ fn:[] -> return $ getFunType fn+ fn:fnss -> error $ "More than one function matching: " ++ show (fn:fnss)++-- | Typecheck one field of a record+typecheckR :: (String, Term) -> Typechecker (String, Type)+typecheckR (n, t) = do+ tp <- typecheckT t+ case tp of+ TVoid -> error $ "Type error: " ++ show t ++ " returning no value in a record field"+ tp1 -> return (n, tp1)++-- | Typecheck a Dec or Inc operation+typecheckIncDec :: VariableName -> Typechecker (Type)+typecheckIncDec v = do+ s <- get+ let tcx = getStateVariables s+ case lookup v tcx of+ Just TVoid -> error $ "Type error: " ++ show v ++ " is not initilized, should be initialized as " ++ show TInt+ Just TInt -> return TInt+ tp -> error $ "Type error: " ++ show v ++ " has type " ++ show tp ++ "instead of " ++ show TInt++-- | Typecheck a term, 'Nothing' symbolizes the expressions without a value+typecheckT :: Term -> Typechecker (Type)+typecheckT (And t1 t2) = logOp t1 t2++typecheckT (Assign v t1) = do+ s <- get+ let tcx = getStateVariables s+ case lookup v tcx of+ Just tp -> do+ assertType t1 tp+ return TVoid+ Nothing -> error $ "Variable " ++ show v ++ " not initialized"++typecheckT (Block ts) = do+ _ <- typecheckB ts+ return TVoid++typecheckT (Inc v) = typecheckIncDec v+typecheckT (Dec v) = typecheckIncDec v+++typecheckT (Div t1 t2) = mathOp t1 t2++typecheckT (Eq t1 t2) = relOp t1 t2++typecheckT (For t1 t2 t3 t4) = do+ _ <- typecheckT t1+ assertType t2 TBool+ _ <- typecheckT t3+ _ <- typecheckT t4+ return TVoid++typecheckT (Funcall f ts) = typecheckFC f ts++typecheckT (Geq t1 t2) = relOp t1 t2++typecheckT (Gt t1 t2) = relOp t1 t2++typecheckT (If t1 t2 t3) = do+ assertType t1 TBool+ _ <- typecheckT t2+ _ <- typecheckT t3+ return TVoid++typecheckT (Int _) = return TInt++typecheckT (InitAssign v t tp) = do+ assertType t tp+ s <- get+ let tcx = getStateVariables s+ case lookup v tcx of+ Just tp1 -> error $ "Variable " ++ show v ++ " already initialized with type " ++ show tp1+ Nothing -> do+ put $ TS (getStateReturn s) (getStateFunctions s) ((v,tp):tcx)+ return TVoid++typecheckT (Leq t1 t2) = relOp t1 t2++typecheckT (Lt t1 t2) = relOp t1 t2++typecheckT (Mul t1 t2) = mathOp t1 t2++typecheckT (Not t1) = do+ assertType t1 TBool+ return TBool++typecheckT (Or t1 t2) = logOp t1 t2++typecheckT (Record rs) = fmap (TRec) (mapM typecheckR rs)++typecheckT (Return t) = do+ s <- get+ let rt = getStateReturn s+ assertType t rt+ return TVoid++typecheckT (Sub t1 t2) = mathOp t1 t2++typecheckT (Sum t1 t2) = mathOp t1 t2++typecheckT (While t1 t2) = do+ assertType t1 TBool+ _ <- typecheckT t2+ return TVoid++typecheckT (Var v) = do+ s <- get+ let tcx = getStateVariables s+ case lookup v tcx of+ Nothing -> error $ "Variable " ++ show v ++ " not initialized"+ Just tp -> return tp++typecheckT (VarInit v tp) = do+ s <- get+ let tcx = getStateVariables s+ case lookup v tcx of+ Just tp1 -> error $ "Variable " ++ show v ++ " already initialized with type " ++ show tp1+ Nothing -> do+ put $ TS (getStateReturn s) (getStateFunctions s) ((v,tp):tcx)+ return TVoid++relOp :: Term -> Term -> Typechecker (Type)+relOp t1 t2 = do+ assertType t1 TInt+ assertType t2 TInt+ return TBool++mathOp :: Term -> Term -> Typechecker (Type)+mathOp t1 t2 = do+ assertType t1 TInt+ assertType t2 TInt+ return TInt++logOp :: Term -> Term -> Typechecker (Type)+logOp t1 t2 = do+ assertType t1 TBool+ assertType t2 TBool+ return TBool
+ Il/tests/d1_delmax_d2_max.il view
@@ -0,0 +1,7 @@+int main()+{+ ds d1+ ds d2+ delete_max(d1)+ max(d2)+}
+ Il/tests/d1_ins_upd_delmax_max_d2_ins_delmax.il view
@@ -0,0 +1,25 @@+int main()+{+ ds d1+ ds d2+ int i++ for(i = 0; i < 20; i++)+ {+ insert(d1, i)+ }++ for(i = 0; i < 10; i++)+ {+ insert(d2, i)+ update(d1, i, 2*i)+ }++ for(i = 0; i < 5; i++)+ {+ delete_max(d1)+ delete_max(d2)+ }++ max(d1)+}
+ Il/tests/ins_max.il view
@@ -0,0 +1,12 @@+int main()+{+ ds d+ int i++ for(i = 0; i < 20; i++)+ {+ insert(d, i)+ }++ max(d)+}
+ Il/tests/ins_sea_upd_max.il view
@@ -0,0 +1,14 @@+int main()+{+ ds d1+ int i+ dselem e+ for(i = 0; i < 20; i++)+ {+ insert(d1, i)+ e = search(d1, i)+ update(e, 2*i)+ }++ max(d1)+}
+ Il/tests/rec_ins_upd_max.il view
@@ -0,0 +1,16 @@+int main()+{+ ds d1+ int i++ [int key, int val] rec = [key = 5, val = 1337]+ [int key, int val] rec2 = [key = 10, val = 1337]++ for(i = 0; i < 20; i++)+ {+ insert(d1, rec)+ update(d1, rec, rec2)+ }++ max(d1)+}
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (C) 2011 by Aleksander Balicki++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Main.hs view
@@ -0,0 +1,107 @@+module Main (main) where++import System.Console.GetOpt+import System.Environment+import System.IO+import System.Exit+import Control.Monad+import Safe++--import Il.Lexer+--import Il.Parser+--import Il.Analyzer+--import Il.Typechecker+import C.Analyzer+import Analyzer++import Prelude hiding (lex)++data Action = AAdvice+ | ADefaultRecommend+ | ARecommend+ | ACompile+ | AInline deriving (Eq)++instance Show Action where+ show AAdvice = "advice (-a)"+ show ADefaultRecommend = show ARecommend+ show ARecommend = "recommend (-r)"+ show ACompile = "compile (-c)"+ show AInline = "inline (-i)"++data Options = Options { optVerbose :: Bool+ , optOutput :: String -> IO ()+ , optAction :: Action+ }+++checkArgs :: Options -> Action -> IO ()+checkArgs (Options { optAction = ADefaultRecommend }) _ = return ()+checkArgs (Options { optAction = action }) oldAction | action == oldAction = return ()+checkArgs (Options { optAction = action }) oldAction = error $ (show action) ++ " incompatible with " ++ (show oldAction)++options :: [ OptDescr (Options -> IO Options) ]+options =+ [ Option "o" ["output"]+ (ReqArg (\arg opt -> writeFile arg "" >> return opt { optOutput = appendFile arg }) "file")+ "Output file"++ , Option "r" ["recommend"]+ (NoArg (\opt -> checkArgs opt ARecommend >> return opt { optAction = ARecommend }))+ "Give recommendations about the data structure in the supplied code (default)"++ , Option "a" ["advice"]+ (NoArg (\opt -> checkArgs opt AAdvice >> return opt { optAction = AAdvice }))+ "Give advice about the data structure in the supplied code"++ , Option "c" ["compile"]+ (NoArg (\opt -> checkArgs opt ACompile >> return opt { optAction = ACompile }))+ "Compile the code with recommended structure linked"++ , Option "i" ["inline"]+ (NoArg (\opt -> checkArgs opt AInline >> return opt { optAction = AInline }))+ "Inline the code implementing the recommended structure in the supplied code"++ , Option "v" ["verbose"]+ (NoArg (\opt -> return opt { optVerbose = True }))+ "Enable verbose messages"++ , Option "h" ["help"]+ (NoArg (\_ -> do+ prg <- getProgName+ hPutStrLn stderr (usageInfo prg options)+ exitSuccess))+ "Show help"+ ]++main :: IO ()+main = do+ args <- getArgs+ case getOpt RequireOrder options args of+ (actions, files, []) -> do+ let startOptions = Options { optVerbose = False+ , optOutput = putStr+ , optAction = ARecommend+ }+ opts <- foldl (>>=) (return startOptions) actions+ let Options { optVerbose = verbose+ , optOutput = output+ , optAction = action } = opts+-- contents <- readFile (head files) --FIXME generalize with all files+-- let ast = analyzeIl.parse.lex $ contents+ dsis <- analyzeC $ headNote "no input files" files+ case action of+ AAdvice -> printAdviceFromAnalysis output dsis+ ADefaultRecommend -> printRecommendationFromAnalysis output dsis+ ARecommend -> printRecommendationFromAnalysis output dsis+ ACompile -> putStrLn "Not implemented yet"+ AInline -> putStrLn "Not implemented yet"+ exitSuccess++ (_, nonOptions, errors) -> do+ unless (errors == []) (putStrLn "Command line errors:")+ mapM_ (\s -> putStrLn ('\t' : s)) errors+ unless (nonOptions == []) (putStrLn "Command line non-options present:")+ mapM_ (\s -> putStrLn ('\t' : s)) nonOptions+ exitFailure+
+ Makefile view
@@ -0,0 +1,35 @@+IL=Il/Analyzer.hs Il/Typechecker.hs Il/AST.hs+C=C/Analyzer.hs C/Functions.hs+SRC=Advice.hs AllStructures.hs Recommend.hs Analyzer.hs Defs/*.hs ${C}+LEXPAR=Il/Lexer.hs Il/Parser.hs+CDOPTS=-package-conf cabal-dev/packages-7.2.2.conf++dsinf: ${LEXPAR} ${SRC} Main.hs+ ghc --make ${CDOPTS} -o dsinf -O Main.hs++tests: ${LEXPAR} ${SRC} Tests.hs+ ghci ${CDOPTS} -O Tests.hs++Il/Lexer.hs: Il/Lexer.x+ alex -g Il/Lexer.x++Il/Parser.hs: Il/Parser.y+ happy -g Il/Parser.y++clean:+ cabal-dev clean+ rm -f Il/Lexer.hs Il/Parser.hs+ rm -f thesis.log thesis.aux thesis.toc++cleanbin: clean+ rm -f dsinf+ rm -f thesis.pdf++doc: ${LEXPAR} ${SRC} Main.hs+ haddock --ignore-all-exports -t "Data Structure Inferrer" -o doc -h Main.hs+ git checkout gh-pages+ cp -r doc/* .+ git add .+ git commit -a -m "Automated doc push"+ git push origin gh-pages+ git checkout master
+ README.md view
@@ -0,0 +1,84 @@+# About the project+This project is meant to be a compiler feature/wrapper that analyzes your code and chooses the best data structure depending on your source code. It analyzes the functions used on a wildcard data structure and chooses the type of structure that minimizes the time complexity. It will support C language and hopefully some other languages too.++# Usage++ alistra@bialobrewy data-structure-inferrer % ./dsinf -h+ dsinf+ -o file --output=file Output file+ -r --recommend Give recommendations about the data structure in the supplied code (default)+ -a --advice Give advice about the data structure in the supplied code+ -c --compile Compile the code with recommended structure linked+ -i --inline Inline the code implementing the recommended structure in the supplied code+ -v --verbose Enable verbose messages+ -h --help Show help+++# Example (not yet working)++For the following C file:++ //example.c+ typedef int dstype;+ #include <ds.h>+ int main()+ {+ ds d1;+ dselem e;++ for(int i = 0; i < 20; i++)+ {+ insert_d(d1, i);+ printf("%d\n", search_d(d1, i));+ update_d(d1, i, 2*i);+ }++ printf("%d\n", max_d(d1));+ }++you'll invoke:++ dsinf -c example.c++and it will automatically compile the file and link the matching library with data structure implementation (here red-black trees with max element cache).++# For now++For now it works as a standalone code analyzer for a toy language that prints the most appropriate structure.++## Examples++You can run tests by running runIlTests from the Tests.hs file. These tests (Il/tests subdirectory) are source code in a simple imperative language. The analyzer infers the best data structure for operations used in the test program.++ *Tests> runIlTests+ Test File Il/tests/1.il+ The recommended structure for ds is:+ Hashtable+ Test File Il/tests/2.il+ The recommended structure for ds is:+ Red-Black Trees with extreme element caching+ The recommended structure for ds2 is:+ Red-Black Trees with extreme element caching+ Test File Il/tests/3.il+ The recommended structure for ds is:+ Red-Black Trees with extreme element caching+ The recommended structure for ds2 is:+ Linked List with extreme element caching++## Low Level++For now you can get the best structures depending on operations used in your program (if you manually put it in the invocation):++ *AllStructures> recommendAllDs [InsertVal, ExtremalVal]+ [Fibonacci Heap,Binomial Heap]+ *AllStructures> recommendAllDs [InsertVal, FindByVal ]+ [Hashtable]+ *AllStructures> recommendAllDs [InsertVal, FindByVal, ExtremalVal]+ [Red-Black Trees]++There's an advice mode which is formatted more nicely:++ *Advice> printAdvice [InsertVal, UpdateByVal, DeleteExtremalVal ]+ Currently, the recommended data structure is: Red-Black Trees+ You could use Hashtable, if you removed the following operations:+ * DeleteExtremalVal
+ Recommend.hs view
@@ -0,0 +1,29 @@+-- | Module for recommending a data structure based on operations used+module Recommend+ ( recommendDS,+ recommendAllDs ) where++import Defs.Structures++import AllStructures++import Data.List+import System.Random++-- | Recommends a data structure which is best for given operations @opns@. If there's more than one optimal structure, it chooses one at random+recommendDS :: [OperationName] -> IO Structure+recommendDS opns = do+ let sorted = reverse $ sortBy (\x y-> compareDS x y opns) allStructures+ let bestStructures = head $ groupBy (\x y -> compareDS x y opns == EQ) sorted+ ridx <- randomRIO (0, length bestStructures - 1)+ return $ bestStructures !! ridx++-- | Recommends all optimal data structures for given operations @opns@+recommendAllDs :: [OperationName] -> [Structure]+recommendAllDs opns = recommendAllDsFromList opns allStructures++-- | Recommends the best possible data structure from @structs@ for given operations @opns@+recommendAllDsFromList :: [OperationName] -> [Structure] -> [Structure]+recommendAllDsFromList opns structs = let+ sorted = reverse $ sortBy (\x y-> compareDS x y opns) structs+ in head $ groupBy (\x y -> compareDS x y opns == EQ) sorted
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Tests.hs view
@@ -0,0 +1,71 @@+-- | Testing module+module Tests+ ( runIlTests ) where++import Il.Lexer+import Il.Parser+import Defs.Util+import Defs.AST+import Analyzer+import Typechecker+import Control.DeepSeq++import System.FilePath.Posix+import Control.Exception+import Data.List+import System.Directory+import Prelude hiding (lex, catch)++-- | Runs all Il tests+runIlTests :: IO ()+runIlTests = listFiles "Il/tests/" >>= runTestFiles++-- | Run all test files given by filenames+runTestFiles :: [FilePath] -> IO()+runTestFiles = mapM_ runTest++-- | Opens a test file and runs the test+runTest :: FilePath -> IO()+runTest name = do+ yellowColor+ putStrLn $ "Test File " ++ name+ resetColor+ contents <- readFile name+ test contents++-- | Lists all filenames in a given directory+listFiles :: FilePath -> IO [FilePath]+listFiles path = do+ allfiles <- getDirectoryContents path+ let files = sort $ filter (\s -> last (split "/" s) `notElem` [".", ".."]) allfiles+ return $ map (path </>) files++-- | Lexes, parses, analyzes and pretty prints test results+test :: String -> IO()+test src = do+ let fns = (parse.lex) src+ typechecking fns `catch` handler "\nTyping failed"+ analysis fns `catch` handler "\nAnalysis failed"++-- | Tests analysis+analysis :: [Function] -> IO ()+analysis fns = do+ printRecommendationFromAnalysis.analyze $ fns+ greenColor+ putStrLn "Passed"+ resetColor++-- | Tests typechecking+typechecking :: [Function] -> IO ()+typechecking fns = mapM_ (\fn -> do+ blueColor+ deepseq (typecheckF fns fn) (putStrLn "Typed")+ resetColor) fns++-- | Handles failing tests+handler :: String -> SomeException -> IO ()+handler msg e = do+ redColor+ putStrLn msg+ print (e :: SomeException)+ resetColor
+ data-structure-inferrer.cabal view
@@ -0,0 +1,91 @@+-- data-structure-inferrer.cabal auto-generated by cabal init. For+-- additional options, see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name: data-structure-inferrer++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version: 1.0++-- A short (one-line) description of the package.+Synopsis: Program that infers the fastest data structure available for your program++-- A longer description of the package.+Description: This project is meant to be a compiler feature/wrapper that analyzes your code and chooses the best data structure depending on your source code. It analyzes the functions used on a wildcard data structure and chooses the type of structure that minimizes the time complexity. It will support C language and hopefully some other languages too.++-- URL for the project homepage or repository.+Homepage: http://github.com/alistra/data-structure-inferrer++-- The license under which the package is released.+License: MIT++-- The file containing the license text.+License-file: LICENSE++-- The package author(s).+Author: Aleksander Balicki++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer: Aleksander Balicki <balicki.aleksander@gmail.com>++-- A copyright notice.+-- Copyright:++Category: Development++Build-type: Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+-- Extra-source-files:+++-- Constraint on the version of Cabal needed to build this package.+Cabal-version: >=1.6++Source-repository head+ type: git+ location: http://github.com/alistra/data-structure-inferrer+++Executable dsinf+ -- .hs or .lhs file containing the Main module.+ Main-is: Main.hs++ -- Packages needed in order to build this package.+ Build-depends: ansi-terminal >= 0.5.0 && < 2+ , base >= 4.3.0 && < 5+ , random >= 1.0.1.1 && < 2+ , directory >= 1.1.0.1 && < 2+ , language-c >= 0.4.2 && < 1+ , filepath >= 1.2.0.1 && < 2+ , mtl >= 2.0.1.0 && < 3+ , array >= 0.3.0.3 && < 1+ , safe >= 0.3.3 && < 1+ , utility-ht >= 0.0.7.1 && < 1+ , deepseq >= 1.2.0.1 && < 2+ , derive >= 2.5.4 && < 3++ -- Modules not exported by this package.+ Other-modules: Analyzer+ , Advice+ , AllStructures+ , Recommend+ , C.Analyzer+ , C.Functions+ , Defs.Structures+ , Defs.Util+ , Defs.Common+ , Il.AST+ , Il.Lexer+ , Il.Parser+ , Il.Analyzer+ , Il.Typechecker+ , Tests+ , Main++ -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+ Build-tools: alex, happy
+ dsimp/ds.h view
@@ -0,0 +1,16 @@+struct ds;+struct dselem;+typedef struct ds *ds;+typedef struct dselem *dselem;++void insert_d(ds, dstype);+void update_d(ds, dstype);+void delete_d(ds, dstype);+dselem search_d(ds, dstype);+void delmax_d(ds);+dselem max_d(ds);+void delmin_d(ds);+dselem min_d(ds);++void delete_de(dselem);+void update_de(dselem);
+ dsimp/linkedlist.c view
@@ -0,0 +1,48 @@+#include<stdlib.h>++typedef int elem;++struct linkedlist {+ elem e;+ struct linkedlist *next;+};++struct ds {+ struct linkedlist *list;+ int elem_count;+};++struct ds* new()+{+ struct ds *d = (struct ds*) malloc(sizeof (struct ds));+ d->list = 0;+ d->elem_count = 0;+ return d;+}++void insert(struct ds *d, elem e)+{+ d->elem_count++;++ struct linkedlist *l = malloc(sizeof (struct linkedlist));+ l->e = e;+ l->next = 0;++ struct linkedlist *temp = d->list;++ if(!temp){+ d->list = l;+ return;+ }++ while(temp->next)+ temp = temp->next;++ temp->next = l;+}++void delete(struct ds *d, elem e)+{++}+