cgen/rtl-c.scm

   1 ; RTL->C translation support.
   2 ; Copyright (C) 2000, 2005, 2009 Red Hat, Inc.
   3 ; This file is part of CGEN.
   4 ; See file COPYING.CGEN for details.
   5
   6 ; Generating C from RTL
   7 ; ---------------------
   8 ; The main way to generate C code from an RTL expression is:
   9 ;
  10 ; (rtl-c-parsed mode isa-name-list nil '(func mode ...))
  11 ;
  12 ; E.g.
  13 ; (rtl-c-parsed SI (all) nil '(add () SI (const () SI 1) (const () SI 2)))
  14 ; -->
  15 ; "ADDSI (1, 2)"
  16 ;
  17 ; The expression is in source form and must be already canonicalized (with
  18 ; rtx-canonicalize).  There is also rtl-c for the occasions where the rtl
  19 ; isn't already canonicalized.
  20 ;
  21 ; The `set' rtx needs to be handled a little carefully.
  22 ; Both the dest and src are processed first, and then code to perform the
  23 ; assignment is computed.  However, the dest may require more than a simple
  24 ; C assignment.  Therefore set dests are converted to the specified object
  25 ; (e.g. a hardware operand) and then a message is sent to this object to
  26 ; perform the actual code generation.
  27 ;
  28 ; All interesting operands (e.g. regs, mem) are `operand' objects.
  29 ; The following messages must be supported by operand objects.
  30 ; - get-mode      - return mode of operand
  31 ; - cxmake-get    - return <c-expr> object containing operand's value
  32 ; - gen-set-quiet - return string of C code to set operand's value (no tracing)
  33 ; - gen-set-trace - return string of C code to set operand's value
  34 ;
  35 ; Instruction fields are refered to by name.
  36 ; Instruction ifields must have these methods:
  37 ; - get-mode
  38 ; - cxmake-get
  39 ;
  40 ; Conventions used in this file:
  41 ; - see rtl.scm
  42 \f
  43 ; The <c-expr> object.
  44 ; This is a fully translated expression (i.e. C code).
  45
  46 (define <c-expr>
  47   (class-make '<c-expr> nil
  48               '(
  49                 ; The mode of C-CODE.
  50                 mode
  51                 ; The translated C code.
  52                 c-code
  53                 ; The source expression, for debugging.
  54                 expr
  55                 ; Attributes of the expression.
  56                 atlist
  57                 ; List of temporaries required to compute the expression.
  58                 ; ??? wip.  These would be combined as the expression is
  59                 ; built up.  Then in sets and other statements, the temporaries
  60                 ; would be declared.
  61                 ;(tmps . nil)
  62                 )
  63               nil)
  64 )
  65
  66 (method-make!
  67  <c-expr> 'make!
  68  (lambda (self mode c-code atlist)
  69    ; FIXME: Extend COS to allow specifying member predicates.
  70    (assert (mode? mode))
  71    (assert (string? c-code))
  72    ;(assert (atlist? atlist)) ; FIXME: What should this be?
  73    (elm-set! self 'mode mode)
  74    (elm-set! self 'c-code c-code)
  75    (elm-set! self 'atlist atlist)
  76    self)
  77 )
  78
  79 ; Accessor fns
  80
  81 (define cx:mode (elm-make-getter <c-expr> 'mode))
  82 (define cx:c-code (elm-make-getter <c-expr> 'c-code))
  83 (define cx:expr (elm-make-getter <c-expr> 'expr))
  84 (define cx:atlist (elm-make-getter <c-expr> 'atlist))
  85 ;(define cx:tmps (elm-make-getter <c-expr> 'tmps))
  86
  87 ; Any object with attributes requires the get-atlist method.
  88
  89 (method-make! <c-expr> 'get-atlist (lambda (self) (elm-get self 'atlist)))
  90
  91 ; Respond to 'get-mode messages.
  92
  93 (method-make! <c-expr> 'get-mode (lambda (self) (elm-get self 'mode)))
  94
  95 ; Respond to 'get-name messages for rtx-dump.
  96
  97 (method-make!
  98  <c-expr> 'get-name
  99  (lambda (self)
 100    (string-append "(" (obj:str-name (elm-get self 'mode)) ") "
 101                   (cx:c self)))
 102 )
 103
 104 ; Return C code to perform an assignment.
 105 ; NEWVAL is a <c-expr> object of the value to be assigned to SELF.
 106
 107 (method-make! <c-expr> 'gen-set-quiet
 108               (lambda (self estate mode indx selector newval)
 109                 (string-append "  " (cx:c self) " = " (cx:c newval) ";\n"))
 110 )
 111
 112 (method-make! <c-expr> 'gen-set-trace
 113               (lambda (self estate mode indx selector newval)
 114                 (string-append "  " (cx:c self) " = " (cx:c newval) ";\n"))
 115 )
 116
 117 ; Return the C code of CX.
 118 ; ??? This used to handle lazy evaluation of the expression.
 119 ; Maybe it will again, so it's left in, as a cover fn to cx:c-code.
 120
 121 (define (cx:c cx)
 122   (cx:c-code cx)
 123 )
 124
 125 ; Main routine to create a <c-expr> node object.
 126 ; MODE is either the mode's symbol (e.g. 'QI) or a <mode> object.
 127 ; CODE is a string of C code.
 128
 129 (define (cx:make mode code)
 130   (make <c-expr> (mode-maybe-lookup mode) code nil)
 131 )
 132
 133 ; Make copy of CX in new mode MODE.
 134 ; MODE must be a <mode> object.
 135
 136 (define (cx-new-mode mode cx)
 137   (make <c-expr> mode (cx:c cx) (cx:atlist cx))
 138 )
 139
 140 ; Same as cx:make except with attributes.
 141
 142 (define (cx:make-with-atlist mode code atlist)
 143   (make <c-expr> (mode-maybe-lookup mode) code atlist)
 144 )
 145
 146 ; Return a boolean indicated if X is a <c-expr> object.
 147
 148 (define (c-expr? x) (class-instance? <c-expr> x))
 149 \f
 150 ; RTX environment support.
 151
 152 (method-make!
 153  <rtx-temp> 'cxmake-get
 154  (lambda (self estate mode indx selector)
 155    (cx:make mode (rtx-temp-value self)))
 156 )
 157
 158 (method-make!
 159  <rtx-temp> 'gen-set-quiet
 160  (lambda (self estate mode indx selector src)
 161    (string-append "  " (rtx-temp-value self) " = " (cx:c src) ";\n"))
 162 )
 163
 164 (method-make!
 165  <rtx-temp> 'gen-set-trace
 166  (lambda (self estate mode indx selector src)
 167    (string-append "  " (rtx-temp-value self) " = " (cx:c src) ";\n"))
 168 )
 169
 170 (define (gen-temp-defs estate env)
 171   (string-map (lambda (temp)
 172                 (let ((temp-obj (cdr temp)))
 173                   (string-append "  " (mode:c-type (rtx-temp-mode temp-obj))
 174                                  " " (rtx-temp-value temp-obj) ";\n")))
 175               env)
 176 )
 177 \f
 178 ; Top level routines to handle rtl->c translation.
 179
 180 ; rtl->c configuration parameters
 181
 182 ; #t -> emit calls to rtl cover fns, otherwise emit plain C where possible.
 183 (define /rtl-c-rtl-cover-fns? #f)
 184
 185 ; Called before emitting code to configure the generator.
 186 ; ??? I think this can go away now (since cover-fn specification is also
 187 ; done at each call to rtl-c).
 188
 189 (define (rtl-c-config! . args)
 190   (set! /rtl-c-rtl-cover-fns? #f)
 191   (let loop ((args args))
 192     (if (null? args)
 193         #f ; done
 194         (begin
 195           (case (car args)
 196             ((#:rtl-cover-fns?)
 197              (set! /rtl-c-rtl-cover-fns? (cadr args)))
 198             (else (error "rtl-c-config: unknown option:" (car args))))
 199           (loop (cddr args)))))
 200   *UNSPECIFIED*
 201 )
 202
 203 ; Subclass of <eval-state> to record additional things needed for rtl->c.
 204
 205 (define <rtl-c-eval-state>
 206   (class-make '<rtl-c-eval-state> '(<eval-state>)
 207               '(
 208                 ; #t -> emit calls to rtl cover fns.
 209                 (rtl-cover-fns? . #f)
 210
 211                 ; name of output language, "c" or "c++"
 212                 (output-language . "c")
 213
 214                 ; #t if generating code for a macro.
 215                 ; Each newline is then preceeded with '\\'.
 216                 (macro? . #f)
 217
 218                 ; Boolean indicating if evaluation is for an instruction.
 219                 ; It's not always possible to look at OWNER, e.g. when we're
 220                 ; processing semantic fragments.
 221                 (for-insn? . #f)
 222
 223                 ; #f -> reference ifield values using FLD macro.
 224                 ; #t -> use C variables.
 225                 ; ??? This is only needed to get correct ifield references
 226                 ; in opcodes, decoder, and semantics.  Maybe a better way to
 227                 ; go would be to specify the caller's name so there'd be just
 228                 ; one of these, rather than an increasing number.  However,
 229                 ; for now either way is the same.
 230                 ; An alternative is to specify a callback to try first.
 231                 (ifield-var? . #f)
 232                 )
 233               nil)
 234 )
 235
 236 ; FIXME: involves upcasting.
 237 (define-getters <rtl-c-eval-state> estate
 238   (rtl-cover-fns? output-language macro? for-insn? ifield-var?)
 239 )
 240
 241 ; Return booleans indicating if output language is C/C++.
 242
 243 (define (estate-output-language-c? estate)
 244   (string=? (estate-output-language estate) "c")
 245 )
 246 (define (estate-output-language-c++? estate)
 247   (string=? (estate-output-language estate) "c++")
 248 )
 249
 250 (method-make!
 251  <rtl-c-eval-state> 'vmake!
 252  (lambda (self args)
 253    ; Initialize parent class first.
 254    (let loop ((args (send-next self '<rtl-c-eval-state> 'vmake! args))
 255               (unrecognized nil))
 256      (if (null? args)
 257          (reverse! unrecognized) ; ??? Could invoke method to initialize here.
 258          (begin
 259            (case (car args)
 260              ((#:rtl-cover-fns?)
 261               (elm-set! self 'rtl-cover-fns? (cadr args)))
 262              ((#:output-language)
 263               (elm-set! self 'output-language (cadr args)))
 264              ((#:macro?)
 265               (elm-set! self 'macro? (cadr args)))
 266              ((#:for-insn?)
 267               (elm-set! self 'for-insn? (cadr args)))
 268              ((#:ifield-var?)
 269               (elm-set! self 'ifield-var? (cadr args)))
 270              (else
 271               ; Build in reverse order, as we reverse it back when we're done.
 272               (set! unrecognized
 273                     (cons (cadr args) (cons (car args) unrecognized)))))
 274            (loop (cddr args) unrecognized)))))
 275 )
 276
 277 ;; Build an estate for use in generating C.
 278 ;; OVERRIDES is a #:keyword/value list of parameters to apply last.
 279
 280 (define (estate-make-for-rtl-c overrides)
 281   (apply vmake
 282          (append!
 283           (list
 284            <rtl-c-eval-state>
 285            #:expr-fn (lambda (rtx-obj expr mode estate)
 286                        (rtl-c-generator rtx-obj))
 287            #:rtl-cover-fns? /rtl-c-rtl-cover-fns?)
 288           overrides))
 289 )
 290
 291 ; Translate RTL expression EXPR to C.
 292 ; ESTATE is the current rtx evaluation state.
 293 ; MODE is a <mode> object.
 294
 295 (define (rtl-c-with-estate estate mode expr)
 296   (cx:c (rtl-c-get estate mode (rtx-eval-with-estate expr mode estate)))
 297 )
 298
 299 ; Translate parsed RTL expression X to a string of C code.
 300 ; EXPR must have already been fed through rtx-canonicalize.
 301 ; MODE is the desired mode of the value or DFLT for "natural mode".
 302 ; MODE is a <mode> object.
 303 ; OVERRIDES is a #:keyword/value list of arguments to build the eval state
 304 ; with.
 305
 306 (define (rtl-c-parsed mode expr . overrides)
 307   ;; ??? If we're passed insn-compiled-semantics the output of xops is
 308   ;; confusing.  Fix by subclassing <operand> -> <xoperand>, and
 309   ;; have <xoperand> provide original source expr.
 310   (let ((estate (estate-make-for-rtl-c (cons #:outer-expr
 311                                              (cons expr overrides)))))
 312     (rtl-c-with-estate estate mode expr))
 313 )
 314
 315 ; Same as rtl-c-parsed but EXPR is unparsed.
 316 ; ISA-NAME-LIST is the list of ISA(s) in which to evaluate EXPR.
 317 ; EXTRA-VARS-ALIST is an association list of extra (symbol <mode> value)
 318 ; elements to be used during value lookup.
 319 ; MODE is a <mode> object.
 320
 321 (define (rtl-c mode isa-name-list extra-vars-alist expr . overrides)
 322   (let* ((canonical-rtl (rtx-canonicalize #f (obj:name mode)
 323                                           isa-name-list extra-vars-alist expr))
 324          (estate (estate-make-for-rtl-c (cons #:outer-expr
 325                                               (cons canonical-rtl overrides)))))
 326     (rtl-c-with-estate estate mode canonical-rtl))
 327 )
 328
 329 ; Same as rtl-c-with-estate except return a <c-expr> object.
 330 ; MODE is a <mode> object.
 331
 332 (define (rtl-c-expr-with-estate estate mode expr)
 333   (rtl-c-get estate mode (rtx-eval-with-estate expr mode estate))
 334 )
 335
 336 ; Same as rtl-c-parsed except return a <c-expr> object.
 337 ; MODE is a <mode> object.
 338
 339 (define (rtl-c-expr-parsed mode expr . overrides)
 340   ;; ??? If we're passed insn-compiled-semantics the output of xops is
 341   ;; confusing.  Fix by subclassing <operand> -> <xoperand>, and
 342   ;; have <xoperand> provide original source expr.
 343   (let ((estate (estate-make-for-rtl-c (cons #:outer-expr
 344                                              (cons expr overrides)))))
 345     (rtl-c-expr-with-estate estate mode expr))
 346 )
 347
 348 ; Same as rtl-c-expr-parsed but EXPR is unparsed.
 349 ; MODE is a <mode> object.
 350
 351 (define (rtl-c-expr mode isa-name-list extra-vars-alist expr . overrides)
 352   (let* ((canonical-rtl (rtx-canonicalize #f (obj:name mode)
 353                                           isa-name-list extra-vars-alist expr))
 354          (estate (estate-make-for-rtl-c (cons #:outer-expr
 355                                               (cons canonical-rtl overrides)))))
 356     (rtl-c-expr-with-estate estate mode canonical-rtl))
 357 )
 358 \f
 359 ; C++ versions of rtl-c routines.
 360
 361 ; Build an estate for use in generating C++.
 362 ; OVERRIDES is a #:keyword/value list of parameters to apply last.
 363
 364 (define (estate-make-for-rtl-c++ overrides)
 365   (estate-make-for-rtl-c (cons #:output-language (cons "c++" overrides)))
 366 )
 367
 368 ; Translate parsed RTL expression X to a string of C++ code.
 369 ; EXPR must have already been fed through rtx-canonicalize.
 370 ; MODE is the desired mode of the value or DFLT for "natural mode".
 371 ; MODE is a <mode> object.
 372 ; OVERRIDES is a #:keyword/value list of arguments to build the eval state
 373 ; with.
 374
 375 (define (rtl-c++-parsed mode expr . overrides)
 376   ;; ??? If we're passed insn-compiled-semantics the output of xops is
 377   ;; confusing.  Fix by subclassing <operand> -> <xoperand>, and
 378   ;; have <xoperand> provide original source expr.
 379   (let ((estate (estate-make-for-rtl-c++ (cons #:outer-expr
 380                                                (cons expr overrides)))))
 381     (rtl-c-with-estate estate mode expr))
 382 )
 383
 384 ; Same as rtl-c++-parsed but EXPR is unparsed.
 385 ; MODE is a <mode> object.
 386
 387 (define (rtl-c++ mode isa-name-list extra-vars-alist expr . overrides)
 388   (let* ((canonical-rtl (rtx-canonicalize #f (obj:name mode)
 389                                           isa-name-list extra-vars-alist expr))
 390          (estate (estate-make-for-rtl-c++ (cons #:outer-expr
 391                                                 (cons canonical-rtl overrides)))))
 392     (rtl-c-with-estate estate mode canonical-rtl))
 393 )
 394 \f
 395 ; Top level routines for getting/setting values.
 396
 397 ; Return a <c-expr> node to get the value of SRC in mode MODE.
 398 ; ESTATE is the current rtl evaluation state.
 399 ; MODE is a <mode> object.
 400 ; SRC is one of:
 401 ; - <c-expr> node
 402 ; - rtl expression (e.g. '(add WI dr sr))
 403 ; - sequence's local variable name
 404 ; - sequence's local variable object
 405 ; - operand name
 406 ; - operand object
 407 ; - an integer
 408 ; - a string of C code
 409 ; FIXME: Reduce acceptable values of SRC.
 410 ; The result has mode MODE, unless MODE is the "default mode indicator"
 411 ; (DFLT) in which case the mode of the result is derived from SRC.
 412 ;
 413 ; ??? mode compatibility checks are wip
 414
 415 (define (/rtl-c-get estate mode src)
 416   (let ((mode mode)) ;;(mode:lookup mode)))
 417
 418     (cond ((c-expr? src)
 419            (cond ((or (mode:eq? 'VOID mode)
 420                       (mode:eq? 'DFLT mode)
 421                       (mode:eq? (cx:mode src) mode))
 422                   src)
 423                  ((rtx-mode-compatible? mode (cx:mode src))
 424                   (cx-new-mode mode src))
 425                  (else
 426                   (estate-error
 427                    estate
 428                    (string-append "incompatible mode: "
 429                                   "(" (obj:str-name (cx:mode src)) " vs "
 430                                   (obj:str-name mode) ") in "
 431                                   "\"" (cx:c src) "\"")
 432                    (obj:name mode)))))
 433
 434           ; The recursive call to /rtl-c-get is in case the result of rtx-eval
 435           ; is a hardware object, rtx-func object, or another rtl expression.
 436           ; FIXME: simplify
 437           ((rtx? src)
 438            (let ((evald-src (rtx-eval-with-estate src mode estate)))
 439              ; There must have been some change, otherwise we'll loop forever.
 440              (assert (not (eq? src evald-src)))
 441              (/rtl-c-get estate mode evald-src)))
 442
 443           ;; FIXME: Can we ever get a symbol here?
 444           ((or (and (symbol? src) (current-op-lookup src))
 445                (operand? src))
 446            (begin
 447              (if (symbol? src)
 448                  (set! src (current-op-lookup src)))
 449              (cond ((mode:eq? 'DFLT mode)
 450                     ; FIXME: Can we get called with 'DFLT anymore?
 451                     ; FIXME: If we fetch the mode here, operands can assume
 452                     ; they never get called with "default mode".
 453                     (send src 'cxmake-get estate mode #f #f))
 454                    ((rtx-mode-compatible? mode (op:mode src))
 455                     (let ((mode (op:mode src))) ;; FIXME: (rtx-sem-mode mode)))
 456                       (send src 'cxmake-get estate mode #f #f)))
 457                    (else
 458                     ;; FIXME: canonicalization should have already caught this
 459                     (estate-error
 460                      estate
 461                      (string-append "operand " (obj:str-name src)
 462                                     " referenced in incompatible mode")
 463                      (obj:name mode))))))
 464
 465           ;; FIXME: Can we ever get a symbol here?
 466           ((or (and (symbol? src) (rtx-temp-lookup (estate-env-stack estate) src))
 467                (rtx-temp? src))
 468            (begin
 469              (if (symbol? src)
 470                  (set! src (rtx-temp-lookup (estate-env-stack estate) src)))
 471              (cond ((mode:eq? 'DFLT mode)
 472                     (send src 'cxmake-get estate (rtx-temp-mode src) #f #f))
 473                    ((rtx-mode-compatible? mode (rtx-temp-mode src))
 474                     (let ((mode (rtx-temp-mode src))) ;; FIXME: (rtx-sem-mode mode)))
 475                       (send src 'cxmake-get estate mode #f #f)))
 476                    (else
 477                     ;; FIXME: canonicalization should have already caught this
 478                     (estate-error
 479                      estate
 480                      (string-append "sequence temp " (rtx-temp-name src)
 481                                     " referenced in incompatible mode")
 482                      (obj:name mode))))))
 483
 484           ((integer? src)
 485            ; Default mode of integer argument is INT.
 486            (if (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode))
 487                (cx:make INT (number->string src))
 488                (cx:make mode (number->string src))))
 489
 490           ((string? src)
 491            ; Default mode of string argument is INT.
 492            (if (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode))
 493                (cx:make INT src)
 494                (cx:make mode src)))
 495
 496           (else (estate-error estate "/rtl-c-get: invalid argument" src))))
 497 )
 498
 499 ;; MODE is either a <mode> object or the mode name.
 500
 501 (define (rtl-c-get estate mode src)
 502   (let ((mode (mode-maybe-lookup mode)))
 503     (logit 4 (spaces (estate-depth estate))
 504            "(rtl-c-get " (mode-real-name mode) " " (rtx-strdump src) ")\n")
 505     (let ((result (/rtl-c-get estate mode src)))
 506       (logit 4 (spaces (estate-depth estate))
 507              "(rtl-c-get " (mode-real-name mode) " " (rtx-strdump src) ") => "
 508              (cx:c result) "\n")
 509       result))
 510 )
 511
 512 ; Return a <c-expr> object to set the value of DEST to SRC.
 513 ; ESTATE is the current rtl evaluation state.
 514 ; MODE is the mode of DEST or DFLT which means fetch the real mode from DEST.
 515 ; MODE is either a <mode> object or the mode name.
 516 ; DEST is one of:
 517 ; - <c-expr> node
 518 ; - rtl expression (e.g. '(mem QI dr))
 519 ; SRC is an RTX expression.  It is important that we evaluate it, instead of
 520 ; our caller, because only we know the mode of DEST (which we need to pass
 521 ; when evaluating SRC if MODE is DFLT).  ??? Can no longer get DFLT, but
 522 ; it feels right to continue to evaluate SRC here.
 523 ; The mode of the result is always VOID (void).
 524 ;
 525 ; ??? One possible optimization is to pass the address of the result
 526 ; to the computation of SRC.  Seems dodgey though.
 527
 528 (define (rtl-c-set-quiet estate mode dest src)
 529   ;(display (list 'rtl-c-set-quiet mode dest src)) (newline)
 530   (let* ((mode (mode-maybe-lookup mode))
 531          (xdest (cond ((c-expr? dest)
 532                        dest)
 533                       ((rtx? dest)
 534                        (rtx-eval-with-estate dest mode estate))
 535                       (else
 536                        (estate-error estate
 537                                      "rtl-c-set-quiet: invalid dest"
 538                                      dest)))))
 539     (assert (mode? mode))
 540     (if (not (object? xdest))
 541         (estate-error estate "rtl-c-set-quiet: invalid dest" dest))
 542     (cx:make VOID (send xdest 'gen-set-quiet
 543                         estate mode #f #f
 544                         (rtl-c-get estate mode src))))
 545 )
 546
 547 ; Same as rtl-c-set-quiet except also print TRACE_RESULT message.
 548 ; MODE is either a <mode> object or the mode name.
 549 ; ??? One possible change is to defer the (rtl-c-get src) call to dest's
 550 ; set handler.  Such sources would be marked accordingly and rtl-c-get
 551 ; would recognize them.  This would allow, for example, passing the address
 552 ; of the result to the computation.
 553
 554 (define (rtl-c-set-trace estate mode dest src)
 555   ;(display (list 'rtl-c-set-trace mode dest src)) (newline)
 556   (let* ((mode (mode-maybe-lookup mode))
 557          (xdest (cond ((c-expr? dest)
 558                        dest)
 559                       ((rtx? dest)
 560                        (rtx-eval-with-estate dest mode estate))
 561                       (else
 562                        (estate-error estate
 563                                      "rtl-c-set-trace: invalid dest"
 564                                      dest)))))
 565     (assert (mode? mode))
 566     (if (not (object? xdest))
 567         (estate-error estate "rtl-c-set-trace: invalid dest" dest))
 568     (cx:make VOID (send xdest 'gen-set-trace
 569                         estate mode #f #f
 570                         (rtl-c-get estate mode src))))
 571 )
 572 \f
 573 ; Emit C code for each rtx function.
 574
 575 ; Table mapping rtx function to C generator.
 576
 577 (define /rtl-c-gen-table #f)
 578
 579 ; Return the C generator for <rtx-func> F.
 580
 581 (define (rtl-c-generator f)
 582   (vector-ref /rtl-c-gen-table (rtx-num f))
 583 )
 584 \f
 585 ; Support for explicit C/C++ code.
 586 ; MODE is the mode name.
 587 ; ??? Actually, "support for explicit foreign language code".
 588 ; s-c-call needs a better name but "unspec" seems like obfuscation.
 589 ; ??? Need to distinguish owner of call (cpu, ???).
 590
 591 (define (s-c-call estate mode name . args)
 592   (cx:make mode
 593            (string-append
 594             (if (estate-output-language-c++? estate)
 595                 (string-append "current_cpu->" name " (")
 596                 ; FIXME: Prepend @cpu@_ to name here, and delete @cpu@_ from
 597                 ; description file.
 598                 (string-append name " (current_cpu"))
 599             (let ((c-args
 600                    (string-map (lambda (arg)
 601                                  (string-append
 602                                   ", "
 603                                   (cx:c (rtl-c-get estate DFLT arg))))
 604                                args)))
 605               (if (estate-output-language-c++? estate)
 606                   (string-drop 2 c-args)
 607                   c-args))
 608             ; If the mode is VOID, this is a statement.
 609             ; Otherwise it's an expression.
 610             ; ??? Bad assumption!  VOID expressions may be used
 611             ; within sequences without local vars, which are translated
 612             ; to comma-expressions.
 613             (if (or (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore
 614                     (mode:eq? 'VOID mode))
 615                 ");\n"
 616                 ")")
 617             ))
 618 )
 619
 620 ; Same as c-call except there is no particular owner of the call.
 621 ; In general this means making a call to a non-member function,
 622 ; whereas c-call makes calls to member functions (in C++ parlance).
 623 ; MODE is the mode name.
 624
 625 (define (s-c-raw-call estate mode name . args)
 626   (cx:make mode
 627            (string-append
 628             name " ("
 629             (string-drop 2
 630                          (string-map (lambda (elm)
 631                                        (string-append
 632                                         ", " (cx:c (rtl-c-get estate DFLT elm))))
 633                                      args))
 634             ; If the mode is VOID, this is a statement.
 635             ; Otherwise it's an expression.
 636             ; ??? Bad assumption!  VOID expressions may be used
 637             ; within sequences without local vars, which are translated
 638             ; to comma-expressions.
 639             (if (or (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore
 640                     (mode:eq? 'VOID mode))
 641                 ");\n"
 642                 ")")
 643             ))
 644 )
 645 \f
 646 ; Standard arithmetic operations.
 647
 648 ; Return a boolean indicating if a cover function/macro should be emitted
 649 ; to perform an operation.
 650 ; C-OP is a string containing the C operation or #f if there is none.
 651 ; MODE is the mode of the operation.
 652
 653 (define (/rtx-use-sem-fn? estate c-op mode)
 654   ; If no C operation has been provided, use a macro, or
 655   ; if this is the simulator and MODE is not a host mode, use a macro.
 656 ;  (or (not c-op)
 657 ;      (and (estate-rtl-cover-fns? estate)
 658 ;          (not (mode:host? mode))))
 659   ; FIXME: The current definition is a temporary hack while host/target-ness
 660   ; of INT/UINT is unresolved.
 661   (and (not (obj-has-attr? mode 'FORCE-C))
 662        (or (not c-op)
 663            (and (estate-rtl-cover-fns? estate)
 664                 ;; NOTE: We can't check (insn? (estate-owner estate)) here.
 665                 ;; It's not necessarily present for semantic fragments.
 666                 (or (estate-for-insn? estate)
 667                     (not (mode:host? mode))))))
 668 )
 669
 670 ; One operand referenced, result is in same mode.
 671 ; MODE is the mode name.
 672
 673 (define (s-unop estate name c-op mode src)
 674   (let* ((val (rtl-c-get estate mode src))
 675          ; Refetch mode in case it was DFLT and ensure unsigned->signed.
 676          (mode (mode:lookup mode)) ;;(cx:mode val)) ;; FIXME: can't get DFLT anymore
 677          (sem-mode (rtx-sem-mode mode)))
 678     ; FIXME: Argument checking.
 679
 680     (if (/rtx-use-sem-fn? estate c-op mode)
 681         (if (mode-float? mode)
 682             (cx:make sem-mode
 683                      (string-append "CGEN_CPU_FPU (current_cpu)->ops->"
 684                                     (string-downcase name)
 685                                     (string-downcase (obj:str-name sem-mode))
 686                                     " (CGEN_CPU_FPU (current_cpu), "
 687                                     (cx:c val) ")"))
 688             (cx:make sem-mode
 689                      (string-append name (obj:str-name sem-mode)
 690                                     " (" (cx:c val) ")")))
 691         (cx:make mode ; not sem-mode on purpose
 692                  (string-append "(" c-op " ("
 693                                 (cx:c val) "))"))))
 694 )
 695
 696 ; Two operands referenced in the same mode producing a result in the same mode.
 697 ; MODE is the mode name.
 698 ;
 699 ; ??? Will eventually want to handle floating point modes specially.  Since
 700 ; bigger modes may get clumsily passed (there is no pass by reference in C) and
 701 ; since we want to eventually handle lazy transformation, FP values could be
 702 ; passed by reference.  This is easy in C++.  C requires more work and is
 703 ; defered until it's warranted.
 704 ; Implementing this should probably be via a new cxmake-get-ref method,
 705 ; rather then complicating cxmake-get.  Ditto for rtl-c-get-ref/rtl-c-get.
 706
 707 (define (s-binop estate name c-op mode src1 src2)
 708   ;(display (list "binop " name ", mode " mode)) (newline)
 709   (let* ((val1 (rtl-c-get estate mode src1))
 710          ; Refetch mode in case it was DFLT and ensure unsigned->signed.
 711          (mode (mode:lookup mode)) ;;(cx:mode val1)) ;; FIXME: can't get DFLT anymore
 712          (sem-mode (rtx-sem-mode mode))
 713          (val2 (rtl-c-get estate mode src2)))
 714     ; FIXME: Argument checking.
 715
 716     (if (/rtx-use-sem-fn? estate c-op mode)
 717         (if (mode-float? mode)
 718             (cx:make sem-mode
 719                      (string-append "CGEN_CPU_FPU (current_cpu)->ops->"
 720                                     (string-downcase name)
 721                                     (string-downcase (obj:str-name sem-mode))
 722                                     " (CGEN_CPU_FPU (current_cpu), "
 723                                     (cx:c val1) ", "
 724                                     (cx:c val2) ")"))
 725             (cx:make sem-mode
 726                      (string-append name (obj:str-name sem-mode)
 727                                     " (" (cx:c val1) ", "
 728                                     (cx:c val2) ")")))
 729         (cx:make mode ; not sem-mode on purpose
 730                  (string-append "(("
 731                                 (cx:c val1)
 732                                 ") " c-op " ("
 733                                 (cx:c val2)
 734                                 "))"))))
 735 )
 736
 737 ; Same as s-binop except there's a third argument which is always one bit.
 738 ; MODE is the mode name.
 739
 740 (define (s-binop-with-bit estate name mode src1 src2 src3)
 741   (let* ((val1 (rtl-c-get estate mode src1))
 742          ; Refetch mode in case it was DFLT and ensure unsigned->signed.
 743          (mode (mode:lookup mode)) ;;(cx:mode val1)) ;; FIXME: can't get DFLT anymore
 744          (sem-mode (rtx-sem-mode mode))
 745          (val2 (rtl-c-get estate mode src2))
 746          (val3 (rtl-c-get estate 'BI src3)))
 747     ; FIXME: Argument checking.
 748
 749     (cx:make mode
 750           (string-append name (obj:str-name sem-mode)
 751                          " ("
 752                          (cx:c val1) ", "
 753                          (cx:c val2) ", "
 754                          (cx:c val3)
 755                          ")")))
 756 )
 757
 758 ; Shift operations are slightly different than binary operations:
 759 ; the mode of src2 is any integral mode.
 760 ; MODE is the mode name.
 761 ; ??? Note that some cpus have a signed shift left that is semantically
 762 ; different from a logical one.  May need to create `sla' some day.  Later.
 763
 764 (define (s-shop estate name c-op mode src1 src2)
 765   ;(display (list "shop " name ", mode " mode)) (newline)
 766   (let* ((val1 (rtl-c-get estate mode src1))
 767          ; Refetch mode in case it was DFLT and ensure unsigned->signed
 768          ; [sign of operation is determined from operation name, not mode].
 769          (mode (mode:lookup mode)) ;;(cx:mode val1)) ;; FIXME: can't get DFLT anymore
 770          (sem-mode (rtx-sem-mode mode))
 771          (val2 (rtl-c-get estate mode src2)))
 772     ; FIXME: Argument checking.
 773
 774     (if (/rtx-use-sem-fn? estate c-op mode)
 775         (cx:make sem-mode
 776                  (string-append name (obj:str-name sem-mode)
 777                                 " (" (cx:c val1) ", "
 778                                 (cx:c val2) ")"))
 779         (cx:make mode ; not sem-mode on purpose
 780                  (string-append "("
 781                                 ; Ensure correct sign of shift.
 782                                 (cond ((equal? name "SRL")
 783                                        (string-append "("
 784                                                       (if (eq? (mode:class mode) 'UINT)
 785                                                           ""
 786                                                           "unsigned ")
 787                                                       (mode:non-mode-c-type mode)
 788                                                       ") "))
 789                                       ((equal? name "SRA")
 790                                        (string-append "("
 791                                                       (mode:non-mode-c-type mode)
 792                                                       ") "))
 793                                       (else ""))
 794                                 "(" (cx:c val1) ") "
 795                                 c-op
 796                                 " (" (cx:c val2) "))"))))
 797 )
 798
 799 ; Process andif, orif.
 800 ; SRC1 and SRC2 have any arithmetic mode.
 801 ; MODE is the mode name.
 802 ; The result has mode BI.
 803 ; ??? May want to use INT as BI may introduce some slowness
 804 ; in the generated code.
 805
 806 (define (s-boolifop estate name c-op src1 src2)
 807   (let* ((val1 (rtl-c-get estate DFLT src1))
 808          (val2 (rtl-c-get estate DFLT src2)))
 809     ; FIXME: Argument checking.
 810
 811     ; If this is the simulator and MODE is not a host mode, use a macro.
 812     ; ??? MODE here being the mode of SRC1.  Maybe later.
 813     (if (estate-rtl-cover-fns? estate)
 814         (cx:make (mode:lookup 'BI)
 815                  (string-append name ; "BI", leave off mode, no need for it
 816                                 " (" (cx:c val1) ", "
 817                                 (cx:c val2) ")"))
 818         (cx:make (mode:lookup 'BI)
 819                  (string-append "(("
 820                                 (cx:c val1)
 821                                 ") " c-op " ("
 822                                 (cx:c val2)
 823                                 "))"))))
 824 )
 825
 826 ; Mode conversions.
 827 ; MODE is the mode name.
 828
 829 (define (s-convop estate name mode s1)
 830   ; Get S1 in its normal mode, then convert.
 831   (let ((s (rtl-c-get estate DFLT s1))
 832         (mode (mode:lookup mode)))
 833     (if (and (not (estate-rtl-cover-fns? estate))
 834              (mode:host? (cx:mode s)))
 835         (cx:make mode
 836                  (string-append "((" (obj:str-name mode) ")"
 837                                 " (" (obj:str-name (cx:mode s)) ")"
 838                                 " (" (cx:c s) "))"))
 839         (if (or (mode-float? mode)
 840                 (mode-float? (cx:mode s)))
 841             (cx:make mode
 842                      (string-append "CGEN_CPU_FPU (current_cpu)->ops->"
 843                                     (string-downcase name)
 844                                     (string-downcase (obj:str-name (rtx-sem-mode (cx:mode s))))
 845                                     (string-downcase (obj:str-name (rtx-sem-mode mode)))
 846                                     " (CGEN_CPU_FPU (current_cpu), "
 847                                     (cx:c s) ")"))
 848             (cx:make mode
 849                      (string-append name
 850                                     (obj:str-name (rtx-sem-mode (cx:mode s)))
 851                                     (obj:str-name (rtx-sem-mode mode))
 852                                     " (" (cx:c s) ")")))))
 853 )
 854
 855 ; Compare SRC1 and SRC2 in mode MODE.
 856 ; NAME is one of eq,ne,lt,le,gt,ge,ltu,leu,gtu,geu.
 857 ; MODE is the mode name.
 858 ; The result has mode BI.
 859 ; ??? May want a host int mode result as BI may introduce some slowness
 860 ; in the generated code.
 861
 862 (define (s-cmpop estate name c-op mode src1 src2)
 863   (let* ((val1 (rtl-c-get estate mode src1))
 864          ; Refetch mode in case it was DFLT.
 865          (mode (mode:lookup mode)) ;;(cx:mode val1)) ;; FIXME: can't get DFLT anymore
 866          (val2 (rtl-c-get estate mode src2)))
 867     ; FIXME: Argument checking.
 868
 869     ; If no C operation has been provided, use a macro, or
 870     ; if this is the simulator and MODE is not a host mode, use a macro.
 871     (if (/rtx-use-sem-fn? estate c-op mode)
 872         (if (mode-float? mode)
 873             (cx:make (mode:lookup 'BI)
 874                      (string-append "CGEN_CPU_FPU (current_cpu)->ops->"
 875                                     (string-downcase (symbol->string name))
 876                                     (string-downcase (obj:str-name (rtx-sem-mode mode)))
 877                                     " (CGEN_CPU_FPU (current_cpu), "
 878                                     (cx:c val1) ", "
 879                                     (cx:c val2) ")"))
 880             (cx:make (mode:lookup 'BI)
 881                      (string-append (string-upcase (symbol->string name))
 882                                     (if (memq name '(eq ne))
 883                                         (obj:str-name (rtx-sem-mode mode))
 884                                         (obj:str-name mode))
 885                                     " (" (cx:c val1) ", "
 886                                     (cx:c val2) ")")))
 887         (cx:make (mode:lookup 'BI)
 888                  (string-append "(("
 889                                 (cx:c val1)
 890                                 ") " c-op " ("
 891                                 (cx:c val2)
 892                                 "))"))))
 893 )
 894 \f
 895 ; Conditional execution.
 896
 897 ; `if' in RTL has a result, like ?: in C.
 898 ; We support both: one with a result (non VOID mode), and one without (VOID mode).
 899 ; The non-VOID case must have an else part.
 900 ; MODE is the mode of the result, not the comparison.
 901 ; MODE is the mode name.
 902 ; The comparison is expected to return a zero/non-zero value.
 903 ; ??? Perhaps this should be a syntax-expr.  Later.
 904
 905 (define (s-if estate mode cond then . else)
 906   (if (> (length else) 1)
 907       (estate-error estate "if: too many elements in `else' part" else))
 908   (let ()
 909     (if (or (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore
 910             (mode:eq? 'VOID mode))
 911         (cx:make mode
 912                  (string-append "if (" (cx:c (rtl-c-get estate DFLT cond)) ")"
 913                                 " {\n" (cx:c (rtl-c-get estate mode then)) "}"
 914                                 (if (not (null? else))
 915                                     (string-append " else {\n"
 916                                                    (cx:c (rtl-c-get estate mode (car else)))
 917                                                    "}\n")
 918                                     "\n")
 919                                 ))
 920         (if (= (length else) 1)
 921             (cx:make mode
 922                      (string-append "(("
 923                                     (cx:c (rtl-c-get estate DFLT cond))
 924                                     ") ? ("
 925                                     (cx:c (rtl-c-get estate mode then))
 926                                     ") : ("
 927                                     (cx:c (rtl-c-get estate mode (car else)))
 928                                     "))"))
 929             (estate-error estate "non-void-mode `if' must have `else' part"))))
 930 )
 931
 932 ; A multiway `if'.
 933 ; MODE is the mode name.
 934 ; If MODE is VOID emit a series of if/else's.
 935 ; If MODE is not VOID, emit a series of ?:'s.
 936 ; COND-CODE-LIST is a list of lists, each sublist is a list of two elements:
 937 ; condition, code.  The condition part must return a zero/non-zero value, and
 938 ; the code part is treated as a `sequence'.
 939 ; This defer argument evaluation, the syntax
 940 ; ((... condition ...) ... action ...)
 941 ; needs special parsing.
 942 ; FIXME: Need more error checking of arguments.
 943
 944 (define (s-cond estate mode . cond-code-list)
 945   ;; FIXME: can't get DFLT anymore
 946   (let ((vm? (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode))))
 947     (if (null? cond-code-list)
 948         (estate-error estate "empty `cond'"))
 949     (let ((if-part (if vm?  "if (" "("))
 950           (then-part (if vm? ") " ") ? "))
 951           (elseif-part (if vm? " else if (" " : ("))
 952           (else-part (if vm? " else " " : "))
 953           (fi-part (if vm? "" ")")))
 954       (let loop ((result
 955                   (string-append
 956                    if-part
 957                    (cx:c (rtl-c-get estate DFLT (caar cond-code-list)))
 958                    then-part
 959                    (cx:c (apply s-sequence
 960                                 (cons estate
 961                                       (cons mode
 962                                             (cons nil
 963                                                   (cdar cond-code-list))))))))
 964                  (ccl (cdr cond-code-list)))
 965         (cond ((null? ccl) (cx:make mode result))
 966               ((eq? (caar ccl) 'else)
 967                (cx:make mode
 968                         (string-append
 969                          result
 970                          else-part
 971                          (cx:c (apply s-sequence
 972                                       (cons estate
 973                                             (cons mode
 974                                                   (cons nil
 975                                                         (cdar ccl)))))))))
 976               (else (loop (string-append
 977                            result
 978                            elseif-part
 979                            (cx:c (rtl-c-get estate DFLT (caar ccl)))
 980                            then-part
 981                            (cx:c (apply s-sequence
 982                                         (cons estate
 983                                               (cons mode
 984                                                     (cons nil
 985                                                           (cdar ccl)))))))
 986                           (cdr ccl)))))))
 987 )
 988
 989 ; Utility of s-case to print a case prefix (for lack of a better term).
 990
 991 (define (/gen-case-prefix val)
 992   (string-append "  case "
 993                  (cond ((number? val)
 994                         (number->string val))
 995                        ((symbol? val)
 996                         (string-upcase (gen-c-symbol val))) ; yes, upcase
 997                        ((string? val) val)
 998                        (else
 999                         (parse-error (make-prefix-context "case:")
1000                                      "bad case" val)))
1001                  " : ")
1002 )
1003
1004 ; Utility of s-case to handle a void result.
1005
1006 (define (s-case-vm estate test case-list)
1007   (cx:make
1008    VOID
1009    (string-append
1010     "  switch ("
1011     (cx:c (rtl-c-get estate DFLT test))
1012     ")\n"
1013     "  {\n"
1014     (string-map (lambda (case-entry)
1015                   (let ((caseval (car case-entry))
1016                         (code (cdr case-entry)))
1017                     (string-append
1018                      (cond ((list? caseval)
1019                             (string-map /gen-case-prefix caseval))
1020                            ((eq? 'else caseval)
1021                             (string-append "  default : "))
1022                            (else
1023                             (/gen-case-prefix caseval)))
1024                      (cx:c (apply s-sequence
1025                                   (cons estate (cons VOID (cons nil code)))))
1026                      "    break;\n")))
1027                 case-list)
1028     "  }\n"))
1029 )
1030
1031 ; Utility of s-case-non-vm to generate code to perform the test.
1032 ; MODE is the mode name.
1033
1034 (define (/gen-non-vm-case-test estate mode test cases)
1035   (assert (not (null? cases)))
1036   (let loop ((result "") (cases cases))
1037     (if (null? cases)
1038         result
1039         (let ((case (cond ((number? (car cases))
1040                            (car cases))
1041                           ((symbol? (car cases))
1042                            (if (enum-lookup-val (car cases))
1043                                (rtx-make 'enum mode (car cases))
1044                                (estate-error estate
1045                                              "symbol not an enum"
1046                                              (car cases))))
1047                           (else
1048                            (estate-error estate "invalid case" (car cases))))))
1049           (loop (string-append
1050                  result
1051                  (if (= (string-length result) 0)
1052                      ""
1053                      " || ")
1054                  (cx:c (rtl-c-get estate mode test))
1055                  " == "
1056                  (cx:c (rtl-c-get estate mode case)))
1057                 (cdr cases)))))
1058 )
1059
1060 ; Utility of s-case to handle a non-void result.
1061 ; This is expanded as a series of ?:'s.
1062 ; MODE is the mode name.
1063
1064 (define (s-case-non-vm estate mode test case-list)
1065   (let ((if-part "(")
1066         (then-part ") ? ")
1067         (elseif-part " : (")
1068         (else-part " : ")
1069         (fi-part ")"))
1070     (let loop ((result
1071                 (string-append
1072                  if-part
1073                  (/gen-non-vm-case-test estate mode test (caar case-list))
1074                  then-part
1075                  (cx:c (apply s-sequence
1076                               (cons estate
1077                                     (cons mode
1078                                           (cons nil
1079                                                 (cdar case-list))))))))
1080                (cl (cdr case-list)))
1081       (cond ((null? cl) (cx:make mode result))
1082             ((eq? (caar cl) 'else)
1083              (cx:make mode
1084                       (string-append
1085                        result
1086                        else-part
1087                        (cx:c (apply s-sequence
1088                                     (cons estate
1089                                           (cons mode
1090                                                 (cons nil
1091                                                       (cdar cl)))))))))
1092             (else (loop (string-append
1093                          result
1094                          elseif-part
1095                          (/gen-non-vm-case-test estate mode test (caar cl))
1096                          then-part
1097                          (cx:c (apply s-sequence
1098                                       (cons estate
1099                                             (cons mode
1100                                                   (cons nil
1101                                                         (cdar cl)))))))
1102                         (cdr cl))))))
1103 )
1104
1105 ; C switch statement
1106 ; To follow convention, MODE is the first arg.
1107 ; MODE is the mode name.
1108 ; FIXME: What to allow for case choices is wip.
1109
1110 (define (s-case estate mode test . case-list)
1111   ;; FIXME: can't get DFLT anymore
1112   (if (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode))
1113       (s-case-vm estate test case-list)
1114       (s-case-non-vm estate mode test case-list))
1115 )
1116 \f
1117 ; Parallels and Sequences
1118
1119 ; Temps for `parallel' are recorded differently than for `sequence'.
1120 ; ??? I believe this is because there was an interaction between the two.
1121
1122 (define /par-temp-list nil)
1123
1124 ; Record a temporary needed for a parallel in mode MODE.
1125 ; We just need to record the mode with a unique name so we use a <c-expr>
1126 ; object where the "expression" is the variable's name.
1127
1128 (define (/par-new-temp! mode)
1129   (set! /par-temp-list
1130         (cons (cx:make mode (string-append "temp"
1131                                            (number->string
1132                                             (length /par-temp-list))))
1133               /par-temp-list))
1134   (car /par-temp-list)
1135 )
1136
1137 ; Return the next temp from the list, and leave the list pointing to the
1138 ; next one.
1139
1140 (define (/par-next-temp!)
1141   (let ((result (car /par-temp-list)))
1142     (set! /par-temp-list (cdr /par-temp-list))
1143     result)
1144 )
1145
1146 (define (/gen-par-temp-defns temp-list)
1147   ;(display temp-list) (newline)
1148   (string-append
1149    "  "
1150    ; ??? mode:c-type
1151    (string-map (lambda (temp) (string-append (obj:str-name (cx:mode temp))
1152                                              " " (cx:c temp) ";"))
1153                temp-list)
1154    "\n")
1155 )
1156
1157 ;; Parallels are handled by converting them into two sequences.  The first has
1158 ;; all set destinations replaced with temps, and the second has all set sources
1159 ;; replaced with those temps.
1160
1161 ;; rtl-traverse expr-fn to replace the dest of sets with the parallel temp.
1162
1163 (define (/par-replace-set-dest-expr-fn rtx-obj expr parent-expr op-pos
1164                                        tstate appstuff)
1165   (case (car expr)
1166     ((set set-quiet)
1167      (let ((name (rtx-name expr))
1168            (options (rtx-options expr))
1169            (mode (rtx-mode expr))
1170            (dest (rtx-set-dest expr))
1171            (src (rtx-set-src expr)))
1172        (list name options mode (/par-new-temp! mode) src)))
1173     (else #f))
1174 )
1175
1176 ;; rtl-traverse expr-fn to replace the src of sets with the parallel temp.
1177 ;; This must process expressions in the same order as /par-replace-set-dests.
1178
1179 (define (/par-replace-set-src-expr-fn rtx-obj expr parent-expr op-pos
1180                                       tstate appstuff)
1181   (case (car expr)
1182     ((set set-quiet)
1183      (let ((name (rtx-name expr))
1184            (options (rtx-options expr))
1185            (mode (rtx-mode expr))
1186            (dest (rtx-set-dest expr))
1187            (src (rtx-set-src expr)))
1188        (list name options mode dest (/par-next-temp!))))
1189     (else #f))
1190 )
1191
1192 ;; Return a <c-expr> node for a `parallel'.
1193
1194 (define (s-parallel estate . exprs)
1195   (begin
1196
1197     ;; Initialize /par-temp-list for /par-replace-set-dests.
1198     (set! /par-temp-list nil)
1199
1200     (let* ((set-dest-exprs
1201             ;; Use map-in-order because we need temp creation and usage to
1202             ;; follow the same order.
1203             (map-in-order (lambda (expr)
1204                             (rtx-traverse (estate-context estate)
1205                                           (estate-owner estate)
1206                                           expr
1207                                           /par-replace-set-dest-expr-fn
1208                                           #f))
1209                           exprs))
1210            (set-dests (string-map (lambda (expr)
1211                                     (rtl-c-with-estate estate VOID expr))
1212                                   set-dest-exprs))
1213            (temps (reverse! /par-temp-list)))
1214
1215       ;; Initialize /par-temp-list for /par-replace-set-srcs.
1216       (set! /par-temp-list temps)
1217
1218       (let* ((set-src-exprs
1219               ;; Use map-in-order because we need temp creation and usage to
1220               ;; follow the same order.
1221               (map-in-order (lambda (expr)
1222                               (rtx-traverse (estate-context estate)
1223                                             (estate-owner estate)
1224                                             expr
1225                                             /par-replace-set-src-expr-fn
1226                                             #f))
1227                             exprs))
1228              (set-srcs (string-map (lambda (expr)
1229                                      (rtl-c-with-estate estate VOID expr))
1230                                     set-src-exprs)))
1231
1232         (cx:make VOID
1233                  (string-append
1234                   ;; ??? do {} while (0); doesn't get "optimized out"
1235                   ;; internally by gcc, meaning two labels and a loop are
1236                   ;; created for it to have to process.  We can generate pretty
1237                   ;; big files and can cause gcc to require *lots* of memory.
1238                   ;; So let's try just {} ...
1239                   "{\n"
1240                   (/gen-par-temp-defns temps)
1241                   set-dests
1242                   set-srcs
1243                   "}\n")
1244                  ))))
1245 )
1246
1247 ;; Subroutine of s-sequence to simplify it.
1248 ;; Return a boolean indicating if GCC's "statement expression" extension
1249 ;; is necessary to implement (sequence MODE ENV EXPR-LIST).
1250 ;; Only use GCC "statement expression" extension if necessary.
1251 ;;
1252 ;; Avoid using statement expressions for
1253 ;; (sequence non-VOID-mode (error "mumble") expr).
1254 ;; Some targets, e.g. cris, use this.
1255
1256 (define (/use-gcc-stmt-expr? mode env expr-list)
1257   (if (not (rtx-env-empty? env))
1258       #t
1259       (case (length expr-list)
1260         ((1) #f)
1261         ((2) (if (eq? (rtx-name (car expr-list)) 'error)
1262                  #f
1263                  #t))
1264         (else #t)))
1265 )
1266
1267 ;; Return a <c-expr> node for a `sequence'.
1268 ;; MODE is the mode name.
1269
1270 (define (s-sequence estate mode env . exprs)
1271   (let* ((env (rtx-env-make-locals env)) ;; compile env
1272          (estate (estate-push-env estate env)))
1273
1274     (if (or (mode:eq? 'DFLT mode) ;; FIXME: DFLT can't appear anymore
1275             (mode:eq? 'VOID mode))
1276
1277         (cx:make VOID
1278                  (string-append
1279                   ;; ??? do {} while (0); doesn't get "optimized out"
1280                   ;; internally by gcc, meaning two labels and a loop are
1281                   ;; created for it to have to process.  We can generate pretty
1282                   ;; big files and can cause gcc to require *lots* of memory.
1283                   ;; So let's try just {} ...
1284                   "{\n"
1285                   (gen-temp-defs estate env)
1286                   (string-map (lambda (e)
1287                                 (rtl-c-with-estate estate VOID e))
1288                               exprs)
1289                   "}\n"))
1290
1291         (let ((use-stmt-expr? (/use-gcc-stmt-expr? mode env exprs)))
1292           (cx:make mode
1293                    (string-append
1294                     (if use-stmt-expr? "({ " "(")
1295                     (gen-temp-defs estate env)
1296                     (string-drop 2
1297                                  (string-map
1298                                   (lambda (e)
1299                                     (string-append
1300                                      (if use-stmt-expr? "; " ", ")
1301                                      ;; Strip off gratuitous ";\n" at end of expressions that
1302                                      ;; misguessed themselves to be in statement context.
1303                                      ;; See s-c-call, s-c-call-raw above.
1304                                      (let ((substmt (rtl-c-with-estate estate DFLT e)))
1305                                        (if (and (not use-stmt-expr?)
1306                                                 (string=? (string-take -2 substmt) ";\n"))
1307                                            (string-drop -2 substmt)
1308                                            substmt))))
1309                                   exprs))
1310                     (if use-stmt-expr? "; })" ")"))))))
1311 )
1312
1313 ; Return a <c-expr> node for a `do-count'.
1314
1315 (define (s-do-count estate iter-var nr-times . exprs)
1316   (let* ((limit-var (rtx-make-iteration-limit-var iter-var))
1317          (env (rtx-env-make-iteration-locals iter-var))
1318          (estate (estate-push-env estate env))
1319          (temp-iter (rtx-temp-lookup (estate-env-stack estate) iter-var))
1320          (temp-limit (rtx-temp-lookup (estate-env-stack estate) limit-var))
1321          (c-iter-var (rtx-temp-value temp-iter))
1322          (c-limit-var (rtx-temp-value temp-limit)))
1323     (cx:make VOID
1324              (string-append
1325               "{\n"
1326               (gen-temp-defs estate env)
1327               "  " c-limit-var " = "
1328               (cx:c (rtl-c-get estate (rtx-temp-mode temp-limit) nr-times))
1329               ";\n"
1330               "  for (" c-iter-var " = 0;\n"
1331               "       " c-iter-var " < " c-limit-var ";\n"
1332               "       ++" c-iter-var ")\n"
1333               "  {\n"
1334               (string-map (lambda (e)
1335                             (rtl-c-with-estate estate VOID e))
1336                           exprs)
1337               "  }\n"
1338               "}\n"))
1339     )
1340 )
1341 \f
1342 ; *****************************************************************************
1343 ;
1344 ; RTL->C generators for each rtx function.
1345
1346 ; Return code to set FN as the generator for RTX.
1347
1348 (defmacro define-fn (rtx args expr . rest)
1349   `(begin
1350      (assert (rtx-lookup (quote ,rtx)))
1351      (vector-set! table (rtx-num (rtx-lookup (quote ,rtx)))
1352                   (lambda ,args ,@(cons expr rest))))
1353 )
1354
1355 (define (rtl-c-init!)
1356   (set! /rtl-c-gen-table (/rtl-c-build-table))
1357   *UNSPECIFIED*
1358 )
1359
1360 ; The rest of this file is one big function to return the rtl->c lookup table.
1361 ; For each of these functions, MODE is the name of the mode.
1362
1363 (define (/rtl-c-build-table)
1364   (let ((table (make-vector (rtx-max-num) #f)))
1365
1366 ; Error generation
1367
1368 (define-fn error (*estate* options mode message)
1369   (let ((c-call (s-c-call *estate* mode "cgen_rtx_error"
1370                           (string-append "\""
1371                                          (backslash "\"" message)
1372                                          "\""))))
1373     (if (mode:eq? mode VOID)
1374         c-call
1375         (cx:make mode (string-append "(" (cx:c c-call) ", 0)"))))
1376 )
1377
1378 ; Enum support
1379
1380 (define-fn enum (*estate* options mode name)
1381   (cx:make mode (string-upcase (gen-c-symbol name)))
1382 )
1383
1384 ; Instruction field support.
1385 ; ??? This should build an operand object like -build-ifield-operand! does
1386 ; in semantics.scm.
1387
1388 (define-fn ifield (*estate* options mode ifld-name)
1389   (if (estate-ifield-var? *estate*)
1390       (cx:make mode (gen-c-symbol ifld-name))
1391       (cx:make mode (string-append "FLD (" (gen-c-symbol ifld-name) ")")))
1392 ;  (let ((f (current-ifld-lookup ifld-name)))
1393 ;    (make <operand> (obj-location f) ifld-name ifld-name
1394 ;         (atlist-cons (bool-attr-make 'SEM-ONLY #t)
1395 ;                      (obj-atlist f))
1396 ;         (obj:name (ifld-hw-type f))
1397 ;         (obj:name (ifld-mode f))
1398 ;         (make <hw-index> 'anonymous
1399 ;               'ifield (ifld-mode f) f)
1400 ;         nil #f #f))
1401 )
1402
1403 ;; Operand support.
1404
1405 (define-fn operand (*estate* options mode object-or-name)
1406   (cond ((operand? object-or-name)
1407          ;; FIXME: <operand> objects is what xop is for
1408          ;; mode checking to be done during canonicalization
1409          object-or-name)
1410         ((symbol? object-or-name)
1411          (let ((object (current-op-lookup object-or-name)))
1412            (if (not object)
1413                (estate-error *estate* "undefined operand" object-or-name))
1414            ;; mode checking to be done during canonicalization
1415            object))
1416         (else
1417          (estate-error *estate* "bad arg to `operand'" object-or-name)))
1418 )
1419
1420 (define-fn xop (*estate* options mode object)
1421   (let ((delayed (assoc '#:delay (estate-modifiers *estate*))))
1422     (if (and delayed
1423              (equal? APPLICATION 'SID-SIMULATOR)
1424              (operand? object))
1425         ;; if we're looking at an operand inside a (delay ...) rtx, then we
1426         ;; are talking about a _delayed_ operand, which is a different
1427         ;; beast.  rather than try to work out what context we were
1428         ;; constructed within, we just clone the operand instance and set
1429         ;; the new one to have a delayed value. the setters and getters
1430         ;; will work it out.
1431         (let ((obj (object-copy object))
1432               (amount (cadr delayed)))
1433           (op:set-delay! obj amount)
1434           obj)
1435         ;; else return the normal object
1436         object)))
1437
1438 (define-fn local (*estate* options mode object-or-name)
1439   (cond ((rtx-temp? object-or-name)
1440          object-or-name)
1441         ((symbol? object-or-name)
1442          (let ((object (rtx-temp-lookup (estate-env-stack *estate*) object-or-name)))
1443            (if (not object)
1444                (estate-error *estate* "undefined local" object-or-name))
1445            object))
1446         (else
1447          (estate-error *estate* "bad arg to `local'" object-or-name)))
1448 )
1449
1450 (define-fn reg (*estate* options mode hw-elm . indx-sel)
1451   (let ((indx (or (list-maybe-ref indx-sel 0) 0))
1452         (sel (or (list-maybe-ref indx-sel 1) hw-selector-default)))
1453     (s-hw *estate* mode hw-elm indx sel))
1454 )
1455
1456 (define-fn raw-reg (*estate* options mode hw-elm . indx-sel)
1457   (let ((indx (or (list-maybe-ref indx-sel 0) 0))
1458         (sel (or (list-maybe-ref indx-sel 1) hw-selector-default)))
1459     (let ((result (s-hw *estate* mode hw-elm indx sel)))
1460       (obj-cons-attr! result (bool-attr-make 'RAW #t))
1461       result))
1462 )
1463
1464 (define-fn mem (*estate* options mode addr . sel)
1465   (s-hw *estate* mode 'h-memory addr
1466         (if (pair? sel) (car sel) hw-selector-default))
1467 )
1468
1469 ; ??? Hmmm... needed?  The pc is usually specified as `pc' which is shorthand
1470 ; for (operand pc).
1471 ;(define-fn pc (*estate* options mode)
1472 ;  s-pc
1473 ;)
1474
1475 (define-fn ref (*estate* options mode name)
1476   (if (not (insn? (estate-owner *estate*)))
1477       (estate-error *estate* "ref: not processing an insn"
1478                     (obj:name (estate-owner *estate*))))
1479   (cx:make 'UINT
1480            (string-append
1481             "(referenced & (1 << "
1482             (number->string
1483              (op:num (insn-lookup-op (estate-owner *estate*) name)))
1484             "))"))
1485 )
1486
1487 ; ??? Maybe this should return an operand object.
1488 (define-fn index-of (*estate* options mode op)
1489   (send (op:index (rtx-eval-with-estate op DFLT *estate*))
1490         'cxmake-get *estate* (mode:lookup mode))
1491 )
1492
1493 (define-fn clobber (*estate* options mode object)
1494   (cx:make VOID "; /*clobber*/\n")
1495 )
1496
1497 (define-fn delay (*estate* options mode num-node rtx)
1498   ;; FIXME: Try to move SID stuff into sid-foo.scm.
1499   (case APPLICATION
1500     ((SID-SIMULATOR)
1501      (let* ((n (cadddr num-node))
1502             (old-delay (let ((old (assoc '#:delay (estate-modifiers *estate*))))
1503                          (if old (cadr old) 0)))
1504             (new-delay (+ n old-delay)))
1505        (begin
1506          ;; check for proper usage
1507          (if (let* ((hw (case (car rtx)
1508                           ((operand) (op:type (current-op-lookup (rtx-arg1 rtx))))
1509                           ((xop) (op:type (rtx-xop-obj rtx)))
1510                           (else #f))))
1511                (not (and hw (or (pc? hw) (memory? hw) (register? hw)))))
1512              (estate-error
1513               *estate*
1514               "(delay ...) rtx applied to wrong type of operand, should be pc, register or memory"
1515                (car rtx)))
1516          ;; signal an error if we're delayed and not in a "parallel-insns" CPU
1517          (if (not (with-parallel?))
1518              (estate-error *estate* "delayed operand in a non-parallel cpu"
1519                            (car rtx)))
1520          ;; update cpu-global pipeline bound
1521          (cpu-set-max-delay! (current-cpu) (max (cpu-max-delay (current-cpu)) new-delay))
1522          ;; pass along new delay to embedded rtx
1523          (rtx-eval-with-estate rtx (mode:lookup mode)
1524                                (estate-with-modifiers *estate* `((#:delay ,new-delay)))))))
1525
1526     ;; not in sid-land
1527     (else (s-sequence (estate-with-modifiers *estate* '((#:delay))) VOID '() rtx)))
1528 )
1529
1530 ; Gets expanded as a macro.
1531 ;(define-fn annul (*estate* yes?)
1532 ;  (s-c-call *estate* 'VOID "SEM_ANNUL_INSN" "pc" yes?)
1533 ;)
1534
1535 (define-fn skip (*estate* options mode yes?)
1536   (send pc 'cxmake-skip *estate* yes?)
1537   ;(s-c-call *estate* 'VOID "SEM_SKIP_INSN" "pc" yes?)
1538 )
1539
1540 (define-fn eq-attr (*estate* options mode obj attr-name value)
1541   (cx:make 'INT
1542            (string-append "(GET_ATTR ("
1543                           (gen-c-symbol attr-name)
1544                           ") == "
1545                           (gen-c-symbol value)
1546                           ")"))
1547 )
1548
1549 (define-fn int-attr (*estate* options mode owner attr-name)
1550   (cond ((or (equal? owner '(current-insn () DFLT)) ;; FIXME: delete in time
1551              (equal? owner '(current-insn () INSN)))
1552          (s-c-raw-call *estate* 'INT "GET_ATTR"
1553                        (string-upcase (gen-c-symbol attr-name))))
1554         (else
1555          (estate-error *estate* "attr: unsupported object type" owner)))
1556 )
1557
1558 (define-fn const (*estate* options mode c)
1559   (assert (not (mode:eq? 'VOID mode)))
1560   (if (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore
1561       (set! mode 'INT))
1562   (let ((mode (mode:lookup mode)))
1563     (cx:make mode
1564              (cond ((or (mode:eq? 'DI mode)
1565                         (mode:eq? 'UDI mode)
1566                         (< #xffffffff c)
1567                         (> #x-80000000 c))
1568                     (string-append "MAKEDI ("
1569                                    (gen-integer (high-part c)) ", "
1570                                    (gen-integer (low-part c))
1571                                    ")"))
1572                    ((and (<= #x-80000000 c) (> #x80000000 c))
1573                     (number->string c))
1574                    ((and (<= #x80000000 c) (>= #xffffffff c))
1575                     ; ??? GCC complains if not affixed with "U" but that's not k&r.
1576                     ;(string-append (number->string val) "U"))
1577                     (string-append "0x" (number->string c 16)))
1578                    ; Else punt.
1579                    (else (number->string c)))))
1580 )
1581
1582 (define-fn join (*estate* options out-mode in-mode arg1 . arg-rest)
1583   ; FIXME: Endianness issues undecided.
1584   ; FIXME: Ensure correct number of args for in/out modes.
1585   ; Ensure compatible modes.
1586   (apply s-c-raw-call (cons *estate*
1587                             (cons out-mode
1588                                   (cons (stringsym-append "JOIN"
1589                                                           in-mode
1590                                                           out-mode)
1591                                         (cons arg1 arg-rest)))))
1592 )
1593
1594 (define-fn subword (*estate* options mode value word-num)
1595   (let* ((mode (mode:lookup mode))
1596          (val (rtl-c-get *estate* DFLT value))
1597          (val-mode (cx:mode val)))
1598     (cx:make mode
1599              (string-append "SUBWORD"
1600                             (obj:str-name val-mode) (obj:str-name mode)
1601                             " (" (cx:c val)
1602                             (if (mode-bigger? val-mode mode)
1603                                 (string-append
1604                                  ", "
1605                                  (if (number? word-num)
1606                                      (number->string word-num)
1607                                      (cx:c (rtl-c-get *estate* DFLT word-num))))
1608                                 "")
1609                             ")")))
1610 )
1611
1612 (define-fn c-code (*estate* options mode text)
1613   (cx:make mode text)
1614 )
1615
1616 (define-fn c-call (*estate* options mode name . args)
1617   (apply s-c-call (cons *estate* (cons mode (cons name args))))
1618 )
1619
1620 (define-fn c-raw-call (*estate* options mode name . args)
1621   (apply s-c-raw-call (cons *estate* (cons mode (cons name args))))
1622 )
1623
1624 (define-fn nop (*estate* options mode)
1625   (cx:make VOID "((void) 0); /*nop*/\n")
1626 )
1627
1628 (define-fn set (*estate* options mode dst src)
1629   (if (estate-for-insn? *estate*)
1630       (rtl-c-set-trace *estate* mode dst src)
1631       (rtl-c-set-quiet *estate* mode dst src))
1632 )
1633
1634 (define-fn set-quiet (*estate* options mode dst src)
1635   (rtl-c-set-quiet *estate* mode dst src)
1636 )
1637
1638 (define-fn neg (*estate* options mode s1)
1639   (s-unop *estate* "NEG" "-" mode s1)
1640 )
1641
1642 (define-fn abs (*estate* options mode s1)
1643   (s-unop *estate* "ABS" #f mode s1)
1644 )
1645
1646 (define-fn inv (*estate* options mode s1)
1647   (s-unop *estate* "INV" "~" mode s1)
1648 )
1649
1650 (define-fn not (*estate* options mode s1)
1651   (s-unop *estate* "NOT" "!" mode s1)
1652 )
1653
1654 (define-fn add (*estate* options mode s1 s2)
1655   (s-binop *estate* "ADD" "+" mode s1 s2)
1656 )
1657 (define-fn sub (*estate* options mode s1 s2)
1658   (s-binop *estate* "SUB" "-" mode s1 s2)
1659 )
1660
1661 (define-fn addc (*estate* options mode s1 s2 s3)
1662   (s-binop-with-bit *estate* "ADDC" mode s1 s2 s3)
1663 )
1664 ;; ??? Whether to rename ADDCF/ADDOF -> ADDCCF/ADDCOF is debatable.
1665 (define-fn addc-cflag (*estate* options mode s1 s2 s3)
1666   (s-binop-with-bit *estate* "ADDCF" mode s1 s2 s3)
1667 )
1668 (define-fn addc-oflag (*estate* options mode s1 s2 s3)
1669   (s-binop-with-bit *estate* "ADDOF" mode s1 s2 s3)
1670 )
1671
1672 (define-fn subc (*estate* options mode s1 s2 s3)
1673   (s-binop-with-bit *estate* "SUBC" mode s1 s2 s3)
1674 )
1675 ;; ??? Whether to rename SUBCF/SUBOF -> SUBCCF/SUBCOF is debatable.
1676 (define-fn subc-cflag (*estate* options mode s1 s2 s3)
1677   (s-binop-with-bit *estate* "SUBCF" mode s1 s2 s3)
1678 )
1679 (define-fn subc-oflag (*estate* options mode s1 s2 s3)
1680   (s-binop-with-bit *estate* "SUBOF" mode s1 s2 s3)
1681 )
1682
1683 ;; ??? These are deprecated.  Delete in time.
1684 (define-fn add-cflag (*estate* options mode s1 s2 s3)
1685   (s-binop-with-bit *estate* "ADDCF" mode s1 s2 s3)
1686 )
1687 (define-fn add-oflag (*estate* options mode s1 s2 s3)
1688   (s-binop-with-bit *estate* "ADDOF" mode s1 s2 s3)
1689 )
1690 (define-fn sub-cflag (*estate* options mode s1 s2 s3)
1691   (s-binop-with-bit *estate* "SUBCF" mode s1 s2 s3)
1692 )
1693 (define-fn sub-oflag (*estate* options mode s1 s2 s3)
1694   (s-binop-with-bit *estate* "SUBOF" mode s1 s2 s3)
1695 )
1696
1697 ;(define-fn zflag (*estate* options mode value)
1698 ;  (list 'eq mode value (list 'const mode 0))
1699 ;)
1700
1701 ;(define-fn nflag (*estate* options mode value)
1702 ;  (list 'lt mode value (list 'const mode 0))
1703 ;)
1704
1705 (define-fn mul (*estate* options mode s1 s2)
1706   (s-binop *estate* "MUL" "*" mode s1 s2)
1707 )
1708 (define-fn div (*estate* options mode s1 s2)
1709   (s-binop *estate* "DIV" "/" mode s1 s2)
1710 )
1711 (define-fn udiv (*estate* options mode s1 s2)
1712   (s-binop *estate* "UDIV" "/" mode s1 s2)
1713 )
1714 (define-fn mod (*estate* options mode s1 s2)
1715   (s-binop *estate* "MOD" "%" mode s1 s2)
1716 )
1717 (define-fn umod (*estate* options mode s1 s2)
1718   (s-binop *estate* "UMOD" "%" mode s1 s2)
1719 )
1720
1721 (define-fn sqrt (*estate* options mode s1)
1722   (s-unop *estate* "SQRT" #f mode s1)
1723 )
1724 (define-fn cos (*estate* options mode s1)
1725   (s-unop *estate* "COS" #f mode s1)
1726 )
1727 (define-fn sin (*estate* options mode s1)
1728   (s-unop *estate* "SIN" #f mode s1)
1729 )
1730
1731 (define-fn min (*estate* options mode s1 s2)
1732   (s-binop *estate* "MIN" #f mode s1 s2)
1733 )
1734 (define-fn max (*estate* options mode s1 s2)
1735   (s-binop *estate* "MAX" #f mode s1 s2)
1736 )
1737 (define-fn umin (*estate* options mode s1 s2)
1738   (s-binop *estate* "UMIN" #f mode s1 s2)
1739 )
1740 (define-fn umax (*estate* options mode s1 s2)
1741   (s-binop *estate* "UMAX" #f mode s1 s2)
1742 )
1743
1744 (define-fn and (*estate* options mode s1 s2)
1745   (s-binop *estate* "AND" "&" mode s1 s2)
1746 )
1747 (define-fn or (*estate* options mode s1 s2)
1748   (s-binop *estate* "OR" "|" mode s1 s2)
1749 )
1750 (define-fn xor (*estate* options mode s1 s2)
1751   (s-binop *estate* "XOR" "^" mode s1 s2)
1752 )
1753
1754 (define-fn sll (*estate* options mode s1 s2)
1755   (s-shop *estate* "SLL" "<<" mode s1 s2)
1756 )
1757 (define-fn srl (*estate* options mode s1 s2)
1758   (s-shop *estate* "SRL" ">>" mode s1 s2)
1759 )
1760 (define-fn sra (*estate* options mode s1 s2)
1761   (s-shop *estate* "SRA" ">>" mode s1 s2)
1762 )
1763 (define-fn ror (*estate* options mode s1 s2)
1764   (s-shop *estate* "ROR" #f mode s1 s2)
1765 )
1766 (define-fn rol (*estate* options mode s1 s2)
1767   (s-shop *estate* "ROL" #f mode s1 s2)
1768 )
1769
1770 (define-fn andif (*estate* options mode s1 s2)
1771   (s-boolifop *estate* "ANDIF" "&&" s1 s2)
1772 )
1773 (define-fn orif (*estate* options mode s1 s2)
1774   (s-boolifop *estate* "ORIF" "||" s1 s2)
1775 )
1776
1777 (define-fn ext (*estate* options mode s1)
1778   (s-convop *estate* "EXT" mode s1)
1779 )
1780 (define-fn zext (*estate* options mode s1)
1781   (s-convop *estate* "ZEXT" mode s1)
1782 )
1783 (define-fn trunc (*estate* options mode s1)
1784   (s-convop *estate* "TRUNC" mode s1)
1785 )
1786 (define-fn fext (*estate* options mode s1)
1787   (s-convop *estate* "FEXT" mode s1)
1788 )
1789 (define-fn ftrunc (*estate* options mode s1)
1790   (s-convop *estate* "FTRUNC" mode s1)
1791 )
1792 (define-fn float (*estate* options mode s1)
1793   (s-convop *estate* "FLOAT" mode s1)
1794 )
1795 (define-fn ufloat (*estate* options mode s1)
1796   (s-convop *estate* "UFLOAT" mode s1)
1797 )
1798 (define-fn fix (*estate* options mode s1)
1799   (s-convop *estate* "FIX" mode s1)
1800 )
1801 (define-fn ufix (*estate* options mode s1)
1802   (s-convop *estate* "UFIX" mode s1)
1803 )
1804
1805 (define-fn eq (*estate* options mode s1 s2)
1806   (s-cmpop *estate* 'eq "==" mode s1 s2)
1807 )
1808 (define-fn ne (*estate* options mode s1 s2)
1809   (s-cmpop *estate* 'ne "!=" mode s1 s2)
1810 )
1811
1812 (define-fn lt (*estate* options mode s1 s2)
1813   (s-cmpop *estate* 'lt "<" mode s1 s2)
1814 )
1815 (define-fn le (*estate* options mode s1 s2)
1816   (s-cmpop *estate* 'le "<=" mode s1 s2)
1817 )
1818 (define-fn gt (*estate* options mode s1 s2)
1819   (s-cmpop *estate* 'gt ">" mode s1 s2)
1820 )
1821 (define-fn ge (*estate* options mode s1 s2)
1822   (s-cmpop *estate* 'ge ">=" mode s1 s2)
1823 )
1824
1825 (define-fn ltu (*estate* options mode s1 s2)
1826   (s-cmpop *estate* 'ltu "<" mode s1 s2)
1827 )
1828 (define-fn leu (*estate* options mode s1 s2)
1829   (s-cmpop *estate* 'leu "<=" mode s1 s2)
1830 )
1831 (define-fn gtu (*estate* options mode s1 s2)
1832   (s-cmpop *estate* 'gtu ">" mode s1 s2)
1833 )
1834 (define-fn geu (*estate* options mode s1 s2)
1835   (s-cmpop *estate* 'geu ">=" mode s1 s2)
1836 )
1837
1838 (define-fn member (*estate* options mode value set)
1839   ;; NOTE: There are multiple evalutions of VALUE in the generated code.
1840   ;; It's probably ok, this comment is more for completeness sake.
1841   (let ((c-value (rtl-c-get *estate* mode value))
1842         (set (rtx-number-list-values set)))
1843     (let loop ((set (cdr set))
1844                (code (string-append "(" (cx:c c-value)
1845                                     " == "
1846                                     (gen-integer (car set))
1847                                     ")")))
1848       (if (null? set)
1849           (cx:make (mode:lookup 'BI) (string-append "(" code ")"))
1850           (loop (cdr set)
1851                 (string-append code
1852                                " || ("
1853                                (cx:c c-value)
1854                                " == "
1855                                (gen-integer (car set))
1856                                ")")))))
1857 )
1858
1859 (define-fn if (*estate* options mode cond then . else)
1860   (apply s-if (append! (list *estate* mode cond then) else))
1861 )
1862
1863 (define-fn cond (*estate* options mode . cond-code-list)
1864   (apply s-cond (cons *estate* (cons mode cond-code-list)))
1865 )
1866
1867 (define-fn case (*estate* options mode test . case-list)
1868   (apply s-case (cons *estate* (cons mode (cons test case-list))))
1869 )
1870
1871 (define-fn parallel (*estate* options mode ignore expr . exprs)
1872   (apply s-parallel (cons *estate* (cons expr exprs)))
1873 )
1874
1875 (define-fn sequence (*estate* options mode locals expr . exprs)
1876   (apply s-sequence
1877          (cons *estate* (cons mode (cons locals (cons expr exprs)))))
1878 )
1879
1880 (define-fn do-count (*estate* options mode iter-var nr-times expr . exprs)
1881   (apply s-do-count
1882          (cons *estate* (cons iter-var (cons nr-times (cons expr exprs)))))
1883 )
1884
1885 (define-fn closure (*estate* options mode isa-name-list env-stack expr)
1886   (rtl-c-with-estate (estate-make-closure *estate* isa-name-list
1887                                           (rtx-make-env-stack env-stack))
1888                      (mode:lookup mode) expr)
1889 )
1890 \f
1891 ;; The result is the rtl->c generator table.
1892 ;; FIXME: verify all elements are filled
1893
1894 table
1895
1896 )) ;; End of /rtl-c-build-table