Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

fix 212 - record initialization order #444

Closed
wants to merge 2 commits into from
Closed

fix 212 - record initialization order #444

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
2ec23c1
fix 212 - record initialization order
dsyme May 12, 2015
fb8a73e
fix 212 - enable tests properly
dsyme May 12, 2015
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
72 changes: 31 additions & 41 deletions src/fsharp/tastops.fs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -5807,51 +5807,41 @@ let permute (sigma:int[]) (data:'T[]) =

let rec existsR a b pred = if a<=b then pred a || existsR (a+1) b pred else false

let mapFoldListi f z xs =
let rec fmapi f i z l =
match l with
| [] -> z,[]
| x::xs -> let z,x = f i z x
let z,xs = fmapi f (i+1) z xs
z,x::xs
fmapi f 0 z xs

/// Given expr = xi = [| x0; ... xN |]
/// Given sigma a permutation to apply to the xi.
/// Return (bindings',expr') such that:
/// (a) xi are permutated under sigma, xi -> position sigma(i).
///------
/// Motivation:
/// opt.fs - put record field assignments in order under known effect information
/// ilxgen.fs - put record field assignments in order if necessary (no optimisations)
/// under unknown-effect information.
let permuteExpr (sigma:int[]) (expr: Expr[]) (typ: TType[]) (names:string[]) =
// Given a permutation for record fields, work out the highest entry that we must lift out
// of a record initialization. Lift out xi if xi goes to position that will be preceded by an expr with an effect
// that originally followed xi. If one entry gets lifted then everything before it also gets lifted.
let liftAllBefore sigma =
let invSigma = inversePerm sigma
let liftPosition i =
// Lift out xi if
// LC2: xi goes to position that will be preceded by
// an expr with an effect that originally followed xi
let i' = sigma.[i]
existsR 0 (i' - 1) (fun j' -> invSigma.[j'] > i)

let rewrite i rbinds (xi:Expr) =
if liftPosition i then
let tmpv,tmpe = mkCompGenLocal xi.Range names.[i] typ.[i]
let bind = mkCompGenBind tmpv xi
bind :: rbinds,tmpe

let lifted =
[ for i in 0 .. sigma.Length - 1 do
let i' = sigma.[i]
if existsR 0 (i' - 1) (fun j' -> invSigma.[j'] > i) then
yield i ]

if lifted.IsEmpty then 0 else List.max lifted + 1


/// Put record field assignments in order.
//
let permuteExprList (sigma:int[]) (exprs: Expr list) (typ: TType list) (names:string list) =
let typ,names = (Array.ofList typ, Array.ofList names)

let liftLim = liftAllBefore sigma

let rewrite rbinds (i, expri:Expr) =
if i < liftLim then
let tmpvi,tmpei = mkCompGenLocal expri.Range names.[i] typ.[i]
let bindi = mkCompGenBind tmpvi expri
tmpei, bindi :: rbinds
else
rbinds,xi
expri, rbinds

let xis = Array.toList expr
let rbinds,xis = mapFoldListi rewrite [] xis
let binds = List.rev rbinds
let expr = permute sigma (Array.ofList xis)
binds,expr
let newExprs, reversedBinds = List.mapFold rewrite [] (exprs |> List.mapi (fun i x -> (i,x)))
let binds = List.rev reversedBinds
let reorderedExprs = permute sigma (Array.ofList newExprs)
binds,Array.toList reorderedExprs

let permuteExprList (sigma:int array) (expr: Expr list) (typ: TType list) (names:string list) =
let binds,expr = permuteExpr sigma (Array.ofList expr) (Array.ofList typ) (Array.ofList names)
binds,Array.toList expr

//-------------------------------------------------------------------------
// Build record expressions...
//-------------------------------------------------------------------------
Expand Down
190 changes: 188 additions & 2 deletions tests/fsharp/core/apporder/test.fsx
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,7 @@ module Core_apporder
#light
let failures = ref false
let report_failure (s) =
stderr.WriteLine ("NO: " + s); failures := true; failwith ""
stderr.WriteLine ("NO: " + s); failures := true
let test s b = if b then () else report_failure(s)

(* TEST SUITE FOR Int32 *)
Expand All @@ -15,7 +15,7 @@ let out r (s:string) = r := !r @ [s]

let check s v1 v2 =
if v1 = v2 then printfn "%s: OK" s
else printfn "%s: FAILED, expected %A, got %A" s v2 v1
else report_failure (sprintf "%s: FAILED, expected %A, got %A" s v2 v1)

module CheckMutationOfArgumentValuesInOtherArguments =
let test1232() =
Expand Down Expand Up @@ -930,6 +930,192 @@ module MemberAppOrder =
check "cwkneccewi" state [3;2;5;4]
check "nvroirv" (sprintf "%d %d %d %d %d" foo.A foo.B foo.X foo.Y foo.Z) "4 5 3 2 99"

type RecordWithInts =
{ A : int
B : int
C : int }

module OrderOfRecordInitialisation =

let expected =
{ A = 1
B = 2
C = 3 }

let ShouldInitialzeInGivenOrder1 =
let order = ref ""
let actual =
{ A = let _ = order := !order + "1" in 1
B = let _ = order := !order + "2" in 2
C = let _ = order := !order + "3" in 3 }

check "cnclewlecp2" expected actual
check "ceiewoi" "123" !order

let ShouldInitialzeInGivenOrder2 =
let order = ref ""
let actual =
{ A = let _ = order := !order + "1" in 1
C = let _ = order := !order + "2" in 3
B = let _ = order := !order + "3" in 2 }

check "cd33289e0ewn1" expected actual
check "ewlknewv90we2" "123" !order

let ShouldInitialzeInGivenOrder3 =
let order = ref ""
let actual =
{ B = let _ = order := !order + "1" in 2
A = let _ = order := !order + "2" in 1
C = let _ = order := !order + "3" in 3 }

check "cewekcjnwe3" expected actual
check "cewekcjnwe4" "123" !order


let ShouldInitialzeInGivenOrder4 =
let order = ref ""
let actual =
{ B = let _ = order := !order + "1" in 2
C = let _ = order := !order + "2" in 3
A = let _ = order := !order + "3" in 1 }

check "cewekcjnwe5" expected actual
check "cewekcjnwe6" "123" !order


let ShouldInitialzeInGivenOrder5 =
let order = ref ""
let actual =
{ C = let _ = order := !order + "1" in 3
A = let _ = order := !order + "2" in 1
B = let _ = order := !order + "3" in 2 }

check "cewekcjnwe7" expected actual
check "cewekcjnwe8" "123" !order


let ShouldInitialzeInGivenOrder6 =
let order = ref ""
let actual =
{ C = let _ = order := !order + "1" in 3
B = let _ = order := !order + "2" in 2
A = let _ = order := !order + "3" in 1 }

check "cewekcjnwe9" expected actual
check "cewekcjnwe10" "123" !order


type RecordWithDifferentTypes =
{ A : int
B : string
C : float
D : RecordWithInts }


module RecordInitialisationWithDifferentTxpes =

let expected =
{ A = 1
B = "2"
C = 3.0
D =
{ A = 4
B = 5
C = 6 }}


let ShouldInitialzeInGivenOrder1 =
let order = ref ""
let actual =
{ A = let _ = order := !order + "1" in 1
B = let _ = order := !order + "2" in "2"
C = let _ = order := !order + "3" in 3.0
D = let _ = order := !order + "4" in
{ A = let _ = order := !order + "5" in 4
B = let _ = order := !order + "6" in 5
C = let _ = order := !order + "7" in 6 } }

check "cewekcjnwe11" expected actual
check "cewekcjnwe12" "1234567" !order


let ShouldInitialzeInGivenOrder2 =
let order = ref ""
let actual =
{ A = let _ = order := !order + "1" in 1
C = let _ = order := !order + "2" in 3.0
D = let _ = order := !order + "3" in
{ A = let _ = order := !order + "4" in 4
B = let _ = order := !order + "5" in 5
C = let _ = order := !order + "6" in 6 }

B = let _ = order := !order + "7" in "2" }

check "cewekcjnwe13" expected actual
check "cewekcjnwe14" "1234567" !order


let ShouldInitialzeInGivenOrder3 =
let order = ref ""
let actual =
{ A = let _ = order := !order + "1" in 1
C = let _ = order := !order + "2" in 3.0
B = let _ = order := !order + "3" in "2"
D = let _ = order := !order + "4" in
{ A = let _ = order := !order + "5" in 4
B = let _ = order := !order + "6" in 5
C = let _ = order := !order + "7" in 6 } }

check "cewekcjnwe15" expected actual
check "cewekcjnwe16" "1234567" !order



let ShouldInitialzeInGivenOrder4 =
let order = ref ""
let actual =
{ B = let _ = order := !order + "1" in "2"
A = let _ = order := !order + "2" in 1
C = let _ = order := !order + "3" in 3.0
D = let _ = order := !order + "4" in
{ A = let _ = order := !order + "5" in 4
B = let _ = order := !order + "6" in 5
C = let _ = order := !order + "7" in 6 } }

check "cewekcjnwe17" expected actual
check "cewekcjnwe18" "1234567" !order


let ShouldInitialzeInGivenOrder5 =
let order = ref ""
let actual =
{ D = let _ = order := !order + "1" in
{ A = let _ = order := !order + "2" in 4
B = let _ = order := !order + "3" in 5
C = let _ = order := !order + "4" in 6 }
B = let _ = order := !order + "5" in "2"
C = let _ = order := !order + "6" in 3.0
A = let _ = order := !order + "7" in 1 }

check "cewekcjnwe19" expected actual
check "cewekcjnwe20" "1234567" !order


let ShouldInitialzeInGivenOrder6 =
let order = ref ""
let actual =
{ D = let _ = order := !order + "1" in
{ A = let _ = order := !order + "2" in 4
B = let _ = order := !order + "3" in 5
C = let _ = order := !order + "4" in 6 }
A = let _ = order := !order + "5" in 1
B = let _ = order := !order + "6" in "2"
C = let _ = order := !order + "7" in 3.0 }

check "cewekcjnwe21" expected actual
check "cewekcjnwe22" "1234567" !order

let aa =
if !failures then (stdout.WriteLine "Test Failed"; exit 1)
else (stdout.WriteLine "Test Passed";
Expand Down