Skip to content

Commit

Permalink
More ValueOption in compiler: part 1
Browse files Browse the repository at this point in the history
  • Loading branch information
psfinaki committed Jan 9, 2024
1 parent f0fb143 commit c501700
Show file tree
Hide file tree
Showing 10 changed files with 122 additions and 85 deletions.
28 changes: 15 additions & 13 deletions src/Compiler/Checking/CheckComputationExpressions.fs
Original file line number Diff line number Diff line change
Expand Up @@ -39,19 +39,21 @@ let TryFindIntrinsicOrExtensionMethInfo collectionSettings (cenv: cenv) (env: Tc
/// Ignores an attribute
let IgnoreAttribute _ = None

[<return: Struct>]
let (|ExprAsPat|_|) (f: SynExpr) =
match f with
| SingleIdent v1 | SynExprParen(SingleIdent v1, _, _, _) -> Some (mkSynPatVar None v1)
| SingleIdent v1 | SynExprParen(SingleIdent v1, _, _, _) -> ValueSome (mkSynPatVar None v1)
| SynExprParen(SynExpr.Tuple (false, elems, commas, _), _, _, _) ->
let elems = elems |> List.map (|SingleIdent|_|)
if elems |> List.forall (fun x -> x.IsSome) then
Some (SynPat.Tuple(false, (elems |> List.map (fun x -> mkSynPatVar None x.Value)), commas, f.Range))
ValueSome (SynPat.Tuple(false, (elems |> List.map (fun x -> mkSynPatVar None x.Value)), commas, f.Range))
else
None
| _ -> None
ValueNone
| _ -> ValueNone

// For join clauses that join on nullable, we syntactically insert the creation of nullable values on the appropriate side of the condition,
// then pull the syntax apart again
[<return: Struct>]
let (|JoinRelation|_|) cenv env (expr: SynExpr) =
let m = expr.Range
let ad = env.eAccessRights
Expand All @@ -63,23 +65,23 @@ let (|JoinRelation|_|) cenv env (expr: SynExpr) =
| _ -> false

match expr with
| BinOpExpr(opId, a, b) when isOpName opNameEquals cenv.g.equals_operator_vref opId.idText -> Some (a, b)
| BinOpExpr(opId, a, b) when isOpName opNameEquals cenv.g.equals_operator_vref opId.idText -> ValueSome (a, b)

| BinOpExpr(opId, a, b) when isOpName opNameEqualsNullable cenv.g.equals_nullable_operator_vref opId.idText ->

let a = SynExpr.App (ExprAtomicFlag.Atomic, false, mkSynLidGet a.Range [MangledGlobalName;"System"] "Nullable", a, a.Range)
Some (a, b)
ValueSome (a, b)

| BinOpExpr(opId, a, b) when isOpName opNameNullableEquals cenv.g.nullable_equals_operator_vref opId.idText ->

let b = SynExpr.App (ExprAtomicFlag.Atomic, false, mkSynLidGet b.Range [MangledGlobalName;"System"] "Nullable", b, b.Range)
Some (a, b)
ValueSome (a, b)

| BinOpExpr(opId, a, b) when isOpName opNameNullableEqualsNullable cenv.g.nullable_equals_nullable_operator_vref opId.idText ->

Some (a, b)
ValueSome (a, b)

| _ -> None
| _ -> ValueNone

let elimFastIntegerForLoop (spFor, spTo, id, start: SynExpr, dir, finish: SynExpr, innerExpr, m: range) =
let mOp = (unionRanges start.Range finish.Range).MakeSynthetic()
Expand Down Expand Up @@ -161,7 +163,7 @@ let YieldFree (cenv: cenv) expr =
/// Determine if a syntactic expression inside 'seq { ... }' or '[...]' counts as a "simple sequence
/// of semicolon separated values". For example [1;2;3].
/// 'acceptDeprecated' is true for the '[ ... ]' case, where we allow the syntax '[ if g then t else e ]' but ask it to be parenthesized
///
[<return: Struct>]
let (|SimpleSemicolonSequence|_|) cenv acceptDeprecated cexpr =

let IsSimpleSemicolonSequenceElement expr =
Expand Down Expand Up @@ -189,12 +191,12 @@ let (|SimpleSemicolonSequence|_|) cenv acceptDeprecated cexpr =
if IsSimpleSemicolonSequenceElement e1 then
TryGetSimpleSemicolonSequenceOfComprehension e2 (e1 :: acc)
else
None
ValueNone
| _ ->
if IsSimpleSemicolonSequenceElement expr then
Some(List.rev (expr :: acc))
ValueSome(List.rev (expr :: acc))
else
None
ValueNone

TryGetSimpleSemicolonSequenceOfComprehension cexpr []

Expand Down
10 changes: 6 additions & 4 deletions src/Compiler/Checking/CheckExpressions.fs
Original file line number Diff line number Diff line change
Expand Up @@ -3115,15 +3115,17 @@ let BuildRecdFieldSet g m objExpr (rfinfo: RecdFieldInfo) argExpr =
// Helpers dealing with named and optional args at callsites
//-------------------------------------------------------------------------

[<return: Struct>]
let (|BinOpExpr|_|) expr =
match expr with
| SynExpr.App (_, _, SynExpr.App (_, _, SingleIdent opId, a, _), b, _) -> Some (opId, a, b)
| _ -> None
| SynExpr.App (_, _, SynExpr.App (_, _, SingleIdent opId, a, _), b, _) -> ValueSome (opId, a, b)
| _ -> ValueNone

[<return: Struct>]
let (|SimpleEqualsExpr|_|) expr =
match expr with
| BinOpExpr(opId, a, b) when opId.idText = opNameEquals -> Some (a, b)
| _ -> None
| BinOpExpr(opId, a, b) when opId.idText = opNameEquals -> ValueSome (a, b)
| _ -> ValueNone

/// Detect a named argument at a callsite
let TryGetNamedArg expr =
Expand Down
3 changes: 2 additions & 1 deletion src/Compiler/Checking/CheckExpressions.fsi
Original file line number Diff line number Diff line change
Expand Up @@ -712,7 +712,8 @@ val TcMatchPattern:
synWhenExprOpt: SynExpr option ->
Pattern * Expr option * Val list * TcEnv * UnscopedTyparEnv

val (|BinOpExpr|_|): SynExpr -> (Ident * SynExpr * SynExpr) option
[<return: Struct>]
val (|BinOpExpr|_|): SynExpr -> (Ident * SynExpr * SynExpr) voption

/// Check a set of let bindings in a class or module
val TcLetBindings:
Expand Down
95 changes: 55 additions & 40 deletions src/Compiler/Checking/NameResolution.fs
Original file line number Diff line number Diff line change
Expand Up @@ -1739,87 +1739,100 @@ let (|ValRefOfProp|_|) (pi: PropInfo) = pi.ArbitraryValRef
let (|ValRefOfMeth|_|) (mi: MethInfo) = mi.ArbitraryValRef
let (|ValRefOfEvent|_|) (evt: EventInfo) = evt.ArbitraryValRef

[<return: Struct>]
let rec (|RecordFieldUse|_|) (item: Item) =
match item with
| Item.RecdField(RecdFieldInfo(_, RecdFieldRef(tcref, name))) -> Some (name, tcref)
| Item.SetterArg(_, RecordFieldUse f) -> Some f
| _ -> None
| Item.RecdField(RecdFieldInfo(_, RecdFieldRef(tcref, name))) -> ValueSome (name, tcref)
| Item.SetterArg(_, RecordFieldUse f) -> ValueSome f
| _ -> ValueNone

[<return: Struct>]
let (|UnionCaseFieldUse|_|) (item: Item) =
match item with
| Item.UnionCaseField (uci, fieldIndex) -> Some (fieldIndex, uci.UnionCaseRef)
| _ -> None
| Item.UnionCaseField (uci, fieldIndex) -> ValueSome (fieldIndex, uci.UnionCaseRef)
| _ -> ValueNone

[<return: Struct>]
let rec (|ILFieldUse|_|) (item: Item) =
match item with
| Item.ILField finfo -> Some finfo
| Item.SetterArg(_, ILFieldUse f) -> Some f
| _ -> None
| Item.ILField finfo -> ValueSome finfo
| Item.SetterArg(_, ILFieldUse f) -> ValueSome f
| _ -> ValueNone

[<return: Struct>]
let rec (|PropertyUse|_|) (item: Item) =
match item with
| Item.Property(info = pinfo :: _) -> Some pinfo
| Item.SetterArg(_, PropertyUse pinfo) -> Some pinfo
| _ -> None
| Item.Property(info = pinfo :: _) -> ValueSome pinfo
| Item.SetterArg(_, PropertyUse pinfo) -> ValueSome pinfo
| _ -> ValueNone

[<return: Struct>]
let rec (|FSharpPropertyUse|_|) (item: Item) =
match item with
| Item.Property(info = [ValRefOfProp vref]) -> Some vref
| Item.SetterArg(_, FSharpPropertyUse propDef) -> Some propDef
| _ -> None
| Item.Property(info = [ValRefOfProp vref]) -> ValueSome vref
| Item.SetterArg(_, FSharpPropertyUse propDef) -> ValueSome propDef
| _ -> ValueNone

[<return: Struct>]
let (|MethodUse|_|) (item: Item) =
match item with
| Item.MethodGroup(_, [minfo], _) -> Some minfo
| _ -> None
| Item.MethodGroup(_, [minfo], _) -> ValueSome minfo
| _ -> ValueNone

[<return: Struct>]
let (|FSharpMethodUse|_|) (item: Item) =
match item with
| Item.MethodGroup(_, [ValRefOfMeth vref], _) -> Some vref
| Item.Value vref when vref.IsMember -> Some vref
| _ -> None
| Item.MethodGroup(_, [ValRefOfMeth vref], _) -> ValueSome vref
| Item.Value vref when vref.IsMember -> ValueSome vref
| _ -> ValueNone

[<return: Struct>]
let (|EntityUse|_|) (item: Item) =
match item with
| Item.UnqualifiedType (tcref :: _) -> Some tcref
| Item.ExnCase tcref -> Some tcref
| Item.UnqualifiedType (tcref :: _) -> ValueSome tcref
| Item.ExnCase tcref -> ValueSome tcref
| Item.Types(_, [AbbrevOrAppTy tcref])
| Item.DelegateCtor(AbbrevOrAppTy tcref) -> Some tcref
| Item.DelegateCtor(AbbrevOrAppTy tcref) -> ValueSome tcref
| Item.CtorGroup(_, ctor :: _) ->
match ctor.ApparentEnclosingType with
| AbbrevOrAppTy tcref -> Some tcref
| _ -> None
| _ -> None
| AbbrevOrAppTy tcref -> ValueSome tcref
| _ -> ValueNone
| _ -> ValueNone

[<return: Struct>]
let (|EventUse|_|) (item: Item) =
match item with
| Item.Event einfo -> Some einfo
| _ -> None
| Item.Event einfo -> ValueSome einfo
| _ -> ValueNone

[<return: Struct>]
let (|FSharpEventUse|_|) (item: Item) =
match item with
| Item.Event(ValRefOfEvent vref) -> Some vref
| _ -> None
| Item.Event(ValRefOfEvent vref) -> ValueSome vref
| _ -> ValueNone

[<return: Struct>]
let (|UnionCaseUse|_|) (item: Item) =
match item with
| Item.UnionCase(UnionCaseInfo(_, u1), _) -> Some u1
| _ -> None
| Item.UnionCase(UnionCaseInfo(_, u1), _) -> ValueSome u1
| _ -> ValueNone

[<return: Struct>]
let (|ValUse|_|) (item: Item) =
match item with
| Item.Value vref
| FSharpPropertyUse vref
| FSharpMethodUse vref
| FSharpEventUse vref
| Item.CustomBuilder(_, vref) -> Some vref
| _ -> None
| Item.CustomBuilder(_, vref) -> ValueSome vref
| _ -> ValueNone

[<return: Struct>]
let (|ActivePatternCaseUse|_|) (item: Item) =
match item with
| Item.ActivePatternCase(APElemRef(_, vref, idx, _)) -> Some (vref.SigRange, vref.DefinitionRange, idx)
| Item.ActivePatternResult(ap, _, idx, _) -> Some (ap.Range, ap.Range, idx)
| _ -> None
| Item.ActivePatternCase(APElemRef(_, vref, idx, _)) -> ValueSome (vref.SigRange, vref.DefinitionRange, idx)
| Item.ActivePatternResult(ap, _, idx, _) -> ValueSome (ap.Range, ap.Range, idx)
| _ -> ValueNone

let tyconRefDefnHash (_g: TcGlobals) (eref1: EntityRef) =
hash eref1.LogicalName
Expand Down Expand Up @@ -2840,9 +2853,10 @@ let private ResolveLongIdentInTyconRefs atMostOne (ncenv: NameResolver) nenv loo
// ResolveExprLongIdentInModuleOrNamespace
//-------------------------------------------------------------------------

[<return: Struct>]
let (|AccessibleEntityRef|_|) amap m ad (modref: ModuleOrNamespaceRef) mspec =
let eref = modref.NestedTyconRef mspec
if IsEntityAccessible amap m ad eref then Some eref else None
if IsEntityAccessible amap m ad eref then ValueSome eref else ValueNone

let rec ResolveExprLongIdentInModuleOrNamespace (ncenv: NameResolver) nenv (typeNameResInfo: TypeNameResolutionInfo) ad resInfo depth m modref (mty: ModuleOrNamespaceType) (id: Ident) (rest: Ident list) =
// resInfo records the modules or namespaces actually relevant to a resolution
Expand Down Expand Up @@ -4088,11 +4102,12 @@ let ResolveLongIdentAsExprAndComputeRange (sink: TcResultsSink) (ncenv: NameReso

success (tinstEnclosing, item, itemRange, rest, afterResolution)

[<return: Struct>]
let (|NonOverridable|_|) namedItem =
match namedItem with
| Item.MethodGroup(_, minfos, _) when minfos |> List.exists(fun minfo -> minfo.IsVirtual || minfo.IsAbstract) -> None
| Item.Property(info = pinfos) when pinfos |> List.exists(fun pinfo -> pinfo.IsVirtualProperty) -> None
| _ -> Some ()
| Item.MethodGroup(_, minfos, _) when minfos |> List.exists(fun minfo -> minfo.IsVirtual || minfo.IsAbstract) -> ValueNone
| Item.Property(info = pinfos) when pinfos |> List.exists(fun pinfo -> pinfo.IsVirtualProperty) -> ValueNone
| _ -> ValueSome ()

/// Called for 'expression.Bar' - for VS IntelliSense, we can filter out static members from method groups
/// Also called for 'GenericType<Args>.Bar' - for VS IntelliSense, we can filter out non-static members from method groups
Expand Down
15 changes: 9 additions & 6 deletions src/Compiler/Checking/PatternMatchCompilation.fs
Original file line number Diff line number Diff line change
Expand Up @@ -740,19 +740,22 @@ let ChooseInvestigationPointLeftToRight frontiers =
// This is an initial attempt to remove extra typetests/castclass for simple list pattern matching "match x with h :: t -> ... | [] -> ..."
// The problem with this technique is that it creates extra locals which inhibit the process of converting pattern matches into linear let bindings.

[<return: Struct>]
let (|ListConsDiscrim|_|) g = function
| (DecisionTreeTest.UnionCase (ucref, tinst))
(* check we can use a simple 'isinst' instruction *)
when tyconRefEq g ucref.TyconRef g.list_tcr_canon & ucref.CaseName = "op_ColonColon" -> Some tinst
| _ -> None
when tyconRefEq g ucref.TyconRef g.list_tcr_canon & ucref.CaseName = "op_ColonColon" -> ValueSome tinst
| _ -> ValueNone

[<return: Struct>]
let (|ListEmptyDiscrim|_|) g = function
| (DecisionTreeTest.UnionCase (ucref, tinst))
(* check we can use a simple 'isinst' instruction *)
when tyconRefEq g ucref.TyconRef g.list_tcr_canon & ucref.CaseName = "op_Nil" -> Some tinst
| _ -> None
when tyconRefEq g ucref.TyconRef g.list_tcr_canon & ucref.CaseName = "op_Nil" -> ValueSome tinst
| _ -> ValueNone
#endif

[<return: Struct>]
let (|ConstNeedsDefaultCase|_|) c =
match c with
| Const.Decimal _
Expand All @@ -767,8 +770,8 @@ let (|ConstNeedsDefaultCase|_|) c =
| Const.UInt64 _
| Const.IntPtr _
| Const.UIntPtr _
| Const.Char _ -> Some ()
| _ -> None
| Const.Char _ -> ValueSome ()
| _ -> ValueNone

/// Build a dtree, equivalent to: TDSwitch("expr", edges, default, m)
///
Expand Down
22 changes: 13 additions & 9 deletions src/Compiler/Checking/QuotationTranslator.fs
Original file line number Diff line number Diff line change
Expand Up @@ -167,33 +167,37 @@ exception IgnoringPartOfQuotedTermWarning of string * range

let wfail e = raise (InvalidQuotedTerm e)

[<return: Struct>]
let (|ModuleValueOrMemberUse|_|) g expr =
let rec loop expr args =
match stripExpr expr with
| Expr.App (InnerExprPat(Expr.Val (vref, vFlags, _) as f), fty, tyargs, actualArgs, _m) when vref.IsMemberOrModuleBinding ->
Some(vref, vFlags, f, fty, tyargs, actualArgs @ args)
ValueSome(vref, vFlags, f, fty, tyargs, actualArgs @ args)
| Expr.App (f, _fTy, [], actualArgs, _) ->
loop f (actualArgs @ args)
| Expr.Val (vref, vFlags, _m) as f when (match vref.TryDeclaringEntity with ParentNone -> false | _ -> true) ->
let fty = tyOfExpr g f
Some(vref, vFlags, f, fty, [], args)
ValueSome(vref, vFlags, f, fty, [], args)
| _ ->
None
ValueNone
loop expr []

[<return: Struct>]
let (|SimpleArrayLoopUpperBound|_|) expr =
match expr with
| Expr.Op (TOp.ILAsm ([AI_sub], _), _, [Expr.Op (TOp.ILAsm ([I_ldlen; AI_conv ILBasicType.DT_I4], _), _, _, _); Expr.Const (Const.Int32 1, _, _) ], _) -> Some ()
| _ -> None
| Expr.Op (TOp.ILAsm ([AI_sub], _), _, [Expr.Op (TOp.ILAsm ([I_ldlen; AI_conv ILBasicType.DT_I4], _), _, _, _); Expr.Const (Const.Int32 1, _, _) ], _) -> ValueSome ()
| _ -> ValueNone

[<return: Struct>]
let (|SimpleArrayLoopBody|_|) g expr =
match expr with
| Expr.Lambda (_, a, b, ([_] as args), DebugPoints (Expr.Let (TBind(forVarLoop, DebugPoints (Expr.Op (TOp.ILAsm ([I_ldelem_any(ILArrayShape [(Some 0, None)], _)], _), [elemTy], [arr; idx], m1), _), seqPoint), body, m2, freeVars), _), m, ty) ->
let body = Expr.Let (TBind(forVarLoop, mkCallArrayGet g m1 elemTy arr idx, seqPoint), body, m2, freeVars)
let expr = Expr.Lambda (newUnique(), a, b, args, body, m, ty)
Some (arr, elemTy, expr)
| _ -> None
ValueSome (arr, elemTy, expr)
| _ -> ValueNone

[<return: Struct>]
let (|ObjectInitializationCheck|_|) g expr =
// recognize "if this.init@ < 1 then failinit"
match expr with
Expand All @@ -207,8 +211,8 @@ let (|ObjectInitializationCheck|_|) g expr =
name.StartsWithOrdinal("init") &&
selfRef.IsMemberThisVal &&
valRefEq g failInitRef (ValRefForIntrinsic g.fail_init_info) &&
isUnitTy g resultTy -> Some()
| _ -> None
isUnitTy g resultTy -> ValueSome()
| _ -> ValueNone

let isSplice g vref = valRefEq g vref g.splice_expr_vref || valRefEq g vref g.splice_raw_expr_vref

Expand Down
15 changes: 11 additions & 4 deletions src/Compiler/Checking/QuotationTranslator.fsi
Original file line number Diff line number Diff line change
Expand Up @@ -41,10 +41,17 @@ val ConvExprPublic: QuotationGenerationScope -> suppressWitnesses: bool -> Expr
val ConvReflectedDefinition:
QuotationGenerationScope -> string -> Val -> Expr -> QuotationPickler.MethodBaseData * QuotationPickler.ExprData

[<return: Struct>]
val (|ModuleValueOrMemberUse|_|):
TcGlobals -> Expr -> (ValRef * ValUseFlag * Expr * TType * TypeInst * Expr list) option
TcGlobals -> Expr -> (ValRef * ValUseFlag * Expr * TType * TypeInst * Expr list) voption

[<return: Struct>]
val (|SimpleArrayLoopUpperBound|_|): Expr -> unit voption

[<return: Struct>]
val (|SimpleArrayLoopBody|_|): TcGlobals -> Expr -> (Expr * TType * Expr) voption

[<return: Struct>]
val (|ObjectInitializationCheck|_|): TcGlobals -> Expr -> unit voption

val (|SimpleArrayLoopUpperBound|_|): Expr -> unit option
val (|SimpleArrayLoopBody|_|): TcGlobals -> Expr -> (Expr * TType * Expr) option
val (|ObjectInitializationCheck|_|): TcGlobals -> Expr -> unit option
val isSplice: TcGlobals -> ValRef -> bool
Loading

0 comments on commit c501700

Please sign in to comment.