Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
cduce
cduce
Commits
9f389c21
Commit
9f389c21
authored
May 08, 2014
by
Kim Nguyễn
Browse files
Try an early simplification of types.
parent
3f63d285
Changes
1
Hide whitespace changes
Inline
Side-by-side
types/types.ml
View file @
9f389c21
...
...
@@ -2546,9 +2546,7 @@ struct
(* returns a recursive type where all occurrences of alpha n t
* are substituted with a recursive variable X and all fresh variables
* in covariant position are substituted with empty and contravariant
* position with any *)
* are substituted with a recursive variable X *)
let
substituterec
t
alpha
=
let
subst
x
d
=
if
Var
.
equal
d
alpha
then
x
...
...
@@ -2605,9 +2603,9 @@ struct
end
)
in
let
vars
=
Hashtbl
.
create
17
in
let
memo
=
Memo
.
create
17
in
let
t_emp
=
ty
empty
in
let
t_any
=
ty
any
in
let
memo
=
Memo
.
create
17
in
let
t_emp
=
cup
[]
in
let
t_any
=
cap
[]
in
let
idx
=
ref
0
in
(* we memoize based on the pair (pos, v), since v can occur both
...
...
@@ -2623,7 +2621,7 @@ struct
let
td
=
Hashtbl
.
find
vars
d
in
if
((
td
==
t_emp
)
&&
not
pos
)
||
((
td
==
t_any
)
&&
pos
)
then
(* polarity
problem
, replace the binding by a new,
then
(* polarity
conflict
, replace the binding by a new,
pretty-printed variable *)
begin
let
id
=
pretty_name
!
idx
""
in
...
...
@@ -2659,20 +2657,33 @@ struct
descr
(
solve
new_t
)
end
let
clean_type
t
=
if
no_var
t
then
t
else
if
not
(
subtype
t
Arrow
.
any
)
then
clean_variables
t
else
let
_
,
u_arrow
=
Arrow
.
get
t
in
let
rec
uniq
=
function
|
([]
|
[
_
])
as
l
->
l
|
t1
::
((
t2
::
_
)
as
l1
)
->
if
equiv
t1
t2
then
uniq
l1
else
t1
::
uniq
l1
let
clean_type
t
=
if
no_var
t
then
t
else
let
t
=
clean_variables
t
in
let
arrow_t
,
non_arrow_t
=
{
empty
with
arrow
=
t
.
arrow
}
,
{
t
with
arrow
=
empty
.
arrow
}
in
let
_
,
u_arrow
=
Arrow
.
get
arrow_t
in
List
.
fold_left
(
fun
acc
i_arrow
->
T
.
cup
acc
(
(
List
.
fold_left
(
fun
acc
(
dom
,
cdom
)
->
let
conj_arrow
=
(
List
.
fold_left
(
fun
acc
(
dom
,
cdom
)
->
let
indiv_arrow
=
T
.
arrow
(
T
.
cons
dom
)
(
T
.
cons
cdom
)
in
let
pretty_arrow
=
clean_variables
indiv_arrow
in
T
.
cap
acc
pretty_arrow
)
T
.
any
i_arrow
)
indiv_arrow
::
acc
)
[]
i_arrow
)
in
let
sorted_conj
=
List
.
sort
(
fun
t1
t2
->
if
equiv
t1
t2
then
0
else
compare
t1
t2
)
conj_arrow
in
List
.
fold_left
(
T
.
cap
)
T
.
any
(
uniq
sorted_conj
)
)
)
T
.
empty
u_arrow
)
non_arrow_t
u_arrow
end
...
...
@@ -3231,6 +3242,7 @@ let apply_raw s t =
let
get
a
i
=
if
i
<
0
then
any
else
(
!
a
)
.
(
i
)
in
let
gamma
=
var
(
Var
.
mk
"Gamma"
)
in
let
cgamma
=
cons
gamma
in
(* cell i of ai contains /\k<=i s_k, cell j of aj contains /\k<=j t_k *)
let
ai
=
ref
[
|
|
]
and
aj
=
ref
[
|
|
]
in
let
result
=
ref
any
in
...
...
@@ -3244,20 +3256,24 @@ let apply_raw s t =
cap
tacc
(
List
.
fold_left
(
fun
tacc
subst
->
Positive
.
substitute
tacc
subst
)
gamma
constr_lst
))
any
sl
in
let
new_res
=
Positive
.
clean_type
new_res
in
if
subtype
new_res
!
result
&&
not
(
subtype
!
result
new_res
)
then
then
begin
(* strictly improved the result, continue *)
Format
.
printf
"Found a partial solution at %i, %i: %a@
\n
@."
i
j
Print
.
print
new_res
;
result
:=
new_res
end
else
raise
(
Found
(
new_res
,
i
,
j
,
sl
))
with
Tallying
.
Step1Fail
->
raise
(
Tallying
.
UnSatConstr
"apply_raw step1"
)
Tallying
.
Step1Fail
->
(
assert
(
i
==
0
&&
j
==
0
);
raise
(
Tallying
.
UnSatConstr
"apply_raw step1"
)
)
|
Tallying
.
Step2Fail
->
()
(* continue *)
in
let
rec
loop
i
=
try
Format
.
printf
"Starting expansion %i @
\n
@."
i
;
set
ai
(
i
)
(
cap
(
Positive
.
substitutefree
s
)
(
get
ai
(
i
-
1
)));
set
aj
(
i
)
(
cap
(
Positive
.
substitutefree
t
)
(
get
aj
(
i
-
1
)));
set
ai
i
(
cap
(
Positive
.
substitutefree
s
)
(
get
ai
(
i
-
1
)));
set
aj
i
(
cap
(
Positive
.
substitutefree
t
)
(
get
aj
(
i
-
1
)));
for
j
=
0
to
i
-
1
do
tallying
j
i
;
tallying
i
j
;
...
...
@@ -3275,7 +3291,6 @@ let apply_raw s t =
let
apply_full
s
t
=
let
_
,_,_,
res
=
apply_raw
s
t
in
let
res
=
Positive
.
clean_type
res
in
Format
.
printf
"result: %a@
\n
@."
Print
.
print
res
;
res
...
...
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