libguile/instructions.c

   1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19 #if HAVE_CONFIG_H
  20 #  include <config.h>
  21 #endif
  22
  23 #include <string.h>
  24
  25 #include "_scm.h"
  26 #include "threads.h"
  27 #include "instructions.h"
  28
  29
  30 struct scm_instruction {
  31   enum scm_opcode opcode;       /* opcode */
  32   const char *name;             /* instruction name */
  33   signed char len;              /* Instruction length.  This may be -1 for
  34                                    the loader (see the `VM_LOADER'
  35                                    macro).  */
  36   signed char npop;             /* The number of values popped.  This may be
  37                                    -1 for insns like `call' which can take
  38                                    any number of arguments.  */
  39   char npush;                   /* the number of values pushed */
  40   SCM symname;                  /* filled in later */
  41 };
  42
  43
  44 SCM_SYMBOL (sym_left_arrow, "<-");
  45 SCM_SYMBOL (sym_bang, "!");
  46
  47
  48 #define OP_HAS_ARITY (1U << 0)
  49
  50 #define FOR_EACH_INSTRUCTION_WORD_TYPE(M)       \
  51     M(X32)                                      \
  52     M(U8_X24)                                   \
  53     M(U8_U24)                                   \
  54     M(U8_L24)                                   \
  55     M(U8_U8_I16)                                \
  56     M(U8_U8_U8_U8)                              \
  57     M(U8_U12_U12)                               \
  58     M(U32) /* Unsigned. */                      \
  59     M(I32) /* Immediate. */                     \
  60     M(A32) /* Immediate, high bits. */          \
  61     M(B32) /* Immediate, low bits. */           \
  62     M(N32) /* Non-immediate. */                 \
  63     M(S32) /* Scheme value (indirected). */     \
  64     M(L32) /* Label. */                         \
  65     M(LO32) /* Label with offset. */            \
  66     M(X8_U24)                                   \
  67     M(X8_U12_U12)                               \
  68     M(X8_L24)                                   \
  69     M(B1_X7_L24)                                \
  70     M(B1_U7_L24)
  71
  72 #define TYPE_WIDTH 5
  73
  74 enum word_type
  75   {
  76 #define ENUM(type) type,
  77     FOR_EACH_INSTRUCTION_WORD_TYPE (ENUM)
  78 #undef ENUM
  79   };
  80
  81 static SCM word_type_symbols[] =
  82   {
  83 #define FALSE(type) SCM_BOOL_F,
  84     FOR_EACH_INSTRUCTION_WORD_TYPE (FALSE)
  85 #undef FALSE
  86   };
  87
  88 #define OP(n,type) ((type) << (n*TYPE_WIDTH))
  89
  90 /* The VM_DEFINE_OP macro uses a CPP-based DSL to describe what kinds of
  91    arguments each RTL instruction takes.  This piece of code is the only
  92    bit that actually interprets that language.  These macro definitions
  93    encode the operand types into bits in a 32-bit integer.
  94
  95    (rtl-instruction-list) parses those encoded values into lists of
  96    symbols, one for each 32-bit word that the operator takes.  (system
  97    vm rtl) uses those word types to generate assemblers and
  98    disassemblers for the instructions.  */
  99
 100 #define OP1(type0) \
 101   (OP (0, type0))
 102 #define OP2(type0, type1) \
 103   (OP (0, type0) | OP (1, type1))
 104 #define OP3(type0, type1, type2) \
 105   (OP (0, type0) | OP (1, type1) | OP (2, type2))
 106 #define OP4(type0, type1, type2, type3) \
 107   (OP (0, type0) | OP (1, type1) | OP (2, type2) | OP (3, type3))
 108
 109 #define OP_DST (1 << (TYPE_WIDTH * 5))
 110
 111 #define WORD_TYPE(n, word) \
 112   (((word) >> ((n) * TYPE_WIDTH)) & ((1 << TYPE_WIDTH) - 1))
 113
 114 struct scm_rtl_instruction {
 115   enum scm_rtl_opcode opcode;   /* opcode */
 116   const char *name;             /* instruction name */
 117   scm_t_uint32 meta;
 118   SCM symname;                  /* filled in later */
 119 };
 120
 121
 122 #define SCM_VALIDATE_LOOKUP_INSTRUCTION(pos, var, cvar)               \
 123   do {                                                                \
 124     cvar = scm_lookup_instruction_by_name (var);                      \
 125     SCM_ASSERT_TYPE (cvar, var, pos, FUNC_NAME, "INSTRUCTION_P");     \
 126   } while (0)
 127
 128
 129 static scm_i_pthread_mutex_t itable_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 130
 131
 132 static const struct scm_instruction*
 133 fetch_instruction_table ()
 134 {
 135   static struct scm_instruction *table = NULL;
 136
 137   scm_i_pthread_mutex_lock (&itable_lock);
 138   if (SCM_UNLIKELY (!table))
 139     {
 140       size_t bytes = SCM_VM_NUM_INSTRUCTIONS * sizeof(struct scm_instruction);
 141       int i;
 142       table = malloc (bytes);
 143       memset (table, 0, bytes);
 144 #define VM_INSTRUCTION_TO_TABLE 1
 145 #include <libguile/vm-expand.h>
 146 #include <libguile/vm-i-system.i>
 147 #include <libguile/vm-i-scheme.i>
 148 #include <libguile/vm-i-loader.i>
 149 #undef VM_INSTRUCTION_TO_TABLE
 150       for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
 151         {
 152           table[i].opcode = i;
 153           if (table[i].name)
 154             table[i].symname = scm_from_utf8_symbol (table[i].name);
 155           else
 156             table[i].symname = SCM_BOOL_F;
 157         }
 158     }
 159   scm_i_pthread_mutex_unlock (&itable_lock);
 160
 161   return table;
 162 }
 163
 164 static const struct scm_rtl_instruction*
 165 fetch_rtl_instruction_table ()
 166 {
 167   static struct scm_rtl_instruction *table = NULL;
 168
 169   scm_i_pthread_mutex_lock (&itable_lock);
 170   if (SCM_UNLIKELY (!table))
 171     {
 172       size_t bytes = SCM_VM_NUM_INSTRUCTIONS * sizeof(struct scm_rtl_instruction);
 173       int i;
 174       table = malloc (bytes);
 175       memset (table, 0, bytes);
 176
 177 #define INIT(opcode, tag, name_, meta_) table[opcode].name = name_; table[opcode].meta = meta_;
 178       FOR_EACH_VM_OPERATION (INIT);
 179 #undef INIT
 180
 181       for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
 182         {
 183           table[i].opcode = i;
 184           if (table[i].name)
 185             table[i].symname = scm_from_utf8_symbol (table[i].name);
 186           else
 187             table[i].symname = SCM_BOOL_F;
 188         }
 189     }
 190   scm_i_pthread_mutex_unlock (&itable_lock);
 191
 192   return table;
 193 }
 194
 195 static const struct scm_instruction *
 196 scm_lookup_instruction_by_name (SCM name)
 197 {
 198   static SCM instructions_by_name = SCM_BOOL_F;
 199   const struct scm_instruction *table = fetch_instruction_table ();
 200   SCM op;
 201
 202   if (SCM_UNLIKELY (scm_is_false (instructions_by_name)))
 203     {
 204       unsigned int i;
 205
 206       instructions_by_name =
 207         scm_make_hash_table (SCM_I_MAKINUM (SCM_VM_NUM_INSTRUCTIONS));
 208
 209       for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
 210         if (scm_is_true (table[i].symname))
 211           scm_hashq_set_x (instructions_by_name, table[i].symname,
 212                            SCM_I_MAKINUM (i));
 213     }
 214
 215   op = scm_hashq_ref (instructions_by_name, name, SCM_UNDEFINED);
 216   if (SCM_I_INUMP (op))
 217     return &table[SCM_I_INUM (op)];
 218
 219   return NULL;
 220 }
 221
 222
 223 /* Scheme interface */
 224
 225 SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0,
 226             (void),
 227             "")
 228 #define FUNC_NAME s_scm_instruction_list
 229 {
 230   SCM list = SCM_EOL;
 231   int i;
 232   const struct scm_instruction *ip = fetch_instruction_table ();
 233   for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
 234     if (ip[i].name)
 235       list = scm_cons (ip[i].symname, list);
 236   return scm_reverse_x (list, SCM_EOL);
 237 }
 238 #undef FUNC_NAME
 239
 240 SCM_DEFINE (scm_rtl_instruction_list, "rtl-instruction-list", 0, 0, 0,
 241             (void),
 242             "")
 243 #define FUNC_NAME s_scm_rtl_instruction_list
 244 {
 245   SCM list = SCM_EOL;
 246   int i;
 247   const struct scm_rtl_instruction *ip = fetch_rtl_instruction_table ();
 248   for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
 249     if (ip[i].name)
 250       {
 251         scm_t_uint32 meta = ip[i].meta;
 252         SCM tail = SCM_EOL;
 253         int len;
 254
 255         /* Format: (name opcode word0 word1 ...) */
 256
 257         if (WORD_TYPE (3, meta))
 258           len = 4;
 259         else if (WORD_TYPE (2, meta))
 260           len = 3;
 261         else if (WORD_TYPE (1, meta))
 262           len = 2;
 263         else if (WORD_TYPE (0, meta))
 264           len = 1;
 265         else
 266           abort ();
 267
 268         switch (len)
 269           {
 270           case 4:
 271             tail = scm_cons (word_type_symbols[WORD_TYPE (3, meta)], tail);
 272           case 3:
 273             tail = scm_cons (word_type_symbols[WORD_TYPE (2, meta)], tail);
 274           case 2:
 275             tail = scm_cons (word_type_symbols[WORD_TYPE (1, meta)], tail);
 276           case 1:
 277             tail = scm_cons (word_type_symbols[WORD_TYPE (0, meta)], tail);
 278           default:
 279             tail = scm_cons ((meta & OP_DST) ? sym_left_arrow : sym_bang, tail);
 280             tail = scm_cons (scm_from_int (ip[i].opcode), tail);
 281             tail = scm_cons (ip[i].symname, tail);
 282             break;
 283           }
 284
 285         list = scm_cons (tail, list);
 286       }
 287
 288   return scm_reverse_x (list, SCM_EOL);
 289 }
 290 #undef FUNC_NAME
 291
 292 SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0,
 293             (SCM obj),
 294             "")
 295 #define FUNC_NAME s_scm_instruction_p
 296 {
 297   return scm_from_bool (scm_lookup_instruction_by_name (obj) != NULL);
 298 }
 299 #undef FUNC_NAME
 300
 301 SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0,
 302             (SCM inst),
 303             "")
 304 #define FUNC_NAME s_scm_instruction_length
 305 {
 306   const struct scm_instruction *ip;
 307   SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
 308   return SCM_I_MAKINUM (ip->len);
 309 }
 310 #undef FUNC_NAME
 311
 312 SCM_DEFINE (scm_instruction_pops, "instruction-pops", 1, 0, 0,
 313             (SCM inst),
 314             "")
 315 #define FUNC_NAME s_scm_instruction_pops
 316 {
 317   const struct scm_instruction *ip;
 318   SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
 319   return SCM_I_MAKINUM (ip->npop);
 320 }
 321 #undef FUNC_NAME
 322
 323 SCM_DEFINE (scm_instruction_pushes, "instruction-pushes", 1, 0, 0,
 324             (SCM inst),
 325             "")
 326 #define FUNC_NAME s_scm_instruction_pushes
 327 {
 328   const struct scm_instruction *ip;
 329   SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
 330   return SCM_I_MAKINUM (ip->npush);
 331 }
 332 #undef FUNC_NAME
 333
 334 SCM_DEFINE (scm_instruction_to_opcode, "instruction->opcode", 1, 0, 0,
 335             (SCM inst),
 336             "")
 337 #define FUNC_NAME s_scm_instruction_to_opcode
 338 {
 339   const struct scm_instruction *ip;
 340   SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
 341   return SCM_I_MAKINUM (ip->opcode);
 342 }
 343 #undef FUNC_NAME
 344
 345 SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0,
 346             (SCM op),
 347             "")
 348 #define FUNC_NAME s_scm_opcode_to_instruction
 349 {
 350   scm_t_signed_bits opcode;
 351   SCM ret = SCM_BOOL_F;
 352
 353   SCM_MAKE_VALIDATE (1, op, I_INUMP);
 354   opcode = SCM_I_INUM (op);
 355
 356   if (opcode >= 0 && opcode < SCM_VM_NUM_INSTRUCTIONS)
 357     ret = fetch_instruction_table ()[opcode].symname;
 358
 359   if (scm_is_false (ret))
 360     scm_wrong_type_arg_msg (FUNC_NAME, 1, op, "INSTRUCTION_P");
 361
 362   return ret;
 363 }
 364 #undef FUNC_NAME
 365
 366 void
 367 scm_bootstrap_instructions (void)
 368 {
 369   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
 370                             "scm_init_instructions",
 371                             (scm_t_extension_init_func)scm_init_instructions,
 372                             NULL);
 373
 374 #define INIT(type) \
 375   word_type_symbols[type] = scm_from_utf8_symbol (#type);
 376     FOR_EACH_INSTRUCTION_WORD_TYPE (INIT)
 377 #undef INIT
 378 }
 379
 380 void
 381 scm_init_instructions (void)
 382 {
 383 #ifndef SCM_MAGIC_SNARFER
 384 #include "libguile/instructions.x"
 385 #endif
 386 }
 387
 388 /*
 389   Local Variables:
 390   c-file-style: "gnu"
 391   End:
 392 */