cgen/attr.scm

   1 ; Attributes.
   2 ; Copyright (C) 2000, 2003, 2005, 2009 Red Hat, Inc.
   3 ; This file is part of CGEN.
   4 ; See file COPYING.CGEN for details.
   5
   6 ; There are 5 kinds of attributes: boolean, integer, enum, bitset, and string.
   7 ; Boolean attributes are really enum attributes with two possible values,
   8 ; but they occur frequently enough that they are special cased.
   9 ; String attributes are intentionally not documented in the manual as
  10 ; being supported - they're still a bit of work-in-progress.
  11 ;
  12 ; All objects that use attributes must have two methods:
  13 ; - 'get-atlist - returns the object's attr-list
  14 ; - 'set-atlist! - set the object's attr-list
  15 ;
  16 ; In .cpu files, attribute lists are associative lists of (NAME VALUE).
  17 ; Boolean attributes are specified as (NAME #t) or (NAME #f),
  18 ; but for convenience ATTR and !ATTR are also supported.
  19 ; integer/enum attrs are specified as (ATTR value).
  20 ; string attrs are specified as (ATTR "value").
  21 ; Bitset attrs are specified as (ATTR val1 val2 val3), each value must be
  22 ; a valid Scheme symbol (stick with valid C symbols + "-" and you'll be fine).
  23 ; For backwards compatibility (ATTR val1,val2,val3) and
  24 ; (ATTR "val1,val2,val3") are also supported for bitset values.
  25 ; val1,val2,val3 is not portable (e.g. mzscheme will reject it).
  26 ; In all cases the value needn't be constant, and can be an expression,
  27 ; though expressions are currently only supported for META-attributes
  28 ; (attributes that don't appear in any generated code).
  29 ;
  30 ; Example:
  31 ; (FOO1 !FOO2 (BAR 3) (FOO3 X) (MACH sparc sparclite))
  32 ;
  33 ; ??? Implementation of expressions is being postponed as long
  34 ; as possible, avoiding adding complications for complication's sake, and
  35 ; because I'm not completely sure how I want to do them.
  36 ; The syntax for an expression value is (ATTR (rtx-func ...)).
  37 ;
  38 ; ??? May wish to allow a bitset attribute like (ATTR val1 !val2), where `!'
  39 ; means to turn off that particular bit (or bits if val2 refers to several).
  40 ;
  41 ; ??? May wish to allow specifying enum attributes by only having to
  42 ; specify the value (move names into "enum space" or some such).
  43 \f
  44 ; An attr-list (or "atlist") is a collection of attributes.
  45 ; Attributes are stored as an associative list.
  46 ; There is possible confusion between "alist" (associative-list) and
  47 ; "atlist" (attribute-list) but in practice I haven't had a problem.
  48 ; ??? May wish to change this to a list of objects, as the alist doesn't carry
  49 ; enough info.  However the alist is simple and fast.
  50
  51 (define <attr-list> (class-make '<attr-list> nil '(prefix attrs) nil))
  52
  53 (define atlist-prefix (elm-make-getter <attr-list> 'prefix))
  54 (define atlist-attrs (elm-make-getter <attr-list> 'attrs))
  55
  56 (define (atlist? x) (class-instance? <attr-list> x))
  57
  58 ; An empty attribute-list.
  59
  60 (define atlist-empty (make <attr-list> "" nil))
  61
  62 ; The attribute baseclass.
  63 ; The attributes of <ident> are the set of attributes for this attribute
  64 ; [meaning attributes themselves can have attributes].
  65 ; [Ya, that's clumsily written.  I left it that way for fun.]
  66 ; An odd notion that is of some use.  It's current raison d'etre is to
  67 ; support sanitization of attributes [which is implemented with the
  68 ; `sanitize' attribute].
  69
  70 (define <attribute>
  71   (class-make '<attribute>
  72               '(<ident>)
  73               '(
  74                 ; List of object types this attribute is for.
  75                 ; Possible element values are:
  76                 ; attr, enum, cpu, mach, model, ifield, hardware, operand,
  77                 ; insn
  78                 ; A value of #f means the attribute is for everything.
  79                 for
  80                 )
  81               nil)
  82 )
  83
  84 ; Accessors.
  85
  86 (define atlist-for (elm-make-getter <attribute> 'for))
  87
  88 ; A class for each type of attribute.
  89
  90 ; `values' exists for boolean-attribute to simplify the code, it's ignored.
  91 ; Ditto for `default'.  The default for boolean-attribute is always #f.
  92
  93 (define <boolean-attribute>
  94   (class-make '<boolean-attribute>
  95               '(<attribute>)
  96               '(default values)
  97               nil)
  98 )
  99
 100 ; VALUES is ignored for string-attribute.
 101
 102 (define <string-attribute>
 103   (class-make '<string-attribute>
 104               '(<attribute>)
 105               '(default values)
 106               nil)
 107 )
 108
 109 ; For bitset attributes VALUES is a list of
 110 ; (symbol bit-number-or-#f attr-list comment-or-#f),
 111 ; one for each bit.
 112 ; If bit-number is #f (unspecified), cgen will choose.
 113 ; Int's are used to record the bitset in the generated code so there's a limit
 114 ; of 32 elements, though there's nothing inherent in the description language
 115 ; that precludes removing the limit.
 116 ; NOTE: While one might want to record each element as an object, there's
 117 ; currently no need for the added complexity.
 118
 119 (define <bitset-attribute>
 120   (class-make '<bitset-attribute>
 121               '(<attribute>)
 122               '(default values)
 123               nil)
 124 )
 125
 126 ; For integer attributes VALUES is a list of (int),
 127 ; one for each possible value,
 128 ; or the empty list of all values are permissible.
 129 ; Note that each element is itself a list.  This is for consistency.
 130
 131 (define <integer-attribute>
 132   (class-make '<integer-attribute>
 133               '(<attribute>)
 134               '(default values)
 135               nil)
 136 )
 137
 138 ; For enum attributes VALUES is a list of
 139 ; (symbol enum-value-or-#f attr-list comment-or-#f),
 140 ; one for each possible.
 141 ; If enum-value is #f (unspecified) cgen will apply the standard rule for
 142 ; assigning enum values.
 143 ; NOTE: While one might want to record each element as an object, there's
 144 ; currently no need for the added complexity.
 145
 146 (define <enum-attribute>
 147   (class-make '<enum-attribute>
 148               '(<attribute>)
 149               '(default values)
 150               nil)
 151 )
 152
 153 ; Return a boolean indicating if X is a <boolean-attribute> object.
 154
 155 (define (bool-attr? x) (class-instance? <boolean-attribute> x))
 156
 157 ; Return a symbol indicating the kind of attribute ATTR is.
 158 ; The result is one of boolean,integer,enum,bitset or string.
 159
 160 (define (attr-kind attr)
 161   (case (object-class-name attr)
 162     ((<boolean-attribute>) 'boolean)
 163     ((<string-attribute>)  'string)
 164     ((<integer-attribute>) 'integer)
 165     ((<enum-attribute>)    'enum)
 166     ((<bitset-attribute>)  'bitset)
 167     (else (error "attr-kind: internal error, not an attribute class"
 168                  (object-class-name attr))))
 169 )
 170
 171 ; Accessors.
 172
 173 (define (attr-default attr) (elm-xget attr 'default))
 174 (define (attr-values attr) (elm-xget attr 'values))
 175
 176 ; Create an attribute.
 177 ; Attributes are stored in attribute lists using the actual value
 178 ; rather than an object containing the value, so we only have to cons
 179 ; NAME and VALUE rather than building some object.  This is for simplicity
 180 ; and speed.  We try to incrementally complicate things, only as necessary.
 181
 182 ; VALUE must be #f or #t.
 183
 184 (define (bool-attr-make name value) (cons name value))
 185
 186 ; VALUES must be a list of symbols.
 187 ; E.g., (val1 val2) not val1,val2.
 188
 189 (define (bitset-attr-make name values) (cons name values))
 190
 191 ; VALUE must be a number (or maybe a symbol).
 192
 193 (define (int-attr-make name value) (cons name value))
 194
 195 ; VALUE must be a symbol.
 196
 197 (define (enum-attr-make name value) (cons name value))
 198
 199 ;; Return a procedure to parse an attribute.
 200 ;; RIGHT-TYPE? is a procedure that verifies the value is the right type.
 201 ;; MESSAGE is printed if there is an error.
 202 ;; The result of the parsed attribute is (name . value).
 203
 204 (define (/parse-simple-attribute right-type? message)
 205   (lambda (self context val)
 206     (if (and (not (null? val))
 207              (right-type? (car val))
 208              (null? (cdr val)))
 209         (cons (obj:name self) (car val))
 210         (parse-error context message (cons (obj:name self) val))))
 211 )
 212
 213 ; A boolean attribute's value is either #t or #f.
 214
 215 (method-make!
 216  <boolean-attribute> 'parse-value
 217  (/parse-simple-attribute boolean? "boolean attribute not one of #f/#t")
 218 )
 219
 220 (method-make!
 221  <string-attribute> 'parse-value
 222  (/parse-simple-attribute string? "invalid argument to string attribute"))
 223
 224 ; A bitset attribute's value is a list of symbols.
 225 ; For backwards compatibility (ATTR val1,val2,val3) and
 226 ; (ATTR "val1,val2,val3") are also supported for bitset values.
 227 ; val1,val2,val3 is not portable (e.g. mzscheme will reject it).
 228 ;
 229 ; We don't validate the values.  In the case of the MACH attribute,
 230 ; there's no current mechanism to create it after all define-mach's have
 231 ; been read in.
 232 ; ??? Need to decide whether all define-mach's must appear before any
 233 ; define-insn's.  It would be nice to be able to spread an architecture's
 234 ; description over several .cpu files.
 235 ; ??? On the other hand, all machs are specified in define-arch.
 236 ; Perhaps creation of builtins could be defered until then.
 237
 238 (method-make!
 239  <bitset-attribute> 'parse-value
 240  (lambda (self context val)
 241    (let ((value (if (and (= (length val) 1)
 242                          (or (symbol? (car val)) (string? (car val))))
 243                     (map string->symbol (string-cut (->string (car val)) #\,))
 244                     val))
 245          (message "improper bitset attribute"))
 246      ;; NOTE: An empty list is ok.
 247      (if (all-true? (map symbol? value))
 248          (cons (obj:name self) value)
 249          (parse-error context message (cons (obj:name self) val)))))
 250 )
 251
 252 ; An integer attribute's value is a number
 253 ; (or maybe a symbol representing that value).
 254
 255 (method-make!
 256  <integer-attribute> 'parse-value
 257  (/parse-simple-attribute (lambda (x) (or (number? x) (symbol? x)))
 258                           "improper integer attribute")
 259 )
 260
 261 ; An enum attribute's value is a symbol representing that value.
 262
 263 (method-make!
 264  <enum-attribute> 'parse-value
 265  (/parse-simple-attribute (lambda (x) (or (symbol? x) (string? x)))
 266                           "improper enum attribute")
 267 )
 268
 269 ; Parse a boolean attribute's value definition.
 270
 271 (method-make!
 272  <boolean-attribute> 'parse-value-def
 273  (lambda (self context values)
 274    (if (equal? values '(#f #t))
 275        values
 276        (parse-error context "boolean value list must be (#f #t)" values)))
 277 )
 278
 279 ; Ignore values for strings.
 280 ; They're not supported and /attr-read catches this.
 281
 282 (method-make!
 283  <string-attribute> 'parse-value-def
 284  (lambda (self context values) #f)
 285 )
 286
 287 ; Parse a bitset attribute's value definition.
 288
 289 (method-make!
 290  <bitset-attribute> 'parse-value-def
 291  (lambda (self context values)
 292    ;; parse-enum-vals works well enough
 293    (parse-enum-vals context "" values))
 294 )
 295
 296 ; Parse an integer attribute's value definition.
 297 ; VALUES may be #f which means any value is ok.
 298 ; A fixed set of VALUES is work-in-progress.
 299
 300 (method-make!
 301  <integer-attribute> 'parse-value-def
 302  (lambda (self context values)
 303    (if values
 304        (for-each (lambda (val)
 305                    ;; A list entry is for providing a sanitization key.
 306                    (if (or (not (list? val))
 307                            (not (number? (car val))))
 308                        (parse-error context
 309                                     "invalid element in integer attribute list"
 310                                     val)))
 311                  values))
 312    values)
 313 )
 314
 315 ; Parse an enum attribute's value definition.
 316 ; See parse-enum-vals for more info.
 317
 318 (method-make!
 319  <enum-attribute> 'parse-value-def
 320  (lambda (self context values)
 321    (parse-enum-vals context "" values))
 322 )
 323
 324 ; Make an attribute list object from a list of name/value pairs.
 325
 326 (define (atlist-make prefix . attrs) (make <attr-list> prefix attrs))
 327 \f
 328 ; Parse an attribute definition.
 329 ; This is the main routine for building an attribute object from a
 330 ; description in the .cpu file.
 331 ; All arguments are in raw (non-evaluated) form.
 332 ; TYPE-CLASS is the class of the object to create.
 333 ; i.e. one of <{boolean,bitset,integer,enum,string}-attribute>.
 334 ; For enum attributes, if DEFAULT is #f use the first value.
 335 ; For all other attribute kinds, we use what /attr-read gives us.
 336 ; ??? Allowable values for integer attributes is wip,
 337 ; for now it is the portable set of integers (int32_t).
 338
 339 (define (/attr-parse context type-class name comment attrs for default values)
 340   (logit 2 "Processing attribute " name " ...\n")
 341
 342   ;; Pick out name first to augment the error context.
 343   (let* ((name (parse-name context name))
 344          (context (context-append-name context name))
 345          (result (new type-class))
 346          (parsed-values (send result 'parse-value-def context values)))
 347
 348     (elm-xset! result 'name name)
 349     (elm-xset! result 'comment (parse-comment context comment))
 350     (elm-xset! result 'attrs (atlist-parse context attrs ""))
 351     (elm-xset! result 'for for)
 352
 353     ;; Set the default.
 354     ;; FIXME: Clean up with /attr-read.
 355     (case (class-name type-class)
 356       ((<boolean-attribute>)
 357        ;; ??? docs say default must be #f, but we want to allow an rtx to
 358        ;; specify the default.
 359        (if (and (not (memq default '(#f #t)))
 360                 (not (/attr-val-is-rtx? default)))
 361            (parse-error context "invalid default" default))
 362        (elm-xset! result 'default default))
 363       ((<string-attribute>)
 364        (let ((default (or default "")))
 365          (if (and (not (string? default))
 366                   (not (/attr-val-is-rtx? default)))
 367              (parse-error context "invalid default" default))
 368          (elm-xset! result 'default default)))
 369       ((<integer-attribute>)
 370        (let ((default (if default default (if (null? values) 0 (car values)))))
 371          (if (and (not (integer? default))
 372                   (not (/attr-val-is-rtx? default)))
 373              (parse-error context "invalid default" default))
 374          (elm-xset! result 'default default)))
 375       ((<enum-attribute>)
 376        (let ((default (if default default (caar parsed-values))))
 377          (if (and (not (assq default parsed-values))
 378                   (not (/attr-val-is-rtx? default)))
 379              (parse-error context "invalid default" default))
 380          (elm-xset! result 'default default)))
 381       ((<bitset-attribute>)
 382        ;; bitset attributes must specify a default, /attr-read catches this
 383        (assert default)
 384        ;; It's also /attr-read's job to ensure it is a list.
 385        (assert (list? default))
 386        (let ((default default))
 387          ;; NOTE: We don't allow an rtx for bitset attributes,
 388          ;; the rtl language currently doesn't support them.
 389          (if (/attr-val-is-rtx? default)
 390              (parse-error context "invalid default, rtx not supported for bitset" default))
 391          (if (not (all-true? (map (lambda (v) (assq v parsed-values))
 392                                   default)))
 393              (parse-error context "invalid default" default))
 394          (elm-xset! result 'default default))))
 395
 396     (elm-xset! result 'values parsed-values)
 397
 398     result)
 399 )
 400
 401 ; Read an attribute description
 402 ; This is the main routine for analyzing attributes in the .cpu file.
 403 ; CONTEXT is a <context> object for error messages.
 404 ; ARG-LIST is an associative list of field name and field value.
 405 ; /attr-parse is invoked to create the attribute object.
 406
 407 (define (/attr-read context . arg-list)
 408   (let (
 409         (type 'not-set) ;; attribute type
 410         (type-class 'not-set) ;; attribute class
 411         (name #f)
 412         (comment "")
 413         (attrs nil)
 414         (for #f) ;; assume for everything
 415         (default #f) ;; #f indicates "not set"
 416         (values #f) ;; #f indicates "not set"
 417         )
 418
 419     ;; Loop over each element in ARG-LIST, recording what's found.
 420     (let loop ((arg-list arg-list))
 421       (if (null? arg-list)
 422           nil
 423           (let ((arg (car arg-list))
 424                 (elm-name (caar arg-list)))
 425             (case elm-name
 426               ((type)
 427                (set! type-class (case (cadr arg)
 428                                   ((boolean) <boolean-attribute>)
 429                                   ((string) <string-attribute>)
 430                                   ((bitset) <bitset-attribute>)
 431                                   ((integer) <integer-attribute>)
 432                                   ((enum) <enum-attribute>)
 433                                   (else (parse-error
 434                                          context
 435                                          "invalid attribute type"
 436                                          (cadr arg)))))
 437                (set! type (cadr arg)))
 438               ((name) (set! name (cadr arg)))
 439               ((comment) (set! comment (cadr arg)))
 440               ((attrs) (set! attrs (cdr arg)))
 441               ((for) (set! for (cdr arg)))
 442               ((default) (set! default (cdr arg)))
 443               ((values) (set! values (cdr arg)))
 444               (else (parse-error context "invalid attribute arg" arg)))
 445             (loop (cdr arg-list)))))
 446
 447     ;; Must have type now.
 448     (if (eq? type-class 'not-set)
 449         (parse-error context "type not specified") arg-list)
 450
 451     ;; For scalar attributes, fix up the default.
 452     (if (and default (memq type '(boolean string integer enum)))
 453         (begin
 454           (if (!= (length default) 1)
 455               (parse-error context "invalid default" default))
 456           ;; Don't change rtx values.
 457           (if (not (pair? (car default)))
 458               (set! default (car default)))))
 459
 460     ;; Establish proper defaults now that we know the type.
 461     ;; FIXME: Clean up with /attr-parse.
 462     (case type
 463       ((boolean)
 464        (if (eq? default #f)
 465            (set! default #f)) ;; really a nop, but for consistency
 466        (if (eq? values #f)
 467            (set! values '(#f #t))))
 468       ((bitset) ;; FIXME
 469        (if (eq? default #f)
 470            (parse-error context "bitset attribute default not specified"
 471                         arg-list))
 472        (if (eq? values #f)
 473            (parse-error context "bitset attribute values not specified"
 474                         arg-list)))
 475       ((integer) ;; FIXME
 476        (if (eq? default #f)
 477            (set! default 0))
 478        (if (eq? values #f)
 479            (set! values #f))) ;; really a nop, but for consistency
 480       ((enum) ;; FIXME
 481 ;; There are some existing cases where no default is specified,
 482 ;; expecting that the first value is the default.
 483 ;;     (if (eq? default #f)
 484 ;;         (parse-error context "enum attribute default not specified"
 485 ;;                      arg-list))
 486        (if (eq? values #f)
 487            (parse-error context "enum attribute values not specified"
 488                         arg-list)))
 489       ((string)
 490        (if (eq? default #f)
 491            (set! default ""))
 492        (if (not (eq? values #f))
 493            (parse-error context "string attribute values specified"
 494                         arg-list)))
 495       )
 496
 497     ;; Now that we've identified the elements, build the object.
 498     (/attr-parse context type-class name comment attrs for default values))
 499 )
 500
 501 ; Main routines for defining attributes in .cpu files.
 502
 503 (define define-attr
 504   (lambda arg-list
 505     (let ((a (apply /attr-read (cons (make-current-context "define-attr")
 506                                      arg-list))))
 507       (current-attr-add! a)
 508       a))
 509 )
 510 \f
 511 ; Query routines.
 512
 513 ; Lookup ATTR-NAME in ATTR-LIST.
 514 ; The result is the object or #f if not found.
 515
 516 (define (attr-lookup attr-name attr-list)
 517   (object-assq attr-name attr-list)
 518 )
 519
 520 ; Return a boolean indicating if boolean attribute ATTR is "true" in
 521 ; attribute alist ALIST.
 522 ; Note that if the attribute isn't present, it is defined to be #f.
 523
 524 (method-make!
 525  <attr-list> 'has-attr?
 526  (lambda (self attr)
 527    (let ((a (assq attr (elm-get self 'attrs))))
 528      (cond ((not a) a)
 529            ((boolean? (cdr a)) (cdr a))
 530            (else (error "Not a boolean attribute:" attr)))))
 531 )
 532
 533 (define (atlist-has-attr? atlist attr)
 534   (send atlist 'has-attr? attr)
 535 )
 536
 537 ; Return a boolean indicating if attribute ATTR is present in
 538 ; attribute alist ALIST.
 539
 540 (method-make!
 541  <attr-list> 'attr-present?
 542  (lambda (self attr)
 543    (->bool (assq attr (elm-get self 'attrs))))
 544 )
 545
 546 (define (atlist-attr-present? atlist attr)
 547   (send atlist 'attr-present? attr)
 548 )
 549
 550 ;; Return #t if attribute value VAL is an rtx expression.
 551 ;; RTXs in attributes are recorded as a list of one element
 552 ;; which is the rtx.
 553 ;; I.e., ((rtx foo bar)).
 554
 555 (define (/attr-val-is-rtx? val)
 556   (and (pair? val)
 557        (null? (cdr val))
 558        (pair? (car val))) ;; pair? -> cheap non-null-list?
 559 )
 560
 561 ; Expand attribute value ATVAL, which is an rtx expression.
 562 ; OWNER is the containing object or #f if there is none.
 563 ; OWNER is needed if an attribute is defined in terms of other attributes.
 564 ; OWNER is also needed to get the ISA(s) in which to evaluate the expression.
 565 ; If it's #f obviously ATVAL can't be defined in terms of others,
 566 ; or refer to operands that require an ISA to disambiguate.
 567
 568 (define (/attr-eval atval owner)
 569   (let* ((atval-expr (car atval))
 570          (expr (rtx-simplify #f owner
 571                              (rtx-canonicalize #f 'DFLT
 572                                                (and owner (obj-isa-list owner))
 573                                                nil atval-expr)
 574                              nil))
 575          (value (rtx-value expr owner)))
 576     (cond ((symbol? value) value)
 577           ((number? value) value)
 578           (error "/attr-eval: internal error, unsupported result:" value)))
 579 )
 580
 581 ; Return value of ATTR in attribute alist ALIST.
 582 ; If not present, return the default value.
 583 ; If ATTR is an unknown attribute, return #f.
 584 ; OWNER is the containing object or #f if there is none.
 585
 586 (define (attr-value alist attr owner)
 587   (let ((a (assq-ref alist attr)))
 588     (if a
 589         (if (/attr-val-is-rtx? a)
 590             (/attr-eval a owner)
 591             a)
 592         (attr-lookup-default attr owner)))
 593 )
 594
 595 ; Return the value of ATTR in ATLIST.
 596 ; If not present, return the default value.
 597 ; If ATTR is an unknown attribute, return #f.
 598 ; OWNER is the containing object or #f if there is none.
 599
 600 (define (atlist-attr-value atlist attr owner)
 601   (attr-value (atlist-attrs atlist) attr owner)
 602 )
 603
 604 ; Same as atlist-attr-value but return nil if attribute not present.
 605
 606 (define (atlist-attr-value-no-default atlist attr owner)
 607   (let ((a (assq-ref (atlist-attrs atlist) attr)))
 608     (if a
 609         (if (/attr-val-is-rtx? a)
 610             (/attr-eval a owner)
 611             a)
 612         nil))
 613 )
 614
 615 ; Return the default for attribute A.
 616 ;
 617 ; If A is unknown return #f.
 618 ; This means the caller can't distinguish booleans from unknowns,
 619 ; but the caller is left to deal with that.
 620 ;
 621 ; OWNER is the containing object or #f if there is none.
 622
 623 (define (attr-lookup-default a owner)
 624   (let ((at (current-attr-lookup a)))
 625     (if at
 626         (if (bool-attr? at)
 627             #f ;; FIXME: should fetch default from the attribute
 628             (let ((deflt (attr-default at)))
 629               (if deflt
 630                   (if (/attr-val-is-rtx? deflt)
 631                       (/attr-eval deflt owner)
 632                       deflt)
 633                   ;; If no default was provided, use the first value.
 634                   ;; FIXME: This shouldn't happen.  /attr-parse should DTRT.
 635                   (caar (attr-values at)))))
 636         #f))
 637 )
 638
 639 ; Return a boolean indicating if X is present in BITSET.
 640 ; Bitset values are recorded as (val1 val2 ...).
 641
 642 (define (bitset-attr-member? x bitset)
 643   (->bool (memq x bitset))
 644 )
 645 \f
 646 ; Routines for accessing attributes in objects.
 647
 648 ; Get/set attributes of OBJ.
 649 ; OBJ is any object which supports the get-atlist message.
 650
 651 (define (obj-atlist obj)
 652   (let ((result (send obj 'get-atlist)))
 653     ; As a speed up, we allow objects to specify an empty attribute list
 654     ; with #f or (), rather than creating an attr-list object.
 655     ; ??? There is atlist-empty now which should be used directly.
 656     (if (or (null? result) (not result))
 657         atlist-empty
 658         result))
 659 )
 660
 661 (define (obj-set-atlist! obj attrs) (send obj 'set-atlist! attrs))
 662
 663 ; Add attribute ATTR to OBJ.
 664 ; The attribute is prepended to the front so it overrides any existing
 665 ; definition.
 666
 667 (define (obj-cons-attr! obj attr)
 668   (obj-set-atlist! obj (atlist-cons attr (obj-atlist obj)))
 669 )
 670
 671 ; Add attribute list ATLIST to OBJ.
 672 ; Attributes in ATLIST override existing values, so ATLIST is "prepended".
 673
 674 (define (obj-prepend-atlist! obj atlist)
 675   ; Must have same prefix.
 676   (assert (equal? (atlist-prefix (obj-atlist obj))
 677                   (atlist-prefix atlist)))
 678   (obj-set-atlist! obj (atlist-append atlist (obj-atlist obj)))
 679 )
 680
 681 ; Return boolean of whether OBJ has boolean attribute ATTR or not.
 682 ; OBJ is any object that supports attributes.
 683
 684 (define (obj-has-attr? obj attr)
 685   (atlist-has-attr? (obj-atlist obj) attr)
 686 )
 687
 688 ; FIXME: for backward compatibility.  Delete in time.
 689 (define has-attr? obj-has-attr?)
 690
 691 ; Return a boolean indicating if attribute ATTR is present in OBJ.
 692
 693 (define (obj-attr-present? obj attr)
 694   (atlist-attr-present? (obj-atlist obj) attr)
 695 )
 696
 697 ; Return value of attribute ATTR in OBJ.
 698 ; If the attribute isn't present, the default is returned.
 699 ; If ATTR is an unknown attribute, return #f.
 700 ; OBJ is any object that supports the get-atlist method.
 701
 702 (define (obj-attr-value obj attr)
 703   (let ((atlist (obj-atlist obj)))
 704     (atlist-attr-value atlist attr obj))
 705 )
 706
 707 ; Return boolean of whether OBJ has attribute ATTR value VALUE or not.
 708 ; OBJ is any object that supports attributes.
 709 ; NOTE: The default value of the attribute IS considered.
 710
 711 (define (obj-has-attr-value? obj attr value)
 712   (let ((a (obj-attr-value obj attr)))
 713     (eq? a value))
 714 )
 715
 716 ; Return boolean of whether OBJ explicitly has attribute ATTR value VALUE
 717 ; or not.
 718 ; OBJ is any object that supports attributes.
 719 ; NOTE: The default value of the attribute IS NOT considered.
 720
 721 (define (obj-has-attr-value-no-default? obj attr value)
 722   (let* ((atlist (obj-atlist obj))
 723          (objs-value (atlist-attr-value-no-default atlist attr obj)))
 724     (and (not (null? objs-value)) (eq? value objs-value)))
 725 )
 726 \f
 727 ; Utilities.
 728
 729 ; Generate a list representing a bit mask of the indices of 'values'
 730 ; within 'all-values'. Each element in the resulting list represents a byte.
 731 ; Both bits and bytes are indexed from left to right starting at 0
 732 ; with 8 bits in a byte.
 733
 734 (define (charmask-bytes values all-values vec-length)
 735   (logit 3 "charmask-bytes for " values " " all-values "\n")
 736   (let ((result (make-vector vec-length 0))
 737         (indices (map (lambda (name)
 738                         (list-ref (map cadr all-values)
 739                                   (element-lookup-index name (map car all-values) 0)))
 740                       values)))
 741     (logit 3 "indices: " indices "\n")
 742     (for-each (lambda (x)
 743                 (let* ((byteno (quotient x 8))
 744                        (bitno (- 7 (remainder x 8)))
 745                        (byteval (logior (vector-ref result byteno)
 746                                         (ash 1 bitno))))
 747                   (vector-set! result byteno byteval)))
 748               indices)
 749     (logit 3 "result: " (vector->list result) "\n")
 750     (vector->list result))
 751 )
 752
 753 ; Convert a bitset value into a bit string based on the
 754 ; index of each member in values.
 755 ; VALUE is a list of symbols in the bitset.
 756 ; VALUES is the values member of the attribute's definition.
 757
 758 (define (/bitset-attr->charmask value values)
 759   (let* ((values-names (map car values))
 760          (values-values (map cadr values))
 761          (vec-length (+ 1 (quotient (apply max values-values) 8))))
 762     (string-append "{ " (number->string vec-length) ", \""
 763                    (string-map (lambda (x)
 764                                  (string-append "\\x" (number->hex x)))
 765                                (charmask-bytes value values vec-length))
 766                    "\" }"))
 767 )
 768
 769 ; Return the enum of ATTR-NAME for type TYPE.
 770 ; TYPE is one of 'ifld, 'hw, 'operand, 'insn.
 771
 772 (define (gen-attr-enum type attr-name)
 773   (string-upcase (string-append "CGEN_" type "_" (gen-sym attr-name)))
 774 )
 775
 776 ; Return a list of enum value definitions for gen-enum-decl.
 777 ; Attributes numbers are organized as follows: booleans are numbered 0-31.
 778 ; The range is because that's what fits in a portable int.  Unused numbers
 779 ; are left unused.  Non-booleans are numbered starting at 32.
 780 ; An alternative is start numbering the booleans at 32.  The generated code
 781 ; is simpler with the current way (the "- 32" to get back the bit number or
 782 ; array index number occurs less often).
 783 ;
 784 ; Three special values are created:
 785 ; END-BOOLS - mark end of boolean attributes
 786 ; END-NBOOLS - mark end of non-boolean attributes
 787 ; START-NBOOLS - marks the start of the non-boolean attributes
 788 ; (needed in case first non-bool is sanytized out).
 789 ;
 790 ; ATTR-OBJ-LIST is a list of <attribute> objects (always subclassed of course).
 791
 792 (define (attr-list-enum-list attr-obj-list)
 793   (let ((sorted-attrs (/attr-sort (attr-remove-meta-attrs attr-obj-list))))
 794     (assert (<= (length (car sorted-attrs)) 32))
 795     (append!
 796      (map (lambda (bool-attr)
 797             (list (obj:name bool-attr) '-
 798                   (atlist-attrs (obj-atlist bool-attr))))
 799           (car sorted-attrs))
 800      (list '(END-BOOLS))
 801      (list '(START-NBOOLS 31))
 802      (map (lambda (nbool-attr)
 803             (list (obj:name nbool-attr) '-
 804                   (atlist-attrs (obj-atlist nbool-attr))))
 805           (cdr sorted-attrs))
 806      (list '(END-NBOOLS))
 807      ))
 808 )
 809
 810 ; Sort an alist of attributes so non-boolean attributes are at the front.
 811 ; This is used to sort a particular object's attributes.
 812 ; This is required by the C support code (cgen.h:CGEN_ATTR_VALUE).
 813 ; Boolean attributes appear as (NAME . #t/#f), non-boolean ones appear as
 814 ; (NAME . VALUE).  Attributes of the same type are sorted by name.
 815
 816 (define (/attr-sort-alist alist)
 817   (sort alist
 818         (lambda (a b)
 819           ;(display (list a b "\n"))
 820           (cond ((and (boolean? (cdr a)) (boolean? (cdr b)))
 821                  (string<? (symbol->string (car a)) (symbol->string (car b))))
 822                 ((boolean? (cdr a)) #f) ; we know b is non-bool here
 823                 ((boolean? (cdr b)) #t) ; we know a is non-bool here
 824                 (else (string<? (symbol->string (car a))
 825                                 (symbol->string (car b)))))))
 826 )
 827
 828 ; Sort ATTR-LIST into two lists: bools and non-bools.
 829 ; The car of the result is the bools, the cdr is the non-bools.
 830 ; Attributes requiring a fixed index have the INDEX attribute,
 831 ; and used for the few special attributes that are refered to by
 832 ; architecture independent code.
 833 ; For each of non-bools and bools, put attributes with the INDEX attribute
 834 ; first.  This is used to sort a list of attributes for output (e.g. define
 835 ; the attr enum).
 836 ;
 837 ; FIXME: Record index number with the INDEX attribute and sort on it.
 838 ; At present it's just a boolean.
 839
 840 (define (/attr-sort attr-list)
 841   (let loop ((fixed-non-bools nil)
 842              (non-fixed-non-bools nil)
 843              (fixed-bools nil)
 844              (non-fixed-bools nil)
 845              (attr-list attr-list))
 846     (cond ((null? attr-list)
 847            (cons (append! (reverse! fixed-bools)
 848                           (reverse! non-fixed-bools))
 849                  (append! (reverse! fixed-non-bools)
 850                           (reverse! non-fixed-non-bools))))
 851           ((bool-attr? (car attr-list))
 852            (if (obj-has-attr? (car attr-list) 'INDEX)
 853                (loop fixed-non-bools non-fixed-non-bools
 854                      (cons (car attr-list) fixed-bools) non-fixed-bools
 855                      (cdr attr-list))
 856                (loop fixed-non-bools non-fixed-non-bools
 857                      fixed-bools (cons (car attr-list) non-fixed-bools)
 858                      (cdr attr-list))))
 859           (else
 860            (if (obj-has-attr? (car attr-list) 'INDEX)
 861                (loop (cons (car attr-list) fixed-non-bools) non-fixed-non-bools
 862                      fixed-bools non-fixed-bools
 863                      (cdr attr-list))
 864                (loop fixed-non-bools (cons (car attr-list) non-fixed-non-bools)
 865                      fixed-bools non-fixed-bools
 866                      (cdr attr-list))))))
 867 )
 868
 869 ; Return number of non-bools in attributes ATLIST.
 870
 871 (define (attr-count-non-bools atlist)
 872   (count-true (map (lambda (a) (not (bool-attr? a)))
 873                    atlist))
 874 )
 875
 876 ; Given an alist of attributes, return the non-bools.
 877
 878 (define (attr-non-bool-attrs alist)
 879   (let loop ((result nil) (alist alist))
 880     (cond ((null? alist) (reverse! result))
 881           ((boolean? (cdar alist)) (loop result (cdr alist)))
 882           (else (loop (cons (car alist) result) (cdr alist)))))
 883 )
 884
 885 ; Given an alist of attributes, return the bools.
 886
 887 (define (attr-bool-attrs alist)
 888   (let loop ((result nil) (alist alist))
 889     (cond ((null? alist) (reverse! result))
 890           ((boolean? (cdar alist))
 891            (loop (cons (car alist) result) (cdr alist)))
 892           (else (loop result (cdr alist)))))
 893 )
 894
 895 ; Parse an attribute spec.
 896 ; CONTEXT is a <context> object or #f if there is none.
 897 ; ATTRS is a list of attribute specs (e.g. (FOO !BAR (BAZ 3))).
 898 ; The result is the attribute alist.
 899
 900 (define (attr-parse context attrs)
 901   (logit 4 (list 'attr-parse context attrs) "\n")
 902   (if (not (list? attrs))
 903       (parse-error context "improper attribute list" attrs))
 904   (let ((alist nil))
 905     (for-each (lambda (elm)
 906                 (cond ((symbol? elm)
 907                        ; boolean attribute
 908                        (if (char=? (string-ref (symbol->string elm) 0) #\!)
 909                            (set! alist (acons (string->symbol (string-drop1 (symbol->string elm))) #f alist))
 910                            (set! alist (acons elm #t alist)))
 911                        (if (not (current-attr-lookup (caar alist)))
 912                            (parse-error context "unknown attribute" (caar alist))))
 913                       ((and (list? elm) (pair? elm) (symbol? (car elm)))
 914                        (let ((a (current-attr-lookup (car elm))))
 915                          (if (not a)
 916                              (parse-error context "unknown attribute" elm))
 917                          (set! alist (cons (send a 'parse-value
 918                                                  context (cdr elm))
 919                                            alist))))
 920                       (else (parse-error context "improper attribute" elm))))
 921               attrs)
 922     alist)
 923 )
 924
 925 ; Parse an object attribute spec.
 926 ; ATTRS is a list of attribute specs (e.g. (FOO !BAR (BAZ 3))).
 927 ; The result is an <attr-list> object.
 928
 929 (define (atlist-parse context attrs prefix)
 930   (make <attr-list> prefix (attr-parse context attrs))
 931 )
 932
 933 ;; Return the source form of an atlist's values.
 934 ;; Externally scalar attributes (boolean, integer, enum and string) are
 935 ;; ((name1 value1) (name2 value2) ...).
 936 ;; Internally they are ((name1 . value1) (name2 . value2) ...).
 937 ;; Externally bitset attributes are (name value1 value2 ...).
 938 ;; Internally they are the same, (name value1 value2 ...).
 939 ;; If the value is an rtx expression, externally it is (name (expr)),
 940 ;; and internally it is the same, (name (expr)).
 941
 942 (define (atlist-source-form atlist)
 943   (map (lambda (attr)
 944          (let ((value (cdr attr)))
 945            (if (pair? value)
 946                (cons (car attr) value)
 947                (list (car attr) value))))
 948        (atlist-attrs atlist))
 949 )
 950
 951 ; Cons an attribute to an attribute list to create a new attribute list.
 952 ; ATLIST is either an attr-list object or #f or () (both of the latter two
 953 ; signify an empty attribute list, in which case we make the prefix of the
 954 ; result "").
 955
 956 (define (atlist-cons attr atlist)
 957   (if (or (not atlist) (null? atlist))
 958       (make <attr-list> "" (cons attr nil))
 959       (make <attr-list> (atlist-prefix atlist) (cons attr (atlist-attrs atlist))))
 960 )
 961
 962 ; Append one attribute list to another.
 963 ; The prefix for the new atlist is taken from the first one.
 964
 965 (define (atlist-append attr-list1 attr-list2)
 966   (make <attr-list>
 967         (atlist-prefix attr-list1)
 968         (append (atlist-attrs attr-list1) (atlist-attrs attr-list2)))
 969 )
 970
 971 ; Remove meta-attributes from ALIST.
 972 ; "meta" may be the wrong adjective to use here.
 973 ; The attributes in question are not intended to appear in generated files.
 974 ; They started out being attributes of attributes, hence the name "meta".
 975
 976 (define (attr-remove-meta-attrs-alist alist)
 977   (let ((all-attrs (current-attr-list)))
 978     ; FIXME: Why not use find?
 979     (let loop ((result nil) (alist alist))
 980       (if (null? alist)
 981           (reverse! result)
 982           (let ((attr (attr-lookup (caar alist) all-attrs)))
 983             (if (and attr (has-attr? attr 'META))
 984                 (loop result (cdr alist))
 985                 (loop (cons (car alist) result) (cdr alist)))))))
 986 )
 987
 988 ; Remove meta-attributes from ATTR-LIST.
 989 ; "meta" may be the wrong adjective to use here.
 990 ; The attributes in question are not intended to appear in generated files.
 991 ; They started out being attributes of attributes, hence the name "meta".
 992
 993 (define (attr-remove-meta-attrs attr-list)
 994   ; FIXME: Why not use find?
 995   (let loop ((result nil) (attr-list attr-list))
 996     (cond ((null? attr-list)
 997            (reverse! result))
 998           ((has-attr? (car attr-list) 'META)
 999            (loop result (cdr attr-list)))
1000           (else
1001            (loop (cons (car attr-list) result) (cdr attr-list)))))
1002 )
1003
1004 ; Remove duplicates from ATTRS, a list of attributes.
1005 ; Attribute lists are typically small so we use a simple O^2 algorithm.
1006 ; The leading entry of an attribute overrides subsequent ones so this is
1007 ; defined to pick the first entry of each attribute.
1008
1009 (define (attr-nub attrs)
1010   (let loop ((result nil) (attrs attrs))
1011     (cond ((null? attrs) (reverse! result))
1012           ((assq (caar attrs) result) (loop result (cdr attrs)))
1013           (else (loop (cons (car attrs) result) (cdr attrs)))))
1014 )
1015
1016 ; Return a list of all attrs in TABLE-LIST, a list of lists of arbitrary
1017 ; elements.   A list of lists is passed to simplify computation of insn
1018 ; attributes where the insns and macro-insns are on separate lists and
1019 ; appending them into one list would be unnecessarily expensive.
1020 ; ACCESSOR is a function to access the attrs field from TABLE-LIST.
1021 ; Duplicates are eliminated and the list is sorted so non-boolean attributes
1022 ; are at the front (required by the C code that fetches attribute values).
1023 ; STD-ATTRS is an `attr-list' object of attrs that are always available.
1024 ; The actual values returned are random (e.g. #t vs #f).  We could
1025 ; canonicalize them.
1026 ; The result is an alist of all the attributes that are used in TABLE-LIST.
1027 ; ??? The cdr of each element is some random value.  Perhaps it should be
1028 ; the default value or perhaps we should just return a list of names.
1029 ; ??? No longer used.
1030
1031 (define (attr-compute-all table-list accessor std-attrs)
1032   (let ((accessor (lambda (elm) (atlist-attrs (accessor elm)))))
1033     (attr-remove-meta-attrs-alist
1034      (attr-nub
1035       (/attr-sort-alist
1036        (append
1037         (apply append
1038                (map (lambda (table-elm)
1039                       (apply append
1040                              (find-apply accessor
1041                                          (lambda (e)
1042                                            (let ((attrs (accessor e)))
1043                                              (not (null? attrs))))
1044                                          table-elm)))
1045                     table-list))
1046         (atlist-attrs std-attrs))))))
1047 )
1048
1049 ; Return lists of attributes for particular object types.
1050 ; FIXME: The output shouldn't be required to be sorted.
1051
1052 (define (current-attr-list-for type)
1053   (let ((sorted (/attr-sort (find (lambda (a)
1054                                     (if (atlist-for a)
1055                                         (memq type (atlist-for a))
1056                                         #t))
1057                                   (attr-remove-meta-attrs
1058                                    (current-attr-list))))))
1059     ; Current behaviour puts the non-bools at the front.
1060     (append! (cdr sorted) (car sorted)))
1061 )
1062 (define (current-ifld-attr-list)
1063   (current-attr-list-for 'ifield)
1064 )
1065 (define (current-hw-attr-list)
1066   (current-attr-list-for 'hardware)
1067 )
1068 (define (current-op-attr-list)
1069   (current-attr-list-for 'operand)
1070 )
1071 (define (current-insn-attr-list)
1072   (current-attr-list-for 'insn)
1073 )
1074 \f
1075 ; Methods to emit the C value of an attribute.
1076 ; These don't _really_ belong here (C code doesn't belong in the appl'n
1077 ; independent part of CGEN), but there isn't a better place for them
1078 ; (maybe utils-cgen.scm?) and there's only a few of them.
1079
1080 (method-make!
1081  <boolean-attribute> 'gen-value-for-defn-raw
1082  (lambda (self value)
1083    (if (not value)
1084        "0"
1085        "1"))
1086  ;(string-upcase (string-append (obj:str-name self) "_" value)))
1087 )
1088
1089 (method-make!
1090  <boolean-attribute> 'gen-value-for-defn
1091  (lambda (self value)
1092    (send self 'gen-value-for-defn-raw value))
1093 )
1094
1095 ;; NOTE: VALUE is a list of symbols in the bitset.
1096
1097 (method-make!
1098  <bitset-attribute> 'gen-value-for-defn-raw
1099  (lambda (self value)
1100    (if (string=? (string-downcase (gen-sym self)) "isa")
1101        (/bitset-attr->charmask value (elm-get self 'values))
1102        (string-drop1
1103         (string-upcase
1104          (string-map (lambda (x)
1105                        (string-append "|(1<<"
1106                                       (gen-sym self)
1107                                       "_" (gen-c-symbol x) ")"))
1108                      value))))
1109  )
1110 )
1111
1112 ;; NOTE: VALUE is a list of symbols in the bitset.
1113
1114 (method-make!
1115  <bitset-attribute> 'gen-value-for-defn
1116  (lambda (self value)
1117    (string-append
1118     "{ "
1119     (if (string=? (string-downcase (gen-sym self)) "isa")
1120         (/bitset-attr->charmask value (elm-get self 'values))
1121         (string-append
1122          "{ "
1123          (string-drop1
1124           (string-upcase
1125            (string-map (lambda (x)
1126                          (string-append "|(1<<"
1127                                         (gen-sym self)
1128                                         "_" (gen-c-symbol x) ")"))
1129                        value)))
1130          ", 0 }"))
1131     " }")
1132  )
1133 )
1134
1135 (method-make!
1136  <integer-attribute> 'gen-value-for-defn-raw
1137  (lambda (self value)
1138    (number->string value)
1139  )
1140 )
1141
1142 (method-make!
1143  <integer-attribute> 'gen-value-for-defn
1144  (lambda (self value)
1145    (string-append
1146     "{ { "
1147     (send self 'gen-value-for-defn-raw value)
1148     ", 0 } }")
1149  )
1150 )
1151
1152 (method-make!
1153  <enum-attribute> 'gen-value-for-defn-raw
1154  (lambda (self value)
1155    (string-upcase
1156     (gen-c-symbol (string-append (obj:str-name self)
1157                                  "_"
1158                                  (symbol->string value))))
1159  )
1160 )
1161
1162 (method-make!
1163  <enum-attribute> 'gen-value-for-defn
1164  (lambda (self value)
1165    (string-append
1166     "{ { "
1167      (send self 'gen-value-for-defn-raw value)
1168      ", 0 } }")
1169  )
1170 )
1171
1172 ;; Doesn't handle escape sequences.
1173 (method-make!
1174  <string-attribute> 'gen-value-for-defn-raw
1175  (lambda (self value)
1176    (string-append "\"" value "\""))
1177 )
1178
1179 (method-make!
1180  <string-attribute> 'gen-value-for-defn
1181  (lambda (self value)
1182    (send self 'gen-value-for-defn-raw value))
1183 )
1184
1185 \f
1186 ; Called before loading a .cpu file to initialize.
1187
1188 (define (attr-init!)
1189
1190   (reader-add-command! 'define-attr
1191                        "\
1192 Define an attribute, name/value pair list version.
1193 "
1194                        nil 'arg-list define-attr)
1195
1196   *UNSPECIFIED*
1197 )
1198
1199 ; Called before a . cpu file is read in to install any builtins.
1200 ; One thing this does is define all attributes requiring a fixed index,
1201 ; keeping them all in one place.
1202 ; ??? Perhaps it would make sense to define all predefined attributes here.
1203
1204 (define (attr-builtin!)
1205   (define-attr '(type boolean) '(name VIRTUAL) '(comment "virtual object"))
1206
1207   ; The meta attribute is used for attributes that aren't to appear in
1208   ; generated output (need a better name).
1209   (define-attr '(for attr) '(type boolean) '(name META))
1210
1211   ; Objects to keep local to a generated file.
1212   (define-attr '(for keyword) '(type boolean) '(name PRIVATE))
1213
1214   ; Attributes requiring fixed indices.
1215   (define-attr '(for attr) '(type boolean) '(name INDEX) '(attrs META))
1216
1217   ; ALIAS is used for instructions that are aliases of more general insns.
1218   ; ALIAS insns are ignored by the simulator.
1219   (define-attr '(for insn) '(type boolean) '(name ALIAS)
1220     '(comment "insn is an alias of another")
1221     '(attrs INDEX))
1222
1223   *UNSPECIFIED*
1224 )
1225
1226 ; Called after loading a .cpu file to perform any post-processing required.
1227
1228 (define (attr-finish!)
1229   *UNSPECIFIED*
1230 )