[movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv18461

Modified Files:
	symbols.lisp 
Log Message:
Fixed creation and copying of symbols not to use malloc-pointer-words.

Date: Wed Sep 22 20:49:24 2004
Author: ffjeld

Index: movitz/losp/muerte/symbols.lisp
diff -u movitz/losp/muerte/symbols.lisp:1.18 movitz/losp/muerte/symbols.lisp:1.19
--- movitz/losp/muerte/symbols.lisp:1.18	Thu Jul 29 02:13:22 2004
+++ movitz/losp/muerte/symbols.lisp	Wed Sep 22 20:49:24 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 23:55:41 2001
 ;;;;                
-;;;; $Id: symbols.lisp,v 1.18 2004/07/29 00:13:22 ffjeld Exp $
+;;;; $Id: symbols.lisp,v 1.19 2004/09/22 18:49:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -143,17 +143,31 @@
 				      (flags 0))
   (eval-when (:compile-toplevel)
     (assert (= 1 (- (movitz:tag :symbol) (movitz:tag :other)))))
-  (let ((symbol (%word-offset (malloc-pointer-words 6) 1)))
-    (setf-movitz-accessor (symbol movitz-symbol package) package)
-    (setf-movitz-accessor (symbol movitz-symbol name) name)
-    (setf (memref symbol #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::hash-key)
-		  0 :unsigned-byte16)
-      (sxhash name))
-    (setf (symbol-flags symbol) flags
-	  (symbol-plist symbol) plist
-	  (symbol-function symbol) function
-	  (symbol-value symbol) value)
-    symbol))
+  (let ((sxhash (sxhash name)))
+    (macrolet
+	((do-it ()
+	   `(with-non-pointer-allocation-assembly (6 :fixed-size-p t
+						     :object-register :eax)
+	      (:addl ,(- (movitz:tag :symbol) (movitz:tag :other)) :eax)
+	      (:load-lexical (:lexical-binding package) :ebx)
+	      (:movl :ebx (:eax (:offset movitz-symbol package)))
+	      (:load-lexical (:lexical-binding name) :ebx)
+	      (:movl :ebx (:eax (:offset movitz-symbol name)))
+	      (:load-lexical (:lexical-binding function) :ebx)
+	      (:movl :ebx (:eax (:offset movitz-symbol function-value)))
+	      (:load-lexical (:lexical-binding plist) :ebx)
+	      (:movl :ebx (:eax (:offset movitz-symbol plist)))
+	      (:load-lexical (:lexical-binding value) :ebx)
+	      (:movl :ebx (:eax (:offset movitz-symbol value)))
+
+	      (:load-lexical (:lexical-binding flags) :ecx)
+	      (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+	      (:load-lexical (:lexical-binding sxhash) :ebx)
+	      (:shll ,(- 16 movitz:+movitz-fixnum-shift+) :ebx)
+	      (:orl :ebx :ecx)
+	      (:movl :ecx (:eax (:offset movitz-symbol flags)))
+	      )))
+      (do-it))))
 
 (defun make-symbol (name)
   (check-type name string "a symbol name")
@@ -166,11 +180,29 @@
   (if (or (eq nil symbol)
 	  (not copy-properties))
       (%create-symbol (symbol-name symbol))
-    (let ((x (%word-offset (malloc-pointer-words 6) 1)))
-      (dotimes (i 6)
-	(setf (memref x #.(cl:- (movitz:tag :symbol)) i :lisp)
-	  (memref symbol #.(cl:- (movitz:tag :symbol)) i :lisp)))
-      x)))
+    (with-allocation-assembly (6 :object-register :eax
+				 :fixed-size-p t)
+      (:addl 1 :eax)
+      (:load-lexical (:lexical-binding symbol) :ebx)
+      ;; 0
+      (:movl (:ebx #.(cl:- (movitz:tag :symbol)) 0) :ecx)
+      (:movl :ecx (:eax #.(cl:- (movitz:tag :symbol)) 0))
+      ;; 1
+      (:movl (:ebx #.(cl:- (movitz:tag :symbol)) 4) :ecx)
+      (:movl :ecx (:eax #.(cl:- (movitz:tag :symbol)) 4))
+      ;; 2
+      (:movl (:ebx #.(cl:- (movitz:tag :symbol)) 8) :ecx)
+      (:movl :ecx (:eax #.(cl:- (movitz:tag :symbol)) 8))
+      ;; 3
+      (:movl (:ebx #.(cl:- (movitz:tag :symbol)) 12) :ecx)
+      (:movl :ecx (:eax #.(cl:- (movitz:tag :symbol)) 12))
+      ;; 4
+      (:movl (:ebx #.(cl:- (movitz:tag :symbol)) 16) :ecx)
+      (:movl :ecx (:eax #.(cl:- (movitz:tag :symbol)) 16))
+      ;; 5
+      (:movl (:ebx #.(cl:- (movitz:tag :symbol)) 20) :ecx)
+      (:movl :ecx (:eax #.(cl:- (movitz:tag :symbol)) 20)))))
+
 
 (defun symbol-flags (symbol)
   (etypecase symbol