cgen/rtl-traverse.scm

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