cgen/rtl-xform.scm

   1 ;; Various RTL transformations.
   2 ;;
   3 ;; Copyright (C) 2000, 2009 Red Hat, Inc.
   4 ;; This file is part of CGEN.
   5 ;; See file COPYING.CGEN for details.
   6 ;;
   7 ;; In particular:
   8 ;; rtx-simplify
   9 ;; rtx-solve
  10 ;; rtx-trim-for-doc
  11 \f
  12 ;; Utility to verify there are no DFLT modes present in EXPR
  13
  14 ;; Subroutine of rtx-verify-no-dflt-modes to simplify it.
  15 ;; This is the EXPR-FN argument to rtl-traverse.
  16
  17 (define (/rtx-verify-no-dflt-modes-expr-fn rtx-obj expr parent-expr op-pos
  18                                            tstate appstuff)
  19   (if (eq? (rtx-mode expr) 'DFLT)
  20       (tstate-error tstate "DFLT mode present" expr))
  21
  22   ;; Leave EXPR unchanged and continue.
  23   #f
  24 )
  25
  26 ;; Entry point.  Verify there are no DFLT modes in EXPR.
  27
  28 (define (rtx-verify-no-dflt-modes context expr)
  29   (rtx-traverse context #f expr /rtx-verify-no-dflt-modes-expr-fn #f)
  30 )
  31 \f
  32 ;; rtx-simplify (and supporting cast)
  33
  34 ; Subroutine of /rtx-simplify-expr-fn to compare two values for equality.
  35 ; If both are constants and they're equal return #f/#t.
  36 ; INVERT? = #f -> return #t if equal, #t -> return #f if equal.
  37 ; Returns 'unknown if either argument is not a constant.
  38
  39 (define (/rtx-const-equal arg0 arg1 invert?)
  40   (if (and (rtx-constant? arg0)
  41            (rtx-constant? arg1))
  42       (if invert?
  43           (!= (rtx-constant-value arg0)
  44               (rtx-constant-value arg1))
  45           (= (rtx-constant-value arg0)
  46              (rtx-constant-value arg1)))
  47       'unknown)
  48 )
  49
  50 ; Subroutine of /rtx-simplify-expr-fn to see if MAYBE-CONST is
  51 ; an element of NUMBER-LIST.
  52 ; NUMBER-LIST is a `number-list' rtx.
  53 ; INVERT? is #t if looking for non-membership.
  54 ; #f/#t is only returned for definitive answers.
  55 ; If INVERT? is #f:
  56 ; - return #f if MAYBE-CONST is not in NUMBER-LIST
  57 ; - return #t if MAYBE-CONST is in NUMBER-LIST and it has only one member
  58 ; - return 'member if MAYBE-CONST is in NUMBER-LIST and it has many members
  59 ; - otherwise return 'unknown
  60 ; If INVERT? is #t:
  61 ; - return #t if MAYBE-CONST is not in NUMBER-LIST
  62 ; - return #f if MAYBE-CONST is in NUMBER-LIST and it has only one member
  63 ; - return 'member if MAYBE-CONST is in NUMBER-LIST and it has many members
  64 ; - otherwise return 'unknown
  65
  66 (define (/rtx-const-list-equal maybe-const number-list invert?)
  67   (assert (rtx-kind? 'number-list number-list))
  68   (if (rtx-constant? maybe-const)
  69       (let ((values (rtx-number-list-values number-list)))
  70         (if invert?
  71             (if (memq (rtx-constant-value maybe-const) values)
  72                 (if (= (length values) 1)
  73                     #f
  74                     'member)
  75                 #t)
  76             (if (memq (rtx-constant-value maybe-const) values)
  77                 (if (= (length values) 1)
  78                     #t
  79                     'member)
  80                 #f)))
  81       'unknown)
  82 )
  83
  84 ; Subroutine of /rtx-simplify-expr-fn to simplify an eq-attr of (current-mach).
  85 ; CONTEXT is a <context> object or #f if there is none.
  86
  87 (define (/rtx-simplify-eq-attr-mach rtx context)
  88   (let ((attr (rtx-eq-attr-attr rtx))
  89         (value (rtx-eq-attr-value rtx)))
  90     ; If all currently selected machs will yield the same value
  91     ; for the attribute, we can simplify.
  92     (let ((values (map (lambda (m)
  93                          (obj-attr-value m attr))
  94                        (current-mach-list))))
  95       ; Ensure at least one mach is selected.
  96       (if (null? values)
  97           (context-error context
  98                          "While simplifying rtl"
  99                          "no machs selected"
 100                          (rtx-strdump rtx)))
 101       ; All values equal to the first one?
 102       (if (all-true? (map (lambda (val)
 103                             (equal? val (car values)))
 104                           values))
 105           (if (equal? value
 106                       ; Convert internal boolean attribute value
 107                       ; #f/#t to external value FALSE/TRUE.
 108                       ; FIXME:revisit.
 109                       (case (car values)
 110                         ((#f) 'FALSE)
 111                         ((#t) 'TRUE)
 112                         (else (car values))))
 113               (rtx-true)
 114               (rtx-false))
 115           ; couldn't simplify
 116           rtx)))
 117 )
 118
 119 ; Subroutine of /rtx-simplify-expr-fn to simplify an eq-attr of (current-insn).
 120
 121 (define (/rtx-simplify-eq-attr-insn rtx insn context)
 122   (let ((attr (rtx-eq-attr-attr rtx))
 123         (value (rtx-eq-attr-value rtx)))
 124     (if (not (insn? insn))
 125         (context-error context
 126                        "While simplifying rtl"
 127                        "No current insn for `(current-insn)'"
 128                        (rtx-strdump rtx)))
 129     (let ((attr-value (obj-attr-value insn attr)))
 130       (if (eq? value attr-value)
 131           (rtx-true)
 132           (rtx-false))))
 133 )
 134
 135 ; Subroutine of rtx-simplify.
 136 ; This is the EXPR-FN argument to rtx-traverse.
 137
 138 (define (/rtx-simplify-expr-fn rtx-obj expr parent-expr op-pos
 139                                tstate appstuff)
 140
 141   ;(display "Processing ") (display (rtx-dump expr)) (newline)
 142
 143   (case (rtx-name expr)
 144
 145     ((not)
 146      (let* ((arg (/rtx-traverse (rtx-alu-op-arg expr 0)
 147                                 'RTX expr 1 tstate appstuff))
 148             (no-side-effects? (not (rtx-side-effects? arg))))
 149        (cond ((and no-side-effects? (rtx-false? arg))
 150               (rtx-true))
 151              ((and no-side-effects? (rtx-true? arg))
 152               (rtx-false))
 153              (else (rtx-make 'not (rtx-alu-op-mode expr) arg)))))
 154
 155     ((orif)
 156      (let ((arg0 (/rtx-traverse (rtx-boolif-op-arg expr 0)
 157                                 'RTX expr 0 tstate appstuff))
 158            (arg1 (/rtx-traverse (rtx-boolif-op-arg expr 1)
 159                                 'RTX expr 1 tstate appstuff)))
 160        (let ((no-side-effects-0? (not (rtx-side-effects? arg0)))
 161              (no-side-effects-1? (not (rtx-side-effects? arg1))))
 162          (cond ((and no-side-effects-0? (rtx-true? arg0))
 163                 (rtx-true))
 164                ((and no-side-effects-0? (rtx-false? arg0))
 165                 (rtx-canonical-bool arg1))
 166                ; Value of arg0 is unknown or has side-effects.
 167                ((and no-side-effects-1? (rtx-true? arg1))
 168                 (if no-side-effects-0?
 169                     (rtx-true)
 170                     (rtx-make 'orif arg0 (rtx-true))))
 171                ((and no-side-effects-1? (rtx-false? arg1))
 172                 arg0)
 173                (else
 174                 (rtx-make 'orif arg0 arg1))))))
 175
 176     ((andif)
 177      (let ((arg0 (/rtx-traverse (rtx-boolif-op-arg expr 0)
 178                                 'RTX expr 0 tstate appstuff))
 179            (arg1 (/rtx-traverse (rtx-boolif-op-arg expr 1)
 180                                 'RTX expr 1 tstate appstuff)))
 181        (let ((no-side-effects-0? (not (rtx-side-effects? arg0)))
 182              (no-side-effects-1? (not (rtx-side-effects? arg1))))
 183          (cond ((and no-side-effects-0? (rtx-false? arg0))
 184                 (rtx-false))
 185                ((and no-side-effects-0? (rtx-true? arg0))
 186                 (rtx-canonical-bool arg1))
 187                ; Value of arg0 is unknown or has side-effects.
 188                ((and no-side-effects-1? (rtx-false? arg1))
 189                 (if no-side-effects-0?
 190                     (rtx-false)
 191                     (rtx-make 'andif arg0 (rtx-false))))
 192                ((and no-side-effects-1? (rtx-true? arg1))
 193                 arg0)
 194                (else
 195                 (rtx-make 'andif arg0 arg1))))))
 196
 197     ; Fold if's to their then or else part if we can determine the
 198     ; result of the test.
 199     ((if)
 200      (let ((test
 201             ; ??? Was this but that calls rtx-traverse again which
 202             ; resets the temp stack!
 203             ; (rtx-simplify context (caddr expr))))
 204             (/rtx-traverse (rtx-if-test expr) 'RTX expr 1 tstate appstuff)))
 205        (cond ((rtx-true? test)
 206               (/rtx-traverse (rtx-if-then expr) 'RTX expr 2 tstate appstuff))
 207              ((rtx-false? test)
 208               (if (rtx-if-else expr)
 209                   (/rtx-traverse (rtx-if-else expr) 'RTX expr 3 tstate appstuff)
 210                   ; Sanity check, mode must be VOID.
 211                   ; FIXME: DFLT can no longer appear
 212                   (if (or (mode:eq? 'DFLT (rtx-mode expr))
 213                           (mode:eq? 'VOID (rtx-mode expr)))
 214                       (rtx-make 'nop 'VOID)
 215                       (error "rtx-simplify: non-void-mode `if' missing `else' part" expr))))
 216              ; Can't simplify.
 217              ; We could traverse the then/else clauses here, but it's simpler
 218              ; to have our caller do it (by returning #f).
 219              ; The cost is retraversing `test'.
 220              (else #f))))
 221
 222     ((eq ne)
 223      (let ((name (rtx-name expr))
 224            (cmp-mode (rtx-cmp-op-mode expr))
 225            (arg0 (/rtx-traverse (rtx-cmp-op-arg expr 0) 'RTX
 226                                 expr 1 tstate appstuff))
 227            (arg1 (/rtx-traverse (rtx-cmp-op-arg expr 1) 'RTX
 228                                 expr 2 tstate appstuff)))
 229        (if (or (rtx-side-effects? arg0) (rtx-side-effects? arg1))
 230            (rtx-make name cmp-mode arg0 arg1)
 231            (case (/rtx-const-equal arg0 arg1 (rtx-kind? 'ne expr))
 232              ((#f) (rtx-false))
 233              ((#t) (rtx-true))
 234              (else
 235               ; That didn't work.  See if we have an ifield/operand with a
 236               ; known range of values.  We don't need to check for a known
 237               ; single value, that is handled below.
 238               (case (rtx-name arg0)
 239                 ((ifield)
 240                  (let ((known-val (tstate-known-lookup tstate
 241                                                        (rtx-ifield-name arg0))))
 242                    (if (and known-val (rtx-kind? 'number-list known-val))
 243                        (case (/rtx-const-list-equal arg1 known-val
 244                                                     (rtx-kind? 'ne expr))
 245                          ((#f) (rtx-false))
 246                          ((#t) (rtx-true))
 247                          (else
 248                           (rtx-make name cmp-mode arg0 arg1)))
 249                        (rtx-make name cmp-mode arg0 arg1))))
 250                 ((operand)
 251                  (let ((known-val (tstate-known-lookup tstate
 252                                                        (rtx-operand-name arg0))))
 253                    (if (and known-val (rtx-kind? 'number-list known-val))
 254                        (case (/rtx-const-list-equal arg1 known-val
 255                                                     (rtx-kind? 'ne expr))
 256                          ((#f) (rtx-false))
 257                          ((#t) (rtx-true))
 258                          (else
 259                           (rtx-make name cmp-mode arg0 arg1)))
 260                        (rtx-make name cmp-mode arg0 arg1))))
 261                 (else
 262                  (rtx-make name cmp-mode arg0 arg1))))))))
 263
 264     ; Recognize attribute requests of current-insn, current-mach.
 265     ((eq-attr)
 266      (cond ((rtx-kind? 'current-mach (rtx-eq-attr-owner expr))
 267             (/rtx-simplify-eq-attr-mach expr (tstate-context tstate)))
 268            ((rtx-kind? 'current-insn (rtx-eq-attr-owner expr))
 269             (/rtx-simplify-eq-attr-insn expr (tstate-owner tstate) (tstate-context tstate)))
 270            (else expr)))
 271
 272     ((ifield)
 273      (let ((known-val (tstate-known-lookup tstate (rtx-ifield-name expr))))
 274        ; If the value is a single number, return that.
 275        ; It can be one of several, represented as a number list.
 276        (if (and known-val (rtx-constant? known-val))
 277            known-val ; (rtx-make 'const 'INT known-val)
 278            #f)))
 279
 280     ((operand)
 281      (let ((known-val (tstate-known-lookup tstate (rtx-operand-name expr))))
 282        ; If the value is a single number, return that.
 283        ; It can be one of several, represented as a number list.
 284        (if (and known-val (rtx-constant? known-val))
 285            known-val ; (rtx-make 'const 'INT known-val)
 286            #f)))
 287
 288     ((closure)
 289      (let ((simplified-expr (/rtx-traverse (rtx-closure-expr expr)
 290                                            'RTX expr 2 tstate appstuff)))
 291        simplified-expr))
 292
 293     ; Leave EXPR unchanged and continue.
 294     (else #f))
 295 )
 296
 297 ; Simplify an rtl expression.
 298 ;
 299 ; EXPR must be in canonical source form.
 300 ; The result is a possibly simplified EXPR, still in source form.
 301 ;
 302 ; CONTEXT is a <context> object or #f, used for error messages.
 303 ; OWNER is the owner of the expression (e.g. <insn>) or #f if there is none.
 304 ;
 305 ; KNOWN is an alist of known values.  Each element is (name . value) where
 306 ; NAME is an ifield/operand name and VALUE is a const/number-list rtx.
 307 ; FIXME: Need ranges, later.
 308 ;
 309 ; The following operations are performed:
 310 ; - unselected machine dependent code is removed (eq-attr of (current-mach))
 311 ; - if's are reduced to either then/else if we can determine that the test is
 312 ;   a compile-time constant
 313 ; - orif/andif
 314 ; - eq/ne
 315 ; - not
 316 ;
 317 ; ??? Will become more intelligent as needed.
 318
 319 (define (rtx-simplify context owner expr known)
 320   (/rtx-traverse expr #f #f 0
 321                  (tstate-make context owner
 322                               /rtx-simplify-expr-fn
 323                               #f ;; ok since EXPR is fully canonical
 324                               (rtx-env-empty-stack)
 325                               #f known 0)
 326                  #f)
 327 )
 328
 329 ;; Return an insn's semantics simplified.
 330 ;; CONTEXT is a <context> object or #f, used for error messages.
 331
 332 (define (rtx-simplify-insn context insn)
 333   (rtx-simplify context insn (insn-canonical-semantics insn)
 334                 (insn-build-known-values insn))
 335 )
 336 \f
 337 ;; rtx-solve (and supporting cast)
 338
 339 ; Utilities for equation solving.
 340 ; ??? At the moment this is only focused on ifield assertions.
 341 ; ??? That there exist more sophisticated versions than this one can take
 342 ; as a given.  This works for the task at hand and will evolve or be replaced
 343 ; as necessary.
 344 ; ??? This makes the simplifying assumption that no expr has side-effects.
 345
 346 ; Subroutine of rtx-solve.
 347 ; This is the EXPR-FN argument to rtx-traverse.
 348
 349 (define (/solve-expr-fn rtx-obj expr parent-expr op-pos tstate appstuff)
 350   #f ; wip
 351 )
 352
 353 ; Return a boolean indicating if {expr} equates to "true".
 354 ; If the expression can't be reduced to #f/#t, return '?.
 355 ; ??? Use rtx-eval instead of rtx-traverse?
 356 ;
 357 ; EXPR must be in source form.
 358 ; CONTEXT is a <context> object, used for error messages.
 359 ; OWNER is the owner of the expression (e.g. <insn>) or #f if there is none.
 360 ; KNOWN is an alist of known values.  Each element is (name . value) where
 361 ; NAME is an ifield/operand name and VALUE is a const/number-list rtx.
 362 ; FIXME: Need ranges, later.
 363 ;
 364 ; This is akin to rtx-simplify except it's geared towards solving ifield
 365 ; assertions.  It's not unreasonable to combine them.  The worry is the
 366 ; efficiency lost.
 367 ; ??? Will become more intelligent as needed.
 368
 369 (define (rtx-solve context owner expr known)
 370   ; First simplify, then solve.
 371   (let* ((simplified-expr (rtx-simplify context owner expr known))
 372          (maybe-solved-expr
 373           simplified-expr) ; FIXME: for now
 374 ;         (/rtx-traverse simplified-expr #f #f 0
 375 ;                        (tstate-make context owner
 376 ;                                     /solve-expr-fn
 377 ;                                     #f (rtx-env-empty-stack)
 378 ;                                     #f known 0)
 379 ;                        #f))
 380          )
 381     (cond ((rtx-true? maybe-solved-expr) #t)
 382           ((rtx-false? maybe-solved-expr) #f)
 383           (else '?)))
 384 )
 385 \f
 386 ;; rtx-trim-for-doc (and supporting cast)
 387 ;; RTX trimming (removing fluff not normally needed for the human viewer).
 388
 389 ;; Subroutine of /rtx-trim-args to simplify it.
 390 ;; Trim a list of rtxes.
 391
 392 (define (/rtx-trim-rtx-list rtx-list)
 393   (map /rtx-rtim-for-doc rtx-list)
 394 )
 395
 396 ; Subroutine of /rtx-trim-for-doc to simplify it.
 397 ; Trim all the arguments of rtx NAME.
 398
 399 (define (/rtx-trim-args name args)
 400   (let* ((rtx-obj (rtx-lookup name))
 401          (arg-types (rtx-arg-types rtx-obj)))
 402
 403     (let loop ((args args)
 404                (types (cddr arg-types)) ; skip options, mode
 405                (result nil))
 406
 407       (if (null? args)
 408
 409           (reverse! result)
 410
 411           (let ((arg (car args))
 412                 ; Remember, types may be an improper list.
 413                 (type (if (pair? types) (car types) types))
 414                 (new-arg (car args)))
 415
 416             ;(display arg (current-error-port)) (newline (current-error-port))
 417             ;(display type (current-error-port)) (newline (current-error-port))
 418
 419             (case type
 420               ((OPTIONS)
 421                (assert #f)) ; shouldn't get here
 422
 423               ((ANYINTMODE ANYFLOATMODE ANYNUMMODE ANYEXPRMODE EXPLNUMMODE
 424                 VOIDORNUMMODE VOIDMODE BIMODE INTMODE
 425                 SYMMODE INSNMODE MACHMODE)
 426                #f) ; leave arg untouched
 427
 428               ((RTX SETRTX TESTRTX)
 429                (set! new-arg (/rtx-trim-for-doc arg)))
 430
 431               ((CONDRTX)
 432                (assert (= (length arg) 2))
 433                (if (eq? (car arg) 'else)
 434                    (set! new-arg (cons 'else (/rtx-trim-for-doc (cadr arg))))
 435                    (set! new-arg (list (/rtx-trim-for-doc (car arg))
 436                                        (/rtx-trim-for-doc (cadr arg)))))
 437                )
 438
 439               ((CASERTX)
 440                (assert (= (length arg) 2))
 441                (set! new-arg (list (car arg) (/rtx-trim-for-doc (cadr arg))))
 442                )
 443
 444               ((LOCALS)
 445                #f) ; leave arg untouched
 446
 447               ((ITERATION SYMBOLLIST ENVSTACK)
 448                #f) ; leave arg untouched for now
 449
 450               ((ATTRS)
 451                #f) ; leave arg untouched for now
 452
 453               ((SYMBOL STRING NUMBER SYMORNUM)
 454                #f) ; leave arg untouched
 455
 456               ((OBJECT)
 457                (assert #f)) ; hopefully(wip!) shouldn't get here
 458
 459               (else
 460                (assert #f))) ; unknown arg type
 461
 462             (loop (cdr args)
 463                   (if (pair? types) (cdr types) types)
 464                   (cons new-arg result))))))
 465 )
 466
 467 ; Given a canonical rtl expression, usually the result of rtx-simplify,
 468 ; remove bits unnecessary for documentation purposes.
 469 ; Canonical rtl too verbose for docs.
 470 ; Examples of things to remove:
 471 ; - empty options list
 472 ; - ifield/operand/local/const wrappers
 473 ;
 474 ; NOTE: While having to trim the result of rtx-simplify may seem ironic,
 475 ; it isn't.  You need to keep separate the notions of simplifying "1+1" to "2"
 476 ; and trimming the clutter from "(const () BI 0)" yielding "0".
 477
 478 (define (/rtx-trim-for-doc rtx)
 479   (if (pair? rtx) ; ??? cheap rtx?
 480
 481       (let ((name (car rtx))
 482             (options (cadr rtx))
 483             (mode (caddr rtx))
 484             (rest (cdddr rtx)))
 485
 486         (case name
 487
 488           ((const ifield operand local)
 489            (if (null? options)
 490                (car rest)
 491                rtx))
 492
 493           ((set)
 494            (let ((trimmed-args (/rtx-trim-args name rest)))
 495              (if (null? options)
 496                  (cons name trimmed-args)
 497                  (cons name (cons options (cons mode trimmed-args))))))
 498
 499           ((if)
 500            (let ((trimmed-args (/rtx-trim-args name rest)))
 501              (if (null? options)
 502                  (if (eq? mode 'VOID)
 503                      (cons name trimmed-args)
 504                      (cons name (cons mode trimmed-args)))
 505                  (cons name (cons options (cons mode trimmed-args))))))
 506
 507           ((sequence parallel)
 508            ; No special support is needed, except it's nice to remove nop
 509            ; statements.  These can be created when an `if' get simplified.
 510            (let ((trimmed-args (/rtx-trim-args name rest))
 511                  (result nil))
 512              (for-each (lambda (rtx)
 513                          (if (equal? rtx '(nop))
 514                              #f ; ignore
 515                              (set! result (cons rtx result))))
 516                        trimmed-args)
 517              (if (null? options)
 518                  (if (eq? mode 'VOID)
 519                      (cons name (reverse result))
 520                      (cons name (cons mode (reverse result))))
 521                  (cons name (cons options (cons mode (reverse result)))))))
 522
 523           ((closure)
 524            ;; Remove outer closures, they are artificially added, and are
 525            ;; basically noise to the human trying to understand the semantics.
 526            ;; ??? Since we currently can't distinguish outer closures,
 527            ;; just remove them all.
 528            (let ((trimmed-expr (/rtx-trim-for-doc (rtx-closure-expr rtx))))
 529              (if (and (null? options) (null? (rtx-closure-env-stack rtx)))
 530                  trimmed-expr
 531                  (rtx-make 'closure options mode
 532                            (rtx-closure-isas rtx)
 533                            (rtx-closure-env-stack rtx)
 534                            trimmed-expr))))
 535
 536           (else
 537            (let ((trimmed-args (/rtx-trim-args name rest)))
 538              (if (null? options)
 539                  (if (eq? mode 'DFLT) ;; FIXME: DFLT can no longer appear
 540                      (cons name trimmed-args)
 541                      (cons name (cons mode trimmed-args)))
 542                  (cons name (cons options (cons mode trimmed-args))))))))
 543
 544       ; Not an rtx expression, must be number, symbol, string.
 545       rtx)
 546 )
 547
 548 (define (rtx-trim-for-doc rtx)
 549   (/rtx-trim-for-doc rtx)
 550 )