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 / machines / vax / machin.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  9.6 KB  |  294 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: machin.scm,v 4.13 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1987-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. ;;;; Machine Model for DEC Vax
  23. ;;; package: (compiler)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Architecture Parameters
  28.  
  29. (define use-pre/post-increment? true)
  30. (define-integrable endianness 'LITTLE)
  31. (define-integrable addressing-granularity 8)
  32. (define-integrable scheme-object-width 32)
  33. (define-integrable scheme-type-width 6)    ;or 8
  34.  
  35. ;; NOTE: expt is not being constant-folded now.
  36. ;; For the time being, some of the parameters below are
  37. ;; pre-computed and marked with ***
  38. ;; There are similar parameters in lapgen.scm
  39. ;; Change them if any of the parameters above change.
  40.  
  41. (define-integrable scheme-datum-width
  42.   (- scheme-object-width scheme-type-width))
  43.  
  44. (define-integrable float-width 64)
  45. (define-integrable float-alignment 32)
  46.  
  47. (define-integrable address-units-per-float
  48.   (quotient float-width addressing-granularity))
  49.  
  50. ;;; It is currently required that both packed characters and objects
  51. ;;; be integrable numbers of address units.  Furthermore, the number
  52. ;;; of address units per object must be an integral multiple of the
  53. ;;; number of address units per character.  This will cause problems
  54. ;;; on a machine that is word addressed: we will have to rethink the
  55. ;;; character addressing strategy.
  56.  
  57. (define-integrable address-units-per-object
  58.   (quotient scheme-object-width addressing-granularity))
  59.  
  60. (define-integrable address-units-per-packed-char 1)
  61.  
  62. (define-integrable signed-fixnum/upper-limit
  63.   ;; (expt 2 (-1+ scheme-datum-width)) ***
  64.   33554432)
  65.  
  66. (define-integrable signed-fixnum/lower-limit
  67.   (- signed-fixnum/upper-limit))
  68.  
  69. (define-integrable unsigned-fixnum/upper-limit
  70.   (* 2 signed-fixnum/upper-limit))
  71.  
  72. (define-integrable (stack->memory-offset offset) offset)
  73. (define-integrable ic-block-first-parameter-offset 2)
  74.  
  75. ;; This must return a word based offset.
  76. ;; On the VAX, to save space, entries can be at 2 mod 4 addresses,
  77. ;; which makes it impossible if the closure object used for
  78. ;; referencing points to arbitrary entries.  Instead, all closure
  79. ;; entry points bump to the canonical entry point, which is always
  80. ;; longword aligned.
  81. ;; On other machines (word aligned), it may be easier to bump back
  82. ;; to each entry point, and the entry number `entry' would be part
  83. ;; of the computation.
  84.  
  85. (define (closure-first-offset nentries entry)
  86.   entry                    ; ignored
  87.   (if (zero? nentries)
  88.       1
  89.       (quotient (+ (+ 3 1) (* 5 (- nentries 1))) 2)))
  90.  
  91. ;; This is from the start of the complete closure object,
  92. ;; viewed as a vector, and including the header word.
  93.  
  94. (define (closure-object-first-offset nentries)
  95.   (case nentries
  96.     ((0) 1)
  97.     ((1) 4)
  98.     (else
  99.      (quotient (+ 5 (* 5 nentries)) 2))))
  100.  
  101. ;; Bump from one entry point to another.
  102.  
  103. (define (closure-entry-distance nentries entry entry*)
  104.   nentries                ; ignored
  105.   (* 10 (- entry* entry)))
  106.  
  107. ;; Bump to the canonical entry point.
  108.  
  109. (define (closure-environment-adjustment nentries entry)
  110.   (declare (integrate-operator closure-entry-distance))
  111.   (closure-entry-distance nentries entry 0))
  112.  
  113. (define-integrable r0 0)        ; return value
  114. (define-integrable r1 1)
  115. (define-integrable r2 2)
  116. (define-integrable r3 3)
  117. (define-integrable r4 4)
  118. (define-integrable r5 5)
  119. (define-integrable r6 6)
  120. (define-integrable r7 7)
  121. (define-integrable r8 8)
  122. (define-integrable r9 9)
  123. (define-integrable r10 10)
  124. (define-integrable r11 11)
  125. (define-integrable r12 12)        ; AP
  126. (define-integrable r13 13)        ; FP
  127. (define-integrable r14 14)        ; SP
  128. (define-integrable r15 15)         ; PC, not really useable.
  129.  
  130. (define number-of-machine-registers 16)
  131. (define number-of-temporary-registers 256)
  132.  
  133. (define-integrable regnum:return-value r9)
  134. (define-integrable regnum:regs-pointer r10)
  135. (define-integrable regnum:pointer-mask r11)
  136. (define-integrable regnum:free-pointer r12)
  137. (define-integrable regnum:dynamic-link r13)
  138. (define-integrable regnum:stack-pointer r14)
  139. (define-integrable (machine-register-known-value register) register false)
  140.  
  141. (define (machine-register-value-class register)
  142.   (cond ((<= 0 register 9) value-class=object)
  143.     ((= 11 register) value-class=immediate)
  144.     ((<= 10 register 15) value-class=address)
  145.     (else (error "illegal machine register" register))))
  146.  
  147. ;;;; RTL Generator Interface
  148.  
  149. (define (interpreter-register:access)
  150.   (rtl:make-machine-register r0))
  151.  
  152. (define (interpreter-register:cache-reference)
  153.   (rtl:make-machine-register r0))
  154.  
  155. (define (interpreter-register:cache-unassigned?)
  156.   (rtl:make-machine-register r0))
  157.  
  158. (define (interpreter-register:lookup)
  159.   (rtl:make-machine-register r0))
  160.  
  161. (define (interpreter-register:unassigned?)
  162.   (rtl:make-machine-register r0))
  163.  
  164. (define (interpreter-register:unbound?)
  165.   (rtl:make-machine-register r0))
  166.  
  167. (define-integrable (interpreter-value-register)
  168.   (rtl:make-machine-register regnum:return-value))
  169.  
  170. (define (interpreter-value-register? expression)
  171.   (and (rtl:register? expression)
  172.        (= (rtl:register-number expression) regnum:return-value)))
  173.  
  174. (define (interpreter-environment-register)
  175.   (rtl:make-offset (interpreter-regs-pointer) 3))
  176.  
  177. (define (interpreter-environment-register? expression)
  178.   (and (rtl:offset? expression)
  179.        (interpreter-regs-pointer? (rtl:offset-base expression))
  180.        (= 3 (rtl:offset-number expression))))
  181.  
  182. (define (interpreter-free-pointer)
  183.   (rtl:make-machine-register regnum:free-pointer))
  184.  
  185. (define (interpreter-free-pointer? expression)
  186.   (and (rtl:register? expression)
  187.        (= (rtl:register-number expression) regnum:free-pointer)))
  188.  
  189. (define (interpreter-regs-pointer)
  190.   (rtl:make-machine-register regnum:regs-pointer))
  191.  
  192. (define (interpreter-regs-pointer? expression)
  193.   (and (rtl:register? expression)
  194.        (= (rtl:register-number expression) regnum:regs-pointer)))
  195.  
  196. (define (interpreter-stack-pointer)
  197.   (rtl:make-machine-register regnum:stack-pointer))
  198.  
  199. (define (interpreter-stack-pointer? expression)
  200.   (and (rtl:register? expression)
  201.        (= (rtl:register-number expression) regnum:stack-pointer)))
  202.  
  203. (define (interpreter-dynamic-link)
  204.   (rtl:make-machine-register regnum:dynamic-link))
  205.  
  206. (define (interpreter-dynamic-link? expression)
  207.   (and (rtl:register? expression)
  208.        (= (rtl:register-number expression) regnum:dynamic-link)))
  209.  
  210. (define (rtl:machine-register? rtl-register)
  211.   (case rtl-register
  212.     ((STACK-POINTER)
  213.      (interpreter-stack-pointer))
  214.     ((DYNAMIC-LINK)
  215.      (interpreter-dynamic-link))
  216.     ((VALUE)
  217.      (interpreter-value-register))
  218.     ((FREE)
  219.      (interpreter-free-pointer))
  220.     ((INTERPRETER-CALL-RESULT:ACCESS)
  221.      (interpreter-register:access))
  222.     ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
  223.      (interpreter-register:cache-reference))
  224.     ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
  225.      (interpreter-register:cache-unassigned?))
  226.     ((INTERPRETER-CALL-RESULT:LOOKUP)
  227.      (interpreter-register:lookup))
  228.     ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
  229.      (interpreter-register:unassigned?))
  230.     ((INTERPRETER-CALL-RESULT:UNBOUND?)
  231.      (interpreter-register:unbound?))
  232.     (else
  233.      false)))
  234.  
  235. (define (rtl:interpreter-register? rtl-register)
  236.   (case rtl-register
  237.     ((MEMORY-TOP) 0)
  238.     ((INT-MASK) 1)
  239.     #| ((VALUE) 2) |#
  240.     ((ENVIRONMENT) 3)
  241.     ((TEMPORARY) 4)
  242.     (else false)))
  243.  
  244. (define (rtl:interpreter-register->offset locative)
  245.   (or (rtl:interpreter-register? locative)
  246.       (error "Unknown register type" locative)))
  247.  
  248. (define (rtl:constant-cost expression)
  249.   ;; Magic numbers
  250.   ;; number of bytes for the instruction to construct/fetch into register.
  251.   (let ((if-integer
  252.      (lambda (value)
  253.        (cond ((zero? value) 2)
  254.          ((<= -63 value 63)
  255.           3)
  256.          (else
  257.           7)))))
  258.     (let ((if-synthesized-constant
  259.        (lambda (type datum)
  260.          (if-integer (make-non-pointer-literal type datum)))))
  261.       (case (rtl:expression-type expression)
  262.     ((CONSTANT)
  263.      (let ((value (rtl:constant-value expression)))
  264.        (if (non-pointer-object? value)
  265.            (if-synthesized-constant (object-type value)
  266.                     (careful-object-datum value))
  267.            3)))
  268.     ((MACHINE-CONSTANT)
  269.      (if-integer (rtl:machine-constant-value expression)))
  270.     ((ENTRY:PROCEDURE
  271.       ENTRY:CONTINUATION
  272.       ASSIGNMENT-CACHE
  273.       VARIABLE-CACHE
  274.       OFFSET-ADDRESS
  275.       BYTE-OFFSET-ADDRESS)
  276.      4)                ; assuming word offset
  277.     ((CONS-POINTER)
  278.      (and (rtl:machine-constant? (rtl:cons-pointer-type expression))
  279.           (rtl:machine-constant? (rtl:cons-pointer-datum expression))
  280.           (if-synthesized-constant
  281.            (rtl:machine-constant-value (rtl:cons-pointer-type expression))
  282.            (rtl:machine-constant-value
  283.         (rtl:cons-pointer-datum expression)))))
  284.     (else false)))))
  285.  
  286. ;;; Floating-point open-coding not implemented for VAXen.
  287.  
  288. (define compiler:open-code-floating-point-arithmetic?
  289.   false)
  290.  
  291. (define compiler:primitives-with-no-open-coding
  292.   '(DIVIDE-FIXNUM GCD-FIXNUM &/
  293.     VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS
  294.     FLOATING-VECTOR-REF FLOATING-VECTOR-SET!))