cgen/rtl-traverse.scm

   1 ;; RTL traversing support.
   2 ;; Copyright (C) 2000, 2001, 2009, 2010 Red Hat, Inc.
   3 ;; This file is part of CGEN.
   4 ;; See file COPYING.CGEN for details.
   5
   6 ;; Canonicalization support.
   7 ;; Canonicalizing an rtl expression involves adding possibly missing options
   8 ;; and mode, and converting occurrences of DFLT into usable modes.
   9 ;; Various error checks are done as well.
  10 ;; This is done differently than traversal support because it has a more
  11 ;; specific purpose, it doesn't need to support arbitrary "expr-fns".
  12 ;; ??? At present the internal form is also the source form (easier debugging).
  13
  14 (define /rtx-canon-debug? #f)
  15
  16 ;; Canonicalization state.
  17 ;; This carries the immutable elements only!
  18 ;; OUTER-EXPR is the EXPR argument to rtx-canonicalize.
  19
  20 (define (/make-cstate context isa-name-list outer-expr)
  21   (vector context isa-name-list outer-expr)
  22 )
  23
  24 (define (/cstate-context cstate) (vector-ref cstate 0))
  25 (define (/cstate-isas cstate) (vector-ref cstate 1))
  26 (define (/cstate-outer-expr cstate) (vector-ref cstate 2))
  27
  28 ;; Flag an error while canonicalizing rtl.
  29
  30 (define (/rtx-canon-error cstate errmsg expr parent-expr op-num)
  31   (let* ((pretty-parent-expr (rtx-pretty-strdump (/cstate-outer-expr cstate)))
  32          (intro (if parent-expr
  33                     (string-append "While canonicalizing "
  34                                    (rtx-strdump parent-expr)
  35                                    (if op-num
  36                                        (string-append ", operand #"
  37                                                       (number->string op-num))
  38                                        "")
  39                                    " of:\n"
  40                                    pretty-parent-expr)
  41                     (string-append "While canonicalizing:\n" pretty-parent-expr))))
  42     (context-error (/cstate-context cstate) intro errmsg (rtx-dump expr)))
  43 )
  44
  45 ;; Lookup h/w object HW-NAME and return it (as a <hardware-base> object).
  46 ;; If multiple h/w objects with the same name are defined, require
  47 ;; all to have the same mode.
  48 ;; CHECK-KIND is a function of one argument to verify the h/w objects
  49 ;; are valid and if not flag an error.
  50
  51 (define (/rtx-lookup-hw cstate hw-name parent-expr check-kind)
  52   (let ((hw-objs (current-hw-sem-lookup hw-name)))
  53
  54     (if (null? hw-objs)
  55         (/rtx-canon-error cstate "unknown h/w object"
  56                           hw-name parent-expr #f))
  57
  58     ;; Just check the first one with CHECK-KIND.
  59     (check-kind (car hw-objs))
  60
  61     (let* ((hw1 (car hw-objs))
  62            (hw1-mode (hw-mode hw1))
  63            (hw1-mode-name (obj:name hw1-mode)))
  64
  65       ;; Allow multiple h/w objects with the same name
  66       ;; as long has they have the same mode.
  67       (if (> (length hw-objs) 1)
  68           (let ((other-hw-mode-names (map (lambda (hw)
  69                                             (obj:name (hw-mode hw)))
  70                                           (cdr hw-objs))))
  71             (if (not (all-true? (map (lambda (mode-name)
  72                                        (eq? mode-name hw1-mode-name))
  73                                      other-hw-mode-names)))
  74                 (/rtx-canon-error cstate "multiple h/w objects with different modes selected"
  75                                   hw-name parent-expr #f))))
  76
  77       hw1))
  78 )
  79
  80 ;; Return the mode name to use in an expression given the requested mode
  81 ;; and the mode used in the expression.
  82 ;; If both are DFLT, leave it alone and hope the expression provides
  83 ;; enough info to pick a usable mode.
  84 ;; If both are provided, prefer the mode used in the expression.
  85 ;; If the modes are incompatible, return #f.
  86
  87 (define (/rtx-pick-mode cstate requested-mode-name expr-mode-name)
  88   (cond ((eq? requested-mode-name 'DFLT)
  89          expr-mode-name)
  90         ((eq? expr-mode-name 'DFLT)
  91          requested-mode-name)
  92         (else
  93          (let ((requested-mode (mode:lookup requested-mode-name))
  94                (expr-mode (mode:lookup expr-mode-name)))
  95            (if (not requested-mode)
  96                (/rtx-canon-error cstate "invalid mode" requested-mode-name #f #f))
  97            (if (not expr-mode)
  98                (/rtx-canon-error cstate "invalid mode" expr-mode-name #f #f))
  99            ;; FIXME: 'would prefer samesize or "no precision lost", sigh
 100            (if (mode-compatible? 'sameclass requested-mode expr-mode)
 101                expr-mode-name
 102                expr-mode-name)))) ;; FIXME: should be #f, disabled pending completion of rtl mode handling rewrite
 103 )
 104
 105 ;; Return the mode name (as a symbol) to use in an object's rtl given
 106 ;; the requested mode, the mode used in the expression, and the object's
 107 ;; real mode.
 108 ;; If both requested mode and expr mode are DFLT, use the real mode.
 109 ;; If requested mode is DFLT, prefer expr mode.
 110 ;; If expr mode is DFLT, prefer the real mode.
 111 ;; If both requested mode and expr mode are specified, prefer expr-mode.
 112 ;; If there's an error the result is the error message (as a string).
 113 ;;
 114 ;; E.g. in (set SI dest (ifield DFLT f-r1)), the mode of the ifield's
 115 ;; expression is DFLT, the requested mode is SI, and the real mode of f-r1
 116 ;; may be INT.
 117 ;;
 118 ;; REAL-MODE is a <mode> object.
 119
 120 (define (/rtx-pick-mode3 requested-mode-name expr-mode-name real-mode)
 121   ;; Leave checking for (symbol? requested-mode-name) to caller (or higher).
 122   (let ((expr-mode (mode:lookup expr-mode-name)))
 123     (cond ((not expr-mode)
 124            "unknown mode")
 125           ((eq? requested-mode-name 'DFLT)
 126            (if (eq? expr-mode-name 'DFLT)
 127                (obj:name real-mode)
 128                (if (rtx-mode-compatible? expr-mode real-mode)
 129                    expr-mode-name
 130                    (string-append "expression mode "
 131                                   (symbol->string expr-mode-name)
 132                                   " is incompatible with real mode "
 133                                   (obj:str-name real-mode)))))
 134           ((eq? expr-mode-name 'DFLT)
 135            (if (rtx-mode-compatible? (mode:lookup requested-mode-name)
 136                                      real-mode)
 137                (obj:name real-mode)
 138                (string-append "mode of containing expression "
 139                               (symbol->string requested-mode-name)
 140                               " is incompatible with real mode "
 141                               (obj:str-name real-mode))))
 142           (else
 143            (let ((requested-mode (mode:lookup requested-mode-name)))
 144              (cond ((not (rtx-mode-compatible? requested-mode expr-mode))
 145                     (string-append "mode of containing expression "
 146                                    (symbol->string requested-mode-name)
 147                                    " is incompatible with expression mode "
 148                                    (symbol->string expr-mode-name)))
 149                    ((not (rtx-mode-compatible? expr-mode real-mode))
 150                     (string-append "expression mode "
 151                                    (symbol->string expr-mode-name)
 152                                    " is incompatible with real mode "
 153                                    (obj:str-name real-mode)))
 154                    (else
 155                     expr-mode-name))))))
 156 )
 157
 158 ;; Return the mode name (as a symbol) to use in an operand's rtl given
 159 ;; the requested mode, the mode used in the expression, and the operand's
 160 ;; real mode.
 161 ;; If both requested mode and expr mode are DFLT, use the real mode.
 162 ;; If requested mode is DFLT, prefer expr mode.
 163 ;; If expr mode is DFLT, prefer the real mode.
 164 ;; If both requested mode and expr mode are specified, prefer expr-mode.
 165 ;; If the modes are incompatible an error is signalled.
 166 ;;
 167 ;; E.g. in (set QI (mem QI src2) src1), the mode to set is QI, but if src1
 168 ;; is a 32-bit (SI) register we want QI.
 169 ;; OTOH, in (set QI (mem QI src2) uimm8), the mode to set is QI, but we want
 170 ;; the real mode of uimm8.
 171 ;;
 172 ;; ??? This is different from /rtx-pick-mode3 for compatibility with
 173 ;; pre-full-canonicalization versions.
 174 ;  It's currently a toss-up on whether it improves things.
 175 ;;
 176 ;; OP is an <operand> object.
 177 ;;
 178 ;; Things are complicated because multiple versions of a h/w object can be
 179 ;; defined, and the operand refers to the h/w by name.
 180 ;; op:type, which op:mode calls, will flag an error if multiple versions of
 181 ;; a h/w object are defined - only one should have been kept during .cpu
 182 ;; file loading.  This is for semantic code generation, but for generating
 183 ;; files covering the entire architecture we need to keep all the versions.
 184 ;; Things are ok, as far as canonicalization is concerned, if all h/w versions
 185 ;; have the same mode (which could be WI for 32/64 arches).
 186
 187 (define (/rtx-pick-op-mode cstate requested-mode-name expr-mode-name op
 188                            parent-expr)
 189   ;; Leave checking for (symbol? requested-mode-name) to caller (or higher).
 190   (let* ((op-mode-name (op:mode-name op))
 191          (hw (/rtx-lookup-hw cstate (op:hw-name op) parent-expr
 192                              (lambda (hw) *UNSPECIFIED*)))
 193          (op-mode (if (eq? op-mode-name 'DFLT)
 194                       (hw-mode hw)
 195                       (mode:lookup op-mode-name)))
 196          (expr-mode (mode:lookup expr-mode-name)))
 197     (cond ((not expr-mode)
 198            (/rtx-canon-error cstate "unknown mode" expr-mode-name
 199                              parent-expr #f))
 200           ((eq? requested-mode-name 'DFLT)
 201            (if (eq? expr-mode-name 'DFLT)
 202                (obj:name op-mode)
 203                (if (rtx-mode-compatible? expr-mode op-mode)
 204                    expr-mode-name
 205                    (/rtx-canon-error cstate
 206                                      (string-append
 207                                       "expression mode "
 208                                       (symbol->string expr-mode-name)
 209                                       " is incompatible with operand mode "
 210                                       (obj:str-name op-mode))
 211                                      expr-mode-name parent-expr #f))))
 212           ((eq? expr-mode-name 'DFLT)
 213            (if (rtx-mode-compatible? (mode:lookup requested-mode-name)
 214                                      op-mode)
 215 ; FIXME: Experiment.  It's currently a toss-up on whether it improves things.
 216 ;              (cond ((pc? op)
 217 ;                     (obj:name op-mode))
 218 ;                    ((register? hw)
 219 ;                     requested-mode-name)
 220 ;                    (else
 221 ;                     (obj:name op-mode)))
 222                (obj:name op-mode)
 223                (/rtx-canon-error cstate
 224                                  (string-append
 225                                   "mode of containing expression "
 226                                   (symbol->string requested-mode-name)
 227                                   " is incompatible with operand mode "
 228                                   (obj:str-name op-mode))
 229                                  requested-mode-name parent-expr #f)))
 230           (else
 231            (let ((requested-mode (mode:lookup requested-mode-name)))
 232              (cond ((not (rtx-mode-compatible? requested-mode expr-mode))
 233                     (/rtx-canon-error cstate
 234                                       (string-append
 235                                        "mode of containing expression "
 236                                        (symbol->string requested-mode-name)
 237                                        " is incompatible with expression mode "
 238                                        (symbol->string expr-mode-name))
 239                                       requested-mode-name parent-expr #f))
 240                    ((not (rtx-mode-compatible? expr-mode op-mode))
 241                     (/rtx-canon-error cstate
 242                                       (string-append
 243                                        "expression mode "
 244                                        (symbol->string expr-mode-name)
 245                                        " is incompatible with operand mode "
 246                                        (obj:str-name op-mode))
 247                                       expr-mode-name parent-expr #f))
 248                    (else
 249                     expr-mode-name))))))
 250 )
 251
 252 ;; Return the last rtx in cond or case expression EXPR.
 253
 254 (define (/rtx-get-last-cond-case-rtx expr)
 255   (let ((len (length expr)))
 256     (list-ref expr (- len 1)))
 257 )
 258
 259 ;; Canonicalize a list of rtx's.
 260 ;; The mode of rtxes prior to the last one must be VOID.
 261
 262 (define (/rtx-canon-rtx-list rtx-list mode parent-expr op-num cstate env depth)
 263   (let* ((nr-rtxes (length rtx-list))
 264          (last-op-num (- nr-rtxes 1)))
 265     (map (lambda (rtx op-num)
 266            (/rtx-canon rtx 'RTX
 267                        (if (= op-num last-op-num) mode 'VOID)
 268                        parent-expr op-num cstate env depth))
 269          rtx-list (iota nr-rtxes)))
 270 )
 271
 272 ;; Rtx canonicalizers.
 273 ;; These are defined as individual functions that are then built into a table
 274 ;; mostly for simplicity.
 275 ;
 276 ;; The result is either a pair of the parsed VAL and new environment,
 277 ;; or #f meaning there is no change (saves lots of unnecessarying cons'ing).
 278
 279 (define (/rtx-canon-options val mode parent-expr op-num cstate env depth)
 280   #f
 281 )
 282
 283 (define (/rtx-canon-anyintmode val mode parent-expr op-num cstate env depth)
 284   (let ((val-obj (mode:lookup val)))
 285     (if (and val-obj
 286              (or (memq (mode:class val-obj) '(INT UINT))
 287                  (eq? val 'DFLT)))
 288         #f
 289         (/rtx-canon-error cstate "expecting an integer mode"
 290                           val parent-expr op-num)))
 291 )
 292
 293 (define (/rtx-canon-anyfloatmode val mode parent-expr op-num cstate env depth)
 294   (let ((val-obj (mode:lookup val)))
 295     (if (and val-obj
 296              (or (memq (mode:class val-obj) '(FLOAT))
 297                  (eq? val 'DFLT)))
 298         #f
 299         (/rtx-canon-error cstate "expecting a float mode"
 300                           val parent-expr op-num)))
 301 )
 302
 303 (define (/rtx-canon-anynummode val mode parent-expr op-num cstate env depth)
 304   (let ((val-obj (mode:lookup val)))
 305     (if (and val-obj
 306              (or (memq (mode:class val-obj) '(INT UINT FLOAT))
 307                  (eq? val 'DFLT)))
 308         #f
 309         (/rtx-canon-error cstate "expecting a numeric mode"
 310                           val parent-expr op-num)))
 311 )
 312
 313 (define (/rtx-canon-anyexprmode val mode parent-expr op-num cstate env depth)
 314   (let ((val-obj (mode:lookup val)))
 315     (if (and val-obj
 316              (or (memq (mode:class val-obj) '(INT UINT FLOAT))
 317                  (memq val '(DFLT PTR VOID SYM))))
 318         #f
 319         (/rtx-canon-error cstate "expecting a numeric mode, PTR, VOID, or SYM"
 320                           val parent-expr op-num)))
 321 )
 322
 323 (define (/rtx-canon-anycexprmode val mode parent-expr op-num cstate env depth)
 324   (let ((val-obj (mode:lookup val)))
 325     (if (and val-obj
 326              (or (memq (mode:class val-obj) '(INT UINT FLOAT))
 327                  (memq val '(DFLT PTR VOID))))
 328         #f
 329         (/rtx-canon-error cstate "expecting a numeric mode, PTR, or VOID"
 330                           val parent-expr op-num)))
 331 )
 332
 333 (define (/rtx-canon-explnummode val mode parent-expr op-num cstate env depth)
 334   (let ((val-obj (mode:lookup val)))
 335     (if (and val-obj
 336              (memq (mode:class val-obj) '(INT UINT FLOAT)))
 337         #f
 338         (/rtx-canon-error cstate "expecting an explicit numeric mode"
 339                           val parent-expr op-num)))
 340 )
 341
 342 (define (/rtx-canon-voidornummode val mode parent-expr op-num cstate env depth)
 343   (let ((val-obj (mode:lookup val)))
 344     (if (and val-obj
 345              (or (memq (mode:class val-obj) '(INT UINT FLOAT))
 346                  (memq val '(DFLT VOID))))
 347         #f
 348         (/rtx-canon-error cstate "expecting void or a numeric mode"
 349                           val parent-expr op-num)))
 350 )
 351
 352 (define (/rtx-canon-voidmode val mode parent-expr op-num cstate env depth)
 353   (if (memq val '(DFLT VOID))
 354       (cons 'VOID env)
 355       (/rtx-canon-error cstate "expecting VOID mode"
 356                         val parent-expr op-num))
 357 )
 358
 359 (define (/rtx-canon-bimode val mode parent-expr op-num cstate env depth)
 360   (if (memq val '(DFLT BI))
 361       (cons 'BI env)
 362       (/rtx-canon-error cstate "expecting BI mode"
 363                         val parent-expr op-num))
 364 )
 365
 366 (define (/rtx-canon-intmode val mode parent-expr op-num cstate env depth)
 367   (if (memq val '(DFLT INT))
 368       (cons 'INT env)
 369       (/rtx-canon-error cstate "expecting INT mode"
 370                         val parent-expr op-num))
 371 )
 372
 373 (define (/rtx-canon-symmode val mode parent-expr op-num cstate env depth)
 374   (if (memq val '(DFLT SYM))
 375       (cons 'SYM env)
 376       (/rtx-canon-error cstate "expecting SYM mode"
 377                         val parent-expr op-num))
 378 )
 379
 380 (define (/rtx-canon-insnmode val mode parent-expr op-num cstate env depth)
 381   (if (memq val '(DFLT INSN))
 382       (cons 'INSN env)
 383       (/rtx-canon-error cstate "expecting INSN mode"
 384                         val parent-expr op-num))
 385 )
 386
 387 (define (/rtx-canon-machmode val mode parent-expr op-num cstate env depth)
 388   (if (memq val '(DFLT MACH))
 389       (cons 'MACH env)
 390       (/rtx-canon-error cstate "expecting MACH mode"
 391                         val parent-expr op-num))
 392 )
 393
 394 (define (/rtx-canon-rtx val mode parent-expr op-num cstate env depth)
 395 ; Commented out 'cus it doesn't quite work yet.
 396 ; (if (not (rtx? val))
 397 ;     (/rtx-canon-error cstate "expecting an rtx" val parent-expr op-num))
 398   (cons (/rtx-canon val 'RTX mode parent-expr op-num cstate env depth)
 399         env)
 400 )
 401
 402 (define (/rtx-canon-setrtx val mode parent-expr op-num cstate env depth)
 403 ; Commented out 'cus it doesn't quite work yet.
 404 ; (if (not (rtx? val))
 405 ;     (/rtx-canon-error cstate "expecting an rtx" val parent-expr op-num))
 406   (let ((dest (/rtx-canon val 'SETRTX mode parent-expr op-num cstate env depth)))
 407     (cons dest env))
 408 )
 409
 410 ;; This is the test of an `if'.
 411
 412 (define (/rtx-canon-testrtx val mode parent-expr op-num cstate env depth)
 413 ; Commented out 'cus it doesn't quite work yet.
 414 ; (if (not (rtx? val))
 415 ;     (/rtx-canon-error cstate "expecting an rtx"
 416 ;                         val parent-expr op-num))
 417   (cons (/rtx-canon val 'RTX mode parent-expr op-num cstate env depth)
 418         env)
 419 )
 420
 421 (define (/rtx-canon-condrtx val mode parent-expr op-num cstate env depth)
 422   (if (not (pair? val))
 423       (/rtx-canon-error cstate "expecting an expression"
 424                           val parent-expr op-num))
 425   (if (eq? (car val) 'else)
 426       (begin
 427         (if (!= (+ op-num 2) (length parent-expr))
 428             (/rtx-canon-error cstate "`else' clause not last"
 429                               val parent-expr op-num))
 430         (cons (cons 'else
 431                     (/rtx-canon-rtx-list
 432                      (cdr val) mode parent-expr op-num cstate env depth))
 433               env))
 434       (cons (cons
 435              ;; ??? Entries after the first are conditional.
 436              (/rtx-canon (car val) 'RTX 'INT parent-expr op-num cstate env depth)
 437              (/rtx-canon-rtx-list
 438               (cdr val) mode parent-expr op-num cstate env depth))
 439             env))
 440 )
 441
 442 (define (/rtx-canon-casertx val mode parent-expr op-num cstate env depth)
 443   (if (or (not (list? val))
 444           (< (length val) 2))
 445       (/rtx-canon-error cstate "invalid `case' expression"
 446                         val parent-expr op-num))
 447   ;; car is either 'else or list of symbols/numbers
 448   (if (not (or (eq? (car val) 'else)
 449                (and (list? (car val))
 450                     (not (null? (car val)))
 451                     (all-true? (map /rtx-symornum?
 452                                     (car val))))))
 453       (/rtx-canon-error cstate "invalid `case' choice"
 454                         val parent-expr op-num))
 455   (if (and (eq? (car val) 'else)
 456            (!= (+ op-num 2) (length parent-expr)))
 457       (/rtx-canon-error cstate "`else' clause not last"
 458                         val parent-expr op-num))
 459   (cons (cons (car val)
 460               (/rtx-canon-rtx-list
 461                (cdr val) mode parent-expr op-num cstate env depth))
 462         env)
 463 )
 464
 465 (define (/rtx-canon-locals val mode parent-expr op-num cstate env depth)
 466   (if (not (list? val))
 467       (/rtx-canon-error cstate "bad locals list"
 468                         val parent-expr op-num))
 469   (for-each (lambda (var)
 470               (if (or (not (list? var))
 471                       (!= (length var) 2)
 472                       (not (/rtx-any-mode? (car var)))
 473                       (not (symbol? (cadr var))))
 474                   (/rtx-canon-error cstate "bad locals list"
 475                                     val parent-expr op-num)))
 476             val)
 477   (let ((new-env (rtx-env-make-locals val)))
 478     (cons val (cons new-env env)))
 479 )
 480
 481 (define (/rtx-canon-iteration val mode parent-expr op-num cstate env depth)
 482   (if (not (symbol? val))
 483       (/rtx-canon-error cstate "bad iteration variable name"
 484                         val parent-expr op-num))
 485   (let ((new-env (rtx-env-make-iteration-locals val)))
 486     (cons val (cons new-env env)))
 487 )
 488
 489 (define (/rtx-canon-symbol-list val mode parent-expr op-num cstate env depth)
 490   (if (or (not (list? val))
 491           (not (all-true? (map symbol? val))))
 492       (/rtx-canon-error cstate "bad symbol list"
 493                         val parent-expr op-num))
 494   #f
 495 )
 496
 497 (define (/rtx-canon-env-stack val mode parent-expr op-num cstate env depth)
 498   ;; VAL is an environment stack.
 499   (if (not (list? val))
 500       (/rtx-canon-error cstate "environment not a list"
 501                         val parent-expr op-num))
 502   ;; FIXME: Shouldn't this push VAL onto ENV?
 503   (cons val env)
 504 )
 505
 506 (define (/rtx-canon-attrs val mode parent-expr op-num cstate env depth)
 507 ;  (cons val ; (atlist-source-form (atlist-parse (make-prefix-cstate "with-attr") val ""))
 508 ;       env)
 509   #f
 510 )
 511
 512 (define (/rtx-canon-symbol val mode parent-expr op-num cstate env depth)
 513   (if (not (symbol? val))
 514       (/rtx-canon-error cstate "expecting a symbol"
 515                         val parent-expr op-num))
 516   #f
 517 )
 518
 519 (define (/rtx-canon-string val mode parent-expr op-num cstate env depth)
 520   (if (not (string? val))
 521       (/rtx-canon-error cstate "expecting a string"
 522                         val parent-expr op-num))
 523   #f
 524 )
 525
 526 (define (/rtx-canon-number val mode parent-expr op-num cstate env depth)
 527   (if (not (number? val))
 528       (/rtx-canon-error cstate "expecting a number"
 529                         val parent-expr op-num))
 530   #f
 531 )
 532
 533 (define (/rtx-canon-symornum val mode parent-expr op-num cstate env depth)
 534   (if (not (or (symbol? val) (number? val)))
 535       (/rtx-canon-error cstate "expecting a symbol or number"
 536                         val parent-expr op-num))
 537   #f
 538 )
 539
 540 (define (/rtx-canon-object val mode parent-expr op-num cstate env depth)
 541   #f
 542 )
 543
 544 ;; Table of rtx canonicalizers.
 545 ;; This is a vector of size rtx-max-num.
 546 ;; Each entry is a list of (arg-type-name . canonicalizer) elements
 547 ;; for rtx-arg-types.
 548 ;; FIXME: Initialized in rtl.scm (i.e. outside this file).
 549
 550 (define /rtx-canoner-table #f)
 551
 552 ;; Return a hash table of standard operand canonicalizers.
 553 ;; The result of each canonicalizer is a pair of the canonical form
 554 ;; of `val' and a possibly new environment or #f if there is no change.
 555
 556 (define (/rtx-make-canon-table)
 557   (let ((hash-tab (make-hash-table 31))
 558         (canoners
 559          (list
 560           (cons 'OPTIONS /rtx-canon-options)
 561           (cons 'ANYINTMODE /rtx-canon-anyintmode)
 562           (cons 'ANYFLOATMODE /rtx-canon-anyfloatmode)
 563           (cons 'ANYNUMMODE /rtx-canon-anynummode)
 564           (cons 'ANYEXPRMODE /rtx-canon-anyexprmode)
 565           (cons 'ANYCEXPRMODE /rtx-canon-anycexprmode)
 566           (cons 'EXPLNUMMODE /rtx-canon-explnummode)
 567           (cons 'VOIDORNUMMODE /rtx-canon-voidornummode)
 568           (cons 'VOIDMODE /rtx-canon-voidmode)
 569           (cons 'BIMODE /rtx-canon-bimode)
 570           (cons 'INTMODE /rtx-canon-intmode)
 571           (cons 'SYMMODE /rtx-canon-symmode)
 572           (cons 'INSNMODE /rtx-canon-insnmode)
 573           (cons 'MACHMODE /rtx-canon-machmode)
 574           (cons 'RTX /rtx-canon-rtx)
 575           (cons 'SETRTX /rtx-canon-setrtx)
 576           (cons 'TESTRTX /rtx-canon-testrtx)
 577           (cons 'CONDRTX /rtx-canon-condrtx)
 578           (cons 'CASERTX /rtx-canon-casertx)
 579           (cons 'LOCALS /rtx-canon-locals)
 580           (cons 'ITERATION /rtx-canon-iteration)
 581           (cons 'SYMBOLLIST /rtx-canon-symbol-list)
 582           (cons 'ENVSTACK /rtx-canon-env-stack)
 583           (cons 'ATTRS /rtx-canon-attrs)
 584           (cons 'SYMBOL /rtx-canon-symbol)
 585           (cons 'STRING /rtx-canon-string)
 586           (cons 'NUMBER /rtx-canon-number)
 587           (cons 'SYMORNUM /rtx-canon-symornum)
 588           (cons 'OBJECT /rtx-canon-object)
 589           )))
 590
 591     (for-each (lambda (canoner)
 592                 (hashq-set! hash-tab (car canoner) (cdr canoner)))
 593               canoners)
 594
 595     hash-tab)
 596 )
 597
 598 ;; Standard expression operand canonicalizer.
 599 ;; Loop over the operands, verifying them according to the argument type
 600 ;; and mode matcher, and replace DFLT with a usable mode.
 601
 602 (define (/rtx-canon-operands rtx-obj requested-mode-name
 603                              func args parent-expr parent-op-num
 604                              cstate env depth)
 605   ;; ??? Might want to just leave operands as a list.
 606   (let* ((operands (list->vector args))
 607          (nr-operands (vector-length operands))
 608          (this-expr (cons func args)) ;; For error messages.
 609          (expr-mode
 610           ;; For sets, the requested mode is DFLT or VOID (the mode of the
 611           ;; result), but the mode we want is the mode of the set destination.
 612           (if (rtx-result-mode rtx-obj)
 613               (cadr args) ;; mode of arg2 doesn't come from containing expr
 614               (/rtx-pick-mode cstate requested-mode-name (cadr args))))
 615          (all-arg-types (vector-ref /rtx-canoner-table (rtx-num rtx-obj))))
 616
 617     (if (not expr-mode)
 618         (/rtx-canon-error cstate
 619                           (string-append "requested mode "
 620                                          (symbol->string requested-mode-name)
 621                                          " is incompatible with expression mode "
 622                                          (symbol->string (cadr args)))
 623                           this-expr parent-expr #f))
 624
 625     (if /rtx-canon-debug?
 626         (begin
 627           (display (spaces (* 4 depth)))
 628           (display "expr-mode ")
 629           (display expr-mode)
 630           (newline)
 631           (force-output)))
 632
 633     (let loop ((env env)
 634                (op-num 0)
 635                (arg-types all-arg-types)
 636                (arg-modes (rtx-arg-modes rtx-obj)))
 637
 638       (let ((varargs? (and (pair? arg-types) (symbol? (car arg-types)))))
 639
 640         (if /rtx-canon-debug?
 641             (begin
 642               (display (spaces (* 4 depth)))
 643               (if (= op-num nr-operands)
 644                   (display "end of operands")
 645                   (begin
 646                     (display "op-num ") (display op-num) (display ": ")
 647                     (display (rtx-dump (vector-ref operands op-num)))
 648                     (display ", ")
 649                     (display (if varargs? (car arg-types) (caar arg-types)))
 650                     (display ", ")
 651                     (display (if varargs? arg-modes (car arg-modes)))
 652                     ))
 653               (newline)
 654               (force-output)))
 655
 656         (cond ((= op-num nr-operands)
 657
 658                ;; Out of operands, check if we have the expected number.
 659                (if (or (null? arg-types)
 660                        varargs?)
 661
 662                    ;; We're theoretically done.
 663                    (let ((set-mode-from-arg!
 664                           (lambda (arg-num)
 665                             (if /rtx-canon-debug?
 666                                 (begin
 667                                   (display (spaces (* 4 depth)))
 668                                   (display "Computing expr mode from arguments.")
 669                                   (newline)))
 670                             (let* ((expr-to-match
 671                                     (case func
 672                                       ((cond case)
 673                                        (/rtx-get-last-cond-case-rtx (vector-ref operands arg-num)))
 674                                       (else
 675                                        (vector-ref operands arg-num))))
 676                                    (expr-to-match-obj (rtx-lookup (rtx-name expr-to-match)))
 677                                    (new-expr-mode (or (rtx-result-mode expr-to-match-obj)
 678                                                       (let ((expr-mode (rtx-mode expr-to-match)))
 679                                                         (if (eq? expr-mode 'DFLT)
 680                                                             (if (eq? requested-mode-name 'DFLT)
 681                                                                 (/rtx-canon-error cstate
 682                                                                                   "unable to determine mode of expression from arguments, please specify a mode"
 683                                                                                   this-expr parent-expr #f)
 684                                                                 requested-mode-name)
 685                                                             expr-mode)))))
 686                               ;; Verify the mode to be recorded matches the spec.
 687                               (let* ((expr-mode-spec (cadr all-arg-types))
 688                                      (canoner (cdr expr-mode-spec)))
 689                                 ;; Ignore the result of the canoner, we just
 690                                 ;; want the error checking.
 691                                 (canoner new-expr-mode #f this-expr 1
 692                                          cstate env depth))
 693                               (vector-set! operands 1 new-expr-mode)))))
 694
 695                      ;; The expression's mode might still be DFLT.
 696                      ;; If it is, fetch the mode of the MATCHEXPR operand,
 697                      ;; or MATCHSEQ operand, or containing expression.
 698                      ;; If it's still DFLT, flag an error.
 699                      (if (eq? (vector-ref operands 1) 'DFLT)
 700                          (cond ((rtx-matchexpr-index rtx-obj)
 701                                 => (lambda (matchexpr-index)
 702                                      (set-mode-from-arg! matchexpr-index)))
 703                                ((eq? func 'sequence)
 704                                 (set-mode-from-arg! (- nr-operands 1)))
 705                                (else
 706                                 (if /rtx-canon-debug?
 707                                     (begin
 708                                       (display (spaces (* 4 depth)))
 709                                       (display "Computing expr mode from containing expression.")
 710                                       (newline)))
 711                                 (if (or (eq? requested-mode-name 'DFLT)
 712                                         (rtx-result-mode rtx-obj))
 713                                     (/rtx-canon-error cstate
 714                                                       "unable to determine mode of expression, please specify a mode"
 715                                                       this-expr parent-expr #f)
 716                                     (vector-set! operands 1 requested-mode-name)))))
 717                      (vector->list operands))
 718
 719                    (/rtx-canon-error cstate "missing operands"
 720                                      this-expr parent-expr #f)))
 721
 722               ((null? arg-types)
 723                (/rtx-canon-error cstate "too many operands"
 724                                  this-expr parent-expr #f))
 725
 726               (else
 727                (let ((type (if varargs? arg-types (car arg-types)))
 728                      (mode (let ((mode-spec (if varargs?
 729                                                 arg-modes
 730                                                 (car arg-modes))))
 731                              ;; We don't necessarily have enough information
 732                              ;; at this point.  Just propagate what we do know,
 733                              ;; and leave it for final processing to fix up what
 734                              ;; we missed.
 735                              ;; This is small enough that case is fast enough,
 736                              ;; and the number of entries should be stable.
 737                              (case mode-spec
 738                                ((ANY) 'DFLT)
 739                                ((ANYINT) 'DFLT) ;; FIXME
 740                                ((NA) #f)
 741                                ((MATCHEXPR) expr-mode)
 742                                ((MATCHSEQ)
 743                                 (if (= (+ op-num 1) nr-operands) ;; last one?
 744                                     expr-mode
 745                                     'VOID))
 746                                ((MATCH2)
 747                                 ;; This is complicated by the fact that some
 748                                 ;; rtx have a different result mode than what
 749                                 ;; is specified in the rtl (e.g. set, eq).
 750                                 ;; ??? Make these rtx specify both modes?
 751                                 (let* ((op2 (vector-ref operands 2))
 752                                        (op2-obj (rtx-lookup (rtx-name op2))))
 753                                   (or (rtx-result-mode op2-obj)
 754                                       (rtx-mode op2))))
 755                                ((MATCH3)
 756                                 ;; This is complicated by the fact that some
 757                                 ;; rtx have a different result mode than what
 758                                 ;; is specified in the rtl (e.g. set, eq).
 759                                 ;; ??? Make these rtx specify both modes?
 760                                 (let* ((op2 (vector-ref operands 3))
 761                                        (op2-obj (rtx-lookup (rtx-name op2))))
 762                                   (or (rtx-result-mode op2-obj)
 763                                       (rtx-mode op2))))
 764                                ;; Otherwise mode-spec is the mode to use.
 765                                (else mode-spec))))
 766                      (val (vector-ref operands op-num))
 767                      )
 768
 769                  ;; Look up the canoner for this operand and perform it.
 770                  ;; FIXME: This would benefit from returning multiple values.
 771                  (let ((canoner (cdr type)))
 772                    (let ((canon-val (canoner val mode this-expr op-num
 773                                              cstate env depth)))
 774                      (if canon-val
 775                          (begin
 776                            (set! val (car canon-val))
 777                            (set! env (cdr canon-val))))))
 778
 779                  (vector-set! operands op-num val)
 780
 781                  ;; Done with this operand, proceed to the next.
 782                  (loop env
 783                        (+ op-num 1)
 784                        (if varargs? arg-types (cdr arg-types))
 785                        (if varargs? arg-modes (cdr arg-modes)))))))))
 786 )
 787
 788 (define (/rtx-canon-rtx-enum rtx-obj requested-mode-name
 789                              func args parent-expr parent-op-num
 790                              cstate env depth)
 791   (if (!= (length args) 3)
 792       (/rtx-canon-error cstate "wrong number of operands to enum, expecting 3"
 793                         (cons func args) parent-expr #f))
 794
 795   (let ((mode-name (cadr args))
 796         (enum-name (caddr args)))
 797     (let ((mode-obj (mode:lookup mode-name))
 798           (enum-val-and-obj (enum-lookup-val enum-name)))
 799
 800       (if (not enum-val-and-obj)
 801           (/rtx-canon-error cstate "unknown enum value"
 802                             enum-name parent-expr #f))
 803
 804       (let ((expr-mode-or-errmsg (/rtx-pick-mode3 requested-mode-name mode-name INT)))
 805         (if (symbol? expr-mode-or-errmsg)
 806             (list (car args) expr-mode-or-errmsg enum-name)
 807             (/rtx-canon-error cstate expr-mode-or-errmsg
 808                               enum-name parent-expr #f)))))
 809 )
 810
 811 (define (/rtx-canon-rtx-ifield rtx-obj requested-mode-name
 812                                func args parent-expr parent-op-num
 813                                cstate env depth)
 814   (if (!= (length args) 3)
 815       (/rtx-canon-error cstate "wrong number of operands to ifield, expecting 3"
 816                         (cons func args) parent-expr #f))
 817
 818   (let ((expr-mode-name (cadr args))
 819         (ifld-name (caddr args)))
 820     (let ((ifld-obj (current-ifld-lookup ifld-name)))
 821
 822       (if ifld-obj
 823
 824           (let ((mode-or-errmsg (/rtx-pick-mode3 requested-mode-name
 825                                                  expr-mode-name
 826                                                  (ifld-mode ifld-obj))))
 827             (if (symbol? mode-or-errmsg)
 828                 (list (car args) mode-or-errmsg ifld-name)
 829                 (/rtx-canon-error cstate mode-or-errmsg expr-mode-name
 830                                   parent-expr parent-op-num)))
 831
 832           (/rtx-canon-error cstate "unknown ifield"
 833                             ifld-name parent-expr #f))))
 834 )
 835
 836 (define (/rtx-canon-rtx-operand rtx-obj requested-mode-name
 837                                 func args parent-expr parent-op-num
 838                                 cstate env depth)
 839   (if (!= (length args) 3)
 840       (/rtx-canon-error cstate "wrong number of operands to operand, expecting 3"
 841                         (cons func args) parent-expr #f))
 842
 843   (let ((expr-mode-name (cadr args))
 844         (op-name (caddr args)))
 845     (let ((op-obj (current-op-lookup op-name (/cstate-isas cstate))))
 846
 847       (if op-obj
 848
 849           (let ((mode (/rtx-pick-op-mode cstate requested-mode-name
 850                                          expr-mode-name op-obj parent-expr)))
 851             (list (car args) mode op-name))
 852
 853           (/rtx-canon-error cstate "unknown operand"
 854                             op-name parent-expr #f))))
 855 )
 856
 857 (define (/rtx-canon-rtx-xop rtx-obj requested-mode-name
 858                             func args parent-expr parent-op-num
 859                             cstate env depth)
 860   (if (!= (length args) 3)
 861       (/rtx-canon-error cstate "wrong number of operands to xop, expecting 3"
 862                         (cons func args) parent-expr #f))
 863
 864   (let ((expr-mode-name (cadr args))
 865         (xop-obj (caddr args)))
 866
 867     (if (operand? xop-obj)
 868
 869         (let ((mode-or-errmsg (/rtx-pick-mode3 requested-mode-name
 870                                                expr-mode-name
 871                                                (op:mode xop-obj))))
 872           (if (symbol? mode-or-errmsg)
 873               (list (car args) mode-or-errmsg xop-obj)
 874               (/rtx-canon-error cstate mode-or-errmsg expr-mode-name
 875                                 parent-expr parent-op-num)))
 876
 877         (/rtx-canon-error cstate "xop operand #2 not an operand"
 878                           (obj:name xop-obj) parent-expr #f)))
 879 )
 880
 881 (define (/rtx-canon-rtx-local rtx-obj requested-mode-name
 882                               func args parent-expr parent-op-num
 883                               cstate env depth)
 884   (if (!= (length args) 3)
 885       (/rtx-canon-error cstate "wrong number of operands to local, expecting 3"
 886                         (cons func args) parent-expr #f))
 887
 888   (let ((expr-mode-name (cadr args))
 889         (local-name (caddr args)))
 890     (let ((local-obj (rtx-temp-lookup env local-name)))
 891
 892       (if local-obj
 893
 894           (let ((mode-or-errmsg (/rtx-pick-mode3 requested-mode-name
 895                                                  expr-mode-name
 896                                                  (rtx-temp-mode local-obj))))
 897             (if (symbol? mode-or-errmsg)
 898                 (list (car args) mode-or-errmsg local-name)
 899                 (/rtx-canon-error cstate mode-or-errmsg expr-mode-name
 900                                   parent-expr parent-op-num)))
 901
 902           (/rtx-canon-error cstate "unknown local"
 903                             local-name parent-expr #f))))
 904 )
 905
 906 (define (/rtx-canon-rtx-ref rtx-obj requested-mode-name
 907                             func args parent-expr parent-op-num
 908                             cstate env depth)
 909   (if (!= (length args) 3)
 910       (/rtx-canon-error cstate "wrong number of operands to ref, expecting 3"
 911                         (cons func args) parent-expr #f))
 912
 913   (let ((expr-mode-name (cadr args))
 914         (ref-name (caddr args)))
 915     ;; FIXME: Will current-op-lookup find named operands?
 916     (let ((op-obj (current-op-lookup ref-name (/cstate-isas cstate))))
 917
 918       (if op-obj
 919
 920           ;; The result of "ref" is canonically an INT.
 921           (let ((mode-or-errmsg (/rtx-pick-mode3 requested-mode-name
 922                                                  expr-mode-name
 923                                                  INT)))
 924             (if (symbol? mode-or-errmsg)
 925                 (list (car args) mode-or-errmsg ref-name)
 926                 (/rtx-canon-error cstate mode-or-errmsg expr-mode-name
 927                                   parent-expr parent-op-num)))
 928
 929           (/rtx-canon-error cstate "unknown operand"
 930                             ref-name parent-expr #f))))
 931 )
 932
 933 (define (/rtx-canon-rtx-reg rtx-obj requested-mode-name
 934                             func args parent-expr parent-op-num
 935                             cstate env depth)
 936   (let ((len (length args)))
 937     (if (or (< len 3) (> len 5))
 938         (/rtx-canon-error cstate
 939                           ;; TODO: be more firm on expected number of args
 940                           (string-append
 941                            "wrong number of operands to "
 942                            (symbol->string func)
 943                            ", expecting 3 (or possibly 4,5)")
 944                           (cons func args) parent-expr #f))
 945
 946     (let ((expr-mode-name (cadr args))
 947           (hw-name (caddr args))
 948           (this-expr (cons func args)))
 949       (let* ((hw (/rtx-lookup-hw cstate hw-name parent-expr
 950                                  (lambda (hw)
 951                                    (if (not (register? hw))
 952                                        (/rtx-canon-error cstate "not a register" hw-name
 953                                                          parent-expr parent-op-num))
 954                                    *UNSPECIFIED*)))
 955              (hw-mode-obj (hw-mode hw)))
 956
 957         (let ((mode-or-errmsg (/rtx-pick-mode3 requested-mode-name
 958                                                expr-mode-name
 959                                                hw-mode-obj)))
 960
 961           (if (symbol? mode-or-errmsg)
 962
 963               ;; Canonicalizing optional index/selector.
 964               (let ((index (if (>= len 4)
 965                                (let ((canon (/rtx-canon-rtx
 966                                              (list-ref args 3) 'INT
 967                                              this-expr 3 cstate env depth)))
 968                                  (car canon)) ;; discard env
 969                                #f))
 970                     (sel (if (= len 5)
 971                              (let ((canon (/rtx-canon-rtx
 972                                            (list-ref args 4) 'INT
 973                                            this-expr 4 cstate env depth)))
 974                                (car canon)) ;; discard env
 975                              #f)))
 976                 (if sel
 977                     (begin
 978                       (assert index)
 979                       (list (car args) mode-or-errmsg hw-name index sel))
 980                     (if index
 981                         (list (car args) mode-or-errmsg hw-name index)
 982                         (list (car args) mode-or-errmsg hw-name))))
 983
 984               (/rtx-canon-error cstate mode-or-errmsg expr-mode-name
 985                                 parent-expr parent-op-num))))))
 986 )
 987
 988 (define (/rtx-canon-rtx-mem rtx-obj requested-mode-name
 989                             func args parent-expr parent-op-num
 990                             cstate env depth)
 991   (let ((len (length args)))
 992     (if (or (< len 3) (> len 4))
 993         (/rtx-canon-error cstate
 994                           "wrong number of operands to mem, expecting 3 (or possibly 4)"
 995                           (cons func args) parent-expr #f))
 996
 997     (let ((expr-mode-name (cadr args))
 998           (addr-expr (caddr args))
 999           (this-expr (cons func args)))
1000
1001       ;; Call /rtx-canon-explnummode just for the error checking.
1002       (/rtx-canon-explnummode expr-mode-name #f this-expr 1 cstate env depth)
1003
1004       (if (and (not (eq? requested-mode-name 'DFLT))
1005                ;; FIXME: 'would prefer samesize or "no precision lost", sigh
1006                (not (mode-compatible? 'sameclass
1007                                       requested-mode-name expr-mode-name)))
1008           (/rtx-canon-error cstate
1009                             (string-append "requested mode "
1010                                            (symbol->string requested-mode-name)
1011                                            " is incompatible with expression mode "
1012                                            (symbol->string expr-mode-name))
1013                             this-expr parent-expr #f))
1014
1015       (let ((addr (car ;; discard env
1016                    (/rtx-canon-rtx (list-ref args 2) 'AI
1017                                    this-expr 2 cstate env depth)))
1018             (sel (if (= len 4)
1019                      (let ((canon (/rtx-canon-rtx (list-ref args 3) 'INT
1020                                                   this-expr 3 cstate env depth)))
1021                        (car canon)) ;; discard env
1022                      #f)))
1023         (if sel
1024             (list (car args) expr-mode-name addr sel)
1025             (list (car args) expr-mode-name addr)))))
1026 )
1027
1028 (define (/rtx-canon-rtx-const rtx-obj requested-mode-name
1029                               func args parent-expr parent-op-num
1030                               cstate env depth)
1031   (if (!= (length args) 3)
1032       (/rtx-canon-error cstate "wrong number of operands to const, expecting 3"
1033                         (cons func args) parent-expr #f))
1034
1035   ;; ??? floating point support is wip
1036   ;; NOTE: (integer? 1.0) == #t, but (inexact? 1.0) ==> #t too.
1037
1038   (let ((expr-mode-name1 (if (and (eq? requested-mode-name 'DFLT)
1039                                   (eq? (cadr args) 'DFLT))
1040                              'INT
1041                              (cadr args)))
1042         (value (caddr args))
1043         (this-expr (cons func args)))
1044
1045     (let ((expr-mode-name (/rtx-pick-mode cstate requested-mode-name
1046                                           expr-mode-name1)))
1047
1048       (if (not expr-mode-name)
1049           (/rtx-canon-error cstate
1050                             (string-append "requested mode "
1051                                            (symbol->string requested-mode-name)
1052                                            " is incompatible with expression mode "
1053                                            (symbol->string expr-mode-name1))
1054                             this-expr parent-expr #f))
1055
1056       (let ((expr-mode (mode:lookup expr-mode-name)))
1057
1058         (cond ((integer? value)
1059                (if (not (memq (mode:class expr-mode) '(INT UINT FLOAT)))
1060                    (/rtx-canon-error cstate "integer value incompatible with mode"
1061                                      value this-expr 2)))
1062               ((inexact? value)
1063                (if (not (memq (mode:class expr-mode) '(FLOAT)))
1064                    (/rtx-canon-error cstate "floating point value incompatible with mode"
1065                                      value this-expr 2)))
1066               (else
1067                (/rtx-canon-error cstate
1068                                  (string-append "expecting a"
1069                                                 (if (eq? (mode:class expr-mode) 'FLOAT)
1070                                                     " floating point"
1071                                                     "n integer")
1072                                                 " constant")
1073                                  value this-expr 2)))
1074
1075         (list (car args) expr-mode-name value))))
1076 )
1077
1078 ;; Table of operand canonicalizers.
1079 ;; The main one is /rtx-traverse-operands, but a few rtx functions are simple
1080 ;; and special-purpose enough that it's simpler to have specific traversers.
1081
1082 (define /rtx-operand-canoners #f)
1083
1084 ;; Return list of rtx functions that have special purpose canoners.
1085
1086 (define (/rtx-special-expr-canoners)
1087   (list
1088    (cons 'enum /rtx-canon-rtx-enum)
1089    (cons 'ifield /rtx-canon-rtx-ifield)
1090    (cons 'operand /rtx-canon-rtx-operand)
1091    ;;(cons 'name /rtx-canon-rtx-name) ;; ??? needed?
1092    (cons 'xop /rtx-canon-rtx-xop) ;; yes, it can appear
1093    (cons 'local /rtx-canon-rtx-local)
1094    (cons 'ref /rtx-canon-rtx-ref)
1095    ;;(cons 'index-of /rtx-canon-rtx-index-of) ;; ??? needed?
1096    (cons 'reg /rtx-canon-rtx-reg)
1097    (cons 'raw-reg /rtx-canon-rtx-reg)
1098    (cons 'mem /rtx-canon-rtx-mem)
1099    (cons 'const /rtx-canon-rtx-const)
1100    )
1101 )
1102
1103 ;; Subroutine of rtx-munge-mode&options.
1104 ;; Return boolean indicating if X is an rtx option.
1105
1106 (define (/rtx-option? x)
1107   (keyword? x)
1108 )
1109
1110 ;; Subroutine of rtx-munge-mode&options.
1111 ;; Return boolean indicating if X is an rtx option list.
1112
1113 (define (/rtx-option-list? x)
1114   (or (null? x)
1115       (and (pair? x)
1116            (/rtx-option? (car x))))
1117 )
1118
1119 ;; Subroutine of /rtx-canon-expr to fill in the options and mode if absent.
1120 ;; The result is the canonical form of ARGS.
1121 ;;
1122 ;; "munge" is an awkward name to use here, but I like it for now because
1123 ;; it's easy to grep for.
1124 ;; An empty option list requires a mode to be present so that the empty
1125 ;; list in `(sequence () foo bar)' is unambiguously recognized as the locals
1126 ;; list.  Icky, sure, but less icky than the alternatives thus far.
1127
1128 (define (rtx-munge-mode&options rtx-obj requested-mode-name func args)
1129   (let ((orig-args args)
1130         (options #f)
1131         (mode-name #f)
1132         ;; The mode in a `set' is the mode of the destination,
1133         ;; whereas the mode of the result is VOID.
1134         ;; The mode in a compare (e.g. `eq') is the mode of the operands,
1135         ;; but the mode of the result is BI.
1136         (requested-mode-name (if (rtx-result-mode rtx-obj)
1137                                  'DFLT ;; mode of args doesn't come from containing expr
1138                                  'DFLT))) ;; FIXME: requested-mode-name)))
1139
1140     ;; Pick off the option list if present.
1141     (if (and (pair? args)
1142              (/rtx-option-list? (car args))
1143              ;; Handle `(sequence () foo bar)'.  If empty list isn't followed
1144              ;; by a mode, it is not an option list.
1145              (or (not (null? (car args)))
1146                  (and (pair? (cdr args))
1147                       (mode-name? (cadr args)))))
1148         (begin
1149           (set! options (car args))
1150           (set! args (cdr args))))
1151
1152     ;; Pick off the mode if present.
1153     (if (and (pair? args)
1154              (mode-name? (car args)))
1155         (begin
1156           (set! mode-name (car args))
1157           (set! args (cdr args))))
1158
1159     ;; Now put option list and mode back.
1160     ;; But don't do unnecessary consing.
1161     (if options
1162         (if (and mode-name (not (eq? mode-name 'DFLT)))
1163             orig-args ;; can return ARGS unchanged
1164             (cons options (cons requested-mode-name args)))
1165         (if (and mode-name (not (eq? mode-name 'DFLT)))
1166             (cons nil orig-args) ;; just need to insert options
1167             (cons nil (cons requested-mode-name args)))))
1168 )
1169
1170 ;; Subroutine of /rtx-canon to simplify it.
1171
1172 (define (/rtx-canon-expr rtx-obj requested-mode-name
1173                          func args parent-expr op-num cstate env depth)
1174   (let ((args2 (rtx-munge-mode&options rtx-obj requested-mode-name func args)))
1175
1176     (if /rtx-canon-debug?
1177         (begin
1178           (display (spaces (* 4 depth)))
1179           (display "Traversing operands of: ")
1180           (display (rtx-dump (cons func args)))
1181           (newline)
1182           (display (spaces (* 4 depth)))
1183           (display "Requested mode: ")
1184           (display requested-mode-name)
1185           (newline)
1186           (display (spaces (* 4 depth)))
1187           (rtx-env-stack-dump env)
1188           (force-output)))
1189
1190     (let* ((canoner (vector-ref /rtx-operand-canoners (rtx-num rtx-obj)))
1191            (operands (canoner rtx-obj requested-mode-name
1192                               func args2 parent-expr op-num
1193                               cstate env (+ depth 1))))
1194       (cons func operands)))
1195 )
1196
1197 ;; Convert rtl expression EXPR from source form to canonical form.
1198 ;; The expression is validated and rtx macros are expanded as well.
1199 ;; Plus DFLT mode is converted to a useful mode.
1200 ;; The result is EXPR in canonical form.
1201 ;;
1202 ;; CSTATE is a <cstate> object or #f if there is none.
1203 ;; It is used in error messages.
1204
1205 (define (/rtx-canon expr expected mode parent-expr op-num cstate env depth)
1206   (if /rtx-canon-debug?
1207       (begin
1208         (display (spaces (* 4 depth)))
1209         (display "Canonicalizing (")
1210         (display mode)
1211         (display "): ")
1212         (display (rtx-dump expr))
1213         (newline)
1214         (display (spaces (* 4 depth)))
1215         (rtx-env-stack-dump env)
1216         (force-output)
1217         ))
1218
1219   (let ((result
1220          (if (pair? expr) ;; pair? -> cheap non-null-list?
1221
1222              (let ((rtx-name (car expr)))
1223                (if (not (symbol? rtx-name))
1224                    (/rtx-canon-error cstate "invalid rtx function name"
1225                                      expr parent-expr op-num))
1226                (let ((rtx-obj (rtx-lookup rtx-name)))
1227                  (if rtx-obj
1228                      (let ((canon-expr
1229                             (/rtx-canon-expr rtx-obj mode rtx-name (cdr expr)
1230                                              parent-expr op-num cstate env depth)))
1231                        (if (eq? mode 'VOID)
1232                            (let ((expr-mode (or (rtx-result-mode rtx-obj)
1233                                                 (rtx-mode canon-expr))))
1234                              (if (not (eq? expr-mode 'VOID))
1235                                  (/rtx-canon-error cstate "non-VOID-mode expression"
1236                                                    expr parent-expr op-num))))
1237                        canon-expr)
1238                      (let ((rtx-obj (/rtx-macro-lookup rtx-name)))
1239                        (if rtx-obj
1240                            (/rtx-canon (/rtx-macro-expand expr rtx-evaluator)
1241                                        expected mode parent-expr op-num cstate env (+ depth 1))
1242                            (/rtx-canon-error cstate "unknown rtx function"
1243                                              expr parent-expr op-num))))))
1244
1245              ;; EXPR is not a list.
1246              ;; See if it's an operand shortcut.
1247              (if (memq expected '(RTX SETRTX))
1248
1249                  (begin
1250                    (if (eq? mode 'VOID)
1251                        (/rtx-canon-error cstate "non-VOID-mode expression"
1252                                          expr parent-expr op-num))
1253                    (cond ((symbol? expr)
1254                           (cond ((current-op-lookup expr (/cstate-isas cstate))
1255                                  => (lambda (op)
1256                                       ;; NOTE: We can't simply call
1257                                       ;; op:mode-name here, we need the real
1258                                       ;; mode, not (potentially) DFLT.
1259                                       ;; See /rtx-pick-op-mode.
1260                                       (rtx-make-operand (/rtx-pick-op-mode cstate mode 'DFLT op parent-expr)
1261                                                         expr)))
1262                                 ((rtx-temp-lookup env expr)
1263                                  => (lambda (tmp)
1264                                       (rtx-make-local (obj:name (rtx-temp-mode tmp)) expr)))
1265                                 ((current-ifld-lookup expr)
1266                                  => (lambda (f)
1267                                       (rtx-make-ifield (obj:name (ifld-mode f)) expr)))
1268                                 ((enum-lookup-val expr)
1269                                  ;; ??? If enums could have modes other than INT,
1270                                  ;; we'd want to propagate that mode here.
1271                                  (rtx-make-enum 'INT expr))
1272                                 (else
1273                                  (/rtx-canon-error cstate "unknown operand"
1274                                                    expr parent-expr op-num))))
1275                          ((integer? expr)
1276                           (rtx-make-const 'INT expr))
1277                          (else
1278                           (/rtx-canon-error cstate "unexpected operand"
1279                                             expr parent-expr op-num))))
1280
1281                  ;; Not expecting RTX or SETRTX.
1282                  (/rtx-canon-error cstate "unexpected operand"
1283                                    expr parent-expr op-num)))))
1284
1285     (if /rtx-canon-debug?
1286         (begin
1287           (display (spaces (* 4 depth)))
1288           (display "Result: ")
1289           (display (rtx-dump result))
1290           (newline)
1291           (force-output)
1292           ))
1293
1294     result)
1295 )
1296
1297 ;; Public entry point.
1298 ;; Convert rtl expression EXPR from source form to canonical form.
1299 ;; The expression is validated and rtx macros are expanded as well.
1300 ;; Plus operand shortcuts are expanded:
1301 ;;   - numbers -> (const number)
1302 ;;   - operand-name -> (operand operand-name)
1303 ;;   - ifield-name -> (ifield ifield-name)
1304 ;; Plus an absent option list is replaced with ().
1305 ;; Plus DFLT mode is converted to a useful mode.
1306 ;; Plus the specified isa-name-list is recorded in the RTL.
1307 ;;
1308 ;; The result is EXPR in canonical form.
1309 ;;
1310 ;; CONTEXT is a <context> object or #f if there is none.
1311 ;; It is used in error messages.
1312 ;;
1313 ;; ISA-NAME-LIST is a list of ISAs in which to evaluate the expression,
1314 ;; e.g. to do operand lookups.
1315 ;; The ISAs must be compatible, e.g. operand lookups must be unambiguous.
1316 ;;
1317 ;; MODE-NAME is the requested mode of the result, or DFLT.
1318 ;;
1319 ;; EXTRA-VARS-ALIST is an association list of extra (symbol <mode> value)
1320 ;; elements to be used during value lookup.
1321 ;; VALUE can be #f which means the value is assumed to be known, but is
1322 ;; currently unrepresentable.  This is used, for example, when representing
1323 ;; ifield setters: we don't know the new value, but it will be known when the
1324 ;; rtx is evaluated (??? Sigh, this is a bit of a cheat, closures have no
1325 ;; such thing, but it's useful here because we don't necessarily know what
1326 ;; the value will be in the application side of things).
1327
1328 (define (rtx-canonicalize context mode-name isa-name-list extra-vars-alist expr)
1329   (let ((result
1330          (/rtx-canon expr 'RTX mode-name #f 0
1331                      (/make-cstate context isa-name-list expr)
1332                      (rtx-env-init-stack1 extra-vars-alist) 0)))
1333     (rtx-verify-no-dflt-modes context result)
1334     (rtx-make 'closure mode-name isa-name-list
1335               (rtx-var-alist-to-closure-env-stack extra-vars-alist)
1336               result))
1337 )
1338 \f
1339 ;; RTL expression traversal support.
1340 ;; This is for analyzing the semantics in some way.
1341 ;; The rtl must already be in canonical form.
1342
1343 ;; Set to #t to debug rtx traversal.
1344
1345 (define /rtx-traverse-debug? #f)
1346
1347 ; Container to record the current state of traversal.
1348 ; This is initialized before traversal, and modified (in a copy) as the
1349 ; traversal state changes.
1350 ; This doesn't record all traversal state, just the more static elements.
1351 ; There's no point in recording things like the parent expression and operand
1352 ; position as they change for every sub-traversal.
1353 ; The main raison d'etre for this class is so we can add more state without
1354 ; having to modify all the traversal handlers.
1355 ; ??? At present it's not a proper "class" as there's no real need.
1356 ;
1357 ; CONTEXT is a <context> object or #f if there is none.
1358 ; It is used for error messages.
1359 ;
1360 ; EXPR-FN is a dual-purpose beast.  The first purpose is to just process
1361 ; the current expression and return the result.  The second purpose is to
1362 ; lookup the function which will then process the expression.
1363 ; It is applied recursively to the expression and each sub-expression.
1364 ; It must be defined as
1365 ; (lambda (rtx-obj expr parent-expr op-pos tstate appstuff) ...).
1366 ; If the result of EXPR-FN is a lambda, it is applied to
1367 ; (cons TSTATE EXPR), TSTATE is prepended to the arguments.
1368 ; For syntax expressions if the result of EXPR-FN is #f, the operands are
1369 ; processed using the builtin traverser.
1370 ; So to repeat: EXPR-FN can process the expression, and if its result is a
1371 ; lambda then it also processes the expression.  The arguments to EXPR-FN
1372 ; are (rtx-obj expr parent-expr op-pos tstate appstuff).  The format
1373 ; of the result of EXPR-FN are (cons TSTATE EXPR).
1374 ; The reason for the duality is that when trying to understand EXPR (e.g. when
1375 ; computing the insn format) EXPR-FN processes the expression itself, and
1376 ; when evaluating EXPR it's the result of EXPR-FN that computes the value.
1377 ;
1378 ; ISAS is a list of ISA name(s) in which to evaluate the expression.
1379 ;
1380 ; ENV is the current environment.  This is a stack of sequence locals.
1381 ;
1382 ; COND? is a boolean indicating if the current expression is on a conditional
1383 ; execution path.  This is for optimization purposes only and it is always ok
1384 ; to pass #t, except for the top-level caller which must pass #f (since the top
1385 ; level expression obviously isn't subject to any condition).
1386 ; It is used, for example, to speed up the simulator: there's no need to keep
1387 ; track of whether an operand has been assigned to (or potentially read from)
1388 ; if it's known it's always assigned to.
1389 ;
1390 ; OWNER is the owner of the expression or #f if there is none.
1391 ; Typically it is an <insn> object.
1392 ;
1393 ; KNOWN is an alist of known values.  This is used by rtx-simplify.
1394 ; Each element is (name . value) where
1395 ; NAME is a scalar ifield name (in the future it might be an operand name or
1396 ; sequence local name), and
1397 ; VALUE is a const rtx, (const () mode value),
1398 ; or a number-list rtx, (number-list () mode value1 [value2 ...]).
1399 ; A "scalar ifield" is a simple ifield (not a multi or derived ifield),
1400 ; or a multi-ifield consisting of only simple ifields.
1401 ;
1402 ; DEPTH is the current traversal depth.
1403
1404 (define (tstate-make context owner expr-fn isas env cond? known depth)
1405   (vector context owner expr-fn isas env cond? known depth)
1406 )
1407
1408 (define (tstate-context state)               (vector-ref state 0))
1409 (define (tstate-set-context! state newval)   (vector-set! state 0 newval))
1410 (define (tstate-owner state)                 (vector-ref state 1))
1411 (define (tstate-set-owner! state newval)     (vector-set! state 1 newval))
1412 (define (tstate-expr-fn state)               (vector-ref state 2))
1413 (define (tstate-set-expr-fn! state newval)   (vector-set! state 2 newval))
1414 (define (tstate-isas state)                  (vector-ref state 3))
1415 (define (tstate-set-isas! state newval)      (vector-set! state 3 newval))
1416 (define (tstate-env-stack state)             (vector-ref state 4))
1417 (define (tstate-set-env-stack! state newval) (vector-set! state 4 newval))
1418 (define (tstate-cond? state)                 (vector-ref state 5))
1419 (define (tstate-set-cond?! state newval)     (vector-set! state 5 newval))
1420 (define (tstate-known state)                 (vector-ref state 6))
1421 (define (tstate-set-known! state newval)     (vector-set! state 6 newval))
1422 (define (tstate-depth state)                 (vector-ref state 7))
1423 (define (tstate-set-depth! state newval)     (vector-set! state 7 newval))
1424
1425 ; Create a copy of STATE.
1426
1427 (define (tstate-copy state)
1428   ; A fast vector-copy would be nice, but this is simple and portable.
1429   (list->vector (vector->list state))
1430 )
1431
1432 ;; Create a copy of STATE with environment stack ENV-STACK added,
1433 ;; and the ISA(s) set to ISA-NAME-LIST.
1434
1435 (define (tstate-make-closure state isa-name-list env-stack)
1436   (let ((result (tstate-copy state)))
1437     (tstate-set-isas! result isa-name-list)
1438     (tstate-set-env-stack! result (append env-stack (tstate-env-stack result)))
1439     result)
1440 )
1441
1442 ; Create a copy of STATE with environment ENV pushed onto the existing
1443 ; environment list.
1444 ; There's no routine to pop the environment list as there's no current
1445 ; need for it: we make a copy of the state when we push.
1446
1447 (define (tstate-push-env state env)
1448   (let ((result (tstate-copy state)))
1449     (tstate-set-env-stack! result (cons env (tstate-env-stack result)))
1450     result)
1451 )
1452
1453 ; Create a copy of STATE with a new COND? value.
1454
1455 (define (tstate-new-cond? state cond?)
1456   (let ((result (tstate-copy state)))
1457     (tstate-set-cond?! result cond?)
1458     result)
1459 )
1460
1461 ; Lookup NAME in the known value table.
1462 ; Returns the value or #f if not found.
1463 ; The value is either a const rtx or a number-list rtx.
1464
1465 (define (tstate-known-lookup tstate name)
1466   (let ((known (tstate-known tstate)))
1467     (assq-ref known name))
1468 )
1469
1470 ; Increment the recorded traversal depth of TSTATE.
1471
1472 (define (tstate-incr-depth! tstate)
1473   (tstate-set-depth! tstate (1+ (tstate-depth tstate)))
1474 )
1475
1476 ; Decrement the recorded traversal depth of TSTATE.
1477
1478 (define (tstate-decr-depth! tstate)
1479   (tstate-set-depth! tstate (1- (tstate-depth tstate)))
1480 )
1481
1482 ; Issue an error given a tstate.
1483
1484 (define (tstate-error tstate errmsg . expr)
1485   (apply context-owner-error
1486          (cons (tstate-context tstate)
1487                (cons (tstate-owner tstate)
1488                      (cons "During rtx traversal"
1489                            (cons errmsg expr)))))
1490 )
1491 \f
1492 ; Traversal support.
1493
1494 ; Return a boolean indicating if X is a mode.
1495
1496 (define (/rtx-any-mode? x)
1497   (->bool (mode:lookup x))
1498 )
1499
1500 ; Return a boolean indicating if X is a symbol or rtx.
1501
1502 (define (/rtx-symornum? x)
1503   (or (symbol? x) (number? x))
1504 )
1505
1506 ; Traverse a list of rtx's.
1507
1508 (define (/rtx-traverse-rtx-list rtx-list expr op-num tstate appstuff)
1509   (map (lambda (rtx)
1510          ; ??? Shouldn't OP-NUM change for each element?
1511          (/rtx-traverse rtx 'RTX expr op-num tstate appstuff))
1512        rtx-list)
1513 )
1514
1515 ; Cover-fn to tstate-error for signalling an error during rtx traversal
1516 ; of operand OP-NUM.
1517 ; RTL-EXPR must be an rtl expression.
1518
1519 (define (/rtx-traverse-error tstate errmsg rtl-expr op-num)
1520   (tstate-error tstate
1521                 (string-append errmsg ", operand #" (number->string op-num))
1522                 (rtx-dump rtl-expr))
1523 )
1524
1525 ; Rtx traversers.
1526 ;
1527 ; The result is either a pair of the parsed VAL and new TSTATE,
1528 ; or #f meaning there is no change (saves lots of unnecessarying cons'ing).
1529
1530 (define (/rtx-traverse-normal-operand val expr op-num tstate appstuff)
1531   #f
1532 )
1533
1534 (define (/rtx-traverse-rtx val expr op-num tstate appstuff)
1535   (cons (/rtx-traverse val 'RTX expr op-num tstate appstuff)
1536         tstate)
1537 )
1538
1539 (define (/rtx-traverse-setrtx val expr op-num tstate appstuff)
1540   (cons (/rtx-traverse val 'SETRTX expr op-num tstate appstuff)
1541         tstate)
1542 )
1543
1544 ; This is the test of an `if'.
1545
1546 (define (/rtx-traverse-testrtx val expr op-num tstate appstuff)
1547   (cons (/rtx-traverse val 'RTX expr op-num tstate appstuff)
1548         (tstate-new-cond?
1549          tstate
1550          (not (rtx-compile-time-constant? val))))
1551 )
1552
1553 (define (/rtx-traverse-condrtx val expr op-num tstate appstuff)
1554   (if (eq? (car val) 'else)
1555       (cons (cons 'else
1556                   (/rtx-traverse-rtx-list
1557                    (cdr val) expr op-num
1558                    (tstate-new-cond? tstate #t)
1559                    appstuff))
1560             (tstate-new-cond? tstate #t))
1561       (cons (cons
1562              ; ??? Entries after the first are conditional.
1563              (/rtx-traverse (car val) 'RTX expr op-num tstate appstuff)
1564              (/rtx-traverse-rtx-list
1565               (cdr val) expr op-num
1566               (tstate-new-cond? tstate #t)
1567               appstuff))
1568             (tstate-new-cond? tstate #t)))
1569 )
1570
1571 (define (/rtx-traverse-casertx val expr op-num tstate appstuff)
1572   (cons (cons (car val)
1573               (/rtx-traverse-rtx-list
1574                (cdr val) expr op-num
1575                (tstate-new-cond? tstate #t)
1576                appstuff))
1577         (tstate-new-cond? tstate #t))
1578 )
1579
1580 (define (/rtx-traverse-locals val expr op-num tstate appstuff)
1581   (let ((env (rtx-env-make-locals val)))
1582     (cons val (tstate-push-env tstate env)))
1583 )
1584
1585 (define (/rtx-traverse-iteration val expr op-num tstate appstuff)
1586   (let ((env (rtx-env-make-iteration-locals val)))
1587     (cons val (tstate-push-env tstate env)))
1588 )
1589
1590 (define (/rtx-traverse-attrs val expr op-num tstate appstuff)
1591 ;  (cons val ; (atlist-source-form (atlist-parse (make-prefix-context "with-attr") val ""))
1592 ;       tstate)
1593   #f
1594 )
1595
1596 ; Table of rtx traversers.
1597 ; This is a vector of size rtx-max-num.
1598 ; Each entry is a list of (arg-type-name . traverser) elements
1599 ; for rtx-arg-types.
1600 ; FIXME: Initialized in rtl.scm (i.e. outside this file).
1601
1602 (define /rtx-traverser-table #f)
1603
1604 ; Return a hash table of standard operand traversers.
1605 ; The result of each traverser is a pair of the compiled form of `val' and
1606 ; a possibly new traversal state or #f if there is no change.
1607
1608 (define (/rtx-make-traverser-table)
1609   (let ((hash-tab (make-hash-table 31))
1610         (traversers
1611          (list
1612           (cons 'OPTIONS /rtx-traverse-normal-operand)
1613           (cons 'ANYINTMODE /rtx-traverse-normal-operand)
1614           (cons 'ANYFLOATMODE /rtx-traverse-normal-operand)
1615           (cons 'ANYNUMMODE /rtx-traverse-normal-operand)
1616           (cons 'ANYEXPRMODE /rtx-traverse-normal-operand)
1617           (cons 'ANYCEXPRMODE /rtx-traverse-normal-operand)
1618           (cons 'EXPLNUMMODE /rtx-traverse-normal-operand)
1619           (cons 'VOIDORNUMMODE /rtx-traverse-normal-operand)
1620           (cons 'VOIDMODE /rtx-traverse-normal-operand)
1621           (cons 'BIMODE /rtx-traverse-normal-operand)
1622           (cons 'INTMODE /rtx-traverse-normal-operand)
1623           (cons 'SYMMODE /rtx-traverse-normal-operand)
1624           (cons 'INSNMODE /rtx-traverse-normal-operand)
1625           (cons 'MACHMODE /rtx-traverse-normal-operand)
1626           (cons 'RTX /rtx-traverse-rtx)
1627           (cons 'SETRTX /rtx-traverse-setrtx)
1628           (cons 'TESTRTX /rtx-traverse-testrtx)
1629           (cons 'CONDRTX /rtx-traverse-condrtx)
1630           (cons 'CASERTX /rtx-traverse-casertx)
1631           (cons 'LOCALS /rtx-traverse-locals)
1632           (cons 'ITERATION /rtx-traverse-iteration)
1633           ;; NOTE: Closure isas and env are handled in /rtx-traverse.
1634           (cons 'SYMBOLLIST /rtx-traverse-normal-operand)
1635           (cons 'ENVSTACK /rtx-traverse-normal-operand)
1636           (cons 'ATTRS /rtx-traverse-attrs)
1637           (cons 'SYMBOL /rtx-traverse-normal-operand)
1638           (cons 'STRING /rtx-traverse-normal-operand)
1639           (cons 'NUMBER /rtx-traverse-normal-operand)
1640           (cons 'SYMORNUM /rtx-traverse-normal-operand)
1641           (cons 'OBJECT /rtx-traverse-normal-operand)
1642           )))
1643
1644     (for-each (lambda (traverser)
1645                 (hashq-set! hash-tab (car traverser) (cdr traverser)))
1646               traversers)
1647
1648     hash-tab)
1649 )
1650
1651 ; Traverse the operands of EXPR, a canonicalized RTL expression.
1652 ; Here "canonicalized" means that EXPR has been run through rtx-canonicalize.
1653 ; Note that this means that, yes, the options and mode are "traversed" too.
1654
1655 (define (/rtx-traverse-operands rtx-obj expr tstate appstuff)
1656   (if /rtx-traverse-debug?
1657       (begin
1658         (display (spaces (* 4 (tstate-depth tstate))))
1659         (display "Traversing operands of: ")
1660         (display (rtx-dump expr))
1661         (newline)
1662         (rtx-env-stack-dump (tstate-env-stack tstate))
1663         (force-output)))
1664
1665   (let loop ((operands (cdr expr))
1666              (op-num 0)
1667              (arg-types (vector-ref /rtx-traverser-table (rtx-num rtx-obj)))
1668              (arg-modes (rtx-arg-modes rtx-obj))
1669              (result nil))
1670
1671     (let ((varargs? (and (pair? arg-types) (symbol? (car arg-types)))))
1672
1673       (if /rtx-traverse-debug?
1674           (begin
1675             (display (spaces (* 4 (tstate-depth tstate))))
1676             (if (null? operands)
1677                 (display "end of operands")
1678                 (begin
1679                   (display "op-num ") (display op-num) (display ": ")
1680                   (display (rtx-dump (car operands)))
1681                   (display ", ")
1682                   (display (if varargs? (car arg-types) (caar arg-types)))
1683                   (display ", ")
1684                   (display (if varargs? arg-modes (car arg-modes)))
1685                   ))
1686             (newline)
1687             (force-output)))
1688
1689       (cond ((null? operands)
1690              ;; Out of operands, check if we have the expected number.
1691              (if (or (null? arg-types)
1692                      varargs?)
1693                  (reverse! result)
1694                  (tstate-error tstate "missing operands" (rtx-dump expr))))
1695
1696             ((null? arg-types)
1697              (tstate-error tstate "too many operands" (rtx-dump expr)))
1698
1699             (else
1700              (let* ((val (car operands))
1701                     (type (if varargs? arg-types (car arg-types))))
1702
1703                ;; Look up the traverser for this kind of operand and perform it.
1704                ;; FIXME: This would benefit from returning multiple values.
1705                (let ((traverser (cdr type)))
1706                  (let ((traversed-val (traverser val expr op-num tstate appstuff)))
1707                    (if traversed-val
1708                        (begin
1709                          (set! val (car traversed-val))
1710                          (set! tstate (cdr traversed-val))))))
1711
1712                ;; Done with this operand, proceed to the next.
1713                (loop (cdr operands)
1714                      (+ op-num 1)
1715                      (if varargs? arg-types (cdr arg-types))
1716                      (if varargs? arg-modes (cdr arg-modes))
1717                      (cons val result)))))))
1718 )
1719
1720 ; Publically accessible version of /rtx-traverse-operands as EXPR-FN may
1721 ; need to call it.
1722
1723 (define rtx-traverse-operands /rtx-traverse-operands)
1724
1725 ; Subroutine of /rtx-traverse to traverse an expression.
1726 ;
1727 ; RTX-OBJ is the <rtx-func> object of the (outer) expression being traversed.
1728 ;
1729 ; EXPR is the expression to be traversed.
1730 ; It must be fully canonical.
1731 ;
1732 ; PARENT-EXPR is the expression EXPR is contained in.  The top-level
1733 ; caller must pass #f for it.
1734 ;
1735 ; OP-POS is the position EXPR appears in PARENT-EXPR.  The
1736 ; top-level caller must pass 0 for it.
1737 ;
1738 ; TSTATE is the current traversal state.
1739 ;
1740 ; APPSTUFF is for application specific use.
1741 ;
1742 ; For syntax expressions arguments are not pre-evaluated before calling the
1743 ; user's expression handler.  Otherwise they are.
1744 ;
1745 ; If (tstate-expr-fn TSTATE) wants to just scan the operands, rather than
1746 ; evaluating them, one thing it can do is call back to rtx-traverse-operands.
1747 ; If (tstate-expr-fn TSTATE) returns #f, traverse the operands normally and
1748 ; return (rtx's-name ([options]) mode traversed-operand1 ...),
1749 ; i.e., the canonicalized form.
1750 ; This is for semantic-compile's sake and all traversal handlers are
1751 ; required to do this if the expr-fn returns #f.
1752
1753 (define (/rtx-traverse-expr rtx-obj expr parent-expr op-pos tstate appstuff)
1754   (let ((fn ((tstate-expr-fn tstate)
1755              rtx-obj expr parent-expr op-pos tstate appstuff)))
1756     (if fn
1757         (if (procedure? fn)
1758             ; Don't traverse operands for syntax expressions.
1759             (if (eq? (rtx-style rtx-obj) 'SYNTAX)
1760                 (apply fn (cons tstate cdr expr))
1761                 (let ((operands (/rtx-traverse-operands rtx-obj expr tstate appstuff)))
1762                   (apply fn (cons tstate operands))))
1763             fn)
1764         (let ((operands (/rtx-traverse-operands rtx-obj expr tstate appstuff)))
1765           (cons (car expr) operands))))
1766 )
1767
1768 ; Main entry point for expression traversal.
1769 ; (Actually rtx-traverse is, but it's just a cover function for this.)
1770 ;
1771 ; The result is the result of the lambda (tstate-expr-fn TSTATE) looks up
1772 ; in the case of expressions, or an operand object (usually <operand>)
1773 ; in the case of operands.
1774 ;
1775 ; EXPR is the expression to be traversed.
1776 ; It must be fully canonical.
1777 ;
1778 ; EXPECTED is one of `-rtx-valid-types' and indicates the expected rtx type
1779 ; or #f if it doesn't matter.
1780 ;
1781 ; PARENT-EXPR is the expression EXPR is contained in.  The top-level
1782 ; caller must pass #f for it.
1783 ;
1784 ; OP-POS is the position EXPR appears in PARENT-EXPR.  The
1785 ; top-level caller must pass 0 for it.
1786 ;
1787 ; TSTATE is the current traversal state.
1788 ;
1789 ; APPSTUFF is for application specific use.
1790
1791 (define (/rtx-traverse expr expected parent-expr op-pos tstate appstuff)
1792   (if /rtx-traverse-debug?
1793       (begin
1794         (display (spaces (* 4 (tstate-depth tstate))))
1795         (display "Traversing expr: ")
1796         (display expr)
1797         (newline)
1798         (display (spaces (* 4 (tstate-depth tstate))))
1799         (display "-expected:       ")
1800         (display expected)
1801         (newline)
1802         (display (spaces (* 4 (tstate-depth tstate))))
1803         (display "-conditional:    ")
1804         (display (tstate-cond? tstate))
1805         (newline)
1806         (force-output)
1807         ))
1808
1809   ;; FIXME: error checking here should be deleteable.
1810
1811   (if (pair? expr) ; pair? -> cheap non-null-list?
1812
1813       (let* ((rtx-name (car expr))
1814              (rtx-obj (rtx-lookup rtx-name))
1815              ;; If this is a closure, update tstate.
1816              ;; ??? This is a bit of a wart.  All other rtxes handle their
1817              ;; special args/needs via rtx-arg-types.  Left as is to simmer.
1818              (tstate (if (eq? rtx-name 'closure)
1819                          (tstate-make-closure tstate
1820                                               (rtx-closure-isas expr)
1821                                               (rtx-make-env-stack (rtx-closure-env-stack expr)))
1822                          tstate)))
1823         (tstate-incr-depth! tstate)
1824         (let ((result
1825                (if rtx-obj
1826                    (/rtx-traverse-expr rtx-obj expr parent-expr op-pos tstate appstuff)
1827                    (let ((rtx-obj (/rtx-macro-lookup rtx-name)))
1828                      (if rtx-obj
1829                          (/rtx-traverse (/rtx-macro-expand expr rtx-evaluator)
1830                                         expected parent-expr op-pos tstate appstuff)
1831                          (tstate-error tstate "unknown rtx function" expr))))))
1832           (tstate-decr-depth! tstate)
1833           result))
1834
1835       ; EXPR is not a list.
1836       ; See if it's an operand shortcut.
1837       ; FIXME: Can we get here any more? [now that EXPR is already canonical]
1838       (if (memq expected '(RTX SETRTX))
1839
1840           (cond ((symbol? expr)
1841                  (cond ((current-op-lookup expr (tstate-isas tstate))
1842                         => (lambda (op)
1843                              (/rtx-traverse
1844                               ;; NOTE: Can't call op:mode-name here, we need
1845                               ;; the real mode, not (potentially) DFLT.
1846                               (rtx-make-operand (obj:name (op:mode op)) expr)
1847                               expected parent-expr op-pos tstate appstuff)))
1848                        ((rtx-temp-lookup (tstate-env-stack tstate) expr)
1849                         => (lambda (tmp)
1850                              (/rtx-traverse
1851                               (rtx-make-local (rtx-temp-mode tmp) expr)
1852                               expected parent-expr op-pos tstate appstuff)))
1853                        ((current-ifld-lookup expr)
1854                         => (lambda (f)
1855                              (/rtx-traverse
1856                               (rtx-make-ifield (obj:name (ifld-mode f)) expr)
1857                               expected parent-expr op-pos tstate appstuff)))
1858                        ((enum-lookup-val expr)
1859                         ;; ??? If enums could have modes other than INT,
1860                         ;; we'd want to propagate that mode here.
1861                         (/rtx-traverse
1862                          (rtx-make-enum 'INT expr)
1863                          expected parent-expr op-pos tstate appstuff))
1864                        (else
1865                         (tstate-error tstate "unknown operand" expr))))
1866                 ((integer? expr)
1867                  (/rtx-traverse (rtx-make-const 'INT expr)
1868                                 expected parent-expr op-pos tstate appstuff))
1869                 (else
1870                  (tstate-error tstate "unexpected operand" expr)))
1871
1872           ; Not expecting RTX or SETRTX.
1873           (tstate-error tstate "unexpected operand" expr)))
1874 )
1875
1876 ; User visible procedures to traverse an rtl expression.
1877 ; EXPR must be fully canonical.
1878 ; These calls /rtx-traverse to do most of the work.
1879 ; See tstate-make for explanations of OWNER, EXPR-FN.
1880 ; CONTEXT is a <context> object or #f if there is none.
1881 ; LOCALS is a list of (mode . name) elements (the locals arg to `sequence').
1882 ; APPSTUFF is for application specific use.
1883
1884 (define (rtx-traverse context owner expr expr-fn appstuff)
1885   (/rtx-traverse expr #f #f 0
1886                  (tstate-make context owner expr-fn
1887                               #f ;; ok since EXPR is fully canonical
1888                               (rtx-env-empty-stack)
1889                               #f nil 0)
1890                  appstuff)
1891 )
1892
1893 (define (rtx-traverse-with-locals context owner expr expr-fn locals appstuff)
1894   (/rtx-traverse expr #f #f 0
1895                  (tstate-make context owner expr-fn
1896                               #f ;; ok since EXPR is fully canonical
1897                               (rtx-env-push (rtx-env-empty-stack)
1898                                             (rtx-env-make-locals locals))
1899                               #f nil 0)
1900                  appstuff)
1901 )
1902
1903 ; Traverser debugger.
1904 ; This just traverses EXPR printing everything it sees.
1905
1906 (define (rtx-traverse-debug expr)
1907   (rtx-traverse
1908    #f #f expr
1909    (lambda (rtx-obj expr parent-expr op-pos tstate appstuff)
1910      (display "-expr:    ")
1911      (display (string-append "rtx=" (obj:str-name rtx-obj)))
1912      (display " expr=")
1913      (display expr)
1914      (display " parent=")
1915      (display parent-expr)
1916      (display " op-pos=")
1917      (display op-pos)
1918      (display " cond?=")
1919      (display (tstate-cond? tstate))
1920      (newline)
1921      #f)
1922    #f
1923    )
1924 )
1925 \f
1926 ; RTL evaluation state.
1927 ; Applications may subclass <eval-state> if they need to add things.
1928 ;
1929 ; This is initialized before evaluation, and modified (in a copy) as the
1930 ; evaluation state changes.
1931 ; This doesn't record all evaluation state, just the less dynamic elements.
1932 ; There's no point in recording things like the parent expression and operand
1933 ; position as they change for every sub-eval.
1934 ; The main raison d'etre for this class is so we can add more state without
1935 ; having to modify all the eval handlers.
1936
1937 (define <eval-state>
1938   (class-make '<eval-state> nil
1939               '(
1940                 ; <context> object or #f if there is none
1941                 (context . #f)
1942
1943                 ; Current object rtl is being evaluated for.
1944                 ; We need to be able to access the current instruction while
1945                 ; generating semantic code.  However, the semantic description
1946                 ; doesn't specify it as an argument to anything (and we don't
1947                 ; want it to).  So we record the value here.
1948                 (owner . #f)
1949
1950                 ;; The outer expr being evaluated, for error messages.
1951                 ;; #f if there is none.
1952                 (outer-expr . #f)
1953
1954                 ; EXPR-FN is a dual-purpose beast.  The first purpose is to
1955                 ; just process the current expression and return the result.
1956                 ; The second purpose is to lookup the function which will then
1957                 ; process the expression.  It is applied recursively to the
1958                 ; expression and each sub-expression.  It must be defined as
1959                 ; (lambda (rtx-obj expr mode estate) ...).
1960                 ; If the result of EXPR-FN is a lambda, it is applied to
1961                 ; (cons ESTATE (cdr EXPR)).  ESTATE is prepended to the
1962                 ; arguments.
1963                 ; For syntax expressions if the result of EXPR-FN is #f,
1964                 ; the operands are processed using the builtin evaluator.
1965                 ; FIXME: This special handling of syntax expressions is
1966                 ; not currently done.
1967                 ; So to repeat: EXPR-FN can process the expression, and if its
1968                 ; result is a lambda then it also processes the expression.
1969                 ; The arguments to EXPR-FN are
1970                 ; (rtx-obj expr mode estate).
1971                 ; The arguments to the result of EXPR-FN are
1972                 ; (cons ESTATE (cdr EXPR)).
1973                 ; The reason for the duality is mostly history.
1974                 ; In time things should be simplified.
1975                 (expr-fn . #f)
1976
1977                 ; List of ISA name(s) in which to evaluate the expression.
1978                 ; This is used for example during operand lookups.
1979                 ; All specified ISAs must be compatible,
1980                 ; e.g. operand lookups must be unambiguous.
1981                 ; A value of #f means "all ISAs".
1982                 (isas . #f)
1983
1984                 ; Current environment.  This is a stack of sequence locals,
1985                 ; e.g. made with rtx-env-init-stack1.
1986                 (env-stack . ())
1987
1988                 ; Current evaluation depth.  This is used, for example, to
1989                 ; control indentation in generated output.
1990                 (depth . 0)
1991
1992                 ; Associative list of modifiers.
1993                 ; This is here to support things like `delay'.
1994                 (modifiers . ())
1995                 )
1996               nil)
1997 )
1998
1999 ; Create an <eval-state> object using a list of keyword/value elements.
2000 ; ARGS is a list of #:keyword/value elements.
2001 ; The result is a list of the unrecognized elements.
2002 ; Subclasses should override this method and send-next it first, then
2003 ; see if they recognize anything in the result, returning what isn't
2004 ; recognized.
2005
2006 (method-make!
2007  <eval-state> 'vmake!
2008  (lambda (self args)
2009    (let loop ((args args) (unrecognized nil))
2010      (if (null? args)
2011          (reverse! unrecognized) ; ??? Could invoke method to initialize here.
2012          (begin
2013            (case (car args)
2014              ((#:context)
2015               (elm-set! self 'context (cadr args)))
2016              ((#:owner)
2017               (elm-set! self 'owner (cadr args)))
2018              ((#:outer-expr)
2019               (elm-set! self 'outer-expr (cadr args)))
2020              ((#:expr-fn)
2021               (elm-set! self 'expr-fn (cadr args)))
2022              ((#:env-stack)
2023               (elm-set! self 'env-stack (cadr args)))
2024              ((#:isas)
2025               (elm-set! self 'isas (cadr args)))
2026              ((#:depth)
2027               (elm-set! self 'depth (cadr args)))
2028              ((#:modifiers)
2029               (elm-set! self 'modifiers (cadr args)))
2030              (else
2031               ; Build in reverse order, as we reverse it back when we're done.
2032               (set! unrecognized
2033                     (cons (cadr args) (cons (car args) unrecognized)))))
2034            (loop (cddr args) unrecognized)))))
2035 )
2036
2037 ; Accessors.
2038
2039 (define-getters <eval-state> estate
2040   (context owner outer-expr expr-fn isas env-stack depth modifiers)
2041 )
2042 (define-setters <eval-state> estate
2043   (isas env-stack depth modifiers)
2044 )
2045
2046 ; Build an estate for use in producing a value from rtl.
2047 ; CONTEXT is a <context> object or #f if there is none.
2048 ; OWNER is the owner of the expression or #f if there is none.
2049
2050 (define (estate-make-for-eval context owner)
2051   (vmake <eval-state>
2052          #:context context
2053          #:owner owner
2054          #:expr-fn (lambda (rtx-obj expr mode estate)
2055                      (rtx-evaluator rtx-obj))
2056          #:isas (and owner (obj-isa-list owner)))
2057 )
2058
2059 ; Create a copy of ESTATE.
2060
2061 (define (estate-copy estate)
2062   (object-copy estate)
2063 )
2064
2065 ;; Create a copy of ESTATE with environment stack ENV-STACK added,
2066 ;; and the ISA(s) set to ISA-NAME-LIST.
2067
2068 (define (estate-make-closure estate isa-name-list env-stack)
2069   (let ((result (estate-copy estate)))
2070     (estate-set-isas! result isa-name-list)
2071     (estate-set-env-stack! result (append env-stack (estate-env-stack result)))
2072     result)
2073 )
2074
2075 ; Create a copy of ESTATE with environment ENV pushed onto the existing
2076 ; environment list.
2077 ; There's no routine to pop the environment list as there's no current
2078 ; need for it: we make a copy of the state when we push.
2079
2080 (define (estate-push-env estate env)
2081   (let ((result (estate-copy estate)))
2082     (estate-set-env-stack! result (cons env (estate-env-stack result)))
2083     result)
2084 )
2085
2086 ; Create a copy of ESTATE with the depth incremented by one.
2087
2088 (define (estate-deepen estate)
2089   (let ((result (estate-copy estate)))
2090     (estate-set-depth! result (1+ (estate-depth estate)))
2091     result)
2092 )
2093
2094 ; Create a copy of ESTATE with modifiers MODS.
2095
2096 (define (estate-with-modifiers estate mods)
2097   (let ((result (estate-copy estate)))
2098     (estate-set-modifiers! result (append mods (estate-modifiers result)))
2099     result)
2100 )
2101
2102 ; Convert a tstate to an estate.
2103
2104 (define (tstate->estate t)
2105   (vmake <eval-state>
2106          #:context (tstate-context t)
2107          #:env-stack (tstate-env-stack t))
2108 )
2109
2110 ; Issue an error given an estate.
2111
2112 (define (estate-error estate errmsg . expr)
2113   (apply context-owner-error
2114          (cons (estate-context estate)
2115                (cons (estate-owner estate)
2116                      (cons (string-append "During rtx evalution"
2117                                           (if (estate-outer-expr estate)
2118                                               (string-append " of\n"
2119                                                              (rtx-pretty-strdump (estate-outer-expr estate))
2120                                                              "\n")
2121                                               ""))
2122                            (cons errmsg expr)))))
2123 )
2124 \f
2125 ; RTL expression evaluation.
2126 ;
2127 ; ??? These used eval2 at one point.  Not sure which is faster but I suspect
2128 ; eval2 is by far.  On the otherhand this has yet to be compiled.  And this way
2129 ; is more portable, more flexible, and works with guile 1.2 (which has
2130 ; problems with eval'ing self referential vectors, though that's one reason to
2131 ; use smobs).
2132
2133 ; Set to #t to debug rtx evaluation.
2134
2135 (define /rtx-eval-debug? #f)
2136
2137 ; RTX expression evaluator.
2138 ;
2139 ; EXPR is the expression to be eval'd.  It must be in compiled(canonical) form.
2140 ; MODE is the desired mode of EXPR, a <mode> object.
2141 ; ESTATE is the current evaluation state.
2142
2143 (define (rtx-eval-with-estate expr mode estate)
2144   (if /rtx-eval-debug?
2145       (begin
2146         (display "Evaluating expr with mode ")
2147         (display (if (symbol? mode) mode (obj:name mode)))
2148         (newline)
2149         (display (rtx-dump expr))
2150         (newline)
2151         (rtx-env-stack-dump (estate-env-stack estate))
2152         ))
2153
2154   (if (pair? expr) ; pair? -> cheap non-null-list?
2155
2156       (let* ((rtx-obj (rtx-lookup (car expr)))
2157              (fn ((estate-expr-fn estate) rtx-obj expr mode estate)))
2158         (if fn
2159             (if (procedure? fn)
2160                 (apply fn (cons estate (cdr expr)))
2161 ;               ; Don't eval operands for syntax expressions.
2162 ;               (if (eq? (rtx-style rtx-obj) 'SYNTAX)
2163 ;                   (apply fn (cons estate (cdr expr)))
2164 ;                   (let ((operands
2165 ;                          (/rtx-eval-operands rtx-obj expr estate)))
2166 ;                     (apply fn (cons estate operands))))
2167                 fn)
2168             ; Leave expr unchanged.
2169             expr))
2170 ;           (let ((operands
2171 ;                  (/rtx-traverse-operands rtx-obj expr estate)))
2172 ;             (cons rtx-obj operands))))
2173
2174       ; EXPR is not a list
2175       (error "argument to rtx-eval-with-estate is not a list" expr))
2176 )
2177
2178 ; Evaluate rtx expression EXPR and return the computed value.
2179 ; EXPR must already be in canonical form (the result of rtx-canonicalize).
2180 ; OWNER is the owner of the value, used for attribute computation
2181 ; and to get the ISA name list.
2182 ; OWNER is #f if there isn't one.
2183 ; FIXME: context?
2184
2185 (define (rtx-value expr owner)
2186   (rtx-eval-with-estate expr DFLT (estate-make-for-eval #f owner))
2187 )
2188 \f
2189 ;; Initialize the tables.
2190
2191 (define (rtx-init-traversal-tables!)
2192   (let ((compiler-hash-table (/rtx-make-canon-table))
2193         (traverser-hash-table (/rtx-make-traverser-table)))
2194
2195     (set! /rtx-canoner-table (make-vector (rtx-max-num) #f))
2196     (set! /rtx-traverser-table (make-vector (rtx-max-num) #f))
2197
2198     (for-each (lambda (rtx-name)
2199                 (let ((rtx (rtx-lookup rtx-name)))
2200                   (if rtx
2201                       (let ((num (rtx-num rtx))
2202                             (arg-types (rtx-arg-types rtx)))
2203                         (vector-set! /rtx-canoner-table num
2204                                      (map1-improper
2205                                       (lambda (arg-type)
2206                                         (cons arg-type
2207                                               (hashq-ref compiler-hash-table arg-type)))
2208                                       arg-types))
2209                         (vector-set! /rtx-traverser-table num
2210                                      (map1-improper
2211                                       (lambda (arg-type)
2212                                         (cons arg-type
2213                                               (hashq-ref traverser-hash-table arg-type)))
2214                                       arg-types))))))
2215               (rtx-name-list)))
2216
2217   (set! /rtx-operand-canoners (make-vector (rtx-max-num) /rtx-canon-operands))
2218   (for-each (lambda (rtx-canoner)
2219               (let ((rtx-obj (rtx-lookup (car rtx-canoner))))
2220                 (vector-set! /rtx-operand-canoners (rtx-num rtx-obj) (cdr rtx-canoner))))
2221             (/rtx-special-expr-canoners))
2222 )