cgen/utils-sim.scm

   1 ; Generic simulator application utilities.
   2 ; Copyright (C) 2000, 2005, 2006, 2009 Red Hat, Inc.
   3 ; This file is part of CGEN.
   4 ; See file COPYING.CGEN for details.
   5
   6 ; The cache-addr? method.
   7 ; Return #t if the hardware element's address is stored in the scache buffer.
   8 ; This saves doing the index calculation during semantic processing.
   9
  10 (method-make!
  11  <hardware-base> 'cache-addr?
  12  (lambda (self)
  13    (and (with-scache?)
  14         (has-attr? self 'CACHE-ADDR)))
  15 )
  16
  17 (define (hw-cache-addr? hw) (send hw 'cache-addr?))
  18 \f
  19 ; The needed-iflds method.
  20 ; Return list of ifields needed during semantic execution by hardware element
  21 ; SELF referenced by <operand> OP in <sformat> SFMT.
  22
  23 (method-make!
  24  <hardware-base> 'needed-iflds
  25  (lambda (self op sfmt)
  26    (list (op-ifield op)))
  27 )
  28
  29 (method-make!
  30  <hw-register> 'needed-iflds
  31  (lambda (self op sfmt)
  32    (list (op-ifield op)))
  33 ; Instead of the following, we now arrange to store the ifield in the
  34 ; argbuf, even for CACHE-ADDR operands.  This way, the ifield values
  35 ; (register numbers, etc.) remain available during semantics tracing.
  36 ;   (if (hw-cache-addr? self)
  37 ;       nil
  38 ;       (list (op-ifield op))))
  39 )
  40
  41 ; For addresses this is none because we make our own copy of the ifield
  42 ; [because we want to use a special type].
  43
  44 (method-make!
  45  <hw-address> 'needed-iflds
  46  (lambda (self op sfmt)
  47    nil)
  48 )
  49
  50 (define (hw-needed-iflds hw op sfmt) (send hw 'needed-iflds op sfmt))
  51
  52 ; Return a list of ifields of <operand> OP that must be recorded in ARGBUF
  53 ; for <sformat> SFMT.
  54 ; ??? At the moment there can only be at most one, but callers must not
  55 ; assume this.
  56
  57 (define (op-needed-iflds op sfmt)
  58   (let ((indx (op:index op)))
  59     (logit 4 "op-needed-iflds op=" (obj:name op) " indx=" (obj:name indx)
  60            " indx-type=" (hw-index:type indx) " sfmt=" (obj:name sfmt) "\n")
  61     (cond
  62      ((and
  63        (eq? (hw-index:type indx) 'ifield)
  64        (not (= (ifld-length (hw-index:value indx)) 0)))
  65       (hw-needed-iflds (op:type op) op sfmt))
  66      ((eq? (hw-index:type indx) 'derived-ifield)
  67       (ifld-needed-iflds indx))
  68      (else nil)))
  69   )
  70 \f
  71 ; Operand extraction (ARGBUF) support code.
  72 ;
  73 ; Any operand that uses a non-empty ifield needs extraction support.
  74 ; Normally we just record the ifield's value.  However, in cases where
  75 ; hardware elements have CACHE-ADDR specified or where the mode of the
  76 ; hardware index isn't compatible with the mode of the decoded ifield
  77 ; (this can happen for pc-relative instruction address), we need to record
  78 ; something else.
  79
  80 ; Return a boolean indicating if <operand> OP needs any extraction processing.
  81
  82 (define (op-extract? op)
  83   (let* ((indx (op:index op))
  84          (extract?
  85           (if (derived-operand? op)
  86               (any-true? (map op-extract? (derived-args op)))
  87               (and (eq? (hw-index:type indx) 'ifield)
  88                    (not (= (ifld-length (hw-index:value indx)) 0))))))
  89     (logit 4 "op-extract? op=" (obj:name op) " =>" extract? "\n")
  90     extract?)
  91 )
  92
  93 ; Return a list of operands that need special extraction processing.
  94 ; SFMT is an <sformat> object.
  95
  96 (define (sfmt-extracted-operands sfmt)
  97   (let ((in-ops (sfmt-in-ops sfmt))
  98         (out-ops (sfmt-out-ops sfmt)))
  99     (let ((ops (append (find op-extract? in-ops)
 100                        (find op-extract? out-ops))))
 101       (nub ops obj:name)))
 102 )
 103
 104 ; Return a list of ifields that are needed by the semantic code.
 105 ; SFMT is an <sformat> object.
 106 ; ??? This redoes a lot of the calculation that sfmt-extracted-operands does.
 107
 108 (define (sfmt-needed-iflds sfmt)
 109   (let ((in-ops (sfmt-in-ops sfmt))
 110         (out-ops (sfmt-out-ops sfmt)))
 111     (let ((ops (append (find op-extract? in-ops)
 112                        (find op-extract? out-ops))))
 113       (nub (apply append (map (lambda (op)
 114                                 (op-needed-iflds op sfmt))
 115                               ops))
 116            obj:name)))
 117 )
 118 \f
 119 ; Sformat argument buffer.
 120 ;
 121 ; This contains the details needed to create an argument buffer `fields' union
 122 ; entry for the containing sformats.
 123
 124 (define <sformat-argbuf>
 125   (class-make '<sformat-argbuf>
 126               '(<ident>)
 127               ; From <ident>:
 128               ; - NAME is derived from one of the containing sformats.
 129               '(
 130                 ; List of structure elements.
 131                 ; Each element is ("var name" "C type" bitsize).
 132                 ; The list is sorted by decreasing size, then C type,
 133                 ; then var name.
 134                 elms
 135                 )
 136               nil)
 137 )
 138
 139 (define-getters <sformat-argbuf> sbuf (sfmts elms))
 140
 141 ; Subroutine of /sfmt-contents to return an ifield element.
 142 ; The result is ("var-name" "C-type" bitsize).
 143
 144 (define (/sfmt-ifld-elm f sfmt)
 145   (let ((real-mode (mode-real-mode (ifld-decode-mode f))))
 146     (list (gen-sym f)
 147           (mode:c-type real-mode)
 148           (mode:bits real-mode)))
 149 )
 150
 151 ; sbuf-elm method.
 152 ; The result is ("var-name" "C-type" approx-bitsize) or #f if unneeded.
 153 ; For the default case we use the ifield as is, which is computed elsewhere.
 154
 155 (method-make!
 156  <hardware-base> 'sbuf-elm
 157  (lambda (self op ifmt)
 158    #f)
 159 )
 160
 161 (method-make!
 162  <hw-register> 'sbuf-elm
 163  (lambda (self op ifmt)
 164    (if (hw-cache-addr? self)
 165        (list (gen-sym (op:index op))
 166              (string-append (gen-type self) "*")
 167              ; Use 64 bits for size.  Doesn't really matter, just put them
 168              ; near the front.
 169              64)
 170        #f))
 171 )
 172
 173 ; We want to use ADDR/IADDR in ARGBUF for addresses
 174
 175 (method-make!
 176  <hw-address> 'sbuf-elm
 177  (lambda (self op ifmt)
 178    (list (gen-sym (op:index op))
 179          "ADDR"
 180          ; Use 64 bits for size.  Doesn't really matter, just put them
 181          ; near the front.
 182          64))
 183 )
 184
 185 (method-make!
 186  <hw-iaddress> 'sbuf-elm
 187  (lambda (self op ifmt)
 188    (list (gen-sym (op:index op))
 189          "IADDR"
 190          ; Use 64 bits for size.  Doesn't really matter, just put them
 191          ; near the front.
 192          64))
 193 )
 194
 195 ; Subroutine of /sfmt-contents to return an operand element.
 196 ; These are in addition (or instead of) the actual ifields.
 197 ; This is also used to compute definitions of local vars needed in the
 198 ; !with-scache case.
 199 ; The result is ("var-name" "C-type" approx-bitsize) or #f if unneeded.
 200
 201 (define (sfmt-op-sbuf-elm op sfmt)
 202   (send (op:type op) 'sbuf-elm op sfmt)
 203 )
 204
 205 ; Subroutine of compute-sformat-bufs! to compute list of structure elements
 206 ; needed by <sformat> SFMT.
 207 ; The result is
 208 ; (SFMT ("var-name1" "C-type1" size1) ("var-name2" "C-type2" size2) ...)
 209 ; and is sorted by decreasing size, then C type, then variable name
 210 ; (as <sformat-argbuf> wants it).
 211
 212 (define (/sfmt-contents sfmt)
 213   (let ((needed-iflds (sfmt-needed-iflds sfmt))
 214         (extracted-ops (sfmt-extracted-operands sfmt))
 215         (in-ops (sfmt-in-ops sfmt))
 216         (out-ops (sfmt-out-ops sfmt))
 217         (sort-elms (lambda (a b)
 218                      ; Sort by descending size, then ascending C type name,
 219                      ; then ascending name.
 220                      (cond ((> (caddr a) (caddr b))
 221                             #t)
 222                            ((= (caddr a) (caddr b))
 223                             (cond ((string<? (cadr a) (cadr b))
 224                                    #t)
 225                                   ((string=? (cadr a) (cadr b))
 226                                    (string<? (car a) (car b)))
 227                                   (else
 228                                    #f)))
 229                            (else
 230                             #f))))
 231         )
 232     (logit 4
 233            "/sfmt-contents sfmt=" (obj:name sfmt)
 234            " needed-iflds=" (obj-csv-names needed-iflds)
 235            " extracted-ops=" (obj-csv-names extracted-ops)
 236            " in-ops=" (obj-csv-names in-ops)
 237            " out-ops=" (obj-csv-names out-ops)
 238            "\n")
 239     (cons sfmt
 240           (sort
 241            ; Compute list of all things we need to record at extraction time.
 242            (find (lambda (x)
 243                    ; Discard #f entries, they indicate "unneeded".
 244                    x)
 245                  (append
 246                   (map (lambda (f)
 247                          (/sfmt-ifld-elm f sfmt))
 248                        needed-iflds)
 249                   (map (lambda (op)
 250                          (sfmt-op-sbuf-elm op sfmt))
 251                        extracted-ops)
 252                   (cond ((with-any-profile?)
 253                          (append
 254                           ; Profiling support.  ??? This stuff is in flux.
 255                           (map (lambda (op)
 256                                  (sfmt-op-profile-elm op sfmt #f))
 257                                (find op-profilable? in-ops))
 258                           (map (lambda (op)
 259                                  (sfmt-op-profile-elm op sfmt #t))
 260                                (find op-profilable? out-ops))))
 261                         (else
 262                          (append)))))
 263            sort-elms)))
 264 )
 265
 266 ; Return #t if ELM-LIST is a subset of SBUF.
 267 ; SBUF is an <sformat-argbuf> object.
 268
 269 (define (/sbuf-subset? elm-list sbuf)
 270   ; We take advantage of the fact that elements in each are already sorted.
 271   ; FIXME: Can speed up.
 272   (let loop ((elm-list elm-list) (sbuf-elm-list (sbuf-elms sbuf)))
 273     (cond ((null? elm-list)
 274            #t)
 275           ((null? sbuf-elm-list)
 276            #f)
 277           ((equal? (car elm-list) (car sbuf-elm-list))
 278            (loop (cdr elm-list) (cdr sbuf-elm-list)))
 279           (else
 280            (loop elm-list (cdr sbuf-elm-list)))))
 281 )
 282
 283 ; Subroutine of compute-sformat-bufs!.
 284 ; Lookup ELM-LIST in SBUF-LIST.  A match is found if ELM-LIST
 285 ; is a subset of one in SBUF-LIST.
 286 ; Return the containing <sformat-argbuf> object if found, otherwise return #f.
 287 ; SBUF-LIST is a list of <sformat-argbuf> objects.
 288 ; ELM-LIST is (elm1 elm2 ...).
 289
 290 (define (/sbuf-lookup elm-list sbuf-list)
 291   (let loop ((sbuf-list sbuf-list))
 292     (cond ((null? sbuf-list)
 293            #f)
 294           ((/sbuf-subset? elm-list (car sbuf-list))
 295            (car sbuf-list))
 296           (else
 297            (loop (cdr sbuf-list)))))
 298 )
 299
 300 ; Compute and record the set of <sformat-argbuf> objects needed for SFMT-LIST,
 301 ; a list of all sformats.
 302 ; The result is the computed list of <sformat-argbuf> objects.
 303 ;
 304 ; This is used to further reduce the number of entries in the argument buffer's
 305 ; `fields' union.  Some sformats have structs with the same contents or one is
 306 ; a subset of another's, thus there is no need to distinguish them as far as
 307 ; the struct is concerned (there may be other reasons to distinguish them of
 308 ; course).
 309 ; The consequence of this is fewer semantic fragments created in with-sem-frags
 310 ; pbb engines.
 311
 312 (define (compute-sformat-argbufs! sfmt-list)
 313   (logit 1 "Computing sformat argument buffers ...\n")
 314
 315   (let ((sfmt-contents
 316          ; Sort by descending length.  This helps building the result: while
 317          ; iterating over each element, its sbuf is either a subset of a
 318          ; previous entry or requires a new entry.
 319          (sort (map /sfmt-contents sfmt-list)
 320                (lambda (a b)
 321                  (> (length a) (length b)))))
 322         ; Build an <sformat-argbuf> object.
 323         (build-sbuf (lambda (sfmt-data)
 324                       (make <sformat-argbuf>
 325                         (obj:name (car sfmt-data))
 326                         ""
 327                         atlist-empty
 328                         (cdr sfmt-data))))
 329         )
 330     ; Start off with the first sfmt.
 331     ; Also build an empty sbuf.  Which sbuf to use for an empty argument list
 332     ; is rather arbitrary.  Rather than pick one, keep the empty sbuf unto
 333     ; itself.
 334     (let ((nub-sbufs (list (build-sbuf (car sfmt-contents))))
 335           (empty-sbuf (make <sformat-argbuf>
 336                         'fmt-empty "no operands" atlist-empty
 337                         nil))
 338           )
 339       (sfmt-set-sbuf! (caar sfmt-contents) (car nub-sbufs))
 340
 341       ; Now loop over the remaining sfmts.
 342       (let loop ((sfmt-contents (cdr sfmt-contents)))
 343         (if (not (null? sfmt-contents))
 344             (let ((sfmt-data (car sfmt-contents)))
 345               (if (null? (cdr sfmt-data))
 346                   (sfmt-set-sbuf! (car sfmt-data) empty-sbuf)
 347                   (let ((sbuf (/sbuf-lookup (cdr sfmt-data) nub-sbufs)))
 348                     (if (not sbuf)
 349                         (begin
 350                           (set! sbuf (build-sbuf sfmt-data))
 351                           (set! nub-sbufs (cons sbuf nub-sbufs))))
 352                     (sfmt-set-sbuf! (car sfmt-data) sbuf)))
 353               (loop (cdr sfmt-contents)))))
 354
 355       ; Done.
 356       ; Note that the result will be sorted by ascending number of elements
 357       ; (because the search list was sorted by descending length and the result
 358       ; is built up in reverse order of that).
 359       ; Not that it matters, but that's kinda nice.
 360       (cons empty-sbuf nub-sbufs)))
 361 )
 362 \f
 363 ; Profiling support.
 364
 365 ; By default hardware elements are not profilable.
 366
 367 (method-make! <hardware-base> 'profilable? (lambda (self) #f))
 368
 369 (method-make!
 370  <hw-register> 'profilable?
 371  (lambda (self) (has-attr? self 'PROFILE))
 372 )
 373
 374 ; Return boolean indicating if HW is profilable.
 375
 376 (define (hw-profilable? hw) (send hw 'profilable?))
 377
 378 ; Return a boolean indicating if OP is profilable.
 379
 380 (define (op-profilable? op)
 381   (hw-profilable? (op:type op))
 382 )
 383
 384 ; sbuf-profile-data method.
 385 ; Return a list of C type and size to use in an sformat's argument buffer.
 386
 387 (method-make!
 388  <hardware-base> 'sbuf-profile-data
 389  (lambda (self)
 390    (error "sbuf-profile-elm not supported for this hw type"))
 391 )
 392
 393 (method-make!
 394  <hw-register> 'sbuf-profile-data
 395  (lambda (self)
 396    ; Don't unnecessarily bloat size of argument buffer.
 397    (if (<= (hw-num-elms self) 255)
 398        (list "unsigned char" 8)
 399        (list "unsigned short" 16)))
 400 )
 401
 402 ; Utility to return name of variable/structure-member to use to record
 403 ; profiling data for SYM.
 404
 405 (define (gen-profile-sym sym out?)
 406   (string-append (if out? "out_" "in_")
 407                  (if (symbol? sym) (symbol->string sym) sym))
 408 )
 409
 410 ; Return name of variable/structure-member to use to record data needed for
 411 ; profiling operand SELF.
 412
 413 (method-make!
 414  <operand> 'sbuf-profile-sym
 415  (lambda (self out?)
 416    (gen-profile-sym (gen-sym self) out?))
 417 )
 418
 419 ; sbuf-profile-elm method.
 420 ; Return the ARGBUF member needed for profiling SELF in <sformat> SFMT.
 421 ; The result is (var-name "C-type" approx-bitsize) or #f if unneeded.
 422
 423 (method-make!
 424  <operand> 'sbuf-profile-elm
 425  (lambda (self sfmt out?)
 426    (if (hw-scalar? (op:type self))
 427        #f
 428        (cons (send self 'sbuf-profile-sym out?)
 429              (send (op:type self) 'sbuf-profile-data))))
 430 )
 431
 432 ; Subroutine of /sfmt-contents to return an operand's profile element.
 433 ; The result is (var-name "C-type" approx-bitsize) or #f if unneeded.
 434
 435 (define (sfmt-op-profile-elm op sfmt out?)
 436   (send op 'sbuf-profile-elm sfmt out?)
 437 )
 438 \f
 439 ; ARGBUF accessor support.
 440
 441 ; Define and undefine C macros to tuck away details of instruction format used
 442 ; in the extraction and semantic code.  Instruction format names can
 443 ; change frequently and this can result in unnecessarily large diffs from one
 444 ; generated version of the file to the next.  Secondly, tucking away details of
 445 ; the extracted argument structure from the extraction code is a good thing.
 446
 447 ; Name of macro to access fields in ARGBUF.
 448 (define c-argbuf-macro "FLD")
 449
 450 ; NB: If sfmt is #f, then define the macro to pass through the argument
 451 ; symbol.  This is appropriate for "simple" (non-scache) simulators
 452 ; that have no abuf/scache in the sem.c routines, but rather plain
 453 ; local variables.
 454 (define (gen-define-argbuf-macro sfmt)
 455   (string-append "#define " c-argbuf-macro "(f) "
 456                  (if sfmt
 457                      (string-append
 458                       "abuf->fields."
 459                       (gen-sym (sfmt-sbuf sfmt))
 460                       ".f\n")
 461                      "f\n"))
 462 )
 463
 464 (define (gen-undef-argbuf-macro sfmt)
 465   (string-append "#undef " c-argbuf-macro "\n")
 466 )
 467
 468 ; For old code.  Delete in time.
 469 (define gen-define-field-macro gen-define-argbuf-macro)
 470 (define gen-undef-field-macro gen-undef-argbuf-macro)
 471
 472 ; Return a C reference to an ARGBUF field value.
 473
 474 (define (gen-argbuf-ref name)
 475   (string-append c-argbuf-macro " (" name ")")
 476 )
 477
 478 ; Return name of ARGBUF member for extracted <field> F.
 479
 480 (define (gen-ifld-argbuf-name f)
 481   (gen-sym f)
 482 )
 483
 484 ; Return the C reference to a cached ifield.
 485
 486 (define (gen-ifld-argbuf-ref f)
 487   (gen-argbuf-ref (gen-ifld-argbuf-name f))
 488 )
 489
 490 ; Return name of ARGBUF member holding processed from of extracted
 491 ; ifield value for <hw-index> index.
 492
 493 (define (gen-hw-index-argbuf-name index)
 494   (gen-sym index)
 495 )
 496
 497 ; Return C reference to a processed <hw-index> in ARGBUF.
 498
 499 (define (gen-hw-index-argbuf-ref index)
 500   (gen-argbuf-ref (gen-hw-index-argbuf-name index))
 501 )
 502 \f
 503 ; Decode support.
 504
 505 ; Main procedure call tree:
 506 ; cgen-decode.{c,cxx}
 507 ;     /gen-decode-fn
 508 ;         gen-decoder [our entry point]
 509 ;             decode-build-table
 510 ;             /gen-decoder-switch
 511 ;                 /gen-decoder-switch
 512 ;
 513 ; decode-build-table is called to construct a tree of "table-guts" elements
 514 ; (??? Need better name obviously),
 515 ; and then gen-decoder is recursively called on each of these elements.
 516
 517 ; Return C/C++ code that fetches the desired decode bits from C value VAL.
 518 ; SIZE is the size in bits of val (the MSB is 1 << (size - 1)) which we
 519 ; treat as bitnum 0.
 520 ; BITNUMS must be monotonically increasing.
 521 ; LSB0? is non-#f if bit number 0 is the least significant bit.
 522 ; FIXME: START may not be handled right in words beyond first.
 523 ;
 524 ; ENTIRE-VAL is passed as a hack for cgen 1.1 which would previously generate
 525 ; negative shifts.  FIXME: Revisit for 1.2.
 526 ;
 527 ; e.g. (/gen-decode-bits '(0 1 2 3 8 9 10 11) 0 16 "insn" #f)
 528 ; --> "(((insn >> 8) & 0xf0) | ((insn >> 4) & 0xf))"
 529 ; FIXME: The generated code has some inefficiencies in edge cases.  Later.
 530
 531 (define (/gen-decode-bits bitnums start size val entire-val lsb0?)
 532
 533   ; Compute a list of lists of three numbers:
 534   ; (first bitnum in group, position in result (0=LSB), bits in result)
 535
 536   (let ((groups
 537          ; POS = starting bit position of current group.
 538          ; COUNT = number of bits in group.
 539          ; Work from least to most significant bit so reverse bitnums.
 540          (let loop ((result nil) (pos 0) (count 0) (bitnums (reverse bitnums)))
 541            ;(display (list result pos count bitnums)) (newline)
 542            (if (null? bitnums)
 543                result
 544                (if (or (= (length bitnums) 1)
 545                        ; Are numbers not next to each other?
 546                        (not (= (- (car bitnums) (if lsb0? -1 1))
 547                                (cadr bitnums))))
 548                    (loop (cons (list (car bitnums) pos (+ 1 count))
 549                                result)
 550                          (+ pos count 1) 0
 551                          (cdr bitnums))
 552                    (loop result
 553                          pos (+ 1 count)
 554                          (cdr bitnums)))))))
 555     (string-append
 556      ; While we could just always emit "(0" to handle the case of an empty set,
 557      ; keeping the code more readable for the normal case is important.
 558      (if (< (length groups) 1)
 559          "(0"
 560          "(")
 561      (string-drop 3
 562                   (string-map
 563                    (lambda (group)
 564                      (let* ((first (car group))
 565                             (pos (cadr group))
 566                             (bits (caddr group))
 567                             ; Difference between where value is and where
 568                             ; it needs to be.
 569                             (shift (- (if lsb0?
 570                                           (- first bits -1)
 571                                           (- (+ start size) (+ first bits)))
 572                                       pos)))
 573                        ; FIXME: There should never be a -ve shift here,
 574                        ; but it can occur on the m32r.  Compensate here
 575                        ; with hack and fix in 1.2.
 576                        (if (< shift 0)
 577                            (begin
 578                              (set! val entire-val)
 579                              (set! shift (+ shift size))))
 580                        ; END-FIXME
 581                        (string-append
 582                         " | ((" val " >> " (number->string shift)
 583                         ") & ("
 584                         (number->string (- (integer-expt 2 bits) 1))
 585                         " << " (number->string pos) "))")))
 586                    groups))
 587      ")"))
 588 )
 589
 590 ; Convert decoder table into C code.
 591
 592 ; Return code for the default entry of each switch table
 593 ;
 594 (define (/gen-decode-default-entry indent invalid-insn fn?)
 595   (string-append
 596    "itype = "
 597    (gen-cpu-insn-enum (current-cpu) invalid-insn)
 598    ";"
 599    (if (with-scache?)
 600        (if fn?
 601            " @prefix@_extract_sfmt_empty (this, current_cpu, pc, base_insn, entire_insn); goto done;\n"
 602            " goto extract_sfmt_empty;\n")
 603        " goto done;\n")
 604   )
 605 )
 606
 607 ; Return code for one insn entry.
 608 ; REST is the remaining entries.
 609
 610 (define (/gen-decode-insn-entry entry rest indent invalid-insn fn?)
 611   (assert (eq? 'insn (dtable-entry-type entry)))
 612   (logit 3 "Generating decode insn entry for " (obj:name (dtable-entry-value entry)) " ...\n")
 613
 614   (let* ((insn (dtable-entry-value entry))
 615          (fmt-name (gen-sym (insn-sfmt insn))))
 616
 617     (cond
 618
 619      ; Leave invalids to the default case.
 620      ((eq? (obj:name insn) 'x-invalid)
 621       "")
 622
 623      ; If same contents as next case, fall through.
 624      ; FIXME: Can reduce more by sorting cases.  Much later.
 625      ((and (not (null? rest))
 626            ; Ensure both insns.
 627            (eq? 'insn (dtable-entry-type (car rest)))
 628            ; Ensure same insn.
 629            (eq? (obj:name insn)
 630                 (obj:name (dtable-entry-value (car rest)))))
 631       (string-append indent "  case "
 632                      (number->string (dtable-entry-index entry))
 633                      " : /* fall through */\n"))
 634
 635      (else
 636       (string-append indent "  case "
 637                      (number->string (dtable-entry-index entry)) " :\n"
 638                      ; Compensate for base-insn-size > current-insn-size by adjusting entire_insn.
 639                      ; Activate this logic only for sid simulators; they are consistent in
 640                      ; interpreting base-insn-bitsize this way.
 641                      (if (and (equal? APPLICATION 'SID-SIMULATOR)
 642                               (> (state-base-insn-bitsize) (insn-length insn)))
 643                          (string-append
 644                           indent "    entire_insn = entire_insn >> "
 645                           (number->string (- (state-base-insn-bitsize) (insn-length insn)))
 646                           ";\n")
 647                          "")
 648                      ; Generate code to check that all of the opcode bits for this insn match
 649                      indent "    if (("
 650                      (if (adata-integral-insn? CURRENT-ARCH) "entire_insn" "base_insn")
 651                      " & 0x" (number->hex (insn-base-mask insn)) ") == 0x" (number->hex (insn-value insn)) ")\n"
 652                      indent "      { itype = " (gen-cpu-insn-enum (current-cpu) insn) ";"
 653                      (if (with-scache?)
 654                          (if fn?
 655                              (string-append " @prefix@_extract_" fmt-name " (this, current_cpu, pc, base_insn, entire_insn); goto done;")
 656                              (string-append " goto extract_" fmt-name ";"))
 657                          " goto done;")
 658                      " }\n"
 659                      indent "    " (/gen-decode-default-entry indent invalid-insn fn?)))))
 660 )
 661
 662 ; Subroutine of /decode-expr-ifield-tracking.
 663 ; Return a list of all possible values for ifield IFLD-NAME.
 664 ; FIXME: Quick-n-dirty implementation.  Should use bit arrays.
 665
 666 (define (/decode-expr-ifield-values ifld-name)
 667   (let* ((ifld (current-ifld-lookup ifld-name))
 668          (bits (ifld-length ifld)))
 669     (if (mode-unsigned? (ifld-mode ifld))
 670         (iota (logsll 1 bits))
 671         (iota (logsll 1 bits) (- (logsll 1 (- bits 1))))))
 672 )
 673
 674 ; Subroutine of /decode-expr-ifield-tracking,/decode-expr-ifield-mark-used.
 675 ; Create the search key for tracking table lookup.
 676
 677 (define (/decode-expr-ifield-tracking-key insn ifld-name)
 678   (symbol-append (obj:name (insn-ifmt insn)) '-x- ifld-name)
 679 )
 680
 681 ; Subroutine of /gen-decode-expr-entry.
 682 ; Return a table to track used ifield values.
 683 ; The table is an associative list of (key . value-list).
 684 ; KEY is "iformat-name-x-ifield-name".
 685 ; VALUE-LIST is a list of the unused values.
 686
 687 (define (/decode-expr-ifield-tracking expr-list)
 688   (let ((table1
 689          (apply append
 690                 (map (lambda (entry)
 691                        (map (lambda (ifld-name)
 692                               (cons (exprtable-entry-insn entry)
 693                                     (cons ifld-name
 694                                           (/decode-expr-ifield-values ifld-name))))
 695                             (exprtable-entry-iflds entry)))
 696                      expr-list))))
 697     ; TABLE1 is a list of (insn ifld-name value1 value2 ...).
 698     (nub (map (lambda (elm)
 699                 (cons
 700                  (/decode-expr-ifield-tracking-key (car elm) (cadr elm))
 701                  (cddr elm)))
 702               table1)
 703          car))
 704 )
 705
 706 ; Subroutine of /decode-expr-ifield-mark-used!.
 707 ; Return list of values completely used for ifield IFLD-NAME in EXPR.
 708 ; "completely used" here means the value won't appear elsewhere.
 709 ; e.g. in (andif (eq f-rd 15) (eq f-rx 14)) we don't know what happens
 710 ; for the (ne f-rx 14) case.
 711
 712 (define (/decode-expr-ifield-values-used ifld-name expr)
 713   (case (rtx-name expr)
 714     ((eq)
 715      (if (and (rtx-kind? 'ifield (rtx-cmp-op-arg expr 0))
 716               (rtx-constant? (rtx-cmp-op-arg expr 1)))
 717          (list (rtx-constant-value (rtx-cmp-op-arg expr 1)))
 718          nil))
 719     ((member)
 720      (if (rtx-kind? 'ifield (rtx-member-value expr))
 721          (rtx-member-set expr)
 722          nil))
 723     ; FIXME: more needed
 724     (else nil))
 725 )
 726
 727 ; Subroutine of /gen-decode-expr-entry.
 728 ; Mark ifield values used by EXPR-ENTRY in TRACKING-TABLE.
 729
 730 (define (/decode-expr-ifield-mark-used! tracking-table expr-entry)
 731   (let ((insn (exprtable-entry-insn expr-entry))
 732         (expr (exprtable-entry-expr expr-entry))
 733         (ifld-names (exprtable-entry-iflds expr-entry)))
 734     (for-each (lambda (ifld-name)
 735                 (let ((table-entry
 736                        (assq (/decode-expr-ifield-tracking-key insn ifld-name)
 737                              tracking-table))
 738                       (used (/decode-expr-ifield-values-used ifld-name expr)))
 739                   (for-each (lambda (value)
 740                               (delq! value table-entry))
 741                             used)
 742                   ))
 743               ifld-names))
 744   *UNSPECIFIED*
 745 )
 746
 747 ; Subroutine of /gen-decode-expr-entry.
 748 ; Return code to set `itype' and branch to the extraction phase.
 749
 750 (define (/gen-decode-expr-set-itype indent insn-enum fmt-name fn?)
 751   (string-append
 752    indent
 753    "{ itype = "
 754    insn-enum
 755    "; "
 756    (if (with-scache?)
 757        (if fn?
 758            (string-append "@prefix@_extract_" fmt-name " (this, current_cpu, pc, base_insn, entire_insn);  goto done;")
 759            (string-append "goto extract_" fmt-name ";"))
 760        "goto done;")
 761    " }\n"
 762    )
 763 )
 764
 765 ; Generate code to decode the expression table in ENTRY.
 766 ; INVALID-INSN is the <insn> object of the pseudo insn to handle invalid ones.
 767
 768 (define (/gen-decode-expr-entry entry indent invalid-insn fn?)
 769   (assert (eq? 'expr (dtable-entry-type entry)))
 770   (logit 3 "Generating decode expr entry for " (exprtable-name (dtable-entry-value entry)) " ...\n")
 771
 772   (let ((expr-list (exprtable-insns (dtable-entry-value entry))))
 773     (string-list
 774      indent "  case "
 775      (number->string (dtable-entry-index entry))
 776      " :\n"
 777
 778      (let ((iflds-tracking (/decode-expr-ifield-tracking expr-list))
 779            (indent (string-append indent "    ")))
 780
 781        (let loop ((expr-list expr-list) (code nil))
 782
 783          (if (null? expr-list)
 784
 785              ; All done.  If we used up all field values we don't need to
 786              ; "fall through" and select the invalid insn marker.
 787
 788              (if (all-true? (map null? (map cdr iflds-tracking)))
 789                  code
 790                  (append! code
 791                           (list
 792                            (/gen-decode-expr-set-itype
 793                             indent
 794                             (gen-cpu-insn-enum (current-cpu) invalid-insn)
 795                             "sfmt_empty"
 796                             fn?))))
 797
 798              ; Not all done, process next expr.
 799
 800              (let ((insn (exprtable-entry-insn (car expr-list)))
 801                    (expr (exprtable-entry-expr (car expr-list)))
 802                    (ifld-names (exprtable-entry-iflds (car expr-list))))
 803
 804                ; Mark of those ifield values we use first.
 805                ; If there are none left afterwards, we can unconditionally
 806                ; choose this insn.
 807                (/decode-expr-ifield-mark-used! iflds-tracking (car expr-list))
 808
 809                (let ((next-code
 810                       ; If this is the last expression, and it uses up all
 811                       ; remaining ifield values, there's no need to perform any
 812                       ; test.
 813                       (if (and (null? (cdr expr-list))
 814                                (all-true? (map null? (map cdr iflds-tracking))))
 815
 816                           ; Need this in a list for a later append!.
 817                           (string-list
 818                            (/gen-decode-expr-set-itype
 819                             indent
 820                             (gen-cpu-insn-enum (current-cpu) insn)
 821                             (gen-sym (insn-sfmt insn))
 822                             fn?))
 823
 824                           ; We don't use up all ifield values, so emit a test.
 825                            (let ((iflds (map current-ifld-lookup ifld-names)))
 826                              (string-list
 827                               indent "{\n"
 828                               (gen-define-ifields iflds
 829                                                   (insn-length insn)
 830                                                   (string-append indent "  ")
 831                                                   #f)
 832                               (gen-extract-ifields iflds
 833                                                    (insn-length insn)
 834                                                    (string-append indent "  ")
 835                                                    #f)
 836                               indent "  if ("
 837                               (rtl-c 'BI expr nil #:ifield-var? #t)
 838                               ")\n"
 839                               (/gen-decode-expr-set-itype
 840                                (string-append indent "    ")
 841                                (gen-cpu-insn-enum (current-cpu) insn)
 842                                (gen-sym (insn-sfmt insn))
 843                                fn?)
 844                               indent "}\n")))))
 845
 846                  (loop (cdr expr-list)
 847                        (append! code next-code)))))))
 848      ))
 849 )
 850
 851 ; Generate code to decode TABLE.
 852 ; REST is the remaining entries.
 853 ; SWITCH-NUM, STARTBIT, DECODE-BITSIZE, INDENT, LSB0?, INVALID-INSN are same
 854 ; as for /gen-decoder-switch.
 855
 856 (define (/gen-decode-table-entry table rest switch-num startbit decode-bitsize indent lsb0? invalid-insn fn?)
 857   (assert (eq? 'table (dtable-entry-type table)))
 858   (logit 3 "Generating decode table entry for case " (dtable-entry-index table) " ...\n")
 859
 860   (string-list
 861    indent "  case "
 862    (number->string (dtable-entry-index table))
 863    " :"
 864    ; If table is same as next, just emit a "fall through" to cut down on
 865    ; generated code.
 866    (if (and (not (null? rest))
 867             ; Ensure both tables.
 868             (eq? 'table (dtable-entry-type (car rest)))
 869             ; Ensure same table.
 870             (eqv? (subdtable-key (dtable-entry-value table))
 871                   (subdtable-key (dtable-entry-value (car rest)))))
 872        " /* fall through */\n"
 873        (string-list
 874         "\n"
 875         (/gen-decoder-switch switch-num
 876                              startbit
 877                              decode-bitsize
 878                              (subdtable-table (dtable-entry-value table))
 879                              (string-append indent "    ")
 880                              lsb0?
 881                              invalid-insn
 882                              fn?))))
 883 )
 884
 885 ; Subroutine of /decode-sort-entries.
 886 ; Return a boolean indicating if A,B are equivalent entries.
 887
 888 (define (/decode-equiv-entries? a b)
 889   (let ((a-type (dtable-entry-type a))
 890         (b-type (dtable-entry-type b)))
 891     (if (eq? a-type b-type)
 892         (case a-type
 893           ((insn)
 894            (let ((a-name (obj:name (dtable-entry-value a)))
 895                  (b-name (obj:name (dtable-entry-value b))))
 896             (eq? a-name b-name)))
 897           ((expr)
 898            ; Ignore expr entries for now.
 899            #f)
 900           ((table)
 901            (let ((a-name (subdtable-key (dtable-entry-value a)))
 902                  (b-name (subdtable-key (dtable-entry-value b))))
 903              (eq? a-name b-name))))
 904         ; A and B are not the same type.
 905         #f))
 906 )
 907
 908 ; Subroutine of /gen-decoder-switch, sort ENTRIES according to desired
 909 ; print order (maximizes amount of fall-throughs, but maintains numerical
 910 ; order as much as possible).
 911 ; ??? This is an O(n^2) algorithm.  An O(n Log(n)) algorithm can be done
 912 ; but it seemed more complicated than necessary for now.
 913
 914 (define (/decode-sort-entries entries)
 915   (let ((find-equiv!
 916          ; Return list of entries in non-empty list L that have the same decode
 917          ; entry as the first entry.  Entries found are marked with #f so
 918          ; they're not processed again.
 919          (lambda (l)
 920            ; Start off the result with the first entry, then see if the
 921            ; remaining ones match it.
 922            (let ((first (car l)))
 923              (let loop ((l (cdr l)) (result (cons first nil)))
 924                (if (null? l)
 925                    (reverse! result)
 926                    (if (and (car l) (/decode-equiv-entries? first (car l)))
 927                        (let ((lval (car l)))
 928                          (set-car! l #f)
 929                          (loop (cdr l) (cons lval result)))
 930                        (loop (cdr l) result)))))))
 931         )
 932     (let loop ((entries (list-copy entries)) (result nil))
 933       (if (null? entries)
 934           (apply append (reverse! result))
 935           (if (car entries)
 936               (loop (cdr entries)
 937                     (cons (find-equiv! entries)
 938                           result))
 939               (loop (cdr entries) result)))))
 940 )
 941
 942 ; Generate switch statement to decode TABLE-GUTS.
 943 ; SWITCH-NUM is for compatibility with the computed goto decoder and
 944 ; isn't used.
 945 ; STARTBIT is the bit offset of the instruction value that C variable `insn'
 946 ; holds (note that this is independent of LSB0?).
 947 ; DECODE-BITSIZE is the number of bits of the insn that `insn' holds.
 948 ; LSB0? is non-#f if bit number 0 is the least significant bit.
 949 ; INVALID-INSN is the <insn> object of the pseudo insn to handle invalid ones.
 950
 951 ; FIXME: for the few-alternative case (say, 2), generating
 952 ; if (0) {}
 953 ; else if (val == 0) { ... }
 954 ; else if (val == 1) { ... }
 955 ; else {}
 956 ; may well be less stressful on the compiler to optimize than small switch() stmts.
 957
 958 (define (/gen-decoder-switch switch-num startbit decode-bitsize table-guts
 959                              indent lsb0? invalid-insn fn?)
 960   ; For entries that are a single insn, we're done, otherwise recurse.
 961
 962   (string-list
 963    indent "{\n"
 964    ; Are we at the next word?
 965    (if (not (= startbit (dtable-guts-startbit table-guts)))
 966        (begin
 967          (set! startbit (dtable-guts-startbit table-guts))
 968          (set! decode-bitsize (dtable-guts-bitsize table-guts))
 969          ; FIXME: Bits may get fetched again during extraction.
 970          (string-append indent "  unsigned int val;\n"
 971                         indent "  /* Must fetch more bits.  */\n"
 972                         indent "  insn = "
 973                         (gen-ifetch "pc" startbit decode-bitsize)
 974                         ";\n"
 975                         indent "  val = "))
 976        (string-append indent "  unsigned int val = "))
 977    (/gen-decode-bits (dtable-guts-bitnums table-guts)
 978                      (dtable-guts-startbit table-guts)
 979                      (dtable-guts-bitsize table-guts)
 980                      "insn" "entire_insn" lsb0?)
 981    ";\n"
 982    indent "  switch (val)\n"
 983    indent "  {\n"
 984
 985    ; The code is more readable, and icache use is improved, if we collapse
 986    ; common code into one case and use "fall throughs" for all but the last of
 987    ; a set of common cases.
 988    ; FIXME: We currently rely on /gen-decode-foo-entry to recognize the fall
 989    ; through.  We should take care of it ourselves.
 990
 991    (let loop ((entries (/decode-sort-entries (dtable-guts-entries table-guts)))
 992               (result nil))
 993      (if (null? entries)
 994          (reverse! result)
 995          (loop
 996           (cdr entries)
 997           (cons (case (dtable-entry-type (car entries))
 998                   ((insn)
 999                    (/gen-decode-insn-entry (car entries) (cdr entries) indent invalid-insn fn?))
1000                   ((expr)
1001                    (/gen-decode-expr-entry (car entries) indent invalid-insn fn?))
1002                   ((table)
1003                    (/gen-decode-table-entry (car entries) (cdr entries)
1004                                             switch-num startbit decode-bitsize
1005                                             indent lsb0? invalid-insn fn?))
1006                   )
1007                 result))))
1008
1009    ; ??? Can delete if all cases are present.
1010    indent "  default : "
1011    (/gen-decode-default-entry indent invalid-insn fn?)
1012    indent "  }\n"
1013    indent "}\n"
1014    )
1015 )
1016
1017 ; Decoder generation entry point.
1018 ; Generate code to decode INSN-LIST.
1019 ; BITNUMS is the set of bits to initially key off of.
1020 ; DECODE-BITSIZE is the number of bits of the instruction that `insn' holds.
1021 ; LSB0? is non-#f if bit number 0 is the least significant bit.
1022 ; INVALID-INSN is the <insn> object of the pseudo insn to handle invalid ones.
1023 ; FN? is non-#f if the extractors are functions rather than inline code
1024
1025 (define (gen-decoder insn-list bitnums decode-bitsize indent lsb0? invalid-insn fn?)
1026   (logit 3 "Building decode tree.\n"
1027          "bitnums = " (stringize bitnums " ") "\n"
1028          "decode-bitsize = " (number->string decode-bitsize) "\n"
1029          "lsb0? = " (if lsb0? "#t" "#f") "\n"
1030          "fn? = " (if fn? "#t" "#f") "\n"
1031          )
1032
1033   ; First build a table that decodes the instruction set.
1034
1035   (let ((table-guts (decode-build-table insn-list bitnums
1036                                         decode-bitsize lsb0?
1037                                         invalid-insn)))
1038
1039     ; Now print it out.
1040
1041     (/gen-decoder-switch "0" 0 decode-bitsize table-guts indent lsb0?
1042                          invalid-insn fn?)
1043     )
1044 )