simon 01/08/29 05:07:06
Modified: . README
Added: . Makefile assemble.pl basic_opcodes.c bytecode.c
bytecode.h config.h disassemble.pl events.h
exceptions.h global_setup.c interpreter.c
interpreter.h io.h make_op_header.pl
make_op_table_build.pl memory.c memory.h op.h
opcode_table parrot.c parrot.h register.c
register.h stacks.h string.c string.h strnative.c
strnative.h test.pasm test.pbc test_main.c
test_opcodes.c
Log:
Initial checkin of Simon's work directory - Dan, feel free to nuke.
I'm still working on the string stuff, though.
Revision Changes Path
1.3 +3 -8 parrot/README
Index: README
===================================================================
RCS file: /home/perlcvs/parrot/README,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -w -r1.2 -r1.3
--- README 2001/08/29 11:44:39 1.2
+++ README 2001/08/29 12:07:01 1.3
@@ -1,9 +1,4 @@
-
-
-For access to the Parrot CVS module, see http://dev.perl.org/cvs/
-
-Simon or Dan, please change this file. I just put it here so you can
-see that something happened. :-)
-
-Be sure to send mail to [EMAIL PROTECTED]
+This is not yet ready for public consumption; this is just
+my working copy of Parrot so that there's *something* here.
+(And to test that we can check stuff in, as well.)
1.1 parrot/Makefile
Index: Makefile
===================================================================
H_FILES = config.h exceptions.h io.h op.h register.h string.h events.h interpreter.h
memory.h parrot.h stacks.h bytecode.h
O_FILES = global_setup.o interpreter.o parrot.o register.o basic_opcodes.o memory.o
bytecode.o string.o strnative.o
C_FLAGS = -Wall
CC = gcc $(C_FLAGS)
all : $(O_FILES)
test_prog: test_main.o $(O_FILES)
gcc -o test_prog $(O_FILES) test_main.o
driver.o: $(H_FILES)
global_setup.o: $(H_FILES)
string.o: $(H_FILES)
strnative.o: $(H_FILES)
interpreter.o: $(H_FILES)
memory.o: $(H_FILES)
bytecode.o: $(H_FILES)
parrot.o: $(H_FILES)
register.o: $(H_FILES)
basic_opcodes.o: $(H_FILES)
1.1 parrot/assemble.pl
Index: assemble.pl
===================================================================
#! /usr/bin/perl -w
#
# assemble.pl - take a parrot assembly file and spit out a bytecode file
my %opcodes;
my %pack_type;
%pack_type = (i => 'l',
n => 'd',
);
open OPCODES, "<opcode_table" or die "Can't get opcode table, $!/$^E";
while (<OPCODES>) {
next if /^\s*#/;
chomp;
my ($code, $name, $args, @types) = split /\s+/, $_;
$opcodes{$name} = {CODE => $code,
ARGS => $args,
TYPES => [@types]
};
}
my $pc = 0;
my @code;
my %constants;
my @constants;
# First scan for labels and strings
while (<>) {
s/^\s*//;
if (s/^\s*([a-zA-Z_]\w+):\s*//) { $labels{$1} = $pc; }
1 while s/\"([^\\\"]*(?:\\.[^\\\"]*)*)\"/constantize($1)/eg;
my ($opcode, @args) = split /\s+/, $_;
push @code, $_;
$pc += 1+@args;
}
emit_magic();
emit_fixup_section();
emit_constants_section();
# Now assemble
$pc = 0;
while ($_ = shift @code) {
chomp;
s/,/ /g;
my ($opcode, @args) = split /\s+/, $_;
if (!exists $opcodes{lc $opcode}) {
die "No opcode $opcode";
}
if (@args != $opcodes{$opcode}{ARGS}) {
die "wrong arg count--got ". scalar @args. " needed " .
$opcodes{$opcode}{ARGS};
}
$args[0] = fixup($args[0])
if $opcode eq "branch_ic" and $args[0] =~ /[a-zA-Z]/;
if ($opcode eq "eq_i_ic") {
$args[2] = fixup($args[2]) if $args[2] =~ /[a-zA-Z]/;
$args[3] = fixup($args[3]) if $args[3] =~ /[a-zA-Z]/;
}
if ($opcode eq "if_i_ic") {
$args[1] = fixup($args[1]) if $args[1] =~ /[a-zA-Z]/;
$args[2] = fixup($args[2]) if $args[2] =~ /[a-zA-Z]/;
}
print pack "l", $opcodes{$opcode}{CODE};
foreach (0..$#args) {
$args[$_] =~ s/^[INPS]?(\d+)$/$1/i;
$type = $pack_type{$opcodes{$opcode}{TYPES}[$_]};
print pack $type, $args[$_];
}
$pc += 1+@args;
}
sub fixup {
my $l = shift;
die "Unknown label $l" unless exists $labels{$l};
return $labels{$l} - $pc;
}
sub constantize {
my $s = shift;
return $constants{$s} if exists $constants{$s};
push @constants, $s;
return $constants{$s} = $#constants;
}
my $sizeof_packi = length(pack($pack_type{i},1024));
sub emit_magic { print pack($pack_type{i}, 0x13155a1) }
# Dummy for now.
sub emit_fixup_section { print pack($pack_type{i}, 0) }
sub emit_constants_section {
# First, compute how big it's going to be.
# The fields we'll need to fill in are: strlen, flags, encoding, type
my $size =0 ;
$size += length($_)+4*$sizeof_packi for @constants;
print pack($pack_type{i}, $size);
# Now emit each constant
for (@constants) {
print pack($pack_type{i},0) x 3; # Flags, encoding, type
print pack($pack_type{i},length($_)); # Strlen followed by that many bytes.
print $_;
}
}
1.1 parrot/basic_opcodes.c
Index: basic_opcodes.c
===================================================================
/* basic_opcodes.c
*
* Just some basic opcodes
*
*/
#include "parrot.h"
// SET Ix, CONSTANT
IV *set_i_ic(IV cur_opcode[], struct Perl_Interp *interpreter) {
INT_REG(cur_opcode[1]) = cur_opcode[2];
return cur_opcode + 3;
}
// ADD Ix, Iy, Iz
IV *add_i(IV cur_opcode[], struct Perl_Interp *interpreter) {
INT_REG(cur_opcode[1]) = INT_REG(cur_opcode[2]) +
INT_REG(cur_opcode[3]);
return cur_opcode + 4;
}
// SUB Ix, Iy, Iz
IV *sub_i(IV cur_opcode[], struct Perl_Interp *interpreter) {
INT_REG(cur_opcode[1]) = INT_REG(cur_opcode[2]) -
INT_REG(cur_opcode[3]);
return cur_opcode + 4;
}
// MUL Ix, Iy, Iz
IV *mul_i(IV cur_opcode[], struct Perl_Interp *interpreter) {
INT_REG(cur_opcode[1]) = INT_REG(cur_opcode[2]) *
INT_REG(cur_opcode[3]);
return cur_opcode + 4;
}
// DIV Ix, Iy, Iz
IV *div_i(IV cur_opcode[], struct Perl_Interp *interpreter) {
INT_REG(cur_opcode[1]) = INT_REG(cur_opcode[2]) /
INT_REG(cur_opcode[3]);
return cur_opcode + 4;
}
// EQ Ix, Iy, EQ_BRANCH, NE_BRANCH
IV *eq_i_ic(IV cur_opcode[], struct Perl_Interp *interpreter) {
if (INT_REG(cur_opcode[1]) == INT_REG(cur_opcode[2])) {
return cur_opcode + cur_opcode[3];
} else {
return cur_opcode + cur_opcode[4];
}
}
// IF IXx, TRUE_BRANCH, FALSE_BRANCH
IV *if_i_ic(IV cur_opcode[], struct Perl_Interp *interpreter) {
if (INT_REG(cur_opcode[1])) {
return cur_opcode + cur_opcode[2];
} else {
return cur_opcode + cur_opcode[3];
}
}
// TIME Ix
IV *time_i(IV cur_opcode[], struct Perl_Interp *interpreter) {
INT_REG(cur_opcode[1]) = time(NULL);
return cur_opcode + 2;
}
// PRINT Ix
IV *print_i(IV cur_opcode[], struct Perl_Interp *interpreter) {
printf("I reg %i is %i\n", cur_opcode[1], INT_REG(cur_opcode[1]));
return(cur_opcode + 2);
}
// BRANCH CONSTANT
IV *branch_ic(IV cur_opcode[], struct Perl_Interp *interpreter) {
return cur_opcode + cur_opcode[1];
}
// END
IV *end(IV cur_opcode[], struct Perl_Interp *interpreter) {
return 0;
}
// INC Ix
IV *inc_i(IV cur_opcode[], struct Perl_Interp *interpreter) {
INT_REG(cur_opcode[1])++;
return cur_opcode + 2;
}
// INC Ix, nnn
IV *inc_i_ic(IV cur_opcode[], struct Perl_Interp *interpreter) {
INT_REG(cur_opcode[1]) += cur_opcode[2];
return cur_opcode + 3;
}
// DEC Ix
IV *dec_i(IV cur_opcode[], struct Perl_Interp *interpreter) {
INT_REG(cur_opcode[1]);
return cur_opcode + 2;
}
// DEC Ix, nnn
IV *dec_i_ic(IV cur_opcode[], struct Perl_Interp *interpreter) {
INT_REG(cur_opcode[1]) += cur_opcode[2];
return cur_opcode + 3;
}
// JUMP Ix
IV *jump_i(IV cur_opcode[], struct Perl_Interp *interpreter) {
return (IV *)INT_REG(cur_opcode[1]);
}
// SET Nx, CONSTANT
IV *set_n_nc(IV cur_opcode[], struct Perl_Interp *interpreter) {
NUM_REG(cur_opcode[1]) = *(double *)&cur_opcode[2];
return cur_opcode + 4; // Don't forget, NVs are two slots wide
}
// ADD Nx, Ny, Nz
IV *add_n(IV cur_opcode[], struct Perl_Interp *interpreter) {
NUM_REG(cur_opcode[1]) = NUM_REG(cur_opcode[2]) +
NUM_REG(cur_opcode[3]);
return cur_opcode + 4;
}
// SUB Nx, Ny, Iz
IV *sub_n(IV cur_opcode[], struct Perl_Interp *interpreter) {
NUM_REG(cur_opcode[1]) = NUM_REG(cur_opcode[2]) -
NUM_REG(cur_opcode[3]);
return cur_opcode + 4;
}
// MUL Nx, Ny, Iz
IV *mul_n(IV cur_opcode[], struct Perl_Interp *interpreter) {
NUM_REG(cur_opcode[1]) = NUM_REG(cur_opcode[2]) *
NUM_REG(cur_opcode[3]);
return cur_opcode + 4;
}
// DIV Nx, Ny, Iz
IV *div_n(IV cur_opcode[], struct Perl_Interp *interpreter) {
NUM_REG(cur_opcode[1]) = NUM_REG(cur_opcode[2]) /
NUM_REG(cur_opcode[3]);
return cur_opcode + 4;
}
// EQ Nx, Ny, EQ_BRANCH, NE_BRANCH
IV *eq_n_ic(IV cur_opcode[], struct Perl_Interp *interpreter) {
if (NUM_REG(cur_opcode[1]) == NUM_REG(cur_opcode[2])) {
return cur_opcode + cur_opcode[3];
} else {
return cur_opcode + cur_opcode[4];
}
}
// IF Nx, TRUE_BRANCH, FALSE_BRANCH
IV *if_n_ic(IV cur_opcode[], struct Perl_Interp *interpreter) {
if (NUM_REG(cur_opcode[1])) {
return cur_opcode + cur_opcode[2];
} else {
return cur_opcode + cur_opcode[3];
}
}
// TIME Nx
IV *time_n(IV cur_opcode[], struct Perl_Interp *interpreter) {
NUM_REG(cur_opcode[1]) = time(NULL);
return cur_opcode + 2;
}
// PRINT Nx
IV *print_n(IV cur_opcode[], struct Perl_Interp *interpreter) {
printf("N reg %i is %Lf\n", cur_opcode[1], NUM_REG(cur_opcode[1]));
return(cur_opcode + 2);
}
// INC Nx
IV *inc_n(IV cur_opcode[], struct Perl_Interp *interpreter) {
NUM_REG(cur_opcode[1]) += 1;
return cur_opcode + 2;
}
// INC Nx, nnn
IV *inc_n_nc(IV cur_opcode[], struct Perl_Interp *interpreter) {
(NV)NUM_REG(cur_opcode[1]) += *(double *)&cur_opcode[2];
return cur_opcode + 4;
}
// DEC Nx
IV *dec_n(IV cur_opcode[], struct Perl_Interp *interpreter) {
NUM_REG(cur_opcode[1]);
return cur_opcode + 2;
}
// DEC Nx, nnn
IV *dec_n_nc(IV cur_opcode[], struct Perl_Interp *interpreter) {
NUM_REG(cur_opcode[1]) += *(double *)&cur_opcode[2];
return cur_opcode + 4;
}
// ITON Nx, Iy
IV *iton_n_i(IV cur_opcode[], struct Perl_Interp *interpreter) {
IV number;
number = INT_REG(cur_opcode[2]);
NUM_REG(cur_opcode[1]) = (NV)number;
return cur_opcode + 3;
}
// NTOI Ix, Ny
IV *ntoi_i_n(IV cur_opcode[], struct Perl_Interp *interpreter) {
NV number;
number = NUM_REG(cur_opcode[2]);
INT_REG(cur_opcode[1]) = number;
return cur_opcode + 3;
}
1.1 parrot/bytecode.c
Index: bytecode.c
===================================================================
#include "parrot.h"
#define GRAB_IV(x) *((IV*)*x)++
static int
check_magic(void** program_code) {
return (GRAB_IV(program_code) == PARROT_MAGIC);
}
static void
read_constants_table(void** program_code)
{
IV len = GRAB_IV(program_code);
/* For now, just skip over it */
((IV*)*program_code) += len;
}
static void
read_fixup_table(void** program_code)
{
IV len = GRAB_IV(program_code);
/* For now, just skip over it */
((IV*)*program_code) += len;
}
void *
init_bytecode(void* program_code)
{
if (!check_magic(&program_code)) {
printf("This isn't Parrot bytecode!\n");
exit(1);
}
read_constants_table(&program_code);
read_fixup_table(&program_code);
return program_code;
}
1.1 parrot/bytecode.h
Index: bytecode.h
===================================================================
/* bytecode.h
*
* Bytecode functions header
*
*/
#if !defined(PARROT_BYTECODE_H_GUARD)
#define PARROT_BYTECODE_H_GUARD
void* init_bytecode(void* program_code);
#endif
1.1 parrot/config.h
Index: config.h
===================================================================
/* config.h
*
* Platform-specific config file
*
*/
#if !defined(PARROT_CONFIG_H_GUARD)
#define PARROT_CONFIG_H_GUARD
typedef long IV;
typedef long double NV;
typedef void VTABLE;
typedef void DPOINTER;
typedef void SYNC;
//typedef IV *(*opcode_funcs)(void *, void *) OPFUNC;
#define FRAMES_PER_CHUNK 16
#define FRAMES_PER_PMC_REG_CHUNK FRAMES_PER_CHUNK
#define FRAMES_PER_NUM_REG_CHUNK FRAMES_PER_CHUNK
#define FRAMES_PER_INT_REG_CHUNK FRAMES_PER_CHUNK
#define FRAMES_PER_STR_REG_CHUNK FRAMES_PER_CHUNK
#define MASK_CHUNK_LOW_BITS 0xfffff000
#endif
1.1 parrot/disassemble.pl
Index: disassemble.pl
===================================================================
#! perl -w
#
# Disassemble.pl
#
# Turn a parrot bytecode file into text
my %opcodes;
my %unpack_type;
%unpack_type = (i => 'l',
n => 'd',
);
my %unpack_size = (i => 4,
n => 8,
);
open OPCODES, "<opcode_table" or die "Can't get opcode table, $!/$^E";
while (<OPCODES>) {
next if /^\s*#/;
chomp;
my ($code, $name, $args, @types) = split /\s+/, $_;
$opcodes{$name} = {CODE => $code,
ARGS => $args,
TYPES => [@types]
};
$opcodes[$code] = {NAME => $name,
ARGS => $args,
TYPES => [@types]
}
}
$/ = \4;
while (<>) {
$code = unpack 'l', $_;
$args = $opcodes[$code]{ARGS};
print $opcodes[$code]{NAME};
if ($args) {
foreach (1..$args) {
local $/ = \$unpack_size{$opcodes[$code]{TYPES}[$_-1]};
$data = <>;
print " ", unpack $unpack_type{$opcodes[$code]{TYPES}[$_-1]}, $data;
}
}
print "\n";
}
1.1 parrot/events.h
Index: events.h
===================================================================
/* Events.h
*
* Event header
*
*/
#if !defined(PARROT_EVENT_H_GUARD)
#define PARROT_EVENT_H_GUARD
#define EXECUTE_OPCODE(x) interpreter->opcode_funcs[*(IV *)x]->(code, interpreter)
#define CHECK_EVENTS(x)
#endif
1.1 parrot/exceptions.h
Index: exceptions.h
===================================================================
/* exceptions.h
*
* define the internal interpreter exceptions
*
*/
#if !defined(PARROT_EXCEPTIONS_H_GUARD)
#define PARROT_EXCEPTIONS_H_GUARD
#define INTERNAL_EXCEPTION(x,y) {fprintf(stderr, y); exit(x);}
#define NO_REG_FRAMES 1
#endif
1.1 parrot/global_setup.c
Index: global_setup.c
===================================================================
/* Global_setup.c
*
* Performs all the global setting up of things. This includes the
* (very few) global variables that Parrot totes around
*
*/
#define INSIDE_GLOBAL_SETUP
#include "parrot.h"
void init_world() {
}
1.1 parrot/interpreter.c
Index: interpreter.c
===================================================================
/* Interpreter.c
*
* Main interpreter code
*
*/
#include "parrot.h"
void runops (struct Perl_Interp *interpreter, IV *code) {
while (code) {
IV *(*func)();
void **foo;
foo = (void *)interpreter->opcode_funcs;
(void *)func = foo[*code];
// printf("code %i\n", *code);
code = func(code, interpreter)
CHECK_EVENTS(interpreter);
}
}
struct Perl_Interp *make_interpreter() {
struct Perl_Interp *interpreter;
/* Get an empty interpreter from system memory */
interpreter = Sys_Allocate(sizeof(struct Perl_Interp));
/* Set up the memory allocation system */
Setup_Allocator(interpreter);
/* Set up the initial register chunks */
interpreter->int_reg_base = Allocate_Aligned(sizeof(struct IRegChunk));
interpreter->num_reg_base = Allocate_Aligned(sizeof(struct NRegChunk));
interpreter->string_reg_base = Allocate_Aligned(sizeof(struct SRegChunk));
interpreter->pmc_reg_base = Allocate_Aligned(sizeof(struct PRegChunk));
/* Set up the initial register frame pointers */
interpreter->int_reg = &interpreter->int_reg_base->IReg[0];
interpreter->num_reg = &interpreter->num_reg_base->NReg[0];
interpreter->string_reg = &interpreter->string_reg_base->SReg[0];
interpreter->pmc_reg = &interpreter->pmc_reg_base->PReg[0];
/* Initialize the integer register chunk */
interpreter->int_reg_base->used = 1;
interpreter->int_reg_base->free = FRAMES_PER_INT_REG_CHUNK - 1;
interpreter->int_reg_base->next = NULL;
interpreter->int_reg_base->prev = NULL;
/* Initialize the initial numeric register chunk */
interpreter->num_reg_base->used = 1;
interpreter->num_reg_base->free = FRAMES_PER_NUM_REG_CHUNK - 1;
interpreter->num_reg_base->next = NULL;
interpreter->num_reg_base->prev = NULL;
/* Initialize the inital string register chunk */
interpreter->string_reg_base->used = 1;
interpreter->string_reg_base->free = FRAMES_PER_STR_REG_CHUNK - 1;
interpreter->string_reg_base->next = NULL;
interpreter->string_reg_base->prev = NULL;
/* Initialize the initial PMC register chunk. Gotta NULL them out,
too, otherwise we might GC Wrong Things later */
interpreter->pmc_reg_base->used = 1;
interpreter->pmc_reg_base->free = FRAMES_PER_PMC_REG_CHUNK - 1;
interpreter->pmc_reg_base->next = NULL;
interpreter->pmc_reg_base->prev = NULL;
clear_p(interpreter);
/* Need a default stack */
interpreter->stack_base = Allocate_New_Stack();
/* Need an empty stash */
interpreter->perl_stash = Allocate_New_Stash();
/* The default opcode function table would be a good thing here... */
{
void **foo;
foo = Sys_Allocate(2048 * sizeof(void *));
foo[0] = set_i_ic;
foo[1] = add_i;
foo[7] = sub_i;
foo[8] = mul_i;
foo[9] = div_i;
foo[2] = eq_i_ic;
foo[3] = time_i;
foo[4] = print_i;
foo[5] = branch_ic;
foo[6] = end;
foo[10] = if_i_ic;
foo[11] = inc_i;
foo[12] = inc_i_ic;
foo[13] = dec_i;
foo[14] = dec_i_ic;
foo[15] = jump_i;
foo[16] = set_n_nc;
foo[17] = add_n;
foo[18] = sub_n;
foo[19] = mul_n;
foo[20] = div_n;
foo[21] = eq_n_ic;
foo[22] = time_n;
foo[23] = print_n;
foo[24] = if_n_ic;
foo[25] = inc_n;
foo[26] = inc_n_nc;
foo[27] = dec_n;
foo[28] = dec_n_nc;
foo[29] = iton_n_i;
foo[30] = ntoi_i_n;
(void *)interpreter->opcode_funcs = foo;
}
/* In case the I/O system needs something */
Init_IO(interpreter);
/* Done. Return and be done with it */
return interpreter;
}
1.1 parrot/interpreter.h
Index: interpreter.h
===================================================================
/* interpreter.h
*
* "Insert apropos quote here"
*
* This include file defines the structures used by the interpreter
*
*/
#if !defined(PARROT_INTERPRETER_H_GUARD)
#define PARROT_INTERPRETER_H_GUARD
#include "parrot.h"
struct Perl_Interp {
struct IReg *int_reg; // Current top of int reg stack
struct NReg *num_reg; // Current top of the float reg stack
struct SReg *string_reg; // Current top of the string stack
struct PReg *pmc_reg; // Current top of the PMC stack
struct Stack *stack_top; // Current top of the generic stack
struct IRegChunk *int_reg_base; // base of the int reg stack
struct NRegChunk *num_reg_base; // Base of the float reg stack
struct SRegChunk *string_reg_base; // Base of the string stack
struct PRegChunk *pmc_reg_base; // Base of the PMC stack
struct StackFrame *stack_base; // Base of the generic stack
struct Stash *perl_stash; // Pointer to the global
// variable area
struct Arenas *arena_base; // Pointer to this
// interpreter's arena
IV *(*(*opcode_funcs)[2048])(); // Opcode
// function table
};
struct Perl_Interp *make_interpreter();
#endif
1.1 parrot/io.h
Index: io.h
===================================================================
/* io.h
*
* I/O operations header
*
*/
#if !defined(PARROT_IO_H_GUARD)
#define PARROT_IO_H_GUARD
#define Init_IO(x)
#endif
1.1 parrot/make_op_header.pl
Index: make_op_header.pl
===================================================================
#! perl -w
#
# rip through opcode_table and spit out a chunk of C header for the
# functions in it
while (<>) {
next if /^\s*#/;
chomp;
(undef, $name, undef) = split /\t/, $_;
print "IV *$name(IV *, struct Perl_Interp *);\n";
}
1.1 parrot/make_op_table_build.pl
Index: make_op_table_build.pl
===================================================================
#! perl -w
#
# rip through opcode_table and spit out a chunk of C header for the
# functions in it
while (<>) {
next if /^\s*#/;
chomp;
next unless $_;
($num, $name, undef) = split /\s+/, $_;
print "\tfoo[$num] = $name;\n";
}
1.1 parrot/memory.c
Index: memory.c
===================================================================
/* Memory.c
*
* Handle memory allocation
*
*/
#include "parrot.h"
/* Allocate a chunk of memory aligned on a power-of-2 boundary */
void *Allocate_Aligned(IV size) {
IV boundary;
IV max_to_alloc;
IV temp;
void *mem = NULL;
boundary = 1;
for (temp = size; temp; temp >>= 1) {
boundary *= 2;
}
max_to_alloc = boundary * 2;
mem = malloc(max_to_alloc);
return mem;
}
void *Sys_Allocate(IV size) {
return malloc(size);
}
void Setup_Allocator(struct Perl_Interp *interpreter) {
}
1.1 parrot/memory.h
Index: memory.h
===================================================================
/* Memory.h
*
* Memory functions header
*
*/
#if !defined(PARROT_MEMORY_H_GUARD)
#define PARROT_MEMORY_H_GUARD
void *Allocate_Aligned(IV);
void *Sys_Allocate(IV);
void Setup_Allocator(struct Perl_Interp *);
#define Allocate_New_Stash() NULL
#define Allocate_New_Stack() NULL
#define Sys_Memcopy memcpy
#endif
1.1 parrot/op.h
Index: op.h
===================================================================
/* op.h
*
* Opcode header
*
*/
#if !defined(PARROT_OP_H_GUARD)
#define PARROT_OP_H_GUARD
typedef IV OP;
#define DEFAULT_OPCODE_TABLE NULL
IV *set_i_ic(IV *, struct Perl_Interp *);
IV *add_i(IV *, struct Perl_Interp *);
IV *sub_i(IV *, struct Perl_Interp *);
IV *mul_i(IV *, struct Perl_Interp *);
IV *div_i(IV *, struct Perl_Interp *);
IV *eq_i_ic(IV *, struct Perl_Interp *);
IV *time_i(IV *, struct Perl_Interp *);
IV *print_i(IV *, struct Perl_Interp *);
IV *branch_ic(IV *, struct Perl_Interp *);
IV *end(IV *, struct Perl_Interp *);
IV *if_i_ic(IV *, struct Perl_Interp *);
IV *inc_i(IV *, struct Perl_Interp *);
IV *inc_i_ic(IV *, struct Perl_Interp *);
IV *dec_i(IV *, struct Perl_Interp *);
IV *dec_i_ic(IV *, struct Perl_Interp *);
IV *jump_i(IV *, struct Perl_Interp *);
IV *set_n_nc(IV *, struct Perl_Interp *);
IV *add_n(IV *, struct Perl_Interp *);
IV *sub_n(IV *, struct Perl_Interp *);
IV *mul_n(IV *, struct Perl_Interp *);
IV *div_n(IV *, struct Perl_Interp *);
IV *eq_n_ic(IV *, struct Perl_Interp *);
IV *time_n(IV *, struct Perl_Interp *);
IV *print_n(IV *, struct Perl_Interp *);
IV *if_n_ic(IV *, struct Perl_Interp *);
IV *inc_n(IV *, struct Perl_Interp *);
IV *inc_n_nc(IV *, struct Perl_Interp *);
IV *dec_n(IV *, struct Perl_Interp *);
IV *dec_n_nc(IV *, struct Perl_Interp *);
IV *iton_n_i(IV *, struct Perl_Interp *);
IV *ntoi_i_n(IV *, struct Perl_Interp *);
#endif
1.1 parrot/opcode_table
Index: opcode_table
===================================================================
# opcode function table
#
# format is:
# number name args arg_types
#
# All fields should be whitespace separated
#
# The arg_types are the types to be packed (integer, number, whatever)
# not the type of the register or anything. So N3 is still an i, since that
# 3 specifying the register should be packed as an integer.
0 set_i_ic 2 i i
1 add_i 3 i i i
7 sub_i 3 i i i
8 mul_i 3 i i i
9 div_i 3 i i i
2 eq_i_ic 4 i i i i
3 time_i 1 i
4 print_i 1 i
5 branch_ic 1 i
6 end 0
10 if_i_ic 3 i i i
11 inc_i 1 i
12 inc_i_ic 2 i i
13 dec_i 1 i
14 dec_i_ic 2 i i
15 jump_i 1 i
16 set_n_nc 2 i n
17 add_n 3 i i i
18 sub_n 3 i i i
19 mul_n 3 i i i
20 div_n 3 i i i
21 eq_n_ic 4 i i i i
22 time_n 1 i
23 print_n 1 i
24 if_n_ic 3 i i i
25 inc_n 1 i
26 inc_n_nc 2 i n
27 dec_n 1 i
28 dec_n_nc 2 i n
29 iton_n_i 2 i i
30 ntoi_i_n 2 i i
1.1 parrot/parrot.c
Index: parrot.c
===================================================================
/* Parrot.c
*
* Main driver file for Parrot
*
*/
#include "parrot.h"
1.1 parrot/parrot.h
Index: parrot.h
===================================================================
/* parrot.h
*
* General header file includes for the parrot interpreter
*
*/
#if !defined(PARROT_PARROT_H_GUARD)
#define PARROT_PARROT_H_GUARD
#if defined(INSIDE_GLOBAL_SETUP)
#define VAR_SCOPE
#else
#define VAR_SCOPE extern
#endif
#include "config.h"
#include <stdlib.h>
#include <stdio.h>
//#include <types.h>
#include <time.h>
#include <unistd.h>
#include <sys/mman.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
#include <errno.h>
#define NUM_REGISTERS 32
#define PARROT_MAGIC 0x13155a1
struct PMC {
VTABLE *vtable;
IV flags;
DPOINTER *data;
union {
IV int_val;
NV num_val;
DPOINTER *struct_val;
} cache;
SYNC *synchronize;
};
typedef struct PMC PMC;
#include "string.h"
#include "interpreter.h"
#include "register.h"
#include "exceptions.h"
#include "memory.h"
#include "bytecode.h"
#include "io.h"
#include "op.h"
#include "events.h"
#endif
1.1 parrot/register.c
Index: register.c
===================================================================
/* register.c
*
* Register handling routines
*
*/
#include "parrot.h"
void push_i(struct Perl_Interp *interpreter) {
struct IRegChunk *chunk_base;
chunk_base = CHUNK_BASE(interpreter->int_reg);
/* Do we have any slots left in the current chunk? */
if (chunk_base->free) {
interpreter->int_reg = &chunk_base->IReg[chunk_base->used++];
chunk_base->free--;
}
/* Nope, so plan B time. Allocate a new chunk of integer register frames */
else {
struct IRegChunk *new_chunk;
new_chunk = Allocate_Aligned(sizeof(struct IRegChunk));
new_chunk->used = 1;
new_chunk->free = FRAMES_PER_INT_REG_CHUNK - 1;
new_chunk->next = NULL;
new_chunk->prev = chunk_base;
chunk_base->next = new_chunk;
interpreter->int_reg = &new_chunk->IReg[0];
}
}
void pop_i(struct Perl_Interp *interpreter) {
struct IRegChunk *chunk_base;
chunk_base = CHUNK_BASE(interpreter->int_reg);
/* Is there more than one register frame in use? */
if (chunk_base->used > 1) {
chunk_base->used--;
chunk_base->free++;
interpreter->int_reg = &chunk_base->IReg[chunk_base->used - 1];
}
/* nope. Walk back */
else {
/* Can we even walk back? */
if (chunk_base->prev) {
/* Do so. We don't need to adjust used/free, since they're
already OK for the "We're full" case */
chunk_base = chunk_base->prev;
interpreter->int_reg = &chunk_base->IReg[chunk_base->used];
}
/* Nope. So pitch a fit */
else {
INTERNAL_EXCEPTION(NO_REG_FRAMES, "No more I register frames to pop!");
}
}
}
void clear_i(struct Perl_Interp *interpreter) {
int i;
for (i=0; i<NUM_REGISTERS; i++) {
INT_REG(i) = 0;
}
}
void push_s(struct Perl_Interp *interpreter) {
struct SRegChunk *chunk_base;
chunk_base = CHUNK_BASE(interpreter->string_reg);
/* Do we have any slots left in the current chunk? */
if (chunk_base->free) {
interpreter->string_reg = &chunk_base->SReg[chunk_base->used++];
chunk_base->free--;
}
/* Nope, so plan B time. Allocate a new chunk of string register frames */
else {
struct SRegChunk *new_chunk;
new_chunk = Allocate_Aligned(sizeof(struct SRegChunk));
new_chunk->used = 1;
new_chunk->free = FRAMES_PER_STR_REG_CHUNK - 1;
new_chunk->next = NULL;
new_chunk->prev = chunk_base;
chunk_base->next = new_chunk;
interpreter->string_reg = &new_chunk->SReg[0];
}
}
void pop_s(struct Perl_Interp *interpreter) {
struct SRegChunk *chunk_base;
chunk_base = CHUNK_BASE(interpreter->string_reg);
/* Is there more than one register frame in use? */
if (chunk_base->used > 1) {
chunk_base->used--;
chunk_base->free++;
interpreter->string_reg = &chunk_base->SReg[chunk_base->used - 1];
}
/* nope. Walk back */
else {
/* Can we even walk back? */
if (chunk_base->prev) {
/* Do so. We don't need to adjust used/free, since they're
already OK for the "We're full" case */
chunk_base = chunk_base->prev;
interpreter->string_reg = &chunk_base->SReg[chunk_base->used];
}
/* Nope. So pitch a fit */
else {
INTERNAL_EXCEPTION(NO_REG_FRAMES, "No more S register frames to pop!");
}
}
}
void clear_s(struct Perl_Interp *interpreter) {
int i;
for (i=0; i<NUM_REGISTERS; i++) {
STR_REG(i) = NULL;
}
}
void push_n(struct Perl_Interp *interpreter) {
struct NRegChunk *chunk_base;
chunk_base = CHUNK_BASE(interpreter->num_reg);
/* Do we have any slots left in the current chunk? */
if (chunk_base->free) {
interpreter->num_reg = &chunk_base->NReg[chunk_base->used++];
chunk_base->free--;
}
/* Nope, so plan B time. Allocate a new chunk of float register frames */
else {
struct NRegChunk *new_chunk;
new_chunk = Allocate_Aligned(sizeof(struct NRegChunk));
new_chunk->used = 1;
new_chunk->free = FRAMES_PER_NUM_REG_CHUNK - 1;
new_chunk->next = NULL;
new_chunk->prev = chunk_base;
chunk_base->next = new_chunk;
interpreter->num_reg = &new_chunk->NReg[0];
}
}
void pop_n(struct Perl_Interp *interpreter) {
struct NRegChunk *chunk_base;
chunk_base = CHUNK_BASE(interpreter->num_reg);
/* Is there more than one register frame in use? */
if (chunk_base->used > 1) {
chunk_base->used--;
chunk_base->free++;
interpreter->num_reg = &chunk_base->NReg[chunk_base->used - 1];
}
/* nope. Walk back */
else {
/* Can we even walk back? */
if (chunk_base->prev) {
/* Do so. We don't need to adjust used/free, since they're
already OK for the "We're full" case */
chunk_base = chunk_base->prev;
interpreter->num_reg = &chunk_base->NReg[chunk_base->used];
}
/* Nope. So pitch a fit */
else {
INTERNAL_EXCEPTION(NO_REG_FRAMES, "No more N register frames to pop!");
}
}
}
void clear_n(struct Perl_Interp *interpreter) {
int i;
for (i=0; i<NUM_REGISTERS; i++) {
NUM_REG(i) = 0;
}
}
void push_p(struct Perl_Interp *interpreter) {
struct PRegChunk *chunk_base;
chunk_base = CHUNK_BASE(interpreter->pmc_reg);
/* Do we have any slots left in the current chunk? */
if (chunk_base->free) {
interpreter->pmc_reg = &chunk_base->PReg[chunk_base->used++];
chunk_base->free--;
}
/* Nope, so plan B time. Allocate a new chunk of float register frames */
else {
struct PRegChunk *new_chunk;
new_chunk = Allocate_Aligned(sizeof(struct PRegChunk));
new_chunk->used = 1;
new_chunk->free = FRAMES_PER_PMC_REG_CHUNK - 1;
new_chunk->next = NULL;
new_chunk->prev = chunk_base;
chunk_base->next = new_chunk;
interpreter->pmc_reg = &new_chunk->PReg[0];
}
}
void pop_p(struct Perl_Interp *interpreter) {
struct PRegChunk *chunk_base;
chunk_base = CHUNK_BASE(interpreter->pmc_reg);
/* Is there more than one register frame in use? */
if (chunk_base->used > 1) {
chunk_base->used--;
chunk_base->free++;
interpreter->pmc_reg = &chunk_base->PReg[chunk_base->used - 1];
}
/* nope. Walk back */
else {
/* Can we even walk back? */
if (chunk_base->prev) {
/* Do so. We don't need to adjust used/free, since they're
already OK for the "We're full" case */
chunk_base = chunk_base->prev;
interpreter->pmc_reg = &chunk_base->PReg[chunk_base->used];
}
/* Nope. So pitch a fit */
else {
INTERNAL_EXCEPTION(NO_REG_FRAMES, "No more P register frames to pop!");
}
}
}
void clear_p(struct Perl_Interp *interpreter) {
int i;
for (i=0; i<NUM_REGISTERS; i++) {
PMC_REG(i) = NULL;
}
}
void push_on_stack(void *thing, IV size, IV type) {
}
void pop_off_stack(void *thing, IV type) {
}
1.1 parrot/register.h
Index: register.h
===================================================================
/* register.h
*
* Define the register structures
*
*/
#if !defined(__PARROT_REGISTER_H_GUARD)
#define __PARROT_REGISTER_H_GUARD
#include "parrot.h"
struct IReg {
IV registers[NUM_REGISTERS];
};
struct NReg {
NV registers[NUM_REGISTERS];
};
struct SReg {
STRING *registers[NUM_REGISTERS];
};
struct PReg {
PMC *registers[NUM_REGISTERS];
};
struct IRegChunk {
IV used;
IV free;
struct IRegChunk *next;
struct IRegChunk *prev;
struct IReg IReg[FRAMES_PER_CHUNK];
};
struct NRegChunk {
IV used;
IV free;
struct NRegChunk *next;
struct NRegChunk *prev;
struct NReg NReg[FRAMES_PER_CHUNK];
};
struct SRegChunk {
IV used;
IV free;
struct SRegChunk *next;
struct SRegChunk *prev;
struct SReg SReg[FRAMES_PER_CHUNK];
};
struct PRegChunk {
IV used;
IV free;
struct PRegChunk *next;
struct PRegChunk *prev;
struct PReg PReg[FRAMES_PER_CHUNK];
};
/* Accessor macros */
#define INT_REG(x) interpreter->int_reg->registers[x]
#define STR_REG(x) interpreter->string_reg->registers[x]
#define PMC_REG(x) interpreter->pmc_reg->registers[x]
#define NUM_REG(x) interpreter->num_reg->registers[x]
/* This macro masks off the low bits of a register chunk address,
since we're guaranteed to be aligned */
#define CHUNK_BASE(x) (void *)(MASK_CHUNK_LOW_BITS && (IV)x)
void clear_i(struct Perl_Interp *);
void clear_s(struct Perl_Interp *);
void clear_p(struct Perl_Interp *);
void clear_n(struct Perl_Interp *);
#endif /* __PARROT_REGISTER_H */
1.1 parrot/stacks.h
Index: stacks.h
===================================================================
/* stacks.h
*
* Define the structures in the perl 6 stack system
*
*/
struct Stack_Entry {
IV entry_type;
union {
NV number;
IV int;
PMC *pmc;
STRING *string;
void *generic_pointer;
} entry;
}
struct Stack {
struct *Stack_Entry[];
}
1.1 parrot/string.c
Index: string.c
===================================================================
/* string.c
*
* String handling code
*
*/
#include "parrot.h"
STRING_VTABLE Parrot_string_vtable[enc_max];
STRING *
string_make(char *buffer, IV buflen, IV encoding, IV flags, IV type) {
STRING *s = Sys_Allocate(sizeof(STRING));
Sys_Memcopy(s->bufstart, buffer, buflen);
s->encoding = encoding;
s->buflen = buflen;
s->flags = flags;
string_compute_strlen(s);
s->type = type;
return s;
}
/* Setup string vtables */
void
string_init(void) {
Parrot_string_vtable[enc_native] = string_native_vtable();
}
/* vtable despatch functions */
IV
string_compute_strlen(STRING *s) {
return (s->strlen = (Parrot_string_vtable[s->encoding].compute_strlen)(s));
}
1.1 parrot/string.h
Index: string.h
===================================================================
/* string.h
*
* String data info
*
*/
#if !defined(PARROT_STRING_H_GUARD)
#define PARROT_STRING_H_GUARD 1
struct parrot_string {
void *bufstart;
IV buflen;
IV bufused;
IV flags;
IV strlen;
IV encoding;
IV type;
IV unused;
};
enum {
enc_native,
enc_utf8,
enc_utf16,
enc_utf32,
enc_foreign,
enc_max
};
typedef struct parrot_string STRING;
/* String vtable functions */
typedef IV (*string_to_iv_t)(STRING *);
struct string_vtable {
string_to_iv_t compute_strlen;
};
typedef struct string_vtable STRING_VTABLE;
/* Declarations of accessors */
IV string_compute_strlen(STRING*);
#include "strnative.h"
#endif
1.1 parrot/strnative.c
Index: strnative.c
===================================================================
/* strnative.c
Functions for handling strings in native byte format
"Native" in this context means the equivalent of "LANG=C": No
fancy multi-byte stuff, this is plain old byte-at-a-time. But
we don't make any assumptions about what those bytes *mean*.
*/
#include "parrot.h"
static IV
string_native_compute_strlen (STRING *s) {
return s->buflen;
}
STRING_VTABLE
string_native_vtable (void) {
return (STRING_VTABLE) {
string_native_compute_strlen,
};
}
1.1 parrot/strnative.h
Index: strnative.h
===================================================================
/* strnative.h
*
* Native string handling functions header
*
*/
#if !defined(PARROT_STRNATIVE_H_GUARD)
#define PARROT_STRNATIVE_H_GUARD
STRING_VTABLE string_native_vtable (void);
#endif
1.1 parrot/test.pasm
Index: test.pasm
===================================================================
time_i I1
set_i_ic I2, 0
set_n_nc N1, 50
print_n N1
set_n_nc N2, 5
print_n N2
add_n N1, N1, N2
print_n N1
set_i_ic I3, 1
set_i_ic I4, 10000000
REDO: eq_i_ic I2, I4, DONE, NEXT
NEXT: add_i I2, I2, I3
branch_ic REDO
DONE: time_i I5
print_i I1
print_i I5
print_i I2
sub_i I2, I5, I1
print_i I2
set_i_ic I1, 3
mul_i I4, I4, I1
iton_n_i N1, I4
iton_n_i N2, I2
print_i I4
print_n N1
print_i I2
print_n N2
div_n N1, N1, N2
print_n N1
end
1.1 parrot/test.pbc
<<Binary file>>
1.1 parrot/test_main.c
Index: test_main.c
===================================================================
/* driver.c
*
* A sample main program
*
*/
#include "parrot.h"
IV opcodes[] = {3, 1, // put the time in reg 1
0, 2, 0, // Set reg 2 to 0
0, 3, 1, // set reg 3 to 1
0, 4, 100000000, // set reg 4 to 100M
2, 2, 4, 11, 5, // is reg 2 eq to reg 4?
1, 2, 2, 3, // Add register 2 to 3, store in 2
5, -9, // branch back to if
3, 5, // Put the time in reg 5
4, 1, // Print reg 1
4, 5, // Print reg 5
6 // exit
};
int main(int argc, char **argv) {
struct Perl_Interp *interpreter;
init_world();
interpreter = make_interpreter();
/* If we got only the program name, run the test program */
if (argc == 1) {
runops(interpreter, opcodes);
}
/* Otherwise load in the program they gave and try that */
else {
void *program_code;
struct stat file_stat;
int fd;
if (stat(argv[1], &file_stat)) {
printf("can't stat %s, code %i\n", argv[1], errno);
return 1;
}
fd = open(argv[1], O_RDONLY);
if (!fd) {
printf("Can't open, error %i\n", errno);
return 1;
}
program_code = mmap(0, file_stat.st_size, PROT_READ, MAP_SHARED, fd, 0);
if (!program_code) {
printf("Can't mmap, code %i\n", errno);
return 1;
}
program_code = init_bytecode(program_code);
runops(interpreter, program_code);
}
return 0;
}
1.1 parrot/test_opcodes.c
Index: test_opcodes.c
===================================================================
/* basic_opcodes.c
*
* Just some basic opcodes
*
*/
#include "parrot.h"
// SET Ix, CONSTANT
IV *set_i(IV cur_opcode[], struct Perl_Interp *interpreter) {
INT_REG(cur_opcode[1]) = cur_opcode[2];
return cur_opcode + 3;
}
// ADD Ix, Iy, Iz
IV *add_i(IV cur_opcode[], struct Perl_Interp *interpreter) {
INT_REG(cur_opcode[1]) = INT_REG(cur_opcode[2]) +
INT_REG(cur_opcode[3]);
return cur_opcode + 4;
}
// SUB Ix, Iy, Iz
IV *sub_i(IV cur_opcode[], struct Perl_Interp *interpreter) {
INT_REG(cur_opcode[1]) = INT_REG(cur_opcode[2]) -
INT_REG(cur_opcode[3]);
return cur_opcode + 4;
}
// MUL Ix, Iy, Iz
IV *mul_i(IV cur_opcode[], struct Perl_Interp *interpreter) {
INT_REG(cur_opcode[1]) = INT_REG(cur_opcode[2]) *
INT_REG(cur_opcode[3]);
return cur_opcode + 4;
}
// DIV Ix, Iy, Iz
IV *div_i(IV cur_opcode[], struct Perl_Interp *interpreter) {
INT_REG(cur_opcode[1]) = INT_REG(cur_opcode[2]) /
INT_REG(cur_opcode[3]);
return cur_opcode + 4;
}
// EQ Ix, Iy, EQ_BRANCH, NE_BRANCH
IV *eq_i(IV cur_opcode[], struct Perl_Interp *interpreter) {
if (INT_REG(cur_opcode[1]) == INT_REG(cur_opcode[2])) {
return cur_opcode + cur_opcode[3];
} else {
return cur_opcode + cur_opcode[4];
}
}
// IF IXx, TRUE_BRANCH, FALSE_BRANCH
IV *if_i(IV cur_opcode[], struct Perl_Interp *interpreter) {
if (INT_REG(cur_opcode[1])) {
return cur_opcode + cur_opcode[2];
} else {
return cur_opcode + cur_opcode[3];
}
}
// TIME Ix
IV *time_i(IV cur_opcode[], struct Perl_Interp *interpreter) {
INT_REG(cur_opcode[1]) = time(NULL);
return cur_opcode + 2;
}
// PRINT Ix
IV *print_i(IV cur_opcode[], struct Perl_Interp *interpreter) {
printf("I reg %i is %i\n", cur_opcode[1], INT_REG(cur_opcode[1]));
return(cur_opcode + 2);
}
// BRANCH CONSTANT
IV *branch_i_c(IV cur_opcode[], struct Perl_Interp *interpreter) {
return cur_opcode + cur_opcode[1];
}
// END
IV *end(IV cur_opcode[], struct Perl_Interp *interpreter) {
return 0;
}
