cgen/semantics.scm

   1 ; Routines for instruction semantic analysis (including rtx-simplify).
   2 ; Copyright (C) 2000 Red Hat, Inc.
   3 ; This file is part of CGEN.
   4 ; See file COPYING.CGEN for details.
   5
   6 ; Semantic expression compilation.
   7 ; This is more involved than normal rtx compilation as we need to keep
   8 ; track of the inputs and outputs.  Various attributes that can be derived
   9 ; from the code are also computed.
  10 \f
  11 ; Subroutine of -simplify-expr-fn to compare two values for equality.
  12 ; If both are constants and they're equal return #f/#t.
  13 ; INVERT? = #f -> return #t if equal, #t -> return #f if equal.
  14 ; Returns 'unknown if either argument is not a constant.
  15
  16 (define (rtx-const-equal arg0 arg1 invert?)
  17   (if (and (rtx-constant? arg0)
  18            (rtx-constant? arg1))
  19       (if invert?
  20           (!= (rtx-constant-value arg0)
  21               (rtx-constant-value arg1))
  22           (= (rtx-constant-value arg0)
  23              (rtx-constant-value arg1)))
  24       'unknown)
  25 )
  26
  27 ; Subroutine of -simplify-expr-fn to see if MAYBE-CONST is one of NUMBER-LIST.
  28 ; NUMBER-LIST is a `number-list' rtx.
  29 ; INVERT? is #t if looking for non-membership.
  30 ; #f/#t is only returned for definitive answers.
  31 ; If INVERT? is #f:
  32 ; - return #f if MAYBE-CONST is not in NUMBER-LIST
  33 ; - return #t if MAYBE-CONST is in NUMBER-LIST and it has only one member
  34 ; - return 'member if MAYBE-CONST is in NUMBER-LIST and it has many members
  35 ; - otherwise return 'unknown
  36 ; If INVERT? is #t:
  37 ; - return #t if MAYBE-CONST is not in NUMBER-LIST
  38 ; - return #f if MAYBE-CONST is in NUMBER-LIST and it has only one member
  39 ; - return 'member if MAYBE-CONST is in NUMBER-LIST and it has many members
  40 ; - otherwise return 'unknown
  41
  42 (define (rtx-const-list-equal maybe-const number-list invert?)
  43   (assert (rtx-kind? 'number-list number-list))
  44   (if (rtx-constant? maybe-const)
  45       (let ((values (rtx-number-list-values number-list)))
  46         (if invert?
  47             (if (memq (rtx-constant-value maybe-const) values)
  48                 (if (= (length values) 1)
  49                     #f
  50                     'member)
  51                 #t)
  52             (if (memq (rtx-constant-value maybe-const) values)
  53                 (if (= (length values) 1)
  54                     #t
  55                     'member)
  56                 #f)))
  57       'unknown)
  58 )
  59
  60 ; Subroutine of -simplify-expr-fn to simplify an eq-attr of (current-mach).
  61 ; CONTEXT is a <context> object or #f if there is none.
  62
  63 (define (rtx-simplify-eq-attr-mach rtx context)
  64   (let ((attr (rtx-eq-attr-attr rtx))
  65         (value (rtx-eq-attr-value rtx)))
  66     ; If all currently selected machs will yield the same value
  67     ; for the attribute, we can simplify.
  68     (let ((values (map (lambda (m)
  69                          (obj-attr-value m attr))
  70                        (current-mach-list))))
  71       ; Ensure at least one mach is selected.
  72       (if (null? values)
  73           (context-error context "rtx simplification, no machs selected"
  74                          (rtx-strdump rtx)))
  75       ; All values equal to the first one?
  76       (if (all-true? (map (lambda (val)
  77                             (equal? val (car values)))
  78                           values))
  79           (if (equal? value
  80                       ; Convert internal boolean attribute value
  81                       ; #f/#t to external value FALSE/TRUE.
  82                       ; FIXME:revisit.
  83                       (case (car values)
  84                         ((#f) 'FALSE)
  85                         ((#t) 'TRUE)
  86                         (else (car values))))
  87               (rtx-true)
  88               (rtx-false))
  89           ; couldn't simplify
  90           rtx)))
  91 )
  92
  93 ; Subroutine of -simplify-expr-fn to simplify an eq-attr of (current-insn).
  94
  95 (define (rtx-simplify-eq-attr-insn rtx insn context)
  96   (let ((attr (rtx-eq-attr-attr rtx))
  97         (value (rtx-eq-attr-value rtx)))
  98     (if (not (insn? insn))
  99         (context-error context
 100                        "No current insn for `(current-insn)'"
 101                        (rtx-strdump rtx)))
 102     (let ((attr-value (obj-attr-value insn attr)))
 103       (if (eq? value attr-value)
 104           (rtx-true)
 105           (rtx-false))))
 106 )
 107
 108 ; Subroutine of rtx-simplify.
 109 ; This is the EXPR-FN argument to rtx-traverse.
 110
 111 (define (-simplify-expr-fn rtx-obj expr mode parent-expr op-pos tstate appstuff)
 112
 113   ;(display "Processing ") (display (rtx-dump expr)) (newline)
 114
 115   (case (rtx-name expr)
 116
 117     ((not)
 118      (let* ((arg (-rtx-traverse (rtx-alu-op-arg expr 0)
 119                                 'RTX
 120                                 (rtx-alu-op-mode expr)
 121                                 expr 1 tstate appstuff))
 122             (no-side-effects? (not (rtx-side-effects? arg))))
 123        (cond ((and no-side-effects? (rtx-false? arg))
 124               (rtx-true))
 125              ((and no-side-effects? (rtx-true? arg))
 126               (rtx-false))
 127              (else (rtx-make 'not (rtx-alu-op-mode expr) arg)))))
 128
 129     ((orif)
 130      (let ((arg0 (-rtx-traverse (rtx-boolif-op-arg expr 0)
 131                                 'RTX 'DFLT expr 0 tstate appstuff))
 132            (arg1 (-rtx-traverse (rtx-boolif-op-arg expr 1)
 133                                 'RTX 'DFLT expr 1 tstate appstuff)))
 134        (let ((no-side-effects-0? (not (rtx-side-effects? arg0)))
 135              (no-side-effects-1? (not (rtx-side-effects? arg1))))
 136          (cond ((and no-side-effects-0? (rtx-true? arg0))
 137                 (rtx-true))
 138                ((and no-side-effects-0? (rtx-false? arg0))
 139                 (rtx-canonical-bool arg1))
 140                ; Value of arg0 is unknown or has side-effects.
 141                ((and no-side-effects-1? (rtx-true? arg1))
 142                 (if no-side-effects-0?
 143                     (rtx-true)
 144                     (rtx-make 'orif arg0 (rtx-true))))
 145                ((and no-side-effects-1? (rtx-false? arg1))
 146                 arg0)
 147                (else
 148                 (rtx-make 'orif arg0 arg1))))))
 149
 150     ((andif)
 151      (let ((arg0 (-rtx-traverse (rtx-boolif-op-arg expr 0)
 152                                 'RTX 'DFLT expr 0 tstate appstuff))
 153            (arg1 (-rtx-traverse (rtx-boolif-op-arg expr 1)
 154                                 'RTX 'DFLT expr 1 tstate appstuff)))
 155        (let ((no-side-effects-0? (not (rtx-side-effects? arg0)))
 156              (no-side-effects-1? (not (rtx-side-effects? arg1))))
 157          (cond ((and no-side-effects-0? (rtx-false? arg0))
 158                 (rtx-false))
 159                ((and no-side-effects-0? (rtx-true? arg0))
 160                 (rtx-canonical-bool arg1))
 161                ; Value of arg0 is unknown or has side-effects.
 162                ((and no-side-effects-1? (rtx-false? arg1))
 163                 (if no-side-effects-0?
 164                     (rtx-false)
 165                     (rtx-make 'andif arg0 (rtx-false))))
 166                ((and no-side-effects-1? (rtx-true? arg1))
 167                 arg0)
 168                (else
 169                 (rtx-make 'andif arg0 arg1))))))
 170
 171     ; Fold if's to their then or else part if we can determine the
 172     ; result of the test.
 173     ((if)
 174      (let ((test
 175             ; ??? Was this but that calls rtx-traverse again which
 176             ; resets the temp stack!
 177             ; (rtx-simplify context (caddr expr))))
 178             (-rtx-traverse (rtx-if-test expr) 'RTX 'DFLT expr 1 tstate appstuff)))
 179        (cond ((rtx-true? test)
 180               (-rtx-traverse (rtx-if-then expr) 'RTX mode expr 2 tstate appstuff))
 181              ((rtx-false? test)
 182               (if (rtx-if-else expr)
 183                   (-rtx-traverse (rtx-if-else expr) 'RTX mode expr 3 tstate appstuff)
 184                   ; Sanity check, mode must be VOID.
 185                   (if (or (mode:eq? 'DFLT (rtx-mode expr))
 186                           (mode:eq? 'VOID (rtx-mode expr)))
 187                       (rtx-make 'nop)
 188                       (error "rtx-simplify: non-void-mode `if' missing `else' part" expr))))
 189              ; Can't simplify.
 190              ; We could traverse the then/else clauses here, but it's simpler
 191              ; to have our caller do it.  The cost is retraversing `test'.
 192              (else #f))))
 193
 194     ((eq ne)
 195      (let ((name (rtx-name expr))
 196            (cmp-mode (rtx-cmp-op-mode expr))
 197            (arg0 (-rtx-traverse (rtx-cmp-op-arg expr 0) 'RTX
 198                                 (rtx-cmp-op-mode expr)
 199                                 expr 1 tstate appstuff))
 200            (arg1 (-rtx-traverse (rtx-cmp-op-arg expr 1) 'RTX
 201                                 (rtx-cmp-op-mode expr)
 202                                 expr 2 tstate appstuff)))
 203        (if (or (rtx-side-effects? arg0) (rtx-side-effects? arg1))
 204            (rtx-make name cmp-mode arg0 arg1)
 205            (case (rtx-const-equal arg0 arg1 (rtx-kind? 'ne expr))
 206              ((#f) (rtx-false))
 207              ((#t) (rtx-true))
 208              (else
 209               ; That didn't work.  See if we have an ifield/operand with a
 210               ; known range of values.
 211               (case (rtx-name arg0)
 212                 ((ifield)
 213                  (let ((known-val (tstate-known-lookup tstate
 214                                                        (rtx-ifield-name arg0))))
 215                    (if (and known-val (rtx-kind? 'number-list known-val))
 216                        (case (rtx-const-list-equal arg1 known-val (rtx-kind? 'ne expr))
 217                          ((#f) (rtx-false))
 218                          ((#t) (rtx-true))
 219                          (else
 220                           (rtx-make name cmp-mode arg0 arg1)))
 221                        (rtx-make name cmp-mode arg0 arg1))))
 222                 ((operand)
 223                  (let ((known-val (tstate-known-lookup tstate
 224                                                        (rtx-operand-name arg0))))
 225                    (if (and known-val (rtx-kind? 'number-list known-val))
 226                        (case (rtx-const-list-equal arg1 known-val (rtx-kind? 'ne expr))
 227                          ((#f) (rtx-false))
 228                          ((#t) (rtx-true))
 229                          (else
 230                           (rtx-make name cmp-mode arg0 arg1)))
 231                        (rtx-make name cmp-mode arg0 arg1))))
 232                 (else
 233                  (rtx-make name cmp-mode arg0 arg1))))))))
 234
 235     ; Recognize attribute requests of current-insn, current-mach.
 236     ((eq-attr)
 237      (cond ((rtx-kind? 'current-mach (rtx-eq-attr-owner expr))
 238             (rtx-simplify-eq-attr-mach expr (tstate-context tstate)))
 239            ((rtx-kind? 'current-insn (rtx-eq-attr-owner expr))
 240             (rtx-simplify-eq-attr-insn expr (tstate-owner tstate) (tstate-context tstate)))
 241            (else expr)))
 242
 243     ((ifield)
 244      (let ((known-val (tstate-known-lookup tstate (rtx-ifield-name expr))))
 245        ; If the value is a single number, return that.
 246        ; It can be one of several, represented as a number list.
 247        (if (and known-val (rtx-constant? known-val))
 248            known-val ; (rtx-make 'const 'INT known-val)
 249            #f)))
 250
 251     ((operand)
 252      (let ((known-val (tstate-known-lookup tstate (rtx-operand-name expr))))
 253        ; If the value is a single number, return that.
 254        ; It can be one of several, represented as a number list.
 255        (if (and known-val (rtx-constant? known-val))
 256            known-val ; (rtx-make 'const 'INT known-val)
 257            #f)))
 258
 259     ; Leave EXPR unchanged and continue.
 260     (else #f))
 261 )
 262
 263 ; Simplify an rtl expression.
 264 ; EXPR must be in source form.
 265 ; The result is a possibly simplified EXPR, still in source form.
 266 ;
 267 ; CONTEXT is a <context> object, used for error messages.
 268 ; OWNER is the owner of the expression (e.g. <insn>) or #f if there is none.
 269 ;
 270 ; KNOWN is an alist of known values.  Each element is (name . value) where
 271 ; NAME is an ifield/operand name and VALUE is a const/number-list rtx.
 272 ; FIXME: Need ranges, later.
 273 ;
 274 ; The following operations are performed:
 275 ; - unselected machine dependent code is removed (eq-attr of (current-mach))
 276 ; - if's are reduced to either then/else if we can determine that the test is
 277 ;   a compile-time constant
 278 ; - orif/andif
 279 ; - eq/ne
 280 ; - not
 281 ;
 282 ; ??? Will become more intelligent as needed.
 283
 284 (define (rtx-simplify context owner expr known)
 285   (-rtx-traverse expr #f 'DFLT #f 0
 286                  (tstate-make context owner
 287                               (/fastcall-make -simplify-expr-fn)
 288                               (rtx-env-empty-stack)
 289                               #f #f known 0)
 290                  #f)
 291 )
 292 \f
 293 ; Utilities for equation solving.
 294 ; ??? At the moment this is only focused on ifield assertions.
 295 ; ??? That there exist more sophisticated versions than this one can take
 296 ; as a given.  This works for the task at hand and will evolve or be replaced
 297 ; as necessary.
 298 ; ??? This makes the simplifying assumption that no expr has side-effects.
 299
 300 ; Subroutine of rtx-solve.
 301 ; This is the EXPR-FN argument to rtx-traverse.
 302
 303 (define (-solve-expr-fn rtx-obj expr mode parent-expr op-pos tstate appstuff)
 304   #f ; wip
 305 )
 306
 307 ; Return a boolean indicating if {expr} equates to "true".
 308 ; If the expression can't be reduced to #f/#t, return '?.
 309 ; ??? Use rtx-eval instead of rtx-traverse?
 310 ;
 311 ; EXPR must be in source form.
 312 ; CONTEXT is a <context> object, used for error messages.
 313 ; OWNER is the owner of the expression (e.g. <insn>) or #f if there is none.
 314 ; KNOWN is an alist of known values.  Each element is (name . value) where
 315 ; NAME is an ifield/operand name and VALUE is a const/number-list rtx.
 316 ; FIXME: Need ranges, later.
 317 ;
 318 ; This is akin to rtx-simplify except it's geared towards solving ifield
 319 ; assertions.  It's not unreasonable to combine them.  The worry is the
 320 ; efficiency lost.
 321 ; ??? Will become more intelligent as needed.
 322
 323 (define (rtx-solve context owner expr known)
 324   ; First simplify, then solve.
 325   (let* ((simplified-expr (rtx-simplify context owner expr known))
 326          (maybe-solved-expr
 327           simplified-expr) ; FIXME: for now
 328 ;         (-rtx-traverse simplified-expr #f 'DFLT #f 0
 329 ;                        (tstate-make context owner
 330 ;                                     (/fastcall-make -solve-expr-fn)
 331 ;                                     (rtx-env-empty-stack)
 332 ;                                     #f #f known 0)
 333 ;                        #f))
 334          )
 335     (cond ((rtx-true? maybe-solved-expr) #t)
 336           ((rtx-false? maybe-solved-expr) #f)
 337           (else '?)))
 338 )
 339 \f
 340 ; Subroutine of -rtx-find-op to determine if two modes are equivalent.
 341 ; Two modes are equivalent if they're equal, or if their sem-mode fields
 342 ; are equal.
 343
 344 (define (-rtx-mode-equiv? m1 m2)
 345   (or (eq? m1 m2)
 346       (let ((mode1 (mode:lookup m1))
 347             (mode2 (mode:lookup m2)))
 348         (let ((s1 (mode:sem-mode mode1))
 349               (s2 (mode:sem-mode mode2)))
 350           (eq? (if s1 (obj:name s1) m1) (if s2 (obj:name s2) m2)))))
 351 )
 352
 353 ; Subroutine of semantic-compile to find OP in OP-LIST.
 354 ; OP-LIST is a list of operand expressions: (type expr mode name indx-sel).
 355 ; The result is the list element or #f if not found.
 356 ; TYPE is one of -op- reg mem.
 357 ; EXPR is the constructed `xop' rtx expression for the operand,
 358 ;   ignored in the search.
 359 ; MODE must match, as defined by -rtx-mode-equiv?.
 360 ; NAME is the hardware element name, ifield name, or '-op-'.
 361 ; INDX-SEL must match if present in either.
 362 ;
 363 ; ??? Does this need to take "conditionally-referenced" into account?
 364
 365 (define (-rtx-find-op op op-list)
 366   (let ((type (car op))
 367         (mode (caddr op))
 368         (name (cadddr op))
 369         (indx-sel (car (cddddr op))))
 370     ; The first cdr is to drop the dummy first arg.
 371     (let loop ((op-list (cdr op-list)))
 372       (cond ((null? op-list) #f)
 373             ((eq? type (caar op-list))
 374              (let ((try (car op-list)))
 375                (if (and (eq? name (cadddr try))
 376                         (-rtx-mode-equiv? mode (caddr try))
 377                         (equal? indx-sel (car (cddddr try))))
 378                    try
 379                    (loop (cdr op-list)))))
 380             (else (loop (cdr op-list))))))
 381 )
 382
 383 ; Subroutine of semantic-compile to determine how the operand in
 384 ; position OP-POS of EXPR is used.
 385 ; The result is one of 'use, 'set, 'set-quiet.
 386 ; "use" means "input operand".
 387
 388 (define (-rtx-ref-type expr op-pos)
 389   ; operand 0 is the option list, operand 1 is the mode
 390   ; (if you want to complain, fine, it's not like it would be unexpected)
 391   (if (= op-pos 2)
 392       (case (car expr)
 393         ((set) 'set)
 394         ((set-quiet clobber) 'set-quiet)
 395         (else 'use))
 396       'use)
 397 )
 398
 399 ; Subroutine of semantic-compile:process-expr!, to simplify it.
 400 ; Looks up the operand in the current set, returns it if found,
 401 ; otherwise adds it.
 402 ; REF-TYPE is one of 'use, 'set, 'set-quiet.
 403 ; Adds COND-CTI/UNCOND-CTI to SEM-ATTRS if the operand is a set of the pc.
 404
 405 (define (-build-operand! op-name op mode tstate ref-type op-list sem-attrs)
 406   ;(display (list op-name mode ref-type)) (newline) (force-output)
 407   (let* ((mode (mode-real-name (if (eq? mode 'DFLT)
 408                                    (op:mode op)
 409                                    mode)))
 410          ; The first #f is a placeholder for the object.
 411          (try (list '-op- #f mode op-name #f))
 412          (existing-op (-rtx-find-op try op-list)))
 413
 414     (if (and (pc? op)
 415              (memq ref-type '(set set-quiet)))
 416         (append! sem-attrs
 417                  (list (if (tstate-cond? tstate) 'COND-CTI 'UNCOND-CTI))))
 418
 419     ; If already present, return the object, otherwise add it.
 420     (if existing-op
 421
 422         (cadr existing-op)
 423
 424         ; We can't set the operand number yet 'cus we don't know it.
 425         ; However, when it's computed we'll need to set all associated
 426         ; operands.  This is done by creating shared rtx (a la gcc) - the
 427         ; operand number then need only be updated in one place.
 428
 429         (let ((xop (op:new-mode op mode)))
 430           (op:set-cond?! xop (tstate-cond? tstate))
 431           ; Set the object rtx in `try', now that we have it.
 432           (set-car! (cdr try) (rtx-make 'xop xop))
 433           ; Add the operand to in/out-ops.
 434           (append! op-list (list try))
 435           (cadr try))))
 436 )
 437
 438 ; Subroutine of semantic-compile:process-expr!, to simplify it.
 439
 440 (define (-build-reg-operand! expr tstate op-list)
 441   (let* ((hw-name (rtx-reg-name expr))
 442          (hw (current-hw-sem-lookup-1 hw-name)))
 443
 444     (if hw
 445         ; If the mode is DFLT, use the object's natural mode.
 446         (let* ((mode (mode-real-name (if (eq? (rtx-mode expr) 'DFLT)
 447                                          (obj:name (hw-mode hw))
 448                                          (rtx-mode expr))))
 449                (indx-sel (rtx-reg-index-sel expr))
 450                ; #f is a place-holder for the object (filled in later)
 451                (try (list 'reg #f mode hw-name indx-sel))
 452                (existing-op (-rtx-find-op try op-list)))
 453
 454           ; If already present, return the object, otherwise add it.
 455           (if existing-op
 456
 457               (cadr existing-op)
 458
 459               (let ((xop (apply reg (cons (tstate->estate tstate)
 460                                           (cons mode
 461                                                 (cons hw-name indx-sel))))))
 462                 (op:set-cond?! xop (tstate-cond? tstate))
 463                 ; Set the object rtx in `try', now that we have it.
 464                 (set-car! (cdr try) (rtx-make 'xop xop))
 465                 ; Add the operand to in/out-ops.
 466                 (append! op-list (list try))
 467                 (cadr try))))
 468
 469         (parse-error "FIXME" "unknown reg" expr)))
 470 )
 471
 472 ; Subroutine of semantic-compile:process-expr!, to simplify it.
 473
 474 (define (-build-mem-operand! expr tstate op-list)
 475   (let ((mode (rtx-mode expr))
 476         (indx-sel (rtx-mem-index-sel expr)))
 477
 478     (if (memq mode '(DFLT VOID))
 479         (parse-error "FIXME" "memory must have explicit mode" expr))
 480
 481     (let* ((try (list 'mem #f mode 'h-memory indx-sel))
 482            (existing-op (-rtx-find-op try op-list)))
 483
 484       ; If already present, return the object, otherwise add it.
 485       (if existing-op
 486
 487           (cadr existing-op)
 488
 489           (let ((xop (apply mem (cons (tstate->estate tstate)
 490                                       (cons mode indx-sel)))))
 491             (op:set-cond?! xop (tstate-cond? tstate))
 492             ; Set the object in `try', now that we have it.
 493             (set-car! (cdr try) (rtx-make 'xop xop))
 494             ; Add the operand to in/out-ops.
 495             (append! op-list (list try))
 496             (cadr try)))))
 497 )
 498
 499 ; Subroutine of semantic-compile:process-expr!, to simplify it.
 500
 501 (define (-build-ifield-operand! expr tstate op-list)
 502   (let* ((f-name (rtx-ifield-name expr))
 503          (f (current-ifld-lookup f-name)))
 504
 505     (if (not f)
 506         (parse-error "FIXME" "unknown ifield" f-name))
 507
 508     (let* ((mode (obj:name (ifld-mode f)))
 509            (try (list '-op- #f mode f-name #f))
 510            (existing-op (-rtx-find-op try op-list)))
 511
 512       ; If already present, return the object, otherwise add it.
 513       (if existing-op
 514
 515           (cadr existing-op)
 516
 517           (let ((xop (make <operand> f-name f-name
 518                            (atlist-cons (bool-attr-make 'SEM-ONLY #t)
 519                                         (obj-atlist f))
 520                            (obj:name (ifld-hw-type f))
 521                            mode
 522                            (make <hw-index> 'anonymous
 523                                  'ifield (ifld-mode f) f)
 524                            nil #f #f)))
 525             (set-car! (cdr try) (rtx-make 'xop xop))
 526             (append! op-list (list try))
 527             (cadr try)))))
 528 )
 529
 530 ; Subroutine of semantic-compile:process-expr!, to simplify it.
 531 ;
 532 ; ??? There are various optimizations (both space usage in ARGBUF and time
 533 ; spent in semantic code) that can be done on code that uses index-of
 534 ; (see i960's movq insn).  Later.
 535
 536 (define (-build-index-of-operand! expr tstate op-list)
 537   (if (not (and (rtx? (rtx-index-of-value expr))
 538                 (rtx-kind? 'operand (rtx-index-of-value expr))))
 539       (parse-error "FIXME" "only `(index-of operand)' is currently supported"
 540                    expr))
 541
 542   (let ((op (rtx-operand-obj (rtx-index-of-value expr))))
 543     (let ((indx (op:index op)))
 544       (if (not (eq? (hw-index:type indx) 'ifield))
 545           (parse-error "FIXME" "only ifield indices are currently supported"
 546                        expr))
 547       (let* ((f (hw-index:value indx))
 548              (f-name (obj:name f)))
 549         ; The rest of this is identical to -build-ifield-operand!.
 550         (let* ((mode (obj:name (ifld-mode f)))
 551                (try (list '-op- #f mode f-name #f))
 552                (existing-op (-rtx-find-op try op-list)))
 553
 554           ; If already present, return the object, otherwise add it.
 555           (if existing-op
 556
 557               (cadr existing-op)
 558
 559               (let ((xop (make <operand> f-name f-name
 560                                (atlist-cons (bool-attr-make 'SEM-ONLY #t)
 561                                             (obj-atlist f))
 562                                (obj:name (ifld-hw-type f))
 563                                mode
 564                                (make <hw-index> 'anonymous
 565                                      'ifield
 566                                      (ifld-mode f)
 567                                      ; (send (op:type op) 'get-index-mode)
 568                                      f)
 569                                nil #f #f)))
 570                 (set-car! (cdr try) (rtx-make 'xop xop))
 571                 (append! op-list (list try))
 572                 (cadr try)))))))
 573 )
 574
 575 ; Build the tstate known value list for INSN.
 576 ; This built from the ifield-assertion list.
 577
 578 (define (insn-build-known-values insn)
 579   (let ((expr (insn-ifield-assertion insn)))
 580     (if expr
 581         (case (rtx-name expr)
 582           ((eq)
 583            (if (and (rtx-kind? 'ifield (rtx-cmp-op-arg expr 0))
 584                     (rtx-constant? (rtx-cmp-op-arg expr 1)))
 585                (list (cons (rtx-ifield-name (rtx-cmp-op-arg expr 0))
 586                            (rtx-cmp-op-arg expr 1)))
 587                nil))
 588           ((member)
 589            (if (rtx-kind? 'ifield (rtx-member-value expr))
 590                (list (cons (rtx-ifield-name (rtx-member-value expr))
 591                            (rtx-member-set expr)))
 592                nil))
 593           (else nil))
 594         nil))
 595 )
 596
 597 ; Structure to record the result of semantic-compile.
 598
 599 (define (csem-make compiled-code inputs outputs attributes)
 600   (vector compiled-code inputs outputs attributes)
 601 )
 602
 603 ; Accessors.
 604
 605 (define (csem-code csem) (vector-ref csem 0))
 606 (define (csem-inputs csem) (vector-ref csem 1))
 607 (define (csem-outputs csem) (vector-ref csem 2))
 608 (define (csem-attrs csem) (vector-ref csem 3))
 609 \f
 610 ; Traverse each element in SEM-CODE-LIST, converting them to canonical form,
 611 ; and computing the input and output operands.
 612 ; The result is an object of four elements (built with csem-make).
 613 ; The first is a list of the canonical form of each element in SEM-CODE-LIST:
 614 ; operand and ifield elements specified without `operand' or `ifield' have it
 615 ; prepended, and operand numbers are computed for each operand.
 616 ; Operand numbers are needed when emitting "write" handlers for LIW cpus.
 617 ; Having the operand numbers available is also useful for efficient
 618 ; modeling: recording operand references can be done with a bitmask (one host
 619 ; insn), and the code to do the modeling can be kept out of the code that
 620 ; performs the insn.
 621 ; The second is the list of input <operand> objects.
 622 ; The third is the list of output <operand> objects.
 623 ; The fourth is an <attr-list> object of attributes that can be computed from
 624 ; the semantics.
 625 ; The possibilities are: UNCOND-CTI, COND-CTI, SKIP-CTI, DELAY-SLOT.
 626 ; ??? Combine *-CTI into an enum attribute.
 627 ;
 628 ; CONTEXT is a <context> object or #f if there is none.
 629 ; INSN is the <insn> object.
 630 ;
 631 ; ??? Specifying operand ordinals in the source would simplify this and speed
 632 ; it up.  On the other hand that makes the source form more complex.  Maybe the
 633 ; complexity will prove necessary, but following the goal of "incremental
 634 ; complication", we don't do this yet.
 635 ; Another way to simplify this and speed it up would be to add lists of
 636 ; input/output operands to the instruction description.
 637 ;
 638 ; ??? This calls rtx-simplify which calls rtx-traverse as it's simpler to
 639 ; simplify EXPR first, and then compile it.  On the other hand it's slower
 640 ; (two calls to rtx-traverse!).
 641 ;
 642 ; FIXME: There's no need for sem-code-list to be a list.
 643 ; The caller always passes (list (insn-semantics insn)).
 644
 645 (define (semantic-compile context insn sem-code-list)
 646   (for-each (lambda (rtx) (assert (rtx? rtx)))
 647             sem-code-list)
 648
 649   (let*
 650       ; String for error messages.
 651       ((errtxt "semantic compilation")
 652
 653        ; These record the result of traversing SEM-CODE-LIST.
 654        ; They're lists of (type object mode name [args ...]).
 655        ; TYPE is one of: -op- reg mem.
 656        ; `-op-' is just something unique and is only used internally.
 657        ; OBJECT is the constructed <operand> object.
 658        ; The first element is just a dummy so that append! always works.
 659        (in-ops (list (list #f)))
 660        (out-ops (list (list #f)))
 661
 662        ; List of attributes computed from SEM-CODE-LIST.
 663        ; The first element is just a dummy so that append! always works.
 664        (sem-attrs (list #f))
 665
 666        ; Called for expressions encountered in SEM-CODE-LIST.
 667        ; Don't waste cpu here, this is part of the slowest piece in CGEN.
 668        (process-expr!
 669         (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff)
 670           (case (car expr)
 671
 672             ; Registers.
 673             ((reg) (let ((ref-type (-rtx-ref-type parent-expr op-pos))
 674                          ; ??? could verify reg is a scalar
 675                          (regno (or (rtx-reg-number expr) 0)))
 676                      ; The register number is either a number or an
 677                      ; expression.
 678                      ; ??? This is a departure from GCC RTL that might have
 679                      ; significant ramifications.  On the other hand in cases
 680                      ; where it matters the expression could always be
 681                      ; required to reduce to a constant (or some such).
 682                      (cond ((number? regno) #t)
 683                            ((form? regno)
 684                             (rtx-traverse-operands rtx-obj expr tstate appstuff))
 685                            (else (parse-error errtxt
 686                                               "invalid register number"
 687                                               regno)))
 688                      (-build-reg-operand! expr tstate
 689                                           (if (eq? ref-type 'use)
 690                                               in-ops
 691                                               out-ops))))
 692
 693             ; Memory.
 694             ((mem) (let ((ref-type (-rtx-ref-type parent-expr op-pos)))
 695                      (rtx-traverse-operands rtx-obj expr tstate appstuff)
 696                      (-build-mem-operand! expr tstate
 697                                           (if (eq? ref-type 'use)
 698                                               in-ops
 699                                               out-ops))))
 700
 701             ; Operands.
 702             ((operand) (let ((op (rtx-operand-obj expr))
 703                              (ref-type (-rtx-ref-type parent-expr op-pos)))
 704                          (-build-operand! (obj:name op) op mode tstate ref-type
 705                                           (if (eq? ref-type 'use)
 706                                               in-ops
 707                                               out-ops)
 708                                           sem-attrs)))
 709
 710             ; Give operand new name.
 711             ((name) (let ((result (-rtx-traverse (caddr expr) 'RTX mode
 712                                                  parent-expr op-pos tstate appstuff)))
 713                       (if (not (operand? result))
 714                           (error "name: invalid argument:" expr result))
 715                       (op:set-sem-name! result (cadr expr))
 716                       ; (op:set-num! result (caddr expr))
 717                       result))
 718
 719             ; Specify a reference to a local variable
 720             ((local) expr) ; nothing to do
 721
 722             ; Instruction fields.
 723             ((ifield) (let ((ref-type (-rtx-ref-type parent-expr op-pos)))
 724                         (if (not (eq? ref-type 'use))
 725                             (parse-error errtxt "can't set an `ifield'" expr))
 726                         (-build-ifield-operand! expr tstate in-ops)))
 727
 728             ; Hardware indices.
 729             ; For registers this is the register number.
 730             ; For memory this is the address.
 731             ; For constants, this is the constant.
 732             ((index-of) (let ((ref-type (-rtx-ref-type parent-expr op-pos)))
 733                           (if (not (eq? ref-type 'use))
 734                               (parse-error errtxt "can't set an `index-of'" expr))
 735                           (-build-index-of-operand! expr tstate in-ops)))
 736
 737             ; Machine generate the SKIP-CTI attribute.
 738             ((skip) (append! sem-attrs (list 'SKIP-CTI)) #f)
 739
 740             ; Machine generate the DELAY-SLOT attribute.
 741             ((delay) (append! sem-attrs (list 'DELAY-SLOT)) #f)
 742
 743             ; If this is a syntax expression, the operands won't have been
 744             ; processed, so tell our caller we want it to by returning #f.
 745             ; We do the same for non-syntax expressions to keep things
 746             ; simple.  This requires collaboration with the traversal
 747             ; handlers which are defined to do what we want if we return #f.
 748             (else #f))))
 749
 750        ; Whew.  We're now ready to traverse the expression.
 751        ; Traverse the expression recording the operands and building objects
 752        ; for most elements in the source representation.
 753        ; This also performs various simplifications.
 754        ; In particular machine dependent code for non-selected machines
 755        ; is discarded.
 756        (compiled-exprs (map (lambda (expr)
 757                               (rtx-traverse
 758                                context
 759                                insn
 760                                (rtx-simplify context insn expr
 761                                              (insn-build-known-values insn))
 762                                process-expr!
 763                                #f))
 764                             sem-code-list))
 765        )
 766
 767     ;(display "in:  ") (display in-ops) (newline)
 768     ;(display "out: ") (display out-ops) (newline)
 769     ;(force-output)
 770
 771     ; Now that we have the nub of all input and output operands,
 772     ; we can assign operand numbers.  Inputs and outputs are not defined
 773     ; separately, output operand numbers follow inputs.  This simplifies the
 774     ; code which keeps track of such things: it can use one variable.
 775     ; The assignment is defined to be arbitrary.  If there comes a day
 776     ; when we need to prespecify operand numbers, revisit.
 777     ; The operand lists are sorted to avoid spurious differences in generated
 778     ; code (for example unnecessary extra entries can be created in the
 779     ; ARGBUF struct).
 780
 781     ; Drop dummy first arg and sort operand lists.
 782     (let ((sorted-ins
 783            (alpha-sort-obj-list (map (lambda (op)
 784                                        (rtx-xop-obj (cadr op)))
 785                                      (cdr in-ops))))
 786           (sorted-outs
 787            (alpha-sort-obj-list (map (lambda (op)
 788                                        (rtx-xop-obj (cadr op)))
 789                                      (cdr out-ops))))
 790           (sem-attrs (cdr sem-attrs)))
 791
 792       (let ((in-op-nums (iota (length sorted-ins)))
 793             (out-op-nums (iota (length sorted-outs) (length sorted-ins))))
 794
 795         (for-each (lambda (op num) (op:set-num! op num))
 796                   sorted-ins in-op-nums)
 797         (for-each (lambda (op num) (op:set-num! op num))
 798                   sorted-outs out-op-nums)
 799
 800         (let ((dump (lambda (op)
 801                       (string/symbol-append "  "
 802                                             (obj:name op)
 803                                             " "
 804                                             (number->string (op:num op))
 805                                             "\n"))))
 806           (logit 4
 807                  "Input operands:\n"
 808                  (map dump sorted-ins)
 809                  "Output operands:\n"
 810                  (map dump sorted-outs)
 811                  "End of operands.\n"))
 812
 813         (csem-make compiled-exprs sorted-ins sorted-outs
 814                    (atlist-parse sem-attrs "" "semantic attributes")))))
 815 )
 816 \f
 817 ; Traverse SEM-CODE-LIST, computing attributes derivable from it.
 818 ; The result is an <attr-list> object of attributes that can be computed from
 819 ; the semantics.
 820 ; The possibilities are: UNCOND-CTI, COND-CTI, SKIP-CTI, DELAY-SLOT.
 821 ; This computes the same values as semantic-compile, but for speed is
 822 ; focused on attributes only.
 823 ; ??? Combine *-CTI into an enum attribute.
 824 ;
 825 ; CONTEXT is a <context> object or #f if there is none.
 826 ; INSN is the <insn> object.
 827 ;
 828 ; FIXME: There's no need for sem-code-list to be a list.
 829 ; The caller always passes (list (insn-semantics insn)).
 830
 831 (define (semantic-attrs context insn sem-code-list)
 832   (for-each (lambda (rtx) (assert (rtx? rtx)))
 833             sem-code-list)
 834
 835   (let*
 836       ; String for error messages.
 837       ((errtxt "semantic attribute computation")
 838
 839        ; List of attributes computed from SEM-CODE-LIST.
 840        ; The first element is just a dummy so that append! always works.
 841        (sem-attrs (list #f))
 842
 843        ; Called for expressions encountered in SEM-CODE-LIST.
 844        (process-expr!
 845         (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff)
 846           (case (car expr)
 847
 848             ((operand) (if (and (eq? 'pc (obj:name (rtx-operand-obj expr)))
 849                                 (memq (-rtx-ref-type parent-expr op-pos)
 850                                       '(set set-quiet)))
 851                            (append! sem-attrs
 852                                     (if (tstate-cond? tstate)
 853                                         ; Don't change these to '(FOO), since
 854                                         ; we use append!.
 855                                         (list 'COND-CTI)
 856                                         (list 'UNCOND-CTI)))))
 857             ((skip) (append! sem-attrs (list 'SKIP-CTI)) #f)
 858             ((delay) (append! sem-attrs (list 'DELAY-SLOT)) #f)
 859
 860             ; If this is a syntax expression, the operands won't have been
 861             ; processed, so tell our caller we want it to by returning #f.
 862             ; We do the same for non-syntax expressions to keep things
 863             ; simple.  This requires collaboration with the traversal
 864             ; handlers which are defined to do what we want if we return #f.
 865             (else #f))))
 866
 867        ; Traverse the expression recording the attributes.
 868        (traversed-exprs (map (lambda (expr)
 869                                (rtx-traverse
 870                                 context
 871                                 insn
 872                                 (rtx-simplify context insn expr
 873                                               (insn-build-known-values insn))
 874                                 process-expr!
 875                                 #f))
 876                              sem-code-list))
 877        )
 878
 879     (let
 880         ; Drop dummy first arg.
 881         ((sem-attrs (cdr sem-attrs)))
 882       (atlist-parse sem-attrs "" "semantic attributes")))
 883 )