special-operators.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 20012000, 2002-2005,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway
   5 ;;;;
   6 ;;;; Filename:      special-operators.lisp
   7 ;;;; Description:   Compilation of internal special operators.
   8 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
   9 ;;;; Created at:    Fri Nov 24 16:22:59 2000
  10 ;;;;
  11 ;;;; $Id: special-operators.lisp,v 1.56 2007/02/26 18:25:21 ffjeld Exp $
  12 ;;;;
  13 ;;;;------------------------------------------------------------------
  14
  15 (in-package movitz)
  16
  17 (defun ccc-result-to-returns (result-mode)
  18   (check-type result-mode keyword)
  19   (case result-mode
  20     (:ignore :nothing)
  21     (:function :multiple-values)
  22     (t result-mode)))
  23
  24 (defun make-compiled-cond-clause (clause clause-num last-clause-p exit-label funobj env result-mode)
  25   "Return three values: The code for a cond clause,
  26 a boolean value indicating whether the clause's test was constantly true,
  27 The set of modified bindings."
  28   (assert (not (atom clause)))
  29   (let* ((clause-modifies nil)
  30          (test-form (car clause))
  31          (then-forms (cdr clause)))
  32     (cond
  33      ((null then-forms)
  34       (compiler-values-bind (&code test-code &returns test-returns)
  35           (compiler-call #'compile-form
  36             :modify-accumulate clause-modifies
  37             :result-mode (case (operator result-mode)
  38                            (:boolean-branch-on-false
  39                             (if last-clause-p
  40                                 result-mode
  41                               (cons :boolean-branch-on-true
  42                                     exit-label)))
  43                            (:boolean-branch-on-true
  44                             result-mode)
  45                            (:ignore
  46                             (cons :boolean-branch-on-true
  47                                   exit-label))
  48                            (:push
  49                             (if last-clause-p
  50                                 :push
  51                               :eax))
  52                            (#.+multiple-value-result-modes+
  53                             :eax)
  54                            (t result-mode))
  55             :form test-form
  56             :funobj funobj
  57             :env env)
  58         (assert (not (null test-code)) (clause) "null test-code!")
  59         (values (ecase (operator test-returns)
  60                   ((:boolean-branch-on-true
  61                     :boolean-branch-on-false)
  62                    test-code)
  63                   (:push
  64                    (assert last-clause-p)
  65                    test-code)
  66                   ((:multiple-values :eax :ebx :ecx :edx)
  67 ;;;                (when (eq result-mode :function)
  68 ;;;                  (warn "test-returns: ~S" test-returns))
  69                    (let ((singlify (when (member result-mode +multiple-value-result-modes+)
  70                                      '((:clc)))))
  71                      (append test-code
  72                              (cond
  73                               ((not last-clause-p)
  74                                (append
  75                                 `((:cmpl :edi ,(single-value-register (operator test-returns))))
  76                                 singlify
  77                                 (when (eq :push result-mode)
  78                                   `((:pushl ,(single-value-register (operator test-returns)))))
  79                                 `((:jne ',exit-label))))
  80                               (t singlify))))))
  81                 nil)))
  82      ((not (null then-forms))
  83       (let ((skip-label (gensym (format nil "cond-skip-~D-" clause-num))))
  84         (compiler-values-bind (&code test-code)
  85             (compiler-call #'compile-form
  86               :result-mode (cond
  87                             ((and last-clause-p
  88                                   (eq (operator result-mode)
  89                                       :boolean-branch-on-false))
  90                              (cons :boolean-branch-on-false
  91                                    (cdr result-mode)))
  92                             (t (cons :boolean-branch-on-false
  93                                      skip-label)))
  94               :modify-accumulate clause-modifies
  95               :form test-form
  96               :funobj funobj
  97               :env env)
  98           (compiler-values-bind (&code then-code &returns then-returns)
  99               (compiler-call #'compile-form
 100                 :form (cons 'muerte.cl::progn then-forms)
 101                 :modify-accumulate clause-modifies
 102                 :funobj funobj
 103                 :env env
 104                 :result-mode result-mode)
 105             (let ((constantly-true-p (null test-code)))
 106               (values (append test-code
 107                               then-code
 108                               (unless (or last-clause-p (eq then-returns :non-local-exit))
 109                                 `((:jmp ',exit-label)))
 110                               (unless constantly-true-p
 111                                 (list skip-label)))
 112                       constantly-true-p
 113                       clause-modifies)))))))))
 114
 115 (defun chose-joined-returns-and-result (result-mode)
 116   "From a result-mode, determine a joined result-mode (for several branches),
 117 and the correspondig returns mode (secondary value)."
 118   (let ((joined-result-mode (case (operator result-mode)
 119                               (:values :multiple-values)
 120                               ((:ignore :function :multiple-values :eax :ebx :ecx :edx
 121                                 :boolean-branch-on-false :boolean-branch-on-true)
 122                                result-mode)
 123                               (t :eax))))
 124     (values joined-result-mode
 125             (ecase (operator joined-result-mode)
 126               (:ignore :nothing)
 127               (:function :multiple-values)
 128               ((:multiple-values :eax :push :eax :ebx :ecx :edx
 129                 :boolean-branch-on-true :boolean-branch-on-false)
 130                joined-result-mode)))))
 131
 132 (define-special-operator compiled-cond
 133     (&form form &funobj funobj &env env &result-mode result-mode)
 134   (let ((clauses (cdr form)))
 135     (let* ((cond-exit-label (gensym "cond-exit-"))
 136            (cond-result-mode (case (operator result-mode)
 137                                (:values :multiple-values)
 138                                ((:ignore :function :multiple-values :eax :ebx :ecx :edx
 139                                  :boolean-branch-on-false :boolean-branch-on-true)
 140                                 result-mode)
 141                                (t :eax)))
 142            (cond-returns (ecase (operator cond-result-mode)
 143                            (:ignore :nothing)
 144                            (:function :multiple-values)
 145                            ((:multiple-values :eax :push :eax :ebx :ecx :edx
 146                              :boolean-branch-on-true :boolean-branch-on-false)
 147                             cond-result-mode)))
 148            (only-control-p (member (operator cond-result-mode)
 149                                    '(:ignore
 150                                      :boolean-branch-on-true
 151                                      :boolean-branch-on-false))))
 152       (loop with last-clause-num = (1- (length clauses))
 153           for clause in clauses
 154           for clause-num upfrom 0
 155           as (clause-code constantly-true-p) =
 156             (multiple-value-list
 157              (make-compiled-cond-clause clause
 158                                         clause-num
 159                                         (and only-control-p
 160                                              (= clause-num last-clause-num))
 161                                         cond-exit-label funobj env cond-result-mode))
 162           append clause-code into cond-code
 163           when constantly-true-p
 164           do (return (compiler-values ()
 165                        :returns cond-returns
 166                        :code (append cond-code
 167                                      (list cond-exit-label))))
 168           finally
 169             (return (compiler-values ()
 170                       :returns cond-returns
 171                       :code (append cond-code
 172                                     ;; no test succeeded => nil
 173                                     (unless only-control-p
 174                                       (compiler-call #'compile-form
 175                                         :form nil
 176                                         :funobj funobj
 177                                         :env env
 178                                         :top-level-p nil
 179                                         :result-mode cond-result-mode))
 180                                     (list cond-exit-label))))))))
 181
 182
 183 (define-special-operator compiled-case (&all all &form form &result-mode result-mode)
 184   (destructuring-bind (keyform &rest clauses)
 185       (cdr form)
 186     #+ignore
 187     (let ((cases (loop for (clause . nil) in clauses
 188                      append (if (consp clause)
 189                                 clause
 190                               (unless (member clause '(nil muerte.cl:t muerte.cl:otherwise))
 191                                 (list clause))))))
 192       (warn "case clauses:~%~S" cases))
 193     (compiler-values-bind (&code key-code &returns key-returns)
 194         (compiler-call #'compile-form-unprotected
 195           :result-mode :eax
 196           :forward all
 197           :form keyform)
 198       (multiple-value-bind (case-result-mode case-returns)
 199           (chose-joined-returns-and-result result-mode)
 200         (let ((key-reg (accept-register-mode key-returns)))
 201           (flet ((otherwise-clause-p (x)
 202                    (member (car x) '(muerte.cl:t muerte.cl:otherwise)))
 203                  (make-first-check (key then-label then-code exit-label)
 204                    `((:load-constant ,key ,key-reg :op :cmpl)
 205                      (:je '(:sub-program (,then-label)
 206                             ,@then-code
 207                             (:jmp ',exit-label))))))
 208             (cond
 209              ((otherwise-clause-p (first clauses))
 210               (compiler-call #'compile-implicit-progn
 211                 :forward all
 212                 :form (rest (first clauses))))
 213              (t (compiler-values ()
 214                   :returns case-returns
 215                   :code (append (make-result-and-returns-glue key-reg key-returns key-code)
 216                                 (loop with exit-label = (gensym "case-exit-")
 217                                     for clause-head on clauses
 218                                     as clause = (first clause-head)
 219                                     as keys =  (first clause)
 220                                     as then-forms = (rest clause)
 221                                     as then-label = (gensym "case-then-")
 222                                     as then-code = (compiler-call #'compile-form
 223                                                      :result-mode case-result-mode
 224                                                      :forward all
 225                                                      :form `(muerte.cl:progn ,@then-forms))
 226                                     if (otherwise-clause-p clause)
 227                                     do (assert (endp (rest clause-head)) ()
 228                                          "Case's otherwise clause must be the last clause.")
 229                                     and append then-code
 230                                     else if (atom keys)
 231                                     append (make-first-check keys then-label then-code exit-label)
 232                                     else append (make-first-check (first keys) then-label
 233                                                                   then-code exit-label)
 234                                     and append (loop for key in (rest keys)
 235                                                    append `((:load-constant ,key ,key-reg :op :cmpl)
 236                                                             (:je ',then-label)))
 237                                     if (endp (rest clause-head))
 238                                     append (append (unless (otherwise-clause-p clause)
 239                                                      (compiler-call #'compile-form
 240                                                        :result-mode case-result-mode
 241                                                        :forward all
 242                                                        :form nil))
 243                                                    (list exit-label)))))))))))))
 244
 245 (define-special-operator compile-time-find-class (&all all &form form)
 246   (destructuring-bind (class-name)
 247       (cdr form)
 248     (compiler-call #'compile-form-unprotected
 249       :form (muerte::movitz-find-class class-name)
 250       :forward all)))
 251
 252 (define-special-operator make-named-function (&form form &env env)
 253   (destructuring-bind (name formals declarations docstring body)
 254       (cdr form)
 255     (declare (ignore docstring))
 256     (handler-bind (#+ignore ((or error warning) (lambda (c)
 257                                          (declare (ignore c))
 258                                          (format *error-output* "~&;; In function ~S:~&" name))))
 259       (let* ((*compiling-function-name* name)
 260              (funobj (make-compiled-funobj name formals declarations body env nil)))
 261         (setf (movitz-funobj-symbolic-name funobj) name)
 262         (setf (movitz-env-named-function name) funobj))))
 263   (compiler-values ()))
 264
 265 (define-special-operator make-primitive-function (&form form &env env)
 266   (destructuring-bind (name docstring body)
 267       (cdr form)
 268     (destructuring-bind (name &key symtab-property)
 269         (if (consp name) name (list name))
 270       (handler-bind (((or warning error)
 271                       (lambda (c)
 272                         (declare (ignore c))
 273                         (format *error-output* "~&;; In primitive function ~S:" name))))
 274         (multiple-value-bind (code-vector symtab)
 275             (make-compiled-primitive body env nil docstring)
 276           (setf (movitz-symbol-value (movitz-read name)) code-vector)
 277           (when symtab-property
 278             (setf (movitz-env-get name :symtab)
 279               (muerte::translate-program symtab :movitz :muerte)))
 280           (compiler-values ()))))))
 281
 282 (define-special-operator define-prototyped-function (&form form)
 283   (destructuring-bind (function-name proto-name &rest parameters)
 284       (cdr form)
 285     (let* ((funobj-proto (movitz-env-named-function proto-name))
 286            (funobj (make-instance 'movitz-funobj
 287                      :name (movitz-read function-name)
 288                      :code-vector (movitz-funobj-code-vector funobj-proto)
 289                      :code-vector%1op (movitz-funobj-code-vector%1op funobj-proto)
 290                      :code-vector%2op (movitz-funobj-code-vector%2op funobj-proto)
 291                      :code-vector%3op (movitz-funobj-code-vector%3op funobj-proto)
 292                      :lambda-list (movitz-funobj-lambda-list funobj-proto)
 293                      :num-constants (movitz-funobj-num-constants funobj-proto)
 294                      :num-jumpers (movitz-funobj-num-jumpers funobj-proto)
 295                      :jumpers-map (movitz-funobj-jumpers-map funobj-proto)
 296                      :symbolic-code (when (slot-boundp funobj-proto 'symbolic-code)
 297                                       (movitz-funobj-symbolic-code funobj-proto))
 298                      :const-list (let ((c (copy-list (movitz-funobj-const-list funobj-proto))))
 299                                    (loop for (lisp-parameter value) in parameters
 300                                        as parameter = (movitz-read lisp-parameter)
 301                                        do (assert (member parameter c) ()
 302                                             "~S is not a function prototype parameter for ~S. ~
 303 The valid parameters are~{ ~S~}."
 304                                             parameter proto-name
 305                                             (mapcar #'movitz-print (movitz-funobj-const-list funobj-proto)))
 306                                           (setf (car (member parameter c))
 307                                             (if (and (consp value)
 308                                                      (eq :movitz-find-class (car value)))
 309                                                 (muerte::movitz-find-class (cadr value))
 310                                               (movitz-read value))))
 311                                    c))))
 312       (setf (movitz-funobj-symbolic-name funobj) function-name)
 313       (setf (movitz-env-named-function function-name) funobj)
 314       (compiler-values ()))))
 315
 316 (define-special-operator define-setf-expander-compile-time (&form form)
 317   (destructuring-bind (access-fn lambda-list macro-body)
 318       (cdr form)
 319     (multiple-value-bind (wholevar envvar reqvars optionals restvar keyvars auxvars)
 320         (decode-macro-lambda-list lambda-list)
 321       (let ((cl-lambda-list (translate-program `(,@reqvars
 322                                                  ,@(when optionals '(&optional)) ,@optionals
 323                                                  ,@(when restvar `(&rest ,restvar))
 324                                                  ,@(when keyvars '(&key)) ,@keyvars
 325                                                  ,@(when auxvars '(&aux)) ,@auxvars)
 326                                                :muerte.cl :cl))
 327             (cl-macro-body (translate-program macro-body :muerte.cl :cl)))
 328         (multiple-value-bind (cl-body declarations doc-string)
 329             (parse-docstring-declarations-and-body cl-macro-body 'cl:declare)
 330           (declare (ignore doc-string))
 331           (setf (movitz-env-get access-fn 'muerte::setf-expander nil)
 332             (let* ((form-formal (or wholevar (gensym)))
 333                    (env-formal (or envvar (gensym)))
 334                    (expander (if (null cl-lambda-list)
 335                                  `(lambda (,form-formal ,env-formal)
 336                                     (declare (ignorable ,form-formal ,env-formal)
 337                                              ,@declarations)
 338                                     (translate-program (block ,access-fn ,@cl-body) :cl :muerte.cl))
 339                                `(lambda (,form-formal ,env-formal)
 340                                   (declare (ignorable ,form-formal ,env-formal)
 341                                            ,@declarations)
 342                                   (destructuring-bind ,cl-lambda-list
 343                                       (translate-program (rest ,form-formal) :muerte.cl :cl)
 344                                     (values-list
 345                                      (translate-program (multiple-value-list (block ,access-fn ,@cl-body))
 346                                                         :cl :muerte.cl)))))))
 347               (movitz-macro-expander-make-function expander :type :setf :name access-fn)))))))
 348   (compiler-values ()))
 349
 350 (define-special-operator muerte::defmacro-compile-time (&form form)
 351   (destructuring-bind (name lambda-list macro-body)
 352       (cdr form)
 353     (check-type name symbol "a macro name")
 354     (multiple-value-bind (wholevar envvar reqvars optionals restvar keyvars auxvars)
 355         (decode-macro-lambda-list lambda-list)
 356       (let ((expander-name (make-symbol (format nil "~A-macro" name)))
 357             (cl-lambda-list (translate-program `(,@reqvars
 358                                                  ,@(when optionals '(&optional)) ,@optionals
 359                                                  ,@(when restvar `(&rest ,restvar))
 360                                                  ,@(when keyvars '(&key)) ,@keyvars
 361                                                  ,@(when auxvars '(&aux)) ,@auxvars)
 362                                                :muerte.cl :cl))
 363             (cl-macro-body (translate-program macro-body :muerte.cl :cl)))
 364         (when (member name (image-called-functions *image*) :key #'first)
 365           #+ignore (warn "Macro ~S defined after being called as function (first in ~S)."
 366                          name
 367                          (cdr (find name (image-called-functions *image*) :key #'first))))
 368         (multiple-value-bind (cl-body declarations doc-string)
 369             (parse-docstring-declarations-and-body cl-macro-body 'cl:declare)
 370           (declare (ignore doc-string))
 371 ;;;     (warn "defmacro ~S: ~S" name cl-body)
 372           (let ((expander-lambda
 373                  (let ((form-formal (or wholevar (gensym)))
 374                        (env-formal (or envvar (gensym))))
 375                    (if (null cl-lambda-list)
 376                        `(lambda (,form-formal ,env-formal)
 377                           (declare (ignorable ,form-formal ,env-formal))
 378                           (declare ,@declarations)
 379                           (translate-program  (block ,name ,@cl-body) :cl :muerte.cl))
 380                      `(lambda (,form-formal ,env-formal)
 381                         (declare (ignorable ,form-formal ,env-formal))
 382                         (destructuring-bind ,cl-lambda-list
 383                             (translate-program (rest ,form-formal) :muerte.cl :cl)
 384                           (declare ,@declarations)
 385                           (translate-program  (block ,name ,@cl-body) :cl :muerte.cl)))))))
 386             (setf (movitz-macro-function name)
 387               (movitz-macro-expander-make-function expander-lambda
 388                                                    :name expander-name
 389                                                    :type :defmacro)))))))
 390   (compiler-values ()))
 391
 392 (define-special-operator muerte::define-compiler-macro-compile-time (&form form)
 393   ;; This scheme doesn't quite cut it..
 394   (destructuring-bind (name lambda-list doc-dec-body)
 395       (cdr form)
 396     (multiple-value-bind (body declarations)
 397         (parse-docstring-declarations-and-body doc-dec-body)
 398       (let ((operator-name (or (and (setf-name name)
 399                                     (movitz-env-setf-operator-name (setf-name name)))
 400                                name)))
 401         (multiple-value-bind (wholevar envvar reqvars optionals restvar keyvars auxvars)
 402             (decode-macro-lambda-list lambda-list)
 403           (let ((cl-lambda-list (translate-program `(,@reqvars
 404                                                      ,@(when optionals '(&optional)) ,@optionals
 405                                                      ,@(when restvar `(&rest ,restvar))
 406                                                      ,@(when keyvars '(&key)) ,@keyvars
 407                                                      ,@(when auxvars '(&aux)) ,@auxvars)
 408                                                    :muerte.cl :cl))
 409                 (cl-body (translate-program body :muerte.cl :cl))
 410                 (declarations (translate-program declarations :muerte.cl :cl))
 411                 (form-formal (or wholevar (gensym)))
 412                 (env-formal (or envvar (gensym)))
 413                 (expansion-var (gensym)))
 414             (when (member operator-name (image-called-functions *image*) :key #'first)
 415               (warn "Compiler-macro ~S defined after being called as function (first in ~S)"
 416                     operator-name
 417                     (cdr (find operator-name (image-called-functions *image*) :key #'first))))
 418             (let ((expander
 419                    `(lambda (,form-formal ,env-formal)
 420                       (declare (ignorable ,env-formal))
 421                       (destructuring-bind ,cl-lambda-list
 422                           (translate-program (rest ,form-formal) :muerte.cl :cl)
 423                         (declare ,@declarations)
 424                         (let ((,expansion-var (block ,operator-name ,@cl-body)))
 425                           (if (eq ,form-formal ,expansion-var)
 426                               ,form-formal ; declined
 427                             (translate-program ,expansion-var :cl :muerte.cl)))))))
 428               (setf (movitz-compiler-macro-function operator-name nil)
 429                 (movitz-macro-expander-make-function expander
 430                                                      :name name
 431                                                      :type :compiler-macro))))))))
 432   (compiler-values ()))
 433
 434 (define-special-operator muerte::with-inline-assembly-case
 435     (&all forward &form form &funobj funobj &env env &result-mode result-mode)
 436   (destructuring-bind (global-options &body inline-asm-cases)
 437       (cdr form)
 438     (destructuring-bind (&key (side-effects t) ((:type global-type)))
 439         global-options
 440       (let ((modifies ()))
 441         (loop for case-spec in inline-asm-cases
 442             finally (error "Found no inline-assembly-case matching ~S." result-mode)
 443             do (destructuring-bind ((matching-result-modes &optional (returns :same)
 444                                                            &key labels (type global-type))
 445                                     &body inline-asm)
 446                    (cdr case-spec)
 447                  (when (eq returns :same)
 448                    (setf returns
 449                      (case result-mode
 450                        (:function :multiple-values)
 451                        (t result-mode))))
 452                  (when (flet ((match (matching-result-mode)
 453                                 (or (eq 'muerte.cl::t matching-result-mode)
 454                                     (eq t matching-result-mode)
 455                                     (eq (operator result-mode) matching-result-mode)
 456                                     (and (eq :register matching-result-mode)
 457                                          (member result-mode '(:eax ebx ecx edx :single-value))))))
 458                          (if (symbolp matching-result-modes)
 459                              (match matching-result-modes)
 460                            (find-if #'match matching-result-modes)))
 461                    (case returns
 462                      (:register
 463                       (setf returns (case result-mode
 464                                       ((:eax :ebx :ecx :edx) result-mode)
 465                                       (t :eax)))))
 466                    (unless type
 467                      (setf type
 468                        (ecase (operator returns)
 469                          ((:nothing) nil)
 470                          ((:eax :ebx :ecx :edx) t)
 471                          (#.+boolean-modes+ t)
 472                          ((:boolean-branch-on-false
 473                            :boolean-branch-on-true) t)
 474                          ((:multiple-values) '(values &rest t)))))
 475                    (return
 476                      (let ((amenv (make-assembly-macro-environment))) ; XXX this is really wasteful..
 477                        (setf (assembly-macro-expander :branch-when amenv)
 478                          #'(lambda (expr)
 479                              (destructuring-bind (boolean-mode)
 480                                  (cdr expr)
 481                                (ecase (operator result-mode)
 482                                  ((:boolean-branch-on-true :boolean-branch-on-false)
 483                                   (list (make-branch-on-boolean boolean-mode (operands result-mode)
 484                                                                 :invert nil)))))))
 485                        (setf (assembly-macro-expander :compile-form amenv)
 486                          #'(lambda (expr)
 487                              (destructuring-bind ((&key ((:result-mode sub-result-mode))) sub-form)
 488                                  (cdr expr)
 489                                (case sub-result-mode
 490                                  (:register
 491                                   (setf sub-result-mode returns))
 492                                  (:same
 493                                   (setf sub-result-mode result-mode)))
 494                                (assert sub-result-mode (sub-result-mode)
 495                                  "Assembly :COMPILE-FORM directive doesn't provide a result-mode: ~S"
 496                                  expr)
 497                                (compiler-values-bind (&code sub-code &functional-p sub-functional-p
 498                                                       &modifies sub-modifies)
 499                                    (compiler-call #'compile-form
 500                                      :defaults forward
 501                                      :form sub-form
 502                                      :result-mode sub-result-mode)
 503                                  ;; if a sub-compile has side-effects, then the entire
 504                                  ;; with-inline-assembly form does too.
 505                                  (unless sub-functional-p
 506                                    (setq side-effects t))
 507                                  (setf modifies (modifies-union modifies sub-modifies))
 508                                  sub-code))))
 509                        (setf (assembly-macro-expander :offset amenv)
 510                          #'(lambda (expr)
 511                              (destructuring-bind (type slot &optional (extra 0))
 512                                  (cdr expr)
 513                                (let ((mtype (find-symbol (symbol-name type) :movitz))
 514                                      (mslot (find-symbol (symbol-name slot) :movitz)))
 515                                  (assert mtype (mtype) "Type not a Movitz symbol: ~A" type)
 516                                  (assert mslot (mslot) "Slot not a Movitz symbol: ~A" slot)
 517                                  (list (+ (slot-offset mtype mslot)
 518                                           (eval extra)))))))
 519                        (setf (assembly-macro-expander :returns-mode amenv)
 520                          #'(lambda (expr)
 521                              (assert (= 1 (length expr)))
 522                              (list returns)))
 523                        (setf (assembly-macro-expander :result-register amenv)
 524                          #'(lambda (expr)
 525                              (assert (= 1 (length expr)))
 526                              (assert (member returns '(:eax :ebx :ecx :edx)))
 527                              (list returns)))
 528                        (setf (assembly-macro-expander :result-register-low8 amenv)
 529                          #'(lambda (expr)
 530                              (assert (= 1 (length expr)))
 531                              (assert (member returns '(:eax :ebx :ecx :edx)))
 532                              (list (register32-to-low8 returns))))
 533                        (setf (assembly-macro-expander :compile-arglist amenv)
 534                          #'(lambda (expr)
 535                              (destructuring-bind (ignore &rest arg-forms)
 536                                  (cdr expr)
 537                                (declare (ignore ignore))
 538                                (setq side-effects t)
 539                                (make-compiled-argument-forms arg-forms funobj env))))
 540                        (setf (assembly-macro-expander :compile-two-forms amenv)
 541                          #'(lambda (expr)
 542                              (destructuring-bind ((reg1 reg2) form1 form2)
 543                                  (cdr expr)
 544                                (multiple-value-bind (code sub-functional-p sub-modifies)
 545                                    (make-compiled-two-forms-into-registers form1 reg1 form2 reg2
 546                                                                            funobj env)
 547                                  (unless sub-functional-p
 548                                    (setq side-effects t))
 549                                  (setq modifies (modifies-union modifies sub-modifies))
 550                                  code))))
 551                        (setf (assembly-macro-expander :call-global-pf amenv)
 552                          #'(lambda (expr)
 553                              (destructuring-bind (name)
 554                                  (cdr expr)
 555                                `((:globally (:call (:edi (:edi-offset ,name))))))))
 556                        (setf (assembly-macro-expander :call-local-pf amenv)
 557                          #'(lambda (expr)
 558                              (destructuring-bind (name)
 559                                  (cdr expr)
 560                                `((:locally (:call (:edi (:edi-offset ,name))))))))
 561                        (setf (assembly-macro-expander :warn amenv)
 562                          #'(lambda (expr)
 563                              (apply #'warn (cdr expr))
 564                              nil))
 565                        (setf (assembly-macro-expander :lexical-store amenv)
 566                          (lambda (expr)
 567                            (destructuring-bind (var reg &key (type t))
 568                                (cdr expr)
 569                              `((:store-lexical ,(movitz-binding var env) ,reg :type ,type)))))
 570                        (setf (assembly-macro-expander :lexical-binding amenv)
 571                          (lambda (expr)
 572                            (destructuring-bind (var)
 573                                (cdr expr)
 574                              (let ((binding (movitz-binding var env)))
 575                                (check-type binding binding)
 576                                (list binding)))))
 577                        (let ((code (assembly-macroexpand inline-asm amenv)))
 578                          #+ignore
 579                          (assert (not (and (not side-effects)
 580                                            (tree-search code '(:store-lexical))))
 581                              ()
 582                            "Inline assembly is declared side-effects-free, but contains :store-lexical.")
 583                          (when labels
 584                            (setf code (subst (gensym (format nil "~A-" (first labels)))
 585                                              (first labels)
 586                                              code))
 587                            (dolist (label (rest labels))
 588                              (setf code (nsubst (gensym (format nil "~A-" label))
 589                                                 label
 590                                                 code))))
 591                          (compiler-values ()
 592                            :code code
 593                            :returns returns
 594                            :type (translate-program type :muerte.cl :cl)
 595                            :modifies modifies
 596                            :functional-p (not side-effects))))))))))))
 597
 598
 599 (define-special-operator muerte::declaim-compile-time (&form form &top-level-p top-level-p)
 600   (unless top-level-p
 601     (warn "DECLAIM not at top-level."))
 602   (let ((declaration-specifiers (cdr form)))
 603     (movitz-env-load-declarations declaration-specifiers *movitz-global-environment* :declaim))
 604   (compiler-values ()))
 605
 606 (define-special-operator call-internal (&form form)
 607   (destructuring-bind (if-name &optional argument)
 608       (cdr form)
 609     (assert (not argument))
 610     (compiler-values ()
 611       :code `((:call (:edi ,(slot-offset 'movitz-run-time-context if-name))))
 612       :returns :nothing)))
 613
 614 (define-special-operator inlined-not (&all forward &form form &result-mode result-mode)
 615   (assert (= 2 (length form)))
 616   (let ((x (second form)))
 617     (if (eq result-mode :ignore)
 618         (compiler-call #'compile-form-unprotected
 619           :forward forward
 620           :form x)
 621       (multiple-value-bind (not-result-mode result-mode-inverted-p)
 622           (cond
 623            ((or (member (operator result-mode) +boolean-modes+)
 624                 (member (operator result-mode) '(:boolean-branch-on-false
 625                                                  :boolean-branch-on-true)))
 626             (values (complement-boolean-result-mode result-mode)
 627                     t))
 628            ((member (operator result-mode) +multiple-value-result-modes+)
 629             (values :eax nil))
 630            ((member (operator result-mode) '(:push))
 631             (values :eax nil))
 632            (t (values result-mode nil)))
 633         (compiler-values-bind (&all not-values &returns not-returns &code not-code &type not-type)
 634             (compiler-call #'compile-form-unprotected
 635               :defaults forward
 636               :form x
 637               :result-mode not-result-mode)
 638           (setf (not-values :producer)
 639             (list :not (not-values :producer)))
 640           (let ((not-type (type-specifier-primary not-type)))
 641            (setf (not-values :type)
 642             (cond
 643              ((movitz-subtypep not-type 'null)
 644               '(eql t))
 645              ((movitz-subtypep not-type '(not null))
 646               'null)
 647              (t 'boolean))))
 648           ;; (warn "res: ~S" result-mode-inverted-p)
 649           (cond
 650            ((and result-mode-inverted-p
 651                  (eql not-result-mode not-returns))
 652             ;; Inversion by result-mode ok.
 653             (compiler-values (not-values)
 654               :returns result-mode))
 655            (result-mode-inverted-p
 656             ;; (warn "Not done: ~S/~S/~S." result-mode not-result-mode not-returns)
 657             (multiple-value-bind (code)
 658                 (make-result-and-returns-glue not-result-mode not-returns not-code)
 659               (compiler-values (not-values)
 660                 :returns result-mode
 661                 :code code)))
 662            ((not result-mode-inverted-p)
 663             ;; We must invert returns-mode
 664             (case (operator not-returns)
 665               (#.(append +boolean-modes+ '(:boolean-branch-on-true :boolean-branch-on-false))
 666                  (compiler-values (not-values)
 667                    :returns (complement-boolean-result-mode not-returns)))
 668 ;;;           ((:eax :function :multiple-values :ebx :edx)
 669 ;;;            (case result-mode
 670 ;;;              ((:eax :ebx :ecx :edx :function :multiple-values)
 671 ;;;               (compiler-values (not-values)
 672 ;;;                 :code (append (not-values :code)
 673 ;;;                               `((:cmpl :edi ,(single-value-register not-returns))
 674 ;;;                                 (:sbbl :ecx :ecx)
 675 ;;;                                 (:cmpl ,(1+ (image-nil-word *image*))
 676 ;;;                                        ,(single-value-register not-returns))
 677 ;;;                                 (:adcl 0 :ecx)))
 678 ;;;                 :returns '(:boolean-ecx 1 0)))
 679 ;;;              (t (compiler-values (not-values)
 680 ;;;                   :code (append (not-values :code)
 681 ;;;                                 `((:cmpl :edi ,(single-value-register not-returns))))
 682 ;;;                   :returns :boolean-zf=1))))
 683               ((:eax :function :multiple-values :ebx :ecx :edx)
 684                (compiler-values (not-values)
 685                  :code (append (not-values :code)
 686                                `((:cmpl :edi ,(single-value-register not-returns))))
 687                  :returns :boolean-zf=1)) ; TRUE iff result equal to :edi/NIL.
 688               (otherwise
 689                #+ignore
 690                (warn "unable to deal intelligently with inlined-NOT not-returns: ~S for ~S from ~S"
 691                      not-returns not-result-mode (not-values :producer))
 692                (let ((label (make-symbol "not-label")))
 693                  (compiler-values (not-values)
 694                    :returns :eax
 695                    :code (append (make-result-and-returns-glue :eax not-returns (not-values :code))
 696                                  `((:cmpl :edi :eax)
 697                                    (:movl :edi :eax)
 698                                    (:jne ',label)
 699                                    (:globally (:movl (:edi (:edi-offset t-symbol)) :eax))
 700                                    ,label)))))))))))))
 701
 702 (define-special-operator muerte::with-progn-results
 703     (&all forward &form form &top-level-p top-level-p &result-mode result-mode)
 704   (destructuring-bind (buried-result-modes &body body)
 705       (cdr form)
 706     (assert (< (length buried-result-modes) (length body)) ()
 707       "WITH-PROGN-RESULTS must have fewer result-modes than body elements: ~S" form)
 708     (loop with returns-mode = :nothing
 709         with no-side-effects-p = t
 710         with modifies = nil
 711         for sub-form on body
 712         as sub-form-result-mode = buried-result-modes
 713         then (or (cdr sub-form-result-mode)
 714                  sub-form-result-mode)
 715         as current-result-mode = (if (endp (cdr sub-form))
 716                                      ;; all but the last form have result-mode as declared
 717                                      result-mode
 718                                    (car sub-form-result-mode))
 719         as last-form-p = (endp (cdr sub-form))
 720                          ;; do (warn "progn rm: ~S" (car sub-form-result-mode))
 721         appending
 722           (compiler-values-bind (&code code &returns sub-returns-mode
 723                                  &functional-p no-sub-side-effects-p
 724                                  &modifies sub-modifies)
 725               (compiler-call (if last-form-p
 726                                  #'compile-form-unprotected
 727                                #'compile-form)
 728                 :defaults forward
 729                 :form (car sub-form)
 730                 :top-level-p top-level-p
 731                 :result-mode current-result-mode)
 732             (unless no-sub-side-effects-p
 733               (setf no-side-effects-p nil))
 734             (setq modifies (modifies-union modifies sub-modifies))
 735             (when last-form-p
 736               ;; (warn "progn rm: ~S form: ~S" sub-returns-mode (car sub-form))
 737               (setf returns-mode sub-returns-mode))
 738             (if (and no-sub-side-effects-p (eq current-result-mode :ignore))
 739                 nil
 740               code))
 741         into progn-code
 742         finally (return (compiler-values ()
 743                           :code progn-code
 744                           :returns returns-mode
 745                           :modifies modifies
 746                           :functional-p no-side-effects-p)))))
 747
 748 (define-special-operator muerte::simple-funcall (&form form)
 749   (destructuring-bind (apply-funobj)
 750       (cdr form)
 751     (compiler-values ()
 752       :returns :multiple-values
 753       :functional-p nil
 754       :code `((:load-constant ,apply-funobj :esi) ; put function funobj in ESI
 755               (:xorl :ecx :ecx)         ; number of arguments
 756                                         ; call new ESI's code-vector
 757               (:call (:esi ,(slot-offset 'movitz-funobj 'code-vector)))))))
 758
 759 (define-special-operator muerte::compiled-nth-value (&all all &form form &env env &result-mode result-mode)
 760   (destructuring-bind (n-form subform)
 761       (cdr form)
 762     (cond
 763      ((movitz-constantp n-form)
 764       (let ((n (eval-form n-form env)))
 765         (check-type n (integer 0 *))
 766         (compiler-values-bind (&code subform-code &returns subform-returns)
 767             (compiler-call #'compile-form-unprotected
 768               :forward all
 769               :result-mode :multiple-values
 770               :form subform)
 771           (if (not (eq subform-returns :multiple-values))
 772               ;; single-value result
 773               (case n
 774                 (0 (compiler-values ()
 775                      :code subform-code
 776                      :returns subform-returns))
 777                 (t (compiler-call #'compile-implicit-progn
 778                      :forward all
 779                      :form `(,subform nil))))
 780             ;; multiple-value result
 781             (case n
 782               (0 (compiler-call #'compile-form-unprotected
 783                    :forward all
 784                    :result-mode result-mode
 785                    :form `(muerte.cl:values ,subform)))
 786               (1 (compiler-values ()
 787                    :returns :ebx
 788                    :code (append subform-code
 789                                  (with-labels (nth-value (done no-secondary))
 790                                    `((:jnc '(:sub-program (,no-secondary)
 791                                              (:movl :edi :ebx)
 792                                              (:jmp ',done)))
 793                                      (:cmpl 2 :ecx)
 794                                      (:jb ',no-secondary)
 795                                      ,done)))))
 796               (t (compiler-values ()
 797                    :returns :eax
 798                    :code (append subform-code
 799                                  (with-labels (nth-value (done no-value))
 800                                    `((:jnc '(:sub-program (,no-value)
 801                                              (:movl :edi :eax)
 802                                              (:jmp ',done)))
 803                                      (:cmpl ,(1+ n) :ecx)
 804                                      (:jb ',no-value)
 805                                      (:locally (:movl (:edi (:edi-offset values ,(* 4 (- n 2))))
 806                                                       :eax))
 807                                      ,done))))))))))
 808      (t (error "non-constant nth-values not yet implemented.")))))
 809
 810
 811 (define-special-operator muerte::with-cloak
 812     (&all all &result-mode result-mode &form form &env env &funobj funobj)
 813   "Compile sub-forms such that they execute ``invisibly'', i.e. have no impact
 814 on the current result."
 815   (destructuring-bind ((&optional (cover-returns :nothing) cover-code (cover-modifies t)
 816                                   (cover-type '(values &rest t)))
 817                        &body cloaked-forms)
 818       (cdr form)
 819     (assert (or cover-type (eq cover-returns :nothing)))
 820     (let ((modifies cover-modifies))
 821       (cond
 822        ((null cloaked-forms)
 823         (compiler-values ()
 824           :code cover-code
 825           :modifies modifies
 826           :type cover-type
 827           :returns cover-returns))
 828        ((or (eq :nothing cover-returns)
 829             (eq :ignore result-mode))
 830         (let* ((code (append cover-code
 831                              (loop for cloaked-form in cloaked-forms
 832                                  appending
 833                                    (compiler-values-bind (&code code &modifies sub-modifies)
 834                                        (compiler-call #'compile-form-unprotected
 835                                          :forward all
 836                                          :form cloaked-form
 837                                          :result-mode :ignore)
 838                                      (setf modifies (modifies-union modifies sub-modifies))
 839                                      code)))))
 840           (compiler-values ()
 841             :code code
 842             :type nil
 843             :modifies modifies
 844             :returns :nothing)))
 845        (t (let* ((cloaked-env (make-instance 'with-things-on-stack-env
 846                                 :uplink env
 847                                 :funobj funobj))
 848                  (cloaked-code (loop for cloaked-form in cloaked-forms
 849                                    append (compiler-values-bind (&code code &modifies sub-modifies)
 850                                               (compiler-call #'compile-form-unprotected
 851                                                 :env cloaked-env
 852                                                 :defaults all
 853                                                 :form cloaked-form
 854                                                 :result-mode :ignore)
 855                                             (setf modifies (modifies-union modifies sub-modifies))
 856                                             code))))
 857             (cond
 858              ((member cloaked-code
 859                       '(() ((:cld)) ((:std))) ; simple programs that don't interfere with current-result.
 860                       :test #'equal)
 861               (compiler-values ()
 862                 :returns cover-returns
 863                 :type cover-type
 864                 :modifies modifies
 865                 :code (append cover-code cloaked-code)))
 866              ((and (eq :multiple-values cover-returns)
 867                    (member result-mode '(:function :multiple-values))
 868                    (type-specifier-num-values cover-type)
 869                    (loop for i from 0 below (type-specifier-num-values cover-type)
 870                        always (type-specifier-singleton (type-specifier-nth-value i cover-type))))
 871               ;; We cover a known set of values, so no need to push anything.
 872               (let ((value-forms
 873                      (loop for i from 0 below (type-specifier-num-values cover-type)
 874                          collect
 875                            (cons 'muerte.cl:quote
 876                                  (type-specifier-singleton
 877                                   (type-specifier-nth-value i cover-type))))))
 878                 (compiler-values ()
 879                 :returns :multiple-values
 880                 :type cover-type
 881                 :code (append cover-code
 882                               cloaked-code
 883                               (compiler-call #'compile-form
 884                                 :defaults all
 885                                 :result-mode :multiple-values
 886                                 :form `(muerte.cl:values ,@value-forms))))))
 887              ((and (eq :multiple-values cover-returns)
 888                    (member result-mode '(:function :multiple-values))
 889                    (type-specifier-num-values cover-type))
 890               (when (loop for i from 0 below (type-specifier-num-values cover-type)
 891                         always (type-specifier-singleton (type-specifier-nth-value i cover-type)))
 892                 (warn "Covering only constants: ~S" cover-type))
 893               ;; We know the number of values to cover..
 894               (let ((num-values (type-specifier-num-values cover-type)))
 895                 ;; (warn "Cunningly covering ~D values.." num-values)
 896                 (setf (stack-used cloaked-env) num-values)
 897                 (compiler-values ()
 898                   :returns :multiple-values
 899                   :type cover-type
 900                   :code (append cover-code
 901                                 (when (<= 1 num-values)
 902                                   '((:locally (:pushl :eax))))
 903                                 (when (<= 2 num-values)
 904                                   '((:locally (:pushl :ebx))))
 905                                 (loop for i from 0 below (- num-values 2)
 906                                     collect
 907                                       `(:locally (:pushl (:edi ,(+ (global-constant-offset 'values)
 908                                                                    (* 4 i))))))
 909                                 cloaked-code
 910                                 (when (<= 3 num-values)
 911                                   `((:locally (:movl ,(* +movitz-fixnum-factor+
 912                                                          (- num-values 2))
 913                                                      (:edi (:edi-offset num-values))))))
 914                                 (loop for i downfrom (- num-values 2 1) to 0
 915                                     collect
 916                                       `(:locally (:popl (:edi ,(+ (global-constant-offset 'values)
 917                                                                   (* 4 i))))))
 918                                 (when (<= 2 num-values)
 919                                   '((:popl :ebx)))
 920                                 (when (<= 1 num-values)
 921                                   '((:popl :eax)))
 922                                 (case num-values
 923                                   (1 '((:clc)))
 924                                   (t (append (make-immediate-move num-values :ecx)
 925                                              '((:stc)))))))))
 926              ((and (eq :multiple-values cover-returns)
 927                    (member result-mode '(:function :multiple-values)))
 928               (when (type-specifier-num-values cover-type)
 929                 (warn "covering ~D values: ~S."
 930                       (type-specifier-num-values cover-type)
 931                       cover-type))
 932               ;; we need a full-fledged m-v-prog1, i.e to save all values of first-form.
 933               ;; (lexically) unknown amount of stack is used.
 934               (setf (stack-used cloaked-env) t)
 935               (compiler-values ()
 936                 :returns :multiple-values
 937                 :modifies modifies
 938                 :type cover-type
 939                 :code (append cover-code
 940                               (make-compiled-push-current-values)
 941                               `((:pushl :ecx))
 942                               cloaked-code
 943                               `((:popl :ecx)
 944                                 (:globally (:call (:edi (:edi-offset pop-current-values))))
 945                                 (:leal (:esp (:ecx 4)) :esp)))))
 946              ((and (not (cdr cloaked-code))
 947                    (instruction-is (car cloaked-code) :incf-lexvar))
 948               (destructuring-bind (binding delta &key protect-registers)
 949                   (cdar cloaked-code)
 950                 (let ((protected-register (case cover-returns
 951                                             ((:eax :ebx :ecx :edx) cover-returns)
 952                                             (t :edx))))
 953                   (assert (not (member protected-register protect-registers)) ()
 954                     "Can't protect ~S. Sorry, this opertor must be smartened up."
 955                     protected-register)
 956                   (compiler-values ()
 957                     :returns protected-register
 958                     :type cover-type
 959                     :code (append cover-code
 960                                   (make-result-and-returns-glue protected-register cover-returns)
 961                                   `((:incf-lexvar ,binding ,delta
 962                                                   :protect-registers ,(cons protected-register
 963                                                                             protect-registers))))))))
 964              (t ;; just put the (singular) result of form1 on the stack..
 965 ;;;           (when (not (typep cover-returns 'keyword))
 966 ;;;             ;; if it's a (non-modified) lexical-binding, we can do better..
 967 ;;;             (warn "Covering non-register ~S" cover-returns))
 968 ;;;           (when (type-specifier-singleton (type-specifier-primary cover-type))
 969 ;;;             (warn "Covering constant ~S"
 970 ;;;                   (type-specifier-singleton cover-type)))
 971               (let ((protected-register (case cover-returns
 972                                           ((:ebx :ecx :edx) cover-returns)
 973                                           (t :eax))))
 974                 #+ignore
 975                 (when (>= 2 (length cloaked-code))
 976                   (warn "simple-cloaking for ~S: ~{~&~S~}" cover-returns cloaked-code))
 977                 (setf (stack-used cloaked-env) 1)
 978                 (compiler-values ()
 979                   :returns protected-register
 980                   :modifies modifies
 981                   :type cover-type
 982                   :code (append cover-code
 983                                 (make-result-and-returns-glue protected-register cover-returns)
 984                                 `((:pushl ,protected-register))
 985                                 ;; evaluate each rest-form, discarding results
 986                                 cloaked-code
 987                                 ;; pop the result back
 988                                 `((:popl ,protected-register)))))))))))))
 989
 990 (define-special-operator muerte::with-local-env (&all all &form form)
 991   (destructuring-bind ((local-env) sub-form)
 992       (cdr form)
 993     (compiler-call #'compile-form-unprotected
 994       :forward all
 995       :env local-env
 996       :form sub-form)))
 997
 998 (define-special-operator muerte::++%2op (&all all &form form &env env &result-mode result-mode)
 999   (destructuring-bind (term1 term2)
1000       (cdr form)
1001     (if (eq :ignore result-mode)
1002         (compiler-call #'compile-form-unprotected
1003           :forward all
1004           :form `(muerte.cl:progn term1 term2))
1005       (let ((returns (ecase (result-mode-type result-mode)
1006                        ((:function :multiple-values :eax :push) :eax)
1007                        ((:ebx :ecx :edx) result-mode)
1008                        ((:lexical-binding) result-mode))))
1009         (compiler-values ()
1010           :returns returns
1011           :type 'number
1012           :code `((:add ,(movitz-binding term1 env) ,(movitz-binding term2 env) ,returns)))))))
1013
1014 (define-special-operator muerte::include (&form form)
1015   (let ((*require-dependency-chain*
1016          (and (boundp '*require-dependency-chain*)
1017               (symbol-value '*require-dependency-chain*))))
1018     (declare (special *require-dependency-chain*))
1019     (destructuring-bind (module-name &optional path-spec)
1020         (cdr form)
1021       (declare (ignore path-spec))
1022       (push module-name *require-dependency-chain*)
1023       (when (member module-name (cdr *require-dependency-chain*))
1024         (error "Circular Movitz module dependency chain: ~S"
1025                (reverse (subseq *require-dependency-chain* 0
1026                                 (1+ (position  module-name *require-dependency-chain* :start 1))))))
1027       (let ((require-path (movitz-module-path form)))
1028         (movitz-compile-file-internal require-path))))
1029   (compiler-values ()))
1030
1031 ;;;
1032
1033 (define-special-operator muerte::no-macro-call (&all all &form form)
1034   (destructuring-bind (operator &rest arguments)
1035       (cdr form)
1036     (compiler-call #'compile-apply-symbol
1037       :forward all
1038       :form (cons operator arguments))))
1039
1040 (define-special-operator muerte::compiler-macro-call (&all all &form form &env env)
1041   (destructuring-bind (operator &rest arguments)
1042       (cdr form)
1043     (let ((name (if (not (setf-name operator))
1044                     operator
1045                   (movitz-env-setf-operator-name (setf-name operator)))))
1046       (assert (movitz-compiler-macro-function name env) ()
1047         "There is no compiler-macro ~S." name)
1048       (compiler-call #'compile-compiler-macro-form
1049         :forward all
1050         :form (cons name arguments)))))
1051
1052 (define-special-operator muerte::do-result-mode-case (&all all &result-mode result-mode &form form)
1053   (loop for (cases . then-forms) in (cddr form)
1054       do (when (or (eq cases 'muerte.cl::t)
1055                    (and (eq cases :plural)
1056                         (member result-mode +multiple-value-result-modes+))
1057                    (and (eq cases :booleans)
1058                         (member (result-mode-type result-mode) '(:boolean-branch-on-false :boolean-branch-on-true)))
1059                    (if (atom cases)
1060                        (eq cases (result-mode-type result-mode))
1061                      (member (result-mode-type result-mode) cases)))
1062            (return (compiler-call #'compile-implicit-progn
1063                      :form then-forms
1064                      :forward all)))
1065       finally (error "No matching result-mode-case for result-mode ~S." result-mode)))
1066
1067
1068 (define-special-operator muerte::inline-values (&all all &result-mode result-mode &form form)
1069   (let ((sub-forms (cdr form)))
1070     (if (eq :ignore result-mode)
1071         (compiler-call #'compile-implicit-progn ; compile only for side-effects.
1072           :forward all
1073           :form sub-forms)
1074       (case (length sub-forms)
1075         (0 (compiler-values ()
1076              :functional-p t
1077              :returns :multiple-values
1078              :type '(values)
1079              :code `((:movl :edi :eax)
1080                      (:xorl :ecx :ecx)
1081                      (:stc))))
1082         (1 (compiler-values-bind (&all sub-form &code code &returns returns &type type)
1083                (compiler-call #'compile-form-unprotected
1084                  :result-mode (if (member result-mode +multiple-value-result-modes+)
1085                                   :eax
1086                                 result-mode)
1087                  :forward all
1088                  :form (first sub-forms))
1089              (compiler-values (sub-form)
1090                :type (type-specifier-primary type)
1091                :returns (if (eq :multiple-values returns)
1092                             :eax
1093                           returns))))
1094         (2 (multiple-value-bind (code functional-p modifies first-values second-values)
1095                (make-compiled-two-forms-into-registers (first sub-forms) :eax
1096                                                        (second sub-forms) :ebx
1097                                                        (all :funobj)
1098                                                        (all :env))
1099              (compiler-values ()
1100                :code (append code
1101                              ;; (make-immediate-move 2 :ecx)
1102                              '((:xorl :ecx :ecx) (:movb 2 :cl))
1103                              '((:stc)))
1104                :returns :multiple-values
1105                :type `(values ,(type-specifier-primary (compiler-values-getf first-values :type))
1106                               ,(type-specifier-primary (compiler-values-getf second-values :type)))
1107                :functional-p functional-p
1108                :modifies modifies)))
1109         (t (multiple-value-bind (arguments-code stack-displacement arguments-modifies
1110                                  arguments-types arguments-functional-p)
1111                (make-compiled-argument-forms sub-forms (all :funobj) (all :env))
1112              (assert (not (minusp (- stack-displacement (- (length sub-forms) 2)))))
1113              (multiple-value-bind (stack-restore-code new-returns)
1114                  (make-compiled-stack-restore (- stack-displacement
1115                                                  (- (length sub-forms) 2))
1116                                               result-mode
1117                                               :multiple-values)
1118                (compiler-values ()
1119                  :returns new-returns
1120                  :type `(values ,@arguments-types)
1121                  :functional-p arguments-functional-p
1122                  :modifies arguments-modifies
1123                  :code (append arguments-code
1124                                (loop for i from (- (length sub-forms) 3) downto 0
1125                                    collecting
1126                                      `(:locally (:popl (:edi (:edi-offset values ,(* i 4))))))
1127                                (make-immediate-move (* +movitz-fixnum-factor+ (- (length sub-forms) 2))
1128                                                     :ecx)
1129                                `((:locally (:movl :ecx (:edi (:edi-offset num-values)))))
1130                                (make-immediate-move (length sub-forms) :ecx)
1131                                `((:stc))
1132                                stack-restore-code)))))))))
1133
1134 (define-special-operator muerte::compiler-typecase (&all all &form form)
1135   (destructuring-bind (keyform &rest clauses)
1136       (cdr form)
1137     (compiler-values-bind (&type keyform-type)
1138         ;; This compiler-call is only for the &type..
1139         (compiler-call #'compile-form-unprotected
1140           :form keyform
1141           :result-mode :eax
1142           :forward all)
1143 ;;;      (declare (ignore keyform-type))
1144 ;;;      (warn "keyform type: ~S" keyform-type)
1145 ;;;      (warn "clause-types: ~S" (mapcar #'car clauses))
1146       #+ignore
1147       (let ((clause (find 'muerte.cl::t clauses :key #'car)))
1148         (assert clause)
1149         (compiler-call #'compile-implicit-progn
1150           :form (cdr clause)
1151           :forward all))
1152       (loop for (clause-type . clause-forms) in clauses
1153           when (movitz-subtypep (type-specifier-primary keyform-type) clause-type)
1154           return (compiler-call #'compile-implicit-progn
1155                    :form clause-forms
1156                    :forward all)
1157           finally (error "No compiler-typecase clause matched compile-time type ~S." keyform-type)))))
1158
1159 (define-special-operator muerte::exact-throw (&all all-throw &form form &env env &funobj funobj)
1160   "Perform a dynamic control transfer to catch-env-slot context (evaluated),
1161 with values from value-form. Error-form, if provided, is evaluated in case the context
1162 is zero (i.e. not found)."
1163   (destructuring-bind (context value-form &optional error-form)
1164       (cdr form)
1165     (let* ((local-env (make-local-movitz-environment env funobj :type 'let-env))
1166            (dynamic-slot-binding
1167             (movitz-env-add-binding local-env
1168                                     (make-instance 'located-binding
1169                                       :name (gensym "dynamic-slot-"))))
1170            (next-continuation-step-binding
1171             (movitz-env-add-binding local-env
1172                                     (make-instance 'located-binding
1173                                       :name (gensym "continuation-step-")))))
1174       (compiler-values ()
1175         :returns :non-local-exit
1176         :code (append (compiler-call #'compile-form
1177                         :forward all-throw
1178                         :result-mode dynamic-slot-binding
1179                         :form context)
1180                       (compiler-call #'compile-form
1181                         :forward all-throw
1182                         :result-mode :multiple-values
1183                         :form `(muerte.cl:multiple-value-prog1
1184                                    ,value-form
1185                                  (muerte::with-inline-assembly (:returns :nothing)
1186                                    (:load-lexical ,dynamic-slot-binding :eax)
1187                                    ,@(when error-form
1188                                        `((:testl :eax :eax)
1189                                          (:jz '(:sub-program ()
1190                                                 (:compile-form (:result-mode :ignore)
1191                                                  ,error-form)))))
1192                                    (:locally (:call (:edi (:edi-offset dynamic-unwind-next))))
1193                                    (:store-lexical ,next-continuation-step-binding :eax :type t)
1194                                    )))
1195                       ;; now outside of m-v-prog1's cloak, with final dynamic-slot in ..
1196                       ;; ..unwind it and transfer control.
1197                       ;;
1198                       ;; * 12 dynamic-env uplink
1199                       ;; *  8 target jumper number
1200                       ;; *  4 target catch tag
1201                       ;; *  0 target EBP
1202                       `((:load-lexical ,dynamic-slot-binding :edx)
1203                         (:locally (:movl :edx (:edi (:edi-offset raw-scratch0)))) ; final continuation
1204                         (:load-lexical ,next-continuation-step-binding :edx) ; next continuation-step
1205                         (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; goto target dynamic-env
1206                         (:locally (:call (:edi (:edi-offset dynamic-jump-next))))))))))
1207
1208 ;;;                     (:locally (:movl :esi (:edi (:edi-offset scratch1))))
1209
1210
1211 ;;;                     (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; exit dynamic-env
1212 ;;;                     (:movl :edx :esp) ; enter non-local jump stack mode.
1213 ;;;                     (:movl (:esp) :edx) ; target stack-frame EBP
1214 ;;;                     (:movl (:edx -4) :esi) ; get target funobj into ESI
1215 ;;;                     (:movl (:esp 8) :edx) ; target jumper number
1216 ;;;                     (:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0)))))))))
1217
1218
1219 (define-special-operator muerte::with-basic-restart (&all defaults &form form &env env)
1220   (destructuring-bind ((name function interactive test format-control
1221                              &rest format-arguments)
1222                        &body body)
1223       (cdr form)
1224     (check-type name symbol "a restart name")
1225     (let* ((entry-size (+ 10 (* 2 (length format-arguments)))))
1226       (with-labels (basic-restart-catch (label-set exit-point))
1227         (compiler-values ()
1228           :returns :multiple-values
1229 ;;; Basic-restart entry:
1230 ;;;   12: parent
1231 ;;;    8: jumper index (=> eip)
1232 ;;;    4: tag = #:basic-restart-tag
1233 ;;;    0: ebp/stack-frame
1234 ;;;   -4: name
1235 ;;;   -8: function
1236 ;;;  -12: interactive function
1237 ;;;  -16: test
1238 ;;;  -20: format-control
1239 ;;;  -24: (on-stack) list of format-arguments
1240 ;;;  -28: cdr
1241 ;;;  -32: car ...
1242           :code (append `((:locally (:pushl (:edi (:edi-offset dynamic-env)))) ; parent
1243                           (:declare-label-set ,label-set (,exit-point))
1244                           (:pushl ',label-set) ; jumper index
1245                           (:globally (:pushl (:edi (:edi-offset restart-tag)))) ; tag
1246                           (:pushl :ebp) ; ebp
1247                           (:load-constant ,name :push)) ; name
1248                         (compiler-call #'compile-form
1249                           :defaults defaults
1250                           :form function
1251                           :with-stack-used 5
1252                           :result-mode :push)
1253                         (compiler-call #'compile-form
1254                           :defaults defaults
1255                           :form interactive
1256                           :with-stack-used 6
1257                           :result-mode :push)
1258                         (compiler-call #'compile-form
1259                           :defaults defaults
1260                           :form test
1261                           :with-stack-used 7
1262                           :result-mode :push)
1263                         `((:load-constant ,format-control :push)
1264                           (:pushl :edi))
1265                         (loop for format-argument-cons on format-arguments
1266                             as stack-use upfrom 11 by 2
1267                             append
1268                               (if (cdr format-argument-cons)
1269                                   '((:leal (:esp -15) :eax)
1270                                     (:pushl :eax))
1271                                 '((:pushl :edi)))
1272                             append
1273                               (compiler-call #'compile-form
1274                                 :defaults defaults
1275                                 :form (car format-argument-cons)
1276                                 :result-mode :push
1277                                 :with-stack-used stack-use
1278                                 :env env))
1279                         `((:leal (:esp ,(* 4 (+ 6 (* 2 (length format-arguments))))) :eax)
1280                           (:locally (:movl :eax (:edi (:edi-offset dynamic-env)))))
1281                         (when format-arguments
1282                           `((:leal (:eax -31) :ebx)
1283                             (:movl :ebx (:eax -24))))
1284                         (compiler-call #'compile-implicit-progn
1285                           :forward defaults
1286                           :env (make-instance 'simple-dynamic-env
1287                                  :uplink env
1288                                  :funobj (defaults :funobj)
1289                                  :num-specials 1)
1290                           :result-mode :multiple-values
1291                           :with-stack-used entry-size
1292                           :form body)
1293                         `((:leal (:esp ,(+ -12 -4 (* 4 entry-size))) :esp)
1294                           ,exit-point
1295                           (:movl (:esp) :ebp)
1296                           (:movl (:esp 12) :edx)
1297                           (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
1298                           (:leal (:esp 16) :esp)
1299                           )))))))
1300
1301
1302 (define-special-operator muerte::eql%b (&form form &env env &result-mode result-mode)
1303   (destructuring-bind (x y)
1304       (cdr form)
1305     (let ((returns (case (result-mode-type result-mode)
1306                      ((:boolean-branch-on-true :boolean-branch-on-false)
1307                       result-mode)
1308                      (t :boolean-zf=1)))
1309           (x (movitz-binding x env))
1310           (y (movitz-binding y env)))
1311       (compiler-values ()
1312         :returns returns
1313         :code `((:eql ,x ,y ,returns))))))
1314
1315
1316 (define-special-operator muerte::with-dynamic-extent-scope
1317     (&all all &form form &env env &funobj funobj)
1318   (destructuring-bind ((scope-tag) &body body)
1319       (cdr form)
1320     (let* ((save-esp-binding (make-instance 'located-binding
1321                                :name (gensym "dynamic-extent-save-esp-")))
1322            (base-binding (make-instance 'located-binding
1323                            :name (gensym "dynamic-extent-base-")))
1324            (scope-env
1325             (make-local-movitz-environment env funobj
1326                                            :type 'with-dynamic-extent-scope-env
1327                                            :scope-tag scope-tag
1328                                            :save-esp-binding save-esp-binding
1329                                            :base-binding base-binding)))
1330       (movitz-env-add-binding scope-env save-esp-binding)
1331       (movitz-env-add-binding scope-env base-binding)
1332       (compiler-values-bind (&code body-code &all body-values)
1333           (compiler-call #'compile-implicit-progn
1334             :env scope-env
1335             :form body
1336             :forward all)
1337         (compiler-values (body-values)
1338           :code (append `((:init-lexvar ,save-esp-binding
1339                                         :init-with-register :esp
1340                                         :init-with-type fixnum)
1341                           (:enter-dynamic-scope ,scope-env)
1342                           (:init-lexvar ,base-binding
1343                                         :init-with-register :esp
1344                                         :init-with-type fixnum))
1345                         body-code
1346                         `((:load-lexical ,save-esp-binding :esp))))))))
1347
1348 (define-special-operator muerte::with-dynamic-extent-allocation
1349     (&all all &form form &env env &funobj funobj)
1350   (destructuring-bind ((scope-tag) &body body)
1351       (cdr form)
1352     (let* ((scope-env (loop for e = env then (movitz-environment-uplink e)
1353                           unless e
1354                           do (error "Dynamic-extent scope ~S not seen." scope-tag)
1355                           when (and (typep e 'with-dynamic-extent-scope-env)
1356                                     (eq scope-tag (dynamic-extent-scope-tag e)))
1357                           return e))
1358            (allocation-env
1359             (make-local-movitz-environment env funobj
1360                                            :type 'with-dynamic-extent-allocation-env
1361                                            :scope scope-env)))
1362       (compiler-call #'compile-implicit-progn
1363         :form body
1364         :forward all
1365         :env allocation-env))))
1366
1367
1368 (define-special-operator muerte::compiled-cons
1369     (&all all &form form &env env &funobj funobj)
1370   (destructuring-bind (car cdr)
1371       (cdr form)
1372     (let ((dynamic-extent-scope (find-dynamic-extent-scope env)))
1373       (cond
1374        (dynamic-extent-scope
1375         (compiler-values ()
1376           :returns :eax
1377           :functional-p t
1378           :type 'cons
1379           :code (append (make-compiled-two-forms-into-registers car :eax cdr :ebx funobj env)
1380                         `((:stack-cons ,(make-instance 'movitz-cons)
1381                                        ,dynamic-extent-scope)))))
1382        (t (compiler-values ()
1383             :returns :eax
1384             :functional-p t
1385             :type 'cons
1386             :code (append (make-compiled-two-forms-into-registers car :eax cdr :ebx funobj env)
1387                           `((:globally (:call (:edi (:edi-offset fast-cons))))))))))))