F# compiler

val offwhite : char list

Full name: index.offwhite

val not : value:bool -> bool

Full name: Microsoft.FSharp.Core.Operators.not

Multiple items
val int64 : value:'T -> int64 (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.int64

--------------------
type int64 = System.Int64

Full name: Microsoft.FSharp.Core.int64

--------------------
type int64<'Measure> = int64

Full name: Microsoft.FSharp.Core.int64<_>

Multiple items
val string : value:'T -> string

Full name: Microsoft.FSharp.Core.Operators.string

--------------------
type string = System.String

Full name: Microsoft.FSharp.Core.string

namespace System

Multiple items
type Object =
  new : unit -> obj
  member Equals : obj:obj -> bool
  member GetHashCode : unit -> int
  member GetType : unit -> Type
  member ToString : unit -> string
  static member Equals : objA:obj * objB:obj -> bool
  static member ReferenceEquals : objA:obj * objB:obj -> bool

Full name: System.Object

--------------------
System.Object() : unit

System.Object.ReferenceEquals(objA: obj, objB: obj) : bool

val raise : exn:System.Exception -> 'T

Full name: Microsoft.FSharp.Core.Operators.raise

Multiple items
type ArgumentNullException =
inherit ArgumentException
new : unit -> ArgumentNullException + 3 overloads

Full name: System.ArgumentNullException

--------------------
System.ArgumentNullException() : unit
System.ArgumentNullException(paramName: string) : unit
System.ArgumentNullException(message: string, innerException: exn) : unit
System.ArgumentNullException(paramName: string, message: string) : unit

val sign : value:'T -> int (requires member get_Sign)

Full name: Microsoft.FSharp.Core.Operators.sign

namespace System.Collections

namespace System.Collections.Generic

type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>

Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member GetSlice : startIndex:int option * endIndex:int option -> 'T list
  member Head : 'T
  member IsEmpty : bool
  member Item : index:int -> 'T with get
  member Length : int
  member Tail : 'T list
  static member Cons : head:'T * tail:'T list -> 'T list
  static member Empty : 'T list

Full name: Microsoft.FSharp.Collections.List<_>

val printfn : format:Printf.TextWriterFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printfn

Multiple items
type NoEqualityAttribute =
inherit Attribute
new : unit -> NoEqualityAttribute

Full name: Microsoft.FSharp.Core.NoEqualityAttribute

--------------------
new : unit -> NoEqualityAttribute

Multiple items
type NoComparisonAttribute =
inherit Attribute
new : unit -> NoComparisonAttribute

Full name: Microsoft.FSharp.Core.NoComparisonAttribute

--------------------
new : unit -> NoComparisonAttribute

val id : x:'T -> 'T

Full name: Microsoft.FSharp.Core.Operators.id

union case Option.Some: Value: 'T -> Option<'T>

union case Option.None: Option<'T>

module Seq

from Microsoft.FSharp.Collections

val filter : predicate:('T -> bool) -> source:seq<'T> -> seq<'T>

Full name: Microsoft.FSharp.Collections.Seq.filter

val map : mapping:('T -> 'U) -> list:'T list -> 'U list

Full name: Microsoft.FSharp.Collections.List.map

val exists : predicate:('T -> bool) -> list:'T list -> bool

Full name: Microsoft.FSharp.Collections.List.exists

val map : mapping:('T -> 'U) -> source:seq<'T> -> seq<'U>

Full name: Microsoft.FSharp.Collections.Seq.map

Multiple items
module Set

from Microsoft.FSharp.Collections

--------------------
type Set<'T (requires comparison)> =
  interface IComparable
  interface IEnumerable
  interface IEnumerable<'T>
  interface ICollection<'T>
  new : elements:seq<'T> -> Set<'T>
  member Add : value:'T -> Set<'T>
  member Contains : value:'T -> bool
  override Equals : obj -> bool
  member IsProperSubsetOf : otherSet:Set<'T> -> bool
  member IsProperSupersetOf : otherSet:Set<'T> -> bool
  ...

Full name: Microsoft.FSharp.Collections.Set<_>

--------------------
new : elements:seq<'T> -> Set<'T>

val ofSeq : elements:seq<'T> -> Set<'T> (requires comparison)

Full name: Microsoft.FSharp.Collections.Set.ofSeq

val filter : predicate:('T -> bool) -> list:'T list -> 'T list

Full name: Microsoft.FSharp.Collections.List.filter

val ofList : elements:'T list -> Set<'T> (requires comparison)

Full name: Microsoft.FSharp.Collections.Set.ofList

val difference : set1:Set<'T> -> set2:Set<'T> -> Set<'T> (requires comparison)

Full name: Microsoft.FSharp.Collections.Set.difference

val toList : source:seq<'T> -> 'T list

Full name: Microsoft.FSharp.Collections.Seq.toList

val distinct : list:'T list -> 'T list (requires equality)

Full name: Microsoft.FSharp.Collections.List.distinct

val sortBy : projection:('T -> 'Key) -> list:'T list -> 'T list (requires comparison)

Full name: Microsoft.FSharp.Collections.List.sortBy

type 'T option = Option<'T>

Full name: Microsoft.FSharp.Core.option<_>

type bool = System.Boolean

Full name: Microsoft.FSharp.Core.bool

Multiple items
val int : value:'T -> int (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.int

--------------------
type int = int32

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>

A journey into the F# compiler

Steffen Forkmann

Disclaimer

This is NOT a formal compiler design talk

Disclaimer

PRs

My current level: Knowing just enough to be dangerous

What is a compiler?

Source code

-> Compiler

-> Program / Error message

Lexer

Source code -> Lexer ==> Stream of Tokens

Lexer pattern match

Tabs vs. Spaces

Tabs vs. Spaces - lex.fsl

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12:

let offwhite = ['\t']

match token with
...
| offwhite+  
    { if args.lightSyntaxStatus.Status then 
          errorR(Error(FSComp.SR.lexTabsNotAllowed(),lexbuf.LexemeRange))
      
      if not skip then 
          WHITESPACE (LexCont.Token !args.ifdefStack)
      else 
          token args skip lexbuf }

Pull Request #1243 (@AviAvni)

1: 
2: 
3: 
4: 
5: 
6: 
7: 
8:

let creditCardNumber = 1234_5678_9012_3456L
let socialSecurityNumber = 999_99_9999L
let pi = 3.14_15F
let hexBytes = 0xFF_EC_DE_5E
let hexWords = 0xCAFE_BABE
let maxLong = 0x7fff_ffff_ffff_ffffL
let nybbles = 0b0010_0101
let bytes = 0b11010010_01101001_10010100_10010010

Pull Request #1243

1: 
2: 
3: 
4: 
5: 
6:

// before
let integer = digit+


// after
let integer = digit ((digit | separator)* digit)?

Parser

Source code -> Lexer -> Parser ==> Parse tree

Euclidean algorithm (pseudo code)

1: 
2: 
3: 
4: 
5: 
6:

while b <> 0
    if a > b
        a := a - b
    else
        b := b - a
return a

Pull Request #1243

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21:

let inline ( *. )  (x:int64)  (y:int64)  = (# "mul" x y : int64 #)

// convert to int
let ParseInt32 (s:string) = 
    if System.Object.ReferenceEquals(s,null) then
        raise( new System.ArgumentNullException("s") )
    let s = removeUnderscores (s.Trim())
    let l = s.Length 
    let mutable p = 0 
    let sign = getSign32 s & p l
    let specifier = get0OXB s & p l 
    if p >= l then formatError() else        
    match Char.ToLowerInvariant(specifier) with
    | 'x' -> 
        sign *. Int64.Parse(
                    s.Substring(p), 
                    NumberStyles.AllowHexSpecifier,
                    CultureInfo.InvariantCulture)
    | 'b' -> sign *. (int64OfUInt64 (parseBinaryUInt64 s p l))
    | 'o' -> sign *. (int64OfUInt64 (parseOctalUInt64 s p l))
    | _ -> Int64.Parse(s, NumberStyles.AllowLeadingSign, CultureInfo.InvariantCulture)

Name resolution

Source code -> Lexer -> Parser -> Name resolution ==> AST

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11:

open System
open System.Collections.Generic

let list = List<_>()
list.Add 3

type List = { ... }

let f (list:List) = list.Length

printfn "%A" list.Items

Immutable maps FTW

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19:

[<NoEquality; NoComparison>]
/// The environment of information used to resolve names
type NameResolutionEnv =
  { /// Values and Data Tags available by unqualified name 
    eUnqualifiedItems: LayeredMap<string,Item>
    /// Data Tags and Active Pattern Tags available by unqualified name 
    ePatItems: NameMap<Item>
    /// Modules accessible via "." notation. Note this is a multi-map. 
    eModulesAndNamespaces:  NameMultiMap<Tast.ModuleOrNamespaceRef>        
    /// Fully qualified modules and namespaces. 'open' does not change this. 
    eFullyQualifiedModulesAndNamespaces:  NameMultiMap<Tast.ModuleOrNamespaceRef>        
    /// RecdField labels in scope. 
    eFieldLabels: NameMultiMap<Tast.RecdFieldRef>

    /// ...

    /// Extension members by type and name 
    eIndexedExtensionMembers: TyconRefMultiMap<ExtensionMember>
    }

PRs

Pull Request #1102

Record labels

Pull Request #1102

Record labels

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21:

/// Resolve a long identifier representing a record field 
let ResolveFieldPrim (ncenv:NameResolver) nenv ad typ (mp,id:Ident) fields =
    let typeNameResInfo = TypeNameResolutionInfo.Default
    let m = id.idRange
    match mp with 
    | [] -> 
        let lookup() = ...

        if isAppTy ncenv.g typ then 
            match ncenv.InfoReader.TryFindRecdOrClassFieldInfoOfType(id.idText,m,typ) with
            | Some (RecdFieldInfo(_,rfref)) -> 
                [ResolutionInfo.Empty, FieldResolution(rfref,false)]
            | None ->
                let typeName = NicePrint.minimalStringOfType nenv.eDisplayEnv typ
                if isRecdTy ncenv.g typ then               
                    error(SuggestOtherLabelsOfSameRecordType nenv typeName id fields,m)
                else
                    lookup()
        else 
            lookup()
    | _ -> ...

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22:

/// Suggest other labels of the same record
let SuggestOtherLabelsOfSameRecordType (nenv:NameResolutionEnv) typeName id fields =    
    let labelsOfPossibleRecord =
        nenv.eFieldLabels
        |> Seq.filter (fun kv -> 
            kv.Value 
            |> List.map (fun r -> r.TyconRef.DisplayName)
            |> List.exists ((=) typeName))
        |> Seq.map (fun kv -> kv.Key)
        |> Set.ofSeq

    let givenFields = 
        fields 
        |> List.map (fun fld -> fld.idText) 
        |> List.filter ((<>) id.idText)
        |> Set.ofList

    let predictedLabels = Set.difference labelsOfPossibleRecord givenFields
    let predictions = ErrorResolutionHints.FilterPredictions id.idText predictedLabels

    let errorCode,text = FSComp.SR.nrRecordDoesNotContainSuchLabel(typeName, id.idText)
    errorCode,text + ErrorResolutionHints.FormatPredictions predictions

1: 
2: 
3: 
4: 
5: 
6: 
7:

/// Filters predictions based on edit distance to an unknown identifier.
let FilterPredictions unknownIdent allPredictions =
    allPredictions
    |> Seq.toList
    |> List.distinct
    |> List.sortBy (fun s -> EditDistance.CalcEditDistance(unknownIdent,s))
    |> take 5

Type checking

Hindley-Milner Type Inference Algorithm

Source code -> Lexer -> Parser -> Name resolution
-> Type checker ==> TAST

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17:

type TcEnv =
  { eNameResEnv : NameResolutionEnv 
    eUngeneralizableItems: UngeneralizableItem list
    eCompPath: CompilationPath 
    eAccessPath: CompilationPath         
    eContextInfo : ContextInfo 
    eCallerMemberName : string option
    // ...
    }

type cenv = 
  { g: TcGlobals
    tcSink: TcResultsSink 
    topCcu: CcuThunk  
    css: ConstraintSolverState
    // ...        
    }

1: 
2: 
3: 
4: 
5:

let rec fib n = 
    if n <= 2 then 
        1
    else 
        fib (n - 1) + fib (n - 2)

1: 
2: 
3: 
4: 
5:

// if :: bool - 'a - 'a -> 'a
if n <= 2 then 
    1
else 
    fib (n - 1) + fib (n - 2)

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10:

// if :: bool - 'a - 'a -> 'a
if n <= 2 then 
    1
else 
    fib (n - 1) + fib (n - 2) 

[T_COND: bool]
[T_IF: 'a]
[T_ELSE: 'a]
[T_IF = T_ELSE]

1: 
2: 
3: 
4: 
5: 
6: 
7: 
8:

// if :: bool - 'a - 'a -> 'a
if n <= 2 then 
    1
else 
    fib (n - 1) + fib (n - 2) 

[T_COND: bool]
[T_IF: 'a]

1: 
2: 
3: 
4: 
5: 
6: 
7: 
8:

// (<=) :: 'a -> 'a -> bool when 'a is Number
n <= 2

[T_n: 'a when 'a is Number]
[T_2: 'a when 'a is Number]
[T_n = T_2]
[T_COND: bool]
[T_IF: 'a]

1: 
2: 
3: 
4: 
5: 
6: 
7:

// 2 :: int
n <= 2

[T_n: int]
[T_2: int]
[T_COND: bool]
[T_IF: 'a]

1: 
2: 
3: 
4: 
5: 
6: 
7: 
8: 
9:

if n <= 2 then 
    1 // 1 :: int
else 
    fib (n - 1) + fib (n - 2) 

[T_n: int]
[T_2: int]
[T_COND: bool]
[T_IF: int]

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11:

// (+) :: 'a -> 'a -> 'a when 'a is Number    
(fib (n - 1)) + (fib (n - 2))

[T_n: int]
[T_2: int]
[T_COND: bool]
[T_IF: int]
[T_Left: 'a when 'a is Number]
[T_Right: 'a when 'a is Number]
[T_Left = T_Right]
[T_Left = T_IF]

1: 
2: 
3: 
4: 
5: 
6: 
7:

// (+) :: 'a -> 'a -> 'a when 'a is Number    
(fib (n - 1)) + (fib (n - 2))

[T_n: int]
[T_2: int]
[T_COND: bool]
[T_IF: int]

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10:

// fib :: 'a -> 'b
fib (n - 1)

[T_n: int]
[T_2: int]
[T_COND: bool]
[T_IF: int]
[T_Fib: 'a -> 'b]
[T_Arg: 'a]
[T_FibResult: int]

1: 
2: 
3: 
4: 
5: 
6: 
7: 
8: 
9:

// (-) :: 'a -> 'a -> 'a when 'a is number
(n - 1)

[T_n: int]
[T_2: int]
[T_COND: bool]
[T_IF: int]
[T_Fib: 'a -> int]
[T_Arg: int]

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11:

let rec fib n = 
    if n <= 2 then 
        1
    else 
        fib (n - 1) + fib (n - 2)

[T_n: int]
[T_2: int]
[T_COND: bool]
[T_IF : int]
[T_Fib : int -> int]

1: 
2: 
3: 
4:

let UnifyTypes cenv (env: TcEnv) m expectedTy actualTy = 
    ConstraintSolver.AddCxTypeEqualsType env.eContextInfo env.DisplayEnv cenv.css m 
       (tryNormalizeMeasureInType cenv.g expectedTy) 
       (tryNormalizeMeasureInType cenv.g actualTy)

Pull Request #1149

type test

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10:

let SolveTypSubsumesTypWithReport (csenv:ConstraintSolverEnv) ndeep m trace ty1 ty2 =
    TryD (fun () -> SolveTypSubsumesTypKeepAbbrevs csenv ndeep m trace ty1 ty2)
        (fun res ->
            match csenv.eContextInfo with
            | ContextInfo.RuntimeTypeTest ->
                // test if we can cast other way around
                match CollectThenUndo (fun _ -> SolveTypSubsumesTypKeepAbbrevs ...) with 
                | OkResult _ -> ErrorD(...,ContextInfo.DowncastUsedInsteadOfUpcast)
                | _ -> ErrorD(...,ContextInfo.NoContext)
            | _ -> ErrorD (...,csenv.eContextInfo)

Optimizer

Source code -> Lexer -> Parser -> Name resolution
-> Type checker -> Optimizer ==> TAST

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12:

let rec OptimizeExpr cenv (env:IncrementalOptimizationEnv) expr =
    match expr with
    | Expr.Sequential _ | Expr.Let _ -> OptimizeLinearExpr cenv env expr id
    | Expr.Const (c,m,ty) -> OptimizeConst cenv env expr (c,m,ty)
    | Expr.Val (v,_vFlags,m) -> OptimizeVal cenv env expr (v,m)
    | Expr.Quote(ast,splices,isFromQueryExpression,m,ty) -> ...
    | Expr.App(f,fty,tyargs,argsl,m) -> 
        // eliminate uses of query
        match TryDetectQueryQuoteAndRun cenv expr with 
        | Some newExpr -> OptimizeExpr cenv env newExpr
        | None -> OptimizeApplication cenv env (f,fty,tyargs,argsl,m)
    ...

Optimizer

Inlining
Inner lambda to top level funcs
Removing tuples
Optimize seq { } workflows
Numeric calculations
Beta reduction
...

Optimizer

1: 
2: 
3: 
4: 
5: 
6: 
7: 
8:

let y = (fun x -> 2 + x * x) 3

// beta reduction
let y = 2 + 3 * 3

// numeric calculations
// (special form of beta reduction)
let y = 11

Optimizer experiment: Fusion

1: 
2: 
3: 
4: 
5: 
6: 
7:

["hello"; "world"; "!"]
|> Seq.map (fun (y:string) -> y.Length * 2) 
|> Seq.map (fun x -> x * 3)

// after PR 1525 reduction
["hello"; "world"; "!"]
|> Seq.map (fun x -> x.Length * 6)

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20:

match expr' with
// Rewrite Seq.map f (Seq.map g) xs into Seq.map (fun x -> f(g x)) xs
| Expr.App(Expr.Val(outerValRef,_,_) as outerSeqMap,ttype1,[_;fOutType],
            [(Expr.Lambda(_,None,None,_,_,m1,fRetType) as f)
                Expr.App(Expr.Val(innerValRef,_,_),_,[gInType;_],
                        [Expr.Lambda(_,None,None,gVals,g,_,gRetType)
                            rest],_)],m2) when
    valRefEq cenv.g innerValRef cenv.g.seq_map_vref &&
    valRefEq cenv.g outerValRef cenv.g.seq_map_vref 
        -> 
    let newApp = Expr.App(f,TType_fun(gRetType, fRetType),[],[g],m2)
    
    let reduced =
        Expr.App(outerSeqMap,ttype1,[gInType;fOutType],
                [Expr.Lambda(newUnique(),None,None,gVals,newApp,m1,gRetType) 
                    rest],
                m2)

    OptimizeExpr cenv env reduced
| _ ->

Code gen: IL Emitter

Source code -> Lexer -> Parser -> Name resolution
-> Type checker -> Optimizer -> IL Emitter ==> Program / PDBs

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19:

let rec GenExpr (cenv:cenv) (cgbuf:CodeGenBuffer) eenv sp expr sequel =
    match expr with 
    | Expr.Const(c,m,ty) -> 
        GenConstant cenv cgbuf eenv (c,m,ty) sequel
    | Expr.Match (spBind,exprm,tree,targets,m,ty) -> 
        GenMatch cenv cgbuf eenv (spBind,exprm,tree,targets,m,ty) sequel
    | Expr.Sequential(e1,e2,dir,spSeq,m) ->  
        GenSequential cenv cgbuf eenv sp (e1,e2,dir,spSeq,m) sequel
    | Expr.LetRec (binds,body,m,_)  -> 
        GenLetRec cenv cgbuf eenv (binds,body,m) sequel
    | Expr.Let (bind,body,_,_)  -> 
        // This case implemented here to get a guaranteed tailcall 
        // Make sure we generate the sequence point outside the scope of the variable
        let startScope,endScope as scopeMarks = StartDelayedLocalScope "let" cgbuf
        let eenv = AllocStorageForBind cenv cgbuf scopeMarks eenv bind
        let spBind = GenSequencePointForBind cenv cgbuf bind
        CG.SetMarkToHere cgbuf startScope 
        GenBindAfterSequencePoint cenv cgbuf eenv spBind bind
    | ...

FSharp.Compiler.Service

Code gen: Fable

Thank you