#| -*-Scheme-*-

$Id: rtlty2.scm,v 4.18 2008/01/30 20:01:56 cph Exp $

Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
    2006, 2007, 2008 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; Register Transfer Language Type Definitions
;;; package: (compiler)

(declare (usual-integrations))

(define-integrable rtl:expression? pair?)
(define-integrable rtl:expression-type car)
(define-integrable rtl:address-register cadr)
(define-integrable rtl:address-number caddr)
(define-integrable rtl:test-expression cadr)
(define-integrable rtl:invocation-pushed cadr)
(define-integrable rtl:invocation-continuation caddr)

(define-integrable (rtl:set-invocation-continuation! rtl continuation)
  (set-car! (cddr rtl) continuation))

;;;; Locatives

;;; Locatives are used as an intermediate form by the code generator
;;; to build expressions.  Later, when the expressions are inserted
;;; into statements, any locatives they contain are eliminated by
;;; "simplifying" them into sequential instructions using pseudo
;;; registers.

(define-integrable register:environment
  'ENVIRONMENT)

(define-integrable register:stack-pointer
  'STACK-POINTER)

(define-integrable register:dynamic-link
  'DYNAMIC-LINK)

(define-integrable register:value
  'VALUE)

(define-integrable register:int-mask
  'INT-MASK)

(define-integrable register:memory-top
  'MEMORY-TOP)

(define-integrable register:free
  'FREE)

(define-integrable (rtl:interpreter-call-result:access)
  (rtl:make-fetch 'INTERPRETER-CALL-RESULT:ACCESS))

(define-integrable (rtl:interpreter-call-result:cache-reference)
  (rtl:make-fetch 'INTERPRETER-CALL-RESULT:CACHE-REFERENCE))

(define-integrable (rtl:interpreter-call-result:cache-unassigned?)
  (rtl:make-fetch 'INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?))

(define-integrable (rtl:interpreter-call-result:lookup)
  (rtl:make-fetch 'INTERPRETER-CALL-RESULT:LOOKUP))

(define-integrable (rtl:interpreter-call-result:unassigned?)
  (rtl:make-fetch 'INTERPRETER-CALL-RESULT:UNASSIGNED?))

(define-integrable (rtl:interpreter-call-result:unbound?)
  (rtl:make-fetch 'INTERPRETER-CALL-RESULT:UNBOUND?))

;;; "Pre-simplification" locative offsets

(define (rtl:locative-offset? locative)
  (and (pair? locative) (eq? (car locative) 'OFFSET)))

(define-integrable rtl:locative-offset-base cadr)
(define-integrable rtl:locative-offset-offset caddr)

#|
(define (rtl:locative-offset-granularity locative)
  ;; This is kludged up for backward compatibility
  (if (rtl:locative-offset? locative)
      (if (pair? (cdddr locative))
	  (cadddr locative)
	  'OBJECT)
      (error "Not a locative offset" locative)))
|#
(define-integrable rtl:locative-offset-granularity cadddr)

(define-integrable (rtl:locative-byte-offset? locative)
  (eq? (rtl:locative-offset-granularity locative) 'BYTE))

(define-integrable (rtl:locative-float-offset? locative)
  (eq? (rtl:locative-offset-granularity locative) 'FLOAT))

(define-integrable (rtl:locative-object-offset? locative)
  (eq? (rtl:locative-offset-granularity locative) 'OBJECT))

(define-integrable (rtl:locative-offset locative offset)
  (rtl:locative-object-offset locative offset))

(define (rtl:locative-byte-offset locative byte-offset)
  (cond ((rtl:locative-offset? locative)
	 `(OFFSET ,(rtl:locative-offset-base locative)
		  ,(back-end:+
		    byte-offset
		    (cond ((rtl:locative-byte-offset? locative)
			   (rtl:locative-offset-offset locative))
			  ((rtl:locative-object-offset? locative)
			   (back-end:*
			    (rtl:locative-offset-offset locative)
			    address-units-per-object))
			  (else
			   (back-end:*
			    (rtl:locative-offset-offset locative)
			    address-units-per-float))))
		  BYTE))
	((back-end:= byte-offset 0)
	 locative)
	(else
	 `(OFFSET ,locative ,byte-offset BYTE))))

(define (rtl:locative-float-offset locative float-offset)
  (let ((default
	  (lambda ()
	    `(OFFSET ,locative ,float-offset FLOAT))))
    (cond ((rtl:locative-offset? locative)
	   (if (rtl:locative-float-offset? locative)
	       `(OFFSET ,(rtl:locative-offset-base locative)
			,(back-end:+ (rtl:locative-offset-offset locative)
				     float-offset)
			FLOAT)
	       (default)))
	  (else
	   (default)))))

(define (rtl:locative-object-offset locative offset)
  (cond ((back-end:= offset 0) locative)
	((rtl:locative-offset? locative)
	 (if (not (rtl:locative-object-offset? locative))
	     (error "Can't add object offset to non-object offset"
		    locative offset)
	     `(OFFSET ,(rtl:locative-offset-base locative)
		      ,(back-end:+ (rtl:locative-offset-offset locative)
				   offset)
		      OBJECT)))
	(else
	 `(OFFSET ,locative ,offset OBJECT))))

(define (rtl:locative-index? locative)
  (and (pair? locative) (eq? (car locative) 'INDEX)))

(define-integrable rtl:locative-index-base cadr)
(define-integrable rtl:locative-index-offset caddr)
(define-integrable rtl:locative-index-granularity cadddr)

(define-integrable (rtl:locative-byte-index? locative)
  (eq? (rtl:locative-index-granularity locative) 'BYTE))

(define-integrable (rtl:locative-float-index? locative)
  (eq? (rtl:locative-index-granularity locative) 'FLOAT))

(define-integrable (rtl:locative-object-index? locative)
  (eq? (rtl:locative-index-granularity locative) 'OBJECT))

(define (rtl:locative-byte-index locative offset)
  `(INDEX ,locative ,offset BYTE))

(define (rtl:locative-float-index locative offset)
  `(INDEX ,locative ,offset FLOAT))

(define (rtl:locative-object-index locative offset)
  `(INDEX ,locative ,offset OBJECT))

;;; Expressions that are used in the intermediate form.

(define-integrable (rtl:make-address locative)
  `(ADDRESS ,locative))

(define-integrable (rtl:make-environment locative)
  `(ENVIRONMENT ,locative))

(define-integrable (rtl:make-cell-cons expression)
  `(CELL-CONS ,expression))

(define-integrable (rtl:make-fetch locative)
  `(FETCH ,locative))

(define-integrable (rtl:make-typed-cons:pair type car cdr)
  `(TYPED-CONS:PAIR ,type ,car ,cdr))

(define-integrable (rtl:make-typed-cons:vector type elements)
  `(TYPED-CONS:VECTOR ,type ,@elements))

(define-integrable (rtl:make-typed-cons:procedure entry)
  `(TYPED-CONS:PROCEDURE ,entry))

;;; Linearizer Support

(define-integrable (rtl:make-jump-statement label)
  `(JUMP ,label))

(define-integrable (rtl:make-jumpc-statement predicate label)
  `(JUMPC ,predicate ,label))

(define-integrable (rtl:make-label-statement label)
  `(LABEL ,label))

(define-integrable (rtl:negate-predicate expression)
  `(NOT ,expression))

;;; Stack

(define-integrable (stack-locative-offset locative offset)
  (rtl:locative-offset locative (stack->memory-offset offset)))

(define-integrable (stack-push-address)
  (rtl:make-pre-increment (interpreter-stack-pointer)
			  (stack->memory-offset -1)))

(define-integrable (stack-pop-address)
  (rtl:make-post-increment (interpreter-stack-pointer)
			   (stack->memory-offset 1)))