compiler-protocol.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2001-2005,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway.
   5 ;;;;
   6 ;;;;    For distribution policy, see the accompanying file COPYING.
   7 ;;;;
   8 ;;;; Filename:      compiler-protocol.lisp
   9 ;;;; Description:
  10 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
  11 ;;;; Created at:    Wed Oct 10 13:02:03 2001
  12 ;;;;
  13 ;;;; $Id: compiler-protocol.lisp,v 1.4 2005/08/20 20:30:03 ffjeld Exp $
  14 ;;;;
  15 ;;;;------------------------------------------------------------------
  16
  17 (in-package movitz)
  18
  19 (eval-when (:compile-toplevel :load-toplevel :execute)
  20   (defconstant +boolean-modes+
  21       '(:boolean-greater
  22         :boolean-less
  23         :boolean-greater-equal
  24         :boolean-less-equal
  25         :boolean-below
  26         :boolean-above
  27         :boolean-below-equal
  28         :boolean-above-equal
  29         :boolean-zf=1
  30         :boolean-zf=0
  31         :boolean-cf=1
  32         :boolean-cf=0
  33         :boolean-ecx))
  34
  35   (defconstant +multiple-value-result-modes+
  36       '(:multiple-values
  37         :function)))
  38
  39 ;; Mode :boolean-ecx takes two parameters: the true value and the false value.
  40
  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))
  45        (prog1 ,(car new)
  46          (setq ,(car new) (+ ,(car new) ,delta))
  47          ,setter))))
  48
  49 (defmacro default-compiler-values-producer () nil)
  50
  51 (defun valid-finals (&rest final-form-values)
  52   (not (some (lambda (x) (eq x 'unknown-final-form)) final-form-values)))
  53
  54 (defun modifies-union (x y)
  55   (if (or (eq x t) (eq y t))
  56       t
  57     (union x y)))
  58
  59 (defun modifies-member (item set)
  60   (or (eq set t) (member item set :test #'eq)))
  61
  62 ;;; Upstream values
  63 ;;; ===============
  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.
  75
  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)
  89       (progn
  90         (assert (or abstract
  91                     (eq :nothing returns)
  92                     code-p) ()
  93           "Returning CODE and RETURNS is mandatory ~@[for ~A ~]in the compiler protocol."
  94           producer)
  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)))))
 103
 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))
 112                                 form &body body)
 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
 115 COMPILER-VALUES."
 116   (if (not all)
 117       `(multiple-value-bind (,code ,returns ,functional-p ,producer ,modifies ,type ,final-form)
 118            ,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))))
 126          ,@body)
 127     `(multiple-value-bind (,code ,returns ,functional-p ,producer ,modifies ,type ,final-form)
 128          ,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))))
 136        (macrolet ((,all (x)
 137                     (ecase x
 138                       (:code ',code) (:returns ',returns) (:functional-p ',functional-p)
 139                       (:producer ',producer) (:modifies ',modifies) (:type ',type)
 140                       (:final-form ',final-form))))
 141          ,@body))))
 142
 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)))
 146
 147 (defmacro compiler-values-list-bind (var-specs form &body body)
 148   "Unwrap compiler-values from a list."
 149   `(compiler-values-bind ,var-specs
 150        (values-list ,form)
 151      ,@body))
 152
 153 (defmacro compiler-values-getf (values indicator)
 154   `(compiler-values-list-bind (&all my-values) ,values (my-values ,indicator)))
 155
 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))
 164                            &body defun-body)
 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)
 171        ,@docstring
 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)
 180                   ,@(when all-p
 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))))))
 185          ,@body))))
 186
 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.")
 197   (cond
 198    (modify-accumulate
 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))))
 203    (defaults
 204        `(let* ((outer-env ,(if env-p env-var `(,defaults :env)))
 205                (inner-env ,(if (not with-stack-used)
 206                                `outer-env
 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))
 213                    inner-env
 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)))))
 217    (forward
 218     `(let* ((outer-env ,(if env-p env-var `(,forward :env)))
 219             (inner-env ,(if (not with-stack-used)
 220                             `outer-env
 221                           `(make-instance 'with-things-on-stack-env
 222                              :uplink outer-env :stack-used ,with-stack-used
 223                              :funobj (movitz-environment-funobj outer-env)))))
 224
 225        (funcall ,compiler-name
 226                 ,(if form-p form-var `(,forward :form))
 227                 ,(if funobj-p funobj-var `(,forward :funobj))
 228                 inner-env
 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))))
 241
 242 (defmacro define-special-operator (name formals &body body)
 243   (let* ((movitz-name (intern (symbol-name (translate-program name :cl :muerte.cl))
 244                            :muerte))
 245          (fname (intern (with-standard-io-syntax
 246                           (format nil "~A-~A" 'special-operator movitz-name)))))
 247     `(progn
 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
 252            'compiler ',fname))
 253        (define-compiler ,fname ,formals
 254          (block ,name ,@body)))))
 255
 256 (defmacro compiler-values-setq ((&key ((&code code-var) nil code-p)
 257                                       ((&returns returns-var) nil returns-p))
 258                                 values-form)
 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)))
 263          ,values-form
 264        (setq ,@(when code-p `(,code-var ,code-tmp))
 265              ,@(when returns-p `(,returns-var ,returns-tmp))))))
 266
 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))))
 270      ,@body))