[WIP] Add Reference Assembly support

src/fsharp/CompilerConfig.fs

@@ -317,6 +317,13 @@ type PackageManagerLine =
     static member StripDependencyManagerKey (packageKey: string) (line: string): string =
         line.Substring(packageKey.Length + 1).Trim()
 
+[<RequireQualifiedAccess>]
+type ReferenceAssemblyGeneration =
+    | None
+    | WithOptimizations
+    | WithoutOptimizations
+    | TestMockTypedImplFile
+
 [<NoEquality; NoComparison>]
 type TcConfigBuilder =
     {
@@ -429,6 +436,7 @@ type TcConfigBuilder =
       mutable emitTailcalls: bool
       mutable deterministic: bool
       mutable concurrentBuild: bool
+      mutable emitReferenceAssemblyOnly: ReferenceAssemblyGeneration
       mutable preferredUiLang: string option
       mutable lcid: int option
       mutable productNameForBannerText: string
@@ -634,6 +642,7 @@ type TcConfigBuilder =
           emitTailcalls = true
           deterministic = false
           concurrentBuild = true
+          emitReferenceAssemblyOnly = ReferenceAssemblyGeneration.None
           preferredUiLang = None
           lcid = None
           productNameForBannerText = FSharpProductName
@@ -1014,6 +1023,7 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) =
     member x.emitTailcalls = data.emitTailcalls
     member x.deterministic = data.deterministic
     member x.concurrentBuild = data.concurrentBuild
+    member x.emitReferenceAssemblyOnly = data.emitReferenceAssemblyOnly
     member x.pathMap = data.pathMap
     member x.langVersion = data.langVersion
     member x.preferredUiLang = data.preferredUiLang

src/fsharp/CompilerConfig.fsi

@@ -130,6 +130,13 @@ type PackageManagerLine =
     static member SetLinesAsProcessed: string -> Map<string, PackageManagerLine list> -> Map<string, PackageManagerLine list>
     static member StripDependencyManagerKey: string -> string -> string
 
+[<RequireQualifiedAccess>]
+type ReferenceAssemblyGeneration =
+    | None
+    | WithOptimizations
+    | WithoutOptimizations
+    | TestMockTypedImplFile
+
 [<NoEquality; NoComparison>]
 type TcConfigBuilder =
     { mutable primaryAssembly: PrimaryAssembly
@@ -236,6 +243,7 @@ type TcConfigBuilder =
       mutable emitTailcalls: bool
       mutable deterministic: bool
       mutable concurrentBuild: bool
+      mutable emitReferenceAssemblyOnly: ReferenceAssemblyGeneration
       mutable preferredUiLang: string option
       mutable lcid        : int option
       mutable productNameForBannerText: string
@@ -426,6 +434,7 @@ type TcConfig =
     member emitTailcalls: bool
     member deterministic: bool
     member concurrentBuild: bool
+    member emitReferenceAssemblyOnly: ReferenceAssemblyGeneration
     member pathMap: PathMap
     member preferredUiLang: string option
     member optsOn       : bool 

src/fsharp/CompilerOptions.fs

@@ -411,6 +411,9 @@ let SetTailcallSwitch (tcConfigB: TcConfigBuilder) switch =
 let SetDeterministicSwitch (tcConfigB: TcConfigBuilder) switch =
     tcConfigB.deterministic <- (switch = OptionSwitch.On)
 
+let SetReferenceAssemblyOnlySwitch (tcConfigB: TcConfigBuilder) switch =
+    tcConfigB.emitReferenceAssemblyOnly <- if (switch = OptionSwitch.On) then ReferenceAssemblyGeneration.WithOptimizations else ReferenceAssemblyGeneration.None
+
 let AddPathMapping (tcConfigB: TcConfigBuilder) (pathPair: string) =
     match pathPair.Split([|'='|], 2) with
     | [| oldPrefix; newPrefix |] ->
@@ -816,6 +819,11 @@ let codeGenerationFlags isFsi (tcConfigB: TcConfigBuilder) =
             OptionSwitch (SetDeterministicSwitch tcConfigB), None,
             Some (FSComp.SR.optsDeterministic()))
 
+          CompilerOption
+           ("refonly", tagNone,
+            OptionSwitch (SetReferenceAssemblyOnlySwitch tcConfigB), None,
+            Some (FSComp.SR.optsRefOnly()))
+
           CompilerOption
            ("pathmap", tagPathMap,
             OptionStringList (AddPathMapping tcConfigB), None,
@@ -1046,6 +1054,8 @@ let testFlag tcConfigB =
                 | "ShowLoadedAssemblies" -> tcConfigB.showLoadedAssemblies <- true
                 | "ContinueAfterParseFailure" -> tcConfigB.continueAfterParseFailure <- true
                 | "ParallelOff" -> tcConfigB.concurrentBuild <- false
+                | "RefOnlyWithoutOpt" -> tcConfigB.emitReferenceAssemblyOnly <- ReferenceAssemblyGeneration.WithoutOptimizations
+                | "RefOnlyMockTypedImplFile" -> tcConfigB.emitReferenceAssemblyOnly <- ReferenceAssemblyGeneration.TestMockTypedImplFile
 #if DEBUG
                 | "ShowParserStackOnParseError" -> showParserStackOnParseError <- true
 #endif

src/fsharp/FSComp.txt

@@ -871,6 +871,7 @@ optsDebug,"Specify debugging type: full, portable, embedded, pdbonly. ('%s' is t
 optsOptimize,"Enable optimizations (Short form: -O)"
 optsTailcalls,"Enable or disable tailcalls"
 optsDeterministic,"Produce a deterministic assembly (including module version GUID and timestamp)"
+optsRefOnly,"Produce a reference assembly, instead of a full assembly, as the primary output"
 optsPathMap,"Maps physical paths to source path names output by the compiler"
 optsCrossoptimize,"Enable or disable cross-module optimizations"
 optsWarnaserrorPM,"Report all warnings as errors"

src/fsharp/IlxGen.fs

@@ -74,6 +74,12 @@ let mkLdfldMethodDef (ilMethName, reprAccess, isStatic, ilTy, ilFieldName, ilPro
            mkILNonGenericInstanceMethod (ilMethName, reprAccess, [], ilReturn, mkMethodBody (true, [], 2, nonBranchingInstrsToCode [ mkLdarg0; mkNormalLdfld ilFieldSpec], None))
    ilMethodDef.WithSpecialName
 
+let ilThrowNullInstrs = [|ILInstr.AI_ldnull; ILInstr.I_throw|]
+let emptyDict = Dictionary()
+let mkILThrowNullMethodBody name =
+    let ilCode = IL.buildILCode name emptyDict ilThrowNullInstrs [] []
+    mkILMethodBody(false, ILLocals.Empty, 0, ilCode, None)
+
 /// Choose the constructor parameter names for fields
 let ChooseParamNames fieldNamesAndTypes =
     let takenFieldNames = fieldNamesAndTypes |> List.map p23 |> Set.ofList
@@ -213,7 +219,10 @@ type IlxGenOptions =
       isInteractiveItExpr: bool
 
       /// Whenever possible, use callvirt instead of call
-      alwaysCallVirt: bool 
+      alwaysCallVirt: bool
+
+      /// Indicates that we are only generating a reference assembly.
+      referenceAssemblyOnly: bool
     }
 
 /// Compilation environment for compiling a fragment of an assembly
@@ -253,6 +262,9 @@ type cenv =
 
       /// Delayed Method Generation - prevents stack overflows when we need to generate methods that are split into many methods by the optimizer.
       delayedGenMethods: Queue<cenv -> unit>
+
+      /// Indicates that the generating assembly will have an assembly-level attribute, System.Runtime.CompilerServices.InternalsVisibleToAttribute.
+      hasInternalsVisibleToAttr: bool
     }
 
     override x.ToString() = "<cenv>"
@@ -6130,6 +6142,13 @@ and GenMethodForBinding
          ctorThisValOpt, baseValOpt, methLambdaTypars, methLambdaVars, methLambdaBody, returnTy) =
     let g = cenv.g
     let m = v.Range
+
+    // When emitting a reference assembly, do not emit methods that are private unless they are virtual/abstract or provide an explicit interface implementation.
+    // Internal methods can be omitted only if the assembly does not contain a System.Runtime.CompilerServices.InternalsVisibleToAttribute.
+    if cenv.opts.referenceAssemblyOnly && 
+       (v.Accessibility.IsPrivate || (v.Accessibility.IsInternal && not cenv.hasInternalsVisibleToAttr)) && 
+       not (v.IsOverrideOrExplicitImpl || v.IsDispatchSlot) then ()
+    else
 
     // If a method has a witness-passing version of the code, then suppress
     // the generation of any witness in the non-witness passing version of the code
@@ -6212,10 +6231,16 @@ and GenMethodForBinding
                 else
                     body
 
-            let ilCodeLazy = lazy CodeGenMethodForExpr cenv mgbuf (SPAlways, tailCallInfo, mspec.Name, eenvForMeth, 0, bodyExpr, sequel)
+            if cenv.opts.referenceAssemblyOnly then
+                // The reason for using 'throw null' bodies (as opposed to no bodies) is so 
+                // that PEVerify can run and pass (thus validating the completeness of the metadata).
+                let ilMethBody = mkILThrowNullMethodBody mspec.Name
+                false, MethodBody.IL(lazy ilMethBody), false
+            else
+                let ilCodeLazy = lazy CodeGenMethodForExpr cenv mgbuf (SPAlways, tailCallInfo, mspec.Name, eenvForMeth, 0, bodyExpr, sequel)
 
-            // This is the main code generation for most methods
-            false, MethodBody.IL(ilCodeLazy), false
+                // This is the main code generation for most methods
+                false, MethodBody.IL(ilCodeLazy), false
 
     match ilMethodBody with
     | MethodBody.IL(ilCodeLazy) ->
@@ -8065,6 +8090,20 @@ let GenerateCode (cenv, anonTypeTable, eenv, TypedAssemblyAfterOptimization impl
     // Generate the whole assembly
     CodegenAssembly cenv eenv mgbuf implFiles
 
+    let assemAttribs =
+        // Emit System.Runtime.CompilerServices.ReferenceAssemblyAttribute as an assembly-level when generating a reference assembly.
+        // Useful for the runtime to know that the assembly is a reference assembly.
+        if cenv.opts.referenceAssemblyOnly && g.attrib_ReferenceAssemblyAttribute.TyconRef.CanDeref then
+            let ilRefAsmAttribMethRef =
+                let ilTyRef = g.attrib_ReferenceAssemblyAttribute.TypeRef
+                let ilTySpec = mkILTySpec(ilTyRef, [])
+                let ilMethSpec = mkILCtorMethSpecForTy(mkILBoxedType ilTySpec, [])
+                ilMethSpec.MethodRef
+            let refAsmAttrib = Attrib(g.attrib_ReferenceAssemblyAttribute.TyconRef, AttribKind.ILAttrib ilRefAsmAttribMethRef, [], [], false, None, range0)
+            refAsmAttrib :: assemAttribs
+        else
+            assemAttribs
+
     let ilAssemAttrs = GenAttrs cenv eenv assemAttribs
 
     let tdefs, reflectedDefinitions = mgbuf.Close()
@@ -8249,6 +8288,8 @@ type IlxAssemblyGenerator(amap: ImportMap, tcGlobals: TcGlobals, tcVal: Constrai
 
     /// Generate ILX code for an assembly fragment
     member _.GenerateCode (codeGenOpts, typedAssembly, assemAttribs, moduleAttribs) =
+        let hasInternalsVisibleToAttr = HasFSharpAttribute tcGlobals tcGlobals.attrib_InternalsVisibleToAttribute assemAttribs
+
         let cenv: cenv =
             { g=tcGlobals
               tcVal = tcVal
@@ -8260,7 +8301,8 @@ type IlxAssemblyGenerator(amap: ImportMap, tcGlobals: TcGlobals, tcVal: Constrai
               opts = codeGenOpts
               optimizeDuringCodeGen = (fun _flag expr -> expr)
               exprRecursionDepth = 0
-              delayedGenMethods = Queue () }
+              delayedGenMethods = Queue ()
+              hasInternalsVisibleToAttr = hasInternalsVisibleToAttr }
         GenerateCode (cenv, anonTypeTable, ilxGenEnv, typedAssembly, assemAttribs, moduleAttribs)
 
     /// Invert the compilation of the given value and clear the storage of the value

src/fsharp/IlxGen.fsi

@@ -52,6 +52,9 @@ type internal IlxGenOptions =
 
       /// Indicates that, whenever possible, use callvirt instead of call
       alwaysCallVirt: bool
+
+      /// Indicates that we are only generating a reference assembly.
+      referenceAssemblyOnly: bool
     }
 
 /// The results of the ILX compilation of one fragment of an assembly

src/fsharp/OptimizeInputs.fs

@@ -178,7 +178,8 @@ let GenerateIlxCode
           ilxBackend = ilxBackend
           isInteractive = tcConfig.isInteractive
           isInteractiveItExpr = isInteractiveItExpr
-          alwaysCallVirt = tcConfig.alwaysCallVirt }
+          alwaysCallVirt = tcConfig.alwaysCallVirt
+          referenceAssemblyOnly = tcConfig.emitReferenceAssemblyOnly <> ReferenceAssemblyGeneration.None }
 
     ilxGenerator.GenerateCode (ilxGenOpts, optimizedImpls, topAttrs.assemblyAttrs, topAttrs.netModuleAttrs) 
 

src/fsharp/ParseAndCheckInputs.fs

@@ -37,6 +37,7 @@ open FSharp.Compiler.Text.Range
 open FSharp.Compiler.Xml
 open FSharp.Compiler.TypedTree
 open FSharp.Compiler.TypedTreeOps
+open FSharp.Compiler.TypedTreeBasics
 open FSharp.Compiler.TcGlobals
 
 let CanonicalizeFilename filename = 
@@ -755,6 +756,111 @@ let GetInitialTcState(m, ccuName, tcConfig: TcConfig, tcGlobals, tcImports: TcIm
       tcsRootImpls = Zset.empty qnameOrder
       tcsCcuSig = Construct.NewEmptyModuleOrNamespaceType Namespace }
 
+let rec createMockModuleOrNamespaceExpr (g: TcGlobals) (anonRecdTypeInfos: StampMap<AnonRecdTypeInfo>) (mty: ModuleOrNamespaceType) =
+
+    let mockValAsBinding (anonRecdTypeInfos: StampMap<AnonRecdTypeInfo>) (v: Val) =
+        let expr, anonRecdTypeInfos =
+            let retExpr = Expr.Op(TOp.Return, [], [], range0)
+            if isFunTy g v.Type || isForallFunctionTy g v.Type then
+                match v.ValReprInfo with
+                | Some valReprInfo ->
+                    let memberFlags =
+                        match v.MemberInfo with
+                        | Some memberInfo -> memberInfo.MemberFlags
+                        | _ ->
+                            {
+                                SynMemberFlags.IsInstance = false
+                                IsDispatchSlot = false
+                                IsOverrideOrExplicitImpl = false
+                                IsFinal = false
+                                MemberKind = SynMemberKind.Member
+                            }
+
+                    let numEnclosingTypars = CountEnclosingTyparsOfActualParentOfVal v
+                    let typars, _, curriedArgInfos, retTy, _retInfo = GetMemberTypeInMemberForm g memberFlags valReprInfo numEnclosingTypars v.Type v.Range
+                    let retTy =
+                        retTy
+                        |> Option.defaultValue g.unit_ty
+
+                    let anonRecdTypeInfos =
+                        match tryDestAnonRecdTy g retTy with
+                        | ValueSome(anonRecdTypeInfo, _) ->
+                            anonRecdTypeInfos.Add(anonRecdTypeInfo.Stamp, anonRecdTypeInfo)
+                        | _ ->
+                            anonRecdTypeInfos
+
+                    let valParams =
+                        curriedArgInfos
+                        |> List.map (fun argInfos ->
+                            argInfos
+                            |> List.map (fun (ty, argInfo) ->
+                                let name =
+                                    argInfo.Name
+                                    |> Option.map (fun x -> x.idText)
+                                    |> Option.defaultValue ""
+                                Construct.NewVal(
+                                    name, range0, None, ty, ValMutability.Immutable, false, None, Accessibility.TAccess([]),
+                                    ValRecursiveScopeInfo.ValNotInRecScope, None, ValBaseOrThisInfo.NormalVal, argInfo.Attribs, ValInline.Never,
+                                    XmlDoc.Empty, false, false, false, false, false, false, None, ParentNone)
+                            )
+                        )
+                    if valParams.IsEmpty || (valParams.Length = 1 && valParams.Head.IsEmpty) then
+                        Expr.Lambda(newUnique(), None, None, [], retExpr, range0, retTy), anonRecdTypeInfos 
+                    else
+                        mkMemberLambdas range0 typars None None valParams (retExpr, retTy), anonRecdTypeInfos 
+                | _ ->
+                    failwith "Expected top-level val"
+            else
+                retExpr, anonRecdTypeInfos 
+        mkBind DebugPointAtBinding.NoneAtLet v expr, anonRecdTypeInfos
+
+    let mockValAsModuleOrNamespaceExpr (anonRecdTypeInfos: StampMap<AnonRecdTypeInfo>) (v: Val) =
+        let binding, anonRecdTypeInfos = mockValAsBinding anonRecdTypeInfos v
+        ModuleOrNamespaceExpr.TMDefLet(binding, range0), anonRecdTypeInfos
+
+    let mockValAsModuleOrNamespaceExprs (anonRecdTypeInfos: StampMap<AnonRecdTypeInfo>) (vs: Val seq) =
+        (anonRecdTypeInfos, vs)
+        ||> Seq.mapFold mockValAsModuleOrNamespaceExpr
+
+    let mockEntityAsModuleOrNamespaceBinding (anonRecdTypeInfos: StampMap<AnonRecdTypeInfo>) (ent: Entity) =
+        let expr, anonRecdTypeInfos = createMockModuleOrNamespaceExpr g anonRecdTypeInfos ent.ModuleOrNamespaceType
+        ModuleOrNamespaceBinding.Module(ent, expr), anonRecdTypeInfos
+
+    let mockEntitiesAsModuleOrNamespaceBindings (anonRecdTypeInfos: StampMap<AnonRecdTypeInfo>) (ents: Entity seq) =
+        (anonRecdTypeInfos, ents)
+        ||> Seq.mapFold mockEntityAsModuleOrNamespaceBinding
+
+    let entBindings, anonRecdTypeInfos =
+        mty.ModuleAndNamespaceDefinitions
+        |> mockEntitiesAsModuleOrNamespaceBindings anonRecdTypeInfos
+
+    let tycons = mty.TypeAndExceptionDefinitions
+
+    let exprs, anonRecdTypeInfos = mockValAsModuleOrNamespaceExprs anonRecdTypeInfos mty.AllValsAndMembers
+
+    let entBindings = entBindings |> List.ofSeq
+    let exprs = exprs |> List.ofSeq
+    let exprs =
+        if entBindings.IsEmpty && tycons.IsEmpty then
+            exprs
+        else
+            ModuleOrNamespaceExpr.TMDefRec(false, tycons, entBindings, range0) :: exprs
+
+    (ModuleOrNamespaceExpr.TMDefs exprs), anonRecdTypeInfos
+
+let createMockModuleOrNamespaceExprWithSig g (anonRecdTypeInfos: StampMap<AnonRecdTypeInfo>) (mty: ModuleOrNamespaceType) =
+    let innerExpr, anonRecdTypeInfos = createMockModuleOrNamespaceExpr g anonRecdTypeInfos mty
+    let expr =
+        ModuleOrNamespaceExpr.TMDefs
+            [
+                innerExpr
+            ]
+    ModuleOrNamespaceExprWithSig(mty, expr, range0), anonRecdTypeInfos
+
+let createMockTypedImplFile g (mty: ModuleOrNamespaceType, qualNameOfFile: QualifiedNameOfFile) =
+    let exprWithSig, anonRecdTypeInfos = createMockModuleOrNamespaceExprWithSig g StampMap.Empty mty
+    TypedImplFile.TImplFile(qualNameOfFile, [], exprWithSig, false, false, anonRecdTypeInfos)
+
 /// Typecheck a single file (or interactive entry into F# Interactive)
 let TypeCheckOneInputEventually (checkForErrors, tcConfig: TcConfig, tcImports: TcImports, tcGlobals, prefixPathOpt, tcSink, tcState: TcState, inp: ParsedInput, skipImplIfSigExists: bool) =
 
@@ -831,9 +937,15 @@ let TypeCheckOneInputEventually (checkForErrors, tcConfig: TcConfig, tcImports:
                   else
                     TypeCheckOneImplFile (tcGlobals, tcState.tcsNiceNameGen, amap, tcState.tcsCcu, checkForErrors, conditionalDefines, tcSink, tcConfig.internalTestSpanStackReferring) tcImplEnv rootSigOpt file
 
-              let! topAttrs, implFile, _implFileHiddenType, tcEnvAtEnd, createsGeneratedProvidedTypes = typeCheckOne
+              let! topAttrs, implFile0, _implFileHiddenType, tcEnvAtEnd, createsGeneratedProvidedTypes = typeCheckOne
+
+              let implFileSigType = SigTypeOfImplFile implFile0
 
-              let implFileSigType = SigTypeOfImplFile implFile
+              let implFile =
+                if tcConfig.emitReferenceAssemblyOnly = ReferenceAssemblyGeneration.TestMockTypedImplFile then
+                    createMockTypedImplFile tcGlobals (implFileSigType, qualNameOfFile)
+                else
+                    implFile0
 
               let rootImpls = Zset.add qualNameOfFile tcState.tcsRootImpls
 

src/fsharp/TcGlobals.fs

@@ -1192,6 +1192,7 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d
   member val attrib_CallerLineNumberAttribute = findSysAttrib "System.Runtime.CompilerServices.CallerLineNumberAttribute"
   member val attrib_CallerFilePathAttribute = findSysAttrib "System.Runtime.CompilerServices.CallerFilePathAttribute"
   member val attrib_CallerMemberNameAttribute = findSysAttrib "System.Runtime.CompilerServices.CallerMemberNameAttribute"
+  member val attrib_ReferenceAssemblyAttribute = findSysAttrib "System.Runtime.CompilerServices.ReferenceAssemblyAttribute"
 
   member val attrib_ProjectionParameterAttribute           = mk_MFCore_attrib "ProjectionParameterAttribute"
   member val attrib_CustomOperationAttribute               = mk_MFCore_attrib "CustomOperationAttribute"