src/compiler/alpha/static-fn.lisp

   1 ;;; -*- Package: ALPHA -*-
   2 ;;;
   3 ;;; **********************************************************************
   4 ;;; This code was written as part of the CMU Common Lisp project at
   5 ;;; Carnegie Mellon University, and has been placed in the public domain.
   6 ;;;
   7
   8 ;;;
   9 ;;; **********************************************************************
  10 ;;;
  11 ;;; This file contains the VOPs and macro magic necessary to call static
  12 ;;; functions.
  13 ;;;
  14 ;;; Written by William Lott.
  15 ;;; Converted by Sean Hallgren.
  16 ;;;
  17 (in-package "SB!VM")
  18
  19
  20
  21
  22 (define-vop (static-function-template)
  23   (:save-p t)
  24   (:policy :safe)
  25   (:variant-vars symbol)
  26   (:vop-var vop)
  27   (:temporary (:scs (non-descriptor-reg)) temp)
  28   (:temporary (:scs (descriptor-reg)) move-temp)
  29   (:temporary (:sc descriptor-reg :offset lra-offset) lra)
  30   (:temporary (:sc interior-reg :offset lip-offset) entry-point)
  31   (:temporary (:sc any-reg :offset nargs-offset) nargs)
  32   (:temporary (:sc any-reg :offset ocfp-offset) ocfp)
  33   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))
  34
  35
  36 (eval-when  (:compile-toplevel :load-toplevel :execute)
  37
  38
  39 (defun static-function-template-name (num-args num-results)
  40   (intern (format nil "~:@(~R-arg-~R-result-static-function~)"
  41                   num-args num-results)))
  42
  43
  44 (defun moves (src dst)
  45   (collect ((moves))
  46     (do ((dst dst (cdr dst))
  47          (src src (cdr src)))
  48         ((or (null dst) (null src)))
  49       (moves `(move ,(car src) ,(car dst))))
  50     (moves)))
  51
  52 (defun static-function-template-vop (num-args num-results)
  53   (assert (and (<= num-args register-arg-count)
  54                (<= num-results register-arg-count))
  55           (num-args num-results)
  56           "Either too many args (~D) or too many results (~D).  Max = ~D"
  57           num-args num-results register-arg-count)
  58   (let ((num-temps (max num-args num-results)))
  59     (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
  60       (dotimes (i num-results)
  61         (let ((result-name (intern (format nil "RESULT-~D" i))))
  62           (result-names result-name)
  63           (results `(,result-name :scs (any-reg descriptor-reg)))))
  64       (dotimes (i num-temps)
  65         (let ((temp-name (intern (format nil "TEMP-~D" i))))
  66           (temp-names temp-name)
  67           (temps `(:temporary (:sc descriptor-reg
  68                                :offset ,(nth i *register-arg-offsets*)
  69                                ,@(when (< i num-args)
  70                                    `(:from (:argument ,i)))
  71                                ,@(when (< i num-results)
  72                                    `(:to (:result ,i)
  73                                      :target ,(nth i (result-names)))))
  74                               ,temp-name))))
  75       (dotimes (i num-args)
  76         (let ((arg-name (intern (format nil "ARG-~D" i))))
  77           (arg-names arg-name)
  78           (args `(,arg-name
  79                   :scs (any-reg descriptor-reg null zero)
  80                   :target ,(nth i (temp-names))))))
  81       `(define-vop (,(static-function-template-name num-args num-results)
  82                     static-function-template)
  83          (:args ,@(args))
  84          ,@(temps)
  85          (:results ,@(results))
  86          (:generator ,(+ 50 num-args num-results)
  87            (let ((lra-label (gen-label))
  88                  (cur-nfp (current-nfp-tn vop)))
  89              ,@(moves (arg-names) (temp-names))
  90              (inst li (fixnumize ,num-args) nargs)
  91              (inst ldl entry-point (static-function-offset symbol) null-tn)
  92              (when cur-nfp
  93                (store-stack-tn nfp-save cur-nfp))
  94              (inst move cfp-tn ocfp)
  95              (inst compute-lra-from-code lra code-tn lra-label temp)
  96              (note-this-location vop :call-site)
  97              (inst move csp-tn cfp-tn)
  98              (inst jsr zero-tn entry-point)
  99              (emit-return-pc lra-label)
 100              ,(collect ((bindings) (links))
 101                 (do ((temp (temp-names) (cdr temp))
 102                      (name 'values (gensym))
 103                      (prev nil name)
 104                      (i 0 (1+ i)))
 105                     ((= i num-results))
 106                   (bindings `(,name
 107                               (make-tn-ref ,(car temp) nil)))
 108                   (when prev
 109                     (links `(setf (tn-ref-across ,prev) ,name))))
 110                 `(let ,(bindings)
 111                    ,@(links)
 112                    (default-unknown-values vop
 113                        ,(if (zerop num-results) nil 'values)
 114                        ,num-results move-temp temp lra-label)))
 115              (when cur-nfp
 116                (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))
 117              ,@(moves (temp-names) (result-names))))))))
 118
 119
 120 ) ; eval-when (compile load eval)
 121
 122
 123 (expand
 124  (collect ((templates (list 'progn)))
 125    (dotimes (i register-arg-count)
 126      (templates (static-function-template-vop i 1)))
 127    (templates)))
 128
 129
 130 (defmacro define-static-function (name args &key (results '(x)) translate
 131                                        policy cost arg-types result-types)
 132   `(define-vop (,name
 133                 ,(static-function-template-name (length args)
 134                                                 (length results)))
 135      (:variant ',name)
 136      (:note ,(format nil "static-function ~@(~S~)" name))
 137      ,@(when translate
 138          `((:translate ,translate)))
 139      ,@(when policy
 140          `((:policy ,policy)))
 141      ,@(when cost
 142          `((:generator-cost ,cost)))
 143      ,@(when arg-types
 144          `((:arg-types ,@arg-types)))
 145      ,@(when result-types
 146          `((:result-types ,@result-types)))))