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 / cmpint.h < prev    next >
C/C++ Source or Header  |  2000-12-05  |  9KB  |  274 lines
  1. /* -*-C-*-
  2.  
  3. $Id: cmpint.h,v 10.7 2000/12/05 21:23:43 cph Exp $
  4.  
  5. Copyright (c) 1987-1990, 1999, 2000 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. /* Macros for the interface between compiled code and interpreted code. */
  23.  
  24. /* Stack Gap Operations: */
  25.  
  26. /* With_Stack_Gap opens a gap Gap_Size wide Gap_Position cells above the
  27.  * top of the stack.  Code must push Gap_Size objects.  It executes Code
  28.  * with the stack pointer placed so that these objects will fill the gap.
  29.  */
  30.  
  31. #define With_Stack_Gap(Gap_Size, Gap_Position, Code)            \
  32. {                                    \
  33.   fast long size_to_move = (Gap_Position);                \
  34.   fast SCHEME_OBJECT * Destination = (STACK_LOC (- (Gap_Size)));    \
  35.   SCHEME_OBJECT * Saved_Destination = Destination;            \
  36.   while ((--size_to_move) >= 0)                        \
  37.     (STACK_LOCATIVE_POP (Destination)) = (STACK_POP ());        \
  38.   Code;                                    \
  39.   Stack_Pointer = Saved_Destination;                    \
  40. }
  41.  
  42. /* Close_Stack_Gap closes a gap Gap_Size wide Gap_Position cells above the
  43.  * top of the stack.  The contents of the gap are lost.
  44.  */
  45.  
  46. #define Close_Stack_Gap(Gap_Size, Gap_Position, extra_code)        \
  47. {                                    \
  48.   fast long size_to_move;                        \
  49.   fast SCHEME_OBJECT *Source;                        \
  50.                                     \
  51.   size_to_move = (Gap_Position);                    \
  52.   Source = (STACK_LOC (size_to_move));                    \
  53.   Stack_Pointer = (STACK_LOC ((Gap_Size) + size_to_move));        \
  54.   extra_code;                                \
  55.   while (--size_to_move >= 0)                        \
  56.   {                                    \
  57.     STACK_PUSH (STACK_LOCATIVE_PUSH (Source));                \
  58.   }                                    \
  59. }
  60.  
  61. /* Going from interpreted code to compiled code */
  62.  
  63. /* Tail recursion is handled as follows:
  64.    if the return code is `reenter_compiled_code', it is discarded,
  65.    and the two contiguous interpreter segments on the stack are
  66.    merged.
  67.  */
  68.  
  69. /* Apply interface:
  70.    calling a compiled procedure with a frame nslots long.
  71.  */
  72.  
  73. #define apply_compiled_setup(nslots)                    \
  74. {                                    \
  75.   long frame_size;                            \
  76.                                     \
  77.   frame_size = (nslots);                        \
  78.   if (STACK_REF(frame_size + CONTINUATION_RETURN_CODE) ==        \
  79.       (MAKE_OBJECT (TC_RETURN_CODE, RC_REENTER_COMPILED_CODE)))        \
  80.   {                                    \
  81.     /* Merge compiled code segments on the stack. */            \
  82.     Close_Stack_Gap (CONTINUATION_SIZE,                    \
  83.              frame_size,                    \
  84.            {                            \
  85.              long segment_size =                \
  86.                (OBJECT_DATUM                    \
  87.             (STACK_REF                    \
  88.              (CONTINUATION_EXPRESSION -            \
  89.               CONTINUATION_SIZE)));                \
  90.              last_return_code = (STACK_LOC (segment_size));    \
  91.            });                            \
  92.     /* Undo the subproblem rotation. */                    \
  93.     Compiler_End_Subproblem();                        \
  94.   }                                    \
  95.   else                                    \
  96.   {                                    \
  97.     /* Make a new compiled code segment which includes this frame. */    \
  98.     /* History need not be hacked here. */                \
  99.     With_Stack_Gap(1,                            \
  100.            frame_size,                        \
  101.          {                            \
  102.            last_return_code = (STACK_LOC (0));            \
  103.            STACK_PUSH (return_to_interpreter);            \
  104.          });                            \
  105.   }                                    \
  106. }
  107.  
  108. /* Eval interface:
  109.    executing a compiled expression.
  110.  */
  111.  
  112. #define execute_compiled_setup()                    \
  113. {                                    \
  114.   if (STACK_REF(CONTINUATION_RETURN_CODE) ==                \
  115.       (MAKE_OBJECT (TC_RETURN_CODE, RC_REENTER_COMPILED_CODE)))        \
  116.   {                                    \
  117.     /* Merge compiled code segments on the stack. */            \
  118.     long segment_size;                            \
  119.                                     \
  120.     Restore_Cont();                            \
  121.     segment_size = OBJECT_DATUM (Fetch_Expression());            \
  122.     last_return_code = (STACK_LOC (segment_size));            \
  123.     /* Undo the subproblem rotation. */                    \
  124.     Compiler_End_Subproblem();                        \
  125.   }                                    \
  126.     else                                \
  127.   {                                    \
  128.     /* Make a new compiled code segment on the stack. */        \
  129.     /* History need not be hacked here. */                \
  130.     last_return_code = (STACK_LOC (0));                    \
  131.     STACK_PUSH (return_to_interpreter);                    \
  132.   }                                    \
  133. }
  134.  
  135. /* Pop return interface:
  136.    Returning to compiled code from the interpreter.
  137.  */
  138.  
  139. #define compiled_code_restart()                        \
  140. {                                    \
  141.   long segment_size = OBJECT_DATUM (Fetch_Expression());        \
  142.   last_return_code = (STACK_LOC (segment_size));            \
  143.   /* Undo the subproblem rotation. */                    \
  144.   Compiler_End_Subproblem();                        \
  145. }
  146.  
  147. /* Going from compiled code to interpreted code */
  148.  
  149. /* Tail recursion is handled in the following way:
  150.    if the return address is `return_to_interpreter', it is discarded,
  151.    and the two contiguous interpreter segments on the stack are
  152.    merged.
  153.  */
  154.  
  155. /* Apply interface:
  156.    calling an interpreted procedure (or unsafe primitive)
  157.    with a frame nslots long.
  158.  */
  159.  
  160. #define compiler_apply_procedure(nslots)                \
  161. {                                    \
  162.   long frame_size = (nslots);                        \
  163.   if ((STACK_REF (frame_size)) == return_to_interpreter)        \
  164.   {                                    \
  165.     Close_Stack_Gap(1, frame_size, {});                    \
  166.     /* Set up the current rib. */                    \
  167.     Compiler_New_Reduction ();                        \
  168.   }                                    \
  169.   else                                    \
  170.     { /* Make a new interpreter segment which includes this frame. */    \
  171.       With_Stack_Gap                            \
  172.     (CONTINUATION_SIZE,                        \
  173.      frame_size,                            \
  174.      {                                \
  175.        long segment_size =                        \
  176.          (STACK_LOCATIVE_DIFFERENCE                    \
  177.           (last_return_code, (STACK_LOC (0))));            \
  178.        Store_Expression (LONG_TO_UNSIGNED_FIXNUM (segment_size));    \
  179.        Store_Return (RC_REENTER_COMPILED_CODE);            \
  180.        Save_Cont ();                        \
  181.      });                                \
  182.       /* Rotate history to a new subproblem. */                \
  183.       Compiler_New_Subproblem ();                    \
  184.     }                                    \
  185. }
  186.  
  187. /* Pop Return interface:
  188.    returning to the interpreter from compiled code.
  189.    Nothing needs to be done at this time.
  190.  */
  191.  
  192. #define compiled_code_done()
  193.  
  194. /* Various handlers for backing out of compiled code. */
  195.  
  196. /* Backing out of apply. */
  197.  
  198. #define apply_compiled_backout()                    \
  199. {                                    \
  200.   compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS +            \
  201.                OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)));\
  202. }
  203.  
  204. /* Backing out of eval. */
  205.  
  206. #define execute_compiled_backout()                    \
  207. {                                    \
  208.   if ((STACK_REF (0)) == return_to_interpreter)                \
  209.   {                                    \
  210.     /* Set up the current rib. */                    \
  211.     Compiler_New_Reduction ();                        \
  212.   }                                    \
  213.   else                                    \
  214.   {                                    \
  215.     long segment_size =                            \
  216.       (STACK_LOCATIVE_DIFFERENCE (last_return_code, (STACK_LOC (0))));    \
  217.     Store_Expression (LONG_TO_UNSIGNED_FIXNUM (segment_size));        \
  218.     Store_Return (RC_REENTER_COMPILED_CODE);                \
  219.     Save_Cont ();                            \
  220.     /* Rotate history to a new subproblem. */                \
  221.     Compiler_New_Subproblem ();                        \
  222.   }                                    \
  223. }
  224.  
  225. /* Backing out because of special errors or interrupts.
  226.    The microcode has already setup a return code with a #F.
  227.    No tail recursion in this case.
  228.    ***
  229.        Is the history manipulation correct?
  230.        Does Microcode_Error do something special?
  231.    ***
  232.  */
  233.  
  234. #define compiled_error_backout()                    \
  235. {                                    \
  236.   long segment_size;                            \
  237.                                     \
  238.   Restore_Cont();                            \
  239.   segment_size =                            \
  240.     (STACK_LOCATIVE_DIFFERENCE (last_return_code, (STACK_LOC (0))));    \
  241.   Store_Expression (LONG_TO_UNSIGNED_FIXNUM (segment_size));        \
  242.   /* The Store_Return is a NOP, the Save_Cont is done by the code    \
  243.      that follows. */                            \
  244.   /* Store_Return (OBJECT_DATUM (Fetch_Return ())); */            \
  245.   /* Save_Cont (); */                            \
  246.   Compiler_New_Subproblem ();                        \
  247. }
  248.  
  249. extern long EXFUN (apply_compiled_procedure, (void));
  250. extern long EXFUN (comp_access_restart, (void));
  251. extern long EXFUN (comp_assignment_restart, (void));
  252. extern long EXFUN (comp_assignment_trap_restart, (void));
  253. extern long EXFUN (comp_cache_lookup_apply_restart, (void));
  254. extern long EXFUN (comp_definition_restart, (void));
  255. extern long EXFUN (comp_error_restart, (void));
  256. extern long EXFUN (comp_interrupt_restart, (void));
  257. extern long EXFUN (comp_link_caches_restart, (void));
  258. extern long EXFUN (comp_lookup_apply_restart, (void));
  259. extern long EXFUN (comp_lookup_trap_restart, (void));
  260. extern long EXFUN (comp_op_lookup_trap_restart, (void));
  261. extern long EXFUN (comp_reference_restart, (void));
  262. extern long EXFUN (comp_safe_lookup_trap_restart, (void));
  263. extern long EXFUN (comp_safe_reference_restart, (void));
  264. extern long EXFUN (comp_unassigned_p_restart, (void));
  265. extern long EXFUN (comp_unassigned_p_trap_restart, (void));
  266. extern long EXFUN (comp_unbound_p_restart, (void));
  267. extern long EXFUN (enter_compiled_expression, (void));
  268. extern long EXFUN (return_to_compiled_code, (void));
  269.  
  270. extern SCHEME_OBJECT * EXFUN
  271.   (compiled_entry_to_block_address, (SCHEME_OBJECT));
  272.  
  273. extern void EXFUN (compiled_entry_type, (SCHEME_OBJECT, long *));
  274.