Skip to content

Commit b3df14c

Browse files
dsymeKevinRansom
dsyme
authored and
KevinRansom
committed
Fix for anonymous record execution order (#6606)
* start of fix * fix anon recd construction * fix test * add tests, fix tests * add tests, fix tests
1 parent 028d118 commit b3df14c

File tree

4 files changed

+151
-54
lines changed

4 files changed

+151
-54
lines changed

‎src/fsharp/TastOps.fs‎

Lines changed: 25 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -6492,8 +6492,6 @@ let mkRefTupledNoTypes g m args = mkRefTupled g m args (List.map (tyOfExpr g) ar
64926492

64936493
let mkRefTupledVars g m vs = mkRefTupled g m (List.map (exprForVal m) vs) (typesOfVals vs)
64946494

6495-
let mkAnonRecd (_g: TcGlobals) m anonInfo es tys = Expr.Op (TOp.AnonRecd anonInfo,tys,es,m)
6496-
64976495
//--------------------------------------------------------------------------
64986496
// Permute expressions
64996497
//--------------------------------------------------------------------------
@@ -6554,21 +6552,35 @@ let permuteExprList (sigma: int[]) (exprs: Expr list) (ty: TType list) (names: s
65546552
/// let sigma = Array.map #Index ()
65556553
/// However the presence of static fields means .Index may index into a non-compact set of instance field indexes.
65566554
/// We still need to sort by index.
6557-
let mkRecordExpr g (lnk, tcref, tinst, rfrefs: RecdFieldRef list, args, m) =
6555+
let mkRecordExpr g (lnk, tcref, tinst, unsortedRecdFields: RecdFieldRef list, unsortedFieldExprs, m) =
65586556
// Remove any abbreviations
65596557
let tcref, tinst = destAppTy g (mkAppTy tcref tinst)
65606558

6561-
let rfrefsArray = rfrefs |> List.indexed |> Array.ofList
6562-
rfrefsArray |> Array.sortInPlaceBy (fun (_, r) -> r.Index)
6563-
let sigma = Array.create rfrefsArray.Length -1
6564-
Array.iteri (fun j (i, _) ->
6565-
if sigma.[i] <> -1 then error(InternalError("bad permutation", m))
6566-
sigma.[i] <- j) rfrefsArray
6559+
let sortedRecdFields = unsortedRecdFields |> List.indexed |> Array.ofList |> Array.sortBy (fun (_, r) -> r.Index)
6560+
let sigma = Array.create sortedRecdFields.Length -1
6561+
sortedRecdFields |> Array.iteri (fun sortedIdx (unsortedIdx, _) ->
6562+
if sigma.[unsortedIdx] <> -1 then error(InternalError("bad permutation", m))
6563+
sigma.[unsortedIdx] <- sortedIdx)
6564+
6565+
let unsortedArgTys = unsortedRecdFields |> List.map (fun rfref -> actualTyOfRecdFieldRef rfref tinst)
6566+
let unsortedArgNames = unsortedRecdFields |> List.map (fun rfref -> rfref.FieldName)
6567+
let unsortedArgBinds, sortedArgExprs = permuteExprList sigma unsortedFieldExprs unsortedArgTys unsortedArgNames
6568+
let core = Expr.Op (TOp.Recd (lnk, tcref), tinst, sortedArgExprs, m)
6569+
mkLetsBind m unsortedArgBinds core
6570+
6571+
let mkAnonRecd (_g: TcGlobals) m (anonInfo: AnonRecdTypeInfo) (unsortedIds: Ident[]) (unsortedFieldExprs: Expr list) unsortedArgTys =
6572+
let sortedRecdFields = unsortedFieldExprs |> List.indexed |> Array.ofList |> Array.sortBy (fun (i,_) -> unsortedIds.[i].idText)
6573+
let sortedArgTys = unsortedArgTys |> List.indexed |> List.sortBy (fun (i,_) -> unsortedIds.[i].idText) |> List.map snd
6574+
6575+
let sigma = Array.create sortedRecdFields.Length -1
6576+
sortedRecdFields |> Array.iteri (fun sortedIdx (unsortedIdx, _) ->
6577+
if sigma.[unsortedIdx] <> -1 then error(InternalError("bad permutation", m))
6578+
sigma.[unsortedIdx] <- sortedIdx)
65676579

6568-
let argTys = List.map (fun rfref -> actualTyOfRecdFieldRef rfref tinst) rfrefs
6569-
let names = rfrefs |> List.map (fun rfref -> rfref.FieldName)
6570-
let binds, args = permuteExprList sigma args argTys names
6571-
mkLetsBind m binds (Expr.Op (TOp.Recd (lnk, tcref), tinst, args, m))
6580+
let unsortedArgNames = unsortedIds |> Array.toList |> List.map (fun id -> id.idText)
6581+
let unsortedArgBinds, sortedArgExprs = permuteExprList sigma unsortedFieldExprs unsortedArgTys unsortedArgNames
6582+
let core = Expr.Op (TOp.AnonRecd anonInfo, sortedArgTys, sortedArgExprs, m)
6583+
mkLetsBind m unsortedArgBinds core
65726584

65736585
//-------------------------------------------------------------------------
65746586
// List builders

‎src/fsharp/TastOps.fsi‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2120,7 +2120,7 @@ val mkMethodTy : TcGlobals -> TType list list -> TType -> TType
21202120

21212121
val mkAnyAnonRecdTy : TcGlobals -> AnonRecdTypeInfo -> TType list -> TType
21222122

2123-
val mkAnonRecd : TcGlobals -> range -> AnonRecdTypeInfo -> Exprs -> TType list -> Expr
2123+
val mkAnonRecd : TcGlobals -> range -> AnonRecdTypeInfo -> Ident[] -> Exprs -> TType list -> Expr
21242124

21252125
val AdjustValForExpectedArity : TcGlobals -> range -> ValRef -> ValUseFlag -> ValReprInfo -> Expr * TType
21262126

‎src/fsharp/TypeChecker.fs‎

Lines changed: 79 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -4673,11 +4673,11 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv: SyntacticUnscope
46734673
| SynType.AnonRecd(isStruct, args,m) ->
46744674
let tupInfo = mkTupInfo isStruct
46754675
let args',tpenv = TcTypesAsTuple cenv newOk checkCxs occ env tpenv (args |> List.map snd |> List.map (fun x -> (false,x))) m
4676-
let unsortedIds = args |> List.map fst |> List.toArray
4677-
let anonInfo = AnonRecdTypeInfo.Create(cenv.topCcu, tupInfo, unsortedIds)
4676+
let unsortedFieldIds = args |> List.map fst |> List.toArray
4677+
let anonInfo = AnonRecdTypeInfo.Create(cenv.topCcu, tupInfo, unsortedFieldIds)
46784678
// Sort into canonical order
4679-
let sortedArgTys, sortedCheckedArgTys = List.zip args args' |> List.indexed |> List.sortBy (fun (i,_) -> unsortedIds.[i].idText) |> List.map snd |> List.unzip
4680-
sortedArgTys |> List.iteri (fun i (x,_) ->
4679+
let sortedFieldTys, sortedCheckedArgTys = List.zip args args' |> List.indexed |> List.sortBy (fun (i,_) -> unsortedFieldIds.[i].idText) |> List.map snd |> List.unzip
4680+
sortedFieldTys |> List.iteri (fun i (x,_) ->
46814681
let item = Item.AnonRecdField(anonInfo, sortedCheckedArgTys, i, x.idRange)
46824682
CallNameResolutionSink cenv.tcSink (x.idRange,env.NameEnv,item,item,emptyTyparInst,ItemOccurence.UseInType,env.DisplayEnv,env.eAccessRights))
46834683
TType_anon(anonInfo, sortedCheckedArgTys),tpenv
@@ -5879,8 +5879,8 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) =
58795879
let expr = mkAnyTupled cenv.g m tupInfo args' argTys
58805880
expr, tpenv
58815881

5882-
| SynExpr.AnonRecd (isStruct, optOrigExpr, unsortedArgs, mWholeExpr) ->
5883-
TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigExpr, unsortedArgs, mWholeExpr)
5882+
| SynExpr.AnonRecd (isStruct, optOrigExpr, unsortedFieldExprs, mWholeExpr) ->
5883+
TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigExpr, unsortedFieldExprs, mWholeExpr)
58845884

58855885
| SynExpr.ArrayOrList (isArray, args, m) ->
58865886
CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.DisplayEnv, env.eAccessRights)
@@ -7036,26 +7036,39 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr
70367036

70377037

70387038
// Check '{| .... |}'
7039-
and TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigExpr, unsortedArgs, mWholeExpr) =
7039+
and TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigSynExpr, unsortedFieldIdsAndSynExprsGiven, mWholeExpr) =
7040+
let unsortedFieldSynExprsGiven = List.map snd unsortedFieldIdsAndSynExprsGiven
70407041

7041-
match optOrigExpr with
7042+
match optOrigSynExpr with
70427043
| None ->
7043-
let unsortedIds = unsortedArgs |> List.map fst |> List.toArray
7044-
let anonInfo, sortedArgTys = UnifyAnonRecdTypeAndInferCharacteristics env.eContextInfo cenv env.DisplayEnv mWholeExpr overallTy isStruct unsortedIds
7044+
let unsortedFieldIds = unsortedFieldIdsAndSynExprsGiven |> List.map fst |> List.toArray
7045+
let anonInfo, sortedFieldTys = UnifyAnonRecdTypeAndInferCharacteristics env.eContextInfo cenv env.DisplayEnv mWholeExpr overallTy isStruct unsortedFieldIds
70457046

70467047
// Sort into canonical order
7047-
let sortedIndexedArgs = unsortedArgs |> List.indexed |> List.sortBy (fun (i,_) -> unsortedIds.[i].idText)
7048+
let sortedIndexedArgs =
7049+
unsortedFieldIdsAndSynExprsGiven
7050+
|> List.indexed
7051+
|> List.sortBy (fun (i,_) -> unsortedFieldIds.[i].idText)
7052+
7053+
// Map from sorted indexes to unsorted indexes
70487054
let sigma = List.map fst sortedIndexedArgs |> List.toArray
7049-
let sortedArgs = List.map snd sortedIndexedArgs
7050-
sortedArgs |> List.iteri (fun j (x, _) ->
7051-
let item = Item.AnonRecdField(anonInfo, sortedArgTys, j, x.idRange)
7055+
let sortedFieldExprs = List.map snd sortedIndexedArgs
7056+
7057+
sortedFieldExprs |> List.iteri (fun j (x, _) ->
7058+
let item = Item.AnonRecdField(anonInfo, sortedFieldTys, j, x.idRange)
70527059
CallNameResolutionSink cenv.tcSink (x.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights))
7053-
let unsortedArgTys = sortedArgTys |> List.indexed |> List.sortBy (fun (j, _) -> sigma.[j]) |> List.map snd
7054-
let flexes = unsortedArgTys |> List.map (fun _ -> true)
7055-
let unsortedCheckedArgs, tpenv = TcExprs cenv env mWholeExpr tpenv flexes unsortedArgTys (List.map snd unsortedArgs)
7056-
let sortedCheckedArgs = unsortedCheckedArgs |> List.indexed |> List.sortBy (fun (i,_) -> unsortedIds.[i].idText) |> List.map snd
70577060

7058-
mkAnonRecd cenv.g mWholeExpr anonInfo sortedCheckedArgs sortedArgTys, tpenv
7061+
let unsortedFieldTys =
7062+
sortedFieldTys
7063+
|> List.indexed
7064+
|> List.sortBy (fun (sortedIdx, _) -> sigma.[sortedIdx])
7065+
|> List.map snd
7066+
7067+
let flexes = unsortedFieldTys |> List.map (fun _ -> true)
7068+
7069+
let unsortedCheckedArgs, tpenv = TcExprs cenv env mWholeExpr tpenv flexes unsortedFieldTys unsortedFieldSynExprsGiven
7070+
7071+
mkAnonRecd cenv.g mWholeExpr anonInfo unsortedFieldIds unsortedCheckedArgs unsortedFieldTys, tpenv
70597072

70607073
| Some (origExpr, _) ->
70617074
// The fairly complex case '{| origExpr with X = 1; Y = 2 |}'
@@ -7088,7 +7101,7 @@ and TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigExpr, unsortedArgs
70887101
/// - Choice1Of2 for a new binding
70897102
/// - Choice2Of2 for a binding coming from the original expression
70907103
let unsortedIdAndExprsAll =
7091-
[| for (id, e) in unsortedArgs do
7104+
[| for (id, e) in unsortedFieldIdsAndSynExprsGiven do
70927105
yield (id, Choice1Of2 e)
70937106
match tryDestAnonRecdTy cenv.g origExprTy with
70947107
| ValueSome (anonInfo, tinst) ->
@@ -7104,32 +7117,61 @@ and TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigExpr, unsortedArgs
71047117
error (Error (FSComp.SR.tcCopyAndUpdateNeedsRecordType(), mOrigExpr)) |]
71057118
|> Array.distinctBy (fst >> textOfId)
71067119

7107-
let unsortedIdsAll = Array.map fst unsortedIdAndExprsAll
7108-
let anonInfo, sortedArgTysAll = UnifyAnonRecdTypeAndInferCharacteristics env.eContextInfo cenv env.DisplayEnv mWholeExpr overallTy isStruct unsortedIdsAll
7109-
let sortedIndexedArgsAll = unsortedIdAndExprsAll |> Array.indexed |> Array.sortBy (snd >> fst >> textOfId)
7110-
let sigma = Array.map fst sortedIndexedArgsAll // map from sorted indexes to unsorted indexes
7111-
let sortedArgsAll = Array.map snd sortedIndexedArgsAll
7112-
sortedArgsAll |> Array.iteri (fun j (x, expr) ->
7120+
let unsortedFieldIdsAll = Array.map fst unsortedIdAndExprsAll
7121+
7122+
let anonInfo, sortedFieldTysAll = UnifyAnonRecdTypeAndInferCharacteristics env.eContextInfo cenv env.DisplayEnv mWholeExpr overallTy isStruct unsortedFieldIdsAll
7123+
7124+
let sortedIndexedFieldsAll = unsortedIdAndExprsAll |> Array.indexed |> Array.sortBy (snd >> fst >> textOfId)
7125+
7126+
// map from sorted indexes to unsorted indexes
7127+
let sigma = Array.map fst sortedIndexedFieldsAll
7128+
7129+
let sortedFieldsAll = Array.map snd sortedIndexedFieldsAll
7130+
7131+
// Report _all_ identifiers to name resolution. We should likely just report the ones
7132+
// that are explicit in source code.
7133+
sortedFieldsAll |> Array.iteri (fun j (x, expr) ->
71137134
match expr with
71147135
| Choice1Of2 _ ->
7115-
let item = Item.AnonRecdField(anonInfo, sortedArgTysAll, j, x.idRange)
7136+
let item = Item.AnonRecdField(anonInfo, sortedFieldTysAll, j, x.idRange)
71167137
CallNameResolutionSink cenv.tcSink (x.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights)
71177138
| Choice2Of2 _ -> ())
71187139

7119-
let unsortedArgTysNew = sortedArgTysAll |> List.indexed |> List.sortBy (fun (j, _) -> sigma.[j]) |> List.take unsortedArgs.Length |> List.map snd
7120-
let flexes = unsortedArgTysNew |> List.map (fun _ -> true)
7140+
let unsortedFieldTysAll =
7141+
sortedFieldTysAll
7142+
|> List.indexed
7143+
|> List.sortBy (fun (sortedIdx, _) -> sigma.[sortedIdx])
7144+
|> List.map snd
7145+
7146+
let unsortedFieldTysGiven =
7147+
unsortedFieldTysAll
7148+
|> List.take unsortedFieldIdsAndSynExprsGiven.Length
7149+
7150+
let flexes = unsortedFieldTysGiven |> List.map (fun _ -> true)
71217151

7122-
let unsortedCheckedArgsNew, tpenv = TcExprs cenv env mWholeExpr tpenv flexes unsortedArgTysNew (List.map snd unsortedArgs)
7123-
let sortedArgTysAllArray = Array.ofList sortedArgTysAll
7124-
let unsortedCheckedArgsNewArray = unsortedCheckedArgsNew |> List.toArray
7125-
let sortedCheckedArgsAll =
7126-
sortedArgsAll |> Array.mapi (fun j (_, expr) ->
7152+
// Check the expressions in unsorted order
7153+
let unsortedFieldExprsGiven, tpenv =
7154+
TcExprs cenv env mWholeExpr tpenv flexes unsortedFieldTysGiven unsortedFieldSynExprsGiven
7155+
7156+
let unsortedFieldExprsGiven = unsortedFieldExprsGiven |> List.toArray
7157+
7158+
let unsortedFieldIds =
7159+
unsortedIdAndExprsAll
7160+
|> Array.map fst
7161+
7162+
let unsortedFieldExprs =
7163+
unsortedIdAndExprsAll
7164+
|> Array.mapi (fun unsortedIdx (_, expr) ->
71277165
match expr with
7128-
| Choice1Of2 _ -> unsortedCheckedArgsNewArray.[sigma.[j]]
7129-
| Choice2Of2 subExpr -> UnifyTypes cenv env mOrigExpr (tyOfExpr cenv.g subExpr) sortedArgTysAllArray.[j]; subExpr)
7166+
| Choice1Of2 _ -> unsortedFieldExprsGiven.[unsortedIdx]
7167+
| Choice2Of2 subExpr -> UnifyTypes cenv env mOrigExpr (tyOfExpr cenv.g subExpr) unsortedFieldTysAll.[unsortedIdx]; subExpr)
7168+
|> List.ofArray
71307169

7131-
let expr = mkAnonRecd cenv.g mWholeExpr anonInfo (List.ofArray sortedCheckedArgsAll) sortedArgTysAll
7170+
// Permute the expressions to sorted order in the TAST
7171+
let expr = mkAnonRecd cenv.g mWholeExpr anonInfo unsortedFieldIds unsortedFieldExprs unsortedFieldTysAll
71327172
let expr = wrap expr
7173+
7174+
// Bind the original expression
71337175
let expr = mkCompGenLet mOrigExpr oldv origExprChecked expr
71347176
expr, tpenv
71357177

‎tests/fsharp/core/anon/lib.fs‎

Lines changed: 46 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,7 @@ let test (s : string) b =
1717
let check (s:string) x1 x2 =
1818
stderr.Write(s)
1919
if (x1 = x2) then stderr.WriteLine " OK"
20-
else (stderr.WriteLine (sprintf "fail, expected %A, got %A" x2 x1); report_failure (s))
20+
else (stderr.WriteLine (sprintf " failed, expected %A, got %A" x2 x1); report_failure (s))
2121

2222
let inline getX (x: ^TX) : ^X =
2323
(^TX : (member get_X : unit -> ^X) (x))
@@ -205,13 +205,56 @@ module QuotesNewRecord2 =
205205

206206
open FSharp.Quotations
207207
open FSharp.Quotations.Patterns
208-
let ty, args = match <@ {| Y = "two"; X = 1 |} @> with NewRecord(a,b) -> a,b
208+
let yarg,ty, args = match <@ {| Y = "two"; X = 1 |} @> with Let(_,yarg,NewRecord(a,b)) -> yarg,a,b
209209

210210
check "qgceoijew90ewcw1" (FSharp.Reflection.FSharpType.IsRecord(ty)) true
211211
check "qgceoijew90ewcw2" (FSharp.Reflection.FSharpType.GetRecordFields(ty).Length) 2
212212
// Fields are sorted
213213
check "qgceoijew90ewcw2" ([ for p in FSharp.Reflection.FSharpType.GetRecordFields(ty) -> p.Name ]) [ "X"; "Y" ]
214-
check "qgceoijew90ewcw3" args [ <@@ 1 @@>; <@@ "two" @@> ]
214+
check "qgceoijew90ewcw3" args.[0] <@@ 1 @@>
215+
check "qgceoijew90ewcw4" yarg <@@ "two" @@>
216+
217+
module QuotesFieldInitOrder =
218+
219+
let mutable x = 1
220+
let test() =
221+
x <- 1
222+
{| X = (check "clwknckl1" x 1; x <- x + 1; 3)
223+
Y = (check "cwkencelwe2" x 2; x <- x + 1; 2)
224+
|} |> check "ceweoiwe1" {| Y=2; X=3 |}
225+
x <- 1
226+
{| X = (check "clwknckl3" x 1; x <- x + 1; 2)
227+
W = (check "cwkencelwe4" x 2; x <- x + 1; 3)
228+
|} |> check "ceweoiwe2" {| W=3; X=2 |}
229+
x <- 1
230+
{| X = (check "clwknckl5" x 1; x <- x + 1; 2)
231+
Y = (check "clwknckl6" x 2; x <- x + 1; 3)
232+
W = (check "cwkencelwe7" x 3; x <- x + 1; 4) |}
233+
|> check "ceweoiwe" {| Y=3; X=2; W=4 |}
234+
x <- 1
235+
let a =
236+
{| Y = (check "clwknckl8" x 1; x <- x + 1; 2)
237+
X = (check "clwknckl9" x 2; x <- x + 1; 3)
238+
W = (check "cwkencel10" x 3; x <- x + 1; 4)
239+
|}
240+
a |> check "ceweoiwe" {| Y=2; X=3; W=4 |}
241+
x <- 1
242+
let b =
243+
{| a with
244+
X = (check "clwknckl9" x 1; x <- x + 1; 6)
245+
W = (check "cwkencel10" x 2; x <- x + 1; 7)
246+
|}
247+
b |> check "ceweoiwe87" {| Y=2; X=6; W=7 |}
248+
x <- 1
249+
let c =
250+
{| a with
251+
X = (check "clwknckl9" x 1; x <- x + 1; 6)
252+
A = (check "cwkencel11" x 2; x <- x + 1; 8)
253+
W = (check "cwkencel10" x 3; x <- x + 1; 7)
254+
|}
255+
c |> check "ceweoiwe87" {| Y=2; X=6; W=7; A=8 |}
256+
test()
257+
215258

216259
module QuotesPropertyGet =
217260

0 commit comments

Comments
 (0)