Skip to content
Snippets Groups Projects
Commit f01ee31d authored by ram's avatar ram
Browse files

Added some hacks to defeat type checking so that this stuff will work

under the new compiler.  Made the GC hook break all the next links in the
freelist.
parent 8bbe7143
No related branches found
No related tags found
No related merge requests found
...@@ -13,6 +13,29 @@ ...@@ -13,6 +13,29 @@
;;; ;;;
(in-package "C") (in-package "C")
;;; A hack we we to defeat compile-time type checking in deinitializing slots
;;; where there isn't any convenient legal value.
;;;
(defvar *undefined* '**undefined**)
;;; ZAP-IN -- Internal
;;;
;;; A convenient macro for iterating over linked lists when we are
;;; clobbering the next link as we go.
;;;
(defmacro zap-in ((var in slot) &body body)
(let ((next (gensym)))
`(let ((,var ,in) ,next)
(when ,var
(loop
(setq ,next (,slot ,var))
,@body
(unless ,next (return))
(setq ,var ,next))))))
;;; DEFALLOCATERS -- Internal ;;; DEFALLOCATERS -- Internal
;;; ;;;
;;; Define some structure freelisting operations. ;;; Define some structure freelisting operations.
...@@ -36,6 +59,7 @@ ...@@ -36,6 +59,7 @@
(forms `(proclaim '(inline ,fun-name ,unfun-name))) (forms `(proclaim '(inline ,fun-name ,unfun-name)))
(forms `(defvar ,var-name nil)) (forms `(defvar ,var-name nil))
(forms `(defun ,fun-name ,lambda-list (forms `(defun ,fun-name ,lambda-list
(declare (optimize (safety 0)))
(let ((structure ,var-name)) (let ((structure ,var-name))
(cond (structure (cond (structure
(setq ,var-name (,slot structure)) (setq ,var-name (,slot structure))
...@@ -45,6 +69,7 @@ ...@@ -45,6 +69,7 @@
(,real-fun-name ,@real-lambda-list)))))) (,real-fun-name ,@real-lambda-list))))))
(forms `(defun ,unfun-name (structure) (forms `(defun ,unfun-name (structure)
(declare (optimize (safety 0)))
,@(third spec) ,@(third spec)
#+nil #+nil
(when (find-in #',slot structure ,var-name) (when (find-in #',slot structure ,var-name)
...@@ -52,11 +77,16 @@ ...@@ -52,11 +77,16 @@
(setf (,slot structure) ,var-name) (setf (,slot structure) ,var-name)
(setq ,var-name structure))) (setq ,var-name structure)))
(hook-forms `(setq ,var-name nil)))) (hook-forms
`(progn
(zap-in (structure ,var-name ,slot)
(setf (,slot structure) nil))
(setq ,var-name nil)))))
`(progn `(progn
,@(forms) ,@(forms)
(defun defallocator-deallocation-hook () (defun defallocator-deallocation-hook ()
(declare (optimize (safety 0)))
,@(hook-forms)) ,@(hook-forms))
(pushnew 'defallocator-deallocation-hook ext:*before-gc-hooks*)))) (pushnew 'defallocator-deallocation-hook ext:*before-gc-hooks*))))
...@@ -116,9 +146,28 @@ ...@@ -116,9 +146,28 @@
(setf (block-component structure) *current-component*) (setf (block-component structure) *current-component*)
(setf (block-start structure) start))) (setf (block-start structure) start)))
((ref (derived-type source leaf inlinep)) node-source
((node-deinits)
(setf (ref-leaf structure) *undefined*))
((node-inits)
(setf (node-derived-type structure) derived-type)
(setf (node-source structure) source)
(setf (ref-leaf structure) leaf)
(setf (ref-inlinep structure) inlinep)))
((combination (source fun)) node-source
((node-deinits)
(setf (basic-combination-fun structure) *undefined*)
(setf (basic-combination-args structure) nil)
(setf (basic-combination-kind structure) :full)
(setf (basic-combination-info structure) nil))
((node-inits)
(setf (node-source structure) source)
(setf (basic-combination-fun structure) fun)))
((ir2-block (block)) ir2-block-next ((ir2-block (block)) ir2-block-next
((setf (ir2-block-number structure) nil) ((setf (ir2-block-number structure) nil)
(setf (ir2-block-block structure) nil) (setf (ir2-block-block structure) *undefined*)
(setf (ir2-block-prev structure) nil) (setf (ir2-block-prev structure) nil)
(setf (ir2-block-pushed structure) nil) (setf (ir2-block-pushed structure) nil)
(setf (ir2-block-popped structure) nil) (setf (ir2-block-popped structure) nil)
...@@ -139,7 +188,7 @@ ...@@ -139,7 +188,7 @@
(setf (ir2-block-block structure) block))) (setf (ir2-block-block structure) block)))
((vop (block node info args results)) vop-next ((vop (block node info args results)) vop-next
((setf (vop-block structure) nil) ((setf (vop-block structure) *undefined*)
(setf (vop-prev structure) nil) (setf (vop-prev structure) nil)
(setf (vop-args structure) nil) (setf (vop-args structure) nil)
(setf (vop-results structure) nil) (setf (vop-results structure) nil)
...@@ -155,27 +204,8 @@ ...@@ -155,27 +204,8 @@
(setf (vop-args structure) args) (setf (vop-args structure) args)
(setf (vop-results structure) results))) (setf (vop-results structure) results)))
((ref (derived-type source leaf inlinep)) node-source
((node-deinits)
(setf (ref-leaf structure) nil))
((node-inits)
(setf (node-derived-type structure) derived-type)
(setf (node-source structure) source)
(setf (ref-leaf structure) leaf)
(setf (ref-inlinep structure) inlinep)))
((combination (source fun)) node-source
((node-deinits)
(setf (basic-combination-fun structure) nil)
(setf (basic-combination-args structure) nil)
(setf (basic-combination-kind structure) :full)
(setf (basic-combination-info structure) nil))
((node-inits)
(setf (node-source structure) source)
(setf (basic-combination-fun structure) fun)))
((tn-ref (tn write-p)) tn-ref-next ((tn-ref (tn write-p)) tn-ref-next
((setf (tn-ref-tn structure) nil) ((setf (tn-ref-tn structure) *undefined*)
(setf (tn-ref-vop structure) nil) (setf (tn-ref-vop structure) nil)
(setf (tn-ref-next-ref structure) nil) (setf (tn-ref-next-ref structure) nil)
(setf (tn-ref-across structure) nil) (setf (tn-ref-across structure) nil)
...@@ -211,9 +241,9 @@ ...@@ -211,9 +241,9 @@
(setf (tn-sc structure) sc))) (setf (tn-sc structure) sc)))
((global-conflicts (kind tn block number)) global-conflicts-next ((global-conflicts (kind tn block number)) global-conflicts-next
((setf (global-conflicts-block structure) nil) ((setf (global-conflicts-block structure) *undefined*)
(clear-bit-vector (global-conflicts-conflicts structure)) (clear-bit-vector (global-conflicts-conflicts structure))
(setf (global-conflicts-tn structure) nil) (setf (global-conflicts-tn structure) *undefined*)
(setf (global-conflicts-tn-next structure) nil)) (setf (global-conflicts-tn-next structure) nil))
((setf (global-conflicts-next structure) nil) ((setf (global-conflicts-next structure) nil)
(setf (global-conflicts-kind structure) kind) (setf (global-conflicts-kind structure) kind)
...@@ -222,17 +252,6 @@ ...@@ -222,17 +252,6 @@
(setf (global-conflicts-number structure) number)))) (setf (global-conflicts-number structure) number))))
(defmacro zap-in ((var in slot) &body body)
(let ((next (gensym)))
`(let ((,var ,in) ,next)
(when ,var
(loop
(setq ,next (,slot ,var))
,@body
(unless ,next (return))
(setq ,var ,next))))))
;;; NUKE-IR2-COMPONENT -- Interface ;;; NUKE-IR2-COMPONENT -- Interface
;;; ;;;
;;; Destroy the connectivity of the IR2 as much as possible in an attempt to ;;; Destroy the connectivity of the IR2 as much as possible in an attempt to
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment