Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
L
lutin
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
1
Issues
1
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Packages & Registries
Packages & Registries
Container Registry
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
verimag
synchrone
lutin
Commits
9d0c853a
Commit
9d0c853a
authored
Apr 12, 2019
by
erwan
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Update: monadisation of Lutin, part 4.
Rationale: make rdbg time traveling work.
parent
7a6ac267
Changes
23
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
23 changed files
with
3361 additions
and
4210 deletions
+3361
-4210
_oasis
_oasis
+1
-1
ltop/src/lurettetop.ml
ltop/src/lurettetop.ml
+1
-1
ltop/src/runDirect.ml
ltop/src/runDirect.ml
+1
-1
lurette-nocaml/src/lurette.ml
lurette-nocaml/src/lurette.ml
+6
-6
lutin/src/auto2Lucky.ml
lutin/src/auto2Lucky.ml
+4
-6
lutin/src/autoExplore.ml
lutin/src/autoExplore.ml
+0
-924
lutin/src/autoGen.ml
lutin/src/autoGen.ml
+5
-12
lutin/src/ckTypeEff.ml
lutin/src/ckTypeEff.ml
+14
-14
lutin/src/coAlgExp.ml
lutin/src/coAlgExp.ml
+1
-1
lutin/src/exp.ml
lutin/src/exp.ml
+2
-2
lutin/src/expand.ml
lutin/src/expand.ml
+1322
-1256
lutin/src/expand.mli
lutin/src/expand.mli
+13
-11
lutin/src/luc2alice.ml
lutin/src/luc2alice.ml
+2
-8
lutin/src/luc2c.ml
lutin/src/luc2c.ml
+1
-1
lutin/src/lucFGen.ml
lutin/src/lucFGen.ml
+107
-107
lutin/src/lutExe.ml
lutin/src/lutExe.ml
+1835
-1820
lutin/src/lutExe.mli
lutin/src/lutExe.mli
+1
-2
lutin/src/lutProg.ml
lutin/src/lutProg.ml
+2
-2
lutin/src/lutinRun.ml
lutin/src/lutinRun.ml
+13
-3
lutin/src/main.ml
lutin/src/main.ml
+1
-1
lutin/src/mainArg.ml
lutin/src/mainArg.ml
+2
-5
lutin/src/util.ml
lutin/src/util.ml
+23
-23
lutin/src/value.ml
lutin/src/value.ml
+4
-3
No files found.
_oasis
View file @
9d0c853a
...
...
@@ -27,7 +27,7 @@ Executable lutin
Path: lutin/src
MainIs: main.ml
BuildDepends: str,unix,num,rdbg-plugin (>= 1.177),lutin-utils,ezdl,gbddml,polka,camlp4,camlidl,gmp
NativeOpt: -package num # XXX turn around a bug in oasis/ocamlbuild/ocamlfind?
NativeOpt: -
warn-error "+26" -
package num # XXX turn around a bug in oasis/ocamlbuild/ocamlfind?
Build: true
Install:true
CompiledObject: native
...
...
ltop/src/lurettetop.ml
View file @
9d0c853a
...
...
@@ -73,7 +73,7 @@ let main_read_arg () =
args
.
tmp_dir
<-
lurette_tmp_dir
;
Unix
.
putenv
"TMPDIR"
(
String
.
escaped
lurette_tmp_dir
)
;
in
let
source_dir
=
(
Filename
.
concat
(
ExtTools
.
lurette_path
()
)
"source"
)
in
let
_source_dir
=
(
Filename
.
concat
(
ExtTools
.
lurette_path
()
)
"source"
)
in
match
args
.
sut_compiler
with
|
Scade
->
assert
false
|
VerimagV4
...
...
ltop/src/runDirect.ml
View file @
9d0c853a
...
...
@@ -89,7 +89,7 @@ let (make_rp_list : reactive_program list ->
(
Data
.
subst
list
->
ctx
->
(
Data
.
subst
list
->
ctx
->
Event
.
t
)
->
Event
.
t
)
list
*
Data
.
subst
list
list
*
Data
.
subst
list
list
)
=
fun
rpl
->
let
add_init
init
(
a
,
b
,
c
,
d
,
e
)
=
(
a
,
b
,
c
,
d
,
e
,
init
,
init
)
in
let
_
add_init
init
(
a
,
b
,
c
,
d
,
e
)
=
(
a
,
b
,
c
,
d
,
e
,
init
,
init
)
in
let
aux
rp
=
let
plugin
=
match
rp
with
...
...
lurette-nocaml/src/lurette.ml
View file @
9d0c853a
(* Time-stamp: <modified the
29/03/2019 (at 14:53
) by Erwan Jahier> *)
(* Time-stamp: <modified the
11/04/2019 (at 14:56
) by Erwan Jahier> *)
(* Mimick the behavior of 'rdbg -lurette', but without the dependency
on ocaml *)
open
Event
...
...
@@ -77,11 +77,11 @@ let _ =
args
.
verbose
<-
if
!
verbose
then
1
else
0
;
args
.
output
<-
!
output_file
;
args
.
overwrite_output
=
!
overwrite_output
;
args
.
stop_on_oracle_error
=
not
!
dont_stop_on_oracle_error
;
args
.
log
=
!
log
;
args
.
cov_file
=
!
cov_file
;
args
.
reset_cov_file
=
!
reset_cov_file
;
args
.
overwrite_output
<-
!
overwrite_output
;
args
.
stop_on_oracle_error
<-
not
!
dont_stop_on_oracle_error
;
args
.
log
<-
!
log
;
args
.
cov_file
<-
!
cov_file
;
args
.
reset_cov_file
<-
!
reset_cov_file
;
args
.
debug_rdbg
<-
!
drdbg
;
args
.
rdbg
<-
false
;
...
...
lutin/src/auto2Lucky.ml
View file @
9d0c853a
...
...
@@ -42,13 +42,13 @@ let print_header
)
open
Util
let
make
(
srcname
:
string
)
(
mnode
:
string
)
(
auto
:
AutoGen
.
t
)
(
os
:
Pervasives
.
out_channel
)
=
(
(* le source au cas ou ... *)
let
source_code
=
AutoGen
.
source
auto
in
...
...
@@ -61,8 +61,7 @@ let make
let
etab2prof
s
xi
acc
=
(
(
s
,
xi
.
xi_prof
)
::
acc
)
in
let
xlist
=
Hashtbl
.
fold
etab2prof
(
Expand
.
extern_tab
source_code
)
[]
in
let
xlist
=
Util
.
StringMap
.
fold
etab2prof
(
Expand
.
extern_tab
source_code
)
[]
in
if
(
xlist
=
[]
)
then
()
else
(
fprintf
os
"
\n
functions {
\n
"
;
...
...
@@ -79,7 +78,7 @@ let make
(* pour les dumps des vars support *)
(* Hashtbl.iter (print_support Local) (Expand.support_tab source_code); *)
let
print_support
nme
=
(
let
info
=
Util
.
hfind
(
Expand
.
support_tab
source_code
)
nme
in
let
info
=
Util
.
StringMap
.
find
nme
(
Expand
.
support_tab
source_code
)
in
fprintf
os
" %s : %s"
(
CoIdent
.
to_string
nme
)
(
CkTypeEff
.
to_string
info
.
si_type
);
...
...
@@ -104,8 +103,7 @@ let make
(* pour les dumps de la liste d'alias *)
let
print_alias
nme
=
(
let
info
=
Util
.
hfind
(
Expand
.
alias_tab
source_code
)
nme
in
let
info
=
StringMap
.
find
nme
(
Expand
.
alias_tab
source_code
)
in
fprintf
os
" %s : %s"
(
CoIdent
.
to_string
nme
)
(
CkTypeEff
.
to_string
info
.
ai_type
);
...
...
lutin/src/autoExplore.ml
deleted
100644 → 0
View file @
7a6ac267
This diff is collapsed.
Click to expand it.
lutin/src/autoGen.ml
View file @
9d0c853a
...
...
@@ -354,12 +354,8 @@ let gentrans
(* Correspondance id de trace -> trace exp
N.B. on traque les récursions ? *)
(*-------------------------------------------*)
let
id2trace
s
=
(
(
Util
.
hfind
(
Expand
.
trace_tab
xenv
)
s
)
.
ti_def_exp
)
in
let
unalias
s
=
(
(
Util
.
hfind
(
Expand
.
alias_tab
xenv
)
s
)
.
ai_def_exp
)
in
let
id2trace
s
=
(
StringMap
.
find
s
(
Expand
.
trace_tab
xenv
))
.
ti_def_exp
in
let
unalias
s
=
(
StringMap
.
find
s
(
Expand
.
alias_tab
xenv
))
.
ai_def_exp
in
(*-------------------------------------------*)
(* LA FONCTION RÉCURSIVE *)
...
...
@@ -891,7 +887,7 @@ let init (xenv : Expand.t) =
}
in
let
is
=
Expand
.
main_trace
xenv
in
let
ie
=
(
Util
.
hfind
(
Expand
.
trace_tab
xenv
)
is
)
.
ti_def_exp
in
let
ie
=
(
Util
.
StringMap
.
find
is
(
Expand
.
trace_tab
xenv
)
)
.
ti_def_exp
in
let
init_control
,
res
=
get_stable
res
ie
in
let
final_control
,
res
=
get_sink
res
"vanish"
in
{
res
with
...
...
@@ -924,12 +920,9 @@ let rec ttree2trans (it:t) (src: string) (tt : ttree) = (
)
let
get_state_def
(
it
:
t
)
(
ix
:
string
)
=
StringMap
.
find
ix
it
._
state2trace
let
get_state_def
(
it
:
t
)
(
ix
:
string
)
=
StringMap
.
find
ix
it
._
state2trace
let
get_state_info
(
it
:
t
)
(
ix
:
string
)
=
StringMap
.
find
ix
it
.
states
let
get_state_info
(
it
:
t
)
(
ix
:
string
)
=
StringMap
.
find
ix
it
.
states
(*
*)
...
...
lutin/src/ckTypeEff.ml
View file @
9d0c853a
...
...
@@ -191,20 +191,20 @@ let rec of_texp = ( function
x ref -> x
*)
let
lifts_to
t1
t2
=
(
let
res
=
(
t1
=
t2
)
or
((
t1
=
boolref
)
&&
(
t2
=
boolean
))
or
((
t1
=
boolean
)
&&
(
t2
=
trace
))
or
((
t1
=
boolref
)
&&
(
t2
=
trace
))
or
((
t1
=
integer
)
&&
(
t2
=
weight
))
or
((
t1
=
intref
)
&&
(
t2
=
weight
))
or
(
match
(
t1
,
t2
)
with
(
TEFF_ref
x
,
TEFF_data
y
)
->
(
x
=
y
)
|
_
->
false
)
in
res
let
res
=
(
t1
=
t2
)
||
((
t1
=
boolref
)
&&
(
t2
=
boolean
))
||
((
t1
=
boolean
)
&&
(
t2
=
trace
))
||
((
t1
=
boolref
)
&&
(
t2
=
trace
))
||
((
t1
=
integer
)
&&
(
t2
=
weight
))
||
((
t1
=
intref
)
&&
(
t2
=
weight
))
||
(
match
(
t1
,
t2
)
with
(
TEFF_ref
x
,
TEFF_data
y
)
->
(
x
=
y
)
|
_
->
false
)
in
res
)
(* compatibilit d'un profil avec une liste de types de params
Renvoie le type eff du rsultat ou lve une exception :
...
...
lutin/src/coAlgExp.ml
View file @
9d0c853a
...
...
@@ -95,7 +95,7 @@ let of_alias i t c =
{
ae_type
=
t
;
ae_ctrl
=
c
;
ae_val
=
AE_alias
i
}
let
of_call
i
t
args
=
(
let
f
b
ae
=
(
b
or
ae
.
ae_ctrl
)
in
let
f
b
ae
=
(
b
||
ae
.
ae_ctrl
)
in
let
c
=
List
.
fold_left
f
false
args
in
{
ae_type
=
t
;
ae_ctrl
=
c
;
ae_val
=
AE_call
(
i
,
args
)}
)
...
...
lutin/src/exp.ml
View file @
9d0c853a
...
...
@@ -238,7 +238,7 @@ let rec (simplifie_a_little : formula -> formula) =
let
f1'
=
simplifie_a_little
f1
and
f2'
=
simplifie_a_little
f2
in
if
f1
<>
f1'
or
f2
<>
f2'
then
if
f1
<>
f1'
||
f2
<>
f2'
then
simplifie_a_little
(
And
(
f1'
,
f2'
))
else
And
(
f1'
,
f2'
)
...
...
@@ -246,7 +246,7 @@ let rec (simplifie_a_little : formula -> formula) =
let
f1'
=
simplifie_a_little
f1
and
f2'
=
simplifie_a_little
f2
in
let
f12'
=
Or
(
f1'
,
f2'
)
in
if
f1
<>
f1'
or
f2
<>
f2'
then
if
f1
<>
f1'
||
f2
<>
f2'
then
simplifie_a_little
f12'
else
f12'
...
...
lutin/src/expand.ml
View file @
9d0c853a
This diff is collapsed.
Click to expand it.
lutin/src/expand.mli
View file @
9d0c853a
...
...
@@ -49,26 +49,28 @@ val make : CheckEnv.t -> Syntaxe.package -> string -> t
type
support_scope
type
support_nature
=
Input
|
Output
|
LocalIn
|
LocalOut
and
support_info
=
{
|
Input
|
Output
|
LocalIn
|
LocalOut
type
support_info
=
{
si_ident
:
CoIdent
.
t
;
si_nature
:
support_nature
;
si_type
:
CkTypeEff
.
t
;
si_ref_exp
:
CoAlgExp
.
t
;
si_src
:
CoIdent
.
src_stack
;
(* on ne la crée qu'à la demande *)
mutable
si_pre_ref_exp
:
CoAlgExp
.
t
option
;
si_pre_ref_exp
:
CoAlgExp
.
t
option
;
si_default
:
CoAlgExp
.
t
option
;
si_scope
:
support_scope
option
;
si_init
:
CoAlgExp
.
t
option
;
si_range
:
(
CoAlgExp
.
t
*
CoAlgExp
.
t
)
option
;
}
open
Util
(* support_info that are actually used in pre's *)
val
support_tab
:
t
->
(
CoIdent
.
t
,
support_info
)
Hashtbl
.
t
val
support_tab
:
t
->
support_info
StringMap
.
t
(* support_info that are actually used in pre's *)
val
support_pres
:
t
->
(
CoIdent
.
t
*
support_info
)
list
...
...
@@ -91,12 +93,12 @@ type alias_info = {
ai_src
:
CoIdent
.
src_stack
}
val
alias_tab
:
t
->
(
CoIdent
.
t
,
alias_info
)
Hashtbl
.
t
val
alias_tab
:
t
->
alias_info
StringMap
.
t
val
alias_list
:
t
->
CoIdent
.
t
list
(* Run tab *)
(* not necessary ?
val run_tab : t -> (CoIdent.t, t)
Hashtbl
.t
val run_tab : t -> (CoIdent.t, t)
StringMap
.t
*)
val
get_run_expanded_code
:
t
->
CoIdent
.
t
->
t
...
...
@@ -108,7 +110,7 @@ type trace_info = {
ti_src
:
CoIdent
.
src_stack
;
}
val
trace_tab
:
t
->
(
CoIdent
.
t
,
trace_info
)
Hashtbl
.
t
val
trace_tab
:
t
->
trace_info
StringMap
.
t
val
get_trace_info
:
t
->
CoIdent
.
t
->
trace_info
...
...
@@ -124,7 +126,7 @@ type extern_info = {
xi_src
:
Lexeme
.
t
}
val
extern_tab
:
t
->
(
string
,
extern_info
)
Hashtbl
.
t
val
extern_tab
:
t
->
extern_info
StringMap
.
t
(** Identificateur (target) de la trace principale *)
val
main_trace
:
t
->
CoIdent
.
t
...
...
lutin/src/luc2alice.ml
View file @
9d0c853a
...
...
@@ -233,15 +233,9 @@ let (gen_alice_stub_c : alice_args -> unit) =
fun
args
->
let
amn
=
Filename
.
basename
args
.
alice_module_name
in
let
oc
=
my_open_out
(
Filename
.
concat
args
.
output_dir
(
amn
^
".cpp"
))
in
let
put
s
=
output_string
oc
s
in
let
putln
s
=
output_string
oc
(
s
^
"
\n
"
)
in
let
rec
putlist
=
function
[]
->
()
|
[
x
]
->
put
x
|
x
::
l'
->
put
x
;
put
", "
;
putlist
l'
in
putln
(
Util
.
entete
"// "
""
);
putln
(
gen_alice_stub
args
)
putln
(
Util
.
entete
"// "
""
);
putln
(
gen_alice_stub
args
)
let
(
gen_alice_stub_h
:
alice_args
->
unit
)
=
...
...
lutin/src/luc2c.ml
View file @
9d0c853a
...
...
@@ -480,7 +480,7 @@ Input procedures must be used:
)
in_vars
;
let
lut_file
=
(
List
.
hd
option
.
env
)
(* only work with lutin XXX fixme? *)
in
let
_
lut_file
=
(
List
.
hd
option
.
env
)
(* only work with lutin XXX fixme? *)
in
(* let lut_dir = Filename.dirname lut_file in *)
putln
(
"
/*--------
...
...
lutin/src/lucFGen.ml
View file @
9d0c853a
...
...
@@ -83,119 +83,119 @@ let (get_all_formula: t -> formula list) =
fun
a
->
let
rec
aux
a
acc
=
let
(
a'
,
f
,
_nl
)
=
choose_one_formula
a
in
if
no_more_formula
a'
then
acc
else
(
aux
a'
(
f
::
acc
))
if
no_more_formula
a'
then
acc
else
(
aux
a'
(
f
::
acc
))
in
aux
a
[]
(****************************************************************************)
let
rec
(
wt_list_to_cont
:
Var
.
env_in
->
Prog
.
state
->
wt_cont
list
->
formula
->
node
list
->
t
->
t
)
=
formula
->
node
list
->
t
->
t
)
=
fun
input
state
wtl
facc
nl
fgen
->
(* [nl] is the list of nodes that correspond to [facc] *)
let
_
=
if
debug
then
(
print_string
"XXX wt_list_to_cont
\n
"
;
flush
stdout
)
in
match
wtl
with
|
[]
->
Cont
(
fun
()
->
(
fgen
,
facc
,
nl
))
|
wt
::
wtl'
->
if
wt
=
WFinish
then
fgen
else
match
choose_one_formula_atomic
input
state
facc
wt
with
|
WFinish
,
False
,
""
->
fgen
|
WStop
str
,
_
,
""
->
RStop
str
|
wt2
,
f2
,
n
->
let
fgen'
=
Cont
(
fun
()
->
call_cont
(
wt_list_to_cont
input
state
(
wt2
::
wtl'
)
facc
nl
fgen
))
in
wt_list_to_cont
input
state
wtl'
f2
(
n
::
nl
)
fgen'
match
wtl
with
|
[]
->
Cont
(
fun
()
->
(
fgen
,
facc
,
nl
))
|
wt
::
wtl'
->
if
wt
=
WFinish
then
fgen
else
match
choose_one_formula_atomic
input
state
facc
wt
with
|
WFinish
,
False
,
""
->
fgen
|
WStop
str
,
_
,
""
->
RStop
str
|
wt2
,
f2
,
n
->
let
fgen'
=
Cont
(
fun
()
->
call_cont
(
wt_list_to_cont
input
state
(
wt2
::
wtl'
)
facc
nl
fgen
))
in
wt_list_to_cont
input
state
wtl'
f2
(
n
::
nl
)
fgen'
and
(
choose_one_formula_atomic
:
Var
.
env_in
->
Prog
.
state
->
Exp
.
formula
->
wt_cont
->
wt_cont
*
formula
*
node
)
=
(
choose_one_formula_atomic
:
Var
.
env_in
->
Prog
.
state
->
Exp
.
formula
->
wt_cont
->
wt_cont
*
formula
*
node
)
=
fun
input
state
facc
cont
->
let
_
=
if
debug
then
(
print_string
"XXX choose_one_formula_atomic
\n
"
;
flush
stdout
)
in
match
cont
with
|
WFinish
->
WFinish
,
False
,
""
|
WStop
_
->
cont
,
True
,
""
|
WCont
_
->
let
(
cont'
,
f
,
n
)
=
call_wt_cont
cont
in
let
_
=
if
debug
then
(
print_string
(
"XXX "
^
n
^
"
\n
"
);
flush
stdout
)
in
let
facc'
=
match
f
,
facc
with
True
,
True
->
True
|
True
,
f
->
f
|
f
,
True
->
f
|
_
,_
->
And
(
f
,
facc
)
in
let
ctx_msg
=
Prog
.
ctrl_state_to_string_long
state
.
d
.
ctrl_state
in
Utils
.
time_C
"is_sat"
;
let
sat
=
(
Solver
.
is_satisfiable
input
state
.
d
.
memory
state
.
d
.
verbose
ctx_msg
facc'
""
)
in
Utils
.
time_R
"is_sat"
;
if
sat
then
(
cont'
,
facc'
,
n
)
else
choose_one_formula_atomic
input
state
facc
cont'
match
cont
with
|
WFinish
->
WFinish
,
False
,
""
|
WStop
_
->
cont
,
True
,
""
|
WCont
_
->
let
(
cont'
,
f
,
n
)
=
call_wt_cont
cont
in
let
_
=
if
debug
then
(
print_string
(
"XXX "
^
n
^
"
\n
"
);
flush
stdout
)
in
let
facc'
=
match
f
,
facc
with
True
,
True
->
True
|
True
,
f
->
f
|
f
,
True
->
f
|
_
,_
->
And
(
f
,
facc
)
in
let
ctx_msg
=
Prog
.
ctrl_state_to_string_long
state
.
d
.
ctrl_state
in
Utils
.
time_C
"is_sat"
;
let
sat
=
(
Solver
.
is_satisfiable
input
state
.
d
.
memory
state
.
d
.
verbose
ctx_msg
facc'
""
)
in
Utils
.
time_R
"is_sat"
;
if
sat
then
(
cont'
,
facc'
,
n
)
else
choose_one_formula_atomic
input
state
facc
cont'
and
(
wt_to_cont
:
Var
.
env_in
->
Prog
.
state
->
wt
->
wt_cont
->
wt_cont
)
=
fun
input
state
(
tbl
,
n
)
cont
->
let
_
=
if
debug
then
(
print_string
(
"XXX wt_to_cont "
^
n
^
"
\n
"
);
flush
stdout
)
in
let
children
=
Util
.
StringMap
.
find
n
tbl
in
match
children
with
|
Prog
.
Stop
str
->
WStop
str
|
Leave
(
f
,
nstate
)
->
WCont
(
fun
()
->
(
cont
,
f
,
nstate
))
|
Children
l
->
if
l
=
[]
then
cont
else
let
(
l1
,
l2
)
=
List
.
partition
(
fun
(
dw
,_
)
->
dw
=
Infin
)
l
in
(
match
l1
with
|
[]
->
let
get_weigth
dw
=
match
dw
with
|
V
i
->
if
i
<
0
then
0
else
i
(* a negative weight means null weigth *)
|
Infin
->
assert
false
in
let
w_sum
=
List
.
fold_left
(
fun
acc
(
dw
,_
)
->
acc
+
(
get_weigth
dw
))
0
l2
in
if
w_sum
=
0
then
cont
else
let
j
=
1
+
Random
.
int
w_sum
in
let
rec
get_jth_trans
j
list
acc
=
match
list
with
[]
->
assert
false
|
(
dw
,
nt
)
::
tail
->
let
newj
=
j
-
(
get_weigth
dw
)
in
if
(
newj
<
1
)
then
nt
,
(
rev_append
acc
tail
)
else
get_jth_trans
newj
tail
((
dw
,
nt
)
::
acc
)
in
let
(
nt
,
l2'
)
=
get_jth_trans
j
l2
[]
in
let
tbl'
=
Util
.
StringMap
.
add
n
(
Children
l2'
)
tbl
in
let
tbl''
=
Util
.
StringMap
.
remove
n
tbl
in
(* to optimize mem *)
let
cont'
=
WCont
(
fun
()
->
call_wt_cont
(
wt_to_cont
input
state
(
tbl'
,
n
)
cont
)
)
in
wt_to_cont
input
state
(
tbl''
,
nt
)
cont'
|
[(
_
,
nt
)]
->
let
tbl'
=
Util
.
StringMap
.
add
n
(
Children
l2
)
tbl
in
let
tbl''
=
Util
.
StringMap
.
remove
n
tbl
in
let
cont'
=
WCont
(
fun
()
->
call_wt_cont
(
wt_to_cont
input
state
(
tbl'
,
n
)
cont
)
)
in
wt_to_cont
input
state
(
tbl''
,
nt
)
cont'
|
_
::_
->
failwith
"Only one transition with a infinite weigth is allowed"
)
match
children
with
|
Prog
.
Stop
str
->
WStop
str
|
Leave
(
f
,
nstate
)
->
WCont
(
fun
()
->
(
cont
,
f
,
nstate
))
|
Children
l
->
if
l
=
[]
then
cont
else
let
(
l1
,
l2
)
=
List
.
partition
(
fun
(
dw
,_
)
->
dw
=
Infin
)
l
in
(
match
l1
with
|
[]
->
let
get_weigth
dw
=
match
dw
with
|
V
i
->
if
i
<
0
then
0
else
i
(* a negative weight means null weigth *)
|
Infin
->
assert
false
in
let
w_sum
=
List
.
fold_left
(
fun
acc
(
dw
,_
)
->
acc
+
(
get_weigth
dw
))
0
l2
in
if
w_sum
=
0
then
cont
else
let
j
=
1
+
Random
.
int
w_sum
in
let
rec
get_jth_trans
j
list
acc
=
match
list
with
[]
->
assert
false
|
(
dw
,
nt
)
::
tail
->
let
newj
=
j
-
(
get_weigth
dw
)
in
if
(
newj
<
1
)
then
nt
,
(
rev_append
acc
tail
)
else
get_jth_trans
newj
tail
((
dw
,
nt
)
::
acc
)
in
let
(
nt
,
l2'
)
=
get_jth_trans
j
l2
[]
in
let
tbl'
=
Util
.
StringMap
.
add
n
(
Children
l2'
)
tbl
in
let
tbl''
=
Util
.
StringMap
.
remove
n
tbl
in
(* to optimize mem *)
let
cont'
=
WCont
(
fun
()
->
call_wt_cont
(
wt_to_cont
input
state
(
tbl'
,
n
)
cont
)
)
in
wt_to_cont
input
state
(
tbl''
,
nt
)
cont'
|
[(
_
,
nt
)]
->
let
tbl'
=
Util
.
StringMap
.
add
n
(
Children
l2
)
tbl
in
let
tbl''
=
Util
.
StringMap
.
remove
n
tbl
in
let
cont'
=
WCont
(
fun
()
->
call_wt_cont
(
wt_to_cont
input
state
(
tbl'
,
n
)
cont
)
)
in
wt_to_cont
input
state
(
tbl''
,
nt
)
cont'
|
_
::_
->
failwith
"Only one transition with a infinite weigth is allowed"
)
(****************************************************************************)
(* NO LONGER EXPORTED *)
let
(
_internal_get
:
Var
.
env_in
->
Prog
.
state
->
t
list
)
=
...
...
@@ -214,7 +214,7 @@ Utils.time_R "wt_to_cont";
Utils
.
time_C
"wt_list_to_cont"
;
let
res
=
wt_list_to_cont
input
state
wt_cont_l
True
[]
Finish
in
Utils
.
time_R
"wt_list_to_cont"
;
res
res
)
nll
...
...
@@ -222,17 +222,17 @@ Utils.time_R "wt_list_to_cont";
(* EXPORTED *)
let
rec
(
fgen_of_t
:
t
->
FGen
.
t
)
=
fun
t
->
{
FGen
.
choose_one_formula
=
(
fun
()
->
let
(
t'
,
s
,
f
)
=
choose_one_formula
t
in
(
fgen_of_t
t'
,
s
,
f
)
)
;
FGen
.
get_all_formula
=
(
fun
()
->
get_all_formula
t
)
}
fun
t
->
{
FGen
.
choose_one_formula
=
(
fun
()
->
let
(
t'
,
s
,
f
)
=
choose_one_formula
t
in
(
fgen_of_t
t'
,
s
,
f
)
)
;
FGen
.
get_all_formula
=
(
fun
()
->
get_all_formula
t
)
}
let
get
i
s
=
List
.
map
fgen_of_t
(
_internal_get
i
s
)
lutin/src/lutExe.ml
View file @
9d0c853a
This diff is collapsed.
Click to expand it.
lutin/src/lutExe.mli
View file @
9d0c853a
...
...
@@ -81,8 +81,7 @@ val find_some_sols : t -> Thickness.formula_draw_nb -> Thickness.numeric -> guar
val
find_one_sol
:
t
->
guard
->
(
Var
.
env_out
*
Var
.
env_loc
)
(* the "t" is given in order to filter necessary pres, not really necessary *)
val
make_pre
:
t
->
Var
.
env_in
->
Var
.
env_out
->
Var
.
env_loc
->
Var
.
env
val
make_pre
:
Var
.
env_in
->
Var
.
env_out
->
Var
.
env_loc
->
Var
.
env
(*
May raise Deadlock (or Event.Error ("deadlock",event))
...
...
lutin/src/lutProg.ml
View file @
9d0c853a
...
...
@@ -320,7 +320,7 @@ let init_vars (it: t) = (
(***********************************************************)
let
add_support
mode
it
id
=
(
let
nme
=
CoIdent
.
to_string
id
in
let
info
=
Util
.
hfind
(
Expand
.
support_tab
source_code
)
id
in
let
info
=
Util
.
StringMap
.
find
id
(
Expand
.
support_tab
source_code
)
in
(* Verbose.put ~flag:dbg " LutProg.add_support \"%s\"\n" nme; *)
let
res
=
lucky_make_var
it
mnode
nme
(
lucky_type_of
info
.
Expand
.
si_type
)
mode
info
.
Expand
.
si_range
in
(* init ? *)
...
...
@@ -344,7 +344,7 @@ let init_vars (it: t) = (
let
add_alias
it
id
=
(
let
nme
=
CoIdent
.
to_string
id
in
Verbose
.
put
~
flag
:
dbg
" LutProg.add_alias
\"
%s
\"\n
"
nme
;
let
info
=
Util
.
hfind
(
Expand
.
alias_tab
source_code
)
id
in
let
info
=
Util
.
StringMap
.
find
id
(
Expand
.
alias_tab
source_code
)
in
(* les alias sont des Local spciaux en lucky *)
let
res
=
Var
.
set_alias
(
lucky_make_var
it
mnode
nme
(
lucky_type_of
info
.
Expand
.
ai_type
)
Var
.
Local
None
)
...
...
lutin/src/lutinRun.ml
View file @
9d0c853a
(* Time-stamp: <modified the 1
0/04/2019 (at 10:10
) by Erwan Jahier> *)
(* Time-stamp: <modified the 1
2/04/2019 (at 11:32
) by Erwan Jahier> *)
(**********************************************************************************)
type
vars
=
(
string
*
Data
.
t
)
list
...
...
@@ -23,6 +23,10 @@ open RdbgPlugin
type
ctx
=
Event
.
t
type
e
=
Event
.
t
let
compact
str
=
let
str
=
Str
.
global_replace
(
Str
.
regexp
"
\n
"
)
";"
str
in
let
str
=
Str
.
global_replace
(
Str
.
regexp
"[
\t
]+"
)
""
str
in
str
let
make
argv
=
let
opt
=
MainArg
.
parse
argv
in
...
...
@@ -122,8 +126,14 @@ let make argv =
match
Hashtbl
.
find_opt
ss_table
i
with
|
Some
(
cs
,
ds
,
prgs
)
->
if
Verbose
.
level
()
>
0
then
(
Printf
.
eprintf
"Restore state %i from Lutin (%i)
\n
"
i
(
Random
.
State
.
bits
(
Random
.
State
.
copy
prgs
));
Printf
.
eprintf
"Restore state %i from Lutin
\n\t
PRGS:%i
\n\t
ins:%s
\n\t
outs:%s
\n\t
mems:%s
\n
"
i
(
Random
.
State
.
bits
(
Random
.
State
.
copy
prgs
))
(
compact
(
Value
.
OfIdent
.
to_string
""
ds
.
LutExe
.
ins
))
(
compact
(
Value
.
OfIdent
.
to_string
""
ds
.
LutExe
.
outs
))
(
compact
(
Value
.
OfIdent
.
to_string
""
ds
.
LutExe
.
mems
))
;
flush
stderr
);