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 / C / machin.scm < prev    next >
Text File  |  1999-01-02  |  10KB  |  299 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: machin.scm,v 1.8 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1992-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 C
  23. ;;; package: (compiler)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Architecture Parameters
  28.  
  29. (define use-pre/post-increment? true)
  30. (define endianness 'DONT-KNOW)
  31. (define scheme-object-width "OBJECT_LENGTH")
  32. (define scheme-type-width "TYPE_CODE_LENGTH")
  33.  
  34. (define scheme-datum-width "DATUM_LENGTH")
  35.  
  36. ;;; It is currently required that both packed characters and objects
  37. ;;; be integrable numbers of address units.  Furthermore, the number
  38. ;;; of address units per object must be an integral multiple of the
  39. ;;; number of address units per character.  This will cause problems
  40. ;;; on a machine that is word addressed, in which case we will have to
  41. ;;; rethink the character addressing strategy.
  42.  
  43. (define address-units-per-object "ADDRESS_UNITS_PER_OBJECT")
  44. (define-integrable address-units-per-float "ADDRESS_UNITS_PER_FLOAT")
  45. (define-integrable address-units-per-packed-char 1)
  46.  
  47. ;; We expect a C long to be at least 32 bits wide,
  48. ;; but not necessarily two's complement.
  49.  
  50. (define-integrable min-long-width 32)
  51. (define-integrable max-tag-width 8)
  52.  
  53. (define-integrable guaranteed-long/upper-limit
  54.   (expt 2 (-1+ min-long-width)))
  55. (define-integrable guaranteed-long/lower-limit
  56.   (- (-1+ guaranteed-long/upper-limit)))
  57.  
  58. (define signed-fixnum/upper-limit
  59.   (expt 2 (- min-long-width (1+ max-tag-width))))
  60. (define signed-fixnum/lower-limit
  61.   (- signed-fixnum/upper-limit))
  62.  
  63. (define-integrable (stack->memory-offset offset) offset)
  64. (define-integrable ic-block-first-parameter-offset 2)
  65. (define-integrable execute-cache-size 2) ; Long words per UUO link slot
  66. (define-integrable closure-entry-size
  67.   ;; Long words in a single closure entry:
  68.   ;;   Format + GC offset word
  69.   ;;   C procedure descriptor + switch tag
  70.   ;;   pointer to code block
  71.   3)
  72.  
  73. ;; Given: the number of entry points in a closure, and a particular
  74. ;; entry point number. Return: the distance from that entry point to
  75. ;; the first variable slot in the closure (in words).
  76.  
  77. (define (closure-first-offset nentries entry)
  78.   (if (zero? nentries)
  79.       1                    ; Strange boundary case
  80.       (- (* closure-entry-size (- nentries entry)) 1)))
  81.  
  82. ;; Like the above, but from the start of the complete closure object,
  83. ;; viewed as a vector, and including the header word.
  84.  
  85. (define (closure-object-first-offset nentries)
  86.   (case nentries
  87.     ((0)
  88.      ;; Vector header only
  89.      1)
  90.     ((1)
  91.      ;; Manifest closure header followed by single entry point
  92.      (+ 1 closure-entry-size))
  93.     (else
  94.      ;; Manifest closure header, number of entries, then entries.
  95.      (+ 1 1 (* closure-entry-size nentries)))))
  96.  
  97. ;; Bump from one entry point to another -- distance in addressing units.
  98.  
  99. (define (closure-entry-distance nentries entry entry*) ; for now
  100.   nentries                ; ignored
  101.   (let ((entry-delta (- entry* entry)))
  102.     (if (zero? entry-delta)
  103.     0
  104.     (string-append "(CLOSURE_ENTRY_DELTA * "
  105.                (number->string
  106.             (* closure-entry-size entry-delta))
  107.                ")"))))
  108.  
  109. ;; Bump to the canonical entry point.  On a RISC (which forces
  110. ;; longword alignment for entry points anyway) there is no need to
  111. ;; canonicalize.
  112.  
  113. (define (closure-environment-adjustment nentries entry)
  114.   nentries entry            ; ignored
  115.   0)
  116.  
  117. ;;;; Machine Registers
  118.  
  119. (define-integrable number-of-machine-registers 5)         ; for now
  120. (define-integrable number-of-temporary-registers 1000000)    ; enough?
  121.  
  122. ;;; Fixed-use registers for Scheme compiled code.
  123. (define-integrable regnum:regs 0)
  124. (define-integrable regnum:stack-pointer 1)
  125. (define-integrable regnum:free 2)
  126. (define-integrable regnum:dynamic-link 3)
  127. (define-integrable regnum:value 4)
  128.  
  129. ;;; Fixed-use registers due to architecture or OS calling conventions.
  130.  
  131. (define machine-register-value-class
  132.   (let ((special-registers
  133.      `((,regnum:stack-pointer . ,value-class=address)
  134.        (,regnum:regs . ,value-class=unboxed)
  135.        (,regnum:free . ,value-class=address)
  136.        (,regnum:dynamic-link . ,value-class=address)
  137.        (,regnum:value . ,value-class=object))))
  138.  
  139.     (lambda (register)
  140.       (let ((lookup (assv register special-registers)))
  141.     (cond
  142.      ((not (null? lookup)) (cdr lookup))
  143.      (else (error "illegal machine register" register)))))))
  144.  
  145. (define-integrable (machine-register-known-value register)
  146.   register                ;ignore
  147.   false)
  148.  
  149. ;;;; Interpreter Registers
  150.  
  151. (define-integrable register-block/memtop-offset 0)
  152. (define-integrable register-block/value-offset 2)
  153. (define-integrable register-block/environment-offset 3)
  154. (define-integrable register-block/dynamic-link-offset 4) ; compiler temp
  155. (define-integrable register-block/lexpr-primitive-arity-offset 7)
  156. (define-integrable register-block/utility-arg4-offset 9) ; closure free
  157. (define-integrable register-block/stack-guard-offset 11)
  158.  
  159. (define-integrable (interpreter-free-pointer)
  160.   (rtl:make-machine-register regnum:free))
  161.  
  162. (define (interpreter-free-pointer? expression)
  163.   (and (rtl:register? expression)
  164.        (= (rtl:register-number expression) regnum:free)))
  165.  
  166. (define-integrable (interpreter-regs-pointer)
  167.   (rtl:make-machine-register regnum:regs))
  168.  
  169. (define (interpreter-regs-pointer? expression)
  170.   (and (rtl:register? expression)
  171.        (= (rtl:register-number expression) regnum:regs)))
  172.  
  173. (define-integrable (interpreter-value-register)
  174.   #|
  175.   (rtl:make-offset (interpreter-regs-pointer)
  176.            register-block/value-offset)
  177.   |#
  178.   (rtl:make-machine-register regnum:value))
  179.  
  180. (define (interpreter-value-register? expression)
  181.   #|
  182.   (and (rtl:offset? expression)
  183.        (interpreter-regs-pointer? (rtl:offset-base expression))
  184.        (= (rtl:offset-number expression) register-block/value-offset))
  185.   |#
  186.   (and (rtl:register? expression)
  187.        (= (rtl:register-number expression) regnum:value)))
  188.  
  189. (define-integrable (interpreter-stack-pointer)
  190.   (rtl:make-machine-register regnum:stack-pointer))
  191.  
  192. (define (interpreter-stack-pointer? expression)
  193.   (and (rtl:register? expression)
  194.        (= (rtl:register-number expression) regnum:stack-pointer)))
  195.  
  196. (define-integrable (interpreter-dynamic-link)
  197.   (rtl:make-machine-register regnum:dynamic-link))
  198.  
  199. (define (interpreter-dynamic-link? expression)
  200.   (and (rtl:register? expression)
  201.        (= (rtl:register-number expression) regnum:dynamic-link)))
  202.  
  203. (define-integrable (interpreter-environment-register)
  204.   (rtl:make-offset (interpreter-regs-pointer)
  205.            register-block/environment-offset))
  206.  
  207. (define (interpreter-environment-register? expression)
  208.   (and (rtl:offset? expression)
  209.        (interpreter-regs-pointer? (rtl:offset-base expression))
  210.        (let ((offset (rtl:offset-offset expression)))
  211.      (and (rtl:machine-constant? offset)
  212.           (= 3 (rtl:machine-constant-value offset))))))
  213.  
  214. (define-integrable (interpreter-register:access)
  215.   (interpreter-value-register))
  216.  
  217. (define-integrable (interpreter-register:cache-reference)
  218.   (interpreter-value-register))
  219.  
  220. (define-integrable (interpreter-register:cache-unassigned?)
  221.   (interpreter-value-register))
  222.  
  223. (define-integrable (interpreter-register:lookup)
  224.   (interpreter-value-register))
  225.  
  226. (define-integrable (interpreter-register:unassigned?)
  227.   (interpreter-value-register))
  228.  
  229. (define-integrable (interpreter-register:unbound?)
  230.   (interpreter-value-register))
  231.  
  232. ;;;; RTL Registers, Constants, and Primitives
  233.  
  234. (define (rtl:machine-register? rtl-register)
  235.   (case rtl-register
  236.     ((STACK-POINTER)
  237.      (interpreter-stack-pointer))
  238.     ((DYNAMIC-LINK)
  239.      (interpreter-dynamic-link))
  240.     ((VALUE)
  241.      (interpreter-value-register))
  242.     ((FREE)
  243.      (interpreter-free-pointer))
  244.     ((INTERPRETER-CALL-RESULT:ACCESS)
  245.      (interpreter-register:access))
  246.     ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
  247.      (interpreter-register:cache-reference))
  248.     ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
  249.      (interpreter-register:cache-unassigned?))
  250.     ((INTERPRETER-CALL-RESULT:LOOKUP)
  251.      (interpreter-register:lookup))
  252.     ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
  253.      (interpreter-register:unassigned?))
  254.     ((INTERPRETER-CALL-RESULT:UNBOUND?)
  255.      (interpreter-register:unbound?))
  256.     (else
  257.      false)))
  258.  
  259. (define (rtl:interpreter-register? rtl-register)
  260.   (case rtl-register
  261.     ((MEMORY-TOP)
  262.      register-block/memtop-offset)
  263.     ((STACK-GUARD)
  264.      register-block/stack-guard-offset)
  265.     ((ENVIRONMENT)
  266.      register-block/environment-offset)
  267.     #|
  268.     ((VALUE)
  269.      register-block/value-offset)
  270.     ((INTERPRETER-CALL-RESULT:ACCESS)
  271.      register-block/value-offset)
  272.     ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
  273.      register-block/value-offset)
  274.     ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
  275.      register-block/value-offset)
  276.     ((INTERPRETER-CALL-RESULT:LOOKUP)
  277.      register-block/value-offset)
  278.     ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
  279.      register-block/value-offset)
  280.     ((INTERPRETER-CALL-RESULT:UNBOUND?)
  281.      register-block/value-offset)
  282.     |#
  283.     (else
  284.      false)))
  285.  
  286. (define (rtl:interpreter-register->offset locative)
  287.   (or (rtl:interpreter-register? locative)
  288.       (error "Unknown register type" locative)))
  289.  
  290. (define (rtl:constant-cost expression)
  291.   expression                ; ignored
  292.   1)
  293.  
  294. (define compiler:open-code-floating-point-arithmetic?
  295.   true)
  296.  
  297. (define compiler:primitives-with-no-open-coding
  298.   '(DIVIDE-FIXNUM GCD-FIXNUM &/
  299.     VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS))