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
61836fc9
Commit
61836fc9
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2005-03-23 14:03:59 by afrisch] Empty log message
Original author: afrisch Date: 2005-03-23 14:04:00+00:00
parent
5bdee9c5
Changes
6
Hide whitespace changes
Inline
Side-by-side
misc/inttbl.ml
View file @
61836fc9
...
...
@@ -8,6 +8,7 @@ module type S = sig
val
add
:
'
a
t
->
key
->
'
a
->
unit
val
find
:
'
a
t
->
key
->
'
a
val
mem
:
'
a
t
->
key
->
bool
val
remove
:
'
a
t
->
key
->
unit
end
type
key
=
int
...
...
@@ -29,7 +30,6 @@ let fold t f x =
aux
(
pred
i
)
x
in
aux
(
pred
(
Array
.
length
!
t
))
x
let
add
t
i
x
=
let
l
=
Array
.
length
!
t
in
...
...
@@ -41,6 +41,9 @@ let add t i x =
);
(
!
t
)
.
(
i
)
<-
Some
x
let
remove
t
i
=
if
(
i
<=
Array
.
length
!
t
)
then
(
!
t
)
.
(
i
)
<-
None
let
find
t
i
=
if
i
>=
Array
.
length
!
t
then
raise
Not_found
else
match
(
!
t
)
.
(
i
)
with
...
...
misc/inttbl.mli
View file @
61836fc9
...
...
@@ -8,6 +8,7 @@ module type S = sig
val
add
:
'
a
t
->
key
->
'
a
->
unit
val
find
:
'
a
t
->
key
->
'
a
val
mem
:
'
a
t
->
key
->
bool
val
remove
:
'
a
t
->
key
->
unit
end
include
S
with
type
key
=
int
runtime/serial.ml
View file @
61836fc9
module
T
=
Custom
.
Array
(
Custom
.
Pair
(
Types
)(
Custom
.
List
(
Patterns
.
Node
)))
let
cu
=
Types
.
CompUnit
.
mk
(
Encodings
.
Utf8
.
mk
"OCAML"
)
let
()
=
Types
.
CompUnit
.
enter
cu
;
Types
.
caml_mode
:=
true
let
init
=
ref
[]
let
serialize
=
ref
[]
module
Mk
(
X
:
Custom
.
T
)
=
struct
module
A
=
Custom
.
Array
(
X
)
let
lst
=
ref
[]
and
nb
=
ref
(
-
1
)
let
put
x
=
lst
:=
x
::
!
lst
;
incr
nb
;
!
nb
let
init
()
=
lst
:=
[]
;
nb
:=
(
-
1
)
let
serialize
s
=
Serialize
.
Put
.
array
X
.
serialize
s
(
Array
.
of_list
(
List
.
rev
!
lst
))
type
'
a
entry
=
Serialized
of
X
.
t
|
Computed
of
'
a
type
'
a
chunk
=
'
a
entry
array
let
deserialize
s
=
Serialize
.
Get
.
array
(
fun
s
->
Serialized
(
X
.
deserialize
s
))
s
let
get
f
a
i
=
match
a
.
(
i
)
with
|
Serialized
x
->
let
x
=
f
x
in
a
.
(
i
)
<-
Computed
x
;
x
|
Computed
x
->
x
end
module
PM
=
Mk
(
Custom
.
Pair
(
Types
)(
Custom
.
List
(
Patterns
.
Node
)))
module
CONST
=
Mk
(
Types
.
Const
)
module
P
=
struct
let
()
=
Types
.
CompUnit
.
enter
(
Types
.
CompUnit
.
mk
(
Encodings
.
Utf8
.
mk
"OCAML"
))
let
init
()
=
PM
.
init
()
;
CONST
.
init
()
let
pms
=
ref
[]
and
nb_pms
=
ref
(
-
1
)
let
serialize
s
()
=
PM
.
serialize
s
;
CONST
.
serialize
s
let
init
()
=
pms
:=
[]
;
nb_pms
:=
(
-
1
)
let
mk
()
=
let
pms
=
Array
.
of_list
(
List
.
rev
!
pms
)
in
Serialize
.
Put
.
run
T
.
serialize
pms
let
pm
=
PM
.
put
let
const
=
CONST
.
put
let
mk
()
=
let
s
=
Serialize
.
Put
.
run
serialize
()
in
ignore
(
Types
.
CompUnit
.
close_serialize
()
);
s
let
pm
t
=
pms
:=
t
::!
pms
;
incr
nb_pms
;
!
nb_pms
end
module
G
=
struct
type
chunk
=
T
.
t
*
(
Patterns
.
Compile
.
dispatcher
*
int
Patterns
.
Compile
.
rhs
array
)
option
array
type
chunk
=
{
pm
:
(
Patterns
.
Compile
.
dispatcher
*
int
Patterns
.
Compile
.
rhs
array
)
PM
.
chunk
;
cst
:
Value
.
t
CONST
.
chunk
;
}
let
deserialize
s
=
let
pm
=
PM
.
deserialize
s
in
let
cst
=
CONST
.
deserialize
s
in
{
pm
=
pm
;
cst
=
cst
}
let
mk
s
=
try
let
a
=
Serialize
.
Get
.
run
T
.
deserialize
s
in
(
a
,
Array
.
create
(
Array
.
length
a
)
None
)
with
_
->
assert
false
let
disp
(
spec
,
d
)
i
=
match
d
.
(
i
)
with
|
Some
x
->
x
|
None
->
let
(
t
,
brs
)
=
spec
.
(
i
)
in
let
brs
=
Array
.
to_list
(
Array
.
mapi
(
fun
i
x
->
(
x
,
i
))
(
Array
.
of_list
brs
))
in
let
x
=
Patterns
.
Compile
.
make_branches
t
brs
in
d
.
(
i
)
<-
Some
x
;
x
Types
.
clear_deserialize_table
()
;
Serialize
.
Get
.
run
deserialize
s
let
mk_pm
(
t
,
brs
)
=
let
brs
=
Array
.
to_list
(
Array
.
mapi
(
fun
i
x
->
(
x
,
i
))
(
Array
.
of_list
brs
))
in
Patterns
.
Compile
.
make_branches
t
brs
let
run
(
chunk
:
chunk
)
i
v
=
let
(
d
,
rhs
)
=
disp
chunk
i
in
let
pm
chunk
i
v
=
let
(
d
,
rhs
)
=
PM
.
get
mk_pm
chunk
.
pm
i
in
let
(
code
,
bindings
)
=
Run_dispatch
.
run_dispatcher
d
v
in
match
rhs
.
(
code
)
with
|
Patterns
.
Compile
.
Fail
->
assert
false
...
...
@@ -49,5 +83,10 @@ module G = struct
Array
.
map
(
fun
(
_
,
i
)
->
if
(
i
==
-
1
)
then
v
else
bindings
.
(
i
))
(
Array
.
of_list
bind
)
let
const
chunk
i
=
CONST
.
get
Value
.
const
chunk
.
cst
i
end
runtime/serial.mli
View file @
61836fc9
...
...
@@ -3,13 +3,15 @@ module P : sig
val
mk
:
unit
->
string
val
pm
:
Types
.
t
*
Patterns
.
Node
.
t
list
->
int
val
const
:
Types
.
const
->
int
end
module
G
:
sig
type
chunk
val
mk
:
string
->
chunk
val
run
:
chunk
->
int
->
Value
.
t
->
int
*
Value
.
t
array
val
pm
:
chunk
->
int
->
Value
.
t
->
int
*
Value
.
t
array
val
const
:
chunk
->
int
->
Value
.
t
end
types/types.ml
View file @
61836fc9
open
Ident
open
Encodings
let
caml_mode
=
ref
false
let
count
=
State
.
ref
"Types.count"
0
let
()
=
Stats
.
register
Stats
.
Summary
(
fun
ppf
->
Format
.
fprintf
ppf
"Allocated type nodes:%i@
\n
"
!
count
)
(* TODO:
- I store hash in types to avoid computing it several times.
Does not seem to help a lot.
...
...
@@ -26,6 +34,8 @@ module CompUnit = struct
assert
(
!
current
!=
dummy_min
);
!
current
let
print
ppf
t
=
Format
.
fprintf
ppf
"%a"
U
.
print
(
value
t
)
let
print_qual
ppf
t
=
if
(
t
!=
!
current
)
&&
(
t
!=
pervasives
)
then
Format
.
fprintf
ppf
"%a."
U
.
print
(
value
t
)
...
...
@@ -48,6 +58,8 @@ module CompUnit = struct
let
stack
=
ref
[]
let
enter
i
=
(* Format.fprintf Format.std_formatter "Types.CompUnit.enter: %a@."
U.print (value i); *)
stack
:=
!
current
::
!
stack
;
current
:=
i
let
leave
()
=
...
...
@@ -357,6 +369,7 @@ sig
val
serialize
:
t
Serialize
.
Put
.
f
val
deserialize
:
t
Serialize
.
Get
.
f
val
mk
:
int
->
Descr
.
t
->
t
val
clear_deserialize_table
:
unit
->
unit
end
=
struct
...
...
@@ -365,6 +378,7 @@ struct
let
dump
ppf
n
=
failwith
"Types.Node.dump"
let
hash
x
=
x
.
id
+
17
*
x
.
comp_unit
let
compare
x
y
=
assert
(
x
.
id
!=
y
.
id
||
x
.
comp_unit
!=
y
.
comp_unit
||
x
==
y
);
let
c
=
x
.
id
-
y
.
id
in
if
c
=
0
then
x
.
comp_unit
-
y
.
comp_unit
else
c
let
equal
x
y
=
x
==
y
...
...
@@ -375,6 +389,7 @@ struct
let
()
=
CompUnit
.
close_serialize_ref
:=
(
fun
()
->
(* Format.fprintf Format.std_formatter "Close_serialize@."; *)
Inttbl
.
clear
serialize_memo
;
counter_serialize
:=
0
)
...
...
@@ -383,10 +398,15 @@ struct
Serialize
.
Put
.
bool
t
true
;
try
let
i
=
Inttbl
.
find
serialize_memo
n
.
id
in
(* Format.fprintf Format.std_formatter
"serialize node (memo) id=%i i=%i@."
n.id i; *)
Serialize
.
Put
.
int
t
i
with
Not_found
->
let
i
=
!
counter_serialize
in
incr
counter_serialize
;
(* Format.fprintf Format.std_formatter "serialize node id=%i i=%i@."
n.id i; *)
Inttbl
.
add
serialize_memo
n
.
id
i
;
Serialize
.
Put
.
int
t
i
;
Descr
.
serialize
t
n
.
descr
...
...
@@ -406,7 +426,12 @@ struct
Inttbl
.
add
deserialize_memo
id
tbl
;
tbl
let
clear_deserialize_table
()
=
Inttbl
.
remove
deserialize_memo
!
CompUnit
.
current
let
mk
id
d
=
(* Format.fprintf Format.std_formatter "mk cu=%a i=%i@."
CompUnit.print !CompUnit.current id; *)
let
n
=
{
id
=
id
;
comp_unit
=
!
CompUnit
.
current
;
descr
=
d
}
in
if
!
CompUnit
.
current
==
CompUnit
.
pervasives
then
Inttbl
.
add
(
find_tbl
CompUnit
.
pervasives
)
n
.
id
n
;
...
...
@@ -415,17 +440,21 @@ struct
let
deserialize
t
=
if
Serialize
.
Get
.
bool
t
then
let
i
=
Serialize
.
Get
.
int
t
in
(* Format.fprintf Format.std_formatter "deserialize i=%i@." i; *)
let
tbl
=
find_tbl
!
CompUnit
.
current
in
try
Inttbl
.
find
tbl
i
with
Not_found
->
let
n
=
{
id
=
i
;
comp_unit
=
!
CompUnit
.
current
;
descr
=
Descr
.
empty
}
in
let
id
=
if
!
caml_mode
then
(
incr
count
;
!
count
)
else
i
in
(* Format.fprintf Format.std_formatter "... not found ==> %i@." id; *)
let
n
=
mk
id
Descr
.
empty
in
Inttbl
.
add
tbl
i
n
;
n
.
descr
<-
Descr
.
deserialize
t
;
n
else
let
cu
=
CompUnit
.
deserialize
t
in
let
i
=
Serialize
.
Get
.
int
t
in
(* Format.fprintf Format.std_formatter "deserialize cu=%a i=%i@."
CompUnit.print cu i; *)
try
Inttbl
.
find
(
Inttbl
.
find
deserialize_memo
cu
)
i
with
Not_found
->
assert
false
...
...
@@ -462,15 +491,13 @@ type descr = Descr.t
type
node
=
Node
.
t
include
Descr
let
clear_deserialize_table
=
Node
.
clear_deserialize_table
let
forward_print
=
ref
(
fun
_
_
->
assert
false
)
let
hash_cons
=
DescrHash
.
create
17000
let
count
=
State
.
ref
"Types.count"
0
let
()
=
Stats
.
register
Stats
.
Summary
(
fun
ppf
->
Format
.
fprintf
ppf
"Allocated type nodes:%i@
\n
"
!
count
)
let
make
()
=
incr
count
;
...
...
types/types.mli
View file @
61836fc9
...
...
@@ -12,7 +12,6 @@ type const =
module
Const
:
Custom
.
T
with
type
t
=
const
module
CompUnit
:
sig
include
Custom
.
T
...
...
@@ -61,6 +60,9 @@ val internalize: Node.t -> Node.t
val
id
:
Node
.
t
->
int
val
descr
:
Node
.
t
->
t
val
caml_mode
:
bool
ref
val
clear_deserialize_table
:
unit
->
unit
(** Boolean connectives **)
val
cup
:
t
->
t
->
t
...
...
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