lib.fs

// Copyright (c) Microsoft Corporation.  All Rights Reserved.  See License.txt in the project root for license information.

module internal Microsoft.FSharp.Compiler.Lib

open System.IO
open System.Collections.Generic
open Internal.Utilities
open Microsoft.FSharp.Compiler.AbstractIL
open Microsoft.FSharp.Compiler.AbstractIL.Internal 
open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library


/// is this the developer-debug build? 
let debug = false 
let verbose = false
let progress = ref false 
let tracking = ref false // intended to be a general hook to control diagnostic output when tracking down bugs

let condition _s = 
    try (System.Environment.GetEnvironmentVariable(_s) <> null) with _ -> false

let GetEnvInteger e dflt = match System.Environment.GetEnvironmentVariable(e) with null -> dflt | t -> try int t with _ -> dflt

let dispose (x:System.IDisposable) = match x with null -> () | x -> x.Dispose()

type SaveAndRestoreConsoleEncoding () =
    let savedOut = System.Console.Out

    interface System.IDisposable with
        member this.Dispose() = 
            try 
                System.Console.SetOut(savedOut)
            with _ -> ()

//-------------------------------------------------------------------------
// Library: bits
//------------------------------------------------------------------------

module Bits = 
    let b0 n =  (n          &&& 0xFF)  
    let b1 n =  ((n >>> 8)  &&& 0xFF) 
    let b2 n =  ((n >>> 16) &&& 0xFF) 
    let b3 n =  ((n >>> 24) &&& 0xFF) 

    let rec pown32 n = if n = 0 then 0  else (pown32 (n-1) ||| (1  <<<  (n-1)))
    let rec pown64 n = if n = 0 then 0L else (pown64 (n-1) ||| (1L <<< (n-1)))
    let mask32 m n = (pown32 n) <<< m
    let mask64 m n = (pown64 n) <<< m


//-------------------------------------------------------------------------
// Library: files
//------------------------------------------------------------------------

module Filename = 
    let fullpath cwd nm = 
        let p = if FileSystem.IsPathRootedShim(nm) then nm else Path.Combine(cwd,nm)
        try FileSystem.GetFullPathShim(p) with 
        | :? System.ArgumentException 
        | :? System.ArgumentNullException 
        | :? System.NotSupportedException 
        | :? System.IO.PathTooLongException 
        | :? System.Security.SecurityException -> p

    let hasSuffixCaseInsensitive suffix filename = (* case-insensitive *)
      Filename.checkSuffix (String.lowercase filename) (String.lowercase suffix)

    let isDll file = hasSuffixCaseInsensitive ".dll" file 

//-------------------------------------------------------------------------
// Library: Orders
//------------------------------------------------------------------------

module Bool = 
    let order = LanguagePrimitives.FastGenericComparer<bool>

module Int32 = 
    let order = LanguagePrimitives.FastGenericComparer<int>

module Int64 = 
    let order = LanguagePrimitives.FastGenericComparer<int64>

module Pair = 
    let order (compare1: IComparer<'T1>, compare2: IComparer<'T2>) =
        { new IComparer<'T1 * 'T2> with 
             member __.Compare((a1,a2),(aa1,aa2)) =
                  let res1 = compare1.Compare (a1, aa1)
                  if res1 <> 0 then res1 else compare2.Compare (a2, aa2) }


type NameSet =  Zset<string>
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module NameSet =
    let ofList l : NameSet = List.foldBack Zset.add l (Zset.empty String.order)

[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module NameMap = 
    let domain m = Map.foldBack (fun x _ acc -> Zset.add x acc) m (Zset.empty String.order)
    let domainL m = Zset.elements (domain m)



//---------------------------------------------------------------------------
// Library: Pre\Post checks
//------------------------------------------------------------------------- 
module Check = 
    
    /// Throw <c>System.InvalidOperationException()</c> if argument is <c>None</c>.
    /// If there is a value (e.g. <c>Some(value)</c>) then value is returned.
    let NotNone argname (arg:'T option) : 'T = 
        match arg with 
        | None -> raise (new System.InvalidOperationException(argname))
        | Some x -> x

    /// Throw <c>System.ArgumentNullException()</c> if argument is <c>null</c>.
    let ArgumentNotNull arg argname = 
        match box(arg) with 
        | null -> raise (new System.ArgumentNullException(argname))
        | _ -> ()
       
        
    /// Throw <c>System.ArgumentNullException()</c> if array argument is <c>null</c>.
    /// Throw <c>System.ArgumentOutOfRangeException()</c> is array argument is empty.
    let ArrayArgumentNotNullOrEmpty (arr:'T[]) argname = 
        ArgumentNotNull arr argname
        if (0 = arr.Length) then
            raise (new System.ArgumentOutOfRangeException(argname))

    /// Throw <c>System.ArgumentNullException()</c> if string argument is <c>null</c>.
    /// Throw <c>System.ArgumentOutOfRangeException()</c> is string argument is empty.
    let StringArgumentNotNullOrEmpty (s:string) argname = 
        ArgumentNotNull s argname
        if s.Length = 0 then
            raise (new System.ArgumentNullException(argname))

//-------------------------------------------------------------------------
// Library 
//------------------------------------------------------------------------

type IntMap<'T> = Zmap<int,'T>
module IntMap = 
    let empty () = Zmap.empty Int32.order

    let add k v (t:IntMap<'T>) = Zmap.add k v t
    let find k (t:IntMap<'T>) = Zmap.find k t
    let tryFind k (t:IntMap<'T>) = Zmap.tryFind k t
    let remove  k (t:IntMap<'T>) = Zmap.remove k t
    let mem     k (t:IntMap<'T>)  = Zmap.mem k t
    let iter    f (t:IntMap<'T>)  = Zmap.iter f t
    let map     f (t:IntMap<'T>)  = Zmap.map f t 
    let fold    f (t:IntMap<'T>)  z = Zmap.fold f t z


//-------------------------------------------------------------------------
// Library: generalized association lists
//------------------------------------------------------------------------

module ListAssoc = 

    /// Treat a list of key-value pairs as a lookup collection.
    /// This function looks up a value based on a match from the supplied
    /// predicate function.
    let rec find f x l = 
      match l with 
      | [] -> notFound()
      | (x',y)::t -> if f x x' then y else find f x t

    /// Treat a list of key-value pairs as a lookup collection.
    /// This function returns true if two keys are the same according to the predicate
    /// function passed in.
    let rec containsKey (f:'key->'key->bool) (x:'key) (l:('key*'value) list) : bool = 
      match l with 
      | [] -> false
      | (x',_y)::t -> f x x' || containsKey f x t

//-------------------------------------------------------------------------
// Library: lists as generalized sets
//------------------------------------------------------------------------

module ListSet = 
    let inline contains f x l = List.exists (f x) l

    (* NOTE: O(n)! *)
    let insert f x l = if contains f x l then l else x::l

    let unionFavourRight f l1 l2 = 
        match l1, l2 with 
        | _, [] -> l1
        | [], _ -> l2 
        | _ -> List.foldBack (insert f) l1 l2 (* nb. foldBack to preserve natural orders *)

    (* NOTE: O(n)! *)
    let rec private findIndexAux eq x l n =
        match l with
        | [] -> notFound()
        | (h::t) -> if eq h x then n else findIndexAux eq x t (n+1)

    let findIndex eq x l = findIndexAux eq x l 0

    let rec remove f x l = 
        match l with 
        | (h::t) -> if f x h then t else h:: remove f x t
        | [] -> []

    (* NOTE: quadratic! *)
    let rec subtract f l1 l2 = 
      match l2 with 
      | (h::t) -> subtract f (remove (fun y2 y1 ->  f y1 y2) h l1) t
      | [] -> l1

    let isSubsetOf f l1 l2 = List.forall (fun x1 -> contains f x1 l2) l1
    (* nb. preserve orders here: f must be applied to elements of l1 then elements of l2*)
    let isSupersetOf f l1 l2 = List.forall (fun x2 -> contains (fun y2 y1 ->  f y1 y2) x2 l1) l2
    let equals f l1 l2 = isSubsetOf f l1 l2 && isSupersetOf f l1 l2

    let unionFavourLeft f l1 l2 = 
        match l1,l2 with 
        | _,[] -> l1 
        | [],_ -> l2 
        | _ -> l1 @ (subtract f l2 l1)


    (* NOTE: not tail recursive! *)
    let rec intersect f l1 l2 = 
        match l2 with 
        | (h::t) -> if contains f h l1 then h::intersect f l1 t else intersect f l1 t
        | [] -> []

    (* NOTE: quadratic! *)
    // Note: if duplicates appear, keep the ones toward the _front_ of the list
    let setify f l = List.foldBack (insert f) (List.rev l) [] |> List.rev

//-------------------------------------------------------------------------
// Library: pairs
//------------------------------------------------------------------------

let mapFoldFst f s (x,y) =  let x',s = f s x in  (x',y),s
let mapFoldSnd f s (x,y) =  let y',s = f s y in  (x,y'),s
let pair a b = a,b      

let p13 (x,_y,_z) = x
let p23 (_x,y,_z) = y
let p33 (_x,_y,z) = z

let map1Of2 f (a1,a2)       = (f a1,a2)
let map2Of2 f (a1,a2)       = (a1,f a2)
let map1Of3 f (a1,a2,a3)     = (f a1,a2,a3)
let map2Of3 f (a1,a2,a3)     = (a1,f a2,a3)
let map3Of3 f (a1,a2,a3)     = (a1,a2,f a3)
let map3Of4 f (a1,a2,a3,a4)     = (a1,a2,f a3,a4)
let map4Of4 f (a1,a2,a3,a4)   = (a1,a2,a3,f a4)
let map5Of5 f (a1,a2,a3,a4,a5) = (a1,a2,a3,a4,f a5)
let map6Of6 f (a1,a2,a3,a4,a5,a6) = (a1,a2,a3,a4,a5,f a6)
let foldPair (f1,f2)    acc (a1,a2)         = f2 (f1 acc a1) a2
let fold1Of2 f1    acc (a1,_a2)         = f1 acc a1
let foldTriple (f1,f2,f3) acc (a1,a2,a3)      = f3 (f2 (f1 acc a1) a2) a3
let foldQuadruple (f1,f2,f3,f4) acc (a1,a2,a3,a4)      = f4 (f3 (f2 (f1 acc a1) a2) a3) a4
let mapPair (f1,f2)    (a1,a2)     = (f1 a1, f2 a2)
let mapTriple (f1,f2,f3) (a1,a2,a3)  = (f1 a1, f2 a2, f3 a3)
let mapQuadruple (f1,f2,f3,f4) (a1,a2,a3,a4)  = (f1 a1, f2 a2, f3 a3, f4 a4)
let fmap2Of2 f z (a1,a2)       = let z,a2 = f z a2 in z,(a1,a2)

module List = 
    let noRepeats xOrder xs =
        let s = Zset.addList   xs (Zset.empty xOrder) // build set 
        Zset.elements s          // get elements... no repeats

//---------------------------------------------------------------------------
// Zmap rebinds
//------------------------------------------------------------------------- 

module Zmap = 
    let force  k   mp           = match Zmap.tryFind k mp with Some x -> x | None -> failwith "Zmap.force: lookup failed"

    let mapKey key f mp =
      match f (Zmap.tryFind key mp) with
      | Some fx -> Zmap.add key fx mp       
      | None    -> Zmap.remove key mp

//---------------------------------------------------------------------------
// Zset
//------------------------------------------------------------------------- 

module Zset =
    let ofList order xs = Zset.addList   xs (Zset.empty order)

    // CLEANUP NOTE: move to Zset?
    let rec fixpoint f (s as s0) =
        let s = f s
        if Zset.equal s s0 then s0           (* fixed *)
                           else fixpoint f s (* iterate *)

//---------------------------------------------------------------------------
// Misc
//------------------------------------------------------------------------- 

let equalOn f x y = (f x) = (f y)


//---------------------------------------------------------------------------
// Buffer printing utilities
//---------------------------------------------------------------------------

let bufs f = 
    let buf = System.Text.StringBuilder 100 
    f buf 
    buf.ToString()

let buff (os: TextWriter) f x = 
    let buf = System.Text.StringBuilder 100 
    f buf x 
    os.Write(buf.ToString())

// Converts "\n" into System.Environment.NewLine before writing to os. See lib.fs:buff
let writeViaBufferWithEnvironmentNewLines (os: TextWriter) f x = 
    let buf = System.Text.StringBuilder 100 
    f buf x
    let text = buf.ToString()
    let text = text.Replace("\n",System.Environment.NewLine)
    os.Write text
        
//---------------------------------------------------------------------------
// Imperative Graphs 
//---------------------------------------------------------------------------

type GraphNode<'Data, 'Id> = { nodeId: 'Id; nodeData: 'Data; mutable nodeNeighbours: GraphNode<'Data, 'Id> list }

type Graph<'Data, 'Id when 'Id : comparison and 'Id : equality>
         (nodeIdentity: ('Data -> 'Id),
          nodes: 'Data list,
          edges: ('Data * 'Data) list) =

    let edges = edges |> List.map (fun (v1,v2) -> nodeIdentity v1, nodeIdentity v2)
    let nodes = nodes |> List.map (fun d -> nodeIdentity d, { nodeId = nodeIdentity d; nodeData=d; nodeNeighbours=[] }) 
    let tab = Map.ofList nodes 
    let nodes = List.map snd nodes
    do for node in nodes do 
        node.nodeNeighbours <- edges |>  List.filter (fun (x,_y) -> x = node.nodeId) |> List.map (fun (_,nodeId) -> tab.[nodeId])

    member g.GetNodeData nodeId = tab.[nodeId].nodeData

    member g.IterateCycles f = 
        let rec trace path node = 
            if List.exists (nodeIdentity >> (=) node.nodeId) path then f (List.rev path)
            else List.iter (trace (node.nodeData::path)) node.nodeNeighbours
        List.iter (fun node -> trace [] node) nodes 

//---------------------------------------------------------------------------
// In some cases we play games where we use 'null' as a more efficient representation
// in F#. The functions below are used to give initial values to mutable fields.
// This is an unsafe trick, as it relies on the fact that the type of values
// being placed into the slot never utilizes "null" as a representation. To be used with
// with care.
//----------------------------------------------------------------------------

// The following DEBUG code does not currently compile.
//#if DEBUG
//type 'T NonNullSlot = 'T option 
//let nullableSlotEmpty() = None 
//let nullableSlotFull(x) = Some x
//#else
type NonNullSlot<'T> = 'T
let nullableSlotEmpty() = Unchecked.defaultof<'T>
let nullableSlotFull x = x
//#endif    

//---------------------------------------------------------------------------
// Caches, mainly for free variables
//---------------------------------------------------------------------------

type cache<'T> = { mutable cacheVal: 'T NonNullSlot }
let newCache() = { cacheVal = nullableSlotEmpty() }

let inline cached cache resf = 
    match box cache.cacheVal with 
    | null -> 
        let res = resf() 
        cache.cacheVal <- nullableSlotFull res 
        res
    | _ -> 
        cache.cacheVal

let inline cacheOptRef cache f = 
    match !cache with 
    | Some v -> v
    | None -> 
       let res = f()
       cache := Some res
       res 


#if DUMPER
type Dumper(x:obj) =
     [<DebuggerBrowsable(DebuggerBrowsableState.Collapsed)>]
     member self.Dump = sprintf "%A" x 
#endif

//---------------------------------------------------------------------------
// AsyncUtil
//---------------------------------------------------------------------------

module internal AsyncUtil =
    open System
    open System.Threading
    open Microsoft.FSharp.Control

    /// Represents the reified result of an asynchronous computation.
    [<NoEquality; NoComparison>]
    type AsyncResult<'T>  =
        |   AsyncOk of 'T
        |   AsyncException of exn
        |   AsyncCanceled of OperationCanceledException

        static member Commit(res:AsyncResult<'T>) =
            Async.FromContinuations (fun (cont,econt,ccont) ->
                    match res with
                    | AsyncOk v -> cont v
                    | AsyncException exn -> econt exn
                    | AsyncCanceled exn -> ccont exn)

    /// When using .NET 4.0 you can replace this type by <see cref="Task{T}"/>
    [<Sealed>]
    type AsyncResultCell<'T>() =
        let mutable result = None
        // The continuation for the result, if any
        let mutable savedConts = []
       
        let syncRoot = new obj()
               

        // Record the result in the AsyncResultCell.
        // Ignore subsequent sets of the result. This can happen, e.g. for a race between
        // a cancellation and a success.
        member x.RegisterResult (res:AsyncResult<'T>) =
            let grabbedConts =
                lock syncRoot (fun () ->
                    if result.IsSome then  
                        []
                    else
                        result <- Some res
                        // Invoke continuations in FIFO order
                        // Continuations that Async.FromContinuations provide do QUWI/SynchContext.Post,
                        // so the order is not overly relevant but still.                        
                        List.rev savedConts)
            let postOrQueue (sc:SynchronizationContext,cont) =
                match sc with
                |   null -> ThreadPool.QueueUserWorkItem(fun _ -> cont res) |> ignore
                |   sc -> sc.Post((fun _ -> cont res), state=null)

            // Run continuations outside the lock
            match grabbedConts with
            |   [] -> ()
            |   [(sc,cont) as c] -> 
                    if SynchronizationContext.Current = sc then
                        cont res
                    else
                        postOrQueue c
            |   _ ->
                    grabbedConts |> List.iter postOrQueue

        /// Get the reified result.
        member private x.AsyncPrimitiveResult =
            Async.FromContinuations(fun (cont,_,_) ->
                let grabbedResult =
                    lock syncRoot (fun () ->
                        match result with
                        | Some _ ->
                            result
                        | None ->
                            // Otherwise save the continuation and call it in RegisterResult
                            let sc = SynchronizationContext.Current
                            savedConts <- (sc,cont)::savedConts
                            None)
                // Run the action outside the lock
                match grabbedResult with
                | None -> ()
                | Some res -> cont res)
                          

        /// Get the result and Commit(...).
        member x.AsyncResult =
            async { let! res = x.AsyncPrimitiveResult
                    return! AsyncResult.Commit(res) }

//---------------------------------------------------------------------------
// EnableHeapTerminationOnCorruption()
//---------------------------------------------------------------------------

// USAGE: call UnmanagedProcessExecutionOptions.EnableHeapTerminationOnCorruption() from "main()".
// Note: This is not SDL required but recommended.
module UnmanagedProcessExecutionOptions =
    open System
    open System.Runtime.InteropServices

    [<DllImport("kernel32.dll")>] 
    extern UIntPtr private GetProcessHeap()

    [<DllImport("kernel32.dll")>]
    extern bool private HeapSetInformation( 
        UIntPtr _HeapHandle, 
        UInt32  _HeapInformationClass, 
        UIntPtr _HeapInformation, 
        UIntPtr _HeapInformationLength)

    [<DllImport("kernel32.dll")>]
    extern UInt32 private GetLastError()

    // Translation of C# from http://swikb/v1/DisplayOnlineDoc.aspx?entryID=826 and copy in bug://5018
#if !FX_NO_SECURITY_PERMISSIONS
    [<System.Security.Permissions.SecurityPermission(System.Security.Permissions.SecurityAction.Assert,UnmanagedCode = true)>] 
#endif
    let EnableHeapTerminationOnCorruption() =
#if FX_NO_HEAPTERMINATION
        ()
#else
        if (System.Environment.OSVersion.Version.Major >= 6 && // If OS is Vista or higher
            System.Environment.Version.Major < 3) then         // and CLR not 3.0 or higher 
            // "The flag HeapSetInformation sets is available in Windows XP SP3 and later.
            //  The data structure used for heap information is available on earlier versions of Windows.
            //  The call will either return TRUE (found and set the flag) or false (flag not found).
            //  Not a problem in native code, so the program will merrily continue running.
            //  In managed code, the call to HeapSetInformation is a p/invoke.
            //  If HeapSetInformation returns FALSE then an exception will be thrown.
            //  If we are not running an OS which supports this (XP SP3, Vista, Server 2008, and Win7)
            //  then the call should not be made." -- see bug://5018.
            // See also:
            //  http://blogs.msdn.com/michael_howard/archive/2008/02/18/faq-about-heapsetinformation-in-windows-vista-and-heap-based-buffer-overruns.aspx
            let HeapEnableTerminationOnCorruption = 1u : uint32
            if not (HeapSetInformation(GetProcessHeap(),HeapEnableTerminationOnCorruption,UIntPtr.Zero,UIntPtr.Zero)) then
                  raise (System.Security.SecurityException( 
                            "Unable to enable unmanaged process execution option TerminationOnCorruption. " + 
                            "HeapSetInformation() returned FALSE; LastError = 0x" + 
                            GetLastError().ToString("X").PadLeft(8,'0') + "."))
#endif