cgen/operand.scm

   1 ; Operands
   2 ; Copyright (C) 2000, 2001, 2005, 2009 Red Hat, Inc.
   3 ; This file is part of CGEN.
   4 ; See file COPYING.CGEN for details.
   5
   6 ; Operands map a set of values (registers, whatever) to an instruction field
   7 ; or other indexing mechanism.  Operands are also how the semantic code refers
   8 ; to hardware elements.
   9
  10 ; The `<operand>' class.
  11 ;
  12 ; ??? Need a new lighterweight version for instances in semantics.
  13 ; This should only contain the static elements from the description file.
  14 ;
  15 ; ??? Derived operands don't use all the current class members.  Perhaps
  16 ; split <operand> into two.
  17
  18 (define <operand>
  19   (class-make '<operand>
  20               '(<source-ident>)
  21               '(
  22                 ; Name as used in semantic code.
  23                 ; Generally this is the same as NAME.  It is changed by the
  24                 ; `operand:' rtx function.  One reason is to set a "pretty"
  25                 ; name in tracing output (most useful in memory operands).
  26                 ; A more important reason is to help match semantic operands
  27                 ; with function unit input/output arguments.
  28                 sem-name
  29
  30                 ; Pretty name as used in tracing code.
  31                 ; Generally this is the same as the hardware element's name.
  32                 pretty-sem-name
  33
  34                 ; Semantic name of hardware element refered to by this operand.
  35                 hw-name
  36
  37                 ; Hardware type of operand, a subclass of <hardware-base>.
  38                 ; This is computed lazily from HW-NAME as many hardware
  39                 ; elements can have the same semantic name.  Applications
  40                 ; that require a unique hardware element to be refered to are
  41                 ; required to ensure duplicates are discarded (usually done
  42                 ; by keeping the appropriate machs).
  43                 ; All h/w elements with the same semantic name are required
  44                 ; to be the same kind (register, immediate, etc.).
  45                 ; FIXME: Rename to hw.
  46                 (type . #f)
  47
  48                 ; Name of mode, as specified in description file.
  49                 ; This needn't be the actual mode, as WI will get coerced
  50                 ; to the actual word int mode.
  51                 mode-name
  52
  53                 ; The mode TYPE is being referenced in.
  54                 ; This is also looked up lazily for the same reasons as TYPE.
  55                 (mode . #f)
  56
  57                 ; Selector.
  58                 ; A number or #f used to select a variant of the hardware
  59                 ; element.  An example is ASI's on sparc.
  60                 ; ??? I really need to be better at picking names.
  61                 (selector . #f)
  62
  63                 ; Index into type, class <hw-index>.
  64                 ; For example in the case of an array of registers
  65                 ; it can be an instruction field or in the case of a memory
  66                 ; reference it can be a register operand (or general rtx).
  67                 ; ??? At present <hw-index> is a facade over the real index
  68                 ; type.  Not sure what the best way to do this is.
  69                 (index . #f)
  70
  71                 ; Code to run when the operand is read or #f meaning pass
  72                 ; the request on to the hardware object.
  73                 (getter . #f)
  74
  75                 ; Code to run when the operand is written or #f meaning pass
  76                 ; the request on to the hardware object.
  77                 (setter . #f)
  78
  79                 ; Associative list of (symbol . "handler") entries.
  80                 ; Each entry maps an operation to its handler (which is up to
  81                 ; the application but is generally a function name).
  82                 (handlers . ())
  83
  84                 ; Ordinal number of the operand in an insn's semantic
  85                 ; description.  There is no relation between the number and
  86                 ; where in the semantics the operand appears.  An operand that
  87                 ; is both read and written are given separate ordinal numbers
  88                 ; (inputs are treated separately from outputs).
  89                 (num . -1)
  90
  91                 ; Boolean indicating if the operand is conditionally
  92                 ; referenced.  #f means the operand is always referenced by
  93                 ; the instruction.
  94                 (cond? . #f)
  95
  96                 ; whether (and by how much) this instance of the operand is
  97                 ; delayed.
  98                 (delayed . #f)
  99                 )
 100               nil)
 101 )
 102
 103 ; The default make! assigns the default h/w selector.
 104
 105 (method-make!
 106  <operand> 'make!
 107  (lambda (self location name comment attrs
 108                hw-name mode-name index handlers getter setter)
 109    (elm-set! self 'location location)
 110    (elm-set! self 'name name)
 111    (elm-set! self 'sem-name name)
 112    (elm-set! self 'pretty-sem-name hw-name)
 113    (elm-set! self 'comment comment)
 114    (elm-set! self 'attrs attrs)
 115    (elm-set! self 'hw-name hw-name)
 116    (elm-set! self 'mode-name mode-name)
 117    (elm-set! self 'selector hw-selector-default)
 118    (elm-set! self 'index index)
 119    (elm-set! self 'handlers handlers)
 120    (elm-set! self 'getter getter)
 121    (elm-set! self 'setter setter)
 122    self)
 123 )
 124
 125 ; FIXME: The prefix field- doesn't seem right.  Indices needn't be
 126 ; ifields, though for operands defined in .cpu files they usually are.
 127 (method-make-forward! <operand> 'index '(field-start field-length))
 128
 129 ; Accessor fns
 130
 131 (define op:sem-name (elm-make-getter <operand> 'sem-name))
 132 (define op:set-sem-name! (elm-make-setter <operand> 'sem-name))
 133 (define op:set-pretty-sem-name! (elm-make-setter <operand> 'pretty-sem-name))
 134 (define op:hw-name (elm-make-getter <operand> 'hw-name))
 135 (define op:mode-name (elm-make-getter <operand> 'mode-name))
 136 (define op:selector (elm-make-getter <operand> 'selector))
 137 ; FIXME: op:index should be named op:hwindex.
 138 (define op:index (elm-make-getter <operand> 'index))
 139 (define op:handlers (elm-make-getter <operand> 'handlers))
 140 (define op:getter (elm-make-getter <operand> 'getter))
 141 (define op:setter (elm-make-getter <operand> 'setter))
 142 (define op:num (elm-make-getter <operand> 'num))
 143 (define op:set-num! (elm-make-setter <operand> 'num))
 144 (define op:cond? (elm-make-getter <operand> 'cond?))
 145 (define op:set-cond?! (elm-make-setter <operand> 'cond?))
 146 (define op:delay (elm-make-getter <operand> 'delayed))
 147 (define op:set-delay! (elm-make-setter <operand> 'delayed))
 148
 149 ; Compute the hardware type lazily.
 150 ; FIXME: op:type should be named op:hwtype or some such.
 151
 152 (define op:type
 153   (let ((getter (elm-make-getter <operand> 'type)))
 154     (lambda (op)
 155       (let ((type (getter op)))
 156         (if type
 157             type
 158             (let* ((hw-name (op:hw-name op))
 159                    (hw-objs (current-hw-sem-lookup hw-name)))
 160               (if (!= (length hw-objs) 1)
 161                   (error "cannot resolve h/w reference" hw-name))
 162               ((elm-make-setter <operand> 'type) op (car hw-objs))
 163               (car hw-objs))))))
 164 )
 165
 166 ; Compute the operand's mode lazily (depends on hardware type which is
 167 ; computed lazily).
 168
 169 (define op:mode
 170   (let ((getter (elm-make-getter <operand> 'mode)))
 171     (lambda (op)
 172       (let ((mode (getter op)))
 173         (if mode
 174             mode
 175             (let ((mode-name (op:mode-name op))
 176                   (type (op:type op)))
 177               (let ((mode (if (eq? mode-name 'DFLT)
 178                               (hw-default-mode type)
 179                               (mode:lookup mode-name))))
 180                 ((elm-make-setter <operand> 'mode) op mode)
 181                 mode))))))
 182 )
 183
 184 (method-make! <operand> 'get-mode (lambda (self) (op:mode self)))
 185
 186 ; FIXME: wip
 187 ; Result is the <ifield> object or #f if there is none.
 188
 189 (define (op-ifield op)
 190   (logit 4 "  op-ifield op= " (obj:name op)
 191          ", indx= " (obj:name (op:index op)) "\n")
 192   (let ((indx (op:index op)))
 193     (if indx
 194         (let ((maybe-ifld (hw-index:value (op:index op))))
 195           (logit 4 "  ifld=" (obj:name maybe-ifld) "\n")
 196           (cond ((ifield? maybe-ifld) maybe-ifld)
 197                 ((derived-ifield? maybe-ifld) maybe-ifld)
 198                 ((ifield? indx) indx)
 199                 ((derived-ifield? indx) indx)
 200                 (else #f)))
 201         #f))
 202 )
 203
 204 ; Return mode to use for index or #f if scalar.
 205 ; This can't use method-make-forward! as we need to call op:type to
 206 ; resolve the hardware reference.
 207
 208 (method-make!
 209  <operand> 'get-index-mode
 210  (lambda (self) (send (op:type self) 'get-index-mode))
 211 )
 212
 213 ; Return the operand's enum.
 214
 215 (define (op-enum op)
 216   (string-upcase (string-append "@ARCH@_OPERAND_" (gen-sym op)))
 217 )
 218
 219 ; Return a boolean indicating if X is an operand.
 220
 221 (define (operand? x) (class-instance? <operand> x))
 222
 223 ; Default gen-pretty-name method.
 224 ; Return a C string of the name intended for users.
 225 ;
 226 ; FIXME: The current implementation is a quick hack.  Parallel execution
 227 ; support can create operands with long names.  e.g. h-memory-add-WI-src2-slo16
 228 ; The eventual way this will be handled is to record with each operand the
 229 ; entry number (or some such) in the operand instance table so that for
 230 ; registers we can compute the register's name.
 231
 232 (method-make!
 233  <operand> 'gen-pretty-name
 234  (lambda (self mode)
 235    (let* ((name (->string (if (elm-bound? self 'pretty-sem-name)
 236                               (elm-get self 'pretty-sem-name)
 237                               (if (elm-bound? self 'sem-name)
 238                                   (elm-get self 'sem-name)
 239                                   (obj:name self)))))
 240           (pname (cond ((string=? "h-memory" (string-take 8 name)) "memory")
 241                        ((string=? "h-" (string-take 2 name)) (string-drop 2 name))
 242                        (else name))))
 243      (string-append "\"" pname "\"")))
 244 )
 245 \f
 246 ; PC support.
 247 ; This is a subclass of <operand>, used to give the simulator a place to
 248 ; hang a couple of methods.
 249 ; At the moment we only support one pc, a reasonable place to stop for now.
 250
 251 (define <pc> (class-make '<pc> '(<operand>) nil nil))
 252
 253 (method-make!
 254  <pc> 'make!
 255  (lambda (self)
 256    (send-next self 'make! (builtin-location) 'pc "program counter"
 257               (atlist-parse (make-prefix-context "make! of pc")
 258                             '(SEM-ONLY) "cgen_operand")
 259               'h-pc
 260               'DFLT
 261               (make <hw-index> 'anonymous
 262                     'ifield 'UINT (current-ifld-lookup 'f-nil))
 263               nil ; handlers
 264               #f #f) ; getter setter
 265    self)
 266 )
 267
 268 ; Return a boolean indicating if operand op is the pc.
 269 ; This must not call op:type.  op:type will try to resolve a hardware
 270 ; element that may be multiply specified, and this is used in contexts
 271 ; where that's not possible.
 272
 273 (define (pc? op) (class-instance? <pc> op))
 274 \f
 275 ; Mode support.
 276
 277 ; Create a copy of operand OP in mode NEW-MODE-NAME.
 278 ; NOTE: Even if the mode isn't changing this creates a copy.
 279 ; If OP has been subclassed the result must contain the complete class
 280 ; (e.g. the behaviour of `object-copy-top').
 281 ; NEW-MODE-NAME must be a valid numeric mode.
 282
 283 (define (op:new-mode op new-mode-name)
 284   (let ((result (object-copy-top op)))
 285     ; (logit 1 "op:new-mode op=" (op:sem-name op)
 286     ;   " class=" (object-class-name op)
 287     ;   " hw-name=" (op:hw-name op)
 288     ;   " mode=" (op:mode op)
 289     ;   " newmode=" new-mode-name)
 290 ;    (if (or (eq? new-mode-name 'DFLT)
 291 ;           (eq? new-mode-name 'VOID) ; temporary: for upward compatibility
 292 ;           (mode:eq? new-mode-name (op:mode op)))
 293 ;       ; Mode isn't changing.
 294 ;       result
 295     (if #t ;; FIXME
 296         ; See if new mode is supported by the hardware.
 297         (if (hw-mode-ok? (op:type op) new-mode-name (op:index op))
 298             (let ((new-mode (mode:lookup new-mode-name)))
 299               (if (not new-mode)
 300                   (error "op:new-mode: internal error, bad mode"
 301                          new-mode-name))
 302               (elm-xset! result 'mode-name new-mode-name)
 303               (elm-xset! result 'mode new-mode)
 304               result)
 305             (parse-error (make-obj-context op "op:new-mode")
 306                          (string-append "invalid mode for operand `"
 307                                         (->string (obj:name op))
 308                                         "'")
 309                          new-mode-name))))
 310 )
 311
 312 ; Return #t if operand OP references its h/w element in its natural mode.
 313
 314 (define (op-natural-mode? op)
 315   (or (eq? (op:mode-name op) 'DFLT)
 316       (mode-compatible? 'samesize (op:mode op) (hw-default-mode (op:type op))))
 317 )
 318 \f
 319 ; Ifield support.
 320
 321 ; Return list of ifields used by OP.
 322
 323 (define (op-iflds-used op)
 324   (if (derived-operand? op)
 325       (collect op-iflds-used (derived-args op))
 326       ; else
 327       (let ((indx (op:index op)))
 328         (if (and (eq? (hw-index:type indx) 'ifield)
 329                  (not (= (ifld-length (hw-index:value indx)) 0)))
 330             (ifld-needed-iflds (hw-index:value indx))
 331             nil)))
 332 )
 333 \f
 334 ; The `hw-index' class.
 335 ; [Was named `index' but that conflicts with the C library function and caused
 336 ; problems when using Hobbit.  And `index' is too generic a name anyway.]
 337 ;
 338 ; An operand combines a hardware object with its index.
 339 ; e.g. in an array of registers an operand serves to combine the register bank
 340 ; with the instruction field that chooses which one.
 341 ; Hardware elements are accessed via other means as well besides instruction
 342 ; fields so we need a way to designate something as being an index.
 343 ; The `hw-index' class does that.  It serves as a facade to the underlying
 344 ; details.
 345 ; ??? Not sure whether this is the best way to handle this or not.
 346 ;
 347 ; NAME is the name of the index or 'anonymous.
 348 ; This is used, for example, to give a name to the simulator extraction
 349 ; structure member.
 350 ; TYPE is a symbol that indicates what VALUE is.
 351 ; scalar: the hardware object is a scalar, no index is required
 352 ;         [MODE and VALUE are #f to denote "undefined" in this case]
 353 ; constant: a (non-negative) integer
 354 ; str-expr: a C expression as a string
 355 ; rtx: an rtx to be expanded
 356 ; ifield: an ifield object
 357 ; operand: an operand object
 358 ; ??? A useful simplification may be to always record the value as an rtx
 359 ; [which may require extensions to rtl so is deferred].
 360 ; ??? We could use runtime type identification, but doing things this way
 361 ; adds more structure.
 362 ;
 363 ; MODE is the mode of VALUE.  If DFLT, mode must be obtained from VALUE.
 364 ; DFLT is only allowable for rtx and operand types.
 365
 366 (define <hw-index> (class-make '<hw-index> nil '(name type mode value) nil))
 367
 368 ; Accessors.
 369 ; Use obj:name for `name'.
 370 (define hw-index:type (elm-make-getter <hw-index> 'type))
 371 (define hw-index:mode (elm-make-getter <hw-index> 'mode))
 372 (define hw-index:value (elm-make-getter <hw-index> 'value))
 373
 374 ; Allow the mode to be specified by its name.
 375 (method-make!
 376  <hw-index> 'make!
 377  (lambda (self name type mode value)
 378    (elm-set! self 'name name)
 379    (elm-set! self 'type type)
 380    (elm-set! self 'mode (mode-maybe-lookup mode))
 381    (elm-set! self 'value value)
 382    self)
 383 )
 384
 385 ; get-name handler
 386 (method-make!
 387  <hw-index> 'get-name
 388  (lambda (self)
 389    (elm-get self 'name))
 390 )
 391
 392 ; get-atlist handler
 393 (method-make!
 394  <hw-index> 'get-atlist
 395  (lambda (self)
 396    (case (hw-index:type self)
 397      ((ifield) (obj-atlist (hw-index:value self)))
 398      (else atlist-empty)))
 399 )
 400
 401 ; ??? Until other things settle.
 402 (method-make!
 403  <hw-index> 'field-start
 404  (lambda (self)
 405    (if (eq? (hw-index:type self) 'ifield)
 406        (send (hw-index:value self) 'field-start)
 407        0))
 408 )
 409 (method-make!
 410  <hw-index> 'field-length
 411  (lambda (self)
 412    (if (eq? (hw-index:type self) 'ifield)
 413        (send (hw-index:value self) 'field-length)
 414        0))
 415 )
 416
 417 ; There only ever needs to be one of these objects, so create one.
 418
 419 (define hw-index-scalar
 420   ; We can't use `make' here as the make! method calls mode:lookup which
 421   ; (a) doesn't exist if we're compiled with Hobbit and mode.scm isn't
 422   ; and (b) will fail anyway since #f isn't a valid mode.
 423   (let ((scalar-index (new <hw-index>)))
 424     (elm-xset! scalar-index 'name 'hw-index-scalar)
 425     (elm-xset! scalar-index 'type 'scalar)
 426     (elm-xset! scalar-index 'mode #f)
 427     (elm-xset! scalar-index 'value #f)
 428     (lambda () scalar-index))
 429 )
 430
 431 ; Placeholder for indices of "anyof" operands.
 432 ; There only needs to be one of these, so we create one and always use that.
 433
 434 (define hw-index-anyof
 435   ; We can't use `make' here as the make! method calls mode:lookup which
 436   ; (a) doesn't exist if we're compiled with Hobbit and mode.scm isn't
 437   ; and (b) will fail anyway since #f isn't a valid mode.
 438   (let ((anyof-index (new <hw-index>)))
 439     (elm-xset! anyof-index 'name 'hw-index-anyof)
 440     (elm-xset! anyof-index 'type 'scalar)
 441     (elm-xset! anyof-index 'mode #f)
 442     (elm-xset! anyof-index 'value #f)
 443     (lambda () anyof-index))
 444 )
 445
 446 (define hw-index-derived
 447   ; We can't use `make' here as the make! method calls mode:lookup which
 448   ; (a) doesn't exist if we're compiled with Hobbit and mode.scm isn't
 449   ; and (b) will fail anyway since #f isn't a valid mode.
 450   (let ((derived-index (new <hw-index>)))
 451     (elm-xset! derived-index 'name 'hw-index-derived)
 452     (elm-xset! derived-index 'type 'scalar)
 453     (elm-xset! derived-index 'mode #f)
 454     (elm-xset! derived-index 'value #f)
 455     (lambda () derived-index))
 456 )
 457 \f
 458 ; Hardware selector support.
 459 ;
 460 ; A hardware "selector" is like an index except is along an atypical axis
 461 ; and thus is rarely used.  It exists to support things like ASI's on Sparc.
 462
 463 ; What to pass to indicate "default selector".
 464 ; (??? value is temporary choice to be revisited).
 465 (define hw-selector-default '(symbol NONE))
 466
 467 (define (hw-selector-default? sel) (equal? sel hw-selector-default))
 468 \f
 469 ; Hardware support.
 470
 471 ; Return list of hardware elements refered to in OP-LIST
 472 ; with no duplicates.
 473
 474 (define (op-nub-hw op-list)
 475   ; Build a list of hw elements.
 476   (let ((hw-list (map (lambda (op)
 477                         (if (hw-ref? op) ; FIXME: hw-ref? is undefined
 478                             op
 479                             (op:type op)))
 480                       op-list)))
 481     ; Now build an alist of (name . obj) elements, take the nub, then the cdr.
 482     ; ??? These lists tend to be small so sorting first is probably overkill.
 483     (map cdr
 484          (alist-nub (alist-sort (map (lambda (hw) (cons (obj:name hw) hw))
 485                                      hw-list)))))
 486 )
 487 \f
 488 ; Parsing support.
 489
 490 ; Utility of /operand-parse-[gs]etter to build the expected syntax,
 491 ; for use in error messages.
 492
 493 (define (/operand-g/setter-syntax rank setter?)
 494   (string-append "("
 495                  (string-drop1
 496                   (numbers->string (iota rank) " index"))
 497                  (if setter?
 498                      (if (>= rank 1)
 499                          " newval"
 500                          "newval")
 501                      "")
 502                  ") (expression)")
 503 )
 504
 505 ; Parse a getter spec.
 506 ; The syntax is (([index-names]) (... code ...)).
 507 ; Omit `index-names' for scalar objects.
 508 ; {rank} is the required number of elements in {index-names}.
 509
 510 (define (/operand-parse-getter context getter rank)
 511   (if (null? getter)
 512       #f ; use default
 513       (let ()
 514         (if (or (not (list? getter))
 515                 (!= (length getter) 2)
 516                 (not (and (list? (car getter))
 517                           (= (length (car getter)) rank))))
 518             (parse-error context
 519                          (string-append "invalid getter, should be "
 520                                         (/operand-g/setter-syntax rank #f))
 521                          getter))
 522         (if (not (rtx? (cadr getter)))
 523             (parse-error context "invalid rtx expression" getter))
 524         getter))
 525 )
 526
 527 ; Parse a setter spec.
 528 ; The syntax is (([index-names] newval) (... code ...)).
 529 ; Omit `index-names' for scalar objects.
 530 ; {rank} is the required number of elements in {index-names}.
 531
 532 (define (/operand-parse-setter context setter rank)
 533   (if (null? setter)
 534       #f ; use default
 535       (let ()
 536         (if (or (not (list? setter))
 537                 (!= (length setter) 2)
 538                 (not (and (list? (car setter))
 539                           (= (+ 1 (length (car setter)) rank)))))
 540             (parse-error context
 541                          (string-append "invalid setter, should be "
 542                                         (/operand-g/setter-syntax rank #t))
 543                          setter))
 544         (if (not (rtx? (cadr setter)))
 545             (parse-error context "invalid rtx expression" setter))
 546         setter))
 547 )
 548
 549 ; Parse an operand definition.
 550 ; This is the main routine for building an operand object from a
 551 ; description in the .cpu file.
 552 ; All arguments are in raw (non-evaluated) form.
 553 ; The result is the parsed object or #f if object isn't for selected mach(s).
 554 ; ??? This only takes insn fields as the index.  May need another proc (or an
 555 ; enhancement of this one) that takes other kinds of indices.
 556
 557 (define (/operand-parse context name comment attrs hw mode ifld handlers getter setter)
 558   (logit 2 "Processing operand " name " ...\n")
 559
 560   ;; Pick out name first to augment the error context.
 561   (let* ((name (parse-name context name))
 562          (context (context-append-name context name))
 563          (atlist-obj (atlist-parse context attrs "cgen_operand")))
 564
 565     (if (keep-atlist? atlist-obj #f)
 566
 567         (let ((hw-objs (current-hw-sem-lookup hw))
 568               (mode-obj (parse-mode-name context mode))
 569               (ifld-val (if (integer? ifld)
 570                             ifld
 571                             (current-ifld-lookup ifld))))
 572
 573           (if (not mode-obj)
 574               (parse-error context "unknown mode" mode))
 575           (if (not ifld-val)
 576               (parse-error context "unknown insn field" ifld))
 577           ; Disallow some obviously invalid numeric indices.
 578           (if (and (integer? ifld-val)
 579                    (< ifld-val 0))
 580               (parse-error context "invalid integer index" ifld-val))
 581           ; Don't validate HW until we know whether this operand will be kept
 582           ; or not.  If not, HW may have been discarded too.
 583           (if (null? hw-objs)
 584               (parse-error context "unknown hardware element" hw))
 585
 586           ; At this point IFLD-VAL is either an integer or an <ifield> object.
 587           ; Since we can't look up the hardware element at this time
 588           ; [well, actually we should be able to with a bit of work],
 589           ; we determine scalarness from the index.
 590           (let* ((scalar? (or (integer? ifld-val) (ifld-nil? ifld-val)))
 591                  (hw-index
 592                   (if (integer? ifld-val)
 593                       (make <hw-index> (symbol-append 'i- name)
 594                             ; FIXME: constant -> const
 595                             'constant 'UINT ifld-val)
 596                       (if scalar?
 597                           (hw-index-scalar)
 598                           (make <hw-index> (symbol-append 'i- name)
 599                                 'ifield 'UINT ifld-val)))))
 600             (make <operand>
 601               (context-location context)
 602               name
 603               (parse-comment context comment)
 604               ; Copy FLD's attributes so one needn't duplicate attrs like
 605               ; PCREL-ADDR, etc.  An operand inherits the attributes of
 606               ; its field.  They are overridable of course, which is why we use
 607               ; `atlist-append' here.
 608               (if (integer? ifld-val)
 609                   atlist-obj
 610                   (atlist-append atlist-obj (obj-atlist ifld-val)))
 611               hw   ; note that this is the hw's name, not an object
 612               mode ; ditto, this is a name, not an object
 613               hw-index
 614               (parse-handlers context '(parse print) handlers)
 615               (/operand-parse-getter context getter (if scalar? 0 1))
 616               (/operand-parse-setter context setter (if scalar? 0 1))
 617               )))
 618
 619         (begin
 620           (logit 2 "Ignoring " name ".\n")
 621           #f)))
 622 )
 623
 624 ; Read an operand description.
 625 ; This is the main routine for analyzing operands in the .cpu file.
 626 ; CONTEXT is a <context> object for error messages.
 627 ; ARG-LIST is an associative list of field name and field value.
 628 ; /operand-parse is invoked to create the <operand> object.
 629
 630 (define (/operand-read context . arg-list)
 631   (let (
 632         (name nil)
 633         (comment nil)
 634         (attrs nil)
 635         (type nil)
 636         (mode 'DFLT)     ; use default mode of TYPE
 637         (index nil)
 638         (handlers nil)
 639         (getter nil)
 640         (setter nil)
 641         )
 642
 643     (let loop ((arg-list arg-list))
 644       (if (null? arg-list)
 645           nil
 646           (let ((arg (car arg-list))
 647                 (elm-name (caar arg-list)))
 648             (case elm-name
 649               ((name) (set! name (cadr arg)))
 650               ((comment) (set! comment (cadr arg)))
 651               ((attrs) (set! attrs (cdr arg)))
 652               ((type) (set! type (cadr arg)))
 653               ((mode) (set! mode (cadr arg)))
 654               ((index) (set! index (cadr arg)))
 655               ((handlers) (set! handlers (cdr arg)))
 656               ((getter) (set! getter (cdr arg)))
 657               ((setter) (set! setter (cdr arg)))
 658               (else (parse-error context "invalid operand arg" arg)))
 659             (loop (cdr arg-list)))))
 660
 661     ; Now that we've identified the elements, build the object.
 662     (/operand-parse context name comment attrs type mode index handlers
 663                     getter setter))
 664 )
 665
 666 ; Define an operand object, name/value pair list version.
 667
 668 (define define-operand
 669   (lambda arg-list
 670     (let ((op (apply /operand-read (cons (make-current-context "define-operand")
 671                                          arg-list))))
 672       (if op
 673           (current-op-add! op))
 674       op))
 675 )
 676
 677 ; Define an operand object, all arguments specified.
 678
 679 (define (define-full-operand name comment attrs type mode index handlers getter setter)
 680   (let ((op (/operand-parse (make-current-context "define-full-operand")
 681                             name comment attrs
 682                             type mode index handlers getter setter)))
 683     (if op
 684         (current-op-add! op))
 685     op)
 686 )
 687 \f
 688 ; Derived operands.
 689 ;
 690 ; Derived operands are used to implement operands more complex than just
 691 ; the mapping of an instruction field to a register bank.  Their present
 692 ; raison d'etre is to create a new axis on which to implement the complex
 693 ; addressing modes of the i386 and m68k.  The brute force way of describing
 694 ; these instruction sets would be to have one `dni' per addressing mode
 695 ; per instruction.  What's needed is to abstract away the various addressing
 696 ; modes within something like operands.
 697 ;
 698 ; ??? While internally we end up with the "brute force" approach, in and of
 699 ; itself that's ok because it's an internal implementation issue.
 700 ; See <multi-insn>.
 701 ;
 702 ; ??? Another way to go is to have one dni per addressing mode.  That seems
 703 ; less clean though as one dni would be any of add, sub, and, or, xor, etc.
 704 ;
 705 ; ??? Some addressing modes have side-effects (e.g. pre-dec, etc. like insns).
 706 ; This can be represented, but if two operands have side-effects special
 707 ; trickery may be required to get the order of side-effects right.  Need to
 708 ; avoid any "trickery" at all.
 709 ;
 710 ; ??? Not yet handled are modelling parameters.
 711 ; ??? Not yet handled are the handlers,getter,setter spec of normal operands.
 712 ;
 713 ; ??? Division of class members b/w <operand> and <derived-operand> is wip.
 714 ; ??? As is potential introduction of other classes to properly organize
 715 ; things.
 716
 717 (define <derived-operand>
 718   (class-make '<derived-operand>
 719               '(<operand>)
 720               '(
 721                 ; Args (list of <operands> objects).
 722                 args
 723
 724                 ; Syntax string.
 725                 syntax
 726
 727                 ; Base ifield, common to all choices.
 728                 ; ??? experiment
 729                 base-ifield
 730
 731                 ; <derived-ifield> object.
 732                 encoding
 733
 734                 ; Assertions of any ifield values or #f if none.
 735                 (ifield-assertion . #f)
 736                 )
 737               '())
 738 )
 739
 740 ;; <derived-operand> constructor.
 741 ;; MODE is a <mode> object.
 742
 743 (method-make!
 744  <derived-operand> 'make!
 745  (lambda (self name comment attrs mode
 746                args syntax base-ifield encoding ifield-assertion
 747                getter setter)
 748    (elm-set! self 'name name)
 749    (elm-set! self 'comment comment)
 750    (elm-set! self 'attrs attrs)
 751    (elm-set! self 'sem-name name)
 752    (elm-set! self 'pretty-sem-name #f) ;; FIXME
 753    (elm-set! self 'hw-name #f) ;; FIXME
 754    (elm-set! self 'mode mode)
 755    (elm-set! self 'mode-name (obj:name mode))
 756    (elm-set! self 'getter getter)
 757    (elm-set! self 'setter setter)
 758    ;; These are the additional fields in <derived-operand>.
 759    (elm-set! self 'args args)
 760    (elm-set! self 'syntax syntax)
 761    (elm-set! self 'base-ifield base-ifield)
 762    (elm-set! self 'encoding encoding)
 763    (elm-set! self 'ifield-assertion ifield-assertion)
 764    self)
 765 )
 766
 767 (define (derived-operand? x) (class-instance? <derived-operand> x))
 768
 769 (define-getters <derived-operand> derived
 770   (args syntax base-ifield encoding ifield-assertion)
 771 )
 772
 773 ; "anyof" operands are subclassed from derived operands.
 774 ; They typically handle multiple addressing modes of CISC architectures.
 775
 776 (define <anyof-operand>
 777   (class-make '<anyof-operand>
 778               '(<operand>)
 779               '(
 780                 ; Base ifield, common to all choices.
 781                 ; FIXME: wip
 782                 base-ifield
 783
 784                 ; List of <derived-operand> objects.
 785                 ; ??? Maybe allow <operand>'s too?
 786                 choices
 787                 )
 788               '())
 789 )
 790
 791 (define (anyof-operand? x) (class-instance? <anyof-operand> x))
 792
 793 (method-make!
 794  <anyof-operand> 'make!
 795  (lambda (self name comment attrs mode-name base-ifield choices)
 796    (elm-set! self 'name name)
 797    (elm-set! self 'comment comment)
 798    (elm-set! self 'attrs attrs)
 799    (elm-set! self 'sem-name name)
 800    (elm-set! self 'pretty-sem-name #f) ;; FIXME
 801    (elm-set! self 'hw-name #f) ;; FIXME
 802    (elm-set! self 'mode-name mode-name)
 803    (elm-set! self 'base-ifield base-ifield)
 804    (elm-set! self 'choices choices)
 805    ; Set index to a special marker value.
 806    (elm-set! self 'index (hw-index-anyof))
 807    self)
 808 )
 809
 810 (define-getters <anyof-operand> anyof (choices))
 811 \f
 812 ; Derived/Anyof parsing support.
 813
 814 ; Subroutine of /derived-operand-parse to parse the encoding.
 815 ; The result is a <derived-ifield> object.
 816 ; The {owner} member still needs to be set!
 817
 818 (define (/derived-parse-encoding context operand-name encoding)
 819   (if (or (null? encoding)
 820           (not (list? encoding)))
 821       (parse-error context "encoding not a list" encoding))
 822   (if (not (eq? (car encoding) '+))
 823       (parse-error context "encoding must begin with `+'" encoding))
 824
 825   ; ??? Calling /parse-insn-format is a quick hack.
 826   ; It's an internal routine of some other file.
 827   (let ((iflds (/parse-insn-format context #f #f encoding)))
 828     (make <derived-ifield>
 829           operand-name
 830           'derived-ifield ; (string-append "<derived-ifield> for " operand-name)
 831           atlist-empty
 832           #f ; owner
 833           iflds ; subfields
 834           ))
 835 )
 836
 837 ;; Subroutine of /derived-operand-parse to parse the ifield assertion.
 838 ;; The ifield assertion is either () or a (restricted) RTL expression
 839 ;; asserting something about the ifield values of the containing insn.
 840 ;; The result is #f if the assertion is (), or the canonical rtl.
 841
 842 (define (/derived-parse-ifield-assertion context ifield-assertion)
 843   (if (null? ifield-assertion)
 844       #f
 845       (rtx-canonicalize context 'INT ifield-assertion nil))
 846 )
 847
 848 ; Parse a derived operand definition.
 849 ; This is the main routine for building a derived operand object from a
 850 ; description in the .cpu file.
 851 ; All arguments are in raw (non-evaluated) form.
 852 ; The result is the parsed object or #f if object isn't for selected mach(s).
 853 ;
 854 ; ??? Currently no support for handlers(,???) found in normal operands.
 855 ; Later, when necessary.
 856
 857 (define (/derived-operand-parse context name comment attrs mode
 858                                 args syntax
 859                                 base-ifield encoding ifield-assertion
 860                                 getter setter)
 861   (logit 2 "Processing derived operand " name " ...\n")
 862
 863   ;; Pick out name first to augment the error context.
 864   (let* ((name (parse-name context name))
 865          (context (context-append-name context name))
 866          (atlist-obj (atlist-parse context attrs "cgen_operand")))
 867
 868     (if (keep-atlist? atlist-obj #f)
 869
 870         (let ((mode-obj (parse-mode-name context mode))
 871               (parsed-encoding (/derived-parse-encoding context name encoding)))
 872
 873           (if (not mode-obj)
 874               (parse-error context "unknown mode" mode))
 875
 876           (let ((result
 877                  (make <derived-operand>
 878                        name
 879                        (parse-comment context comment)
 880                        atlist-obj
 881                        mode-obj
 882                        (map (lambda (a)
 883                               (if (not (symbol? a))
 884                                   (parse-error context "arg not a symbol" a))
 885                               (let ((op (current-op-lookup a)))
 886                                 (if (not op)
 887                                     (parse-error context "not an operand" a))
 888                                 op))
 889                             args)
 890                        syntax
 891                        base-ifield ; FIXME: validate
 892                        parsed-encoding
 893                        (/derived-parse-ifield-assertion context ifield-assertion)
 894                        (if (null? getter)
 895                            #f
 896                            (/operand-parse-getter context
 897                                                   (list args
 898                                                         (rtx-canonicalize context mode getter nil))
 899                                                   (length args)))
 900                        (if (null? setter)
 901                            #f
 902                            (/operand-parse-setter context
 903                                                   (list (append args '(newval))
 904                                                         (rtx-canonicalize context 'VOID setter
 905                                                                           (list (list 'newval mode #f))))
 906                                                   (length args)))
 907                        )))
 908             (elm-set! result 'hw-name (obj:name (hardware-for-mode mode-obj)))
 909             ;(elm-set! result 'hw-name (obj:name parsed-encoding))
 910             ;(elm-set! result 'hw-name base-ifield)
 911             (elm-set! result 'index parsed-encoding)
 912             ; (elm-set! result 'index (hw-index-derived)) ; A temporary dummy
 913             (logit 2 "  new derived-operand; name= " name
 914                    ", hw-name= " (op:hw-name result)
 915                    ", index=" (obj:name parsed-encoding) "\n")
 916             (derived-ifield-set-owner! parsed-encoding result)
 917             result))
 918
 919         (begin
 920           (logit 2 "Ignoring " name ".\n")
 921           #f)))
 922 )
 923
 924 ; Read a derived operand description.
 925 ; This is the main routine for analyzing derived operands in the .cpu file.
 926 ; CONTEXT is a <context> object for error messages.
 927 ; ARG-LIST is an associative list of field name and field value.
 928 ; /derived-operand-parse is invoked to create the <derived-operand> object.
 929
 930 (define (/derived-operand-read context . arg-list)
 931   (let (
 932         (name nil)
 933         (comment nil)
 934         (attrs nil)
 935         (mode 'DFLT)     ; use default mode of TYPE
 936         (args nil)
 937         (syntax nil)
 938         (base-ifield nil)
 939         (encoding nil)
 940         (ifield-assertion nil)
 941         (getter nil)
 942         (setter nil)
 943         )
 944
 945     (let loop ((arg-list arg-list))
 946       (if (null? arg-list)
 947           nil
 948           (let ((arg (car arg-list))
 949                 (elm-name (caar arg-list)))
 950             (case elm-name
 951               ((name) (set! name (cadr arg)))
 952               ((comment) (set! comment (cadr arg)))
 953               ((attrs) (set! attrs (cdr arg)))
 954               ((mode) (set! mode (cadr arg)))
 955               ((args) (set! args (cadr arg)))
 956               ((syntax) (set! syntax (cadr arg)))
 957               ((base-ifield) (set! base-ifield (cadr arg)))
 958               ((encoding) (set! encoding (cadr arg)))
 959               ((ifield-assertion) (set! ifield-assertion (cadr arg)))
 960               ((getter) (set! getter (cadr arg)))
 961               ((setter) (set! setter (cadr arg)))
 962               (else (parse-error context "invalid derived-operand arg" arg)))
 963             (loop (cdr arg-list)))))
 964
 965     ; Now that we've identified the elements, build the object.
 966     (/derived-operand-parse context name comment attrs mode args
 967                             syntax base-ifield encoding ifield-assertion
 968                             getter setter))
 969 )
 970
 971 ; Define a derived operand object, name/value pair list version.
 972
 973 (define define-derived-operand
 974   (lambda arg-list
 975     (let ((op (apply /derived-operand-read
 976                      (cons (make-current-context "define-derived-operand")
 977                            arg-list))))
 978       (if op
 979           (current-op-add! op))
 980       op))
 981 )
 982
 983 ; Define a derived operand object, all arguments specified.
 984 ; ??? Not supported (yet).
 985 ;
 986 ;(define (define-full-derived-operand name comment attrs mode ...)
 987 ;  (let ((op (/derived-operand-parse (make-current-context "define-full-derived-operand")
 988 ;                                   name comment attrs
 989 ;                                   mode ...)))
 990 ;    (if op
 991 ;       (current-op-add! op))
 992 ;    op)
 993 ;)
 994
 995 ; Parse an "anyof" choice, which is a derived-operand name.
 996 ; The result is {choice} unchanged.
 997
 998 (define (/anyof-parse-choice context choice)
 999   (if (not (symbol? choice))
1000       (parse-error context "anyof choice not a symbol" choice))
1001   (let ((op (current-op-lookup choice)))
1002     (if (not (derived-operand? op))
1003         (parse-error context "anyof choice not a derived-operand" choice))
1004     op)
1005 )
1006
1007 ; Parse an "anyof" derived operand.
1008 ; This is the main routine for building a derived operand object from a
1009 ; description in the .cpu file.
1010 ; All arguments are in raw (non-evaluated) form.
1011 ; The result is the parsed object or #f if object isn't for selected mach(s).
1012 ;
1013 ; ??? Currently no support for handlers(,???) found in normal operands.
1014 ; Later, when necessary.
1015
1016 (define (/anyof-operand-parse context name comment attrs mode
1017                               base-ifield choices)
1018   (logit 2 "Processing anyof operand " name " ...\n")
1019
1020   ;; Pick out name first to augment the error context.
1021   (let* ((name (parse-name context name))
1022          (context (context-append-name context name))
1023          (atlist-obj (atlist-parse context attrs "cgen_operand")))
1024
1025     (if (keep-atlist? atlist-obj #f)
1026
1027         (let ((mode-obj (parse-mode-name context mode)))
1028           (if (not mode-obj)
1029               (parse-error context "unknown mode" mode))
1030
1031           (make <anyof-operand>
1032                 name
1033                 (parse-comment context comment)
1034                 atlist-obj
1035                 mode
1036                 base-ifield
1037                 (map (lambda (c)
1038                        (/anyof-parse-choice context c))
1039                      choices)))
1040
1041         (begin
1042           (logit 2 "Ignoring " name ".\n")
1043           #f)))
1044 )
1045
1046 ; Read an anyof operand description.
1047 ; This is the main routine for analyzing anyof operands in the .cpu file.
1048 ; CONTEXT is a <context> object for error messages.
1049 ; ARG-LIST is an associative list of field name and field value.
1050 ; /anyof-operand-parse is invoked to create the <anyof-operand> object.
1051
1052 (define (/anyof-operand-read context . arg-list)
1053   (let (
1054         (name nil)
1055         (comment nil)
1056         (attrs nil)
1057         (mode 'DFLT)     ; use default mode of TYPE
1058         (base-ifield nil)
1059         (choices nil)
1060         )
1061
1062     (let loop ((arg-list arg-list))
1063       (if (null? arg-list)
1064           nil
1065           (let ((arg (car arg-list))
1066                 (elm-name (caar arg-list)))
1067             (case elm-name
1068               ((name) (set! name (cadr arg)))
1069               ((comment) (set! comment (cadr arg)))
1070               ((attrs) (set! attrs (cdr arg)))
1071               ((mode) (set! mode (cadr arg)))
1072               ((base-ifield) (set! base-ifield (cadr arg)))
1073               ((choices) (set! choices (cdr arg)))
1074               (else (parse-error context "invalid anyof-operand arg" arg)))
1075             (loop (cdr arg-list)))))
1076
1077     ; Now that we've identified the elements, build the object.
1078     (/anyof-operand-parse context name comment attrs mode base-ifield choices))
1079 )
1080
1081 ; Define an anyof operand object, name/value pair list version.
1082
1083 (define define-anyof-operand
1084   (lambda arg-list
1085     (let ((op (apply /anyof-operand-read
1086                      (cons (make-current-context "define-anyof-operand")
1087                            arg-list))))
1088       (if op
1089           (current-op-add! op))
1090       op))
1091 )
1092 \f
1093 ; Utilities to flatten out the <anyof-operand> derivation heirarchy.
1094
1095 ; Utility class used when instantiating insns with derived operands.
1096 ; This collects together in one place all the appropriate data of an
1097 ; instantiated "anyof" operand.
1098
1099 (define <anyof-instance>
1100   (class-make '<anyof-instance>
1101               '(<derived-operand>)
1102               '(
1103                 ; <anyof-operand> object we were instantiated from.
1104                 parent
1105                 )
1106               nil)
1107 )
1108
1109 (method-make-make! <anyof-instance>
1110                    '(name comment attrs mode
1111                           args syntax base-ifield encoding ifield-assertion
1112                           getter setter parent)
1113 )
1114
1115 (define-getters <anyof-instance> anyof-instance (parent))
1116
1117 (define (anyof-instance? x) (class-instance? <anyof-instance> x))
1118
1119 ; Return initial list of known ifield values in {anyof-instance}.
1120
1121 (define (/anyof-initial-known anyof-instance)
1122   (assert (derived-operand? anyof-instance))
1123   (let ((encoding (derived-encoding anyof-instance)))
1124     (assert (derived-ifield? encoding))
1125     (ifld-known-values (derived-ifield-subfields encoding)))
1126 )
1127
1128 ; Return true if {anyof-instance} satisfies its ifield assertions.
1129 ; {known-values} is the {known} argument to rtx-solve.
1130
1131 (define (anyof-satisfies-assertions? anyof-instance known-values)
1132   (assert (derived-operand? anyof-instance))
1133   (let ((assertion (derived-ifield-assertion anyof-instance)))
1134     (if assertion
1135         (rtx-solve #f ; FIXME: context
1136                    anyof-instance ; owner
1137                    assertion
1138                    known-values)
1139         #t))
1140 )
1141
1142 ; Subroutine of /anyof-merge-subchoices.
1143 ; Merge syntaxes of VALUE-NAMES/VALUES into SYNTAX.
1144 ;
1145 ; Example:
1146 ; If SYNTAX is "$a+$b", and VALUE-NAMES is (b), and VALUES is
1147 ; ("$c+$d"-object), then return "$a+$c+$d".
1148
1149 (define (/anyof-syntax anyof-instance)
1150   (elm-get anyof-instance 'syntax)
1151 )
1152
1153 (define (/anyof-name anyof-instance)
1154   (elm-get anyof-instance 'name)
1155 )
1156
1157 (define (/anyof-merge-syntax syntax value-names values)
1158   (let ((syntax-elements (syntax-break-out syntax)))
1159     (syntax-make (map (lambda (e)
1160                         (if (anyof-operand? e)
1161                             (let* ((name (obj:name e))
1162                                    (indx (element-lookup-index name value-names 0)))
1163                               (if (not indx)
1164                                 (error "Name " name " not one of " values)
1165                                 )
1166                               (/anyof-syntax (list-ref values indx)))
1167                             e))
1168                       syntax-elements)))
1169 )
1170
1171 ; Subroutine of /anyof-merge-subchoices.
1172 ; Merge syntaxes of {value-names}/{values} into <derived-ifield> {encoding}.
1173 ; The result is a new <derived-ifield> object with subfields matching
1174 ; {value-names} replaced with {values}.
1175 ; {container} is the containing <anyof-operand>.
1176 ;
1177 ; Example:
1178 ; If {encoding} is (a-ifield-object b-anyof-ifield-object), and {value-names}
1179 ; is (b), and {values} is (c-choice-of-b-object), then return
1180 ; (a-ifield-object c-choice-of-b-ifield-object).
1181
1182 (define (/anyof-merge-encoding container encoding value-names values)
1183   (assert (derived-ifield? encoding))
1184   (let ((subfields (derived-ifield-subfields encoding))
1185         (result (object-copy-top encoding)))
1186     ; Delete all the elements that are being replaced with ifields from
1187     ; {values} and add the new ifields.
1188     (derived-ifield-set-subfields! result
1189                                    (append
1190                                     (find (lambda (f)
1191                                             (not (memq (obj:name f) value-names)))
1192                                           subfields)
1193                                     (map derived-encoding values)))
1194     result)
1195 )
1196
1197 ; Subroutine of /anyof-merge-subchoices.
1198 ; Merge semantics of VALUE-NAMES/VALUES into GETTER.
1199 ;
1200 ; Example:
1201 ; If GETTER is (mem QI foo), and VALUE-NAMES is (foo), and VALUES is
1202 ; ((add a b)-object), then return (mem QI (add a b)).
1203
1204 (define (/anyof-merge-getter getter value-names values)
1205   ;(debug-repl-env getter value-names values)
1206   ; ??? This implementation is a quick hack, intended to evolve or be replaced.
1207   (cond ((not getter)
1208          #f)
1209         (else
1210          (map (lambda (e)
1211                 (cond ((symbol? e)
1212                        (let ((indx (element-lookup-index e value-names 0)))
1213                          (if indx
1214                              (op:getter (list-ref values indx))
1215                              e)))
1216                       ((pair? e) ; pair? -> cheap non-null-list?
1217                        (/anyof-merge-getter e value-names values))
1218                       (else
1219                        e)))
1220               getter)))
1221 )
1222
1223 ; Subroutine of /anyof-merge-subchoices.
1224 ; Merge semantics of VALUE-NAMES/VALUES into SETTER.
1225 ;
1226 ; Example:
1227 ; If SETTER is (set (mem QI foo) newval), and VALUE-NAMES is (foo),
1228 ; and VALUES is ((add a b)-object), then return
1229 ; (set (mem QI (add a b)) newval).
1230 ;
1231 ; ??? `newval' in this context is a reserved word.
1232
1233 (define (/anyof-merge-setter setter value-names values)
1234   ;(debug-repl-env setter value-names values)
1235   ; ??? This implementation is a quick hack, intended to evolve or be replaced.
1236   (cond ((not setter)
1237          #f)
1238         ((rtx-single-set? setter)
1239          (let ((src (rtx-set-src setter))
1240                (dest (rtx-set-dest setter))
1241                (mode (rtx-mode setter))
1242                (options (rtx-options setter)))
1243            (if (rtx-kind 'mem dest)
1244                (set! dest
1245                      (rtx-change-address dest
1246                                          (/anyof-merge-getter
1247                                           (rtx-mem-addr dest)
1248                                           value-names values))))
1249            (set! src (/anyof-merge-getter src value-names values))
1250            (rtx-make 'set options mode dest src)))
1251         (else
1252          (error "/anyof-merge-setter: unsupported form" (car setter))))
1253 )
1254
1255 ; Subroutine of -sub-insn-make!.
1256 ; Merge semantics of VALUE-NAMES/VALUES into SEMANTICS.
1257 ; Defined here and not in insn.scm to keep it with the getter/setter mergers.
1258 ;
1259 ; Example:
1260 ; If SEMANTICS is (mem QI foo), and VALUE-NAMES is (foo), and VALUES is
1261 ; ((add a b)-object), then return (mem QI (add a b)).
1262
1263 (define (anyof-merge-semantics semantics value-names values)
1264   ;(debug-repl-env semantics value-names values)
1265   ; ??? This implementation is a quick hack, intended to evolve or be replaced.
1266   (let ((result
1267          (cond ((not semantics)
1268                 #f)
1269                (else
1270                 (map (lambda (e)
1271                        (cond ((symbol? e)
1272                               (let ((indx (element-lookup-index e value-names 0)))
1273                                 (if indx
1274                                     (/anyof-name (list-ref values indx))
1275                                     ; (op:sem-name (list-ref values indx))
1276                                     e)))
1277                              ((pair? e) ; pair? -> cheap non-null-list?
1278                               (anyof-merge-semantics e value-names values))
1279                              (else
1280                               e)))
1281                      semantics)))))
1282     (logit 4 "  merged semantics: [" semantics "] -> [" result "]\n")
1283     result)
1284 )
1285
1286 ; Subroutine of /anyof-merge-subchoices.
1287 ; Merge assertion of VALUE-NAMES/VALUES into ASSERTION.
1288 ;
1289 ; Example:
1290 ; If ASSERTION is (ne f-base-reg 5), and VALUE-NAMES is
1291 ; (foo), and VALUES is ((ne f-mod 0)), then return
1292 ; (andif (ne f-base-reg 5) (ne f-mod 0)).
1293 ;
1294 ; FIXME: Perform simplification pass, based on combined set of known
1295 ; ifield values.
1296
1297 (define (/anyof-merge-ifield-assertion assertion value-names values)
1298   (let ((assertions (find identity
1299                           (cons assertion
1300                                 (map derived-ifield-assertion values)))))
1301     (if (null? assertions)
1302         #f
1303         (rtx-combine 'andif assertions)))
1304 )
1305
1306 ; Subroutine of /anyof-all-subchoices.
1307 ; Return a copy of <derived-operand> CHOICE with NEW-ARGS from ANYOF-ARGS
1308 ; merged in.  This is for when a derived operand is itself composed of
1309 ; anyof operands.
1310 ; ANYOF-ARGS is a list of <anyof-operand>'s to be replaced in CHOICE.
1311 ; NEW-ARGS is a corresponding list of values (<derived-operands>'s) of each
1312 ; element in ANYOF-ARGS.
1313 ; CONTAINER is the <anyof-operand> containing CHOICE.
1314
1315 (define (/anyof-merge-subchoices container choice anyof-args new-args)
1316   (assert (all-true? (map anyof-operand? anyof-args)))
1317   (assert (all-true? (map derived-operand? new-args)))
1318
1319   (let* ((arg-names (map obj:name anyof-args))
1320          (encoding (/anyof-merge-encoding container (derived-encoding choice)
1321                                           arg-names new-args))
1322          (result
1323           (make <anyof-instance>
1324                 (apply symbol-append
1325                        (cons (obj:name choice)
1326                              (map (lambda (anyof)
1327                                     (symbol-append '- (obj:name anyof)))
1328                                   new-args)))
1329                 (obj:comment choice)
1330                 (obj-atlist choice)
1331                 (op:mode choice)
1332                 (derived-args choice)
1333                 (/anyof-merge-syntax (derived-syntax choice)
1334                                      arg-names new-args)
1335                 (derived-base-ifield choice)
1336                 encoding
1337                 (/anyof-merge-ifield-assertion (derived-ifield-assertion choice)
1338                                                anyof-args new-args)
1339                 (/anyof-merge-getter (op:getter choice)
1340                                      arg-names new-args)
1341                 (/anyof-merge-setter (op:setter choice)
1342                                      arg-names new-args)
1343                 container)))
1344
1345     (elm-set! result 'index encoding)
1346     ; Creating the link from {encoding} to {result}.
1347     (derived-ifield-set-owner! encoding result)
1348     result)
1349 )
1350
1351 ; Subroutine of /anyof-all-choices-1.
1352 ; Return a list of all possible subchoices of <derived-operand> ANYOF-CHOICE,
1353 ; known to use <anyof-operand>'s itself.
1354 ; CONTAINER is the containing <anyof-operand>.
1355
1356 (define (/anyof-all-subchoices container anyof-choice)
1357   ; Split args into anyof and non-anyof elements.
1358   (let* ((args (derived-args anyof-choice))
1359          (anyof-args (find anyof-operand? args)))
1360
1361     (assert (not (null? anyof-args)))
1362
1363     ; Iterate over all combinations.
1364     ; {todo} is a list with one element for each anyof argument.
1365     ; Each element is in turn a list of all <derived-operand> choices for the
1366     ; <anyof-operand>.  The result we want is every possible combination.
1367     ; Example:
1368     ; If {todo} is ((1 2 3) (a) (B C)) the result we want is
1369     ; ((1 a B) (1 a C) (2 a B) (2 a C) (3 a B) (3 a C)).
1370     ;
1371     ; Note that some of these values may be derived from nested
1372     ; <anyof-operand>'s which is why we recursively call /anyof-all-choices-1.
1373     ; ??? /anyof-all-choices-1 should cache the results.
1374
1375     (let* ((todo (map /anyof-all-choices-1 anyof-args))
1376            (lengths (map length todo))
1377            (total (apply * lengths))
1378            (result nil))
1379
1380       ; ??? One might prefer a `do' loop here, but every time I see one I
1381       ; have to spend too long remembering its syntax.
1382       (let loop ((i 0))
1383         (if (< i total)
1384             (let* ((indices (split-value lengths i))
1385                    (new-args (map list-ref todo indices)))
1386               ;(display "new-args: " (current-error-port))
1387               ;(display (map obj:name new-args) (current-error-port))
1388               ;(newline (current-error-port))
1389               (set! result
1390                     (cons (/anyof-merge-subchoices container
1391                                                    anyof-choice
1392                                                    anyof-args
1393                                                    new-args)
1394                           result))
1395               (loop (+ i 1)))))
1396
1397       result))
1398 )
1399
1400 ; Return an <anyof-instance> object from <derived-operand> {derop}, which is a
1401 ; choice of {anyof-operand}.
1402
1403 (define (/anyof-instance-from-derived anyof-operand derop)
1404   (let* ((encoding (object-copy-top (derived-encoding derop)))
1405          (result
1406           (make <anyof-instance>
1407                 (obj:name derop)
1408                 (obj:comment derop)
1409                 (obj-atlist derop)
1410                 (op:mode derop)
1411                 (derived-args derop)
1412                 (derived-syntax derop)
1413                 (derived-base-ifield derop)
1414                 encoding
1415                 (derived-ifield-assertion derop)
1416                 (op:getter derop)
1417                 (op:setter derop)
1418                 anyof-operand)))
1419     ; Creating the link from {encoding} to {result}.
1420     (derived-ifield-set-owner! encoding result)
1421     result)
1422 )
1423
1424 ; Return list of <anyof-instance> objects, one for each possible variant of
1425 ; ANYOF-OPERAND.
1426 ;
1427 ; One could move this up into the cpu description file using pmacros.
1428 ; However, that's not the right way to go.  How we currently implement
1429 ; the notion of derived operands is separate from the notion of having them
1430 ; in the description language.  pmacros are not "in" the language (to the
1431 ; extent that the cpu description file reader "sees" them), they live
1432 ; above it.  And the right way to do this is with something "in" the language.
1433 ; Derived operands are the first cut at it.  They'll evolve or be replaced
1434 ; (and it's the implementation of them that will evolve first).
1435
1436 (define (/anyof-all-choices-1 anyof-operand)
1437   (assert (anyof-operand? anyof-operand))
1438
1439   (let ((result nil))
1440
1441     ; For each choice, scan the operands for further derived operands.
1442     ; If found, replace the choice with the list of its subchoices.
1443     ; If not found, create an <anyof-instance> object for it.  This is
1444     ; basically just a copy of the object, but {anyof-operand} is recorded
1445     ; with it so that we can later resolve `follows' specs.
1446
1447     (let loop ((choices (anyof-choices anyof-operand)))
1448       (if (not (null? choices))
1449           (let* ((this (car choices))
1450                  (args (derived-args this)))
1451
1452             (if (any-true? (map anyof-operand? args))
1453
1454                 ; This operand has "anyof" operands so we need to turn this
1455                 ; choice into a list of all possible subchoices.
1456                 (let ((subchoices (/anyof-all-subchoices anyof-operand this)))
1457                   (set! result
1458                         (append subchoices result)))
1459
1460                 ; No <anyof-operand> arguments.
1461                 (set! result
1462                       (cons (/anyof-instance-from-derived anyof-operand this)
1463                             result)))
1464
1465             (loop (cdr choices)))))
1466
1467     (assert (all-true? (map anyof-instance? result)))
1468     result)
1469 )
1470
1471 ; Cover fn of /anyof-all-choices-1.
1472 ; Return list of <anyof-instance> objects, one for each possible variant of
1473 ; ANYOF-OPERAND.
1474 ; We want to delete choices that fail their ifield assertions, but since
1475 ; /anyof-all-choices-1 can recursively call itself, assertion checking is
1476 ; defered until it returns.
1477
1478 (define (anyof-all-choices anyof-operand)
1479   (let ((all-choices (/anyof-all-choices-1 anyof-operand)))
1480
1481     ; Delete ones that fail their ifield assertions.
1482     ; Sometimes there isn't enough information yet to completely do this.
1483     ; When that happens it is the caller's responsibility to deal with it.
1484     ; However, it is our responsibility to assert as much as we can.
1485     (find (lambda (op)
1486             (anyof-satisfies-assertions? op
1487                                          (/anyof-initial-known op)))
1488           all-choices))
1489 )
1490 \f
1491 ; Operand utilities.
1492
1493 ; Look up operand NAME in the operand table.
1494 ; This proc isolates the strategy we use to record operand objects.
1495
1496 ; Look up an operand via SEM-NAME.
1497
1498 (define (op:lookup-sem-name op-list sem-name)
1499   (let loop ((op-list op-list))
1500     (cond ((null? op-list) #f)
1501           ((eq? sem-name (op:sem-name (car op-list))) (car op-list))
1502           (else (loop (cdr op-list)))))
1503 )
1504
1505 ; Given an operand, return the starting bit number.
1506 ; Note that the field isn't necessarily contiguous.
1507
1508 (define (op:start operand) (send operand 'field-start))
1509
1510 ; Given an operand, return the total length in bits.
1511 ; Note that the field isn't necessarily contiguous.
1512
1513 (define (op:length operand) (send operand 'field-length))
1514
1515 ; Return the nub of a list of operands, base on their names.
1516
1517 (define (op-nub op-list)
1518   (nub op-list obj:name)
1519 )
1520
1521 ; Return a sorted list of operand lists.
1522 ; Each element in the inner list is an operand with the same name, but for
1523 ; whatever reason were defined separately.
1524 ; The outer list is sorted by name.
1525
1526 (define (op-sort op-list)
1527   ; We assume there is at least one operand.
1528   (if (null? op-list)
1529       (error "op-sort: no operands!"))
1530   ; First sort by name.
1531   (let ((sorted-ops (alpha-sort-obj-list op-list)))
1532     (let loop ((result nil)
1533                ; Current set of operands with same name.
1534                (this-elm (list (car sorted-ops)))
1535                (ops (cdr sorted-ops))
1536                )
1537       (if (null? ops)
1538           ; Reverse things to keep them in file order (minimizes random
1539           ; changes in generated files).
1540           (reverse! (cons (reverse! this-elm) result))
1541           ; Not done.  Check for new set.
1542           (if (eq? (obj:name (car ops)) (obj:name (car this-elm)))
1543               (loop result (cons (car ops) this-elm) (cdr ops))
1544               (loop (cons (reverse! this-elm) result) (list (car ops))
1545                     (cdr ops))))))
1546 )
1547
1548 ; FIXME: Not used anymore but leave in for now.
1549 ; Objects used in assembler syntax ($0, $1, ...).
1550 ;
1551 ;(define <syntax-operand>
1552 ;  (class-make '<syntax-operand> nil '(number value) nil))
1553 ;(method-make-make! <syntax-operand> '(number))
1554 ;
1555 ;(define $0 (make <syntax-operand> 0))
1556 ;(define $1 (make <syntax-operand> 1))
1557 ;(define $2 (make <syntax-operand> 2))
1558 ;(define $3 (make <syntax-operand> 3))
1559 \f
1560 ; Called before/after loading the .cpu file to initialize/finalize.
1561
1562 ; Builtins.
1563 ; The pc operand used in rtl expressions.
1564 (define pc nil)
1565
1566 ; Called before reading a .cpu file in.
1567
1568 (define (operand-init!)
1569   (reader-add-command! 'define-operand
1570                        "\
1571 Define an operand, name/value pair list version.
1572 "
1573                        nil 'arg-list define-operand)
1574   (reader-add-command! 'define-full-operand
1575                        "\
1576 Define an operand, all arguments specified.
1577 "
1578                        nil '(name comment attrs hw-type mode hw-index handlers getter setter)
1579                        define-full-operand)
1580
1581   (reader-add-command! 'define-derived-operand
1582                        "\
1583 Define a derived operand, name/value pair list version.
1584 "
1585                        nil 'arg-list define-derived-operand)
1586
1587   (reader-add-command! 'define-anyof-operand
1588                        "\
1589 Define an anyof operand, name/value pair list version.
1590 "
1591                        nil 'arg-list define-anyof-operand)
1592
1593   *UNSPECIFIED*
1594 )
1595
1596 ; Install builtin operands.
1597
1598 (define (operand-builtin!)
1599   ; Standard operand attributes.
1600   ; ??? Some of these can be combined into one.
1601
1602   (define-attr '(for operand) '(type boolean) '(name NEGATIVE)
1603     '(comment "value is negative"))
1604
1605   ; Operand plays a part in RELAXABLE/RELAXED insns.
1606   (define-attr '(for operand) '(type boolean) '(name RELAX)
1607     '(comment "operand is the relax participant"))
1608
1609   ; ??? Might be able to make SEM-ONLY go away (or machine compute it)
1610   ; by scanning which operands are refered to by the insn syntax strings.
1611   (define-attr '(for operand) '(type boolean) '(name SEM-ONLY)
1612     '(comment "operand is for semantic use only"))
1613
1614   ; Also (defined elsewhere): PCREL-ADDR ABS-ADDR.
1615
1616   (set! pc (make <pc>))
1617   (current-op-add! pc)
1618
1619   *UNSPECIFIED*
1620 )
1621
1622 ; Called after a .cpu file has been read in.
1623
1624 (define (operand-finish!)
1625   *UNSPECIFIED*
1626 )