Mentions légales du service
Skip to content
GitLab
Explore
Sign in
Primary navigation
Search or go to…
Project
why3
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Deploy
Releases
Container registry
Monitor
Service Desk
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Why3
why3
Commits
6a62c33e
Commit
6a62c33e
authored
10 years ago
by
Andrei Paskevich
Browse files
Options
Downloads
Patches
Plain Diff
Mlw: region-per-value instead of region-per-field
parent
836af666
No related branches found
No related tags found
No related merge requests found
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
src/mlw/ity.ml
+144
-221
144 additions, 221 deletions
src/mlw/ity.ml
src/mlw/ity.mli
+22
-51
22 additions, 51 deletions
src/mlw/ity.mli
with
166 additions
and
272 deletions
src/mlw/ity.ml
+
144
−
221
View file @
6a62c33e
...
@@ -12,22 +12,17 @@
...
@@ -12,22 +12,17 @@
open
Stdlib
open
Stdlib
open
Ident
open
Ident
open
Ty
open
Ty
(*
open Term
*)
(** {2 Individual types (first-order types w/o effects)} *)
(** {2 Individual types (first-order types w/o effects)} *)
type
itysymbol
=
{
type
itysymbol
=
{
its_ts
:
tysymbol
;
(** pure "snapshot" type symbol *)
its_ts
:
tysymbol
;
(** pure "snapshot" type symbol *)
its_def
:
ity
option
;
(** is a type alias *)
its_mutable
:
bool
;
(** is a record with mutable fields *)
its_mutable
:
bool
;
(** is a record with mutable fields *)
its_
shared
:
ity
list
;
(** mutable shareable components *)
its_
regions
:
ity
list
;
(** mutable shareable components *)
its_visible
:
bool
list
;
(** non-ghost shareable components *)
its_visible
:
bool
list
;
(** non-ghost shareable components *)
its_
access
:
bool
list
;
(** accessible type argument
s *)
its_
def
:
ity
option
;
(** is a type alia
s *)
}
}
(** ity = individual type in programs, first-order, i.e. no functions *)
and
ity
=
{
and
ity
=
{
ity_node
:
ity_node
;
ity_node
:
ity_node
;
ity_tag
:
Weakhtbl
.
tag
;
ity_tag
:
Weakhtbl
.
tag
;
...
@@ -39,7 +34,7 @@ and ity_node =
...
@@ -39,7 +34,7 @@ and ity_node =
|
Ityapp
of
itysymbol
*
ity
list
*
region
list
|
Ityapp
of
itysymbol
*
ity
list
*
region
list
|
Itymut
of
itysymbol
*
ity
list
*
region
list
*
tvsymbol
|
Itymut
of
itysymbol
*
ity
list
*
region
list
*
tvsymbol
and
region
=
ity
and
region
=
ity
(** regions are itys of the [Itymut] kind *)
(* value type symbols *)
(* value type symbols *)
...
@@ -59,9 +54,6 @@ let ity_equal : ity -> ity -> bool = (==)
...
@@ -59,9 +54,6 @@ let ity_equal : ity -> ity -> bool = (==)
let
its_hash
its
=
id_hash
its
.
its_ts
.
ts_name
let
its_hash
its
=
id_hash
its
.
its_ts
.
ts_name
let
ity_hash
ity
=
Weakhtbl
.
tag_hash
ity
.
ity_tag
let
ity_hash
ity
=
Weakhtbl
.
tag_hash
ity
.
ity_tag
let
reg_equal
=
ity_equal
let
reg_hash
=
ity_hash
module
Hsity
=
Hashcons
.
Make
(
struct
module
Hsity
=
Hashcons
.
Make
(
struct
type
t
=
ity
type
t
=
ity
...
@@ -106,18 +98,6 @@ module Mreg = Mity
...
@@ -106,18 +98,6 @@ module Mreg = Mity
module
Hreg
=
Hity
module
Hreg
=
Hity
module
Wreg
=
Wity
module
Wreg
=
Wity
exception
NotMutable
of
ity
let
ity_of_region
reg
=
reg
let
region_of_ity
ity
=
match
ity
.
ity_node
with
|
Itymut
_
->
ity
|
_
->
raise
(
NotMutable
ity
)
let
open_region
reg
=
match
reg
.
ity_node
with
|
Itymut
(
s
,
tl
,
rl
,
tv
)
->
s
,
tl
,
rl
,
tv
|
_
->
assert
false
let
mk_ity
n
=
{
let
mk_ity
n
=
{
ity_node
=
n
;
ity_node
=
n
;
ity_tag
=
Weakhtbl
.
dummy_tag
;
ity_tag
=
Weakhtbl
.
dummy_tag
;
...
@@ -128,6 +108,25 @@ let ity_pur_unsafe s tl = Hsity.hashcons (mk_ity (Itypur (s,tl)))
...
@@ -128,6 +108,25 @@ let ity_pur_unsafe s tl = Hsity.hashcons (mk_ity (Itypur (s,tl)))
let
ity_app_unsafe
s
tl
rl
=
Hsity
.
hashcons
(
mk_ity
(
Ityapp
(
s
,
tl
,
rl
)))
let
ity_app_unsafe
s
tl
rl
=
Hsity
.
hashcons
(
mk_ity
(
Ityapp
(
s
,
tl
,
rl
)))
let
ity_mut_unsafe
s
tl
rl
v
=
Hsity
.
hashcons
(
mk_ity
(
Itymut
(
s
,
tl
,
rl
,
v
)))
let
ity_mut_unsafe
s
tl
rl
v
=
Hsity
.
hashcons
(
mk_ity
(
Itymut
(
s
,
tl
,
rl
,
v
)))
let
tv_of_region
reg
=
match
reg
.
ity_node
with
|
Itymut
(
_
,_,_,
tv
)
->
tv
|
_
->
invalid_arg
"Ity.tv_of_region"
let
open_region
reg
=
match
reg
.
ity_node
with
|
Itymut
(
s
,
tl
,
rl
,
tv
)
->
s
,
tl
,
rl
,
tv
|
_
->
invalid_arg
"Ity.open_region"
let
ity_mut_fresh_unsafe
s
tl
rl
=
ity_mut_unsafe
s
tl
rl
(
create_tvsymbol
(
id_fresh
"rho"
))
let
ity_mut_known_unsafe
s
tl
rl
v
=
let
ity
=
ity_mut_unsafe
s
tl
rl
v
in
let
s'
,
tl'
,
rl'
,_
=
open_region
ity
in
assert
(
its_equal
s
s'
);
assert
(
Lists
.
equal
ity_equal
tl
tl'
);
assert
(
Lists
.
equal
ity_equal
rl
rl'
);
ity
(* generic traversal functions *)
(* generic traversal functions *)
let
ity_fold
fn
acc
ity
=
match
ity
.
ity_node
with
let
ity_fold
fn
acc
ity
=
match
ity
.
ity_node
with
...
@@ -197,7 +196,7 @@ let ity_r_all pr ity =
...
@@ -197,7 +196,7 @@ let ity_r_all pr ity =
let
ity_r_any
pr
ity
=
let
ity_r_any
pr
ity
=
try
ity_r_fold
(
Util
.
any_fn
pr
)
false
ity
with
Util
.
FoldSkip
->
true
try
ity_r_fold
(
Util
.
any_fn
pr
)
false
ity
with
Util
.
FoldSkip
->
true
let
ity_r_occurs
r
ity
=
ity_r_any
(
reg
_equal
r
)
ity
let
ity_r_occurs
r
ity
=
ity_r_any
(
ity
_equal
r
)
ity
let
ity_immutable
ity
=
ity_r_all
(
fun
_
->
false
)
ity
let
ity_immutable
ity
=
ity_r_all
(
fun
_
->
false
)
ity
...
@@ -209,10 +208,10 @@ let rec fold_nonghost on_reg acc ity =
...
@@ -209,10 +208,10 @@ let rec fold_nonghost on_reg acc ity =
match
ity
.
ity_node
with
match
ity
.
ity_node
with
|
Ityvar
_
->
acc
|
Ityvar
_
->
acc
|
Itypur
(
_
,
tl
)
->
List
.
fold_left
fnt
acc
tl
|
Itypur
(
_
,
tl
)
->
List
.
fold_left
fnt
acc
tl
|
Ityapp
({
its_visible
=
vis
}
,
tl
,
rl
)
->
|
Ityapp
({
its_visible
=
vis
}
,
tl
,
rl
)
->
let
acc
=
List
.
fold_left2
fnr
acc
vis
rl
in
let
acc
=
List
.
fold_left2
fnr
acc
vis
rl
in
List
.
fold_left
fnt
acc
tl
List
.
fold_left
fnt
acc
tl
|
Itymut
({
its_visible
=
vis
}
,
tl
,
rl
,_
)
->
|
Itymut
({
its_visible
=
vis
}
,
tl
,
rl
,_
)
->
let
acc
=
on_reg
ity
acc
in
let
acc
=
on_reg
ity
acc
in
let
acc
=
List
.
fold_left2
fnr
acc
vis
rl
in
let
acc
=
List
.
fold_left2
fnr
acc
vis
rl
in
List
.
fold_left
fnt
acc
tl
List
.
fold_left
fnt
acc
tl
...
@@ -232,29 +231,10 @@ exception BadRegArity of itysymbol * int
...
@@ -232,29 +231,10 @@ exception BadRegArity of itysymbol * int
exception
DuplicateRegion
of
region
exception
DuplicateRegion
of
region
exception
UnboundRegion
of
region
exception
UnboundRegion
of
region
let
_ity_var
n
=
ity_var
n
exception
TypeMismatch
of
ity
*
ity
*
ity
Mtv
.
t
let
_ity_pur_unsafe
s
tl
=
ity_pur_unsafe
s
tl
let
_ity_app_unsafe
s
tl
rl
=
ity_app_unsafe
s
tl
rl
let
_ity_mut_unsafe
s
tl
rl
v
=
ity_mut_unsafe
s
tl
rl
v
(*
type ity_subst = ity Mtv.t
(* every tvsymbol, both in Ityvar and Itymut, must be covered *)
let ity_subst_empty = Mtv.empty;
(*
exception RegionMismatch of region * region * ity_subst
*)
exception TypeMismatch of ity * ity * ity_subst
let
ity_equal_check
ty1
ty2
=
let
ity_equal_check
ty1
ty2
=
if not (ity_equal ty1 ty2) then raise (TypeMismatch (ty1,ty2,ity_subst_empty))
if
not
(
ity_equal
ty1
ty2
)
then
raise
(
TypeMismatch
(
ty1
,
ty2
,
Mtv
.
empty
))
(*
let reg_equal_check r1 r2 =
if not (reg_equal r1 r2) then raise (RegionMismatch (r1,r2,ity_subst_empty))
*)
let
ity_full_inst
s
ity
=
let
ity_full_inst
s
ity
=
if
Mtv
.
is_empty
s
then
ity
else
if
Mtv
.
is_empty
s
then
ity
else
...
@@ -264,165 +244,159 @@ let ity_full_inst s ity =
...
@@ -264,165 +244,159 @@ let ity_full_inst s ity =
|
Ityvar
v
|
Itymut
(
_
,_,_,
v
)
->
Mtv
.
find
v
s
in
|
Ityvar
v
|
Itymut
(
_
,_,_,
v
)
->
Mtv
.
find
v
s
in
inst
ity
inst
ity
let
rec
ity_match
sbs
ity1
ity2
=
match
ity1
.
ity_node
,
ity2
.
ity_node
with
let reg_full_inst s r = Mreg.find r s.ity_subst_reg
|
(
Itymut
(
_
,_,_,
v1
)
|
Ityvar
v1
)
,
_
when
Mtv
.
mem
v1
sbs
->
if
ity_equal
(
Mtv
.
find
v1
sbs
)
ity2
then
sbs
else
raise
Exit
let ity_full_inst s ity =
|
Itymut
(
s1
,
l1
,
r1
,
v1
)
,
Itymut
(
s2
,
l2
,
r2
,_
)
when
its_equal
s1
s2
->
if ity_closed ity && ity_immutable ity then ity
let
sbs
=
List
.
fold_left2
ity_match
sbs
l1
l2
in
else ity_subst_unsafe s.ity_subst_tv s.ity_subst_reg ity
let
sbs
=
List
.
fold_left2
ity_match
sbs
r1
r2
in
Mtv
.
add
v1
ity2
sbs
let rec ity_match s ity1 ity2 =
|
Ityapp
(
s1
,
l1
,
r1
)
,
Ityapp
(
s2
,
l2
,
r2
)
when
its_equal
s1
s2
->
let set = function
let
sbs
=
List
.
fold_left2
ity_match
sbs
l1
l2
in
| None -> Some ity2
List
.
fold_left2
ity_match
sbs
r1
r2
| Some ity3 as r when ity_equal ity3 ity2 -> r
| _ -> raise Exit
in
match ity1.ity_node, ity2.ity_node with
| Ityapp (s1, l1, r1), Ityapp (s2, l2, r2) when its_equal s1 s2 ->
let s = List.fold_left2 ity_match s l1 l2 in
List.fold_left2 reg_match s r1 r2
|
Itypur
(
s1
,
l1
)
,
Itypur
(
s2
,
l2
)
when
ts_equal
s1
s2
->
|
Itypur
(
s1
,
l1
)
,
Itypur
(
s2
,
l2
)
when
ts_equal
s1
s2
->
List.fold_left2 ity_match s l1 l2
List
.
fold_left2
ity_match
sbs
l1
l2
| Ityvar tv1, _ ->
|
Ityvar
v1
,
_
->
{ s with ity_subst_tv = Mtv.change set tv1 s.ity_subst_tv }
Mtv
.
add
v1
ity2
sbs
| _ ->
|
_
->
raise
Exit
raise Exit
and reg_match s r1 r2 =
let is_new = ref false in
let set = function
| None -> is_new := true; Some r2
| Some r3 as r when reg_equal r3 r2 -> r
| _ -> raise Exit
in
let reg_map = Mreg.change set r1 s.ity_subst_reg in
let s = { s with ity_subst_reg = reg_map } in
if !is_new then ity_match s r1.reg_ity r2.reg_ity else s
let ity_match s ity1 ity2 =
let
ity_match
s
bs
ity1
ity2
=
try ity_match s ity1 ity2
try
ity_match
s
bs
ity1
ity2
with Exit -> raise (TypeMismatch (ity1,ity2,s))
with
Exit
->
raise
(
TypeMismatch
(
ity1
,
ity2
,
s
bs
))
let reg_match s r1 r2 =
let
ity_freeze
sbs
ity
=
ity_match
sbs
ity
ity
try reg_match s r1 r2
with Exit -> raise (RegionMismatch (r1,r2,s))
let
rec
ty_of_ity
ity
=
match
ity
.
ity_node
with
let
rec
ty_of_ity
ity
=
match
ity
.
ity_node
with
|
Ityvar
v
->
ty_var
v
|
Ityvar
v
->
ty_var
v
|
Itypur
(
s
,
tl
)
->
ty_app
s
(
List
.
map
ty_of_ity
tl
)
|
Itypur
(
s
,
tl
)
->
ty_app
s
(
List
.
map
ty_of_ity
tl
)
| Ityapp (s,tl,_) -> ty_app s.its_ts (List.map ty_of_ity tl)
|
Ityapp
(
s
,
tl
,_
)
|
Itymut
(
s
,
tl
,_,_
)
->
ty_app
s
.
its_ts
(
List
.
map
ty_of_ity
tl
)
let
rec
ity_of_ty
ty
=
match
ty
.
ty_node
with
let
rec
ity_of_ty
ty
=
match
ty
.
ty_node
with
|
Tyvar
v
->
ity_var
v
|
Tyvar
v
->
ity_var
v
|
Tyapp
(
s
,
tl
)
->
ity_pur_unsafe
s
(
List
.
map
ity_of_ty
tl
)
|
Tyapp
(
s
,
tl
)
->
ity_pur_unsafe
s
(
List
.
map
ity_of_ty
tl
)
let rec ity_inst_fresh mv mr ity = match ity.ity_node with
let
ity_pur
s
tl
=
if
List
.
length
s
.
ts_args
<>
List
.
length
tl
then
raise
(
Ty
.
BadTypeArity
(
s
,
List
.
length
tl
));
match
s
.
ts_def
with
|
Some
ty
->
let
sbs
=
List
.
fold_right2
Mtv
.
add
s
.
ts_args
tl
Mtv
.
empty
in
ity_full_inst
sbs
(
ity_of_ty
ty
)
|
None
->
ity_pur_unsafe
s
tl
let
ity_mut
s
tl
rl
v
=
(* compute the substitution even for non-aliases to verify regions *)
let
sbs
=
try
List
.
fold_right2
Mtv
.
add
s
.
its_ts
.
ts_args
tl
Mtv
.
empty
with
Invalid_argument
_
->
raise
(
BadItyArity
(
s
,
List
.
length
tl
))
in
let
sbs
=
try
List
.
fold_left2
ity_match
sbs
s
.
its_regions
rl
with
Invalid_argument
_
->
raise
(
BadRegArity
(
s
,
List
.
length
rl
))
in
match
s
.
its_def
with
|
Some
{
ity_node
=
Itymut
(
s
,
tl
,
rl
,_
)
}
->
let
tl
=
List
.
map
(
ity_full_inst
sbs
)
tl
in
let
rl
=
List
.
map
(
ity_full_inst
sbs
)
rl
in
ity_mut_known_unsafe
s
tl
rl
v
|
None
when
s
.
its_mutable
->
ity_mut_known_unsafe
s
tl
rl
v
|
_
->
invalid_arg
"Ity.ity_mut"
let
ity_app
sbs
s
tl
rl
=
match
s
.
its_def
with
|
Some
{
ity_node
=
Itymut
(
s
,
tl
,
rl
,_
)
}
->
let
tl
=
List
.
map
(
ity_full_inst
sbs
)
tl
in
let
rl
=
List
.
map
(
ity_full_inst
sbs
)
rl
in
ity_mut_fresh_unsafe
s
tl
rl
|
None
when
s
.
its_mutable
->
ity_mut_fresh_unsafe
s
tl
rl
|
Some
ity
->
ity_full_inst
sbs
ity
|
None
->
ity_app_unsafe
s
tl
rl
let
rec
ity_inst_fresh
sbs
ity
=
match
ity
.
ity_node
with
|
Ityvar
v
->
|
Ityvar
v
->
mr
, Mtv.find v
mv
sbs
,
Mtv
.
find
v
sbs
|
Itypur
(
s
,
tl
)
->
|
Itypur
(
s
,
tl
)
->
let
mr
,tl = Lists.map_fold_left
(
ity_inst_fresh
mv) mr
tl in
let
sbs
,
tl
=
Lists
.
map_fold_left
ity_inst_fresh
sbs
tl
in
mr
, ity_pur_unsafe s tl
sbs
,
ity_pur_unsafe
s
tl
|
Ityapp
(
s
,
tl
,
rl
)
->
|
Ityapp
(
s
,
tl
,
rl
)
->
let mr,tl = Lists.map_fold_left (ity_inst_fresh mv) mr tl in
let
sbs
,
tl
=
Lists
.
map_fold_left
ity_inst_fresh
sbs
tl
in
let mr,rl = Lists.map_fold_left (reg_refresh mv) mr rl in
let
sbs
,
rl
=
Lists
.
map_fold_left
ity_inst_fresh
sbs
rl
in
mr, ity_app_unsafe s tl rl
sbs
,
ity_app_unsafe
s
tl
rl
|
Itymut
(
_
,_,_,
v
)
when
Mtv
.
mem
v
sbs
->
and reg_refresh mv mr r = match Mreg.find_opt r mr with
sbs
,
Mtv
.
find
v
sbs
| Some r ->
|
Itymut
(
s
,
tl
,
rl
,
v
)
->
mr, r
let
sbs
,
tl
=
Lists
.
map_fold_left
ity_inst_fresh
sbs
tl
in
| None ->
let
sbs
,
rl
=
Lists
.
map_fold_left
ity_inst_fresh
sbs
rl
in
let mr,ity = ity_inst_fresh mv mr r.reg_ity in
let
ity
=
ity_mut_unsafe
s
tl
rl
(
create_tvsymbol
(
id_clone
v
.
tv_name
))
in
let id = id_clone r.reg_name in
Mtv
.
add
v
ity
sbs
,
ity
let reg = create_region id ity in
Mreg.add r reg mr, reg
let
ity_app_fresh
s
tl
=
let
ity_app_fresh
s
tl
=
(* type variable map *)
let
sbs
=
try
List
.
fold_right2
Mtv
.
add
s
.
its_ts
.
ts_args
tl
Mtv
.
empty
let mv = try List.fold_right2 Mtv.add s.its_ts.ts_args tl Mtv.empty with
with
Invalid_argument
_
->
raise
(
BadItyArity
(
s
,
List
.
length
tl
))
in
| Invalid_argument _ -> raise (BadItyArity (s, List.length tl)) in
let
sbs
,
rl
=
Lists
.
map_fold_left
ity_inst_fresh
sbs
s
.
its_regions
in
(* refresh regions *)
ity_app
sbs
s
tl
rl
let mr,rl = Lists.map_fold_left (reg_refresh mv) Mreg.empty s.its_regs in
let sub = { ity_subst_tv = mv; ity_subst_reg = mr } in
(* every top region in def is guaranteed to be in mr *)
match s.its_def with
| Some ity -> ity_full_inst sub ity
| None -> ity_app_unsafe s tl rl
let
ity_app
s
tl
rl
=
let
ity_app
s
tl
rl
=
(* type variable map *)
(* compute the substitution even for non-aliases to verify regions *)
let mv = try List.fold_right2 Mtv.add s.its_ts.ts_args tl Mtv.empty with
let
sbs
=
try
List
.
fold_right2
Mtv
.
add
s
.
its_ts
.
ts_args
tl
Mtv
.
empty
| Invalid_argument _ -> raise (BadItyArity (s, List.length tl)) in
with
Invalid_argument
_
->
raise
(
BadItyArity
(
s
,
List
.
length
tl
))
in
(* region map *)
let
sbs
=
try
List
.
fold_left2
ity_match
sbs
s
.
its_regions
rl
let sub = { ity_subst_tv = mv; ity_subst_reg = Mreg.empty } in
with
Invalid_argument
_
->
raise
(
BadRegArity
(
s
,
List
.
length
rl
))
in
let sub = try List.fold_left2 reg_match sub s.its_regs rl with
ity_app
sbs
s
tl
rl
| Invalid_argument _ -> raise (BadRegArity (s, List.length rl)) in
(* every type var and top region in def are in its_ts.ts_args and its_regs *)
match s.its_def with
| Some ity -> ity_full_inst sub ity
| None -> ity_app_unsafe s tl rl
let ity_pur s tl =
(* type variable map *)
let mv = try List.fold_right2 Mtv.add s.ts_args tl Mtv.empty with
| Invalid_argument _ -> raise (Ty.BadTypeArity (s, List.length tl)) in
let sub = { ity_subst_tv = mv; ity_subst_reg = Mreg.empty } in
(* every top region in def is guaranteed to be in mr *)
match s.ts_def with
| Some ty -> ity_full_inst sub (ity_of_ty ty)
| None -> ity_pur_unsafe s tl
(* itysymbol creation *)
(* itysymbol creation *)
let
create_itysymbol_unsafe
,
restore_its
=
let
create_itysymbol_unsafe
,
restore_its
=
let
ts_to_its
=
Wts
.
create
17
in
let
ts_to_its
=
Wts
.
create
17
in
(fun ts ~
abst ~priv ~inv ~ghrl regs
def ->
(
fun
~
ts
~
mut
~
regs
~
vis
~
def
->
let
its
=
{
let
its
=
{
its_ts = ts;
its_ts
=
ts
;
its_regs = regs;
its_mutable
=
mut
;
its_def = def;
its_regions
=
regs
;
its_ghrl = ghrl;
its_visible
=
vis
;
its_inv = inv;
its_def
=
def
;
its_abst = abst;
its_priv = priv;
}
in
}
in
Wts
.
set
ts_to_its
ts
its
;
Wts
.
set
ts_to_its
ts
its
;
its
)
,
its
)
,
Wts
.
find
ts_to_its
Wts
.
find
ts_to_its
let create_itysymbol name
let
create_itysymbol
name
args
mut
regvis
def
=
?(abst=false) ?(priv=false) ?(inv=false) ?(ghost_reg=Sreg.empty)
args regs def =
let
puredef
=
Opt
.
map
ty_of_ity
def
in
let
puredef
=
Opt
.
map
ty_of_ity
def
in
let purets = create_tysymbol name args puredef in
let
ts
=
create_tysymbol
name
args
puredef
in
let
regs
,
vis
=
List
.
split
regvis
in
(* all regions *)
(* all regions *)
let
add
s
r
=
Sreg
.
add_new
(
DuplicateRegion
r
)
r
s
in
let
add
s
r
=
Sreg
.
add_new
(
DuplicateRegion
r
)
r
s
in
let
sregs
=
List
.
fold_left
add
Sreg
.
empty
regs
in
let
sregs
=
List
.
fold_left
add
Sreg
.
empty
regs
in
(* all type variables *)
(* all type variables *)
let
sargs
=
List
.
fold_right
Stv
.
add
args
Stv
.
empty
in
let
sargs
=
List
.
fold_right
Stv
.
add
args
Stv
.
empty
in
(* all type variables in [regs] must be in [args] *)
(* each type variable in [regs] must be in [args] *)
let check dtvs = if not (Stv.subset dtvs sargs) then
let
check_v
()
v
=
raise (UnboundTypeVar (Stv.choose (Stv.diff dtvs sargs))) in
if
not
(
Stv
.
mem
v
sargs
)
then
raise
(
UnboundTypeVar
v
)
in
List.iter (fun r -> check r.reg_ity.ity_vars.vars_tv) regs;
List
.
fold_left
(
ity_v_fold
check_v
)
()
regs
;
(* all regions in [def] must be in [regs] *)
(* each lower region in [def] must be in [regs] *)
let check dregs = if not (Sreg.subset dregs sregs) then
let
check_r
r
=
raise (UnboundRegion (Sreg.choose (Sreg.diff dregs sregs))) in
if
not
(
Sreg
.
mem
r
sregs
)
then
raise
(
UnboundRegion
r
)
in
Opt.iter (fun d -> check d.ity_vars.vars_reg) def;
let
rec
check
()
ity
=
match
ity
.
ity_node
with
(* if a type is an alias then it cannot be abstract or private *)
|
Itymut
(
_
,_,
rl
,_
)
->
if def <> None then begin
List
.
iter
check_r
rl
;
if abst then Loc.errorm "Type aliases cannot be abstract";
ity_fold
check
()
ity
if priv then Loc.errorm "Type aliases cannot be private";
|
_
->
if inv then Loc.errorm "Type aliases cannot have invariants"
ity_fold
check
()
ity
in
end;
Opt
.
fold
check
()
def
;
(* every ghost region argument must be in [regs] *)
(* the alias is mutable if and only if the symbol is *)
if not (Sreg.subset ghost_reg sregs) then
let
check
=
function
invalid_arg "Mlw_ty.create_itysymbol";
|
Some
{
ity_node
=
Itymut
_
}
->
mut
Opt.iter (fun ity ->
|
Some
_
->
not
mut
let nogh = ity_nonghost_reg Sreg.empty ity in
|
None
->
true
in
if Sreg.exists (fun r -> Sreg.mem r ghost_reg) nogh then
if
not
(
check
def
)
then
invalid_arg
"Ity.create_itysymbol"
;
invalid_arg "Mlw_ty.create_itysymbol") def;
(* each invisible region must be invisible in [def] *)
let ghrl = List.map (fun r -> Sreg.mem r ghost_reg) regs in
let
visible
=
Opt
.
fold
ity_nonghost_reg
Sreg
.
empty
def
in
let
check
(
r
,
v
)
=
if
not
v
&&
Sreg
.
mem
r
visible
then
invalid_arg
"Ity.create_itysymbol"
in
List
.
iter
check
regvis
;
(* create the type symbol *)
(* create the type symbol *)
create_itysymbol_unsafe
purets ~abst ~priv ~inv ~ghrl
regs
def
create_itysymbol_unsafe
~
ts
~
def
~
mut
~
regs
~
vis
let
ts_unit
=
ts_tuple
0
let
ts_unit
=
ts_tuple
0
let
ty_unit
=
ty_tuple
[]
let
ty_unit
=
ty_tuple
[]
...
@@ -431,58 +405,6 @@ let ity_int = ity_of_ty Ty.ty_int
...
@@ -431,58 +405,6 @@ let ity_int = ity_of_ty Ty.ty_int
let
ity_bool
=
ity_of_ty
Ty
.
ty_bool
let
ity_bool
=
ity_of_ty
Ty
.
ty_bool
let
ity_unit
=
ity_of_ty
ty_unit
let
ity_unit
=
ity_of_ty
ty_unit
let vars_freeze s =
let sbs = Stv.fold (fun v -> Mtv.add v (ity_var v)) s.vars_tv Mtv.empty in
let sbs = { ity_subst_tv = sbs ; ity_subst_reg = Mreg.empty } in
Sreg.fold (fun r s -> reg_match s r r) s.vars_reg sbs
(** cloning *)
let its_clone sm =
let itsh = Hits.create 3 in
let regh = Hreg.create 3 in
let rec add_ts oits nts =
let nits = try restore_its nts with Not_found ->
let abst = oits.its_abst in
let priv = oits.its_priv in
let ghrl = oits.its_ghrl in
let inv = oits.its_inv in
let regs = List.map conv_reg oits.its_regs in
let def = Opt.map conv_ity oits.its_def in
create_itysymbol_unsafe nts ~abst ~priv ~inv ~ghrl regs def
in
Hits.replace itsh oits nits;
nits
and conv_reg r =
try Hreg.find regh r with Not_found ->
let ity = conv_ity r.reg_ity in
let nr = create_region (id_clone r.reg_name) ity in
Hreg.replace regh r nr;
nr
and conv_ity ity = match ity.ity_node with
| Ityapp (its,tl,rl) ->
let tl = List.map conv_ity tl in
let rl = List.map conv_reg rl in
ity_app_unsafe (conv_its its) tl rl
| Itypur (ts,tl) ->
let tl = List.map conv_ity tl in
ity_pur_unsafe (conv_ts ts) tl
| Ityvar _ -> ity
and conv_its its =
try Hits.find itsh its with Not_found ->
try add_ts its (Mts.find its.its_ts sm.Theory.sm_ts)
with Not_found -> its
and conv_ts ts =
Mts.find_def ts ts sm.Theory.sm_ts
in
let add_ts ots nts =
try ignore (add_ts (restore_its ots) nts)
with Not_found -> ()
in
Mts.iter add_ts sm.Theory.sm_ts;
Hits.fold Mits.add itsh Mits.empty,
Hreg.fold Mreg.add regh Mreg.empty
(** computation types (with effects) *)
(** computation types (with effects) *)
(* exception symbols *)
(* exception symbols *)
...
@@ -510,6 +432,7 @@ end)
...
@@ -510,6 +432,7 @@ end)
module
Sexn
=
Exn
.
S
module
Sexn
=
Exn
.
S
module
Mexn
=
Exn
.
M
module
Mexn
=
Exn
.
M
(*
(* effects *)
(* effects *)
type effect = {
type effect = {
eff_writes : Sreg.t;
eff_writes : Sreg.t;
...
...
This diff is collapsed.
Click to expand it.
src/mlw/ity.mli
+
22
−
51
View file @
6a62c33e
...
@@ -9,17 +9,17 @@
...
@@ -9,17 +9,17 @@
(* *)
(* *)
(********************************************************************)
(********************************************************************)
open
Ident
open
Ty
open
Ty
(** {2 Individual types (first-order types w/o effects)} *)
(** {2 Individual types (first-order types w/o effects)} *)
type
itysymbol
=
private
{
type
itysymbol
=
private
{
its_ts
:
tysymbol
;
(** pure "snapshot" type symbol *)
its_ts
:
tysymbol
;
(** pure "snapshot" type symbol *)
its_def
:
ity
option
;
(** is a type alias *)
its_mutable
:
bool
;
(** is a record with mutable fields *)
its_mutable
:
bool
;
(** is a record with mutable fields *)
its_
shared
:
region
list
;
(** mutable shareable components *)
its_
regions
:
region
list
;
(** mutable shareable components *)
its_visible
:
bool
list
;
(** non-ghost shareable components *)
its_visible
:
bool
list
;
(** non-ghost shareable components *)
its_
access
:
bool
list
;
(** accessible type argument
s *)
its_
def
:
ity
option
;
(** is a type alia
s *)
}
}
and
ity
=
private
{
and
ity
=
private
{
...
@@ -33,7 +33,7 @@ and ity_node = private
...
@@ -33,7 +33,7 @@ and ity_node = private
|
Ityapp
of
itysymbol
*
ity
list
*
region
list
|
Ityapp
of
itysymbol
*
ity
list
*
region
list
|
Itymut
of
itysymbol
*
ity
list
*
region
list
*
tvsymbol
|
Itymut
of
itysymbol
*
ity
list
*
region
list
*
tvsymbol
and
region
and
region
=
ity
(** regions are itys of the [Itymut] kind *)
module
Mits
:
Extmap
.
S
with
type
key
=
itysymbol
module
Mits
:
Extmap
.
S
with
type
key
=
itysymbol
module
Sits
:
Extset
.
S
with
module
M
=
Mits
module
Sits
:
Extset
.
S
with
module
M
=
Mits
...
@@ -45,44 +45,35 @@ module Sity : Extset.S with module M = Mity
...
@@ -45,44 +45,35 @@ module Sity : Extset.S with module M = Mity
module
Hity
:
Exthtbl
.
S
with
type
key
=
ity
module
Hity
:
Exthtbl
.
S
with
type
key
=
ity
module
Wity
:
Weakhtbl
.
S
with
type
key
=
ity
module
Wity
:
Weakhtbl
.
S
with
type
key
=
ity
module
Mreg
:
Extmap
.
S
with
type
key
=
region
module
Mreg
:
Extmap
.
S
with
type
key
=
region
and
type
'
a
t
=
'
a
Mity
.
t
module
Sreg
:
Extset
.
S
with
module
M
=
Mreg
module
Sreg
:
Extset
.
S
with
module
M
=
Mreg
module
Hreg
:
Exthtbl
.
S
with
type
key
=
region
module
Hreg
:
Exthtbl
.
S
with
type
key
=
region
and
type
'
a
t
=
'
a
Hity
.
t
module
Wreg
:
Weakhtbl
.
S
with
type
key
=
region
module
Wreg
:
Weakhtbl
.
S
with
type
key
=
region
and
type
'
a
t
=
'
a
Wity
.
t
val
its_equal
:
itysymbol
->
itysymbol
->
bool
val
its_equal
:
itysymbol
->
itysymbol
->
bool
val
ity_equal
:
ity
->
ity
->
bool
val
ity_equal
:
ity
->
ity
->
bool
val
reg_equal
:
region
->
region
->
bool
val
its_hash
:
itysymbol
->
int
val
its_hash
:
itysymbol
->
int
val
ity_hash
:
ity
->
int
val
ity_hash
:
ity
->
int
val
reg_hash
:
region
->
int
exception
BadItyArity
of
itysymbol
*
int
exception
BadItyArity
of
itysymbol
*
int
exception
BadRegArity
of
itysymbol
*
int
exception
BadRegArity
of
itysymbol
*
int
exception
DuplicateRegion
of
region
exception
DuplicateRegion
of
region
exception
UnboundRegion
of
region
exception
UnboundRegion
of
region
exception
NotMutable
of
ity
val
ity_of_region
:
region
->
ity
val
region_of_ity
:
ity
->
region
val
open_region
:
region
->
itysymbol
*
ity
list
*
region
list
*
tvsymbol
(*
(** creation of a symbol for type in programs *)
(** creation of a symbol for type in programs *)
val
create_itysymbol
:
val
create_itysymbol
:
preid ->
preid
->
tvsymbol
list
->
?abst:bool -> ?priv:bool -> ?inv:bool -> ?ghost_reg:Sreg.t ->
bool
->
(
region
*
bool
)
list
->
ity
option
->
itysymbol
tvsymbol list -> region list -> ity option -> itysymbol
val
restore_its
:
tysymbol
->
itysymbol
val
restore_its
:
tysymbol
->
itysymbol
(** raises [Not_found] if the argument is not a its_ts *)
(** raises [Not_found] if the argument is not a its_ts *)
val
ity_var
:
tvsymbol
->
ity
val
ity_var
:
tvsymbol
->
ity
val
ity_pur
:
tysymbol
->
ity
list
->
ity
val
ity_pur
:
tysymbol
->
ity
list
->
ity
val
ity_app
:
itysymbol
->
ity
list
->
region
list
->
ity
val
ity_app
:
itysymbol
->
ity
list
->
region
list
->
ity
val
ity_mut
:
itysymbol
->
ity
list
->
region
list
->
tvsymbol
->
ity
val
ity_app_fresh
:
itysymbol
->
ity
list
->
ity
val
ity_app_fresh
:
itysymbol
->
ity
list
->
ity
val
ty_of_ity
:
ity
->
ty
val
ty_of_ity
:
ity
->
ty
...
@@ -90,7 +81,8 @@ val ty_of_ity : ity -> ty
...
@@ -90,7 +81,8 @@ val ty_of_ity : ity -> ty
val
ity_of_ty
:
ty
->
ity
val
ity_of_ty
:
ty
->
ity
(** replaces every [Tyapp] with [Itypur] *)
(** replaces every [Tyapp] with [Itypur] *)
*)
val
tv_of_region
:
region
->
tvsymbol
(** {2 Generic traversal functions} *)
(** {2 Generic traversal functions} *)
...
@@ -119,9 +111,6 @@ val ity_r_all : (region -> bool) -> ity -> bool
...
@@ -119,9 +111,6 @@ val ity_r_all : (region -> bool) -> ity -> bool
val
ity_r_any
:
(
region
->
bool
)
->
ity
->
bool
val
ity_r_any
:
(
region
->
bool
)
->
ity
->
bool
val
ity_r_occurs
:
region
->
ity
->
bool
val
ity_r_occurs
:
region
->
ity
->
bool
(*
val its_clone : Theory.symbol_map -> itysymbol Mits.t * region Mreg.t
*)
val
ity_closed
:
ity
->
bool
val
ity_closed
:
ity
->
bool
val
ity_immutable
:
ity
->
bool
val
ity_immutable
:
ity
->
bool
...
@@ -131,7 +120,6 @@ val ity_immutable : ity -> bool
...
@@ -131,7 +120,6 @@ val ity_immutable : ity -> bool
val
ity_nonghost_reg
:
Sreg
.
t
->
ity
->
Sreg
.
t
val
ity_nonghost_reg
:
Sreg
.
t
->
ity
->
Sreg
.
t
val
lookup_nonghost_reg
:
Sreg
.
t
->
ity
->
bool
val
lookup_nonghost_reg
:
Sreg
.
t
->
ity
->
bool
(*
(** {2 Built-in types} *)
(** {2 Built-in types} *)
val
ts_unit
:
tysymbol
(** the same as [Ty.ts_tuple 0] *)
val
ts_unit
:
tysymbol
(** the same as [Ty.ts_tuple 0] *)
...
@@ -141,35 +129,17 @@ val ity_int : ity
...
@@ -141,35 +129,17 @@ val ity_int : ity
val
ity_bool
:
ity
val
ity_bool
:
ity
val
ity_unit
:
ity
val
ity_unit
:
ity
type ity_subst = private {
(** {2 Type matching and instantiation} *)
ity_subst_tv : ity Mtv.t;
ity_subst_reg : region Mreg.t;
}
exception RegionMismatch of region * region * ity_subst
exception TypeMismatch of ity * ity * ity_subst
val ity_subst_emp
ty
:
ity
_subs
t
exception
TypeMismatch
of
ity
*
i
ty
*
ity
Mtv
.
t
val ity_match : ity
_subs
t -> ity -> ity -> ity
_subs
t
val
ity_match
:
ity
Mtv
.
t
->
ity
->
ity
->
ity
Mtv
.
t
val
reg_match : ity_subst -> region -> region -> ity_subst
val
ity_freeze
:
ity
Mtv
.
t
->
ity
->
ity
Mtv
.
t
(* self-match *)
val
ity_equal_check
:
ity
->
ity
->
unit
val
ity_equal_check
:
ity
->
ity
->
unit
val reg_equal_check : region -> region -> unit
val
ity_full_inst
:
ity
Mtv
.
t
->
ity
->
ity
val ity_full_inst : ity_subst -> ity -> ity
val reg_full_inst : ity_subst -> region -> region
(** {2 Varset manipulation} *)
val vars_empty : varset
val vars_union : varset -> varset -> varset
val vars_freeze : varset -> ity_subst
(** {2 Exception symbols} *)
(** {2 Exception symbols} *)
...
@@ -188,6 +158,7 @@ val create_xsymbol : preid -> ity -> xsymbol
...
@@ -188,6 +158,7 @@ val create_xsymbol : preid -> ity -> xsymbol
module
Mexn
:
Extmap
.
S
with
type
key
=
xsymbol
module
Mexn
:
Extmap
.
S
with
type
key
=
xsymbol
module
Sexn
:
Extset
.
S
with
module
M
=
Mexn
module
Sexn
:
Extset
.
S
with
module
M
=
Mexn
(*
(** {2 Effects} *)
(** {2 Effects} *)
type effect = private {
type effect = private {
...
@@ -224,7 +195,7 @@ exception IllegalAlias of region
...
@@ -224,7 +195,7 @@ exception IllegalAlias of region
exception IllegalCompar of tvsymbol * ity
exception IllegalCompar of tvsymbol * ity
exception GhostDiverg
exception GhostDiverg
val eff_full_inst : ity
_subs
t -> effect -> effect
val eff_full_inst : ity
Mtv.
t -> effect -> effect
val eff_is_empty : effect -> bool
val eff_is_empty : effect -> bool
...
@@ -295,13 +266,13 @@ val vty_arrow : pvsymbol list -> ?spec:spec -> vty -> aty
...
@@ -295,13 +266,13 @@ val vty_arrow : pvsymbol list -> ?spec:spec -> vty -> aty
val aty_pvset : aty -> Spv.t
val aty_pvset : aty -> Spv.t
(** raises [Not_found] if the spec contains non-pv variables *)
(** raises [Not_found] if the spec contains non-pv variables *)
val aty_vars_match : ity
_subs
t -> aty -> ity list -> ity -> ity
_subs
t
val aty_vars_match : ity
Mtv.
t -> aty -> ity list -> ity -> ity
Mtv.
t
(** this only compares the types of arguments and results, and ignores
(** this only compares the types of arguments and results, and ignores
the spec. In other words, only the type variables and regions in
the spec. In other words, only the type variables and regions in
[aty_vars aty] are matched. The caller should supply a "freezing"
[aty_vars aty] are matched. The caller should supply a "freezing"
substitution that covers all external type variables and regions. *)
substitution that covers all external type variables and regions. *)
val aty_full_inst : ity
_subs
t -> aty -> aty
val aty_full_inst : ity
Mtv.
t -> aty -> aty
(** the substitution must cover not only [aty_vars aty] but
(** the substitution must cover not only [aty_vars aty] but
also every type variable and every region in [aty_spec] *)
also every type variable and every region in [aty_spec] *)
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment