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
443d9cd8
Commit
443d9cd8
authored
Feb 03, 2015
by
Erwan Jahier
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Update the lus2lic plugin.
parent
3f34cfa4
Changes
31
Hide whitespace changes
Inline
Side-by-side
Showing
31 changed files
with
375 additions
and
303 deletions
+375
-303
source/Lurettetop/Makefile.comon
source/Lurettetop/Makefile.comon
+6
-0
source/lus2lic/actionsDeps.ml
source/lus2lic/actionsDeps.ml
+5
-50
source/lus2lic/actionsDeps.mli
source/lus2lic/actionsDeps.mli
+6
-30
source/lus2lic/ast2lic.ml
source/lus2lic/ast2lic.ml
+4
-4
source/lus2lic/astCore.ml
source/lus2lic/astCore.ml
+5
-3
source/lus2lic/astInstanciateModel.ml
source/lus2lic/astInstanciateModel.ml
+3
-3
source/lus2lic/astV6Dump.ml
source/lus2lic/astV6Dump.ml
+4
-3
source/lus2lic/compile.ml
source/lus2lic/compile.ml
+19
-10
source/lus2lic/l2lCheckLoops.ml
source/lus2lic/l2lCheckLoops.ml
+1
-2
source/lus2lic/l2lExpandArrays.ml
source/lus2lic/l2lExpandArrays.ml
+53
-30
source/lus2lic/l2lExpandNodes.ml
source/lus2lic/l2lExpandNodes.ml
+10
-22
source/lus2lic/l2lSplit.ml
source/lus2lic/l2lSplit.ml
+34
-5
source/lus2lic/l2lSplit.mli
source/lus2lic/l2lSplit.mli
+1
-5
source/lus2lic/lic.ml
source/lus2lic/lic.ml
+1
-1
source/lus2lic/lic2soc.ml
source/lus2lic/lic2soc.ml
+24
-35
source/lus2lic/lic2soc.mli
source/lus2lic/lic2soc.mli
+1
-1
source/lus2lic/licDump.ml
source/lus2lic/licDump.ml
+12
-8
source/lus2lic/licEvalType.ml
source/lus2lic/licEvalType.ml
+41
-40
source/lus2lic/licEvalType.mli
source/lus2lic/licEvalType.mli
+4
-4
source/lus2lic/licName.ml
source/lus2lic/licName.ml
+24
-2
source/lus2lic/licName.mli
source/lus2lic/licName.mli
+5
-1
source/lus2lic/licPrg.ml
source/lus2lic/licPrg.ml
+6
-2
source/lus2lic/licTab.ml
source/lus2lic/licTab.ml
+3
-3
source/lus2lic/lus2licRun.ml
source/lus2lic/lus2licRun.ml
+1
-1
source/lus2lic/lv6MainArgs.ml
source/lus2lic/lv6MainArgs.ml
+17
-8
source/lus2lic/lv6MainArgs.mli
source/lus2lic/lv6MainArgs.mli
+1
-0
source/lus2lic/lv6lexer.mll
source/lus2lic/lv6lexer.mll
+2
-0
source/lus2lic/lv6parser.mly
source/lus2lic/lv6parser.mly
+62
-10
source/lus2lic/lv6parserUtils.ml
source/lus2lic/lv6parserUtils.ml
+15
-15
source/lus2lic/lv6version.ml
source/lus2lic/lv6version.ml
+2
-2
source/lus2lic/socPredef.ml
source/lus2lic/socPredef.ml
+3
-3
No files found.
source/Lurettetop/Makefile.comon
View file @
443d9cd8
...
...
@@ -45,6 +45,8 @@ SOC_SOURCES = \
$(OBJDIR)
/socPredef.ml
\
$(OBJDIR)
/toposort.mli
\
$(OBJDIR)
/toposort.ml
\
$(OBJDIR)
/action.mli
\
$(OBJDIR)
/action.ml
\
$(OBJDIR)
/actionsDeps.mli
\
$(OBJDIR)
/actionsDeps.ml
\
$(OBJDIR)
/sortActions.mli
\
...
...
@@ -118,6 +120,10 @@ LUSTRE_SOURCES = \
$(OBJDIR)
/ast2lic.mli
\
$(OBJDIR)
/ast2lic.ml
\
$(OBJDIR)
/misc.ml
\
$(OBJDIR)
/l2lCheckMemSafe.mli
\
$(OBJDIR)
/l2lCheckMemSafe.ml
\
$(OBJDIR)
/l2lOptimIte.mli
\
$(OBJDIR)
/l2lOptimIte.ml
\
$(OBJDIR)
/l2lCheckLoops.mli
\
$(OBJDIR)
/l2lCheckLoops.ml
\
$(OBJDIR)
/l2lCheckOutputs.mli
\
...
...
source/lus2lic/actionsDeps.ml
View file @
443d9cd8
(** Time-stamp: <modified the
06/01/2015 (at 10:52
) by Erwan Jahier> *)
(** Time-stamp: <modified the
15/01/2015 (at 10:51
) by Erwan Jahier> *)
let
dbg
=
(
Verbose
.
get_flag
"deps"
)
(* exported *)
type
rhs
=
Soc
.
var_expr
list
type
lhs
=
Soc
.
var_expr
list
type
action
=
Lic
.
clock
*
rhs
*
lhs
*
Soc
.
atomic_operation
*
Lxm
.
t
(*********************************************************************************)
let
string_of_action
:
(
action
->
string
)
=
fun
(
c
,
i
,
o
,
p
,
lxm
)
->
(* Version surchargée de Soc.string_of_operation pour afficher les "=" *)
let
string_of_operation
=
function
|
Soc
.
Assign
->
""
|
op
->
SocUtils
.
string_of_operation
op
in
let
string_of_params
p
=
String
.
concat
", "
(
List
.
map
SocUtils
.
string_of_filter
p
)
in
if
o
=
[]
then
Format
.
sprintf
"%s(%s)"
(
string_of_operation
p
)
(
string_of_params
i
)
else
Format
.
sprintf
"%s = %s(%s) on %s"
(
string_of_params
o
)
(
string_of_operation
p
)
(
string_of_params
i
)
(
Lic
.
string_of_clock
c
)
let
string_of_action_simple
:
(
action
->
string
)
=
fun
(
c
,
i
,
o
,
p
,_
)
->
(* Version surchargée de SocUtils.string_of_operation : l'objectif est d'afficher,
en cas de cycle combinatoire, un message d'erreur qui parle le plus possible
à l'utilisateur qui a programmé en V6... Pour cela le mieux (je pense) est
simplement de rendre la variable sur laquelle porte le cycle
*)
let
string_of_operation
=
function
|
Soc
.
Assign
->
""
|
Soc
.
Method
((
n
,
sk
)
,
sname
)
->
n
|
Soc
.
Procedure
(
name
,_,_
)
->
name
in
let
string_of_params
p
=
String
.
concat
", "
(
List
.
map
SocUtils
.
string_of_filter
p
)
in
if
o
=
[]
then
Format
.
sprintf
"%s(%s)"
(
string_of_operation
p
)
(
string_of_params
i
)
else
Format
.
sprintf
"%s = %s(%s)"
(
string_of_params
o
)
(
string_of_operation
p
)
(
string_of_params
i
)
type
action
=
Action
.
t
(*********************************************************************************)
module
OrderedAction
=
struct
...
...
@@ -201,7 +156,7 @@ let rec (actions_of_vars: Soc.var_expr list -> var2actions_tbl -> action list) =
let
string_of_actions
:
Actions
.
t
->
string
=
fun
s
->
let
to_string
a
acc
=
acc
^
(
string_of_action
a
)
^
" ; "
acc
^
(
Action
.
to_string
a
)
^
" ; "
in
"Actions("
^
(
Actions
.
fold
to_string
s
""
)
^
")"
...
...
@@ -219,7 +174,7 @@ let to_string: t -> string = fun m ->
let
to_string
key
value
acc
=
let
entry
=
Format
.
sprintf
"%s
\n
depends on
\"
%s
\"
"
(
string_of_action
key
)
(
Action
.
to_string
key
)
(
string_of_actions
value
)
in
acc
^
entry
^
"
\n
"
...
...
@@ -255,7 +210,7 @@ let build_data_deps_from_actions: (Lic.type_ -> Data.t) -> t -> action list ->
al
in
Verbose
.
exe
~
flag
:
dbg
(
fun
()
->
let
al_str
=
List
.
map
string_of_action
al
in
let
al_str
=
List
.
map
Action
.
to_string
al
in
print_string
"
\n
====> List of actions to be sorted:
\n
"
;
print_string
(
String
.
concat
"
\n
"
al_str
);
print_string
"
\n
====> List of computed dependencies:
\n
"
;
...
...
source/lus2lic/actionsDeps.mli
View file @
443d9cd8
(** Time-stamp: <modified the
06/10/2014 (at 10:45
) by Erwan Jahier> *)
(** Time-stamp: <modified the
15/01/2015 (at 10:43
) by Erwan Jahier> *)
(** Compute dependencies between actions *)
...
...
@@ -11,30 +11,6 @@ val empty : t
val
concat
:
t
->
t
->
t
(** An action is an intermediary data type that is used to translate expressions
into [Soc.gao]. It is basically a clocked Soc.atomic_operation with arguments.
The idea is that each expression is translated into one or several actions.
And those clocks are then translated into guards, so that each action is
translated into a gao.
A more natural Module to define that type in would have been Soc, but that
module is meant to be shared with other front-ends (e.g., lucid-synchrone),
and I prefer that module not to depend on
- such a cutting (expr -> action -> gao)
- The [Eff.clock] name (could have been a module parameter though).
*)
type
rhs
=
Soc
.
var_expr
list
type
lhs
=
Soc
.
var_expr
list
type
action
=
Lic
.
clock
*
rhs
*
lhs
*
Soc
.
atomic_operation
*
Lxm
.
t
val
string_of_action_simple
:
action
->
string
(** Compute the action dependencies that comes from the I/O.
Construit des dépendances entre les actions en reliant les entrées et
...
...
@@ -42,17 +18,17 @@ val string_of_action_simple: action -> string
Lic2soc.lic_to_soc_type is passed in argument to break a dep loop
*)
val
build_data_deps_from_actions
:
(
Lic
.
type_
->
Data
.
t
)
->
t
->
action
list
->
t
val
build_data_deps_from_actions
:
(
Lic
.
type_
->
Data
.
t
)
->
t
->
Action
.
t
list
->
t
(** Use the dependency constraints that come from the SOC (e.g., 'get' before 'set'
in memory SOC).
*)
val
generate_deps_from_step_policy
:
Soc
.
precedence
list
->
(
string
*
action
)
list
->
t
val
generate_deps_from_step_policy
:
Soc
.
precedence
list
->
(
string
*
Action
.
t
)
list
->
t
(** Returns the list of actions that depends on the action in argument. *)
val
find_deps
:
t
->
action
->
action
list
val
have_deps
:
t
->
action
->
bool
val
remove_dep
:
t
->
action
->
t
val
find_deps
:
t
->
Action
.
t
->
Action
.
t
list
val
have_deps
:
t
->
Action
.
t
->
bool
val
remove_dep
:
t
->
Action
.
t
->
t
val
to_string
:
t
->
string
source/lus2lic/ast2lic.ml
View file @
443d9cd8
(* Time-stamp: <modified the
01/09/2014 (at 11:22
) by Erwan Jahier> *)
(* Time-stamp: <modified the
21/01/2015 (at 17:00
) by Erwan Jahier> *)
open
Lxm
...
...
@@ -124,7 +124,7 @@ let do_abstract_static_param x =
match
x
.
it
with
|
StaticParamType
id
->
ASP_type
id
|
StaticParamConst
(
id
,_
)
->
ASP_const
id
|
StaticParamNode
(
id
,_,_,_
)
->
ASP_node
id
|
StaticParamNode
(
id
,_,_,_
,_
)
->
ASP_node
id
let
get_abstract_static_params
...
...
@@ -279,7 +279,7 @@ and check_static_arg
NodeStaticArgLic
(
id
,
neff
.
node_key_eff
)
(* node exp vs node *)
|
(
StaticArgNode
(
Predef_n
(
op
))
,
ASP_node
id
)
->
let
opeff
=
LicEvalType
.
make_node_exp_eff
node_id_solver
None
op
.
it
sa
.
src
in
let
opeff
=
LicEvalType
.
make_node_exp_eff
node_id_solver
None
true
op
.
it
sa
.
src
in
NodeStaticArgLic
(
id
,
opeff
.
node_key_eff
)
|
(
_
,
ASP_type
_
)
->
nature_error
"type"
|
(
_
,
ASP_const
_
)
->
nature_error
"constant"
...
...
@@ -584,7 +584,7 @@ and node_of_static_arg id_solver node_or_node_ident lxm =
|
StaticArgNode
(
CALL_n
ne
)
->
of_node
id_solver
ne
|
StaticArgNode
(
Predef_n
(
op
))
->
LicEvalType
.
make_node_exp_eff
id_solver
None
op
.
it
lxm
LicEvalType
.
make_node_exp_eff
id_solver
None
true
op
.
it
lxm
|
StaticArgNode
(
_
)
->
assert
false
...
...
source/lus2lic/astCore.ml
View file @
443d9cd8
(* Time-stamp: <modified the 2
6/08/2014 (at 16:06
) by Erwan Jahier> *)
(* Time-stamp: <modified the 2
1/01/2015 (at 16:59
) by Erwan Jahier> *)
(** (Raw) Abstract syntax tree of source Lustre Core programs. *)
...
...
@@ -31,14 +31,14 @@ and node_info = {
loc_consts
:
(
Lxm
.
t
*
const_info
)
list
;
def
:
node_def
;
has_mem
:
bool
;
is_safe
:
bool
;
is_safe
:
bool
;
(* safe <=> no side-effect are performed *)
}
and
static_param
=
|
StaticParamType
of
Ident
.
t
|
StaticParamConst
of
Ident
.
t
*
type_exp
|
StaticParamNode
of
(
Ident
.
t
*
var_info
srcflagged
list
*
var_info
srcflagged
list
*
has_mem_flag
)
(
Ident
.
t
*
var_info
srcflagged
list
*
var_info
srcflagged
list
*
has_mem_flag
*
is_safe_flag
)
and
node_vars
=
{
inlist
:
Ident
.
t
list
;
...
...
@@ -70,6 +70,7 @@ and node_body = {
eqs
:
(
eq_info
srcflagged
)
list
;
}
and
has_mem_flag
=
bool
and
is_safe_flag
=
bool
and
eq_info
=
(
left_part
list
*
val_exp
)
...
...
@@ -149,6 +150,7 @@ and static_arg =
|
StaticArgIdent
of
Ident
.
idref
|
StaticArgConst
of
val_exp
|
StaticArgType
of
type_exp
|
StaticArgNode
of
by_pos_op
(* | StaticArgFunc of node_exp *)
...
...
source/lus2lic/astInstanciateModel.ml
View file @
443d9cd8
(* Time-stamp: <modified the
11/04/2013 (at 15
:47) by Erwan Jahier> *)
(* Time-stamp: <modified the
21/01/2015 (at 16
:47) by Erwan Jahier> *)
open
Lxm
open
AstV6
...
...
@@ -79,7 +79,7 @@ let (check_arg :
put_in_tab
"const"
ctab
s
y
;
((
ConstItem
s
)
::
defs
,
x
::
prov
)
)
|
StaticParamNode
(
s
,
inl
,
outl
,
has_memory
)
->
(
|
StaticParamNode
(
s
,
inl
,
outl
,
has_memory
,
is_safe
)
->
(
let
arg
=
find_arg
s
in
let
by_pos_op
=
match
(
arg
.
it
)
with
|
StaticArgIdent
idr
->
CALL_n
(
Lxm
.
flagit
((
idr
,
[]
))
arg
.
src
)
...
...
@@ -94,7 +94,7 @@ let (check_arg :
loc_consts
=
[]
;
def
=
Alias
(
flagit
by_pos_op
arg
.
src
);
has_mem
=
has_memory
;
is_safe
=
tru
e
;
is_safe
=
is_saf
e
;
}
in
let
x
=
Lxm
.
flagit
(
NodeInfo
ni
)
param
.
src
in
...
...
source/lus2lic/astV6Dump.ml
View file @
443d9cd8
(* Time-stamp: <modified the 2
4/04/2013 (at 17:25
) by Erwan Jahier> *)
(* Time-stamp: <modified the 2
1/01/2015 (at 16:56
) by Erwan Jahier> *)
open
Lxm
...
...
@@ -197,8 +197,9 @@ and dump_static_param
|
StaticParamType
id
->
fprintf
os
"type %s"
(
Ident
.
to_string
id
)
|
StaticParamConst
(
id
,
exp
)
->
fprintf
os
"const %s : %a"
(
Ident
.
to_string
id
)
dump_type_exp
exp
|
StaticParamNode
(
id
,
ins
,
outs
,
has_mem
)
->
(
fprintf
os
"%s %s(@,%a@,)returns(@,%a@,)"
|
StaticParamNode
(
id
,
ins
,
outs
,
has_mem
,
is_safe
)
->
(
fprintf
os
"%s%s %s(@,%a@,)returns(@,%a@,)"
(
if
is_safe
then
""
else
"unsafe "
)
(
if
has_mem
then
"node"
else
"function"
)
(
Ident
.
to_string
id
)
dump_line_var_decl_list
ins
dump_line_var_decl_list
outs
...
...
source/lus2lic/compile.ml
View file @
443d9cd8
(* Time-stamp: <modified the
02/10/2014 (at 11:41
) by Erwan Jahier> *)
(* Time-stamp: <modified the
21/01/2015 (at 15:15
) by Erwan Jahier> *)
open
Lxm
open
Lv6errors
...
...
@@ -41,21 +41,30 @@ let (doit : Lv6MainArgs.t -> AstV6.pack_or_model list -> Ident.idref option -> L
in
info
"Converting to lic_prg...
\n
"
;
let
zelic
=
LicTab
.
to_lic_prg
lic_tab
in
info
"Check safety and memory declarations...
\n
"
;
L2lCheckMemSafe
.
doit
zelic
;
let
zelic
=
if
not
opt
.
Lv6MainArgs
.
optim_ite
then
zelic
else
(
info
"Optimizing if/then/else...
\n
"
;
L2lOptimIte
.
doit
zelic
)
in
let
zelic
=
(* limination polymorphisme surcharge *)
info
"Removing polymorphism...
\n
"
;
let
zelic
=
L2lRmPoly
.
doit
zelic
in
info
"Removing polymorphism...
\n
"
;
L2lRmPoly
.
doit
zelic
in
let
zelic
=
if
not
opt
.
Lv6MainArgs
.
inline_iterator
then
zelic
else
(
info
"Inlining iterators...
\n
"
;
(* to be done before array expansion otherwise they won't be expanded *)
L2lExpandMetaOp
.
doit
zelic
)
in
let
zelic
=
if
Lv6MainArgs
.
global_opt
.
Lv6MainArgs
.
one_op_per_equation
let
zelic
=
if
Lv6MainArgs
.
global_opt
.
Lv6MainArgs
.
one_op_per_equation
||
opt
.
Lv6MainArgs
.
expand_nodes
(* expand performs no fixpoint, so it will work
only if we have one op per equation...*)
then
(
then
(
(* Split des equations (1 eq = 1 op) *)
info
"One op per equations...
\n
"
;
L2lSplit
.
doit
opt
zelic
)
...
...
@@ -85,7 +94,7 @@ let (doit : Lv6MainArgs.t -> AstV6.pack_or_model list -> Ident.idref option -> L
if
opt
.
Lv6MainArgs
.
expand_nodes
then
(
if
long_match_idref
long
mn
then
(
long
,
sargs
)
::
acc
else
acc
)
else
if
List
.
exists
(
long_match_idref
long
)
ids_to_expand
List
.
exists
(
long_match_idref
long
)
ids_to_expand
then
acc
else
...
...
@@ -116,11 +125,11 @@ let (doit : Lv6MainArgs.t -> AstV6.pack_or_model list -> Ident.idref option -> L
info "Aliasing arrays...\n";
let zelic = L2lAliasType.doit zelic in
*)
(* Currently only works in this mode *)
if
Lv6MainArgs
.
global_opt
.
Lv6MainArgs
.
ec
then
(
info
"Check loops...
\n
"
;
L2lCheckLoops
.
doit
zelic
);
L2lCheckLoops
.
doit
zelic
);
info
"Check unique outputs...
\n
"
;
L2lCheckOutputs
.
doit
zelic
;
info
"Lic Compilation done!
\n
"
;
...
...
source/lus2lic/l2lCheckLoops.ml
View file @
443d9cd8
(* Time-stamp: <modified the
13/08/2014 (at 16:24
) by Erwan Jahier> *)
(* Time-stamp: <modified the
21/01/2015 (at 14:37
) by Erwan Jahier> *)
open
Lxm
open
Lv6errors
...
...
@@ -117,7 +117,6 @@ let (check_node : Lic.node_exp -> unit) =
let
f
id
_
vi
=
visit
deps
vi
id
[]
in
ignore
(
IdMap
.
fold
f
deps
vi
)
exception
Compile_error_gen
of
Lxm
.
t
*
string
(* exported *)
let
(
doit
:
LicPrg
.
t
->
unit
)
=
...
...
source/lus2lic/l2lExpandArrays.ml
View file @
443d9cd8
(** Time-stamp: <modified the
03/09/2014 (at 10:55
) by Erwan Jahier> *)
(** Time-stamp: <modified the
14/01/2015 (at 14:53
) by Erwan Jahier> *)
(* Replace structures and arrays by as many variables as necessary.
Since structures can be nested, it migth be a lot of new variables...
...
...
@@ -219,10 +219,28 @@ let (expand_left : local_ctx -> left -> left list) =
in
flatten_var_tree
vt
let
rec
unfold
i
x
=
if
i
<
0
then
[]
else
x
::
(
unfold
(
i
-
1
)
x
)
let
rec
(
expand_array_types
:
Lic
.
type_
list
->
Lic
.
type_
list
)
=
fun
tl
->
(* arrays are transformed into tuples *)
List
.
flatten
(
List
.
map
aux
tl
)
and
(
aux
:
Lic
.
type_
->
Lic
.
type_
list
)
=
function
|
Array_type_eff
(
st
,
i
)
->
unfold
i
st
|
t
->
[
t
]
(* arrays within abstract and struct won't be translated.
XXX should i raise an error saying that -esa is not
compatible with structure of arrays (instead of silently
returns arrays) ? To handle them, i would need to modify
Lic.type_ and to replace 'type_' by 'type_ list' in all
the recursive cases. It would be quite a lot of work and
-esa is not a useful option anymore... *)
(********************************************************************************)
(** build a new loc that will alias ve, and add its definition in the
set of equations (cf acc) *)
set of equations (cf acc) *)
let
rec
(
make_new_loc
:
local_ctx
->
Lxm
.
t
->
acc
->
Lic
.
val_exp
->
acc
*
var_info
)
=
fun
lctx
lxm
acc
ve
->
...
...
@@ -243,7 +261,7 @@ and (var_trees_of_val_exp :
let
id
=
prefix
in
{
ve_core
=
CallByPosLic
({
src
=
lxm
;
it
=
(
VAR_REF
id
)}
,
[]
);
ve_typ
=
[
vi
.
var_type_
eff
]
;
ve_typ
=
[
t
eff
]
;
ve_clk
=
[
snd
vi
.
var_clock_eff
]
}
in
...
...
@@ -316,7 +334,7 @@ and (var_trees_of_val_exp :
|
HAT
(
_
)
|
CONCAT
|
ARRAY
|
PREDEF_CALL
_
|
CALL
_
|
PRE
|
ARROW
|
FBY
|
CURRENT
_
|
WHEN
_
|
TUPLE
->
(
(* Create a new loc var to alias such expressions *)
(* Create a new loc var to alias such expressions *)
let
acc
,
nloc
=
make_new_loc
lctx
lxm
acc
ve
in
acc
,
gen_var_trees
(
make_val_exp
lxm
nloc
)
""
nloc
.
var_type_eff
)
...
...
@@ -333,7 +351,7 @@ and do_const acc lctx lxm const =
let
ve_const
,
acc
=
match
ve_const
.
ve_core
with
|
CallByPosLic
({
it
=
CONST_REF
_
}
,_
)
->
(* in order to avoid a potential infinite loop *)
(* in order to avoid a potential infinite loop *)
(
ve_const
,
acc
)
|
_
->
expand_val_exp
lctx
acc
ve_const
...
...
@@ -342,9 +360,9 @@ and do_const acc lctx lxm const =
and
(
break_tuple
:
Lxm
.
t
->
left
list
->
val_exp
->
Lic
.
eq_info
srcflagged
list
)
=
fun
lxm
left_list
ve
->
(* Note that this work only if the node expansion has already
been done! (otherwise, we would not have the same number of
items in the left and in the rigth part) *)
(* Note that this work only if the node expansion has already
been done! (otherwise, we would not have the same number of
items in the left and in the rigth part) *)
let
rec
aux
ve
=
(* flatten val exp*)
match
ve
.
ve_core
with
|
CallByPosLic
({
it
=
TUPLE
}
,
vel
)
...
...
@@ -408,8 +426,8 @@ and (break_tuple : Lxm.t -> left list -> val_exp -> Lic.eq_info srcflagged list)
else
let
vel
=
aux
ve
in
if
(
List
.
length
vel
<>
lll
)
then
(* migth occur for generic nodes, that needs to be compiled,
but that will not be dumped. *)
(* migth occur for generic nodes, that needs to be compiled,
but that will not be dumped. *)
[{
src
=
lxm
;
it
=
(
left_list
,
ve
)
}]
else
List
.
map2
...
...
@@ -455,16 +473,17 @@ and (expand_val_exp: local_ctx -> acc -> val_exp -> val_exp * acc) =
match
by_pos_op
with
|
HAT
(
i
)
->
(
let
ve
,
acc
=
expand_val_exp
lctx
acc
(
List
.
hd
vel
)
in
let
rec
unfold
cpt
=
if
cpt
=
0
then
[]
else
ve
::
(
unfold
(
cpt
-
1
))
let
rec
unfold
(
cpt
,
ve_acc
)
=
if
cpt
=
0
then
ve_acc
else
(
unfold
(
cpt
-
1
,
ve
::
ve_acc
))
in
TUPLE
,
acc
,
unfold
i
let
ve
=
unfold
(
i
,
[]
)
in
TUPLE
,
acc
,
ve
)
|
CONCAT
|
PREDEF_CALL
_
|
CALL
_
|
PRE
|
ARROW
|
FBY
|
CURRENT
_
|
WHEN
_
|
TUPLE
|
CONST
_
->
let
vel
,
acc
=
expand_val_exp_list
lctx
acc
vel
in
by_pos_op
,
acc
,
vel
by_pos_op
,
acc
,
vel
|
ARRAY
->
let
vel
,
acc
=
expand_val_exp_list
lctx
acc
vel
in
TUPLE
,
acc
,
vel
...
...
@@ -475,21 +494,25 @@ and (expand_val_exp: local_ctx -> acc -> val_exp -> val_exp * acc) =
|
CONST_REF
_
->
let
acc
,
vt
=
try
var_trees_of_val_exp
lctx
acc
ve
with
(
Not_found
|
Failure
_
)
->
assert
false
(*
just
a defense against nth and assoc *)
assert
false
(*
SNO:
a defense against nth and assoc *)
in
TUPLE
,
acc
,
flatten_var_tree
vt
TUPLE
,
acc
,
flatten_var_tree
vt
in
let
newve
=
CallByPosLic
(
Lxm
.
flagit
by_pos_op
lxm
,
vel
)
in
let
newve
=
{
ve
with
ve_core
=
newve
}
in
(* if newve.core <> ve.core then ( *)
(* EvalClock.copy newve ve *)
(* ); *)
let
newve
=
{
ve
with
ve_core
=
newve
;
ve_typ
=
expand_array_types
ve
.
ve_typ
;
}
in
(* if newve.core <> ve.core then ( *)
(* EvalClock.copy newve ve *)
(* ); *)
newve
,
acc
|
CallByNameLic
(
by_name_op
,
fl_val
)
->
(* we want to print fields in the order of the type.
Moreover, we have to deal with default value.
*)
(* we want to print fields in the order of the type.
Moreover, we have to deal with default value.
*)
let
teff
=
ve
.
ve_typ
in
match
teff
with
|
[
Struct_type_eff
(
_
,
fl
)]
->
...
...
@@ -504,7 +527,7 @@ and (expand_val_exp: local_ctx -> acc -> val_exp -> val_exp * acc) =
with
Not_found
->
match
const_opt
with
|
None
->
assert
false
(* ougth to have been checked before *)
(* ougth to have been checked before *)
|
Some
const
->
let
s
,
ve_const
=
(* XXX *)
UnifyClock
.
const_to_val_eff
lxm
true
...
...
@@ -524,9 +547,9 @@ and (expand_val_exp: local_ctx -> acc -> val_exp -> val_exp * acc) =
ve_core
=
CallByPosLic
({
src
=
lxm
;
it
=
TUPLE
}
,
(
List
.
rev
vel
))
}
in
(* if newve.core <> ve.core then ( *)
(* EvalClock.copy newve ve *)
(* ); *)
(* if newve.core <> ve.core then ( *)
(* EvalClock.copy newve ve *)
(* ); *)
newve
,
acc
|
_
->
assert
false
...
...
@@ -563,10 +586,10 @@ and (expand_var_info: local_ctx -> var_info list * acc ->
let
new_var
=
clone_var
lctx
vi
(
"_"
^
soi
i
)
at
in
let
new_vil
,
new_acc
=
expand_var_info
lctx
(
vil
,
acc
)
new_var
in
if
new_vil
=
new_var
::
vil
then
(
(* [new_var] type is not made of structure *)
(* [new_var] type is not made of structure *)
assert
(
is_a_basic_type
at
);
(* XXX
Hashtbl.add nenv.lenv_vars new_var.var_name_eff new_var *)
(* XXX
Hashtbl.add nenv.lenv_vars new_var.var_name_eff new_var *)
);
local_aux
(
i
+
1
)
(
new_vil
,
new_acc
)
in
...
...
source/lus2lic/l2lExpandNodes.ml
View file @
443d9cd8
(* Time-stamp: <modified the
09/10/2014 (at 17:31
) by Erwan Jahier> *)
(* Time-stamp: <modified the
16/01/2015 (at 10:18
) by Erwan Jahier> *)
open
Lxm
...
...
@@ -15,25 +15,7 @@ type local_ctx = {
}
(********************************************************************************)
(* stuff to create fresh var names.
XXX code dupl. with Split.new_var
*)
let
new_var
str
lctx
type_eff
clock_eff
=
let
id
=
Ident
.
of_string
(
LicName
.
new_local_var
str
)
in
let
var
=
{
var_name_eff
=
id
;
var_nature_eff
=
AstCore
.
VarLocal
;
var_number_eff
=
-
1
;
(* this field is used only for i/o.
Should i rather put something sensible there ? *)
var_type_eff
=
type_eff
;
var_clock_eff
=
clock_eff
;
}
in
(* let clk_str = string_of_clock (snd clock_eff) in *)
(* print_string (" ===> creating "^id^ " from " ^ str^ " with clock " ^clk_str ^ "\n");flush stdout; *)
var
let
new_var
=
LicName
.
new_var_info
(********************************************************************************)
let
get_locals
node
=
...
...
@@ -133,7 +115,7 @@ type acc =
let
(
mk_fresh_loc
:
local_ctx
->
var_info
->
clock
->
var_info
)
=
fun
lctx
v
c
->
new_var
(
Ident
.
to_string
v
.
var_name_eff
)
lctx
v
.
var_type_eff
(
fst
v
.
var_clock_eff
,
c
)
new_var
(
Ident
.
to_string
v
.
var_name_eff
)
v
.
var_type_eff
(
fst
v
.
var_clock_eff
,
c
)
(* When expanding a node call such as
...
...
@@ -294,10 +276,16 @@ and (expand_eq_aux: local_ctx -> Lic.eq_info -> local_ctx * acc option)=
and
(
expand_assert
:
local_ctx
*
acc
->
val_exp
srcflagged
->
local_ctx
*
acc
)
=
fun
(
lctx
,
(
a_acc
,
e_acc
,
v_acc
))
ve
->
(* assert(ve);
is transformed into
assert_var=ve;
assert(assert_var);
where assert_var is a fresh new local var
*)
let
lxm
=
ve
.
src
in
let
ve
=
ve
.
it
in
let
clk
=
Ident
.
of_string
"dummy_expand_assert"
,
BaseLic
in
let
assert_var
=
new_var
"assert"
lctx
Bool_type_eff
clk
in
let
assert_var
=
new_var
"assert"
Bool_type_eff
clk
in
let
assert_eq
=
Lxm
.
flagit
([
LeftVarLic
(
assert_var
,
lxm
)]
,
ve
)
lxm
in
let
assert_op
=
Lic
.
VAR_REF
(
assert_var
.
var_name_eff
)
in
let
nve
=
{
...
...
source/lus2lic/l2lSplit.ml
View file @
443d9cd8
...
...
@@ -16,6 +16,9 @@ let info msg =
Verbose
.
exe
~
flag
:
dbg
(
fun
()
->
Printf
.
eprintf
"%4.4f: %s%!"
t
msg
)
(********************************************************************************)
(* XXX use LicName.new_var_info *)
let
new_var
getid
type_eff
clock_eff
=
let
id
=
getid
"v"
in
let
var
=
...
...
@@ -187,13 +190,39 @@ and (split_val_exp : bool -> bool -> LicPrg.id_generator -> Lic.val_exp ->
is no "when"...
*)
match
ve
.
ve_core
with
|
Merge
(
ce
,
cl
)
->
|
Merge
(
ce
,
cl
)
->
(
let
ce
,
(
eql1
,
vl1
)
=
split_val_exp
false
false
getid
ce
in
let
const_l
,
vel
=
List
.
split
cl
in
let
vel
,
(
eql2
,
vl2
)
=
split_val_exp_list
false
false
getid
vel
in
let
eql
,
vl
=
eql1
@
eql2
,
vl1
@
vl2
in
let
cl
=
List
.
combine
const_l
vel
in
{
ve
with
ve_core
=
Merge
(
ce
,
cl
)}
,
(
eql1
@
eql2
,
vl1
@
vl2
)