; Routines for instruction semantic analysis (including rtx-simplify).
; Copyright (C) 2000 Red Hat, Inc.
; This file is part of CGEN.
; See file COPYING.CGEN for details.

; Semantic expression compilation.
; This is more involved than normal rtx compilation as we need to keep
; track of the inputs and outputs.  Various attributes that can be derived
; from the code are also computed.

; Subroutine of -simplify-expr-fn to compare two values for equality.
; If both are constants and they're equal return #f/#t.
; INVERT? = #f -> return #t if equal, #t -> return #f if equal.
; Returns 'unknown if either argument is not a constant.

(define (rtx-const-equal arg0 arg1 invert?)
  (if (and (rtx-constant? arg0)
	   (rtx-constant? arg1))
      (if invert?
	  (!= (rtx-constant-value arg0)
	      (rtx-constant-value arg1))
	  (= (rtx-constant-value arg0)
	     (rtx-constant-value arg1)))
      'unknown)
)

; Subroutine of -simplify-expr-fn to see if MAYBE-CONST is one of NUMBER-LIST.
; NUMBER-LIST is a `number-list' rtx.
; INVERT? is #t if looking for non-membership.
; #f/#t is only returned for definitive answers.
; If INVERT? is #f:
; - return #f if MAYBE-CONST is not in NUMBER-LIST
; - return #t if MAYBE-CONST is in NUMBER-LIST and it has only one member
; - return 'member if MAYBE-CONST is in NUMBER-LIST and it has many members
; - otherwise return 'unknown
; If INVERT? is #t:
; - return #t if MAYBE-CONST is not in NUMBER-LIST
; - return #f if MAYBE-CONST is in NUMBER-LIST and it has only one member
; - return 'member if MAYBE-CONST is in NUMBER-LIST and it has many members
; - otherwise return 'unknown

(define (rtx-const-list-equal maybe-const number-list invert?)
  (assert (rtx-kind? 'number-list number-list))
  (if (rtx-constant? maybe-const)
      (let ((values (rtx-number-list-values number-list)))
	(if invert?
	    (if (memq (rtx-constant-value maybe-const) values)
		(if (= (length values) 1)
		    #f
		    'member)
		#t)
	    (if (memq (rtx-constant-value maybe-const) values)
		(if (= (length values) 1)
		    #t
		    'member)
		#f)))
      'unknown)
)

; Subroutine of -simplify-expr-fn to simplify an eq-attr of (current-mach).
; CONTEXT is a <context> object or #f if there is none.

(define (rtx-simplify-eq-attr-mach rtx context)
  (let ((attr (rtx-eq-attr-attr rtx))
	(value (rtx-eq-attr-value rtx)))
    ; If all currently selected machs will yield the same value
    ; for the attribute, we can simplify.
    (let ((values (map (lambda (m)
			 (obj-attr-value m attr))
		       (current-mach-list))))
      ; Ensure at least one mach is selected.
      (if (null? values)
	  (context-error context "rtx simplification, no machs selected"
			 (rtx-strdump rtx)))
      ; All values equal to the first one?
      (if (all-true? (map (lambda (val)
			    (equal? val (car values)))
			  values))
	  (if (equal? value
		      ; Convert internal boolean attribute value
		      ; #f/#t to external value FALSE/TRUE.
		      ; FIXME:revisit.
		      (case (car values)
			((#f) 'FALSE)
			((#t) 'TRUE)
			(else (car values))))
	      (rtx-true)
	      (rtx-false))
	  ; couldn't simplify
	  rtx)))
)

; Subroutine of -simplify-expr-fn to simplify an eq-attr of (current-insn).

(define (rtx-simplify-eq-attr-insn rtx insn context)
  (let ((attr (rtx-eq-attr-attr rtx))
	(value (rtx-eq-attr-value rtx)))
    (if (not (insn? insn))
	(context-error context
		       "No current insn for `(current-insn)'"
		       (rtx-strdump rtx)))
    (let ((attr-value (obj-attr-value insn attr)))
      (if (eq? value attr-value)
	  (rtx-true)
	  (rtx-false))))
)

; Subroutine of rtx-simplify.
; This is the EXPR-FN argument to rtx-traverse.

(define (-simplify-expr-fn rtx-obj expr mode parent-expr op-pos tstate appstuff)

  ;(display "Processing ") (display (rtx-dump expr)) (newline)

  (case (rtx-name expr)

    ((not)
     (let* ((arg (-rtx-traverse (rtx-alu-op-arg expr 0)
				'RTX
				(rtx-alu-op-mode expr)
				expr 1 tstate appstuff))
	    (no-side-effects? (not (rtx-side-effects? arg))))
       (cond ((and no-side-effects? (rtx-false? arg))
	      (rtx-true))
	     ((and no-side-effects? (rtx-true? arg))
	      (rtx-false))
	     (else (rtx-make 'not (rtx-alu-op-mode expr) arg)))))

    ((orif)
     (let ((arg0 (-rtx-traverse (rtx-boolif-op-arg expr 0)
				'RTX 'DFLT expr 0 tstate appstuff))
	   (arg1 (-rtx-traverse (rtx-boolif-op-arg expr 1)
				'RTX 'DFLT expr 1 tstate appstuff)))
       (let ((no-side-effects-0? (not (rtx-side-effects? arg0)))
	     (no-side-effects-1? (not (rtx-side-effects? arg1))))
	 (cond ((and no-side-effects-0? (rtx-true? arg0))
		(rtx-true))
	       ((and no-side-effects-0? (rtx-false? arg0))
		(rtx-canonical-bool arg1))
	       ; Value of arg0 is unknown or has side-effects.
	       ((and no-side-effects-1? (rtx-true? arg1))
		(if no-side-effects-0?
		    (rtx-true)
		    (rtx-make 'orif arg0 (rtx-true))))
	       ((and no-side-effects-1? (rtx-false? arg1))
		arg0)
	       (else
		(rtx-make 'orif arg0 arg1))))))

    ((andif)
     (let ((arg0 (-rtx-traverse (rtx-boolif-op-arg expr 0)
				'RTX 'DFLT expr 0 tstate appstuff))
	   (arg1 (-rtx-traverse (rtx-boolif-op-arg expr 1)
				'RTX 'DFLT expr 1 tstate appstuff)))
       (let ((no-side-effects-0? (not (rtx-side-effects? arg0)))
	     (no-side-effects-1? (not (rtx-side-effects? arg1))))
	 (cond ((and no-side-effects-0? (rtx-false? arg0))
		(rtx-false))
	       ((and no-side-effects-0? (rtx-true? arg0))
		(rtx-canonical-bool arg1))
	       ; Value of arg0 is unknown or has side-effects.
	       ((and no-side-effects-1? (rtx-false? arg1))
		(if no-side-effects-0?
		    (rtx-false)
		    (rtx-make 'andif arg0 (rtx-false))))
	       ((and no-side-effects-1? (rtx-true? arg1))
		arg0)
	       (else
		(rtx-make 'andif arg0 arg1))))))

    ; Fold if's to their then or else part if we can determine the
    ; result of the test.
    ((if)
     (let ((test
	    ; ??? Was this but that calls rtx-traverse again which
	    ; resets the temp stack!
	    ; (rtx-simplify context (caddr expr))))
	    (-rtx-traverse (rtx-if-test expr) 'RTX 'DFLT expr 1 tstate appstuff)))
       (cond ((rtx-true? test)
	      (-rtx-traverse (rtx-if-then expr) 'RTX mode expr 2 tstate appstuff))
	     ((rtx-false? test)
	      (if (rtx-if-else expr)
		  (-rtx-traverse (rtx-if-else expr) 'RTX mode expr 3 tstate appstuff)
		  ; Sanity check, mode must be VOID.
		  (if (or (mode:eq? 'DFLT (rtx-mode expr))
			  (mode:eq? 'VOID (rtx-mode expr)))
		      (rtx-make 'nop)
		      (error "rtx-simplify: non-void-mode `if' missing `else' part" expr))))
	     ; Can't simplify.
	     ; We could traverse the then/else clauses here, but it's simpler
	     ; to have our caller do it.  The cost is retraversing `test'.
	     (else #f))))

    ((eq ne)
     (let ((name (rtx-name expr))
	   (cmp-mode (rtx-cmp-op-mode expr))
	   (arg0 (-rtx-traverse (rtx-cmp-op-arg expr 0) 'RTX
				(rtx-cmp-op-mode expr)
				expr 1 tstate appstuff))
	   (arg1 (-rtx-traverse (rtx-cmp-op-arg expr 1) 'RTX
				(rtx-cmp-op-mode expr)
				expr 2 tstate appstuff)))
       (if (or (rtx-side-effects? arg0) (rtx-side-effects? arg1))
	   (rtx-make name cmp-mode arg0 arg1)
	   (case (rtx-const-equal arg0 arg1 (rtx-kind? 'ne expr))
	     ((#f) (rtx-false))
	     ((#t) (rtx-true))
	     (else
	      ; That didn't work.  See if we have an ifield/operand with a
	      ; known range of values.
	      (case (rtx-name arg0)
		((ifield)
		 (let ((known-val (tstate-known-lookup tstate
						       (rtx-ifield-name arg0))))
		   (if (and known-val (rtx-kind? 'number-list known-val))
		       (case (rtx-const-list-equal arg1 known-val (rtx-kind? 'ne expr))
			 ((#f) (rtx-false))
			 ((#t) (rtx-true))
			 (else
			  (rtx-make name cmp-mode arg0 arg1)))
		       (rtx-make name cmp-mode arg0 arg1))))
		((operand)
		 (let ((known-val (tstate-known-lookup tstate
						       (rtx-operand-name arg0))))
		   (if (and known-val (rtx-kind? 'number-list known-val))
		       (case (rtx-const-list-equal arg1 known-val (rtx-kind? 'ne expr))
			 ((#f) (rtx-false))
			 ((#t) (rtx-true))
			 (else
			  (rtx-make name cmp-mode arg0 arg1)))
		       (rtx-make name cmp-mode arg0 arg1))))
		(else
		 (rtx-make name cmp-mode arg0 arg1))))))))

    ; Recognize attribute requests of current-insn, current-mach.
    ((eq-attr)
     (cond ((rtx-kind? 'current-mach (rtx-eq-attr-owner expr))
	    (rtx-simplify-eq-attr-mach expr (tstate-context tstate)))
	   ((rtx-kind? 'current-insn (rtx-eq-attr-owner expr))
	    (rtx-simplify-eq-attr-insn expr (tstate-owner tstate) (tstate-context tstate)))
	   (else expr)))

    ((ifield)
     (let ((known-val (tstate-known-lookup tstate (rtx-ifield-name expr))))
       ; If the value is a single number, return that.
       ; It can be one of several, represented as a number list.
       (if (and known-val (rtx-constant? known-val))
	   known-val ; (rtx-make 'const 'INT known-val)
	   #f)))

    ((operand)
     (let ((known-val (tstate-known-lookup tstate (rtx-operand-name expr))))
       ; If the value is a single number, return that.
       ; It can be one of several, represented as a number list.
       (if (and known-val (rtx-constant? known-val))
	   known-val ; (rtx-make 'const 'INT known-val)
	   #f)))

    ; Leave EXPR unchanged and continue.
    (else #f))
)

; Simplify an rtl expression.
; EXPR must be in source form.
; The result is a possibly simplified EXPR, still in source form.
;
; CONTEXT is a <context> object, used for error messages.
; OWNER is the owner of the expression (e.g. <insn>) or #f if there is none.
;
; KNOWN is an alist of known values.  Each element is (name . value) where
; NAME is an ifield/operand name and VALUE is a const/number-list rtx.
; FIXME: Need ranges, later.
;
; The following operations are performed:
; - unselected machine dependent code is removed (eq-attr of (current-mach))
; - if's are reduced to either then/else if we can determine that the test is
;   a compile-time constant
; - orif/andif
; - eq/ne
; - not
;
; ??? Will become more intelligent as needed.

(define (rtx-simplify context owner expr known)
  (-rtx-traverse expr #f 'DFLT #f 0
		 (tstate-make context owner
			      (/fastcall-make -simplify-expr-fn)
			      (rtx-env-empty-stack)
			      #f #f known 0)
		 #f)
)

; Utilities for equation solving.
; ??? At the moment this is only focused on ifield assertions.
; ??? That there exist more sophisticated versions than this one can take
; as a given.  This works for the task at hand and will evolve or be replaced
; as necessary.
; ??? This makes the simplifying assumption that no expr has side-effects.

; Subroutine of rtx-solve.
; This is the EXPR-FN argument to rtx-traverse.

(define (-solve-expr-fn rtx-obj expr mode parent-expr op-pos tstate appstuff)
  #f ; wip
)

; Return a boolean indicating if {expr} equates to "true".
; If the expression can't be reduced to #f/#t, return '?.
; ??? Use rtx-eval instead of rtx-traverse?
;
; EXPR must be in source form.
; CONTEXT is a <context> object, used for error messages.
; OWNER is the owner of the expression (e.g. <insn>) or #f if there is none.
; KNOWN is an alist of known values.  Each element is (name . value) where
; NAME is an ifield/operand name and VALUE is a const/number-list rtx.
; FIXME: Need ranges, later.
;
; This is akin to rtx-simplify except it's geared towards solving ifield
; assertions.  It's not unreasonable to combine them.  The worry is the
; efficiency lost.
; ??? Will become more intelligent as needed.

(define (rtx-solve context owner expr known)
  ; First simplify, then solve.
  (let* ((simplified-expr (rtx-simplify context owner expr known))
	 (maybe-solved-expr
	  simplified-expr) ; FIXME: for now
;	  (-rtx-traverse simplified-expr #f 'DFLT #f 0
;			 (tstate-make context owner
;				      (/fastcall-make -solve-expr-fn)
;				      (rtx-env-empty-stack)
;				      #f #f known 0)
;			 #f))
	 )
    (cond ((rtx-true? maybe-solved-expr) #t)
	  ((rtx-false? maybe-solved-expr) #f)
	  (else '?)))
)

; Subroutine of -rtx-find-op to determine if two modes are equivalent.
; Two modes are equivalent if they're equal, or if their sem-mode fields
; are equal.

(define (-rtx-mode-equiv? m1 m2)
  (or (eq? m1 m2)
      (let ((mode1 (mode:lookup m1))
	    (mode2 (mode:lookup m2)))
	(let ((s1 (mode:sem-mode mode1))
	      (s2 (mode:sem-mode mode2)))
	  (eq? (if s1 (obj:name s1) m1) (if s2 (obj:name s2) m2)))))
)

; Subroutine of semantic-compile to find OP in OP-LIST.
; OP-LIST is a list of operand expressions: (type expr mode name indx-sel).
; The result is the list element or #f if not found.
; TYPE is one of -op- reg mem.
; EXPR is the constructed `xop' rtx expression for the operand,
;   ignored in the search.
; MODE must match, as defined by -rtx-mode-equiv?.
; NAME is the hardware element name, ifield name, or '-op-'.
; INDX-SEL must match if present in either.
;
; ??? Does this need to take "conditionally-referenced" into account?

(define (-rtx-find-op op op-list)
  (let ((type (car op))
	(mode (caddr op))
	(name (cadddr op))
	(indx-sel (car (cddddr op))))
    ; The first cdr is to drop the dummy first arg.
    (let loop ((op-list (cdr op-list)))
      (cond ((null? op-list) #f)
	    ((eq? type (caar op-list))
	     (let ((try (car op-list)))
	       (if (and (eq? name (cadddr try))
			(-rtx-mode-equiv? mode (caddr try))
			(equal? indx-sel (car (cddddr try))))
		   try
		   (loop (cdr op-list)))))
	    (else (loop (cdr op-list))))))
)

; Subroutine of semantic-compile to determine how the operand in
; position OP-POS of EXPR is used.
; The result is one of 'use, 'set, 'set-quiet.
; "use" means "input operand".

(define (-rtx-ref-type expr op-pos)
  ; operand 0 is the option list, operand 1 is the mode
  ; (if you want to complain, fine, it's not like it would be unexpected)
  (if (= op-pos 2)
      (case (car expr)
	((set) 'set)
	((set-quiet clobber) 'set-quiet)
	(else 'use))
      'use)
)

; Subroutine of semantic-compile:process-expr!, to simplify it.
; Looks up the operand in the current set, returns it if found,
; otherwise adds it.
; REF-TYPE is one of 'use, 'set, 'set-quiet.
; Adds COND-CTI/UNCOND-CTI to SEM-ATTRS if the operand is a set of the pc.

(define (-build-operand! op-name op mode tstate ref-type op-list sem-attrs)
  ;(display (list op-name mode ref-type)) (newline) (force-output)
  (let* ((mode (mode-real-name (if (eq? mode 'DFLT)
				   (op:mode op)
				   mode)))
         ; The first #f is a placeholder for the object.
	 (try (list '-op- #f mode op-name #f))
	 (existing-op (-rtx-find-op try op-list)))

    (if (and (pc? op)
	     (memq ref-type '(set set-quiet)))
	(append! sem-attrs
		 (list (if (tstate-cond? tstate) 'COND-CTI 'UNCOND-CTI))))

    ; If already present, return the object, otherwise add it.
    (if existing-op

	(cadr existing-op)

	; We can't set the operand number yet 'cus we don't know it.
	; However, when it's computed we'll need to set all associated
	; operands.  This is done by creating shared rtx (a la gcc) - the
	; operand number then need only be updated in one place.

	(let ((xop (op:new-mode op mode)))
	  (op:set-cond?! xop (tstate-cond? tstate))
	  ; Set the object rtx in `try', now that we have it.
	  (set-car! (cdr try) (rtx-make 'xop xop))
	  ; Add the operand to in/out-ops.
	  (append! op-list (list try))
	  (cadr try))))
)

; Subroutine of semantic-compile:process-expr!, to simplify it.

(define (-build-reg-operand! expr tstate op-list)
  (let* ((hw-name (rtx-reg-name expr))
	 (hw (current-hw-sem-lookup-1 hw-name)))

    (if hw
	; If the mode is DFLT, use the object's natural mode.
	(let* ((mode (mode-real-name (if (eq? (rtx-mode expr) 'DFLT)
					 (obj:name (hw-mode hw))
					 (rtx-mode expr))))
	       (indx-sel (rtx-reg-index-sel expr))
	       ; #f is a place-holder for the object (filled in later)
	       (try (list 'reg #f mode hw-name indx-sel))
	       (existing-op (-rtx-find-op try op-list)))

	  ; If already present, return the object, otherwise add it.
	  (if existing-op

	      (cadr existing-op)

	      (let ((xop (apply reg (cons (tstate->estate tstate)
					  (cons mode
						(cons hw-name indx-sel))))))
		(op:set-cond?! xop (tstate-cond? tstate))
		; Set the object rtx in `try', now that we have it.
		(set-car! (cdr try) (rtx-make 'xop xop))
		; Add the operand to in/out-ops.
		(append! op-list (list try))
		(cadr try))))

	(parse-error "FIXME" "unknown reg" expr)))
)

; Subroutine of semantic-compile:process-expr!, to simplify it.

(define (-build-mem-operand! expr tstate op-list)
  (let ((mode (rtx-mode expr))
	(indx-sel (rtx-mem-index-sel expr)))

    (if (memq mode '(DFLT VOID))
	(parse-error "FIXME" "memory must have explicit mode" expr))

    (let* ((try (list 'mem #f mode 'h-memory indx-sel))
	   (existing-op (-rtx-find-op try op-list)))

      ; If already present, return the object, otherwise add it.
      (if existing-op

	  (cadr existing-op)

	  (let ((xop (apply mem (cons (tstate->estate tstate)
				      (cons mode indx-sel)))))
	    (op:set-cond?! xop (tstate-cond? tstate))
	    ; Set the object in `try', now that we have it.
	    (set-car! (cdr try) (rtx-make 'xop xop))
	    ; Add the operand to in/out-ops.
	    (append! op-list (list try))
	    (cadr try)))))
)

; Subroutine of semantic-compile:process-expr!, to simplify it.

(define (-build-ifield-operand! expr tstate op-list)
  (let* ((f-name (rtx-ifield-name expr))
	 (f (current-ifld-lookup f-name)))

    (if (not f)
	(parse-error "FIXME" "unknown ifield" f-name))

    (let* ((mode (obj:name (ifld-mode f)))
	   (try (list '-op- #f mode f-name #f))
	   (existing-op (-rtx-find-op try op-list)))

      ; If already present, return the object, otherwise add it.
      (if existing-op

	  (cadr existing-op)

	  (let ((xop (make <operand> f-name f-name
			   (atlist-cons (bool-attr-make 'SEM-ONLY #t)
					(obj-atlist f))
			   (obj:name (ifld-hw-type f))
			   mode
			   (make <hw-index> 'anonymous
				 'ifield (ifld-mode f) f)
			   nil #f #f)))
	    (set-car! (cdr try) (rtx-make 'xop xop))
	    (append! op-list (list try))
	    (cadr try)))))
)

; Subroutine of semantic-compile:process-expr!, to simplify it.
;
; ??? There are various optimizations (both space usage in ARGBUF and time
; spent in semantic code) that can be done on code that uses index-of
; (see i960's movq insn).  Later.

(define (-build-index-of-operand! expr tstate op-list)
  (if (not (and (rtx? (rtx-index-of-value expr))
		(rtx-kind? 'operand (rtx-index-of-value expr))))
      (parse-error "FIXME" "only `(index-of operand)' is currently supported"
		   expr))

  (let ((op (rtx-operand-obj (rtx-index-of-value expr))))
    (let ((indx (op:index op)))
      (if (not (eq? (hw-index:type indx) 'ifield))
	  (parse-error "FIXME" "only ifield indices are currently supported"
		       expr))
      (let* ((f (hw-index:value indx))
	     (f-name (obj:name f)))
	; The rest of this is identical to -build-ifield-operand!.
	(let* ((mode (obj:name (ifld-mode f)))
	       (try (list '-op- #f mode f-name #f))
	       (existing-op (-rtx-find-op try op-list)))

	  ; If already present, return the object, otherwise add it.
	  (if existing-op

	      (cadr existing-op)

	      (let ((xop (make <operand> f-name f-name
			       (atlist-cons (bool-attr-make 'SEM-ONLY #t)
					    (obj-atlist f))
			       (obj:name (ifld-hw-type f))
			       mode
			       (make <hw-index> 'anonymous
				     'ifield
				     (ifld-mode f)
				     ; (send (op:type op) 'get-index-mode)
				     f)
			       nil #f #f)))
		(set-car! (cdr try) (rtx-make 'xop xop))
		(append! op-list (list try))
		(cadr try)))))))
)

; Build the tstate known value list for INSN.
; This built from the ifield-assertion list.

(define (insn-build-known-values insn)
  (let ((expr (insn-ifield-assertion insn)))
    (if expr
	(case (rtx-name expr)
	  ((eq)
	   (if (and (rtx-kind? 'ifield (rtx-cmp-op-arg expr 0))
		    (rtx-constant? (rtx-cmp-op-arg expr 1)))
	       (list (cons (rtx-ifield-name (rtx-cmp-op-arg expr 0))
			   (rtx-cmp-op-arg expr 1)))
	       nil))
	  ((member)
	   (if (rtx-kind? 'ifield (rtx-member-value expr))
	       (list (cons (rtx-ifield-name (rtx-member-value expr))
			   (rtx-member-set expr)))
	       nil))
	  (else nil))
	nil))
)

; Structure to record the result of semantic-compile.

(define (csem-make compiled-code inputs outputs attributes)
  (vector compiled-code inputs outputs attributes)
)

; Accessors.

(define (csem-code csem) (vector-ref csem 0))
(define (csem-inputs csem) (vector-ref csem 1))
(define (csem-outputs csem) (vector-ref csem 2))
(define (csem-attrs csem) (vector-ref csem 3))

; Traverse each element in SEM-CODE-LIST, converting them to canonical form,
; and computing the input and output operands.
; The result is an object of four elements (built with csem-make).
; The first is a list of the canonical form of each element in SEM-CODE-LIST:
; operand and ifield elements specified without `operand' or `ifield' have it
; prepended, and operand numbers are computed for each operand.
; Operand numbers are needed when emitting "write" handlers for LIW cpus.
; Having the operand numbers available is also useful for efficient
; modeling: recording operand references can be done with a bitmask (one host
; insn), and the code to do the modeling can be kept out of the code that
; performs the insn.
; The second is the list of input <operand> objects.
; The third is the list of output <operand> objects.
; The fourth is an <attr-list> object of attributes that can be computed from
; the semantics.
; The possibilities are: UNCOND-CTI, COND-CTI, SKIP-CTI, DELAY-SLOT.
; ??? Combine *-CTI into an enum attribute.
;
; CONTEXT is a <context> object or #f if there is none.
; INSN is the <insn> object.
;
; ??? Specifying operand ordinals in the source would simplify this and speed
; it up.  On the other hand that makes the source form more complex.  Maybe the
; complexity will prove necessary, but following the goal of "incremental
; complication", we don't do this yet.
; Another way to simplify this and speed it up would be to add lists of
; input/output operands to the instruction description.
;
; ??? This calls rtx-simplify which calls rtx-traverse as it's simpler to
; simplify EXPR first, and then compile it.  On the other hand it's slower
; (two calls to rtx-traverse!).
;
; FIXME: There's no need for sem-code-list to be a list.
; The caller always passes (list (insn-semantics insn)).

(define (semantic-compile context insn sem-code-list)
  (for-each (lambda (rtx) (assert (rtx? rtx)))
	    sem-code-list)

  (let*
      ; String for error messages.
      ((errtxt "semantic compilation")

       ; These record the result of traversing SEM-CODE-LIST.
       ; They're lists of (type object mode name [args ...]).
       ; TYPE is one of: -op- reg mem.
       ; `-op-' is just something unique and is only used internally.
       ; OBJECT is the constructed <operand> object.
       ; The first element is just a dummy so that append! always works.
       (in-ops (list (list #f)))
       (out-ops (list (list #f)))

       ; List of attributes computed from SEM-CODE-LIST.
       ; The first element is just a dummy so that append! always works.
       (sem-attrs (list #f))

       ; Called for expressions encountered in SEM-CODE-LIST.
       ; Don't waste cpu here, this is part of the slowest piece in CGEN.
       (process-expr!
	(lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff)
	  (case (car expr)

	    ; Registers.
	    ((reg) (let ((ref-type (-rtx-ref-type parent-expr op-pos))
			 ; ??? could verify reg is a scalar
			 (regno (or (rtx-reg-number expr) 0)))
		     ; The register number is either a number or an
		     ; expression.
		     ; ??? This is a departure from GCC RTL that might have
		     ; significant ramifications.  On the other hand in cases
		     ; where it matters the expression could always be
		     ; required to reduce to a constant (or some such).
		     (cond ((number? regno) #t)
			   ((form? regno)
			    (rtx-traverse-operands rtx-obj expr tstate appstuff))
			   (else (parse-error errtxt
					      "invalid register number"
					      regno)))
		     (-build-reg-operand! expr tstate
					  (if (eq? ref-type 'use)
					      in-ops
					      out-ops))))

	    ; Memory.
	    ((mem) (let ((ref-type (-rtx-ref-type parent-expr op-pos)))
		     (rtx-traverse-operands rtx-obj expr tstate appstuff)
		     (-build-mem-operand! expr tstate
					  (if (eq? ref-type 'use)
					      in-ops
					      out-ops))))

	    ; Operands.
	    ((operand) (let ((op (rtx-operand-obj expr))
			     (ref-type (-rtx-ref-type parent-expr op-pos)))
			 (-build-operand! (obj:name op) op mode tstate ref-type
					  (if (eq? ref-type 'use)
					      in-ops
					      out-ops)
					  sem-attrs)))

	    ; Give operand new name.
	    ((name) (let ((result (-rtx-traverse (caddr expr) 'RTX mode
						 parent-expr op-pos tstate appstuff)))
		      (if (not (operand? result))
			  (error "name: invalid argument:" expr result))
		      (op:set-sem-name! result (cadr expr))
		      ; (op:set-num! result (caddr expr))
		      result))

	    ; Specify a reference to a local variable
	    ((local) expr) ; nothing to do

	    ; Instruction fields.
	    ((ifield) (let ((ref-type (-rtx-ref-type parent-expr op-pos)))
			(if (not (eq? ref-type 'use))
			    (parse-error errtxt "can't set an `ifield'" expr))
			(-build-ifield-operand! expr tstate in-ops)))

	    ; Hardware indices.
	    ; For registers this is the register number.
	    ; For memory this is the address.
	    ; For constants, this is the constant.
	    ((index-of) (let ((ref-type (-rtx-ref-type parent-expr op-pos)))
			  (if (not (eq? ref-type 'use))
			      (parse-error errtxt "can't set an `index-of'" expr))
			  (-build-index-of-operand! expr tstate in-ops)))

	    ; Machine generate the SKIP-CTI attribute.
	    ((skip) (append! sem-attrs (list 'SKIP-CTI)) #f)

	    ; Machine generate the DELAY-SLOT attribute.
	    ((delay) (append! sem-attrs (list 'DELAY-SLOT)) #f)

	    ; If this is a syntax expression, the operands won't have been
	    ; processed, so tell our caller we want it to by returning #f.
	    ; We do the same for non-syntax expressions to keep things
	    ; simple.  This requires collaboration with the traversal
	    ; handlers which are defined to do what we want if we return #f.
	    (else #f))))

       ; Whew.  We're now ready to traverse the expression.
       ; Traverse the expression recording the operands and building objects
       ; for most elements in the source representation.
       ; This also performs various simplifications.
       ; In particular machine dependent code for non-selected machines
       ; is discarded.
       (compiled-exprs (map (lambda (expr)
			      (rtx-traverse
			       context
			       insn
			       (rtx-simplify context insn expr
					     (insn-build-known-values insn))
			       process-expr!
			       #f))
			    sem-code-list))
       )

    ;(display "in:  ") (display in-ops) (newline)
    ;(display "out: ") (display out-ops) (newline)
    ;(force-output)

    ; Now that we have the nub of all input and output operands,
    ; we can assign operand numbers.  Inputs and outputs are not defined
    ; separately, output operand numbers follow inputs.  This simplifies the
    ; code which keeps track of such things: it can use one variable.
    ; The assignment is defined to be arbitrary.  If there comes a day
    ; when we need to prespecify operand numbers, revisit.
    ; The operand lists are sorted to avoid spurious differences in generated
    ; code (for example unnecessary extra entries can be created in the
    ; ARGBUF struct).

    ; Drop dummy first arg and sort operand lists.
    (let ((sorted-ins
	   (alpha-sort-obj-list (map (lambda (op)
				       (rtx-xop-obj (cadr op)))
				     (cdr in-ops))))
	  (sorted-outs
	   (alpha-sort-obj-list (map (lambda (op)
				       (rtx-xop-obj (cadr op)))
				     (cdr out-ops))))
	  (sem-attrs (cdr sem-attrs)))

      (let ((in-op-nums (iota (length sorted-ins)))
	    (out-op-nums (iota (length sorted-outs) (length sorted-ins))))

	(for-each (lambda (op num) (op:set-num! op num))
		  sorted-ins in-op-nums)
	(for-each (lambda (op num) (op:set-num! op num))
		  sorted-outs out-op-nums)

	(let ((dump (lambda (op)
		      (string/symbol-append "  "
					    (obj:name op)
					    " "
					    (number->string (op:num op))
					    "\n"))))
	  (logit 4
		 "Input operands:\n"
		 (map dump sorted-ins)
		 "Output operands:\n"
		 (map dump sorted-outs)
		 "End of operands.\n"))

	(csem-make compiled-exprs sorted-ins sorted-outs
		   (atlist-parse sem-attrs "" "semantic attributes")))))
)

; Traverse SEM-CODE-LIST, computing attributes derivable from it.
; The result is an <attr-list> object of attributes that can be computed from
; the semantics.
; The possibilities are: UNCOND-CTI, COND-CTI, SKIP-CTI, DELAY-SLOT.
; This computes the same values as semantic-compile, but for speed is
; focused on attributes only.
; ??? Combine *-CTI into an enum attribute.
;
; CONTEXT is a <context> object or #f if there is none.
; INSN is the <insn> object.
;
; FIXME: There's no need for sem-code-list to be a list.
; The caller always passes (list (insn-semantics insn)).

(define (semantic-attrs context insn sem-code-list)
  (for-each (lambda (rtx) (assert (rtx? rtx)))
	    sem-code-list)

  (let*
      ; String for error messages.
      ((errtxt "semantic attribute computation")

       ; List of attributes computed from SEM-CODE-LIST.
       ; The first element is just a dummy so that append! always works.
       (sem-attrs (list #f))

       ; Called for expressions encountered in SEM-CODE-LIST.
       (process-expr!
	(lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff)
	  (case (car expr)

	    ((operand) (if (and (eq? 'pc (obj:name (rtx-operand-obj expr)))
				(memq (-rtx-ref-type parent-expr op-pos)
				      '(set set-quiet)))
			   (append! sem-attrs
				    (if (tstate-cond? tstate)
					; Don't change these to '(FOO), since
					; we use append!.
					(list 'COND-CTI)
					(list 'UNCOND-CTI)))))
	    ((skip) (append! sem-attrs (list 'SKIP-CTI)) #f)
	    ((delay) (append! sem-attrs (list 'DELAY-SLOT)) #f)

	    ; If this is a syntax expression, the operands won't have been
	    ; processed, so tell our caller we want it to by returning #f.
	    ; We do the same for non-syntax expressions to keep things
	    ; simple.  This requires collaboration with the traversal
	    ; handlers which are defined to do what we want if we return #f.
	    (else #f))))

       ; Traverse the expression recording the attributes.
       (traversed-exprs (map (lambda (expr)
			       (rtx-traverse
				context
				insn
				(rtx-simplify context insn expr
					      (insn-build-known-values insn))
				process-expr!
				#f))
			     sem-code-list))
       )

    (let
	; Drop dummy first arg.
	((sem-attrs (cdr sem-attrs)))
      (atlist-parse sem-attrs "" "semantic attributes")))
)