cgen/rtl-c.scm

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