Mercurial > urweb

comparison src/sqlcache.sml @ 2288:98f96a976ede

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Finish locking, but it's not yet tested rigorously.
author Ziv Scully <ziv@mit.edu>
date Fri, 13 Nov 2015 11:03:09 -0500
parents 0bdfec16a01d
children 78820fa8f5a7
comparison
equal deleted inserted replaced
2287:08203f93dbc3 2288:98f96a976ede
911 911
912 (*************************************) 912 (*************************************)
913 (* Program Instrumentation Utilities *) 913 (* Program Instrumentation Utilities *)
914 (*************************************) 914 (*************************************)
915 915
916 val {check, store, flush, ...} = getCache () 916 val {check, store, flush, lock, ...} = getCache ()
917 917
918 val dummyTyp = (TRecord [], dummyLoc) 918 val dummyTyp = (TRecord [], dummyLoc)
919 919
920 fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), dummyLoc) 920 fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), dummyLoc)
921 921
1429 1429
1430 (***********) 1430 (***********)
1431 (* Locking *) 1431 (* Locking *)
1432 (***********) 1432 (***********)
1433 1433
1434 (* TODO: do this less evil-ly by not relying on specific FFI names, please? *) 1434 (* TODO: do this less evilly by not relying on specific FFI names, please? *)
1435 fun locksNeeded file = 1435 fun locksNeeded file =
1436 transitiveAnalysis 1436 transitiveAnalysis
1437 (fn ((_, name, _, e, _), state) => 1437 (fn ((_, name, _, e, _), state) =>
1438 MonoUtil.Exp.fold 1438 MonoUtil.Exp.fold
1439 {typ = #2, 1439 {typ = #2,
1440 exp = fn (EFfiApp ("Sqlcache", x, _), state as {store, flush}) => 1440 exp = fn (EFfiApp ("Sqlcache", x, _), state as {store, flush}) =>
1441 (case Int.fromString (String.extract (x, 5, NONE)) of 1441 (case Int.fromString (String.extract (x, 5, NONE)) of
1442 NONE => raise Match 1442 NONE => state
1443 | SOME index => 1443 | SOME index =>
1444 if String.isPrefix "store" x 1444 if String.isPrefix "flush" x
1445 then {store = store, flush = IIMM.insert (flush, name, index)}
1446 else if String.isPrefix "store" x
1445 then {store = IIMM.insert (store, name, index), flush = flush} 1447 then {store = IIMM.insert (store, name, index), flush = flush}
1446 else if String.isPrefix "flush" x
1447 then {store = store, flush = IIMM.insert (flush, name, index)}
1448 else state) 1448 else state)
1449 | _ => state} 1449 | (_, state) => state}
1450 state 1450 state
1451 e) 1451 e)
1452 {store = IIMM.empty, flush = IIMM.empty} 1452 {store = IIMM.empty, flush = IIMM.empty}
1453 file 1453 file
1454 1454
1457 | ((DTask _, _), _) => raise Fail "Sqlcache doesn't yet support tasks." 1457 | ((DTask _, _), _) => raise Fail "Sqlcache doesn't yet support tasks."
1458 | (_, ns) => ns) 1458 | (_, ns) => ns)
1459 IS.empty 1459 IS.empty
1460 decls 1460 decls
1461 1461
1462 (* fun addLocking file = *) 1462 fun wrapLocks (locks, (exp', loc)) =
1463 (* let *) 1463 case exp' of
1464 (* val whichLocks = locksNeeded file *) 1464 EAbs (s, t1, t2, exp) => (EAbs (s, t1, t2, wrapLocks (locks, exp)), loc)
1465 (* val needsLocks = exports file *) 1465 | _ => (List.foldr (fn (l, e') => sequence [lock l, e']) exp' locks, loc)
1466 (* in *) 1466
1467 1467 fun addLocking file =
1468 (* end *) 1468 let
1469 val {store, flush} = locksNeeded file
1470 fun locks n =
1471 let
1472 val wlocks = IIMM.findSet (flush, n)
1473 val rlocks = IIMM.findSet (store, n)
1474 val ls = map (fn i => (i, true)) (IS.listItems wlocks)
1475 @ map (fn i => (i, false)) (IS.listItems (IS.difference (rlocks, wlocks)))
1476 in
1477 ListMergeSort.sort (fn ((i, _), (j, _)) => i > j) ls
1478 end
1479 val expts = exports file
1480 fun doVal (v as (x, n, t, exp, s)) =
1481 if IS.member (expts, n)
1482 then (x, n, t, wrapLocks ((locks n), exp), s)
1483 else v
1484 val doDecl =
1485 fn (DVal v, loc) => (DVal (doVal v), loc)
1486 | (DValRec vs, loc) => (DValRec (map doVal vs), loc)
1487 | decl => decl
1488 in
1489 mapFst (map doDecl) file
1490 end
1491
1469 1492
1470 (************************) 1493 (************************)
1471 (* Compiler Entry Point *) 1494 (* Compiler Entry Point *)
1472 (************************) 1495 (************************)
1473 1496
1492 val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls 1515 val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls
1493 in 1516 in
1494 (datatypes @ newDecls @ others, sideInfo) 1517 (datatypes @ newDecls @ others, sideInfo)
1495 end 1518 end
1496 1519
1497 val go' = addFlushing o addCaching o simplifySql o inlineSql 1520 val go' = addLocking o addFlushing o addCaching o simplifySql o inlineSql
1498 1521
1499 fun go file = 1522 fun go file =
1500 let 1523 let
1501 (* TODO: do something nicer than [Sql] being in one of two modes. *) 1524 (* TODO: do something nicer than [Sql] being in one of two modes. *)
1502 val () = (resetFfiInfo (); Sql.sqlcacheMode := true) 1525 val () = (resetFfiInfo (); Sql.sqlcacheMode := true)