diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,12 @@ +cabal-dev/ +dist/ +doc/ +*.hi +*.o +Parser.hs +Lexer.hs +grammar.log +thesis.log +dsinf +thesis.pdf + diff --git a/1.c b/1.c new file mode 100644 --- /dev/null +++ b/1.c @@ -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 (,-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))))])) +]) +*/ diff --git a/Advice.hs b/Advice.hs new file mode 100644 --- /dev/null +++ b/Advice.hs @@ -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 diff --git a/AllStructures.hs b/AllStructures.hs new file mode 100644 --- /dev/null +++ b/AllStructures.hs @@ -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] diff --git a/Analyzer.hs b/Analyzer.hs new file mode 100644 --- /dev/null +++ b/Analyzer.hs @@ -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 diff --git a/C/Analyzer.hs b/C/Analyzer.hs new file mode 100644 --- /dev/null +++ b/C/Analyzer.hs @@ -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 diff --git a/C/Functions.hs b/C/Functions.hs new file mode 100644 --- /dev/null +++ b/C/Functions.hs @@ -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]) + ] diff --git a/C/tests/d1_delmax_d2_max.c b/C/tests/d1_delmax_d2_max.c new file mode 100644 --- /dev/null +++ b/C/tests/d1_delmax_d2_max.c @@ -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)); +} diff --git a/C/tests/d1_ins_upd_delmax_max_d2_ins_delmax.c b/C/tests/d1_ins_upd_delmax_max_d2_ins_delmax.c new file mode 100644 --- /dev/null +++ b/C/tests/d1_ins_upd_delmax_max_d2_ins_delmax.c @@ -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)); +} diff --git a/C/tests/ins_max.c b/C/tests/ins_max.c new file mode 100644 --- /dev/null +++ b/C/tests/ins_max.c @@ -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)); +} diff --git a/C/tests/ins_sea_upd_max.c b/C/tests/ins_sea_upd_max.c new file mode 100644 --- /dev/null +++ b/C/tests/ins_sea_upd_max.c @@ -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)); +} diff --git a/C/tests/rec_ins_upd_max.c b/C/tests/rec_ins_upd_max.c new file mode 100644 --- /dev/null +++ b/C/tests/rec_ins_upd_max.c @@ -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)); +} diff --git a/CompileDriver.hs b/CompileDriver.hs new file mode 100644 --- /dev/null +++ b/CompileDriver.hs @@ -0,0 +1,2 @@ +module CompileDriver where + diff --git a/Defs/Common.hs b/Defs/Common.hs new file mode 100644 --- /dev/null +++ b/Defs/Common.hs @@ -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) + diff --git a/Defs/Structures.hs b/Defs/Structures.hs new file mode 100644 --- /dev/null +++ b/Defs/Structures.hs @@ -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) diff --git a/Defs/Util.hs b/Defs/Util.hs new file mode 100644 --- /dev/null +++ b/Defs/Util.hs @@ -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 _ _ _ = [] diff --git a/Il/AST.hs b/Il/AST.hs new file mode 100644 --- /dev/null +++ b/Il/AST.hs @@ -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 = [] diff --git a/Il/Analyzer.hs b/Il/Analyzer.hs new file mode 100644 --- /dev/null +++ b/Il/Analyzer.hs @@ -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 diff --git a/Il/Lexer.x b/Il/Lexer.x new file mode 100644 --- /dev/null +++ b/Il/Lexer.x @@ -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 +} diff --git a/Il/Parser.y b/Il/Parser.y new file mode 100644 --- /dev/null +++ b/Il/Parser.y @@ -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" + +} diff --git a/Il/Typechecker.hs b/Il/Typechecker.hs new file mode 100644 --- /dev/null +++ b/Il/Typechecker.hs @@ -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 diff --git a/Il/tests/d1_delmax_d2_max.il b/Il/tests/d1_delmax_d2_max.il new file mode 100644 --- /dev/null +++ b/Il/tests/d1_delmax_d2_max.il @@ -0,0 +1,7 @@ +int main() +{ + ds d1 + ds d2 + delete_max(d1) + max(d2) +} diff --git a/Il/tests/d1_ins_upd_delmax_max_d2_ins_delmax.il b/Il/tests/d1_ins_upd_delmax_max_d2_ins_delmax.il new file mode 100644 --- /dev/null +++ b/Il/tests/d1_ins_upd_delmax_max_d2_ins_delmax.il @@ -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) +} diff --git a/Il/tests/ins_max.il b/Il/tests/ins_max.il new file mode 100644 --- /dev/null +++ b/Il/tests/ins_max.il @@ -0,0 +1,12 @@ +int main() +{ + ds d + int i + + for(i = 0; i < 20; i++) + { + insert(d, i) + } + + max(d) +} diff --git a/Il/tests/ins_sea_upd_max.il b/Il/tests/ins_sea_upd_max.il new file mode 100644 --- /dev/null +++ b/Il/tests/ins_sea_upd_max.il @@ -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) +} diff --git a/Il/tests/rec_ins_upd_max.il b/Il/tests/rec_ins_upd_max.il new file mode 100644 --- /dev/null +++ b/Il/tests/rec_ins_upd_max.il @@ -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) +} diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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 + diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 + 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 diff --git a/Recommend.hs b/Recommend.hs new file mode 100644 --- /dev/null +++ b/Recommend.hs @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Tests.hs b/Tests.hs new file mode 100644 --- /dev/null +++ b/Tests.hs @@ -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 diff --git a/data-structure-inferrer.cabal b/data-structure-inferrer.cabal new file mode 100644 --- /dev/null +++ b/data-structure-inferrer.cabal @@ -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 + +-- 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 diff --git a/dsimp/ds.h b/dsimp/ds.h new file mode 100644 --- /dev/null +++ b/dsimp/ds.h @@ -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); diff --git a/dsimp/linkedlist.c b/dsimp/linkedlist.c new file mode 100644 --- /dev/null +++ b/dsimp/linkedlist.c @@ -0,0 +1,48 @@ +#include + +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) +{ + +} +