use
5.008007;
our
$VERSION
=
'0.0312'
;
our
$COMPILER
;
our
$API
;
our
@PACKAGE_INFOS
;
our
%PACKAGE_INFO_SYMTABLE
;
our
$HOME_DIR
;
XSLoader::load(
'SPVM'
,
$VERSION
);
sub
create_jit_sub_name {
my
$sub_name
=
shift
;
my
$jit_sub_name
=
$sub_name
;
$jit_sub_name
=~ s/:/_/g;
$jit_sub_name
=
"SPVM_JITCODE_$jit_sub_name"
;
return
$jit_sub_name
;
}
my
$count
= 0;
sub
compile_jit_sub {
my
(
$sub_id
,
$sub_jitcode_source
) =
@_
;
my
$sub_abs_name
= SPVM::get_sub_name(
$sub_id
);
my
$jit_sub_name
= SPVM::create_jit_sub_name(
$sub_abs_name
);
my
$tmp_dir
= File::Temp->newdir;
my
$jit_source_dir
=
$SPVM::HOME_DIR
||
$tmp_dir
->dirname;
my
$jit_source_file
=
"$jit_source_dir/$jit_sub_name.c"
;
my
$jit_shared_lib_file
=
"$jit_source_dir/$jit_sub_name.$Config{dlext}"
;
my
$old_sub_jitcode_source
;
if
(-f
$jit_source_file
) {
open
my
$fh
,
'<'
,
$jit_source_file
or
die
"Can't open $jit_source_file"
;
$old_sub_jitcode_source
=
do
{
local
$/; <
$fh
> };
}
else
{
$old_sub_jitcode_source
=
''
;
}
if
(!-f
$jit_shared_lib_file
|| (
$sub_jitcode_source
ne
$old_sub_jitcode_source
)) {
open
my
$fh
,
'>'
,
$jit_source_file
or
die
"Can't create $jit_source_file"
;
print
$fh
$sub_jitcode_source
;
close
$fh
;
SPVM::Build::compile_jitcode(
$jit_source_file
);
}
my
$sub_jit_address
= search_shared_lib_func_address(
$jit_shared_lib_file
,
$jit_sub_name
);
unless
(
$sub_jit_address
) {
confess
"Can't get $sub_abs_name jitcode address"
;
}
bind_jitcode_sub(
$sub_abs_name
,
$sub_jit_address
);
my
$success
= 1;
return
$success
;
}
sub
import
{
my
(
$class
,
$package_name
) =
@_
;
$SPVM::HOME_DIR
||=
$ENV
{SPVM_HOME_DIR};
if
(
defined
$package_name
) {
unless
(
$SPVM::PACKAGE_INFO_SYMTABLE
{
$package_name
}) {
my
(
$file
,
$line
) = (
caller
)[1, 2];
my
$package_info
= {
name
=>
$package_name
,
file
=>
$file
,
line
=>
$line
};
push
@SPVM::PACKAGE_INFOS
,
$package_info
;
$SPVM::PACKAGE_INFO_SYMTABLE
{
$package_name
} = 1;
return
$package_info
;
}
}
return
;
}
sub
_get_dll_file {
my
$package_name
=
shift
;
my
$package_name2
=
$package_name
;
$package_name2
=~ s/SPVM:://;
my
@package_name_parts
=
split
(/::/,
$package_name2
);
my
$package_load_path
= get_package_load_path(
$package_name2
);
my
$dll_file
=
$package_load_path
;
$dll_file
=~ s/\.[^.]+$//;
$dll_file
.=
".native/$package_name_parts[-1].$Config{dlext}"
;
return
$dll_file
;
}
sub
search_shared_lib_func_address {
my
(
$shared_lib_file
,
$shared_lib_func_name
) =
@_
;
my
$native_address
;
if
(
$shared_lib_file
) {
my
$dll_libref
= DynaLoader::dl_load_file(
$shared_lib_file
);
if
(
$dll_libref
) {
$native_address
= DynaLoader::dl_find_symbol(
$dll_libref
,
$shared_lib_func_name
);
}
else
{
return
;
}
}
else
{
return
;
}
return
$native_address
;
}
sub
get_sub_native_address {
my
$sub_abs_name
=
shift
;
my
$package_name
;
my
$sub_name
;
if
(
$sub_abs_name
=~ /^(?:(.+)::)(.+)$/) {
$package_name
= $1;
$sub_name
= $2;
}
my
$dll_package_name
=
$package_name
;
my
$shared_lib_file
= _get_dll_file(
$dll_package_name
);
my
$shared_lib_func_name
=
$sub_abs_name
;
$shared_lib_func_name
=~ s/:/_/g;
my
$native_address
= search_shared_lib_func_address(
$shared_lib_file
,
$shared_lib_func_name
);
unless
(
$native_address
) {
my
$module_name
=
$package_name
;
$module_name
=~ s/^SPVM:://;
my
$module_dir
= get_package_load_path(
$module_name
);
$module_dir
=~ s/\.spvm$//;
my
$module_name_slash
=
$package_name
;
$module_name_slash
=~ s/::/\//g;
$module_dir
=~ s/
$module_name_slash
$//;
$module_dir
=~ s/\/$//;
my
$shared_lib_file
;
my
$tmp_dir
= File::Temp->newdir;
eval
{
$shared_lib_file
= SPVM::Build::build_shared_lib(
module_dir
=>
$module_dir
,
module_name
=>
"SPVM::$module_name"
,
object_dir
=>
$tmp_dir
->dirname
);
};
if
($@) {
return
;
}
else
{
$native_address
= search_shared_lib_func_address(
$shared_lib_file
,
$shared_lib_func_name
);
}
}
return
$native_address
;
}
sub
bind_native_subs {
my
$native_func_names
= get_native_sub_names();
for
my
$native_func_name
(
@$native_func_names
) {
my
$native_func_name_spvm
=
"SPVM::$native_func_name"
;
my
$native_address
= get_sub_native_address(
$native_func_name_spvm
);
unless
(
$native_address
) {
my
$native_func_name_c
=
$native_func_name_spvm
;
$native_func_name_c
=~ s/:/_/g;
confess
"Can't find native address of $native_func_name_spvm(). Native function name must be $native_func_name_c"
;
}
bind_native_sub(
$native_func_name
,
$native_address
);
}
}
CHECK {
unless
(
$ENV
{SPVM_NO_COMPILE}) {
my
$compile_success
= compile_spvm();
unless
(
$compile_success
) {
croak(
"SPVM compile error"
);
}
}
}
sub
compile_spvm {
my
$compile_success
= compile();
if
(
$compile_success
) {
build_constant_pool();
build_opcode();
build_runtime();
bind_native_subs();
build_spvm_subs();
}
return
$compile_success
;
}
sub
new_byte_array_len {
my
$length
=
shift
;
my
$array
= SPVM::Core::Object::Array::Byte->new_len(
$length
);
return
$array
;
}
sub
new_byte_array {
my
$elements
=
shift
;
return
undef
unless
defined
$elements
;
if
(
ref
$elements
ne
'ARRAY'
) {
confess
"Argument must be array reference"
;
}
my
$length
=
@$elements
;
my
$array
= SPVM::Core::Object::Array::Byte->new_len(
$length
);
$array
->set_elements(
$elements
);
return
$array
;
}
sub
new_short_array {
my
$elements
=
shift
;
return
undef
unless
defined
$elements
;
if
(
ref
$elements
ne
'ARRAY'
) {
confess
"Argument must be array reference"
;
}
my
$length
=
@$elements
;
my
$array
= SPVM::Core::Object::Array::Short->new_len(
$length
);
$array
->set_elements(
$elements
);
return
$array
;
}
sub
new_byte_array_data {
my
$data
=
shift
;
my
$length
=
length
$data
;
my
$array
= SPVM::Core::Object::Array::Byte->new_len(
$length
);
$array
->set_data(
$data
);
return
$array
;
}
sub
new_short_array_len {
my
$length
=
shift
;
my
$array
= SPVM::Core::Object::Array::Short->new_len(
$length
);
return
$array
;
}
sub
new_byte_array_string {
my
$string
=
shift
;
my
$data
= Encode::encode(
'UTF-8'
,
$string
);
my
$array
= SPVM::new_byte_array_data(
$data
);
return
$array
;
}
sub
new_short_array_data {
my
$data
=
shift
;
my
$byte_length
=
length
$data
;
unless
(
$byte_length
% 2 == 0) {
confess(
"data byte length must be divide by 2(SPVM::new_short_array_data())"
);
}
my
$length
=
int
(
$byte_length
/ 2);
my
$array
= SPVM::Core::Object::Array::Short->new_len(
$length
);
$array
->set_data(
$data
);
return
$array
;
}
sub
new_int_array_len {
my
$length
=
shift
;
my
$array
= SPVM::Core::Object::Array::Int->new_len(
$length
);
return
$array
;
}
sub
new_int_array {
my
$elements
=
shift
;
return
undef
unless
defined
$elements
;
if
(
ref
$elements
ne
'ARRAY'
) {
confess
"Argument must be array reference"
;
}
my
$length
=
@$elements
;
my
$array
= SPVM::Core::Object::Array::Int->new_len(
$length
);
$array
->set_elements(
$elements
);
return
$array
;
}
sub
new_int_array_data {
my
$data
=
shift
;
my
$byte_length
=
length
$data
;
unless
(
$byte_length
% 4 == 0) {
confess(
"data byte length must be divide by 4(SPVM::new_int_array_data())"
);
}
my
$length
=
int
(
$byte_length
/ 4);
my
$array
= SPVM::Core::Object::Array::Int->new_len(
$length
);
$array
->set_data(
$data
);
return
$array
;
}
sub
new_long_array_len {
my
$length
=
shift
;
my
$array
= SPVM::Core::Object::Array::Long->new_len(
$length
);
return
$array
;
}
sub
new_long_array {
my
$elements
=
shift
;
return
undef
unless
defined
$elements
;
if
(
ref
$elements
ne
'ARRAY'
) {
confess
"Argument must be array reference"
;
}
my
$length
=
@$elements
;
my
$array
= SPVM::Core::Object::Array::Long->new_len(
$length
);
$array
->set_elements(
$elements
);
return
$array
;
}
sub
new_long_array_data {
my
$data
=
shift
;
my
$byte_length
=
length
$data
;
unless
(
$byte_length
% 8 == 0) {
confess(
"data byte length must be divide by 8(SPVM::new_long_array_data())"
);
}
my
$length
=
$byte_length
/ 8;
my
$array
= SPVM::Core::Object::Array::Long->new_len(
$length
);
$array
->set_data(
$data
);
return
$array
;
}
sub
new_float_array_len {
my
$length
=
shift
;
my
$array
= SPVM::Core::Object::Array::Float->new_len(
$length
);
return
$array
;
}
sub
new_float_array {
my
$elements
=
shift
;
return
undef
unless
defined
$elements
;
if
(
ref
$elements
ne
'ARRAY'
) {
confess
"Argument must be array reference"
;
}
my
$length
=
@$elements
;
my
$array
= SPVM::Core::Object::Array::Float->new_len(
$length
);
$array
->set_elements(
$elements
);
return
$array
;
}
sub
new_float_array_data {
my
$data
=
shift
;
my
$byte_length
=
length
$data
;
unless
(
$byte_length
% 4 == 0) {
confess(
"data byte length must be divide by 4(SPVM::new_float_array_data())"
);
}
my
$length
=
$byte_length
/ 4;
my
$array
= SPVM::Core::Object::Array::Float->new_len(
$length
);
$array
->set_data(
$data
);
return
$array
;
}
sub
new_double_array_len {
my
$length
=
shift
;
my
$array
= SPVM::Core::Object::Array::Double->new_len(
$length
);
return
$array
;
}
sub
new_double_array {
my
$elements
=
shift
;
return
undef
unless
defined
$elements
;
if
(
ref
$elements
ne
'ARRAY'
) {
confess
"Argument must be array reference"
;
}
my
$length
=
@$elements
;
my
$array
= SPVM::Core::Object::Array::Double->new_len(
$length
);
$array
->set_elements(
$elements
);
return
$array
;
}
sub
new_double_array_data {
my
$data
=
shift
;
my
$byte_length
=
length
$data
;
unless
(
$byte_length
% 8 == 0) {
confess(
"data byte length must be divide by 8(SPVM::new_double_array_data())"
);
}
my
$length
=
$byte_length
/ 8;
my
$array
= SPVM::Core::Object::Array::Double->new_len(
$length
);
$array
->set_data(
$data
);
return
$array
;
}
sub
new_object_array_len {
my
(
$type_name
,
$length
) =
@_
;
my
$array
= SPVM::Core::Object::Array::Object->new_len(
$type_name
,
$length
);
return
$array
;
}
sub
new_object {
my
$package_name
=
shift
;
my
$object
= SPVM::Core::Object::Package->new(
$package_name
);
return
$object
;
}
my
$package_name_h
= {};
sub
build_spvm_subs {
my
$sub_names
= get_sub_names();
for
my
$abs_name
(
@$sub_names
) {
no
strict
'refs'
;
my
(
$package_name
) =
$abs_name
=~ /^(?:(.+)::)/;
$package_name
=
"SPVM::$package_name"
;
unless
(
$package_name_h
->{
$package_name
}) {
my
$code
=
"package $package_name; our \@ISA = ('SPVM::Core::Object::Package');"
;
eval
$code
;
if
(
my
$error
= $@) {
confess
$error
;
}
$package_name_h
->{
$package_name
} = 1;
}
*{
"SPVM::$abs_name"
} =
sub
{
my
$return_value
;
eval
{
$return_value
= SPVM::call_sub(
"$abs_name"
,
@_
) };
my
$error
= $@;
if
(
$error
) {
confess
$error
;
}
$return_value
;
};
}
}
1;