gsc/_back.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "_back.scm"
   4
   5 ;;; Copyright (c) 1994-2012 by Marc Feeley, All Rights Reserved.
   6
   7 (include "fixnum.scm")
   8
   9 (include-adt "_envadt.scm")
  10 (include-adt "_gvmadt.scm")
  11 (include-adt "_ptreeadt.scm")
  12 (include-adt "_sourceadt.scm")
  13
  14 ;;;----------------------------------------------------------------------------
  15
  16 ;;;; Interface to back ends
  17
  18 ;; This file defines the interface to all the target machine implementations.
  19 ;; Target machine implementations define (among other things):
  20 ;;
  21 ;;   - how Scheme objects are represented in the target machine
  22 ;;   - how GVM instructions are translated into target machine instructions
  23 ;;   - what is known about some of the Scheme primitives (e.g. which are
  24 ;;     defined, what their calling pattern is, which can be open-coded, etc.)
  25 ;;
  26 ;; When a given target machine module is loaded, a 'target' description
  27 ;; object is created and added to the list of available back ends (the
  28 ;; procedure 'target-add' should be used for this).
  29 ;;
  30 ;; Target description objects contain the following fields:
  31 ;;
  32 ;; field        value
  33 ;; -----        ------
  34 ;;
  35 ;; begin!       Procedure (lambda (info-port) ...)
  36 ;;              This procedure must be called to initialize the module
  37 ;;              before any of the other fields are referenced.
  38 ;;              If 'info-port' is not #f, it is used to display
  39 ;;              user-related information.
  40 ;;
  41 ;; end!         Procedure (lambda () ...)
  42 ;;              This procedure must be called to do final 'cleanup'.
  43 ;;              References to the other fields in the module should thus
  44 ;;              happen inside calls to 'begin!' and 'end!'.
  45 ;;
  46 ;; dump         Procedure (lambda (procs output output-root c-intf script-line
  47 ;;                                 options) ...)
  48 ;;              This procedure takes a list of 'procedure objects' and dumps
  49 ;;              the corresponding loader-compatible object file to the
  50 ;;              specified file.  The first procedure in 'procs', which must
  51 ;;              be a 0 argument procedure, will be called once when
  52 ;;              the program it is linked into is started up.  'options'
  53 ;;              is a list of back-end specific symbols passed by the
  54 ;;              front end of the compiler.  'c-intf' is a c-intf structure
  55 ;;              containing the C declarations, procedures, and initialization
  56 ;;              code contained in the source file.  It is the responsibility
  57 ;;              of the back-end (and loader) to create one Scheme primitive
  58 ;;              for each C procedure in the c-intf structure and to provide
  59 ;;              the linking between the two.  If the entries of the 'c-intf'
  60 ;;              structure are replaced with the empty list, the front-end
  61 ;;              will NOT produce the C interface file automatically as is
  62 ;;              normally the case (this is useful in the case of a back-end
  63 ;;              generating C that will itself be creating this file).
  64 ;;              The 'output' argument specifies the file name of the
  65 ;;              file to produce.  If it is #f, 'output-root' concatenated
  66 ;;              with the appropriate extension should be used as a
  67 ;;              file name.  The 'script-line' argument indicates the text
  68 ;;              on the first line of the source file (after the #! or @;)
  69 ;;              if the source file is a script or #f if it is not a script.
  70 ;;
  71 ;; nb-regs      Integer denoting the maximum number of GVM registers
  72 ;;              that should be used when generating GVM code for this
  73 ;;              target machine.
  74 ;;
  75 ;; prim-info    Procedure (lambda (name) ...)
  76 ;;              This procedure is used to get information about the
  77 ;;              Scheme primitive procedures built into the system (not
  78 ;;              necessarily standard procedures).  The procedure returns
  79 ;;              a 'procedure object' describing the named procedure if it
  80 ;;              exists and #f if it doesn't.
  81 ;;
  82 ;; label-info   Procedure (lambda (nb-parms nb-opts nb-keys rest? closed?) ...)
  83 ;;              This procedure returns information describing where
  84 ;;              parameters are located immediately following a procedure
  85 ;;              'label' instruction with the given parameters.  The locations
  86 ;;              can be registers or stack slots.
  87 ;;
  88 ;; jump-info    Procedure (lambda (nb-args) ...)
  89 ;;              This procedure returns information describing where
  90 ;;              arguments are expected to be immediately following a 'jump'
  91 ;;              instruction that passes 'nb-args' arguments.  The
  92 ;;              locations can be registers or stack slots.
  93 ;;
  94 ;; frame-constraints  Frame constraints structure
  95 ;;              The frame constraints structure indicates the frame alignment
  96 ;;              constraints.
  97 ;;
  98 ;; proc-result  GVM location.
  99 ;;              This value is the GVM register where the result of a
 100 ;;              procedure and task is returned.
 101 ;;
 102 ;; task-return  GVM location.
 103 ;;              This value is the GVM register where the task's return address
 104 ;;              is passed.
 105
 106 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 107
 108 ;;;; Target description object manipulation
 109
 110 (define (make-target version name)
 111
 112   (define current-target-version 6) ; number for this version of the module
 113
 114   (if (not (= version current-target-version))
 115       (compiler-internal-error
 116        "make-target, version of target module is not current" name))
 117
 118   (let ((x (make-vector 13)))
 119     (vector-set! x 0 'target)
 120     (vector-set! x 1 name)
 121     x))
 122
 123 (define (target-name x)                     (vector-ref x 1))
 124
 125 (define (target-begin! x)                   (vector-ref x 2))
 126 (define (target-begin!-set! x y)            (vector-set! x 2 y))
 127 (define (target-end! x)                     (vector-ref x 3))
 128 (define (target-end!-set! x y)              (vector-set! x 3 y))
 129
 130 (define (target-dump x)                     (vector-ref x 4))
 131 (define (target-dump-set! x y)              (vector-set! x 4 y))
 132 (define (target-nb-regs x)                  (vector-ref x 5))
 133 (define (target-nb-regs-set! x y)           (vector-set! x 5 y))
 134 (define (target-prim-info x)                (vector-ref x 6))
 135 (define (target-prim-info-set! x y)         (vector-set! x 6 y))
 136 (define (target-label-info x)               (vector-ref x 7))
 137 (define (target-label-info-set! x y)        (vector-set! x 7 y))
 138 (define (target-jump-info x)                (vector-ref x 8))
 139 (define (target-jump-info-set! x y)         (vector-set! x 8 y))
 140 (define (target-frame-constraints x)        (vector-ref x 9))
 141 (define (target-frame-constraints-set! x y) (vector-set! x 9 y))
 142 (define (target-proc-result x)              (vector-ref x 10))
 143 (define (target-proc-result-set! x y)       (vector-set! x 10 y))
 144 (define (target-task-return x)              (vector-ref x 11))
 145 (define (target-task-return-set! x y)       (vector-set! x 11 y))
 146 (define (target-switch-testable? x)         (vector-ref x 12))
 147 (define (target-switch-testable?-set! x y)  (vector-set! x 12 y))
 148
 149 ;;;; Frame constraints structure
 150
 151 (define (make-frame-constraints reserve align) (vector reserve align))
 152 (define (frame-constraints-reserve fc)         (vector-ref fc 0))
 153 (define (frame-constraints-align fc)           (vector-ref fc 1))
 154
 155 ;;;; Database of all target modules loaded
 156
 157 (define targets-loaded '())
 158
 159 (define (target-get name)
 160   (let ((x (assq name targets-loaded)))
 161     (if x
 162         (cdr x)
 163         (compiler-error
 164          "Target module is not available:" name))))
 165
 166 (define (target-add targ)
 167   (let* ((name (target-name targ))
 168          (x (assq name targets-loaded)))
 169     (if x
 170         (set-cdr! x targ)
 171         (set! targets-loaded (cons (cons name targ) targets-loaded)))
 172     #f))
 173
 174 (define (default-target)
 175   (if (null? targets-loaded)
 176       (compiler-error "No target module is available")
 177       (car (car targets-loaded))))
 178
 179 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 180
 181 ;;;; Target machine selection
 182
 183 (define (target-select! name info-port)
 184
 185   (set! target (target-get name))
 186
 187   ((target-begin! target) info-port)
 188
 189   (set! target.dump              (target-dump target))
 190   (set! target.nb-regs           (target-nb-regs target))
 191   (set! target.prim-info         (target-prim-info target))
 192   (set! target.label-info        (target-label-info target))
 193   (set! target.jump-info         (target-jump-info target))
 194   (set! target.frame-constraints (target-frame-constraints target))
 195   (set! target.proc-result       (target-proc-result target))
 196   (set! target.task-return       (target-task-return target))
 197   (set! target.switch-testable?  (target-switch-testable?  target))
 198
 199   (set! **not-proc-obj
 200         (target.prim-info **not-sym))
 201
 202   (set! **eq?-proc-obj
 203         (target.prim-info **eq?-sym))
 204
 205   (set! **quasi-append-proc-obj
 206         (target.prim-info **quasi-append-sym))
 207
 208   (set! **quasi-list-proc-obj
 209         (target.prim-info **quasi-list-sym))
 210
 211   (set! **quasi-cons-proc-obj
 212         (target.prim-info **quasi-cons-sym))
 213
 214   (set! **quasi-list->vector-proc-obj
 215         (target.prim-info **quasi-list->vector-sym))
 216
 217   (set! **quasi-vector-proc-obj
 218         (target.prim-info **quasi-vector-sym))
 219
 220   (set! **case-memv-proc-obj
 221         (target.prim-info **case-memv-sym))
 222
 223   #f)
 224
 225 (define (target-unselect!)
 226
 227   (set! **not-proc-obj                #f)
 228   (set! **eq?-proc-obj                #f)
 229   (set! **quasi-append-proc-obj       #f)
 230   (set! **quasi-list-proc-obj         #f)
 231   (set! **quasi-cons-proc-obj         #f)
 232   (set! **quasi-list->vector-proc-obj #f)
 233   (set! **quasi-vector-proc-obj       #f)
 234   (set! **case-memv-proc-obj          #f)
 235
 236   ((target-end! target))
 237
 238   #f)
 239
 240 (define target                   #f)
 241 (define target.dump              #f)
 242 (define target.nb-regs           #f)
 243 (define target.prim-info         #f)
 244 (define target.label-info        #f)
 245 (define target.jump-info         #f)
 246 (define target.frame-constraints #f)
 247 (define target.proc-result       #f)
 248 (define target.task-return       #f)
 249 (define target.switch-testable?  #f)
 250
 251 ;; procedures defined in back-end:
 252
 253 (define **not-proc-obj                #f)  ;; ##not
 254 (define **eq?-proc-obj                #f)  ;; ##eq?
 255 (define **quasi-append-proc-obj       #f)  ;; ##quasi-append
 256 (define **quasi-list-proc-obj         #f)  ;; ##quasi-list
 257 (define **quasi-cons-proc-obj         #f)  ;; ##quasi-cons
 258 (define **quasi-list->vector-proc-obj #f)  ;; ##quasi-list->vector
 259 (define **quasi-vector-proc-obj       #f)  ;; ##quasi-vector
 260 (define **case-memv-proc-obj          #f)  ;; ##case-memv
 261
 262 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 263
 264 ;;;; Declarations relevant to back end
 265
 266 ;; Arithmetic related declarations:
 267 ;;
 268 ;; (generic)                         all arithmetic is done on generic numbers
 269 ;; (generic <var1> ...)              apply only to primitives specified
 270 ;;
 271 ;; (fixnum)                          all arithmetic is done on fixnums
 272 ;; (fixnum <var1> ...)               apply only to primitives specified
 273 ;;
 274 ;; (flonum)                          all arithmetic is done on flonums
 275 ;; (flonum <var1> ...)               apply only to primitives specified
 276 ;;
 277 ;; (mostly-generic)                  generic arithmetic is frequent
 278 ;; (mostly-generic <var1> ...)       apply only to primitives specified
 279 ;;
 280 ;; (mostly-fixnum)                   fixnum arithmetic is frequent
 281 ;; (mostly-fixnum <var1> ...)        apply only to primitives specified
 282 ;;
 283 ;; (mostly-flonum)                   flonum arithmetic is frequent
 284 ;; (mostly-flonum <var1> ...)        apply only to primitives specified
 285 ;;
 286 ;; (mostly-fixnum-flonum)            fixnum and flonum arithmetic is frequent
 287 ;; (mostly-fixnum-flonum <var1> ...) apply only to primitives specified
 288 ;;
 289 ;; (mostly-flonum-fixnum)            flonum and fixnum arithmetic is frequent
 290 ;; (mostly-flonum-fixnum <var1> ...) apply only to primitives specified
 291
 292 (define-namable-decl generic-sym 'arith)
 293 (define-namable-decl fixnum-sym  'arith)
 294 (define-namable-decl flonum-sym  'arith)
 295
 296 (define (arith-implementation name env)
 297   (declaration-value 'arith name generic-sym env))
 298
 299 (define-namable-decl mostly-generic-sym       'mostly-arith)
 300 (define-namable-decl mostly-fixnum-sym        'mostly-arith)
 301 (define-namable-decl mostly-flonum-sym        'mostly-arith)
 302 (define-namable-decl mostly-fixnum-flonum-sym 'mostly-arith)
 303 (define-namable-decl mostly-flonum-fixnum-sym 'mostly-arith)
 304
 305 (define (mostly-arith-implementation name env)
 306   (declaration-value 'mostly-arith name mostly-fixnum-flonum-sym env))
 307
 308 ;;;============================================================================