source: branches/working-0711/ccl/compiler/risc-lap.lisp @ 11089

Last change on this file since 11089 was 11089, checked in by gz, 13 years ago

Merge/bootstrap assorted low level stuff from trunk - kernel, syscall stuff, lowmem-bias, formatting tweaks, a few bug fixes included

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 6.3 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;; Lap data structures & some generic code (at least for RISC backends.)
18
19(in-package "CCL")
20
21(defvar *lap-labels* ())
22(defvar *lap-instructions* ())
23
24(eval-when (:compile-toplevel :load-toplevel :execute)
25  (require "ARCH")
26  (require "DLL-NODE")
27  (require "SUBPRIMS"))
28
29
30;;; For assembly/disassembly, at least on RISC platforms.
31(defstruct opcode 
32  (name (error "Opcode name must be present") :type (or string symbol))
33  (opcode 0 :type (unsigned-byte 32))
34  (majorop 0 :type (unsigned-byte 6))
35  (mask #xffffffff :type (unsigned-byte 32))
36  (flags 0 :type (unsigned-byte 32))
37  (operands () :type list)
38  (min-args 0 :type (unsigned-byte 3))
39  (max-args 0 :type (unsigned-byte 3))
40  (op-high 0 :type (unsigned-byte 16))
41  (op-low 0 :type (unsigned-byte 16))
42  (mask-high #xffff :type (unsigned-byte 16))
43  (mask-low #xffff :type (unsigned-byte 16))
44  (vinsn-operands () :type list)
45  (min-vinsn-args 0 :type fixnum)
46  (max-vinsn-args 0 :type fixnum))
47
48(defmethod print-object ((p opcode) stream)
49  (print-unreadable-object (p stream :type t) 
50    (format stream "~a" (string (opcode-name p)))))
51
52(defmethod make-load-form ((p opcode) &optional env)
53  (make-load-form-saving-slots p :environment env))
54
55(defstruct operand
56  (index 0 :type unsigned-byte)
57  (width 0 :type (mod 32))
58  (offset 0 :type (mod 32))
59  (insert-function nil :type (or null symbol function))
60  (extract-function 'nil :type (or symbol function))
61  (flags 0 :type fixnum))
62
63(defmethod make-load-form ((o operand) &optional env)
64  (make-load-form-saving-slots o :environment env))
65
66(defconstant operand-optional 27)
67(defconstant operand-fake 28)
68
69(eval-when (:execute :load-toplevel)
70  (defstruct (instruction-element (:include dll-node))
71    address)
72
73  (defstruct (lap-instruction (:include instruction-element)
74                                  (:constructor %make-lap-instruction (opcode)))
75    opcode
76    parsed-operands
77    )
78
79  (defstruct (lap-note (:include instruction-element))
80    peer
81    id)
82
83  (defstruct (lap-note-begin (:include lap-note)))
84  (defstruct (lap-note-end (:include lap-note)))
85   
86  (defstruct (lap-label (:include instruction-element)
87                            (:constructor %%make-lap-label (name)))
88    name
89    refs))
90
91(def-standard-initial-binding *lap-label-freelist* (make-dll-node-freelist))
92(def-standard-initial-binding *lap-instruction-freelist* (make-dll-node-freelist))
93
94(def-standard-initial-binding *operand-vector-freelist* (%cons-pool))
95
96(defconstant lap-operand-vector-size #+ppc-target 5)
97
98(defun alloc-lap-operand-vector (&optional (size lap-operand-vector-size))
99  (declare (fixnum size))
100  (if (eql size lap-operand-vector-size)
101    (without-interrupts 
102     (let* ((freelist  *operand-vector-freelist*)
103            (v (pool.data freelist)))
104       (if v
105         (progn
106           (setf (pool.data freelist) 
107                 (svref v 0))
108           (%init-misc nil v)
109           v)
110         (make-array lap-operand-vector-size  :initial-element nil))))
111    (make-array size :initial-element nil)))
112
113(defun free-lap-operand-vector (v)
114  (when (= (length v) lap-operand-vector-size)
115    (without-interrupts 
116     (setf (svref v 0) (pool.data *operand-vector-freelist*)
117           (pool.data *operand-vector-freelist*) nil))))
118
119(defun %make-lap-label (name)
120  (let* ((lab (alloc-dll-node *lap-label-freelist*)))
121    (if lab
122      (progn
123        (setf (lap-label-address lab) nil
124              (lap-label-refs lab) nil
125              (lap-label-name lab) name)
126        lab)
127      (%%make-lap-label name))))
128
129(defun make-lap-instruction (opcode)
130  (let* ((insn (alloc-dll-node *lap-instruction-freelist*)))
131    (if (typep insn 'lap-instruction)
132      (progn
133        (setf (lap-instruction-address insn) nil
134              (lap-instruction-parsed-operands insn) nil
135              (lap-instruction-opcode insn) opcode)
136        insn)
137      (%make-lap-instruction opcode))))
138
139(defmacro do-lap-labels ((lab &optional result) &body body)
140  (let* ((thunk-name (gensym))
141         (k (gensym))
142         (xlab (gensym)))
143    `(flet ((,thunk-name (,lab) ,@body))
144      (if (listp *lap-labels*)
145        (dolist (,xlab *lap-labels*)
146          (,thunk-name ,xlab))
147        (maphash #'(lambda (,k ,xlab)
148                     (declare (ignore ,k))
149                     (,thunk-name ,xlab))
150                 *lap-labels*))
151      ,result)))
152
153(defun make-lap-label (name)
154  (let* ((lab (%make-lap-label name)))
155    (if (typep *lap-labels* 'hash-table)
156      (setf (gethash name *lap-labels*) lab)
157      (progn
158        (push lab *lap-labels*)
159        (if (> (length *lap-labels*) 255)
160          (let* ((hash (make-hash-table :size 512 :test #'eq)))
161            (dolist (l *lap-labels* (setq *lap-labels* hash))
162              (setf (gethash (lap-label-name l) hash) l))))))
163    lab))
164
165(defun find-lap-label (name)
166  (if (typep *lap-labels* 'hash-table)
167    (gethash name *lap-labels*)
168    (car (member name *lap-labels* :test #'eq :key #'lap-label-name))))
169
170(defun lap-note-label-reference (labx insn)
171  '(unless (and labx (symbolp labx))
172    (error "Label names must be symbols; otherwise, all hell might break loose."))
173  (let* ((lab (or (find-lap-label labx)
174                  (make-lap-label labx))))
175    (push insn (lap-label-refs lab))
176    lab))
177
178;;; A label can only be emitted once.  Once it's been emitted, its pred/succ
179;;; slots will be non-nil.
180
181(defun lap-label-emitted-p (lab)
182  (not (null (lap-label-pred lab))))
183
184
185(defun emit-lap-label (name)
186  (let* ((lab (find-lap-label name)))
187    (if  lab 
188      (when (lap-label-emitted-p lab)
189        (error "Label ~s: multiply defined." name))
190      (setq lab (make-lap-label name)))
191    (append-dll-node lab *lap-instructions*)))
192
193(defun emit-lap-note (note)
194  (append-dll-node note *lap-instructions*))
195
196(provide "RISC-LAP")
197
Note: See TracBrowser for help on using the repository browser.