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 / compiler / rtlbase / rtlty2.scm < prev    next >
Text File  |  1999-01-02  |  8KB  |  237 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rtlty2.scm,v 4.13 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988-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. ;;;; Register Transfer Language Type Definitions
  23. ;;; package: (compiler)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define-integrable rtl:expression? pair?)
  28. (define-integrable rtl:expression-type car)
  29. (define-integrable rtl:address-register cadr)
  30. (define-integrable rtl:address-number caddr)
  31. (define-integrable rtl:test-expression cadr)
  32. (define-integrable rtl:invocation-pushed cadr)
  33. (define-integrable rtl:invocation-continuation caddr)
  34.  
  35. (define-integrable (rtl:set-invocation-continuation! rtl continuation)
  36.   (set-car! (cddr rtl) continuation))
  37.  
  38. ;;;; Locatives
  39.  
  40. ;;; Locatives are used as an intermediate form by the code generator
  41. ;;; to build expressions.  Later, when the expressions are inserted
  42. ;;; into statements, any locatives they contain are eliminated by
  43. ;;; "simplifying" them into sequential instructions using pseudo
  44. ;;; registers.
  45.  
  46. (define-integrable register:environment
  47.   'ENVIRONMENT)
  48.  
  49. (define-integrable register:stack-pointer
  50.   'STACK-POINTER)
  51.  
  52. (define-integrable register:dynamic-link
  53.   'DYNAMIC-LINK)
  54.  
  55. (define-integrable register:value
  56.   'VALUE)
  57.  
  58. (define-integrable register:int-mask
  59.   'INT-MASK)
  60.  
  61. (define-integrable register:memory-top
  62.   'MEMORY-TOP)
  63.  
  64. (define-integrable register:free
  65.   'FREE)
  66.  
  67. (define-integrable (rtl:interpreter-call-result:access)
  68.   (rtl:make-fetch 'INTERPRETER-CALL-RESULT:ACCESS))
  69.  
  70. (define-integrable (rtl:interpreter-call-result:cache-reference)
  71.   (rtl:make-fetch 'INTERPRETER-CALL-RESULT:CACHE-REFERENCE))
  72.  
  73. (define-integrable (rtl:interpreter-call-result:cache-unassigned?)
  74.   (rtl:make-fetch 'INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?))
  75.  
  76. (define-integrable (rtl:interpreter-call-result:lookup)
  77.   (rtl:make-fetch 'INTERPRETER-CALL-RESULT:LOOKUP))
  78.  
  79. (define-integrable (rtl:interpreter-call-result:unassigned?)
  80.   (rtl:make-fetch 'INTERPRETER-CALL-RESULT:UNASSIGNED?))
  81.  
  82. (define-integrable (rtl:interpreter-call-result:unbound?)
  83.   (rtl:make-fetch 'INTERPRETER-CALL-RESULT:UNBOUND?))
  84.  
  85. ;;; "Pre-simplification" locative offsets
  86.  
  87. (define (rtl:locative-offset? locative)
  88.   (and (pair? locative) (eq? (car locative) 'OFFSET)))
  89.  
  90. (define-integrable rtl:locative-offset-base cadr)
  91. (define-integrable rtl:locative-offset-offset caddr)
  92.  
  93. #|
  94. (define (rtl:locative-offset-granularity locative)
  95.   ;; This is kludged up for backward compatibility
  96.   (if (rtl:locative-offset? locative)
  97.       (if (pair? (cdddr locative))
  98.       (cadddr locative)
  99.       'OBJECT)
  100.       (error "Not a locative offset" locative)))
  101. |#
  102. (define-integrable rtl:locative-offset-granularity cadddr)
  103.  
  104. (define-integrable (rtl:locative-byte-offset? locative)
  105.   (eq? (rtl:locative-offset-granularity locative) 'BYTE))
  106.  
  107. (define-integrable (rtl:locative-float-offset? locative)
  108.   (eq? (rtl:locative-offset-granularity locative) 'FLOAT))
  109.  
  110. (define-integrable (rtl:locative-object-offset? locative)
  111.   (eq? (rtl:locative-offset-granularity locative) 'OBJECT))
  112.  
  113. (define-integrable (rtl:locative-offset locative offset)
  114.   (rtl:locative-object-offset locative offset))
  115.  
  116. (define (rtl:locative-byte-offset locative byte-offset)
  117.   (cond ((rtl:locative-offset? locative)
  118.      `(OFFSET ,(rtl:locative-offset-base locative)
  119.           ,(back-end:+
  120.             byte-offset
  121.             (cond ((rtl:locative-byte-offset? locative)
  122.                (rtl:locative-offset-offset locative))
  123.               ((rtl:locative-object-offset? locative)
  124.                (back-end:*
  125.                 (rtl:locative-offset-offset locative)
  126.                 address-units-per-object))
  127.               (else
  128.                (back-end:*
  129.                 (rtl:locative-offset-offset locative)
  130.                 address-units-per-float))))
  131.           BYTE))
  132.     ((back-end:= byte-offset 0)
  133.      locative)
  134.     (else
  135.      `(OFFSET ,locative ,byte-offset BYTE))))
  136.  
  137. (define (rtl:locative-float-offset locative float-offset)
  138.   (let ((default
  139.       (lambda ()
  140.         `(OFFSET ,locative ,float-offset FLOAT))))
  141.     (cond ((rtl:locative-offset? locative)
  142.        (if (rtl:locative-float-offset? locative)
  143.            `(OFFSET ,(rtl:locative-offset-base locative)
  144.             ,(back-end:+ (rtl:locative-offset-offset locative)
  145.                      float-offset)
  146.             FLOAT)
  147.            (default)))
  148.       (else
  149.        (default)))))
  150.  
  151. (define (rtl:locative-object-offset locative offset)
  152.   (cond ((back-end:= offset 0) locative)
  153.     ((rtl:locative-offset? locative)
  154.      (if (not (rtl:locative-object-offset? locative))
  155.          (error "Can't add object offset to non-object offset"
  156.             locative offset)
  157.          `(OFFSET ,(rtl:locative-offset-base locative)
  158.               ,(back-end:+ (rtl:locative-offset-offset locative)
  159.                    offset)
  160.               OBJECT)))
  161.     (else
  162.      `(OFFSET ,locative ,offset OBJECT))))
  163.  
  164. (define (rtl:locative-index? locative)
  165.   (and (pair? locative) (eq? (car locative) 'INDEX)))
  166.  
  167. (define-integrable rtl:locative-index-base cadr)
  168. (define-integrable rtl:locative-index-offset caddr)
  169. (define-integrable rtl:locative-index-granularity cadddr)
  170.  
  171. (define-integrable (rtl:locative-byte-index? locative)
  172.   (eq? (rtl:locative-index-granularity locative) 'BYTE))
  173.  
  174. (define-integrable (rtl:locative-float-index? locative)
  175.   (eq? (rtl:locative-index-granularity locative) 'FLOAT))
  176.  
  177. (define-integrable (rtl:locative-object-index? locative)
  178.   (eq? (rtl:locative-index-granularity locative) 'OBJECT))
  179.  
  180. (define (rtl:locative-byte-index locative offset)
  181.   `(INDEX ,locative ,offset BYTE))
  182.  
  183. (define (rtl:locative-float-index locative offset)
  184.   `(INDEX ,locative ,offset FLOAT))
  185.  
  186. (define (rtl:locative-object-index locative offset)
  187.   `(INDEX ,locative ,offset OBJECT))
  188.  
  189. ;;; Expressions that are used in the intermediate form.
  190.  
  191. (define-integrable (rtl:make-address locative)
  192.   `(ADDRESS ,locative))
  193.  
  194. (define-integrable (rtl:make-environment locative)
  195.   `(ENVIRONMENT ,locative))
  196.  
  197. (define-integrable (rtl:make-cell-cons expression)
  198.   `(CELL-CONS ,expression))
  199.  
  200. (define-integrable (rtl:make-fetch locative)
  201.   `(FETCH ,locative))
  202.  
  203. (define-integrable (rtl:make-typed-cons:pair type car cdr)
  204.   `(TYPED-CONS:PAIR ,type ,car ,cdr))
  205.  
  206. (define-integrable (rtl:make-typed-cons:vector type elements)
  207.   `(TYPED-CONS:VECTOR ,type ,@elements))
  208.  
  209. (define-integrable (rtl:make-typed-cons:procedure entry)
  210.   `(TYPED-CONS:PROCEDURE ,entry))
  211.  
  212. ;;; Linearizer Support
  213.  
  214. (define-integrable (rtl:make-jump-statement label)
  215.   `(JUMP ,label))
  216.  
  217. (define-integrable (rtl:make-jumpc-statement predicate label)
  218.   `(JUMPC ,predicate ,label))
  219.  
  220. (define-integrable (rtl:make-label-statement label)
  221.   `(LABEL ,label))
  222.  
  223. (define-integrable (rtl:negate-predicate expression)
  224.   `(NOT ,expression))
  225.  
  226. ;;; Stack
  227.  
  228. (define-integrable (stack-locative-offset locative offset)
  229.   (rtl:locative-offset locative (stack->memory-offset offset)))
  230.  
  231. (define-integrable (stack-push-address)
  232.   (rtl:make-pre-increment (interpreter-stack-pointer)
  233.               (stack->memory-offset -1)))
  234.  
  235. (define-integrable (stack-pop-address)
  236.   (rtl:make-post-increment (interpreter-stack-pointer)
  237.                (stack->memory-offset 1)))