1 ;;; -*- Package: ALPHA -*-
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.
9 ;;; **********************************************************************
11 ;;; This file contains the VOPs and macro magic necessary to call static
14 ;;; Written by William Lott.
15 ;;; Converted by Sean Hallgren.
22 (define-vop (static-function-template)
25 (:variant-vars symbol)
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))
36 (eval-when (:compile-toplevel :load-toplevel :execute)
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)))
44 (defun moves (src dst)
46 (do ((dst dst (cdr dst))
48 ((or (null dst) (null src)))
49 (moves `(move ,(car src) ,(car dst))))
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)
73 :target ,(nth i (result-names)))))
76 (let ((arg-name (intern (format nil "ARG-~D" i))))
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)
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)
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))
107 (make-tn-ref ,(car temp) nil)))
109 (links `(setf (tn-ref-across ,prev) ,name))))
112 (default-unknown-values vop
113 ,(if (zerop num-results) nil 'values)
114 ,num-results move-temp temp lra-label)))
116 (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))
117 ,@(moves (temp-names) (result-names))))))))
120 ) ; eval-when (compile load eval)
124 (collect ((templates (list 'progn)))
125 (dotimes (i register-arg-count)
126 (templates (static-function-template-vop i 1)))
130 (defmacro define-static-function (name args &key (results '(x)) translate
131 policy cost arg-types result-types)
133 ,(static-function-template-name (length args)
136 (:note ,(format nil "static-function ~@(~S~)" name))
138 `((:translate ,translate)))
140 `((:policy ,policy)))
142 `((:generator-cost ,cost)))
144 `((:arg-types ,@arg-types)))
146 `((:result-types ,@result-types)))))