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