package FFI::TinyCC;
use strict;
use warnings;
use 5.008001;
use Config;
use FFI::Platypus;
use FFI::Platypus::Memory qw( malloc free );
use Carp qw( croak carp );
use File::Spec;
use File::ShareDir::Dist qw( dist_share );
# ABSTRACT: Tiny C Compiler for FFI
our $VERSION = '0.30'; # VERSION
sub _dlext ()
{
$^O eq 'MSWin32' ? 'dll' : $Config{dlext};
}
our $ffi = FFI::Platypus->new;
$ffi->lib(
File::Spec->catfile(dist_share( 'FFI-TinyCC' ), 'libtcc.' . _dlext)
);
$ffi->custom_type( tcc_t => {
perl_to_native => sub {
$_[0]->{handle},
},
native_to_perl => sub {
{
handle => $_[0],
relocate => 0,
error => [],
};
},
});
do {
my %output_type = qw(
memory 0
exe 1
dll 2
obj 3
);
$ffi->custom_type( output_t => {
native_type => 'int',
perl_to_native => sub { $output_type{$_[0]} },
});
};
$ffi->type('int' => 'error_t');
$ffi->type('(opaque,string)->void' => 'error_handler_t');
$ffi->attach([tcc_new => '_new'] => [] => 'tcc_t');
$ffi->attach([tcc_delete => '_delete'] => ['tcc_t'] => 'void');
$ffi->attach([tcc_set_error_func => '_set_error_func'] => ['tcc_t', 'opaque', 'error_handler_t'] => 'void');
$ffi->attach([tcc_add_symbol => '_add_symbol'] => ['tcc_t', 'string', 'opaque'] => 'int');
$ffi->attach([tcc_get_symbol => '_get_symbol'] => ['tcc_t', 'string'] => 'opaque');
$ffi->attach([tcc_relocate => '_relocate'] => ['tcc_t', 'opaque'] => 'int');
$ffi->attach([tcc_run => '_run'] => ['tcc_t', 'int', 'opaque'] => 'int');
sub _method ($;@)
{
my($name, @args) = @_;
$ffi->attach(["tcc_$name" => "_$name"] => ['tcc_t', @args] => 'error_t');
eval '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) .qq{
sub $name
{
my \$r = _$name (\@_);
die FFI::TinyCC::Exception->new(\$_[0]) if \$r == -1;
\$_[0];
}
};
die $@ if $@;
}
sub new
{
my($class, %opt) = @_;
my $self = bless _new(), $class;
$self->{error_cb} = $ffi->closure(sub {
push @{ $self->{error} }, $_[1];
});
_set_error_func($self, undef, $self->{error_cb});
if($^O eq 'MSWin32')
{
require File::Basename;
require File::Spec;
my $path = File::Spec->catdir(File::Basename::dirname($ffi->lib), 'lib');
$self->add_library_path($path);
}
$self->{no_free_store} = 1 if $opt{_no_free_store};
$self;
}
sub _error
{
my($self, $msg) = @_;
push @{ $self->{error} }, $msg;
$self;
}
if(defined ${^GLOBAL_PHASE})
{
*DESTROY = sub
{
my($self) = @_;
return if ${^GLOBAL_PHASE} eq 'DESTRUCT';
_delete($self);
# TODO: should we do this?
free($self->{store});
}
}
else
{
require Devel::GlobalDestruction;
*DESTROY = sub
{
my($self) = @_;
return if Devel::GlobalDestruction::in_global_destruction();
_delete($self);
# TODO: should we do this?
free($self->{store});
}
}
_method set_options => qw( string );
_method add_file => qw( string );
_method compile_string => qw( string );
sub add_symbol
{
my($self, $name, $ptr) = @_;
my $r;
$r = _add_symbol($self, $name, $ptr);
die FFI::TinyCC::Exception->new($self) if $r == -1;
$self;
}
sub detect_sysinclude_path
{
my($self) = @_;
my @path_list;
if($^O eq 'MSWin32')
{
require File::Spec;
push @path_list, File::Spec->catdir(dist_share('Alien-TinyCC'), 'include');
}
elsif($Config{incpth})
{
require Alien::TinyCC;
require File::Spec;
push @path_list, File::Spec->catdir(Alien::TinyCC->libtcc_library_path, qw( tcc include ));
push @path_list, split /\s+/, $Config{incpth};
}
elsif($Config{ccname} eq 'gcc')
{
require File::Temp;
my($fh, $filename) = File::Temp::tempfile( "tryXXXX", SUFFIX => '.c', UNLINK => 1 );
close $fh;
my @lines = `$Config{cpprun} -v $filename 2>&1`;
shift @lines while defined $lines[0] && $lines[0] !~ /^#include </;
shift @lines;
pop @lines while defined $lines[-1] && $lines[-1] !~ /^End of search /;
pop @lines;
croak "Cannot detect sysinclude path" unless @lines;
require Alien::TinyCC;
require File::Spec;
push @path_list, File::Spec->catdir(Alien::TinyCC->libtcc_library_path, qw( tcc include ));
push @path_list, map { chomp; s/^ //; $_ } @lines;
}
else
{
croak "Cannot detect sysinclude path";
}
croak "Cannot detect sysinclude path" unless grep { -d $_ } @path_list;
$self->add_sysinclude_path($_) for @path_list;
@path_list;
}
_method add_include_path => qw( string );
_method add_sysinclude_path => qw( string );
_method set_lib_path => qw( string );
$ffi->attach([tcc_define_symbol=>'define_symbol'] => ['tcc_t', 'string', 'string'] => 'void');
$ffi->attach([tcc_undefine_symbol=>'undefine_symbol'] => ['tcc_t', 'string', 'string'] => 'void');
_method set_output_type => qw( output_t );
_method add_library => qw( string );
_method add_library_path => qw( string );
sub run
{
my($self, @args) = @_;
croak "unable to use run method after get_symbol" if $self->{relocate};
my $argc = scalar @args;
my @c_strings = map { "$_\0" } @args;
my $ptrs = pack 'P' x $argc, @c_strings;
my $argv = unpack('L!', pack('P', $ptrs));
my $r = _run($self, $argc, $argv);
die FFI::TinyCC::Exception->new($self) if $r == -1;
$r;
}
sub get_symbol
{
my($self, $symbol_name) = @_;
unless($self->{relocate})
{
my $size = _relocate($self, undef);
$self->{store} = malloc($size);
my $r = _relocate($self, $self->{store});
die FFI::TinyCC::Exception->new($self) if $r == -1;
$self->{relocate} = 1;
}
_get_symbol($self, $symbol_name);
}
_method output_file => qw( string );
package
FFI::TinyCC::Exception;
use overload '""' => sub {
my $self = shift;
if(@{ $self->{fault} } == 2)
{
join(' ', $self->as_string,
at => $self->{fault}->[0],
line => $self->{fault}->[1],
);
}
else
{
$self->as_string . "\n";
}
};
use overload fallback => 1;
sub new
{
my($class, $tcc) = @_;
my @errors = @{ $tcc->{error} };
$tcc->{errors} = [];
my @stack;
my @fault;
my $i=2;
while(my @frame = caller($i++))
{
push @stack, \@frame;
if(@fault == 0 && $frame[0] !~ /^FFI::TinyCC/)
{
@fault = ($frame[1], $frame[2]);
}
}
my $self = bless {
errors => \@errors,
stack => \@stack,
fault => \@fault,
}, $class;
$self;
}
sub errors { shift->{errors} }
sub as_string
{
my($self) = @_;
join "\n", @{ $self->{errors} };
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
FFI::TinyCC - Tiny C Compiler for FFI
=head1 VERSION
version 0.30
=head1 SYNOPSIS
use FFI::TinyCC;
use FFI::Platypus;
my $tcc = FFI::TinyCC->new;
$tcc->compile_string(q{
int
find_square(int value)
{
return value*value;
}
});
my $address = $tcc->get_symbol('find_square');
my $ffi = FFI::Platypus->new;
$ffi->attach([$address => 'find_square'] => ['int'] => 'int');
print find_square(4), "\n"; # prints 16
For code that requires system headers:
use FFI::TinyCC;
use FFI::Platypus;
my $tcc = FFI::TinyCC->new;
# this will throw an exception if the system
# include paths cannot be detected.
$tcc->detect_sysinclude_path;
$tcc->compile_string(q{
#include <stdio.h>
void print_hello()
{
puts("hello world");
}
});
my $address = $tcc->get_symbol('print_hello');
my $ffi = FFI::Platypus->new;
$ffi->attach([$address => 'print_hello'] => [] => 'void');
print_hello();
=head1 DESCRIPTION
This module provides an interface to a very small C compiler known as
TinyCC. It does almost no optimizations, so C<gcc> or C<clang> will
probably generate faster code, but it is very small and is very fast and
thus may be useful for some Just In Time (JIT) or Foreign Function
Interface (FFI) situations.
For a simpler, but less powerful interface see L<FFI::TinyCC::Inline>.
=head1 CONSTRUCTOR
=head2 new
my $tcc = FFI::TinyCC->new;
Create a new TinyCC instance.
=head1 METHODS
Methods will generally throw an exception on failure.
=head2 Compile
=head3 set_options
$tcc->set_options($options);
Set compiler and linker options, as you would on the command line, for
example:
$tcc->set_options('-I/foo/include -L/foo/lib -DFOO=22');
=head3 add_file
$tcc->add_file('foo.c');
$tcc->add_file('foo.o');
$tcc->add_file('foo.so'); # or dll on windows
Add a file, DLL, shared object or object file.
On windows adding a DLL is not supported via this interface.
=head3 compile_string
$tcc->compile_string($c_code);
Compile a string containing C source code.
=head3 add_symbol
$tcc->add_symbol($name, $callback);
$tcc->add_symbol($name, $pointer);
Add the given given symbol name / callback or pointer combination. See
example below for how to use this to call Perl from Tiny C code.
If you are using L<FFI::Platypus> you can use L<FFI::Platypus#cast>
to get a pointer to a closure:
use FFI::Platypus;
my $ffi = FFI::Platypus;
my $closure = $ffi->closure(sub { return $_[0]+1 });
my $pointer = $ffi->cast('(int)->int' => 'opaque', $closure);
$tcc->add_symbol('foo' => $pointer);
=head2 Preprocessor options
=head3 detect_sysinclude_path
[version 0.18]
$tcc->detect_sysinclude_path;
Attempt to find and configure the appropriate system include directories. If
the platform that you are on does not (yet?) support this functionality
then this method will throw an exception.
[version 0.19]
Returns the list of directories added to the system include directories.
=head3 add_include_path
$tcc->add_include_path($path);
Add the given path to the list of paths used to search for include files.
=head3 add_sysinclude_path
$tcc->add_sysinclude_path($path);
Add the given path to the list of paths used to search for system
include files.
=head3 set_lib_path
$tcc->set_lib_path($path);
Set the lib path
=head3 define_symbol
$tcc->define_symbol($name => $value);
$tcc->define_symbol($name);
Define the given symbol, optionally with the specified value.
=head3 undefine_symbol
$tcc->undefine_symbol($name);
Undefine the given symbol.
=head2 Link / run
=head3 set_output_type
$tcc->set_output_type('memory');
$tcc->set_output_type('exe');
$tcc->set_output_type('dll');
$tcc->set_output_type('obj');
Set the output type. This must be called before any compilation.
Output formats may not be supported on your platform. C<exe> is
NOT supported on *BSD or OS X. It may NOT be supported on Linux.
As a basic baseline at least C<memory> should be supported.
=head3 add_library
$tcc->add_library($libname);
Add the given library when linking. Example:
$tcc->add_library('m'); # equivalent to -lm (math library)
=head3 add_library_path
$tcc->add_library_path($pathname);
Add the given directory to the search path used to find libraries.
=head3 run
my $exit_value = $tcc->run(@arguments);
=head3 get_symbol
my $pointer = $tcc->get_symbol($symbol_name);
Return symbol address or undef if not found. This can be passed into
the L<FFI::Platypus#function> method, L<FFI::Platypus#attach> method,
or similar interface that takes a pointer to a C function.
=head3 output_file
$tcc->output_file($filename);
Output the generated code (either executable, object or DLL) to the
given filename. The type of output is specified by the
L<set_output_type|/set_output_type> method.
=head1 EXAMPLES
=head2 Calling Tiny C code from Perl
use FFI::TinyCC;
my $tcc = FFI::TinyCC->new;
$tcc->compile_string(<<EOF);
int
main(int argc, char *argv[])
{
puts("hello world");
}
EOF
my $r = $tcc->run;
exit $r;
=head2 Calling Perl from Tiny C code
use FFI::TinyCC;
use FFI::Platypus;
my $ffi = FFI::Platypus->new;
my $say = $ffi->closure(sub { print $_[0], "\n" });
my $ptr = $ffi->cast('(string)->void' => 'opaque' => $say);
my $tcc = FFI::TinyCC->new;
$tcc->add_symbol(say => $ptr);
$tcc->compile_string(<<EOF);
extern void say(const char *);
int
main(int argc, char *argv[])
{
int i;
for(i=0; i<argc; i++)
{
say(argv[i]);
}
}
EOF
my $r = $tcc->run($0, @ARGV);
exit $r;
=head2 Attaching as a FFI::Platypus function from a Tiny C function
use FFI::TinyCC;
use FFI::Platypus;
my $tcc = FFI::TinyCC->new;
$tcc->compile_string(q{
int
calculate_square(int value)
{
return value*value;
}
});
my $value = shift @ARGV;
$value = 4 unless defined $value;
my $address = $tcc->get_symbol('calculate_square');
my $ffi = FFI::Platypus->new;
$ffi->attach([$address => 'square'] => ['int'] => 'int');
print square($value), "\n";
=head1 CAVEATS
Tiny C is only supported on platforms with ARM or Intel processors. All
features may not be fully supported on all operating systems.
Tiny C is no longer supported by its original author, though various
forks seem to have varying levels of support. We use the fork that comes
with L<Alien::TinyCC>.
=head1 SEE ALSO
=over 4
=item L<FFI::TinyCC::Inline>
=item L<Tiny C|http://bellard.org/tcc/>
=item L<Tiny C Compiler Reference Documentation|http://bellard.org/tcc/tcc-doc.html>
=item L<FFI::Platypus>
=item L<C::Blocks>
=item L<Alien::TinyCC>
=item L<C::TinyCompiler>
=back
=head1 BUNDLED SOFTWARE
This package also comes with a parser that was shamelessly stolen from
L<XS::TCC>, which I strongly suspect was itself shamelessly "borrowed"
from L<Inline::C::Parser::RegExp>
The license details for the parser are:
Copyright 2002 Brian Ingerson
Copyright 2008, 2010-2012 Sisyphus
Copyright 2013 Steffen Muellero
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=head1 AUTHOR
Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>
Contributors:
aero
Dylan Cali (calid)
pipcet
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2015 by Graham Ollis.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut