home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / cmpauxmd / mc68k.m4 < prev    next >
Encoding:
Text File  |  2000-12-05  |  22.0 KB  |  719 lines
  1. ### -*-Midas-*-
  2. ###
  3. ### $Id: mc68k.m4,v 1.27 2000/12/05 21:23:50 cph Exp $
  4. ###
  5. ### Copyright (c) 1989-2000 Massachusetts Institute of Technology
  6. ###
  7. ### This program is free software; you can redistribute it and/or
  8. ### modify it under the terms of the GNU General Public License as
  9. ### published by the Free Software Foundation; either version 2 of the
  10. ### License, or (at your option) any later version.
  11. ###
  12. ### This program is distributed in the hope that it will be useful,
  13. ### but 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. #### 68K assembly language (HP/Motorola Syntax) part of the compiled
  23. #### code interface.  See cmpint.txt, cmpint.c, cmpint-mc68k.h, and
  24. #### cmpgc.h for more documentation.
  25. ####
  26. #### NOTE:
  27. ####    Assumptions:
  28. ####
  29. ####    1) All registers (except double floating point registers) and
  30. ####    stack locations hold a C long object.
  31. ####
  32. ####    2) The C compiler divides registers into three groups:
  33. ####    - Linkage registers, used for procedure calls and global
  34. ####    references.  On MC68K: a6, sp.
  35. ####    - super temporaries, not preserved accross procedure calls and
  36. ####    always usable. On MC68K: a0, a1, d0, d1
  37. ####    - preserved registers saved by the callee if they are written.
  38. ####    On MC68K: all others.
  39. ####
  40. ####    3) Arguments, if passed on a stack, are popped by the caller
  41. ####    or by the procedure return instruction (as on the VAX).  Thus
  42. ####    most "leaf" procedures need not worry about them.
  43. ####
  44. ####    4) There is a hardware or software maintained stack for
  45. ####    control.  The procedure calling sequence may leave return
  46. ####    addresses in registers, but they must be saved somewhere for
  47. ####    nested calls and recursive procedures.  On MC68K: saved on
  48. ####    the stack.
  49. ####
  50. ####    5) C procedures return long values in a super temporary
  51. ####    register.  Two word structures are returned in super temporary
  52. ####    registers as well.  On MC68K: d0 is used for long returns.
  53. ####    Since there are two methods for returning structures on MC68K,
  54. ####    there is a flag to choose a mechanism:
  55. ####    o  GCC returns two word structures in d0/d1 (set flag GCC in
  56. ####       M4_MACHINE_SWITCHES in m.h)
  57. ####    o  Other compilers return the address of the structure in d0
  58. ####    o  The HP compiler requires that the address of this structure
  59. ####       be in a1 before the procedure is called (set flag HP in
  60. ####       M4_MACHINE_SWITCHES in m.h)
  61. ####
  62. ####    6) Floating point registers are not preserved by this
  63. ####    interface.  The interface is only called from the Scheme
  64. ####    interpreter, which does not use floating point data.  Thus
  65. ####    although the calling convention would require us to preserve
  66. ####    them, they contain garbage.
  67. ####
  68. #### Compiled Scheme code uses the following register convention:
  69. ####    - a7 (sp) contains the Scheme stack pointer, not the C stack
  70. ####    pointer.
  71. ####    - a6 (fp) contains a pointer to the Scheme interpreter's
  72. ####    "register" block.  This block contains the compiler's copy of
  73. ####    MemTop, the interpreter's registers (val, env, exp, etc),
  74. ####    temporary locations for compiled code, and the mechanism used
  75. ####    to invoke the hooks in this file.
  76. ####    - a5 contains the Scheme free pointer.
  77. ####    - a4 contains the dynamic link when needed.
  78. ####    - d7 contains the Scheme datum mask.
  79. ####    - d6 is where Scheme compiled code returns values.
  80. ####
  81. ####    All other registers are available to the compiler.  A
  82. ####    caller-saves convention is used, so the registers need not be
  83. ####    preserved by subprocedures.
  84.  
  85. ####    Utility macros and definitions
  86.  
  87. define(KEEP_HISTORY,0)            # Debugging switch
  88.  
  89. define(reference_external,`')        # Declare desire to use an external
  90. define(extern_c_label,`_$1')        # The actual reference
  91.  
  92. define(define_c_label,
  93. `    global    extern_c_label($1)
  94. extern_c_label($1):')
  95.  
  96. define(define_debugging_label,
  97. `    global    $1
  98. $1:')
  99.  
  100. # Call a SCHEME_UTILITY (see cmpint.c) and then dispatch to the
  101. # interface procedure requested with the data to be passed to the
  102. # procedure in d1.
  103. #
  104. # NOTE: Read introductory note about GCC and HP switches
  105.  
  106. define(allocate_utility_result,
  107.     `ifdef(`HP',
  108.           `subq.l    &8,%sp
  109.            mov.l    %sp,%a1',
  110.           `')')
  111.  
  112.  
  113. define(utility_call,
  114.        `jsr    (%a0)        # call C procedure
  115.     ifdef(`HP',
  116.           `lea    eval(($1+2)*4)(%sp),%sp',
  117.               `lea    eval($1*4)(%sp),%sp')
  118.     mov.l    %d0,%a0
  119.     ifdef(`GCC',
  120.               `',
  121.           `mov.l    4(%a0),%d1
  122.            mov.l    0(%a0),%a0')
  123.     jmp    (%a0)')
  124.  
  125. # Scheme object representation.  Must match object.h
  126.  
  127. define(HEX, `0x$1')
  128. define(TC_LENGTH, ifdef(`TYPE_CODE_LENGTH', TYPE_CODE_LENGTH, 6))
  129. define(ADDRESS_MASK, eval(((2 ** (32 - TC_LENGTH)) - 1), 16))
  130. define(TYPE_CODE_FACTOR, eval(2 ** (8 - TC_LENGTH)))
  131. define(TYPE_CODE_MASK, eval((256 - TYPE_CODE_FACTOR), 16))
  132. define(CLEAR_TYPE_MASK, eval((TYPE_CODE_FACTOR - 1), 16))
  133.  
  134. define(TYPE_CODE_TO_BYTE, `$1*TYPE_CODE_FACTOR')
  135. define(TYPE_CODE_TO_OBJECT, `TYPE_CODE_TO_BYTE($1)*0x1000000')
  136.  
  137. define(EXTRACT_TYPE_CODE,
  138.     `ifelse(TC_LENGTH, 8,
  139.     `mov.b    $1,$2',
  140.     `mov.b    $1,$2
  141.     and.b    &HEX(TYPE_CODE_MASK), $2')')
  142.  
  143. define(COMPARE_TYPE_CODE,
  144.     `cmp.b    $1,&TYPE_CODE_TO_BYTE($2)')
  145.  
  146. ### External conventions
  147.  
  148.     set    regblock_memtop,0    # from const.h (* 4)
  149.     set    regblock_int_mask,4
  150.     set    regblock_val,8
  151.     set    regblock_stack_guard,44
  152.     set    regblock_int_code,48
  153.     set    address_mask,HEX(ADDRESS_MASK)
  154.  
  155. # This must match the compiler (machin.scm)
  156.  
  157. define(dlink, %a4)            # Dynamic link register (contains a
  158.                     # pointer to a return address) 
  159. define(rfree, %a5)            # Free pointer
  160. define(regs, %a6)            # Pointer to Registers[0]
  161. define(rmask, %d7)            # Mask to clear type code
  162. define(rval,%d6)            # Procedure value
  163.  
  164. reference_external(Ext_Stack_Pointer)
  165. reference_external(Free)
  166. reference_external(Registers)
  167.  
  168. # These must match the C compiler
  169.  
  170. define(switch_to_scheme_registers,
  171.     `mov.l    %a6,(%sp)
  172.     mov.l    %sp,c_save_stack
  173.     mov.l    extern_c_label(Ext_Stack_Pointer),%sp
  174.     mov.l    extern_c_label(Free),rfree
  175.     lea    extern_c_label(Registers),regs
  176.     mov.l    &address_mask,rmask')
  177.  
  178. define(switch_to_C_registers,
  179.     `mov.l    rfree,extern_c_label(Free)
  180.     mov.l    %sp,extern_c_label(Ext_Stack_Pointer)
  181.     mov.l    c_save_stack,%sp
  182.     mov.l    (%sp),%a6')
  183.  
  184. ###
  185. ### Global data
  186. ###
  187.  
  188.     data
  189.  
  190. define_debugging_label(c_save_stack)
  191.     space    4
  192. ifelse(KEEP_HISTORY, 1,
  193. `define_debugging_label(ring_pointer)
  194.     long    ring_block_1
  195. define_debugging_label(ring_block_1)
  196.     long    ring_block_2
  197.     space    28
  198. define_debugging_label(ring_block_2)
  199.     long    ring_block_3
  200.     space    28
  201. define_debugging_label(ring_block_3)
  202.     long    ring_block_4
  203.     space    28
  204. define_debugging_label(ring_block_4)
  205.     long    ring_block_5
  206.     space    28
  207. define_debugging_label(ring_block_5)
  208.     long    ring_block_1
  209.     space    28')
  210.     text
  211.  
  212. ### Initialize the 68881 if present.
  213.  
  214. define_c_label(interface_initialize)
  215.     link    %a6,&0
  216.     ifdef(`MC68881', `fmov.l    &0x3480,%fpcr')
  217.     unlk    %a6
  218.     rts
  219.  
  220. ### Callable by C conventions.  Swaps to Scheme register set and jumps
  221. ### to the entry point specified by its only argument.
  222.  
  223. define_c_label(C_to_interface)
  224.     link    %a6,&-44
  225.     movm.l    %d2-%d7/%a2-%a5,4(%sp)
  226.     mov.l    8(%a6),%a0        # Argument: entry point
  227.     bra.b    interface_to_scheme_internal
  228.  
  229. ### Called by Scheme through a jump instruction in the register block.
  230. ### It expects an index in %d0, and 4 longword arguments in %d1-%d4
  231.  
  232. reference_external(utility_table)
  233.  
  234. define_c_label(asm_scheme_to_interface)
  235. define_debugging_label(scheme_to_interface)
  236.     ifelse(KEEP_HISTORY, 1,
  237.     `lea    ring_pointer,%a1
  238.     mov.l    (%a1),%a0
  239.     mov.l    (%a0),(%a1)
  240.     mov.l    %sp,4(%a0)
  241.     mov.l    %a5,8(%a0)
  242.     mov.l    %d0,12(%a0)
  243.     mov.l    %d1,16(%a0)
  244.     mov.l    %d2,20(%a0)
  245.     mov.l    %d3,24(%a0)
  246.     mov.l    %d4,28(%a0)
  247.     cmp.l    %sp,%a5
  248.     bgt.b    scheme_to_interface_proceed
  249.     nop
  250. define_debugging_label(scheme_to_interface_proceed)')
  251.     mov.l    rval,regblock_val(regs)
  252.     switch_to_C_registers()
  253.     allocate_utility_result()
  254.     mov.l    %d4,-(%sp)        # Push arguments to scheme utility
  255.     mov.l    %d3,-(%sp)
  256.     mov.l    %d2,-(%sp)
  257.     mov.l    %d1,-(%sp)
  258.     lea    extern_c_label(utility_table),%a0
  259.     mov.l    (0,%a0,%d0.w*4),%a0    # C-written Scheme utility
  260.     utility_call(4)                 # 4 arguments
  261.  
  262. ### The data in %d1 is the address of an entry point to invoke.
  263.  
  264. define_c_label(interface_to_scheme)
  265.     mov.l    %d1,%a0
  266. ###
  267. ###    Enter the scheme compiled world.
  268. ###    The value register is copied to %d0 because some utilities are
  269. ###    expected to return their value there (this should be fixed),
  270. ###    and it is stripped and placed in the dlink register since
  271. ###    we may be returning after interrupting a procedure which
  272. ###    needs this register.  This should also be separated or handled
  273. ###    inline.
  274. ###
  275. define_debugging_label(interface_to_scheme_internal)
  276.     switch_to_scheme_registers()
  277.     mov.l    regblock_val(regs),rval
  278.     mov.l    rval,%d0
  279.     mov.l    %d0,%d1
  280.     and.l    rmask,%d1
  281.     mov.l    %d1,dlink    
  282.     jmp    (%a0)
  283.  
  284. ### The data in %d1 is a return code (integer) to the interpreter.
  285.  
  286. define_c_label(interface_to_C)
  287.     mov.l    %d1,%d0            # C return value location
  288.     movm.l    4(%sp),%d2-%d7/%a2-%a5
  289.     unlk    %a6
  290.     rts    
  291.  
  292. #### Optimized entry points
  293.  
  294. ### Additional entry points that take care of common cases and are used to
  295. ### shorten code sequences.
  296. ### These are not strictly necessary, since the code sequences emitted by
  297. ### the compiler could use scheme_to_interface instead, but a few instructions
  298. ### are saved this way.
  299.  
  300. ### Called by linker-generated trampolines to invoke the appropriate
  301. ### C-written handler.  The return address on the stack is the address
  302. ### of the trampoline storage area, passed to the C handler as the
  303. ### first argument.
  304.  
  305. ### IMPORTANT:
  306. ### All the asm_* routines are declared in cmpint-mc68k.h.
  307. ### New ones need to be declared there as well!
  308.  
  309. define_c_label(asm_trampoline_to_interface)
  310. define_debugging_label(trampoline_to_interface)
  311.     mov.l    (%sp)+,%d1
  312.     bra    scheme_to_interface
  313.  
  314. ### Called by Scheme through a jump instruction in the register block.
  315. ### It is a special version of scheme_to_interface below, used when
  316. ### a return address is stored in the Scheme stack.
  317.  
  318. define_c_label(asm_scheme_to_interface_jsr)
  319. define_debugging_label(scheme_to_interface_jsr)
  320.     mov.l    (%sp)+,%d1              # Return addr -> d1
  321.     addq.l    &4,%d1            # Skip format info.
  322.     bra    scheme_to_interface
  323.  
  324. define(define_interface_indirection,
  325. `define_c_label(asm_$1)
  326.     movq    &HEX($2),%d0
  327.     bra    scheme_to_interface')
  328.  
  329. define(define_interface_jsr_indirection,
  330. `define_c_label(asm_$1)
  331.     movq    &HEX($2),%d0
  332.     bra    scheme_to_interface_jsr')
  333.  
  334. define_interface_indirection(primitive_lexpr_apply,13)
  335. define_interface_indirection(error,15)
  336. define_interface_jsr_indirection(link,17)
  337. define_interface_indirection(interrupt_closure,18)
  338. define_interface_jsr_indirection(interrupt_procedure,1a)
  339. define_interface_jsr_indirection(interrupt_continuation,1b)
  340. define_interface_jsr_indirection(assignment_trap,1d)
  341. define_interface_jsr_indirection(reference_trap,1f)
  342. define_interface_jsr_indirection(safe_reference_trap,20)
  343. ###
  344. ### These are handled directly below.
  345. ###
  346. ### define_interface_indirection(generic_decrement,22)
  347. ### define_interface_indirection(generic_divide,23)
  348. ### define_interface_indirection(generic_equal,24)
  349. ### define_interface_indirection(generic_greater,25)
  350. ### define_interface_indirection(generic_increment,26)
  351. ### define_interface_indirection(generic_less,27)
  352. ### define_interface_indirection(generic_subtract,28)
  353. ### define_interface_indirection(generic_multiply,29)
  354. ### define_interface_indirection(generic_negative,2a)
  355. ### define_interface_indirection(generic_add,2b)
  356. ### define_interface_indirection(generic_positive,2c)
  357. ### define_interface_indirection(generic_zero,2d)
  358. ###
  359. define_interface_jsr_indirection(primitive_error,36)
  360. define_interface_indirection(generic_quotient,37)
  361. define_interface_indirection(generic_remainder,38)
  362. define_interface_indirection(generic_modulo,39)
  363.  
  364. # Save an additional instruction here to load the dynamic link.
  365. define_c_label(asm_interrupt_dlink)
  366.     mov.l    dlink,%d2        # Dynamic link -> d2
  367.     movq    &HEX(19),%d0
  368.     bra    scheme_to_interface_jsr
  369.  
  370. # Bum this one for speed.
  371. define_c_label(asm_primitive_apply)
  372.     switch_to_C_registers()
  373.     allocate_utility_result()
  374.     mov.l    %d1,-(%sp)        # only one argument
  375.     ifdef(`SUNASM',
  376.     `lea    extern_c_label(utility_table),%a0
  377.     mov.l    HEX(12)*4(%a0),%a0',
  378.     `mov.l    extern_c_label(utility_table)+HEX(12)*4,%a0')
  379.     utility_call(1)                 # one argument
  380.  
  381.     set    tc_compiled_entry,HEX(28)
  382.     set    tc_flonum,HEX(06)
  383.     set    tc_fixnum,HEX(1A)
  384.     set    tc_manifest_nmv,HEX(27)
  385.     set    tc_false,HEX(0)
  386.     set    tc_true,HEX(8)
  387.     set    offset_apply,HEX(14)
  388.  
  389. define(call_utility,
  390.     `movq    &offset_$1,%d0
  391.     bra    scheme_to_interface')
  392.  
  393. ### Called by Scheme when invoking an unknown procedure.
  394. ### Having this short sequence in assembly language avoids the C call
  395. ### in the common case where the procedure is compiled and the number
  396. ### of arguments is correct.
  397. ### The number of actual arguments is in d2, the procedure on top
  398. ### of the stack.
  399.  
  400. define_c_label(asm_shortcircuit_apply)
  401. define_debugging_label(shortcircuit_apply)
  402.     EXTRACT_TYPE_CODE((%sp),%d0)    # Get procedure type
  403.     mov.l    (%sp)+,%d1        # Get procedure
  404.     COMPARE_TYPE_CODE(%d0,tc_compiled_entry)
  405.     bne.b    shortcircuit_apply_1
  406.     mov.l    %d1,%d3            # Extract entry point
  407.     and.l    rmask,%d3
  408.     mov.l    %d3,%a0
  409.     mov.b    -3(%a0),%d3        # Extract the frame size
  410.     ext.w    %d3
  411.     cmp.w    %d2,%d3            # Is the frame size right?
  412.     bne.b    shortcircuit_apply_1
  413.     jmp    (%a0)            # Invoke
  414.  
  415. define_debugging_label(shortcircuit_apply_1)
  416.     call_utility(apply)
  417.  
  418. ### Optimized versions of shortcircuit_apply for 0-7 arguments.
  419.  
  420. define(define_apply_size_n,
  421. `define_c_label(asm_shortcircuit_apply_size_$1)
  422. define_debugging_label(shortcircuit_apply_size_$1)
  423.     EXTRACT_TYPE_CODE((%sp),%d0)    # Get procedure type
  424.     mov.l    (%sp)+,%d1        # Get procedure
  425.     COMPARE_TYPE_CODE(%d0,tc_compiled_entry)
  426.     bne.b    shortcircuit_apply_size_$1_1
  427.     mov.l    %d1,%d3            # Extract entry point
  428.     and.l    rmask,%d3
  429.     mov.l    %d3,%a0
  430.     cmp.b    -3(%a0),&$1        # Is the frame size right?
  431.     bne.b    shortcircuit_apply_size_$1_1
  432.     jmp    (%a0)            # Invoke
  433.  
  434. define_debugging_label(shortcircuit_apply_size_$1_1)
  435.     movq    &$1,%d2            # initialize frame size
  436.     call_utility(apply)')
  437.  
  438. define_apply_size_n(1)
  439. define_apply_size_n(2)
  440. define_apply_size_n(3)
  441. define_apply_size_n(4)
  442. define_apply_size_n(5)
  443. define_apply_size_n(6)
  444. define_apply_size_n(7)
  445. define_apply_size_n(8)
  446.  
  447. ###    This utility depends on the C compiler preserving d2-d7 and a2-a7.
  448. ###    It takes its parameters in d0 and d1, and returns its value in a0.
  449.  
  450. define_c_label(asm_allocate_closure)
  451.     switch_to_C_registers()
  452.     mov.l    %a1,-(%sp)        # Preserve reg.
  453.     mov.l    %d1,-(%sp)        # Preserve reg.
  454.     mov.l    %d0,-(%sp)        # Push arg.
  455.     jsr    extern_c_label(allocate_closure)
  456.     addq.l    &4,%sp            # Pop arg.
  457.     mov.l    %d0,%a0            # Return value
  458.     mov.l    (%sp)+,%d1        # Restore reg.
  459.     mov.l    (%sp)+,%a1        # Restore reg.
  460.     switch_to_scheme_registers()
  461.     rts
  462.  
  463. ###    These utilities improve the performance of floating point code
  464. ###    significantly.
  465. ###    Arguments on top of the stack followed by the return address.
  466.  
  467. define_debugging_label(asm_generic_flonum_result)
  468.     mov.l    rfree,rval
  469.     mov.l    &TYPE_CODE_TO_OBJECT(tc_manifest_nmv)+2,(rfree)+
  470.     fmove.d    %fp0,(rfree)+
  471.     or.l    &TYPE_CODE_TO_OBJECT(tc_flonum),rval
  472.     and.b    &TYPE_CODE_TO_BYTE(1)-1,(%sp)
  473.     rts
  474.  
  475. define_debugging_label(asm_true_result)
  476.     mov.l    &TYPE_CODE_TO_OBJECT(tc_true),rval
  477.     and.b    &TYPE_CODE_TO_BYTE(1)-1,(%sp)
  478.     rts
  479.  
  480. define_debugging_label(asm_false_result)
  481.     mov.l    &TYPE_CODE_TO_OBJECT(tc_false),rval
  482.     and.b    &TYPE_CODE_TO_BYTE(1)-1,(%sp)
  483.     rts
  484.  
  485. define(define_generic_unary,
  486. `define_c_label(asm_generic_$1)
  487.     EXTRACT_TYPE_CODE((%sp),%d0)    # Get arg1s type
  488.      COMPARE_TYPE_CODE(%d0,tc_flonum)
  489.     bne.b    asm_generic_$1_hook
  490.     mov.l    (%sp)+,%d0        # arg1
  491.     and.l    rmask,%d0
  492.     mov.l    %d0,%a0
  493.     fmove.d    4(%a0),%fp0
  494.     $3.b    &1,%fp0
  495.     bra    asm_generic_flonum_result
  496.  
  497. asm_generic_$1_hook:
  498.     movq    &HEX($2),%d0
  499.     bra    scheme_to_interface')
  500.  
  501. define(define_generic_unary_predicate,
  502. `define_c_label(asm_generic_$1)
  503.     EXTRACT_TYPE_CODE((%sp),%d0)    # Get arg1s type
  504.      COMPARE_TYPE_CODE(%d0,tc_flonum)
  505.     bne.b    asm_generic_$1_hook
  506.     mov.l    (%sp)+,%d0        # arg1
  507.     and.l    rmask,%d0
  508.     mov.l    %d0,%a0
  509.     fmove.d    4(%a0),%fp0
  510.     fb$3    asm_true_result
  511.     bra    asm_false_result
  512.  
  513. asm_generic_$1_hook:
  514.     movq    &HEX($2),%d0
  515.     bra    scheme_to_interface')
  516.  
  517. define(define_generic_binary,
  518. `define_c_label(asm_generic_$1)
  519.     EXTRACT_TYPE_CODE((%sp),%d0)    # Get arg1s type
  520.     EXTRACT_TYPE_CODE(4(%sp),%d1)    # Get arg2s type
  521.     mov.l    (%sp),%d2        # arg1
  522.     mov.l    4(%sp),%d3        # arg2
  523.     and.l    rmask,%d2
  524.     and.l    rmask,%d3
  525.     mov.l    %d2,%a0
  526.     mov.l    %d3,%a1
  527.      COMPARE_TYPE_CODE(%d0,tc_flonum)
  528.     bne.b    asm_generic_$1_fix_flo
  529.     COMPARE_TYPE_CODE(%d1,tc_flonum)
  530.     bne.b    asm_generic_$1_flo_fix
  531.     fmove.d    4(%a0),%fp0
  532.     $3.d    4(%a1),%fp0
  533.     addq.l    &8,%sp
  534.     bra    asm_generic_flonum_result
  535.  
  536. asm_generic_$1_fix_flo:
  537.     COMPARE_TYPE_CODE(%d0,tc_fixnum)
  538.     bne.b    asm_generic_$1_hook
  539.     COMPARE_TYPE_CODE(%d1,tc_flonum)
  540.     bne.b    asm_generic_$1_hook
  541.     lsl.l    &TC_LENGTH,%d2
  542.     asr.l    &TC_LENGTH,%d2
  543.     fmove.l    %d2,%fp0
  544.     $3.d    4(%a1),%fp0
  545.     addq.l    &8,%sp
  546.     bra    asm_generic_flonum_result
  547.  
  548. asm_generic_$1_flo_fix:
  549.     COMPARE_TYPE_CODE(%d1,tc_fixnum)
  550.     bne.b    asm_generic_$1_hook
  551.     lsl.l    &TC_LENGTH,%d3
  552.     asr.l    &TC_LENGTH,%d3
  553.     fmove.d    4(%a0),%fp0
  554.     $3.l    %d3,%fp0
  555.     addq.l    &8,%sp
  556.     bra    asm_generic_flonum_result
  557.  
  558. asm_generic_$1_hook:
  559.     movq    &HEX($2),%d0
  560.     bra    scheme_to_interface')
  561.  
  562. define(define_generic_binary_predicate,
  563. `define_c_label(asm_generic_$1)
  564.     EXTRACT_TYPE_CODE((%sp),%d0)    # Get arg1s type
  565.     EXTRACT_TYPE_CODE(4(%sp),%d1)    # Get arg2s type
  566.     mov.l    (%sp),%d2        # arg1
  567.     mov.l    4(%sp),%d3        # arg2
  568.     and.l    rmask,%d2
  569.     and.l    rmask,%d3
  570.     mov.l    %d2,%a0
  571.     mov.l    %d3,%a1
  572.      COMPARE_TYPE_CODE(%d0,tc_flonum)
  573.     bne.b    asm_generic_$1_fix_flo
  574.     COMPARE_TYPE_CODE(%d1,tc_flonum)
  575.     bne.b    asm_generic_$1_flo_fix
  576.     addq.l    &8,%sp
  577.     fmove.d    4(%a0),%fp0
  578.     fcmp.d    %fp0,4(%a1)
  579.     fb$3    asm_true_result
  580.     bra    asm_false_result
  581.  
  582. asm_generic_$1_fix_flo:
  583.     COMPARE_TYPE_CODE(%d0,tc_fixnum)
  584.     bne.b    asm_generic_$1_hook
  585.     COMPARE_TYPE_CODE(%d1,tc_flonum)
  586.     bne.b    asm_generic_$1_hook
  587.     addq.l    &8,%sp
  588.     lsl.l    &TC_LENGTH,%d2
  589.     asr.l    &TC_LENGTH,%d2
  590.     fmove.l    %d2,%fp0
  591.     fcmp.d    %fp0,4(%a1)
  592.     fb$3    asm_true_result
  593.     bra    asm_false_result
  594.  
  595. asm_generic_$1_flo_fix:
  596.     COMPARE_TYPE_CODE(%d1,tc_fixnum)
  597.     bne.b    asm_generic_$1_hook
  598.     addq.l    &8,%sp
  599.     lsl.l    &TC_LENGTH,%d3
  600.     asr.l    &TC_LENGTH,%d3
  601.     fmove.d    4(%a0),%fp0
  602.     fcmp.l    %fp0,%d3
  603.     fb$3    asm_true_result
  604.     bra    asm_false_result
  605.  
  606. asm_generic_$1_hook:
  607.     movq    &HEX($2),%d0
  608.     bra    scheme_to_interface')
  609.  
  610. define_generic_unary(decrement,22,fsub)
  611. define_generic_binary(divide,23,fdiv)
  612. define_generic_binary_predicate(equal,24,eq)
  613. define_generic_binary_predicate(greater,25,gt)
  614. define_generic_unary(increment,26,fadd)
  615. define_generic_binary_predicate(less,27,lt)
  616. define_generic_binary(subtract,28,fsub)
  617. define_generic_binary(multiply,29,fmul)
  618. define_generic_unary_predicate(negative,2a,lt)
  619. define_generic_binary(add,2b,fadd)
  620. define_generic_unary_predicate(positive,2c,gt)
  621. define_generic_unary_predicate(zero,2d,eq)
  622.  
  623. ### Close-coded stack and interrupt check for use when stack checking
  624. ### is enabled.
  625.  
  626. define_c_label(asm_stack_and_interrupt_check_12)
  627.     mov.l    &-12,-(%sp)
  628.     bra.b    stack_and_interrupt_check
  629.  
  630. define_c_label(asm_stack_and_interrupt_check_14)
  631.     mov.l    &-14,-(%sp)
  632.     bra.b    stack_and_interrupt_check
  633.  
  634. define_c_label(asm_stack_and_interrupt_check_18)
  635.     mov.l    &-18,-(%sp)
  636.     bra.b    stack_and_interrupt_check
  637.  
  638. define_c_label(asm_stack_and_interrupt_check_22)
  639.     mov.l    &-22,-(%sp)
  640.     bra.b    stack_and_interrupt_check
  641.  
  642. define_c_label(asm_stack_and_interrupt_check_24)
  643.     mov.l    &-24,-(%sp)
  644. #    bra.b    stack_and_interrupt_check
  645.  
  646. ### On entry, 4(%sp) contains the resumption address, and 0(%sp) is
  647. ### the offset between the resumption address and the GC label
  648. ### address.
  649. define_debugging_label(stack_and_interrupt_check)
  650.  
  651. ### If the Scheme stack pointer is <= Stack_Guard, then the stack has
  652. ### overflowed -- in which case we must signal a stack-overflow interrupt.
  653.     cmp.l    %sp,regblock_stack_guard(regs)
  654.     bgt.b    stack_and_interrupt_check_1
  655.  
  656. ### Set the stack-overflow interrupt bit. If the stack-overflow
  657. ### interrupt is disabled, skip forward to gc test.  Otherwise, set
  658. ### MemTop to -1 and signal the interrupt.
  659.     bset    &0,regblock_int_code+3(regs)
  660.     btst    &0,regblock_int_mask+3(regs)
  661.     beq.b    stack_and_interrupt_check_1
  662.     mov.l    &-1,regblock_memtop(regs)
  663.     bra.b    stack_and_interrupt_check_2
  664.  
  665. ### If (Free >= MemTop), signal an interrupt.
  666. stack_and_interrupt_check_1:
  667.     cmp.l    rfree,regblock_memtop(regs)
  668.     bge.b    stack_and_interrupt_check_2
  669.  
  670. ### No action necessary -- return to resumption address.
  671.     addq.l    &4,%sp
  672.     rts
  673.  
  674. ### Must signal the interrupt -- return to GC label instead.
  675. stack_and_interrupt_check_2:
  676.     mov.l    %d0,-(%sp)
  677.     mov.l    4(%sp),%d0
  678.     add.l    %d0,8(%sp)
  679.     mov.l    (%sp),%d0
  680.     addq.l    &8,%sp
  681.     rts
  682.  
  683. ### Assembly-language implementation of SET-INTERRUPT-ENABLES!
  684. ### primitive.  Argument appears at top of stack, return address below
  685. ### that.
  686.  
  687. define_c_label(asm_set_interrupt_enables)
  688. define_debugging_label(set_interrupt_enables)
  689.     # Return value is previous contents of mask register.
  690.     mov.l    regblock_int_mask(regs),rval
  691.     or.l    &TYPE_CODE_TO_OBJECT(tc_fixnum),rval
  692.     mov.l    (%sp)+,%d0        # get new interrupt mask
  693.     and.l    rmask,%d0        # strip fixnum type
  694.     mov.l    %d0,regblock_int_mask(regs) # store it in mask register
  695.     # Setup compiled memtop register: -1 if pending interrupt,
  696.     # Memtop if GC enabled, else Heap_Top.
  697.     movq    &-1,%d1
  698.     mov.l    regblock_int_code(regs),%d2
  699.     and.l    %d0,%d2
  700.     bne.b    set_interrupt_enables_1
  701.     mov.l    extern_c_label(MemTop),%d1
  702.     btst    &2,%d0
  703.     bne.b    set_interrupt_enables_1
  704.     mov.l    extern_c_label(Heap_Top),%d1
  705. set_interrupt_enables_1:
  706.     mov.l    %d1,regblock_memtop(regs)
  707.     # Setup compiled stack_guard register: Stack_Guard if
  708.     # stack-overflow enabled, else Stack_Bottom
  709.     mov.l    extern_c_label(Stack_Guard),%d1
  710.     btst    &0,%d0
  711.     bne.b    set_interrupt_enables_2
  712.     mov.l    extern_c_label(Stack_Bottom),%d1
  713. set_interrupt_enables_2:
  714.     mov.l    %d1,regblock_stack_guard(regs)
  715.     mov.l    (%sp)+,%d0
  716.     and.l    rmask,%d0
  717.     mov.l    %d0,%a0
  718.     jmp    (%a0)
  719.