1 ;; Various RTL transformations.
3 ;; Copyright (C) 2000, 2009 Red Hat, Inc.
4 ;; This file is part of CGEN.
5 ;; See file COPYING.CGEN for details.
12 ;; Utility to verify there are no DFLT modes present in EXPR
14 ;; Subroutine of rtx-verify-no-dflt-modes to simplify it.
15 ;; This is the EXPR-FN argument to rtl-traverse.
17 (define (/rtx-verify-no-dflt-modes-expr-fn rtx-obj expr parent-expr op-pos
19 (if (eq? (rtx-mode expr) 'DFLT)
20 (tstate-error tstate "DFLT mode present" expr))
22 ;; Leave EXPR unchanged and continue.
26 ;; Entry point. Verify there are no DFLT modes in EXPR.
28 (define (rtx-verify-no-dflt-modes context expr)
29 (rtx-traverse context #f expr /rtx-verify-no-dflt-modes-expr-fn #f)
32 ;; rtx-simplify (and supporting cast)
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.
39 (define (/rtx-const-equal arg0 arg1 invert?)
40 (if (and (rtx-constant? arg0)
43 (!= (rtx-constant-value arg0)
44 (rtx-constant-value arg1))
45 (= (rtx-constant-value arg0)
46 (rtx-constant-value arg1)))
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.
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
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
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)))
71 (if (memq (rtx-constant-value maybe-const) values)
72 (if (= (length values) 1)
76 (if (memq (rtx-constant-value maybe-const) values)
77 (if (= (length values) 1)
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.
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.
97 (context-error context
98 "While simplifying rtl"
101 ; All values equal to the first one?
102 (if (all-true? (map (lambda (val)
103 (equal? val (car values)))
106 ; Convert internal boolean attribute value
107 ; #f/#t to external value FALSE/TRUE.
112 (else (car values))))
119 ; Subroutine of /rtx-simplify-expr-fn to simplify an eq-attr of (current-insn).
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)'"
129 (let ((attr-value (obj-attr-value insn attr)))
130 (if (eq? value attr-value)
135 ; Subroutine of rtx-simplify.
136 ; This is the EXPR-FN argument to rtx-traverse.
138 (define (/rtx-simplify-expr-fn rtx-obj expr parent-expr op-pos
141 ;(display "Processing ") (display (rtx-dump expr)) (newline)
143 (case (rtx-name expr)
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))
151 ((and no-side-effects? (rtx-true? arg))
153 (else (rtx-make 'not (rtx-alu-op-mode expr) arg)))))
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))
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?
170 (rtx-make 'orif arg0 (rtx-true))))
171 ((and no-side-effects-1? (rtx-false? arg1))
174 (rtx-make 'orif arg0 arg1))))))
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))
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?
191 (rtx-make 'andif arg0 (rtx-false))))
192 ((and no-side-effects-1? (rtx-true? arg1))
195 (rtx-make 'andif arg0 arg1))))))
197 ; Fold if's to their then or else part if we can determine the
198 ; result of the 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))
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))))
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'.
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))
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)
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))
248 (rtx-make name cmp-mode arg0 arg1)))
249 (rtx-make name cmp-mode arg0 arg1))))
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))
259 (rtx-make name cmp-mode arg0 arg1)))
260 (rtx-make name cmp-mode arg0 arg1))))
262 (rtx-make name cmp-mode arg0 arg1))))))))
264 ; Recognize attribute requests of current-insn, current-mach.
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)))
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)
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)
289 (let ((simplified-expr (/rtx-traverse (rtx-closure-expr expr)
290 'RTX expr 2 tstate appstuff)))
293 ; Leave EXPR unchanged and continue.
297 ; Simplify an rtl expression.
299 ; EXPR must be in canonical source form.
300 ; The result is a possibly simplified EXPR, still in source form.
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.
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.
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
317 ; ??? Will become more intelligent as needed.
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)
329 ;; Return an insn's semantics simplified.
330 ;; CONTEXT is a <context> object or #f, used for error messages.
332 (define (rtx-simplify-insn context insn)
333 (rtx-simplify context insn (insn-canonical-semantics insn)
334 (insn-build-known-values insn))
337 ;; rtx-solve (and supporting cast)
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
344 ; ??? This makes the simplifying assumption that no expr has side-effects.
346 ; Subroutine of rtx-solve.
347 ; This is the EXPR-FN argument to rtx-traverse.
349 (define (/solve-expr-fn rtx-obj expr parent-expr op-pos tstate appstuff)
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?
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.
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
367 ; ??? Will become more intelligent as needed.
369 (define (rtx-solve context owner expr known)
370 ; First simplify, then solve.
371 (let* ((simplified-expr (rtx-simplify context owner expr known))
373 simplified-expr) ; FIXME: for now
374 ; (/rtx-traverse simplified-expr #f #f 0
375 ; (tstate-make context owner
377 ; #f (rtx-env-empty-stack)
381 (cond ((rtx-true? maybe-solved-expr) #t)
382 ((rtx-false? maybe-solved-expr) #f)
386 ;; rtx-trim-for-doc (and supporting cast)
387 ;; RTX trimming (removing fluff not normally needed for the human viewer).
389 ;; Subroutine of /rtx-trim-args to simplify it.
390 ;; Trim a list of rtxes.
392 (define (/rtx-trim-rtx-list rtx-list)
393 (map /rtx-rtim-for-doc rtx-list)
396 ; Subroutine of /rtx-trim-for-doc to simplify it.
397 ; Trim the arguments of rtx NAME.
398 ; ARGS has already had options,mode removed.
400 (define (/rtx-trim-args name args)
401 (logit 4 "Trimming args of " name ": " args "\n")
402 (let* ((rtx-obj (rtx-lookup name))
403 (arg-types (rtx-arg-types rtx-obj)))
405 (let loop ((args args)
406 (types (cddr arg-types)) ; skip options, mode
413 (let ((arg (car args))
414 ; Remember, types may be an improper list.
415 (type (if (pair? types) (car types) types))
416 (new-arg (car args)))
418 ;(display arg (current-error-port)) (newline (current-error-port))
419 ;(display type (current-error-port)) (newline (current-error-port))
423 (assert #f)) ; shouldn't get here
425 ((ANYINTMODE ANYFLOATMODE ANYNUMMODE ANYEXPRMODE EXPLNUMMODE
426 VOIDORNUMMODE VOIDMODE BIMODE INTMODE
427 SYMMODE INSNMODE MACHMODE)
428 #f) ; leave arg untouched
430 ((RTX SETRTX TESTRTX)
431 (set! new-arg (/rtx-trim-for-doc arg)))
434 (assert (= (length arg) 2))
435 (if (eq? (car arg) 'else)
436 (set! new-arg (cons 'else (/rtx-trim-for-doc (cadr arg))))
437 (set! new-arg (list (/rtx-trim-for-doc (car arg))
438 (/rtx-trim-for-doc (cadr arg)))))
442 (assert (= (length arg) 2))
443 (set! new-arg (list (car arg) (/rtx-trim-for-doc (cadr arg))))
447 #f) ; leave arg untouched
449 ((ITERATION SYMBOLLIST ENVSTACK)
450 #f) ; leave arg untouched for now
453 #f) ; leave arg untouched for now
455 ((SYMBOL STRING NUMBER SYMORNUM)
456 #f) ; leave arg untouched
459 (assert #f)) ; hopefully(wip!) shouldn't get here
462 (assert #f))) ; unknown arg type
465 (if (pair? types) (cdr types) types)
466 (cons new-arg result))))))
469 ; Given a canonical rtl expression, usually the result of rtx-simplify,
470 ; remove bits unnecessary for documentation purposes.
471 ; Canonical rtl too verbose for docs.
472 ; Examples of things to remove:
473 ; - empty options list
474 ; - ifield/operand/local/const wrappers
475 ; - modes of operations that don't need them to convey meaning
477 ; NOTE: While having to trim the result of rtx-simplify may seem ironic,
478 ; it isn't. You need to keep separate the notions of simplifying "1+1" to "2"
479 ; and trimming the clutter from "(const () BI 0)" yielding "0".
481 (define (/rtx-trim-for-doc rtx)
482 (if (pair? rtx) ; ??? cheap rtx?
484 (let ((name (car rtx))
491 ((const ifield operand local)
497 (let ((trimmed-args (/rtx-trim-args name rest)))
499 (cons name trimmed-args)
500 (cons name (cons options (cons mode trimmed-args))))))
502 ((eq ne lt le gt ge ltu leu gtu geu index-of)
503 (let ((trimmed-args (/rtx-trim-args name rest)))
505 (cons name trimmed-args)
506 (cons name (cons options (cons mode trimmed-args))))))
509 (let ((trimmed-args (/rtx-trim-args name rest)))
512 (cons name trimmed-args)
513 (cons name (cons mode trimmed-args)))
514 (cons name (cons options (cons mode trimmed-args))))))
517 ; No special support is needed, except it's nice to remove nop
518 ; statements. These can be created when an `if' get simplified.
519 (let ((trimmed-args (/rtx-trim-args name rest))
521 (for-each (lambda (rtx)
522 (if (equal? rtx '(nop))
524 (set! result (cons rtx result))))
528 (cons name (reverse result))
529 (cons name (cons mode (reverse result))))
530 (cons name (cons options (cons mode (reverse result)))))))
536 ;; Remove outer closures, they are artificially added, and are
537 ;; basically noise to the human trying to understand the semantics.
538 ;; ??? Since we currently can't distinguish outer closures,
539 ;; just remove them all.
540 (let ((trimmed-expr (/rtx-trim-for-doc (rtx-closure-expr rtx))))
541 (if (and (null? options) (null? (rtx-closure-env-stack rtx)))
543 (rtx-make 'closure options mode
544 (rtx-closure-isas rtx)
545 (rtx-closure-env-stack rtx)
549 (let ((trimmed-args (/rtx-trim-args name rest)))
551 (if (eq? mode 'DFLT) ;; FIXME: DFLT can no longer appear
552 (cons name trimmed-args)
553 (cons name (cons mode trimmed-args)))
554 (cons name (cons options (cons mode trimmed-args))))))))
556 ; Not an rtx expression, must be number, symbol, string.
560 (define (rtx-trim-for-doc rtx)
561 (/rtx-trim-for-doc rtx)