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