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