luabytecode.pmc

/*
Copyright (C) 2008-2009, Parrot Foundation.
$Id$

=head1 Lua 5.1 VM bytecode loader

=head2 Description

This singleton PMC holds a factory.

=head3 Methods

=over 4

=cut

*/

/*** from lua.h ***/

/* type of numbers in Lua */
typedef double lua_Number;

/*** from limits.h ***/

/*
** type for virtual-machine instructions
** must be an unsigned with (at least) 4 bytes (see details in lopcodes.h)
*/
typedef Parrot_Int4 Instruction;

/*** from lundump.h ***/

/* for header of binary files -- this is Lua 5.1 */
#define LUAC_VERSION            0x51

/* for header of binary files -- this is the official format */
#define LUAC_FORMAT             0

/* size of header of binary files */
#define LUAC_HEADERSIZE         12

/***  ***/

static const char header_ref[LUAC_HEADERSIZE] = {
    '\033', 'L', 'u', 'a',
    LUAC_VERSION,
    LUAC_FORMAT,
    PARROT_LITTLEENDIAN,
    sizeof (int),
    sizeof (size_t),
    sizeof (Instruction),
    sizeof (lua_Number),
    0,
};

static PMC * LuaBytecode_PMC;
static char * bytecode;
static UINTVAL maxi;
static const char *fp;

static void _init(Interp *interp, STRING *str)
{
    bytecode = Parrot_str_to_cstring(interp, str);
    maxi     = Parrot_str_byte_length(interp, str);
    fp       = bytecode;
}


#define _info_get()     (UINTVAL)(&bytecode[maxi] - fp)
#define _get_pos()      (fp)
#define _get_byte()     (*(fp++))

static void _get_block(void* b, size_t size)
{
    memcpy(b, fp, size);
    fp += size;
}

static int _get_integer(void)
{
    int x;
    memcpy(&x, fp, sizeof x);
    fp += sizeof x;
    return x;
}

static Instruction _get_instruction(void)
{
    Instruction x;
    memcpy(&x, fp, sizeof x);
    fp += sizeof x;
    return x;
}

static double _get_number(void)
{
    double x;
    memcpy(&x, fp, sizeof x);
    fp += sizeof x;
    return x;
}

static STRING* _get_string(Interp *interp)
{
    STRING* str;
    size_t s;
    memcpy(&s, fp, sizeof s);
    fp += sizeof s;
    if (s != 0) {
        str = Parrot_str_new(interp, fp, s-1);
        fp += s;
    }
    else
        str = Parrot_str_new(interp, "", 0);
    return str;
}

static PMC * _new_lua(Interp *interp, const char *name)
{
    PMC * const key = Parrot_key_append(interp,
          Parrot_key_new_cstring(interp, "Lua"),
          Parrot_key_new_cstring(interp, name));
    PMC * const class_object = Parrot_oo_get_class(interp, key);
    if (PMC_IS_NULL(class_object))
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_ILL_INHERIT,
              "Lua::%s not loaded", name);
    return VTABLE_instantiate(interp, class_object, PMCNULL);
}

static PMC* _load_function(Interp *interp);

static PMC* _load_bool(Interp *interp)
{
    PMC* const ret = Parrot_pmc_new(interp, Parrot_pmc_get_type_str(interp,
          Parrot_str_new_constant(interp, "Boolean")));
    VTABLE_set_integer_native(interp, ret, _get_byte());
    return ret;
}

static PMC* _load_byte(Interp *interp)
{
    PMC* const ret = Parrot_pmc_new(interp, Parrot_pmc_get_type_str(interp,
          Parrot_str_new_constant(interp, "Integer")));
    VTABLE_set_integer_native(interp, ret, _get_byte());
    return ret;
}

static PMC* _load_integer(Interp *interp)
{
    PMC* const ret = Parrot_pmc_new(interp, Parrot_pmc_get_type_str(interp,
          Parrot_str_new_constant(interp, "Integer")));
    VTABLE_set_integer_native(interp, ret, _get_integer());
    return ret;
}

static PMC* _load_string(Interp *interp)
{
    PMC* const ret = Parrot_pmc_new(interp, Parrot_pmc_get_type_str(interp,
          Parrot_str_new_constant(interp, "String")));
    VTABLE_set_string_native(interp, ret, _get_string(interp));
    return ret;
}

static void _load_header(Interp *interp, PMC *script)
{
    char header[LUAC_HEADERSIZE];

    _get_block(header, sizeof header);

    if (memcmp(header, header_ref, sizeof header) != 0)
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_ILL_INHERIT, "bad header");

#if 1
    fp -= 8;
    VTABLE_set_attr_str(interp, script,
        Parrot_str_new_constant(interp, "version"), _load_byte(interp));
    VTABLE_set_attr_str(interp, script,
        Parrot_str_new_constant(interp, "format"), _load_byte(interp));
    VTABLE_set_attr_str(interp, script,
        Parrot_str_new_constant(interp, "endian"), _load_byte(interp));
    VTABLE_set_attr_str(interp, script,
        Parrot_str_new_constant(interp, "sizeof_int"), _load_byte(interp));
    VTABLE_set_attr_str(interp, script,
        Parrot_str_new_constant(interp, "sizeof_size_t"), _load_byte(interp));
    VTABLE_set_attr_str(interp, script,
        Parrot_str_new_constant(interp, "sizeof_opcode"), _load_byte(interp));
    VTABLE_set_attr_str(interp, script,
        Parrot_str_new_constant(interp, "sizeof_number"), _load_byte(interp));
    VTABLE_set_attr_str(interp, script,
        Parrot_str_new_constant(interp, "integral"), _load_byte(interp));
#endif
}

static PMC* _load_instruction_list(Interp *interp)
{
    int i;
    const int n = _get_integer();
    PMC * const ret = _new_lua(interp, "InstructionList");
    VTABLE_set_integer_native(interp, ret, n);

    for (i = 0; i < n; i++) {
        VTABLE_set_integer_keyed_int(interp, ret, i, _get_instruction());
    }

    return ret;
}

static PMC* _load_constant_list(Interp *interp)
{
    int i;
    const int n = _get_integer();
    PMC * const ret = _new_lua(interp, "ConstantList");
    VTABLE_set_integer_native(interp, ret, n);

    for (i = 0; i < n; i++) {
        PMC* k;
        const int type = _get_byte();
        switch (type) {
        case 0:
            k = _new_lua(interp, "Nil");
            break;
        case 1:
            k = _new_lua(interp, "Boolean");
            VTABLE_set_integer_native(interp, k, _get_byte());
            break;
        case 3:
            k = _new_lua(interp, "Number");
            VTABLE_set_number_native(interp, k, _get_number());
            break;
        case 4:
            k = _new_lua(interp, "String");
            VTABLE_set_string_native(interp, k, _get_string(interp));
            break;
        default:
            Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_ILL_INHERIT, "bad constant");
        }
        VTABLE_set_pmc_keyed_int(interp, ret, i, k);
    }

    return ret;
}

static PMC* _load_prototype_list(Interp *interp)
{
    int i;
    const int n = _get_integer();
    PMC * const ret = _new_lua(interp, "PrototypeList");
    VTABLE_set_integer_native(interp, ret, n);

    for (i = 0; i < n; i++) {
        VTABLE_set_pmc_keyed_int(interp, ret, i, _load_function(interp));
    }

    return ret;
}

static PMC* _load_line_list(Interp *interp)
{
    int i;
    const int n = _get_integer();
    PMC * const ret = _new_lua(interp, "LineList");
    VTABLE_set_integer_native(interp, ret, n);

    for (i = 0; i < n; i++) {
        VTABLE_set_integer_keyed_int(interp, ret, i, _get_integer());
    }

    return ret;
}

static PMC* _load_local_list(Interp *interp)
{
    int i;
    const int n = _get_integer();
    PMC * const ret = _new_lua(interp, "LocalList");
    VTABLE_set_integer_native(interp, ret, n);

    for (i = 0; i < n; i++) {
        PMC* const local = _new_lua(interp, "Local");
        VTABLE_set_string_native(interp, local, _get_string(interp));
        VTABLE_set_attr_str(interp, local,
            Parrot_str_new_constant(interp, "startpc"), _load_integer(interp));
        VTABLE_set_attr_str(interp, local,
            Parrot_str_new_constant(interp, "endpc"), _load_integer(interp));
        VTABLE_set_pmc_keyed_int(interp, ret, i, local);
    }

    return ret;
}

static PMC* _load_upvalue_list(Interp *interp)
{
    int i;
    const int n = _get_integer();
    PMC * const ret = _new_lua(interp, "UpvalueList");
    VTABLE_set_integer_native(interp, ret, n);

    for (i = 0; i < n; i++) {
        PMC* const upvalue = _new_lua(interp, "Upvalue");
        VTABLE_set_string_native(interp, upvalue, _get_string(interp));
        VTABLE_set_pmc_keyed_int(interp, ret, i, upvalue);
    }

    return ret;
}

static PMC* _load_function(Interp *interp)
{
    PMC * const ret = _new_lua(interp, "Function");

    VTABLE_set_attr_str(interp, ret,
        Parrot_str_new_constant(interp, "source"), _load_string(interp));
    VTABLE_set_attr_str(interp, ret,
        Parrot_str_new_constant(interp, "linedefined"), _load_integer(interp));
    VTABLE_set_attr_str(interp, ret,
        Parrot_str_new_constant(interp, "lastlinedefined"), _load_integer(interp));
    VTABLE_set_attr_str(interp, ret,
        Parrot_str_new_constant(interp, "nups"), _load_byte(interp));
    VTABLE_set_attr_str(interp, ret,
        Parrot_str_new_constant(interp, "numparams"), _load_byte(interp));
    VTABLE_set_attr_str(interp, ret,
        Parrot_str_new_constant(interp, "is_vararg"), _load_byte(interp));
    VTABLE_set_attr_str(interp, ret,
        Parrot_str_new_constant(interp, "maxstacksize"), _load_byte(interp));
    VTABLE_set_attr_str(interp, ret,
        Parrot_str_new_constant(interp, "code"), _load_instruction_list(interp));
    VTABLE_set_attr_str(interp, ret,
        Parrot_str_new_constant(interp, "k"), _load_constant_list(interp));
    VTABLE_set_attr_str(interp, ret,
        Parrot_str_new_constant(interp, "p"), _load_prototype_list(interp));
    VTABLE_set_attr_str(interp, ret,
        Parrot_str_new_constant(interp, "lineinfo"), _load_line_list(interp));
    VTABLE_set_attr_str(interp, ret,
        Parrot_str_new_constant(interp, "locvars"), _load_local_list(interp));
    VTABLE_set_attr_str(interp, ret,
        Parrot_str_new_constant(interp, "upvalues"), _load_upvalue_list(interp));

    return ret;
}


pmclass LuaBytecode
    singleton
    dynpmc
    group lua_group {

/*

=item C<void* get_pointer()>

=item C<void set_pointer(void *ptr)>

These two functions are part of the singleton creation interface. For more
information see F<src/pmc.c>.

=cut

*/
    VTABLE void* get_pointer() {
        return LuaBytecode_PMC;
    }

    VTABLE void set_pointer(void* ptr) {
        LuaBytecode_PMC = (PMC*) ptr;
    }

/*

=item C<PMC* undump(STRING* luabytecode)>

Loads Lua 5.1 VM bytecode.

=cut

*/
    METHOD PMC* undump(STRING* luabytecode) {
        PMC * const script = _new_lua(INTERP, "Bytecode");

        _init(INTERP, luabytecode);
        _load_header(INTERP, script);
        VTABLE_set_attr_str(INTERP, script,
          Parrot_str_new_constant(INTERP, "top"), _load_function(INTERP));
        Parrot_str_free_cstring(bytecode);

        RETURN(PMC *script);
    }

}

/*

=back

=cut

*/

/*
 * Local variables:
 *   c-file-style: "parrot"
 * End:
 * vim: expandtab shiftwidth=4:
 */