home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / rt / static-fn.lisp < prev    next >
Encoding:
Text File  |  1991-11-06  |  4.8 KB  |  147 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  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 91/02/18 15:08:13 chiles Exp $
  11. ;;;
  12. ;;; This file contains the VOPs and macro magic necessary to call static
  13. ;;; functions.
  14. ;;;
  15. ;;; Written by William Lott.
  16. ;;; Converted by Bill Chiles.
  17. ;;;
  18.  
  19. (in-package "RT")
  20.  
  21.  
  22.  
  23. (define-vop (static-function-template)
  24.   (:save-p t)
  25.   (:policy :safe)
  26.   (:variant-vars symbol)
  27.   (:vop-var vop)
  28.   (:temporary (:scs (non-descriptor-reg)) temp)
  29.   (:temporary (:scs (descriptor-reg)) move-temp)
  30.   (:temporary (:sc descriptor-reg :offset lra-offset) lra)
  31.   (:temporary (:sc descriptor-reg :offset cname-offset) cname)
  32.   (:temporary (:scs (interior-reg) :type interior) lip)
  33.   (:temporary (:sc any-reg :offset nargs-offset) nargs)
  34.   (:temporary (:sc any-reg :offset ocfp-offset) old-fp)
  35.   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))
  36.  
  37.  
  38. (eval-when (compile load eval)
  39.  
  40. (defun static-function-template-name (num-args num-results)
  41.   (intern (format nil "~:@(~R-arg-~R-result-static-function~)"
  42.           num-args num-results)))
  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.          (loadw lip cname vm:symbol-raw-function-addr-slot
  93.             vm:other-pointer-type)
  94.          (when cur-nfp
  95.            (store-stack-tn cur-nfp nfp-save))
  96.          (move old-fp cfp-tn)
  97.          (inst compute-lra-from-code lra code-tn lra-label)
  98.          (inst bx lip)
  99.          (inst move cfp-tn csp-tn)
  100.          (emit-return-pc lra-label)
  101.          (note-this-location vop :unknown-return)
  102.          ,(collect ((bindings) (links))
  103.         (do ((temp (temp-names) (cdr temp))
  104.              (name 'values (gensym))
  105.              (prev nil name)
  106.              (i 0 (1+ i)))
  107.             ((= i num-results))
  108.           (bindings `(,name
  109.                   (make-tn-ref ,(car temp) nil)))
  110.           (when prev
  111.             (links `(setf (tn-ref-across ,prev) ,name))))
  112.         `(let ,(bindings)
  113.            ,@(links)
  114.            (default-unknown-values
  115.                ,(if (zerop num-results) nil 'values)
  116.                ,num-results move-temp lra-label)))
  117.          (when cur-nfp
  118.            (load-stack-tn cur-nfp nfp-save))
  119.          ,@(moves (result-names) (temp-names))))))))
  120.  
  121. ) ;EVAL-WHEN (compile load eval)
  122.  
  123.  
  124. (macrolet ((frob (nargs nres)
  125.          (static-function-template-vop nargs nres)))
  126.   (frob 0 1)
  127.   (frob 1 1)
  128.   (frob 2 1))
  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)))))
  147.