~ubuntu-branches/ubuntu/intrepid/mit-scheme/intrepid-updates

« back to all changes in this revision

Viewing changes to src/microcode/cmpintmd/hppa.h

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2002-03-14 17:04:07 UTC
  • Revision ID: james.westby@ubuntu.com-20020314170407-m5lg1d6bdsl9lv0s
Tags: upstream-7.7.0
ImportĀ upstreamĀ versionĀ 7.7.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
 
1
/* -*-C-*-
 
2
 
 
3
$Id: hppa.h,v 1.51 1999/01/02 06:06:43 cph Exp $
 
4
 
 
5
Copyright (c) 1989-1999 Massachusetts Institute of Technology
 
6
 
 
7
This program is free software; you can redistribute it and/or modify
 
8
it under the terms of the GNU General Public License as published by
 
9
the Free Software Foundation; either version 2 of the License, or (at
 
10
your option) any later version.
 
11
 
 
12
This program is distributed in the hope that it will be useful, but
 
13
WITHOUT ANY WARRANTY; without even the implied warranty of
 
14
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 
15
General Public License for more details.
 
16
 
 
17
You should have received a copy of the GNU General Public License
 
18
along with this program; if not, write to the Free Software
 
19
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
20
*/
 
21
 
 
22
/*
 
23
 *
 
24
 * Compiled code interface macros.
 
25
 *
 
26
 * See cmpint.txt for a description of these fields.
 
27
 *
 
28
 * Specialized for the HP Precision Architecture (Spectrum)
 
29
 */
 
30
 
 
31
#ifndef CMPINTMD_H_INCLUDED
 
32
#define CMPINTMD_H_INCLUDED
 
33
 
 
34
#include "cmptype.h"
 
35
#include "hppacach.h"
 
36
 
 
37
/* Machine parameters to be set by the user. */
 
38
 
 
39
/* Until cmpaux-hppa.m4 is updated. */
 
40
#define CMPINT_USE_STRUCS
 
41
 
 
42
/* Processor type.  Choose a number from the above list, or allocate your own. */
 
43
 
 
44
#define COMPILER_PROCESSOR_TYPE                 COMPILER_SPECTRUM_TYPE
 
45
 
 
46
/* Size (in long words) of the contents of a floating point register if
 
47
   different from a double.  For example, an MC68881 saves registers
 
48
   in 96 bit (3 longword) blocks.
 
49
   Default is fine for PA.
 
50
   define COMPILER_TEMP_SIZE                    3
 
51
*/
 
52
 
 
53
/* Descriptor size.
 
54
   This is the size of the offset field, and of the format field.
 
55
   This definition probably does not need to be changed.
 
56
 */
 
57
 
 
58
typedef unsigned short format_word;
 
59
 
 
60
/* PC alignment constraint.
 
61
   Change PC_ZERO_BITS to be how many low order bits of the pc are
 
62
   guaranteed to be 0 always because of PC alignment constraints.
 
63
*/
 
64
 
 
65
#define PC_ZERO_BITS                    2
 
66
 
 
67
/* C function pointers are pairs of instruction addreses and data segment
 
68
   pointers.  We don't want that for the assembly language entry points.
 
69
 */
 
70
 
 
71
#define C_FUNC_PTR_IS_CLOSURE
 
72
 
 
73
#ifndef C_FUNC_PTR_IS_CLOSURE
 
74
#  define interface_to_C ep_interface_to_C
 
75
#  define interface_to_scheme ep_interface_to_scheme
 
76
#endif
 
77
 
 
78
/* Utilities for manipulating absolute subroutine calls.
 
79
   On the PA the absolute address is "smeared out" over two
 
80
   instructions, an LDIL and a BLE instruction.
 
81
 */
 
82
 
 
83
extern unsigned long
 
84
  EXFUN (hppa_extract_absolute_address, (unsigned long *));
 
85
 
 
86
extern void
 
87
  EXFUN (hppa_store_absolute_address,
 
88
         (unsigned long *, unsigned long, unsigned long));
 
89
 
 
90
#define EXTRACT_ABSOLUTE_ADDRESS(target, address)                       \
 
91
{                                                                       \
 
92
  (target) =                                                            \
 
93
    ((SCHEME_OBJECT)                                                    \
 
94
     (hppa_extract_absolute_address ((unsigned long *) (address))));    \
 
95
}
 
96
 
 
97
#define STORE_ABSOLUTE_ADDRESS(entry_point, address, nullify_p)         \
 
98
{                                                                       \
 
99
  hppa_store_absolute_address (((unsigned long *) (address)),           \
 
100
                               ((unsigned long) (entry_point)),         \
 
101
                               ((unsigned long) (nullify_p)));          \
 
102
}
 
103
 
 
104
/* Interrupt/GC polling. */
 
105
 
 
106
/* The length of the GC recovery code that precedes an entry.
 
107
   On the HP-PA a "ble, ldi" instruction sequence.
 
108
 */
 
109
 
 
110
#define ENTRY_PREFIX_LENGTH             8
 
111
 
 
112
/*
 
113
  The instructions for a normal entry should be something like
 
114
 
 
115
  COMBT,>=,N    Rfree,Rmemtop,interrupt
 
116
  LDW           0(0,Regs),Rmemtop
 
117
 
 
118
  For a closure
 
119
 
 
120
  DEPI          tc_closure>>1,4,5,25            ; set type code
 
121
  STWM          25,-4(0,Rstack)                 ; push on stack
 
122
  COMB,>=       Rfree,Rmemtop,interrupt         ; GC/interrupt check
 
123
  LDW           0(0,Regs),Rmemtop               ; Recache memtop
 
124
 
 
125
  Notes:
 
126
 
 
127
  The LDW can be eliminated once the C interrupt handler is changed to
 
128
  update Rmemtop directly.  At that point, the instruction following the
 
129
  COMB instruction will have to be nullified whenever the interrupt
 
130
  branch is processed.
 
131
 
 
132
 */
 
133
 
 
134
/* Compiled closures */
 
135
 
 
136
/* Manifest closure entry block size.
 
137
   Size in bytes of a compiled closure's header excluding the
 
138
   TC_MANIFEST_CLOSURE header.
 
139
 
 
140
   On the PA this is 2 format_words for the format word and gc
 
141
   offset words, and 12 more bytes for 3 instructions:
 
142
 
 
143
   LDIL         L'target,26
 
144
   BLE          R'target(5,26)
 
145
   ADDI         -15,31,25               ; handle privilege bits
 
146
 */
 
147
 
 
148
#define COMPILED_CLOSURE_ENTRY_SIZE     16
 
149
 
 
150
/* Manifest closure entry destructuring.
 
151
 
 
152
   Given the entry point of a closure, extract the `real entry point'
 
153
   (the address of the real code of the procedure, ie. one indirection)
 
154
   from the closure.
 
155
   On the PA, the real entry point is "smeared out" over the LDIL and
 
156
   the BLE instructions.
 
157
*/
 
158
 
 
159
#define EXTRACT_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point)    \
 
160
{                                                                       \
 
161
  EXTRACT_ABSOLUTE_ADDRESS (real_entry_point, entry_point);             \
 
162
}
 
163
 
 
164
/* This is the inverse of EXTRACT_CLOSURE_ENTRY_ADDRESS.
 
165
   Given a closure's entry point and a code entry point, store the
 
166
   code entry point in the closure.
 
167
 */
 
168
 
 
169
#define STORE_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point)      \
 
170
{                                                                       \
 
171
  STORE_ABSOLUTE_ADDRESS (real_entry_point, entry_point, false);        \
 
172
}
 
173
 
 
174
/* Trampolines
 
175
 
 
176
   Here's a picture of a trampoline on the PA (offset in bytes from
 
177
   entry point)
 
178
 
 
179
     -12: MANIFEST vector header
 
180
     - 8: NON_MARKED header
 
181
     - 4: Format word
 
182
     - 2: 0xC (GC Offset to start of block from .+2)
 
183
       0: BLE   4(4,3)          ; call trampoline_to_interface
 
184
       4: LDI   index,28
 
185
       8: trampoline dependent storage (0 - 3 longwords)
 
186
 
 
187
   TRAMPOLINE_ENTRY_SIZE is the size in longwords of the machine
 
188
   dependent portion of a trampoline, including the GC and format
 
189
   headers.  The code in the trampoline must store an index (used to
 
190
   determine which C SCHEME_UTILITY procedure to invoke) in a
 
191
   register, jump to "scheme_to_interface" and leave the address of
 
192
   the storage following the code in a standard location.
 
193
 
 
194
   TRAMPOLINE_ENTRY_POINT returns the address of the entry point of a
 
195
   trampoline when given the address of the word containing
 
196
   the manifest vector header.  According to the above picture,
 
197
   it would add 12 bytes to its argument.
 
198
 
 
199
   TRAMPOLINE_STORAGE takes the address of the first instruction in a
 
200
   trampoline (not the start of the trampoline block) and returns the
 
201
   address of the first storage word in the trampoline.
 
202
 
 
203
   STORE_TRAMPOLINE_ENTRY gets the address of the first instruction in
 
204
   the trampoline and stores the instructions.  It also receives the
 
205
   index of the C SCHEME_UTILITY to be invoked.
 
206
 
 
207
   Note: this flushes both caches because the words may fall in a cache
 
208
   line that already has an association in the i-cache because a different
 
209
   trampoline or a closure are in it.
 
210
*/
 
211
 
 
212
#define TRAMPOLINE_ENTRY_SIZE           3
 
213
#define TRAMPOLINE_BLOCK_TO_ENTRY       3 /* longwords from MNV to BLE */
 
214
 
 
215
#define TRAMPOLINE_ENTRY_POINT(tramp_block)                             \
 
216
  (((SCHEME_OBJECT *) (tramp_block)) + TRAMPOLINE_BLOCK_TO_ENTRY)
 
217
 
 
218
#define TRAMPOLINE_STORAGE(tramp_entry)                                 \
 
219
  ((((SCHEME_OBJECT *) (tramp_entry)) - TRAMPOLINE_BLOCK_TO_ENTRY) +    \
 
220
   (2 + TRAMPOLINE_ENTRY_SIZE)) 
 
221
 
 
222
#define STORE_TRAMPOLINE_ENTRY(entry_address, index) do                 \
 
223
{                                                                       \
 
224
  extern void                                                           \
 
225
    EXFUN (cache_flush_region, (PTR, long, unsigned int));              \
 
226
                                                                        \
 
227
  unsigned long *PC;                                                    \
 
228
                                                                        \
 
229
  PC = ((unsigned long *) (entry_address));                             \
 
230
                                                                        \
 
231
  /*    BLE     4(4,3)          */                                      \
 
232
                                                                        \
 
233
  *PC = ((unsigned long) 0xe4602008);                                   \
 
234
                                                                        \
 
235
  /*    LDO     index(0),28     */                                      \
 
236
  /*    This assumes that index is >= 0. */                             \
 
237
                                                                        \
 
238
  *(PC + 1) = (((unsigned long) 0x341c0000) +                           \
 
239
               (((unsigned long) (index)) << 1));                       \
 
240
  cache_flush_region (PC, (TRAMPOLINE_ENTRY_SIZE - 1),                  \
 
241
                      (I_CACHE | D_CACHE));                             \
 
242
} while (0)
 
243
 
 
244
/* Execute cache entries.
 
245
 
 
246
   Execute cache entry size size in longwords.  The cache itself
 
247
   contains both the number of arguments provided by the caller and
 
248
   code to jump to the destination address.  Before linkage, the cache
 
249
   contains the callee's name instead of the jump code.
 
250
 
 
251
   On PA: 2 instructions, and a fixnum representing the number of arguments.
 
252
 */
 
253
 
 
254
#define EXECUTE_CACHE_ENTRY_SIZE        3
 
255
 
 
256
/* For the HPPA, addresses in bytes from the start of the cache:
 
257
 
 
258
   Before linking
 
259
 
 
260
     +0: TC_SYMBOL || symbol address
 
261
     +4: #F
 
262
     +8: TC_FIXNUM || 0
 
263
    +10: number of supplied arguments, +1
 
264
 
 
265
   After linking
 
266
 
 
267
     +0: LDIL   L'target,26
 
268
     +4: BLE,n  R'target(5,26)
 
269
     +8: (unchanged)
 
270
    +10: (unchanged)
 
271
 
 
272
   Important:
 
273
 
 
274
     Currently the code below unconditionally nullifies the delay-slot
 
275
     instruction for the BLE instruction.  This is wasteful and
 
276
     unnecessary.  An EXECUTE_CACHE_ENTRY could be one word longer to
 
277
     accomodate a delay-slot instruction, and the linker could do the
 
278
     following:
 
279
 
 
280
     - If the target instruction is not a branch instruction, use 4 +
 
281
     the address of the target instruction, and copy the target
 
282
     instruction to the delay slot.  Note that branch instructions are
 
283
     those with opcodes (6 bits) in the range #b1xy0zw, for any bit
 
284
     value for x, y, z, w.
 
285
 
 
286
     - If the target instruction is the COMBT instruction of an
 
287
     interrupt/gc check, use 4 + the address of the target
 
288
     instruction, and insert a similar COMBT instruction in the delay
 
289
     slot.  This COMBT instruction would then branch to an instruction
 
290
     shared by all the cache cells in the same block.  This shared
 
291
     instruction would be a BE instruction used to jump to an assembly
 
292
     language handler.  This handler would recover the target address
 
293
     from the link address left in register 31 by the BLE instruction
 
294
     in the execute cache cell, and use it to compute the address of
 
295
     and branch to the interrupt code for the entry.
 
296
 
 
297
     - Otherwise use the address of the target instruction and insert
 
298
     a NOP in the delay slot.
 
299
*/
 
300
 
 
301
/* Execute cache destructuring. */
 
302
 
 
303
/* Given a target location and the address of the first word of an
 
304
   execute cache entry, extract from the cache cell the number of
 
305
   arguments supplied by the caller and store it in target.
 
306
 */
 
307
 
 
308
#define EXTRACT_EXECUTE_CACHE_ARITY(target, address)                    \
 
309
{                                                                       \
 
310
  (target) = ((long) (* (((unsigned short *) (address)) + 5)));         \
 
311
}
 
312
 
 
313
/* Given a target location and the address of the first word of an
 
314
   execute cache entry, extract from the cache cell the name
 
315
   of the variable whose value is being invoked.
 
316
   This is valid only before linking.
 
317
 */
 
318
 
 
319
#define EXTRACT_EXECUTE_CACHE_SYMBOL(target, address)                   \
 
320
{                                                                       \
 
321
  (target) = (* (((SCHEME_OBJECT *) (address))));                       \
 
322
}
 
323
 
 
324
/* Extract the target address (not the code to get there) from an
 
325
   execute cache cell.
 
326
 */
 
327
 
 
328
#define EXTRACT_EXECUTE_CACHE_ADDRESS(target, address)                  \
 
329
{                                                                       \
 
330
  EXTRACT_ABSOLUTE_ADDRESS(target, address);                            \
 
331
}
 
332
 
 
333
/* This is the inverse of EXTRACT_EXECUTE_CACHE_ADDRESS. */
 
334
 
 
335
#define STORE_EXECUTE_CACHE_ADDRESS(address, entry)                     \
 
336
{                                                                       \
 
337
  STORE_ABSOLUTE_ADDRESS(entry, address, true);                         \
 
338
}
 
339
 
 
340
/* This stores the fixed part of the instructions leaving the
 
341
   destination address and the number of arguments intact.  These are
 
342
   split apart so the GC can call EXTRACT/STORE...ADDRESS but it does
 
343
   NOT need to store the instructions back.  On some architectures the
 
344
   instructions may change due to GC and then STORE_EXECUTE_CACHE_CODE
 
345
   should become a no-op and all of the work is done by
 
346
   STORE_EXECUTE_CACHE_ADDRESS instead.
 
347
   On PA this is a NOP.
 
348
 */
 
349
 
 
350
#define STORE_EXECUTE_CACHE_CODE(address) do                            \
 
351
{                                                                       \
 
352
} while (0)
 
353
 
 
354
/* This is supposed to flush the Scheme portion of the I-cache.
 
355
   It flushes the entire I-cache instead, since it is easier.
 
356
   It is used after a GC or disk-restore.
 
357
   It's needed because the GC has moved code around, and closures
 
358
   and execute cache cells have absolute addresses that the
 
359
   processor might have old copies of.
 
360
 */
 
361
 
 
362
#define FLUSH_I_CACHE() do                                              \
 
363
{                                                                       \
 
364
  extern void                                                           \
 
365
    EXFUN (flush_i_cache, (void));                                      \
 
366
                                                                        \
 
367
  flush_i_cache ();                                                     \
 
368
} while (0)
 
369
 
 
370
/* This flushes a region of the I-cache.
 
371
   It is used after updating an execute cache while running.
 
372
   Not needed during GC because FLUSH_I_CACHE will be used.
 
373
 */   
 
374
 
 
375
#define FLUSH_I_CACHE_REGION(address, nwords) do                        \
 
376
{                                                                       \
 
377
  extern void                                                           \
 
378
    EXFUN (cache_flush_region, (PTR, long, unsigned int));              \
 
379
                                                                        \
 
380
  cache_flush_region (((PTR) (address)), ((long) (nwords)),             \
 
381
                      (D_CACHE | I_CACHE));                             \
 
382
} while (0)
 
383
 
 
384
/* This pushes a region of the D-cache back to memory.
 
385
   It is (typically) used after loading (and relocating) a piece of code
 
386
   into memory.
 
387
 */   
 
388
 
 
389
#define PUSH_D_CACHE_REGION(address, nwords) do                         \
 
390
{                                                                       \
 
391
  extern void                                                           \
 
392
    EXFUN (push_d_cache_region, (PTR, unsigned long));                  \
 
393
                                                                        \
 
394
  push_d_cache_region (((PTR) (address)),                               \
 
395
                       ((unsigned long) (nwords)));                     \
 
396
} while (0)
 
397
 
 
398
extern void EXFUN (hppa_update_primitive_table, (int, int));
 
399
extern Boolean EXFUN (hppa_grow_primitive_table, (int));
 
400
 
 
401
#define UPDATE_PRIMITIVE_TABLE_HOOK hppa_update_primitive_table
 
402
#define GROW_PRIMITIVE_TABLE_HOOK hppa_grow_primitive_table
 
403
 
 
404
/* This is not completely true.  Some models (eg. 850) have combined caches,
 
405
   but we have to assume the worst.
 
406
 */
 
407
 
 
408
#define SPLIT_CACHES
 
409
 
 
410
/* Derived parameters and macros.
 
411
 
 
412
   These macros expect the above definitions to be meaningful.
 
413
   If they are not, the macros below may have to be changed as well.
 
414
 */
 
415
 
 
416
#define COMPILED_ENTRY_OFFSET_WORD(entry)                               \
 
417
  (((format_word *) (entry))[-1])
 
418
#define COMPILED_ENTRY_FORMAT_WORD(entry)                               \
 
419
  (((format_word *) (entry))[-2])
 
420
 
 
421
/* The next one assumes 2's complement integers....*/
 
422
#define CLEAR_LOW_BIT(word)                     ((word) & ((unsigned long) -2))
 
423
#define OFFSET_WORD_CONTINUATION_P(word)        (((word) & 1) != 0)
 
424
 
 
425
#if (PC_ZERO_BITS == 0)
 
426
/* Instructions aligned on byte boundaries */
 
427
#define BYTE_OFFSET_TO_OFFSET_WORD(offset)      ((offset) << 1)
 
428
#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word)                         \
 
429
  ((CLEAR_LOW_BIT(offset_word)) >> 1)
 
430
#endif
 
431
 
 
432
#if (PC_ZERO_BITS == 1)
 
433
/* Instructions aligned on word (16 bit) boundaries */
 
434
#define BYTE_OFFSET_TO_OFFSET_WORD(offset)      (offset)
 
435
#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word)                         \
 
436
  (CLEAR_LOW_BIT(offset_word))
 
437
#endif
 
438
 
 
439
#if (PC_ZERO_BITS >= 2)
 
440
/* Should be OK for =2, but bets are off for >2 because of problems
 
441
   mentioned earlier!
 
442
*/
 
443
#define SHIFT_AMOUNT                            (PC_ZERO_BITS - 1)
 
444
#define BYTE_OFFSET_TO_OFFSET_WORD(offset)      ((offset) >> (SHIFT_AMOUNT))
 
445
#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word)                         \
 
446
  ((CLEAR_LOW_BIT(offset_word)) << (SHIFT_AMOUNT))
 
447
#endif
 
448
 
 
449
#define MAKE_OFFSET_WORD(entry, block, continue)                        \
 
450
  ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) -                     \
 
451
                               ((char *) (block)))) |                   \
 
452
   ((continue) ? 1 : 0))
 
453
 
 
454
#if (EXECUTE_CACHE_ENTRY_SIZE == 2)
 
455
#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count)                           \
 
456
  ((count) >> 1)
 
457
#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries)                         \
 
458
  ((entries) << 1)
 
459
#endif
 
460
 
 
461
#if (EXECUTE_CACHE_ENTRY_SIZE == 4)
 
462
#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count)                           \
 
463
  ((count) >> 2)
 
464
#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries)                         \
 
465
  ((entries) << 2)
 
466
#endif
 
467
 
 
468
#if (!defined(EXECUTE_CACHE_COUNT_TO_ENTRIES))
 
469
#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count)                           \
 
470
  ((count) / EXECUTE_CACHE_ENTRY_SIZE)
 
471
#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries)                         \
 
472
  ((entries) * EXECUTE_CACHE_ENTRY_SIZE)
 
473
#endif
 
474
 
 
475
/* The first entry in a cc block is preceeded by 2 headers (block and nmv),
 
476
   a format word and a gc offset word.   See the early part of the
 
477
   TRAMPOLINE picture, above.
 
478
 */
 
479
 
 
480
#define CC_BLOCK_FIRST_ENTRY_OFFSET                                     \
 
481
  (2 * ((sizeof(SCHEME_OBJECT)) + (sizeof(format_word))))
 
482
 
 
483
#ifndef FORMAT_BYTE_CLOSURE
 
484
#define FORMAT_BYTE_CLOSURE                     0xFA
 
485
#endif
 
486
 
 
487
#ifndef FORMAT_WORD_CLOSURE
 
488
#define FORMAT_WORD_CLOSURE     (MAKE_FORMAT_WORD (0xFF, FORMAT_BYTE_CLOSURE))
 
489
#endif
 
490
 
 
491
/* This assumes that a format word is at least 16 bits,
 
492
   and the low order field is always 8 bits.
 
493
 */
 
494
 
 
495
#define MAKE_FORMAT_WORD(field1, field2)                                \
 
496
  (((field1) << 8) | ((field2) & 0xff))
 
497
 
 
498
#define SIGN_EXTEND_FIELD(field, size)                                  \
 
499
  (((field) & ((1 << (size)) - 1)) |                                    \
 
500
   ((((field) & (1 << ((size) - 1))) == 0) ? 0 :                        \
 
501
    ((-1) << (size))))
 
502
 
 
503
#define FORMAT_WORD_LOW_BYTE(word)                                      \
 
504
  (SIGN_EXTEND_FIELD((((unsigned long) (word)) & 0xff), 8))
 
505
 
 
506
#define FORMAT_WORD_HIGH_BYTE(word)                                     \
 
507
  (SIGN_EXTEND_FIELD((((unsigned long) (word)) >> 8),                   \
 
508
                     (((sizeof (format_word)) * CHAR_BIT) - 8)))
 
509
 
 
510
#define COMPILED_ENTRY_FORMAT_HIGH(addr)                                \
 
511
  (FORMAT_WORD_HIGH_BYTE(COMPILED_ENTRY_FORMAT_WORD(addr)))
 
512
 
 
513
#define COMPILED_ENTRY_FORMAT_LOW(addr)                                 \
 
514
  (FORMAT_WORD_LOW_BYTE(COMPILED_ENTRY_FORMAT_WORD(addr)))
 
515
 
 
516
#define COMPILED_ENTRY_MAXIMUM_ARITY    COMPILED_ENTRY_FORMAT_LOW
 
517
#define COMPILED_ENTRY_MINIMUM_ARITY    COMPILED_ENTRY_FORMAT_HIGH
 
518
 
 
519
#ifdef IN_CMPINT_C
 
520
 
 
521
/* Definitions of the utility procedures.
 
522
   Procedure calls of leaf procedures on the HPPA are pretty fast,
 
523
   so there is no reason not to do this out of line.
 
524
   In this way compiled code can use them too.
 
525
 */
 
526
 
 
527
union ldil_inst
 
528
{
 
529
  unsigned long inst;
 
530
  struct
 
531
  {
 
532
    unsigned opcode     : 6;
 
533
    unsigned base       : 5;
 
534
    unsigned D          : 5;
 
535
    unsigned C          : 2;
 
536
    unsigned E          : 2;
 
537
    unsigned B          : 11;
 
538
    unsigned A          : 1;
 
539
  } fields;
 
540
};
 
541
 
 
542
union branch_inst
 
543
{
 
544
  unsigned long inst;
 
545
  struct
 
546
  {
 
547
    unsigned opcode     : 6;
 
548
    unsigned t_or_b     : 5;
 
549
    unsigned x_or_w1    : 5;
 
550
    unsigned s          : 3;
 
551
    unsigned w2b        : 10;
 
552
    unsigned w2a        : 1;
 
553
    unsigned n          : 1;
 
554
    unsigned w0         : 1;
 
555
  } fields;
 
556
};
 
557
 
 
558
union short_pointer
 
559
{
 
560
  unsigned long address;
 
561
  struct
 
562
  {
 
563
    unsigned A          : 1;
 
564
    unsigned B          : 11;
 
565
    unsigned C          : 2;
 
566
    unsigned D          : 5;
 
567
    unsigned w2a        : 1;
 
568
    unsigned w2b        : 10;
 
569
    unsigned pad        : 2;
 
570
  } fields;
 
571
};
 
572
 
 
573
union assemble_17_u
 
574
{
 
575
  long value;
 
576
  struct
 
577
  {
 
578
    int sign_pad        : 13;
 
579
    unsigned w0         : 1;
 
580
    unsigned w1         : 5;
 
581
    unsigned w2a        : 1;
 
582
    unsigned w2b        : 10;
 
583
    unsigned pad        : 2;
 
584
  } fields;
 
585
};
 
586
 
 
587
union assemble_12_u
 
588
{
 
589
  long value;
 
590
  struct
 
591
  {
 
592
    int sign_pad        : 18;
 
593
    unsigned w0         : 1;
 
594
    unsigned w2a        : 1;
 
595
    unsigned w2b        : 10;
 
596
    unsigned pad        : 2;
 
597
  } fields;
 
598
};
 
599
 
 
600
long
 
601
DEFUN (assemble_17, (inst), union branch_inst inst)
 
602
{
 
603
  union assemble_17_u off;
 
604
 
 
605
  off.fields.pad = 0;
 
606
  off.fields.w2b = inst.fields.w2b;
 
607
  off.fields.w2a = inst.fields.w2a;
 
608
  off.fields.w1  = inst.fields.x_or_w1;
 
609
  off.fields.w0  = inst.fields.w0;
 
610
  off.fields.sign_pad = ((inst.fields.w0 == 0) ? 0 : -1);
 
611
  return (off.value);
 
612
}
 
613
 
 
614
long
 
615
DEFUN (assemble_12, (inst), union branch_inst inst)
 
616
{
 
617
  union assemble_12_u off;
 
618
 
 
619
  off.fields.pad = 0;
 
620
  off.fields.w2b = inst.fields.w2b;
 
621
  off.fields.w2a = inst.fields.w2a;
 
622
  off.fields.w0  = inst.fields.w0;
 
623
  off.fields.sign_pad = ((inst.fields.w0 == 0) ? 0 : -1);
 
624
  return (off.value);
 
625
}
 
626
 
 
627
static unsigned long hppa_closure_hook = 0;
 
628
 
 
629
static unsigned long
 
630
DEFUN (C_closure_entry_point, (C_closure), unsigned long C_closure)
 
631
{
 
632
  if ((C_closure & 0x3) != 0x2)
 
633
    return (C_closure);
 
634
  else
 
635
  {
 
636
    long offset;
 
637
    extern int etext;
 
638
    unsigned long entry_point;
 
639
    char * blp = (* ((char **) (C_closure - 2)));
 
640
 
 
641
    blp = ((char *) (((unsigned long) blp) & ~3));
 
642
    offset = (assemble_17 (* ((union branch_inst *) blp)));
 
643
    entry_point = ((unsigned long) ((blp + 8) + offset));
 
644
    return ((entry_point < ((unsigned long) &etext))
 
645
            ? entry_point
 
646
            : hppa_closure_hook);
 
647
  }
 
648
}
 
649
 
 
650
#define HAVE_BKPT_SUPPORT
 
651
 
 
652
static unsigned short branch_opcodes[] =
 
653
{
 
654
  0x20, 0x21, 0x22, 0x23, 0x28, 0x29, 0x2a, 0x2b,
 
655
  0x30, 0x31, 0x32, 0x33, 0x38, 0x39, 0x3a
 
656
};
 
657
 
 
658
static Boolean
 
659
  branch_opcode_table[64];
 
660
 
 
661
static unsigned long
 
662
  bkpt_instruction,
 
663
  closure_bkpt_instruction,
 
664
  closure_entry_bkpt_instruction,
 
665
  * bkpt_normal_proceed_thunk,
 
666
  * bkpt_plus_proceed_thunk,
 
667
  * bkpt_minus_proceed_thunk_start,
 
668
  * bkpt_minus_proceed_thunk,
 
669
  * bkpt_closure_proceed_thunk,
 
670
  * bkpt_closure_proceed_thunk_end,
 
671
  * bkpt_proceed_buffer = ((unsigned long *) NULL);
 
672
 
 
673
#define FAHRENHEIT 451
 
674
 
 
675
static void
 
676
DEFUN_VOID (bkpt_init)
 
677
{
 
678
  int i, this_size, max_size;
 
679
  union branch_inst instr;
 
680
  extern void EXFUN (bkpt_normal_proceed, (void));
 
681
  extern void EXFUN (bkpt_plus_proceed, (void));
 
682
  extern void EXFUN (bkpt_minus_proceed_start, (void));
 
683
  extern void EXFUN (bkpt_minus_proceed, (void));
 
684
  extern void EXFUN (bkpt_closure_proceed, (void));
 
685
  extern void EXFUN (bkpt_closure_proceed_end, (void));
 
686
 
 
687
  for (i = 0;
 
688
       i < ((sizeof (branch_opcode_table)) / (sizeof (Boolean)));
 
689
       i++)
 
690
    branch_opcode_table[i] = FALSE;
 
691
 
 
692
  for (i = 0;
 
693
       i < ((sizeof (branch_opcodes)) / (sizeof (short)));
 
694
       i++)
 
695
    branch_opcode_table[branch_opcodes[i]] = TRUE;
 
696
 
 
697
  instr.fields.opcode   = 0x39; /* BLE opcode */
 
698
  instr.fields.t_or_b   = 03;   /* scheme_to_interface_ble */
 
699
  instr.fields.n        = 01;   /* nullify */
 
700
  instr.fields.s        = 01;   /* C code space, rotated illegibly */
 
701
  instr.fields.w0       = 00;
 
702
  instr.fields.x_or_w1  = 00;
 
703
  instr.fields.w2a      = 00;
 
704
  instr.fields.w2b      = ((FAHRENHEIT + 1) >> 2);
 
705
 
 
706
  bkpt_instruction = instr.inst;
 
707
 
 
708
  instr.fields.w2b      = ((FAHRENHEIT + 33) >> 2);
 
709
  closure_entry_bkpt_instruction = instr.inst;
 
710
 
 
711
  instr.fields.opcode   = 0x38; /* BE opcode */
 
712
  instr.fields.w2b      = ((FAHRENHEIT + 9) >> 2);
 
713
  closure_bkpt_instruction = instr.inst;
 
714
 
 
715
  bkpt_normal_proceed_thunk
 
716
    = ((unsigned long *)
 
717
       (C_closure_entry_point ((unsigned long) bkpt_normal_proceed)));
 
718
  bkpt_plus_proceed_thunk
 
719
    = ((unsigned long *)
 
720
       (C_closure_entry_point ((unsigned long) bkpt_plus_proceed)));
 
721
  bkpt_minus_proceed_thunk_start
 
722
    = ((unsigned long *)
 
723
       (C_closure_entry_point ((unsigned long) bkpt_minus_proceed_start)));
 
724
  bkpt_minus_proceed_thunk
 
725
    = ((unsigned long *)
 
726
       (C_closure_entry_point ((unsigned long) bkpt_minus_proceed)));
 
727
  bkpt_closure_proceed_thunk
 
728
    = ((unsigned long *)
 
729
       (C_closure_entry_point ((unsigned long) bkpt_closure_proceed)));
 
730
  bkpt_closure_proceed_thunk_end
 
731
    = ((unsigned long *)
 
732
       (C_closure_entry_point ((unsigned long) bkpt_closure_proceed_end)));
 
733
 
 
734
  max_size = (bkpt_closure_proceed_thunk_end - bkpt_closure_proceed_thunk);
 
735
  this_size = (bkpt_plus_proceed_thunk - bkpt_normal_proceed_thunk);
 
736
  if (this_size > max_size)
 
737
    max_size = this_size;
 
738
  this_size = (bkpt_closure_proceed_thunk - bkpt_minus_proceed_thunk_start);
 
739
  if (this_size > max_size)
 
740
    max_size = this_size;
 
741
  this_size = (bkpt_minus_proceed_thunk_start - bkpt_plus_proceed_thunk);
 
742
  if (this_size > max_size)
 
743
    max_size = this_size;
 
744
  
 
745
  bkpt_proceed_buffer = ((unsigned long *)
 
746
                         (malloc (max_size * (sizeof (unsigned long)))));
 
747
  if (bkpt_proceed_buffer == ((unsigned long *) NULL))
 
748
  {
 
749
    outf_fatal ("Unable to allocate the breakpoint buffer.\n");
 
750
    termination_init_error ();
 
751
  }
 
752
  return;
 
753
}
 
754
 
 
755
#define BKPT_KIND_CLOSURE               0
 
756
#define BKPT_KIND_NORMAL                1
 
757
#define BKPT_KIND_PC_REL_BRANCH         2
 
758
#define BKPT_KIND_BL_INST               3
 
759
#define BKPT_KIND_BLE_INST              4
 
760
#define BKPT_KIND_CLOSURE_ENTRY         5
 
761
 
 
762
extern void EXFUN (cache_flush_region, (PTR, long, unsigned int));
 
763
 
 
764
static SCHEME_OBJECT
 
765
DEFUN (alloc_bkpt_handle, (kind, first_instr, entry_point),
 
766
       int kind AND unsigned long first_instr AND PTR entry_point)
 
767
{
 
768
  SCHEME_OBJECT * handle;
 
769
  Primitive_GC_If_Needed (5);
 
770
  handle = Free;
 
771
  Free += 5;
 
772
 
 
773
  handle[0] = (MAKE_OBJECT (TC_MANIFEST_VECTOR, 4));
 
774
  handle[1] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 2));
 
775
  handle[2] = ((SCHEME_OBJECT) (FIXNUM_ZERO + kind));
 
776
  handle[3] = ((SCHEME_OBJECT) first_instr);
 
777
  handle[4] = (ENTRY_TO_OBJECT (entry_point));
 
778
  
 
779
  return (MAKE_POINTER_OBJECT (TC_NON_MARKED_VECTOR, handle));
 
780
}
 
781
 
 
782
SCHEME_OBJECT
 
783
DEFUN (bkpt_install, (entry_point), PTR entry_point)
 
784
{
 
785
  unsigned long kind;
 
786
  SCHEME_OBJECT handle;
 
787
  unsigned long first_instr = (* ((unsigned long *) entry_point));
 
788
  unsigned short opcode = ((first_instr >> 26) & 0x3f);
 
789
  unsigned long new_instr = bkpt_instruction;
 
790
 
 
791
  if ((COMPILED_ENTRY_FORMAT_WORD (entry_point)) == FORMAT_WORD_CLOSURE)
 
792
  {
 
793
    /* This assumes that the first instruction is normal */ 
 
794
    kind = BKPT_KIND_CLOSURE_ENTRY;
 
795
    new_instr = closure_entry_bkpt_instruction;
 
796
  }
 
797
  else if ((! (branch_opcode_table[opcode])) || (opcode == 0x38))
 
798
    kind = BKPT_KIND_NORMAL;    /* BE instr included */
 
799
  else if (opcode == 0x39)
 
800
#if 0
 
801
    kind = BKPT_KIND_BLE_INST;
 
802
#else /* for now */
 
803
    return (SHARP_F);
 
804
#endif
 
805
  else if (opcode != 0x3a)
 
806
  {
 
807
    unsigned long second_instr = (* (((unsigned long *) entry_point) + 1));
 
808
    unsigned long second_opcode = ((second_instr >> 26) & 0x3f);
 
809
 
 
810
    /* We can't handle breakpoints to a branch instruction
 
811
       with another branch instruction in its delay slot.
 
812
       This could be nullification sensitive, but not
 
813
       currently worthwhile.
 
814
     */
 
815
 
 
816
    if (branch_opcode_table[second_opcode])
 
817
      return (SHARP_F);
 
818
 
 
819
    kind = BKPT_KIND_PC_REL_BRANCH;
 
820
  }
 
821
 
 
822
  else
 
823
  {
 
824
    union branch_inst finstr;
 
825
 
 
826
    finstr.inst = first_instr;
 
827
    switch (finstr.fields.s)    /* minor opcode */
 
828
    {
 
829
      case 0:                   /* BL instruction */
 
830
#if 0
 
831
        kind = BKPT_KIND_BL_INST;
 
832
        break;
 
833
#endif /* for now, fall through */
 
834
 
 
835
      case 1:                   /* GATE instruction */
 
836
      case 2:                   /* BLR  instruction */
 
837
      default:                  /* ?? */
 
838
        return (SHARP_F);
 
839
 
 
840
      case 6:
 
841
        kind = BKPT_KIND_NORMAL;
 
842
        break;
 
843
    }
 
844
  }
 
845
 
 
846
  handle = (alloc_bkpt_handle (kind, first_instr, entry_point));
 
847
 
 
848
  (* ((unsigned long *) entry_point)) = new_instr;
 
849
  cache_flush_region (((PTR) entry_point), 1, (D_CACHE | I_CACHE));
 
850
 
 
851
  return (handle);
 
852
}
 
853
 
 
854
SCHEME_OBJECT
 
855
DEFUN (bkpt_closure_install, (entry_point), PTR entry_point)
 
856
{
 
857
  unsigned long * instrs = ((unsigned long *) entry_point);
 
858
  SCHEME_OBJECT handle;
 
859
 
 
860
  handle = (alloc_bkpt_handle (BKPT_KIND_CLOSURE, instrs[2], entry_point));
 
861
  instrs[2] = closure_bkpt_instruction;
 
862
  cache_flush_region (((PTR) &instrs[2]), 1, (D_CACHE | I_CACHE));
 
863
  return (handle);
 
864
}
 
865
 
 
866
void
 
867
DEFUN (bkpt_remove, (entry_point, handle),
 
868
       PTR entry_point AND SCHEME_OBJECT handle)
 
869
{
 
870
  int offset;
 
871
  unsigned long * instrs = ((unsigned long *) entry_point);
 
872
 
 
873
  if ((instrs[0] == bkpt_instruction)
 
874
      || (instrs[0] == closure_entry_bkpt_instruction))
 
875
    offset = 0;
 
876
  else if (instrs[2] == closure_bkpt_instruction)
 
877
    offset = 2;
 
878
  else
 
879
    error_external_return ();
 
880
 
 
881
  instrs[offset] = ((unsigned long) (FAST_MEMORY_REF (handle, 3)));
 
882
  cache_flush_region (((PTR) &instrs[offset]), 1, (D_CACHE | I_CACHE));
 
883
  return;
 
884
}
 
885
 
 
886
Boolean
 
887
DEFUN (bkpt_p, (entry_point), PTR entry_point)
 
888
{
 
889
  unsigned long * instrs = ((unsigned long *) entry_point);
 
890
 
 
891
  return ((instrs[0] == bkpt_instruction)
 
892
          || (instrs[0] == closure_entry_bkpt_instruction)
 
893
          || (instrs[2] == closure_bkpt_instruction));
 
894
}
 
895
 
 
896
Boolean
 
897
DEFUN (do_bkpt_proceed, (value), unsigned long * value)
 
898
{
 
899
  unsigned long * buffer = ((unsigned long *) bkpt_proceed_buffer);
 
900
  SCHEME_OBJECT ep = (STACK_POP ());
 
901
  SCHEME_OBJECT handle = (STACK_POP ());
 
902
  SCHEME_OBJECT state = (STACK_POP ());
 
903
 
 
904
  STACK_POP ();                 /* Pop duplicate entry point. */
 
905
 
 
906
  switch (OBJECT_DATUM (FAST_MEMORY_REF (handle, 2)))
 
907
  {
 
908
    case BKPT_KIND_CLOSURE:
 
909
    {
 
910
      int i, len;
 
911
      unsigned long * clos_entry
 
912
        = (OBJECT_ADDRESS (FAST_MEMORY_REF (handle, 4)));
 
913
      SCHEME_OBJECT real_entry_point;
 
914
 
 
915
      EXTRACT_CLOSURE_ENTRY_ADDRESS (real_entry_point, clos_entry);
 
916
      len = (bkpt_closure_proceed_thunk_end - bkpt_closure_proceed_thunk);
 
917
      for (i = 0; i < (len - 2); i++)
 
918
        buffer[i] = bkpt_closure_proceed_thunk[i];
 
919
      cache_flush_region (((PTR) buffer), (len - 2), (D_CACHE | I_CACHE));
 
920
 
 
921
      buffer[len - 2] = ((unsigned long) clos_entry);
 
922
      buffer[len - 1] = real_entry_point;
 
923
 
 
924
      Val = SHARP_F;
 
925
      * value = ((unsigned long) buffer);
 
926
      return (TRUE);
 
927
    }
 
928
 
 
929
    case BKPT_KIND_NORMAL:
 
930
    {
 
931
      int i, len;
 
932
 
 
933
      len = (bkpt_plus_proceed_thunk - bkpt_normal_proceed_thunk);
 
934
      for (i = 0; i < (len - 2); i++)
 
935
        buffer[i] = bkpt_normal_proceed_thunk[i];
 
936
      buffer[len - 2] = ((unsigned long) (FAST_MEMORY_REF (handle, 3)));
 
937
 
 
938
      cache_flush_region (((PTR) buffer), (len - 1), (D_CACHE | I_CACHE));
 
939
      buffer[len - 1] = (((unsigned long) (OBJECT_ADDRESS (ep))) + 4);
 
940
 
 
941
      Val = state;
 
942
      * value = ((unsigned long) buffer);
 
943
      return (TRUE);
 
944
    }
 
945
 
 
946
    case BKPT_KIND_CLOSURE_ENTRY:
 
947
    {
 
948
      STACK_PUSH (state);       /* closure object */
 
949
      * value = ((unsigned long) ((OBJECT_ADDRESS (ep)) + 2));
 
950
      return (TRUE);
 
951
    }
 
952
 
 
953
    case BKPT_KIND_BL_INST:
 
954
    case BKPT_KIND_BLE_INST:
 
955
    default:
 
956
      STACK_PUSH (ep);
 
957
      * value = ((unsigned long) ERR_EXTERNAL_RETURN);
 
958
      return (FALSE);
 
959
 
 
960
    case BKPT_KIND_PC_REL_BRANCH:
 
961
    {
 
962
      long offset;
 
963
      int i, len, clobber;
 
964
      union branch_inst new, old;
 
965
      unsigned long * instrs = ((unsigned long *) (OBJECT_ADDRESS (ep)));
 
966
      unsigned long * block;
 
967
 
 
968
      old.inst = ((unsigned long) (FAST_MEMORY_REF (handle, 3)));
 
969
      offset = (assemble_12 (old));
 
970
      if (offset >= 0)
 
971
      {
 
972
        block = bkpt_plus_proceed_thunk;
 
973
        len = (bkpt_minus_proceed_thunk_start - block);
 
974
        clobber = 0;
 
975
      }
 
976
      else
 
977
      {
 
978
        block = bkpt_minus_proceed_thunk_start;
 
979
        len = (bkpt_closure_proceed_thunk - block);
 
980
        clobber = (bkpt_minus_proceed_thunk - block);
 
981
      }
 
982
      
 
983
      for (i = 0; i < (len - 2); i++)
 
984
        buffer[i] = block[i];
 
985
 
 
986
      new.inst = buffer[clobber];
 
987
      old.inst = ((unsigned long) (FAST_MEMORY_REF (handle, 3)));
 
988
      old.fields.w2b = new.fields.w2b;
 
989
      old.fields.w2a = new.fields.w2a;
 
990
      old.fields.w0 = new.fields.w0;
 
991
      buffer[clobber] = old.inst;
 
992
      buffer[clobber + 1] = instrs[1];
 
993
      cache_flush_region (((PTR) buffer), (len - 2), (D_CACHE | I_CACHE));
 
994
 
 
995
      buffer[len - 2] = (((unsigned long) instrs) + 8);
 
996
      buffer[len - 1] = ((((unsigned long) instrs) + 8)
 
997
                         + offset);
 
998
      
 
999
      Val = state;
 
1000
      * value = ((unsigned long) &buffer[clobber]);
 
1001
      return (TRUE);
 
1002
    }
 
1003
  }
 
1004
}
 
1005
 
 
1006
static void
 
1007
DEFUN (transform_procedure_entries, (len, otable, ntable),
 
1008
       long len AND PTR * otable AND PTR * ntable)
 
1009
{
 
1010
  long counter;
 
1011
  
 
1012
  for (counter = 0; counter < len; counter++)
 
1013
    ntable[counter] =
 
1014
      ((PTR) (C_closure_entry_point ((unsigned long) (otable [counter]))));
 
1015
  return;
 
1016
}       
 
1017
 
 
1018
static PTR *
 
1019
DEFUN (transform_procedure_table, (table_length, old_table),
 
1020
       long table_length AND PTR * old_table)
 
1021
{
 
1022
  PTR * new_table;
 
1023
 
 
1024
  new_table = ((PTR *) (malloc (table_length * (sizeof (PTR)))));
 
1025
  if (new_table == ((PTR *) NULL))
 
1026
  {
 
1027
    outf_fatal ("transform_procedure_table: malloc (%d) failed.\n",
 
1028
                (table_length * (sizeof (PTR))));
 
1029
    exit (1);
 
1030
  }
 
1031
  transform_procedure_entries (table_length, old_table, new_table);
 
1032
  return (new_table);
 
1033
}
 
1034
 
 
1035
#define UTIL_TABLE_PC_REF(index)                                        \
 
1036
  (C_closure_entry_point (UTIL_TABLE_PC_REF_REAL (index)))
 
1037
 
 
1038
#ifdef _BSD4_3
 
1039
#  include <sys/mman.h>
 
1040
#  define VM_PROT_SCHEME (PROT_READ | PROT_WRITE | PROT_EXEC)
 
1041
#endif
 
1042
 
 
1043
void
 
1044
DEFUN_VOID (change_vm_protection)
 
1045
{
 
1046
#if 0
 
1047
  /* Thought I needed this under _BSD4_3 */
 
1048
 
 
1049
  unsigned long pagesize = (getpagesize ());
 
1050
  unsigned long heap_start_page;
 
1051
  unsigned long size;
 
1052
 
 
1053
  heap_start_page = (((unsigned long) Heap) & (pagesize - 1));
 
1054
  size = (((((unsigned long) Highest_Allocated_Address) + (pagesize - 1))
 
1055
           & (pagesize - 1))
 
1056
          - heap_start_page);
 
1057
  if ((mprotect (((caddr_t) heap_start_page), size, VM_PROT_SCHEME))
 
1058
      == -1)
 
1059
  {
 
1060
    perror ("\nchange_vm_protection");
 
1061
    outf_fatal ("mprotect (0x%lx, 0x%lx, 0x%lx)\n",
 
1062
                heap_start_page, size, VM_PROT_SCHEME);
 
1063
    outf_fatal ("ASM_RESET_HOOK: Unable to change VM protection of Heap.\n");
 
1064
    termination_init_error ();
 
1065
  }
 
1066
#endif
 
1067
  return;
 
1068
}
 
1069
 
 
1070
#include "option.h"
 
1071
 
 
1072
#ifndef MODELS_FILENAME
 
1073
#define MODELS_FILENAME "hppacach.mod"
 
1074
#endif
 
1075
 
 
1076
static struct pdc_cache_dump cache_info;
 
1077
 
 
1078
static void
 
1079
DEFUN_VOID (flush_i_cache_initialize)
 
1080
{
 
1081
  extern char * EXFUN (getenv, (const char *));
 
1082
  CONST char * models_filename =
 
1083
    (search_path_for_file (0, MODELS_FILENAME, 1, 1));
 
1084
  char * model;
 
1085
 
 
1086
  model = (getenv ("MITSCHEME_HPPA_MODEL"));
 
1087
 
 
1088
#ifdef _HPUX
 
1089
  if (model == ((char *) NULL))
 
1090
  {
 
1091
    struct utsname sysinfo;
 
1092
    if ((uname (&sysinfo)) < 0)
 
1093
    {
 
1094
      outf_fatal ("\nflush_i_cache: uname failed.\n");
 
1095
      goto loser;
 
1096
    }
 
1097
    model = &sysinfo.machine[0];
 
1098
  }
 
1099
#endif /* _HPUX */
 
1100
  if (model == ((char *) NULL))
 
1101
  {
 
1102
    outf_fatal
 
1103
      ("\nflush_i_cache: MITSCHEME_HPPA_MODEL not set in environment.\n");
 
1104
    goto loser;
 
1105
  }
 
1106
  {
 
1107
    int fd = (open (models_filename, O_RDONLY));
 
1108
    if (fd < 0)
 
1109
      {
 
1110
        outf_fatal ("\nflush_i_cache: open (%s) failed.\n",
 
1111
                    models_filename);
 
1112
        goto loser;
 
1113
      }
 
1114
    while (1)
 
1115
      {
 
1116
        int read_result =
 
1117
          (read (fd,
 
1118
                 ((char *) (&cache_info)),
 
1119
                 (sizeof (struct pdc_cache_dump))));
 
1120
        if (read_result == 0)
 
1121
          {
 
1122
            close (fd);
 
1123
            break;
 
1124
          }
 
1125
        if (read_result != (sizeof (struct pdc_cache_dump)))
 
1126
          {
 
1127
            close (fd);
 
1128
            outf_fatal ("\nflush_i_cache: read (%s) failed.\n",
 
1129
                        models_filename);
 
1130
            goto loser;
 
1131
          }
 
1132
        if ((strcmp (model, (cache_info . hardware))) == 0)
 
1133
          {
 
1134
            close (fd);
 
1135
            return;
 
1136
          }
 
1137
      }
 
1138
  }
 
1139
  outf_fatal (
 
1140
              "The cache parameters database has no entry for the %s model.\n",
 
1141
              model);
 
1142
  outf_fatal ("Please make an entry in the database;\n");
 
1143
  outf_fatal ("the installation notes contain instructions for doing so.\n");
 
1144
 loser:
 
1145
  outf_fatal ("\nASM_RESET_HOOK: Unable to read cache parameters.\n");
 
1146
  termination_init_error ();
 
1147
}
 
1148
 
 
1149
/* This loads the cache information structure for use by flush_i_cache,
 
1150
   sets the floating point flags correctly, and accommodates the c
 
1151
   function pointer closure format problems for utilities for HP-UX >= 8.0 .
 
1152
   It also changes the VM protection of the heap, if necessary.
 
1153
 */
 
1154
 
 
1155
extern PTR * hppa_utility_table;
 
1156
extern PTR * hppa_primitive_table;
 
1157
 
 
1158
PTR * hppa_utility_table = ((PTR *) NULL);
 
1159
 
 
1160
static void
 
1161
DEFUN (hppa_reset_hook, (utility_length, utility_table),
 
1162
       long utility_length AND PTR * utility_table)
 
1163
{
 
1164
  extern void EXFUN (interface_initialize, (void));
 
1165
  extern void EXFUN (cross_segment_call, (void));
 
1166
 
 
1167
  flush_i_cache_initialize ();
 
1168
  interface_initialize ();
 
1169
  change_vm_protection ();
 
1170
  hppa_closure_hook
 
1171
    = (C_closure_entry_point ((unsigned long) cross_segment_call));
 
1172
  hppa_utility_table
 
1173
    = (transform_procedure_table (utility_length, utility_table));
 
1174
  return;
 
1175
}
 
1176
 
 
1177
#define ASM_RESET_HOOK() do                                             \
 
1178
{                                                                       \
 
1179
  bkpt_init ();                                                         \
 
1180
  hppa_reset_hook (((sizeof (utility_table)) / (sizeof (PTR))),         \
 
1181
                   ((PTR *) (&utility_table[0])));                      \
 
1182
} while (0)
 
1183
 
 
1184
PTR * hppa_primitive_table = ((PTR *) NULL);
 
1185
 
 
1186
void
 
1187
DEFUN (hppa_update_primitive_table, (low, high), int low AND int high)
 
1188
{
 
1189
  transform_procedure_entries ((high - low),
 
1190
                               ((PTR *) (Primitive_Procedure_Table + low)),
 
1191
                               (hppa_primitive_table + low));
 
1192
  return;
 
1193
}
 
1194
 
 
1195
Boolean 
 
1196
DEFUN (hppa_grow_primitive_table, (new_size), int new_size)
 
1197
{
 
1198
  PTR * new_table
 
1199
    = ((PTR *) (realloc (hppa_primitive_table, (new_size * (sizeof (PTR))))));
 
1200
  if (new_table != ((PTR *) NULL))
 
1201
    hppa_primitive_table = new_table;
 
1202
  return (new_table != ((PTR *) NULL));
 
1203
}
 
1204
 
 
1205
/*
 
1206
   Note: The following does not do a full decoding of the BLE instruction.
 
1207
   It assumes that the bits have been set by STORE_ABSOLUTE_ADDRESS below,
 
1208
   which decomposes an absolute address according to the `short_pointer'
 
1209
   structure above, and thus certain fields are 0.
 
1210
 
 
1211
   The sequence inserted by STORE_ABSOLUTE_ADDRESS is approximately
 
1212
   (the actual address decomposition is given above).
 
1213
   LDIL         L'ep,26
 
1214
   BLE          R'ep(5,26)
 
1215
 */
 
1216
 
 
1217
unsigned long
 
1218
DEFUN (hppa_extract_absolute_address, (addr), unsigned long * addr)
 
1219
{
 
1220
  union short_pointer result;
 
1221
  union branch_inst ble;
 
1222
  union ldil_inst ldil;
 
1223
 
 
1224
  ldil.inst = *addr++;
 
1225
  ble.inst = *addr;
 
1226
 
 
1227
  /* Fill the padding */
 
1228
  result.address = 0;
 
1229
 
 
1230
  result.fields.A = ldil.fields.A;
 
1231
  result.fields.B = ldil.fields.B;
 
1232
  result.fields.C = ldil.fields.C;
 
1233
  result.fields.D = ldil.fields.D;
 
1234
  result.fields.w2a = ble.fields.w2a;
 
1235
  result.fields.w2b = ble.fields.w2b;
 
1236
 
 
1237
  return (result.address);
 
1238
}
 
1239
 
 
1240
void
 
1241
DEFUN (hppa_store_absolute_address, (addr, sourcev, nullify_p),
 
1242
       unsigned long * addr AND unsigned long sourcev
 
1243
       AND unsigned long nullify_p)
 
1244
{
 
1245
  union short_pointer source;
 
1246
  union ldil_inst ldil;
 
1247
  union branch_inst ble;
 
1248
 
 
1249
  source.address = sourcev;
 
1250
 
 
1251
#if 0
 
1252
  ldil.fields.opcode = 0x08;
 
1253
  ldil.fields.base = 26;
 
1254
  ldil.fields.E = 0;
 
1255
#else
 
1256
  ldil.inst = ((0x08 << 26) | (26 << 21));
 
1257
#endif
 
1258
 
 
1259
  ldil.fields.A = source.fields.A;
 
1260
  ldil.fields.B = source.fields.B;
 
1261
  ldil.fields.C = source.fields.C;
 
1262
  ldil.fields.D = source.fields.D;
 
1263
 
 
1264
#if 0
 
1265
  ble.fields.opcode = 0x39;
 
1266
  ble.fields.t_or_b = 26;
 
1267
  ble.fields.x_or_w1 = 0;
 
1268
  ble.fields.s = 3;
 
1269
  ble.fields.w0 = 0;
 
1270
#else
 
1271
  ble.inst = ((0x39 << 26) | (26 << 21) | (3 << 13));
 
1272
#endif
 
1273
 
 
1274
  ble.fields.w2a = source.fields.w2a;
 
1275
  ble.fields.w2b = source.fields.w2b;
 
1276
  ble.fields.n = (nullify_p & 1);
 
1277
 
 
1278
  *addr++ = ldil.inst;
 
1279
  *addr = ble.inst;
 
1280
  return;
 
1281
}
 
1282
 
 
1283
/* Cache flushing/pushing code.
 
1284
   Uses routines from cmpaux-hppa.m4.
 
1285
 */
 
1286
 
 
1287
extern void
 
1288
  EXFUN (flush_i_cache, (void)),
 
1289
  EXFUN (push_d_cache_region, (PTR, unsigned long));
 
1290
 
 
1291
void
 
1292
DEFUN_VOID (flush_i_cache)
 
1293
{
 
1294
  extern void
 
1295
    EXFUN (cache_flush_all, (unsigned int, struct pdc_cache_result *));
 
1296
 
 
1297
  struct pdc_cache_result * cache_desc;
 
1298
  
 
1299
  cache_desc = ((struct pdc_cache_result *) &(cache_info.cache_format));
 
1300
 
 
1301
  /* The call can be interrupted in the middle of a set, so do it twice.
 
1302
     Probability of two interrupts in the same cache line is
 
1303
     exceedingly small, so this is likely to win.
 
1304
     On the other hand, if the caches are directly mapped, a single
 
1305
     call can't lose.
 
1306
     In addition, if the cache is shared, there is no need to flush at all.
 
1307
   */
 
1308
 
 
1309
  if (((cache_desc->I_info.conf.bits.fsel & 1) == 0)
 
1310
      || ((cache_desc->D_info.conf.bits.fsel & 1) == 0))
 
1311
  {
 
1312
    unsigned int flag = 0;
 
1313
 
 
1314
    if (cache_desc->I_info.loop != 1)
 
1315
      flag |= I_CACHE;
 
1316
    if (cache_desc->D_info.loop != 1)
 
1317
      flag |= D_CACHE;
 
1318
 
 
1319
    if (flag != 0)
 
1320
      cache_flush_all (flag, cache_desc);
 
1321
    cache_flush_all ((D_CACHE | I_CACHE), cache_desc);
 
1322
  }
 
1323
}
 
1324
 
 
1325
void
 
1326
DEFUN (push_d_cache_region, (start_address, block_size),
 
1327
       PTR start_address AND unsigned long block_size)
 
1328
{
 
1329
  extern void
 
1330
    EXFUN (cache_flush_region, (PTR, long, unsigned int));
 
1331
 
 
1332
  struct pdc_cache_result * cache_desc;
 
1333
  
 
1334
  cache_desc = ((struct pdc_cache_result *) &(cache_info.cache_format));
 
1335
 
 
1336
  /* Note that the first and last words are also flushed from the I-cache
 
1337
     in case this object is adjacent to another that has already caused
 
1338
     the cache line to be copied into the I-cache.
 
1339
   */
 
1340
 
 
1341
  if (((cache_desc->I_info.conf.bits.fsel & 1) == 0)
 
1342
      || ((cache_desc->D_info.conf.bits.fsel & 1) == 0))
 
1343
  {
 
1344
    cache_flush_region (start_address, block_size, D_CACHE);
 
1345
    cache_flush_region (start_address, 1, I_CACHE);
 
1346
    cache_flush_region (((PTR)
 
1347
                         (((unsigned long *) start_address)
 
1348
                          + (block_size - 1))),
 
1349
                        1,
 
1350
                        I_CACHE);
 
1351
  }
 
1352
  return;
 
1353
}
 
1354
 
 
1355
#define DECLARE_CMPINTMD_UTILITIES()                                    \
 
1356
  UTLD (assemble_17),                                                   \
 
1357
  UTLD (assemble_12),                                                   \
 
1358
  UTLD (C_closure_entry_point),                                         \
 
1359
  UTLD (bkpt_init),                                                     \
 
1360
  UTLD (alloc_bkpt_handle),                                             \
 
1361
  UTLD (bkpt_install),                                                  \
 
1362
  UTLD (bkpt_closure_install),                                          \
 
1363
  UTLD (bkpt_remove),                                                   \
 
1364
  UTLD (bkpt_p),                                                        \
 
1365
  UTLD (do_bkpt_proceed),                                               \
 
1366
  UTLD (transform_procedure_entries),                                   \
 
1367
  UTLD (transform_procedure_table),                                     \
 
1368
  UTLD (change_vm_protection),                                          \
 
1369
  UTLD (hppa_reset_hook),                                               \
 
1370
  UTLD (hppa_update_primitive_table),                                   \
 
1371
  UTLD (hppa_grow_primitive_table),                                     \
 
1372
  UTLD (hppa_extract_absolute_address),                                 \
 
1373
  UTLD (hppa_store_absolute_address),                                   \
 
1374
  UTLD (flush_i_cache),                                                 \
 
1375
  UTLD (push_d_cache_region),                                           \
 
1376
  UTLD (flush_i_cache_initialize)
 
1377
 
 
1378
#endif /* IN_CMPINT_C */
 
1379
 
 
1380
#endif /* CMPINTMD_H_INCLUDED */