diff --git a/debugger/Main.hs b/debugger/Main.hs index 1c3dc65d5..2c9650dc4 100644 --- a/debugger/Main.hs +++ b/debugger/Main.hs @@ -21,19 +21,111 @@ OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -} -import Language.DifferentialDatalog.Debugger.DebugEventParser -import Text.Parsec +{-# LANGUAGE RecordWildCards, ImplicitParams, LambdaCase, FlexibleContexts, TemplateHaskell #-} + +import Control.Exception +import Control.Monad +import Data.List +-- import Debug.Trace +import System.Console.GetOpt import System.Environment +import System.FilePath.Posix +import Text.Parsec + +import Language.DifferentialDatalog.Config +import Language.DifferentialDatalog.Debug +import Language.DifferentialDatalog.Debugger.DebugTypes +import Language.DifferentialDatalog.Debugger.DebugState +import Language.DifferentialDatalog.Debugger.DebugEventParser +import Language.DifferentialDatalog.Module +import Language.DifferentialDatalog.Syntax + +data TOption = Help + | DebugDumpFile String + | Datalog String + | LibDir String + | OutputDir String + +options :: [OptDescr TOption] +options = [ Option ['h'] ["help"] (NoArg Help) "Display help message." + , Option ['d'] [] (ReqArg DebugDumpFile "DEBUG_FILE") "Debug dumped file." + , Option ['i'] [] (ReqArg Datalog "FILE") "DDlog program to compile." + , Option ['L'] [] (ReqArg LibDir "PATH") "Extra DDlog library directory." + , Option ['o'] ["output-dir"] (ReqArg OutputDir "DIR") "Output directory (default based on program name)." + ] -parseText :: String -> String -parseText inputString = do - case parse eventsParser "" inputString of - Left e -> errorWithoutStackTrace $ "Failed to parse input file: " ++ show e - Right r -> show r +addOption :: Config -> TOption -> IO Config +addOption config (DebugDumpFile f) = return config { confDebugDumpFile = f} +addOption config (Datalog f) = return config { confDatalogFile = f} +addOption config (LibDir d) = return config { confLibDirs = nub (d:confLibDirs config)} +addOption config (OutputDir d) = return config { confOutputDir = d } +addOption config Help = return config { confAction = ActionHelp} + +validateConfig :: Config -> IO () +validateConfig Config{..} = do + when (confDatalogFile == "" && confAction /= ActionHelp && confAction /= ActionVersion) + $ errorWithoutStackTrace "input file not specified" main :: IO () main = do - (filename:_) <- getArgs - contents <- readFile filename - let result = parseText contents - putStr result + args <- getArgs + prog <- getProgName + home <- lookupEnv "DDLOG_HOME" + config <- case getOpt Permute options args of + (flags, [], []) -> do + conf <- foldM addOption defaultConfig flags + validateConfig conf + return conf + `catch` + (\e -> do putStrLn $ usageInfo ("Usage: " ++ prog ++ " [OPTION...]") options + throw (e::SomeException)) + _ -> errorWithoutStackTrace $ usageInfo ("Usage: " ++ prog ++ " [OPTION...]") options + config' <- case home of + Just(p) -> addOption config (LibDir $ p ++ "/lib") + _ -> return config + do + datalogProg <- parseProgram config' + events <- parseEventFromDumpFile config' + let recordMap = handleDebugEvents events emptyDebuggerMaps datalogProg + s = queryAll events (dbgRecordMap recordMap) + dumpQueryResultToFile config' s + +queryAll :: [Event] -> DebuggerRecordMap -> String +queryAll [] _ = "\n" +queryAll (event: events) dgbRecordMap = + let outputRecord = evtOutput event + operatorId = evtOperatorId event + operatorInput = InputOp operatorId + dbgRecord = DebuggerRecord {dbgRecord=outputRecord, dbgOperatorId=operatorInput} + dbgRecordNodes = queryDerivations dbgRecord dgbRecordMap + in (show dbgRecordNodes) ++ "\n\n" ++ (queryAll events dgbRecordMap) + +parseProgram :: Config -> IO (DatalogProgram) +parseProgram Config{..} = do + fdata <- readFile confDatalogFile + (d, _, _) <- parseDatalogProgram (takeDirectory confDatalogFile:confLibDirs) True fdata confDatalogFile + return (progDebugUpdateRules d) + +parseEventFromDumpFile :: Config -> IO ([Event]) +parseEventFromDumpFile Config{..} = do + contents <- readFile confDebugDumpFile + return (parseDebugEvents contents) + +parseDebugEvents :: String -> [Event] +parseDebugEvents inputString = do + case parse eventsParser "" inputString of + Left e -> errorWithoutStackTrace $ "Failed to parse input file: " ++ show e + Right r -> r + +progDebugUpdateRules :: DatalogProgram -> DatalogProgram +progDebugUpdateRules d = + let + rules = progRules d + updatedRules = [(rules !! i) {ruleRHS = debugUpdateRHSRulesWithoutHooks d i (rules !! i)} | i <- [0..length rules - 1]] + in d { progRules = updatedRules } + +dumpQueryResultToFile :: Config -> String -> IO() +dumpQueryResultToFile Config{..} content = + case confOutputDir of + "" -> return () + _ -> writeFile confOutputDir content \ No newline at end of file diff --git a/src/Language/DifferentialDatalog/Config.hs b/src/Language/DifferentialDatalog/Config.hs index fd139c7d2..da64af376 100644 --- a/src/Language/DifferentialDatalog/Config.hs +++ b/src/Language/DifferentialDatalog/Config.hs @@ -51,6 +51,7 @@ data Config = Config { confDatalogFile :: FilePath , confDumpDebug :: Bool , confDumpOpt :: Bool , confReValidate :: Bool + , confDebugDumpFile :: FilePath } defaultConfig :: Config @@ -69,4 +70,5 @@ defaultConfig = Config { confDatalogFile = "" , confDumpDebug = False , confDumpOpt = False , confReValidate = False + , confDebugDumpFile = "" } diff --git a/src/Language/DifferentialDatalog/Debug.hs b/src/Language/DifferentialDatalog/Debug.hs index a6d2582e3..8eae65c3b 100644 --- a/src/Language/DifferentialDatalog/Debug.hs +++ b/src/Language/DifferentialDatalog/Debug.hs @@ -30,6 +30,7 @@ Description: Helper functions for adding debug hooks to a 'DatalogProgram'. module Language.DifferentialDatalog.Debug ( debugAggregateFunctions, debugUpdateRHSRules, + debugUpdateRHSRulesWithoutHooks, ) where @@ -182,12 +183,17 @@ insertRHSInspectDebugHooks d rlIdx rule = debugUpdateRHSRules :: DatalogProgram -> Int -> Rule -> [RuleRHS] debugUpdateRHSRules d rlIdx rule = + let rhs = debugUpdateRHSRulesWithoutHooks d rlIdx rule + in insertRHSInspectDebugHooks d rlIdx rule {ruleRHS = rhs} + +debugUpdateRHSRulesWithoutHooks :: DatalogProgram -> Int -> Rule -> [RuleRHS] +debugUpdateRHSRulesWithoutHooks d rlIdx rule = let -- First pass updates RHSLiteral without any binding with a binding. rhs = map addBindingToRHSLiteral $ zip (ruleRHS rule) [0..] -- Second pass updates RHSAggregate to use the debug function (so that inputs are not dropped). - rhs' = concatMap (updateRHSAggregate d rule{ruleRHS = rhs} rlIdx) [0..length rhs - 1] - in insertRHSInspectDebugHooks d rlIdx rule {ruleRHS = rhs'} + in concatMap (updateRHSAggregate d rule{ruleRHS = rhs} rlIdx) [0..length rhs - 1] + -- Insert an aggregate function that wraps the original function used in the aggregate term. -- For example, if an aggregate operator uses std::group_max(), i.e., var c = Aggregate((a), group_max(b)). diff --git a/src/Language/DifferentialDatalog/Debugger/DebugEventParser.hs b/src/Language/DifferentialDatalog/Debugger/DebugEventParser.hs index 0f81bc30c..eb6a23085 100644 --- a/src/Language/DifferentialDatalog/Debugger/DebugEventParser.hs +++ b/src/Language/DifferentialDatalog/Debugger/DebugEventParser.hs @@ -29,40 +29,11 @@ import Text.Parsec import Text.Parsec.Language import Data.Functor.Identity -data Operator = OpMap | OpAggregate | OpCondition | OpJoin - | OpAntijoin | OpInspect | OpUndefined deriving (Show) - -data OperatorId = OperatorId {opRelId:: Int, opRule::Int, opOperaror::Int} deriving (Show) - -data Event = DebugEvent { evtOperatorId :: OperatorId - , evtWeight :: Int - , evtTimestamp :: Integer - , evtOperator :: Operator - , evtInput :: Record - , evtOutput :: Record - } - | DebugJoinEvent { evtOperatorId :: OperatorId - , evtWeight :: Int - , evtTimestamp :: Integer - , evtOperator :: Operator - , evtInput1 :: Record - , evtInput2 :: Record - , evtOutput :: Record - } - deriving (Show) - -data Record = IntRecord {intVal :: Integer} - | BoolRecord {boolVal :: Bool} - | DoubleRecord {doubleVal :: Double} - | StringRecord {stringVal :: String} - | NamedStructRecord {name :: String, val :: [(String, Record)]} - | TupleRecord {tupleVal :: [Record]} - | ArrayRecord {arrayVal :: [Record]} - deriving (Show) +import Language.DifferentialDatalog.Debugger.DebugTypes debugDef :: GenLanguageDef String u Data.Functor.Identity.Identity -debugDef = emptyDef { T.identStart = alphaNum - , T.identLetter = alphaNum +debugDef = emptyDef { T.identStart = alphaNum <|> char '_' + , T.identLetter = alphaNum <|> char '_' <|> char ':' , T.caseSensitive = True} identifier :: ParsecT String u Identity String @@ -89,6 +60,9 @@ parens = T.parens lexer brackets :: ParsecT String u Identity a -> ParsecT String u Identity a brackets = T.brackets lexer +integer :: ParsecT String u Identity Integer +integer = T.integer lexer + decimal :: ParsecT String u Identity Integer decimal = T.decimal lexer @@ -143,7 +117,7 @@ debugEventParser :: ParsecT String u Identity Event debugEventParser = do opid <- parens (OperatorId <$> (fromIntegral <$> (decimal <* comma)) <*> (fromIntegral <$> (decimal <* comma)) <*> (fromIntegral <$> decimal)) - w <- fromIntegral <$> (comma *> decimal) + w <- fromIntegral <$> (comma *> integer) ts <- comma *> decimal <* comma op <- operatorParser case op of diff --git a/src/Language/DifferentialDatalog/Debugger/DebugState.hs b/src/Language/DifferentialDatalog/Debugger/DebugState.hs new file mode 100644 index 000000000..beb499091 --- /dev/null +++ b/src/Language/DifferentialDatalog/Debugger/DebugState.hs @@ -0,0 +1,179 @@ +{- +Copyright (c) 2020 VMware, Inc. +SPDX-License-Identifier: MIT + +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. +-} + +{-# LANGUAGE TupleSections, LambdaCase, RecordWildCards#-} + +module Language.DifferentialDatalog.Debugger.DebugState ( + queryDerivations, + constructRecordMap, + handleDebugEvents, + emptyDebuggerMaps, + getPredecessorOpId, + DebuggerMaps(..), + DebuggerRecord(..), + OperatorInput(..), + DebuggerRecordMap, + )where + +import qualified Data.Map as M + +import Language.DifferentialDatalog.Syntax +import Language.DifferentialDatalog.Debugger.DebugTypes + +-- (1) Derivation corresponds to the input records for a specifc output record. +-- (2) One derivation could have at most two elements since Join has at most two input +-- records and other operators have only one input record. +-- (3) One output record may have multiple derivations. +type Derivation = [DebuggerRecord] + +-- Output Record -> all possible derivations +type DebuggerRecordMap = M.Map DebuggerRecord [Derivation] +type DebuggerRecordWeightMap = M.Map DebuggerRecord Int + +data OperatorInput = InputOp OperatorId + | InputRel String + deriving (Show, Eq, Ord) + +data DebuggerRecord = DebuggerRecord { dbgRecord :: Record + , dbgOperatorId :: OperatorInput + } deriving (Show, Eq, Ord) + +-- DebuggerRecordNode +-- nodeVal : record val and its operator id +-- childrenList : each list element is a children set that construct the parent node +-- there could be multiple derivations, so it is a list of children set +data DebuggerRecordNode = DebuggerRecordNode { nodeVal :: DebuggerRecord + , childrenList :: [[DebuggerRecordNode]] + } deriving (Show) + + +data DebuggerMaps = DebuggerMaps { dbgRecordMap :: DebuggerRecordMap + , dbgRecordWeightMap :: DebuggerRecordWeightMap + } deriving (Show) + +emptyDebuggerMaps :: DebuggerMaps +emptyDebuggerMaps = DebuggerMaps M.empty M.empty + +-- Return root node of the derivation tree +queryDerivations :: DebuggerRecord -> DebuggerRecordMap -> DebuggerRecordNode +queryDerivations debuggerRecord debuggerRecordMap = + let root = DebuggerRecordNode { nodeVal = debuggerRecord, childrenList = []} + in case (dbgOperatorId debuggerRecord) of + InputRel _ -> root + InputOp _ -> let derivation = M.lookup debuggerRecord debuggerRecordMap + in case derivation of + Nothing -> root -- control should never arrive here + Just derivations -> let childrenList = map (derivationToDebuggerRecordNode debuggerRecordMap) derivations + in DebuggerRecordNode {nodeVal = debuggerRecord, childrenList = childrenList} + +-- helper function used by `queryDerivations` +-- Derivation: [DebuggerRecord], generally has one/two input records, it stands +-- for one possible derivation for a specific output record + +derivationToDebuggerRecordNode :: DebuggerRecordMap -> Derivation -> [DebuggerRecordNode] +derivationToDebuggerRecordNode debuggerRecordMap derivation = + map (\inputrecord -> queryDerivations inputrecord debuggerRecordMap) derivation + +handleDebugEvents :: [Event] -> DebuggerMaps -> DatalogProgram -> DebuggerMaps +handleDebugEvents [] dbgMaps _ = dbgMaps +handleDebugEvents (event:events) dbgMaps prog = + let updatedMaps = handleDebugEvent event dbgMaps prog + in handleDebugEvents events updatedMaps prog + +handleDebugEvent :: Event -> DebuggerMaps -> DatalogProgram -> DebuggerMaps +handleDebugEvent DebugJoinEvent{..} DebuggerMaps{..} prog = + let outputRecord = DebuggerRecord { dbgRecord = evtOutput, dbgOperatorId = InputOp evtOperatorId} + outputRecordWeight = M.lookup outputRecord dbgRecordWeightMap + updatedWeight = case outputRecordWeight of + Nothing -> evtWeight + Just w -> evtWeight + w + in if updatedWeight == 0 + then + let updatedDbgRecordMap = M.delete outputRecord dbgRecordMap + updatedDbgRecordWeightMap = M.delete outputRecord dbgRecordWeightMap + in DebuggerMaps { dbgRecordMap = updatedDbgRecordMap, dbgRecordWeightMap = updatedDbgRecordWeightMap} + else + let traceRecords = M.lookup outputRecord dbgRecordMap + predecessorIds = getPredecessorOpId evtOperatorId prog + inputRecord1 = DebuggerRecord { dbgRecord = evtInput1, dbgOperatorId = (predecessorIds !! 0)} + inputRecord2 = DebuggerRecord { dbgRecord = evtInput2, dbgOperatorId = (predecessorIds !! 1)} + derivation = [inputRecord1, inputRecord2] + updatedDbgRecordWeightMap = M.insert outputRecord updatedWeight dbgRecordWeightMap + in case traceRecords of + Nothing -> let updatedDbgRecordMap = M.insert outputRecord [derivation] dbgRecordMap + in DebuggerMaps { dbgRecordMap = updatedDbgRecordMap, dbgRecordWeightMap = updatedDbgRecordWeightMap} + Just derivations -> let updatedDbgRecordMap = M.insert outputRecord (derivations ++ [derivation]) dbgRecordMap + in DebuggerMaps { dbgRecordMap = updatedDbgRecordMap, dbgRecordWeightMap = updatedDbgRecordWeightMap} + +handleDebugEvent DebugEvent{..} DebuggerMaps{..} prog = + let outputRecord = DebuggerRecord { dbgRecord = evtOutput, dbgOperatorId = InputOp evtOperatorId} + outputRecordWeight = M.lookup outputRecord dbgRecordWeightMap + updatedWeight = case outputRecordWeight of + Nothing -> evtWeight + Just w -> evtWeight + w + in if updatedWeight == 0 + then + let updatedDbgRecordMap = M.delete outputRecord dbgRecordMap + updatedDbgRecordWeightMap = M.delete outputRecord dbgRecordWeightMap + in DebuggerMaps { dbgRecordMap = updatedDbgRecordMap, dbgRecordWeightMap = updatedDbgRecordWeightMap} + else + let traceRecords = M.lookup outputRecord dbgRecordMap + predecessorIds = getPredecessorOpId evtOperatorId prog + inputRecord = DebuggerRecord { dbgRecord = evtInput, dbgOperatorId = (predecessorIds !! 0)} + derivation = [inputRecord] + updatedDbgRecordWeightMap = M.insert outputRecord updatedWeight dbgRecordWeightMap + in case traceRecords of + Nothing -> let updatedDbgRecordMap = M.insert outputRecord [derivation] dbgRecordMap + in DebuggerMaps { dbgRecordMap = updatedDbgRecordMap, dbgRecordWeightMap = updatedDbgRecordWeightMap} + Just derivations -> let updatedDbgRecordMap = M.insert outputRecord (derivations ++ [derivation]) dbgRecordMap + in DebuggerMaps { dbgRecordMap = updatedDbgRecordMap, dbgRecordWeightMap = updatedDbgRecordWeightMap} + +constructRecordMap :: [Event] -> DebuggerMaps -> DatalogProgram -> DebuggerMaps +constructRecordMap [] recordMaps _ = recordMaps +constructRecordMap (event:events) recordMaps prog = + let updatedMaps = handleDebugEvent event recordMaps prog + in constructRecordMap events updatedMaps prog + + +-- Get the operator if for input records in a debug entry +getPredecessorOpId :: OperatorId -> DatalogProgram-> [OperatorInput] +getPredecessorOpId OperatorId{..} DatalogProgram{..} = + let Rule{..} = progRules !! ruleIdx + ruleRhs = ruleRHS !! rhsIdx + in case ruleRhs of + RHSLiteral{..} -> + if rhsIdx == 0 + then [InputRel (atomRelation rhsAtom)] + else let prevRuleRhs = ruleRHS !! (rhsIdx - 1) + in case prevRuleRhs of + RHSLiteral{rhsAtom = prevAtom} -> [InputRel (atomRelation prevAtom), InputRel (atomRelation rhsAtom)] + _ -> [InputOp OperatorId {ruleIdx = ruleIdx, rhsIdx = (rhsIdx - 1), headIdx = headIdx}, InputRel (atomRelation rhsAtom)] + RHSCondition{..} -> let prevRhsIdx = getPredecessorRHSRuleIdxForCondition rhsIdx ruleRHS + in [InputOp OperatorId {ruleIdx = ruleIdx, rhsIdx = prevRhsIdx, headIdx = headIdx}] + _ -> [InputOp OperatorId {ruleIdx = ruleIdx, rhsIdx = (rhsIdx - 1), headIdx = headIdx}] + +getPredecessorRHSRuleIdxForCondition :: Int -> [RuleRHS] -> Int +getPredecessorRHSRuleIdxForCondition rhsIdx rules = + case (rules !! (rhsIdx-1)) of + RHSCondition{..} -> getPredecessorRHSRuleIdxForCondition (rhsIdx-1) rules + _ -> (rhsIdx-1) diff --git a/src/Language/DifferentialDatalog/Debugger/DebugTypes.hs b/src/Language/DifferentialDatalog/Debugger/DebugTypes.hs new file mode 100644 index 000000000..190cf65c8 --- /dev/null +++ b/src/Language/DifferentialDatalog/Debugger/DebugTypes.hs @@ -0,0 +1,59 @@ +{- +Copyright (c) 2020 VMware, Inc. +SPDX-License-Identifier: MIT + +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. +-} + +module Language.DifferentialDatalog.Debugger.DebugTypes ( + Event(..), + Record(..), + Operator(..), + OperatorId(..)) where + +data Operator = OpMap | OpAggregate | OpCondition | OpJoin + | OpAntijoin | OpInspect | OpUndefined deriving (Show) + +data OperatorId = OperatorId {ruleIdx:: Int, rhsIdx::Int, headIdx::Int} deriving (Show, Eq, Ord) + +data Event = DebugEvent { evtOperatorId :: OperatorId + , evtWeight :: Int + , evtTimestamp :: Integer + , evtOperator :: Operator + , evtInput :: Record + , evtOutput :: Record + } + | DebugJoinEvent { evtOperatorId :: OperatorId + , evtWeight :: Int + , evtTimestamp :: Integer + , evtOperator :: Operator + , evtInput1 :: Record + , evtInput2 :: Record + , evtOutput :: Record + } + deriving (Show) + +data Record = IntRecord {intVal :: Integer} + | BoolRecord {boolVal :: Bool} + | DoubleRecord {doubleVal :: Double} + | StringRecord {stringVal :: String} + | NamedStructRecord {name :: String, val :: [(String, Record)]} + | TupleRecord {tupleVal :: [Record]} + | ArrayRecord {arrayVal :: [Record]} + deriving (Show, Eq, Ord) \ No newline at end of file