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