cgen/attr.scm

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