7x31
/
shellcheck
mirror of https://github.com/koalaman/shellcheck.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity
shellcheck/src/ShellCheck/CFG.hs

1269 lines
46 KiB
Haskell
Raw Blame History

{-
Copyright 2022 Vidar Holen
This file is part of ShellCheck.
https://www.shellcheck.net
ShellCheck is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
ShellCheck is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <https://www.gnu.org/licenses/>.
-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}
-- Constructs a Control Flow Graph from an AST
module ShellCheck.CFG (
CFNode (..),
CFEdge (..),
CFEffect (..),
CFStringPart (..),
CFVariableProp (..),
CFGResult (..),
CFValue (..),
CFGraph,
CFGParameters (..),
IdTagged (..),
Scope (..),
buildGraph
, ShellCheck.CFG.runTests -- STRIP
)
where
import GHC.Generics (Generic)
import ShellCheck.AST
import ShellCheck.ASTLib
import ShellCheck.Interface
import ShellCheck.Prelude
import ShellCheck.Regex
import Control.DeepSeq
import Control.Monad
import Control.Monad.Identity
import Data.List hiding (map)
import Data.Maybe
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Monad.RWS.Lazy
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Query.DFS
import Data.Graph.Inductive.Basic
import Data.Graph.Inductive.Query.Dominators
import Data.Graph.Inductive.PatriciaTree as G
import Debug.Trace -- STRIP
import Test.QuickCheck.All (forAllProperties)
import Test.QuickCheck.Test (quickCheckWithResult, stdArgs, maxSuccess)
-- Our basic Graph type
type CFGraph = G.Gr CFNode CFEdge
-- Node labels in a Control Flow Graph
data CFNode =
-- A no-op node for structural purposes
CFStructuralNode
-- A no-op for graph inspection purposes
| CFEntryPoint String
-- Drop current prefix assignments
| CFDropPrefixAssignments
-- A node with a certain effect on program state
| CFApplyEffects [IdTagged CFEffect]
-- The execution of a command or function by literal string if possible
| CFExecuteCommand (Maybe String)
-- Execute a subshell. These are represented by disjoint graphs just like
-- functions, but they don't require any form of name resolution
| CFExecuteSubshell String Node Node
-- Assignment of $?
| CFSetExitCode Id
-- The virtual 'exit' at the natural end of a subshell
| CFImpliedExit
-- An exit statement resolvable at CFG build time
| CFResolvedExit
-- An exit statement only resolvable at DFA time
| CFUnresolvedExit
-- An unreachable node, serving as the unconnected end point of a range
| CFUnreachable
-- Assignment of $!
| CFSetBackgroundPid Id
deriving (Eq, Ord, Show, Generic, NFData)
-- Edge labels in a Control Flow Graph
data CFEdge =
CFEErrExit
-- Regular control flow edge
| CFEFlow
-- An edge that a human might think exists (e.g. from a backgrounded process to its parent)
| CFEFalseFlow
-- An edge followed on exit
| CFEExit
deriving (Eq, Ord, Show, Generic, NFData)
-- Actions we track
data CFEffect =
CFSetProps Scope String (S.Set CFVariableProp)
| CFUnsetProps Scope String (S.Set CFVariableProp)
| CFReadVariable String
| CFWriteVariable String CFValue
| CFWriteGlobal String CFValue
| CFWriteLocal String CFValue
| CFWritePrefix String CFValue
| CFDefineFunction String Id Node Node
| CFUndefine String
| CFUndefineVariable String
| CFUndefineFunction String
| CFUndefineNameref String
-- Usage implies that this is an array (e.g. it's expanded with index)
| CFHintArray String
-- Operation implies that the variable will be defined (e.g. [ -z "$var" ])
| CFHintDefined String
deriving (Eq, Ord, Show, Generic, NFData)
data IdTagged a = IdTagged Id a
deriving (Eq, Ord, Show, Generic, NFData)
-- Where a variable's value comes from
data CFValue =
-- The special 'uninitialized' value
CFValueUninitialized
-- An arbitrary array value
| CFValueArray
-- An arbitrary string value
| CFValueString
-- An arbitrary integer
| CFValueInteger
-- Token 'Id' concatenates and assigns the given parts
| CFValueComputed Id [CFStringPart]
deriving (Eq, Ord, Show, Generic, NFData)
-- Simplified computed strings
data CFStringPart =
-- A known literal string value, like 'foo'
CFStringLiteral String
-- The contents of a variable, like $foo (may not be a string)
| CFStringVariable String
-- An value that is unknown but an integer
| CFStringInteger
-- An unknown string value, for things we can't handle
| CFStringUnknown
deriving (Eq, Ord, Show, Generic, NFData)
-- The properties of a variable
data CFVariableProp = CFVPExport | CFVPArray | CFVPAssociative | CFVPInteger
deriving (Eq, Ord, Show, Generic, NFData)
-- Options when generating CFG
data CFGParameters = CFGParameters {
-- Whether the last element in a pipeline runs in the current shell
cfLastpipe :: Bool,
-- Whether all elements in a pipeline count towards the exit status
cfPipefail :: Bool
}
data CFGResult = CFGResult {
-- The graph itself
cfGraph :: CFGraph,
-- Map from Id to nominal start&end node (i.e. assuming normal execution without exits)
cfIdToRange :: M.Map Id (Node, Node),
-- A set of all nodes belonging to an Id, recursively
cfIdToNodes :: M.Map Id (S.Set Node),
-- A map to nodes that the given node postdominates
cfPostDominators :: M.Map Node (S.Set Node)
}
deriving (Show, Generic, NFData)
buildGraph :: CFGParameters -> Token -> CFGResult
buildGraph params root =
let
(nextNode, base) = execRWS (buildRoot root) (newCFContext params) 0
(nodes, edges, mapping, association) =
-- renumberTopologically $
removeUnnecessaryStructuralNodes
base
idToRange = M.fromList mapping
isRealEdge (from, to, edge) = case edge of CFEFlow -> True; _ -> False
onlyRealEdges = filter isRealEdge edges
(_, mainExit) = fromJust $ M.lookup (getId root) idToRange
result = CFGResult {
cfGraph = mkGraph nodes edges,
cfIdToRange = idToRange,
cfIdToNodes = M.fromListWith S.union $ map (\(id, n) -> (id, S.singleton n)) association,
cfPostDominators = findPostDominators mainExit $ mkGraph nodes onlyRealEdges
}
in
deepseq result result
remapGraph :: M.Map Node Node -> CFW -> CFW
remapGraph remap (nodes, edges, mapping, assoc) =
(
map (remapNode remap) nodes,
map (remapEdge remap) edges,
map (\(id, (a,b)) -> (id, (remapHelper remap a, remapHelper remap b))) mapping,
map (\(id, n) -> (id, remapHelper remap n)) assoc
)
prop_testRenumbering =
let
s = CFStructuralNode
before = (
[(1,s), (3,s), (4, s), (8,s)],
[(1,3,CFEFlow), (3,4, CFEFlow), (4,8,CFEFlow)],
[(Id 0, (3,4))],
[(Id 1, 3), (Id 2, 4)]
)
after = (
[(0,s), (1,s), (2,s), (3,s)],
[(0,1,CFEFlow), (1,2, CFEFlow), (2,3,CFEFlow)],
[(Id 0, (1,2))],
[(Id 1, 1), (Id 2, 2)]
)
in after == renumberGraph before
-- Renumber the graph for prettiness, so there are no gaps in node numbers
renumberGraph :: CFW -> CFW
renumberGraph g@(nodes, edges, mapping, assoc) =
let renumbering = M.fromList (flip zip [0..] $ sort $ map fst nodes)
in remapGraph renumbering g
prop_testRenumberTopologically =
let
s = CFStructuralNode
before = (
[(4,s), (2,s), (3, s)],
[(4,2,CFEFlow), (2,3, CFEFlow)],
[(Id 0, (4,2))],
[]
)
after = (
[(0,s), (1,s), (2,s)],
[(0,1,CFEFlow), (1,2, CFEFlow)],
[(Id 0, (0,1))],
[]
)
in after == renumberTopologically before
-- Renumber the graph in topological order
renumberTopologically g@(nodes, edges, mapping, assoc) =
let renumbering = M.fromList (flip zip [0..] $ topsort (mkGraph nodes edges :: CFGraph))
in remapGraph renumbering g
prop_testRemoveStructural =
let
s = CFStructuralNode
before = (
[(1,s), (2,s), (3, s), (4,s)],
[(1,2,CFEFlow), (2,3, CFEFlow), (3,4,CFEFlow)],
[(Id 0, (2,3))],
[(Id 0, 3)]
)
after = (
[(1,s), (2,s), (4,s)],
[(1,2,CFEFlow), (2,4,CFEFlow)],
[(Id 0, (2,2))],
[(Id 0, 2)]
)
in after == removeUnnecessaryStructuralNodes before
-- Collapse structural nodes that just form long chains like x->x->x.
-- This way we can generate them with abandon, without making DFA slower.
--
-- Note in particular that we can't remove a structural node x in
-- foo -> x -> bar , because then the pre/post-condition for tokens
-- previously pointing to x would be wrong.
removeUnnecessaryStructuralNodes (nodes, edges, mapping, association) =
remapGraph recursiveRemapping
(
filter (\(n, _) -> n `M.notMember` recursiveRemapping) nodes,
filter (`S.notMember` edgesToCollapse) edges,
mapping,
association
)
where
regularEdges = filter isRegularEdge edges
inDegree = counter $ map (\(from,to,_) -> from) regularEdges
outDegree = counter $ map (\(from,to,_) -> to) regularEdges
structuralNodes = S.fromList $ map fst $ filter isStructural nodes
candidateNodes = S.filter isLinear structuralNodes
edgesToCollapse = S.fromList $ filter filterEdges regularEdges
remapping :: M.Map Node Node
remapping = foldl' (\m (new, old) -> M.insert old new m) M.empty $ map orderEdge $ S.toList edgesToCollapse
recursiveRemapping = M.fromList $ map (\c -> (c, recursiveLookup remapping c)) $ M.keys remapping
filterEdges (a,b,_) =
a `S.member` candidateNodes && b `S.member` candidateNodes
orderEdge (a,b,_) = if a < b then (a,b) else (b,a)
counter = foldl' (\map key -> M.insertWith (+) key 1 map) M.empty
isRegularEdge (_, _, CFEFlow) = True
isRegularEdge _ = False
recursiveLookup :: M.Map Node Node -> Node -> Node
recursiveLookup map node =
case M.lookup node map of
Nothing -> node
Just x -> recursiveLookup map x
isStructural (node, label) =
case label of
CFStructuralNode -> True
_ -> False
isLinear node =
M.findWithDefault 0 node inDegree == 1
&& M.findWithDefault 0 node outDegree == 1
remapNode :: M.Map Node Node -> LNode CFNode -> LNode CFNode
remapNode m (node, label) =
(remapHelper m node, newLabel)
where
newLabel = case label of
CFApplyEffects effects -> CFApplyEffects (map (remapEffect m) effects)
CFExecuteSubshell s a b -> CFExecuteSubshell s (remapHelper m a) (remapHelper m b)
_ -> label
remapEffect map old@(IdTagged id effect) =
case effect of
CFDefineFunction name id start end -> IdTagged id $ CFDefineFunction name id (remapHelper map start) (remapHelper map end)
_ -> old
remapEdge :: M.Map Node Node -> LEdge CFEdge -> LEdge CFEdge
remapEdge map (from, to, label) = (remapHelper map from, remapHelper map to, label)
remapHelper map n = M.findWithDefault n n map
data Range = Range Node Node
deriving (Eq, Show)
data CFContext = CFContext {
cfIsCondition :: Bool,
cfIsFunction :: Bool,
cfLoopStack :: [(Node, Node)],
cfTokenStack :: [Id],
cfExitTarget :: Maybe Node,
cfReturnTarget :: Maybe Node,
cfParameters :: CFGParameters
}
newCFContext params = CFContext {
cfIsCondition = False,
cfIsFunction = False,
cfLoopStack = [],
cfTokenStack = [],
cfExitTarget = Nothing,
cfReturnTarget = Nothing,
cfParameters = params
}
-- The monad we generate a graph in
type CFM a = RWS CFContext CFW Int a
type CFW = ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))], [(Id, Node)])
newNode :: CFNode -> CFM Node
newNode label = do
n <- get
stack <- asks cfTokenStack
put (n+1)
tell ([(n, label)], [], [], map (\c -> (c, n)) stack)
return n
newNodeRange :: CFNode -> CFM Range
-- newNodeRange label = nodeToRange <$> newNode label
newNodeRange label = nodeToRange <$> newNode label
-- Build a disjoint piece of the graph and return a CFExecuteSubshell. The Id is used purely for debug naming.
subshell :: Id -> String -> CFM Range -> CFM Range
subshell id reason p = do
start <- newNode $ CFEntryPoint $ "Subshell " ++ show id ++ ": " ++ reason
end <- newNode CFStructuralNode
middle <- local (\c -> c { cfExitTarget = Just end, cfReturnTarget = Just end}) p
linkRanges [nodeToRange start, middle, nodeToRange end]
newNodeRange $ CFExecuteSubshell reason start end
withFunctionScope p = do
end <- newNode CFStructuralNode
body <- local (\c -> c { cfReturnTarget = Just end, cfIsFunction = True }) p
linkRanges [body, nodeToRange end]
-- Anything that happens recursively in f will be attributed to this id
under :: Id -> CFM a -> CFM a
under id f = local (\c -> c { cfTokenStack = id:(cfTokenStack c) }) f
nodeToRange :: Node -> Range
nodeToRange n = Range n n
link :: Node -> Node -> CFEdge -> CFM ()
link from to label = do
tell ([], [(from, to, label)], [], [])
registerNode :: Id -> Range -> CFM ()
registerNode id (Range start end) = tell ([], [], [(id, (start, end))], [])
linkRange :: Range -> Range -> CFM Range
linkRange = linkRangeAs CFEFlow
linkRangeAs :: CFEdge -> Range -> Range -> CFM Range
linkRangeAs label (Range start mid1) (Range mid2 end) = do
link mid1 mid2 label
return (Range start end)
-- Like linkRange but without actually linking
spanRange :: Range -> Range -> Range
spanRange (Range start mid1) (Range mid2 end) = Range start end
linkRanges :: [Range] -> CFM Range
linkRanges [] = error "Empty range"
linkRanges (first:rest) = foldM linkRange first rest
sequentially :: [Token] -> CFM Range
sequentially list = do
first <- newStructuralNode
rest <- mapM build list
linkRanges (first:rest)
withContext :: (CFContext -> CFContext) -> CFM a -> CFM a
withContext = local
withReturn :: Range -> CFM a -> CFM a
withReturn _ p = p
asCondition :: CFM Range -> CFM Range
asCondition = withContext (\c -> c { cfIsCondition = True })
newStructuralNode = newNodeRange CFStructuralNode
buildRoot :: Token -> CFM Range
buildRoot t = under (getId t) $ do
entry <- newNodeRange $ CFEntryPoint "MAIN"
impliedExit <- newNode CFImpliedExit
end <- newNode CFStructuralNode
start <- local (\c -> c { cfExitTarget = Just end, cfReturnTarget = Just impliedExit}) $ build t
range <- linkRanges [entry, start, nodeToRange impliedExit, nodeToRange end]
registerNode (getId t) range
return range
applySingle e = CFApplyEffects [e]
-- Build the CFG.
build :: Token -> CFM Range
build t = do
range <- under (getId t) $ build' t
registerNode (getId t) range
return range
where
build' t = case t of
T_Annotation _ _ list -> build list
T_Script _ _ list -> do
sequentially list
TA_Assignment id op var@(TA_Variable _ name indices) rhs -> do
-- value first: (( var[x=1] = (x=2) )) runs x=1 last
value <- build rhs
subscript <- sequentially indices
read <-
if op == "="
then none
-- This is += or something
else newNodeRange $ applySingle $ IdTagged id $ CFReadVariable name
write <- newNodeRange $ applySingle $ IdTagged id $ CFWriteVariable name $
if null indices
then CFValueInteger
else CFValueArray
linkRanges [value, subscript, read, write]
TA_Assignment id op lhs rhs -> do
-- This is likely an invalid assignment like (( 1 = 2 )), but it
-- could be e.g. x=y; (( $x = 3 )); echo $y, so expand both sides
-- without updating anything
sequentially [lhs, rhs]
TA_Binary _ _ a b -> sequentially [a,b]
TA_Expansion _ list -> sequentially list
TA_Sequence _ list -> sequentially list
TA_Parentesis _ t -> build t
TA_Trinary _ cond a b -> do
condition <- build cond
ifthen <- build a
elsethen <- build b
end <- newStructuralNode
linkRanges [condition, ifthen, end]
linkRanges [condition, elsethen, end]
TA_Variable id name indices -> do
subscript <- sequentially indices
hint <-
if null indices
then none
else nodeToRange <$> newNode (applySingle $ IdTagged id $ CFHintArray name)
read <- nodeToRange <$> newNode (applySingle $ IdTagged id $ CFReadVariable name)
linkRanges [subscript, hint, read]
TA_Unary id op (TA_Variable _ name indices) | "--" `isInfixOf` op || "++" `isInfixOf` op -> do
subscript <- sequentially indices
read <- newNodeRange $ applySingle $ IdTagged id $ CFReadVariable name
write <- newNodeRange $ applySingle $ IdTagged id $ CFWriteVariable name $
if null indices
then CFValueInteger
else CFValueArray
linkRanges [subscript, read, write]
TA_Unary _ _ arg -> build arg
TC_And _ SingleBracket _ lhs rhs -> do
sequentially [lhs, rhs]
TC_And _ DoubleBracket _ lhs rhs -> do
left <- build lhs
right <- build rhs
end <- newStructuralNode
-- complete
linkRanges [left, right, end]
-- short circuit
linkRange left end
-- TODO: Handle integer ops
TC_Binary _ mode str lhs rhs -> do
left <- build lhs
right <- build rhs
linkRange left right
TC_Empty {} -> newStructuralNode
TC_Group _ _ t -> build t
-- TODO: Mark as checked
TC_Nullary _ _ arg -> build arg
TC_Or _ SingleBracket _ lhs rhs -> sequentially [lhs, rhs]
TC_Or _ DoubleBracket _ lhs rhs -> do
left <- build lhs
right <- build rhs
end <- newStructuralNode
-- complete
linkRanges [left, right, end]
-- short circuit
linkRange left end
-- TODO: Handle -v, -z, -n
TC_Unary _ _ op arg -> do
build arg
T_Arithmetic id root -> do
exe <- build root
status <- newNodeRange (CFSetExitCode id)
linkRange exe status
T_AndIf _ lhs rhs -> do
left <- build lhs
right <- build rhs
end <- newStructuralNode
linkRange left right
linkRange right end
linkRange left end
T_Array _ list -> sequentially list
T_Assignment {} -> buildAssignment DefaultScope t
T_Backgrounded id body -> do
start <- newStructuralNode
fork <- subshell id "backgrounding '&'" $ build body
pid <- newNodeRange $ CFSetBackgroundPid id
status <- newNodeRange $ CFSetExitCode id
linkRange start fork
-- Add a join from the fork to warn about variable changes
linkRangeAs CFEFalseFlow fork pid
linkRanges [start, pid, status]
T_Backticked id body ->
subshell id "`..` expansion" $ sequentially body
T_Banged id cmd -> do
main <- build cmd
status <- newNodeRange (CFSetExitCode id)
linkRange main status
T_BatsTest id _ body -> do
-- These are technically set by the 'run' command, but we'll just define them
-- up front to avoid figuring out which commands named "run" belong to Bats.
status <- newNodeRange $ applySingle $ IdTagged id $ CFWriteVariable "status" CFValueInteger
output <- newNodeRange $ applySingle $ IdTagged id $ CFWriteVariable "output" CFValueString
main <- build body
linkRanges [status, output, main]
T_BraceExpansion _ list -> sequentially list
T_BraceGroup id body ->
sequentially body
T_CaseExpression id t [] -> build t
T_CaseExpression id t list -> do
start <- newStructuralNode
token <- build t
branches <- mapM buildBranch list
end <- newStructuralNode
let neighbors = zip branches $ tail branches
let (_, firstCond, _) = head branches
let (_, lastCond, lastBody) = last branches
linkRange start token
linkRange token firstCond
mapM_ (uncurry $ linkBranch end) neighbors
linkRange lastBody end
unless (any hasCatchAll list) $
-- There's no *) branch, so assume we can fall through
void $ linkRange token end
return $ spanRange start end
where
-- for a | b | c, evaluate each in turn and allow short circuiting
buildCond list = do
start <- newStructuralNode
conds <- mapM build list
end <- newStructuralNode
linkRanges (start:conds)
mapM_ (`linkRange` end) conds
return $ spanRange start end
buildBranch (typ, cond, body) = do
c <- buildCond cond
b <- sequentially body
linkRange c b
return (typ, c, b)
linkBranch end (typ, cond, body) (_, nextCond, nextBody) = do
-- Failure case
linkRange cond nextCond
-- After body
case typ of
CaseBreak -> linkRange body end
CaseFallThrough -> linkRange body nextBody
CaseContinue -> linkRange body nextCond
-- Find a *) if any
hasCatchAll (_,cond,_) = any isCatchAll cond
isCatchAll c = fromMaybe False $ do
pg <- wordToExactPseudoGlob c
return $ pg `pseudoGlobIsSuperSetof` [PGMany]
T_Condition id _ op -> do
cond <- build op
status <- newNodeRange $ CFSetExitCode id
linkRange cond status
T_CoProc id maybeName t -> do
let name = fromMaybe "COPROC" maybeName
start <- newStructuralNode
parent <- newNodeRange $ applySingle $ IdTagged id $ CFWriteVariable name CFValueArray
child <- subshell id "coproc" $ build t
end <- newNodeRange $ CFSetExitCode id
linkRange start parent
linkRange start child
linkRange parent end
linkRangeAs CFEFalseFlow child end
return $ spanRange start end
T_CoProcBody _ t -> build t
T_DollarArithmetic _ arith -> build arith
T_DollarDoubleQuoted _ list -> sequentially list
T_DollarSingleQuoted _ _ -> none
T_DollarBracket _ t -> build t
T_DollarBraced id _ t -> do
let str = concat $ oversimplify t
let modifier = getBracedModifier str
let reference = getBracedReference str
let indices = getIndexReferences str
let offsets = getOffsetReferences str
vals <- build t
others <- mapM (\x -> nodeToRange <$> newNode (applySingle $ IdTagged id $ CFReadVariable x)) (indices ++ offsets)
deps <- linkRanges (vals:others)
read <- nodeToRange <$> newNode (applySingle $ IdTagged id $ CFReadVariable reference)
totalRead <- linkRange deps read
if any (`isPrefixOf` modifier) ["=", ":="]
then do
optionalAssign <- newNodeRange (applySingle $ IdTagged id $ CFWriteVariable reference CFValueString)
result <- newStructuralNode
linkRange optionalAssign result
linkRange totalRead result
else return totalRead
T_DoubleQuoted _ list -> sequentially list
T_DollarExpansion id body ->
subshell id "$(..) expansion" $ sequentially body
T_Extglob _ _ list -> sequentially list
T_FdRedirect id ('{':identifier) op -> do
let name = takeWhile (/= '}') identifier
expression <- build op
rw <- newNodeRange $
if isClosingFileOp op
then applySingle $ IdTagged id $ CFReadVariable name
else applySingle $ IdTagged id $ CFWriteVariable name CFValueInteger
linkRange expression rw
T_FdRedirect _ name t -> do
build t
T_ForArithmetic _ initT condT incT bodyT -> do
init <- build initT
cond <- build condT
body <- sequentially bodyT
inc <- build incT
end <- newStructuralNode
-- Forward edges
linkRanges [init, cond, body, inc]
linkRange cond end
-- Backward edge
linkRange inc cond
return $ spanRange init end
T_ForIn id name words body -> forInHelper id name words body
-- For functions we generate an unlinked subgraph, and mention that in its definition node
T_Function id _ _ name body -> do
range <- local (\c -> c { cfExitTarget = Nothing }) $ do
entry <- newNodeRange $ CFEntryPoint $ "function " ++ name
f <- withFunctionScope $ build body
linkRange entry f
let (Range entry exit) = range
definition <- newNodeRange (applySingle $ IdTagged id $ CFDefineFunction name id entry exit)
exe <- newNodeRange (CFSetExitCode id)
linkRange definition exe
T_Glob {} -> none
T_HereString _ t -> build t
T_HereDoc _ _ _ _ list -> sequentially list
T_IfExpression id ifs elses -> do
start <- newStructuralNode
branches <- doBranches start ifs elses []
end <- newStructuralNode
mapM_ (`linkRange` end) branches
return $ spanRange start end
where
doBranches start ((conds, thens):rest) elses result = do
cond <- asCondition $ sequentially conds
action <- sequentially thens
linkRange start cond
linkRange cond action
doBranches cond rest elses (action:result)
doBranches start [] elses result = do
rest <-
if null elses
then newNodeRange (CFSetExitCode id)
else sequentially elses
linkRange start rest
return (rest:result)
T_Include _ t -> build t
T_IndexedElement _ indicesT valueT -> do
indices <- sequentially indicesT
value <- build valueT
linkRange indices value
T_IoDuplicate _ op _ -> build op
T_IoFile _ op t -> do
exp <- build t
doesntDoMuch <- build op
linkRange exp doesntDoMuch
T_Literal {} -> none
T_NormalWord _ list -> sequentially list
T_OrIf _ lhs rhs -> do
left <- build lhs
right <- build rhs
end <- newStructuralNode
linkRange left right
linkRange right end
linkRange left end
T_Pipeline _ _ [cmd] -> build cmd
T_Pipeline id _ cmds -> do
start <- newStructuralNode
hasLastpipe <- reader $ cfLastpipe . cfParameters
(leading, last) <- buildPipe hasLastpipe cmds
-- Ideally we'd let this exit code be that of the last command in the pipeline but ok
end <- newNodeRange $ CFSetExitCode id
mapM_ (linkRange start) leading
mapM_ (\c -> linkRangeAs CFEFalseFlow c end) leading
linkRanges $ [start] ++ last ++ [end]
where
buildPipe True [x] = do
last <- build x
return ([], [last])
buildPipe lp (first:rest) = do
this <- subshell id "pipeline" $ build first
(leading, last) <- buildPipe lp rest
return (this:leading, last)
buildPipe _ [] = return ([], [])
T_ProcSub id op cmds -> do
start <- newStructuralNode
body <- subshell id (op ++ "() process substitution") $ sequentially cmds
end <- newStructuralNode
linkRange start body
linkRangeAs CFEFalseFlow body end
linkRange start end
T_Redirecting _ redirs cmd -> do
-- For simple commands, this is the other way around in bash
-- We do it in this order for comound commands like { x=name; } > "$x"
redir <- sequentially redirs
body <- build cmd
linkRange redir body
T_SelectIn id name words body -> forInHelper id name words body
T_SimpleCommand id vars [] -> do
-- Vars can also be empty, as in the command "> foo"
assignments <- sequentially vars
status <- newNodeRange (CFSetExitCode id)
linkRange assignments status
T_SimpleCommand id vars list@(cmd:_) ->
handleCommand t vars list $ getUnquotedLiteral cmd
T_SingleQuoted _ _ -> none
T_SourceCommand _ originalCommand inlinedSource -> do
cmd <- build originalCommand
end <- newStructuralNode
inline <- withReturn end $ build inlinedSource
linkRange cmd inline
linkRange inline end
return $ spanRange cmd inline
T_Subshell id body -> do
main <- subshell id "explicit (..) subshell" $ sequentially body
status <- newNodeRange (CFSetExitCode id)
linkRange main status
T_UntilExpression id cond body -> whileHelper id cond body
T_WhileExpression id cond body -> whileHelper id cond body
T_CLOBBER _ -> none
T_GREATAND _ -> none
T_LESSAND _ -> none
T_LESSGREAT _ -> none
T_DGREAT _ -> none
T_Greater _ -> none
T_Less _ -> none
T_ParamSubSpecialChar _ _ -> none
x -> error ("Unimplemented: " ++ show x)
-- Still in `where` clause
forInHelper id name words body = do
entry <- newStructuralNode
expansion <- sequentially words
assignmentChoice <- newStructuralNode
assignments <-
if null words || any willSplit words
then (:[]) <$> (newNodeRange $ applySingle $ IdTagged id $ CFWriteVariable name CFValueString)
else mapM (\t -> newNodeRange $ applySingle $ IdTagged id $ CFWriteVariable name $ CFValueComputed (getId t) $ tokenToParts t) words
body <- sequentially body
exit <- newStructuralNode
-- Forward edges
linkRanges [entry, expansion, assignmentChoice]
mapM_ (\t -> linkRanges [assignmentChoice, t, body]) assignments
linkRange body exit
linkRange expansion exit
-- Backward edge
linkRange body assignmentChoice
return $ spanRange entry exit
whileHelper id cond body = do
condRange <- asCondition $ sequentially cond
bodyRange <- sequentially body
end <- newNodeRange (CFSetExitCode id)
linkRange condRange bodyRange
linkRange bodyRange condRange
linkRange condRange end
handleCommand cmd vars args literalCmd = do
-- TODO: Handle assignments in declaring commands
case literalCmd of
Just "exit" -> regularExpansion vars args $ handleExit
Just "return" -> regularExpansion vars args $ handleReturn
Just "unset" -> regularExpansionWithStatus vars args $ handleUnset args
Just "declare" -> handleDeclare args
Just "local" -> handleDeclare args
Just "typeset" -> handleDeclare args
Just "printf" -> regularExpansionWithStatus vars args $ handlePrintf args
Just "wait" -> regularExpansionWithStatus vars args $ handleWait args
Just "mapfile" -> regularExpansionWithStatus vars args $ handleMapfile args
Just "readarray" -> regularExpansionWithStatus vars args $ handleMapfile args
Just "DEFINE_boolean" -> regularExpansionWithStatus vars args $ handleDEFINE args
Just "DEFINE_float" -> regularExpansionWithStatus vars args $ handleDEFINE args
Just "DEFINE_integer" -> regularExpansionWithStatus vars args $ handleDEFINE args
Just "DEFINE_string" -> regularExpansionWithStatus vars args $ handleDEFINE args
-- This will mostly behave like 'command' but ok
Just "builtin" ->
case args of
[_] -> regular
(_:newargs@(newcmd:_)) ->
handleCommand newcmd vars newargs $ getLiteralString newcmd
Just "command" ->
case args of
[_] -> regular
(_:newargs@(newcmd:_)) ->
handleOthers (getId newcmd) vars newargs $ getLiteralString newcmd
_ -> regular
where
regular = handleOthers (getId cmd) vars args literalCmd
handleExit = do
exitNode <- reader cfExitTarget
case exitNode of
Just target -> do
exit <- newNode CFResolvedExit
link exit target CFEExit
unreachable <- newNode CFUnreachable
return $ Range exit unreachable
Nothing -> do
exit <- newNode CFUnresolvedExit
unreachable <- newNode CFUnreachable
return $ Range exit unreachable
handleReturn = do
returnTarget <- reader cfReturnTarget
case returnTarget of
Nothing -> error $ pleaseReport "missing return target"
Just target -> do
ret <- newNode CFStructuralNode
link ret target CFEFlow
unreachable <- newNode CFUnreachable
return $ Range ret unreachable
handleUnset (cmd:args) = do
case () of
_ | "n" `elem` flagNames -> unsetWith CFUndefineNameref
_ | "v" `elem` flagNames -> unsetWith CFUndefineVariable
_ | "f" `elem` flagNames -> unsetWith CFUndefineFunction
_ -> unsetWith CFUndefine
where
pairs :: [(String, Token)] -- [(Flag string, token)] e.g. [("-f", t), ("", myfunc)]
pairs = map (\(str, (flag, val)) -> (str, flag)) $ fromMaybe (map (\c -> ("", (c,c))) args) $ getGnuOpts "vfn" args
(names, flags) = partition (null . fst) pairs
flagNames = map fst flags
literalNames :: [(Token, String)] -- Literal names to unset, e.g. [(myfuncToken, "myfunc")]
literalNames = mapMaybe (\(_, t) -> getLiteralString t >>= (return . (,) t)) names
-- Apply a constructor like CFUndefineVariable to each literalName, and tag with its id
unsetWith c = newNodeRange $ CFApplyEffects $ map (\(token, name) -> IdTagged (getId token) $ c name) literalNames
variableAssignRegex = mkRegex "^([_a-zA-Z][_a-zA-Z0-9]*)="
handleDeclare (cmd:args) = do
isFunc <- asks cfIsFunction
-- This is a bit of a kludge: we don't have great support for things like
-- 'declare -i x=$x' so do one round with declare x=$x, followed by declare -i x
let (evaluated, assignments, added, removed) = mconcat $ map (toEffects isFunc) args
before <- sequentially $ evaluated
assignments <- newNodeRange $ CFApplyEffects assignments
addedProps <- if null added then newStructuralNode else newNodeRange $ CFApplyEffects added
removedProps <- if null removed then newStructuralNode else newNodeRange $ CFApplyEffects removed
result <- newNodeRange $ CFSetExitCode (getId cmd)
linkRanges [before, assignments, addedProps, removedProps, result]
where
opts = map fst $ getGenericOpts args
array = "a" `elem` opts || associative
associative = "A" `elem` opts
integer = "i" `elem` opts
func = "f" `elem` opts || "F" `elem` opts
global = "g" `elem` opts
export = "x" `elem` opts
writer isFunc =
case () of
_ | global -> CFWriteGlobal
_ | isFunc -> CFWriteLocal
_ -> CFWriteVariable
scope isFunc =
case () of
_ | global -> GlobalScope
_ | isFunc -> LocalScope
_ -> DefaultScope
addedProps = S.fromList $ concat $ [
[ CFVPArray | array ],
[ CFVPInteger | integer ],
[ CFVPExport | export ],
[ CFVPAssociative | associative ]
]
removedProps = S.fromList $ concat $ [
-- Array property can't be unset
[ CFVPInteger | 'i' `elem` unsetOptions ],
[ CFVPExport | 'e' `elem` unsetOptions ]
]
toEffects isFunc (T_Assignment id mode var idx t) =
let
pre = idx ++ [t]
val = [ IdTagged id $ (writer isFunc) var $ CFValueComputed (getId t) $ [ CFStringVariable var | mode == Append ] ++ tokenToParts t ]
added = [ IdTagged id $ CFSetProps (scope isFunc) var addedProps | not $ S.null addedProps ]
removed = [ IdTagged id $ CFUnsetProps (scope isFunc) var addedProps | not $ S.null removedProps ]
in
(pre, val, added, removed)
toEffects isFunc t =
let
id = getId t
pre = [t]
literal = fromJust $ getLiteralStringExt (const $ Just "\0") t
isKnown = '\0' `notElem` literal
match = fmap head $ variableAssignRegex `matchRegex` literal
name = fromMaybe literal match
asLiteral =
IdTagged id $ (writer isFunc) name $
CFValueComputed (getId t) [ CFStringLiteral $ drop 1 $ dropWhile (/= '=') $ literal ]
asUnknown =
IdTagged id $ (writer isFunc) name $
CFValueString
added = [ IdTagged id $ CFSetProps (scope isFunc) name addedProps ]
removed = [ IdTagged id $ CFUnsetProps (scope isFunc) name removedProps ]
in
case () of
_ | not (isVariableName name) -> (pre, [], [], [])
_ | isJust match && isKnown -> (pre, [asLiteral], added, removed)
_ | isJust match -> (pre, [asUnknown], added, removed)
-- e.g. declare -i x
_ -> (pre, [], added, removed)
-- find "ia" from `define +i +a`
unsetOptions :: String
unsetOptions =
let
strings = mapMaybe getLiteralString args
plusses = filter ("+" `isPrefixOf`) strings
in
concatMap (drop 1) plusses
handlePrintf (cmd:args) =
newNodeRange $ CFApplyEffects $ maybeToList findVar
where
findVar = do
flags <- getBsdOpts "v:" args
(flag, arg) <- lookup "v" flags
name <- getLiteralString arg
return $ IdTagged (getId arg) $ CFWriteVariable name CFValueString
handleWait (cmd:args) =
newNodeRange $ CFApplyEffects $ maybeToList findVar
where
findVar = do
let flags = getGenericOpts args
(flag, arg) <- lookup "p" flags
name <- getLiteralString arg
return $ IdTagged (getId arg) $ CFWriteVariable name CFValueInteger
handleMapfile (cmd:args) =
newNodeRange $ CFApplyEffects [findVar]
where
findVar =
let (id, name) = fromMaybe (getId cmd, "MAPFILE") $ getFromArg `mplus` getFromFallback
in IdTagged id $ CFWriteVariable name CFValueArray
getFromArg = do
flags <- getGnuOpts "d:n:O:s:u:C:c:t" args
(_, arg) <- lookup "" flags
name <- getLiteralString arg
return (getId arg, name)
getFromFallback =
listToMaybe $ mapMaybe getIfVar $ reverse args
getIfVar c = do
name <- getLiteralString c
guard $ isVariableName name
return (getId c, name)
handleDEFINE (cmd:args) =
newNodeRange $ CFApplyEffects $ maybeToList findVar
where
findVar = do
name <- listToMaybe $ drop 1 args
str <- getLiteralString name
guard $ isVariableName str
return $ IdTagged (getId name) $ CFWriteVariable str CFValueString
handleOthers id vars args cmd =
regularExpansion vars args $ do
exe <- newNodeRange $ CFExecuteCommand cmd
status <- newNodeRange $ CFSetExitCode id
linkRange exe status
regularExpansion vars args p = do
args <- sequentially args
assignments <- mapM (buildAssignment PrefixScope) vars
exe <- p
dropAssignments <-
if null vars
then
return []
else do
drop <- newNodeRange CFDropPrefixAssignments
return [drop]
linkRanges $ [args] ++ assignments ++ [exe] ++ dropAssignments
regularExpansionWithStatus vars args@(cmd:_) p = do
initial <- regularExpansion vars args p
status <- newNodeRange $ CFSetExitCode (getId cmd)
linkRange initial status
none = newStructuralNode
data Scope = DefaultScope | GlobalScope | LocalScope | PrefixScope
deriving (Eq, Ord, Show, Generic, NFData)
buildAssignment scope t = do
op <- case t of
T_Assignment id mode var indices value -> do
expand <- build value
index <- sequentially indices
read <- case mode of
Append -> newNodeRange (applySingle $ IdTagged id $ CFReadVariable var)
Assign -> none
let valueType = if null indices then f id value else CFValueArray
let scoper =
case scope of
PrefixScope -> CFWritePrefix
LocalScope -> CFWriteLocal
GlobalScope -> CFWriteGlobal
DefaultScope -> CFWriteVariable
write <- newNodeRange $ applySingle $ IdTagged id $ scoper var valueType
linkRanges [expand, index, read, write]
where
f :: Id -> Token -> CFValue
f id t@T_NormalWord {} = CFValueComputed id $ [CFStringVariable var | mode == Append] ++ tokenToParts t
f id t@(T_Literal _ str) = CFValueComputed id $ [CFStringVariable var | mode == Append] ++ tokenToParts t
f _ T_Array {} = CFValueArray
registerNode (getId t) op
return op
tokenToParts t =
case t of
T_NormalWord _ list -> concatMap tokenToParts list
T_DoubleQuoted _ list -> concatMap tokenToParts list
T_SingleQuoted _ str -> [ CFStringLiteral str ]
T_Literal _ str -> [ CFStringLiteral str ]
T_DollarArithmetic {} -> [ CFStringInteger ]
T_DollarBracket {} -> [ CFStringInteger ]
T_DollarBraced _ _ list | isUnmodifiedParameterExpansion t -> [ CFStringVariable (getBracedReference $ concat $ oversimplify list) ]
-- Check if getLiteralString can handle it, if not it's unknown
_ -> [maybe CFStringUnknown CFStringLiteral $ getLiteralString t]
-- Change all subshell invocations to instead link directly to their contents.
-- This is used for producing dominator trees.
inlineSubshells :: CFGraph -> CFGraph
inlineSubshells graph = relinkedGraph
where
subshells = ufold find [] graph
find (incoming, node, label, outgoing) acc =
case label of
CFExecuteSubshell _ start end -> (node, label, start, end, incoming, outgoing):acc
_ -> acc
relinkedGraph = foldl' relink graph subshells
relink graph (node, label, start, end, incoming, outgoing) =
let
-- Link CFExecuteSubshell to the CFEntryPoint
subshellToStart = (incoming, node, label, [(CFEFlow, start)])
-- Link the subshell exit to the
endToNexts = (endIncoming, endNode, endLabel, outgoing)
(endIncoming, endNode, endLabel, _) = context graph end
in
subshellToStart & (endToNexts & graph)
findEntryNodes :: CFGraph -> [Node]
findEntryNodes graph = ufold find [] graph
where
find (incoming, node, label, _) list =
case label of
CFEntryPoint {} | null incoming -> node:list
_ -> list
findDominators main graph = asSetMap
where
inlined = inlineSubshells graph
entryNodes = main : findEntryNodes graph
asLists = concatMap (dom inlined) entryNodes
asSetMap = M.fromList $ map (\(node, list) -> (node, S.fromList list)) asLists
findTerminalNodes :: CFGraph -> [Node]
findTerminalNodes graph = ufold find [] graph
where
find (_, node, label, _) list =
case label of
CFUnresolvedExit -> node:list
CFApplyEffects effects -> f effects list
_ -> list
f [] list = list
f (IdTagged _ (CFDefineFunction _ id start end):rest) list = f rest (end:list)
f (_:rest) list = f rest list
findPostDominators :: Node -> CFGraph -> M.Map Node (S.Set Node)
findPostDominators mainexit graph = asSetMap
where
inlined = inlineSubshells graph
terminals = findTerminalNodes inlined
(incoming, _, label, outgoing) = context graph mainexit
withExitEdges = (incoming ++ map (\c -> (CFEFlow, c)) terminals, mainexit, label, outgoing) & inlined
reversed = grev withExitEdges
postDoms = dom reversed mainexit
asSetMap = M.fromList $ map (\(node, list) -> (node, S.fromList list)) postDoms
return []
runTests = $( [| $(forAllProperties) (quickCheckWithResult (stdArgs { maxSuccess = 1 }) ) |])
Reference in New Issue View Git Blame Copy Permalink