From df9c13129f719c58f09f5ccf80db645206277ac2 Mon Sep 17 00:00:00 2001 From: Bart Botta <00003b@gmail.com> Date: Wed, 17 Dec 2008 10:43:25 -0600 Subject: [PATCH] get rid of extra special forms move code from special forms to macros or defuns in preparation for compiler cleanup --- compile/special-forms.lisp | 81 ++-------------------------------------------- lib/cl-conses.lisp | 16 ++++----- lib/cl-conses2.lisp | 19 +++++++++-- lib/cl.lisp | 6 ++++ lib/sicl-iteration.lisp | 8 ++--- 5 files changed, 37 insertions(+), 93 deletions(-) diff --git a/compile/special-forms.lisp b/compile/special-forms.lisp index 19cda3c..f277fd3 100644 --- a/compile/special-forms.lisp +++ b/compile/special-forms.lisp @@ -16,9 +16,9 @@ ;;+ go ;;+ tagbody ;; -;; quote +;;~ quote ;; -;; function +;;~ function ;;~ setq ;; ;; symbol-macrolet @@ -96,13 +96,6 @@ (:@kill `(:kill ,(get-lambda-local-index (second x)))) (otherwise x))) cdr)) -(define-special %asm* (args &rest cdr) - ;; (%asm* (arg list) (op1 args) (op2 ...) ... ) - (append - (loop for arg in args - append (scompile arg)) - (copy-list cdr))) - (define-special %label (target) ;; (%label name) ;; for reverse jumps only @@ -139,17 +132,8 @@ (define-special go (tag) (scompile-cons '%go (list (get-lambda-tag tag)))) -(define-special %go-when (cond tag) - (scompile-cons '%when (list cond (get-lambda-tag tag)))) - ;; (with-lambda-context () (scompile '(tagbody foo (go baz) bar 1 baz 2))) -(define-special %when (cond label) - ;; (%when cond label) - `(,@(scompile cond) - (:if-true ,label) - (:push-null))) - (define-special %if (cond false-test true-branch false-branch) (let ((false-label (gensym "%IF-FALSE-")) (end-label (gensym "%IF-END-"))) @@ -327,14 +311,6 @@ call with %flet-call, which sets up hidden return label arg collect '(:pop)) (:jump ,(end-label block))))) -(define-special prog1 (value-form &body body) - (let ((temp (gensym "PROG1-VALUE-"))) - (scompile - `(let ((,temp ,value-form)) - (progn - ,@body - ,temp))))) - (define-special %with-cleanup ((name code) form) (with-cleanup (name code) (scompile form))) @@ -348,26 +324,11 @@ call with %flet-call, which sets up hidden return label arg ,protected (call-%flet ,cleanup-name))))))) -(define-special* list (rest) - (labels ((expand-rest (rest) - (if (consp rest) - (list 'cons (car rest) (expand-rest (cdr rest))) - rest))) - (scompile (expand-rest rest)))) ;;(scompile '(list (list 1) (list 2))) ;;(scompile '(list 1)) ;;(scompile '(quote (1 2 3))) ;;(scompile '(list '(list 1 2 3))) -(define-special* list* (rest) - (labels ((expand-rest (rest) - (if (consp (cdr rest)) - (list 'cons (car rest) (expand-rest (cdr rest))) - (car rest)))) - (when (endp rest) - (error "not enough arguments to LIST*")) - (scompile (expand-rest rest)))) - ;;; internal aref, handles single dimensional flash::Array (define-special %aref-1 (array index) `(,@(scompile array) @@ -381,44 +342,6 @@ call with %flet-call, which sets up hidden return label arg ,@(scompile value) (:set-property (:multiname-l "" "")))) -;;; temporary hack to get inlined cons/car/cdr, speeds up tests noticeably -;;; types and better compilation should give a few orders of magnitude though -(define-special cons (a b) - `((:find-property-strict cons-type) - ,@(scompile a) - ,@(scompile b) - (:construct-prop cons-type 2) - (:coerce-any))) - -;;; coercing to cons-type before accessing slots is ~2x faster -;;; using get-slot instead of get-property is maybe a few % faster -;;; checking type explicitly is slow, so just using built-in check for now -;;; (which works, but doesn't throw the CL specified error type) -;;; :get-lex might be the slow part, so putting cons-type in a global -;;; might help speed of proper type check -(define-special car (a) ;;; FIXME: handle non-cons properly - (let ((temp (gensym "CAR-TEMP-"))) - `(,@(scompile - `(let ((,temp ,a)) - (if (eq ,temp :null) - :null - (%asm* (,temp) - (:coerce cons-type) - #+nil(:get-property %car) - (:get-slot 1)))))))) - -(define-special cdr (a) ;;; FIXME: handle non-cons properly - (let ((temp (gensym "CDR-TEMP-"))) - `(,@(scompile - `(let ((,temp ,a)) - (if (eq ,temp :null) - :null - (%asm (:@ ,temp) - (:coerce cons-type) - #+nil(:get-property %cdr) - (:get-slot 2)))))))) - - ;;(scompile '(list* 1 2 3 4 5)) ;;(scompile '(list* 1)) diff --git a/lib/cl-conses.lisp b/lib/cl-conses.lisp index e056ef3..87d04fa 100644 --- a/lib/cl-conses.lisp +++ b/lib/cl-conses.lisp @@ -26,8 +26,8 @@ (swf-defmemfun cons (a b) (%asm (:find-property-strict cons-type) - (:get-local-1) - (:get-local-2) + (:@ a) + (:@ b) (:construct-prop cons-type 2))) (swf-defmemfun consp (a) @@ -41,22 +41,22 @@ ;;; implementing CAR/CDR as special forms for performance, until ;;; compiler macros are available - #+nil(swf-defmemfun car (a) + (swf-defmemfun car (a) (if (eq a :null) :null (if (consp a) - (%asm* (a) + (%asm (:@ a) (:coerce cons-type) (:get-property %car)) (%type-error "CAR" a)))) - #+nil(swf-defmemfun cdr (a) + (swf-defmemfun cdr (a) (if (eq a :null) :null (if (consp a) - (%asm* (a) - (:coerce cons-type) - (:get-property %cdr)) + (%asm (:@ a) + (:coerce cons-type) + (:get-property %cdr)) (%type-error "CDR" a)))) diff --git a/lib/cl-conses2.lisp b/lib/cl-conses2.lisp index 3f38d0f..2037859 100644 --- a/lib/cl-conses2.lisp +++ b/lib/cl-conses2.lisp @@ -14,7 +14,7 @@ ;; Function TREE-EQUAL ;; fixme: write iterative version of copy-list - (swf-defun copy-list (list) + (swf-defmemfun copy-list (list) (%flet (do-copy (list) (if (consp list) (cons (car list) (do-copy (cdr list))) @@ -23,7 +23,22 @@ (%type-error "COPY-LIST" list) (call-%flet do-copy list)))) - ;; LIST, LIST* implemented as a special form for now due to lack of &rest + (swf-defmemfun list (&arest rest) + (let ((list nil) + (length (%get-property rest :length))) + (dotimes (i length list) + (push (%aref-1 rest (- length i 1)) list)))) + + (swf-defmemfun list* (&arest rest) + (when (zerop (%get-property rest :length)) + (%error "not enough arguments")) + (let* ((length (%get-property rest :length)) + (list (%aref-1 rest (1- length)))) + (dotimes (i (1- length) list) + (push (%aref-1 rest (- length i 2)) list)))) + + + (swf-defun list-length (list) (let ((fast list) diff --git a/lib/cl.lisp b/lib/cl.lisp index 7bb6fb0..4bdff0f 100644 --- a/lib/cl.lisp +++ b/lib/cl.lisp @@ -152,6 +152,12 @@ (:get-property , (find-swf-property slot-name))))) + (swf-defmacro prog1 (value-form &body body) + (let ((temp (gensym))) + `(let ((,temp ,value-form)) + ,@body + ,temp))) + ) #+nil(let ((*symbol-table* (make-instance 'symbol-table :inherit (list *cl-symbol-table* *player-symbol-table*)))) diff --git a/lib/sicl-iteration.lisp b/lib/sicl-iteration.lisp index a43ac93..6cbe706 100644 --- a/lib/sicl-iteration.lisp +++ b/lib/sicl-iteration.lisp @@ -120,15 +120,15 @@ ,@declarations (block nil (tagbody - #+nil(when (endp ,list-var) + (when (endp ,list-var) (go ,end-tag)) - (%go-when (endp ,list-var) ,end-tag) + #+nil(%go-when (endp ,list-var) ,end-tag) ,start-tag (setq ,var (pop ,list-var)) (tagbody ,@forms) - #+nil(when ,list-var + (when ,list-var (go ,start-tag)) - (%go-when ,list-var ,start-tag) + #+nil(%go-when ,list-var ,start-tag) ,end-tag) (let ((,var nil)) #+nil(declare (ignorable ,var)) -- 2.11.4.GIT