refactoring: separate breakpoints and blocking calls

copton · Aug 9, 2012 · b0cd20a · b0cd20a
1 parent 20416d9
commit b0cd20a
Show file tree

Hide file tree

Showing 11 changed files with 184 additions and 132 deletions.
diff --git a/ocram/ghci b/ocram/ghci
@@ -1,3 +1,3 @@
 #!/bin/bash
 
-exec ghci -isrc -idist/build/autogen/ -no-user-package-conf -package-conf cabal-dev/packages-7.4.1.conf Ocram.Main
+exec ghci -Wall -isrc -idist/build/autogen/ -no-user-package-conf -package-conf cabal-dev/packages-7.4.1.conf Ocram.Main
diff --git a/ocram/src/Ocram/Debug.hs b/ocram/src/Ocram/Debug.hs
@@ -4,10 +4,8 @@ module Ocram.Debug where
 -- import {{{1
 import Data.Data (Data)
 import Data.Digest.OpenSSL.MD5 (md5sum)
-import Data.Maybe (fromMaybe)
 import Data.Typeable (Typeable)
-import Language.C.Data.Node (lengthOfNode, posOfNode, CNode(nodeInfo), NodeInfo, undefNode)
-import Language.C.Data.Position (posRow, posColumn, posFile)
+import Language.C.Data.Node (CNode(nodeInfo), NodeInfo, undefNode)
 import Ocram.Analysis (CallGraph, start_functions, blocking_functions, call_order)
 import Ocram.Options (Options(optInput, optOutput))
 import Ocram.Debug.Internal
@@ -20,7 +18,7 @@ import qualified Data.ByteString.Char8 as BS
 data ENodeInfo = ENodeInfo { -- {{{1
     enTnodeInfo     :: NodeInfo
   , enThreadId      :: Maybe Int
-  , enTraceLocation :: Bool
+  , enBreakpoint    :: Bool
   , enBlockingCall  :: Bool
   } deriving (Data, Typeable)
 
@@ -36,26 +34,15 @@ un = enrich_node_info undefNode
 enrich_node_info :: NodeInfo -> ENodeInfo -- {{{1
 enrich_node_info ni = ENodeInfo ni Nothing False False
 
-setThread :: Int -> ENodeInfo -> ENodeInfo -- {{{1
-setThread tid eni = eni {enThreadId = Just tid}
-
-tlocation :: ENodeInfo -> TLocation -- {{{1
-tlocation eni =
-  let
-    ni = enTnodeInfo eni
-    pos = posOfNode ni
-  in
-    TLocation (posRow pos + 1) (posColumn pos) (fromMaybe (-1) (lengthOfNode ni)) (posFile pos)
-
-create_debug_info :: Options -> CallGraph -> BS.ByteString -> BS.ByteString -> BS.ByteString -> VarMap -> LocMap -> DebugInfo -- {{{1
-create_debug_info opt cg tcode pcode ecode vm lm =
+create_debug_info :: Options -> CallGraph -> BS.ByteString -> BS.ByteString -> BS.ByteString -> VarMap -> Breakpoints -> BlockingCalls -> DebugInfo -- {{{1
+create_debug_info opt cg tcode pcode ecode vm lm bkl =
   let
     tfile = File (optInput opt) (md5sum tcode)
     efile = File (optOutput opt) (md5sum ecode)
     ts = zipWith createThreadInfo [0..] (start_functions cg)
     ppm = preproc_map tcode pcode
     oa = blocking_functions cg
   in
-    DebugInfo tfile pcode efile ppm lm vm ts oa
+    DebugInfo tfile pcode efile ppm lm bkl vm ts oa
   where
     createThreadInfo tid sf = Thread tid sf (threadExecutionFunction tid) ($fromJust_s $ call_order cg sf)
diff --git a/ocram/src/Ocram/Main.hs b/ocram/src/Ocram/Main.hs
@@ -28,8 +28,8 @@ runCompiler argv = do
   (tcode, pcode, ast) <- exitOnError "parser" =<< parse opt
   (cg, fpr) <- exitOnError "analysis" $ analysis ast
   let (ast', pal, vm) = transformation cg ast
-  let (ecode, lm) = print_with_log ast'
-  let di = encode_debug_info $ create_debug_info opt cg tcode pcode ecode vm lm
+  let (ecode, lm, bl) = print_with_log ast'
+  let di = encode_debug_info $ create_debug_info opt cg tcode pcode ecode vm lm bl
   exitOnError "output" =<< generate_pal opt fpr pal
   exitOnError "output" =<< dump_ecode opt ecode
   exitOnError "output" =<< dump_debug_info opt di

diff --git a/ocram/src/Ocram/Print.hs b/ocram/src/Ocram/Print.hs
@@ -41,60 +41,84 @@ module Ocram.Print
 ) where
 
 -- import {{{1
-import Control.Arrow (first)
+import Data.Maybe (fromMaybe)
+import Language.C.Data.Position (posRow, posColumn, posFile)
 import Language.C.Syntax
 import Language.C.Data.Ident (Ident, identToString)
+import Language.C.Data.Node (posOfNode, lengthOfNode)
 import Text.PrettyPrint
-import Ocram.Debug (ENodeInfo(..), tlocation)
-import Ocram.Ruab (ELocation(ELocation), Location(Location), LocMap)
-import Ocram.Util (abort)
+import Ocram.Debug (ENodeInfo(..))
+import Ocram.Ruab (TLocation(..), ELocation(..), Breakpoint(..), Breakpoints, BlockingCall(..), BlockingCalls)
+import Ocram.Util (abort, fromJust_s)
+import Prelude hiding (log)
 
 import qualified Data.ByteString.Char8 as BS
 
-print_with_log :: CTranslationUnit ENodeInfo -> (BS.ByteString, LocMap) -- {{{1
-print_with_log tu = first BS.pack $ renderWithLog (pretty tu)
+import Debug.Trace (trace)
 
-marker :: ENodeInfo -> DocL LocMap -> DocL LocMap
+print_with_log :: CTranslationUnit ENodeInfo -> (BS.ByteString, Breakpoints, BlockingCalls) -- {{{1
+print_with_log tu =
+  let
+    (code, log) = renderWithLog (pretty tu)
+    (bps, bcs) = foldr split ([], []) log
+    split (Left x)  (bps', bcs') = (x:bps', bcs')
+    split (Right x) (bps', bcs') = (bps', x:bcs')
+  in
+    (BS.pack code, bps, bcs)
+
+type Log = [Either Breakpoint BlockingCall]
+
+marker :: ENodeInfo -> DocL Log -> DocL Log
 marker eni doc
-  | enTraceLocation eni = here logger doc
+  | enBreakpoint eni = here bpLogger doc
+  | enBlockingCall eni  = trace "YES" (here bcLogger doc)
   | otherwise = doc
   where
-    logger (Position r c) = [Location (tlocation eni) (ELocation r c ) (enBlockingCall eni) (enThreadId eni)]
+    bpLogger (Position r c) = [Left $ Breakpoint tlocation (ELocation r c ) (enThreadId eni)]
+
+    bcLogger (Position r c) = [Right $ BlockingCall (ELocation r c) (($fromJust_s . enThreadId) eni)]
+
+    tlocation =
+      let
+        ni = enTnodeInfo eni
+        pos = posOfNode ni
+      in
+        TLocation (posRow pos + 1) (posColumn pos) (fromMaybe (-1) (lengthOfNode ni)) (posFile pos)
 
 class PrettyLog a where
-  pretty :: a -> DocL LocMap
-  prettyPrec :: Int -> a -> DocL LocMap
+  pretty :: a -> DocL Log
+  prettyPrec :: Int -> a -> DocL Log
 
   pretty = prettyPrec 0
   prettyPrec _ = pretty
 
 -- pretty print optional chunk
-maybeP :: (p -> DocL LocMap) -> Maybe p -> DocL LocMap
+maybeP :: (p -> DocL Log) -> Maybe p -> DocL Log
 maybeP = maybe empty
 
 -- pretty print when flag is true
-ifP :: Bool -> DocL LocMap -> DocL LocMap
+ifP :: Bool -> DocL Log -> DocL Log
 ifP flag doc = if flag then doc else empty
 
 -- pretty print _optional_ list, i.e. [] ~ Nothing and (x:xs) ~ Just (x:xs)
-mlistP :: ([p] -> DocL LocMap) -> [p] -> DocL LocMap
+mlistP :: ([p] -> DocL Log) -> [p] -> DocL Log
 mlistP pp xs = maybeP pp (if null xs then Nothing else Just xs)
 
 -- pretty print identifier
-identP :: Ident -> DocL LocMap
+identP :: Ident -> DocL Log
 identP = text . identToString
 
 -- pretty print attribute annotations
-attrlistP :: [CAttribute ENodeInfo] -> DocL LocMap
+attrlistP :: [CAttribute ENodeInfo] -> DocL Log
 attrlistP [] = empty
 attrlistP attrs = text "__attribute__" <> parens (parens (hcat . punctuate comma . map pretty $ attrs))
 
 -- analogous to showParen
-parenPrec :: Int -> Int -> DocL LocMap -> DocL LocMap
+parenPrec :: Int -> Int -> DocL Log -> DocL Log
 parenPrec prec prec2 t = if prec <= prec2 then t else parens t
 
 -- indent a chunk of code
-ii :: DocL LocMap -> DocL LocMap
+ii :: DocL Log -> DocL Log
 ii = nest 4
 
 -- PrettyLog instances
@@ -319,7 +343,7 @@ instance PrettyLog (CEnumeration ENodeInfo) where
 instance PrettyLog (CDeclarator ENodeInfo) where
     prettyPrec prec declr = prettyDeclr True prec declr
 
-prettyDeclr :: Bool -> Int -> CDeclarator ENodeInfo -> DocL LocMap
+prettyDeclr :: Bool -> Int -> CDeclarator ENodeInfo -> DocL Log
 prettyDeclr show_attrs prec (CDeclr name derived_declrs asmname cattrs _) =
     ppDeclr prec (reverse derived_declrs) <+> prettyAsmName asmname <+> ifP show_attrs (attrlistP cattrs)
     where

diff --git a/ocram/src/Ocram/Print/Test.hs b/ocram/src/Ocram/Print/Test.hs
@@ -6,20 +6,18 @@ module Ocram.Print.Test
 ) where
 
 -- import {{{1
-import Control.Arrow ((***))
 import Data.Generics (everything, mkQ, extQ)
 import Data.List (intercalate)
-import Ocram.Debug (ENodeInfo(..), tlocation)
-import Language.C.Data.Node (nodeInfo)
-import Language.C.Syntax.AST (CTranslUnit, CTranslationUnit(..), annotation)
+import Ocram.Debug (ENodeInfo(..))
+import Language.C.Syntax.AST (annotation)
 import Ocram.Analysis (analysis)
 import Ocram.Print (print_with_log)
-import Ocram.Test.Lib (enumTestGroup, paste, lpaste, enrich, reduce, TLocMap)
+import Ocram.Test.Lib (enumTestGroup, lpaste, enrich, reduce, TBreakpoints, TBlockingCalls)
 import Ocram.Text (show_errors)
 import Ocram.Transformation (transformation)
 import Ocram.Transformation.Types (CExpr', CStat')
 import Test.Framework (Test, testGroup)
-import Test.HUnit ((@=?), Assertion, assertFailure, assertEqual)
+import Test.HUnit (Assertion, assertFailure, assertEqual)
 
 import qualified Data.ByteString.Char8 as BS
 
@@ -61,6 +59,8 @@ test_print_with_log = enumTestGroup "print_with_log" $ map runTest [
     }
     |], [
       (3, 19, Just 0)
+    ], [
+      (19, 0)
     ])
 -- function static variable {{{2
   , ([lpaste|
@@ -98,6 +98,8 @@ test_print_with_log = enumTestGroup "print_with_log" $ map runTest [
   |], [
       (3, 17, Just 0)
     , (4, 20, Just 0)
+  ], [
+      (20, 0)
   ])
 -- global variable {{{2
   , ([lpaste|
@@ -137,6 +139,8 @@ test_print_with_log = enumTestGroup "print_with_log" $ map runTest [
   |], [
       (4, 18, Just 0)
     , (5, 21, Just 0)
+  ], [
+    (21, 0)
   ])
 -- non-critical function call {{{2
   ,([lpaste|
@@ -184,6 +188,8 @@ test_print_with_log = enumTestGroup "print_with_log" $ map runTest [
       (3,  4, Nothing)
     , (7, 22, Just 0)
     , (8, 25, Just 0)
+  ], [
+    (25, 0)
   ])
 -- critical function call {{{2
   ,([lpaste|
@@ -237,6 +243,8 @@ test_print_with_log = enumTestGroup "print_with_log" $ map runTest [
   |], [
       (6, 26, Just 0)
     , (3, 34, Just 0)
+  ], [
+    (34, 0)
   ])
 -- re-entrance {{{2
   ,([lpaste|
@@ -323,6 +331,9 @@ test_print_with_log = enumTestGroup "print_with_log" $ map runTest [
     , (3, 40, Just 0)
     , (9, 54, Just 1)
     , (3, 62, Just 1)
+  ], [
+      (40, 0)
+    , (62, 1)
   ])
 -- multiple statements in a row {{{2
   ,([lpaste|
@@ -364,6 +375,9 @@ test_print_with_log = enumTestGroup "print_with_log" $ map runTest [
   |], [
       (3, 19, Just 0)
     , (3, 25, Just 0)
+  ], [
+      (19, 0)
+    , (25, 0)
   ])
 -- return {{{2
   ,([lpaste|
@@ -417,7 +431,7 @@ test_print_with_log = enumTestGroup "print_with_log" $ map runTest [
         {
             ec_stack_start.ec_frames.c.ec_frames.block.i = 23;
             ec_stack_start.ec_frames.c.ec_frames.block.ec_cont = &&ec_label_c_1;
-            block(&ec_stack_start.ec_frames.c.ec_frames.block);
+39:         block(&ec_stack_start.ec_frames.c.ec_frames.block);
             return;
         ec_label_c_1:
             ;
@@ -431,7 +445,7 @@ test_print_with_log = enumTestGroup "print_with_log" $ map runTest [
         {
             ec_stack_start.ec_frames.c.ec_frames.block.i = 42;
             ec_stack_start.ec_frames.c.ec_frames.block.ec_cont = &&ec_label_c_2;
-            block(&ec_stack_start.ec_frames.c.ec_frames.block);
+53:         block(&ec_stack_start.ec_frames.c.ec_frames.block);
             return;
         ec_label_c_2:
             ;
@@ -447,32 +461,39 @@ test_print_with_log = enumTestGroup "print_with_log" $ map runTest [
     , ( 3, 35, Just 0)
     , ( 4, 46, Just 0)
     , ( 6, 60, Just 0)
+  ], [
+      (39, 0)
+    , (53, 0)
   ])
   ]
 
-runTest :: (String, String, TLocMap) -> Assertion -- {{{1
-runTest (inputCode, expectedCode, expectedLocMap) =
+runTest :: (String, String, TBreakpoints, TBlockingCalls) -> Assertion -- {{{1
+runTest (inputCode, expectedCode, expectedLocMap, expectedBlockList) =
   let ast = enrich inputCode in
   case analysis ast of
     Left es -> assertFailure $ show_errors "analysis" es
     Right (cg, _) ->
       let
-        ast' = (\(a, _, _)->a) $ transformation cg ast
-        (resultCode, resultLocMap) = print_with_log ast'
-        resultCode' = BS.unpack resultCode
-        resultLocMap' = reduce resultLocMap
+        (ast', _, _) = transformation cg ast
+        (resultCode, resultLocMap, resultBlockList) = print_with_log ast'
+        resultCode'      = BS.unpack resultCode
+        resultLocMap'    = reduce resultLocMap
+        resultBlockList' = reduce resultBlockList
       in do
-        expectedCode @=? resultCode'
-        let locs = intercalate "\n" $ map show $ everything (++) (mkQ [] traceLocationExpr `extQ` traceLocationStat) ast'
-        assertEqual (locs ++ "\n" ++ show resultLocMap) expectedLocMap resultLocMap'
+        let dbg = debug ast'
+        assertEqual "code"      expectedCode      resultCode'
+        assertEqual "locmap"    expectedLocMap    resultLocMap'
+        assertEqual ("blocklist: " ++ dbg)  expectedBlockList resultBlockList'
 
   where
+    debug ast = intercalate "\n" $ map show $ everything (++) (mkQ [] traceLocationExpr `extQ` traceLocationStat) ast
+
     traceLocationExpr :: CExpr' -> [String]
     traceLocationExpr expr 
-      | (enTraceLocation . annotation) expr = [show expr]
+      | (enBlockingCall . annotation) expr = [show expr]
       | otherwise = []
 
     traceLocationStat :: CStat' -> [String]
     traceLocationStat stmt
-      | (enTraceLocation . annotation) stmt = [show stmt]
+      | (enBlockingCall . annotation) stmt = [show stmt]
       | otherwise = []