Commit 6a9d4112 authored by cvs2git's avatar cvs2git

This commit was manufactured by cvs2svn to create branch 'new_constraint'.

parent 30f1bd52
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
;;; -*- Mode: Lisp; Package: Compiler -*-
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
(in-package 'compiler)
(export '(asm asm-files) (find-package 'compiler))
(defun asm (f)
(assemble-file (concatenate 'simple-string "miscops:" f ".romp")))
(defun asm-files ()
(asm "abs")
(asm "allocation")
(asm "arith")
(asm "array")
(asm "byte")
(asm "call")
(asm "nlx")
(asm "compare")
(asm "divide")
(asm "gc")
(asm "gcd")
(asm "irrat")
(asm "list")
(asm "logic")
(asm "minus")
(asm "misc")
(asm "multiply")
(asm "negate")
(asm "plus")
(asm "print")
(asm "predicate")
(asm "save")
(asm "stack")
(asm "symbol")
(asm "system")
(asm "truncate"))
This diff is collapsed.
;;; -*- Mode: Lisp; Package: Compiler -*-
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;; This file defines the instruction set for the Common Lisp Romp Assembler
;;; used by the compiler.
;;; Written by David B. McDonald.
(in-package 'Compiler)
(defvar romp-4bit-opcode-symbol (make-array 16))
(defvar romp-8bit-opcode-symbol (make-array 256))
;;; Define-Romp-Instruction defines a Romp instruction to the assembler.
;;; It accepts three arguments:
;;; romp-instruction is a symbol whose pname is the name of a Romp instruction
;;; romp-inst-type specifies the underlying type of the Romp instruction.
;;; it must have one of the following values: JI, X, DS, R, BI, BA,
;;; or D.
;;; romp-code specifies the numeric op code for the instruction.
(defmacro Define-Romp-Instruction (romp-instruction romp-inst-type romp-code)
`(progn (setf (get ',romp-instruction 'romp-instruction-type)
',romp-inst-type)
(setf (get ',romp-instruction 'romp-operation-code)
,romp-code)
,(case romp-inst-type
(ji
`(setf (svref romp-4bit-opcode-symbol 0) ',romp-instruction))
((x ds)
`(setf (svref romp-4bit-opcode-symbol ,romp-code) ',romp-instruction))
((r bi ba d)
`(setf (svref romp-8bit-opcode-symbol ,romp-code) ',romp-instruction))
(T
(error "Illegal instruction type: ~A, for instruction ~A (~A).~%"
romp-inst-type romp-instruction romp-code)))))
;;; Define-Romp-Branch defines a Romp branch instruction to the assembler. It
;;; accepts three arguments:
;;; romp-branch is a symbol whose pname is the name of a branch instruction.
;;; romp-instruction is the underlying romp-instruction that should be used
;;; used to implement the branch instruction.
;;; condition-code specifies the bit of the condition code that should be
;;; be tested to implement the branch.
(defmacro Define-Romp-Branch (romp-branch romp-instruction condition-code)
`(progn (setf (get ',romp-branch 'romp-branch-instruction)
',romp-instruction)
(setf (get ',romp-branch 'romp-condition-code)
,condition-code)))
;;; Define-Condition-Code associates the integer code for a particular condition
;;; code bit with a symbol. It accepts a symbol and a value.
(defmacro Define-Condition-Code (condition-code value)
`(setf (get ',condition-code 'condition-code) ,value))
;;; Storage Access Instructions.
(define-romp-instruction lcs ds #x4)
(define-romp-instruction lc d #xCE)
(define-romp-instruction lhas ds #x5)
(define-romp-instruction lha d #xCA)
(define-romp-instruction lhs r #xEB)
(define-romp-instruction lh d #xDA)
(define-romp-instruction ls ds #x7)
(define-romp-instruction l d #xCD)
(define-romp-instruction lm d #xC9)
(define-romp-instruction tsh d #xCF)
(define-romp-instruction stcs ds #x1)
(define-romp-instruction stc d #xDE)
(define-romp-instruction sths ds #x2)
(define-romp-instruction sth d #xDC)
(define-romp-instruction sts ds #x3)
(define-romp-instruction st d #xDD)
(define-romp-instruction stm d #xD9)
;;; Address Computation Instructions.
(define-romp-instruction cal d #xC8)
(define-romp-instruction cal16 d #xC2)
(define-romp-instruction cau d #xD8)
(define-romp-instruction cas x #x6)
(define-romp-instruction ca16 r #xF3)
(define-romp-instruction inc r #x91)
(define-romp-instruction dec r #x93)
(define-romp-instruction lis r #xA4)
;;; Basic Romp Branch Instructions.
(define-romp-instruction bala ba #x8A)
(define-romp-instruction balax ba #x8B)
(define-romp-instruction bali bi #x8C)
(define-romp-instruction balix bi #x8D)
(define-romp-instruction balr r #xEC)
(define-romp-instruction balrx r #xED)
(define-romp-instruction jb ji #x1)
(define-romp-instruction bb bi #x8E)
(define-romp-instruction bbx bi #x8F)
(define-romp-instruction bbr r #xEE)
(define-romp-instruction bbrx r #xEF)
(define-romp-instruction jnb ji #x0)
(define-romp-instruction bnb bi #x88)
(define-romp-instruction bnbx bi #x89)
(define-romp-instruction bnbr r #xE8)
(define-romp-instruction bnbrx r #xE9)
;;; Romp Trap Instrunctions.
(define-romp-instruction ti d #xCC)
(define-romp-instruction tgte r #xBD)
(define-romp-instruction tlt r #xBE)
;;; Romp Move and Insert Instructions.
(define-romp-instruction mc03 r #xF9)
(define-romp-instruction mc13 r #xFA)
(define-romp-instruction mc23 r #xFB)
(define-romp-instruction mc33 r #xFC)
(define-romp-instruction mc30 r #xFD)
(define-romp-instruction mc31 r #xFE)
(define-romp-instruction mc32 r #xFF)
(define-romp-instruction mftb r #xBC)
(define-romp-instruction mftbil r #x9D)
(define-romp-instruction mftbiu r #x9C)
(define-romp-instruction mttb r #xBF)
(define-romp-instruction mttbil r #x9F)
(define-romp-instruction mttbiu r #x9E)
;;; Romp Arithmetic Instructions.
(define-romp-instruction a r #xE1)
(define-romp-instruction ae r #xF1)
(define-romp-instruction aei d #xD1)
(define-romp-instruction ai d #xC1)
(define-romp-instruction ais r #x90)
(define-romp-instruction abs r #xE0)
(define-romp-instruction onec r #xF4)
(define-romp-instruction twoc r #xE4)
(define-romp-instruction c r #xB4)
(define-romp-instruction cis r #x94)
(define-romp-instruction ci d #xD4)
(define-romp-instruction cl r #xB3)
(define-romp-instruction cli d #xD3)
(define-romp-instruction exts r #xB1)
(define-romp-instruction s r #xE2)
(define-romp-instruction sf r #xB2)
(define-romp-instruction se r #xF2)
(define-romp-instruction sfi d #xD2)
(define-romp-instruction sis r #x92)
(define-romp-instruction d r #xB6)
(define-romp-instruction m r #xE6)
;;; Romp Logical Operations
(define-romp-instruction clrbl r #x99)
(define-romp-instruction clrbu r #x98)
(define-romp-instruction setbl r #x9B)
(define-romp-instruction setbu r #x9A)
(define-romp-instruction n r #xE5)
(define-romp-instruction nilz d #xC5)
(define-romp-instruction nilo d #xC6)
(define-romp-instruction niuz d #xD5)
(define-romp-instruction niuo d #xD6)
(define-romp-instruction o r #xE3)
(define-romp-instruction oil d #xC4)
(define-romp-instruction oiu d #xC3)
(define-romp-instruction x r #xE7)
(define-romp-instruction xil d #xC7)
(define-romp-instruction xiu d #xD7)
(define-romp-instruction clz r #xF5)
;;; Romp Shift Instructions
(define-romp-instruction sar r #xB0)
(define-romp-instruction sari r #xA0)
(define-romp-instruction sari16 r #xA1)
(define-romp-instruction sr r #xB8)
(define-romp-instruction sri r #xA8)
(define-romp-instruction sri16 r #xA9)
(define-romp-instruction srp r #xB9)
(define-romp-instruction srpi r #xAC)
(define-romp-instruction srpi16 r #xAD)
(define-romp-instruction sl r #xBA)
(define-romp-instruction sli r #xAA)
(define-romp-instruction sli16 r #xAB)
(define-romp-instruction slp r #xBB)
(define-romp-instruction slpi r #xAE)
(define-romp-instruction slpi16 r #xAF)
;;; Romp System Control Instructions.
(define-romp-instruction mts r #xB5)
(define-romp-instruction mfs r #x96)
(define-romp-instruction clrsb r #x95)
(define-romp-instruction setsb r #x97)
(define-romp-instruction lps d #xD0)
(define-romp-instruction wait r #xF0)
(define-romp-instruction svc d #xC0)
;;; Romp Input/Output Instructions.
(define-romp-instruction ior d #xCB)
(define-romp-instruction iow d #xDB)
;;; Define bit setting for examining condition codes.
(define-condition-code pz 8)
(define-condition-code lt 9)
(define-condition-code eq 10)
(define-condition-code gt 11)
(define-condition-code cz 12)
(define-condition-code ov 14)
(define-condition-code tb 15)
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/assemfile.lisp,v 1.11 1990/05/24 13:24:06 wlott Exp $
;;;
;;; This file contains the extra code necessary to feed an entire file of
;;; assembly code to the assembler.
;;;
(in-package "C")
(defvar *do-assembly* nil
"If non-NIL, emit assembly code. If NIL, emit VOP templates.")
(defvar *lap-output-file* nil
"The FASL file currently being output to.")
(defvar *assembler-routines* nil
"A List of (name . label) for every entry point.")
(defun assemble-file (name &key
(output-file
(make-pathname :defaults name
:type "mips-fasl"))
trace-file)
(let* ((*do-assembly* t)
(name (pathname name))
(*lap-output-file* (open-fasl-file (pathname output-file) name))
(*assembler-routines* nil)
(won nil))
(unwind-protect
(let (*code-segment*
*elsewhere*
#-new-compiler (lisp::*in-compilation-unit* nil))
(init-assembler)
(load (merge-pathnames name (make-pathname :type "lisp")))
(fasl-dump-cold-load-form `(in-package ,(package-name *package*))
*lap-output-file*)
(assemble (*code-segment* nil)
(insert-segment *elsewhere*))
(let ((length (finalize-segment *code-segment*)))
(dump-assembler-routines *code-segment*
length
*assembler-routines*
*lap-output-file*))
(when trace-file
(with-open-file (file (if (eq trace-file t)
(make-pathname :defaults name
:type "trace")
trace-file)
:direction :output
:if-exists :supersede)
(format file "Assembly listing for ~A:~3%" (namestring name))
(dump-segment *code-segment* file)
(fresh-line file)))
(setq won t))
(close-fasl-file *lap-output-file* (not won)))
won))
(defstruct (reg-spec
(:print-function %print-reg-spec))
(kind :temp :type (member :arg :temp :result))
(name nil :type symbol)
(temp nil :type symbol)
(sc nil :type symbol)
(offset 0 :type fixnum))
(defun %print-reg-spec (spec stream depth)
(declare (ignore depth))
(format stream
"#<reg ~S ~S sc=~S offset=~S>"
(reg-spec-kind spec)
(reg-spec-name spec)
(reg-spec-sc spec)
(reg-spec-offset spec)))
(defun parse-reg-spec (kind name sc offset)
(let ((reg (make-reg-spec :kind kind :name name :sc sc :offset offset)))
(ecase kind
(:temp)
((:arg :res)
(setf (reg-spec-temp reg) (make-symbol (symbol-name name)))))
reg))
(defun emit-assemble (name regs code)
(let* ((labels nil)
(insts (mapcar #'(lambda (inst)
(cond ((symbolp inst)
(push inst labels)
`(emit-label ,inst))
(t
inst)))
code)))
`(let ((,name (gen-label))
,@(mapcar #'(lambda (label)
`(,label (gen-label)))
labels))
(push (cons ',name ,name) *assembler-routines*)
(assemble (*code-segment* ',name)
(emit-label ,name)
(let (,@(mapcar
#'(lambda (reg)
`(,(reg-spec-name reg)
(make-random-tn
:sc (sc-or-lose ',(reg-spec-sc reg))
:offset ,(reg-spec-offset reg))))
regs))
,@insts
(inst addu lip-tn lra-tn (- vm:word-bytes vm:other-pointer-type))
(inst j lip-tn)
(inst nop)))
(format t "~S assembled~%" ',name))))
(defun arg-or-res-spec (reg)
`(,(reg-spec-name reg)
:scs (,(reg-spec-sc reg))
,@(unless (eq (reg-spec-kind reg) :res)
`(:target ,(reg-spec-temp reg)))))
(defun emit-vop (name options vars)
(let* ((args (remove :arg vars :key #'reg-spec-kind :test-not #'eq))
(temps (remove :temp vars :key #'reg-spec-kind :test-not #'eq))
(results (remove :res vars :key #'reg-spec-kind :test-not #'eq))
(return-pc-label (make-symbol "RETURN-PC-LABEL"))
(return-pc (make-symbol "RETURN-PC"))
(lip (make-symbol "LIP"))
(ndescr (make-symbol "NDESCR")))
`(define-vop ,(if (atom name) (list name) name)
(:args ,@(mapcar #'arg-or-res-spec args))
,@(let ((index -1))
(mapcar #'(lambda (arg)
`(:temporary (:sc ,(reg-spec-sc arg)
:offset ,(reg-spec-offset arg)
:from (:argument ,(incf index))
:to (:eval 2))
,(reg-spec-temp arg)))
args))
,@(mapcar #'(lambda (temp)
`(:temporary (:sc ,(reg-spec-sc temp)
:offset ,(reg-spec-offset temp)
:from (:eval 1)
:to (:eval 3))
,(reg-spec-name temp)))
temps)
(:temporary (:scs (interior-reg) :type interior
:from (:eval 0) :to (:eval 1))
,lip)
(:temporary (:sc any-reg :offset lra-offset
:from (:eval 0) :to (:eval 1))
,return-pc)
(:temporary (:scs (non-descriptor-reg) :type random
:from (:eval 0) :to (:eval 1))
,ndescr)
,@(let ((index -1))
(mapcar #'(lambda (res)
`(:temporary (:sc ,(reg-spec-sc res)
:offset ,(reg-spec-offset res)
:from (:eval 2)
:to (:result ,(incf index))
:target ,(reg-spec-name res))
,(reg-spec-temp res)))
results))
(:results ,@(mapcar #'arg-or-res-spec results))
(:ignore ,lip ,@(mapcar #'reg-spec-name temps))
,@options
(:generator 247
(let ((,return-pc-label (gen-label)))
,@(mapcar #'(lambda (arg)
`(move ,(reg-spec-temp arg)
,(reg-spec-name arg)))
args)
(inst compute-lra-from-code ,return-pc code-tn ,return-pc-label)
(inst li ,ndescr (make-fixup ',name :assembly-routine))
(inst j ,ndescr)
(inst nop)
(emit-return-pc ,return-pc-label)
,@(mapcar #'(lambda (res)
`(move ,(reg-spec-name res)
,(reg-spec-temp res)))
results))))))
(defmacro define-assembly-routine ((name options &rest vars) &rest code)
(let* ((regs (mapcar #'(lambda (var) (apply #'parse-reg-spec var)) vars)))
(if *do-assembly*
(emit-assemble (if (atom name) name (car name)) regs code)
(emit-vop name options regs))))
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/mips/array.lisp,v 1.8 1990/05/23 06:11:51 wlott Exp $
;;;
;;; This file contains the support routines for arrays and vectors.
;;;
;;; Written by William Lott.
;;;
(in-package "C")
(eval-when (eval)
(defmacro allocate-vector (type length words vector ndescr)
`(pseudo-atomic (,ndescr)
(inst or ,vector alloc-tn vm:other-pointer-type)
(inst addu alloc-tn alloc-tn (+ (1- (ash 1 vm:lowtag-bits))
(* vm:vector-data-offset vm:word-bytes)))
(inst addu alloc-tn alloc-tn ,words)
(inst li ,ndescr (lognot vm:lowtag-mask))
(inst and alloc-tn alloc-tn ,ndescr)
,(if (constantp type)
`(inst li ,ndescr ,type)
`(inst srl ,ndescr ,type vm:word-shift))
(storew ,ndescr ,vector 0 vm:other-pointer-type)
(storew ,length ,vector vm:vector-length-slot vm:other-pointer-type)))
(defmacro maybe-invoke-gc (vector words)
"Assure that VECTOR lies entirely before the guard page. WORDS is the
number of words of data in the vector."
(declare (ignore vector words))
nil)
); eval-when (eval)
(define-assembly-routine (allocate-vector
()
(:arg type any-reg a0-offset)
(:arg length any-reg a1-offset)
(:arg words any-reg a2-offset)
(:res result descriptor-reg a0-offset)
(:temp ndescr non-descriptor-reg nl0-offset)
(:temp vector descriptor-reg a3-offset))
(allocate-vector type length words vector ndescr)
(maybe-invoke-gc vector words)
(move result vector))
(define-assembly-routine (alloc-g-vector
()
(:arg length any-reg a0-offset)
(:arg fill any-reg a1-offset)
(:res result descriptor-reg a0-offset)
(:temp ndescr non-descriptor-reg nl0-offset)
(:temp lip interior-reg lip-offset)
(:temp vector descriptor-reg a3-offset))
(allocate-vector vm:simple-vector-type length length vector ndescr)
(inst beq length zero-tn done)
(inst addu lip vector (- (* vm:vector-data-offset vm:word-bytes)
vm:other-pointer-type))
loop
(storew fill lip)
(inst addu length length (fixnum -1))
(inst bne length zero-tn loop)
(inst addu lip lip vm:word-bytes)
done
(move result vector))
(define-assembly-routine (alloc-string
()
(:arg length any-reg a0-offset)
(:res result descriptor-reg a0-offset)
(:temp ndescr non-descriptor-reg nl0-offset)
(:temp words any-reg nl1-offset)
(:temp vector descriptor-reg a3-offset))
;; Note: When we calculate the number of words needed, we assure that there
;; will be at least one extra byte available. This allows us to pass strings
;; to C land without having to tack an extra null on the end ourselves.
;;
;; To do this quickly, we divide the length by the number of bytes and strip
;; off the two fixnum lowtag bits, add 1 (binary 1, not fixnum 1), and
;; shift back to a fixnum:
;;
;; length len>>4 1+ <<2
;; 0 0 1 4
;; 1 0 1 4
;; 3 0 1 4
;; 4 1 2 8
;; 7 1 2 8
;; 8 2 3 12
;;
(inst sra words length (+ vm:word-shift 2))
(inst addu words words 1)