From 0489f2e2273b493f8a2c477dea903672f59769c3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 16 Feb 2023 18:33:58 +0100 Subject: [PATCH] cmp: move functions from cmpmac to cmputil both files served the same purpose --- src/cmp/cmpmac.lsp | 114 -------------------------------------------- src/cmp/cmputil.lsp | 107 +++++++++++++++++++++++++++++++++++++++++ src/cmp/load.lsp.in | 1 - 3 files changed, 107 insertions(+), 115 deletions(-) delete mode 100644 src/cmp/cmpmac.lsp diff --git a/src/cmp/cmpmac.lsp b/src/cmp/cmpmac.lsp deleted file mode 100644 index ed8ca3ec5..000000000 --- a/src/cmp/cmpmac.lsp +++ /dev/null @@ -1,114 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - -;;;; -;;; ---------------------------------------------------------------------- -;;; Macros only used in the code of the compiler itself: - -(in-package "COMPILER") - -;; ---------------------------------------------------------------------- -;; CACHED FUNCTIONS -;; -(defmacro defun-cached (name lambda-list test &body body) - (let* ((cache-name (intern (concatenate 'string "*" (string name) "-CACHE*") - (symbol-package name))) - (reset-name (intern (concatenate 'string (string name) "-EMPTY-CACHE") - (symbol-package name))) - (hash-function (case test - (EQ 'SI::HASH-EQ) - (EQL 'SI::HASH-EQL) - ((EQUAL EQUAL-WITH-CIRCULARITY) 'SI::HASH-EQUAL) - (t (setf test 'EQUALP) 'SI::HASH-EQUALP)))) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter ,cache-name (make-array 1024 :element-type t :adjustable nil))) - (defun ,reset-name () - (make-array 1024 :element-type t :adjustable nil)) - (defun ,name ,lambda-list - (flet ((,name ,lambda-list ,@body)) - (let* ((hash (logand (,hash-function ,@lambda-list) 1023)) - (elt (aref ,cache-name hash))) - (declare (type (integer 0 1023) hash) - (type (array t (*)) ,cache-name)) - (if (and elt ,@(loop for arg in lambda-list - collect `(,test (pop (ext:truly-the cons elt)) ,arg))) - (first (ext:truly-the cons elt)) - (let ((output (,name ,@lambda-list))) - (setf (aref ,cache-name hash) (list ,@lambda-list output)) - output)))))))) - -(defmacro defun-equal-cached (name lambda-list &body body) - `(defun-cached ,name ,lambda-list equal-with-circularity ,@body)) - -;;; ---------------------------------------------------------------------- -;;; CONVENIENCE FUNCTIONS / MACROS -;;; - -(defun-cached env-var-name (n) eql - (format nil "env~D" n)) - -(defun-cached lex-env-var-name (n) eql - (format nil "lex~D" n)) - -(defun same-fname-p (name1 name2) (equal name1 name2)) - -;;; from cmplabel.lsp -(defun next-label () - (cons (incf *last-label*) nil)) - -(defun next-label* () - (cons (incf *last-label*) t)) - -(defun labelp (x) - (and (consp x) (integerp (si:cons-car x)))) - -(defun maybe-next-label () - (if (labelp *exit*) - *exit* - (next-label))) - -(defun maybe-wt-label (label) - (unless (eq label *exit*) - (wt-label label))) - -(defmacro with-exit-label ((label) &body body) - `(let* ((,label (next-label)) - (*unwind-exit* (cons ,label *unwind-exit*))) - ,@body - (wt-label ,label))) - -(defmacro with-optional-exit-label ((label) &body body) - `(let* ((,label (maybe-next-label)) - (*unwind-exit* (adjoin ,label *unwind-exit*))) - ,@body - (maybe-wt-label ,label))) - -(defun next-lcl (&optional name) - (list 'LCL (incf *lcl*) T - (if (and name (symbol-package name)) - (lisp-to-c-name name) - ""))) - -(defun next-cfun (&optional (prefix "L~D~A") (lisp-name nil)) - (let ((code (incf *next-cfun*))) - (format nil prefix code (lisp-to-c-name lisp-name)))) - -(defun next-temp () - (prog1 *temp* - (incf *temp*) - (setq *max-temp* (max *temp* *max-temp*)))) - -(defun next-lex () - (prog1 (cons *level* *lex*) - (incf *lex*) - (setq *max-lex* (max *lex* *max-lex*)))) - -(defun next-env () - (prog1 *env* - (incf *env*) - (setq *max-env* (max *env* *max-env*)))) - -(defmacro reckless (&rest body) - `(locally (declare (optimize (safety 0))) - ,@body)) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 6cfcd236a..356176dfe 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -473,3 +473,110 @@ comparing circular objects." (and (equal-recursive (car x) (car y) x0 y0 t (logior (ash path-spec 1) 1) (the fixnum (1+ n))) (equal-recursive (cdr x) (cdr y) x0 y0 t (ash path-spec 1) (the fixnum (1+ n)))))))) (equal-recursive x y nil nil t 0 -1))) + +;; ---------------------------------------------------------------------- +;; CACHED FUNCTIONS +;; +(defmacro defun-cached (name lambda-list test &body body) + (let* ((cache-name (intern (concatenate 'string "*" (string name) "-CACHE*") + (symbol-package name))) + (reset-name (intern (concatenate 'string (string name) "-EMPTY-CACHE") + (symbol-package name))) + (hash-function (case test + (EQ 'SI::HASH-EQ) + (EQL 'SI::HASH-EQL) + ((EQUAL EQUAL-WITH-CIRCULARITY) 'SI::HASH-EQUAL) + (t (setf test 'EQUALP) 'SI::HASH-EQUALP)))) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter ,cache-name (make-array 1024 :element-type t :adjustable nil))) + (defun ,reset-name () + (make-array 1024 :element-type t :adjustable nil)) + (defun ,name ,lambda-list + (flet ((,name ,lambda-list ,@body)) + (let* ((hash (logand (,hash-function ,@lambda-list) 1023)) + (elt (aref ,cache-name hash))) + (declare (type (integer 0 1023) hash) + (type (array t (*)) ,cache-name)) + (if (and elt ,@(loop for arg in lambda-list + collect `(,test (pop (ext:truly-the cons elt)) ,arg))) + (first (ext:truly-the cons elt)) + (let ((output (,name ,@lambda-list))) + (setf (aref ,cache-name hash) (list ,@lambda-list output)) + output)))))))) + +(defmacro defun-equal-cached (name lambda-list &body body) + `(defun-cached ,name ,lambda-list equal-with-circularity ,@body)) + +;;; ---------------------------------------------------------------------- +;;; CONVENIENCE FUNCTIONS / MACROS +;;; + +(defun-cached env-var-name (n) eql + (format nil "env~D" n)) + +(defun-cached lex-env-var-name (n) eql + (format nil "lex~D" n)) + +(defun same-fname-p (name1 name2) + (equal name1 name2)) + +;;; from cmplabel.lsp +(defun next-label () + (cons (incf *last-label*) nil)) + +(defun next-label* () + (cons (incf *last-label*) t)) + +(defun labelp (x) + (and (consp x) (integerp (si:cons-car x)))) + +(defun maybe-next-label () + (if (labelp *exit*) + *exit* + (next-label))) + +(defun maybe-wt-label (label) + (unless (eq label *exit*) + (wt-label label))) + +(defmacro with-exit-label ((label) &body body) + `(let* ((,label (next-label)) + (*unwind-exit* (cons ,label *unwind-exit*))) + ,@body + (wt-label ,label))) + +(defmacro with-optional-exit-label ((label) &body body) + `(let* ((,label (maybe-next-label)) + (*unwind-exit* (adjoin ,label *unwind-exit*))) + ,@body + (maybe-wt-label ,label))) + +(defun next-lcl (&optional name) + (list 'LCL (incf *lcl*) T + (if (and name (symbol-package name)) + (lisp-to-c-name name) + ""))) + +(defun next-cfun (&optional (prefix "L~D~A") (lisp-name nil)) + (let ((code (incf *next-cfun*))) + (format nil prefix code (lisp-to-c-name lisp-name)))) + +(defun next-temp () + (prog1 *temp* + (incf *temp*) + (setq *max-temp* (max *temp* *max-temp*)))) + +(defun next-lex () + (prog1 (cons *level* *lex*) + (incf *lex*) + (setq *max-lex* (max *lex* *max-lex*)))) + +(defun next-env () + (prog1 *env* + (incf *env*) + (setq *max-env* (max *env* *max-env*)))) + +(defmacro reckless (&rest body) + `(locally (declare (optimize (safety 0))) + ,@body)) diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index 131ed65a0..a65775c75 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -5,7 +5,6 @@ '("src:cmp;cmppackage.lsp" "src:cmp;cmpglobals.lsp" "build:cmp;cmpdefs.lsp" - "src:cmp;cmpmac.lsp" "src:cmp;cmputil.lsp" "src:cmp;cmpcond.lsp" ;; Environment