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
C
cduce
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
19
Issues
19
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
cduce
cduce
Commits
25342609
Commit
25342609
authored
Oct 05, 2007
by
Pietro Abate
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[r2005-03-23 14:03:59 by afrisch] Empty log message
Original author: afrisch Date: 2005-03-23 14:04:00+00:00
parent
971dc658
Changes
6
Hide whitespace changes
Inline
Side-by-side
Showing
6 changed files
with
116 additions
and
42 deletions
+116
-42
misc/inttbl.ml
misc/inttbl.ml
+4
-1
misc/inttbl.mli
misc/inttbl.mli
+1
-0
runtime/serial.ml
runtime/serial.ml
+71
-32
runtime/serial.mli
runtime/serial.mli
+3
-1
types/types.ml
types/types.ml
+34
-7
types/types.mli
types/types.mli
+3
-1
No files found.
misc/inttbl.ml
View file @
25342609
...
...
@@ -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 @
25342609
...
...
@@ -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 @
25342609
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 @
25342609
...
...
@@ -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 @
25342609
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 @
25342609
...
...
@@ -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