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
2b647786
Commit
2b647786
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2004-06-28 18:24:35 by afrisch] Delay the allocation of slots for externals
Original author: afrisch Date: 2004-06-28 18:24:35+00:00
parent
307139e9
Changes
14
Hide whitespace changes
Inline
Side-by-side
compile/compile.ml
View file @
2b647786
...
...
@@ -17,9 +17,9 @@ let dump ppf env =
env
.
vars
let
mk
cu
g
=
{
cu
=
cu
;
vars
=
Env
.
empty
;
stack_size
=
0
;
global_size
=
g
}
let
empty_toplevel
=
mk
None
0
let
empty
x
g
=
mk
(
Some
x
)
g
let
mk
cu
=
{
cu
=
cu
;
vars
=
Env
.
empty
;
stack_size
=
0
;
global_size
=
0
}
let
empty_toplevel
=
mk
None
let
empty
x
=
mk
(
Some
x
)
let
serialize
s
env
=
...
...
@@ -84,7 +84,7 @@ and compile_aux env tail = function
|
Typed
.
Ref
(
e
,
t
)
->
Ref
(
compile
env
tail
e
,
t
)
|
Typed
.
External
(
t
,
i
)
->
(
match
env
.
cu
with
|
Some
cu
->
Var
(
Ext
(
cu
,
i
))
|
Some
cu
->
Var
(
Ext
ernal
(
cu
,
i
))
|
None
->
failwith
"Cannot compile externals in the toplevel"
)
and
compile_abstr
env
a
=
...
...
@@ -101,7 +101,7 @@ and compile_abstr env a =
p
::
slots
,
succ
nb_slots
,
Env
.
add
x
(
Env
nb_slots
)
fun_env
;
|
Global
_
|
Ext
_
as
p
->
|
Global
_
|
Ext
_
|
External
_
as
p
->
slots
,
nb_slots
,
Env
.
add
x
p
fun_env
...
...
compile/compile.mli
View file @
2b647786
...
...
@@ -7,17 +7,11 @@ val from_comp_unit: (Types.CompUnit.t -> env) ref
val
dump
:
Format
.
formatter
->
env
->
unit
val
empty
:
Types
.
CompUnit
.
t
->
int
->
env
(* integer: number of already allocated globals *)
val
empty
:
Types
.
CompUnit
.
t
->
env
val
empty_toplevel
:
env
val
serialize
:
env
Serialize
.
Put
.
f
val
deserialize
:
env
Serialize
.
Get
.
f
(*
val enter_global : env -> id -> env
val enter_globals : env -> id list -> env
*)
val
find
:
id
->
env
->
var_loc
val
find_slot
:
id
->
env
->
int
...
...
compile/lambda.ml
View file @
2b647786
...
...
@@ -4,6 +4,8 @@ type var_loc =
|
Stack
of
int
|
Env
of
int
|
Ext
of
Types
.
CompUnit
.
t
*
int
(* If pos < 0, the first arg is the value *)
|
External
of
Types
.
CompUnit
.
t
*
int
(* If pos < 0, the first arg is the value *)
|
Global
of
int
(* Only for the toplevel *)
|
Dummy
...
...
@@ -11,6 +13,7 @@ let print_var_loc ppf = function
|
Stack
i
->
Format
.
fprintf
ppf
"Stack %i"
i
|
Env
i
->
Format
.
fprintf
ppf
"Env %i"
i
|
Ext
(
cu
,
i
)
->
Format
.
fprintf
ppf
"Ext (_,%i)"
i
|
External
(
cu
,
i
)
->
Format
.
fprintf
ppf
"External (_,%i)"
i
|
Global
i
->
Format
.
fprintf
ppf
"Global %i"
i
|
Dummy
->
Format
.
fprintf
ppf
"Dummy"
...
...
@@ -90,17 +93,21 @@ module Put = struct
let
var_loc
s
=
function
|
Stack
i
->
bits
2
s
0
;
bits
3
s
0
;
int
s
i
|
Ext
(
cu
,
i
)
->
bits
2
s
1
;
bits
3
s
1
;
Types
.
CompUnit
.
serialize
s
cu
;
int
s
i
|
External
(
cu
,
i
)
->
bits
3
s
2
;
Types
.
CompUnit
.
serialize
s
cu
;
int
s
i
|
Env
i
->
bits
2
s
2
;
bits
3
s
3
;
int
s
i
|
Dummy
->
bits
2
s
3
bits
3
s
4
|
Global
_
->
assert
false
let
rec
expr
s
=
function
...
...
@@ -207,14 +214,18 @@ module Get = struct
open
Serialize
.
Get
let
var_loc
s
=
match
bits
2
s
with
match
bits
3
s
with
|
0
->
Stack
(
int
s
)
|
1
->
let
cu
=
Types
.
CompUnit
.
deserialize
s
in
let
pos
=
int
s
in
Ext
(
cu
,
pos
)
|
2
->
Env
(
int
s
)
|
3
->
Dummy
|
2
->
let
cu
=
Types
.
CompUnit
.
deserialize
s
in
let
pos
=
int
s
in
External
(
cu
,
pos
)
|
3
->
Env
(
int
s
)
|
4
->
Dummy
|
_
->
assert
false
let
rec
expr
s
=
...
...
driver/librarian.ml
View file @
2b647786
...
...
@@ -18,22 +18,26 @@ type t = {
compile
:
Compile
.
env
;
code
:
Lambda
.
code_item
list
;
types
:
Types
.
t
array
;
has_ext
:
bool
;
mutable
digest
:
Digest
.
t
option
;
vals
:
Value
.
t
array
;
mutable
exts
:
Value
.
t
array
;
mutable
depends
:
C
.
t
list
;
mutable
status
:
[
`Evaluating
|
`Unevaluated
|
`Evaluated
];
mutable
stub
:
stub_ml
option
}
let
mk
((
typing
,
compile
,
code
)
,
types
)
=
let
mk
((
typing
,
compile
,
code
)
,
types
,
ext
)
=
{
typing
=
typing
;
compile
=
compile
;
code
=
code
;
types
=
types
;
has_ext
=
ext
;
digest
=
None
;
vals
=
Array
.
make
(
Compile
.
global_size
compile
)
Value
.
Absent
;
exts
=
[
|
|
];
depends
=
[]
;
status
=
`Unevaluated
;
stub
=
None
...
...
@@ -54,7 +58,8 @@ let serialize s cu =
Typer
.
serialize
s
cu
.
typing
;
Compile
.
serialize
s
cu
.
compile
;
Lambda
.
Put
.
codes
s
cu
.
code
;
Serialize
.
Put
.
array
Types
.
serialize
s
cu
.
types
Serialize
.
Put
.
array
Types
.
serialize
s
cu
.
types
;
Serialize
.
Put
.
bool
s
cu
.
has_ext
let
deserialize
s
=
Serialize
.
Get
.
magic
s
magic
;
...
...
@@ -62,7 +67,8 @@ let deserialize s =
let
compile
=
Compile
.
deserialize
s
in
let
code
=
Lambda
.
Get
.
codes
s
in
let
types
=
Serialize
.
Get
.
array
Types
.
deserialize
s
in
mk
((
typing
,
compile
,
code
)
,
types
)
let
ext
=
Serialize
.
Get
.
bool
s
in
mk
((
typing
,
compile
,
code
)
,
types
,
ext
)
(*
let serialize_dep=
...
...
@@ -167,11 +173,12 @@ let rec compile verbose name id src =
Compile
.
comp_unit
?
show
Builtin
.
env
(
Compile
.
empty
id
(
Externals
.
nb
()
)
)
(
Compile
.
empty
id
)
p
in
let
stub
,
types
=
!
stub_ml
name
ty_env
c_env
in
let
cu
=
mk
(
cu
,
types
)
in
let
ext
=
Externals
.
nb
()
>
0
in
let
cu
=
mk
(
cu
,
types
,
ext
)
in
cu
.
stub
<-
stub
;
C
.
Tbl
.
add
tbl
id
cu
;
C
.
leave
()
;
...
...
@@ -238,6 +245,10 @@ let rec run id =
let
cu
=
find
id
in
match
cu
.
status
with
|
`Unevaluated
->
if
cu
.
has_ext
&&
(
Array
.
length
cu
.
exts
=
0
)
then
failwith
(
"Librarian.run. This module needs externals:"
^
(
U
.
to_string
(
C
.
value
id
)));
List
.
iter
run
cu
.
depends
;
cu
.
status
<-
`Evaluating
;
Eval
.
code_items
cu
.
code
;
...
...
@@ -268,10 +279,10 @@ let () =
Typer
.
from_comp_unit
:=
(
fun
cu
->
(
load
cu
)
.
typing
);
Compile
.
from_comp_unit
:=
(
fun
cu
->
(
load
cu
)
.
compile
);
Eval
.
get_global
:=
(
fun
cu
i
->
import_and_run
cu
;
(
load
cu
)
.
vals
.
(
i
));
Eval
.
set_global
:=
(
fun
cu
i
v
->
import
cu
;
let
cu
=
load
cu
in
cu
.
vals
.
(
i
)
<-
v
)
Eval
.
set_global
:=
(
fun
cu
i
v
->
import
cu
;
(
load
cu
)
.
vals
.
(
i
)
<-
v
);
Eval
.
get_external
:=
(
fun
cu
i
->
(
load
cu
)
.
exts
.
(
i
))
let
set_externals
cu
a
=
(
load
cu
)
.
exts
<-
a
let
registered_types
cu
=
(
load
cu
)
.
types
driver/librarian.mli
View file @
2b647786
...
...
@@ -21,6 +21,8 @@ val save: string -> Types.CompUnit.t -> string -> unit
val
registered_types
:
Types
.
CompUnit
.
t
->
Types
.
t
array
val
set_externals
:
Types
.
CompUnit
.
t
->
Value
.
t
array
->
unit
type
stub_ml
val
stub_ml
:
(
string
->
Typer
.
t
->
Compile
.
env
->
...
...
ocamliface/mlstub.ml
View file @
2b647786
...
...
@@ -461,14 +461,8 @@ let check_value ty_env c_env (s,caml_t,t) =
let
stub
name
ty_env
c_env
values
=
let
items
=
List
.
map
(
check_value
ty_env
c_env
)
values
in
let
exts
=
List
.
map
(
fun
(
s
,
i
,
t
)
->
let
c
=
to_cd
<:
expr
<
$
lid
:
s
$
>>
t
in
<:
str_item
<
Eval
.
set_slot
cu
$
int
:
string_of_int
i
$
$
c
$
>>
)
!
exts
in
let
exts
=
List
.
rev_map
(
fun
(
s
,
t
)
->
to_cd
<:
expr
<
$
lid
:
s
$
>>
t
)
!
exts
in
let
g
=
global_transl
()
in
(*
...
...
@@ -492,7 +486,7 @@ let stub name ty_env c_env values =
[
<:
str_item
<
open
CDuce_all
>>;
<:
str_item
<
value
types
=
Librarian
.
registered_types
cu
>>
]
@
(
if
g
=
[]
then
[]
else
[
<:
str_item
<
value
rec
$
list
:
g
$
>>
])
@
[
<:
str_item
<
declare
$
list
:
exts
$
end
>>;
[
<:
str_item
<
Librarian
.
set_externals
cu
[
|
$
list
:
exts
$
|
]
>>;
<:
str_item
<
Librarian
.
run
cu
>>
]
@
(
if
items
=
[]
then
[]
else
[
<:
str_item
<
value
$
list
:
items_def
$
>>
])
in
...
...
@@ -520,7 +514,7 @@ let () =
with
Mltypes
.
Error
s
->
raise
(
Location
.
Generic
s
)
);
Externals
.
re
solve
:=
Externals
.
re
gister
:=
(
fun
i
s
args
->
let
(
t
,
n
)
=
try
Mltypes
.
find_value
s
...
...
@@ -534,12 +528,10 @@ let () =
Printf
.
eprintf
"Wrong arity for external symbol %s (real arity = %i; given = %i)
\n
"
s
n
m
;
exit
1
);
exts
:=
(
s
,
i
,
t
)
::
!
exts
;
exts
:=
(
s
,
t
)
::
!
exts
;
vars
:=
Array
.
of_list
args
;
let
cdt
=
Types
.
descr
(
typ
t
)
in
(* Format.fprintf Format.std_formatter "Instance: %a@."
Types.Print.print cdt; *)
vars
:=
[
|
|
];
cdt
)
parser/ast.ml
View file @
2b647786
...
...
@@ -72,7 +72,7 @@ and pexpr =
|
Forget
of
pexpr
*
ppat
|
Op
of
string
*
pexpr
list
|
Ref
of
pexpr
*
ppat
|
External
of
string
*
ppat
list
*
int
|
External
of
string
*
ppat
list
...
...
parser/parser.ml
View file @
2b647786
...
...
@@ -218,9 +218,9 @@ EXTEND
|
"fun"
;
(
f
,
a
,
b
)
=
fun_decl
->
exp
loc
(
Abstraction
{
fun_name
=
f
;
fun_iface
=
a
;
fun_body
=
b
})
|
"external"
;
s
=
STRING2
->
exp
loc
(
External
(
s
,
[]
,
Externals
.
alloc
()
))
exp
loc
(
External
(
s
,
[]
))
|
"external"
;
"{"
;
s
=
STRING2
;
pl
=
LIST0
pat
;
"}"
->
exp
loc
(
External
(
s
,
pl
,
Externals
.
alloc
()
))
exp
loc
(
External
(
s
,
pl
))
|
(
_
,
p
,
e1
)
=
let_binding
;
"in"
;
e2
=
expr
LEVEL
"top"
->
exp
loc
(
Match
(
e1
,
[
p
,
e2
]))
|
(
name
,
ns
)
=
namespace_binding
;
"in"
;
e2
=
expr
LEVEL
"top"
->
...
...
runtime/eval.ml
View file @
2b647786
...
...
@@ -63,6 +63,8 @@ let pop () =
let
get_global
=
ref
(
fun
cu
pos
->
assert
false
)
let
set_global
=
ref
(
fun
cu
pos
->
assert
false
)
let
get_external
=
ref
(
fun
cu
pos
->
assert
false
)
let
set_external
=
ref
(
fun
cu
pos
->
assert
false
)
let
get_slot
cu
pos
=
!
get_global
cu
pos
let
set_slot
cu
pos
v
=
!
set_global
cu
pos
v
...
...
@@ -79,6 +81,13 @@ let eval_var env = function
Obj
.
set_field
x
0
(
Obj
.
repr
v
);
Obj
.
set_field
x
1
(
Obj
.
repr
(
-
1
));
v
|
External
(
cu
,
pos
)
as
x
->
if
pos
<
0
then
(
Obj
.
magic
cu
:
Value
.
t
)
else
let
v
=
!
get_external
cu
pos
in
let
x
=
Obj
.
repr
x
in
Obj
.
set_field
x
0
(
Obj
.
repr
v
);
Obj
.
set_field
x
1
(
Obj
.
repr
(
-
1
));
v
let
rec
eval
env
=
function
|
Var
x
->
eval_var
env
x
...
...
runtime/eval.mli
View file @
2b647786
...
...
@@ -7,6 +7,8 @@ val eval_binary_op : (int -> (t -> t -> t)) ref
val
get_global
:
(
Types
.
CompUnit
.
t
->
int
->
t
)
ref
val
set_global
:
(
Types
.
CompUnit
.
t
->
int
->
t
->
unit
)
ref
val
get_external
:
(
Types
.
CompUnit
.
t
->
int
->
t
)
ref
val
set_external
:
(
Types
.
CompUnit
.
t
->
int
->
t
->
unit
)
ref
val
get_slot
:
Types
.
CompUnit
.
t
->
int
->
t
val
set_slot
:
Types
.
CompUnit
.
t
->
int
->
t
->
unit
...
...
tests/ocaml/Makefile
View file @
2b647786
# Do "make install_cdml" before running this test
STATIC
=
-static
CAML
=
ocaml
opt
STATIC
=
CAML
=
ocaml
c
CDUCE
=
../../cduce
CDO2ML
=
../../cdo2ml
...
...
types/externals.ml
View file @
2b647786
let
nb_ext_syms
=
ref
0
let
alloc
()
=
let
i
=
!
nb_ext_syms
in
incr
nb_ext_syms
;
i
let
nb
()
=
!
nb_ext_syms
let
resolve
=
ref
(
fun
i
s
args
->
assert
false
)
let
register
=
ref
(
fun
i
s
args
->
assert
false
)
let
resolve
s
args
=
let
i
=
!
nb_ext_syms
in
incr
nb_ext_syms
;
(
i
,
!
register
i
s
args
)
types/externals.mli
View file @
2b647786
val
alloc
:
unit
->
int
val
nb
:
unit
->
int
val
resolve
:
ref
(
int
->
string
->
Types
.
Node
.
t
list
->
Types
.
t
)
val
register
:
ref
(
int
->
string
->
Types
.
Node
.
t
list
->
Types
.
t
)
val
resolve
:
string
->
Types
.
Node
.
t
list
->
int
*
Types
.
t
typing/typer.ml
View file @
2b647786
...
...
@@ -939,9 +939,9 @@ let rec expr env loc = function
|
Ref
(
e
,
t
)
->
let
(
fv
,
e
)
=
expr
env
loc
e
and
t
=
typ
env
t
in
exp
loc
fv
(
Typed
.
Ref
(
e
,
t
))
|
External
(
s
,
args
,
i
)
->
|
External
(
s
,
args
)
->
let
args
=
List
.
map
(
typ
env
)
args
in
let
t
=
!
Externals
.
resolve
i
s
args
in
let
(
i
,
t
)
=
Externals
.
resolve
s
args
in
exp
loc
Fv
.
empty
(
Typed
.
External
(
t
,
i
))
and
branches
env
b
=
...
...
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