1 ;;;;------------------------------------------------------------------
3 ;;;; Copyright (C) 2001-2005,
4 ;;;; Department of Computer Science, University of Tromso, Norway.
6 ;;;; For distribution policy, see the accompanying file COPYING.
8 ;;;; Filename: compiler-protocol.lisp
10 ;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
11 ;;;; Created at: Wed Oct 10 13:02:03 2001
13 ;;;; $Id: compiler-protocol.lisp,v 1.4 2005/08/20 20:30:03 ffjeld Exp $
15 ;;;;------------------------------------------------------------------
19 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
20 (defconstant +boolean-modes
+
23 :boolean-greater-equal
35 (defconstant +multiple-value-result-modes
+
39 ;; Mode :boolean-ecx takes two parameters: the true value and the false value.
41 (defmacro post-incf
(place &optional
(delta 1) &environment env
)
42 (multiple-value-bind (dummies vals new setter getter
)
43 (get-setf-expansion place env
)
44 `(let* (,@(mapcar #'list dummies vals
) (,(car new
) ,getter
))
46 (setq ,(car new
) (+ ,(car new
) ,delta
))
49 (defmacro default-compiler-values-producer
() nil
)
51 (defun valid-finals (&rest final-form-values
)
52 (not (some (lambda (x) (eq x
'unknown-final-form
)) final-form-values
)))
54 (defun modifies-union (x y
)
55 (if (or (eq x t
) (eq y t
))
59 (defun modifies-member (item set
)
60 (or (eq set t
) (member item set
:test
#'eq
)))
64 ;;; code: Assembly code (required, may be nothing).
65 ;;; returns: The returns mode of code (required).
66 ;;; functional-p: The code has no side-effects.
67 ;;; producer: The name of the compiler function that generated code.
68 ;;; type: The (lisp) type of the value(s) returned by code.
69 ;;; modifies: The set of lexical bindings modified by code, or t for unknown.
70 ;;; final-form: The fully-expanded form that got compiled.
71 ;;; For self-evaluating objects, a movitz-object (from storage-types.lisp).
72 ;;; For lexical bindings, the binding object.
73 ;;; For function applications, the form (<function-name> <args> ..)
74 ;;; For dynamic loads, the symbol.
76 (defmacro compiler-values
((&optional default-values
&key abstract
)
77 &key
(code nil code-p
)
78 (returns :nothing returns-p
)
79 (functional-p (null code
) functional-p-p
)
80 (producer '(default-compiler-values-producer) producer-p
)
81 (modifies (if (eq t functional-p
) nil t
) modifies-p
)
82 (type ''(values &rest t
) type-p
)
83 (final-form ''unknown-final-form final-form-p
))
84 "Return the compiler-values as provided by the &key arguments. DEFAULT-VALUES names
85 an &all variable from compiler-values-bind whose values will be used as defaults in the
86 absence of values explicitly passed. If ABSTRACT is true, it means these compiler-values does
87 not represent actual code, and certain consistency rules will not be enforced."
88 (if (not default-values
)
93 "Returning CODE and RETURNS is mandatory ~@[for ~A ~]in the compiler protocol."
95 `(values ,code
,returns
,functional-p
,producer
,modifies
,type
,final-form
))
96 `(values ,(if code-p code
`(,default-values
:code
))
97 ,(if returns-p returns
`(,default-values
:returns
))
98 ,(if functional-p-p functional-p
`(,default-values
:functional-p
))
99 ,(if producer-p producer
`(,default-values
:producer
))
100 ,(if modifies-p modifies
`(,default-values
:modifies
))
101 ,(if type-p type
`(,default-values
:type
))
102 ,(if final-form-p final-form
`(,default-values
:final-form
)))))
104 (defmacro compiler-values-bind
((&key
((&all all
))
105 ((&code code
) (gensym) code-p
)
106 ((&returns returns
) (gensym) returns-p
)
107 ((&functional-p functional-p
) (gensym) functional-p-p
)
108 ((&producer producer
) (gensym) producer-p
)
109 ((&modifies modifies
) (gensym) modifies-p
)
110 ((&type type
) (gensym) type-p
)
111 ((&final-form final-form
) (gensym) final-form-p
))
113 "Run BODY with variables lexically bound to the compiler-values returned by FORM. &all names a
114 variable that will represent all the compiler-values, to be passed on as default-values to
117 `(multiple-value-bind (,code
,returns
,functional-p
,producer
,modifies
,type
,final-form
)
119 (declare (ignore ,@(unless code-p
(list code
))
120 ,@(unless returns-p
(list returns
))
121 ,@(unless functional-p-p
(list functional-p
))
122 ,@(unless producer-p
(list producer
))
123 ,@(unless modifies-p
(list modifies
))
124 ,@(unless type-p
(list type
))
125 ,@(unless final-form-p
(list final-form
))))
127 `(multiple-value-bind (,code
,returns
,functional-p
,producer
,modifies
,type
,final-form
)
129 (declare (ignorable ,@(unless code-p
(list code
))
130 ,@(unless returns-p
(list returns
))
131 ,@(unless functional-p-p
(list functional-p
))
132 ,@(unless producer-p
(list producer
))
133 ,@(unless modifies-p
(list modifies
))
134 ,@(unless type-p
(list type
))
135 ,@(unless final-form-p
(list final-form
))))
138 (:code
',code
) (:returns
',returns
) (:functional-p
',functional-p
)
139 (:producer
',producer
) (:modifies
',modifies
) (:type
',type
)
140 (:final-form
',final-form
))))
143 (defmacro compiler-values-list
(&rest compiler-values-spec
)
144 "Wrap up compiler-values in a list."
145 `(multiple-value-list (compiler-values ,@compiler-values-spec
)))
147 (defmacro compiler-values-list-bind
(var-specs form
&body body
)
148 "Unwrap compiler-values from a list."
149 `(compiler-values-bind ,var-specs
153 (defmacro compiler-values-getf
(values indicator
)
154 `(compiler-values-list-bind (&all my-values
) ,values
(my-values ,indicator
)))
156 (defmacro define-compiler
(name
157 (&key
((&all all-var
) nil all-p
)
158 ((&form form-var
) (copy-symbol 'form
) form-p
)
159 ((&funobj funobj-var
) (copy-symbol 'funobj
) funobj-p
)
160 ((&env env-var
) (copy-symbol 'env
) env-p
)
161 ((&top-level-p top-level-p-var
) (copy-symbol 'top-level-p
) top-level-p-p
)
162 ((&result-mode result-mode-var
) (copy-symbol 'result-mode
) result-mode-p
)
163 ((&extent extent-var
) (copy-symbol 'extent
) extent-p
))
165 (multiple-value-bind (body docstring
)
166 (if (and (cdr defun-body
)
167 (stringp (car defun-body
)))
168 (values (cdr defun-body
) (list (car defun-body
)))
169 (values defun-body nil
))
170 `(defun ,name
(,form-var
,funobj-var
,env-var
,top-level-p-var
,result-mode-var
,extent-var
)
172 (declare (,(if all-p
'ignorable
'ignore
)
173 ,@(unless form-p
(list form-var
))
174 ,@(unless funobj-p
(list funobj-var
))
175 ,@(unless env-p
(list env-var
))
176 ,@(unless top-level-p-p
(list top-level-p-var
))
177 ,@(unless result-mode-p
(list result-mode-var
))
178 ,@(unless extent-p
(list extent-var
))))
179 (macrolet ((default-compiler-values-producer () '',name
)
181 `((,all-var
(v) (ecase v
(:form
',form-var
) (:funobj
',funobj-var
)
182 (:env
',env-var
) (:top-level-p
',top-level-p-var
)
183 (:result-mode
',result-mode-var
)
184 (:extent
',extent-var
))))))
187 (defmacro compiler-call
(compiler-name &rest all-keys
188 &key defaults forward with-stack-used modify-accumulate
189 ((:form form-var
) nil form-p
)
190 ((:funobj funobj-var
) nil funobj-p
)
191 ((:env env-var
) nil env-p
)
192 ((:extent extent-var
) nil extent-p
)
193 ((:top-level-p top-level-p-var
) nil top-level-p-p
)
194 ((:result-mode result-mode-var
) :ignore result-mode-p
))
195 (assert (not (and defaults forward
)) ()
196 "Both :defaults and :forward can't be specified.")
199 `(compiler-values-bind (&all save-all
&modifies keep-modifies
)
200 (compiler-call ,compiler-name
:modify-accumulate nil
,@all-keys
)
201 (setf ,modify-accumulate
(modifies-union ,modify-accumulate keep-modifies
))
202 (compiler-values (save-all))))
204 `(let* ((outer-env ,(if env-p env-var
`(,defaults
:env
)))
205 (inner-env ,(if (not with-stack-used
)
207 `(make-instance 'with-things-on-stack-env
208 :uplink outer-env
:stack-used
,with-stack-used
209 :funobj
(movitz-environment-funobj outer-env
)))))
210 (funcall ,compiler-name
211 ,(if form-p form-var
`(,defaults
:form
))
212 ,(if funobj-p funobj-var
`(,defaults
:funobj
))
214 ,(when top-level-p-p top-level-p-var
) ; default to nil, no forwarding.
215 ,(if result-mode-p result-mode-var
`(,defaults
:result-mode
))
216 ,(if extent-p extent-var
`(,defaults
:extent
)))))
218 `(let* ((outer-env ,(if env-p env-var
`(,forward
:env
)))
219 (inner-env ,(if (not with-stack-used
)
221 `(make-instance 'with-things-on-stack-env
222 :uplink outer-env
:stack-used
,with-stack-used
223 :funobj
(movitz-environment-funobj outer-env
)))))
225 (funcall ,compiler-name
226 ,(if form-p form-var
`(,forward
:form
))
227 ,(if funobj-p funobj-var
`(,forward
:funobj
))
229 ,(if top-level-p-p top-level-p-var
`(,forward
:top-level-p
))
230 ,(if result-mode-p result-mode-var
`(,forward
:result-mode
))
231 ,(if extent-p extent-var
`(,forward
:extent
)))))
232 ((not with-stack-used
)
233 `(funcall ,compiler-name
,form-var
,funobj-var
,env-var
234 ,top-level-p-var
,result-mode-var
,extent-var
))
235 (t (assert env-p
() ":env is required when with-stack-used is given.")
236 `(funcall ,compiler-name
,form-var
,funobj-var
237 (make-instance 'with-things-on-stack-env
238 :uplink
,env-var
:stack-used
,with-stack-used
239 :funobj
(movitz-environment-funobj ,env-var
))
240 ,top-level-p-var
,result-mode-var
,extent-var
))))
242 (defmacro define-special-operator
(name formals
&body body
)
243 (let* ((movitz-name (intern (symbol-name (translate-program name
:cl
:muerte.cl
))
245 (fname (intern (with-standard-io-syntax
246 (format nil
"~A-~A" 'special-operator movitz-name
)))))
248 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
249 (export ',movitz-name
(symbol-package ',movitz-name
)))
250 (setf (movitz-env-symbol-function ',movitz-name
*persistent-movitz-environment
*)
251 (make-instance 'movitz-special-operator
253 (define-compiler ,fname
,formals
254 (block ,name
,@body
)))))
256 (defmacro compiler-values-setq
((&key
((&code code-var
) nil code-p
)
257 ((&returns returns-var
) nil returns-p
))
259 (let ((code-tmp (gensym))
260 (returns-tmp (gensym)))
261 `(compiler-values-bind (,@(when code-p
`(&code
,code-tmp
))
262 ,@(when returns-p
`(&returns
,returns-tmp
)))
264 (setq ,@(when code-p
`(,code-var
,code-tmp
))
265 ,@(when returns-p
`(,returns-var
,returns-tmp
))))))
267 (defmacro with-labels
((prefix labels
) &body body
)
268 `(let ,(loop for label in labels
269 collect
`(,label
(gensym ,(format nil
"~A-~A" prefix label
))))