open System

open System.IO

open System.Collections.Generic

open System.Threading

open System.Threading.Tasks

open Microsoft.FSharp.Compiler

open Microsoft.FSharp.Compiler.NameResolution

open Microsoft.FSharp.Compiler.Tastops

open Microsoft.FSharp.Compiler.Lib

open Microsoft.FSharp.Compiler.AbstractIL

open Microsoft.FSharp.Compiler.AbstractIL.IL

open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics

open Microsoft.FSharp.Compiler.AbstractIL.Internal

open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library

open Microsoft.FSharp.Compiler.CompileOps

open Microsoft.FSharp.Compiler.CompileOptions

open Microsoft.FSharp.Compiler.Ast

open Microsoft.FSharp.Compiler.ErrorLogger

open Microsoft.FSharp.Compiler.TcGlobals

open Microsoft.FSharp.Compiler.TypeChecker

open Microsoft.FSharp.Compiler.Tast

open Microsoft.FSharp.Compiler.Range

open Internal.Utilities

open Internal.Utilities.Collections

/// A particular node in the Expr language. Use an int for keys instead of the entire Expr to avoid extra hashing.

type Id = Id of int

[<NoEquality; NoComparison>]

/// A build rule representing a single output

type ScalarBuildRule =

/// ScalarInput (uniqueRuleId, outputName)

///

/// A build rule representing a single input, producing the input as its single scalar result

| ScalarInput of Id * string

/// ScalarDemultiplex (uniqueRuleId, outputName, input, taskFunction)

///

/// A build rule representing the merge of a set of inputs to a single output

| ScalarDemultiplex of Id * string * VectorBuildRule * (CompilationThreadToken -> obj[] -> Cancellable<obj>)

/// ScalarMap (uniqueRuleId, outputName, input, taskFunction)

///

/// A build rule representing the transformation of a single input to a single output

/// THIS CASE IS CURRENTLY UNUSED

| ScalarMap of Id * string * ScalarBuildRule * (CompilationThreadToken -> obj -> obj)

/// Get the Id for the given ScalarBuildRule.

member x.Id =

match x with

| ScalarInput(id,_) ->id

| ScalarDemultiplex(id,_,_,_) ->id

| ScalarMap(id,_,_,_) ->id

/// Get the Name for the givenScalarExpr.

member x.Name =

match x with

| ScalarInput(_,n) ->n

| ScalarDemultiplex(_,n,_,_) ->n

| ScalarMap(_,n,_,_) ->n

/// A build rule with a vector of outputs

and VectorBuildRule =

/// VectorInput (uniqueRuleId, outputName)

///

/// A build rule representing the transformation of a single input to a single output

| VectorInput of Id * string

/// VectorInput (uniqueRuleId, outputName, initialAccumulator, inputs, taskFunction)

///

/// A build rule representing the scan-left combining a single scalar accumulator input with a vector of inputs

| VectorScanLeft of Id * string * ScalarBuildRule * VectorBuildRule * (CompilationThreadToken -> obj -> obj->Eventually<obj>)

/// VectorMap (uniqueRuleId, outputName, inputs, taskFunction)

///

/// A build rule representing the parallel map of the inputs to outputs

| VectorMap of Id * string * VectorBuildRule * (CompilationThreadToken -> obj -> obj)

/// VectorStamp (uniqueRuleId, outputName, inputs, stampFunction)

///

/// A build rule representing pairing the inputs with a timestamp specified by the given function.

| VectorStamp of Id * string * VectorBuildRule * (TimeStampCache -> CompilationThreadToken -> obj -> DateTime)

/// VectorMultiplex (uniqueRuleId, outputName, input, taskFunction)

///

/// A build rule representing taking a single input and transforming it to a vector of outputs

| VectorMultiplex of Id * string * ScalarBuildRule * (CompilationThreadToken -> obj -> obj[])

/// Get the Id for the given VectorBuildRule.

member x.Id =

match x with

| VectorInput(id,_) -> id

| VectorScanLeft(id,_,_,_,_) -> id

| VectorMap(id,_,_,_) -> id

| VectorStamp (id,_,_,_) -> id

| VectorMultiplex(id,_,_,_) -> id

/// Get the Name for the given VectorBuildRule.

member x.Name =

match x with

| VectorInput(_,n) -> n

| VectorScanLeft(_,n,_,_,_) -> n

| VectorMap(_,n,_,_) -> n

| VectorStamp (_,n,_,_) -> n

| VectorMultiplex(_,n,_,_) -> n

[<NoEquality; NoComparison>]

type BuildRuleExpr =

| ScalarBuildRule of ScalarBuildRule

| VectorBuildRule of VectorBuildRule

/// Get the Id for the given Expr.

member x.Id =

match x with

| ScalarBuildRule se -> se.Id

| VectorBuildRule ve -> ve.Id

/// Get the Name for the given Expr.

member x.Name =

match x with

| ScalarBuildRule se -> se.Name

| VectorBuildRule ve -> ve.Name

// Ids of exprs

let nextid = ref 999 // Number ids starting with 1000 to discern them

let NextId() =

nextid:=!nextid+1

Id(!nextid)

type INode =

abstract Name: string

type IScalar =

inherit INode

abstract Expr: ScalarBuildRule

type IVector =

inherit INode

abstract Expr: VectorBuildRule

type Scalar<'T> = interface inherit IScalar end

type Vector<'T> = interface inherit IVector end

/// The outputs of a build

[<NoEquality; NoComparison>]

type NamedOutput =

| NamedVectorOutput of IVector

| NamedScalarOutput of IScalar

type BuildRules = { RuleList: (string * BuildRuleExpr) list }

/// Visit each task and call op with the given accumulator.

let FoldOverBuildRules(rules:BuildRules, op, acc)=

let rec visitVector (ve:VectorBuildRule) acc =

match ve with

| VectorInput _ -> op (VectorBuildRule ve) acc

| VectorScanLeft(_,_,a,i,_) -> op (VectorBuildRule ve) (visitVector i (visitScalar a acc))

| VectorMap(_,_,i,_)

| VectorStamp (_,_,i,_) -> op (VectorBuildRule ve) (visitVector i acc)

| VectorMultiplex(_,_,i,_) -> op (VectorBuildRule ve) (visitScalar i acc)

and visitScalar (se:ScalarBuildRule) acc =

match se with

| ScalarInput _ -> op (ScalarBuildRule se) acc

| ScalarDemultiplex(_,_,i,_) -> op (ScalarBuildRule se) (visitVector i acc)

| ScalarMap(_,_,i,_) -> op (ScalarBuildRule se) (visitScalar i acc)

let visitRule (expr:BuildRuleExpr) acc =

match expr with

| ScalarBuildRule se ->visitScalar se acc

| VectorBuildRule ve ->visitVector ve acc

List.foldBack visitRule (rules.RuleList |> List.map snd) acc

/// Convert from interfaces into discriminated union.

let ToBuild (names:NamedOutput list): BuildRules =

// Create the rules.

let createRules() =

{ RuleList = names |> List.map (function NamedVectorOutput(v) -> v.Name,VectorBuildRule(v.Expr)

| NamedScalarOutput(s) -> s.Name,ScalarBuildRule(s.Expr)) }

// Ensure that all names are unique.

let ensureUniqueNames (expr:BuildRuleExpr) (acc:Map<string,Id>) =

let AddUniqueIdToNameMapping(id,name)=

match acc.TryFind name with

| Some priorId ->

if id<>priorId then failwith (sprintf "Two build expressions had the same name: %s" name)

else acc

| None-> Map.add name id acc

let id = expr.Id

let name = expr.Name

AddUniqueIdToNameMapping(id,name)

// Validate the rule tree

let validateRules (rules:BuildRules) =

FoldOverBuildRules(rules,ensureUniqueNames,Map.empty) |> ignore

// Convert and validate

let rules = createRules()

validateRules rules

rules

/// These describe the input conditions for a result. If conditions change then the result is invalid.

type InputSignature =

| SingleMappedVectorInput of InputSignature[]

| EmptyTimeStampedInput of DateTime

| BoundInputScalar // An external input into the build

| BoundInputVector // An external input into the build

| IndexedValueElement of DateTime

| UnevaluatedInput

/// Return true if the result is fully evaluated

member is.IsEvaluated =

match is with

| UnevaluatedInput -> false

| SingleMappedVectorInput iss -> iss |> Array.forall (fun is -> is.IsEvaluated)

| _ -> true

/// A slot for holding a single result.

type Result =

| NotAvailable

| InProgress of (CompilationThreadToken -> Eventually<obj>) * DateTime

| Available of obj * DateTime * InputSignature

/// Get the available result. Throw an exception if not available.

member x.GetAvailable() = match x with Available(o,_,_) ->o | _ -> failwith "No available result"

/// Get the time stamp if available. Otherwise MaxValue.

member x.Timestamp = match x with Available(_,ts,_) -> ts | InProgress(_,ts) -> ts | _ -> DateTime.MaxValue

/// Get the time stamp if available. Otheriwse MaxValue.

member x.InputSignature = match x with Available(_,_,signature) -> signature | _ -> UnevaluatedInput

member x.ResultIsInProgress = match x with | InProgress _ -> true | _ -> false

member x.GetInProgressContinuation ctok = match x with | InProgress (f,_) -> f ctok | _ -> failwith "not in progress"

member x.TryGetAvailable() = match x with | InProgress _ | NotAvailable -> None | Available(obj,dt,i) -> Some (obj,dt,i)

/// An immutable sparse vector of results.

type ResultVector(size,zeroElementTimestamp,map) =

let get slot =

match Map.tryFind slot map with

| Some result ->result

| None->NotAvailable

let asList = lazy List.map (fun i->i,get i) [0..size-1]

static member OfSize(size) = ResultVector(size,DateTime.MinValue,Map.empty)

member rv.Size = size

member rv.Get slot = get slot

member rv.Resize(newsize) =

if size<>newsize then

ResultVector(newsize, zeroElementTimestamp, map |> Map.filter(fun s _ -> s < newsize))

else rv

member rv.Set(slot,value) =

#if DEBUG

if slot<0 then failwith "ResultVector slot less than zero"

if slot>=size then failwith "ResultVector slot too big"

ResultVector(size, zeroElementTimestamp, Map.add slot value map)

member rv.MaxTimestamp() =

let maximize (lasttimestamp:DateTime) (_,result:Result) = max lasttimestamp result.Timestamp

List.fold maximize zeroElementTimestamp (asList.Force())

member rv.Signature() =

let l = asList.Force()

let l = l |> List.map (fun (_,result) -> result.InputSignature)

SingleMappedVectorInput (l|>List.toArray)

member rv.FoldLeft f s: 'a = List.fold f s (asList.Force())

/// A result of performing build actions

[<NoEquality; NoComparison>]

type ResultSet =

| ScalarResult of Result

| VectorResult of ResultVector

/// Result of a particular action over the bound build tree

[<NoEquality; NoComparison>]

type ActionResult =

| IndexedResult of Id * int * (*slotcount*) int * Eventually<obj> * DateTime

| ScalarValuedResult of Id * obj * DateTime * InputSignature

| VectorValuedResult of Id * obj[] * DateTime * InputSignature

| ResizeResult of Id * (*slotcount*) int

/// A pending action over the bound build tree

[<NoEquality; NoComparison>]

type Action =

| IndexedAction of Id * (*taskname*)string * int * (*slotcount*) int * DateTime * (CompilationThreadToken -> Eventually<obj>)

| ScalarAction of Id * (*taskname*)string * DateTime * InputSignature * (CompilationThreadToken -> Cancellable<obj>)

| VectorAction of Id * (*taskname*)string * DateTime * InputSignature * (CompilationThreadToken -> Cancellable<obj[]>)

| ResizeResultAction of Id * (*slotcount*) int

/// Execute one action and return a corresponding result.

member action.Execute(ctok) =

cancellable {

match action with

| IndexedAction(id,_taskname,slot,slotcount,timestamp,func) -> let res = func ctok in return IndexedResult(id,slot,slotcount,res,timestamp)

| ScalarAction(id,_taskname,timestamp,inputsig,func) -> let! res = func ctok in return ScalarValuedResult(id,res,timestamp,inputsig)

| VectorAction(id,_taskname,timestamp,inputsig,func) -> let! res = func ctok in return VectorValuedResult(id,res,timestamp,inputsig)

| ResizeResultAction(id,slotcount) -> return ResizeResult(id,slotcount)

}

/// A set of build rules and the corresponding, possibly partial, results from building.

[<Sealed>]

type PartialBuild(rules:BuildRules, results:Map<Id,ResultSet>) =

member bt.Rules = rules

member bt.Results = results

/// Given an expression, find the expected width.

let rec GetVectorWidthByExpr(bt:PartialBuild,ve:VectorBuildRule) =

let id = ve.Id

let KnownValue() =

match bt.Results.TryFind id with

| Some resultSet ->

match resultSet with

| VectorResult rv ->Some rv.Size

| _ -> failwith "Expected vector to have vector result."

| None-> None

match ve with

| VectorScanLeft(_,_,_,i,_)

| VectorMap(_,_,i,_)

| VectorStamp (_,_,i,_) ->

match GetVectorWidthByExpr(bt,i) with

| Some _ as r -> r

| None -> KnownValue()

| VectorInput _

| VectorMultiplex _ -> KnownValue()

/// Given an expression name, get the corresponding expression.

let GetTopLevelExprByName(bt:PartialBuild, seek:string) =

bt.Rules.RuleList |> List.filter(fun(name,_) ->name=seek) |> List.map (fun(_,root) ->root) |> List.head

/// Get an expression matching the given name.

let GetExprByName(bt:PartialBuild, node:INode): BuildRuleExpr =

let matchName (expr:BuildRuleExpr) (acc:BuildRuleExpr option): BuildRuleExpr option =

if expr.Name = node.Name then Some expr else acc

let matchOption = FoldOverBuildRules(bt.Rules,matchName,None)

Option.get matchOption

// Given an Id, find the corresponding expression.

let GetExprById(bt:PartialBuild, seek:Id): BuildRuleExpr=

let rec vectorExprOfId ve =

match ve with

| VectorInput(id,_) ->if seek=id then Some (VectorBuildRule ve) else None

| VectorScanLeft(id,_,a,i,_) ->

if seek=id then Some (VectorBuildRule ve) else

let result = scalarExprOfId(a)

match result with Some _ -> result | None->vectorExprOfId i

| VectorMap(id,_,i,_) ->if seek=id then Some (VectorBuildRule ve) else vectorExprOfId i

| VectorStamp (id,_,i,_) ->if seek=id then Some (VectorBuildRule ve) else vectorExprOfId i

| VectorMultiplex(id,_,i,_) ->if seek=id then Some (VectorBuildRule ve) else scalarExprOfId i

and scalarExprOfId se =

match se with

| ScalarInput(id,_) ->if seek=id then Some (ScalarBuildRule se) else None

| ScalarDemultiplex(id,_,i,_) ->if seek=id then Some (ScalarBuildRule se) else vectorExprOfId i

| ScalarMap(id,_,i,_) ->if seek=id then Some (ScalarBuildRule se) else scalarExprOfId i

let exprOfId(expr:BuildRuleExpr) =

match expr with

| ScalarBuildRule se ->scalarExprOfId se

| VectorBuildRule ve ->vectorExprOfId ve

let exprs = bt.Rules.RuleList |> List.map (fun(_,root) ->exprOfId(root)) |> List.filter Option.isSome

match exprs with

| Some expr :: _ -> expr

| _ -> failwith (sprintf "GetExprById did not find an expression for Id")

let GetVectorWidthById (bt:PartialBuild) seek =

match GetExprById(bt,seek) with

| ScalarBuildRule _ ->failwith "Attempt to get width of scalar."

| VectorBuildRule ve -> Option.get (GetVectorWidthByExpr(bt,ve))

let GetScalarExprResult (bt:PartialBuild, se:ScalarBuildRule) =

match bt.Results.TryFind (se.Id) with

| Some resultSet ->

match se,resultSet with

| ScalarInput _,ScalarResult r

| ScalarMap _,ScalarResult r

| ScalarDemultiplex _,ScalarResult r ->r

| _ ->failwith "GetScalarExprResult had no match"

| None->NotAvailable

let GetVectorExprResultVector (bt:PartialBuild, ve:VectorBuildRule) =

match bt.Results.TryFind (ve.Id) with

| Some resultSet ->

match ve,resultSet with

| VectorScanLeft _,VectorResult rv

| VectorMap _,VectorResult rv

| VectorInput _,VectorResult rv

| VectorStamp _,VectorResult rv

| VectorMultiplex _,VectorResult rv -> Some rv

| _ -> failwith "GetVectorExprResultVector had no match"

| None->None

let GetVectorExprResult (bt:PartialBuild, ve:VectorBuildRule, slot) =

match bt.Results.TryFind ve.Id with

| Some resultSet ->

match ve,resultSet with

| VectorScanLeft _,VectorResult rv

| VectorMap _,VectorResult rv

| VectorInput _,VectorResult rv

| VectorStamp _,VectorResult rv -> rv.Get slot

| VectorMultiplex _,VectorResult rv -> rv.Get slot

| _ -> failwith "GetVectorExprResult had no match"

| None->NotAvailable

/// Get the maximum build stamp for an output.

let MaxTimestamp(bt:PartialBuild,id) =

match bt.Results.TryFind id with

| Some resultset ->

match resultset with

| ScalarResult(rs) -> rs.Timestamp

| VectorResult rv -> rv.MaxTimestamp()

| None -> DateTime.MaxValue

let Signature(bt:PartialBuild,id) =

match bt.Results.TryFind id with

| Some resultset ->

match resultset with

| ScalarResult(rs) -> rs.InputSignature

| VectorResult rv -> rv.Signature()

| None -> UnevaluatedInput

/// Get all the results for the given expr.

let AllResultsOfExpr extractor (bt:PartialBuild) (expr: VectorBuildRule) =

let GetAvailable (rv:ResultVector) =

let Extract acc (_, result) = (extractor result)::acc

List.rev (rv.FoldLeft Extract [])

let GetVectorResultById id =

match bt.Results.TryFind id with

| Some found ->

match found with

| VectorResult rv ->GetAvailable rv

| _ -> failwith "wrong result type"

| None -> []

GetVectorResultById(expr.Id)

[<RequireQualifiedAccess>]

type BuildInput =

| Vector of INode * obj list

| Scalar of INode * obj

/// Declare a named scalar output.

static member ScalarInput (node:Scalar<'T>,value: 'T) = BuildInput.Scalar(node,box value)

static member VectorInput(node:Vector<'T>,values: 'T list) = BuildInput.Vector(node,List.map box values)

let AvailableAllResultsOfExpr bt expr =

let msg = "Expected all results to be available"

AllResultsOfExpr (function Available(o,_,_) -> o | _ -> failwith msg) bt expr

/// Bind a set of build rules to a set of input values.

let ToBound(buildRules:BuildRules, inputs: BuildInput list) =

let now = DateTime.Now

let rec applyScalarExpr(se,results) =

match se with

| ScalarInput(id,n) ->

let matches =

[ for input in inputs do

match input with

| BuildInput.Scalar (node, value) ->

if node.Name = n then

yield ScalarResult(Available(value,now,BoundInputScalar))

| _ -> () ]

List.foldBack (Map.add id) matches results

| ScalarMap(_,_,se,_) ->applyScalarExpr(se,results)

| ScalarDemultiplex(_,_,ve,_) ->ApplyVectorExpr(ve,results)

and ApplyVectorExpr(ve,results) =

match ve with

| VectorInput(id,n) ->

let matches =

[ for input in inputs do

match input with

| BuildInput.Scalar _ -> ()

| BuildInput.Vector (node, values) ->

if node.Name = n then

let results = values|>List.mapi(fun i value->i,Available(value,now,BoundInputVector))

yield VectorResult(ResultVector(values.Length,DateTime.MinValue,results|>Map.ofList)) ]

List.foldBack (Map.add id) matches results

| VectorScanLeft(_,_,a,i,_) ->ApplyVectorExpr(i,applyScalarExpr(a,results))

| VectorMap(_,_,i,_)

| VectorStamp (_,_,i,_) ->ApplyVectorExpr(i,results)

| VectorMultiplex(_,_,i,_) ->applyScalarExpr(i,results)

let applyExpr expr results =

match expr with

| ScalarBuildRule se ->applyScalarExpr(se,results)

| VectorBuildRule ve ->ApplyVectorExpr(ve,results)

// Place vector inputs into results map.

let results = List.foldBack applyExpr (buildRules.RuleList |> List.map snd) Map.empty

PartialBuild(buildRules,results)

type Target = Target of INode * int option

/// Visit each executable action necessary to evaluate the given output (with an optional slot in a

/// vector output). Call actionFunc with the given accumulator.

let ForeachAction cache ctok (Target(output, optSlot)) bt (actionFunc:Action -> 'T -> 'T) (acc:'T) =

let seen = Dictionary<Id,bool>()

let isSeen id =

if seen.ContainsKey id then true

else

seen.[id] <- true

false

let shouldEvaluate(bt,currentsig:InputSignature,id) =

if currentsig.IsEvaluated then

currentsig <> Signature(bt,id)

else false

/// Make sure the result vector saved matches the size of expr

let resizeVectorExpr(ve:VectorBuildRule,acc) =

match GetVectorWidthByExpr(bt,ve) with

| Some expectedWidth ->

match bt.Results.TryFind ve.Id with

| Some found ->

match found with

| VectorResult rv ->

if rv.Size <> expectedWidth then

actionFunc (ResizeResultAction(ve.Id ,expectedWidth)) acc

else acc

| _ -> acc

| None -> acc

| None -> acc

let rec visitVector optSlot (ve: VectorBuildRule) acc =

if isSeen ve.Id then acc

else

let acc = resizeVectorExpr(ve,acc)

match ve with

| VectorInput _ -> acc

| VectorScanLeft(id,taskname,accumulatorExpr,inputExpr,func) ->

let acc =

match GetVectorWidthByExpr(bt,ve) with

| Some cardinality ->

let limit = match optSlot with None -> cardinality | Some slot -> (slot+1)

let Scan slot =

let accumulatorResult =

if slot=0 then GetScalarExprResult (bt,accumulatorExpr)

else GetVectorExprResult (bt,ve,slot-1)

let inputResult = GetVectorExprResult (bt,inputExpr,slot)

match accumulatorResult,inputResult with

| Available(accumulator,accumulatortimesamp,_accumulatorInputSig),Available(input,inputtimestamp,_inputSig) ->

let inputtimestamp = max inputtimestamp accumulatortimesamp

let prevoutput = GetVectorExprResult (bt,ve,slot)

let outputtimestamp = prevoutput.Timestamp

let scanOpOpt =

if inputtimestamp <> outputtimestamp then

Some (fun ctok -> func ctok accumulator input)

elif prevoutput.ResultIsInProgress then

Some prevoutput.GetInProgressContinuation

else

// up-to-date and complete, no work required

None

match scanOpOpt with

| Some scanOp -> Some (actionFunc (IndexedAction(id,taskname,slot,cardinality,inputtimestamp,scanOp)) acc)

| None -> None

| _ -> None

match ([0..limit-1]|>List.tryPick Scan) with Some (acc) ->acc | None->acc

| None -> acc

// Check each slot for an action that may be performed.

visitVector None inputExpr (visitScalar accumulatorExpr acc)

| VectorMap(id, taskname, inputExpr, func) ->

let acc =

match GetVectorWidthByExpr(bt,ve) with

| Some cardinality ->

if cardinality=0 then

// For vector length zero, just propagate the prior timestamp.

let inputtimestamp = MaxTimestamp(bt,inputExpr.Id)

let outputtimestamp = MaxTimestamp(bt,id)

if inputtimestamp <> outputtimestamp then

actionFunc (VectorAction(id,taskname,inputtimestamp,EmptyTimeStampedInput inputtimestamp, fun _ -> cancellable.Return [||])) acc

else acc

else

let MapResults acc slot =

let inputtimestamp = GetVectorExprResult(bt,inputExpr,slot).Timestamp

let outputtimestamp = GetVectorExprResult(bt,ve,slot).Timestamp

if inputtimestamp <> outputtimestamp then

let OneToOneOp ctok =

Eventually.Done (func ctok (GetVectorExprResult(bt,inputExpr,slot).GetAvailable()))

actionFunc (IndexedAction(id,taskname,slot,cardinality,inputtimestamp,OneToOneOp)) acc

else acc

match optSlot with

| None ->

[0..cardinality-1] |> List.fold MapResults acc

| Some slot ->

MapResults acc slot

| None -> acc

visitVector optSlot inputExpr acc

| VectorStamp (id, taskname, inputExpr, func) ->

// For every result that is available, check time stamps.

let acc =

match GetVectorWidthByExpr(bt,ve) with

| Some cardinality ->

if cardinality=0 then

// For vector length zero, just propagate the prior timestamp.

let inputtimestamp = MaxTimestamp(bt,inputExpr.Id)

let outputtimestamp = MaxTimestamp(bt,id)

if inputtimestamp <> outputtimestamp then

actionFunc (VectorAction(id,taskname,inputtimestamp,EmptyTimeStampedInput inputtimestamp,fun _ -> cancellable.Return [||])) acc

else acc

else

let checkStamp acc slot =

let inputresult = GetVectorExprResult (bt,inputExpr,slot)

match inputresult with

| Available(ires,_,_) ->

let oldtimestamp = GetVectorExprResult(bt,ve,slot).Timestamp

let newtimestamp = func cache ctok ires

if newtimestamp <> oldtimestamp then

actionFunc (IndexedAction(id,taskname,slot,cardinality,newtimestamp, fun _ -> Eventually.Done ires)) acc

else acc

| _ -> acc

match optSlot with

| None ->

[0..cardinality-1] |> List.fold checkStamp acc

| Some slot ->

checkStamp acc slot

| None -> acc

visitVector optSlot inputExpr acc

| VectorMultiplex(id, taskname, inputExpr, func) ->

let acc =

match GetScalarExprResult (bt,inputExpr) with

| Available(inp,inputtimestamp,inputsig) ->

let outputtimestamp = MaxTimestamp(bt,id)

if inputtimestamp <> outputtimestamp then

let MultiplexOp ctok = func ctok inp |> cancellable.Return

actionFunc (VectorAction(id,taskname,inputtimestamp,inputsig,MultiplexOp)) acc

else acc

| _ -> acc

visitScalar inputExpr acc

and visitScalar (se:ScalarBuildRule) acc =

if isSeen se.Id then acc

else

match se with

| ScalarInput _ -> acc

| ScalarDemultiplex (id,taskname,inputExpr,func) ->

let acc =

match GetVectorExprResultVector (bt,inputExpr) with

| Some inputresult ->

let currentsig = inputresult.Signature()

if shouldEvaluate(bt,currentsig,id) then

let inputtimestamp = MaxTimestamp(bt, inputExpr.Id)

let DemultiplexOp ctok =

cancellable {

let input = AvailableAllResultsOfExpr bt inputExpr |> List.toArray

return! func ctok input

}

actionFunc (ScalarAction(id,taskname,inputtimestamp,currentsig,DemultiplexOp)) acc

else acc

| None -> acc

visitVector None inputExpr acc

| ScalarMap (id,taskname,inputExpr,func) ->

let acc =

match GetScalarExprResult (bt,inputExpr) with

| Available(inp,inputtimestamp,inputsig) ->

let outputtimestamp = MaxTimestamp(bt, id)

if inputtimestamp <> outputtimestamp then

let MapOp ctok = func ctok inp |> cancellable.Return

actionFunc (ScalarAction(id,taskname,inputtimestamp,inputsig,MapOp)) acc

else acc

| _ -> acc

visitScalar inputExpr acc

let expr = bt.Rules.RuleList |> List.find (fun (s,_) -> s = output.Name) |> snd

match expr with

| ScalarBuildRule se -> visitScalar se acc

| VectorBuildRule ve -> visitVector optSlot ve acc

let CollectActions cache target (bt: PartialBuild) =

// Explanation: This is a false reuse of 'ForeachAction' where the ctok is unused, we are

// just iterating to determine if there is work to do. This means this is safe to call from any thread.

let ctok = AssumeCompilationThreadWithoutEvidence ()

ForeachAction cache ctok target bt (fun a l -> a :: l) []

/// Compute the max timestamp on all available inputs

let ComputeMaxTimeStamp cache ctok output (bt: PartialBuild) acc =

let expr = bt.Rules.RuleList |> List.find (fun (s,_) -> s = output) |> snd

match expr with

| VectorBuildRule (VectorStamp (_id, _taskname, inputExpr, func) as ve) ->

match GetVectorWidthByExpr(bt,ve) with

| Some cardinality ->

let CheckStamp acc slot =

match GetVectorExprResult (bt,inputExpr,slot) with

| Available(ires,_,_) -> max acc (func cache ctok ires)

| _ -> acc

[0..cardinality-1] |> List.fold CheckStamp acc

| None -> acc

| _ -> failwith "expected a VectorStamp"

/// Given the result of a single action, apply that action to the Build

let ApplyResult(actionResult:ActionResult,bt:PartialBuild) =

match actionResult with

| ResizeResult(id,slotcount) ->

match bt.Results.TryFind id with

| Some resultSet ->

match resultSet with

| VectorResult rv ->

let rv = rv.Resize(slotcount)

let results = Map.add id (VectorResult rv) bt.Results

PartialBuild(bt.Rules,results)

| _ -> failwith "Unexpected"

| None -> failwith "Unexpected"

| ScalarValuedResult(id,value,timestamp,inputsig) ->

PartialBuild(bt.Rules, Map.add id (ScalarResult(Available(value,timestamp,inputsig))) bt.Results)

| VectorValuedResult(id,values,timestamp,inputsig) ->

let Append acc slot =

Map.add slot (Available(values.[slot],timestamp,inputsig)) acc

let results = [0..values.Length-1]|>List.fold Append Map.empty

let results = VectorResult(ResultVector(values.Length,timestamp,results))

let bt = PartialBuild(bt.Rules, Map.add id results bt.Results)

bt

| IndexedResult(id,index,slotcount,value,timestamp) ->

let width = GetVectorWidthById bt id

let priorResults = bt.Results.TryFind id

let prior =

match priorResults with

| Some prior ->prior

| None->VectorResult(ResultVector.OfSize width)

match prior with

| VectorResult rv ->

let result =

match value with

| Eventually.Done res ->

Available(res,timestamp, IndexedValueElement timestamp)

| Eventually.NotYetDone f ->

InProgress (f,timestamp)

let results = rv.Resize(slotcount).Set(index,result)

PartialBuild(bt.Rules, Map.add id (VectorResult(results)) bt.Results)

| _ -> failwith "Unexpected"

let mutable injectCancellationFault = false

let LocallyInjectCancellationFault() =

injectCancellationFault <- true

{ new IDisposable with member __.Dispose() = injectCancellationFault <- false }

/// Apply the result, and call the 'save' function to update the build.

let ExecuteApply (ctok: CompilationThreadToken) save (action:Action) bt =

cancellable {

let! actionResult = action.Execute(ctok)

let newBt = ApplyResult(actionResult,bt)

save ctok newBt

return newBt

}

/// Evaluate the result of a single output

let EvalLeafsFirst cache ctok save target bt =

let rec eval(bt,gen) =

cancellable {

#if DEBUG

// This can happen, for example, if there is a task whose timestamp never stops increasing.

// Possibly could detect this case directly.

if gen>5000 then failwith "Infinite loop in incremental builder?"

#endif

let worklist = CollectActions cache target bt

let! newBt =

(bt,worklist) ||> Cancellable.fold (fun bt action ->

if injectCancellationFault then

Cancellable.canceled()

else

ExecuteApply ctok save action bt)

if newBt=bt then return bt else return! eval(newBt,gen+1)

}

eval(bt,0)

/// Evaluate one step of the build. Call the 'save' function to save the intermediate result.

let Step cache ctok save target (bt:PartialBuild) =

cancellable {

// REVIEW: we're building up the whole list of actions on the fringe of the work tree,

// executing one thing and then throwing the list away. What about saving the list inside the Build instance?

let worklist = CollectActions cache target bt

match worklist with

| action::_ ->

let! res = ExecuteApply ctok save action bt

return Some res

| _ ->

return None

}

/// Evaluate an output of the build.

///

/// Intermediate progrewss along the way may be saved through the use of the 'save' function.

let Eval cache ctok save node bt = EvalLeafsFirst cache ctok save (Target(node,None)) bt

/// Evaluate an output of the build.

///

/// Intermediate progrewss along the way may be saved through the use of the 'save' function.

let EvalUpTo cache ctok save (node, n) bt = EvalLeafsFirst cache ctok save (Target(node, Some n)) bt

/// Check if an output is up-to-date and ready

let IsReady cache target bt =

let worklist = CollectActions cache target bt

worklist.IsEmpty

/// Check if an output is up-to-date and ready

let MaxTimeStampInDependencies cache ctok target bt =

ComputeMaxTimeStamp cache ctok target bt DateTime.MinValue

/// Get a scalar vector. Result must be available

let GetScalarResult<'T>(node:Scalar<'T>,bt): ('T*DateTime) option =

match GetTopLevelExprByName(bt,node.Name) with

| ScalarBuildRule se ->

match bt.Results.TryFind se.Id with

| Some result ->

match result with

| ScalarResult(sr) ->

match sr.TryGetAvailable() with

| Some (r,timestamp,_) -> Some (downcast r, timestamp)

| None -> None

| _ ->failwith "Expected a scalar result."

| None->None

| VectorBuildRule _ -> failwith "Expected scalar."

/// Get a result vector. All results must be available or thrown an exception.

let GetVectorResult<'T>(node:Vector<'T>,bt): 'T[] =

match GetTopLevelExprByName(bt,node.Name) with

| ScalarBuildRule _ -> failwith "Expected vector."

| VectorBuildRule ve -> AvailableAllResultsOfExpr bt ve |> List.map unbox |> Array.ofList

/// Get an element of vector result or None if there were no results.

let GetVectorResultBySlot<'T>(node:Vector<'T>,slot,bt): ('T*DateTime) option =

match GetTopLevelExprByName(bt,node.Name) with

| ScalarBuildRule _ -> failwith "Expected vector expression"

| VectorBuildRule ve ->

match GetVectorExprResult(bt,ve,slot).TryGetAvailable() with

| Some (o,timestamp,_) -> Some (downcast o,timestamp)

| None->None

/// Given an input value, find the corresponding slot.

let TryGetSlotByInput<'T>(node:Vector<'T>,input:'T,build:PartialBuild,equals:'T->'T->bool): int option =

let expr = GetExprByName(build,node)

let id = expr.Id

match build.Results.TryFind id with

| None -> None

| Some resultSet ->

match resultSet with

| VectorResult rv ->

let MatchNames acc (slot,result) =

match result with

| Available(o,_,_) ->

let o = o :?> 'T

if equals o input then Some slot else acc

| _ -> acc

let slotOption = rv.FoldLeft MatchNames None

slotOption

// failwith (sprintf "Could not find requested input '%A' named '%s' in set %+A" input name rv)

| _ -> None // failwith (sprintf "Could not find requested input: %A" input)

// Redeclare functions in the incremental build scope-----------------------------------------------------------------------

// Methods for declaring inputs and outputs

/// Declares a vector build input.

let InputVector<'T> name =

let expr = VectorInput(NextId(),name)

{ new Vector<'T>

interface IVector with

override __.Name = name

override pe.Expr = expr }

/// Declares a scalar build input.

let InputScalar<'T> name =

let expr = ScalarInput(NextId(),name)

{ new Scalar<'T>

interface IScalar with

override __.Name = name

override pe.Expr = expr }

module Vector =

/// Maps one vector to another using the given function.

let Map (taskname:string) (task: CompilationThreadToken -> 'I -> 'O) (input:Vector<'I>): Vector<'O> =

let input = input.Expr

let expr = VectorMap(NextId(),taskname,input,(fun ctok x -> box (task ctok (unbox x))))

{ new Vector<'O>

interface IVector with

override __.Name = taskname

override pe.Expr = expr }

/// Apply a function to each element of the vector, threading an accumulator argument

/// through the computation. Returns intermediate results in a vector.

let ScanLeft (taskname:string) (task: CompilationThreadToken -> 'A -> 'I -> Eventually<'A>) (acc:Scalar<'A>) (input:Vector<'I>): Vector<'A> =

let BoxingScanLeft ctok a i = Eventually.box(task ctok (unbox a) (unbox i))

let acc = acc.Expr

let input = input.Expr

let expr = VectorScanLeft(NextId(),taskname,acc,input,BoxingScanLeft)

{ new Vector<'A>

interface IVector with

override __.Name = taskname

override pe.Expr = expr }

/// Apply a function to a vector to get a scalar value.

let Demultiplex (taskname:string) (task: CompilationThreadToken -> 'I[] -> Cancellable<'O>) (input:Vector<'I>): Scalar<'O> =

let BoxingDemultiplex ctok inps =

cancellable {

let! res = task ctok (Array.map unbox inps)

return box res

}

let input = input.Expr

let expr = ScalarDemultiplex(NextId(),taskname,input,BoxingDemultiplex)

{ new Scalar<'O>

interface IScalar with

override __.Name = taskname

override pe.Expr = expr }

/// Creates a new vector with the same items but with

/// timestamp specified by the passed-in function.

let Stamp (taskname:string) (task: TimeStampCache -> CompilationThreadToken -> 'I -> DateTime) (input:Vector<'I>): Vector<'I> =

let input = input.Expr

let expr = VectorStamp (NextId(),taskname,input,(fun cache ctok x -> task cache ctok (unbox x)))

{ new Vector<'I>

interface IVector with

override __.Name = taskname

override pe.Expr = expr }

let AsScalar (taskname:string) (input:Vector<'I>): Scalar<'I array> =

Demultiplex taskname (fun _ctok x -> cancellable.Return x) input

/// Declare build outputs and bind them to real values.

type BuildDescriptionScope() =

let mutable outputs = []

/// Declare a named scalar output.

member b.DeclareScalarOutput(output:Scalar<'T>)=

outputs <- NamedScalarOutput(output) :: outputs

/// Declare a named vector output.

member b.DeclareVectorOutput(output:Vector<'T>)=

outputs <- NamedVectorOutput(output) :: outputs

/// Set the concrete inputs for this build