1package Inline::ASM; 2 3use strict; 4require Inline::C; 5use Config; 6use Data::Dumper; 7use FindBin; 8use Carp; 9use Cwd qw(cwd abs_path); 10 11$Inline::ASM::VERSION = '0.03'; 12@Inline::ASM::ISA = qw(Inline::C); 13 14#============================================================================== 15# Register this module as an Inline language support module 16#============================================================================== 17sub register { 18 my $suffix = ($^O eq 'aix') ? 'so' : $Config{so}; 19 return { 20 language => 'ASM', 21 aliases => ['nasm', 'NASM', 'gasp', 'GASP', 'as', 'AS', 'asm'], 22 type => 'compiled', 23 suffix => $suffix, 24 }; 25} 26 27#============================================================================== 28# Validate the Assembler config options 29#============================================================================== 30sub validate { 31 my $o = shift; 32 33 $o->{ILSM} = {}; 34 $o->{ILSM}{XS} = {}; 35 $o->{ILSM}{MAKEFILE} = {}; 36 37 # These are written at configuration time 38 $o->{ILSM}{AS} ||= '@ASSEMBLER'; # default assembler 39 $o->{ILSM}{ASFLAGS} ||= '@ASFLAGS'; # default asm flags 40 $o->{ILSM}{MAKEFILE}{CC} ||= '@COMPILER'; # default compiler 41 42 $o->{ILSM}{AUTO_INCLUDE} ||= <<END; 43#include "EXTERN.h" 44#include "perl.h" 45#include "XSUB.h" 46END 47 48 my @propagate; 49 while (@_) { 50 my ($key, $value) = (shift, shift); 51 if ($key eq 'AUTOWRAP') { 52 croak "'$key' is not a valid config option for Inline::ASM\n"; 53 } 54 if ($key eq 'AS' or 55 $key eq 'ASFLAGS') { 56 $o->{ILSM}{$key} = $value; 57 next; 58 } 59 if ($key eq 'PROTOTYPES' or 60 $key eq 'PROTO') { 61 croak "Invalid value for '$key' option" 62 unless ref $value eq 'HASH'; 63 $o->{ILSM}{PROTOTYPES} = $value; 64 next; 65 } 66 push @propagate, $key, $value; 67 } 68 69 $o->SUPER::validate(@propagate) if @propagate; 70} 71 72#============================================================================== 73# Parse and compile code 74#============================================================================== 75sub build { 76 my $o = shift; 77 $o->parse; 78 $o->write_XS; 79 $o->write_ASM; 80 $o->write_Makefile_PL; 81 $o->compile; 82} 83 84#============================================================================== 85# Return a small report about the ASM code. 86#============================================================================== 87sub info { 88 my $o = shift; 89 my $text = ''; 90 91 $o->parse unless $o->{parser}; 92 93 my $sym; 94 if (defined $o->{parser}) { 95 my $num_bound = scalar keys %{$o->{parser}{bound}}; 96 my $num_unbound = scalar keys %{$o->{parser}{unbound}}; 97 my $num_missing = scalar keys %{$o->{parser}{missing}}; 98 if ($num_bound) { 99 $text .= "The following ASM symbols have been bound to Perl:\n"; 100 for $sym (keys %{$o->{parser}{bound}}) { 101 my ($rtype, $args) = $o->{ILSM}{PROTOTYPES}{$sym} 102 =~ m!([^\(]+)(\([^\)]*\))!g; 103 $text .= "\t$rtype $sym $args\n"; 104 } 105 } 106 if ($num_unbound) { 107 $text .= "The following unprototyped symbols were ignored:\n"; 108 for $sym (keys %{$o->{parser}{unbound}}) { $text .= "\t$sym\n"; } 109 } 110 if ($num_missing) { 111 $text .= "The following prototyped symbols were missing:\n"; 112 for $sym (keys %{$o->{parser}{missing}}) { $text .= "\t$sym\n"; } 113 } 114 } 115 else { 116 $text .= "No ASM functions have been successfully bound to Perl.\n\n"; 117 } 118 return $text; 119} 120 121#============================================================================== 122# Parse the function definition information out of the ASM code 123#============================================================================== 124sub parse { 125 my $o = shift; 126 return if $o->{parser}; 127 $o->get_maps; 128 $o->get_types; 129 130 my $globals = $o->global_keys; 131 132 # Extract the GLOBAL and COMMON symbols: 133 $o->{ILSM}{code} = $o->filter(@{$o->{ILSM}{FILTERS}}); 134 my @symbols = ($o->{ILSM}{code} =~ m!^\s*(?:$globals)\s+(\w+)!mig); 135 136 my %bound; 137 my %unbound; 138 my %missing; 139 my $sym; 140 141 for $sym (@symbols) { 142 $bound{$sym}++ if $o->{ILSM}{PROTOTYPES}{$sym}; 143 $unbound{$sym}++ unless $o->{ILSM}{PROTOTYPES}{$sym}; 144 } 145 for $sym (keys %{$o->{ILSM}{PROTOTYPES}}) { 146 $missing{$sym}++ unless $bound{$sym}; 147 } 148 149 $o->{parser} = {bound => \%bound, 150 unbound => \%unbound, 151 missing => \%missing, 152 }; 153} 154 155#============================================================================== 156# Write the ASM code 157#============================================================================== 158sub write_ASM { 159 my $o = shift; 160 open ASM, "> $o->{API}{build_dir}/$o->{API}{modfname}_asm.asm" 161 or croak "Inline::ASM::write_ASM: $!"; 162 print ASM $o->{ILSM}{code}; 163 close ASM; 164} 165 166#============================================================================== 167# Generate the XS glue code 168#============================================================================== 169sub write_XS { 170 my $o = shift; 171 my ($pkg, $module, $modfname) = @{$o->{API}}{qw(pkg module modfname)}; 172 my $prefix = (($o->{ILSM}{XS}{PREFIX}) ? 173 "PREFIX = $o->{ILSM}{XS}{PREFIX}" : 174 ''); 175 176 $o->mkpath($o->{API}{build_dir}); 177 open XS, "> $o->{API}{build_dir}/$modfname.xs" 178 or croak "Inline::ASM::write_XS: $!"; 179 180 print XS <<END; 181$o->{ILSM}{AUTO_INCLUDE} 182END 183 184 for my $sym (keys %{$o->{parser}{bound}}) { 185 my ($rtype, $args) = $o->{ILSM}{PROTOTYPES}{$sym} 186 =~ m!([^\(]+)(\([^\)]*\))!g; 187 print XS "extern $rtype $sym $args;\n"; 188 } 189 190 print XS <<END; 191 192MODULE = $module PACKAGE = $pkg $prefix 193 194PROTOTYPES: DISABLE 195END 196 197 warn("Warning. No Inline ASM functions bound to Perl\n" . 198 "Check your PROTO option(s) for Inline compatibility\n\n") 199 if ((not scalar keys %{$o->{parser}{bound}}) and ($^W)); 200 201 my $parm = "neil"; 202 for my $function (keys %{$o->{parser}{bound}}) { 203 my ($rtype, $args) = $o->{ILSM}{PROTOTYPES}{$function} 204 =~ m!([^\(]+)(\([^\)]*\))!g; 205 206 $args =~ s/\(([^\)]*)\)/$1/; 207 my @arg_types = split/\s*,\s*/, $args; 208 my @arg_names = map { $parm++ } @arg_types; 209 210 print XS ("\n$rtype\n$function (", 211 join(', ', @arg_names), ")\n"); 212 213 for my $arg_name (@arg_names) { 214 my $arg_type = shift @arg_types; 215 last if $arg_type eq '...'; 216 print XS "\t$arg_type\t$arg_name\n"; 217 } 218 219 my $listargs = ''; 220 my $arg_name_list = join(', ', @arg_names); 221 222 if ($rtype eq 'void') { 223 print XS <<END; 224 PREINIT: 225 I32* temp; 226 PPCODE: 227 temp = PL_markstack_ptr++; 228 $function($arg_name_list); 229 if (PL_markstack_ptr != temp) { 230 /* truly void, because dXSARGS not invoked */ 231 PL_markstack_ptr = temp; 232 XSRETURN_EMPTY; /* return empty stack */ 233 } 234 /* must have used dXSARGS; list context implied */ 235 return; /* assume stack size is correct */ 236END 237 } 238 } 239 print XS "\n"; 240 241 if (defined $o->{ILSM}{XS}{BOOT} and 242 $o->{ILSM}{XS}{BOOT}) { 243 print XS <<END; 244BOOT: 245$o->{ILSM}{XS}{BOOT} 246END 247 } 248 249 close XS; 250} 251 252#============================================================================== 253# Generate the Makefile.PL 254#============================================================================== 255sub write_Makefile_PL { 256 my $o = shift; 257 258 $o->{ILSM}{xsubppargs} = ''; 259 for (@{$o->{ILSM}{MAKEFILE}{TYPEMAPS}}) { 260 $o->{ILSM}{xsubppargs} .= "-typemap $_ "; 261 } 262 263 my %options = ( 264 VERSION => '0.00', 265 %{$o->{ILSM}{MAKEFILE}}, 266 NAME => $o->{API}{module}, 267 OBJECT => qq{\$(BASEEXT)\$(OBJ_EXT) $o->{API}{modfname}_asm\$(OBJ_EXT)}, 268 ); 269 270 open MF, "> $o->{API}{build_dir}/Makefile.PL" 271 or croak "Inline::ASM::write_Makefile_PL: $!\n"; 272 273 print MF <<END; 274use ExtUtils::MakeMaker; 275my %options = %\{ 276END 277 278 local $Data::Dumper::Terse = 1; 279 local $Data::Dumper::Indent = 1; 280 print MF Data::Dumper::Dumper(\ %options); 281 282 my $asmcmd; 283 # This neato little hack notices that GASP is being used, and substitutes 284 # 'gasp' for 'gasp <filename.asm> | as -o <filename.o>' 285 if ($o->{ILSM}{AS} =~ /^\s*gasp/) { 286 $asmcmd = $o->{ILSM}{AS}; 287 $asmcmd =~ s|gasp|gasp $o->{API}{modfname}_asm.asm|; 288 $asmcmd .= "| as $o->{ILSM}{ASFLAGS} -o $o->{API}{modfname}_asm\$(OBJ_EXT)"; 289 } 290 else { 291 $asmcmd = "$o->{ILSM}{AS} $o->{ILSM}{ASFLAGS} $o->{API}{modfname}_asm.asm "; 292 $asmcmd .= "-o $o->{API}{modfname}_asm\$(OBJ_EXT)"; 293 } 294 295 print MF <<END; 296\}; 297WriteMakefile(\%options); 298 299sub MY::postamble { 300 <<'FOO'; 301$o->{API}{modfname}_asm\$(OBJ_EXT) : $o->{API}{modfname}_asm.asm 302 $asmcmd 303FOO 304} 305 306END 307 close MF; 308} 309 310#============================================================================== 311# Returns a string which, when used in a regex, can extract global symbols. 312# Depends on assembler being used. 313#============================================================================== 314sub global_keys { 315 my $o = shift; 316 my $asm = $o->{ILSM}{AS}; 317 if ($asm =~ /nasm/i) { 318 return 'GLOBAL|COMMON'; 319 } 320 elsif ($asm =~ /gasp/i) { 321 return '\.GLOBAL'; 322 } 323 elsif ($asm =~ /as/i) { 324 return '\.(?:globl|common)'; 325 } 326} 327 3281; 329 330__END__ 331