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

1314 lines
48 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.Data
import ShellCheck.Interface
import ShellCheck.Prelude
import ShellCheck.Regex
import Control.DeepSeq
import Control.Monad
import Control.Monad.Identity
import Data.Array.Unboxed
import Data.Array.ST
import Data.List hiding (map)
import qualified Data.List.NonEmpty as NE
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 (Maybe Scope) String (S.Set CFVariableProp)
| CFUnsetProps (Maybe 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),
-- An array (from,to) saying whether 'from' postdominates 'to'
cfPostDominators :: Array Node [Node]
}
deriving (Show)
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; CFEExit -> 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
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 Nothing 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@(hd:tl) -> do
start <- newStructuralNode
token <- build t
branches <- mapM buildBranch (hd NE.:| tl)
end <- newStructuralNode
let neighbors = zip (NE.toList branches) $ NE.tail branches
let (_, firstCond, _) = NE.head branches
let (_, lastCond, lastBody) = NE.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 (cmd:args) ->
handleCommand t vars (cmd NE.:| args) $ 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 -> do
error ("Unimplemented: " ++ show x) -- STRIP
none
-- 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 (NE.toList args) $ handleExit
Just "return" -> regularExpansion vars (NE.toList 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 "read" -> regularExpansionWithStatus vars args $ handleRead 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
_ NE.:| [] -> regular
(_ NE.:| newcmd:newargs) ->
handleCommand newcmd vars (newcmd NE.:| newargs) $ getLiteralString newcmd
Just "command" ->
case args of
_ NE.:| [] -> regular
(_ NE.:| newcmd:newargs) ->
handleOthers (getId newcmd) vars (newcmd NE.:| 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 NE.:| 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) -> (,) t <$> getLiteralString 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 NE.:| 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 -> Just GlobalScope
_ | isFunc -> Just LocalScope
_ -> Nothing
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 = getLiteralStringDef "\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 NE.:| 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 NE.:| 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 NE.:| 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 flagsForMapfile 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)
handleRead (cmd NE.:| args) = newNodeRange $ CFApplyEffects main
where
main = fromMaybe fallback $ do
flags <- getGnuOpts flagsForRead args
return $ fromMaybe (withFields flags) $ withArray flags
withArray :: [(String, (Token, Token))] -> Maybe [IdTagged CFEffect]
withArray flags = do
(_, token) <- lookup "a" flags
return $ fromMaybe [] $ do
name <- getLiteralString token
return [ IdTagged (getId token) $ CFWriteVariable name CFValueArray ]
withFields flags = mapMaybe getAssignment flags
getAssignment :: (String, (Token, Token)) -> Maybe (IdTagged CFEffect)
getAssignment f = do
("", (t, _)) <- return f
name <- getLiteralString t
return $ IdTagged (getId t) $ CFWriteVariable name CFValueString
fallback =
let
names = reverse $ map fromJust $ takeWhile isJust $ map (\c -> sequence (getId c, getLiteralString c)) $ reverse args
namesOrDefault = if null names then [(getId cmd, "REPLY")] else names
hasDashA = any (== "a") $ map fst $ getGenericOpts args
value = if hasDashA then CFValueArray else CFValueString
in
map (\(id, name) -> IdTagged id $ CFWriteVariable name value) namesOrDefault
handleDEFINE (cmd NE.:| 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 (NE.toList args) $ do
exe <- newNodeRange $ CFExecuteCommand cmd
status <- newNodeRange $ CFSetExitCode id
linkRange exe status
regularExpansion vars args p = do
args <- sequentially args
assignments <- mapM (buildAssignment (Just 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 NE.:| _) p = do
initial <- regularExpansion vars (NE.toList args) p
status <- newNodeRange $ CFSetExitCode (getId cmd)
linkRange initial status
none = newStructuralNode
data Scope = 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
Just PrefixScope -> CFWritePrefix
Just LocalScope -> CFWriteLocal
Just GlobalScope -> CFWriteGlobal
Nothing -> 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]
-- Like & but well defined when the node already exists
safeUpdate ctx@(_,node,_,_) graph = ctx & (delNode node graph)
-- 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 `safeUpdate` (endToNexts `safeUpdate` 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 -> Array Node [Node]
findPostDominators mainexit graph = asArray
where
inlined = inlineSubshells graph
terminals = findTerminalNodes inlined
(incoming, _, label, outgoing) = context graph mainexit
withExitEdges = (incoming ++ map (\c -> (CFEFlow, c)) terminals, mainexit, label, outgoing) `safeUpdate` inlined
reversed = grev withExitEdges
postDoms = dom reversed mainexit
(_, maxNode) = nodeRange graph
-- Holes in the array cause "Exception: (Array.!): undefined array element" while
-- inspecting/debugging, so fill the array first and then update.
initializedArray = listArray (0, maxNode) $ repeat []
asArray = initializedArray // postDoms
return []
runTests = $( [| $(forAllProperties) (quickCheckWithResult (stdArgs { maxSuccess = 1 }) ) |])
Reference in New Issue View Git Blame Copy Permalink