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
87ad191d
Commit
87ad191d
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2005-06-16 13:53:05 by afrisch] Compilation: new algo for basic
Original author: afrisch Date: 2005-06-16 13:53:05+00:00
parent
a3b8ff22
Changes
2
Hide whitespace changes
Inline
Side-by-side
types/patterns.ml
View file @
87ad191d
...
...
@@ -138,6 +138,8 @@ let capture x = (Types.any, IdSet.singleton x, Capture x)
let
constant
x
c
=
(
Types
.
any
,
IdSet
.
singleton
x
,
Constant
(
x
,
c
))
let
print_node
=
ref
(
fun
_
_
->
assert
false
)
module
Node
=
struct
type
t
=
node
let
compare
n1
n2
=
n1
.
id
-
n2
.
id
...
...
@@ -145,7 +147,7 @@ module Node = struct
let
hash
n
=
n
.
id
let
check
n
=
()
let
dump
=
print_node
let
dump
ppf
x
=
!
print_node
ppf
x
module
SMemo
=
Set
.
Make
(
Custom
.
Int
)
...
...
@@ -377,6 +379,7 @@ module Print = struct
Format
.
fprintf
ppf
"}"
end
let
()
=
print_node
:=
(
fun
ppf
n
->
Print
.
print
ppf
(
descr
n
))
(* Static semantics *)
...
...
@@ -572,13 +575,20 @@ module Normal = struct
|
SCatch
,
_
->
-
1
|
_
,
SCatch
->
1
|
SConst
c1
,
SConst
c2
->
Types
.
Const
.
compare
c1
c2
(*
let hash_source = function
| SCatch -> 1
| SConst c -> Types.Const.hash c
*)
let
compare_result
r1
r2
=
IdMap
.
compare
compare_source
r1
r2
module
ResultMap
=
Map
.
Make
(
struct
type
t
=
result
let
compare
=
compare_result
end
)
module
NodeSet
=
SortedList
.
Make
(
Node
)
module
Nnf
=
struct
...
...
@@ -609,14 +619,6 @@ module Normal = struct
end
module
NBasic
=
struct
type
t
=
result
*
Types
.
t
let
compare
(
r1
,
t1
)
(
r2
,
t2
)
=
let
c
=
compare_result
r1
r2
in
if
c
<>
0
then
c
else
Types
.
compare
t1
t2
end
module
NProd
=
struct
type
t
=
result
*
Nnf
.
t
*
Nnf
.
t
...
...
@@ -626,14 +628,12 @@ module Normal = struct
else
Nnf
.
compare
y1
y2
end
module
NLineBasic
=
Set
.
Make
(
NBasic
)
module
NLineProd
=
Set
.
Make
(
NProd
)
type
record
=
|
RecNolabel
of
result
option
*
result
option
|
RecLabel
of
label
*
NLineProd
.
t
type
t
=
{
nbasic
:
NLineBasic
.
t
;
nprod
:
NLineProd
.
t
;
nxml
:
NLineProd
.
t
;
nrecord
:
record
...
...
@@ -642,8 +642,7 @@ module Normal = struct
let
fus
=
IdMap
.
union_disj
let
nempty
lab
=
{
nbasic
=
NLineBasic
.
empty
;
nprod
=
NLineProd
.
empty
;
{
nprod
=
NLineProd
.
empty
;
nxml
=
NLineProd
.
empty
;
nrecord
=
(
match
lab
with
|
Some
l
->
RecLabel
(
l
,
NLineProd
.
empty
)
...
...
@@ -653,8 +652,7 @@ module Normal = struct
let
ncup
nf1
nf2
=
{
nbasic
=
NLineBasic
.
union
nf1
.
nbasic
nf2
.
nbasic
;
nprod
=
NLineProd
.
union
nf1
.
nprod
nf2
.
nprod
;
{
nprod
=
NLineProd
.
union
nf1
.
nprod
nf2
.
nprod
;
nxml
=
NLineProd
.
union
nf1
.
nxml
nf2
.
nxml
;
nrecord
=
(
match
(
nf1
.
nrecord
,
nf2
.
nrecord
)
with
|
RecLabel
(
l1
,
r1
)
,
RecLabel
(
l2
,
r2
)
->
...
...
@@ -666,11 +664,6 @@ module Normal = struct
|
_
->
assert
false
)
}
let
double_fold_basic
f
l1
l2
=
NLineBasic
.
fold
(
fun
x1
accu
->
NLineBasic
.
fold
(
fun
x2
accu
->
f
accu
x1
x2
)
l2
accu
)
l1
NLineBasic
.
empty
let
double_fold_prod
f
l1
l2
=
NLineProd
.
fold
(
fun
x1
accu
->
NLineProd
.
fold
(
fun
x2
accu
->
f
accu
x1
x2
)
l2
accu
)
...
...
@@ -687,11 +680,6 @@ module Normal = struct
(
NodeSet
.
cup
ql1
ql2
,
s
,
IdSet
.
cup
ys1
ys2
))
accu
in
let
basic
accu
(
res1
,
t1
)
(
res2
,
t2
)
=
let
t
=
Types
.
cap
t1
t2
in
if
Types
.
is_empty
t
then
accu
else
NLineBasic
.
add
(
fus
res1
res2
,
t
)
accu
in
let
record
r1
r2
=
match
r1
,
r2
with
|
RecLabel
(
l1
,
r1
)
,
RecLabel
(
l2
,
r2
)
->
(* assert (l1 = l2); *)
...
...
@@ -706,8 +694,7 @@ module Normal = struct
RecNolabel
(
x
,
y
)
|
_
->
assert
false
in
{
nbasic
=
double_fold_basic
basic
nf1
.
nbasic
nf2
.
nbasic
;
nprod
=
double_fold_prod
prod
nf1
.
nprod
nf2
.
nprod
;
{
nprod
=
double_fold_prod
prod
nf1
.
nprod
nf2
.
nprod
;
nxml
=
double_fold_prod
prod
nf1
.
nxml
nf2
.
nxml
;
nrecord
=
record
nf1
.
nrecord
nf2
.
nrecord
;
}
...
...
@@ -719,7 +706,6 @@ module Normal = struct
let
empty_res
=
IdMap
.
empty
let
single_basic
src
t
=
NLineBasic
.
singleton
(
src
,
t
)
let
single_prod
src
p
q
=
NLineProd
.
singleton
(
src
,
p
,
q
)
let
ntimes
lab
acc
p
q
xs
=
...
...
@@ -759,15 +745,13 @@ module Normal = struct
(
if
y
then
Some
empty_res
else
None
))
|
Some
l
->
RecLabel
(
l
,
aux
(
Types
.
Record
.
split_normal
t
l
))
in
{
nbasic
=
single_basic
empty_res
(
Types
.
cap
t
any_basic
);
nprod
=
aux
(
Types
.
Product
.
normal
t
);
{
nprod
=
aux
(
Types
.
Product
.
normal
t
);
nxml
=
aux
(
Types
.
Product
.
normal
~
kind
:
`XML
t
);
nrecord
=
record
}
let
nany
lab
res
=
{
nbasic
=
single_basic
res
any_basic
;
nprod
=
single_prod
res
ncany
ncany
;
{
nprod
=
single_prod
res
ncany
ncany
;
nxml
=
single_prod
res
ncany
ncany
;
nrecord
=
match
lab
with
|
None
->
RecNolabel
(
Some
res
,
Some
res
)
...
...
@@ -818,27 +802,82 @@ module Normal = struct
(
fun
a
p
->
ncap
a
(
nnormal
l
(
descr
p
)
xs
))
(
nconstr
l
t
)
pl
let
nnf
lab
t0
(
pl
,
t
,
xs
)
=
assert
(
not
(
Types
.
disjoint
t
t0
));
(*
assert (not (Types.disjoint t t0));
*)
let
t
=
if
Types
.
subtype
t
t0
then
t
else
Types
.
cap
t
t0
in
normal
lab
t
(
NodeSet
.
get
pl
)
xs
let
basic_tests
t0
(
pl
,
t
,
xs
)
=
let
t0
=
Types
.
cap
t0
any_basic
in
let
rec
aux
accu
t
res
=
function
|
[]
->
(
res
,
t
)
::
accu
|
(
tp
,
xp
,
d
)
::
rest
->
let
basic_tests
f
(
pl
,
t
,
xs
)
=
let
rec
aux
more
s
accu
t
res
=
function
(* Invariant: t and s disjoint, t not empty *)
|
[]
->
let
accu
=
try
let
t'
=
ResultMap
.
find
res
accu
in
ResultMap
.
add
res
(
Types
.
cup
t
t'
)
accu
with
Not_found
->
ResultMap
.
add
res
t
accu
in
cont
(
Types
.
cup
t
s
)
accu
more
|
(
tp
,
xp
,
d
)
::
r
->
if
(
IdSet
.
disjoint
xp
xs
)
then
aux
accu
(
Types
.
cap
t
tp
)
res
r
est
then
aux
_check
more
s
accu
(
Types
.
cap
t
tp
)
res
r
else
match
d
with
|
Constr
s
->
aux
accu
(
Types
.
cap
t
s
)
res
rest
|
Cup
(
p1
,
p2
)
->
aux
(
aux
accu
t
res
(
p2
::
rest
))
t
res
(
p1
::
rest
)
|
Cap
(
p1
,
p2
)
->
aux
accu
t
res
(
p1
::
p2
::
rest
)
|
Capture
x
->
aux
accu
t
(
IdMap
.
add
x
SCatch
res
)
rest
|
Constant
(
x
,
c
)
->
aux
accu
t
(
IdMap
.
add
x
(
SConst
c
)
res
)
rest
|
_
->
accu
|
Cup
(
p1
,
p2
)
->
aux
((
t
,
res
,
p2
::
r
)
::
more
)
s
accu
t
res
(
p1
::
r
)
|
Cap
(
p1
,
p2
)
->
aux
more
s
accu
t
res
(
p1
::
p2
::
r
)
|
Capture
x
->
aux
more
s
accu
t
(
IdMap
.
add
x
SCatch
res
)
r
|
Constant
(
x
,
c
)
->
aux
more
s
accu
t
(
IdMap
.
add
x
(
SConst
c
)
res
)
r
|
_
->
cont
s
accu
more
and
aux_check
more
s
accu
t
res
pl
=
if
Types
.
is_empty
t
then
cont
s
accu
more
else
aux
more
s
accu
t
res
pl
and
cont
s
accu
=
function
|
[]
->
ResultMap
.
iter
f
accu
|
(
t
,
res
,
pl
)
::
tl
->
aux_check
tl
s
accu
(
Types
.
diff
t
s
)
res
pl
in
aux
[]
(
Types
.
cap
t
any_basic
)
IdMap
.
empty
(
List
.
map
descr
pl
)
aux_check
[]
Types
.
empty
ResultMap
.
empty
(
Types
.
cap
t
any_basic
)
IdMap
.
empty
(
List
.
map
descr
pl
)
(*
let prod_tests (pl,t,xs) =
let rec aux accu q1 q2 res = function
| [] -> (res,q1,q2) :: accu
| (tp,xp,d) :: r ->
if (IdSet.disjoint xp xs)
then aux_check accu q1 q2 res tp r
else match d with
| Cup (p1,p2) -> aux (aux accu q1 q2 res (p2::r)) q1 q2 res (p1::r)
| Cap (p1,p2) -> aux accu q1 q2 res (p1 :: p2 :: r)
| Capture x -> aux accu q1 q2 (IdMap.add x SCatch res) r
| Constant (x,c) -> aux accu q1 q2 (IdMap.add x (SConst c) res) r
| Times (p1,p2) ->
let (pl1,t1,xs1) = q1 and (pl2,t2,xs2) = q2 in
let t1 = Types.cap t1 (Types.descr (accept p1)) in
if Types.is_empty t1 then accu
else let t2 = Types.cap t2 (Types.descr (accept p2)) in
if Types.is_empty t2 then accu
else
let q1 =
let xs1' = IdSet.cap (fv p1) xs in
if IdSet.is_empty xs1' then (pl1,t1,xs1)
else (NodeSet.add p1 pl1, t1, IdSet.cup xs1 xs1')
and q2 =
let xs2' = IdSet.cap (fv p2) xs in
if IdSet.is_empty xs2' then (pl2,t2,xs2)
else (NodeSet.add p2 pl2, t2, IdSet.cup xs2 xs2')
in
aux accu q1 q2 res r
| _ -> accu
and aux_check accu q1 q2 res t r =
List.fold_left
(fun accu (t1',t2') ->
let (pl1,t1,xs1) = q1 and (pl2,t2,xs2) = q2 in
let t1 = Types.cap t1 t1' in
if Types.is_empty t1 then accu
else let t2 = Types.cap t2 t2' in
if Types.is_empty t2 then accu
else aux accu (pl1,t1,xs1) (pl2,t2,xs2) res r)
accu (Types.Product.clean_normal (Types.Product.normal t))
in
aux_check [] ncany ncany IdMap.empty t (List.map descr pl)
*)
end
...
...
@@ -1080,7 +1119,14 @@ struct
let
find_code
d
a
=
let
rec
aux
i
=
function
|
`Result
code
->
code
|
`None
->
assert
false
|
`None
->
Format
.
fprintf
Format
.
std_formatter
"IFACE=%a@."
print_iface
d
.
interface
;
for
i
=
0
to
Array
.
length
a
-
1
do
Format
.
fprintf
Format
.
std_formatter
"a.(i)=%b@."
(
a
.
(
i
)
!=
None
)
done
;
assert
false
|
`Switch
(
yes
,_
)
when
a
.
(
i
)
!=
None
->
aux
(
i
+
1
)
yes
|
`Switch
(
_
,
no
)
->
aux
(
i
+
1
)
no
in
aux
0
d
.
interface
...
...
@@ -1090,8 +1136,7 @@ struct
Array
.
of_list
(
Array
.
fold_right
aux
pl
[]
)
let
return
disp
pl
f
ar
=
let
aux
=
function
[
x
]
->
Some
(
f
x
)
|
[]
->
None
|
_
->
dump_disp
disp
;
assert
false
in
let
aux
=
function
x
::_
->
Some
(
f
x
)
|
[]
->
None
in
let
final
=
Array
.
map
aux
pl
in
(
find_code
disp
final
,
create_result
final
,
ar
)
...
...
@@ -1138,13 +1183,12 @@ struct
module
TypeList
=
SortedList
.
Make
(
Types
)
let
dispatch_basic
disp
pl
:
(
Types
.
t
*
result
)
list
=
(* TODO: try other algo, using disp.codes .... *)
let
pl
=
Array
.
map
(
fun
p
->
p
.
Normal
.
nbasic
)
pl
in
let
tests
=
let
accu
=
ref
[]
in
let
aux
i
(
res
,
x
)
=
accu
:=
(
x
,
[
i
,
res
])
::
!
accu
in
Array
.
iteri
(
fun
i
->
Normal
.
NLineBasic
.
iter
(
aux
i
))
pl
;
let
aux
i
res
t
=
accu
:=
(
t
,
[
i
,
res
])
::
!
accu
in
Array
.
iteri
(
fun
i
p
->
Normal
.
basic_tests
(
aux
i
)
p
)
disp
.
pl
;
TypeList
.
Map
.
get
(
TypeList
.
Map
.
from_list
(
@
)
!
accu
)
in
let
t
=
Types
.
cap
any_basic
disp
.
t
in
...
...
@@ -1187,11 +1231,11 @@ struct
(* Build continuation *)
let
result
(
t
,
ar
,
m
)
=
let
get
a
(
req
,
info
)
=
let
get
(
req
,
info
)
a
=
let
i
=
NfMap
.
find
req
idx
in
let
(
var
,
nil
,_
)
=
reqs_facto
.
(
i
)
in
match
m
.
(
i
)
with
Some
res
->
((
var
,
nil
,
res
)
,
info
)
::
a
|
_
->
a
in
let
pl
=
Array
.
map
(
List
.
fold_
lef
t
get
[]
)
pl
in
let
pl
=
Array
.
map
(
fun
l
->
List
.
fold_
righ
t
get
l
[]
)
pl
in
d
t
ar
pl
in
let
res
=
Array
.
map
result
disp
.
codes
in
...
...
@@ -1217,13 +1261,7 @@ struct
get_tests
false
pl
(
fun
x
->
x
)
t
res
(
fun
x
->
x
)
let
rec
dispatch_prod
?
(
kind
=
`Normal
)
disp
pl
=
let
extr
=
match
kind
with
|
`Normal
->
fun
p
->
Normal
.
NLineProd
.
elements
p
.
Normal
.
nprod
|
`XML
->
fun
p
->
Normal
.
NLineProd
.
elements
p
.
Normal
.
nxml
in
let
t
=
Types
.
Product
.
get
~
kind
disp
.
t
in
dispatch_prod0
disp
t
(
Array
.
map
extr
pl
)
and
dispatch_prod0
disp
t
pl
=
let
rec
dispatch_prod0
disp
t
pl
=
get_tests
true
pl
(
fun
(
res
,
p
,
q
)
->
p
,
(
res
,
q
))
(
Types
.
Product
.
pi1
t
)
...
...
@@ -1239,6 +1277,16 @@ struct
let
aux_final
(
ret2
,
(
ret1
,
res
))
=
merge_res_prod
ar1
ar2
ret1
ret2
res
in
return
disp
pl
aux_final
(
ar1
+
ar2
)
let
dispatch_prod
disp
pl
=
let
t
=
Types
.
Product
.
get
disp
.
t
in
dispatch_prod0
disp
t
(
Array
.
map
(
fun
p
->
Normal
.
NLineProd
.
elements
p
.
Normal
.
nprod
)
pl
)
(* dispatch_prod0 disp t (Array.map Normal.prod_tests disp.pl) *)
let
dispatch_xml
disp
pl
=
let
t
=
Types
.
Product
.
get
~
kind
:
`XML
disp
.
t
in
dispatch_prod0
disp
t
(
Array
.
map
(
fun
p
->
Normal
.
NLineProd
.
elements
p
.
Normal
.
nxml
)
pl
)
let
dispatch_record
disp
pl
:
record
option
=
let
t
=
disp
.
t
in
...
...
@@ -1299,7 +1347,7 @@ struct
let
a
=
combine_kind
(
dispatch_basic
disp
pl
)
(
dispatch_prod
disp
pl
)
(
dispatch_
prod
~
kind
:
`XML
disp
pl
)
(
dispatch_
xml
disp
pl
)
(
dispatch_record
disp
pl
)
in
disp
.
actions
<-
Some
a
;
...
...
@@ -1431,27 +1479,19 @@ struct
|
AIgnore
r
->
Format
.
fprintf
ppf
"v -> %a@
\n
"
(
print_ret
[]
)
r
let
print_dispatcher
ppf
d
=
(*
Format
.
fprintf
ppf
"Dispatcher %i accepts [%a]@
\n
"
d
.
id
Types
.
Print
.
print
(
Types
.
normalize
d
.
t
);
let
print_code
code
(
t
,
arity
,
m
)
=
Format
.
fprintf
ppf
" Returns $%i(arity=%i) for [%a]"
code
arity
Types
.
Print
.
print
(
Types
.
normalize
t
);
(*
List.iter
(fun (i,b) ->
Format.fprintf ppf "[%i:" i;
List.iter
(fun (v,i) -> Format.fprintf ppf "%s=>%i;" v i)
b;
Format.fprintf ppf "]"
) m; *)
Format
.
fprintf
ppf
"@
\n
"
;
in
Array
.
iteri
print_code
d
.
codes
;
*)
Array
.
iter
(
fun
p
->
Format
.
fprintf
ppf
" pat %a@."
Normal
.
Nnf
.
print
p
;
)
d
.
pl
;
Format
.
fprintf
ppf
"let disp_%i = function@
\n
"
d
.
id
;
print_actions
ppf
(
actions
d
);
Format
.
fprintf
ppf
"====================================@
\n
"
...
...
@@ -1475,7 +1515,7 @@ struct
let
t
=
Types
.
descr
t
in
let
pl
=
Array
.
of_list
(
List
.
map
(
fun
p
->
([
p
]
,
Types
.
cap
t
(
Types
.
descr
(
accept
p
)
)
,
fv
p
))
pl
)
in
(
List
.
map
(
fun
p
->
([
p
]
,
Types
.
descr
(
accept
p
)
,
fv
p
))
pl
)
in
show
ppf
t
pl
;
Format
.
fprintf
ppf
"# compiled states: %i@
\n
"
!
generated
...
...
@@ -1496,6 +1536,7 @@ end
(****** More efficient compilation (less optimized) ******)
(*
module Compile2 =
struct
type source =
...
...
@@ -2309,3 +2350,4 @@ struct
end
(* debug compile Any (Int,Int) & (x,y) *)
*)
types/patterns.mli
View file @
87ad191d
...
...
@@ -86,6 +86,8 @@ module Compile: sig
end
(*
module Compile2: sig
val debug_compile : Format.formatter -> Types.Node.t -> node list -> unit
end
*)
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