{-# LANGUAGE TemplateHaskell #-}

{-# LANGUAGE RankNTypes #-}

{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}

{-# LANGUAGE CPP #-}

module ShellCheck.CFGAnalysis (

analyzeControlFlow

,CFGParameters (..)

,CFGAnalysis (..)

,ProgramState (..)

,VariableState (..)

,VariableValue (..)

,VariableProperties

,SpaceStatus (..)

,NumericalStatus (..)

,getIncomingState

,getOutgoingState

,doesPostDominate

,ShellCheck.CFGAnalysis.runTests -- STRIP

) where

import Control.DeepSeq

import Control.Monad

import Control.Monad.ST

import Data.Array.Unboxed

import Data.Char

import Data.Graph.Inductive.Graph

import Data.Graph.Inductive.Query.DFS

import Data.List hiding (map)

import Data.Maybe

import Data.STRef

import Debug.Trace -- STRIP

import GHC.Generics (Generic)

import qualified Data.Map as M

import qualified Data.Set as S

import qualified ShellCheck.Data as Data

import ShellCheck.AST

import ShellCheck.CFG

import ShellCheck.Prelude

import Test.QuickCheck

iterationCount = 1000000

fallbackThreshold = 10000

cacheEntries = 10

logVerbose log = do

-- traceShowM log

return ()

logInfo log = do

-- traceShowM log

return ()

data CFGAnalysis = CFGAnalysis {

graph :: CFGraph,

tokenToRange :: M.Map Id (Node, Node),

tokenToNodes :: M.Map Id (S.Set Node),

postDominators :: Array Node [Node],

nodeToData :: M.Map Node (ProgramState, ProgramState)

} deriving (Show)

data ProgramState = ProgramState {

-- internalState :: InternalState, -- For debugging

variablesInScope :: M.Map String VariableState,

exitCodes :: S.Set Id,

stateIsReachable :: Bool

} deriving (Show, Eq, Generic, NFData)

internalToExternal :: InternalState -> ProgramState

internalToExternal s =

ProgramState {

-- Censor the literal value to avoid introducing dependencies on it. It's just for debugging.

variablesInScope = M.map censor flatVars,

-- internalState = s, -- For debugging

exitCodes = fromMaybe S.empty $ sExitCodes s,

stateIsReachable = fromMaybe True $ sIsReachable s

}

where

censor s = s {

variableValue = (variableValue s) {

literalValue = Nothing

}

}

flatVars = M.unionsWith (\_ last -> last) $ map mapStorage [sGlobalValues s, sLocalValues s, sPrefixValues s]

getIncomingState :: CFGAnalysis -> Id -> Maybe ProgramState

getIncomingState analysis id = do

(start,end) <- M.lookup id $ tokenToRange analysis

fst <$> M.lookup start (nodeToData analysis)

getOutgoingState :: CFGAnalysis -> Id -> Maybe ProgramState

getOutgoingState analysis id = do

(start,end) <- M.lookup id $ tokenToRange analysis

snd <$> M.lookup end (nodeToData analysis)

doesPostDominate :: CFGAnalysis -> Id -> Id -> Bool

doesPostDominate analysis target base = fromMaybe False $ do

(_, baseEnd) <- M.lookup base $ tokenToRange analysis

(targetStart, _) <- M.lookup target $ tokenToRange analysis

return $ targetStart `elem` (postDominators analysis ! baseEnd)

getDataForNode analysis node = M.lookup node $ nodeToData analysis

data InternalState = InternalState {

sVersion :: Integer,

sGlobalValues :: VersionedMap String VariableState,

sLocalValues :: VersionedMap String VariableState,

sPrefixValues :: VersionedMap String VariableState,

sFunctionTargets :: VersionedMap String FunctionValue,

sExitCodes :: Maybe (S.Set Id),

sIsReachable :: Maybe Bool

} deriving (Show, Generic, NFData)

newInternalState = InternalState {

sVersion = 0,

sGlobalValues = vmEmpty,

sLocalValues = vmEmpty,

sPrefixValues = vmEmpty,

sFunctionTargets = vmEmpty,

sExitCodes = Nothing,

sIsReachable = Nothing

}

unreachableState = modified newInternalState {

sIsReachable = Just False

}

createEnvironmentState :: InternalState

createEnvironmentState = do

foldl' (flip ($)) newInternalState $ concat [

addVars Data.internalVariables unknownVariableState,

addVars Data.variablesWithoutSpaces spacelessVariableState,

addVars Data.specialIntegerVariables integerVariableState

]

where

addVars names val = map (\name -> insertGlobal name val) names

spacelessVariableState = unknownVariableState {

variableValue = VariableValue {

literalValue = Nothing,

spaceStatus = SpaceStatusClean,

numericalStatus = NumericalStatusUnknown

}

}

integerVariableState = unknownVariableState {

variableValue = unknownIntegerValue

}

modified s = s { sVersion = -1 }

insertGlobal :: String -> VariableState -> InternalState -> InternalState

insertGlobal name value state = modified state {

sGlobalValues = vmInsert name value $ sGlobalValues state

}

insertLocal :: String -> VariableState -> InternalState -> InternalState

insertLocal name value state = modified state {

sLocalValues = vmInsert name value $ sLocalValues state

}

insertPrefix :: String -> VariableState -> InternalState -> InternalState

insertPrefix name value state = modified state {

sPrefixValues = vmInsert name value $ sPrefixValues state

}

insertFunction :: String -> FunctionValue -> InternalState -> InternalState

insertFunction name value state = modified state {

sFunctionTargets = vmInsert name value $ sFunctionTargets state

}

addProperties :: S.Set CFVariableProp -> VariableState -> VariableState

addProperties props state = state {

variableProperties = S.map (S.union props) $ variableProperties state

}

removeProperties :: S.Set CFVariableProp -> VariableState -> VariableState

removeProperties props state = state {

variableProperties = S.map (\s -> S.difference s props) $ variableProperties state

}

setExitCode id = setExitCodes (S.singleton id)

setExitCodes set state = modified state {

sExitCodes = Just $ set

}

data StateDependency =

-- Complete variable state

DepState Scope String VariableState

-- Only variable properties (we need properties but not values for x=1)

| DepProperties Scope String VariableProperties

-- Function definition

| DepFunction String (S.Set FunctionDefinition)

-- Whether invoking the node would result in recursion (i.e., is the function on the stack?)

| DepIsRecursive Node Bool

-- The set of commands that could have provided the exit code $?

| DepExitCodes (S.Set Id)

deriving (Show, Eq, Ord, Generic, NFData)

data FunctionDefinition = FunctionUnknown | FunctionDefinition String Node Node

deriving (Show, Eq, Ord, Generic, NFData)

type FunctionValue = S.Set FunctionDefinition

depsToState :: S.Set StateDependency -> InternalState

depsToState set = foldl insert newInternalState $ S.toList set

where

insert :: InternalState -> StateDependency -> InternalState

insert state dep =

case dep of

DepFunction name val -> insertFunction name val state

DepState scope name val -> insertIn True scope name val state

-- State includes properties and more, so don't overwrite a state with properties

DepProperties scope name props -> insertIn False scope name unknownVariableState { variableProperties = props } state

DepIsRecursive _ _ -> state

DepExitCodes s -> setExitCodes s state

insertIn overwrite scope name val state =

let

(mapToCheck, inserter) =

case scope of

PrefixScope -> (sPrefixValues, insertPrefix)

LocalScope -> (sLocalValues, insertLocal)

GlobalScope -> (sGlobalValues, insertGlobal)

DefaultScope -> error $ pleaseReport "Unresolved scope in dependency"

alreadyExists = isJust $ vmLookup name $ mapToCheck state

in

if overwrite || not alreadyExists

then inserter name val state

else state

unknownFunctionValue = S.singleton FunctionUnknown

data VariableValue = VariableValue {

literalValue :: Maybe String, -- TODO: For debugging. Remove me.

spaceStatus :: SpaceStatus,

numericalStatus :: NumericalStatus

deriving (Show, Eq, Ord, Generic, NFData)

data VariableState = VariableState {

variableValue :: VariableValue,

variableProperties :: VariableProperties

deriving (Show, Eq, Ord, Generic, NFData)

data SpaceStatus = SpaceStatusEmpty | SpaceStatusClean | SpaceStatusDirty deriving (Show, Eq, Ord, Generic, NFData)

data NumericalStatus = NumericalStatusUnknown | NumericalStatusEmpty | NumericalStatusMaybe | NumericalStatusDefinitely deriving (Show, Eq, Ord, Generic, NFData)

type VariableProperties = S.Set (S.Set CFVariableProp)

defaultProperties = S.singleton S.empty

unknownVariableState = VariableState {

variableValue = unknownVariableValue,

variableProperties = defaultProperties

}

unknownVariableValue = VariableValue {

literalValue = Nothing,

spaceStatus = SpaceStatusDirty,

numericalStatus = NumericalStatusUnknown

}

emptyVariableValue = unknownVariableValue {

literalValue = Just "",

spaceStatus = SpaceStatusEmpty,

numericalStatus = NumericalStatusEmpty

}

unsetVariableState = VariableState {

variableValue = emptyVariableValue,

variableProperties = defaultProperties

}

mergeVariableState a b = VariableState {

variableValue = mergeVariableValue (variableValue a) (variableValue b),

variableProperties = S.union (variableProperties a) (variableProperties b)

}

mergeVariableValue a b = VariableValue {

literalValue = if literalValue a == literalValue b then literalValue a else Nothing,

spaceStatus = mergeSpaceStatus (spaceStatus a) (spaceStatus b),

numericalStatus = mergeNumericalStatus (numericalStatus a) (numericalStatus b)

}

mergeSpaceStatus a b =

case (a,b) of

(SpaceStatusEmpty, y) -> y

(x, SpaceStatusEmpty) -> x

(SpaceStatusClean, SpaceStatusClean) -> SpaceStatusClean

_ -> SpaceStatusDirty

mergeNumericalStatus a b =

case (a,b) of

(NumericalStatusDefinitely, NumericalStatusDefinitely) -> NumericalStatusDefinitely

(NumericalStatusDefinitely, _) -> NumericalStatusMaybe

(_, NumericalStatusDefinitely) -> NumericalStatusMaybe

(NumericalStatusMaybe, _) -> NumericalStatusMaybe

(_, NumericalStatusMaybe) -> NumericalStatusMaybe

(NumericalStatusEmpty, NumericalStatusEmpty) -> NumericalStatusEmpty

_ -> NumericalStatusUnknown

data VersionedMap k v = VersionedMap {

mapVersion :: Integer,

mapStorage :: M.Map k v

deriving (Generic, NFData)

instance (Show k, Show v) => Show (VersionedMap k v) where

show m = (if mapVersion m >= 0 then "V" ++ show (mapVersion m) else "U") ++ " " ++ show (mapStorage m)

instance Eq InternalState where

(==) a b = stateIsQuickEqual a b || stateIsSlowEqual a b

instance (Eq k, Eq v) => Eq (VersionedMap k v) where

(==) a b = vmIsQuickEqual a b || mapStorage a == mapStorage b

instance (Ord k, Ord v) => Ord (VersionedMap k v) where

compare a b =

if vmIsQuickEqual a b

then EQ

else mapStorage a `compare` mapStorage b

data Ctx s = Ctx {

-- The current node

cNode :: STRef s Node,

-- The current input state

cInput :: STRef s InternalState,

-- The current output state

cOutput :: STRef s InternalState,

-- The current functions/subshells stack

cStack :: [StackEntry s],

-- The input graph

cGraph :: CFGraph,

-- An incrementing counter to version maps

cCounter :: STRef s Integer,

-- A cache of input state dependencies to output effects

cCache :: STRef s (M.Map Node [(S.Set StateDependency, InternalState)]),

-- Whether the cache is enabled (see fallbackThreshold)

cEnableCache :: STRef s Bool,

-- The states resulting from data flows per invocation path

cInvocations :: STRef s (M.Map [Node] (S.Set StateDependency, M.Map Node (InternalState, InternalState)))

data StackEntry s = StackEntry {

-- The entry point of this stack entry for the purpose of detecting recursion

entryPoint :: Node,

-- Whether this is a function call (as opposed to a subshell)

isFunctionCall :: Bool,

-- The node where this entry point was invoked

callSite :: Node,

-- A mutable set of dependencies we fetched from here or higher in the stack

dependencies :: STRef s (S.Set StateDependency),

-- The original input state for this stack entry

stackState :: InternalState

deriving (Eq, Generic, NFData)

#if MIN_VERSION_deepseq(1,4,2)

instance NFData (STRef s a) where

rnf = (`seq` ())

patchState :: InternalState -> InternalState -> InternalState

patchState base diff =

case () of

_ | sVersion diff == 0 -> base

_ | sVersion base == 0 -> diff

_ | stateIsQuickEqual base diff -> diff

_ ->

InternalState {

sVersion = -1,

sGlobalValues = vmPatch (sGlobalValues base) (sGlobalValues diff),

sLocalValues = vmPatch (sLocalValues base) (sLocalValues diff),

sPrefixValues = vmPatch (sPrefixValues base) (sPrefixValues diff),

sFunctionTargets = vmPatch (sFunctionTargets base) (sFunctionTargets diff),

sExitCodes = sExitCodes diff `mplus` sExitCodes base,

sIsReachable = sIsReachable diff `mplus` sIsReachable base

}

patchOutputM ctx diff = do

let cOut = cOutput ctx

oldState <- readSTRef cOut

let newState = patchState oldState diff

writeSTRef cOut newState

mergeState :: forall s. Ctx s -> InternalState -> InternalState -> ST s InternalState

mergeState ctx a b = do

-- Kludge: we want `readVariable` & friends not to read from an intermediate state,

-- so temporarily set a blank input.

let cin = cInput ctx

old <- readSTRef cin

writeSTRef cin newInternalState

x <- merge a b

writeSTRef cin old

return x

where

merge a b =

case () of

_ | sIsReachable a == Just True && sIsReachable b == Just False

|| sIsReachable a == Just False && sIsReachable b == Just True ->

error $ pleaseReport "Unexpected merge of reachable and unreachable state"

_ | sIsReachable a == Just False && sIsReachable b == Just False ->

return unreachableState

_ | sVersion a >= 0 && sVersion b >= 0 && sVersion a == sVersion b -> return a

_ -> do

globals <- mergeMaps ctx mergeVariableState readGlobal (sGlobalValues a) (sGlobalValues b)

locals <- mergeMaps ctx mergeVariableState readVariable (sLocalValues a) (sLocalValues b)

prefix <- mergeMaps ctx mergeVariableState readVariable (sPrefixValues a) (sPrefixValues b)

funcs <- mergeMaps ctx S.union readFunction (sFunctionTargets a) (sFunctionTargets b)

exitCodes <- mergeMaybes ctx S.union readExitCodes (sExitCodes a) (sExitCodes b)

return $ InternalState {

sVersion = -1,

sGlobalValues = globals,

sLocalValues = locals,

sPrefixValues = prefix,

sFunctionTargets = funcs,

sExitCodes = exitCodes,

sIsReachable = liftM2 (&&) (sIsReachable a) (sIsReachable b)

}

mergeStates :: forall s. Ctx s -> InternalState -> [InternalState] -> ST s InternalState

mergeStates ctx def list =

case list of

[] -> return def

(first:rest) -> foldM (mergeState ctx) first rest

mergeMaps :: (Ord k) => forall s.

Ctx s ->

(v -> v -> v) ->

(Ctx s -> k -> ST s v) ->

(VersionedMap k v) ->

(VersionedMap k v) ->

ST s (VersionedMap k v)

mergeMaps ctx merger reader a b =

if vmIsQuickEqual a b

then return a

else do

new <- M.fromDistinctAscList <$> reverse <$> f [] (M.toAscList $ mapStorage a) (M.toAscList $ mapStorage b)

vmFromMap ctx new

where

f l [] [] = return l

f l [] b = f l b []

f l ((k,v):rest1) [] = do

other <- reader ctx k

f ((k, merger v other):l) rest1 []

f l l1@((k1, v1):rest1) l2@((k2, v2):rest2) =

case k1 `compare` k2 of

EQ ->

f ((k1, merger v1 v2):l) rest1 rest2

LT -> do

nv2 <- reader ctx k1

f ((k1, merger v1 nv2):l) rest1 l2

GT -> do

nv1 <- reader ctx k2

f ((k2, merger nv1 v2):l) l1 rest2

mergeMaybes ctx merger reader a b =

case (a, b) of

(Nothing, Nothing) -> return Nothing

(Just v1, Nothing) -> single v1

(Nothing, Just v2) -> single v2

(Just v1, Just v2) -> return $ Just $ merger v1 v2

where

single val = do

result <- merger val <$> reader ctx

return $ Just result

vmFromMap ctx map = return $ VersionedMap {

mapVersion = -1,

mapStorage = map

}

versionMap ctx map =

if mapVersion map >= 0

then return map

else do

v <- nextVersion ctx

return map {

mapVersion = v

}

versionState ctx state =

if sVersion state >= 0

then return state

else do

self <- nextVersion ctx

ssGlobalValues <- versionMap ctx $ sGlobalValues state

ssLocalValues <- versionMap ctx $ sLocalValues state

ssFunctionTargets <- versionMap ctx $ sFunctionTargets state

return state {

sVersion = self,

sGlobalValues = ssGlobalValues,

sLocalValues = ssLocalValues,

sFunctionTargets = ssFunctionTargets

}

is2plus :: [a] -> Bool

is2plus l = case l of

_:_:_ -> True

_ -> False

stateIsQuickEqual a b =

let

va = sVersion a

vb = sVersion b

in

va >= 0 && vb >= 0 && va == vb

stateIsSlowEqual a b =

check sGlobalValues

&& check sLocalValues

&& check sPrefixValues

&& check sFunctionTargets

&& check sIsReachable

where

check f = f a == f b

vmIsQuickEqual :: VersionedMap k v -> VersionedMap k v -> Bool

vmIsQuickEqual a b =

let

va = mapVersion a

vb = mapVersion b

in

va >= 0 && vb >= 0 && va == vb

vmEmpty = VersionedMap {

mapVersion = 0,

mapStorage = M.empty

}

vmNull :: VersionedMap k v -> Bool

vmNull m = mapVersion m == 0 || (M.null $ mapStorage m)

vmLookup name map = M.lookup name $ mapStorage map

vmInsert key val map = VersionedMap {

mapVersion = -1,

mapStorage = M.insert key val $ mapStorage map

}

vmPatch :: (Ord k) => VersionedMap k v -> VersionedMap k v -> VersionedMap k v

vmPatch base diff =

case () of

_ | mapVersion base == 0 -> diff

_ | mapVersion diff == 0 -> base

_ | vmIsQuickEqual base diff -> diff

_ -> VersionedMap {

mapVersion = -1,

mapStorage = M.unionWith (flip const) (mapStorage base) (mapStorage diff)

}

writeVariable :: forall s. Ctx s -> String -> VariableState -> ST s ()

writeVariable ctx name val = do

typ <- readVariableScope ctx name

case typ of

GlobalScope -> writeGlobal ctx name val

LocalScope -> writeLocal ctx name val

-- Prefixed variables actually become local variables in the invoked function

PrefixScope -> writeLocal ctx name val

writeGlobal ctx name val = do

modifySTRef (cOutput ctx) $ insertGlobal name val

writeLocal ctx name val = do

modifySTRef (cOutput ctx) $ insertLocal name val

writePrefix ctx name val = do

modifySTRef (cOutput ctx) $ insertPrefix name val

updateVariableValue ctx name val = do

(props, scope) <- readVariablePropertiesWithScope ctx name

let f = case scope of

GlobalScope -> writeGlobal

LocalScope -> writeLocal

PrefixScope -> writeLocal -- Updates become local

f ctx name $ VariableState { variableValue = val, variableProperties = props }

updateGlobalValue ctx name val = do

props <- readGlobalProperties ctx name

writeGlobal ctx name VariableState { variableValue = val, variableProperties = props }

updateLocalValue ctx name val = do

props <- readLocalProperties ctx name

writeLocal ctx name VariableState { variableValue = val, variableProperties = props }

updatePrefixValue ctx name val = do

-- Prefix variables don't inherit properties

writePrefix ctx name VariableState { variableValue = val, variableProperties = defaultProperties }

readVariableWithScope :: forall s. Ctx s -> String -> ST s (VariableState, Scope)

readVariableWithScope ctx name = lookupStack get dep def ctx name

where

def = (unknownVariableState, GlobalScope)

get = getVariableWithScope

dep k (val, scope) = DepState scope k val

readVariablePropertiesWithScope :: forall s. Ctx s -> String -> ST s (VariableProperties, Scope)

readVariablePropertiesWithScope ctx name = lookupStack get dep def ctx name

where

def = (defaultProperties, GlobalScope)

get s k = do

(val, scope) <- getVariableWithScope s k

return (variableProperties val, scope)

dep k (val, scope) = DepProperties scope k val

readVariableScope ctx name = snd <$> readVariablePropertiesWithScope ctx name

getVariableWithScope :: InternalState -> String -> Maybe (VariableState, Scope)

getVariableWithScope s name =

case (vmLookup name $ sPrefixValues s, vmLookup name $ sLocalValues s, vmLookup name $ sGlobalValues s) of

(Just var, _, _) -> return (var, PrefixScope)

(_, Just var, _) -> return (var, LocalScope)

(_, _, Just var) -> return (var, GlobalScope)

_ -> Nothing

undefineFunction ctx name =

writeFunction ctx name $ FunctionUnknown

undefineVariable ctx name =

writeVariable ctx name $ unsetVariableState

readVariable ctx name = fst <$> readVariableWithScope ctx name

readVariableProperties ctx name = fst <$> readVariablePropertiesWithScope ctx name

readGlobal ctx name = lookupStack get dep def ctx name

where

def = unknownVariableState -- could come from the environment

get s name = vmLookup name $ sGlobalValues s

dep k v = DepState GlobalScope k v

readGlobalProperties ctx name = lookupStack get dep def ctx name

where

def = defaultProperties

get s name = variableProperties <$> (vmLookup name $ sGlobalValues s)

-- This dependency will fail to match if it's shadowed by a local variable,

-- such as in x=1; f() { local -i x; declare -ag x; } because we'll look at

-- x and find it to be local and not global. FIXME?

dep k v = DepProperties GlobalScope k v

readLocal ctx name = lookupStackUntilFunction get dep def ctx name

where

def = unsetVariableState -- can't come from the environment

get s name = vmLookup name $ sLocalValues s

dep k v = DepState LocalScope k v

readLocalProperties ctx name = fst <$> lookupStackUntilFunction get dep def ctx name

where

def = (defaultProperties, LocalScope)

with tag f = do

val <- variableProperties <$> f

return (val, tag)

get s name = (with LocalScope $ vmLookup name $ sLocalValues s) `mplus` (with PrefixScope $ vmLookup name $ sPrefixValues s)

dep k (val, scope) = DepProperties scope k val

readFunction ctx name = lookupStack get dep def ctx name

where

def = unknownFunctionValue

get s name = vmLookup name $ sFunctionTargets s

dep k v = DepFunction k v

writeFunction ctx name val = do

modifySTRef (cOutput ctx) $ insertFunction name $ S.singleton val

readExitCodes ctx = lookupStack get dep def ctx ()

where

get s () = sExitCodes s

def = S.empty

dep () v = DepExitCodes v

lookupStack' :: forall s k v.

-- Whether to stop at function boundaries

Bool

-- A function that maybe finds a value from a state

-> (InternalState -> k -> Maybe v)

-- A function that creates a dependency on what was found

-> (k -> v -> StateDependency)

-- A default value, if the value can't be found anywhere

-> v

-- Context

-> Ctx s

-- The key to look up

-> k

-- Returning the result

-> ST s v

lookupStack' functionOnly get dep def ctx key = do

top <- readSTRef $ cInput ctx

case get top key of

Just v -> return v

Nothing -> f (cStack ctx)

where

f [] = return def

f (s:_) | functionOnly && isFunctionCall s = return def

f (s:rest) = do

-- Go up the stack until we find the value, and add

-- a dependency on each state (including where it was found)

res <- fromMaybe (f rest) (return <$> get (stackState s) key)

modifySTRef (dependencies s) $ S.insert $ dep key res

return res

lookupStack = lookupStack' False

lookupStackUntilFunction = lookupStack' True

peekStack get def ctx key = do

top <- readSTRef $ cInput ctx

case get top key of

Just v -> return v

Nothing -> f (cStack ctx)

where

f [] = return def

f (s:rest) =

case get (stackState s) key of

Just v -> return v

Nothing -> f rest

fulfillsDependency ctx entry dep =

case dep of

DepState scope name val -> (== (val, scope)) <$> peek scope ctx name

DepProperties scope name props -> do

(state, s) <- peek scope ctx name

return $ scope == s && variableProperties state == props

DepFunction name val -> (== val) <$> peekFunc ctx name

-- Hack. Since we haven't pushed the soon-to-be invoked function on the stack,

-- it won't be found by the normal check.

DepIsRecursive node val | node == entry -> return True

DepIsRecursive node val -> return $ val == any (\f -> entryPoint f == node) (cStack ctx)

DepExitCodes val -> (== val) <$> peekStack (\s k -> sExitCodes s) S.empty ctx ()

-- _ -> error $ "Unknown dep " ++ show dep

where

peek scope = peekStack getVariableWithScope $ if scope == GlobalScope then (unknownVariableState, GlobalScope) else (unsetVariableState, LocalScope)

peekFunc = peekStack (\state name -> vmLookup name $ sFunctionTargets state) unknownFunctionValue

fulfillsDependencies ctx entry deps =

f $ S.toList deps

where

f [] = return True

f (dep:rest) = do

res <- fulfillsDependency ctx entry dep

if res

then f rest

else return False

newCtx g = do

c <- newSTRef 1

input <- newSTRef undefined

output <- newSTRef undefined

node <- newSTRef undefined

cache <- newSTRef M.empty

enableCache <- newSTRef True

invocations <- newSTRef M.empty

return $ Ctx {

cCounter = c,

cInput = input,

cOutput = output,

cNode = node,

cCache = cache,

cEnableCache = enableCache,

cStack = [],

cInvocations = invocations,

cGraph = g

}

nextVersion ctx = do

let ctr = cCounter ctx

n <- readSTRef ctr

writeSTRef ctr $! n+1

return n

newStackEntry ctx point isCall = do

deps <- newSTRef S.empty

state <- readSTRef $ cOutput ctx

callsite <- readSTRef $ cNode ctx

return $ StackEntry {

entryPoint = point,

isFunctionCall = isCall,

callSite = callsite,

dependencies = deps,

stackState = state

}

withNewStackFrame ctx node isCall f = do

newEntry <- newStackEntry ctx node isCall

newInput <- newSTRef newInternalState

newOutput <- newSTRef newInternalState

newNode <- newSTRef node

let newCtx = ctx {

cInput = newInput,

cOutput = newOutput,

cNode = newNode,

cStack = newEntry : cStack ctx

}

x <- f newCtx

{-

return (x, newEntry)

wouldBeRecursive ctx node = f (cStack ctx)

where

f [] = return False

f (s:rest) = do

res <-

if entryPoint s == node

then return True

else f rest

modifySTRef (dependencies s) $ S.insert $ DepIsRecursive node res

return res

transfer ctx label =

--traceShow ("Transferring", label) $

case label of

CFStructuralNode -> return ()

CFEntryPoint _ -> return ()

CFImpliedExit -> return ()

CFResolvedExit {} -> return ()

CFExecuteCommand cmd -> transferCommand ctx cmd

CFExecuteSubshell reason entry exit -> transferSubshell ctx reason entry exit

CFApplyEffects effects -> mapM_ (\(IdTagged _ f) -> transferEffect ctx f) effects

CFSetExitCode id -> transferExitCode ctx id

CFUnresolvedExit -> patchOutputM ctx unreachableState

CFUnreachable -> patchOutputM ctx unreachableState

-- TODO

CFSetBackgroundPid _ -> return ()

CFDropPrefixAssignments {} ->

modifySTRef (cOutput ctx) $ \c -> modified c { sPrefixValues = vmEmpty }

transferSubshell ctx reason entry exit = do

let cout = cOutput ctx

initial <- readSTRef cout

runCached ctx entry (f entry exit)

res <- readSTRef cout

-- Clear subshell changes. TODO: track this to warn about modifications.

writeSTRef cout $ initial {

sExitCodes = sExitCodes res

}

where

f entry exit ctx = do

(states, frame) <- withNewStackFrame ctx entry False (flip dataflow $ entry)

let (_, res) = fromMaybe (error $ pleaseReport "Subshell has no exit") $ M.lookup exit states

deps <- readSTRef $ dependencies frame

registerFlowResult ctx entry states deps

return (deps, res)

transferCommand ctx Nothing = return ()

transferCommand ctx (Just name) = do

targets <- readFunction ctx name

logVerbose ("Transferring ",name,targets)

transferMultiple ctx $ map (flip transferFunctionValue) $ S.toList targets

transferMultiple ctx funcs = do

logVerbose ("Transferring set of ", length funcs)

original <- readSTRef out

branches <- mapM (apply ctx original) funcs

merged <- mergeStates ctx original branches

let patched = patchState original merged

writeSTRef out patched