#| -*-Scheme-*-

$Id: lapgen.scm,v 1.17 2004/07/01 01:19:57 cph Exp $

Copyright 1993,1998,2001,2002,2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

|#

;;;; RTL Rules for C.  Shared utilities.
;;; package: (compiler lap-syntaxer)

(declare (usual-integrations))

;;;; Compiler error reporting

(define (comp-internal-error message location . irritants)
  (apply error (cons (string-append "Internal inconsistency in "
				    (if (symbol? location)
					(symbol->string location)
					location)
				    ":  "
				    message)
		     irritants)))

;;;; Register-Allocator Interface

(define (type->name type)
  (case type
    ((WORD)
     "machine_word")
    ((SCHEME_OBJECT)
     "SCHEME_OBJECT")
    ((SCHEME_OBJECT*)
     "SCHEME_OBJECT *")
    ((LONG)
     "long")
    ((CHAR*)
     "char *")
    ((ULONG)
     "unsigned long")
    ((DOUBLE)
     "double")
    ((DOUBLE*)
     "double *")
    (else
     (comp-internal-error "Unknown type" 'TYPE->NAME type))))

(define (reg*type->name reg type)
  (string-append
   (case type
     ((WORD) "Wrd")
     ((DOUBLE) "Dbl")
     (else
      (comp-internal-error "Unknown type" 'REG*TYPE->NAME type)))
   (number->string reg)))

(define (machine-register-name reg)
  (cond ((eq? reg regnum:stack-pointer)
	 "Rsp")
	((eq? reg regnum:free)
	 "Rhp")
	((eq? reg regnum:regs)
	 "Rrb")
	((eq? reg regnum:dynamic-link)
	 "Rdl")
	((eq? reg regnum:value)
	 "Rvl")
	(else
	 (comp-internal-error "Unknown machine register"
			      'MACHINE-REGISTER-NAME reg))))
    
(define (machine-register-type reg)
  (cond ((eq? reg regnum:value)
	 "SCHEME_OBJECT")
	(else
	 "SCHEME_OBJECT *")))

(define (machine-register-type-symbol reg)
  (cond ((eq? reg regnum:value)
	 'SCHEME_OBJECT)
	(else
	 'SCHEME_OBJECT*)))

(define-integrable (register-is-machine-register? reg)
  (< reg number-of-machine-registers))

(define (rhs-cast reg type)
  (string-append "((" (type->name type) ") " reg ")"))

(define (lhs-cast reg type)
  (string-append "(* ((" (type->name type) " *) &" reg "))"))

(define permanent-register-list)
(define current-register-list)

(define (find-register reg type)
  (let ((aliases (assq reg current-register-list)))
    (and aliases
	 (let ((alias (assq type (cdr aliases))))
	   (cond (alias)
		 ((not type)
		  (cadr aliases))
		 (else false))))))

(define (allocate-register! reg type)
  (let ((name (new-register-name reg type))
	(aliases (assq reg current-register-list)))
    (if (not aliases)
	(set! current-register-list
	      (cons (list reg (cons type name))
		    current-register-list))
	(set-cdr! aliases
		  (cons (cons type name) (cdr aliases))))
    name))

(define (find-register! reg type)
  (cond ((find-register reg type)
	 => cdr)
	(else
	 (allocate-register! reg type))))

(define-integrable (type->canonical-C-type type)
  (if (eq? type 'DOUBLE) 'DOUBLE 'WORD))

(define (reg-select reg type)
  (string-append
   reg
   (case type
     ((SCHEME_OBJECT) ".Obj")
     ((SCHEME_OBJECT*) ".pObj")
     ((LONG) ".Lng")
     ((CHAR*) ".pChr")
     ((ULONG) ".uLng")
     ((DOUBLE*) ".pDbl")
     (else
      (comp-internal-error "Unknown type" 'REG-SELECT type)))))

(define (standard-source! reg type)
  (let ((type* (type->canonical-C-type type)))
    (cond ((register-is-machine-register? reg)
	   (let ((name (machine-register-name reg)))
	     (if (eq? (machine-register-type-symbol reg) type)
		 name
		 (rhs-cast name type))))
	  ((find-register reg type*)
	   => (lambda (pair)
		(let ((reg (cdr pair)))
		  (if (eq? type* 'DOUBLE)
		      reg
		      (reg-select reg type)))))
	  (else
	   (comp-internal-error "Unallocated register"
				'STANDARD-SOURCE! reg)))))

(define (standard-target! reg type)
  (let* ((type* (type->canonical-C-type type))
	 (finish (lambda (reg)
		   (if (eq? type* 'DOUBLE)
		       reg
		       (reg-select reg type)))))
    
    (cond ((register-is-machine-register? reg)
	   (if (not (compatible/C*register? type (register-type reg)))
	       (error "standard-target!: Incompatible type register" reg type))
	   #|
	   ;; This should not be necessary.
	   ;; We should only assign correctly typed values
	   ;; to dedicated machine registers.
	   (lhs-cast (machine-register-name reg) type)
	   |#
	   (machine-register-name reg))
	  ((find-register reg type*)
	   => (lambda (pair)
		(finish (cdr pair))))
	  (else
	   (finish (allocate-register! reg type*))))))

(define (new-register-name reg type)
  (cond ((assq reg permanent-register-list)
	 => (lambda (aliases)
	      (let ((alias (assq type (cdr aliases))))
		(if alias
		    (cdr alias)
		    (let ((name (reg*type->name reg type)))
		      (set-cdr! aliases
				(cons (cons type name) (cdr aliases)))
		      name)))))
	(else
	 (let ((name (reg*type->name reg type)))
	   (set! permanent-register-list
		 (cons (list reg (cons type name))
		       permanent-register-list))
	   name))))

(define (register-declarations)
  (append-map
   (lambda (register)
     (map (lambda (spec)
	    (string-append "\t" (type->name (car spec)) " " (cdr spec) ";\n"))
	  (cdr register)))
   permanent-register-list))

(define (standard-move-to-target! src tgt)
  (let ((src-type (register-type src)))
    (cond ((not (eq? (register-type tgt) src-type))
	   (comp-internal-error "Incompatible registers"
				'STANDARD-MOVE-TO-TARGET!
				src tgt))
	  ((register-is-machine-register? tgt)
	   (let ((src (standard-source! src
					(machine-register-type-symbol tgt))))
	     (LAP ,(machine-register-name tgt) " = " ,src ";\n\t")))
	  ((register-is-machine-register? src)
	   (let ((tgt (standard-target! tgt
					(machine-register-type-symbol src))))
	     (LAP ,tgt " = " ,(machine-register-name src) ";\n\t")))
	  (else
	   (let ((reg-type
		  (case src-type
		    ((WORD) 'WORD)
		    ((FLOAT) 'DOUBLE)
		    (else
		     (comp-internal-error "Unknown RTL register type"
					  'STANDARD-MOVE-TO-TARGET!
					  src-type)))))
	     (LAP ,(find-register! tgt reg-type) " = "
		  ,(find-register! src reg-type) ";\n\t"))))))

;;;; Communicate with cout.scm

(define (use-invoke-interface! number)
  (set! *invoke-interface*
	(let ((old *invoke-interface*))
	  (if (eq? old 'infinity)
	      number
	      (min old number)))))

(define (use-invoke-primitive!)
  (set! *used-invoke-primitive* true))

(define (use-closure-interrupt-check!)
  (use-invoke-interface! 0))

(define (use-interrupt-check!)
  (use-invoke-interface! 1))

(define (use-dlink-interrupt-check!)
  (use-invoke-interface! 2))

(define (use-jump-execute-chache!)
  (set! *use-jump-execute-chache* #t))

(define (use-pop-return!)
  (set! *use-pop-return* #t))

;;;; Constants, Labels, and Various Caches

(define-integrable make-entry cons)
(define-integrable entry-value car)
(define-integrable entry-label cdr)

(define-integrable (make-table)
  (cons 0 '()))

(define-integrable table->list-of-entries cdr)

(define (find-association table value)
  (let ((x (assoc value (cdr table))))
    (if x
	(entry-label x)
	#f)))

(define (add-object! table name value)
  (set-cdr! table
	    (cons (make-entry value name)
		  (cdr table)))
  unspecific)

(define (add-association! table value prefix)
  (let ((num (car table)))
    (add-object! table
		 (string-append prefix
				*disambiguator*
				(number->string num))
		 value)
    (set-car! table (1+ num))
    num))

(define (find-or-add table value prefix)
  (let ((x (find-association table value)))
    (if x
	x
	(begin
	  (add-association! table value prefix)
	  (find-association table value)))))

(define (define-object name value)
  (add-object! objects
	       (if (symbol? name)
		   (symbol->string name)
		   name)
	       value))

(define (object-label-value label)
  (let ((entry
	 (list-search-positive (table->list-of-entries objects)
	   (lambda (entry)
	     (string=? label (entry-label entry))))))
    (if (not entry)
	(error "object-label-value: Unknown" label)
	(entry-value entry))))

(define objects)
(define free-references)
(define free-assignments)
(define free-uuo-links)
(define global-uuo-links)

(define labels)
(define label-num)

(define (make-special-labels)
  (define (frob name)
    (string->uninterned-symbol (generate-new-label-symbol name)))

  (vector (frob "ENVIRONMENT_LABEL_")
	  (frob "FREE_REFERENCES_LABEL_")
	  (frob "NUMBER_OF_LINKER_SECTIONS_")
	  (frob "DEBUGGING_LABEL_")))

(define-integrable (special-label/environment)
  (vector-ref *special-labels* 0))

(define-integrable (special-label/free-references)
  (vector-ref *special-labels* 1))

(define-integrable (special-label/number-of-sections)
  (vector-ref *special-labels* 2))

(define-integrable (special-label/debugging)
  (vector-ref *special-labels* 3))

(define (prepare-constants-block)
  (values (LAP)
	  (special-label/environment)
	  (special-label/free-references)
	  (special-label/number-of-sections)))

(define (uuo-link-label table name frame-size prefix)
  (define-integrable (uuo-link-label name)
    name				; ignored
    (generate-new-label-symbol prefix))

  (let ((slot1 (assq name (cdr table))))
    (if (not slot1)
	(let ((label (uuo-link-label name)))
	  (set-cdr! table
		    (cons (list name (cons frame-size label))
			  (cdr table)))
	  label)
	(let ((slot2 (assq frame-size (cdr slot1))))
	  (if (not slot2)
	      (let ((label (uuo-link-label name)))
		(set-cdr! slot1
			  (cons (cons frame-size label)
				(cdr slot1)))
		label)
	      (cdr slot2))))))

(define (free-uuo-link-label name frame-size)
  (uuo-link-label free-uuo-links name frame-size "EXECUTE_CACHE_"))

(define (global-uuo-link-label name frame-size)
  (uuo-link-label global-uuo-links name frame-size "GLOBAL_EXECUTE_CACHE_"))

;; this alias is for lapgn1.scm

(define (constant->label object)
  (declare (integrate object->offset))
  (object->offset object))

(define (object->offset scheme-object)
  (find-or-add objects scheme-object "OBJECT_"))

(define (free-reference->offset name)
  (find-or-add free-references name "FREE_REFERENCE_"))

(define (free-assignment->offset name)
  (find-or-add free-assignments name "FREE_ASSIGNMENT_"))

(define-integrable label-1 vector-first)
(define-integrable label-2 vector-second)
(define-integrable symbol-1 vector-third)
(define-integrable symbol-2 vector-fourth)
(define-integrable dispatch-1 vector-fifth)
(define-integrable (set-dispatch-1! x d)
  (vector-set! x 4 d))
(define-integrable dispatch-2 vector-sixth)
(define-integrable code-word-sel vector-seventh)

(define (find-label label labels)
  (let loop ((labels labels))
    (and (not (null? labels))
	 (let ((next (car labels)))
	   (if (or (eq? label (label-1 next))
		   (eq? label (label-2 next)))
	       next
	       (loop (cdr labels)))))))

(define (generate-new-label-symbol prefix)
  (let ((num label-num))
    (set! label-num (1+ num))
    (string-append prefix
		   *disambiguator*
		   (number->string num))))

(define (define-label! label)
  (set! labels
	(cons (vector label #f
		      (generate-new-label-symbol "LABEL_")    
		      #f #f #f #f)
	      labels))
  unspecific)

(define (label->offset label)
  (let ((x (find-label label labels)))
    (if x
	(symbol-1 x)
	(begin
	   (define-label! label)
	   (label->offset label)))))

(define (label->dispatch-tag label)
  (let ((x (find-label label labels)))
    (if x
	(or (dispatch-1 x)
	    (let ((sym (generate-new-label-symbol "TAG_")))
	      (set-dispatch-1! x sym)
	      sym))
	(begin
	  (define-label! label)
	  (label->dispatch-tag label)))))

(define (declare-block-label! code-word label external-label)
  (define (add-new-entry symbol-x symbol-y dispatch-x dispatch-y)
    (set! labels
	  (cons (vector label external-label
			symbol-x symbol-y
			dispatch-x dispatch-y
			code-word)
		labels)))

  (let ((x (and label (find-label label labels)))
	(y (and external-label (find-label external-label labels))))
    (if x
	(set! labels (delq! x labels)))
    (if y
	(set! labels (delq! y labels)))
    (cond ((and x (eq? x y))
	   (add-new-entry (symbol-1 x) (symbol-2 x)
			  (dispatch-1 x) (dispatch-2 x)))
	  ((and x y)
	   (add-new-entry (symbol-1 x) (symbol-1 y)
			  (dispatch-1 x) (dispatch-1 y)))
	  (x
	   (add-new-entry (symbol-1 x) #f
			  (dispatch-1 x) #f))
	  (y
	   (add-new-entry (symbol-1 y) #f
			  (dispatch-1 y) #f))
	  (else
	   (add-new-entry (generate-new-label-symbol "LABEL_")
			  #f
			  #f
			  #f)))
    unspecific))

(define available-machine-registers
  ;; This is really a lie, but lets some things work
  (list
   regnum:stack-pointer regnum:regs regnum:free
   regnum:dynamic-link regnum:value))

(define (sort-machine-registers lst)
  lst)

(define (compatible/C*register? c-type reg-type)
  (if (eq? c-type 'DOUBLE)
      (eq? reg-type 'FLOAT)
      (not (eq? reg-type 'FLOAT))))

(define (compatible/C*C? type1 type2)
  (if (eq? type1 'DOUBLE)
      (eq? type2 'DOUBLE)
      (not (eq? type2 'DOUBLE))))

(define (register-type reg)
  (cond ((or (machine-register? reg)
	     (register-value-class=word? reg))
	 'WORD)
	((register-value-class=float? reg)
	 'FLOAT)
	(else
	 (error "unable to determine register type" reg))))

(define-integrable (word-register? reg)
  (eq? (register-type reg) 'WORD))

(define (register-reference num)
  (comp-internal-error "Should not be using register allocator"
		       'REGISTER-REFERENCE num))

(define (register->register-transfer one two)
  (comp-internal-error "Should not be using register allocator"
		       'REGISTER->REGISTER-TRANSFER one two))

(define (reference->register-transfer one two)
  (comp-internal-error "Should not be using register allocator"
		       'REFERENCE->REGISTER-TRANSFER one two))

(define (pseudo-register-home one)
  (comp-internal-error "Should not be using register allocator"
		       'PSEUDO-REGISTER-HOME one))

(define (home->register-transfer one two)
  (comp-internal-error "Should not be using register allocator"
		       'HOME->REGISTER-TRANSFER one two))

(define (register->home-transfer one two)
  (comp-internal-error "Should not be using register allocator"
		       'REGISTER->HOME-TRANSFER one two))

(define (lap:make-label-statement label)
  (LAP "\n" ,label ":\n\t" ))

(define (lap:make-unconditional-branch label)
  (LAP "goto " ,label ";\n\t"))

(define (lap:make-entry-point label block-start-label)
  block-start-label			; ignored
  (declare-block-label! expression-code-word label #f)
  (lap:make-label-statement label))

(define (compare cc val1 val2)
  (set-current-branches!
   (lambda (label)
     (LAP "if (" ,val1 ,cc ,val2 ")\n\t  goto " ,label ";\n\t"))
   (lambda (label)
     (LAP "if (!(" ,val1 ,cc ,val2 "))\n\t  goto " ,label ";\n\t")))
  (LAP))

(define (define-arithmetic-method operator methods method)
  (let ((entry (assq operator (cdr methods))))
    (if entry
	(set-cdr! entry method)
	(set-cdr! methods (cons (cons operator method) (cdr methods)))))
  operator)

(define (lookup-arithmetic-method operator methods)
  (cdr (or (assq operator (cdr methods))
	   (comp-internal-error "Unknown operator" 'LOOKUP-ARITHMETIC-METHOD
				operator))))

(let-syntax ((define-codes
	       (sc-macro-transformer
		(lambda (form environment)
		  environment
		  `(BEGIN
		     ,@(let loop ((names (cddr form)) (index (cadr form)))
			 (if (pair? names)
			     (cons `(DEFINE-INTEGRABLE
				      ,(symbol-append 'CODE:COMPILER-
						      (car names))
				      ,index)
				   (loop (cdr names) (1+ index)))
			     `())))))))
  (define-codes #x012
    primitive-apply primitive-lexpr-apply
    apply error lexpr-apply link
    interrupt-closure interrupt-dlink interrupt-procedure 
    interrupt-continuation interrupt-ic-procedure
    assignment-trap cache-reference-apply
    reference-trap safe-reference-trap unassigned?-trap
    -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero?
    access lookup safe-lookup unassigned? unbound?
    set! define lookup-apply primitive-error
    quotient remainder modulo
    reflect-to-interface interrupt-continuation-2
    compiled-code-bkpt compiled-closure-bkpt))


(define (pre-lapgen-analysis rgraphs)
  rgraphs
  unspecific)