home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / sparc / static-fn.lisp < prev    next >
Encoding:
Text File  |  1991-11-06  |  4.9 KB  |  155 lines
  1. ;;; -*- Package: SPARC -*-
  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
  6. ;;; domain.  If you want to use this code or any part of CMU Common
  7. ;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
  8. ;;; **********************************************************************
  9. ;;;
  10. ;;; $Header: static-fn.lisp,v 1.1 90/11/30 17:05:03 wlott Exp $
  11. ;;;
  12. ;;; This file contains the VOPs and macro magic necessary to call static
  13. ;;; functions.
  14. ;;;
  15. ;;; Written by William Lott.
  16. ;;;
  17. (in-package "SPARC")
  18.  
  19.  
  20.  
  21. (define-vop (static-function-template)
  22.   (:save-p t)
  23.   (:policy :safe)
  24.   (:variant-vars symbol)
  25.   (:vop-var vop)
  26.   (:temporary (:scs (non-descriptor-reg)) temp)
  27.   (:temporary (:scs (descriptor-reg)) move-temp)
  28.   (:temporary (:sc descriptor-reg :offset lra-offset) lra)
  29.   (:temporary (:sc descriptor-reg :offset cname-offset) cname)
  30.   (:temporary (:scs (descriptor-reg)) func)
  31.   (:temporary (:sc any-reg :offset nargs-offset) nargs)
  32.   (:temporary (:sc any-reg :offset ocfp-offset) old-fp)
  33.   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))
  34.  
  35.  
  36. (eval-when (compile load eval)
  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 (dst src)
  45.   (collect ((moves))
  46.     (do ((dst dst (cdr dst))
  47.      (src src (cdr src)))
  48.     ((or (null dst) (null src)))
  49.       (moves `(move ,(car dst) ,(car src))))
  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)
  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 (temp-names) (arg-names))
  90.          (inst li nargs (fixnum ,num-args))
  91.          (load-symbol cname symbol)
  92.          (inst ld func cname
  93.            (- (ash symbol-raw-function-addr-slot word-shift)
  94.               other-pointer-type))
  95.          (when cur-nfp
  96.            (store-stack-tn nfp-save cur-nfp))
  97.          (inst move old-fp cfp-tn)
  98.          (inst move cfp-tn csp-tn)
  99.          (inst compute-lra-from-code lra code-tn lra-label temp)
  100.          (inst j func (- (ash function-header-code-offset word-shift)
  101.                  function-pointer-type))
  102.          (inst move code-tn func)
  103.          (emit-return-pc lra-label)
  104.          (note-this-location vop :unknown-return)
  105.          ,(collect ((bindings) (links))
  106.         (do ((temp (temp-names) (cdr temp))
  107.              (name 'values (gensym))
  108.              (prev nil name)
  109.              (i 0 (1+ i)))
  110.             ((= i num-results))
  111.           (bindings `(,name
  112.                   (make-tn-ref ,(car temp) nil)))
  113.           (when prev
  114.             (links `(setf (tn-ref-across ,prev) ,name))))
  115.         `(let ,(bindings)
  116.            ,@(links)
  117.            (default-unknown-values
  118.                ,(if (zerop num-results) nil 'values)
  119.                ,num-results move-temp temp lra-label)))
  120.          (when cur-nfp
  121.            (load-stack-tn cur-nfp nfp-save))
  122.          ,@(moves (result-names) (temp-names))))))))
  123.  
  124.  
  125. ) ; eval-when (compile load eval)
  126.  
  127.  
  128. (macrolet ((frob (num-args num-res)
  129.          (static-function-template-vop (eval num-args) (eval num-res))))
  130.   (frob 0 1)
  131.   (frob 1 1)
  132.   (frob 2 1)
  133.   (frob 3 1)
  134.   (frob 4 1)
  135.   (frob 5 1))
  136.  
  137.  
  138. (defmacro define-static-function (name args &key (results '(x)) translate
  139.                        policy cost arg-types result-types)
  140.   `(define-vop (,name
  141.         ,(static-function-template-name (length args)
  142.                         (length results)))
  143.      (:variant ',name)
  144.      (:note ,(format nil "static-function ~@(~S~)" name))
  145.      ,@(when translate
  146.      `((:translate ,translate)))
  147.      ,@(when policy
  148.      `((:policy ,policy)))
  149.      ,@(when cost
  150.      `((:generator-cost ,cost)))
  151.      ,@(when arg-types
  152.      `((:arg-types ,@arg-types)))
  153.      ,@(when result-types
  154.      `((:result-types ,@result-types)))))
  155.