[Unison-hackers] [unison-svn] r374 - in trunk/src: . ubase
vouillon@seas.upenn.edu
vouillon at seas.upenn.edu
Thu Jul 16 15:33:15 EDT 2009
Author: vouillon
Date: 2009-07-16 15:33:15 -0400 (Thu, 16 Jul 2009)
New Revision: 374
Modified:
trunk/src/RECENTNEWS
trunk/src/mkProjectInfo.ml
trunk/src/props.ml
trunk/src/props.mli
trunk/src/ubase/myMap.ml
trunk/src/update.ml
trunk/src/uutil.ml
trunk/src/uutil.mli
Log:
* Experimental update detection optimization:
do not read the contents of unchanged directories
* MyMap.map and MyMap.mapi now iterate in increasing order
(rather than in an unspecified way)
Modified: trunk/src/RECENTNEWS
===================================================================
--- trunk/src/RECENTNEWS 2009-07-15 15:01:31 UTC (rev 373)
+++ trunk/src/RECENTNEWS 2009-07-16 19:33:15 UTC (rev 374)
@@ -1,5 +1,13 @@
CHANGES FROM VERSION 2.36.-27
+* Experimental update detection optimization:
+ do not read the contents of unchanged directories
+* MyMap.map and MyMap.mapi now iterate in increasing order
+ (rather than in an unspecified way)
+
+-------------------------------
+CHANGES FROM VERSION 2.36.-27
+
* GTK UI: disabled scrolling to the first unfinished item during transport.
It goes way too fast when lot of small files are synchronized, and it
makes it impossible to browse the file list during transport.
Modified: trunk/src/mkProjectInfo.ml
===================================================================
--- trunk/src/mkProjectInfo.ml 2009-07-15 15:01:31 UTC (rev 373)
+++ trunk/src/mkProjectInfo.ml 2009-07-16 19:33:15 UTC (rev 374)
@@ -92,3 +92,4 @@
+
Modified: trunk/src/props.ml
===================================================================
--- trunk/src/props.ml 2009-07-15 15:01:31 UTC (rev 373)
+++ trunk/src/props.ml 2009-07-16 19:33:15 UTC (rev 374)
@@ -761,3 +761,28 @@
let perms p = Perm.extract p.perm
let syncModtimes = Time.sync
+
+(* ------------------------------------------------------------------------- *)
+(* Directory change stamps *)
+(* ------------------------------------------------------------------------- *)
+
+(* We are reusing the directory length to store a flag indicating that
+ the directory is unchanged *)
+
+type dirChangedStamp = Uutil.Filesize.t
+
+let freshDirStamp () =
+ let t =
+ (Unix.gettimeofday () +. sqrt 2. *. float (Unix.getpid ())) *. 1000.
+ in
+ Uutil.Filesize.ofFloat t
+
+let changedDirStamp = Uutil.Filesize.zero
+
+let setDirChangeFlag p stamp inode =
+ let stamp = Uutil.Filesize.add stamp (Uutil.Filesize.ofInt inode) in
+ (setLength p stamp, length p <> stamp)
+
+let dirMarkedUnchanged p stamp inode =
+ let stamp = Uutil.Filesize.add stamp (Uutil.Filesize.ofInt inode) in
+ stamp <> changedDirStamp && length p = stamp
Modified: trunk/src/props.mli
===================================================================
--- trunk/src/props.mli 2009-07-15 15:01:31 UTC (rev 373)
+++ trunk/src/props.mli 2009-07-16 19:33:15 UTC (rev 374)
@@ -29,3 +29,11 @@
val dirDefault : t
val syncModtimes : bool Prefs.t
+
+(* We are reusing the directory length to store a flag indicating that
+ the directory is unchanged *)
+type dirChangedStamp
+val freshDirStamp : unit -> dirChangedStamp
+val changedDirStamp : dirChangedStamp
+val setDirChangeFlag : t -> dirChangedStamp -> int -> t * bool
+val dirMarkedUnchanged : t -> dirChangedStamp -> int -> bool
Modified: trunk/src/ubase/myMap.ml
===================================================================
--- trunk/src/ubase/myMap.ml 2009-07-15 15:01:31 UTC (rev 373)
+++ trunk/src/ubase/myMap.ml 2009-07-16 19:33:15 UTC (rev 374)
@@ -164,11 +164,19 @@
let rec map f = function
Empty -> Empty
- | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h)
+ | Node(l, v, d, r, h) ->
+ let l' = map f l in
+ let d' = f d in
+ let r' = map f r in
+ Node(l', v, d', r', h)
let rec mapi f = function
Empty -> Empty
- | Node(l, v, d, r, h) -> Node(mapi f l, v, f v d, mapi f r, h)
+ | Node(l, v, d, r, h) ->
+ let l' = mapi f l in
+ let d' = f v d in
+ let r' = mapi f r in
+ Node(l', v, d', r', h)
let rec mapii f = function
Empty -> Empty
Modified: trunk/src/update.ml
===================================================================
--- trunk/src/update.ml 2009-07-15 15:01:31 UTC (rev 373)
+++ trunk/src/update.ml 2009-07-16 19:33:15 UTC (rev 374)
@@ -1019,6 +1019,11 @@
let immutablenot = Pred.create "immutablenot" ~advanced:true
("This preference overrides {\\tt immutable}.")
+type fastCheckInfos =
+ { fastCheck : bool;
+ dirFastCheck : bool;
+ dirStamp : Props.dirChangedStamp }
+
(** Status display **)
let bigFileLength = 10 * 1024
@@ -1092,6 +1097,60 @@
| NoArchive ->
absentInfo
+(* Check whether the directory immediate children may have changed *)
+let rec noChildChange childUpdates =
+ match childUpdates with
+ [] ->
+ true
+ | (_, Updates (File _, Previous (`FILE, _, _, _))) :: rem
+ | (_, Updates (Dir _, Previous (`DIRECTORY, _, _, _))) :: rem
+ | (_, Updates (Symlink _, Previous (`SYMLINK, _, _, _))) :: rem ->
+ noChildChange rem
+ | _ ->
+ false
+
+(* Check whether the directory contents is different from what is in
+ the archive *)
+let directoryCheckContentUnchanged
+ currfspath path info archDesc childUpdates fastCheckInfos =
+ if
+ noChildChange childUpdates
+ &&
+ let (info', dataUnchanged, ressUnchanged) =
+ Fileinfo.unchanged currfspath path info in
+ dataUnchanged
+ then begin
+ let (archDesc, updated) =
+ let inode =
+ match Fileinfo.stamp info with Fileinfo.InodeStamp i -> i | _ -> 0 in
+ Props.setDirChangeFlag archDesc fastCheckInfos.dirStamp inode in
+ let updated =
+ updated || not (Props.same_time info.Fileinfo.desc archDesc) in
+ if updated then
+ debugverbose (fun()->
+ Util.msg "Contents of directory %s marked unchanged\n"
+ (Fspath.toDebugString (Fspath.concat currfspath path)));
+ (Props.setTime archDesc (Props.time info.Fileinfo.desc), updated)
+ end else begin
+ let (archDesc, updated) =
+ Props.setDirChangeFlag archDesc Props.changedDirStamp 0 in
+ if updated then
+ debugverbose (fun()->
+ Util.msg "Contents of directory %s marked changed\n"
+ (Fspath.toDebugString (Fspath.concat currfspath path)));
+ (archDesc, updated)
+ end
+
+(* Check whether the list of children of a directory is clearly unchanged *)
+let dirContentsClearlyUnchanged info archDesc fastCheckInfos =
+ fastCheckInfos.dirFastCheck
+ &&
+ let inode =
+ match Fileinfo.stamp info with Fileinfo.InodeStamp i -> i | _ -> 0 in
+ Props.dirMarkedUnchanged archDesc fastCheckInfos.dirStamp inode
+ &&
+ Props.same_time info.Fileinfo.desc archDesc
+
(* Check whether a file's permissions have not changed *)
let isPropUnchanged info archiveDesc =
Props.similar info.Fileinfo.desc archiveDesc
@@ -1256,20 +1315,46 @@
remain unchanged, the second a named list of updates; also returns
whether the directory is now empty *)
let rec buildUpdateChildren
- fspath path (archChi: archive NameMap.t) fastCheck
+ fspath path (archChi: archive NameMap.t) unchangedChildren fastCheckInfos
: archive NameMap.t option * (Name.t * Common.updateItem) list * bool
=
showStatusDir path;
- let t = Trace.startTimerQuietly
- (Printf.sprintf "checking %s" (Path.toString path)) in
let skip =
Pred.test immutable (Path.toString path) &&
not (Pred.test immutablenot (Path.toString path))
in
-(*
-if skip then (None, [], false) else
-let curChildren = ref (NameMap.fold (fun nm _ rem -> (nm, `Ok) :: rem) archChi []) in
-*)
+ if unchangedChildren then begin
+ if skip then begin
+ if Prefs.read Xferhint.xferbycopying then
+ NameMap.iter
+ (fun nm archive ->
+ match archive with
+ ArchiveFile (archDesc, archDig, archStamp, archRess) ->
+ Xferhint.insertEntry (fspath, Path.child path nm) archDig
+ | _ ->
+ ())
+ archChi;
+ (None, [], false)
+ end else begin
+ let updates = ref [] in
+ let archUpdated = ref false in
+ let handleChild nm archive =
+ let path' = Path.child path nm in
+ showStatus path';
+ let (arch,uiChild) =
+ buildUpdateRec archive fspath path' fastCheckInfos in
+ if uiChild <> NoUpdates then
+ updates := (nm, uiChild) :: !updates;
+ match arch with
+ None -> archive
+ | Some arch -> archUpdated := true; arch
+ in
+ let newChi = NameMap.mapi handleChild archChi in
+ (* The Recon module relies on the updates to be sorted *)
+ ((if !archUpdated then Some newChi else None),
+ Safelist.rev !updates, false)
+ end
+ end else
let curChildren = ref (getChildren fspath path) in
let emptied = not (NameMap.is_empty archChi) && !curChildren = [] in
let updates = ref [] in
@@ -1294,7 +1379,7 @@
archive
end else begin
let (arch,uiChild) =
- buildUpdateRec archive fspath path' fastCheck in
+ buildUpdateRec archive fspath path' fastCheckInfos in
if uiChild <> NoUpdates then
updates := (nm, uiChild) :: !updates;
match arch with
@@ -1353,12 +1438,11 @@
let arch = handleChild nm NoArchive st in
assert (arch = NoArchive))
!curChildren;
- Trace.showTimer t;
(* The Recon module relies on the updates to be sorted *)
((if !archUpdated then Some newChi else None),
Safelist.rev !updates, emptied)
-and buildUpdateRec archive currfspath path fastCheck =
+and buildUpdateRec archive currfspath path fastCheckInfos =
try
debug (fun() ->
Util.msg "buildUpdate: %s\n"
@@ -1375,7 +1459,7 @@
| (`FILE, ArchiveFile (archDesc, archDig, archStamp, archRess)) ->
checkContentsChange
currfspath path info archive
- archDesc archDig archStamp archRess fastCheck
+ archDesc archDig archStamp archRess fastCheckInfos.fastCheck
| (`FILE, _) ->
debug (fun() -> Util.msg " buildUpdate -> Updated file\n");
None,
@@ -1411,11 +1495,20 @@
(PropsSame, archDesc)
else
(PropsUpdated, info.Fileinfo.desc) in
+ let unchanged =
+ dirContentsClearlyUnchanged info archDesc fastCheckInfos in
let (newChildren, childUpdates, emptied) =
- buildUpdateChildren currfspath path prevChildren fastCheck in
+ buildUpdateChildren
+ currfspath path prevChildren unchanged fastCheckInfos in
+ let (archDesc, updated) =
+ directoryCheckContentUnchanged
+ currfspath path info archDesc childUpdates fastCheckInfos in
(begin match newChildren with
- Some ch -> Some (ArchiveDir (archDesc, ch))
- | None -> None
+ Some ch ->
+ Some (ArchiveDir (archDesc, ch))
+ | None ->
+ if updated then Some (ArchiveDir (archDesc, prevChildren))
+ else None
end,
if childUpdates <> [] || permchange = PropsUpdated then
Updates (Dir (desc, childUpdates, permchange, emptied),
@@ -1425,7 +1518,8 @@
| (`DIRECTORY, _) ->
debug (fun() -> Util.msg " buildUpdate -> New directory\n");
let (newChildren, childUpdates, _) =
- buildUpdateChildren currfspath path NameMap.empty fastCheck in
+ buildUpdateChildren
+ currfspath path NameMap.empty false fastCheckInfos in
(None,
Updates (Dir (info.Fileinfo.desc, childUpdates, PropsUpdated, false),
oldInfoOf archive))
@@ -1436,12 +1530,17 @@
archive, which is the old archive with time stamps updated
appropriately (i.e., for those files whose contents remain
unchanged). *)
-let rec buildUpdate archive fspath fullpath here path =
+let rec buildUpdate archive fspath fullpath here path dirStamp =
match Path.deconstruct path with
None ->
showStatus here;
+ let fastCheckInfos =
+ { fastCheck = useFastChecking ();
+ dirFastCheck = useFastChecking ();
+ dirStamp = dirStamp }
+ in
let (arch, ui) =
- buildUpdateRec archive fspath here (useFastChecking()) in
+ buildUpdateRec archive fspath here fastCheckInfos in
(begin match arch with
None -> archive
| Some arch -> arch
@@ -1509,7 +1608,8 @@
(Props.dummy, NoArchive, NameMap.empty)
in
let (arch, updates) =
- buildUpdate child fspath fullpath (Path.child here name') path'
+ buildUpdate
+ child fspath fullpath (Path.child here name') path' dirStamp
in
(* We need to put a directory in the archive here for path
translation. This is fine because we check that there
@@ -1529,6 +1629,9 @@
let predKey : (string * string list) list Proplist.key =
Proplist.register "update predicates"
+let rsrcKey : bool Proplist.key = Proplist.register "rsrc pref"
+let dirStampKey : Props.dirChangedStamp Proplist.key =
+ Proplist.register "unchanged directory stamp"
let checkNoUpdatePredicateChange thisRoot =
let props = getArchiveProps thisRoot in
@@ -1543,8 +1646,19 @@
newPreds;
Format.eprintf "==> %b at ." (oldPreds = newPreds);
*)
- setArchivePropsLocal thisRoot (Proplist.add predKey newPreds props);
- oldPreds = newPreds
+ let oldRsrc =
+ try Some (Proplist.find rsrcKey props) with Not_found -> None in
+ let newRsrc = Prefs.read Osx.rsrc in
+ try
+ if oldPreds <> newPreds || oldRsrc <> Some newRsrc then raise Not_found;
+ Proplist.find dirStampKey props
+ with Not_found ->
+ let stamp = Props.freshDirStamp () in
+ setArchivePropsLocal thisRoot
+ (Proplist.add dirStampKey stamp
+ (Proplist.add predKey newPreds
+ (Proplist.add rsrcKey newRsrc props)));
+ stamp
(* for the given path, find the archive and compute the list of update
items; as a side effect, update the local archive w.r.t. time-stamps for
@@ -1560,7 +1674,10 @@
deleted. --BCP 2006 *)
let (arcName,thisRoot) = archiveName fspath MainArch in
let archive = getArchive thisRoot in
- let _ = checkNoUpdatePredicateChange thisRoot in
+ let dirStamp = checkNoUpdatePredicateChange thisRoot in
+(*
+let t1 = Unix.gettimeofday () in
+*)
let (archive, updates) =
Safelist.fold_right
(fun path (arch, upd) ->
@@ -1568,11 +1685,15 @@
(arch, NoUpdates :: upd)
else
let (arch', ui) =
- buildUpdate arch fspath path Path.empty path
+ buildUpdate arch fspath path Path.empty path dirStamp
in
arch', ui :: upd)
pathList (archive, [])
in
+(*
+let t2 = Unix.gettimeofday () in
+Format.eprintf "Update detection: %f at ." (t2 -. t1);
+*)
setArchiveLocal thisRoot archive;
abortIfAnyMountpointsAreMissing fspath;
updates
@@ -1996,7 +2117,11 @@
state of the replica... *)
let archive = updateArchiveRec ui archive in
(* ...and check that this is a good description of what's out in the world *)
- let (_, uiNew) = buildUpdateRec archive fspath localPath false in
+ let fastCheckInfos =
+ { fastCheck = false; dirFastCheck = false;
+ dirStamp = Props.changedDirStamp }
+ in
+ let (_, uiNew) = buildUpdateRec archive fspath localPath fastCheckInfos in
markPossiblyUpdatedRec fspath pathInArchive uiNew;
explainUpdate pathInArchive uiNew
Modified: trunk/src/uutil.ml
===================================================================
--- trunk/src/uutil.ml 2009-07-15 15:01:31 UTC (rev 373)
+++ trunk/src/uutil.ml 2009-07-16 19:33:15 UTC (rev 374)
@@ -44,6 +44,7 @@
val dummy : t
val add : t -> t -> t
val sub : t -> t -> t
+ val ofFloat : float -> t
val toFloat : t -> float
val toString : t -> string
val ofInt : int -> t
@@ -57,10 +58,11 @@
module Filesize : FILESIZE = struct
type t = int64
- let zero = Int64.zero
- let dummy = Int64.minus_one
+ let zero = 0L
+ let dummy = -1L
let add = Int64.add
let sub = Int64.sub
+ let ofFloat = Int64.of_float
let toFloat = Int64.to_float
let toString = Int64.to_string
let ofInt x = Int64.of_int x
Modified: trunk/src/uutil.mli
===================================================================
--- trunk/src/uutil.mli 2009-07-15 15:01:31 UTC (rev 373)
+++ trunk/src/uutil.mli 2009-07-16 19:33:15 UTC (rev 374)
@@ -20,6 +20,7 @@
val dummy : t
val add : t -> t -> t
val sub : t -> t -> t
+ val ofFloat : float -> t
val toFloat : t -> float
val toString : t -> string
val ofInt : int -> t
More information about the Unison-hackers
mailing list