home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Interp⁄Comp (.scm) / back.scm next >
Encoding:
Text File  |  1994-07-26  |  7.9 KB  |  208 lines  |  [TEXT/gamI]
  1. ;==============================================================================
  2.  
  3. ; file: "back.scm"
  4.  
  5. ;------------------------------------------------------------------------------
  6. ;
  7. ; Interface to back ends:
  8. ; ----------------------
  9.  
  10. ; This file defines the interface to all the target machine implementations.
  11. ; Target machine implementations define (among other things):
  12. ;
  13. ;   - how Scheme objects are represented in the target machine
  14. ;   - how PVM instructions are translated into target machine instructions
  15. ;   - what is known about some of the Scheme primitives (e.g. which are
  16. ;     defined, what their calling pattern is, which can be open-coded, etc.)
  17. ;
  18. ; When a given target machine package is loaded, a 'target' description
  19. ; object is created and added to the list of available back ends (the
  20. ; procedure 'put-target' should be used for this).
  21. ;
  22. ; Target description objects contain the following fields:
  23. ;
  24. ; field        value
  25. ; -----        ------
  26. ;
  27. ; begin!       Procedure (lambda (info-port) ...)
  28. ;              This procedure must be called to initialize the package
  29. ;              before any of the other slots are referenced.
  30. ;              If 'info-port' is not #f, it is used to display
  31. ;              user-related information.
  32. ;
  33. ; end!         Procedure (lambda () ...)
  34. ;              This procedure must be called to do final 'cleanup'.
  35. ;              References to the other slots in the package should thus
  36. ;              happen inside calls to 'begin!' and 'end!'.
  37. ;
  38. ; dump         Procedure (lambda (proc filename options) ...)
  39. ;              This procedure takes a 'procedure object' and dumps
  40. ;              the corresponding loader-compatible object file to
  41. ;              the specified file.  The PVM procedure 'proc', which must
  42. ;              be a 0 argument procedure, will be called once when
  43. ;              the program it is linked into is started up.  'options'
  44. ;              is a list of back-end specific keywords passed by the
  45. ;              front end of the compiler.
  46. ;
  47. ; nb-regs      Integer denoting the maximum number of PVM registers
  48. ;              that should be used when generating PVM code for this
  49. ;              target machine.
  50. ;
  51. ; prim-info    Procedure (lambda (name) ...)
  52. ;              This procedure is used to get information about the
  53. ;              Scheme primitive procedures built into the system (not
  54. ;              necessarily standard procedures).  The procedure returns
  55. ;              a 'procedure object' describing the named procedure if it
  56. ;              exists and #f if it doesn't.
  57. ;
  58. ; label-info   Procedure (lambda (min-args nb-parms rest? closed?) ...)
  59. ;              This procedure returns information describing where
  60. ;              parameters are located immediately following a procedure
  61. ;              LABEL instruction with the given parameters.  The locations
  62. ;              can be registers or stack slots.
  63. ;
  64. ; jump-info    Procedure (lambda (nb-args) ...)
  65. ;              This procedure returns information describing where
  66. ;              arguments are expected to be immediately following a JUMP
  67. ;              instruction that passes 'nb-args' arguments.  The
  68. ;              locations can be registers or stack slots.
  69. ;
  70. ; proc-result  PVM location.
  71. ;              This value is the PVM register where the result of a
  72. ;              procedure and task is returned.
  73. ;
  74. ; task-return  PVM location.
  75. ;              This value is the PVM register where the task's return address
  76. ;              is passed.
  77.  
  78. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  79. ;
  80. ; Target description object manipulation:
  81.  
  82. (define (make-target version name)
  83.  
  84.   (define current-target-version 3) ; number for this version of the package
  85.  
  86.   (if (not (= version current-target-version))
  87.     (compiler-internal-error
  88.       "make-target, version of target package is not current" NAME))
  89.  
  90.   (let ((x (make-vector 11)))
  91.     (vector-set! x 1 name)
  92.     x))
  93.  
  94. (define (target-name x)                            (vector-ref x 1))
  95.  
  96. (define (target-begin! x)                          (vector-ref x 2))
  97. (define (target-begin!-set! x y)                   (vector-set! x 2 y))
  98. (define (target-end! x)                            (vector-ref x 3))
  99. (define (target-end!-set! x y)                     (vector-set! x 3 y))
  100.  
  101. (define (target-dump x)                            (vector-ref x 4))
  102. (define (target-dump-set! x y)                     (vector-set! x 4 y))
  103. (define (target-nb-regs x)                         (vector-ref x 5))
  104. (define (target-nb-regs-set! x y)                  (vector-set! x 5 y))
  105. (define (target-prim-info x)                       (vector-ref x 6))
  106. (define (target-prim-info-set! x y)                (vector-set! x 6 y))
  107. (define (target-label-info x)                      (vector-ref x 7))
  108. (define (target-label-info-set! x y)               (vector-set! x 7 y))
  109. (define (target-jump-info x)                       (vector-ref x 8))
  110. (define (target-jump-info-set! x y)                (vector-set! x 8 y))
  111. (define (target-proc-result x)                     (vector-ref x 9))
  112. (define (target-proc-result-set! x y)              (vector-set! x 9 y))
  113. (define (target-task-return x)                     (vector-ref x 10))
  114. (define (target-task-return-set! x y)              (vector-set! x 10 y))
  115.  
  116. ; Keep list of all target packages loaded:
  117.  
  118. (define targets-loaded '())
  119.  
  120. (define (get-target name)
  121.   (let ((x (assq name targets-loaded)))
  122.     (if x
  123.       (cdr x)
  124.       (compiler-error
  125.         "target package is not available" name))))
  126.  
  127. (define (put-target targ)
  128.   (let* ((name (target-name targ))
  129.          (x (assq name targets-loaded)))
  130.     (if x
  131.       (set-cdr! x targ)
  132.       (set! targets-loaded (cons (cons name targ) targets-loaded)))
  133.     '()))
  134.  
  135. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  136. ;
  137. ; Target machine selection:
  138.  
  139. (define (select-target! name info-port)
  140.   (set! target (get-target name))
  141.  
  142.   ((target-begin! target) info-port)
  143.  
  144.   (set! target.dump         (target-dump target))
  145.   (set! target.nb-regs      (target-nb-regs target))
  146.   (set! target.prim-info    (target-prim-info target))
  147.   (set! target.label-info   (target-label-info target))
  148.   (set! target.jump-info    (target-jump-info target))
  149.   (set! target.proc-result  (target-proc-result target))
  150.   (set! target.task-return  (target-task-return target))
  151.  
  152.   (set! **NOT-proc-obj (target.prim-info **NOT-sym))
  153.  
  154.   '())
  155.  
  156. (define (unselect-target!)
  157.   ((target-end! target))
  158.   '())
  159.  
  160. (define target              '())
  161. (define target.dump         '())
  162. (define target.nb-regs      '())
  163. (define target.prim-info    '())
  164. (define target.label-info   '())
  165. (define target.jump-info    '())
  166. (define target.proc-result  '())
  167. (define target.task-return  '())
  168.  
  169. (define **NOT-proc-obj '()) ; the procedure ##NOT (from the back-end)
  170.  
  171. (define (target.specialized-prim-info* name decl)
  172.   (let ((x (target.prim-info* name decl)))
  173.     (and x ((proc-obj-specialize x) decl))))
  174.  
  175. (define (target.prim-info* name decl)
  176.   (and (if (standard-procedure name decl)
  177.          (standard-binding? name decl)
  178.          (extended-binding? name decl))
  179.        (target.prim-info name)))
  180.  
  181. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  182. ;
  183. ; Declarations relevant to back end:
  184.  
  185. ; Arithmetic related declarations:
  186. ;
  187. ; (generic)              all arithmetic is done on generic numbers
  188. ; (generic <var1> ...)   apply only to primitives specified
  189. ;
  190. ; (fixnum)               all arithmetic is done on fixnums
  191. ; (fixnum <var1> ...)    apply only to primitives specified
  192. ;
  193. ; (flonum)               all arithmetic is done on flonums
  194. ; (flonum <var1> ...)    apply only to primitives specified
  195.  
  196. (define GENERIC-sym (string->canonical-symbol "GENERIC"))
  197. (define FIXNUM-sym  (string->canonical-symbol "FIXNUM"))
  198. (define FLONUM-sym  (string->canonical-symbol "FLONUM"))
  199.  
  200. (define-namable-decl GENERIC-sym 'arith)
  201. (define-namable-decl FIXNUM-sym  'arith)
  202. (define-namable-decl FLONUM-sym  'arith)
  203.  
  204. (define (arith-implementation name decls)
  205.   (declaration-value 'arith name GENERIC-sym decls))
  206.  
  207. ;==============================================================================
  208.