Hi,
here are the two patches I spoke about recently. You also have the darcs
format attached.
Thu May 28 12:27:32 CEST 2009 kern...@pps.jussieu.fr
* [ocamlutil] Handle 64-bits in Stats.print
Fri May 29 10:52:25 CEST 2009 kern...@pps.jussieu.fr
* Reduce the GC pressure
If you apply the second one, please acknowledge Grégoire Henry who
helped me a lot finding the bottlenecks.
Regards,
Gabriel Kerneis
diff -ur cil-darcs/ocamlutil/stats.ml cil-patched/ocamlutil/stats.ml
--- cil-darcs/ocamlutil/stats.ml 2009-05-28 10:57:08.000000000 +0200
+++ cil-patched/ocamlutil/stats.ml 2009-05-28 12:27:30.000000000 +0200
@@ -100,7 +100,8 @@
else "Unix.time");
let gc = Gc.quick_stat () in
let printM (w: float) : string =
- Printf.sprintf "%.2fMb" (w *. 4.0 /. 1000000.0)
+ let coeff = float_of_int (Sys.word_size / 8) in
+ Printf.sprintf "%.2fMb" (w *. coeff /. 1000000.0)
in
Printf.fprintf chn
"Memory statistics: total=%s, max=%s, minor=%s, major=%s, promoted=%s\n
minor collections=%d major collections=%d compactions=%d\n"
diff -rN -u old-cil-patched/src/cil.ml new-cil-patched/src/cil.ml
--- old-cil-patched/src/cil.ml 2009-05-29 10:52:22.000000000 +0200
+++ new-cil-patched/src/cil.ml 2009-05-29 10:52:23.000000000 +0200
@@ -4990,22 +4990,14 @@
(*** Define the visiting engine ****)
(* visit all the nodes in a Cil expression *)
let doVisit (vis: cilVisitor)
- (startvisit: 'a -> 'a visitAction)
+ (action: 'a visitAction)
(children: cilVisitor -> 'a -> 'a)
(node: 'a) : 'a =
- let action = startvisit node in
match action with
SkipChildren -> node
| ChangeTo node' -> node'
- | _ -> (* DoChildren and ChangeDoChildrenPost *)
- let nodepre = match action with
- ChangeDoChildrenPost (node', _) -> node'
- | _ -> node
- in
- let nodepost = children vis nodepre in
- match action with
- ChangeDoChildrenPost (_, f) -> f nodepost
- | _ -> nodepost
+ | DoChildren -> children vis node
+ | ChangeDoChildrenPost(node', f) -> f (children vis node')
(* mapNoCopy is like map but avoid copying the list if the function does not
* change the elements. *)
@@ -5027,27 +5019,20 @@
(* A visitor for lists *)
let doVisitList (vis: cilVisitor)
- (startvisit: 'a -> 'a list visitAction)
+ (action: 'a list visitAction)
(children: cilVisitor -> 'a -> 'a)
(node: 'a) : 'a list =
- let action = startvisit node in
match action with
SkipChildren -> [node]
| ChangeTo nodes' -> nodes'
- | _ ->
- let nodespre = match action with
- ChangeDoChildrenPost (nodespre, _) -> nodespre
- | _ -> [node]
- in
- let nodespost = mapNoCopy (children vis) nodespre in
- match action with
- ChangeDoChildrenPost (_, f) -> f nodespost
- | _ -> nodespost
+ | DoChildren -> [children vis node]
+ | ChangeDoChildrenPost(nodes', f) ->
+ f (mapNoCopy (fun n -> children vis n) nodes')
let debugVisit = false
let rec visitCilExpr (vis: cilVisitor) (e: exp) : exp =
- doVisit vis vis#vexpr childrenExp e
+ doVisit vis (vis#vexpr e) childrenExp e
and childrenExp (vis: cilVisitor) (e: exp) : exp =
let vExp e = visitCilExpr vis e in
let vTyp t = visitCilType vis t in
@@ -5120,17 +5105,17 @@
let initl' = if !hasChanged then List.rev !newinitl else initl in
if t' != t || initl' != initl then CompoundInit (t', initl') else i
in
- doVisit vis (vis#vinit forglob atoff) childrenInit i
+ doVisit vis (vis#vinit forglob atoff i) childrenInit i
and visitCilLval (vis: cilVisitor) (lv: lval) : lval =
- doVisit vis vis#vlval childrenLval lv
+ doVisit vis (vis#vlval lv) childrenLval lv
and childrenLval (vis: cilVisitor) (lv: lval) : lval =
(* and visit its subexpressions *)
let vExp e = visitCilExpr vis e in
let vOff off = visitCilOffset vis off in
match lv with
Var v, off ->
- let v' = doVisit vis vis#vvrbl (fun _ x -> x) v in
+ let v' = doVisit vis (vis#vvrbl v) (fun _ x -> x) v in
let off' = vOff off in
if v' != v || off' != off then Var v', off' else lv
| Mem e, off ->
@@ -5139,7 +5124,7 @@
if e' != e || off' != off then Mem e', off' else lv
and visitCilOffset (vis: cilVisitor) (off: offset) : offset =
- doVisit vis vis#voffs childrenOffset off
+ doVisit vis (vis#voffs off) childrenOffset off
and childrenOffset (vis: cilVisitor) (off: offset) : offset =
let vOff off = visitCilOffset vis off in
match off with
@@ -5159,20 +5144,20 @@
* initializers will never recursively contain offsets)
*)
and visitCilInitOffset (vis: cilVisitor) (off: offset) : offset =
- doVisit vis vis#vinitoffs childrenOffset off
+ doVisit vis (vis#vinitoffs off) childrenOffset off
and visitCilInstr (vis: cilVisitor) (i: instr) : instr list =
let oldloc = !currentLoc in
currentLoc := (get_instrLoc i);
assertEmptyQueue vis;
- let res = doVisitList vis vis#vinst childrenInstr i in
+ let res = doVisitList vis (vis#vinst i) childrenInstr i in
currentLoc := oldloc;
(* See if we have accumulated some instructions *)
vis#unqueueInstr () @ res
and childrenInstr (vis: cilVisitor) (i: instr) : instr =
- let fExp = visitCilExpr vis in
- let fLval = visitCilLval vis in
+ let fExp e = visitCilExpr vis e in
+ let fLval lv = visitCilLval vis lv in
match i with
| Set(lv,e,l) ->
let lv' = fLval lv in let e' = fExp e in
@@ -5203,7 +5188,7 @@
currentLoc := (get_stmtLoc s.skind) ;
assertEmptyQueue vis;
let toPrepend : instr list ref = ref [] in (* childrenStmt may add to this *)
- let res = doVisit vis vis#vstmt (childrenStmt toPrepend) s in
+ let res = doVisit vis (vis#vstmt s) (childrenStmt toPrepend) s in
(* Now see if we have saved some instructions *)
toPrepend := !toPrepend @ vis#unqueueInstr ();
(match !toPrepend with
@@ -5215,7 +5200,9 @@
currentLoc := oldloc;
res
-and childrenStmt (toPrepend: instr list ref) (vis:cilVisitor) (s:stmt): stmt =
+and childrenStmt (toPrepend: instr list ref) : cilVisitor -> stmt -> stmt =
+ (* this is a hack to avoid currying and reduce GC pressure *)
+ () ; fun vis s ->
let fExp e = (visitCilExpr vis e) in
let fBlock b = visitCilBlock vis b in
let fInst i = visitCilInstr vis i in
@@ -5294,7 +5281,7 @@
and visitCilBlock (vis: cilVisitor) (b: block) : block =
- doVisit vis vis#vblock childrenBlock b
+ doVisit vis (vis#vblock b) childrenBlock b
and childrenBlock (vis: cilVisitor) (b: block) : block =
let fStmt s = visitCilStmt vis s in
let stmts' = mapNoCopy fStmt b.bstmts in
@@ -5302,7 +5289,7 @@
and visitCilType (vis : cilVisitor) (t : typ) : typ =
- doVisit vis vis#vtype childrenType t
+ doVisit vis (vis#vtype t) childrenType t
and childrenType (vis : cilVisitor) (t : typ) : typ =
(* look for types referred to inside t's definition *)
let fTyp t = visitCilType vis t in
@@ -5358,7 +5345,7 @@
(* for declarations, we visit the types inside; but for uses, *)
(* we just visit the varinfo node *)
and visitCilVarDecl (vis : cilVisitor) (v : varinfo) : varinfo =
- doVisit vis vis#vvdec childrenVarDecl v
+ doVisit vis (vis#vvdec v) childrenVarDecl v
and childrenVarDecl (vis : cilVisitor) (v : varinfo) : varinfo =
v.vtype <- visitCilType vis v.vtype;
v.vattr <- visitCilAttributes vis v.vattr;
@@ -5366,7 +5353,7 @@
and visitCilAttributes (vis: cilVisitor) (al: attribute list) : attribute list=
let al' =
- mapNoCopyList (doVisitList vis vis#vattr childrenAttribute) al in
+ mapNoCopyList (fun x -> doVisitList vis (vis#vattr x) childrenAttribute
x) al in
if al' != al then
(* Must re-sort *)
addAttributes al' []
@@ -5381,7 +5368,7 @@
and visitCilAttrParams (vis: cilVisitor) (a: attrparam) : attrparam =
- doVisit vis vis#vattrparam childrenAttrparam a
+ doVisit vis (vis#vattrparam a) childrenAttrparam a
and childrenAttrparam (vis: cilVisitor) (aa: attrparam) : attrparam =
let fTyp t = visitCilType vis t in
let fAttrP a = visitCilAttrParams vis a in
@@ -5436,7 +5423,7 @@
let rec visitCilFunction (vis : cilVisitor) (f : fundec) : fundec =
if debugVisit then ignore (E.log "Visiting function %s\n" f.svar.vname);
assertEmptyQueue vis;
- let f = doVisit vis vis#vfunc childrenFunction f in
+ let f = doVisit vis (vis#vfunc f) childrenFunction f in
let toPrepend = vis#unqueueInstr () in
if toPrepend <> [] then
@@ -5444,11 +5431,12 @@
f
and childrenFunction (vis : cilVisitor) (f : fundec) : fundec =
+ let visitVarDecl vd = visitCilVarDecl vis vd in
f.svar <- visitCilVarDecl vis f.svar; (* hit the function name *)
(* visit local declarations *)
- f.slocals <- mapNoCopy (visitCilVarDecl vis) f.slocals;
+ f.slocals <- mapNoCopy visitVarDecl f.slocals;
(* visit the formals *)
- let newformals = mapNoCopy (visitCilVarDecl vis) f.sformals in
+ let newformals = mapNoCopy visitVarDecl f.sformals in
(* Make sure the type reflects the formals *)
setFormals f newformals;
(* Remember any new instructions that were generated while visiting
@@ -5465,7 +5453,7 @@
let oldloc = !currentLoc in
currentLoc := (get_globalLoc g) ;
currentGlobal := g;
- let res = doVisitList vis vis#vglob childrenGlobal g in
+ let res = doVisitList vis (vis#vglob g) childrenGlobal g in
currentLoc := oldloc;
res
and childrenGlobal (vis: cilVisitor) (g: global) : global =
New patches:
[[ocamlutil] Handle 64-bits in Stats.print
kern...@pps.jussieu.fr**20090528102732
Ignore-this: 7627799830b37247d4d6b3d677591bff
] hunk ./ocamlutil/stats.ml 103
else "Unix.time");
let gc = Gc.quick_stat () in
let printM (w: float) : string =
- Printf.sprintf "%.2fMb" (w *. 4.0 /. 1000000.0)
+ let coeff = float_of_int (Sys.word_size / 8) in
+ Printf.sprintf "%.2fMb" (w *. coeff /. 1000000.0)
in
Printf.fprintf chn
"Memory statistics: total=%s, max=%s, minor=%s, major=%s, promoted=%s\n minor collections=%d major collections=%d compactions=%d\n"
[Reduce the GC pressure
kern...@pps.jussieu.fr**20090529085225
Ignore-this: 5f3fe9a6ad44e2facd7fdd118fd1fa9f
] hunk ./src/cil.ml 4993
(*** Define the visiting engine ****)
(* visit all the nodes in a Cil expression *)
let doVisit (vis: cilVisitor)
- (startvisit: 'a -> 'a visitAction)
+ (action: 'a visitAction)
(children: cilVisitor -> 'a -> 'a)
(node: 'a) : 'a =
hunk ./src/cil.ml 4996
- let action = startvisit node in
match action with
SkipChildren -> node
| ChangeTo node' -> node'
hunk ./src/cil.ml 4999
- | _ -> (* DoChildren and ChangeDoChildrenPost *)
- let nodepre = match action with
- ChangeDoChildrenPost (node', _) -> node'
- | _ -> node
- in
- let nodepost = children vis nodepre in
- match action with
- ChangeDoChildrenPost (_, f) -> f nodepost
- | _ -> nodepost
+ | DoChildren -> children vis node
+ | ChangeDoChildrenPost(node', f) -> f (children vis node')
(* mapNoCopy is like map but avoid copying the list if the function does not
* change the elements. *)
hunk ./src/cil.ml 5022
(* A visitor for lists *)
let doVisitList (vis: cilVisitor)
- (startvisit: 'a -> 'a list visitAction)
+ (action: 'a list visitAction)
(children: cilVisitor -> 'a -> 'a)
(node: 'a) : 'a list =
hunk ./src/cil.ml 5025
- let action = startvisit node in
match action with
SkipChildren -> [node]
| ChangeTo nodes' -> nodes'
hunk ./src/cil.ml 5028
- | _ ->
- let nodespre = match action with
- ChangeDoChildrenPost (nodespre, _) -> nodespre
- | _ -> [node]
- in
- let nodespost = mapNoCopy (children vis) nodespre in
- match action with
- ChangeDoChildrenPost (_, f) -> f nodespost
- | _ -> nodespost
+ | DoChildren -> [children vis node]
+ | ChangeDoChildrenPost(nodes', f) ->
+ f (mapNoCopy (fun n -> children vis n) nodes')
let debugVisit = false
hunk ./src/cil.ml 5035
let rec visitCilExpr (vis: cilVisitor) (e: exp) : exp =
- doVisit vis vis#vexpr childrenExp e
+ doVisit vis (vis#vexpr e) childrenExp e
and childrenExp (vis: cilVisitor) (e: exp) : exp =
let vExp e = visitCilExpr vis e in
let vTyp t = visitCilType vis t in
hunk ./src/cil.ml 5108
let initl' = if !hasChanged then List.rev !newinitl else initl in
if t' != t || initl' != initl then CompoundInit (t', initl') else i
in
- doVisit vis (vis#vinit forglob atoff) childrenInit i
+ doVisit vis (vis#vinit forglob atoff i) childrenInit i
and visitCilLval (vis: cilVisitor) (lv: lval) : lval =
hunk ./src/cil.ml 5111
- doVisit vis vis#vlval childrenLval lv
+ doVisit vis (vis#vlval lv) childrenLval lv
and childrenLval (vis: cilVisitor) (lv: lval) : lval =
(* and visit its subexpressions *)
let vExp e = visitCilExpr vis e in
hunk ./src/cil.ml 5118
let vOff off = visitCilOffset vis off in
match lv with
Var v, off ->
- let v' = doVisit vis vis#vvrbl (fun _ x -> x) v in
+ let v' = doVisit vis (vis#vvrbl v) (fun _ x -> x) v in
let off' = vOff off in
if v' != v || off' != off then Var v', off' else lv
| Mem e, off ->
hunk ./src/cil.ml 5127
if e' != e || off' != off then Mem e', off' else lv
and visitCilOffset (vis: cilVisitor) (off: offset) : offset =
- doVisit vis vis#voffs childrenOffset off
+ doVisit vis (vis#voffs off) childrenOffset off
and childrenOffset (vis: cilVisitor) (off: offset) : offset =
let vOff off = visitCilOffset vis off in
match off with
hunk ./src/cil.ml 5147
* initializers will never recursively contain offsets)
*)
and visitCilInitOffset (vis: cilVisitor) (off: offset) : offset =
- doVisit vis vis#vinitoffs childrenOffset off
+ doVisit vis (vis#vinitoffs off) childrenOffset off
and visitCilInstr (vis: cilVisitor) (i: instr) : instr list =
let oldloc = !currentLoc in
hunk ./src/cil.ml 5153
currentLoc := (get_instrLoc i);
assertEmptyQueue vis;
- let res = doVisitList vis vis#vinst childrenInstr i in
+ let res = doVisitList vis (vis#vinst i) childrenInstr i in
currentLoc := oldloc;
(* See if we have accumulated some instructions *)
vis#unqueueInstr () @ res
hunk ./src/cil.ml 5159
and childrenInstr (vis: cilVisitor) (i: instr) : instr =
- let fExp = visitCilExpr vis in
- let fLval = visitCilLval vis in
+ let fExp e = visitCilExpr vis e in
+ let fLval lv = visitCilLval vis lv in
match i with
| Set(lv,e,l) ->
let lv' = fLval lv in let e' = fExp e in
hunk ./src/cil.ml 5191
currentLoc := (get_stmtLoc s.skind) ;
assertEmptyQueue vis;
let toPrepend : instr list ref = ref [] in (* childrenStmt may add to this *)
- let res = doVisit vis vis#vstmt (childrenStmt toPrepend) s in
+ let res = doVisit vis (vis#vstmt s) (childrenStmt toPrepend) s in
(* Now see if we have saved some instructions *)
toPrepend := !toPrepend @ vis#unqueueInstr ();
(match !toPrepend with
hunk ./src/cil.ml 5203
currentLoc := oldloc;
res
-and childrenStmt (toPrepend: instr list ref) (vis:cilVisitor) (s:stmt): stmt =
+and childrenStmt (toPrepend: instr list ref) : cilVisitor -> stmt -> stmt =
+ (* this is a hack to avoid currying and reduce GC pressure *)
+ () ; fun vis s ->
let fExp e = (visitCilExpr vis e) in
let fBlock b = visitCilBlock vis b in
let fInst i = visitCilInstr vis i in
hunk ./src/cil.ml 5284
and visitCilBlock (vis: cilVisitor) (b: block) : block =
- doVisit vis vis#vblock childrenBlock b
+ doVisit vis (vis#vblock b) childrenBlock b
and childrenBlock (vis: cilVisitor) (b: block) : block =
let fStmt s = visitCilStmt vis s in
let stmts' = mapNoCopy fStmt b.bstmts in
hunk ./src/cil.ml 5292
and visitCilType (vis : cilVisitor) (t : typ) : typ =
- doVisit vis vis#vtype childrenType t
+ doVisit vis (vis#vtype t) childrenType t
and childrenType (vis : cilVisitor) (t : typ) : typ =
(* look for types referred to inside t's definition *)
let fTyp t = visitCilType vis t in
hunk ./src/cil.ml 5348
(* for declarations, we visit the types inside; but for uses, *)
(* we just visit the varinfo node *)
and visitCilVarDecl (vis : cilVisitor) (v : varinfo) : varinfo =
- doVisit vis vis#vvdec childrenVarDecl v
+ doVisit vis (vis#vvdec v) childrenVarDecl v
and childrenVarDecl (vis : cilVisitor) (v : varinfo) : varinfo =
v.vtype <- visitCilType vis v.vtype;
v.vattr <- visitCilAttributes vis v.vattr;
hunk ./src/cil.ml 5356
and visitCilAttributes (vis: cilVisitor) (al: attribute list) : attribute list=
let al' =
- mapNoCopyList (doVisitList vis vis#vattr childrenAttribute) al in
+ mapNoCopyList (fun x -> doVisitList vis (vis#vattr x) childrenAttribute x) al in
if al' != al then
(* Must re-sort *)
addAttributes al' []
hunk ./src/cil.ml 5371
and visitCilAttrParams (vis: cilVisitor) (a: attrparam) : attrparam =
- doVisit vis vis#vattrparam childrenAttrparam a
+ doVisit vis (vis#vattrparam a) childrenAttrparam a
and childrenAttrparam (vis: cilVisitor) (aa: attrparam) : attrparam =
let fTyp t = visitCilType vis t in
let fAttrP a = visitCilAttrParams vis a in
hunk ./src/cil.ml 5426
let rec visitCilFunction (vis : cilVisitor) (f : fundec) : fundec =
if debugVisit then ignore (E.log "Visiting function %s\n" f.svar.vname);
assertEmptyQueue vis;
- let f = doVisit vis vis#vfunc childrenFunction f in
+ let f = doVisit vis (vis#vfunc f) childrenFunction f in
let toPrepend = vis#unqueueInstr () in
if toPrepend <> [] then
hunk ./src/cil.ml 5434
f
and childrenFunction (vis : cilVisitor) (f : fundec) : fundec =
+ let visitVarDecl vd = visitCilVarDecl vis vd in
f.svar <- visitCilVarDecl vis f.svar; (* hit the function name *)
(* visit local declarations *)
hunk ./src/cil.ml 5437
- f.slocals <- mapNoCopy (visitCilVarDecl vis) f.slocals;
+ f.slocals <- mapNoCopy visitVarDecl f.slocals;
(* visit the formals *)
hunk ./src/cil.ml 5439
- let newformals = mapNoCopy (visitCilVarDecl vis) f.sformals in
+ let newformals = mapNoCopy visitVarDecl f.sformals in
(* Make sure the type reflects the formals *)
setFormals f newformals;
(* Remember any new instructions that were generated while visiting
hunk ./src/cil.ml 5456
let oldloc = !currentLoc in
currentLoc := (get_globalLoc g) ;
currentGlobal := g;
- let res = doVisitList vis vis#vglob childrenGlobal g in
+ let res = doVisitList vis (vis#vglob g) childrenGlobal g in
currentLoc := oldloc;
res
and childrenGlobal (vis: cilVisitor) (g: global) : global =
Context:
[[cil @ 10809]
dgay**20090528193039
Ignore-this: c79727ab3be49c554d936385fe87143
minor 64-bit cleanup, mark deprecated functions
]
[[cil @ 10802]
dgay**20090528013209
Ignore-this: b43e38574a5a2f14f4bb428d9175e6bf
64 bit int fixes - fairly extensive
]
[Tailorization
tai...@hokahe.kerneis.info**20090522002712
Ignore-this: bfe2d0ca6d1fba6f708a254c58c97a3b
Import of the upstream sources from
Repository: svn://hal.cs.berkeley.edu/home/svn/projects
Kind: svn
Module: /trunk/cil
Revision: 10792
]
[0-fold type bug
kern...@pps.jussieu.fr**20090526133730
Ignore-this: 52bca590be9f7973b76af491e08987c9
]
[TAG *cil-1.3.7
kern...@pps.jussieu.fr**20090511084527
Ignore-this: b61f52fa95ed83efdc504a0297a5f5b2
Subversion revision 10726
Version 1.3.7 incorporates a number of bug fixes, support for the C99
_Bool extension and many new gcc builtins... It also incorporates a new
extension to generate LLVM (http://llvm.org) assembly from the CIL
intermediate form (with some significant limitations). More details on
the changes here: https://sourceforge.net/project/shownotes.php?
group_id=138953&release_id=678147
David Gay
]
Patch bundle hash:
2dd60f69ab480fabaa4530235846f1f4ec745490
------------------------------------------------------------------------------
Register Now for Creativity and Technology (CaT), June 3rd, NYC. CaT
is a gathering of tech-side developers & brand creativity professionals. Meet
the minds behind Google Creative Lab, Visual Complexity, Processing, &
iPhoneDevCamp as they present alongside digital heavyweights like Barbarian
Group, R/GA, & Big Spaceship. http://p.sf.net/sfu/creativitycat-com
_______________________________________________
CIL-users mailing list
CIL-users@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/cil-users
