cgen/rtl.scm

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