cgen/rtl.scm

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