my
$COMPILER
;
my
$API
;
END {
if
(
$API
) {
{
my
$env
=
delete
$API
->{env};
my
$stack
=
delete
$API
->{stack};
$env
->destroy_class_vars(
$stack
);
}
$API
=
undef
;
$COMPILER
=
undef
;
}
}
sub
api {
unless
(
$API
) {
&init_api
();
}
return
$API
;
}
sub
build_class {
my
(
$class_name
,
$file
,
$line
) =
@_
;
my
$options
= {
class_name
=>
$class_name
,
file
=>
$file
,
line
=>
$line
,
};
&build_class_common
(
$options
);
}
sub
build_anon_class {
my
(
$source
,
$file
,
$line
) =
@_
;
my
$options
= {
source
=>
$source
,
file
=>
$file
,
line
=>
$line
,
};
my
$anon_class_name
=
&build_class_common
(
$options
);
return
$anon_class_name
;
}
sub
build_class_common {
my
(
$options
) =
@_
;
$options
||= {};
my
$class_name
=
$options
->{class_name};
my
$source
=
$options
->{source};
my
$file
=
$options
->{file};
my
$line
=
$options
->{line};
&init_api
();
my
$build_success
;
if
(
defined
$class_name
||
defined
$source
) {
my
$api
=
$API
;
my
$compiler
=
$COMPILER
;
my
$env
=
$api
->env;
my
$runtime
=
$compiler
->get_runtime;
my
$start_basic_types_length
=
$runtime
->get_basic_types_length;
if
(
defined
$source
) {
$class_name
=
$compiler
->compile_anon_class_with_exit(
$source
,
$file
,
$line
);
}
else
{
$compiler
->compile_with_exit(
$class_name
,
$file
,
$line
);
}
my
$basic_types_length
=
$runtime
->get_basic_types_length;
for
(
my
$basic_type_id
=
$start_basic_types_length
;
$basic_type_id
<
$basic_types_length
;
$basic_type_id
++) {
my
$basic_type
=
$runtime
->get_basic_type_by_id(
$basic_type_id
);
my
$class_name
=
$basic_type
->get_name;
&load_dynamic_lib
(
$runtime
,
$class_name
);
}
my
$stack
=
$api
->stack;
$env
->call_init_methods(
$stack
);
&bind_to_perl
(
$class_name
);
}
return
$class_name
;
}
sub
init_api {
unless
(
$API
) {
my
$build_dir
= SPVM::Builder::Util::get_normalized_env(
'SPVM_BUILD_DIR'
);
my
$builder
= SPVM::Builder->new(
build_dir
=>
$build_dir
);
my
$compiler
= SPVM::Builder::Native::Compiler->new;
for
my
$include_dir
(@{
$builder
->include_dirs}) {
$compiler
->add_include_dir(
$include_dir
);
}
my
$runtime
=
$compiler
->get_runtime;
my
$start_basic_types_length
=
$runtime
->get_basic_types_length;
$compiler
->compile_with_exit(
undef
, __FILE__, __LINE__);
my
$basic_types_length
=
$runtime
->get_basic_types_length;
for
(
my
$basic_type_id
=
$start_basic_types_length
;
$basic_type_id
<
$basic_types_length
;
$basic_type_id
++) {
my
$basic_type
=
$runtime
->get_basic_type_by_id(
$basic_type_id
);
my
$class_name
=
$basic_type
->get_name;
&load_dynamic_lib
(
$runtime
,
$class_name
);
}
my
$env
=
$runtime
->get_env;
my
$stack
=
$env
->new_stack;
my
$api
= SPVM::ExchangeAPI->new(
env
=>
$env
,
stack
=>
$stack
);
$COMPILER
=
$compiler
;
$API
=
$api
;
$env
->set_command_info_program_name(
$stack
, $0);
$env
->set_command_info_argv(
$stack
, \
@ARGV
);
my
$base_time
= $^T + 0;
$env
->set_command_info_base_time(
$stack
,
$base_time
);
}
}
sub
load_dynamic_lib {
my
(
$runtime
,
$class_name
) =
@_
;
for
my
$category
(
'precompile'
,
'native'
) {
my
$basic_type
=
$runtime
->get_basic_type_by_name(
$class_name
);
my
$method_names
=
$basic_type
->get_method_names_by_category(
$category
);
if
(
@$method_names
) {
my
$class_file
=
$basic_type
->get_class_file;
my
$dynamic_lib_file
= SPVM::Builder::Util::get_dynamic_lib_file_dist(
$class_file
,
$category
);
unless
(-f
$dynamic_lib_file
) {
my
$build_dir
= SPVM::Builder::Util::get_normalized_env(
'SPVM_BUILD_DIR'
);
my
$builder
= SPVM::Builder->new(
build_dir
=>
$build_dir
);
$dynamic_lib_file
=
$builder
->build_jit(
$class_name
,
{
runtime
=>
$runtime
,
class_file
=>
$class_file
,
category
=>
$category
,
}
);
}
if
(-f
$dynamic_lib_file
) {
my
$method_addresses
= SPVM::Builder::Util::get_method_addresses(
$dynamic_lib_file
,
$class_name
,
$method_names
,
$category
);
for
my
$method_name
(
sort
keys
%$method_addresses
) {
my
$cfunc_address
=
$method_addresses
->{
$method_name
};
my
$method
=
$basic_type
->get_method_by_name(
$method_name
);
if
(
$category
eq
'precompile'
) {
$method
->set_precompile_address(
$cfunc_address
);
}
elsif
(
$category
eq
'native'
) {
$method
->set_native_address(
$cfunc_address
);
}
}
}
}
}
}
my
$BIND_TO_PERL_CLASS_NAME_H
= {};
sub
bind_to_perl {
my
(
$class_name
) =
@_
;
my
$env
=
$API
->env;
my
$runtime
=
$env
->runtime;
my
$basic_type
=
$runtime
->get_basic_type_by_name(
$class_name
);
my
$perl_class_name_base
=
"SPVM::"
;
my
$perl_class_name
=
"$perl_class_name_base$class_name"
;
unless
(
$BIND_TO_PERL_CLASS_NAME_H
->{
$perl_class_name
}) {
my
$parent_basic_type
=
$basic_type
->get_parent;
my
@isa
;
if
(
defined
$parent_basic_type
) {
my
$parent_basic_type_name
=
$parent_basic_type
->get_name;
push
@isa
,
"$perl_class_name_base$parent_basic_type_name"
;
}
push
@isa
,
'SPVM::BlessedObject::Class'
;
my
$isa
=
"our \@ISA = ("
.
join
(
','
,
map
{
"'$_'"
}
@isa
) .
");"
;
my
$suppress_warning_code
=
"sub import {} sub CLONE_SKIP { 1 } sub CLONE {}"
;
my
$code
=
"package $perl_class_name; $isa $suppress_warning_code"
;
eval
$code
;
if
(
my
$error
= $@) {
confess(
$error
);
}
my
$methods_length
=
$basic_type
->get_methods_length;
for
(
my
$method_index
= 0;
$method_index
<
$methods_length
;
$method_index
++) {
my
$method
=
$basic_type
->get_method_by_index(
$method_index
);
my
$method_name
=
$method
->get_name;
if
(
$method_name
eq
'DESTROY'
) {
next
;
}
elsif
(
length
$method_name
== 0) {
next
;
}
my
$perl_method_abs_name
=
"${perl_class_name}::$method_name"
;
my
$is_class_method
=
$method
->is_class_method;
if
(
$is_class_method
) {
no
strict
'refs'
;
my
$class_name_string
=
"$class_name"
;
my
$method_name_string
=
"$method_name"
;
*{
"$perl_method_abs_name"
} =
sub
{
my
$perl_class_name
=
shift
;
my
$return_value
;
eval
{
$return_value
= SPVM::api()->call_method(
$class_name_string
,
$method_name_string
,
@_
) };
my
$error
= $@;
if
(
$error
) {
confess(
$error
);
}
$return_value
;
};
}
}
$BIND_TO_PERL_CLASS_NAME_H
->{
$perl_class_name
} = 1;
}
}
=head1 Name
SPVM::Global - SPVM Global Instance
=head1 Copyright & License
Copyright (c) 2023 Yuki Kimoto
MIT License