cgen/utils-sim.scm

   1 ; Generic simulator application utilities.
   2 ; Copyright (C) 2000, 2005 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=" (string-map obj:str-name needed-iflds)
 235            " extracted-ops=" (string-map obj:str-name extracted-ops)
 236            " in-ops=" (string-map obj:str-name in-ops)
 237            " out-ops=" (string-map obj:str-name 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 ; e.g. (-gen-decode-bits '(0 1 2 3 8 9 10 11) 0 16 "insn" #f)
 525 ; --> "(((insn >> 8) & 0xf0) | ((insn >> 4) & 0xf))"
 526 ; FIXME: The generated code has some inefficiencies in edge cases.  Later.
 527
 528 (define (-gen-decode-bits bitnums start size val lsb0?)
 529
 530   ; Compute a list of lists of three numbers:
 531   ; (first bitnum in group, position in result (0=LSB), bits in result)
 532
 533   (let ((groups
 534          ; POS = starting bit position of current group.
 535          ; COUNT = number of bits in group.
 536          ; Work from least to most significant bit so reverse bitnums.
 537          (let loop ((result nil) (pos 0) (count 0) (bitnums (reverse bitnums)))
 538            ;(display (list result pos count bitnums)) (newline)
 539            (if (null? bitnums)
 540                result
 541                (if (or (= (length bitnums) 1)
 542                        ; Are numbers not next to each other?
 543                        (not (= (- (car bitnums) (if lsb0? -1 1))
 544                                (cadr bitnums))))
 545                    (loop (cons (list (car bitnums) pos (+ 1 count))
 546                                result)
 547                          (+ pos count 1) 0
 548                          (cdr bitnums))
 549                    (loop result
 550                          pos (+ 1 count)
 551                          (cdr bitnums)))))))
 552     (string-append
 553      ; While we could just always emit "(0" to handle the case of an empty set,
 554      ; keeping the code more readable for the normal case is important.
 555      (if (< (length groups) 1)
 556          "(0"
 557          "(")
 558      (string-drop 3
 559                   (string-map
 560                    (lambda (group)
 561                      (let* ((first (car group))
 562                             (pos (cadr group))
 563                             (bits (caddr group))
 564                             ; Difference between where value is and where
 565                             ; it needs to be.
 566                             ; FIXME: Need to handle left (-ve) shift.
 567                             (shift (- (if lsb0?
 568                                           (- first bits -1)
 569                                           (- (+ start size) (+ first bits)))
 570                                       pos)))
 571                      (string-append
 572                       " | ((" val " >> " (number->string shift)
 573                       ") & ("
 574                       (number->string (- (integer-expt 2 bits) 1))
 575                       " << " (number->string pos) "))")))
 576                    groups))
 577      ")"))
 578 )
 579
 580 ; Convert decoder table into C code.
 581
 582 ; Return code for the default entry of each switch table
 583 ;
 584 (define (-gen-decode-default-entry indent invalid-insn fn?)
 585   (string-append
 586    "itype = "
 587    (gen-cpu-insn-enum (current-cpu) invalid-insn)
 588    ";"
 589    (if (with-scache?)
 590        (if fn?
 591            " @prefix@_extract_sfmt_empty (this, current_cpu, pc, base_insn, entire_insn); goto done;\n"
 592            " goto extract_sfmt_empty;\n")
 593        " goto done;\n")
 594   )
 595 )
 596
 597 ; Return code for one insn entry.
 598 ; REST is the remaining entries.
 599
 600 (define (-gen-decode-insn-entry entry rest indent invalid-insn fn?)
 601   (assert (eq? 'insn (dtable-entry-type entry)))
 602   (logit 3 "Generating decode insn entry for " (obj:name (dtable-entry-value entry)) " ...\n")
 603
 604   (let* ((insn (dtable-entry-value entry))
 605          (fmt-name (gen-sym (insn-sfmt insn))))
 606
 607     (cond
 608
 609      ; Leave invalids to the default case.
 610      ((eq? (obj:name insn) 'x-invalid)
 611       "")
 612
 613      ; If same contents as next case, fall through.
 614      ; FIXME: Can reduce more by sorting cases.  Much later.
 615      ((and (not (null? rest))
 616            ; Ensure both insns.
 617            (eq? 'insn (dtable-entry-type (car rest)))
 618            ; Ensure same insn.
 619            (eq? (obj:name insn)
 620                 (obj:name (dtable-entry-value (car rest)))))
 621       (string-append indent "  case "
 622                      (number->string (dtable-entry-index entry))
 623                      " : /* fall through */\n"))
 624
 625      (else
 626       (string-append indent "  case "
 627                      (number->string (dtable-entry-index entry)) " :\n"
 628                      ; Compensate for base-insn-size > current-insn-size by adjusting entire_insn.
 629                      ; Activate this logic only for sid simulators; they are consistent in
 630                      ; interpreting base-insn-bitsize this way.
 631                      (if (and (equal? APPLICATION 'SID-SIMULATOR)
 632                               (> (state-base-insn-bitsize) (insn-length insn)))
 633                          (string-append
 634                           indent "    entire_insn = base_insn >> "
 635                           (number->string (- (state-base-insn-bitsize) (insn-length insn)))
 636                           ";\n")
 637                          "")
 638                      ; Generate code to check that all of the opcode bits for this insn match
 639                      indent "    if ((entire_insn & 0x" (number->hex (insn-base-mask insn)) ") == 0x" (number->hex (insn-value insn)) ")\n"
 640                      indent "      { itype = " (gen-cpu-insn-enum (current-cpu) insn) ";"
 641                      (if (with-scache?)
 642                          (if fn?
 643                              (string-append " @prefix@_extract_" fmt-name " (this, current_cpu, pc, base_insn, entire_insn); goto done;")
 644                              (string-append " goto extract_" fmt-name ";"))
 645                          " goto done;")
 646                      " }\n"
 647                      indent "    " (-gen-decode-default-entry indent invalid-insn fn?)))))
 648 )
 649
 650 ; Subroutine of -decode-expr-ifield-tracking.
 651 ; Return a list of all possible values for ifield IFLD-NAME.
 652 ; FIXME: Quick-n-dirty implementation.  Should use bit arrays.
 653
 654 (define (-decode-expr-ifield-values ifld-name)
 655   (let* ((ifld (current-ifld-lookup ifld-name))
 656          (bits (ifld-length ifld)))
 657     (if (mode-unsigned? (ifld-mode ifld))
 658         (iota (logsll 1 bits))
 659         (iota (logsll 1 bits) (- (logsll 1 (- bits 1))))))
 660 )
 661
 662 ; Subroutine of -decode-expr-ifield-tracking,-decode-expr-ifield-mark-used.
 663 ; Create the search key for tracking table lookup.
 664
 665 (define (-decode-expr-ifield-tracking-key insn ifld-name)
 666   (symbol-append (obj:name (insn-ifmt insn)) '-x- ifld-name)
 667 )
 668
 669 ; Subroutine of -gen-decode-expr-entry.
 670 ; Return a table to track used ifield values.
 671 ; The table is an associative list of (key . value-list).
 672 ; KEY is "iformat-name-x-ifield-name".
 673 ; VALUE-LIST is a list of the unused values.
 674
 675 (define (-decode-expr-ifield-tracking expr-list)
 676   (let ((table1
 677          (apply append
 678                 (map (lambda (entry)
 679                        (map (lambda (ifld-name)
 680                               (cons (exprtable-entry-insn entry)
 681                                     (cons ifld-name
 682                                           (-decode-expr-ifield-values ifld-name))))
 683                             (exprtable-entry-iflds entry)))
 684                      expr-list))))
 685     ; TABLE1 is a list of (insn ifld-name value1 value2 ...).
 686     (nub (map (lambda (elm)
 687                 (cons
 688                  (-decode-expr-ifield-tracking-key (car elm) (cadr elm))
 689                  (cddr elm)))
 690               table1)
 691          car))
 692 )
 693
 694 ; Subroutine of -decode-expr-ifield-mark-used!.
 695 ; Return list of values completely used for ifield IFLD-NAME in EXPR.
 696 ; "completely used" here means the value won't appear elsewhere.
 697 ; e.g. in (andif (eq f-rd 15) (eq f-rx 14)) we don't know what happens
 698 ; for the (ne f-rx 14) case.
 699
 700 (define (-decode-expr-ifield-values-used ifld-name expr)
 701   (case (rtx-name expr)
 702     ((eq)
 703      (if (and (rtx-kind? 'ifield (rtx-cmp-op-arg expr 0))
 704               (rtx-constant? (rtx-cmp-op-arg expr 1)))
 705          (list (rtx-constant-value (rtx-cmp-op-arg expr 1)))
 706          nil))
 707     ((member)
 708      (if (rtx-kind? 'ifield (rtx-member-value expr))
 709          (rtx-member-set expr)
 710          nil))
 711     ; FIXME: more needed
 712     (else nil))
 713 )
 714
 715 ; Subroutine of -gen-decode-expr-entry.
 716 ; Mark ifield values used by EXPR-ENTRY in TRACKING-TABLE.
 717
 718 (define (-decode-expr-ifield-mark-used! tracking-table expr-entry)
 719   (let ((insn (exprtable-entry-insn expr-entry))
 720         (expr (exprtable-entry-expr expr-entry))
 721         (ifld-names (exprtable-entry-iflds expr-entry)))
 722     (for-each (lambda (ifld-name)
 723                 (let ((table-entry
 724                        (assq (-decode-expr-ifield-tracking-key insn ifld-name)
 725                              tracking-table))
 726                       (used (-decode-expr-ifield-values-used ifld-name expr)))
 727                   (for-each (lambda (value)
 728                               (delq! value table-entry))
 729                             used)
 730                   ))
 731               ifld-names))
 732   *UNSPECIFIED*
 733 )
 734
 735 ; Subroutine of -gen-decode-expr-entry.
 736 ; Return code to set `itype' and branch to the extraction phase.
 737
 738 (define (-gen-decode-expr-set-itype indent insn-enum fmt-name fn?)
 739   (string-append
 740    indent
 741    "{ itype = "
 742    insn-enum
 743    "; "
 744    (if (with-scache?)
 745        (if fn?
 746            (string-append "@prefix@_extract_" fmt-name " (this, current_cpu, pc, base_insn, entire_insn);  goto done;")
 747            (string-append "goto extract_" fmt-name ";"))
 748        "goto done;")
 749    " }\n"
 750    )
 751 )
 752
 753 ; Generate code to decode the expression table in ENTRY.
 754 ; INVALID-INSN is the <insn> object of the pseudo insn to handle invalid ones.
 755
 756 (define (-gen-decode-expr-entry entry indent invalid-insn fn?)
 757   (assert (eq? 'expr (dtable-entry-type entry)))
 758   (logit 3 "Generating decode expr entry for " (exprtable-name (dtable-entry-value entry)) " ...\n")
 759
 760   (let ((expr-list (exprtable-insns (dtable-entry-value entry))))
 761     (string-list
 762      indent "  case "
 763      (number->string (dtable-entry-index entry))
 764      " :\n"
 765
 766      (let ((iflds-tracking (-decode-expr-ifield-tracking expr-list))
 767            (indent (string-append indent "    ")))
 768
 769        (let loop ((expr-list expr-list) (code nil))
 770
 771          (if (null? expr-list)
 772
 773              ; All done.  If we used up all field values we don't need to
 774              ; "fall through" and select the invalid insn marker.
 775
 776              (if (all-true? (map null? (map cdr iflds-tracking)))
 777                  code
 778                  (append! code
 779                           (list
 780                            (-gen-decode-expr-set-itype
 781                             indent
 782                             (gen-cpu-insn-enum (current-cpu) invalid-insn)
 783                             "sfmt_empty"
 784                             fn?))))
 785
 786              ; Not all done, process next expr.
 787
 788              (let ((insn (exprtable-entry-insn (car expr-list)))
 789                    (expr (exprtable-entry-expr (car expr-list)))
 790                    (ifld-names (exprtable-entry-iflds (car expr-list))))
 791
 792                ; Mark of those ifield values we use first.
 793                ; If there are none left afterwards, we can unconditionally
 794                ; choose this insn.
 795                (-decode-expr-ifield-mark-used! iflds-tracking (car expr-list))
 796
 797                (let ((next-code
 798                       ; If this is the last expression, and it uses up all
 799                       ; remaining ifield values, there's no need to perform any
 800                       ; test.
 801                       (if (and (null? (cdr expr-list))
 802                                (all-true? (map null? (map cdr iflds-tracking))))
 803
 804                           ; Need this in a list for a later append!.
 805                           (string-list
 806                            (-gen-decode-expr-set-itype
 807                             indent
 808                             (gen-cpu-insn-enum (current-cpu) insn)
 809                             (gen-sym (insn-sfmt insn))
 810                             fn?))
 811
 812                           ; We don't use up all ifield values, so emit a test.
 813                            (let ((iflds (map current-ifld-lookup ifld-names)))
 814                              (string-list
 815                               indent "{\n"
 816                               (gen-define-ifields iflds
 817                                                   (insn-length insn)
 818                                                   (string-append indent "  ")
 819                                                   #f)
 820                               (gen-extract-ifields iflds
 821                                                    (insn-length insn)
 822                                                    (string-append indent "  ")
 823                                                    #f)
 824                               indent "  if ("
 825                               (rtl-c 'BI expr nil #:ifield-var? #t)
 826                               ")\n"
 827                               (-gen-decode-expr-set-itype
 828                                (string-append indent "    ")
 829                                (gen-cpu-insn-enum (current-cpu) insn)
 830                                (gen-sym (insn-sfmt insn))
 831                                fn?)
 832                               indent "}\n")))))
 833
 834                  (loop (cdr expr-list)
 835                        (append! code next-code)))))))
 836      ))
 837 )
 838
 839 ; Generate code to decode TABLE.
 840 ; REST is the remaining entries.
 841 ; SWITCH-NUM, STARTBIT, DECODE-BITSIZE, INDENT, LSB0?, INVALID-INSN are same
 842 ; as for -gen-decoder-switch.
 843
 844 (define (-gen-decode-table-entry table rest switch-num startbit decode-bitsize indent lsb0? invalid-insn fn?)
 845   (assert (eq? 'table (dtable-entry-type table)))
 846   (logit 3 "Generating decode table entry for case " (dtable-entry-index table) " ...\n")
 847
 848   (string-list
 849    indent "  case "
 850    (number->string (dtable-entry-index table))
 851    " :"
 852    ; If table is same as next, just emit a "fall through" to cut down on
 853    ; generated code.
 854    (if (and (not (null? rest))
 855             ; Ensure both tables.
 856             (eq? 'table (dtable-entry-type (car rest)))
 857             ; Ensure same table.
 858             (eqv? (subdtable-key (dtable-entry-value table))
 859                   (subdtable-key (dtable-entry-value (car rest)))))
 860        " /* fall through */\n"
 861        (string-list
 862         "\n"
 863         (-gen-decoder-switch switch-num
 864                              startbit
 865                              decode-bitsize
 866                              (subdtable-table (dtable-entry-value table))
 867                              (string-append indent "    ")
 868                              lsb0?
 869                              invalid-insn
 870                              fn?))))
 871 )
 872
 873 ; Subroutine of -decode-sort-entries.
 874 ; Return a boolean indicating if A,B are equivalent entries.
 875
 876 (define (-decode-equiv-entries? a b)
 877   (let ((a-type (dtable-entry-type a))
 878         (b-type (dtable-entry-type b)))
 879     (if (eq? a-type b-type)
 880         (case a-type
 881           ((insn)
 882            (let ((a-name (obj:name (dtable-entry-value a)))
 883                  (b-name (obj:name (dtable-entry-value b))))
 884             (eq? a-name b-name)))
 885           ((expr)
 886            ; Ignore expr entries for now.
 887            #f)
 888           ((table)
 889            (let ((a-name (subdtable-key (dtable-entry-value a)))
 890                  (b-name (subdtable-key (dtable-entry-value b))))
 891              (eq? a-name b-name))))
 892         ; A and B are not the same type.
 893         #f))
 894 )
 895
 896 ; Subroutine of -gen-decoder-switch, sort ENTRIES according to desired
 897 ; print order (maximizes amount of fall-throughs, but maintains numerical
 898 ; order as much as possible).
 899 ; ??? This is an O(n^2) algorithm.  An O(n Log(n)) algorithm can be done
 900 ; but it seemed more complicated than necessary for now.
 901
 902 (define (-decode-sort-entries entries)
 903   (let ((find-equiv!
 904          ; Return list of entries in non-empty list L that have the same decode
 905          ; entry as the first entry.  Entries found are marked with #f so
 906          ; they're not processed again.
 907          (lambda (l)
 908            ; Start off the result with the first entry, then see if the
 909            ; remaining ones match it.
 910            (let ((first (car l)))
 911              (let loop ((l (cdr l)) (result (cons first nil)))
 912                (if (null? l)
 913                    (reverse! result)
 914                    (if (and (car l) (-decode-equiv-entries? first (car l)))
 915                        (let ((lval (car l)))
 916                          (set-car! l #f)
 917                          (loop (cdr l) (cons lval result)))
 918                        (loop (cdr l) result)))))))
 919         )
 920     (let loop ((entries (list-copy entries)) (result nil))
 921       (if (null? entries)
 922           (apply append (reverse! result))
 923           (if (car entries)
 924               (loop (cdr entries)
 925                     (cons (find-equiv! entries)
 926                           result))
 927               (loop (cdr entries) result)))))
 928 )
 929
 930 ; Generate switch statement to decode TABLE-GUTS.
 931 ; SWITCH-NUM is for compatibility with the computed goto decoder and
 932 ; isn't used.
 933 ; STARTBIT is the bit offset of the instruction value that C variable `insn'
 934 ; holds (note that this is independent of LSB0?).
 935 ; DECODE-BITSIZE is the number of bits of the insn that `insn' holds.
 936 ; LSB0? is non-#f if bit number 0 is the least significant bit.
 937 ; INVALID-INSN is the <insn> object of the pseudo insn to handle invalid ones.
 938
 939 ; FIXME: for the few-alternative case (say, 2), generating
 940 ; if (0) {}
 941 ; else if (val == 0) { ... }
 942 ; else if (val == 1) { ... }
 943 ; else {}
 944 ; may well be less stressful on the compiler to optimize than small switch() stmts.
 945
 946 (define (-gen-decoder-switch switch-num startbit decode-bitsize table-guts indent lsb0? invalid-insn fn?)
 947   ; For entries that are a single insn, we're done, otherwise recurse.
 948
 949   (string-list
 950    indent "{\n"
 951    ; Are we at the next word?
 952    (if (not (= startbit (dtable-guts-startbit table-guts)))
 953        (begin
 954          (set! startbit (dtable-guts-startbit table-guts))
 955          (set! decode-bitsize (dtable-guts-bitsize table-guts))
 956          ; FIXME: Bits may get fetched again during extraction.
 957          (string-append indent "  unsigned int val;\n"
 958                         indent "  /* Must fetch more bits.  */\n"
 959                         indent "  insn = "
 960                         (gen-ifetch "pc" startbit decode-bitsize)
 961                         ";\n"
 962                         indent "  val = "))
 963        (string-append indent "  unsigned int val = "))
 964    (-gen-decode-bits (dtable-guts-bitnums table-guts)
 965                      (dtable-guts-startbit table-guts)
 966                      (dtable-guts-bitsize table-guts) "insn" lsb0?)
 967    ";\n"
 968    indent "  switch (val)\n"
 969    indent "  {\n"
 970
 971    ; The code is more readable, and icache use is improved, if we collapse
 972    ; common code into one case and use "fall throughs" for all but the last of
 973    ; a set of common cases.
 974    ; FIXME: We currently rely on -gen-decode-foo-entry to recognize the fall
 975    ; through.  We should take care of it ourselves.
 976
 977    (let loop ((entries (-decode-sort-entries (dtable-guts-entries table-guts)))
 978               (result nil))
 979      (if (null? entries)
 980          (reverse! result)
 981          (loop
 982           (cdr entries)
 983           (cons (case (dtable-entry-type (car entries))
 984                   ((insn)
 985                    (-gen-decode-insn-entry (car entries) (cdr entries) indent invalid-insn fn?))
 986                   ((expr)
 987                    (-gen-decode-expr-entry (car entries) indent invalid-insn fn?))
 988                   ((table)
 989                    (-gen-decode-table-entry (car entries) (cdr entries)
 990                                             switch-num startbit decode-bitsize
 991                                             indent lsb0? invalid-insn fn?))
 992                   )
 993                 result))))
 994
 995    ; ??? Can delete if all cases are present.
 996    indent "  default : "
 997    (-gen-decode-default-entry indent invalid-insn fn?)
 998    indent "  }\n"
 999    indent "}\n"
1000    )
1001 )
1002
1003 ; Decoder generation entry point.
1004 ; Generate code to decode INSN-LIST.
1005 ; BITNUMS is the set of bits to initially key off of.
1006 ; DECODE-BITSIZE is the number of bits of the instruction that `insn' holds.
1007 ; LSB0? is non-#f if bit number 0 is the least significant bit.
1008 ; INVALID-INSN is the <insn> object of the pseudo insn to handle invalid ones.
1009 ; FN? is non-#f if the extractors are functions rather than inline code
1010
1011 (define (gen-decoder insn-list bitnums decode-bitsize indent lsb0? invalid-insn fn?)
1012   (logit 3 "Building decode tree.\n"
1013          "bitnums = " (stringize bitnums " ") "\n"
1014          "decode-bitsize = " (number->string decode-bitsize) "\n"
1015          "lsb0? = " (if lsb0? "#t" "#f") "\n"
1016          "fn? = " (if fn? "#t" "#f") "\n"
1017          )
1018
1019   ; First build a table that decodes the instruction set.
1020
1021   (let ((table-guts (decode-build-table insn-list bitnums
1022                                         decode-bitsize lsb0?
1023                                         invalid-insn)))
1024
1025     ; Now print it out.
1026
1027     (-gen-decoder-switch "0" 0 decode-bitsize table-guts indent lsb0?
1028                          invalid-insn fn?)
1029     )
1030 )