src/lsp/compiler/gencode.lsp

   1 (in-package "XLSCMP")
   2
   3 #|
   4 clean up, reduce use of global/special variables
   5 clean up, separate out initialisation code generation
   6 implement large case with hashtable?
   7
   8 need to test %catch-tagbody with changes
   9
  10 think about implementation of mvcall -- alternative to %mv-collect
  11
  12 simplifyer rules: drop unused variables from continuations?
  13 be carefull about unused vs real multiple values (for dropping no side eff.)
  14 constant folded version of nth-value?
  15 push code generaotr test into simplifier?
  16
  17 need to recheck calling, test calling speed
  18 |#
  19
  20 #|
  21 Value registers of zero are used to communicate that values should
  22 (only) be stored in the multiple value array. This should work OK since
  23 the zero register is reserved for the real final value continuation.
  24
  25 Continuations are represented in two parts. Part lives in the
  26 continuation stack, part on the value stack. The value stack part may
  27 be shared -- this is true for the local calls generated by things like
  28 unwind-protect. These local functions cannot overlay their call frame
  29 on a tail call, since that would clobber the part on the value stack.
  30 The byte code interpreter checks for this possibility by checking
  31 whether the current call stack part of the framt is identical to the
  32 one for the next continuation on the stack.
  33 |#
  34
  35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36 ;;;;;
  37 ;;;;;                            Code Generator
  38 ;;;;;
  39 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  40
  41 (defvar *code*)
  42 (defvar *literals*)
  43 (defvar *functions*)
  44 (defvar *labels*)
  45 (defvar *registers*)
  46 (defvar *constants*)
  47 (defvar *protected-continuations*)
  48
  49 (defun generate-code (pieces)
  50   (let ((*code* nil)
  51         (*literals* nil)
  52         (*functions* nil)
  53         (*labels* nil))
  54     (initialize-functions pieces)
  55     (dolist (p pieces)
  56       (let ((label (make-label (first p)))
  57             (code (second p)))
  58         (push-label (first p))
  59         (generate-lambda-code label code)))
  60     (peephole-optimize (list (reverse *code*)
  61                              (reverse *literals*)
  62                              (get-function-label (first (first pieces)))
  63                              nil
  64                              (nreverse (mapcar #'second *functions*)))
  65                        (get-function-labels))))
  66
  67 (defun generate-lambda-code (label n)
  68   (let ((*registers* nil)
  69         (*constants* nil)
  70         (*protected-continuations* nil))
  71     (assign-registers n)
  72     ;;**** clean this up!!
  73     (let* ((consts (nreverse *constants*))
  74            (ainfo (lambda-node-lambda-list n))
  75            (nc (length consts))
  76            (nv (lambda-list-num-variables ainfo))
  77            (nr (count-registers))
  78            (nreq (first ainfo))
  79            (nopt (second ainfo))
  80            (odef (coerce (third ainfo) 'vector))
  81            (allow-keys (fourth ainfo))
  82            (rest (sixth ainfo)))
  83       (cond
  84        ((and (= nopt 0) (not allow-keys) (not rest))
  85         (push-instruction `(%initialize-0 ,nreq ,nc ,@consts ,(- nr nv nc))))
  86        ((and (not allow-keys) (not rest))
  87         (let ((ol (add-literal (make-constant-node `(quote ,odef)))))
  88           (push-instruction
  89            `(%initialize 1 ,nreq ,nopt ,ol ,nc ,@consts ,(- nr nv nc)))))
  90        ((not allow-keys)
  91         (if (< 0 nopt)
  92             (let ((ol (add-literal (make-constant-node `(quote ,odef)))))
  93               (push-instruction
  94                `(%initialize 2 ,nreq ,nopt ,ol ,nc ,@consts ,(- nr nv nc))))
  95           (push-instruction
  96            `(%initialize 2 ,nreq ,nopt ,nc ,@consts ,(- nr nv nc)))))
  97        (t
  98         (let* ((kdefs (fifth ainfo))
  99                (allow-other-keys (seventh ainfo))
 100                (ksyms (eighth ainfo))
 101                (kdl (add-literal (make-constant-node `(quote ,kdefs))))
 102                (ksl (add-literal (make-constant-node `(quote ,ksyms))))
 103                (aok (if allow-other-keys 1 0))
 104                (r (if rest 1 0)))
 105           (if (< 0 nopt)
 106               (let ((ol (add-literal (make-constant-node `(quote ,odef)))))
 107                 (push-instruction
 108                  `(%initialize 3 ,nreq ,nopt ,ol ,r ,aok ,ksl ,kdl
 109                                ,nc ,@consts ,(- nr nv nc))))
 110               (push-instruction
 111                `(%initialize 3 ,nreq ,nopt ,r ,aok ,ksl ,kdl
 112                              ,nc ,@consts ,(- nr nv nc))))))))
 113     (set-function-data-registers (get-function-data label) (register-map))
 114     (generate-body-code (lambda-node-body n))))
 115
 116 (defun generate-body-code (form)
 117   (do ((trees (list form)))
 118       ((null trees))
 119       (let ((p (first trees)))
 120         (setf trees
 121               (cond
 122                ((leaf-node-p p) (push-label p) (rest trees))
 123                ((leaf-node-p (call-node-function p))
 124                 (generate-symbol-call-code p (rest trees)))
 125                (t (generate-lambda-call-code p (rest trees))))))))
 126
 127 (defun lifted-lfun-node-p (n) (and (leaf-node-p n) (get-function-label n)))
 128
 129 (defun generate-symbol-call-code (n rest)
 130   (let ((f (call-node-function n)))
 131     (cond
 132      ((gfun-node-p f) (generate-gfun-call-code n rest))
 133      ((lifted-lfun-node-p f) (generate-lfun-call-code n rest))
 134      (t (generate-continuation-call-code n rest)))))
 135
 136 (defun generate-lambda-call-code (n rest)
 137   (let* ((f (call-node-function n))
 138          (alist (lambda-node-arglist f))
 139          (body (lambda-node-body f))
 140          (args (call-node-args n)))
 141     (mapc #'(lambda (x y)
 142               (unless (leaf-node-p y)
 143                       (push (lambda-node-body y) rest)
 144                       (push x rest)))
 145           alist
 146           args)
 147     (push body rest)
 148     rest))
 149
 150
 151 (defun generate-gfun-call-code (n rest)
 152   (let* ((f (call-node-function n))
 153          (cg (get-code-generator (gfun-symbol f) n)))
 154     (if cg
 155         (funcall cg n rest)
 156         (let* ((c (get-continuation (call-node-arg n 0)))
 157                (aregs (mapcar #'find-register (rest (call-node-args n))))
 158                (na (length aregs))
 159                (s (add-literal f)))
 160           (if (final-value-continuation-p c)
 161               (let ((cr (continuation-register c)))
 162                 (push-instruction `(%call ,s ,cr ,na ,@aregs)))
 163               (let ((vr (continuation-value-register c)))
 164                 (push-instruction `(%save-call ,s ,vr ,na ,@aregs))))
 165           (cleanup-continuation c rest nil)))))
 166
 167 (defun generate-lfun-call-code (n rest)
 168   (let* ((f (call-node-function n))
 169          (c (get-continuation (call-node-arg n 0)))
 170          (aregs (mapcar #'find-register (rest (call-node-args n))))
 171          (na (length aregs))
 172          (s (get-function-label f)))
 173     (if (final-value-continuation-p c)
 174         (let ((cr (continuation-register c)))
 175           (push-instruction `(%lcall ,s ,cr ,na ,@aregs)))
 176         (let ((vr (continuation-value-register c)))
 177           (push-instruction `(%save-lcall ,s ,vr ,na ,@aregs))))
 178     (cleanup-continuation c rest nil)))
 179
 180 ;;**** needs to be thought through relative to %y
 181 (defun generate-continuation-call-code (n rest)
 182   (let ((c (get-continuation (call-node-function n))))
 183     (case (continuation-type c)
 184      (final-value
 185       (let ((cr (continuation-register c))
 186             (vr (find-register (call-node-arg n 0))))
 187         (push-instruction `(%set-one-value ,vr))
 188         (push-instruction `(%return ,cr))))
 189      ((protected multiple-value)
 190       (let ((aregs (mapcar #'find-register (call-node-args n))))
 191         (cond
 192          ((= (length aregs) 1)
 193           (push-instruction `(%set-one-value ,@aregs)))
 194          (t (warn "multiple value continuation in callposition ~
 195                    with more than one argument")
 196             (push-instruction `(%set-values ,(length aregs) ,@aregs))))))
 197      (t
 198       (let* ((fsym (continuation-name c))
 199              (f (continuation-function c))
 200              (b (lambda-node-body f))
 201              (vars (lambda-node-arglist f))
 202              (vals (call-node-args n)))
 203         (mapc #'(lambda (x y)
 204                   (when (any-references-p y b)
 205                         (let ((xr (find-register x))
 206                               (yr (find-register y)))
 207                           (push-instruction `(%copy ,xr ,yr)))))
 208               vals
 209               vars)
 210         (push-instruction `(%goto ,(make-label fsym))))))
 211     (cleanup-continuation c rest nil)))
 212
 213
 214 ;;;;
 215 ;;;; Function Information Representation
 216 ;;;;
 217
 218 (defun initialize-functions (pieces)
 219   (dolist (p pieces)
 220     (let* ((label (make-label (first p)))
 221            (d (make-function-data label (leaf-node-value (first p)))))
 222       (push (list label d) *functions*))))
 223
 224 (defun make-function-data (label name) (list label name nil))
 225
 226 (defun get-function-data (label) (second (assoc label *functions*)))
 227 (defun get-function-label (f) (first (assoc (make-label f) *functions*)))
 228 (defun get-function-labels () (mapcar #'first *functions*))
 229
 230 (defun set-function-data-registers (fd r) (setf (third fd) r))
 231
 232
 233 ;;;;
 234 ;;;; Continuation Handling
 235 ;;;;
 236
 237 (defun get-continuation (n)
 238   (if (lambda-node-p n)
 239       (cons nil n)
 240       (let ((cf (find-lambda-binding n)))
 241         (cons n (if cf
 242                     cf
 243                     (if (member n *protected-continuations*)
 244                         'protected
 245                         'final))))))
 246
 247 (defun register-protected-continuation (k)
 248   (pushnew k *protected-continuations*))
 249
 250 (defun immediate-continuation-p (c)
 251   (and (lambda-node-p (cdr c)) (null (continuation-name c))))
 252
 253 (defun continuation-value-ignored-p (c)
 254   (and (not (multiple-value-continuation-p c))
 255        (or (null (lambda-node-arglist (cdr c)))
 256            (not (any-references-p (first (lambda-node-arglist (cdr c)))
 257                                   (cdr c))))))
 258
 259 (defun final-value-continuation-p (c) (eq (cdr c) 'final))
 260
 261 (defun protected-continuation-p (c) (eq (cdr c) 'protected))
 262
 263 (defun continuation-register (c) (if (car c) (find-register (car c))))
 264
 265 (defun multiple-value-continuation-p (c)
 266   (multiple-value-continuation-node-p (cdr c)))
 267
 268 (defun continuation-value-register (c)
 269   (if (and (lambda-node-p (cdr c))
 270            (not (continuation-value-ignored-p c))
 271            (not (multiple-value-continuation-p c)))
 272       (find-register (first (lambda-node-arglist (cdr c))))
 273       0))
 274
 275 (defun continuation-name (c) (car c))
 276 (defun continuation-function (c) (if (lambda-node-p (cdr c)) (cdr c)))
 277
 278 (defun continuation-type (c)
 279   (cond
 280    ((final-value-continuation-p c) 'final-value)
 281    ((protected-continuation-p c) 'protected)
 282    ((multiple-value-continuation-p c) 'multiple-value)
 283    ((continuation-value-ignored-p c) 'value-ignored)
 284    (t 'one-value)))
 285
 286 (defun cleanup-continuation (c rest inline)
 287   (if (final-value-continuation-p c)
 288       (if inline
 289           (let ((cr (continuation-register c)))
 290             (push-instruction `(%return ,cr))))
 291       (if (immediate-continuation-p c)
 292           (push (lambda-node-body (cdr c)) rest)
 293           (push-instruction `(%goto ,(make-label (continuation-name c))))))
 294   rest)
 295
 296
 297 ;;;;
 298 ;;;; Register Handling
 299 ;;;;
 300
 301 (defun find-register (v)
 302   (let ((e (assoc v *registers*)))
 303     (if e (cdr e) (error "register not found"))))
 304
 305 (defun assign-registers (n)
 306   (assign-registers-1 (lambda-node-body n)
 307                       (add-lambda-frame (lambda-node-arglist n) nil)))
 308
 309 (defun pop-unused-frames (env n)
 310   (let ((frame (first env)))
 311     (if (and frame
 312              (eq (cdr frame) 'continuation)
 313              (every #'(lambda (x) (not (any-references-p x n))) (car frame)))
 314         (pop-unused-frames (cdr env) n)
 315         env)))
 316
 317 (defun setq-continuation-p (n)
 318   (if (continuation-node-p n)
 319       (let* ((b (lambda-node-body n))
 320              (f (call-node-function b)))
 321         (if (and (gfun-eq f '%setq) (= (length (lambda-node-arglist n)) 1))
 322             (let ((v (first (lambda-node-arglist n)))
 323                   (c (call-node-arg b 0)))
 324               (and (eq v (call-node-arg b 2))
 325                    (assoc (call-node-arg b 1) *registers*)
 326                    (not (any-references-p v c))))))))
 327
 328 (defun add-register-frame (vars type env)
 329   (let ((maxreg 0))
 330     (dolist (e env) (incf maxreg (length (car e))))
 331     (dolist (v vars)
 332       (push (cons v maxreg) *registers*)
 333       (incf maxreg))
 334     (cons (cons vars type) env)))
 335
 336 (defun add-lambda-frame (vars env) (add-register-frame vars 'lambda env))
 337
 338 (defun add-continuation-frame (n env)
 339   (if (setq-continuation-p n)
 340       (let ((v (first (lambda-node-arglist n)))
 341             (vv (call-node-arg (lambda-node-body n) 1)))
 342         (push (cons v (cdr (assoc vv *registers*))) *registers*)
 343         (pop-unused-frames env n))
 344       (let ((alist (lambda-node-arglist n))
 345             (b (lambda-node-body n)))
 346         (if (and (not (multiple-value-continuation-node-p n))
 347                  (some #'(lambda (x) (any-references-p x b)) alist))
 348             (add-register-frame alist
 349                                 'continuation
 350                                 (pop-unused-frames env n))
 351             (pop-unused-frames env n)))))
 352
 353 (defun assign-registers-1 (n env)
 354   (let ((f (call-node-function n))
 355         (args (call-node-args n)))
 356     (setf env (pop-unused-frames env n)) ;;**** is this OK?
 357     (when (lambda-node-p f)
 358           (let ((nfvars nil))
 359             (mapc #'(lambda (x y)
 360                       (unless (lambda-node-p y)
 361                               (push x nfvars)
 362                               (push (add-literal y) *constants*)))
 363                   (lambda-node-arglist f)
 364                   args)
 365             ;;**** think about this -- should only have non-nil nfvars once
 366             (assign-registers-1 (lambda-node-body f)
 367                                     (add-lambda-frame (nreverse nfvars) env))))
 368     (if (gfun-eq f '%y)
 369         (assign-registers-1 (lambda-node-body (call-node-arg n 0)) env)
 370         (let ((is-y-list (gfun-eq f '%y-list)))
 371           (dolist (a args)
 372             (when (lambda-node-p a)
 373               (let ((new-env (if (and (continuation-node-p a) (not is-y-list))
 374                                  (add-continuation-frame a env)
 375                                  (add-lambda-frame (lambda-node-arglist a)
 376                                                    env))))
 377                 (assign-registers-1 (lambda-node-body a) new-env))))))))
 378
 379 (defun count-registers ()
 380   (let ((n 0))
 381     (dolist (r *registers* n)
 382       (setf n (max n (+ (cdr r) 1))))))
 383
 384 (defun register-map ()
 385   (flet ((rsym (x) (if (symbolp x) x (leaf-node-value x))))
 386     (let ((regs nil))
 387       (dolist (r *registers*)
 388         (let* ((v (rsym (car r)))
 389                (i (cdr r))
 390                (e (assoc i regs)))
 391           (if e (pushnew v (rest e)) (push (list i v) regs))))
 392       (sort regs #'(lambda (x y) (< (first x) (first y)))))))
 393
 394
 395 ;;;;
 396 ;;;; Instruction Representation
 397 ;;;;
 398
 399 (defun make-label (v)
 400   (let ((e (assoc v *labels*)))
 401     (if e
 402         (cdr e)
 403         (let ((s (gensym (string (leaf-node-value v)))))
 404           (push (cons v s) *labels*)
 405           s))))
 406
 407 (defun make-label-node (&optional (label "LABEL"))
 408   (make-leaf-node (gensym (string label))))
 409
 410 (defun push-label (v) (push (make-label v) *code*))
 411 (defun push-instruction (i) (push i *code*))
 412
 413
 414 ;;;;
 415 ;;;; Literals Representation
 416 ;;;;
 417
 418 (defun next-literal-index () (length *literals*))
 419
 420 (defun literal-value (v)
 421   (let ((c (leaf-node-value v)))
 422     (if (and (consp c) (eq (first c) 'quote)) (second c) c)))
 423
 424 (defun push-literal (v)
 425   (let ((n (next-literal-index)))
 426     (push (literal-value v) *literals*)
 427     n))
 428
 429 (defun add-literal (c) (add-literal-value (literal-value c)))
 430
 431 (defun add-literal-value (v)
 432   (let ((p (position v *literals*)))
 433     (if p
 434         (- (length *literals*) p 1)
 435         (prog1 (length *literals*) (push v *literals*)))))
 436
 437
 438 ;;;;
 439 ;;;; Code Generator Support for Special Instuctions
 440 ;;;;
 441
 442 (defun get-code-generator (s n)
 443   (let* ((e (get s 'cmp-code-generator))
 444          (test (first e))
 445          (f (second e)))
 446     (if test (if (funcall test n) f) f)))
 447
 448 (defun set-code-generator (s g)
 449   (let ((e (get s 'cmp-code-generator)))
 450     (if e
 451         (setf (second e) g)
 452         (setf (get s 'cmp-code-generator) (list nil g)))))
 453
 454 (defun set-code-generator-test (s g)
 455   (let ((e (get s 'cmp-code-generator)))
 456     (if e
 457         (setf (first e) g)
 458         (setf (get s 'cmp-code-generator) (list g nil)))))
 459
 460 (defmacro define-code-generator (sym &rest body)
 461   `(set-code-generator ',sym #'(lambda ,@body)))
 462
 463 (defmacro define-code-generator-test (sym &rest body)
 464   `(set-code-generator-test ',sym #'(lambda ,@body)))
 465
 466 (defun generate-inline-function-code (f n rest)
 467   (let* ((c (get-continuation (call-node-arg n 0)))
 468          (vr (continuation-value-register c))
 469          (args (rest (call-node-args n))))
 470     (funcall f args vr)
 471     (cleanup-continuation c rest t)))
 472
 473 (defmacro define-inline-function-generator (sym &rest body)
 474   `(define-code-generator ,sym (n rest)
 475      (generate-inline-function-code #'(lambda ,@body) n rest)))
 476
 477 (defmacro define-standard-inline-generator (sym &optional
 478                                                 (name sym)
 479                                                 (llist nil llist-supplied))
 480   `(progn
 481      ,@(if llist-supplied `((define-lambda-list ,sym ,llist)))
 482      (define-inline-function-generator ,sym (args r)
 483      (push-instruction
 484       (cons ',name (append (mapcar #'find-register args) (list r)))))))
 485
 486 (defmacro define-standard-inline-generator-2 (sym &rest args)
 487   `(progn
 488      (define-standard-inline-generator ,sym ,@args)
 489      (define-code-generator-test ,sym (n) (= (call-node-arg-count n) 3))))
 490
 491 (defmacro define-test-code-generator-1 (name opcode)
 492   `(define-code-generator ,name (n rest)
 493      (let* ((cons (call-node-arg n 0))
 494             (alt (call-node-arg n 1))
 495             (vr (find-register (call-node-arg n 2)))
 496             (clab (if (lambda-node-p cons) (make-label-node "THEN") cons))
 497             (alab (if (lambda-node-p alt) (make-label-node "ELSE") alt)))
 498        (push-instruction
 499         (list '%test-1 ,opcode (make-label clab) (make-label alab) vr))
 500        (when (lambda-node-p alt)
 501              (push (lambda-node-body alt) rest)
 502              (push alab rest))
 503        (when (lambda-node-p cons)
 504              (push (lambda-node-body cons) rest)
 505              (push clab rest))
 506        rest)))
 507
 508 (defmacro define-test-code-generator-2 (name opcode)
 509   `(define-code-generator ,name (n rest)
 510      (let* ((cons (call-node-arg n 0))
 511             (alt (call-node-arg n 1))
 512             (vr1 (find-register (call-node-arg n 2)))
 513             (vr2 (find-register (call-node-arg n 3)))
 514             (clab (if (lambda-node-p cons) (make-label-node "THEN") cons))
 515             (alab (if (lambda-node-p alt) (make-label-node "ELSE") alt)))
 516        (push-instruction
 517         (list '%test-2 ,opcode (make-label clab) (make-label alab) vr1 vr2))
 518        (when (lambda-node-p alt)
 519              (push (lambda-node-body alt) rest)
 520              (push alab rest))
 521        (when (lambda-node-p cons)
 522              (push (lambda-node-body cons) rest)
 523              (push clab rest))
 524        rest)))
 525
 526
 527 (defmacro define-test-arith-code-generator-2 (name opcode)
 528   `(define-code-generator ,name (n rest)
 529      (let* ((cons (call-node-arg n 0))
 530             (alt (call-node-arg n 1))
 531             (vr1 (find-register (call-node-arg n 2)))
 532             (vr2 (find-register (call-node-arg n 3)))
 533             (clab (if (lambda-node-p cons) (make-label-node "THEN") cons))
 534             (alab (if (lambda-node-p alt) (make-label-node "ELSE") alt)))
 535        (push-instruction
 536         (list '%test-arith-2
 537               ,(char-int opcode)
 538               (make-label clab)
 539               (make-label alab)
 540               vr1
 541               vr2))
 542        (when (lambda-node-p alt)
 543              (push (lambda-node-body alt) rest)
 544              (push alab rest))
 545        (when (lambda-node-p cons)
 546              (push (lambda-node-body cons) rest)
 547              (push clab rest))
 548        rest)))
 549
 550 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 551 ;;;;;
 552 ;;;;;                       Specific Code Generators
 553 ;;;;;
 554 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 555
 556 ;;;;
 557 ;;;; Test/Case Code Generators
 558 ;;;;
 559
 560 (define-test-code-generator-1 %test 0)
 561 (define-test-code-generator-1 %test-consp 1)
 562 (define-test-code-generator-1 %test-supplied-p 2)
 563 (define-test-code-generator-1 %test-endp 3)
 564
 565 (define-test-code-generator-2 %test-eq    0)
 566 (define-test-code-generator-2 %test-eql   1)
 567 (define-test-code-generator-2 %test-equal 2)
 568
 569 (define-test-arith-code-generator-2 %test=  #\=)
 570 (define-test-arith-code-generator-2 %test/= #\#)
 571 (define-test-arith-code-generator-2 %test<  #\<)
 572 (define-test-arith-code-generator-2 %test>  #\>)
 573 (define-test-arith-code-generator-2 %test<= #\L)
 574 (define-test-arith-code-generator-2 %test>= #\G)
 575
 576 (define-code-generator %case (n rest)
 577   (let* ((var (find-register (call-node-arg n 0)))
 578          (choices (find-register (call-node-arg n 1)))
 579          (actions (rest (rest (call-node-args n))))
 580          (labels nil))
 581     (dolist (a actions)
 582       (cond
 583        ((lambda-node-p a)
 584         (let ((lab (make-label-node "CASE")))
 585           (push (lambda-node-body a) rest)
 586           (push lab rest)
 587           (push (make-label lab) labels)))
 588        (t (push (make-label a) labels))))
 589     (push-instruction `(%case ,var ,choices ,@(reverse labels)))
 590     rest))
 591
 592
 593 ;;;;
 594 ;;;; Multiple Value Code Generators
 595 ;;;;
 596
 597 (define-code-generator %mvc (n rest)
 598   (let ((c (get-continuation (call-node-arg n 0)))
 599         (f (call-node-arg n 1)))
 600     (if (final-value-continuation-p c)
 601         (let ((cr (continuation-register c)))
 602           (cond
 603            ((gfun-node-p f)
 604             (push-instruction `(%mvcall ,(add-literal f) ,cr)))
 605            ((lifted-lfun-node-p f)
 606             (push-instruction `(%mvlcall ,(get-function-label f) ,cr)))
 607            (t
 608             (push-instruction `(%mvvcall ,(find-register f) ,cr)))))
 609         (let ((vr (continuation-value-register c)))
 610           (cond
 611            ((gfun-node-p f)
 612             (push-instruction `(%save-mvcall ,(add-literal f) ,vr)))
 613            ((lifted-lfun-node-p f)
 614             (push-instruction `(%save-mvlcall ,(get-function-label f) ,vr)))
 615            (t
 616             (push-instruction `(%save-mvvcall ,(find-register f) ,vr))))))
 617     (cleanup-continuation c rest nil)))
 618
 619 ;;**** is the continuation necessarily both immediate and not multiple value?
 620 (define-code-generator %mvcc (n rest)
 621   (let* ((k (call-node-arg n 0))
 622          (alist (lambda-node-arglist k))
 623          (b (lambda-node-body k)))
 624     (if (some #'(lambda (x) (any-references-p x b)) alist)
 625         (let ((vregs (mapcar #'find-register alist)))
 626           (push-instruction `(%get-values ,(length vregs) ,@vregs))))
 627     (cons b rest)))
 628
 629 (define-code-generator values (n rest)
 630   (let* ((c (get-continuation (call-node-arg n 0)))
 631          (aregs (mapcar #'find-register (rest (call-node-args n))))
 632          (r (continuation-value-register c)))
 633     ;;**** check number of values against limit
 634     (push-instruction `(%set-values ,(length aregs) ,@aregs))
 635     (unless (= r 0)
 636             (warn "VALUES occurred in non-multiple value continuations")
 637             (push-instruction `(%get-one-value ,r)))
 638     (cleanup-continuation c rest t)))
 639
 640 (define-code-generator values-list (n rest)
 641   (let* ((c (get-continuation (call-node-arg n 0)))
 642          (ar (find-register (call-node-arg n 1)))
 643          (r (continuation-value-register c)))
 644     (push-instruction `(%set-values-list ,ar))
 645     (unless (= r 0)
 646             (warn "VALUES-LIST occurred in non-multiple value continuations")
 647             (push-instruction `(%get-one-value ,r)))
 648     (cleanup-continuation c rest t)))
 649
 650
 651 ;;;;
 652 ;;;; Catch/Throw/Unwind-Protect Code Generators
 653 ;;;;
 654
 655 (defun cleanup-protected-continuation (label c rest)
 656   (push label rest)
 657   (let ((r (continuation-value-register c)))
 658     (unless (= r 0) (push-instruction `(%get-one-value ,r))))
 659   (cleanup-continuation c rest t))
 660
 661 (define-code-generator %catch (n rest)
 662   (let* ((c (get-continuation (call-node-arg n 0)))
 663          (tr (find-register (call-node-arg n 1)))
 664          (form-fun (call-node-arg n 2))
 665          (fb (lambda-node-body form-fun))
 666          (fv (first (lambda-node-arglist form-fun)))
 667          (fr (find-register fv))
 668          (label (make-label-node "C")))
 669     (push-instruction `(%catch ,tr ,(make-label label) ,fr))
 670     (push fb rest)
 671     (cleanup-protected-continuation label c rest)))
 672
 673 (define-code-generator %throw (n rest)
 674   (let ((tr (find-register (call-node-arg n 0))))
 675     (push-instruction `(%throw ,tr))
 676     rest))
 677
 678 (define-code-generator %catch-block (n rest)
 679   (let* ((c (get-continuation (call-node-arg n 0)))
 680          (nr (find-register (call-node-arg n 1)))
 681          (form-fun (call-node-arg n 2))
 682          (fb (lambda-node-body form-fun))
 683          (fv (first (lambda-node-arglist form-fun)))
 684          (fr (find-register fv))
 685          (ftr (find-register (second (lambda-node-arglist form-fun))))
 686          (label (make-label-node "C")))
 687     (push-instruction `(%catch-block ,nr ,(make-label label) ,fr ,ftr))
 688     (push fb rest)
 689     (cleanup-protected-continuation label c rest)))
 690
 691 (define-code-generator %throw-return-from (n rest)
 692   (let ((tr (find-register (call-node-arg n 0))))
 693     (push-instruction `(%throw-return-from ,tr))
 694     rest))
 695
 696 (define-code-generator %catch-tagbody (n rest)
 697   (cons (lambda-node-body (call-node-arg n 1)) rest))
 698
 699 (define-code-generator %do-catch-tagbody (n rest)
 700   (let* ((c (get-continuation (call-node-arg n 0)))
 701          (vr (continuation-value-register c))
 702          (start (call-node-arg n 1))
 703          (slab (if (lambda-node-p start) (make-label-node "TAGBODY") start))
 704          (cr (find-register (call-node-arg n 2)))
 705          (tr (find-register (call-node-arg n 3))))
 706     (push-instruction `(%catch-tagbody ,(make-label slab) ,cr ,tr ,vr))
 707     (when (lambda-node-p start)
 708           (push (lambda-node-body start) rest)
 709           (push slab rest))
 710     (cleanup-continuation c rest t)))
 711
 712 (define-code-generator %throw-go (n rest)
 713   (let* ((tr (find-register (call-node-arg n 0)))
 714          (target (call-node-arg n 1))
 715          (tlab (if (lambda-node-p target) (make-label-node "TARGET") target)))
 716     (push-instruction `(%throw-go ,tr ,(make-label tlab)))
 717     (when (lambda-node-p target)
 718           (push (lambda-node-body target) rest)
 719           (push tlab rest))
 720     rest))
 721
 722 (define-code-generator %errset (n rest)
 723   (let* ((c (get-continuation (call-node-arg n 0)))
 724          (form-fun (call-node-arg n 1))
 725          (fi (find-register (call-node-arg n 2)))
 726          (fb (lambda-node-body form-fun))
 727          (fv (first (lambda-node-arglist form-fun)))
 728          (fr (find-register fv))
 729          (label (make-label-node "C")))
 730     (push-instruction `(%errset ,(make-label label) ,fr ,fi))
 731     (push fb rest)
 732     (cleanup-protected-continuation label c rest)))
 733
 734 (define-code-generator %unwind-protect (n rest)
 735   (let* ((c (get-continuation (call-node-arg n 0)))
 736          (prot-form (call-node-arg n 1))
 737          (pfb (lambda-node-body prot-form))
 738          (pfv (first (lambda-node-arglist prot-form)))
 739          (pfr (find-register pfv))
 740          (unwind-form (call-node-arg n 2))
 741          (ufb (lambda-node-body unwind-form))
 742          (ufv (first (lambda-node-arglist unwind-form)))
 743          (ufr (find-register ufv))
 744          (label1 (make-label-node "U"))
 745          (label2 (make-label-node "U")))
 746     (push-instruction
 747      `(%unwind-protect ,(make-label label1) ,(make-label label2) ,pfr ,ufr))
 748     (push pfb rest)
 749     (push label1 rest)
 750     (push ufb rest)
 751     (cleanup-protected-continuation label2 c rest)))
 752
 753 (define-code-generator %dynamic-bind (n rest)
 754   (let* ((c (get-continuation (call-node-arg n 0)))
 755          (svr (find-register (call-node-arg n 1)))
 756          (vvr (find-register (call-node-arg n 2)))
 757          (body-form (call-node-arg n 3))
 758          (bfb (lambda-node-body body-form))
 759          (bfv (first (lambda-node-arglist body-form)))
 760          (ulabel (make-label bfv))
 761          (label (make-label-node "D")))
 762     (register-protected-continuation bfv)
 763     (push-instruction `(%dynamic-bind ,svr ,vvr))
 764     (push-instruction `(%goto ,(make-label label)))
 765     (push-instruction (make-label bfv))
 766     (push-instruction '(%dynamic-unbind))
 767     (push bfb rest)
 768     (cleanup-protected-continuation label c rest)))
 769
 770
 771 ;;;;
 772 ;;;; Y Combinator/Closure Code Generators
 773 ;;;;
 774
 775 (define-code-generator %y (n rest)
 776   (let* ((f (call-node-arg n 0))
 777          (names (reverse (lambda-node-arglist f)))
 778          (b (lambda-node-body f))
 779          (bf (call-node-function b)))
 780     (when (gfun-eq bf '%make-y-closures)
 781           (let* ((bc (call-node-arg b 0))
 782                  (cr (mapcar #'find-register (lambda-node-arglist bc)))
 783                  (n (length cr))
 784                  (bargs (rest (call-node-args b)))
 785                  (fi (mapcar #'(lambda (x y) (get-function-label x)) bargs cr))
 786                  (fvr (mapcar #'find-register (nthcdr n bargs)))
 787                  (nv (length fvr))
 788                  (ficr nil))
 789             (mapc #'(lambda (x y) (push x ficr) (push y ficr)) fi cr)
 790             (setf ficr (nreverse ficr))
 791             (push-instruction `(%make-y-closures ,n ,nv ,@ficr ,@fvr))
 792             (setf b (lambda-node-body bc))))
 793     (let* ((y-list-args (call-node-args b))
 794            (body (first y-list-args))
 795            (conts (reverse (rest y-list-args))))
 796       (mapc #'(lambda (x y)
 797                 (push (lambda-node-body y) rest)
 798                 (push x rest))
 799             names
 800             conts)
 801       (push (lambda-node-body body) rest)
 802       rest)))
 803
 804 (define-inline-function-generator %make-closure (args r)
 805   (let ((f (get-function-label (first args)))
 806         (n (length (rest args)))
 807         (aregs (mapcar #'find-register (rest args))))
 808     (push-instruction `(%make-closure ,f ,r ,n ,@aregs))))
 809
 810
 811 ;;;;
 812 ;;;; Funcall/Apply Code Generators
 813 ;;;;
 814
 815 (define-code-generator funcall (n rest)
 816   (let* ((c (get-continuation (call-node-arg n 0)))
 817          (fr (find-register (call-node-arg n 1)))
 818          (aregs (mapcar #'find-register (rest (rest (call-node-args n)))))
 819          (na (length aregs)))
 820     (if (final-value-continuation-p c)
 821         (let ((cr (continuation-register c)))
 822           (push-instruction `(%vcall ,fr ,cr ,na ,@aregs)))
 823         (let ((vr (continuation-value-register c)))
 824           (push-instruction `(%save-vcall ,fr ,vr ,na ,@aregs))))
 825     (cleanup-continuation c rest nil)))
 826
 827
 828 ;;;;
 829 ;;;; Inlined Internal Codes
 830 ;;;;
 831
 832 (define-inline-function-generator %symval (args r)
 833   (push-instruction `(%symval ,(add-literal (first args)) ,r)))
 834
 835 (define-inline-function-generator %symfun (args r)
 836   (push-instruction `(%symfun ,(add-literal (first args)) ,r)))
 837
 838 (define-inline-function-generator %set-symval (args r)
 839   (push-instruction `(%set-symval ,(add-literal (first args))
 840                                   ,(find-register (second args))
 841                                   ,r)))
 842
 843 (define-standard-inline-generator %copy)
 844
 845 (define-code-generator %setq (n rest)
 846   (let* ((c (get-continuation (call-node-arg n 0)))
 847          (p (find-register (call-node-arg n 1)))
 848          (q (find-register (call-node-arg n 2)))
 849          (r (continuation-value-register c)))
 850     (push-instruction `(%copy ,q ,p))
 851     (cond
 852      ((/= r 0) (push-instruction `(%copy ,q ,r)))
 853      ((not (eq (continuation-type c) 'value-ignored))
 854       (push-instruction `(%set-one-value ,q))))
 855     (cleanup-continuation c rest t)))
 856
 857 (define-standard-inline-generator %supplied-p)
 858 (define-standard-inline-generator %make-cell)
 859 (define-standard-inline-generator %cell-value)
 860 (define-standard-inline-generator %set-cell-value)
 861
 862
 863 ;**** drop once implementation changes
 864 (define-code-generator %mv-collect (n rest)
 865   (cleanup-continuation (get-continuation (call-node-arg n 0)) rest nil))
 866
 867 (define-standard-inline-generator %nth-value %nth-value (x))
 868
 869 (define-code-generator %push-values (n rest)
 870   (let* ((c (get-continuation (call-node-arg n 0)))
 871          (r (continuation-value-register c)))
 872     (unless (= r 0) (push-instruction `(%push-values ,r)))
 873     (cleanup-continuation c rest nil)))
 874
 875 (define-code-generator %pop-values (n rest)
 876   (let* ((c (get-continuation (call-node-arg n 0)))
 877          (nv (find-register (call-node-arg n 1)))
 878          (r (continuation-value-register c)))
 879     (push-instruction `(%pop-values ,nv))
 880     (unless (= r 0) (push-instruction `(%get-one-value ,r)))
 881     (cleanup-continuation c rest t)))
 882
 883
 884 ;;;;
 885 ;;;; Inlined Function Code Generators
 886 ;;;;
 887
 888 ;;**** these could handle 3 args specially but funcall for 4 or more
 889 (define-lambda-list + (&rest a))
 890 (define-inline-function-generator + (args r)
 891   (push-instruction `(%arith2 ,(char-int #\+)
 892                               ,(find-register (first args))
 893                               ,(find-register (second args))
 894                               ,r)))
 895 (define-code-generator-test + (n) (= (call-node-arg-count n) 3))
 896
 897 (define-lambda-list * (&rest a))
 898 (define-inline-function-generator * (args r)
 899   (push-instruction `(%arith2 ,(char-int #\*)
 900                               ,(find-register (first args))
 901                               ,(find-register (second args))
 902                               ,r)))
 903 (define-code-generator-test * (n) (= (call-node-arg-count n) 3))
 904
 905 (define-lambda-list - (x &rest a))
 906 (define-inline-function-generator - (args r)
 907   (case (length args)
 908     (1 (push-instruction `(%arith1 ,(char-int #\-)
 909                                    ,(find-register (first args)) ,r)))
 910     (2 (push-instruction `(%arith2 ,(char-int #\-)
 911                                    ,(find-register (first args))
 912                                    ,(find-register (second args))
 913                                    ,r)))))
 914 (define-code-generator-test - (n) (<= (call-node-arg-count n) 3))
 915
 916 (define-lambda-list / (x &rest a))
 917 (define-inline-function-generator / (args r)
 918   (case (length args)
 919     (1 (push-instruction `(%arith1 ,(char-int #\/)
 920                                    ,(find-register (first args)) ,r)))
 921     (2 (push-instruction `(%arith2 ,(char-int #\/)
 922                                    ,(find-register (first args))
 923                                    ,(find-register (second args))
 924                                    ,r)))))
 925 (define-code-generator-test / (n) (<= (call-node-arg-count n) 3))
 926
 927 (define-lambda-list min (x &rest a))
 928 (define-inline-function-generator min (args r)
 929   (push-instruction `(%arith2 ,(char-int #\m)
 930                               ,(find-register (first args))
 931                               ,(find-register (second args))
 932                               ,r)))
 933 (define-code-generator-test min (n) (= (call-node-arg-count n) 3))
 934
 935 (define-lambda-list max (x &rest a))
 936 (define-inline-function-generator max (args r)
 937   (push-instruction `(%arith2 ,(char-int #\M)
 938                               ,(find-register (first args))
 939                               ,(find-register (second args))
 940                               ,r)))
 941 (define-code-generator-test max (n) (= (call-node-arg-count n) 3))
 942
 943 (defmacro define-arith-pred-generator-2 (sym char)
 944   `(progn
 945     (define-lambda-list ,sym (x &rest a))
 946     (define-inline-function-generator ,sym (args r)
 947       (push-instruction
 948        (list '%arith-pred2
 949              (char-int ,char)
 950              (find-register (first args))
 951              (find-register (second args))
 952              r)))
 953     (define-code-generator-test ,sym (n) (= (call-node-arg-count n) 3))))
 954
 955 (define-arith-pred-generator-2 <  #\<)
 956 (define-arith-pred-generator-2 <= #\L)
 957 (define-arith-pred-generator-2 =  #\=)
 958 (define-arith-pred-generator-2 /= #\#)
 959 (define-arith-pred-generator-2 >= #\G)
 960 (define-arith-pred-generator-2 >  #\>)
 961
 962 (define-standard-inline-generator-2 get %get)
 963 (define-standard-inline-generator-2 %set-get)
 964
 965 (define-standard-inline-generator consp %consp (x))
 966 (define-standard-inline-generator endp %endp (x))
 967 (define-standard-inline-generator eq %eq (x y))
 968 (define-standard-inline-generator eql %eql (x y))
 969 (define-standard-inline-generator equal %equal (x y))
 970
 971 (define-inline-function-generator aref (args r)
 972   (case (length args)
 973     (2 (push-instruction `(%aref1 ,(find-register (first args))
 974                                   ,(find-register (second args))
 975                                   ,r)))
 976     (3 (push-instruction `(%aref2 ,(find-register (first args))
 977                                   ,(find-register (second args))
 978                                   ,(find-register (third args))
 979                                   ,r)))))
 980 (define-code-generator-test aref (n) (<= 3 (call-node-arg-count n) 4))
 981 (define-lambda-list aref (x &rest args))
 982
 983 (define-inline-function-generator %set-aref (args r)
 984   (case (length args)
 985     (3 (push-instruction `(%set-aref1 ,(find-register (first args))
 986                                       ,(find-register (second args))
 987                                       ,(find-register (third args))
 988                                       ,r)))
 989     (4 (push-instruction `(%set-aref2 ,(find-register (first args))
 990                                       ,(find-register (second args))
 991                                       ,(find-register (third args))
 992                                       ,(find-register (fourth args))
 993                                       ,r)))))
 994 (define-code-generator-test %set-aref (n) (<= 4 (call-node-arg-count n) 5))
 995 (define-lambda-list %set-aref (x v &rest args))
 996
 997 ;;**** check if others are needed
 998 (define-standard-inline-generator %set-nth %set-nth (i x v))
 999 (define-standard-inline-generator rplaca %rplaca (x v))
1000 (define-standard-inline-generator rplacd %rplacd (x v))
1001 (define-standard-inline-generator %set-svref %set-svref (x i v))
1002 (define-standard-inline-generator %set-elt %set-elt (x i v))
1003
1004 (define-standard-inline-generator nth %nth (i x))
1005 (define-standard-inline-generator svref %svref (x i))
1006 (define-standard-inline-generator elt %elt (x i))
1007
1008 (define-standard-inline-generator cons %cons (x y))
1009
1010 (define-lambda-list 1+ (x))
1011 (define-inline-function-generator 1+ (args r)
1012   (push-instruction `(%arith1 ,(char-int #\p)
1013                               ,(find-register (first args))
1014                               ,r)))
1015
1016 (define-lambda-list 1- (x))
1017 (define-inline-function-generator 1- (args r)
1018   (push-instruction `(%arith1 ,(char-int #\m)
1019                               ,(find-register (first args))
1020                               ,r)))
1021
1022
1023 ;;
1024 ;; SLOT-VALUE
1025 ;;
1026
1027 (define-lambda-list slot-value (x &optional y))
1028
1029 (define-inline-function-generator slot-value (args r)
1030   (case (length args)
1031     (1 (push-instruction `(%slot-value ,(find-register (first args)) ,r)))
1032     (2 (push-instruction `(%set-slot-value ,(find-register (first args))
1033                                            ,(find-register (second args))
1034                                            ,r)))))
1035
1036 ;;
1037 ;; C?R, C??R and C???R
1038 ;;
1039
1040 (define-lambda-list car (x))
1041 (define-standard-inline-generator car %car)
1042
1043 (define-lambda-list cdr (x))
1044 (define-standard-inline-generator cdr %cdr)
1045
1046 (defmacro define-cxr-generator (name n x)
1047   `(progn
1048      (define-lambda-list ,name (x))
1049      (define-inline-function-generator ,name (args r)
1050        (push-instruction (list '%cxr ,n ,x  (find-register (first args)) r)))))
1051
1052 (define-cxr-generator caar 2 #b11)
1053 (define-cxr-generator cadr 2 #b10)
1054 (define-cxr-generator cdar 2 #b01)
1055 (define-cxr-generator cddr 2 #b00)
1056
1057 (define-cxr-generator caaar 3 #b111)
1058 (define-cxr-generator caadr 3 #b110)
1059 (define-cxr-generator cadar 3 #b101)
1060 (define-cxr-generator caddr 3 #b100)
1061 (define-cxr-generator cdaar 3 #b011)
1062 (define-cxr-generator cdadr 3 #b010)
1063 (define-cxr-generator cddar 3 #b001)
1064 (define-cxr-generator cdddr 3 #b000)
1065
1066 ;;
1067 ;; CAR and CDR setf methods
1068 ;;
1069
1070 (define-standard-inline-generator %set-car %set-car (x v))
1071 (define-standard-inline-generator %set-cdr %set-cdr (x v))