Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
Why3
why3
Commits
bfff13fa
Commit
bfff13fa
authored
Jan 21, 2011
by
François Bobot
Browse files
bench : simplify (?) a little by using only one mutex.
MTask merge with MainWorker
parent
98c42d6b
Changes
3
Hide whitespace changes
Inline
Side-by-side
src/bench/bench.ml
View file @
bfff13fa
...
...
@@ -59,36 +59,75 @@ type ('a,'b) callback = 'a -> 'b -> task -> int -> proof_attempt_status -> unit
let
debug_call
=
Debug
.
register_flag
"call"
let
debug
=
Debug
.
register_flag
"bench_core"
module
MTask
:
(** Create and manage one main worker which
wait for the remaining works *)
module
MainWorker
:
sig
type
shared
val
create
:
unit
->
shared
val
start
:
shared
->
unit
val
st
op
:
shared
->
unit
val
lock
:
shared
->
unit
val
unlock
:
shared
->
unit
val
wait
:
shared
->
unit
type
'
a
t
val
create
:
unit
->
'
a
t
val
treat
:
'
a
t
->
(
'
b
->
'
a
->
'
b
)
->
'
b
->
'
b
val
st
art_work
:
'
a
t
->
unit
val
stop_work
:
'
a
t
->
unit
val
add_work
:
'
a
t
->
'
a
->
unit
val
add_works
:
'
a
t
->
'
a
Queue
.
t
->
unit
end
=
struct
type
shared
=
{
m
:
Mutex
.
t
;
c
:
Condition
.
t
;
mutable
nb_task
:
int
;
}
type
'
a
t
=
{
queue
:
'
a
Queue
.
t
;
mutex
:
Mutex
.
t
;
condition
:
Condition
.
t
;
mutable
remaining
:
int
;
}
let
create
()
=
{
m
=
Mutex
.
create
()
;
c
=
Condition
.
create
()
;
nb_task
=
0
}
let
test
s
=
s
.
nb_task
=
0
let
start
s
=
Mutex
.
lock
s
.
m
;
s
.
nb_task
<-
s
.
nb_task
+
1
;
Mutex
.
unlock
s
.
m
let
stop
s
=
Mutex
.
lock
s
.
m
;
s
.
nb_task
<-
s
.
nb_task
-
1
;
if
test
s
then
Condition
.
signal
s
.
c
;
Mutex
.
unlock
s
.
m
let
wait
s
=
Mutex
.
lock
s
.
m
;
if
not
(
test
s
)
then
Condition
.
wait
s
.
c
s
.
m
let
lock
s
=
Mutex
.
lock
s
.
m
let
unlock
s
=
Mutex
.
unlock
s
.
m
{
queue
=
Queue
.
create
()
;
mutex
=
Mutex
.
create
()
;
condition
=
Condition
.
create
()
;
remaining
=
0
;
}
let
treat
t
f
acc
=
let
rec
main
acc
=
Mutex
.
lock
t
.
mutex
;
while
Queue
.
is_empty
t
.
queue
&&
t
.
remaining
>
0
do
Condition
.
wait
t
.
condition
t
.
mutex
done
;
if
Queue
.
is_empty
t
.
queue
then
begin
(* t.remaining < 0 *)
Mutex
.
unlock
t
.
mutex
;
acc
end
else
begin
let
v
=
Queue
.
pop
t
.
queue
in
Mutex
.
unlock
t
.
mutex
;
let
acc
=
f
acc
v
in
Thread
.
yield
()
;
main
acc
end
in
main
acc
let
start_work
t
=
Mutex
.
lock
t
.
mutex
;
t
.
remaining
<-
t
.
remaining
+
1
;
Mutex
.
unlock
t
.
mutex
let
stop_work
t
=
Mutex
.
lock
t
.
mutex
;
t
.
remaining
<-
t
.
remaining
-
1
;
if
t
.
remaining
=
0
then
Condition
.
signal
t
.
condition
;
Mutex
.
unlock
t
.
mutex
let
add_work
t
x
=
Mutex
.
lock
t
.
mutex
;
Queue
.
push
x
t
.
queue
;
Condition
.
signal
t
.
condition
;
Mutex
.
unlock
t
.
mutex
let
add_works
t
q
=
Mutex
.
lock
t
.
mutex
;
Queue
.
transfer
q
t
.
queue
;
Condition
.
signal
t
.
condition
;
Mutex
.
unlock
t
.
mutex
end
let
call
s
callback
tool
prob
=
...
...
@@ -99,48 +138,54 @@ let call s callback tool prob =
~
command
:
(
tool
.
tcommand
)
~
driver
:
(
tool
.
tdriver
)
~
callback
:
cb
task
)
q
in
let
iter
q
pval
i
task
=
M
Task
.
start
s
;
M
ainWorker
.
start
_work
s
;
let
cb
res
=
callback
pval
i
task
res
;
match
res
with
Scheduler
.
Done
_
|
Scheduler
.
InternalFailure
_
->
M
Task
.
stop
s
|
_
->
()
in
|
Scheduler
.
InternalFailure
_
->
M
ainWorker
.
stop_work
s
|
_
->
()
in
call
q
cb
task
;
succ
i
in
let
trans_cb
pval
tl
=
let
q
=
Queue
.
create
()
in
ignore
(
List
.
fold_left
(
iter
q
pval
)
0
(
List
.
rev
tl
));
transfer_proof_attempts
q
;
M
Task
.
stop
s
in
M
ainWorker
.
stop_work
s
in
(** Apply trans *)
let
iter_task
(
pval
,
task
)
=
M
Task
.
start
s
;
M
ainWorker
.
start
_work
s
;
let
trans
=
Trans
.
compose_l
(
prob
.
ptrans
tool
.
tenv
)
(
Trans
.
singleton
tool
.
ttrans
)
in
apply_transformation_l
~
callback
:
(
trans_cb
pval
)
trans
task
in
(** Split *)
let
ths
=
do_why_sync
(
prob
.
ptask
tool
.
tenv
)
tool
.
tuse
in
M
Task
.
start
s
;
M
ainWorker
.
start
_work
s
;
List
.
iter
iter_task
ths
;
M
Task
.
stop
s
M
ainWorker
.
stop_work
s
let
general
?
(
callback
=
fun
_
_
_
_
_
->
()
)
iter
add
=
Debug
.
dprintf
debug
"Start one general@."
;
let
s
=
MTask
.
create
()
in
iter
(
fun
v
tool
prob
->
(** Main worker *)
let
t
=
MainWorker
.
create
()
in
(** Start all *)
MainWorker
.
start_work
t
;
let
_
=
Thread
.
create
(
fun
()
->
iter
(
fun
v
tool
prob
->
let
cb
pval
i
task
res
=
callback
tool
.
tval
pval
task
i
res
;
match
res
with
|
Scheduler
.
InternalFailure
_
|
Scheduler
.
Done
_
->
MTask
.
lock
s
;
add
v
{
tool
=
tool
.
tval
;
prob
=
pval
;
task
=
task
;
idtask
=
i
;
result
=
match
res
with
|
Scheduler
.
InternalFailure
exn
->
InternalFailure
exn
|
Scheduler
.
Done
r
->
Done
r
|
_
->
assert
false
};
MTask
.
unlock
s
|
_
->
()
in
call
s
cb
tool
prob
);
MTask
.
wait
s
;
MTask
.
unlock
s
MainWorker
.
add_work
t
(
fun
()
->
callback
tool
.
tval
pval
task
i
res
;
match
res
with
|
Scheduler
.
InternalFailure
_
|
Scheduler
.
Done
_
->
add
v
{
tool
=
tool
.
tval
;
prob
=
pval
;
task
=
task
;
idtask
=
i
;
result
=
match
res
with
|
Scheduler
.
InternalFailure
exn
->
InternalFailure
exn
|
Scheduler
.
Done
r
->
Done
r
|
_
->
assert
false
}
|
_
->
()
)
in
call
t
cb
tool
prob
);
MainWorker
.
stop_work
t
;
)
()
in
(** Treat the work done and wait *)
MainWorker
.
treat
t
(
fun
()
f
->
f
()
)
()
let
any
?
callback
toolprob
=
let
l
=
ref
[]
in
...
...
@@ -388,43 +433,3 @@ in
)
b
.
boutputs
(** Create and manage one main working thread *)
module
MainWorker
=
struct
type
'
a
t
=
{
queue
:
'
a
Queue
.
t
;
mutex
:
Mutex
.
t
;
condition
:
Condition
.
t
;
}
let
create
f
=
let
t
=
{
queue
=
Queue
.
create
()
;
mutex
=
Mutex
.
create
()
;
condition
=
Condition
.
create
()
;
}
in
let
rec
main
()
=
Mutex
.
lock
t
.
mutex
;
while
Queue
.
is_empty
t
.
queue
do
Condition
.
wait
t
.
condition
t
.
mutex
done
;
let
v
=
Queue
.
pop
t
.
queue
in
Mutex
.
unlock
t
.
mutex
;
f
v
;
Thread
.
yield
()
;
main
()
in
let
_
=
Thread
.
create
main
()
in
t
let
add_work
t
x
=
Mutex
.
lock
t
.
mutex
;
Queue
.
push
x
t
.
queue
;
Condition
.
signal
t
.
condition
;
Mutex
.
unlock
t
.
mutex
let
add_works
t
q
=
Mutex
.
lock
t
.
mutex
;
Queue
.
transfer
q
t
.
queue
;
Condition
.
signal
t
.
condition
;
Mutex
.
unlock
t
.
mutex
end
src/bench/bench.mli
View file @
bfff13fa
...
...
@@ -137,11 +137,3 @@ val print_output :
(
formatter
->
'
a
->
unit
)
->
(
formatter
->
'
b
->
unit
)
->
(
'
a
,
'
b
)
bench
*
(
'
a
*
(
'
a
,
'
b
)
result
list
)
list
->
unit
module
MainWorker
:
sig
type
'
a
t
val
create
:
(
'
a
->
unit
)
->
'
a
t
val
add_work
:
'
a
t
->
'
a
->
unit
val
add_works
:
'
a
t
->
'
a
Queue
.
t
->
unit
end
src/bench/whybench.ml
View file @
bfff13fa
...
...
@@ -374,11 +374,6 @@ let () =
eprintf
"%a@."
Exn_printer
.
exn_printer
e
;
exit
1
let
()
=
let
m
=
B
.
MainWorker
.
create
(
fun
(
f
,
v
)
->
f
v
)
in
let
async
f
v
=
B
.
MainWorker
.
add_work
m
(
f
,
v
)
in
Scheduler
.
async
:=
async
let
()
=
let
nb_scheduled
=
ref
0
in
let
nb_done
=
ref
0
in
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment