source: branches/arm/compiler/risc-lap.lisp @ 13741

Last change on this file since 13741 was 13067, checked in by rme, 10 years ago

Update copyright notices.

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