1 /* -*-C-*- 2 3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts 6 Institute of Technology 7 8 This file is part of MIT/GNU Scheme. 9 10 MIT/GNU Scheme is free software; you can redistribute it and/or modify 11 it under the terms of the GNU General Public License as published by 12 the Free Software Foundation; either version 2 of the License, or (at 13 your option) any later version. 14 15 MIT/GNU Scheme is distributed in the hope that it will be useful, but 16 WITHOUT ANY WARRANTY; without even the implied warranty of 17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 18 General Public License for more details. 19 20 You should have received a copy of the GNU General Public License 21 along with MIT/GNU Scheme; if not, write to the Free Software 22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 23 USA. 24 25 */ 26 27 #ifndef SCM_LIARC_H_INCLUDED 28 #define SCM_LIARC_H_INCLUDED 1 29 30 #ifndef MIT_SCHEME 31 # define MIT_SCHEME 32 #endif 33 34 #include "config.h" 35 #include "dstack.h" 36 #include "types.h" 37 #include "const.h" 38 #include "object.h" 39 #include "sdata.h" 40 #include "fixnum.h" 41 #include "errors.h" 42 #include "stack.h" 43 #include "interp.h" 44 #include "outf.h" 45 #include "extern.h" 46 #include "prim.h" 47 #include "cmpint.h" 48 #include "trap.h" 49 50 extern SCHEME_OBJECT * sp_register; 51 52 #define DEFLABEL(name) name : ATTRIBUTE((unused)) 53 54 union machine_word_u 55 { 56 SCHEME_OBJECT Obj; 57 SCHEME_OBJECT * pObj; 58 long Lng; 59 char * pChr; 60 unsigned long uLng; 61 double * pDbl; 62 }; 63 64 typedef union machine_word_u machine_word; 65 typedef unsigned long entry_count_t; 66 67 #define ADDRESS_UNITS_PER_OBJECT SIZEOF_SCHEME_OBJECT 68 #define ADDRESS_UNITS_PER_FLOAT (sizeof (double)) 69 70 #define CLOSURE_ENTRY_DELTA 1 71 72 #undef FIXNUM_TO_LONG 73 #define FIXNUM_TO_LONG(source) \ 74 ((((long) (source)) << TYPE_CODE_LENGTH) >> TYPE_CODE_LENGTH) 75 76 #define ADDRESS_TO_LONG(source) ((long) (source)) 77 78 #define LONG_TO_ADDRESS(source) (DATUM_TO_ADDRESS (source)) 79 80 #define C_STRING_TO_SCHEME_STRING(len, str) \ 81 (MEMORY_TO_STRING ((len), ((const byte_t *) (str)))) 82 83 #define C_SYM_INTERN(len, str) \ 84 (MEMORY_TO_SYMBOL ((len), ((const byte_t *) (str)))) 85 86 #define MAKE_PRIMITIVE_PROCEDURE(name, arity) (MAKE_PRIMITIVE (name, arity)) 87 88 #define WRITE_LABEL_DESCRIPTOR(entry, code_word, offset) \ 89 ((entry[-1]) = (MAKE_LABEL_DESCRIPTOR ((code_word), (offset)))) 90 91 #define MAKE_LABEL_DESCRIPTOR(code_word, offset) \ 92 ((insn_t) (((offset) << 17) | (code_word))) 93 94 #define MAKE_LINKER_HEADER(kind, count) \ 95 (OBJECT_NEW_TYPE (TC_FIXNUM, \ 96 (make_linkage_section_marker ((kind), (count))))) 97 98 #define ALLOCATE_VECTOR(len) (MAKE_VECTOR ((len), SHARP_F, true)) 99 100 #define ALLOCATE_RECORD(len) \ 101 (OBJECT_NEW_TYPE (TC_RECORD, (ALLOCATE_VECTOR (len)))) 102 103 #define RECORD_SET(rec, off, val) VECTOR_SET ((rec), (off), (val)) 104 105 #define INLINE_DOUBLE_TO_FLONUM(src, tgt) do \ 106 { \ 107 double num = (src); \ 108 SCHEME_OBJECT * val; \ 109 \ 110 ALIGN_FLOAT (Rhp); \ 111 val = Rhp; \ 112 Rhp += (1 + (BYTES_TO_WORDS (sizeof (double)))); \ 113 (*val) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, \ 114 (BYTES_TO_WORDS (sizeof (double))))); \ 115 (* ((double *) (val + 1))) = num; \ 116 (tgt) = (MAKE_POINTER_OBJECT (TC_BIG_FLONUM, (val))); \ 117 } while (false) 118 119 #define MAKE_RATIO(num, den) \ 120 (OBJECT_NEW_TYPE (TC_RATNUM, (CONS ((num), (den))))) 121 122 #define MAKE_COMPLEX(real, imag) \ 123 (OBJECT_NEW_TYPE (TC_COMPLEX, (CONS ((real), (imag))))) 124 125 #define CC_BLOCK_TO_ENTRY(block, offset) \ 126 (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, \ 127 ((OBJECT_ADDRESS (block)) + (offset)))) 128 129 #define INDEX_FIXNUM_P(arg) ((FIXNUM_P(arg)) && (FIXNUM_TO_ULONG_P (arg))) 130 131 #ifdef LIARC_IN_MICROCODE 132 133 #define Rvl (Registers[REGBLOCK_VAL]) 134 #define Rhp Free 135 #define Rrb Registers 136 #define Rsp stack_pointer 137 138 #define DECLARE_VARIABLES() int unused_variable_to_keep_C_happy 139 #define UNCACHE_VARIABLES() do {} while (false) 140 #define CACHE_VARIABLES() do {} while (false) 141 142 #else /* !LIARC_IN_MICROCODE */ 143 144 #define Rrb Registers 145 146 #undef MEMBASE 147 #define MEMBASE lcl_membase 148 149 #define DECLARE_VARIABLES() \ 150 SCHEME_OBJECT Rvl = GET_VAL; \ 151 SCHEME_OBJECT * Rhp = Free; \ 152 SCHEME_OBJECT * Rsp = stack_pointer; \ 153 SCHEME_OBJECT * lcl_membase = memory_base 154 155 #define DECLARE_VARIABLES_FOR_DATA() \ 156 SCHEME_OBJECT * lcl_membase = memory_base 157 158 #define DECLARE_VARIABLES_FOR_OBJECT() 159 160 /* lcl_membase is not cached/uncached because it is a constant */ 161 162 #define UNCACHE_VARIABLES() do \ 163 { \ 164 stack_pointer = Rsp; \ 165 Free = Rhp; \ 166 SET_VAL (Rvl); \ 167 } while (false) 168 169 #define CACHE_VARIABLES() do \ 170 { \ 171 Rvl = GET_VAL; \ 172 Rhp = Free; \ 173 Rsp = stack_pointer; \ 174 } while (false) 175 176 #endif /* !LIARC_IN_MICROCODE */ 177 178 #ifdef ENABLE_DEBUGGING_TOOLS 179 180 #define JUMP(destination) do \ 181 { \ 182 SCHEME_OBJECT * JUMP_new_pc = (destination); \ 183 assert (JUMP_new_pc != 0); \ 184 Rpc = JUMP_new_pc; \ 185 goto perform_dispatch; \ 186 } while (false) 187 188 #else 189 190 #define JUMP(destination) do \ 191 { \ 192 Rpc = (destination); \ 193 goto perform_dispatch; \ 194 } while (false) 195 196 #endif 197 198 #define POP_RETURN() goto pop_return 199 200 #define INVOKE_PRIMITIVE_DECLS 201 #define INVOKE_PRIMITIVE_TARGET 202 203 #define INVOKE_PRIMITIVE(prim, nargs) do \ 204 { \ 205 SCHEME_OBJECT * IPdest; \ 206 \ 207 UNCACHE_VARIABLES (); \ 208 PRIMITIVE_APPLY (prim); \ 209 POP_PRIMITIVE_FRAME (nargs); \ 210 IPdest = (OBJECT_ADDRESS (STACK_POP ())); \ 211 CACHE_VARIABLES (); \ 212 JUMP (IPdest); \ 213 } while (false) 214 215 #define INVOKE_INTERFACE_DECLS 216 #define INVOKE_INTERFACE_TARGET_0 217 #define INVOKE_INTERFACE_TARGET_1 218 #define INVOKE_INTERFACE_TARGET_2 219 #define INVOKE_INTERFACE_TARGET_3 220 #define INVOKE_INTERFACE_TARGET_4 221 222 #define INVOKE_INTERFACE_0(code) \ 223 INVOKE_INTERFACE_4 (code, 0, 0, 0, 0) 224 225 #define INVOKE_INTERFACE_1(code, one) \ 226 INVOKE_INTERFACE_4 (code, one, 0, 0, 0) 227 228 #define INVOKE_INTERFACE_2(code, one, two) \ 229 INVOKE_INTERFACE_4 (code, one, two, 0, 0) 230 231 #define INVOKE_INTERFACE_3(code, one, two, three) \ 232 INVOKE_INTERFACE_4 (code, one, two, three, 0) 233 234 #define INVOKE_INTERFACE_4(code, one, two, three, four) do \ 235 { \ 236 SCHEME_OBJECT * IICdest; \ 237 \ 238 UNCACHE_VARIABLES (); \ 239 IICdest \ 240 = (invoke_utility ((code), \ 241 ((unsigned long) (one)), \ 242 ((unsigned long) (two)), \ 243 ((unsigned long) (three)), \ 244 ((unsigned long) (four)))); \ 245 CACHE_VARIABLES (); \ 246 JUMP (IICdest); \ 247 } while (false) 248 249 #define INTERRUPT_CHECK(code, entry_point) do \ 250 { \ 251 if ((((long) Rhp) >= ((long) GET_MEMTOP)) \ 252 || (((long) Rsp) < ((long) GET_STACK_GUARD))) \ 253 INVOKE_INTERFACE_1 (code, (¤t_block[entry_point])); \ 254 } while (false) 255 256 #define DLINK_INTERRUPT_CHECK(code, entry_point) do \ 257 { \ 258 if ((((long) Rhp) >= ((long) GET_MEMTOP)) \ 259 || (((long) Rsp) < ((long) GET_STACK_GUARD))) \ 260 INVOKE_INTERFACE_2 (code, (¤t_block[entry_point]), Rdl); \ 261 } while (false) 262 263 #define CLOSURE_INTERRUPT_CHECK(code) do \ 264 { \ 265 if ((((long) Rhp) >= ((long) GET_MEMTOP)) \ 266 || (((long) Rsp) < ((long) GET_STACK_GUARD))) \ 267 INVOKE_INTERFACE_0 (code); \ 268 } while (false) 269 270 #define CLOSURE_HEADER(offset) do \ 271 { \ 272 SCHEME_OBJECT * entry = ((SCHEME_OBJECT *) (Rpc[1])); \ 273 current_block = (entry - offset); \ 274 (*--Rsp) = (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, Rpc)); \ 275 } while (false) 276 277 /* Linking and initialization */ 278 279 typedef int liarc_decl_code_t (void); 280 typedef int liarc_decl_data_t (void); 281 typedef SCHEME_OBJECT * liarc_code_proc_t (SCHEME_OBJECT *, entry_count_t); 282 typedef SCHEME_OBJECT * liarc_data_proc_t (entry_count_t); 283 typedef SCHEME_OBJECT liarc_object_proc_t (void); 284 285 struct liarc_code_S 286 { 287 const char * name; 288 entry_count_t nentries; 289 liarc_code_proc_t * code; 290 }; 291 292 struct liarc_data_S 293 { 294 const char * name; 295 liarc_data_proc_t * data; 296 }; 297 298 #define DECLARE_SUBCODE(name, nentries, code) do \ 299 { \ 300 int result = (declare_compiled_code_ns (name, nentries, code)); \ 301 if (result != 0) \ 302 return (result); \ 303 } while (false) 304 305 #define DECLARE_SUBDATA(name, data) do \ 306 { \ 307 int result = (declare_compiled_data_ns (name, data)); \ 308 if (result != 0) \ 309 return (result); \ 310 } while (false) 311 312 #define DECLARE_SUBCODE_MULTIPLE(code_array) do \ 313 { \ 314 int result \ 315 = (declare_compiled_code_mult \ 316 (((sizeof (code_array)) / (sizeof (struct liarc_code_S))), \ 317 code_array)); \ 318 if (result != 0) \ 319 return (result); \ 320 } while (false) 321 322 #define DECLARE_SUBDATA_MULTIPLE(data_array) do \ 323 { \ 324 int result \ 325 = (declare_compiled_data_mult \ 326 (((sizeof (data_array)) / (sizeof (struct liarc_data_S))), \ 327 data_array)); \ 328 if (result != 0) \ 329 return (result); \ 330 } while (false) 331 332 #ifdef ENABLE_LIARC_FILE_INIT 333 334 #define DECLARE_COMPILED_CODE(name, nentries, decl_code, code) \ 335 static int \ 336 dload_initialize_code (void) \ 337 { \ 338 return (declare_compiled_code (name, nentries, decl_code, code)); \ 339 } 340 341 #define DECLARE_COMPILED_DATA(name, decl_data, data) \ 342 static int \ 343 dload_initialize_data (void) \ 344 { \ 345 return (declare_compiled_data (name, decl_data, data)); \ 346 } 347 348 #define DECLARE_COMPILED_DATA_NS(name, data) \ 349 static int \ 350 dload_initialize_data (void) \ 351 { \ 352 return (declare_compiled_data_ns (name, data)); \ 353 } 354 355 #define DECLARE_DATA_OBJECT(name, data) \ 356 static int \ 357 dload_initialize_data (void) \ 358 { \ 359 return (declare_data_object (name, data)); \ 360 } 361 362 #define DECLARE_DYNAMIC_INITIALIZATION(name, nonce) \ 363 const char dload_nonce [] = nonce; \ 364 \ 365 const char * \ 366 dload_initialize_file (void) \ 367 { \ 368 return \ 369 ((((dload_initialize_code ()) == 0) \ 370 && ((dload_initialize_data ()) == 0)) \ 371 ? (liarc_object_file_name (name)) \ 372 : 0); \ 373 } 374 375 #define DECLARE_DYNAMIC_OBJECT_INITIALIZATION(name, nonce) \ 376 const char dload_nonce [] = nonce; \ 377 \ 378 const char * \ 379 dload_initialize_file (void) \ 380 { \ 381 return \ 382 (((dload_initialize_data ()) == 0) \ 383 ? (liarc_object_file_name (name)) \ 384 : 0); \ 385 } 386 387 #else /* !ENABLE_LIARC_FILE_INIT */ 388 389 #define DECLARE_COMPILED_CODE(name, nentries, decl_code, code) 390 #define DECLARE_COMPILED_DATA(name, decl_data, data) 391 #define DECLARE_COMPILED_DATA_NS(name, data) 392 #define DECLARE_DATA_OBJECT(name, data) 393 #define DECLARE_DYNAMIC_INITIALIZATION(name, nonce) 394 #define DECLARE_DYNAMIC_OBJECT_INITIALIZATION(name, nonce) 395 396 #endif /* !ENABLE_LIARC_FILE_INIT */ 397 398 extern SCHEME_OBJECT initialize_subblock (const char *); 399 400 extern SCHEME_OBJECT * invoke_utility 401 (unsigned int, unsigned long, unsigned long, unsigned long, unsigned long); 402 403 extern int declare_compiled_code 404 (const char *, entry_count_t, liarc_decl_code_t *, liarc_code_proc_t *); 405 406 extern int declare_compiled_code_ns 407 (const char *, entry_count_t, liarc_code_proc_t *); 408 409 extern int declare_compiled_data 410 (const char *, liarc_decl_data_t *, liarc_data_proc_t *); 411 412 extern int declare_compiled_data_ns (const char *, liarc_data_proc_t *); 413 extern int declare_data_object (const char *, liarc_object_proc_t *); 414 extern int declare_compiled_code_mult (unsigned, const struct liarc_code_S *); 415 extern int declare_compiled_data_mult (unsigned, const struct liarc_data_S *); 416 417 extern const char * liarc_object_file_name (const char *); 418 419 extern SCHEME_OBJECT unstackify (unsigned char *, size_t, entry_count_t); 420 421 extern int multiply_with_overflow (long, long, long *); 422 423 #define DOUBLE_ACOS acos 424 #define DOUBLE_ASIN asin 425 #define DOUBLE_ATAN atan 426 #define DOUBLE_CEILING ceil 427 #define DOUBLE_COS cos 428 #define DOUBLE_EXP exp 429 #define DOUBLE_EXPM1 expm1 430 #define DOUBLE_FLOOR floor 431 #define DOUBLE_LOG log 432 #define DOUBLE_LOG1P log1p 433 #define DOUBLE_SIN sin 434 #define DOUBLE_SQRT sqrt 435 #define DOUBLE_TAN tan 436 #define DOUBLE_TRUNCATE double_truncate 437 #define DOUBLE_ROUND double_round 438 #define DOUBLE_ATAN2 atan2 439 440 #define MAKE_PRIMITIVE(str, arity) \ 441 (make_primitive (((const char *) (str)), ((int) (arity)))) 442 443 #define MEMORY_TO_STRING memory_to_string 444 #define MEMORY_TO_SYMBOL memory_to_symbol 445 #define MAKE_VECTOR make_vector 446 #define CONS cons 447 #define RCONSM rconsm 448 #define DOUBLE_TO_FLONUM double_to_flonum 449 #define LONG_TO_INTEGER long_to_integer 450 #define C_TO_UNINTERNED_SYMBOL memory_to_uninterned_symbol 451 #define DIGIT_STRING_TO_INTEGER digit_string_to_integer 452 #define DIGIT_STRING_TO_BIT_STRING digit_string_to_bit_string 453 454 extern SCHEME_OBJECT rconsm (unsigned int, SCHEME_OBJECT, ...); 455 extern SCHEME_OBJECT memory_to_uninterned_symbol (unsigned long, const void *); 456 457 extern SCHEME_OBJECT digit_string_to_integer 458 (bool, unsigned long, const char *); 459 460 extern SCHEME_OBJECT digit_string_to_bit_string 461 (unsigned long, unsigned long, const char *); 462 463 #endif /* !SCM_LIARC_H_INCLUDED */ 464