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 SCM_SYMBOL (sym_left_arrow, "<-");
  31 SCM_SYMBOL (sym_bang, "!");
  32
  33
  34 #define OP_HAS_ARITY (1U << 0)
  35
  36 #define FOR_EACH_INSTRUCTION_WORD_TYPE(M)       \
  37     M(X32)                                      \
  38     M(U8_X24)                                   \
  39     M(U8_U24)                                   \
  40     M(U8_L24)                                   \
  41     M(U8_U8_I16)                                \
  42     M(U8_U8_U8_U8)                              \
  43     M(U8_U12_U12)                               \
  44     M(U32) /* Unsigned. */                      \
  45     M(I32) /* Immediate. */                     \
  46     M(A32) /* Immediate, high bits. */          \
  47     M(B32) /* Immediate, low bits. */           \
  48     M(N32) /* Non-immediate. */                 \
  49     M(S32) /* Scheme value (indirected). */     \
  50     M(L32) /* Label. */                         \
  51     M(LO32) /* Label with offset. */            \
  52     M(X8_U24)                                   \
  53     M(X8_U12_U12)                               \
  54     M(X8_L24)                                   \
  55     M(B1_X7_L24)                                \
  56     M(B1_U7_L24)                                \
  57     M(B1_X7_U24)                                \
  58     M(B1_X31)
  59
  60 #define TYPE_WIDTH 5
  61
  62 enum word_type
  63   {
  64 #define ENUM(type) type,
  65     FOR_EACH_INSTRUCTION_WORD_TYPE (ENUM)
  66 #undef ENUM
  67   };
  68
  69 static SCM word_type_symbols[] =
  70   {
  71 #define FALSE(type) SCM_BOOL_F,
  72     FOR_EACH_INSTRUCTION_WORD_TYPE (FALSE)
  73 #undef FALSE
  74   };
  75
  76 #define OP(n,type) ((type) << (n*TYPE_WIDTH))
  77
  78 /* The VM_DEFINE_OP macro uses a CPP-based DSL to describe what kinds of
  79    arguments each instruction takes.  This piece of code is the only
  80    bit that actually interprets that language.  These macro definitions
  81    encode the operand types into bits in a 32-bit integer.
  82
  83    (instruction-list) parses those encoded values into lists of symbols,
  84    one for each 32-bit word that the operator takes.  This list is used
  85    by Scheme to generate assemblers and disassemblers for the
  86    instructions.  */
  87
  88 #define OP1(type0) \
  89   (OP (0, type0))
  90 #define OP2(type0, type1) \
  91   (OP (0, type0) | OP (1, type1))
  92 #define OP3(type0, type1, type2) \
  93   (OP (0, type0) | OP (1, type1) | OP (2, type2))
  94 #define OP4(type0, type1, type2, type3) \
  95   (OP (0, type0) | OP (1, type1) | OP (2, type2) | OP (3, type3))
  96 #define OP5(type0, type1, type2, type3, type4) \
  97   (OP (0, type0) | OP (1, type1) | OP (2, type2) | OP (3, type3) | OP (4, type4))
  98
  99 #define OP_DST (1 << (TYPE_WIDTH * 5))
 100
 101 #define WORD_TYPE(n, word) \
 102   (((word) >> ((n) * TYPE_WIDTH)) & ((1 << TYPE_WIDTH) - 1))
 103
 104 struct scm_instruction {
 105   enum scm_rtl_opcode opcode;   /* opcode */
 106   const char *name;             /* instruction name */
 107   scm_t_uint32 meta;
 108   SCM symname;                  /* filled in later */
 109 };
 110
 111
 112 static scm_i_pthread_mutex_t itable_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 113
 114
 115 static const struct scm_instruction*
 116 fetch_instruction_table ()
 117 {
 118   static struct scm_instruction *table = NULL;
 119
 120   scm_i_pthread_mutex_lock (&itable_lock);
 121   if (SCM_UNLIKELY (!table))
 122     {
 123       size_t bytes = SCM_VM_NUM_INSTRUCTIONS * sizeof(struct scm_instruction);
 124       int i;
 125       table = malloc (bytes);
 126       memset (table, 0, bytes);
 127
 128 #define INIT(opcode, tag, name_, meta_) table[opcode].name = name_; table[opcode].meta = meta_;
 129       FOR_EACH_VM_OPERATION (INIT);
 130 #undef INIT
 131
 132       for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
 133         {
 134           table[i].opcode = i;
 135           if (table[i].name)
 136             table[i].symname = scm_from_utf8_symbol (table[i].name);
 137           else
 138             table[i].symname = SCM_BOOL_F;
 139         }
 140     }
 141   scm_i_pthread_mutex_unlock (&itable_lock);
 142
 143   return table;
 144 }
 145
 146
 147 /* Scheme interface */
 148
 149 SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0,
 150             (void),
 151             "")
 152 #define FUNC_NAME s_scm_instruction_list
 153 {
 154   SCM list = SCM_EOL;
 155   int i;
 156   const struct scm_instruction *ip = fetch_instruction_table ();
 157   for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
 158     if (ip[i].name)
 159       {
 160         scm_t_uint32 meta = ip[i].meta;
 161         SCM tail = SCM_EOL;
 162         int len;
 163
 164         /* Format: (name opcode word0 word1 ...) */
 165
 166         if (WORD_TYPE (4, meta))
 167           len = 5;
 168         else if (WORD_TYPE (3, meta))
 169           len = 4;
 170         else if (WORD_TYPE (2, meta))
 171           len = 3;
 172         else if (WORD_TYPE (1, meta))
 173           len = 2;
 174         else if (WORD_TYPE (0, meta))
 175           len = 1;
 176         else
 177           abort ();
 178
 179         switch (len)
 180           {
 181           case 5:
 182             tail = scm_cons (word_type_symbols[WORD_TYPE (4, meta)], tail);
 183           case 4:
 184             tail = scm_cons (word_type_symbols[WORD_TYPE (3, meta)], tail);
 185           case 3:
 186             tail = scm_cons (word_type_symbols[WORD_TYPE (2, meta)], tail);
 187           case 2:
 188             tail = scm_cons (word_type_symbols[WORD_TYPE (1, meta)], tail);
 189           case 1:
 190             tail = scm_cons (word_type_symbols[WORD_TYPE (0, meta)], tail);
 191           default:
 192             tail = scm_cons ((meta & OP_DST) ? sym_left_arrow : sym_bang, tail);
 193             tail = scm_cons (scm_from_int (ip[i].opcode), tail);
 194             tail = scm_cons (ip[i].symname, tail);
 195             break;
 196           }
 197
 198         list = scm_cons (tail, list);
 199       }
 200
 201   return scm_reverse_x (list, SCM_EOL);
 202 }
 203 #undef FUNC_NAME
 204
 205 void
 206 scm_bootstrap_instructions (void)
 207 {
 208   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
 209                             "scm_init_instructions",
 210                             (scm_t_extension_init_func)scm_init_instructions,
 211                             NULL);
 212 }
 213
 214 void
 215 scm_init_instructions (void)
 216 {
 217 #define INIT(type) \
 218   word_type_symbols[type] = scm_from_utf8_symbol (#type);
 219     FOR_EACH_INSTRUCTION_WORD_TYPE (INIT)
 220 #undef INIT
 221
 222 #ifndef SCM_MAGIC_SNARFER
 223 #include "libguile/instructions.x"
 224 #endif
 225 }
 226
 227 /*
 228   Local Variables:
 229   c-file-style: "gnu"
 230   End:
 231 */