src/inter_misc.c

   1 /*
   2 Copyright (C) 2001-2008, The Perl Foundation.
   3 $Id$
   4
   5 =head1 NAME
   6
   7 src/inter_misc.c - Parrot Interpreter miscellaneous functions
   8
   9 =head1 DESCRIPTION
  10
  11 NCI function setup, compiler registration, C<interpinfo>, and C<sysinfo> opcodes.
  12
  13 =head2 Functions
  14
  15 =over 4
  16
  17 =cut
  18
  19 */
  20
  21
  22 #include "parrot/parrot.h"
  23 #include "inter_misc.str"
  24 #include "../compilers/imcc/imc.h"
  25
  26 /* HEADERIZER HFILE: include/parrot/interpreter.h */
  27
  28 /*
  29
  30 =item C<void register_nci_method>
  31
  32 Create an entry in the C<nci_method_table> for the given NCI method of PMC
  33 class C<type>.
  34
  35 =cut
  36
  37 */
  38
  39 PARROT_API
  40 void
  41 register_nci_method(PARROT_INTERP, const int type, ARGIN(void *func),
  42                     ARGIN(const char *name), ARGIN(const char *proto))
  43 {
  44     PMC    * const method      = pmc_new(interp, enum_class_NCI);
  45     STRING * const method_name = string_make(interp, name, strlen(name),
  46         NULL, PObj_constant_FLAG|PObj_external_FLAG);
  47
  48     /* create call func */
  49     VTABLE_set_pointer_keyed_str(interp, method,
  50             string_make(interp, proto, strlen(proto), NULL,
  51                 PObj_constant_FLAG|PObj_external_FLAG),
  52             func);
  53
  54     /* insert it into namespace */
  55     VTABLE_set_pmc_keyed_str(interp, interp->vtables[type]->_namespace,
  56             method_name, method);
  57 }
  58
  59 /*
  60
  61 =item C<void register_raw_nci_method_in_ns>
  62
  63 Create an entry in the C<nci_method_table> for the given raw NCI method
  64 of PMC class C<type>.
  65
  66 =cut
  67
  68 */
  69
  70 PARROT_API
  71 void
  72 register_raw_nci_method_in_ns(PARROT_INTERP, const int type, ARGIN(void *func),
  73         ARGIN(const char *name))
  74 {
  75     PMC    * const method      = pmc_new(interp, enum_class_NCI);
  76     STRING * const method_name = string_make(interp, name, strlen(name),
  77         NULL, PObj_constant_FLAG|PObj_external_FLAG);
  78
  79     /* setup call func */
  80     VTABLE_set_pointer(interp, method, func);
  81
  82     /* insert it into namespace */
  83     VTABLE_set_pmc_keyed_str(interp, interp->vtables[type]->_namespace,
  84             method_name, method);
  85 }
  86
  87 /*
  88
  89 =item C<void Parrot_mark_method_writes>
  90
  91 Mark the method C<name> on PMC type C<type> as one that modifies the PMC.
  92
  93 =cut
  94
  95 */
  96
  97 PARROT_API
  98 void
  99 Parrot_mark_method_writes(PARROT_INTERP, int type, ARGIN(const char *name))
 100 {
 101     STRING *const str_name = const_string(interp, name);
 102     PMC    *const pmc_true = pmc_new(interp, enum_class_Integer);
 103     PMC    *const method   = VTABLE_get_pmc_keyed_str(
 104         interp, interp->vtables[type]->_namespace, str_name);
 105     VTABLE_set_integer_native(interp, pmc_true, 1);
 106     VTABLE_setprop(interp, method, CONST_STRING(interp, "write"), pmc_true);
 107 }
 108
 109 /*
 110
 111 =item C<void Parrot_compreg>
 112
 113 Register a parser/compiler function.
 114
 115 =cut
 116
 117 */
 118
 119 PARROT_API
 120 void
 121 Parrot_compreg(PARROT_INTERP, ARGIN(STRING *type),
 122                     NOTNULL(Parrot_compiler_func_t func))
 123 {
 124     PMC* const iglobals = interp->iglobals;
 125     PMC        *nci     = pmc_new(interp, enum_class_NCI);
 126     STRING     *sc      = CONST_STRING(interp, "PJt");
 127     PMC        *hash    = VTABLE_get_pmc_keyed_int(interp, interp->iglobals,
 128                               IGLOBALS_COMPREG_HASH);
 129
 130     if (!hash) {
 131         hash = pmc_new_noinit(interp, enum_class_Hash);
 132         VTABLE_init(interp, hash);
 133         VTABLE_set_pmc_keyed_int(interp, iglobals,
 134                 (INTVAL)IGLOBALS_COMPREG_HASH, hash);
 135     }
 136
 137     VTABLE_set_pmc_keyed_str(interp, hash, type, nci);
 138
 139     /* build native call interface for the C sub in "func" */
 140     VTABLE_set_pointer_keyed_str(interp, nci, sc, (void*)func);
 141 }
 142
 143 /*
 144
 145 =item C<PMC * Parrot_compile_string>
 146
 147 Compile code string.
 148
 149 =cut
 150
 151 */
 152
 153 PARROT_API
 154 PARROT_WARN_UNUSED_RESULT
 155 PARROT_CAN_RETURN_NULL
 156 PMC *
 157 Parrot_compile_string(PARROT_INTERP, ARGIN(STRING *type),
 158         ARGIN(const char *code), ARGOUT(STRING **error))
 159 {
 160     if (string_compare(interp, CONST_STRING(interp, "PIR"), type) == 0)
 161         return IMCC_compile_pir_s(interp, code, error);
 162
 163     if (string_compare(interp, CONST_STRING(interp, "PASM"), type) == 0)
 164         return IMCC_compile_pasm_s(interp, code, error);
 165
 166     *error = CONST_STRING(interp, "Invalid interpreter type");
 167     return NULL;
 168 }
 169
 170 /*
 171
 172 =item C<void * Parrot_compile_file>
 173
 174 Compile code file.
 175
 176 =cut
 177
 178 */
 179
 180 PARROT_API
 181 PARROT_CANNOT_RETURN_NULL
 182 void *
 183 Parrot_compile_file(PARROT_INTERP, ARGIN(const char *fullname), ARGOUT(STRING **error))
 184 {
 185     return IMCC_compile_file_s(interp, fullname, error);
 186 }
 187
 188 #ifdef GC_IS_MALLOC
 189 #  if 0
 190 struct mallinfo {
 191     int arena;                  /* non-mmapped space allocated from system */
 192     int ordblks;                /* number of free chunks */
 193     int smblks;                 /* number of fastbin blocks */
 194     int hblks;                  /* number of mmapped regions */
 195     int hblkhd;                 /* space in mmapped regions */
 196     int usmblks;                /* maximum total allocated space */
 197     int fsmblks;                /* space available in freed fastbin blocks */
 198     int uordblks;               /* total allocated space */
 199     int fordblks;               /* total free space */
 200     int keepcost;               /* top-most, releasable (via malloc_trim)
 201                                  * space */
 202 };
 203 #  endif
 204 extern struct mallinfo mallinfo(void);
 205 #endif /* GC_IS_MALLOC */
 206
 207 /*
 208
 209 =item C<INTVAL interpinfo>
 210
 211 C<what> specifies the type of information you want about the
 212 interpreter.
 213
 214 =cut
 215
 216 */
 217
 218 PARROT_API
 219 INTVAL
 220 interpinfo(PARROT_INTERP, INTVAL what)
 221 {
 222     INTVAL ret = 0;
 223     int j;
 224     Arenas *arena_base = interp->arena_base;
 225
 226     switch (what) {
 227         case TOTAL_MEM_ALLOC:
 228 #ifdef GC_IS_MALLOC
 229 #  if 0
 230             interp->memory_allocated = mallinfo().uordblks;
 231 #  endif
 232 #endif
 233             ret = arena_base->memory_allocated;
 234             break;
 235         case DOD_RUNS:
 236             ret = arena_base->dod_runs;
 237             break;
 238         case LAZY_DOD_RUNS:
 239             ret = arena_base->lazy_dod_runs;
 240             break;
 241         case COLLECT_RUNS:
 242             ret = arena_base->collect_runs;
 243             break;
 244         case ACTIVE_PMCS:
 245             ret = arena_base->pmc_pool->total_objects -
 246                 arena_base->pmc_pool->num_free_objects;
 247             break;
 248         case ACTIVE_BUFFERS:
 249             ret = 0;
 250             for (j = 0; j < (INTVAL)arena_base->num_sized; j++) {
 251                 Small_Object_Pool * const header_pool =
 252                     arena_base->sized_header_pools[j];
 253                 if (header_pool)
 254                     ret += header_pool->total_objects -
 255                         header_pool->num_free_objects;
 256             }
 257             break;
 258         case TOTAL_PMCS:
 259             ret = arena_base->pmc_pool->total_objects;
 260             break;
 261         case TOTAL_BUFFERS:
 262             ret = 0;
 263             for (j = 0; j < (INTVAL)arena_base->num_sized; j++) {
 264                 Small_Object_Pool * const header_pool =
 265                     arena_base->sized_header_pools[j];
 266                 if (header_pool)
 267                     ret += header_pool->total_objects;
 268             }
 269             break;
 270         case HEADER_ALLOCS_SINCE_COLLECT:
 271             ret = arena_base->header_allocs_since_last_collect;
 272             break;
 273         case MEM_ALLOCS_SINCE_COLLECT:
 274             ret = arena_base->mem_allocs_since_last_collect;
 275             break;
 276         case TOTAL_COPIED:
 277             ret = arena_base->memory_collected;
 278             break;
 279         case IMPATIENT_PMCS:
 280             ret = arena_base->num_early_DOD_PMCs;
 281             break;
 282         case EXTENDED_PMCS:
 283             ret = arena_base->num_extended_PMCs;
 284             break;
 285         case CURRENT_RUNCORE:
 286             ret = interp->run_core;
 287             break;
 288         default:        /* or a warning only? */
 289             Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_UNIMPLEMENTED,
 290                 "illegal argument in interpinfo");
 291     }
 292     return ret;
 293 }
 294
 295 /*
 296
 297 =item C<PMC* interpinfo_p>
 298
 299 C<what> specifies the type of information you want about the
 300 interpreter.
 301
 302 =cut
 303
 304 */
 305
 306 PARROT_API
 307 PARROT_WARN_UNUSED_RESULT
 308 PARROT_CAN_RETURN_NULL
 309 PMC*
 310 interpinfo_p(PARROT_INTERP, INTVAL what)
 311 {
 312     switch (what) {
 313         case CURRENT_SUB:
 314             return CONTEXT(interp)->current_sub;
 315         case CURRENT_CONT:
 316             {
 317             PMC * const cont = CONTEXT(interp)->current_cont;
 318             if (!PMC_IS_NULL(cont) && cont->vtable->base_type ==
 319                     enum_class_RetContinuation)
 320                 return VTABLE_clone(interp, cont);
 321             return cont;
 322             }
 323         case CURRENT_OBJECT:
 324             return CONTEXT(interp)->current_object;
 325         case CURRENT_LEXPAD:
 326             return CONTEXT(interp)->lex_pad;
 327         default:        /* or a warning only? */
 328             Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_UNIMPLEMENTED,
 329                 "illegal argument in interpinfo");
 330     }
 331 }
 332
 333 /*
 334
 335 =item C<STRING* interpinfo_s>
 336
 337 Takes an interpreter name and an information type as arguments.
 338 Returns corresponding information strings about the interpreter:
 339 the full pathname, executable name, or the file stem,
 340 (or throws an error exception, if the type is not recognised).
 341 Valid types are EXECUTABLE_FULLNAME, EXECUTABLE_BASENAME,
 342 and RUNTIME_PREFIX.
 343
 344 =cut
 345
 346 */
 347
 348 PARROT_API
 349 PARROT_WARN_UNUSED_RESULT
 350 PARROT_CANNOT_RETURN_NULL
 351 STRING*
 352 interpinfo_s(PARROT_INTERP, INTVAL what)
 353 {
 354     switch (what) {
 355         case EXECUTABLE_FULLNAME:
 356             return VTABLE_get_string(interp,
 357                 VTABLE_get_pmc_keyed_int(interp, interp->iglobals,
 358                     IGLOBALS_EXECUTABLE));
 359         case EXECUTABLE_BASENAME:
 360             {
 361             char   *fullname_c;
 362             STRING *fullname;
 363             STRING *basename;
 364             int     pos;
 365
 366             /* Need to strip back to what follows the final / or \. */
 367             fullname = VTABLE_get_string(interp,
 368                 VTABLE_get_pmc_keyed_int(interp, interp->iglobals,
 369                     IGLOBALS_EXECUTABLE));
 370             fullname_c = string_to_cstring(interp, fullname);
 371             pos = strlen(fullname_c) - 1;
 372             while (pos > 0 && fullname_c[pos] != '/' && fullname_c[pos] != '\\')
 373                 pos--;
 374             if (pos > 0)
 375                 pos++;
 376             basename = string_from_cstring(interp, fullname_c + pos, 0);
 377             mem_sys_free(fullname_c);
 378             return basename;
 379             }
 380
 381         case RUNTIME_PREFIX:
 382             {
 383             char   * const fullname_c = Parrot_get_runtime_prefix(interp);
 384             STRING * const fullname   = string_from_cstring(interp, fullname_c, 0);
 385
 386             mem_sys_free(fullname_c);
 387             return fullname;
 388             }
 389
 390         default:
 391             Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_UNIMPLEMENTED,
 392                 "illegal argument in interpinfo");
 393     } /* switch */
 394 }
 395
 396 /*
 397
 398 =item C<INTVAL sysinfo_i>
 399
 400 Returns the system info.
 401
 402 C<info_wanted> is one of:
 403
 404     PARROT_INTSIZE
 405     PARROT_FLOATSIZE
 406     PARROT_POINTERSIZE
 407
 408 In unknown info is requested then -1 is returned.
 409
 410 =cut
 411
 412 */
 413
 414 PARROT_WARN_UNUSED_RESULT
 415 INTVAL
 416 sysinfo_i(SHIM_INTERP, INTVAL info_wanted)
 417 {
 418     switch (info_wanted) {
 419         case PARROT_INTSIZE:
 420             return sizeof (INTVAL);
 421         case PARROT_FLOATSIZE:
 422             return sizeof (FLOATVAL);
 423         case PARROT_POINTERSIZE:
 424             return sizeof (void *);
 425         default:
 426             return -1;
 427     }
 428 }
 429
 430 /*
 431
 432 =item C<STRING * sysinfo_s>
 433
 434 Returns the system info string.
 435
 436 C<info_wanted> is one of:
 437
 438     PARROT_OS
 439     PARROT_OS_VERSION
 440     PARROT_OS_VERSION_NUMBER
 441     CPU_ARCH
 442     CPU_TYPE
 443
 444 If unknown info is requested then and empty string is returned.
 445
 446 =cut
 447
 448 */
 449
 450 PARROT_CANNOT_RETURN_NULL
 451 PARROT_WARN_UNUSED_RESULT
 452 STRING *
 453 sysinfo_s(PARROT_INTERP, INTVAL info_wanted)
 454 {
 455     switch (info_wanted) {
 456         case PARROT_OS:
 457             return const_string(interp, BUILD_OS_NAME);
 458         case PARROT_OS_VERSION:
 459         case PARROT_OS_VERSION_NUMBER:
 460         case CPU_ARCH:
 461         case CPU_TYPE:
 462         default:
 463             return CONST_STRING(interp, "");
 464     }
 465 }
 466
 467 /*
 468  * Local variables:
 469  *   c-file-style: "parrot"
 470  * End:
 471  * vim: expandtab shiftwidth=4:
 472  */