initial commit

App/Optimizer.hs

@@ -0,0 +1,14 @@
+-- Optimizer module
+-- Executes Constant Folding and Dead Code Elimination
+-- sequentially until no furhter change are possible in
+-- order to minimize the program as far as possible
+module App.Optimizer where
+
+import DataFlow.Generic (hasChangedP)
+import Optimizer.DeadCode
+import Optimizer.ConstFold
+
+optimize p = if hasChangedP p p' then optimize p' else p
+    where
+      p' = opt p
+      opt = deadCode . constFold

App/Sanity.hs

@@ -0,0 +1,124 @@
+-- Sanity Checks
+module App.Sanity (sane) where
+
+import qualified Data.Set as S
+import Data.Maybe
+
+import DataFlow.Generic (vars, args, fvS, fvA, calledFuncs)
+import DataFlow.RD
+import While.ParserAS
+
+-- All used variables defined?
+varsDef' d s = S.isSubsetOf (S.fromList $ fvS s) (S.fromList d)
+varsDef (Prog d f s) = varsDef' (vars d) s &&
+                       all (\(Func _ _ a d s _) -> varsDef' (args a ++ vars d) s) f
+
+-- Missing defined variables
+missVarDef' d s = S.difference (S.fromList $ fvS s) (S.fromList d)
+missVarDefF (Func _ f a d s _) = S.map (\v -> f ++ ":" ++ v) $ missVarDef' (args a ++ vars d) s
+missVarDef (Prog d f s) = S.toList $ S.union (missVarDef' (vars d) s) (S.unions $ map missVarDefF f)
+
+missVarDefErr p = "The following variables are not defined:\n" ++ show (missVarDef p)
+
+-- Contain 't' a certain statement indicated by True return of isStat
+hasStat isStat t = isStat t || case t of
+                                 If _ _ s1 s2 -> hasStat' s1 || hasStat' s2
+                                 While _ _ s -> hasStat' s
+                                 Seq s -> any hasStat' s
+                                 _ -> False
+    where
+      hasStat' = hasStat isStat
+
+isReturn (Return _ _) = True
+isReturn _ = False
+
+hasReturn = hasStat isReturn
+
+-- Returns invalid if in program body or no return in any function
+invalidReturns (Prog _ f s) = hasReturn s || any (not . hasReturn . getFuncS) f
+
+getFuncS (Func _ _ _ _ s _) = s
+
+retErr _ = "Found return in program body or no return in a function"
+
+isWrite (Write _ _) = True
+isWrite _ = False
+
+hasWrite = hasStat isWrite
+
+-- Fails if no write within program or any function contains a write statement
+writeProg (Prog _ f s) = not (hasWrite s) || any (hasWrite . getFuncS) f
+
+writeErr _ = "Program body should contain write statement and no write in functions"
+
+isRead (Read _ _) = True
+isRead _ = False
+
+hasRead = hasStat isRead
+
+-- Fails if any function contains a read statement
+readFuncs (Prog _ f _) = any (hasRead . getFuncS) f
+
+readErr _ = "No read statement within functions"
+
+-- Find uninitialized variables using RD
+initLook rd l v = fromJust $ lookup v $ S.toList $ fromJust $ lookup l rd
+isInit rd l v = initLook rd l v /= 0
+isInit' rd = all . isInit rd
+
+-- Var uninitialized if RD for label 'l' contains a (v, 0)
+notInit rd l = map fst . filter ((==) 0 . snd) . map (\v -> (v, initLook rd l v))
+
+-- Traverse s to find a statement with usage of uninitialized variables
+uninit rd s = case s of
+                 Assign _ a l -> uninit' a l
+                 Write a l -> uninit' a l
+                 Return a l -> uninit' a l
+                 If _ _ s1 s2 -> uninit rd s1 ++ uninit rd s2
+                 While _ _ s -> uninit rd s
+                 Seq s -> concatMap (uninit rd) s
+                 _ -> []
+    where
+      uninit' a l = if isInit' rd l $ fvA a then [] else [(l, notInit rd l $ fvA a)]
+
+-- Find uninitialized vars in a function
+uninitF f@(Func _ _ _ _ s _) = uninit (fst $ rdF f) s
+
+-- Find unitialized vars in a program
+uninitP p@(Prog _ f s) = uninit (fst $ rd p) s ++ concatMap uninitF f
+
+-- Fails if program contains usage of uninitalized vars
+uninitVars = not . null . uninitP
+uninitVarsErr p = "Usage of uninitialized variables:\n" ++
+                  unlines (map (\(l, vs) -> "Label " ++ show l ++ " with variables: " ++ show vs)
+                           $ uninitP p)
+
+-- Return tuple of called and declared functions
+funcsDef' p@(Prog _ f _) = (cf, df)
+    where
+      cf = calledFuncs p
+      df = map getFn f
+      getFn (Func _ fn _ _ _ _) = fn
+
+-- List functions called, but not declared
+missFuncDef p = S.toList $ S.difference (S.fromList cf) (S.fromList df)
+    where
+      (cf, df) = funcsDef' p
+
+-- All called functions declared?
+funcsDef p = S.isSubsetOf (S.fromList cf) (S.fromList df)
+    where
+      (cf, df) = funcsDef' p
+
+missFuncDefErr p = "Undefined functions called:\n" ++ show (missFuncDef p)
+
+-- Execute all defined sanity checks and return errors if check failed
+sane p = mapMaybe (\(c, e) -> if c p then Just (e p) else Nothing) checkers
+    where
+      checkers = [(not . varsDef, missVarDefErr),
+                  (not . funcsDef, missFuncDefErr),
+                  (invalidReturns, retErr),
+                  (writeProg, writeErr),
+                  (readFuncs, readErr),
+                  (uninitVars, uninitVarsErr)
+                 ]

App/Slicing.hs

@@ -0,0 +1,135 @@
+-- Program Slicing
+module App.Slicing (slice) where
+
+import Data.Maybe
+import qualified Data.Set as S
+import Data.List (nub)
+
+import While.ParserAS
+import DataFlow.Generic (getBlock, getLabel, scopeFunc, getFunc,
+                         callGraph, validLabel, calledFuncsSNonGreedy)
+import qualified DataFlow.RD as RD
+
+-- Checks if pi is a valid label of program p
+-- If so it performs the slicing, otherwise returns the empty list
+slice p pi = if validLabel p pi
+             then S.toList $ progSlice' p Nothing pi
+             else []
+
+-- Performs the program slice for the scope the pi is located
+-- in. Return set of highlighted labels
+progSlice' p@(Prog _ _ s) mask pi = S.insert pi slice
+    where
+      -- Perform actual program slicing
+      slice = pSlice p func (fst rd) s' pi S.empty mask
+
+      -- Find name of function the PI is located in
+      fname = scopeFunc p pi
+
+      -- Obtain function given by its name 'fname'
+      func = if isJust fname then getFunc p $ fromJust fname else Nothing
+
+      -- Perform RD analysis on scope: either function or program
+      (rd, s') = rdScope func
+      rdScope Nothing = (RD.rd p, s)
+      rdScope (Just fn@(Func _ _ _ _ s _)) = (RD.rdF fn, s)
+
+-- should never happen
+pSlice _ Nothing _ _ pi _ _ | pi < 0 = S.empty
+
+-- inter-procedural slicing
+pSlice p (Just f) _ _ pi _ _ | pi < 0 = S.unions ps'
+                             where
+                               -- Perform program slicing for every
+                               -- label the function is called
+                               ps' = map (\(f, l) -> progSlice' p (Just (l, (f, pi))) l) callers
+
+                               -- Obtain callgraph and filter out only the function we are interested in
+                               callers = filter (\(f', _) -> fn == f') $ callGraph p
+                               fn = getFuncName f
+                               getFuncName (Func _ f _ _ _ _) = f
+
+-- intra-procedural/program slicing
+pSlice p fn rd s pi l mask = if isNothing b' then S.empty
+                             else S.union h' $ S.unions . S.toList $
+                             S.map (\i -> pSlice p fn rd s i (S.union l h) mask) h
+    where
+      -- Filter out negative labels (due to dependency on arguments). Should not occur in final program slice
+      h' = S.filter ((<) 0) h
+
+      -- Filter out duplicates, so we do not analyse labels twice
+      h = S.filter (not . (`S.member` l)) $ S.unions [parentLabels, relVarsLabels, relFuncs]
+
+      -- Obtain labels of the scope (if/while)
+      parentLabels = S.fromList $ scopeLabels pi s
+
+      -- Relevant variable tuples from RD and their corresponding labels
+      relVarsLabels = S.map snd relVarsTuples
+      relVarsTuples = S.filter (\(x, _) -> (x `elem` vs)) $ fromJust $ lookup pi rd
+
+      -- Relevant function calls
+      relFuncs = S.fromList $ relFuncLabels p fs
+
+      -- Relevant vars occuring in PI block 'b'
+      vs = if maskMatch mask then relVars mask b else relVars Nothing b
+
+      -- Relevant function calls occuring in PI block 'b'
+      fs = if maskMatch mask then relFuncCalls p mask b else relFuncCalls p Nothing b
+      b' = getBlock pi s
+      b = fromJust b'
+      maskMatch Nothing = False
+      maskMatch (Just m) = pi == fst m
+
+-- Obtain relevant function calls and it labels
+relFuncLabels p = map fl . catMaybes . map (getFunc p)
+    where
+      fl (Func _ _ _ _ _ l) = l
+relFuncCalls p Nothing = nub . map fst . calledFuncsSNonGreedy p []
+relFuncCalls p (Just (_, (f, _))) = filter (f ==) . relFuncCalls p Nothing
+
+-- Returns the relevant variables of a statement
+-- It navigates through the statment tree, concatenating the
+-- relevant variables
+relVars mask s = case s of
+                   Assign _ a _ -> varsA mask a
+                   Write a _ -> varsA mask a
+                   Return a _ -> varsA mask a
+                   If b _ _ _ -> varsB mask b
+                   While b _ _ -> varsB mask b
+                   _ -> []
+    where
+      -- Obtain variables in arithmetic epxression, without mask applied
+      varsA Nothing t = case t of
+                          Var n -> [n]
+                          AOp _ a1 a2 -> varsA mask a1 ++ varsA mask a2
+                          FuncCall _ as  -> concatMap (varsA mask) as
+                          _ -> []
+
+      -- Obtain variables in arith. expr., with mask applied.
+      -- Mask applies to function calls and its arguments
+      varsA (Just (_, (f, i))) t = case t of
+                                     FuncCall f' as | f == f' -> concatMap (varsArg i) $
+                                                                 zip [-1,-2..] as
+                                     AOp _ a1 a2 -> varsA mask a1 ++ varsA mask a2
+                                     _ -> []
+
+      -- Obtain variables for relevant arguments
+      varsArg i a = if i == fst a then varsA Nothing $ snd a else []
+
+      -- Obtain variables in boolean expression
+      varsB mask t = case t of
+                       BUnOp _ e -> varsB mask e
+                       BOp _ e1 e2 -> varsB mask e1 ++ varsB mask e2
+                       RelOp _ e1 e2 -> varsA mask e1 ++ varsA mask e2
+                       _ -> []
+
+-- In case the statement is inside one or several if/while,
+-- it returns the concatenation of the labels of each of those
+scopeLabels l s = case s of
+                    Seq s -> concatMap (scopeLabels l) s
+                    _ | l == getLabel s -> [l]
+                    If _ l' s1 s2 -> scopeLabels' l' s1 ++ scopeLabels' l' s2
+                    While _ l' s' -> scopeLabels' l' s'
+                    _ -> []
+    where
+      scopeLabels' l' s' = let x = scopeLabels l s' in if null x then [] else l' : x