cgen/rtl.scm

   1 ; Basic RTL 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 ; 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-style-syntax? rtx) (eq? (rtx-style rtx) 'syntax))
 125
 126 ; Add standard `get-name' method since this isn't a subclass of <ident>.
 127
 128 (method-make! <rtx-func> 'get-name (lambda (self) (elm-get self 'name)))
 129
 130 ; List of mode types for arg-types.
 131
 132 (define /rtx-valid-mode-types
 133   '(
 134     ANYMODE INTMODE FLOATMODE NUMMODE EXPLNUMMODE NONVOIDMODE VOIDMODE DFLTMODE
 135    )
 136 )
 137
 138 ; List of valid values for arg-types, not including mode names.
 139
 140 (define /rtx-valid-types
 141   (append
 142    '(OPTIONS)
 143     /rtx-valid-mode-types
 144     '(RTX SETRTX TESTRTX CONDRTX CASERTX)
 145     '(LOCALS ENV ATTRS SYMBOL STRING NUMBER SYMORNUM OBJECT)
 146     )
 147 )
 148
 149 ; List of valid mode matchers, excluding mode names.
 150
 151 (define /rtx-valid-matches
 152   '(ANY NA OP0 MATCH1 MATCH2)
 153 )
 154
 155 ; List of all defined rtx names.  This can be map'd over without having
 156 ; to know the innards of /rtx-func-table (which is a hash table).
 157
 158 (define /rtx-name-list nil)
 159 (define (rtx-name-list) /rtx-name-list)
 160
 161 ; Table of rtx function objects.
 162 ; This is set in rtl-init!.
 163
 164 (define /rtx-func-table nil)
 165
 166 ; Look up the <rtx-func> object for RTX-KIND.
 167 ; Returns the object or #f if not found.
 168 ; RTX-KIND may already be an <rtx-func> object.  FIXME: delete?
 169
 170 (define (rtx-lookup rtx-kind)
 171   (cond ((symbol? rtx-kind)
 172          (hashq-ref /rtx-func-table rtx-kind))
 173         ((rtx-func? rtx-kind)
 174          rtx-kind)
 175         (else #f))
 176 )
 177
 178 ; Table of rtx macro objects.
 179 ; This is set in rtl-init!.
 180
 181 (define /rtx-macro-table nil)
 182
 183 ; Table of operands, modes, and other non-functional aspects of RTL.
 184 ; This is defined in rtl-finish!, after all operands have been read in.
 185
 186 (define /rtx-operand-table nil)
 187
 188 ; Number of next rtx to be defined.
 189
 190 (define /rtx-num-next #f)
 191
 192 ; Return the number of rtx's.
 193
 194 (define (rtx-max-num)
 195   /rtx-num-next
 196 )
 197 \f
 198 ; Define Rtx Node
 199 ;
 200 ; Add an entry to the rtx function table.
 201 ; NAME-ARGS is a list of the operation name and arguments.
 202 ; The mode of the result must be the first element in `args' (if there are
 203 ; any arguments).
 204 ; ARG-TYPES is a list of argument types (/rtx-valid-types).
 205 ; ARG-MODES is a list of mode matchers (/rtx-valid-matches).
 206 ; CLASS is the class of the rtx to be created.
 207 ; ACTION is a list of Scheme expressions to perform the operation.
 208 ;
 209 ; ??? Note that we can support variables.  Not sure it should be done.
 210
 211 (define (def-rtx-node name-args arg-types arg-modes class action)
 212   (let ((name (car name-args))
 213         (args (cdr name-args)))
 214     (let ((rtx (make <rtx-func> name args
 215                      arg-types arg-modes
 216                      class
 217                      'function
 218                      (if action
 219                          (eval1 (list 'lambda (cons '*estate* args) action))
 220                          #f)
 221                      /rtx-num-next)))
 222       ; Add it to the table of rtx handlers.
 223       (hashq-set! /rtx-func-table name rtx)
 224       (set! /rtx-num-next (+ /rtx-num-next 1))
 225       (set! /rtx-name-list (cons name /rtx-name-list))
 226       *UNSPECIFIED*))
 227 )
 228
 229 (define define-rtx-node
 230   ; Written this way so Hobbit can handle it.
 231   (defmacro:syntax-transformer (lambda arg-list
 232                                  (apply def-rtx-node arg-list)
 233                                  nil))
 234 )
 235
 236 ; Same as define-rtx-node but don't pre-evaluate the arguments.
 237 ; Remember that `mode' must be the first argument.
 238
 239 (define (def-rtx-syntax-node name-args arg-types arg-modes class action)
 240   (let ((name (car name-args))
 241         (args (cdr name-args)))
 242     (let ((rtx (make <rtx-func> name args
 243                      arg-types arg-modes
 244                      class
 245                      'syntax
 246                      (if action
 247                          (eval1 (list 'lambda (cons '*estate* args) action))
 248                          #f)
 249                      /rtx-num-next)))
 250       ; Add it to the table of rtx handlers.
 251       (hashq-set! /rtx-func-table name rtx)
 252       (set! /rtx-num-next (+ /rtx-num-next 1))
 253       (set! /rtx-name-list (cons name /rtx-name-list))
 254       *UNSPECIFIED*))
 255 )
 256
 257 (define define-rtx-syntax-node
 258   ; Written this way so Hobbit can handle it.
 259   (defmacro:syntax-transformer (lambda arg-list
 260                                  (apply def-rtx-syntax-node arg-list)
 261                                  nil))
 262 )
 263
 264 ; Same as define-rtx-node but return an operand (usually an <operand> object).
 265 ; ??? `mode' must be the first argument?
 266
 267 (define (def-rtx-operand-node name-args arg-types arg-modes class action)
 268   ; Operand nodes must specify an action.
 269   (assert action)
 270   (let ((name (car name-args))
 271         (args (cdr name-args)))
 272     (let ((rtx (make <rtx-func> name args
 273                      arg-types arg-modes
 274                      class
 275                      'operand
 276                      (eval1 (list 'lambda (cons '*estate* args) action))
 277                      /rtx-num-next)))
 278       ; Add it to the table of rtx handlers.
 279       (hashq-set! /rtx-func-table name rtx)
 280       (set! /rtx-num-next (+ /rtx-num-next 1))
 281       (set! /rtx-name-list (cons name /rtx-name-list))
 282       *UNSPECIFIED*))
 283 )
 284
 285 (define define-rtx-operand-node
 286   ; Written this way so Hobbit can handle it.
 287   (defmacro:syntax-transformer (lambda arg-list
 288                                  (apply def-rtx-operand-node arg-list)
 289                                  nil))
 290 )
 291
 292 ; Convert one rtx expression into another.
 293 ; NAME-ARGS is a list of the operation name and arguments.
 294 ; ACTION is a list of Scheme expressions to perform the operation.
 295 ; The result of ACTION must be another rtx expression (a list).
 296
 297 (define (def-rtx-macro-node name-args action)
 298   ; macro nodes must specify an action
 299   (assert action)
 300   (let ((name (car name-args))
 301         (args (cdr name-args)))
 302     (let ((rtx (make <rtx-func> name args #f #f
 303                      #f ; class
 304                      'macro
 305                      (eval1 (list 'lambda args action))
 306                      /rtx-num-next)))
 307       ; Add it to the table of rtx macros.
 308       (hashq-set! /rtx-macro-table name rtx)
 309       (set! /rtx-num-next (+ /rtx-num-next 1))
 310       (set! /rtx-name-list (cons name /rtx-name-list))
 311       *UNSPECIFIED*))
 312 )
 313
 314 (define define-rtx-macro-node
 315   ; Written this way so Hobbit can handle it.
 316   (defmacro:syntax-transformer (lambda arg-list
 317                                  (apply def-rtx-macro-node arg-list)
 318                                  nil))
 319 )
 320 \f
 321 ; RTL macro expansion.
 322 ; RTL macros are different than pmacros.  The difference is that the expansion
 323 ; happens internally, RTL macros are part of the language.
 324
 325 ; Lookup MACRO-NAME and return its <rtx-func> object or #f if not found.
 326
 327 (define (/rtx-macro-lookup macro-name)
 328   (hashq-ref /rtx-macro-table macro-name)
 329 )
 330
 331 ; Lookup (car exp) and return the macro's lambda if it is one or #f.
 332
 333 (define (/rtx-macro-check exp fn-getter)
 334   (let ((macro (hashq-ref /rtx-macro-table (car exp))))
 335     (if macro
 336         (fn-getter macro)
 337         #f))
 338 )
 339
 340 ; Expand a list.
 341
 342 (define (/rtx-macro-expand-list exp fn-getter)
 343   (let ((macro (/rtx-macro-check exp fn-getter)))
 344     (if macro
 345         (apply macro (map (lambda (x) (/rtx-macro-expand x fn-getter))
 346                           (cdr exp)))
 347         (map (lambda (x) (/rtx-macro-expand x fn-getter))
 348              exp)))
 349 )
 350
 351 ; Main entry point to expand a macro invocation.
 352
 353 (define (/rtx-macro-expand exp fn-getter)
 354   (if (pair? exp) ; pair? -> cheap (and (not (null? exp)) (list? exp))
 355       (let ((result (/rtx-macro-expand-list exp fn-getter)))
 356         ; If the result is a new macro invocation, recurse.
 357         (if (pair? result)
 358             (let ((macro (/rtx-macro-check result fn-getter)))
 359               (if macro
 360                   (/rtx-macro-expand (apply macro (cdr result)) fn-getter)
 361                   result))
 362             result))
 363       exp)
 364 )
 365
 366 ; Publically accessible version.
 367
 368 (define rtx-macro-expand /rtx-macro-expand)
 369 \f
 370 ; RTX mode support.
 371
 372 ; Get implied mode of X, either an operand expression, sequence temp, or
 373 ; a hardware reference expression.
 374 ; The result is the name of the mode.
 375
 376 (define (rtx-lvalue-mode-name estate x)
 377   (assert (rtx? x))
 378   (case (car x)
 379 ;    ((operand) (obj:name (op:mode (current-op-lookup (cadr x)))))
 380     ((xop) (obj:name (send (rtx-xop-obj x) 'get-mode)))
 381 ;    ((opspec)
 382 ;     (if (eq? (rtx-opspec-mode x) 'VOID)
 383 ;        (rtx-lvalue-mode-name estate (rtx-opspec-hw-ref x))
 384 ;        (rtx-opspec-mode x)))
 385 ;    ((reg mem) (cadr x))
 386     ((local) ;; (local options mode name)
 387      (let* ((name (cadddr x))
 388             (temp (rtx-temp-lookup (estate-env estate) name)))
 389        (if (not temp)
 390            (estate-error estate "unknown local" name))
 391        (obj:name (rtx-temp-mode temp))))
 392     (else
 393      (estate-error error
 394                    "rtx-lvalue-mode-name: not an operand or hardware reference:"
 395                    x)))
 396 )
 397
 398 ; Lookup the mode to use for semantic operations (unsigned modes aren't
 399 ; allowed since we don't have ANDUSI, etc.).
 400 ; MODE is a <mode> object.
 401 ; ??? I have actually implemented both ways (full use of unsigned modes
 402 ; and mostly hidden use of unsigned modes).  Neither makes me real
 403 ; comfortable, though I liked bringing unsigned modes out into the open
 404 ; even if it doubled the number of semantic operations.
 405
 406 (define (rtx-sem-mode mode) (or (mode:sem-mode mode) mode))
 407
 408 ; MODE is a <mode> object.
 409
 410 (define (rtx-lazy-sem-mode mode) (rtx-sem-mode mode))
 411
 412 ; Return the mode of object OBJ.
 413
 414 (define (rtx-obj-mode obj) (send obj 'get-mode))
 415
 416 ; Return a boolean indicating of modes M1,M2 are compatible.
 417 ; M1,M2 are <mode> objects.
 418
 419 (define (rtx-mode-compatible? m1 m2)
 420   (let ((mode1 (rtx-lazy-sem-mode m1))
 421         (mode2 (rtx-lazy-sem-mode m2)))
 422     ;(eq? (obj:name mode1) (obj:name mode2)))
 423     ; ??? This is more permissive than is perhaps proper.
 424     (mode-compatible? 'sameclass mode1 mode2))
 425 )
 426 \f
 427 ; Environments (sequences with local variables).
 428
 429 ; Temporaries are created within a sequence.
 430 ; MODE is a <mode> object.
 431 ; e.g. (sequence ((WI tmp)) (set tmp reg0) ...)
 432 ; ??? Perhaps what we want here is `let' but for now I prefer `sequence'.
 433 ; This isn't exactly `let' either as no initial value is specified.
 434 ; Environments are also used to specify incoming values from the top level.
 435
 436 (define <rtx-temp> (class-make '<rtx-temp> nil '(name mode value) nil))
 437
 438 ;(define cx-temp:name (elm-make-getter <c-expr-temp> 'name))
 439 ;(define cx-temp:mode (elm-make-getter <c-expr-temp> 'mode))
 440 ;(define cx-temp:value (elm-make-getter <c-expr-temp> 'value))
 441
 442 (define-getters <rtx-temp> rtx-temp (name mode value))
 443
 444 (method-make!
 445  <rtx-temp> 'make!
 446  (lambda (self name mode value)
 447    (assert (mode? mode))
 448    (elm-set! self 'name name)
 449    (elm-set! self 'mode mode)
 450    (elm-set! self 'value (if value value (gen-temp name)))
 451    self)
 452 )
 453
 454 (define (gen-temp name)
 455   ; ??? calls to gen-c-symbol don't belong here
 456   (string-append "tmp_" (gen-c-symbol name))
 457 )
 458
 459 ; Return a boolean indicating if X is an <rtx-temp>.
 460
 461 (define (rtx-temp? x) (class-instance? <rtx-temp> x))
 462
 463 ; Respond to 'get-mode messages.
 464
 465 (method-make! <rtx-temp> 'get-mode (lambda (self) (elm-get self 'mode)))
 466
 467 ; Respond to 'get-name messages.
 468
 469 (method-make! <rtx-temp> 'get-name (lambda (self) (elm-get self 'name)))
 470
 471 ; An environment is a list of <rtx-temp> objects.
 472 ; An environment stack is a list of environments.
 473
 474 (define (rtx-env-stack-empty? env-stack) (null? env-stack))
 475 (define (rtx-env-stack-head env-stack) (car env-stack))
 476 (define (rtx-env-var-list env) env)
 477 (define (rtx-env-empty-stack) nil)
 478 (define (rtx-env-init-stack1 vars-alist)
 479   (if (null? vars-alist)
 480       nil
 481       (cons (rtx-env-make vars-alist) nil))
 482 )
 483 (define (rtx-env-empty? env) (null? env))
 484
 485 ; Create an initial environment.
 486 ; VAR-LIST is a list of (name <mode>-or-mode-name value) elements.
 487
 488 (define (rtx-env-make var-list)
 489   ; Convert VAR-LIST to an associative list of <rtx-temp> objects.
 490   (map (lambda (var-spec)
 491          (cons (car var-spec)
 492                (make <rtx-temp>
 493                  (car var-spec)
 494                  (mode-maybe-lookup (cadr var-spec))
 495                  (caddr var-spec))))
 496        var-list)
 497 )
 498
 499 ; Create an initial environment with local variables.
 500 ; VAR-LIST is a list of (mode-name name) elements, i.e. the locals argument to
 501 ; `sequence' or equivalent thereof.
 502
 503 (define (rtx-env-make-locals var-list)
 504   ; Convert VAR-LIST to an associative list of <rtx-temp> objects.
 505   (map (lambda (var-spec)
 506          (cons (cadr var-spec)
 507                (make <rtx-temp>
 508                  (cadr var-spec) (mode:lookup (car var-spec)) #f)))
 509        var-list)
 510 )
 511
 512 ; Return the symbol name of the limit variable of `do-count'
 513 ; given iteration-variable ITER-VAR.
 514 ; ??? We don't publish that this variable is available to use, but we could.
 515
 516 (define (rtx-make-iteration-limit-var iter-var)
 517   (symbol-append iter-var '-limit)
 518 )
 519
 520 ; Create an environment with the iteration local variables of `do-count'.
 521
 522 (define (rtx-env-make-iteration-locals iter-var)
 523   (rtx-env-make-locals (list (list 'INT iter-var)
 524                              (list 'INT (rtx-make-iteration-limit-var iter-var))))
 525 )
 526
 527 ; Push environment ENV onto the front of environment stack ENV-STACK,
 528 ; returning a new object.  ENV-STACK is not modified.
 529
 530 (define (rtx-env-push env-stack env)
 531   (cons env env-stack)
 532 )
 533
 534 ; Lookup variable NAME in environment ENV.
 535 ; The result is the <rtx-temp> object.
 536 ; ??? Should environments only have rtx-temps?
 537
 538 (define (rtx-temp-lookup env name)
 539   ;(display "looking up:") (display name) (newline)
 540   (let loop ((stack (rtx-env-var-list env)))
 541     (if (null? stack)
 542         #f
 543         (let ((temp (assq-ref (car stack) name)))
 544           (if temp
 545               temp
 546               (loop (cdr stack))))))
 547 )
 548
 549 ; Create a "closure" of EXPR using the current temp stack.
 550
 551 (define (/rtx-closure-make estate expr)
 552   (rtx-make 'closure expr (estate-env estate))
 553 )
 554
 555 (define (rtx-env-dump env)
 556   (let ((stack env))
 557     (if (rtx-env-stack-empty? stack)
 558         (display "rtx-env stack (empty):\n")
 559         (let loop ((stack stack) (level 0))
 560           (if (null? stack)
 561               #f ; done
 562               (begin
 563                 (display "rtx-env stack, level ")
 564                 (display level)
 565                 (display ":\n")
 566                 (for-each (lambda (var)
 567                             (display "  ")
 568                             ;(display (obj:name (rtx-temp-mode (cdr var))))
 569                             ;(display " ")
 570                             (display (rtx-temp-name (cdr var)))
 571                             (newline))
 572                           (car stack))
 573                 (loop (cdr stack) (+ level 1)))))))
 574 )
 575 \f
 576 ; Build, test, and analyze various kinds of rtx's.
 577 ; ??? A lot of this could be machine generated except that I don't yet need
 578 ; that much.
 579
 580 (define (rtx-make kind . args)
 581   (cons kind (/rtx-munge-mode&options args))
 582 )
 583
 584 (define rtx-name car)
 585 (define (rtx-kind? kind rtx) (eq? kind (rtx-name rtx)))
 586
 587 (define (rtx-make-const mode value) (rtx-make 'const mode value))
 588 (define (rtx-make-enum mode value) (rtx-make 'enum mode value))
 589
 590 (define (rtx-constant? rtx) (memq (rtx-name rtx) '(const enum)))
 591
 592 ; Return value of constant RTX (either const or enum).
 593 (define (rtx-constant-value rtx)
 594   (case (rtx-name rtx)
 595     ((const) (rtx-const-value rtx))
 596     ((enum) (enum-lookup-val (rtx-enum-value rtx)))
 597     (else (error "rtx-constant-value: not const or enum" rtx)))
 598 )
 599
 600 (define rtx-options cadr)
 601 (define rtx-mode caddr)
 602 (define rtx-args cdddr)
 603 (define rtx-arg1 cadddr)
 604 (define (rtx-arg2 rtx) (car (cddddr rtx)))
 605
 606 (define rtx-const-value rtx-arg1)
 607 (define rtx-enum-value rtx-arg1)
 608
 609 (define rtx-reg-name rtx-arg1)
 610
 611 ; Return register number or #f if absent.
 612 ; (reg options mode hw-name [regno [selector]])
 613 (define (rtx-reg-number rtx) (list-maybe-ref rtx 4))
 614
 615 ; Return register selector or #f if absent.
 616 (define (rtx-reg-selector rtx) (list-maybe-ref rtx 5))
 617
 618 ; Return both register number and selector.
 619 (define rtx-reg-index-sel cddddr)
 620
 621 ; Return memory address.
 622 (define rtx-mem-addr rtx-arg1)
 623
 624 ; Return memory selector or #f if absent.
 625 (define (rtx-mem-sel mem) (list-maybe-ref mem 4))
 626
 627 ; Return both memory address and selector.
 628 (define rtx-mem-index-sel cdddr)
 629
 630 ; Return MEM with new address NEW-ADDR.
 631 ; ??? Complicate as necessary.
 632 (define (rtx-change-address mem new-addr)
 633   (rtx-make 'mem
 634             (rtx-options mem)
 635             (rtx-mode mem)
 636             new-addr
 637             (rtx-mem-sel mem))
 638 )
 639
 640 ; Return argument to `symbol' rtx.
 641 (define rtx-symbol-name rtx-arg1)
 642
 643 (define (rtx-make-ifield ifield-name) (rtx-make 'ifield ifield-name))
 644 (define (rtx-ifield? rtx) (eq? 'ifield (rtx-name rtx)))
 645 (define (rtx-ifield-name rtx)
 646   (let ((ifield (rtx-arg1 rtx)))
 647     (if (symbol? ifield)
 648         ifield
 649         (obj:name ifield)))
 650 )
 651 (define (rtx-ifield-obj rtx)
 652   (let ((ifield (rtx-arg1 rtx)))
 653     (if (symbol? ifield)
 654         (current-ifield-lookup ifield)
 655         ifield))
 656 )
 657
 658 (define (rtx-make-operand op-name) (rtx-make 'operand op-name))
 659 (define (rtx-operand? rtx) (eq? 'operand (rtx-name rtx)))
 660 (define (rtx-operand-name rtx)
 661   (let ((operand (rtx-arg1 rtx)))
 662     (if (symbol? operand)
 663         operand
 664         (obj:name operand)))
 665 )
 666 (define (rtx-operand-obj rtx)
 667   (let ((operand (rtx-arg1 rtx)))
 668     (if (symbol? operand)
 669         (current-op-lookup operand)
 670         operand))
 671 )
 672
 673 (define (rtx-make-local local-name) (rtx-make 'local local-name))
 674 (define (rtx-local? rtx) (eq? 'local (rtx-name rtx)))
 675 (define (rtx-local-name rtx)
 676   (let ((local (rtx-arg1 rtx)))
 677     (if (symbol? local)
 678         local
 679         (obj:name local)))
 680 )
 681 (define (rtx-local-obj rtx)
 682   (let ((local (rtx-arg1 rtx)))
 683     (if (symbol? local)
 684         (error "can't use rtx-local-obj on local name")
 685         local))
 686 )
 687
 688 (define rtx-xop-obj rtx-arg1)
 689
 690 ;(define (rtx-opspec? rtx) (eq? 'opspec (rtx-name rtx)))
 691 ;(define (rtx-opspec-mode rtx) (rtx-mode rtx))
 692 ;(define (rtx-opspec-hw-ref rtx) (list-ref rtx 5))
 693 ;(define (rtx-opspec-set-op-num! rtx num) (set-car! (cddddr rtx) num))
 694
 695 (define rtx-index-of-value rtx-arg1)
 696
 697 (define (rtx-make-set dest src) (rtx-make 'set dest src))
 698 (define rtx-set-dest rtx-arg1)
 699 (define rtx-set-src rtx-arg2)
 700 (define (rtx-single-set? rtx) (eq? (car rtx) 'set))
 701
 702 (define rtx-alu-op-mode rtx-mode)
 703 (define (rtx-alu-op-arg rtx n) (list-ref rtx (+ n 3)))
 704
 705 (define (rtx-boolif-op-arg rtx n) (list-ref rtx (+ n 3)))
 706
 707 (define rtx-cmp-op-mode rtx-mode)
 708 (define (rtx-cmp-op-arg rtx n) (list-ref rtx (+ n 3)))
 709
 710 (define rtx-number-list-values cdddr)
 711
 712 (define rtx-member-value rtx-arg1)
 713 (define (rtx-member-set rtx) (list-ref rtx 4))
 714
 715 (define rtx-if-mode rtx-mode)
 716 (define (rtx-if-test rtx) (rtx-arg1 rtx))
 717 (define (rtx-if-then rtx) (list-ref rtx 4))
 718 ; If `else' clause is missing the result is #f.
 719 (define (rtx-if-else rtx) (list-maybe-ref rtx 5))
 720
 721 (define (rtx-eq-attr-owner rtx) (list-ref rtx 3))
 722 (define (rtx-eq-attr-attr rtx) (list-ref rtx 4))
 723 (define (rtx-eq-attr-value rtx) (list-ref rtx 5))
 724
 725 (define (rtx-sequence-locals rtx) (cadddr rtx))
 726 (define (rtx-sequence-exprs rtx) (cddddr rtx))
 727
 728 ; Same as rtx-sequence-locals except return in assq'able form.
 729 ; ??? Sometimes I should it should have been (sequence ((name MODE)) ...)
 730 ; instead of (sequence ((MODE name)) ...) from the beginning, sigh.
 731
 732 (define (rtx-sequence-assq-locals rtx)
 733   (let ((locals (rtx-sequence-locals rtx)))
 734     (map (lambda (local)
 735            (list (cadr local) (car local)))
 736          locals))
 737 )
 738
 739 ; Return a semi-pretty string describing RTX.
 740 ; This is used by hw to include the index in the element's name.
 741
 742 (define (rtx-pretty-name rtx)
 743   (if (pair? rtx)
 744       (case (car rtx)
 745         ((const) (number->string (rtx-const-value rtx)))
 746         ((operand) (symbol->string (obj:name (rtx-operand-obj rtx))))
 747         ((local) (symbol->string (rtx-local-name rtx)))
 748         ((xop) (symbol->string (obj:name (rtx-xop-obj rtx))))
 749         (else
 750          (if (null? (cdr rtx))
 751              (rtx-pretty-name (car rtx))
 752              (apply stringsym-append
 753                     (cons (rtx-pretty-name (car rtx))
 754                           (map (lambda (elm)
 755                                  (string-append "-" (rtx-pretty-name elm)))
 756                                (cdr rtx)))))))
 757       (stringize rtx "-"))
 758 )
 759 \f
 760 ; Various rtx utilities.
 761
 762 ; Dump an rtx expression.
 763
 764 (define (rtx-dump rtx)
 765   (cond ((list? rtx) (map rtx-dump rtx))
 766         ((object? rtx) (string/symbol-append "#<object "
 767                                              (object-class-name rtx)
 768                                              " "
 769                                              (obj:name rtx)
 770                                              ">"))
 771         (else rtx))
 772 )
 773
 774 ; Dump an expression to a string.
 775
 776 (define (rtx-strdump rtx)
 777   (with-output-to-string
 778     (lambda ()
 779       ;; Use write instead of display, we want strings displayed with quotes.
 780       (write (rtx-dump rtx))))
 781 )
 782
 783 ; Return a boolean indicating if EXPR is known to be a compile-time constant.
 784
 785 (define (rtx-compile-time-constant? expr)
 786   (cond ((pair? expr)
 787          (case (car expr)
 788            ((const enum) #t)
 789            (else #f)))
 790         ((memq expr '(FALSE TRUE)) #t)
 791         (else #f))
 792 )
 793
 794 ; Return boolean indicating if EXPR has side-effects.
 795 ; FIXME: for now punt.
 796
 797 (define (rtx-side-effects? expr)
 798   #f
 799 )
 800
 801 ; Return a boolean indicating if EXPR is a "true" boolean value.
 802 ;
 803 ; ??? In RTL, #t is a synonym for (const 1).  This is confusing for Schemers,
 804 ; so maybe RTL's #t should be renamed to TRUE.
 805
 806 (define (rtx-true? expr)
 807   (cond ((pair? expr)
 808          (case (car expr)
 809            ((const enum) (!= (rtx-constant-value expr) 0))
 810            (else #f)))
 811         ((eq? expr 'TRUE) #t)
 812         (else #f))
 813 )
 814
 815 ; Return a boolean indicating if EXPR is a "false" boolean value.
 816 ;
 817 ; ??? In RTL, #f is a synonym for (const 0).  This is confusing for Schemers,
 818 ; so maybe RTL's #f should be renamed to FALSE.
 819
 820 (define (rtx-false? expr)
 821   (cond ((pair? expr)
 822          (case (car expr)
 823            ((const enum) (= (rtx-constant-value expr) 0))
 824            (else #f)))
 825         ((eq? expr 'FALSE) #t)
 826         (else #f))
 827 )
 828
 829 ; Return canonical boolean values.
 830
 831 (define (rtx-false) (rtx-make-const 'BI 0))
 832 (define (rtx-true) (rtx-make-const 'BI 1))
 833
 834 ; Convert EXPR to a canonical boolean if possible.
 835
 836 (define (rtx-canonical-bool expr)
 837   (cond ((rtx-side-effects? expr) expr)
 838         ((rtx-false? expr) (rtx-false))
 839         ((rtx-true? expr) (rtx-true))
 840         (else expr))
 841 )
 842
 843 ; Return rtx values for #f/#t.
 844
 845 (define (rtx-make-bool value)
 846   (if value
 847       (rtx-true)
 848       (rtx-false))
 849 )
 850
 851 ; Return #t if X is an rtl expression.
 852 ; e.g. '(add WI dr simm8);
 853
 854 (define (rtx? x)
 855   (->bool
 856    (and (pair? x) ; pair? -> cheap non-null-list?
 857         (or (hashq-ref /rtx-func-table (car x))
 858             (hashq-ref /rtx-macro-table (car x)))))
 859 )
 860 \f
 861 ; Instruction field support.
 862
 863 ; Return list of ifield names refered to in EXPR.
 864 ; Assumes EXPR is more than just (ifield x).
 865
 866 (define (rtl-find-ifields expr)
 867   (let ((ifields nil))
 868     (letrec ((scan! (lambda (arg-list)
 869                       (for-each (lambda (arg)
 870                                   (if (pair? arg)
 871                                       (if (eq? (car arg) 'ifield)
 872                                           (set! ifields
 873                                                 (cons (rtx-ifield-name arg)
 874                                                       ifields))
 875                                           (scan! (cdr arg)))))
 876                                 arg-list))))
 877       (scan! (cdr expr))
 878       (nub ifields identity)))
 879 )
 880 \f
 881 ; Hardware rtx handlers.
 882
 883 ; Subroutine of hw to compute the object's name.
 884 ; The name of the operand must include the index so that multiple copies
 885 ; of a hardware object (e.g. h-gr[0], h-gr[14]) can be distinguished.
 886 ; We make some attempt to make the name pretty as it appears in generated
 887 ; files.
 888
 889 (define (/rtx-hw-name hw hw-name index-arg)
 890   (cond ((hw-scalar? hw)
 891          hw-name)
 892         ((rtx? index-arg)
 893          (symbolstr-append hw-name '- (rtx-pretty-name index-arg)))
 894         (else
 895          (symbolstr-append hw-name ; (obj:name (op:type self))
 896                            '-
 897                            ; (obj:name (op:index self)))))
 898                            (stringize index-arg "-"))))
 899 )
 900
 901 ; Return the <operand> object described by
 902 ; HW-NAME/MODE-NAME/SELECTOR/INDEX-ARG.
 903 ;
 904 ; HW-NAME is the name of the hardware element.
 905 ; INDEX-ARG is an rtx or number of the index.
 906 ; In the case of scalar hardware elements, pass 0 for INDEX-ARG.
 907 ; MODE-NAME is the name of the mode.
 908 ; In the case of a vector of registers, INDEX-ARG is the vector index.
 909 ; In the case of a scalar register, the value is ignored, but pass 0 (??? #f?).
 910 ; SELECTOR is an rtx or number and is passed to HW-NAME to allow selection of a
 911 ; particular variant of the hardware.  It's kind of like an INDEX, but along
 912 ; an atypical axis.  An example is memory ASI's on Sparc.  Pass
 913 ; hw-selector-default if there is no selector.
 914 ; ESTATE is the current rtx evaluation state.
 915 ;
 916 ; e.g. (hw estate WI h-gr #f (const INT 14))
 917 ; selects register 14 of the h-gr set of registers.
 918 ;
 919 ; *** The index is passed unevaluated because for parallel execution support
 920 ; *** a variable is created with a name based on the hardware element and
 921 ; *** index, and we want a reasonably simple and stable name.  We get this by
 922 ; *** stringize-ing it.
 923 ; *** ??? Though this needs to be redone anyway.
 924 ;
 925 ; ??? The specified hardware element must be either a scalar or a vector.
 926 ; Maybe in the future allow arrays although there's significant utility in
 927 ; allowing only at most a scalar index.
 928
 929 (define (hw estate mode-name hw-name index-arg selector)
 930   ; Enforce some rules to keep things in line with the current design.
 931   (if (not (symbol? mode-name))
 932       (parse-error (estate-context estate) "invalid mode name" mode-name))
 933   (if (not (symbol? hw-name))
 934       (parse-error (estate-context estate) "invalid hw name" hw-name))
 935   (if (not (or (number? index-arg)
 936                (rtx? index-arg)))
 937       (parse-error (estate-context estate) "invalid index" index-arg))
 938   (if (not (or (number? selector)
 939                (rtx? selector)))
 940       (parse-error (estate-context estate) "invalid selector" selector))
 941
 942   (let ((hw (current-hw-sem-lookup-1 hw-name)))
 943     (if (not hw)
 944         (parse-error (estate-context estate) "invalid hardware element" hw-name))
 945
 946     (let* ((mode (if (eq? mode-name 'DFLT) (hw-mode hw) (mode:lookup mode-name)))
 947            (hw-name-with-mode (symbol-append hw-name '- (obj:name mode)))
 948            (result (new <operand>))) ; ??? lookup-for-new?
 949
 950       (if (not mode)
 951           (parse-error (estate-context estate) "invalid mode" mode-name))
 952
 953       ; Record the selector.
 954       (elm-xset! result 'selector selector)
 955
 956       ; Create the index object.
 957       (elm-xset! result 'index
 958                  (cond ((number? index-arg)
 959                         (make <hw-index> 'anonymous 'constant UINT index-arg))
 960                        ((rtx? index-arg)
 961                         ; For the simulator the following could be done which
 962                         ; would save having to create a closure.
 963                         ; ??? Old code, left in for now.
 964                         ; (rtx-get estate DFLT
 965                         ;          (rtx-eval (estate-context estate)
 966                         ;                    (estate-econfig estate)
 967                         ;                    index-arg rtx-evaluator))
 968                         ; Make sure constant indices are recorded as such.
 969                         (if (rtx-constant? index-arg)
 970                             (make <hw-index> 'anonymous 'constant UINT
 971                                   (rtx-constant-value index-arg))
 972                             (make <hw-index> 'anonymous 'rtx DFLT
 973                                   (/rtx-closure-make estate index-arg))))
 974                        (else (parse-error (estate-context estate)
 975                                           "invalid index" index-arg))))
 976
 977       (if (not (hw-mode-ok? hw (obj:name mode) (elm-xget result 'index)))
 978           (parse-error (estate-context estate)
 979                        "invalid mode for hardware" mode-name))
 980
 981       (elm-xset! result 'hw-name hw-name)
 982       (elm-xset! result 'type hw)
 983       (elm-xset! result 'mode-name mode-name)
 984       (elm-xset! result 'mode mode)
 985
 986       (op:set-pretty-sem-name! result hw-name)
 987
 988       ; The name of the operand must include the index so that multiple copies
 989       ; of a hardware object (e.g. h-gr[0], h-gr[14]) can be distinguished.
 990       (let ((name (/rtx-hw-name hw hw-name-with-mode index-arg)))
 991         (send result 'set-name! name)
 992         (op:set-sem-name! result name))
 993
 994       ; Empty comment and attribute.
 995       ; ??? Stick the arguments in the comment for debugging purposes?
 996       (send result 'set-comment! "")
 997       (send result 'set-atlist! atlist-empty)
 998
 999       result))
1000 )
1001
1002 ; This is shorthand for (hw estate mode hw-name regno selector).
1003 ; ESTATE is the current rtx evaluation state.
1004 ; INDX-SEL is an optional register number and possible selector.
1005 ; The register number, if present, is (car indx-sel) and must be a number or
1006 ; unevaluated RTX expression.
1007 ; The selector, if present, is (cadr indx-sel) and must be a number or
1008 ; unevaluated RTX expression.
1009 ; ??? A register selector isn't supported yet.  It's just an idea that's
1010 ; been put down on paper for future reference.
1011
1012 (define (reg estate mode-name hw-name . indx-sel)
1013   (s-hw estate mode-name hw-name
1014         (if (pair? indx-sel) (car indx-sel) 0)
1015         (if (and (pair? indx-sel) (pair? (cdr indx-sel)))
1016             (cadr indx-sel)
1017             hw-selector-default))
1018 )
1019
1020 ; This is shorthand for (hw estate mode-name h-memory addr selector).
1021 ; ADDR must be an unevaluated RTX expression.
1022 ; If present (car sel) must be a number or unevaluated RTX expression.
1023
1024 (define (mem estate mode-name addr . sel)
1025   (s-hw estate mode-name 'h-memory addr
1026         (if (pair? sel) (car sel) hw-selector-default))
1027 )
1028
1029 ; For the rtx nodes to use.
1030
1031 (define s-hw hw)
1032
1033 ; The program counter.
1034 ; When this code is loaded, global `pc' is nil, it hasn't been set to the
1035 ; pc operand yet (see operand-init!).  We can't use `pc' inside the drn as the
1036 ; value is itself.  So we use s-pc.  rtl-finish! must be called after
1037 ; operand-init!.
1038
1039 (define s-pc pc)
1040 \f
1041 ; Conditional execution.
1042
1043 ; `if' in RTL has a result, like ?: in C.
1044 ; We support both: one with a result (non VOID mode), and one without (VOID mode).
1045 ; The non-VOID case must have an else part.
1046 ; MODE is the mode of the result, not the comparison.
1047 ; The comparison is expected to return a zero/non-zero value.
1048 ; ??? Perhaps this should be a syntax-expr.  Later.
1049
1050 (define (e-if estate mode cond then . else)
1051   (if (> (length else) 1)
1052       (estate-error estate "if: too many elements in `else' part" else))
1053   (if (null? else)
1054       (if cond then)
1055       (if cond then (car else)))
1056 )
1057 \f
1058 ; Subroutines.
1059 ; ??? Not sure this should live here.
1060
1061 (define (/subr-read context . arg-list)
1062   #f
1063 )
1064
1065 (define define-subr
1066   (lambda arg-list
1067     (let ((s (apply /subr-read (cons "define-subr" arg-list))))
1068       (if s
1069           (current-subr-add! s))
1070       s))
1071 )
1072 \f
1073 ; Misc. utilities.
1074
1075 ; The argument to drn,drmn,drsn must be Scheme code (or a fixed subset
1076 ; thereof).  .str/.sym are used in pmacros so it makes sense to include them
1077 ; in the subset.
1078 (define .str string-append)
1079 (define .sym symbol-append)
1080
1081 ; Given (expr1 expr2 expr3 expr4), for example,
1082 ; return (fn (fn (fn expr1 expr2) expr3) expr4).
1083
1084 (define (rtx-combine fn exprs)
1085   (assert (not (null? exprs)))
1086   (letrec ((-rtx-combine (lambda (fn exprs result)
1087                            (if (null? exprs)
1088                                result
1089                                (-rtx-combine fn
1090                                              (cdr exprs)
1091                                              (rtx-make fn
1092                                                        result
1093                                                        (car exprs)))))))
1094     (-rtx-combine fn (cdr exprs) (car exprs)))
1095 )
1096 \f
1097 ; Called before a .cpu file is read in.
1098
1099 (define (rtl-init!)
1100   (set! /rtx-func-table (make-hash-table 127))
1101   (set! /rtx-macro-table (make-hash-table 127))
1102   (set! /rtx-num-next 0)
1103   (def-rtx-funcs)
1104
1105   ; Sanity checks.
1106   ; All rtx take options for the first arg and a mode for the second.
1107   (for-each (lambda (rtx-name)
1108               (let ((rtx (rtx-lookup rtx-name)))
1109                 (if rtx
1110                     (begin
1111                       (if (null? (rtx-arg-types rtx))
1112                           #f ; pc is the one exception, blech
1113                           (begin
1114                             (assert (eq? (car (rtx-arg-types rtx)) 'OPTIONS))
1115                             (assert (memq (cadr (rtx-arg-types rtx)) /rtx-valid-mode-types)))))
1116                     #f) ; else a macro
1117                 ))
1118             /rtx-name-list)
1119
1120   (reader-add-command! 'define-subr
1121                        "\
1122 Define an rtx subroutine, name/value pair list version.
1123 "
1124                        nil 'arg-list define-subr)
1125   *UNSPECIFIED*
1126 )
1127
1128 ; Install builtins
1129
1130 (define (rtl-builtin!)
1131   *UNSPECIFIED*
1132 )
1133
1134 ; Called after cpu files are loaded to add misc. remaining entries to the
1135 ; rtx handler table for use during evaluation.
1136 ; rtl-finish! must be done before ifmt-compute!, the latter will
1137 ; construct hardware objects which is done by rtx evaluation.
1138
1139 (define (rtl-finish!)
1140   (logit 2 "Building rtx operand table ...\n")
1141
1142   ; Update s-pc, must be called after operand-init!.
1143   (set! s-pc pc)
1144
1145   ; Table of traversers for the various rtx elements.
1146   (let ((hash-table (/rtx-make-traverser-table)))
1147     (set! /rtx-traverser-table (make-vector (rtx-max-num) #f))
1148     (for-each (lambda (rtx-name)
1149                 (let ((rtx (rtx-lookup rtx-name)))
1150                   (if rtx
1151                       (vector-set! /rtx-traverser-table (rtx-num rtx)
1152                                    (map1-improper
1153                                     (lambda (arg-type)
1154                                       (cons arg-type
1155                                             (hashq-ref hash-table arg-type)))
1156                                     (rtx-arg-types rtx))))))
1157               (rtx-name-list)))
1158
1159   ; Initialize the operand hash table.
1160   (set! /rtx-operand-table (make-hash-table 127))
1161
1162   ; Add the operands to the eval symbol table.
1163   (for-each (lambda (op)
1164               (hashq-set! /rtx-operand-table (obj:name op) op))
1165             (current-op-list))
1166
1167   ; Add ifields to the eval symbol table.
1168   (for-each (lambda (f)
1169               (hashq-set! /rtx-operand-table (obj:name f) f))
1170             (non-derived-ifields (current-ifld-list)))
1171
1172   *UNSPECIFIED*
1173 )