special-operators-cl.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2000-2005,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway
   5 ;;;;
   6 ;;;; Filename:      special-operators-cl.lisp
   7 ;;;; Description:   Special operators in the COMMON-LISP package.
   8 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
   9 ;;;; Created at:    Fri Nov 24 16:31:11 2000
  10 ;;;; Distribution:  See the accompanying file COPYING.
  11 ;;;;
  12 ;;;; $Id: special-operators-cl.lisp,v 1.53 2007/04/11 22:09:39 ffjeld Exp $
  13 ;;;;
  14 ;;;;------------------------------------------------------------------
  15
  16 (in-package movitz)
  17
  18 (define-special-operator progn (&all all &form form &top-level-p top-level-p &result-mode result-mode)
  19   (compiler-call #'compile-implicit-progn
  20     :form (cdr form)
  21     :forward all))
  22
  23 (defun expand-to-operator (operator form env)
  24   "Attempt to compiler-macroexpand FORM to having operator OPERATOR."
  25   (if (and (listp form) (eq operator (first form)))
  26       form
  27     (multiple-value-bind (expansion expanded-p)
  28         (like-compile-macroexpand-form form env)
  29       (if expanded-p
  30           (expand-to-operator operator expansion env)
  31         nil))))
  32
  33 (defun parse-let-var-specs (let-var-specs)
  34   "Given a list of LET variable specifiers (i.e. either VAR or (VAR INIT-FORM)),~
  35    return a list on the canonical form (VAR INIT-FORM)."
  36   (loop for var-spec in let-var-specs
  37       if (symbolp var-spec)
  38       collect `(,var-spec nil)
  39       else if (and (listp var-spec)
  40                    (= 1 (length var-spec)))
  41       collect `(,(first var-spec) nil)
  42       else do (assert (and (listp var-spec)
  43                            (= 2 (length var-spec))))
  44       and collect var-spec))
  45
  46 (define-special-operator let (&all all &form form &funobj funobj &env env &result-mode result-mode)
  47   "An extent-nested let is this: (let ((foo ..) (bar (.. (let ((zot ..)) ..)))))
  48 where zot is not in foo's scope, but _is_ in foo's extent."
  49   (destructuring-bind (operator let-var-specs &body forms)
  50       form
  51     (declare (ignore operator))
  52     (multiple-value-bind (body declarations)
  53         (parse-declarations-and-body forms)
  54       (if (and (null let-var-specs)
  55                (null declarations))
  56           (compiler-call #'compile-implicit-progn
  57             :forward all
  58             :form body)
  59         (let* ((let-modifies nil)
  60                (let-vars (parse-let-var-specs let-var-specs))
  61                (local-env (make-local-movitz-environment env funobj
  62                                                          :type 'let-env
  63                                                          :declarations declarations))
  64                (init-env #+ignore env
  65                          (make-instance 'movitz-environment
  66                            :uplink env
  67                            :funobj funobj
  68                            :extent-uplink local-env))
  69                (stack-used 0)
  70                (binding-var-codes
  71                 (loop for (var init-form) in let-vars
  72                     if (movitz-env-get var 'special nil local-env)
  73                        ;; special... see losp/cl/run-time.lisp
  74                     collect
  75                       (list var
  76                             init-form
  77                             (append (if (= 0 (num-specials local-env)) ; first special? .. binding tail
  78                                         `((:locally (:pushl (:edi (:edi-offset dynamic-env)))))
  79                                       `((:pushl :esp)))
  80                                     (compiler-call #'compile-form ; binding value
  81                                      :with-stack-used (incf stack-used)
  82                                       :env init-env
  83                                       :defaults all
  84                                       :form init-form
  85                                       :modify-accumulate let-modifies
  86                                       :result-mode :push)
  87                                     `((:pushl :edi)) ; scratch
  88                                     (compiler-call #'compile-form ; binding name
  89                                       :with-stack-used (incf stack-used 2)
  90                                       :env init-env
  91                                       :defaults all
  92                                       :form `(muerte.cl:quote ,var)
  93                                       :result-mode :push)
  94                                     (prog1 nil (incf stack-used)))
  95                             nil t)
  96                     and do (movitz-env-add-binding local-env (make-instance 'dynamic-binding
  97                                                                :name var))
  98                     and do (incf (num-specials local-env))
  99                         ;; lexical...
 100                     else collect
 101                          (let ((binding (make-instance 'located-binding :name var)))
 102                            (movitz-env-add-binding local-env binding)
 103                            (compiler-values-bind (&code init-code &functional-p functional-p
 104                                                   &type type &returns init-register
 105                                                   &final-form final-form)
 106
 107                                (compiler-call #'compile-form-unprotected
 108                                  :result-mode binding
 109                                  :env init-env
 110                                  :extent local-env
 111                                  :defaults all
 112                                  :form init-form)
 113                              #+ignore
 114                              (compiler-call #'compile-form-to-register
 115                                  :env init-env
 116                                  :extent local-env
 117                                  :defaults all
 118                                  :form init-form
 119                                  :modify-accumulate let-modifies)
 120                              (when (eq binding init-register)
 121                                (setf init-register nil))
 122 ;;;                          (warn "var ~S, type: ~S" var type)
 123 ;;;                          (warn "var ~S init: ~S.." var init-form)
 124 ;;;                          (warn "bind: ~S reg: ~S" binding init-register)
 125 ;;;                          (print-code 'init init-code)
 126                              (list var
 127                                    init-form
 128                                    init-code
 129                                    functional-p
 130                                    (let ((init-type (type-specifier-primary type)))
 131                                      (assert init-type ()
 132                                        "The init-form ~S yielded the empty primary type!" type)
 133                                      init-type)
 134                                    (case init-register
 135                                      (:non-local-exit :edi)
 136                                      (:multiple-values :eax)
 137                                      (t init-register))
 138                                    final-form))))))
 139           (setf (stack-used local-env) stack-used)
 140           (flet ((compile-body ()
 141                    (if (= 0 (num-specials local-env))
 142                        (compiler-call #'compile-implicit-progn
 143                          :defaults all
 144                          :form body
 145                          :env local-env)
 146                      (compiler-call #'compile-form
 147                        :result-mode (case result-mode
 148                                       (:push :eax)
 149                                       (:function :multiple-values)
 150                                       (t result-mode))
 151                        :defaults all
 152                        :form `(muerte.cl:progn ,@body)
 153                        :modify-accumulate let-modifies
 154                        :env local-env))))
 155             (compiler-values-bind (&all body-values &code body-code &returns body-returns)
 156                 (compile-body)
 157               ;; (print-code 'body body)
 158               ;; (print-code 'body-code body-code)
 159               (let ((first-binding (movitz-binding (caar binding-var-codes) local-env nil)))
 160                 (cond
 161                  ;; Is this (let ((#:foo <form>)) (setq bar #:foo)) ?
 162                  ;; If so, make it into (setq bar <form>)
 163                  ((and (= 1 (length binding-var-codes))
 164                        (typep first-binding 'lexical-binding)
 165                        (instruction-is (first body-code) :load-lexical)
 166                        (instruction-is (second body-code) :store-lexical)
 167                        (null (cddr body-code))
 168                        (eq first-binding ; same binding?
 169                            (second (first body-code)))
 170                        (eq (third (first body-code)) ; same register?
 171                            (third (second body-code))))
 172                   (let ((dest-binding (second (second body-code))))
 173                     (check-type dest-binding lexical-binding)
 174                     (compiler-call #'compile-form
 175                       :forward all
 176                       :extent local-env
 177                       :result-mode dest-binding
 178                       :form (second (first binding-var-codes)))))
 179                  #+ignore
 180                  ((and (= 1 (length binding-var-codes))
 181                        (typep (movitz-binding (caar binding-var-codes) local-env nil)
 182                               'lexical-binding)
 183                        (member (movitz-binding (caar binding-var-codes) local-env nil)
 184                                (find-read-bindings (first body-code)))
 185                        (not (code-uses-binding-p (rest body-code) (second (first body-code))
 186                                                  :load t :store nil)))
 187                   (let ((tmp-binding (second (first body-code))))
 188                     (print-code 'body body-code)
 189                     (break "Yuhu: tmp ~S" tmp-binding)
 190
 191                     ))
 192                  (t (let ((code
 193                            (append
 194                             (loop
 195                                 for ((var init-form init-code functional-p type init-register
 196                                           final-form)
 197                                      . rest-codes)
 198                                 on binding-var-codes
 199                                 as binding = (movitz-binding var local-env nil)
 200                                              ;;  for bb in binding-var-codes
 201                                              ;; do (warn "bind: ~S" bb)
 202                                 do (assert type)
 203                                    (assert (not (binding-lended-p binding)))
 204                                 appending
 205                                   (cond
 206                                    ((and (typep binding 'located-binding)
 207                                          (not (binding-lended-p binding))
 208                                          (typep final-form 'lexical-binding)
 209                                          (let ((target-binding final-form))
 210                                            (and (typep target-binding 'lexical-binding)
 211                                                 (eq (binding-funobj binding)
 212                                                     (binding-funobj target-binding))
 213                                                 #+ignore
 214                                                 (sub-env-p (binding-env binding)
 215                                                            (binding-env target-binding))
 216                                                 (or (and (not (code-uses-binding-p body-code
 217                                                                                    binding
 218                                                                                    :load nil
 219                                                                                    :store t))
 220                                                          (not (code-uses-binding-p body-code
 221                                                                                    target-binding
 222                                                                                    :load nil
 223                                                                                    :store t)))
 224                                                     (and (= 1 (length body-code))
 225                                                          (eq :add (caar body-code)))
 226                                                     (and (>= 1 (length body-code))
 227                                                          (warn "short let body: ~S" body-code))
 228                                                     ;; This is the best we can do now to determine
 229                                                     ;; if target-binding is ever used again.
 230                                                     (and (eq result-mode :function)
 231                                                          (not (and (bindingp body-returns)
 232                                                                    (binding-eql target-binding
 233                                                                                 body-returns)))
 234                                                          (not (code-uses-binding-p body-code
 235                                                                                    target-binding
 236                                                                                    :load t
 237                                                                                    :store t))
 238                                                          (notany (lambda (code)
 239                                                                    (code-uses-binding-p (third code)
 240                                                                                         target-binding
 241                                                                                         :load t
 242                                                                                         :store t))
 243                                                                  rest-codes))))))
 244                                     ;; replace read-only binding with the outer binding
 245                                     (compiler-values-bind (&code new-init-code &final-form target
 246                                                            &type type)
 247                                         (compiler-call #'compile-form-unprotected
 248                                           :extent local-env
 249                                           :form init-form
 250                                           :result-mode :ignore
 251                                           :env init-env
 252                                           :defaults all)
 253                                       (check-type target lexical-binding)
 254                                       (change-class binding 'forwarding-binding
 255                                                     :target-binding target)
 256                                       (let ((btype (if (multiple-value-call #'encoded-allp
 257                                                          (type-specifier-encode
 258                                                           (type-specifier-primary type)))
 259                                                        target
 260                                                      (type-specifier-primary type))))
 261                                         #+ignore (warn "forwarding ~S -[~S]> ~S"
 262                                                        binding btype target)
 263                                         (append new-init-code
 264                                                 `((:init-lexvar
 265                                                    ,binding
 266                                                    :init-with-register ,target
 267                                                    :init-with-type ,btype))))))
 268                                    ((and (typep binding 'located-binding)
 269                                          (type-specifier-singleton type)
 270                                          (not (code-uses-binding-p body-code binding
 271                                                                    :load nil :store t)))
 272                                     ;; replace read-only lexical binding with
 273                                     ;; side-effect-free form
 274                                     #+ignore
 275                                     (warn "Constant binding: ~S => ~S => ~S"
 276                                           (binding-name binding)
 277                                           init-form
 278                                           (car (type-specifier-singleton type)))
 279                                     (change-class binding 'constant-object-binding
 280                                                   :object (car (type-specifier-singleton type)))
 281                                     (if functional-p
 282                                         nil ; only inject code if it's got side-effects.
 283                                       (compiler-call #'compile-form-unprotected
 284                                         :extent local-env
 285                                         :env init-env
 286                                         :defaults all
 287                                         :form init-form
 288                                         :result-mode :ignore
 289                                         :modify-accumulate let-modifies)))
 290                                    ((typep binding 'lexical-binding)
 291                                     (let ((init (type-specifier-singleton
 292                                                  (type-specifier-primary type))))
 293                                       (cond
 294                                        ((and init (eq *movitz-nil* (car init)))
 295                                         (append (if functional-p
 296                                                     nil
 297                                                   (compiler-call #'compile-form-unprotected
 298                                                     :extent local-env
 299                                                     :env init-env
 300                                                     :defaults all
 301                                                     :form init-form
 302                                                     :result-mode :ignore
 303                                                     :modify-accumulate let-modifies))
 304                                                 `((:init-lexvar ,binding
 305                                                                 :init-with-register :edi
 306                                                                 :init-with-type null))))
 307                                        ((and (typep final-form 'lexical-binding)
 308                                              (eq (binding-funobj final-form)
 309                                                  funobj))
 310                                         (compiler-values-bind (&code new-init-code
 311                                                                &type new-type
 312                                                                &final-form new-binding)
 313                                             (compiler-call #'compile-form-unprotected
 314                                               :extent local-env
 315                                               :env init-env
 316                                               :defaults all
 317                                               :form init-form
 318                                               :result-mode :ignore
 319                                               :modify-accumulate let-modifies)
 320                                           (append (if functional-p
 321                                                       nil
 322                                                     new-init-code)
 323                                                   (let ((ptype (type-specifier-primary new-type)))
 324                                                     `((:init-lexvar ,binding
 325                                                                     :init-with-register ,new-binding
 326                                                                     :init-with-type ,ptype
 327                                                                     ))))))
 328                                        ((typep final-form 'constant-object-binding)
 329                                         #+ignore
 330                                         (warn "type: ~S or ~S" final-form
 331                                               (type-specifier-primary type))
 332                                         (append (if functional-p
 333                                                     nil
 334                                                   (compiler-call #'compile-form-unprotected
 335                                                     :extent local-env
 336                                                     :env init-env
 337                                                     :defaults all
 338                                                     :form init-form
 339                                                     :result-mode :ignore
 340                                                     :modify-accumulate let-modifies))
 341                                                 `((:init-lexvar
 342                                                    ,binding
 343                                                    :init-with-register ,final-form
 344                                                    :init-with-type ,(type-specifier-primary type)
 345                                                    ))))
 346                                        (t ;; (warn "for ~S ~S ~S" binding init-register final-form)
 347                                         (append init-code
 348                                                 `((:init-lexvar
 349                                                    ,binding
 350                                                    :init-with-register ,init-register
 351                                                    :init-with-type ,(type-specifier-primary type))))))))
 352                                    (t init-code)))
 353                             (when (plusp (num-specials local-env))
 354                               `((:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context
 355                                                                         'dynamic-variable-install))))
 356                                 (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))))
 357                             body-code
 358                             (when (and (plusp (num-specials local-env))
 359                                        (not (eq :non-local-exit body-returns)))
 360                               #+ignore
 361                               (warn "let spec ret: ~S, want: ~S ~S"
 362                                     body-returns result-mode let-var-specs)
 363                               `((:movl (:esp ,(+ -4 (* 16 (num-specials local-env)))) :edx)
 364                                 (:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context
 365                                                                         'dynamic-variable-uninstall))))
 366                                 (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
 367                                 (:leal (:esp ,(* 16 (num-specials local-env))) :esp))))))
 368                       (compiler-values (body-values)
 369                         :returns body-returns
 370                         :producer (default-compiler-values-producer)
 371                         :functional-p (and (body-values :functional-p)
 372                                            (every #'fourth binding-var-codes))
 373                         :modifies let-modifies
 374                         :code code))))))))))))
 375
 376 (define-special-operator symbol-macrolet (&all forward &form form &env env &funobj funobj)
 377   (destructuring-bind (symbol-expansions &body declarations-and-body)
 378       (cdr form)
 379     (multiple-value-bind (body declarations)
 380         (parse-declarations-and-body declarations-and-body)
 381       (let ((local-env (make-local-movitz-environment
 382                         env funobj
 383                         :type 'operator-env
 384                         :declarations declarations)))
 385         (loop for symbol-expansion in symbol-expansions
 386             do (destructuring-bind (symbol expansion)
 387                    symbol-expansion
 388                  (movitz-env-add-binding local-env (make-instance 'symbol-macro-binding
 389                                                   :name symbol
 390                                                   :expander #'(lambda (form env)
 391                                                                 (declare (ignore form env))
 392                                                                 expansion)))))
 393         (compiler-values-bind (&all body-values &code body-code)
 394             (compiler-call #'compile-implicit-progn
 395               :defaults forward
 396               :form body
 397               :env local-env
 398               :top-level-p (forward :top-level-p))
 399           (compiler-values (body-values)
 400             :code body-code))))))
 401
 402 (define-special-operator macrolet (&all forward &form form &funobj funobj &env env)
 403   (destructuring-bind (macrolet-specs &body declarations-and-body)
 404       (cdr form)
 405     (multiple-value-bind (body declarations)
 406         (parse-declarations-and-body declarations-and-body)
 407       (let ((local-env (make-local-movitz-environment env funobj
 408                                                       :type 'operator-env
 409                                                       :declarations declarations)))
 410         (loop for (name local-lambda-list . local-body-decl-doc) in macrolet-specs
 411             as cl-local-lambda-list = (translate-program local-lambda-list :muerte.cl :cl)
 412             as (local-body local-declarations) =
 413               (multiple-value-list (parse-docstring-declarations-and-body local-body-decl-doc))
 414             as cl-local-body = (translate-program local-body :muerte.cl :cl)
 415             as cl-local-declarations = (translate-program local-declarations :muerte.cl :cl)
 416             as expander = `(lambda (form env)
 417                              (declare (ignorable env))
 418                              (destructuring-bind ,cl-local-lambda-list
 419                                  (translate-program (rest form) :muerte.cl :cl)
 420                                (declare ,@cl-local-declarations)
 421                                (translate-program (block ,name (let () ,@cl-local-body))
 422                                                   :cl :muerte.cl)))
 423             do (movitz-env-add-binding
 424                 local-env
 425                 (make-instance 'macro-binding
 426                   :name name
 427                   :expander (movitz-macro-expander-make-function expander
 428                                                                  :name name
 429                                                                  :type :macrolet))))
 430         (compiler-values-bind (&all body-values &code body-code)
 431             (compiler-call #'compile-implicit-progn
 432               :defaults forward
 433               :form body
 434               :env local-env
 435               :top-level-p (forward :top-level-p))
 436           (compiler-values (body-values)
 437             :code body-code))))))
 438
 439 (define-special-operator multiple-value-prog1 (&all all &form form &result-mode result-mode &env env)
 440   (destructuring-bind (first-form &rest rest-forms)
 441       (cdr form)
 442     (compiler-values-bind (&code form1-code &returns form1-returns &type type)
 443         (compiler-call #'compile-form-unprotected
 444           :defaults all
 445           :result-mode (case (result-mode-type result-mode)
 446                          ((:boolean-branch-on-true :boolean-branch-on-false)
 447                           :eax)
 448                          (t result-mode))
 449           :form first-form)
 450       (compiler-call #'special-operator-with-cloak
 451         ;; :with-stack-used t
 452         :forward all
 453         :form `(muerte::with-cloak (,form1-returns ,form1-code t ,type)
 454                  ,@rest-forms)))))
 455
 456 (define-special-operator multiple-value-call (&all all &form form &funobj funobj)
 457   (destructuring-bind (function-form &rest subforms)
 458       (cdr form)
 459     (let* ((local-env (make-instance 'let-env
 460                         :uplink (all :env)
 461                         :funobj funobj
 462                         :stack-used t))
 463            (numargs-binding (movitz-env-add-binding local-env
 464                                                  (make-instance 'located-binding
 465                                                    :name (gensym "m-v-numargs-"))))
 466            (arg-code (loop for subform in subforms
 467                          collecting
 468                            (compiler-values-bind (&code subform-code &returns subform-returns)
 469                                (compiler-call #'compile-form-unprotected
 470                                  :defaults all
 471                                  :env local-env
 472                                  :form subform
 473                                  :result-mode :multiple-values)
 474                              (case subform-returns
 475                                (:multiple-values
 476                                 `(:multiple
 477                                   ,@subform-code
 478                                   ,@(make-compiled-push-current-values)
 479                                   (:load-lexical ,numargs-binding :eax)
 480                                   (:addl :ecx :eax)
 481                                   (:store-lexical ,numargs-binding :eax :type fixnum)))
 482                                (t (list :single ; marker, used below
 483                                         subform))))))
 484            (number-of-multiple-value-subforms (count :multiple arg-code :key #'car))
 485            (number-of-single-value-subforms (count :single arg-code :key #'car)))
 486       (cond
 487        ((= 0 number-of-multiple-value-subforms)
 488         (compiler-call #'compile-form
 489           :forward all
 490           :form `(muerte.cl::funcall ,function-form ,@subforms)))
 491        (t (compiler-values ()
 492             :returns :multiple-values
 493             :code (append `((:load-constant ,(1+ number-of-single-value-subforms) :eax)
 494                             (:store-lexical ,numargs-binding :eax :type fixnum))
 495                           (compiler-call #'compile-form
 496                             :defaults all
 497                             :env local-env
 498                             :form function-form
 499                             :result-mode :push)
 500                           (loop for ac in arg-code
 501                               append (ecase (car ac)
 502                                        (:single
 503                                         (compiler-call #'compile-form
 504                                           :defaults all
 505                                           :env local-env
 506                                           :form (second ac)
 507                                           :result-mode :push))
 508                                        (:multiple
 509                                         (cdr ac))))
 510                           `((:load-lexical ,numargs-binding :ecx)
 511                             ;; (:store-lexical ,numargs-binding :ecx :type t)
 512                             (:movl (:esp (:ecx 1) -4) :eax)
 513                             (:movl (:esp (:ecx 1) -8) :ebx)
 514                             (:shrl ,+movitz-fixnum-shift+ :ecx)
 515                             (:load-constant muerte.cl::funcall :edx)
 516                             (:movl (:edx ,(slot-offset 'movitz-symbol 'function-value))
 517                                    :esi) ; load new funobj from symbol into ESI
 518                             (:call (:esi ,(slot-offset 'movitz-funobj 'code-vector)))
 519                             (:load-lexical ,numargs-binding :edx)
 520                             ;; Use LEA so as not to modify CF
 521                             (:leal (:esp :edx) :esp)))))))))
 522
 523
 524
 525 (define-special-operator multiple-value-bind (&all forward &form form &env env &funobj funobj
 526                                                    &result-mode result-mode)
 527   (destructuring-bind (variables values-form &body body-and-declarations)
 528       (cdr form)
 529     (multiple-value-bind (body declarations)
 530         (parse-declarations-and-body body-and-declarations)
 531       (compiler-values-bind (&code values-code &returns values-returns &type values-type)
 532           (compiler-call #'compile-form
 533             :defaults forward
 534             :form values-form
 535             :result-mode :multiple-values #+ignore (list :values (length variables)))
 536 ;;;     (warn "mv-code: ~W ~W => ~W ~W" values-form (list :values (length variables)) values-returns (last values-code 10))
 537         (let* ((local-env (make-local-movitz-environment
 538                            env funobj
 539                            :type 'let-env
 540                            :declarations declarations))
 541                (lexical-bindings
 542                 (loop for variable in variables
 543                     as new-binding = (make-instance 'located-binding
 544                                        :name variable)
 545                     do (check-type variable symbol)
 546                     collect new-binding
 547                     do (cond
 548                         ((movitz-env-get variable 'special nil env)
 549                          (let* ((shadowed-variable (gensym (format nil "m-v-bind-shadowed-~A"
 550                                                                    variable))))
 551                            (movitz-env-add-binding local-env new-binding shadowed-variable)
 552                            (push (list variable shadowed-variable)
 553                                  (special-variable-shadows local-env))))
 554                         (t (movitz-env-add-binding local-env new-binding)))))
 555                (init-var-code
 556                 (case (first (operands values-returns))
 557
 558                   (t (append
 559                       (make-result-and-returns-glue :multiple-values values-returns)
 560                       (case (length lexical-bindings)
 561                         (0 nil)
 562                         (1 `((:init-lexvar ,(first lexical-bindings)
 563                                            :protect-carry nil
 564                                            :protect-registers '(:eax))
 565                              (:store-lexical ,(first lexical-bindings) :eax
 566                                              :type ,(type-specifier-primary values-type))))
 567                         (2 (let ((done-label (gensym "m-v-bind-done-")))
 568                              `((:init-lexvar ,(first lexical-bindings)
 569                                              :protect-carry t
 570                                              :protect-registers (:eax :ebx))
 571                                (:store-lexical ,(first lexical-bindings) :eax
 572                                                :type ,(type-specifier-primary values-type)
 573                                                :protect-registers (:ebx))
 574                                (:init-lexvar ,(second lexical-bindings)
 575                                              :protect-carry t
 576                                              :protect-registers (:ebx))
 577                                (:store-lexical ,(second lexical-bindings) :edi
 578                                                :type null)
 579                                (:jnc ',done-label)
 580                                (:cmpl 1 :ecx)
 581                                (:jbe ',done-label)
 582                                (:store-lexical ,(second lexical-bindings) :ebx
 583                                                :type ,(type-specifier-nth-value 1 values-type))
 584                                ,done-label)))
 585                         (t (with-labels (m-v-bind (ecx-ok-label))
 586                              `((:jc ',ecx-ok-label)
 587                                ,@(make-immediate-move 1 :ecx) ; CF=0 means arg-count=1
 588                                ,ecx-ok-label
 589                                ,@(loop for binding in lexical-bindings as pos upfrom 0
 590                                      as skip-label = (gensym "m-v-bind-skip-")
 591                                      as type = (type-specifier-nth-value pos values-type)
 592                                      append
 593                                        (case pos
 594                                          (0 `((:init-lexvar ,binding
 595                                                             :protect-registers (:eax :ebx :ecx))
 596                                               (:store-lexical ,binding :eax :type ,type
 597                                                               :protect-registers (:eax :ebx :ecx))))
 598                                          (1 `((:init-lexvar ,binding
 599                                                             :protect-registers (:ebx :ecx))
 600                                               (:store-lexical ,binding :edi :type null
 601                                                               :protect-registers (:ecx))
 602                                               (:cmpl 1 :ecx)
 603                                               (:jbe ',skip-label)
 604                                               (:store-lexical ,binding :ebx :type ,type
 605                                                               :protect-registers (:ecx))
 606                                               ,skip-label))
 607                                          (t (if *compiler-use-cmov-p*
 608                                                 `((:init-lexvar ,binding :protect-registers '(:ecx))
 609                                                   (:movl :edi :eax)
 610                                                   (:cmpl ,pos :ecx)
 611                                                   (:locally (:cmova (:edi (:edi-offset values
 612                                                                                        ,(* 4 (- pos 2))))
 613                                                                     :eax))
 614                                                   (:store-lexical ,binding :eax :type ,type
 615                                                                   :protect-registers (:eax)))
 616                                               `((:init-lexvar ,binding :protect-registers '(:ecx))
 617                                                 (:movl :edi :eax)
 618                                                 (:cmpl ,pos :ecx)
 619                                                 (:jbe ',skip-label)
 620                                                 (:locally (:movl (:edi (:edi-offset values
 621                                                                                     ,(* 4 (- pos 2))))
 622                                                                  :eax))
 623                                                 ,skip-label
 624                                                 (:store-lexical ,binding :eax :type ,type
 625                                                                 :protect-registers (:ecx))))))))))))))))
 626           (compiler-values-bind (&code body-code &returns body-returns-mode)
 627               (compiler-call #'compile-form-unprotected
 628                 :defaults forward
 629                 :form `(muerte.cl:let ,(special-variable-shadows local-env) ,@body)
 630                 :env local-env)
 631             (compiler-values ()
 632               :returns body-returns-mode
 633               :code (append values-code
 634                             init-var-code
 635                             body-code))))))))
 636
 637 (define-special-operator setq (&all forward &form form &env env &funobj funobj &result-mode result-mode)
 638   (let ((pairs (cdr form)))
 639     (unless (evenp (length pairs))
 640       (error "Odd list of SETQ pairs: ~S" pairs))
 641     (let* ((last-returns :nothing)
 642            (bindings ())
 643            (code (loop
 644                      for (var value-form) on pairs by #'cddr
 645                      as binding = (movitz-binding var env)
 646                      as pos downfrom (- (length pairs) 2) by 2
 647                      as sub-result-mode = (if (zerop pos) result-mode :ignore)
 648                      do (pushnew binding bindings)
 649                      append
 650                        (typecase binding
 651                          (symbol-macro-binding
 652                           (compiler-values-bind (&code code &returns returns)
 653                               (compiler-call #'compile-form-unprotected
 654                                 :defaults forward
 655                                 :result-mode sub-result-mode
 656                                 :form `(muerte.cl:setf ,var ,value-form))
 657                             (setf last-returns returns)
 658                             code))
 659                          (lexical-binding
 660                           (case (operator sub-result-mode)
 661                             (t ;; :ignore
 662                              ;; (setf last-returns :nothing)
 663                              (compiler-values-bind (&code sub-code &returns sub-returns)
 664                                  (compiler-call #'compile-form
 665                                    :defaults forward
 666                                    :form value-form
 667                                    :result-mode binding)
 668                                (setf last-returns sub-returns)
 669                                ;; (warn "sub-returns: ~S" sub-returns)
 670                                sub-code))
 671                             #+ignore
 672                             (t (let ((register (accept-register-mode sub-result-mode)))
 673                                  (compiler-values-bind (&code code &type type)
 674                                      (compiler-call #'compile-form
 675                                        :defaults forward
 676                                        :form value-form
 677                                        :result-mode register)
 678                                    (setf last-returns register)
 679                                    (append code
 680                                            `((:store-lexical ,binding ,register
 681                                                              :type ,(type-specifier-primary type)))))))))
 682                          (t (unless (movitz-env-get var 'special nil env)
 683                               (warn "Assuming destination variable ~S with binding ~S is special."
 684                                     var binding))
 685                             (setf last-returns :ebx)
 686                             (append (compiler-call #'compile-form
 687                                       :defaults forward
 688                                       :form value-form
 689                                       :result-mode :ebx)
 690                                     `((:load-constant ,var :eax)
 691                                       (:locally (:call (:edi (:edi-offset dynamic-variable-store)))))))))))
 692       (compiler-values ()
 693         :code code
 694         :returns last-returns
 695         :functional-p nil))))
 696
 697 (define-special-operator tagbody (&all forward &funobj funobj &form form &env env)
 698   (let* ((save-esp-variable (gensym "tagbody-save-esp"))
 699          (lexical-catch-tag-variable (gensym "tagbody-lexical-catch-tag-"))
 700          (label-set-name (gensym "label-set-"))
 701          (tagbody-env (make-instance 'tagbody-env
 702                         :uplink env
 703                         :funobj funobj
 704                         :save-esp-variable save-esp-variable
 705                         :lexical-catch-tag-variable lexical-catch-tag-variable
 706                         :exit-result-mode :ignore))
 707          (save-esp-binding (make-instance 'located-binding
 708                              :name save-esp-variable))
 709          (lexical-catch-tag-binding (make-instance 'located-binding
 710                                       :name lexical-catch-tag-variable)))
 711     (movitz-env-add-binding tagbody-env save-esp-binding)
 712     (movitz-env-add-binding tagbody-env lexical-catch-tag-binding)
 713     (movitz-env-load-declarations `((muerte.cl::ignorable ,save-esp-variable ,lexical-catch-tag-variable))
 714                                tagbody-env nil)
 715     ;; First generate an assembly-level label for each tag.
 716     (let* ((label-set (loop with label-id = 0
 717                           for tag-or-statement in (cdr form)
 718                           as label = (when (or (symbolp tag-or-statement)
 719                                                (integerp tag-or-statement))
 720                                        (gensym (format nil "go-tag-~A-" tag-or-statement)))
 721                           when label
 722                           do (setf (movitz-env-get tag-or-statement 'go-tag nil tagbody-env)
 723                                label)
 724                              (setf (movitz-env-get tag-or-statement 'go-tag-label-id nil tagbody-env)
 725                                (post-incf label-id))
 726                           and collect label))
 727            (tagbody-codes
 728             (loop for tag-or-statement in (cdr form)
 729                 if (or (symbolp tag-or-statement) ; Tagbody tags are "compiled" into..
 730                        (integerp tag-or-statement)) ; ..their assembly-level labels.
 731                 collect (movitz-env-get tag-or-statement 'go-tag nil tagbody-env)
 732                 else collect
 733                      (compiler-call #'compile-form
 734                        :defaults forward
 735                        :form tag-or-statement
 736                        :env tagbody-env
 737                        :result-mode :ignore))))
 738       (let* ((unlexical-target-p (some (lambda (code)
 739                                          (when (listp code)
 740                                            (code-uses-binding-p code save-esp-binding)))
 741                                        tagbody-codes))
 742              (maybe-store-esp-code
 743               (when (or unlexical-target-p
 744                         (some (lambda (code)
 745                                 (when (listp code)
 746                                   (operators-present-in-code-p code '(:lexical-control-transfer) nil
 747                                                                :test (lambda (x)
 748                                                                        (eq tagbody-env (fifth x))))))
 749                               tagbody-codes))
 750                 `((:init-lexvar ,save-esp-binding
 751                                 :init-with-register :esp
 752                                 :init-with-type t)))))
 753         (if (not unlexical-target-p)
 754             (compiler-values ()
 755               :code (append maybe-store-esp-code
 756                             (loop for code in tagbody-codes
 757                                 if (listp code)
 758                                 append code
 759                                 else append (list code)))
 760               :returns :nothing)
 761           (let ((code (append `((:declare-label-set ,label-set-name ,label-set)
 762                                 ;; catcher
 763                                 (:locally (:pushl (:edi (:edi-offset dynamic-env))))
 764                                 (:pushl ',label-set-name)
 765                                 (:locally (:pushl (:edi (:edi-offset unbound-function))))
 766                                 (:pushl :ebp)
 767                                 (:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))
 768                               maybe-store-esp-code
 769                               (loop for code in tagbody-codes
 770                                   if (listp code)
 771                                   append code
 772                                   else append (list code '(:movl (:esp) :ebp)))
 773                               `((:movl (:esp 12) :edx)
 774                                 (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
 775                                 (:leal (:esp 16) :esp))
 776                               )))
 777             (setf (num-specials tagbody-env) 1
 778                   (stack-used tagbody-env) 4)
 779             (compiler-values ()
 780               :code code
 781               :returns :nothing)))))))
 782
 783
 784 (define-special-operator go (&all all &form form &env env &funobj funobj)
 785   (destructuring-bind (operator tag)
 786       form
 787     (declare (ignore operator))
 788     (multiple-value-bind (label tagbody-env)
 789         (movitz-env-get tag 'go-tag nil env)
 790       (assert (and label tagbody-env) ()
 791         "Go-tag ~W is not visible." tag)
 792       (multiple-value-bind (stack-distance num-dynamic-slots unwind-protects)
 793           (stack-delta env tagbody-env)
 794         (declare (ignore stack-distance))
 795         (if (and (eq funobj (movitz-environment-funobj tagbody-env))
 796                  ;; A well-known number of dynamic-slots?
 797                  (not (eq t num-dynamic-slots))
 798                  ;; any unwind-protects between here and there?
 799                  (null unwind-protects))
 800             (compiler-values ()
 801               :returns :non-local-exit
 802               :code `((:lexical-control-transfer nil :nothing ,env ,tagbody-env ,label)))
 803           ;; Perform a lexical "throw" to the tag. Just like a regular (dynamic) throw.
 804           (let ((save-esp-binding (movitz-binding (save-esp-variable tagbody-env) env))
 805                 (label-id (movitz-env-get tag 'go-tag-label-id nil tagbody-env nil)))
 806             (assert label-id)
 807             (compiler-values ()
 808               :returns :non-local-exit
 809               :code `((:load-lexical ,save-esp-binding :edx)
 810                       (:movl :edx :eax)
 811                       ,@(when (plusp label-id)
 812                           ;; The target jumper points to the tagbody's label-set.
 813                           ;; Now, install correct jumper within tagbody as target.
 814                           `((:addl ,(* 4 label-id) (:edx 8))))
 815                       (:locally (:call (:edi (:edi-offset dynamic-unwind-next))))
 816                       ;; have next-continuation in EAX, final-continuation in EDX
 817                       (:locally (:movl :edx (:edi (:edi-offset raw-scratch0)))) ; final continuation
 818                       (:locally (:movl :eax (:edi (:edi-offset dynamic-env)))) ; new dynamic-env
 819                       (:movl :eax :edx)
 820                       (:clc)
 821                       (:locally (:call (:edi (:edi-offset dynamic-jump-next))))))))))))
 822
 823 ;;;                   (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; exit to next-env
 824 ;;;                   (:movl :edx :esp) ; enter non-local jump stack mode.
 825 ;;;                   (:movl (:esp) :edx) ; target stack-frame EBP
 826 ;;;                   (:movl (:edx -4) :esi) ; get target funobj into ESI
 827 ;;;                   (:movl (:esp 8) :edx) ; target jumper number
 828 ;;;                   (:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0)))))))))))
 829
 830 (define-special-operator block (&all forward &funobj funobj &form form &env env
 831                                      &result-mode result-mode)
 832   (destructuring-bind (block-name &body body)
 833       (cdr form)
 834     (let* ((exit-block-label (gensym (format nil "exit-block-~A-" block-name)))
 835            (save-esp-variable (gensym (format nil "block-~A-save-esp-" block-name)))
 836            (lexical-catch-tag-variable (gensym (format nil "block-~A-lexical-catch-tag-" block-name)))
 837            (block-result-mode (case result-mode
 838                                 ((:eax :eax :multiple-values :function :ebx :ecx :ignore)
 839                                  result-mode)
 840                                 (t :eax)))
 841            (block-returns-mode (case (result-mode-type block-result-mode)
 842                                  (:function :multiple-values)
 843                                  (:ignore :nothing)
 844                                  ((:boolean-branch-on-true :boolean-branch-on-false) :eax)
 845                                  (t block-result-mode)))
 846            (block-env (make-instance 'lexical-exit-point-env
 847                         :uplink env
 848                         :funobj funobj
 849                         :save-esp-variable save-esp-variable
 850                         :lexical-catch-tag-variable lexical-catch-tag-variable
 851                         :exit-label exit-block-label
 852                         :exit-result-mode block-result-mode))
 853            (save-esp-binding (make-instance 'located-binding
 854                                :name save-esp-variable)))
 855       (movitz-env-add-binding block-env save-esp-binding)
 856       (movitz-env-load-declarations `((muerte.cl::ignorable ,save-esp-variable))
 857                                     block-env nil)
 858       (setf (movitz-env-get block-name :block-name nil block-env)
 859         block-env)
 860       (compiler-values-bind (&code block-code &functional-p block-no-side-effects-p)
 861           (compiler-call #'compile-form
 862             :defaults forward
 863             :result-mode (case block-result-mode
 864                            (:function :multiple-values) ; must restore stack
 865                            (t block-result-mode))
 866             :form `(muerte.cl:progn ,@body)
 867             :env block-env)
 868         (let ((label-set-name (gensym "block-label-set-"))
 869               (maybe-store-esp-code
 870                (when (and #+ignore (not (eq block-result-mode :function))
 871                           (operators-present-in-code-p block-code '(:lexical-control-transfer) nil
 872                                                        :test (lambda (x) (eq block-env (fifth x)))))
 873                  `((:init-lexvar ,save-esp-binding
 874                                  :init-with-register :esp
 875                                  :init-with-type t)))))
 876           (if (not (code-uses-binding-p block-code save-esp-binding))
 877               (compiler-values ()
 878                 :code (append maybe-store-esp-code
 879                               block-code
 880                               (list exit-block-label))
 881                 :returns block-returns-mode
 882                 :functional-p block-no-side-effects-p)
 883             (multiple-value-bind (new-code new-returns)
 884                 (make-result-and-returns-glue :multiple-values block-returns-mode block-code)
 885               (assert (eq :multiple-values new-returns))
 886               (incf (stack-used block-env) 4)
 887               (setf (num-specials block-env) 1) ; block-env now has one dynamic slot
 888               (compiler-values ()
 889                 :code (append `((:declare-label-set ,label-set-name (,exit-block-label))
 890                                 ;; catcher
 891                                 (:locally (:pushl (:edi (:edi-offset dynamic-env))))
 892                                 (:pushl ',label-set-name)
 893                                 (:locally (:pushl (:edi (:edi-offset unbound-function))))
 894                                 (:pushl :ebp)
 895                                 (:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))
 896                               `((:init-lexvar ,save-esp-binding
 897                                               :init-with-register :esp
 898                                               :init-with-type t))
 899                               new-code
 900                               ;; wrapped-code
 901                               `(,exit-block-label
 902                                 (:movl (:esp 0) :ebp)
 903                                 (:movl (:esp 12) :edx)
 904                                 (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
 905                                 (:leal (:esp 16) :esp)))
 906                 :returns :multiple-values
 907                 :functional-p block-no-side-effects-p))))))))
 908
 909 (define-special-operator return-from (&all all &form form &env env &funobj funobj)
 910   (destructuring-bind (block-name &optional result-form)
 911       (cdr form)
 912     (let ((block-env (movitz-env-get block-name :block-name nil env)))
 913       (assert block-env (block-name)
 914         "Block-name not found for return-from: ~S." block-name)
 915       (multiple-value-bind (stack-distance num-dynamic-slots unwind-protects)
 916           (stack-delta env block-env)
 917         (declare (ignore stack-distance))
 918         (cond
 919          ((and (eq funobj (movitz-environment-funobj block-env))
 920                (not (eq t num-dynamic-slots))
 921                (null unwind-protects))
 922           (compiler-values-bind (&code return-code &returns return-mode)
 923               (compiler-call #'compile-form
 924                 :forward all
 925                 :form result-form
 926                 :result-mode (exit-result-mode block-env))
 927             (compiler-values ()
 928               :returns :non-local-exit
 929               :code (append return-code
 930                             `((:lexical-control-transfer nil ,return-mode ,env ,block-env))))))
 931          ((not (and (eq funobj (movitz-environment-funobj block-env))
 932                     (not (eq t num-dynamic-slots))
 933                     (null unwind-protects)))
 934           (compiler-call #'compile-form-unprotected
 935             :forward all
 936             :form `(muerte::exact-throw ,(save-esp-variable block-env)
 937                                         ,result-form))))))))
 938
 939 (define-special-operator require (&form form)
 940   (let ((*require-dependency-chain*
 941          (and (boundp '*require-dependency-chain*)
 942               (symbol-value '*require-dependency-chain*))))
 943     (declare (special *require-dependency-chain*))
 944     (destructuring-bind (module-name &optional path-spec)
 945         (cdr form)
 946       (declare (ignore path-spec))
 947       (push module-name *require-dependency-chain*)
 948       (unless (member module-name (image-movitz-modules *image*))
 949         (when (member module-name (cdr *require-dependency-chain*))
 950           (error "Circular Movitz module dependency chain: ~S"
 951                  (reverse (subseq *require-dependency-chain* 0
 952                                   (1+ (position  module-name *require-dependency-chain* :start 1))))))
 953         (let* ((require-path (movitz-module-path form)))
 954           (movitz-compile-file-internal require-path)
 955           (unless (member module-name (image-movitz-modules *image*))
 956             (error "Compiling file ~S didn't provide module ~S."
 957                    require-path module-name))))))
 958   (compiler-values ()))
 959
 960 (define-special-operator provide (&form form &funobj funobj &top-level-p top-level-p)
 961   (unless top-level-p
 962     (warn "Provide form not at top-level."))
 963   (destructuring-bind (module-name &key load-priority)
 964       (cdr form)
 965     (declare (special *default-load-priority*))
 966     (pushnew module-name (image-movitz-modules *image*))
 967     (when load-priority
 968       (setf *default-load-priority* load-priority))
 969     (let ((new-priority *default-load-priority*))
 970       (let ((old-tf (member module-name (image-load-time-funobjs *image*) :key #'second)))
 971         (cond
 972          ((and new-priority old-tf)
 973           (setf (car old-tf) (list funobj module-name new-priority)))
 974          ((and new-priority (not old-tf))
 975           (push (list funobj module-name new-priority)
 976                 (image-load-time-funobjs *image*)))
 977          (old-tf
 978           (setf (car old-tf) (list funobj module-name (third (car old-tf)))))
 979          (t (warn "No existing or provided load-time priority for module ~S, will not be loaded!"
 980                   module-name))))))
 981   (compiler-values ()))
 982
 983 (define-special-operator eval-when (&all forward &form form &top-level-p top-level-p)
 984   (destructuring-bind (situations &body body)
 985       (cdr form)
 986     (multiple-value-prog1
 987         (if (or (member :execute situations)
 988                 (and (member :load-toplevel situations)
 989                      top-level-p))
 990             (compiler-call #'compile-implicit-progn
 991               :defaults forward
 992               :top-level-p top-level-p
 993               :form body)
 994           (compiler-values ()))
 995       (when (member :compile-toplevel situations)
 996         (with-compilation-unit ()
 997           (dolist (toplevel-form (translate-program body :muerte.cl :cl
 998                                                     :when :eval
 999                                                     :remove-double-quotes-p t))
1000             (with-host-environment ()
1001               (if *compiler-compile-eval-whens*
1002                   (funcall (compile () `(lambda () ,toplevel-form)))
1003                 (eval toplevel-form)))))))))
1004
1005 (define-special-operator function (&funobj funobj &form form &result-mode result-mode &env env)
1006   (destructuring-bind (name)
1007       (cdr form)
1008     (flet ((function-of-symbol (name)
1009              "Look up name in the local function namespace."
1010              (let ((movitz-name (movitz-read name))
1011                    (register (case result-mode
1012                                ((:ebx :ecx :edx) result-mode)
1013                                (t :eax))))
1014                (compiler-values ()
1015                  :code `((:load-constant ,movitz-name ,register)
1016                          (:movl (,register ,(bt:slot-offset 'movitz-symbol 'function-value))
1017                                 ,register)
1018                          (:globally (:cmpl (:edi (:edi-offset unbound-function))
1019                                            ,register))
1020                          (:je '(:sub-program ()
1021                                 (:load-constant ,movitz-name :edx)
1022                                 (:int 98))))
1023                  :modifies nil
1024                  :functional-p t
1025                  :type 'function
1026                  :returns register))))
1027       (etypecase name
1028         (null (error "Can't compile (function nil)."))
1029         (symbol
1030          (multiple-value-bind (binding)
1031              (movitz-operator-binding name env)
1032            (etypecase binding
1033              (null                      ; not lexically bound..
1034               (function-of-symbol name))
1035              (function-binding
1036               (compiler-values ()
1037                 :code (make-compiled-lexical-load binding result-mode)
1038                 :type 'function
1039                 :returns result-mode
1040                 :functional-p t))
1041              #+ignore
1042              (funobj-binding
1043               (let ((flet-funobj (funobj-binding-funobj binding)))
1044                 (assert (null (movitz-funobj-borrowed-bindings flet-funobj)))
1045                 (compiler-call #'compile-self-evaluating ; <name> is lexically fbound..
1046                   :env env
1047                   :funobj funobj
1048                   :result-mode result-mode
1049                   :form flet-funobj)))
1050              #+ignore
1051              ((or closure-binding borrowed-binding)
1052               (compiler-values ()
1053                 :code (make-compiled-lexical-load binding binding-env result-mode)
1054                 :type 'function
1055                 :returns result-mode
1056                 :functional-p t)))))
1057         ((cons (eql muerte.cl:setf))
1058          (function-of-symbol (movitz-env-setf-operator-name
1059                               (muerte::translate-program (second name)
1060                                                                 :cl :muerte.cl))))
1061         ((cons (eql muerte.cl:lambda))
1062          (multiple-value-bind (lambda-forms lambda-declarations)
1063              (parse-docstring-declarations-and-body (cddr name))
1064            (let ((lambda-funobj
1065                   (make-compiled-funobj-pass1 '(muerte.cl:lambda)
1066                                               (cadr name)
1067                                               lambda-declarations
1068                                               `(muerte.cl:progn ,@lambda-forms)
1069                                               env nil)))
1070              (let ((lambda-binding (make-instance 'lambda-binding
1071                                      :name (gensym "anonymous-lambda-")
1072                                      :parent-funobj funobj
1073                                      :funobj lambda-funobj)))
1074                (movitz-env-add-binding (find-function-env env funobj) lambda-binding)
1075                (let ((lambda-result-mode (accept-register-mode result-mode)))
1076                  (compiler-values ()
1077                    :type 'function
1078                    :functional-p t
1079                    :returns lambda-result-mode
1080                    :modifies nil
1081                    :code `((:load-lambda ,lambda-binding ,lambda-result-mode ,env))))))))))))
1082
1083 (define-special-operator flet (&all forward &form form &env env &funobj funobj)
1084   (destructuring-bind (flet-specs &body declarations-and-body)
1085       (cdr form)
1086     (multiple-value-bind (body declarations)
1087         (parse-declarations-and-body declarations-and-body)
1088       (let* ((flet-env (make-local-movitz-environment env funobj
1089                                                    :type 'operator-env
1090                                                    :declarations declarations))
1091              (init-code
1092               (loop for (flet-name flet-lambda-list . flet-dd-body) in flet-specs
1093                   as flet-binding =
1094                     (multiple-value-bind (flet-body flet-declarations flet-docstring)
1095                         (parse-docstring-declarations-and-body flet-dd-body)
1096                       (declare (ignore flet-docstring))
1097                       (let ((flet-funobj
1098                              (make-compiled-funobj-pass1 (list 'muerte.cl::flet
1099                                                                (movitz-funobj-name funobj)
1100                                                                flet-name)
1101                                                          flet-lambda-list
1102                                                          flet-declarations
1103                                                          (list* 'muerte.cl:block
1104                                                                 (compute-function-block-name flet-name)
1105                                                                 flet-body)
1106                                                          env nil)))
1107                         (when (find-if (lambda (declaration)
1108                                          (and (eq 'muerte.cl:dynamic-extent (car declaration))
1109                                               (member `(muerte.cl:function ,flet-name)
1110                                                       (cdr declaration)
1111                                                       :test #'equal)))
1112                                        declarations)
1113                           (setf (movitz-funobj-extent flet-funobj) :dynamic-extent)
1114                           (warn "dynamic-extent flet: ~S" flet-name))
1115                         (make-instance 'function-binding
1116                           :name flet-name
1117                           :parent-funobj funobj
1118                           :funobj flet-funobj)))
1119                   do (movitz-env-add-binding flet-env flet-binding)
1120                   collect `(:local-function-init ,flet-binding))))
1121         (compiler-values-bind (&all body-values &code body-code)
1122             (compiler-call #'compile-implicit-progn
1123               :defaults forward
1124               :form body
1125               :env flet-env)
1126           (compiler-values (body-values)
1127             :code (append init-code body-code)))))))
1128
1129 (define-special-operator progv (&all all &form form &funobj funobj &env env &result-mode result-mode)
1130   (destructuring-bind (symbols-form values-form &body body)
1131       (cdr form)
1132     (compiler-values-bind (&code body-code &returns body-returns)
1133         (let ((body-env (make-instance 'progv-env
1134                           :uplink env
1135                           :funobj funobj
1136                           :stack-used t
1137                           :num-specials t)))
1138           ;; amount of stack used and num-specials is not known until run-time.
1139           (compiler-call #'compile-implicit-progn
1140             :env body-env
1141             :result-mode (case result-mode
1142                            (:push :eax)
1143                            (:function :multiple-values)
1144                            (t result-mode))
1145             :form body
1146             :forward all))
1147       (compiler-values ()
1148         :returns (if (eq :push body-returns) :eax body-returns)
1149         :code (append (make-compiled-two-forms-into-registers symbols-form :ebx
1150                                                               values-form :eax
1151                                                               funobj env)
1152                       (with-labels (progv (no-more-symbols no-more-values loop zero-specials))
1153                         `((:xorl :ecx :ecx) ; count number of bindings (fixnum)
1154                           (:locally (:pushl (:edi (:edi-offset dynamic-env)))) ; first tail
1155                           (:cmpl :edi :ebx)
1156                           (:je '(:sub-program (,zero-specials)
1157                                  ;; Insert dummy binding
1158                                  (:pushl :edi) ; biding value
1159                                  (:pushl :edi) ; scratch
1160                                  (:pushl :edi) ; binding name
1161                                  (:pushl :esp)
1162                                  (:addl 4 :ecx)
1163                                  (:jmp ',no-more-symbols)))
1164                           ,loop
1165                           (:cmpl :edi :ebx) ; (endp symbols)
1166                           (:je ',no-more-symbols) ;  .. (go no-more-symbols)
1167                           (:globally (:movl (:edi (:edi-offset new-unbound-value)) :edx))
1168                           (:cmpl :edi :eax) ; (endp values)
1169                           (:je ',no-more-values) ; .. (go no-more-values)
1170                           (:movl (:eax -1) :edx)
1171                           (:movl (:eax 3) :eax) ; (pop values)
1172                           ,no-more-values
1173                           (:pushl :edx) ; push (car values) [[ binding value ]]
1174                           (:pushl :edi) ; push binding scratch
1175                           (:pushl (:ebx -1)) ; push (car symbols) [[ binding name ]]
1176                           (:movl (:ebx 3) :ebx) ; (pop symbols)
1177                           (:addl 4 :ecx)
1178                           (:pushl :esp) ; push next tail
1179                           (:jmp ',loop)
1180                           ,no-more-symbols
1181                           (:popl :eax)  ; remove extra pre-pushed tail
1182                           (:movl :ecx :edx)
1183                           (:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context
1184                                                                   'dynamic-variable-install))))
1185                           (:locally (:movl :esp (:edi (:edi-offset dynamic-env)))) ; install env
1186                           ;; ecx = N/fixnum
1187                           ;; (:shll 4 :ecx) ; ecx = 16*N
1188                           ;; (:leal (:esp :ecx -4) :eax) ; eax = esp + 16*N - 4
1189                           (:pushl :edx) ; Save number of bindings.
1190                           #+ignore (:pushl :eax))) ; push address of first binding's tail
1191                       body-code
1192                       (when (eq body-returns :push)
1193                         `((:popl :eax))) ; glue :push => :eax
1194                       `((:movl (:esp) :edx) ; number of bindings
1195                         (:movl (:esp (:edx 4)) :edx) ; previous dynamic-env
1196                         (:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context
1197                                                                 'dynamic-variable-uninstall))))
1198                         (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
1199                         (:popl :edx)    ; number of bindings
1200                         (:leal (:esp (:edx 4)) :esp)))))))
1201
1202 (define-special-operator labels (&all forward &form form &env env &funobj funobj)
1203   (destructuring-bind (labels-specs &body declarations-and-body)
1204       (cdr form)
1205     (multiple-value-bind (body declarations)
1206         (parse-declarations-and-body declarations-and-body)
1207       (let* ((labels-env (make-local-movitz-environment env funobj
1208                                                      :type 'operator-env
1209                                                      :declarations declarations))
1210              (labels-bindings
1211               (loop for (labels-name) in labels-specs
1212                   do (check-type labels-name symbol)
1213                   collecting
1214                     (movitz-env-add-binding labels-env (make-instance 'function-binding
1215                                                       :name labels-name
1216                                                       :funobj (make-instance 'movitz-funobj-pass1)
1217                                                       :parent-funobj funobj))))
1218              (init-code
1219               (loop for (labels-name labels-lambda-list . labels-dd-body) in labels-specs
1220                   as labels-binding in labels-bindings
1221                   do (multiple-value-bind (labels-body labels-declarations labels-docstring)
1222                          (parse-docstring-declarations-and-body labels-dd-body)
1223                        (declare (ignore labels-docstring))
1224                        (make-compiled-funobj-pass1 (list 'muerte.cl::labels
1225                                                          (movitz-funobj-name funobj)
1226                                                          labels-name)
1227                                                    labels-lambda-list
1228                                                    labels-declarations
1229                                                    (list* 'muerte.cl:block
1230                                                           (compute-function-block-name labels-name)
1231                                                           labels-body)
1232                                                    labels-env nil
1233                                                    :funobj (function-binding-funobj labels-binding)))
1234                   collect `(:local-function-init ,labels-binding))))
1235         (compiler-values-bind (&all body-values &code body-code)
1236             (compiler-call #'compile-implicit-progn
1237               :defaults forward
1238               :form body
1239               :env labels-env)
1240           (compiler-values (body-values)
1241             :code (append init-code body-code)))))))
1242
1243 (define-special-operator catch (&all forward &form form &funobj funobj &env env)
1244   (destructuring-bind (tag &rest forms)
1245       (cdr form)
1246     (let ((catch-env (make-instance 'simple-dynamic-env :uplink env :funobj funobj)))
1247       (compiler-values-bind (&all body-values &code body-code &returns body-returns)
1248           (compiler-call #'compile-form
1249             :env catch-env
1250             :result-mode :multiple-values
1251             :defaults forward
1252             :form `(muerte.cl:progn ,@forms))
1253         (multiple-value-bind (stack-used code)
1254             (make-compiled-catch-wrapper tag funobj env body-returns body-code)
1255           (incf (stack-used catch-env) stack-used)
1256           (compiler-values (body-values)
1257             :returns body-returns
1258             :type '(values &rest t)
1259             :code code))))))
1260
1261 (defun make-compiled-catch-wrapper (tag-form funobj env body-returns body-code)
1262   (assert (member body-returns '(:multiple-values :non-local-exit)))
1263   (values 4                             ; stack-used, must be added to body-code's env.
1264           (with-labels (catch (label-set exit-point))
1265             (append `((:declare-label-set ,label-set (,exit-point))
1266                       (:locally (:pushl (:edi (:edi-offset dynamic-env)))) ; push dynamic-env
1267                       (:pushl ',label-set))
1268                     (compiler-call #'compile-form
1269                       :env env
1270                       :with-stack-used 2
1271                       :funobj funobj
1272                       :form tag-form
1273                       :result-mode :push)
1274                     `((:pushl :ebp)     ; push stack frame
1275                       (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))) ; install catch
1276                     body-code
1277                     `(,exit-point
1278                       (:movl (:esp) :ebp)
1279                       (:movl (:esp 12) :edx)
1280                       (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
1281                       (:leal (:esp 16) :esp)
1282                       )))))
1283
1284 (define-special-operator unwind-protect (&all all &form form &env env)
1285   (destructuring-bind (protected-form &body cleanup-forms)
1286       (cdr form)
1287     (if (null cleanup-forms)
1288         (compiler-call #'compile-form-unprotected
1289           :forward all
1290           :form protected-form)
1291       (let* ((continuation-env (make-instance 'let-env
1292                                  :uplink env
1293                                  :funobj (movitz-environment-funobj env)))
1294              (next-continuation-step-binding
1295               (movitz-env-add-binding continuation-env
1296                                       (make-instance 'located-binding
1297                                         :name (gensym "up-next-continuation-step-"))))
1298              (unwind-protect-env (make-instance 'unwind-protect-env
1299                                    :cleanup-form (cons 'muerte.cl:progn cleanup-forms)
1300                                    :uplink continuation-env
1301                                    :funobj (movitz-environment-funobj env))))
1302         (with-labels (unwind-protect (cleanup-label cleanup-entry continue continue-label))
1303           (compiler-values ()
1304             :returns :multiple-values
1305             :code (append
1306                    ;; install default continuation dynamic-env..
1307                    `((:locally (:pushl (:edi (:edi-offset dynamic-env))))
1308                      (:declare-label-set ,cleanup-label (,cleanup-entry))
1309                      (:declare-label-set ,continue-label (,continue))
1310                      (:pushl ',cleanup-label) ; jumper index
1311                      (:globally (:pushl (:edi (:edi-offset unwind-protect-tag)))) ; tag
1312                      (:pushl :ebp)      ; stack-frame
1313                      (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))) ; install up-env
1314                    ;; Execute protected form..
1315                    (compiler-call #'compile-form
1316                      :env unwind-protect-env
1317                      :with-stack-used t ;; XXX Not really true, is it?
1318                      :forward all
1319                      :result-mode :multiple-values
1320                      :form protected-form)
1321                    ;; From now on, take care not to touch current-values from protected-form.
1322                    `((:locally (:movl :esp (:edi (:edi-offset raw-scratch0))))
1323                      ,cleanup-entry
1324                      ;; First, restore stack-frame in EBP
1325                      (:movl (:esp) :ebp)
1326                      ;; Now, modify unwind-protect dyn-env-entry to be normal continuation
1327                      (:locally (:movl (:edi (:edi-offset unbound-function)) :edx))
1328                      (:movl :edx (:esp 4)) ; not unwind-protect-tag
1329                      (:movl ',continue-label (:esp 8)) ; new jumper index
1330
1331                      (:locally (:pushl (:edi (:edi-offset raw-scratch0))))) ; push final-continuation
1332                    ;; Execute cleanup-forms.
1333                    (compiler-call #'compile-form-unprotected
1334                      :forward all
1335                      :env continuation-env
1336                      :with-stack-used t
1337                      :result-mode :multiple-values
1338                      :form `(muerte::with-cloak (:multiple-values)
1339                               ;; Inside here we don't have to mind current-values.
1340                               (muerte::with-inline-assembly (:returns :nothing)
1341                                 ;; First, save final-continuation across cleanup-forms.
1342                                 (:locally (:pushl (:edi (:edi-offset raw-scratch0)))))
1343                               ,@cleanup-forms
1344                               (muerte::with-inline-assembly (:returns :nothing)
1345                                 ;; Now, find next-continuation-step..
1346                                 (:popl :eax) ; final-continuation
1347                                 (:locally (:call (:edi (:edi-offset dynamic-unwind-next))))
1348                                 (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax))
1349                                 (:store-lexical ,next-continuation-step-binding :eax :type t))))
1350                    `((:locally (:popl (:edi (:edi-offset raw-scratch0)))) ; pop final continuation
1351                      (:load-lexical ,next-continuation-step-binding :edx)
1352                      (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
1353                      (:locally (:call (:edi (:edi-offset dynamic-jump-next))))
1354                      ,continue
1355                      (:movl (:esp) :ebp)
1356                      (:movl (:esp 12) :edx)
1357                      (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
1358                      (:leal (:esp 16) :esp)))))))))
1359
1360 (define-special-operator if (&all all &form form &env env &result-mode result-mode)
1361   (destructuring-bind (test-form then-form &optional else-form)
1362       (cdr form)
1363     (compiler-values-bind (&all then)
1364         (compiler-call #'compile-form-unprotected
1365           :forward all
1366           :form then-form)
1367       (compiler-values-bind (&all else)
1368           (compiler-call #'compile-form-unprotected
1369             :forward all
1370             :form else-form)
1371         #+ignore (warn "p1: ~S/~S/~S, p2: ~S/~S/~S"
1372                        (then :producer) (then :final-form) (then :modifies)
1373                        (else :producer) (else :final-form) (else :modifies))
1374         (cond
1375          ((and (eq result-mode :ignore)
1376                (then :functional-p)
1377                (else :functional-p))
1378           (compiler-call #'compile-form-unprotected
1379             :forward all
1380             :form test-form))
1381          #+ignore
1382          ((and (valid-finals (then :final-form) (else :final-form))
1383                (equal (then :final-form) (else :final-form)))
1384           (warn "if's then and else are equal: ~S both were ~S." form (then :final-form))
1385           (compiler-call #'compile-form-unprotected
1386             :forward all
1387             :form `(muerte.cl:progn ,test-form ,then-form)))
1388          ;; ((
1389          #+ignore
1390          ((and (typep (then :final-form) 'movitz-immediate-object)
1391                (typep (else :final-form) 'movitz-immediate-object))
1392           (let ((then-value (movitz-immediate-value (then :final-form)))
1393                 (else-value (movitz-immediate-value (else :final-form)))
1394                 (true-label (gensym "if-true-")))
1395             (warn "immediate if: ~S vs. ~S"
1396                   then-value else-value)
1397             (compiler-values-bind (&all test)
1398                 (compiler-call #'compile-form
1399                   :forward all
1400                   :form test-form
1401                   :result-mode (cons :boolean-branch-on-true true-label))
1402               (compiler-values (test)
1403                 :code (append (test :code)
1404                               (make-immediate-move then-value :eax)
1405                               (make-immediate-move else-value :eax)
1406                               (list true-label))
1407                 :returns :eax))))
1408          (t (compiler-call #'compile-form-unprotected
1409               :forward all
1410               :form `(muerte::compiled-cond
1411                       (,test-form ,then-form)
1412                       (muerte.cl::t ,else-form)))))))))
1413
1414 (define-special-operator the (&all all &form form)
1415   (destructuring-bind (value-type sub-form)
1416       (cdr form)
1417     (compiler-values-bind (&all sub-form)
1418         (compiler-call #'compile-form-unprotected
1419           :forward all
1420           :form sub-form)
1421       (compiler-values (sub-form)
1422         :type value-type))))