1 ;; RTL traversing support.
2 ;; Copyright (C) 2000, 2001, 2009 Red Hat, Inc.
3 ;; This file is part of CGEN.
4 ;; See file COPYING.CGEN for details.
6 ;; Canonicalization support.
7 ;; Canonicalizing an rtl expression involves adding possibly missing options
8 ;; and mode, and converting occurrences of DFLT into usable modes.
9 ;; Various error checks are done as well.
10 ;; This is done differently than traversal support because it has a more
11 ;; specific purpose, it doesn't need to support arbitrary "expr-fns".
12 ;; ??? At present the internal form is also the source form (easier debugging).
14 (define /rtx-canon-debug? #f)
16 ;; Canonicalization state.
17 ;; This carries the immutable elements only!
18 ;; OUTER-EXPR is the EXPR argument to rtx-canonicalize.
20 (define (/make-cstate context isa-name-list outer-expr)
21 (vector context isa-name-list outer-expr)
24 (define (/cstate-context cstate) (vector-ref cstate 0))
25 (define (/cstate-isas cstate) (vector-ref cstate 1))
26 (define (/cstate-outer-expr cstate) (vector-ref cstate 2))
28 ;; Flag an error while canonicalizing rtl.
30 (define (/rtx-canon-error cstate errmsg expr parent-expr op-num)
31 (let* ((pretty-parent-expr (rtx-pretty-strdump (/cstate-outer-expr cstate)))
32 (intro (if parent-expr
33 (string-append "While canonicalizing "
34 (rtx-strdump parent-expr)
36 (string-append ", operand #"
37 (number->string op-num))
41 (string-append "While canonicalizing:\n" pretty-parent-expr))))
42 (context-error (/cstate-context cstate) intro errmsg (rtx-dump expr)))
45 ;; Lookup h/w object HW-NAME and return it (as a <hardware-base> object).
46 ;; If multiple h/w objects with the same name are defined, require
47 ;; all to have the same mode.
48 ;; CHECK-KIND is a function of one argument to verify the h/w objects
49 ;; are valid and if not flag an error.
51 (define (/rtx-lookup-hw cstate hw-name parent-expr check-kind)
52 (let ((hw-objs (current-hw-sem-lookup hw-name)))
55 (/rtx-canon-error cstate "unknown h/w object"
56 hw-name parent-expr #f))
58 ;; Just check the first one with CHECK-KIND.
59 (check-kind (car hw-objs))
61 (let* ((hw1 (car hw-objs))
62 (hw1-mode (hw-mode hw1))
63 (hw1-mode-name (obj:name hw1-mode)))
65 ;; Allow multiple h/w objects with the same name
66 ;; as long has they have the same mode.
67 (if (> (length hw-objs) 1)
68 (let ((other-hw-mode-names (map (lambda (hw)
69 (obj:name (hw-mode hw)))
71 (if (not (all-true? (map (lambda (mode-name)
72 (eq? mode-name hw1-mode-name))
73 other-hw-mode-names)))
74 (/rtx-canon-error cstate "multiple h/w objects with different modes selected"
75 hw-name parent-expr #f))))
80 ;; Return the mode name to use in an expression given the requested mode
81 ;; and the mode used in the expression.
82 ;; If both are DFLT, leave it alone and hope the expression provides
83 ;; enough info to pick a usable mode.
84 ;; If both are provided, prefer the mode used in the expression.
85 ;; If the modes are incompatible, return #f.
87 (define (/rtx-pick-mode cstate requested-mode-name expr-mode-name)
88 (cond ((eq? requested-mode-name 'DFLT)
90 ((eq? expr-mode-name 'DFLT)
93 (let ((requested-mode (mode:lookup requested-mode-name))
94 (expr-mode (mode:lookup expr-mode-name)))
95 (if (not requested-mode)
96 (/rtx-canon-error cstate "invalid mode" requested-mode-name #f #f))
98 (/rtx-canon-error cstate "invalid mode" expr-mode-name #f #f))
99 ;; FIXME: 'would prefer samesize or "no precision lost", sigh
100 (if (mode-compatible? 'sameclass requested-mode expr-mode)
102 expr-mode-name)))) ;; FIXME: should be #f, disabled pending completion of rtl mode handling rewrite
105 ;; Return the mode name (as a symbol) to use in an object's rtl given
106 ;; the requested mode, the mode used in the expression, and the object's
108 ;; If both requested mode and expr mode are DFLT, use the real mode.
109 ;; If requested mode is DFLT, prefer expr mode.
110 ;; If expr mode is DFLT, prefer the real mode.
111 ;; If both requested mode and expr mode are specified, prefer expr-mode.
112 ;; If there's an error the result is the error message (as a string).
114 ;; E.g. in (set SI dest (ifield DFLT f-r1)), the mode of the ifield's
115 ;; expression is DFLT, the requested mode is SI, and the real mode of f-r1
118 ;; REAL-MODE is a <mode> object.
120 (define (/rtx-pick-mode3 requested-mode-name expr-mode-name real-mode)
121 ;; Leave checking for (symbol? requested-mode-name) to caller (or higher).
122 (let ((expr-mode (mode:lookup expr-mode-name)))
123 (cond ((not expr-mode)
125 ((eq? requested-mode-name 'DFLT)
126 (if (eq? expr-mode-name 'DFLT)
128 (if (rtx-mode-compatible? expr-mode real-mode)
130 (string-append "expression mode "
131 (symbol->string expr-mode-name)
132 " is incompatible with real mode "
133 (obj:str-name real-mode)))))
134 ((eq? expr-mode-name 'DFLT)
135 (if (rtx-mode-compatible? (mode:lookup requested-mode-name)
138 (string-append "mode of containing expression "
139 (symbol->string requested-mode-name)
140 " is incompatible with real mode "
141 (obj:str-name real-mode))))
143 (let ((requested-mode (mode:lookup requested-mode-name)))
144 (cond ((not (rtx-mode-compatible? requested-mode expr-mode))
145 (string-append "mode of containing expression "
146 (symbol->string requested-mode-name)
147 " is incompatible with expression mode "
148 (symbol->string expr-mode-name)))
149 ((not (rtx-mode-compatible? expr-mode real-mode))
150 (string-append "expression mode "
151 (symbol->string expr-mode-name)
152 " is incompatible with real mode "
153 (obj:str-name real-mode)))
158 ;; Return the mode name (as a symbol) to use in an operand's rtl given
159 ;; the requested mode, the mode used in the expression, and the operand's
161 ;; If both requested mode and expr mode are DFLT, use the real mode.
162 ;; If requested mode is DFLT, prefer expr mode.
163 ;; If expr mode is DFLT, prefer the real mode.
164 ;; If both requested mode and expr mode are specified, prefer expr-mode.
165 ;; If the modes are incompatible an error is signalled.
167 ;; E.g. in (set QI (mem QI src2) src1), the mode to set is QI, but if src1
168 ;; is a 32-bit (SI) register we want QI.
169 ;; OTOH, in (set QI (mem QI src2) uimm8), the mode to set is QI, but we want
170 ;; the real mode of uimm8.
172 ;; ??? This is different from /rtx-pick-mode3 for compatibility with
173 ;; pre-full-canonicalization versions.
174 ; It's currently a toss-up on whether it improves things.
176 ;; OP is an <operand> object.
178 ;; Things are complicated because multiple versions of a h/w object can be
179 ;; defined, and the operand refers to the h/w by name.
180 ;; op:type, which op:mode calls, will flag an error if multiple versions of
181 ;; a h/w object are defined - only one should have been kept during .cpu
182 ;; file loading. This is for semantic code generation, but for generating
183 ;; files covering the entire architecture we need to keep all the versions.
184 ;; Things are ok, as far as canonicalization is concerned, if all h/w versions
185 ;; have the same mode (which could be WI for 32/64 arches).
187 (define (/rtx-pick-op-mode cstate requested-mode-name expr-mode-name op
189 ;; Leave checking for (symbol? requested-mode-name) to caller (or higher).
190 (let* ((op-mode-name (op:mode-name op))
191 (hw (/rtx-lookup-hw cstate (op:hw-name op) parent-expr
192 (lambda (hw) *UNSPECIFIED*)))
193 (op-mode (if (eq? op-mode-name 'DFLT)
195 (mode:lookup op-mode-name)))
196 (expr-mode (mode:lookup expr-mode-name)))
197 (cond ((not expr-mode)
198 (/rtx-canon-error cstate "unknown mode" expr-mode-name
200 ((eq? requested-mode-name 'DFLT)
201 (if (eq? expr-mode-name 'DFLT)
203 (if (rtx-mode-compatible? expr-mode op-mode)
205 (/rtx-canon-error cstate
208 (symbol->string expr-mode-name)
209 " is incompatible with operand mode "
210 (obj:str-name op-mode))
211 expr-mode-name parent-expr #f))))
212 ((eq? expr-mode-name 'DFLT)
213 (if (rtx-mode-compatible? (mode:lookup requested-mode-name)
215 ; FIXME: Experiment. It's currently a toss-up on whether it improves things.
217 ; (obj:name op-mode))
219 ; requested-mode-name)
221 ; (obj:name op-mode)))
223 (/rtx-canon-error cstate
225 "mode of containing expression "
226 (symbol->string requested-mode-name)
227 " is incompatible with operand mode "
228 (obj:str-name op-mode))
229 requested-mode-name parent-expr #f)))
231 (let ((requested-mode (mode:lookup requested-mode-name)))
232 (cond ((not (rtx-mode-compatible? requested-mode expr-mode))
233 (/rtx-canon-error cstate
235 "mode of containing expression "
236 (symbol->string requested-mode-name)
237 " is incompatible with expression mode "
238 (symbol->string expr-mode-name))
239 requested-mode-name parent-expr #f))
240 ((not (rtx-mode-compatible? expr-mode op-mode))
241 (/rtx-canon-error cstate
244 (symbol->string expr-mode-name)
245 " is incompatible with operand mode "
246 (obj:str-name op-mode))
247 expr-mode-name parent-expr #f))
252 ;; Return the last rtx in cond or case expression EXPR.
254 (define (/rtx-get-last-cond-case-rtx expr)
255 (let ((len (length expr)))
256 (list-ref expr (- len 1)))
259 ;; Canonicalize a list of rtx's.
260 ;; The mode of rtxes prior to the last one must be VOID.
262 (define (/rtx-canon-rtx-list rtx-list mode parent-expr op-num cstate env depth)
263 (let* ((nr-rtxes (length rtx-list))
264 (last-op-num (- nr-rtxes 1)))
265 (map (lambda (rtx op-num)
267 (if (= op-num last-op-num) mode 'VOID)
268 parent-expr op-num cstate env depth))
269 rtx-list (iota nr-rtxes)))
272 ;; Rtx canonicalizers.
273 ;; These are defined as individual functions that are then built into a table
274 ;; mostly for simplicity.
276 ;; The result is either a pair of the parsed VAL and new environment,
277 ;; or #f meaning there is no change (saves lots of unnecessarying cons'ing).
279 (define (/rtx-canon-options val mode parent-expr op-num cstate env depth)
283 (define (/rtx-canon-anyintmode val mode parent-expr op-num cstate env depth)
284 (let ((val-obj (mode:lookup val)))
286 (or (memq (mode:class val-obj) '(INT UINT))
289 (/rtx-canon-error cstate "expecting an integer mode"
290 val parent-expr op-num)))
293 (define (/rtx-canon-anyfloatmode val mode parent-expr op-num cstate env depth)
294 (let ((val-obj (mode:lookup val)))
296 (or (memq (mode:class val-obj) '(FLOAT))
299 (/rtx-canon-error cstate "expecting a float mode"
300 val parent-expr op-num)))
303 (define (/rtx-canon-anynummode val mode parent-expr op-num cstate env depth)
304 (let ((val-obj (mode:lookup val)))
306 (or (memq (mode:class val-obj) '(INT UINT FLOAT))
309 (/rtx-canon-error cstate "expecting a numeric mode"
310 val parent-expr op-num)))
313 (define (/rtx-canon-anyexprmode val mode parent-expr op-num cstate env depth)
314 (let ((val-obj (mode:lookup val)))
316 (or (memq (mode:class val-obj) '(INT UINT FLOAT))
317 (memq val '(DFLT PTR VOID))))
319 (/rtx-canon-error cstate "expecting a numeric mode, PTR, or VOID"
320 val parent-expr op-num)))
323 (define (/rtx-canon-explnummode val mode parent-expr op-num cstate env depth)
324 (let ((val-obj (mode:lookup val)))
326 (memq (mode:class val-obj) '(INT UINT FLOAT)))
328 (/rtx-canon-error cstate "expecting an explicit numeric mode"
329 val parent-expr op-num)))
332 (define (/rtx-canon-voidornummode val mode parent-expr op-num cstate env depth)
333 (let ((val-obj (mode:lookup val)))
335 (or (memq (mode:class val-obj) '(INT UINT FLOAT))
336 (memq val '(DFLT VOID))))
338 (/rtx-canon-error cstate "expecting void or a numeric mode"
339 val parent-expr op-num)))
342 (define (/rtx-canon-voidmode val mode parent-expr op-num cstate env depth)
343 (if (memq val '(DFLT VOID))
345 (/rtx-canon-error cstate "expecting VOID mode"
346 val parent-expr op-num))
349 (define (/rtx-canon-bimode val mode parent-expr op-num cstate env depth)
350 (if (memq val '(DFLT BI))
352 (/rtx-canon-error cstate "expecting BI mode"
353 val parent-expr op-num))
356 (define (/rtx-canon-intmode val mode parent-expr op-num cstate env depth)
357 (if (memq val '(DFLT INT))
359 (/rtx-canon-error cstate "expecting INT mode"
360 val parent-expr op-num))
363 (define (/rtx-canon-symmode val mode parent-expr op-num cstate env depth)
364 (if (memq val '(DFLT SYM))
366 (/rtx-canon-error cstate "expecting SYM mode"
367 val parent-expr op-num))
370 (define (/rtx-canon-insnmode val mode parent-expr op-num cstate env depth)
371 (if (memq val '(DFLT INSN))
373 (/rtx-canon-error cstate "expecting INSN mode"
374 val parent-expr op-num))
377 (define (/rtx-canon-machmode val mode parent-expr op-num cstate env depth)
378 (if (memq val '(DFLT MACH))
380 (/rtx-canon-error cstate "expecting MACH mode"
381 val parent-expr op-num))
384 (define (/rtx-canon-rtx val mode parent-expr op-num cstate env depth)
385 ; Commented out 'cus it doesn't quite work yet.
386 ; (if (not (rtx? val))
387 ; (/rtx-canon-error cstate "expecting an rtx" val parent-expr op-num))
388 (cons (/rtx-canon val 'RTX mode parent-expr op-num cstate env depth)
392 (define (/rtx-canon-setrtx val mode parent-expr op-num cstate env depth)
393 ; Commented out 'cus it doesn't quite work yet.
394 ; (if (not (rtx? val))
395 ; (/rtx-canon-error cstate "expecting an rtx" val parent-expr op-num))
396 (let ((dest (/rtx-canon val 'SETRTX mode parent-expr op-num cstate env depth)))
400 ;; This is the test of an `if'.
402 (define (/rtx-canon-testrtx val mode parent-expr op-num cstate env depth)
403 ; Commented out 'cus it doesn't quite work yet.
404 ; (if (not (rtx? val))
405 ; (/rtx-canon-error cstate "expecting an rtx"
406 ; val parent-expr op-num))
407 (cons (/rtx-canon val 'RTX mode parent-expr op-num cstate env depth)
411 (define (/rtx-canon-condrtx val mode parent-expr op-num cstate env depth)
412 (if (not (pair? val))
413 (/rtx-canon-error cstate "expecting an expression"
414 val parent-expr op-num))
415 (if (eq? (car val) 'else)
417 (if (!= (+ op-num 2) (length parent-expr))
418 (/rtx-canon-error cstate "`else' clause not last"
419 val parent-expr op-num))
422 (cdr val) mode parent-expr op-num cstate env depth))
425 ;; ??? Entries after the first are conditional.
426 (/rtx-canon (car val) 'RTX 'INT parent-expr op-num cstate env depth)
428 (cdr val) mode parent-expr op-num cstate env depth))
432 (define (/rtx-canon-casertx val mode parent-expr op-num cstate env depth)
433 (if (or (not (list? val))
435 (/rtx-canon-error cstate "invalid `case' expression"
436 val parent-expr op-num))
437 ;; car is either 'else or list of symbols/numbers
438 (if (not (or (eq? (car val) 'else)
439 (and (list? (car val))
440 (not (null? (car val)))
441 (all-true? (map /rtx-symornum?
443 (/rtx-canon-error cstate "invalid `case' choice"
444 val parent-expr op-num))
445 (if (and (eq? (car val) 'else)
446 (!= (+ op-num 2) (length parent-expr)))
447 (/rtx-canon-error cstate "`else' clause not last"
448 val parent-expr op-num))
449 (cons (cons (car val)
451 (cdr val) mode parent-expr op-num cstate env depth))
455 (define (/rtx-canon-locals val mode parent-expr op-num cstate env depth)
456 (if (not (list? val))
457 (/rtx-canon-error cstate "bad locals list"
458 val parent-expr op-num))
459 (for-each (lambda (var)
460 (if (or (not (list? var))
462 (not (/rtx-any-mode? (car var)))
463 (not (symbol? (cadr var))))
464 (/rtx-canon-error cstate "bad locals list"
465 val parent-expr op-num)))
467 (let ((new-env (rtx-env-make-locals val)))
468 (cons val (cons new-env env)))
471 (define (/rtx-canon-iteration val mode parent-expr op-num cstate env depth)
472 (if (not (symbol? val))
473 (/rtx-canon-error cstate "bad iteration variable name"
474 val parent-expr op-num))
475 (let ((new-env (rtx-env-make-iteration-locals val)))
476 (cons val (cons new-env env)))
479 (define (/rtx-canon-symbol-list val mode parent-expr op-num cstate env depth)
480 (if (or (not (list? val))
481 (not (all-true? (map symbol? val))))
482 (/rtx-canon-error cstate "bad symbol list"
483 val parent-expr op-num))
487 (define (/rtx-canon-env-stack val mode parent-expr op-num cstate env depth)
488 ;; VAL is an environment stack.
489 (if (not (list? val))
490 (/rtx-canon-error cstate "environment not a list"
491 val parent-expr op-num))
492 ;; FIXME: Shouldn't this push VAL onto ENV?
496 (define (/rtx-canon-attrs val mode parent-expr op-num cstate env depth)
497 ; (cons val ; (atlist-source-form (atlist-parse (make-prefix-cstate "with-attr") val ""))
502 (define (/rtx-canon-symbol val mode parent-expr op-num cstate env depth)
503 (if (not (symbol? val))
504 (/rtx-canon-error cstate "expecting a symbol"
505 val parent-expr op-num))
509 (define (/rtx-canon-string val mode parent-expr op-num cstate env depth)
510 (if (not (string? val))
511 (/rtx-canon-error cstate "expecting a string"
512 val parent-expr op-num))
516 (define (/rtx-canon-number val mode parent-expr op-num cstate env depth)
517 (if (not (number? val))
518 (/rtx-canon-error cstate "expecting a number"
519 val parent-expr op-num))
523 (define (/rtx-canon-symornum val mode parent-expr op-num cstate env depth)
524 (if (not (or (symbol? val) (number? val)))
525 (/rtx-canon-error cstate "expecting a symbol or number"
526 val parent-expr op-num))
530 (define (/rtx-canon-object val mode parent-expr op-num cstate env depth)
534 ;; Table of rtx canonicalizers.
535 ;; This is a vector of size rtx-max-num.
536 ;; Each entry is a list of (arg-type-name . canonicalizer) elements
537 ;; for rtx-arg-types.
538 ;; FIXME: Initialized in rtl.scm (i.e. outside this file).
540 (define /rtx-canoner-table #f)
542 ;; Return a hash table of standard operand canonicalizers.
543 ;; The result of each canonicalizer is a pair of the canonical form
544 ;; of `val' and a possibly new environment or #f if there is no change.
546 (define (/rtx-make-canon-table)
547 (let ((hash-tab (make-hash-table 31))
550 (cons 'OPTIONS /rtx-canon-options)
551 (cons 'ANYINTMODE /rtx-canon-anyintmode)
552 (cons 'ANYFLOATMODE /rtx-canon-anyfloatmode)
553 (cons 'ANYNUMMODE /rtx-canon-anynummode)
554 (cons 'ANYEXPRMODE /rtx-canon-anyexprmode)
555 (cons 'EXPLNUMMODE /rtx-canon-explnummode)
556 (cons 'VOIDORNUMMODE /rtx-canon-voidornummode)
557 (cons 'VOIDMODE /rtx-canon-voidmode)
558 (cons 'BIMODE /rtx-canon-bimode)
559 (cons 'INTMODE /rtx-canon-intmode)
560 (cons 'SYMMODE /rtx-canon-symmode)
561 (cons 'INSNMODE /rtx-canon-insnmode)
562 (cons 'MACHMODE /rtx-canon-machmode)
563 (cons 'RTX /rtx-canon-rtx)
564 (cons 'SETRTX /rtx-canon-setrtx)
565 (cons 'TESTRTX /rtx-canon-testrtx)
566 (cons 'CONDRTX /rtx-canon-condrtx)
567 (cons 'CASERTX /rtx-canon-casertx)
568 (cons 'LOCALS /rtx-canon-locals)
569 (cons 'ITERATION /rtx-canon-iteration)
570 (cons 'SYMBOLLIST /rtx-canon-symbol-list)
571 (cons 'ENVSTACK /rtx-canon-env-stack)
572 (cons 'ATTRS /rtx-canon-attrs)
573 (cons 'SYMBOL /rtx-canon-symbol)
574 (cons 'STRING /rtx-canon-string)
575 (cons 'NUMBER /rtx-canon-number)
576 (cons 'SYMORNUM /rtx-canon-symornum)
577 (cons 'OBJECT /rtx-canon-object)
580 (for-each (lambda (canoner)
581 (hashq-set! hash-tab (car canoner) (cdr canoner)))
587 ;; Standard expression operand canonicalizer.
588 ;; Loop over the operands, verifying them according to the argument type
589 ;; and mode matcher, and replace DFLT with a usable mode.
591 (define (/rtx-canon-operands rtx-obj requested-mode-name
592 func args parent-expr parent-op-num
594 ;; ??? Might want to just leave operands as a list.
595 (let* ((operands (list->vector args))
596 (nr-operands (vector-length operands))
597 (this-expr (cons func args)) ;; For error messages.
599 ;; For sets, the requested mode is DFLT or VOID (the mode of the
600 ;; result), but the mode we want is the mode of the set destination.
601 (if (rtx-result-mode rtx-obj)
602 (cadr args) ;; mode of arg2 doesn't come from containing expr
603 (/rtx-pick-mode cstate requested-mode-name (cadr args))))
604 (all-arg-types (vector-ref /rtx-canoner-table (rtx-num rtx-obj))))
607 (/rtx-canon-error cstate
608 (string-append "requested mode "
609 (symbol->string requested-mode-name)
610 " is incompatible with expression mode "
611 (symbol->string (cadr args)))
612 this-expr parent-expr #f))
616 (arg-types all-arg-types)
617 (arg-modes (rtx-arg-modes rtx-obj)))
619 (let ((varargs? (and (pair? arg-types) (symbol? (car arg-types)))))
621 (if /rtx-canon-debug?
623 (display (spaces (* 4 depth)))
624 (if (= op-num nr-operands)
625 (display "end of operands")
627 (display "op-num ") (display op-num) (display ": ")
628 (display (rtx-dump (vector-ref operands op-num)))
630 (display (if varargs? (car arg-types) (caar arg-types)))
632 (display (if varargs? arg-modes (car arg-modes)))
637 (cond ((= op-num nr-operands)
639 ;; Out of operands, check if we have the expected number.
640 (if (or (null? arg-types)
643 ;; We're theoretically done.
644 (let ((set-mode-from-arg!
646 (if /rtx-canon-debug?
648 (display (spaces (* 4 depth)))
649 (display "Computing expr mode from arguments.")
651 (let* ((expr-to-match
654 (/rtx-get-last-cond-case-rtx (vector-ref operands arg-num)))
656 (vector-ref operands arg-num))))
657 (expr-to-match-obj (rtx-lookup (rtx-name expr-to-match)))
658 (result-mode (or (rtx-result-mode expr-to-match-obj)
659 (let ((expr-mode (rtx-mode expr-to-match)))
660 (if (eq? expr-mode 'DFLT)
661 (if (eq? requested-mode-name 'DFLT)
662 (/rtx-canon-error cstate
663 "unable to determine mode of expression from arguments, please specify a mode"
664 this-expr parent-expr #f)
667 (vector-set! operands 1 result-mode)))))
668 ;; The expression's mode might still be DFLT.
669 ;; If it is, fetch the mode of the MATCHEXPR operand,
670 ;; or MATCHSEQ operand, or containing expression.
671 ;; If it's still DFLT, flag an error.
672 (if (eq? (vector-ref operands 1) 'DFLT)
673 (cond ((rtx-matchexpr-index rtx-obj)
674 => (lambda (matchexpr-index)
675 (set-mode-from-arg! matchexpr-index)))
676 ((eq? func 'sequence)
677 (set-mode-from-arg! (- nr-operands 1)))
679 (if /rtx-canon-debug?
681 (display (spaces (* 4 depth)))
682 (display "Computing expr mode from containing expression.")
684 (if (or (eq? requested-mode-name 'DFLT)
685 (rtx-result-mode rtx-obj))
686 (/rtx-canon-error cstate
687 "unable to determine mode of expression, please specify a mode"
688 this-expr parent-expr #f)
689 (vector-set! operands 1 requested-mode-name)))))
690 (vector->list operands))
692 (/rtx-canon-error cstate "missing operands"
693 this-expr parent-expr #f)))
696 (/rtx-canon-error cstate "too many operands"
697 this-expr parent-expr #f))
700 (let ((type (if varargs? arg-types (car arg-types)))
701 (mode (let ((mode-spec (if varargs?
704 ;; We don't necessarily have enough information
705 ;; at this point. Just propagate what we do know,
706 ;; and leave it for final processing to fix up what
708 ;; This is small enough that case is fast enough,
709 ;; and the number of entries should be stable.
712 ((ANYINT) 'DFLT) ;; FIXME
714 ((MATCHEXPR) expr-mode)
716 (if (= (+ op-num 1) nr-operands) ;; last one?
720 ;; This is complicated by the fact that some
721 ;; rtx have a different result mode than what
722 ;; is specified in the rtl (e.g. set, eq).
723 ;; ??? Make these rtx specify both modes?
724 (let* ((op2 (vector-ref operands 2))
725 (op2-obj (rtx-lookup (rtx-name op2))))
726 (or (rtx-result-mode op2-obj)
729 ;; This is complicated by the fact that some
730 ;; rtx have a different result mode than what
731 ;; is specified in the rtl (e.g. set, eq).
732 ;; ??? Make these rtx specify both modes?
733 (let* ((op2 (vector-ref operands 3))
734 (op2-obj (rtx-lookup (rtx-name op2))))
735 (or (rtx-result-mode op2-obj)
737 ;; Otherwise mode-spec is the mode to use.
739 (val (vector-ref operands op-num))
742 ;; Look up the canoner for this operand and perform it.
743 ;; FIXME: This would benefit from returning multiple values.
744 (let ((canoner (cdr type)))
745 (let ((canon-val (canoner val mode this-expr op-num
749 (set! val (car canon-val))
750 (set! env (cdr canon-val))))))
752 (vector-set! operands op-num val)
754 ;; Done with this operand, proceed to the next.
757 (if varargs? arg-types (cdr arg-types))
758 (if varargs? arg-modes (cdr arg-modes)))))))))
761 (define (/rtx-canon-rtx-enum rtx-obj requested-mode-name
762 func args parent-expr parent-op-num
764 (if (!= (length args) 3)
765 (/rtx-canon-error cstate "wrong number of operands to enum, expecting 3"
766 (cons func args) parent-expr #f))
768 (let ((mode-name (cadr args))
769 (enum-name (caddr args)))
770 (let ((mode-obj (mode:lookup mode-name))
771 (enum-val-and-obj (enum-lookup-val enum-name)))
773 (if (not enum-val-and-obj)
774 (/rtx-canon-error cstate "unknown enum value"
775 enum-name parent-expr #f))
777 (let ((expr-mode-or-errmsg (/rtx-pick-mode3 requested-mode-name mode-name INT)))
778 (if (symbol? expr-mode-or-errmsg)
779 (list (car args) expr-mode-or-errmsg enum-name)
780 (/rtx-canon-error cstate expr-mode-or-errmsg
781 enum-name parent-expr #f)))))
784 (define (/rtx-canon-rtx-ifield rtx-obj requested-mode-name
785 func args parent-expr parent-op-num
787 (if (!= (length args) 3)
788 (/rtx-canon-error cstate "wrong number of operands to ifield, expecting 3"
789 (cons func args) parent-expr #f))
791 (let ((expr-mode-name (cadr args))
792 (ifld-name (caddr args)))
793 (let ((ifld-obj (current-ifld-lookup ifld-name)))
797 (let ((mode-or-errmsg (/rtx-pick-mode3 requested-mode-name
799 (ifld-mode ifld-obj))))
800 (if (symbol? mode-or-errmsg)
801 (list (car args) mode-or-errmsg ifld-name)
802 (/rtx-canon-error cstate mode-or-errmsg expr-mode-name
803 parent-expr parent-op-num)))
805 (/rtx-canon-error cstate "unknown ifield"
806 ifld-name parent-expr #f))))
809 (define (/rtx-canon-rtx-operand rtx-obj requested-mode-name
810 func args parent-expr parent-op-num
812 (if (!= (length args) 3)
813 (/rtx-canon-error cstate "wrong number of operands to operand, expecting 3"
814 (cons func args) parent-expr #f))
816 (let ((expr-mode-name (cadr args))
817 (op-name (caddr args)))
818 (let ((op-obj (current-op-lookup op-name (/cstate-isas cstate))))
822 (let ((mode (/rtx-pick-op-mode cstate requested-mode-name
823 expr-mode-name op-obj parent-expr)))
824 (list (car args) mode op-name))
826 (/rtx-canon-error cstate "unknown operand"
827 op-name parent-expr #f))))
830 (define (/rtx-canon-rtx-xop rtx-obj requested-mode-name
831 func args parent-expr parent-op-num
833 (if (!= (length args) 3)
834 (/rtx-canon-error cstate "wrong number of operands to xop, expecting 3"
835 (cons func args) parent-expr #f))
837 (let ((expr-mode-name (cadr args))
838 (xop-obj (caddr args)))
840 (if (operand? xop-obj)
842 (let ((mode-or-errmsg (/rtx-pick-mode3 requested-mode-name
845 (if (symbol? mode-or-errmsg)
846 (list (car args) mode-or-errmsg xop-obj)
847 (/rtx-canon-error cstate mode-or-errmsg expr-mode-name
848 parent-expr parent-op-num)))
850 (/rtx-canon-error cstate "xop operand #2 not an operand"
851 (obj:name xop-obj) parent-expr #f)))
854 (define (/rtx-canon-rtx-local rtx-obj requested-mode-name
855 func args parent-expr parent-op-num
857 (if (!= (length args) 3)
858 (/rtx-canon-error cstate "wrong number of operands to local, expecting 3"
859 (cons func args) parent-expr #f))
861 (let ((expr-mode-name (cadr args))
862 (local-name (caddr args)))
863 (let ((local-obj (rtx-temp-lookup env local-name)))
867 (let ((mode-or-errmsg (/rtx-pick-mode3 requested-mode-name
869 (rtx-temp-mode local-obj))))
870 (if (symbol? mode-or-errmsg)
871 (list (car args) mode-or-errmsg local-name)
872 (/rtx-canon-error cstate mode-or-errmsg expr-mode-name
873 parent-expr parent-op-num)))
875 (/rtx-canon-error cstate "unknown local"
876 local-name parent-expr #f))))
879 (define (/rtx-canon-rtx-ref rtx-obj requested-mode-name
880 func args parent-expr parent-op-num
882 (if (!= (length args) 3)
883 (/rtx-canon-error cstate "wrong number of operands to ref, expecting 3"
884 (cons func args) parent-expr #f))
886 (let ((expr-mode-name (cadr args))
887 (ref-name (caddr args)))
888 ;; FIXME: Will current-op-lookup find named operands?
889 (let ((op-obj (current-op-lookup ref-name (/cstate-isas cstate))))
893 ;; The result of "ref" is canonically an INT.
894 (let ((mode-or-errmsg (/rtx-pick-mode3 requested-mode-name
897 (if (symbol? mode-or-errmsg)
898 (list (car args) mode-or-errmsg ref-name)
899 (/rtx-canon-error cstate mode-or-errmsg expr-mode-name
900 parent-expr parent-op-num)))
902 (/rtx-canon-error cstate "unknown operand"
903 ref-name parent-expr #f))))
906 (define (/rtx-canon-rtx-reg rtx-obj requested-mode-name
907 func args parent-expr parent-op-num
909 (let ((len (length args)))
910 (if (or (< len 3) (> len 5))
911 (/rtx-canon-error cstate
912 ;; TODO: be more firm on expected number of args
914 "wrong number of operands to "
915 (symbol->string func)
916 ", expecting 3 (or possibly 4,5)")
917 (cons func args) parent-expr #f))
919 (let ((expr-mode-name (cadr args))
920 (hw-name (caddr args))
921 (this-expr (cons func args)))
922 (let* ((hw (/rtx-lookup-hw cstate hw-name parent-expr
924 (if (not (register? hw))
925 (/rtx-canon-error cstate "not a register" hw-name
926 parent-expr parent-op-num))
928 (hw-mode-obj (hw-mode hw)))
930 (let ((mode-or-errmsg (/rtx-pick-mode3 requested-mode-name
934 (if (symbol? mode-or-errmsg)
936 ;; Canonicalizing optional index/selector.
937 (let ((index (if (>= len 4)
938 (let ((canon (/rtx-canon-rtx
939 (list-ref args 3) 'INT
940 this-expr 3 cstate env depth)))
941 (car canon)) ;; discard env
944 (let ((canon (/rtx-canon-rtx
945 (list-ref args 4) 'INT
946 this-expr 4 cstate env depth)))
947 (car canon)) ;; discard env
952 (list (car args) mode-or-errmsg hw-name index sel))
954 (list (car args) mode-or-errmsg hw-name index)
955 (list (car args) mode-or-errmsg hw-name))))
957 (/rtx-canon-error cstate mode-or-errmsg expr-mode-name
958 parent-expr parent-op-num))))))
961 (define (/rtx-canon-rtx-mem rtx-obj requested-mode-name
962 func args parent-expr parent-op-num
964 (let ((len (length args)))
965 (if (or (< len 3) (> len 4))
966 (/rtx-canon-error cstate
967 "wrong number of operands to mem, expecting 3 (or possibly 4)"
968 (cons func args) parent-expr #f))
970 (let ((expr-mode-name (cadr args))
971 (addr-expr (caddr args))
972 (this-expr (cons func args)))
974 ;; Call /rtx-canon-explnummode just for the error checking.
975 (/rtx-canon-explnummode expr-mode-name #f this-expr 1 cstate env depth)
977 (if (and (not (eq? requested-mode-name 'DFLT))
978 ;; FIXME: 'would prefer samesize or "no precision lost", sigh
979 (not (mode-compatible? 'sameclass
980 requested-mode-name expr-mode-name)))
981 (/rtx-canon-error cstate
982 (string-append "requested mode "
983 (symbol->string requested-mode-name)
984 " is incompatible with expression mode "
985 (symbol->string expr-mode-name))
986 this-expr parent-expr #f))
988 (let ((addr (car ;; discard env
989 (/rtx-canon-rtx (list-ref args 2) 'AI
990 this-expr 2 cstate env depth)))
992 (let ((canon (/rtx-canon-rtx (list-ref args 3) 'INT
993 this-expr 3 cstate env depth)))
994 (car canon)) ;; discard env
997 (list (car args) expr-mode-name addr sel)
998 (list (car args) expr-mode-name addr)))))
1001 (define (/rtx-canon-rtx-const rtx-obj requested-mode-name
1002 func args parent-expr parent-op-num
1004 (if (!= (length args) 3)
1005 (/rtx-canon-error cstate "wrong number of operands to const, expecting 3"
1006 (cons func args) parent-expr #f))
1008 ;; ??? floating point support is wip
1009 ;; NOTE: (integer? 1.0) == #t, but (inexact? 1.0) ==> #t too.
1011 (let ((expr-mode-name1 (if (and (eq? requested-mode-name 'DFLT)
1012 (eq? (cadr args) 'DFLT))
1015 (value (caddr args))
1016 (this-expr (cons func args)))
1018 (let ((expr-mode-name (/rtx-pick-mode cstate requested-mode-name
1021 (if (not expr-mode-name)
1022 (/rtx-canon-error cstate
1023 (string-append "requested mode "
1024 (symbol->string requested-mode-name)
1025 " is incompatible with expression mode "
1026 (symbol->string expr-mode-name1))
1027 this-expr parent-expr #f))
1029 (let ((expr-mode (mode:lookup expr-mode-name)))
1031 (cond ((integer? value)
1032 (if (not (memq (mode:class expr-mode) '(INT UINT FLOAT)))
1033 (/rtx-canon-error cstate "integer value incompatible with mode"
1034 value this-expr 2)))
1036 (if (not (memq (mode:class expr-mode) '(FLOAT)))
1037 (/rtx-canon-error cstate "floating point value incompatible with mode"
1038 value this-expr 2)))
1040 (/rtx-canon-error cstate
1041 (string-append "expecting a"
1042 (if (eq? (mode:class expr-mode) 'FLOAT)
1046 value this-expr 2)))
1048 (list (car args) expr-mode-name value))))
1051 ;; Table of operand canonicalizers.
1052 ;; The main one is /rtx-traverse-operands, but a few rtx functions are simple
1053 ;; and special-purpose enough that it's simpler to have specific traversers.
1055 (define /rtx-operand-canoners #f)
1057 ;; Return list of rtx functions that have special purpose canoners.
1059 (define (/rtx-special-expr-canoners)
1061 (cons 'enum /rtx-canon-rtx-enum)
1062 (cons 'ifield /rtx-canon-rtx-ifield)
1063 (cons 'operand /rtx-canon-rtx-operand)
1064 ;;(cons 'name /rtx-canon-rtx-name) ;; ??? needed?
1065 (cons 'xop /rtx-canon-rtx-xop) ;; yes, it can appear
1066 (cons 'local /rtx-canon-rtx-local)
1067 (cons 'ref /rtx-canon-rtx-ref)
1068 ;;(cons 'index-of /rtx-canon-rtx-index-of) ;; ??? needed?
1069 (cons 'reg /rtx-canon-rtx-reg)
1070 (cons 'raw-reg /rtx-canon-rtx-reg)
1071 (cons 'mem /rtx-canon-rtx-mem)
1072 (cons 'const /rtx-canon-rtx-const)
1076 ;; Subroutine of rtx-munge-mode&options.
1077 ;; Return boolean indicating if X is an rtx option.
1079 (define (/rtx-option? x)
1083 ;; Subroutine of rtx-munge-mode&options.
1084 ;; Return boolean indicating if X is an rtx option list.
1086 (define (/rtx-option-list? x)
1089 (/rtx-option? (car x))))
1092 ;; Subroutine of /rtx-canon-expr to fill in the options and mode if absent.
1093 ;; The result is the canonical form of ARGS.
1095 ;; "munge" is an awkward name to use here, but I like it for now because
1096 ;; it's easy to grep for.
1097 ;; An empty option list requires a mode to be present so that the empty
1098 ;; list in `(sequence () foo bar)' is unambiguously recognized as the locals
1099 ;; list. Icky, sure, but less icky than the alternatives thus far.
1101 (define (rtx-munge-mode&options rtx-obj requested-mode-name func args)
1102 (let ((orig-args args)
1105 ;; The mode in a `set' is the mode of the destination,
1106 ;; whereas the mode of the result is VOID.
1107 ;; The mode in a compare (e.g. `eq') is the mode of the operands,
1108 ;; but the mode of the result is BI.
1109 (requested-mode-name (if (rtx-result-mode rtx-obj)
1110 'DFLT ;; mode of args doesn't come from containing expr
1111 'DFLT))) ;; FIXME: requested-mode-name)))
1113 ;; Pick off the option list if present.
1114 (if (and (pair? args)
1115 (/rtx-option-list? (car args))
1116 ;; Handle `(sequence () foo bar)'. If empty list isn't followed
1117 ;; by a mode, it is not an option list.
1118 (or (not (null? (car args)))
1119 (and (pair? (cdr args))
1120 (mode-name? (cadr args)))))
1122 (set! options (car args))
1123 (set! args (cdr args))))
1125 ;; Pick off the mode if present.
1126 (if (and (pair? args)
1127 (mode-name? (car args)))
1129 (set! mode-name (car args))
1130 (set! args (cdr args))))
1132 ;; Now put option list and mode back.
1133 ;; But don't do unnecessary consing.
1135 (if (and mode-name (not (eq? mode-name 'DFLT)))
1136 orig-args ;; can return ARGS unchanged
1137 (cons options (cons requested-mode-name args)))
1138 (if (and mode-name (not (eq? mode-name 'DFLT)))
1139 (cons nil orig-args) ;; just need to insert options
1140 (cons nil (cons requested-mode-name args)))))
1143 ;; Subroutine of /rtx-canon to simplify it.
1145 (define (/rtx-canon-expr rtx-obj requested-mode-name
1146 func args parent-expr op-num cstate env depth)
1147 (let ((args2 (rtx-munge-mode&options rtx-obj requested-mode-name func args)))
1149 (if /rtx-canon-debug?
1151 (display (spaces (* 4 depth)))
1152 (display "Traversing operands of: ")
1153 (display (rtx-dump (cons func args)))
1155 (display (spaces (* 4 depth)))
1156 (display "Requested mode: ")
1157 (display requested-mode-name)
1159 (display (spaces (* 4 depth)))
1160 (rtx-env-stack-dump env)
1163 (let* ((canoner (vector-ref /rtx-operand-canoners (rtx-num rtx-obj)))
1164 (operands (canoner rtx-obj requested-mode-name
1165 func args2 parent-expr op-num
1166 cstate env (+ depth 1))))
1167 (cons func operands)))
1170 ;; Convert rtl expression EXPR from source form to canonical form.
1171 ;; The expression is validated and rtx macros are expanded as well.
1172 ;; Plus DFLT mode is converted to a useful mode.
1173 ;; The result is EXPR in canonical form.
1175 ;; CSTATE is a <cstate> object or #f if there is none.
1176 ;; It is used in error messages.
1178 (define (/rtx-canon expr expected mode parent-expr op-num cstate env depth)
1179 (if /rtx-canon-debug?
1181 (display (spaces (* 4 depth)))
1182 (display "Canonicalizing (")
1185 (display (rtx-dump expr))
1187 (display (spaces (* 4 depth)))
1188 (rtx-env-stack-dump env)
1193 (if (pair? expr) ;; pair? -> cheap non-null-list?
1195 (let ((rtx-name (car expr)))
1196 (if (not (symbol? rtx-name))
1197 (/rtx-canon-error cstate "invalid rtx function name"
1198 expr parent-expr op-num))
1199 (let ((rtx-obj (rtx-lookup rtx-name)))
1202 (/rtx-canon-expr rtx-obj mode rtx-name (cdr expr)
1203 parent-expr op-num cstate env depth)))
1204 (if (eq? mode 'VOID)
1205 (let ((expr-mode (or (rtx-result-mode rtx-obj)
1206 (rtx-mode canon-expr))))
1207 (if (not (eq? expr-mode 'VOID))
1208 (/rtx-canon-error cstate "non-VOID-mode expression"
1209 expr parent-expr op-num))))
1211 (let ((rtx-obj (/rtx-macro-lookup rtx-name)))
1213 (/rtx-canon (/rtx-macro-expand expr rtx-evaluator)
1214 expected mode parent-expr op-num cstate env (+ depth 1))
1215 (/rtx-canon-error cstate "unknown rtx function"
1216 expr parent-expr op-num))))))
1218 ;; EXPR is not a list.
1219 ;; See if it's an operand shortcut.
1220 (if (memq expected '(RTX SETRTX))
1223 (if (eq? mode 'VOID)
1224 (/rtx-canon-error cstate "non-VOID-mode expression"
1225 expr parent-expr op-num))
1226 (cond ((symbol? expr)
1227 (cond ((current-op-lookup expr (/cstate-isas cstate))
1229 ;; NOTE: We can't simply call
1230 ;; op:mode-name here, we need the real
1231 ;; mode, not (potentially) DFLT.
1232 ;; See /rtx-pick-op-mode.
1233 (rtx-make-operand (/rtx-pick-op-mode cstate mode 'DFLT op parent-expr)
1235 ((rtx-temp-lookup env expr)
1237 (rtx-make-local (obj:name (rtx-temp-mode tmp)) expr)))
1238 ((current-ifld-lookup expr)
1240 (rtx-make-ifield (obj:name (ifld-mode f)) expr)))
1241 ((enum-lookup-val expr)
1242 ;; ??? If enums could have modes other than INT,
1243 ;; we'd want to propagate that mode here.
1244 (rtx-make-enum 'INT expr))
1246 (/rtx-canon-error cstate "unknown operand"
1247 expr parent-expr op-num))))
1249 (rtx-make-const 'INT expr))
1251 (/rtx-canon-error cstate "unexpected operand"
1252 expr parent-expr op-num))))
1254 ;; Not expecting RTX or SETRTX.
1255 (/rtx-canon-error cstate "unexpected operand"
1256 expr parent-expr op-num)))))
1258 (if /rtx-canon-debug?
1260 (display (spaces (* 4 depth)))
1261 (display "Result: ")
1262 (display (rtx-dump result))
1270 ;; Public entry point.
1271 ;; Convert rtl expression EXPR from source form to canonical form.
1272 ;; The expression is validated and rtx macros are expanded as well.
1273 ;; Plus operand shortcuts are expanded:
1274 ;; - numbers -> (const number)
1275 ;; - operand-name -> (operand operand-name)
1276 ;; - ifield-name -> (ifield ifield-name)
1277 ;; Plus an absent option list is replaced with ().
1278 ;; Plus DFLT mode is converted to a useful mode.
1279 ;; Plus the specified isa-name-list is recorded in the RTL.
1281 ;; The result is EXPR in canonical form.
1283 ;; CONTEXT is a <context> object or #f if there is none.
1284 ;; It is used in error messages.
1286 ;; ISA-NAME-LIST is a list of ISAs in which to evaluate the expression,
1287 ;; e.g. to do operand lookups.
1288 ;; The ISAs must be compatible, e.g. operand lookups must be unambiguous.
1290 ;; MODE-NAME is the requested mode of the result, or DFLT.
1292 ;; EXTRA-VARS-ALIST is an association list of extra (symbol <mode> value)
1293 ;; elements to be used during value lookup.
1294 ;; VALUE can be #f which means the value is assumed to be known, but is
1295 ;; currently unrepresentable. This is used, for example, when representing
1296 ;; ifield setters: we don't know the new value, but it will be known when the
1297 ;; rtx is evaluated (??? Sigh, this is a bit of a cheat, closures have no
1298 ;; such thing, but it's useful here because we don't necessarily know what
1299 ;; the value will be in the application side of things).
1301 (define (rtx-canonicalize context mode-name isa-name-list extra-vars-alist expr)
1303 (/rtx-canon expr 'RTX mode-name #f 0
1304 (/make-cstate context isa-name-list expr)
1305 (rtx-env-init-stack1 extra-vars-alist) 0)))
1306 (rtx-verify-no-dflt-modes context result)
1307 (rtx-make 'closure mode-name isa-name-list
1308 (rtx-var-alist-to-closure-env-stack extra-vars-alist)
1312 ;; RTL expression traversal support.
1313 ;; This is for analyzing the semantics in some way.
1314 ;; The rtl must already be in canonical form.
1316 ;; Set to #t to debug rtx traversal.
1318 (define /rtx-traverse-debug? #f)
1320 ; Container to record the current state of traversal.
1321 ; This is initialized before traversal, and modified (in a copy) as the
1322 ; traversal state changes.
1323 ; This doesn't record all traversal state, just the more static elements.
1324 ; There's no point in recording things like the parent expression and operand
1325 ; position as they change for every sub-traversal.
1326 ; The main raison d'etre for this class is so we can add more state without
1327 ; having to modify all the traversal handlers.
1328 ; ??? At present it's not a proper "class" as there's no real need.
1330 ; CONTEXT is a <context> object or #f if there is none.
1331 ; It is used for error messages.
1333 ; EXPR-FN is a dual-purpose beast. The first purpose is to just process
1334 ; the current expression and return the result. The second purpose is to
1335 ; lookup the function which will then process the expression.
1336 ; It is applied recursively to the expression and each sub-expression.
1337 ; It must be defined as
1338 ; (lambda (rtx-obj expr parent-expr op-pos tstate appstuff) ...).
1339 ; If the result of EXPR-FN is a lambda, it is applied to
1340 ; (cons TSTATE EXPR), TSTATE is prepended to the arguments.
1341 ; For syntax expressions if the result of EXPR-FN is #f, the operands are
1342 ; processed using the builtin traverser.
1343 ; So to repeat: EXPR-FN can process the expression, and if its result is a
1344 ; lambda then it also processes the expression. The arguments to EXPR-FN
1345 ; are (rtx-obj expr parent-expr op-pos tstate appstuff). The format
1346 ; of the result of EXPR-FN are (cons TSTATE EXPR).
1347 ; The reason for the duality is that when trying to understand EXPR (e.g. when
1348 ; computing the insn format) EXPR-FN processes the expression itself, and
1349 ; when evaluating EXPR it's the result of EXPR-FN that computes the value.
1351 ; ISAS is a list of ISA name(s) in which to evaluate the expression.
1353 ; ENV is the current environment. This is a stack of sequence locals.
1355 ; COND? is a boolean indicating if the current expression is on a conditional
1356 ; execution path. This is for optimization purposes only and it is always ok
1357 ; to pass #t, except for the top-level caller which must pass #f (since the top
1358 ; level expression obviously isn't subject to any condition).
1359 ; It is used, for example, to speed up the simulator: there's no need to keep
1360 ; track of whether an operand has been assigned to (or potentially read from)
1361 ; if it's known it's always assigned to.
1363 ; OWNER is the owner of the expression or #f if there is none.
1364 ; Typically it is an <insn> object.
1366 ; KNOWN is an alist of known values. This is used by rtx-simplify.
1367 ; Each element is (name . value) where
1368 ; NAME is a scalar ifield name (in the future it might be an operand name or
1369 ; sequence local name), and
1370 ; VALUE is a const rtx, (const () mode value),
1371 ; or a number-list rtx, (number-list () mode value1 [value2 ...]).
1372 ; A "scalar ifield" is a simple ifield (not a multi or derived ifield),
1373 ; or a multi-ifield consisting of only simple ifields.
1375 ; DEPTH is the current traversal depth.
1377 (define (tstate-make context owner expr-fn isas env cond? known depth)
1378 (vector context owner expr-fn isas env cond? known depth)
1381 (define (tstate-context state) (vector-ref state 0))
1382 (define (tstate-set-context! state newval) (vector-set! state 0 newval))
1383 (define (tstate-owner state) (vector-ref state 1))
1384 (define (tstate-set-owner! state newval) (vector-set! state 1 newval))
1385 (define (tstate-expr-fn state) (vector-ref state 2))
1386 (define (tstate-set-expr-fn! state newval) (vector-set! state 2 newval))
1387 (define (tstate-isas state) (vector-ref state 3))
1388 (define (tstate-set-isas! state newval) (vector-set! state 3 newval))
1389 (define (tstate-env-stack state) (vector-ref state 4))
1390 (define (tstate-set-env-stack! state newval) (vector-set! state 4 newval))
1391 (define (tstate-cond? state) (vector-ref state 5))
1392 (define (tstate-set-cond?! state newval) (vector-set! state 5 newval))
1393 (define (tstate-known state) (vector-ref state 6))
1394 (define (tstate-set-known! state newval) (vector-set! state 6 newval))
1395 (define (tstate-depth state) (vector-ref state 7))
1396 (define (tstate-set-depth! state newval) (vector-set! state 7 newval))
1398 ; Create a copy of STATE.
1400 (define (tstate-copy state)
1401 ; A fast vector-copy would be nice, but this is simple and portable.
1402 (list->vector (vector->list state))
1405 ;; Create a copy of STATE with environment stack ENV-STACK added,
1406 ;; and the ISA(s) set to ISA-NAME-LIST.
1408 (define (tstate-make-closure state isa-name-list env-stack)
1409 (let ((result (tstate-copy state)))
1410 (tstate-set-isas! result isa-name-list)
1411 (tstate-set-env-stack! result (append env-stack (tstate-env-stack result)))
1415 ; Create a copy of STATE with environment ENV pushed onto the existing
1417 ; There's no routine to pop the environment list as there's no current
1418 ; need for it: we make a copy of the state when we push.
1420 (define (tstate-push-env state env)
1421 (let ((result (tstate-copy state)))
1422 (tstate-set-env-stack! result (cons env (tstate-env-stack result)))
1426 ; Create a copy of STATE with a new COND? value.
1428 (define (tstate-new-cond? state cond?)
1429 (let ((result (tstate-copy state)))
1430 (tstate-set-cond?! result cond?)
1434 ; Lookup NAME in the known value table.
1435 ; Returns the value or #f if not found.
1436 ; The value is either a const rtx or a number-list rtx.
1438 (define (tstate-known-lookup tstate name)
1439 (let ((known (tstate-known tstate)))
1440 (assq-ref known name))
1443 ; Increment the recorded traversal depth of TSTATE.
1445 (define (tstate-incr-depth! tstate)
1446 (tstate-set-depth! tstate (1+ (tstate-depth tstate)))
1449 ; Decrement the recorded traversal depth of TSTATE.
1451 (define (tstate-decr-depth! tstate)
1452 (tstate-set-depth! tstate (1- (tstate-depth tstate)))
1455 ; Issue an error given a tstate.
1457 (define (tstate-error tstate errmsg . expr)
1458 (apply context-owner-error
1459 (cons (tstate-context tstate)
1460 (cons (tstate-owner tstate)
1461 (cons "During rtx traversal"
1462 (cons errmsg expr)))))
1465 ; Traversal support.
1467 ; Return a boolean indicating if X is a mode.
1469 (define (/rtx-any-mode? x)
1470 (->bool (mode:lookup x))
1473 ; Return a boolean indicating if X is a symbol or rtx.
1475 (define (/rtx-symornum? x)
1476 (or (symbol? x) (number? x))
1479 ; Traverse a list of rtx's.
1481 (define (/rtx-traverse-rtx-list rtx-list expr op-num tstate appstuff)
1483 ; ??? Shouldn't OP-NUM change for each element?
1484 (/rtx-traverse rtx 'RTX expr op-num tstate appstuff))
1488 ; Cover-fn to tstate-error for signalling an error during rtx traversal
1489 ; of operand OP-NUM.
1490 ; RTL-EXPR must be an rtl expression.
1492 (define (/rtx-traverse-error tstate errmsg rtl-expr op-num)
1493 (tstate-error tstate
1494 (string-append errmsg ", operand #" (number->string op-num))
1495 (rtx-dump rtl-expr))
1500 ; The result is either a pair of the parsed VAL and new TSTATE,
1501 ; or #f meaning there is no change (saves lots of unnecessarying cons'ing).
1503 (define (/rtx-traverse-normal-operand val expr op-num tstate appstuff)
1507 (define (/rtx-traverse-rtx val expr op-num tstate appstuff)
1508 (cons (/rtx-traverse val 'RTX expr op-num tstate appstuff)
1512 (define (/rtx-traverse-setrtx val expr op-num tstate appstuff)
1513 (cons (/rtx-traverse val 'SETRTX expr op-num tstate appstuff)
1517 ; This is the test of an `if'.
1519 (define (/rtx-traverse-testrtx val expr op-num tstate appstuff)
1520 (cons (/rtx-traverse val 'RTX expr op-num tstate appstuff)
1523 (not (rtx-compile-time-constant? val))))
1526 (define (/rtx-traverse-condrtx val expr op-num tstate appstuff)
1527 (if (eq? (car val) 'else)
1529 (/rtx-traverse-rtx-list
1530 (cdr val) expr op-num
1531 (tstate-new-cond? tstate #t)
1533 (tstate-new-cond? tstate #t))
1535 ; ??? Entries after the first are conditional.
1536 (/rtx-traverse (car val) 'RTX expr op-num tstate appstuff)
1537 (/rtx-traverse-rtx-list
1538 (cdr val) expr op-num
1539 (tstate-new-cond? tstate #t)
1541 (tstate-new-cond? tstate #t)))
1544 (define (/rtx-traverse-casertx val expr op-num tstate appstuff)
1545 (cons (cons (car val)
1546 (/rtx-traverse-rtx-list
1547 (cdr val) expr op-num
1548 (tstate-new-cond? tstate #t)
1550 (tstate-new-cond? tstate #t))
1553 (define (/rtx-traverse-locals val expr op-num tstate appstuff)
1554 (let ((env (rtx-env-make-locals val)))
1555 (cons val (tstate-push-env tstate env)))
1558 (define (/rtx-traverse-iteration val expr op-num tstate appstuff)
1559 (let ((env (rtx-env-make-iteration-locals val)))
1560 (cons val (tstate-push-env tstate env)))
1563 (define (/rtx-traverse-attrs val expr op-num tstate appstuff)
1564 ; (cons val ; (atlist-source-form (atlist-parse (make-prefix-context "with-attr") val ""))
1569 ; Table of rtx traversers.
1570 ; This is a vector of size rtx-max-num.
1571 ; Each entry is a list of (arg-type-name . traverser) elements
1572 ; for rtx-arg-types.
1573 ; FIXME: Initialized in rtl.scm (i.e. outside this file).
1575 (define /rtx-traverser-table #f)
1577 ; Return a hash table of standard operand traversers.
1578 ; The result of each traverser is a pair of the compiled form of `val' and
1579 ; a possibly new traversal state or #f if there is no change.
1581 (define (/rtx-make-traverser-table)
1582 (let ((hash-tab (make-hash-table 31))
1585 (cons 'OPTIONS /rtx-traverse-normal-operand)
1586 (cons 'ANYINTMODE /rtx-traverse-normal-operand)
1587 (cons 'ANYFLOATMODE /rtx-traverse-normal-operand)
1588 (cons 'ANYNUMMODE /rtx-traverse-normal-operand)
1589 (cons 'ANYEXPRMODE /rtx-traverse-normal-operand)
1590 (cons 'EXPLNUMMODE /rtx-traverse-normal-operand)
1591 (cons 'VOIDORNUMMODE /rtx-traverse-normal-operand)
1592 (cons 'VOIDMODE /rtx-traverse-normal-operand)
1593 (cons 'BIMODE /rtx-traverse-normal-operand)
1594 (cons 'INTMODE /rtx-traverse-normal-operand)
1595 (cons 'SYMMODE /rtx-traverse-normal-operand)
1596 (cons 'INSNMODE /rtx-traverse-normal-operand)
1597 (cons 'MACHMODE /rtx-traverse-normal-operand)
1598 (cons 'RTX /rtx-traverse-rtx)
1599 (cons 'SETRTX /rtx-traverse-setrtx)
1600 (cons 'TESTRTX /rtx-traverse-testrtx)
1601 (cons 'CONDRTX /rtx-traverse-condrtx)
1602 (cons 'CASERTX /rtx-traverse-casertx)
1603 (cons 'LOCALS /rtx-traverse-locals)
1604 (cons 'ITERATION /rtx-traverse-iteration)
1605 ;; NOTE: Closure isas and env are handled in /rtx-traverse.
1606 (cons 'SYMBOLLIST /rtx-traverse-normal-operand)
1607 (cons 'ENVSTACK /rtx-traverse-normal-operand)
1608 (cons 'ATTRS /rtx-traverse-attrs)
1609 (cons 'SYMBOL /rtx-traverse-normal-operand)
1610 (cons 'STRING /rtx-traverse-normal-operand)
1611 (cons 'NUMBER /rtx-traverse-normal-operand)
1612 (cons 'SYMORNUM /rtx-traverse-normal-operand)
1613 (cons 'OBJECT /rtx-traverse-normal-operand)
1616 (for-each (lambda (traverser)
1617 (hashq-set! hash-tab (car traverser) (cdr traverser)))
1623 ; Traverse the operands of EXPR, a canonicalized RTL expression.
1624 ; Here "canonicalized" means that EXPR has been run through rtx-canonicalize.
1625 ; Note that this means that, yes, the options and mode are "traversed" too.
1627 (define (/rtx-traverse-operands rtx-obj expr tstate appstuff)
1628 (if /rtx-traverse-debug?
1630 (display (spaces (* 4 (tstate-depth tstate))))
1631 (display "Traversing operands of: ")
1632 (display (rtx-dump expr))
1634 (rtx-env-stack-dump (tstate-env-stack tstate))
1637 (let loop ((operands (cdr expr))
1639 (arg-types (vector-ref /rtx-traverser-table (rtx-num rtx-obj)))
1640 (arg-modes (rtx-arg-modes rtx-obj))
1643 (let ((varargs? (and (pair? arg-types) (symbol? (car arg-types)))))
1645 (if /rtx-traverse-debug?
1647 (display (spaces (* 4 (tstate-depth tstate))))
1648 (if (null? operands)
1649 (display "end of operands")
1651 (display "op-num ") (display op-num) (display ": ")
1652 (display (rtx-dump (car operands)))
1654 (display (if varargs? (car arg-types) (caar arg-types)))
1656 (display (if varargs? arg-modes (car arg-modes)))
1661 (cond ((null? operands)
1662 ;; Out of operands, check if we have the expected number.
1663 (if (or (null? arg-types)
1666 (tstate-error tstate "missing operands" (rtx-dump expr))))
1669 (tstate-error tstate "too many operands" (rtx-dump expr)))
1672 (let* ((val (car operands))
1673 (type (if varargs? arg-types (car arg-types))))
1675 ;; Look up the traverser for this kind of operand and perform it.
1676 ;; FIXME: This would benefit from returning multiple values.
1677 (let ((traverser (cdr type)))
1678 (let ((traversed-val (traverser val expr op-num tstate appstuff)))
1681 (set! val (car traversed-val))
1682 (set! tstate (cdr traversed-val))))))
1684 ;; Done with this operand, proceed to the next.
1685 (loop (cdr operands)
1687 (if varargs? arg-types (cdr arg-types))
1688 (if varargs? arg-modes (cdr arg-modes))
1689 (cons val result)))))))
1692 ; Publically accessible version of /rtx-traverse-operands as EXPR-FN may
1695 (define rtx-traverse-operands /rtx-traverse-operands)
1697 ; Subroutine of /rtx-traverse to traverse an expression.
1699 ; RTX-OBJ is the <rtx-func> object of the (outer) expression being traversed.
1701 ; EXPR is the expression to be traversed.
1702 ; It must be fully canonical.
1704 ; PARENT-EXPR is the expression EXPR is contained in. The top-level
1705 ; caller must pass #f for it.
1707 ; OP-POS is the position EXPR appears in PARENT-EXPR. The
1708 ; top-level caller must pass 0 for it.
1710 ; TSTATE is the current traversal state.
1712 ; APPSTUFF is for application specific use.
1714 ; For syntax expressions arguments are not pre-evaluated before calling the
1715 ; user's expression handler. Otherwise they are.
1717 ; If (tstate-expr-fn TSTATE) wants to just scan the operands, rather than
1718 ; evaluating them, one thing it can do is call back to rtx-traverse-operands.
1719 ; If (tstate-expr-fn TSTATE) returns #f, traverse the operands normally and
1720 ; return (rtx's-name ([options]) mode traversed-operand1 ...),
1721 ; i.e., the canonicalized form.
1722 ; This is for semantic-compile's sake and all traversal handlers are
1723 ; required to do this if the expr-fn returns #f.
1725 (define (/rtx-traverse-expr rtx-obj expr parent-expr op-pos tstate appstuff)
1726 (let ((fn ((tstate-expr-fn tstate)
1727 rtx-obj expr parent-expr op-pos tstate appstuff)))
1730 ; Don't traverse operands for syntax expressions.
1731 (if (eq? (rtx-style rtx-obj) 'SYNTAX)
1732 (apply fn (cons tstate cdr expr))
1733 (let ((operands (/rtx-traverse-operands rtx-obj expr tstate appstuff)))
1734 (apply fn (cons tstate operands))))
1736 (let ((operands (/rtx-traverse-operands rtx-obj expr tstate appstuff)))
1737 (cons (car expr) operands))))
1740 ; Main entry point for expression traversal.
1741 ; (Actually rtx-traverse is, but it's just a cover function for this.)
1743 ; The result is the result of the lambda (tstate-expr-fn TSTATE) looks up
1744 ; in the case of expressions, or an operand object (usually <operand>)
1745 ; in the case of operands.
1747 ; EXPR is the expression to be traversed.
1748 ; It must be fully canonical.
1750 ; EXPECTED is one of `-rtx-valid-types' and indicates the expected rtx type
1751 ; or #f if it doesn't matter.
1753 ; PARENT-EXPR is the expression EXPR is contained in. The top-level
1754 ; caller must pass #f for it.
1756 ; OP-POS is the position EXPR appears in PARENT-EXPR. The
1757 ; top-level caller must pass 0 for it.
1759 ; TSTATE is the current traversal state.
1761 ; APPSTUFF is for application specific use.
1763 (define (/rtx-traverse expr expected parent-expr op-pos tstate appstuff)
1764 (if /rtx-traverse-debug?
1766 (display (spaces (* 4 (tstate-depth tstate))))
1767 (display "Traversing expr: ")
1770 (display (spaces (* 4 (tstate-depth tstate))))
1771 (display "-expected: ")
1774 (display (spaces (* 4 (tstate-depth tstate))))
1775 (display "-conditional: ")
1776 (display (tstate-cond? tstate))
1781 ;; FIXME: error checking here should be deleteable.
1783 (if (pair? expr) ; pair? -> cheap non-null-list?
1785 (let* ((rtx-name (car expr))
1786 (rtx-obj (rtx-lookup rtx-name))
1787 ;; If this is a closure, update tstate.
1788 ;; ??? This is a bit of a wart. All other rtxes handle their
1789 ;; special args/needs via rtx-arg-types. Left as is to simmer.
1790 (tstate (if (eq? rtx-name 'closure)
1791 (tstate-make-closure tstate
1792 (rtx-closure-isas expr)
1793 (rtx-make-env-stack (rtx-closure-env-stack expr)))
1795 (tstate-incr-depth! tstate)
1798 (/rtx-traverse-expr rtx-obj expr parent-expr op-pos tstate appstuff)
1799 (let ((rtx-obj (/rtx-macro-lookup rtx-name)))
1801 (/rtx-traverse (/rtx-macro-expand expr rtx-evaluator)
1802 expected parent-expr op-pos tstate appstuff)
1803 (tstate-error tstate "unknown rtx function" expr))))))
1804 (tstate-decr-depth! tstate)
1807 ; EXPR is not a list.
1808 ; See if it's an operand shortcut.
1809 ; FIXME: Can we get here any more? [now that EXPR is already canonical]
1810 (if (memq expected '(RTX SETRTX))
1812 (cond ((symbol? expr)
1813 (cond ((current-op-lookup expr (tstate-isas tstate))
1816 ;; NOTE: Can't call op:mode-name here, we need
1817 ;; the real mode, not (potentially) DFLT.
1818 (rtx-make-operand (obj:name (op:mode op)) expr)
1819 expected parent-expr op-pos tstate appstuff)))
1820 ((rtx-temp-lookup (tstate-env-stack tstate) expr)
1823 (rtx-make-local (rtx-temp-mode tmp) expr)
1824 expected parent-expr op-pos tstate appstuff)))
1825 ((current-ifld-lookup expr)
1828 (rtx-make-ifield (obj:name (ifld-mode f)) expr)
1829 expected parent-expr op-pos tstate appstuff)))
1830 ((enum-lookup-val expr)
1831 ;; ??? If enums could have modes other than INT,
1832 ;; we'd want to propagate that mode here.
1834 (rtx-make-enum 'INT expr)
1835 expected parent-expr op-pos tstate appstuff))
1837 (tstate-error tstate "unknown operand" expr))))
1839 (/rtx-traverse (rtx-make-const 'INT expr)
1840 expected parent-expr op-pos tstate appstuff))
1842 (tstate-error tstate "unexpected operand" expr)))
1844 ; Not expecting RTX or SETRTX.
1845 (tstate-error tstate "unexpected operand" expr)))
1848 ; User visible procedures to traverse an rtl expression.
1849 ; EXPR must be fully canonical.
1850 ; These calls /rtx-traverse to do most of the work.
1851 ; See tstate-make for explanations of OWNER, EXPR-FN.
1852 ; CONTEXT is a <context> object or #f if there is none.
1853 ; LOCALS is a list of (mode . name) elements (the locals arg to `sequence').
1854 ; APPSTUFF is for application specific use.
1856 (define (rtx-traverse context owner expr expr-fn appstuff)
1857 (/rtx-traverse expr #f #f 0
1858 (tstate-make context owner expr-fn
1859 #f ;; ok since EXPR is fully canonical
1860 (rtx-env-empty-stack)
1865 (define (rtx-traverse-with-locals context owner expr expr-fn locals appstuff)
1866 (/rtx-traverse expr #f #f 0
1867 (tstate-make context owner expr-fn
1868 #f ;; ok since EXPR is fully canonical
1869 (rtx-env-push (rtx-env-empty-stack)
1870 (rtx-env-make-locals locals))
1875 ; Traverser debugger.
1876 ; This just traverses EXPR printing everything it sees.
1878 (define (rtx-traverse-debug expr)
1881 (lambda (rtx-obj expr parent-expr op-pos tstate appstuff)
1883 (display (string-append "rtx=" (obj:str-name rtx-obj)))
1886 (display " parent=")
1887 (display parent-expr)
1888 (display " op-pos=")
1891 (display (tstate-cond? tstate))
1898 ; RTL evaluation state.
1899 ; Applications may subclass <eval-state> if they need to add things.
1901 ; This is initialized before evaluation, and modified (in a copy) as the
1902 ; evaluation state changes.
1903 ; This doesn't record all evaluation state, just the less dynamic elements.
1904 ; There's no point in recording things like the parent expression and operand
1905 ; position as they change for every sub-eval.
1906 ; The main raison d'etre for this class is so we can add more state without
1907 ; having to modify all the eval handlers.
1909 (define <eval-state>
1910 (class-make '<eval-state> nil
1912 ; <context> object or #f if there is none
1915 ; Current object rtl is being evaluated for.
1916 ; We need to be able to access the current instruction while
1917 ; generating semantic code. However, the semantic description
1918 ; doesn't specify it as an argument to anything (and we don't
1919 ; want it to). So we record the value here.
1922 ;; The outer expr being evaluated, for error messages.
1923 ;; #f if there is none.
1926 ; EXPR-FN is a dual-purpose beast. The first purpose is to
1927 ; just process the current expression and return the result.
1928 ; The second purpose is to lookup the function which will then
1929 ; process the expression. It is applied recursively to the
1930 ; expression and each sub-expression. It must be defined as
1931 ; (lambda (rtx-obj expr mode estate) ...).
1932 ; If the result of EXPR-FN is a lambda, it is applied to
1933 ; (cons ESTATE (cdr EXPR)). ESTATE is prepended to the
1935 ; For syntax expressions if the result of EXPR-FN is #f,
1936 ; the operands are processed using the builtin evaluator.
1937 ; FIXME: This special handling of syntax expressions is
1938 ; not currently done.
1939 ; So to repeat: EXPR-FN can process the expression, and if its
1940 ; result is a lambda then it also processes the expression.
1941 ; The arguments to EXPR-FN are
1942 ; (rtx-obj expr mode estate).
1943 ; The arguments to the result of EXPR-FN are
1944 ; (cons ESTATE (cdr EXPR)).
1945 ; The reason for the duality is mostly history.
1946 ; In time things should be simplified.
1949 ; List of ISA name(s) in which to evaluate the expression.
1950 ; This is used for example during operand lookups.
1951 ; All specified ISAs must be compatible,
1952 ; e.g. operand lookups must be unambiguous.
1953 ; A value of #f means "all ISAs".
1956 ; Current environment. This is a stack of sequence locals,
1957 ; e.g. made with rtx-env-init-stack1.
1960 ; Current evaluation depth. This is used, for example, to
1961 ; control indentation in generated output.
1964 ; Associative list of modifiers.
1965 ; This is here to support things like `delay'.
1971 ; Create an <eval-state> object using a list of keyword/value elements.
1972 ; ARGS is a list of #:keyword/value elements.
1973 ; The result is a list of the unrecognized elements.
1974 ; Subclasses should override this method and send-next it first, then
1975 ; see if they recognize anything in the result, returning what isn't
1979 <eval-state> 'vmake!
1981 (let loop ((args args) (unrecognized nil))
1983 (reverse! unrecognized) ; ??? Could invoke method to initialize here.
1987 (elm-set! self 'context (cadr args)))
1989 (elm-set! self 'owner (cadr args)))
1991 (elm-set! self 'outer-expr (cadr args)))
1993 (elm-set! self 'expr-fn (cadr args)))
1995 (elm-set! self 'env-stack (cadr args)))
1997 (elm-set! self 'isas (cadr args)))
1999 (elm-set! self 'depth (cadr args)))
2001 (elm-set! self 'modifiers (cadr args)))
2003 ; Build in reverse order, as we reverse it back when we're done.
2005 (cons (cadr args) (cons (car args) unrecognized)))))
2006 (loop (cddr args) unrecognized)))))
2011 (define-getters <eval-state> estate
2012 (context owner outer-expr expr-fn isas env-stack depth modifiers)
2014 (define-setters <eval-state> estate
2015 (isas env-stack depth modifiers)
2018 ; Build an estate for use in producing a value from rtl.
2019 ; CONTEXT is a <context> object or #f if there is none.
2020 ; OWNER is the owner of the expression or #f if there is none.
2022 (define (estate-make-for-eval context owner)
2026 #:expr-fn (lambda (rtx-obj expr mode estate)
2027 (rtx-evaluator rtx-obj))
2028 #:isas (and owner (obj-isa-list owner)))
2031 ; Create a copy of ESTATE.
2033 (define (estate-copy estate)
2034 (object-copy-top estate)
2037 ;; Create a copy of ESTATE with environment stack ENV-STACK added,
2038 ;; and the ISA(s) set to ISA-NAME-LIST.
2040 (define (estate-make-closure estate isa-name-list env-stack)
2041 (let ((result (estate-copy estate)))
2042 (estate-set-isas! result isa-name-list)
2043 (estate-set-env-stack! result (append env-stack (estate-env-stack result)))
2047 ; Create a copy of ESTATE with environment ENV pushed onto the existing
2049 ; There's no routine to pop the environment list as there's no current
2050 ; need for it: we make a copy of the state when we push.
2052 (define (estate-push-env estate env)
2053 (let ((result (estate-copy estate)))
2054 (estate-set-env-stack! result (cons env (estate-env-stack result)))
2058 ; Create a copy of ESTATE with the depth incremented by one.
2060 (define (estate-deepen estate)
2061 (let ((result (estate-copy estate)))
2062 (estate-set-depth! result (1+ (estate-depth estate)))
2066 ; Create a copy of ESTATE with modifiers MODS.
2068 (define (estate-with-modifiers estate mods)
2069 (let ((result (estate-copy estate)))
2070 (estate-set-modifiers! result (append mods (estate-modifiers result)))
2074 ; Convert a tstate to an estate.
2076 (define (tstate->estate t)
2078 #:context (tstate-context t)
2079 #:env-stack (tstate-env-stack t))
2082 ; Issue an error given an estate.
2084 (define (estate-error estate errmsg . expr)
2085 (apply context-owner-error
2086 (cons (estate-context estate)
2087 (cons (estate-owner estate)
2088 (cons (string-append "During rtx evalution"
2089 (if (estate-outer-expr estate)
2090 (string-append " of\n"
2091 (rtx-pretty-strdump (estate-outer-expr estate))
2094 (cons errmsg expr)))))
2097 ; RTL expression evaluation.
2099 ; ??? These used eval2 at one point. Not sure which is faster but I suspect
2100 ; eval2 is by far. On the otherhand this has yet to be compiled. And this way
2101 ; is more portable, more flexible, and works with guile 1.2 (which has
2102 ; problems with eval'ing self referential vectors, though that's one reason to
2105 ; Set to #t to debug rtx evaluation.
2107 (define /rtx-eval-debug? #f)
2109 ; RTX expression evaluator.
2111 ; EXPR is the expression to be eval'd. It must be in compiled(canonical) form.
2112 ; MODE is the desired mode of EXPR, a <mode> object.
2113 ; ESTATE is the current evaluation state.
2115 (define (rtx-eval-with-estate expr mode estate)
2116 (if /rtx-eval-debug?
2118 (display "Evaluating expr with mode ")
2119 (display (if (symbol? mode) mode (obj:name mode)))
2121 (display (rtx-dump expr))
2123 (rtx-env-stack-dump (estate-env-stack estate))
2126 (if (pair? expr) ; pair? -> cheap non-null-list?
2128 (let* ((rtx-obj (rtx-lookup (car expr)))
2129 (fn ((estate-expr-fn estate) rtx-obj expr mode estate)))
2132 (apply fn (cons estate (cdr expr)))
2133 ; ; Don't eval operands for syntax expressions.
2134 ; (if (eq? (rtx-style rtx-obj) 'SYNTAX)
2135 ; (apply fn (cons estate (cdr expr)))
2137 ; (/rtx-eval-operands rtx-obj expr estate)))
2138 ; (apply fn (cons estate operands))))
2140 ; Leave expr unchanged.
2143 ; (/rtx-traverse-operands rtx-obj expr estate)))
2144 ; (cons rtx-obj operands))))
2146 ; EXPR is not a list
2147 (error "argument to rtx-eval-with-estate is not a list" expr))
2150 ; Evaluate rtx expression EXPR and return the computed value.
2151 ; EXPR must already be in canonical form (the result of rtx-canonicalize).
2152 ; OWNER is the owner of the value, used for attribute computation
2153 ; and to get the ISA name list.
2154 ; OWNER is #f if there isn't one.
2157 (define (rtx-value expr owner)
2158 (rtx-eval-with-estate expr DFLT (estate-make-for-eval #f owner))
2161 ;; Initialize the tables.
2163 (define (rtx-init-traversal-tables!)
2164 (let ((compiler-hash-table (/rtx-make-canon-table))
2165 (traverser-hash-table (/rtx-make-traverser-table)))
2167 (set! /rtx-canoner-table (make-vector (rtx-max-num) #f))
2168 (set! /rtx-traverser-table (make-vector (rtx-max-num) #f))
2170 (for-each (lambda (rtx-name)
2171 (let ((rtx (rtx-lookup rtx-name)))
2173 (let ((num (rtx-num rtx))
2174 (arg-types (rtx-arg-types rtx)))
2175 (vector-set! /rtx-canoner-table num
2179 (hashq-ref compiler-hash-table arg-type)))
2181 (vector-set! /rtx-traverser-table num
2185 (hashq-ref traverser-hash-table arg-type)))
2189 (set! /rtx-operand-canoners (make-vector (rtx-max-num) /rtx-canon-operands))
2190 (for-each (lambda (rtx-canoner)
2191 (let ((rtx-obj (rtx-lookup (car rtx-canoner))))
2192 (vector-set! /rtx-operand-canoners (rtx-num rtx-obj) (cdr rtx-canoner))))
2193 (/rtx-special-expr-canoners))