;==============================================================================
;		       Copyright (C) 1992 by Marc Feeley -- all rights reserved
; file: "back.scm"
;
;------------------------------------------------------------------------------
;
; Interface to back ends:
; ----------------------

; This file defines the interface to all the target machine implementations.
; Target machine implementations define (among other things):
;
;   - how Scheme objects are represented in the target machine
;   - how PVM instructions are translated into target machine instructions
;   - what is known about some of the Scheme primitives (e.g. which are
;     defined, what their calling pattern is, which can be open-coded, etc.)
;
; When a given target machine package is loaded, a 'target' description
; object is created and added to the list of available back ends (the
; procedure 'put-target' should be used for this).
;
; Target description objects contain the following fields:
;
; field        value
; -----        ------
;
; begin!       Procedure (lambda (info-port) ...)
;              This procedure must be called to initialize the package
;              before any of the other slots are referenced.
;              If 'info-port' is not #f, it is used to display
;              user-related information.
;
; end!         Procedure (lambda () ...)
;              This procedure must be called to do final 'cleanup'.
;              References to the other slots in the package should thus
;              happen inside calls to 'begin!' and 'end!'.
;
; dump         Procedure (lambda (proc filename options) ...)
;              This procedure takes a 'procedure object' and dumps
;              the corresponding loader-compatible object file to
;              the specified file.  The PVM procedure 'proc', which must
;              be a 0 argument procedure, will be called once when
;              the program it is linked into is started up.  'options'
;              is a list of back-end specific keywords passed by the
;              front end of the compiler.
;
; nb-regs      Integer denoting the maximum number of PVM registers
;              that should be used when generating PVM code for this
;              target machine.
;
; prim-info    Procedure (lambda (name) ...)
;              This procedure is used to get information about the
;              Scheme primitive procedures built into the system (not
;              necessarily standard procedures).  The procedure returns
;              a 'procedure object' describing the named procedure if it
;              exists and #f if it doesn't.
;
; label-info   Procedure (lambda (min-args nb-parms rest? closed?) ...)
;              This procedure returns information describing where
;              parameters are located immediately following a procedure
;              LABEL instruction with the given parameters.  The locations
;              can be registers or stack slots.
;
; jump-info    Procedure (lambda (nb-args) ...)
;              This procedure returns information describing where
;              arguments are expected to be immediately following a JUMP
;              instruction that passes 'nb-args' arguments.  The
;              locations can be registers or stack slots.
;
; proc-result  PVM location.
;              This value is the PVM register where the result of a
;              procedure and task is returned.
;
; task-return  PVM location.
;              This value is the PVM register where the task's return address
;              is passed.

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Target description object manipulation:

(define (make-target version name)

  (define current-target-version 3) ; number for this version of the package

  (if (not (= version current-target-version))
    (compiler-internal-error
      "make-target, version of target package is not current" NAME))

  (let ((x (make-vector 11)))
    (vector-set! x 1 name)
    x))

(define (target-name x)                            (vector-ref x 1))

(define (target-begin! x)                          (vector-ref x 2))
(define (target-begin!-set! x y)                   (vector-set! x 2 y))
(define (target-end! x)                            (vector-ref x 3))
(define (target-end!-set! x y)                     (vector-set! x 3 y))

(define (target-dump x)                            (vector-ref x 4))
(define (target-dump-set! x y)                     (vector-set! x 4 y))
(define (target-nb-regs x)                         (vector-ref x 5))
(define (target-nb-regs-set! x y)                  (vector-set! x 5 y))
(define (target-prim-info x)                       (vector-ref x 6))
(define (target-prim-info-set! x y)                (vector-set! x 6 y))
(define (target-label-info x)                      (vector-ref x 7))
(define (target-label-info-set! x y)               (vector-set! x 7 y))
(define (target-jump-info x)                       (vector-ref x 8))
(define (target-jump-info-set! x y)                (vector-set! x 8 y))
(define (target-proc-result x)                     (vector-ref x 9))
(define (target-proc-result-set! x y)              (vector-set! x 9 y))
(define (target-task-return x)                     (vector-ref x 10))
(define (target-task-return-set! x y)              (vector-set! x 10 y))

; Keep list of all target packages loaded:

(define targets-loaded '())

(define (get-target name)
  (let ((x (assq name targets-loaded)))
    (if x
      (cdr x)
      (compiler-error
        "target package is not available" name))))

(define (put-target targ)
  (let* ((name (target-name targ))
         (x (assq name targets-loaded)))
    (if x
      (set-cdr! x targ)
      (set! targets-loaded (cons (cons name targ) targets-loaded)))
    '()))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Target machine selection:

(define (select-target! name info-port)
  (set! target (get-target name))

  ((target-begin! target) info-port)

  (set! target.dump         (target-dump target))
  (set! target.nb-regs      (target-nb-regs target))
  (set! target.prim-info    (target-prim-info target))
  (set! target.label-info   (target-label-info target))
  (set! target.jump-info    (target-jump-info target))
  (set! target.proc-result  (target-proc-result target))
  (set! target.task-return  (target-task-return target))

  (set! **NOT-proc-obj (target.prim-info **NOT-sym))

  '())

(define (unselect-target!)
  ((target-end! target))
  '())

(define target              '())
(define target.dump         '())
(define target.nb-regs      '())
(define target.prim-info    '())
(define target.label-info   '())
(define target.jump-info    '())
(define target.proc-result  '())
(define target.task-return  '())

(define **NOT-proc-obj '()) ; the procedure ##NOT (from the back-end)

(define (target.specialized-prim-info* name decl)
  (let ((x (target.prim-info* name decl)))
    (and x ((proc-obj-specialize x) decl))))

(define (target.prim-info* name decl)
  (and (if (standard-procedure name decl)
         (standard-binding? name decl)
         (extended-binding? name decl))
       (target.prim-info name)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Declarations relevant to back end:

; Arithmetic related declarations:
;
; (generic)              all arithmetic is done on generic numbers
; (generic <var1> ...)   apply only to primitives specified
;
; (fixnum)               all arithmetic is done on fixnums
; (fixnum <var1> ...)    apply only to primitives specified
;
; (flonum)               all arithmetic is done on flonums
; (flonum <var1> ...)    apply only to primitives specified

(define GENERIC-sym (string->canonical-symbol "GENERIC"))
(define FIXNUM-sym  (string->canonical-symbol "FIXNUM"))
(define FLONUM-sym  (string->canonical-symbol "FLONUM"))

(define-namable-decl GENERIC-sym 'arith)
(define-namable-decl FIXNUM-sym  'arith)
(define-namable-decl FLONUM-sym  'arith)

(define (arith-implementation name decls)
  (declaration-value 'arith name GENERIC-sym decls))

;==================================E=O=F=======================================