From b0cd20a8235f632f2c4986dd055d532571dbdb62 Mon Sep 17 00:00:00 2001 From: Alexander Bernauer Date: Thu, 9 Aug 2012 17:59:52 +0200 Subject: [PATCH] refactoring: separate breakpoints and blocking calls --- ocram/ghci | 2 +- ocram/src/Ocram/Debug.hs | 23 ++----- ocram/src/Ocram/Main.hs | 4 +- ocram/src/Ocram/Print.hs | 62 ++++++++++++------ ocram/src/Ocram/Print/Test.hs | 59 +++++++++++------ ocram/src/Ocram/Ruab.hs | 63 +++++++++++-------- ocram/src/Ocram/Test/Lib.hs | 27 +++++--- ocram/src/Ocram/Transformation.hs | 8 +-- .../Translate/ThreadFunctions.hs | 6 +- ruab/src/Ruab/Core.hs | 28 ++++----- ruab/src/Ruab/Core/Internal.hs | 34 +++++----- 11 files changed, 184 insertions(+), 132 deletions(-) diff --git a/ocram/ghci b/ocram/ghci index 69ab49d..0276baf 100755 --- 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 index 6ceb58f..f78ef3b 100644 --- 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,19 +34,8 @@ 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) @@ -56,6 +43,6 @@ create_debug_info opt cg tcode pcode ecode vm lm = 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 index b7bebff..3735a09 100644 --- 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 index 8039af3..1e84dcd 100644 --- 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 index 1df52e8..8d42b1a 100644 --- 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 = [] diff --git a/ocram/src/Ocram/Ruab.hs b/ocram/src/Ocram/Ruab.hs index 4b3b6ef..986d0cd 100644 --- a/ocram/src/Ocram/Ruab.hs +++ b/ocram/src/Ocram/Ruab.hs @@ -24,14 +24,20 @@ data ELocation = ELocation { -- {{{2 , elocCol :: Int } deriving Show -data Location = Location { -- {{{2 - locTloc :: TLocation - , locEloc :: ELocation - , locIsBlockingCall :: Bool - , locThreadId :: Maybe Int +data Breakpoint = Breakpoint { -- {{{2 + bpTloc :: TLocation + , bpEloc :: ELocation + , bpThreadId :: Maybe Int } deriving (Show) -type LocMap = [Location] -- {{{2 +type Breakpoints = [Breakpoint] -- {{{2 + +data BlockingCall = BlockingCall { -- {{{2 + bcEloc :: ELocation + , bcThreadId :: Int + } + +type BlockingCalls = [BlockingCall] -- {{{2 type Variable = String -- {{{2 @@ -56,17 +62,17 @@ data Thread = Thread { -- {{{2 } deriving Show data DebugInfo = DebugInfo { -- {{{2 - diTcode :: File - , diPcode :: BS.ByteString - , diEcode :: File - , diPpm :: PreprocMap - , diLocMap :: LocMap - , diVarMap :: VarMap - , diThreads :: [Thread] - , diOsApi :: [String] + diTcode :: File + , diPcode :: BS.ByteString + , diEcode :: File + , diPpm :: PreprocMap + , diBps :: Breakpoints + , diBcs :: BlockingCalls + , diVarMap :: VarMap + , diThreads :: [Thread] + , diOsApi :: [String] } - -- instances {{{1 instance JSON TLocation where -- {{{2 readJSON val = do @@ -80,12 +86,17 @@ instance JSON ELocation where -- {{{2 showJSON (ELocation r c) = showJSON (r, c) -instance JSON Location where -- {{{2 +instance JSON Breakpoint where -- {{{2 readJSON val = do - (t, e, b, tid) <- readJSON val - return $ Location t e b (if tid == -1 then Nothing else Just tid) + (t, e, tid) <- readJSON val + return $ Breakpoint t e (if tid == -1 then Nothing else Just tid) + + showJSON (Breakpoint t e tid) = showJSON (t, e, maybe (-1) id tid) + +instance JSON BlockingCall where -- {{{2 + readJSON val = readJSON val >>= return . uncurry BlockingCall - showJSON (Location t e b tid) = showJSON (t, e, b, maybe (-1) id tid) + showJSON (BlockingCall e t) = showJSON (e, t) instance JSON PreprocMap where -- {{{2 showJSON (PreprocMap mtr mpr ma) = (JSObject . toJSObject) [ @@ -124,27 +135,29 @@ instance JSON Thread where -- {{{2 readJSON x = readFail "Thread" x instance JSON DebugInfo where -- {{{2 - showJSON (DebugInfo tcode pcode ecode ppm lm vm ts oa) = (JSObject . toJSObject) [ + showJSON (DebugInfo tcode pcode ecode ppm bps bcs vm ts oa) = (JSObject . toJSObject) [ ("tcode", showJSON tcode) , ("pcode", showJSON pcode) , ("ecode", showJSON ecode) , ("ppm", showJSON ppm) - , ("locmap", showJSON lm) - , ("varmap", showJSON vm) + , ("bps", showJSON bps) + , ("bcs", showJSON bcs) + , ("vs", showJSON vm) , ("threads", showJSON ts) , ("osapi", showJSON oa) ] readJSON (JSObject obj) = do - let [tcode, pcode, ecode, ppm, lm, vm, ts, oa] = map snd $ fromJSObject obj + let [tcode, pcode, ecode, ppm, bps, bcs, vm, ts, oa] = map snd $ fromJSObject obj [tcode', ecode'] <- mapM readJSON [tcode, ecode] pcode' <- readJSON pcode ppm' <- readJSON ppm - lm' <- readJSON lm + bps' <- readJSON bps + bcs' <- readJSON bcs vm' <- readJSON vm ts' <- readJSON ts oa' <- readJSON oa - return $ DebugInfo tcode' pcode' ecode' ppm' lm' vm' ts' oa' + return $ DebugInfo tcode' pcode' ecode' ppm' bps' bcs' vm' ts' oa' readJSON x = readFail "DebugInfo" x diff --git a/ocram/src/Ocram/Test/Lib.hs b/ocram/src/Ocram/Test/Lib.hs index 7ca9a93..36a298c 100644 --- a/ocram/src/Ocram/Test/Lib.hs +++ b/ocram/src/Ocram/Test/Lib.hs @@ -10,7 +10,7 @@ import Language.C.Syntax.AST (CTranslUnit) import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Language.Haskell.TH (stringE) import Ocram.Analysis (CallGraph, ErrorCode, from_test_graph, to_test_graph) -import Ocram.Ruab (tlocRow, elocRow, locTloc, locEloc, locThreadId, Location(..), TLocation(..), ELocation(..)) +import Ocram.Ruab (Breakpoint(..), TLocation(..), ELocation(..), BlockingCall(..)) import Test.Framework.Providers.HUnit (testCase) import Test.Framework (testGroup, Test) import Test.HUnit (Assertion) @@ -56,9 +56,13 @@ instance TestData CTranslUnit String where reduce = show . pretty enrich = parse -instance TestData Location (Int, Int, Maybe Int) where - reduce loc = ((tlocRow . locTloc) loc, (elocRow . locEloc) loc, locThreadId loc) - enrich (trow, erow, tid) = Location (TLocation trow 1 1 "test") (ELocation erow 1) False tid +instance TestData Breakpoint TBreakpoint where + reduce bp = ((tlocRow . bpTloc) bp, (elocRow . bpEloc) bp, bpThreadId bp) + enrich (trow, erow, tid) = Breakpoint (TLocation trow 1 1 "test") (ELocation erow 1) tid + +instance TestData BlockingCall TBlockingCall where + reduce bc = ((elocRow . bcEloc) bc, bcThreadId bc) + enrich (erow, tid) = BlockingCall (ELocation erow 1) tid instance TestData Char Char where reduce = id @@ -77,11 +81,14 @@ instance (TestData a b) => TestData [a] [b] where enrich = map enrich -- types {{{1 -type TCode = String +type TCode = String type TBlockingFunctions = [String] -type TCallGraph = [(String, String)] -type TStartFunctions = [String] +type TCallGraph = [(String, String)] +type TStartFunctions = [String] type TCriticalFunctions = [String] -type TErrorCodes = [ErrorCode] -type TCallChain = [String] -type TLocMap = [(Int, Int, Maybe Int)] +type TErrorCodes = [ErrorCode] +type TCallChain = [String] +type TBreakpoint = (Int, Int, Maybe Int) +type TBreakpoints = [TBreakpoint] +type TBlockingCall = (Int, Int) +type TBlockingCalls = [TBlockingCall] diff --git a/ocram/src/Ocram/Transformation.hs b/ocram/src/Ocram/Transformation.hs index 26bd065..67c3872 100644 --- a/ocram/src/Ocram/Transformation.hs +++ b/ocram/src/Ocram/Transformation.hs @@ -33,16 +33,16 @@ enableLocationTracing = everywhere (mkT tStat `extT` tDecl) where tStat :: CStat' -> CStat' tStat o@(CCompound _ _ _) = o - tStat s = amap enableTrace s + tStat s = amap setBreakpoint s tDecl :: CDecl' -> CDecl' -- Decls with initializers - tDecl o@(CDecl _ [(_, Just _, _)] _) = amap enableTrace o + tDecl o@(CDecl _ [(_, Just _, _)] _) = amap setBreakpoint o tDecl o = o - enableTrace x + setBreakpoint x | (isUndefNode . nodeInfo) x = x - | otherwise = x {enTraceLocation = True} + | otherwise = x {enBreakpoint = True} extractPal :: CallGraph -> CTranslUnit' -> CTranslUnit' -- {{{1 extractPal cg (CTranslUnit ds _) = CTranslUnit (map CDeclExt ds') un diff --git a/ocram/src/Ocram/Transformation/Translate/ThreadFunctions.hs b/ocram/src/Ocram/Transformation/Translate/ThreadFunctions.hs index a3138a0..adb9b47 100644 --- a/ocram/src/Ocram/Transformation/Translate/ThreadFunctions.hs +++ b/ocram/src/Ocram/Transformation/Translate/ThreadFunctions.hs @@ -8,7 +8,7 @@ import Data.Generics (everywhereM, everywhere, mkT, mkM) import Data.Maybe (maybeToList) import Language.C.Syntax.AST import Ocram.Analysis (start_functions, call_chain, call_order, is_blocking, is_critical, CallGraph) -import Ocram.Debug (un, setThread, ENodeInfo(..)) +import Ocram.Debug (un, ENodeInfo(..)) import Ocram.Query (function_definition, function_parameters, local_variables_fd) import Ocram.Symbols (symbol, Symbol) import Ocram.Transformation.Names @@ -31,7 +31,7 @@ add_thread_functions cg ast@(CTranslUnit decls ni) = onlyDefs name = not (is_blocking cg name) && is_critical cg name functions = map (inlineCriticalFunction cg ast startFunction) $ zip (True : repeat False) $ filter onlyDefs $ $fromJust_s $ call_order cg startFunction in - fmap (setThread tid) fun + fmap (\eni -> eni {enThreadId = Just tid}) fun inlineCriticalFunction :: CallGraph -> CTranslUnit' -> Symbol -> (Bool, Symbol) -> [CBlockItem'] -- {{{2 inlineCriticalFunction cg ast startFunction (isThreadStartFunction, inlinedFunction) = lbl ?: inlinedBody @@ -95,7 +95,7 @@ inlineCriticalFunction cg ast startFunction (isThreadStartFunction, inlinedFunct return $ CCompound x (concat items') y rewrite o = return o - transform o@(CBlockStmt stat@(CExpr (Just call@(CCall (CVar iden _) params _)) _)) + transform o@(CBlockStmt stat@(CExpr (Just (CCall (CVar iden _) params _)) _)) | is_critical cg calledFunction = callSequence calledFunction (annotation stat) params Nothing | otherwise = return [o] where calledFunction = symbol iden diff --git a/ruab/src/Ruab/Core.hs b/ruab/src/Ruab/Core.hs index bbcf8a2..d32caa7 100644 --- a/ruab/src/Ruab/Core.hs +++ b/ruab/src/Ruab/Core.hs @@ -86,7 +86,7 @@ data Breakpoint = Breakpoint { -- {{{2 data BreakpointType -- {{{2 = BkptUser UserBreakpoint | BkptThreadExecution ThreadId - | BkptCriticalCall ThreadId ERow + | BkptBlockingCall ThreadId ERow --deriving Show data Thread = Thread { -- {{{2 @@ -177,7 +177,7 @@ handleStop ctx backend stopped state = handle (B.stoppedReason stopped) (stateEx thread {thStatus = Running, thProw = Nothing} ) - BkptCriticalCall tid erow -> do + BkptBlockingCall tid erow -> do B.continue backend return $ hide True . updateThread tid (\thread -> thread {thStatus = Blocked, thProw = e2p_row ctx erow `mplus` Just (-2)} @@ -363,12 +363,12 @@ setup opt = do setupBreakpoints :: Context -> B.Context -> State -> IO State -- {{{2 setupBreakpoints ctx backend state = do teb <- threadExecutionBreakpoints - ccb <- criticalCallBreakpoints + ccb <- blockingCallBreakpoints let bbm = M.fromList $ map (\b -> (bkptNumber b, b)) (teb ++ ccb) return $ state {stateBreakpoints = bbm} where threads = (R.diThreads . ctxDebugInfo) ctx - blockingCalls = filter R.locIsBlockingCall $ (R.diLocMap . ctxDebugInfo) ctx + blockingCalls = (R.diBcs . ctxDebugInfo) ctx efile = (R.fileName . R.diEcode . ctxDebugInfo) ctx threadExecutionBreakpoints = forM threads (\thread -> let @@ -378,14 +378,14 @@ setupBreakpoints ctx backend state = do breakpoint <- B.set_breakpoint backend location return $ Breakpoint (B.bkptNumber breakpoint) (BkptThreadExecution (R.threadId thread)) ) - criticalCallBreakpoints = forM blockingCalls (\loc -> + blockingCallBreakpoints = forM blockingCalls (\bc -> let - location = B.file_line_location efile ((R.elocRow . R.locEloc) loc) - tid = ($fromJust_s . R.locThreadId) loc - erow = (R.elocRow . R.locEloc) loc + erow = (R.elocRow . R.bcEloc) bc + location = B.file_line_location efile erow + tid = R.bcThreadId bc in do breakpoint <- B.set_breakpoint backend location - return $ Breakpoint (B.bkptNumber breakpoint) (BkptCriticalCall tid erow) + return $ Breakpoint (B.bkptNumber breakpoint) (BkptBlockingCall tid erow) ) initialState :: Context -> State -- {{{2 @@ -405,7 +405,7 @@ e_file = R.fileName . R.diEcode . ctxDebugInfo possible_breakpoints :: Context -> [PRow] -- {{{2 possible_breakpoints ctx = - S.toList $ S.fromList $ map ($fromJust_s . t2p_row ctx . R.tlocRow . R.locTloc) $ (R.diLocMap . ctxDebugInfo) ctx + S.toList $ S.fromList $ map ($fromJust_s . t2p_row ctx . R.tlocRow . R.bpTloc) $ (R.diBps . ctxDebugInfo) ctx os_api :: Context -> [String] -- {{{2 @@ -421,10 +421,10 @@ e2p_row :: Context -> ERow -> Maybe PRow -- {{{2 e2p_row ctx erow = let tfile = (R.fileName . R.diTcode . ctxDebugInfo) ctx - lm = (R.diLocMap . ctxDebugInfo) ctx + bps = (R.diBps . ctxDebugInfo) ctx ppm = (R.diPpm . ctxDebugInfo) ctx in do - trow <- e2t_row' lm tfile erow + trow <- e2t_row' bps tfile erow prow <- t2p_row' ppm trow return prow @@ -432,8 +432,8 @@ p2e_row :: Context -> PRow -> ERowMatch -- {{{2 p2e_row ctx prow = let tfile = (R.fileName . R.diTcode . ctxDebugInfo) ctx - lm = (R.diLocMap . ctxDebugInfo) ctx + bps = (R.diBps . ctxDebugInfo) ctx ppm = (R.diPpm . ctxDebugInfo) ctx in case p2t_row' ppm prow of Nothing -> NoMatch - Just trow -> t2e_row' lm tfile trow + Just trow -> t2e_row' bps tfile trow diff --git a/ruab/src/Ruab/Core/Internal.hs b/ruab/src/Ruab/Core/Internal.hs index 9735c41..f882ef1 100644 --- a/ruab/src/Ruab/Core/Internal.hs +++ b/ruab/src/Ruab/Core/Internal.hs @@ -36,27 +36,27 @@ p2t_row' ppm@(R.PreprocMap trows _ locs) prow = do guard (prow' == prow) return trow -t2e_row' :: R.LocMap -> String -> TRow -> ERowMatch -- {{{1 -t2e_row' lm tfile row = +t2e_row' :: R.Breakpoints -> String -> TRow -> ERowMatch -- {{{1 +t2e_row' bps tfile row = let - locs = filter ((row==) . R.tlocRow . R.locTloc) $ - filter ((tfile==) . R.tlocFile . R.locTloc) $ - lm + bps' = filter ((row==) . R.tlocRow . R.bpTloc) $ + filter ((tfile==) . R.tlocFile . R.bpTloc) $ + bps in - case locs of + case bps' of [] -> NoMatch - [R.Location _ eloc _ Nothing] -> NonCritical $ R.elocRow eloc - [R.Location _ eloc _ (Just t)] -> Critical [(t, R.elocRow eloc)] - elocs -> Critical $ flip map elocs (\loc -> + [R.Breakpoint _ eloc Nothing] -> NonCritical $ R.elocRow eloc + [R.Breakpoint _ eloc (Just t)] -> Critical [(t, R.elocRow eloc)] + _ -> Critical $ flip map bps' (\bp -> ( - ($fromJust_s . R.locThreadId) loc - , (R.elocRow . R.locEloc) loc + ($fromJust_s . R.bpThreadId) bp + , (R.elocRow . R.bpEloc) bp ) ) -e2t_row' :: R.LocMap -> String -> ERow -> Maybe TRow -- {{{1 -e2t_row' lm tfile row = - fmap (R.tlocRow . R.locTloc) $ - find ((row==) . R.elocRow . R.locEloc) $ - filter ((tfile==) . R.tlocFile . R.locTloc) $ - lm +e2t_row' :: R.Breakpoints -> String -> ERow -> Maybe TRow -- {{{1 +e2t_row' bps tfile row = + fmap (R.tlocRow . R.bpTloc) $ + find ((row==) . R.elocRow . R.bpEloc) $ + filter ((tfile==) . R.tlocFile . R.bpTloc) $ + bps