diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index 290baf5..18a32ec 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -6555,13 +6555,12 @@ Code for encoding function names inside package or domain (defun |mkRepititionAssoc| (z) (labels ( (mkRepfun (z n) - (let (x) (cond ((null z) nil) ((and (pairp z) (eq (qcdr z) nil) (list (cons n (qcar z))))) ((and (pairp z) (pairp (qcdr z)) (equal (qcar (qcdr z)) (qcar z))) (mkRepfun (cdr z) (1+ n))) - (t (cons (cons n (car z)) (mkRepfun (cdr z) 1))))))) + (t (cons (cons n (car z)) (mkRepfun (cdr z) 1)))))) (mkRepfun z 1))) \end{chunk} @@ -8904,6 +8903,242 @@ where item has form \end{chunk} +\section{Code optimization routines} +\defun{optimizeFunctionDef}{optimizeFunctionDef} +\calls{optimizeFunctionDef}{pairp} +\calls{optimizeFunctionDef}{qcar} +\calls{optimizeFunctionDef}{qcdr} +\calls{optimizeFunctionDef}{rplac} +\calls{optimizeFunctionDef}{sayBrightlyI} +\calls{optimizeFunctionDef}{optimize} +\calls{optimizeFunctionDef}{pp} +\calls{optimizeFunctionDef}{bright} +\refsdollar{optimizeFunctionDef}{reportOptimization} +\begin{chunk}{defun optimizeFunctionDef} +(defun |optimizeFunctionDef| (def) + (labels ( + (fn (x g) + (cond + ((and (pairp x) (eq (qcar x) 'throw) (pairp (qcdr x)) + (equal (qcar (qcdr x)) g)) + (|rplac| (car x) 'return) + (|rplac| (cdr x) + (replaceThrowByReturn (qcdr (qcdr x)) g))) + ((atom x) nil) + (t + (replaceThrowByReturn (car x) g) + (replaceThrowByReturn (cdr x) g)))) + (replaceThrowByReturn (x g) + (fn x g) + x) + (removeTopLevelCatch (body) + (if (and (pairp body) (eq (qcar body) 'catch) (pairp (qcdr body)) + (pairp (qcdr (qcdr body))) (eq (qcdr (qcdr (qcdr body))) nil)) + (removeTopLevelCatch + (replaceThrowByReturn + (qcar (qcdr (qcdr body))) (qcar (qcdr body)))) + body))) + (let (defp name slamOrLam args body bodyp) + (declare (special |$reportOptimization|)) + (when |$reportOptimization| + (|sayBrightlyI| (|bright| "Original LISP code:")) + (|pp| def)) + (setq defp (|optimize| (copy def))) + (when |$reportOptimization| + (|sayBrightlyI| (|bright| "Optimized LISP code:")) + (|pp| defp) + (|sayBrightlyI| (|bright| "Final LISP code:"))) + (setq name (car defp)) + (setq slamOrLam (caadr defp)) + (setq args (cadadr defp)) + (setq body (car (cddadr defp))) + (setq bodyp (removeTopLevelCatch body)) + (list name (list slamOrLam args bodyp))))) + +\end{chunk} + +\defun{optimize}{optimize} +\calls{optimize}{pairp} +\calls{optimize}{qcar} +\calls{optimize}{qcdr} +\calls{optimize}{optimize} +\calls{optimize}{say} +\calls{optimize}{prettyprint} +\calls{optimize}{rplac} +\calls{optimize}{optIF2COND} +\calls{optimize}{getl} +\calls{optimize}{subrname} +\begin{chunk}{defun optimize} +(defun |optimize| (x) + (labels ( + (opt (x) + (let (argl body a y op) + (cond + ((atom x) nil) + ((eq (setq y (car x)) 'quote) nil) + ((eq y 'closedfn) nil) + ((and (pairp y) (pairp (qcar y)) (eq (qcar (qcar y)) 'xlam) + (pairp (qcdr (qcar y))) (pairp (qcdr (qcdr (qcar y)))) + (eq (qcdr (qcdr (qcdr (qcar y)))) nil)) + (setq argl (qcar (qcdr (qcar y)))) + (setq body (qcar (qcdr (qcdr (qcar y))))) + (setq a (qcdr y)) + (|optimize| (cdr x)) + (cond + ((eq argl '|ignore|) (rplac (car x) body)) + (t + (when (null (<= (length argl) (length a))) + (say "length mismatch in XLAM expression") + (prettyprint y)) + (rplac (car x) + (|optimize| + (|optXLAMCond| + (sublis (|pairList| argl a) body))))))) + ((atom y) + (|optimize| (cdr x)) + (cond + ((eq y '|true|) (rplac (car x) '''T)) + ((eq y '|false|) (rplac (car x) nil)))) + ((eq (car y) 'if) + (rplac (car x) (|optIF2COND| y)) + (setq y (car x)) + (when (setq op (getl (|subrname| (car y)) 'optimize)) + (|optimize| (cdr x)) + (rplac (car x) (funcall op (|optimize| (car x)))))) + ((setq op (getl (|subrname| (car y)) 'optimize)) + (|optimize| (cdr x)) + (rplac (car x) (funcall op (|optimize| (car x))))) + (t + (rplac (car x) (|optimize| (car x))) + (|optimize| (cdr x))))))) + (opt x) + x)) + +\end{chunk} + +\defun{subrname}{subrname} +\calls{subrname}{identp} +\calls{subrname}{compiled-function-p} +\calls{subrname}{mbpip} +\calls{subrname}{bpiname} +\begin{chunk}{defun subrname} +(defun |subrname| (u) + (cond + ((identp u) u) + ((or (compiled-function-p u) (mbpip u)) (bpiname u)) + (t nil))) + +\end{chunk} + +\subsection{Special case optimizers} +Optimization functions are called through the OPTIMIZE property on the +symbol property list. + +\defplist{call}{optCall} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get '|call| 'optimize) '|optCall|)) + +\end{chunk} + +\defplist{seq}{optSEQ} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'seq 'optimize) '|optSEQ|)) + +\end{chunk} + +\defplist{eq}{optEQ} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'eq 'optimize) '|optEQ|)) + +\end{chunk} + +\defplist{minus}{optMINUS} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'minus 'optimize) '|optMINUS|)) + +\end{chunk} + +\defplist{qsminus}{optQSMINUS} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'qsminus 'optimize) '|optQSMINUS|)) + +\end{chunk} + +\defplist{-}{opt-} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get '- 'optimize) '|opt-|)) + +\end{chunk} + +\defplist{lessp}{optLESSP} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'lessp 'optimize) '|optLESSP|)) + +\end{chunk} + +\defplist{spadcall}{optSPADCALL} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'spadcall 'optimize) '|optSPADCALL|)) + +\end{chunk} + +\defplist{\vert{}}{optSuchthat} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get '|\|| 'optimize) '|optSuchthat|)) + +\end{chunk} + +\defplist{catch}{optCatch} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'catch 'optimize) '|optCatch|)) + +\end{chunk} + +\defplist{cond}{optCond} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'cond 'optimize) '|optCond|)) + +\end{chunk} + +\defplist{mkRecord}{optMkRecord} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get '|mkRecord| 'optimize) '|optMkRecord|)) + +\end{chunk} + +\defplist{recordelt}{optRECORDELT} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'recordelt 'optimize) '|optRECORDELT|)) + +\end{chunk} + +\defplist{setrecordelt}{optSETRECORDELT} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'setrecordelt 'optimize) '|optSETRECORDELT|)) + +\end{chunk} + +\defplist{recordcopy}{optRECORDCOPY} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'recordcopy 'optimize) '|optRECORDCOPY|)) + +\end{chunk} + \section{Functions to manipulate modemaps} \defun{addDomain}{addDomain} @@ -21880,6 +22115,8 @@ The current input line. \getchunk{defun new2OldLisp} \getchunk{defun nonblankloc} +\getchunk{defun optimize} +\getchunk{defun optimizeFunctionDef} \getchunk{defun optional} \getchunk{defun orderByDependency} \getchunk{defun orderPredicateItems} @@ -22115,6 +22352,7 @@ The current input line. \getchunk{defun storeblanks} \getchunk{defun stripOffArgumentConditions} \getchunk{defun stripOffSubdomainConditions} +\getchunk{defun subrname} \getchunk{defun substituteCategoryArguments} \getchunk{defun substNames} \getchunk{defun substVars} diff --git a/changelog b/changelog index 0d2269f..109037b 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20110830 tpd src/axiom-website/patches.html 20110830.01.tpd.patch +20110830 tpd src/interp/g-opt.lisp treeshake compiler +20110830 tpd books/bookvol9 treeshake compiler 20110828 tpd src/axiom-website/patches.html 20110828.01.tpd.patch 20110828 tpd src/interp/Makefile remove package.lisp 20110828 tpd src/interp/package.lisp removed diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index ef7bcc0..6c3e3b4 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3602,5 +3602,7 @@ books/bookvol9 treeshake compiler
src/interp/package.lisp remove isPackageFunction
20110828.01.tpd.patch books/bookvol9 treeshake compiler, remove package.lisp
+20110830.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/g-opt.lisp.pamphlet b/src/interp/g-opt.lisp.pamphlet index 6c5f60b..ce3dc60 100644 --- a/src/interp/g-opt.lisp.pamphlet +++ b/src/interp/g-opt.lisp.pamphlet @@ -15,201 +15,7 @@ ;--% OPTIMIZER ; -;optimizeFunctionDef(def) == -; if $reportOptimization then -; sayBrightlyI bright '"Original LISP code:" -; pp def ; -; def' := optimize COPY def -; -; if $reportOptimization then -; sayBrightlyI bright '"Optimized LISP code:" -; pp def' -; sayBrightlyI bright '"Final LISP code:" -; [name,[slamOrLam,args,body]] := def' -; -; body':= -; removeTopLevelCatch body where -; removeTopLevelCatch body == -; body is ["CATCH",g,u] => -; removeTopLevelCatch replaceThrowByReturn(u,g) -; body -; replaceThrowByReturn(x,g) == -; fn(x,g) -; x -; fn(x,g) == -; x is ["THROW", =g,:u] => -; rplac(first x,"RETURN") -; rplac(rest x,replaceThrowByReturn(u,g)) -; atom x => nil -; replaceThrowByReturn(first x,g) -; replaceThrowByReturn(rest x,g) -; [name,[slamOrLam,args,body']] - -(DEFUN |optimizeFunctionDef,fn| (|x| |g|) - (PROG (|ISTMP#1| |u|) - (RETURN - (SEQ (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'THROW) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) |g|) - (PROGN (SPADLET |u| (QCDR |ISTMP#1|)) 'T)))) - (EXIT (SEQ (|rplac| (CAR |x|) 'RETURN) - (EXIT (|rplac| (CDR |x|) - (|optimizeFunctionDef,replaceThrowByReturn| - |u| |g|)))))) - (IF (ATOM |x|) (EXIT NIL)) - (|optimizeFunctionDef,replaceThrowByReturn| (CAR |x|) |g|) - (EXIT (|optimizeFunctionDef,replaceThrowByReturn| (CDR |x|) - |g|)))))) - - -(DEFUN |optimizeFunctionDef,replaceThrowByReturn| (|x| |g|) - (SEQ (|optimizeFunctionDef,fn| |x| |g|) (EXIT |x|))) - -(DEFUN |optimizeFunctionDef,removeTopLevelCatch| (|body|) - (PROG (|ISTMP#1| |g| |ISTMP#2| |u|) - (RETURN - (SEQ (IF (AND (PAIRP |body|) (EQ (QCAR |body|) 'CATCH) - (PROGN - (SPADLET |ISTMP#1| (QCDR |body|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |g| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |u| (QCAR |ISTMP#2|)) - 'T)))))) - (EXIT (|optimizeFunctionDef,removeTopLevelCatch| - (|optimizeFunctionDef,replaceThrowByReturn| - |u| |g|)))) - (EXIT |body|))))) - -(DEFUN |optimizeFunctionDef| (|def|) - (PROG (|def'| |name| |slamOrLam| |args| |body| |body'|) - (DECLARE (SPECIAL |$reportOptimization|)) - (RETURN - (PROGN - (COND - (|$reportOptimization| - (|sayBrightlyI| - (|bright| "Original LISP code:")) - (|pp| |def|))) - (SPADLET |def'| (|optimize| (COPY |def|))) - (COND - (|$reportOptimization| - (|sayBrightlyI| - (|bright| "Optimized LISP code:")) - (|pp| |def'|) - (|sayBrightlyI| - (|bright| "Final LISP code:")))) - (SPADLET |name| (CAR |def'|)) - (SPADLET |slamOrLam| (CAADR |def'|)) - (SPADLET |args| (CADADR |def'|)) - (SPADLET |body| (CAR (CDDADR |def'|))) - (SPADLET |body'| - (|optimizeFunctionDef,removeTopLevelCatch| |body|)) - (CONS |name| - (CONS (CONS |slamOrLam| (CONS |args| (CONS |body'| NIL))) - NIL)))))) - -;optimize x == -; (opt x; x) where -; opt x == -; atom x => nil -; (y:= first x)='QUOTE => nil -; y='CLOSEDFN => nil -; y is [["XLAM",argl,body],:a] => -; optimize rest x -; argl = "ignore" => RPLAC(first x,body) -; if not (LENGTH argl<=LENGTH a) then -; SAY '"length mismatch in XLAM expression" -; PRETTYPRINT y -; RPLAC(first x,optimize optXLAMCond SUBLIS(pairList(argl,a),body)) -; atom y => -; optimize rest x -; y="true" => RPLAC(first x,'(QUOTE (QUOTE T))) -; y="false" => RPLAC(first x,nil) -; if first y="IF" then (RPLAC(first x,optIF2COND y); y:= first x) -; op:= GET(subrname first y,"OPTIMIZE") => -; (optimize rest x; RPLAC(first x,FUNCALL(op,optimize first x))) -; RPLAC(first x,optimize first x) -; optimize rest x - -(DEFUN |optimize,opt| (|x|) - (PROG (|ISTMP#1| |ISTMP#2| |argl| |ISTMP#3| |body| |a| |y| |op|) - (RETURN - (SEQ (IF (ATOM |x|) (EXIT NIL)) - (IF (BOOT-EQUAL (SPADLET |y| (CAR |x|)) 'QUOTE) (EXIT NIL)) - (IF (BOOT-EQUAL |y| 'CLOSEDFN) (EXIT NIL)) - (IF (AND (PAIRP |y|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |y|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) 'XLAM) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |argl| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |body| - (QCAR |ISTMP#3|)) - 'T))))))) - (PROGN (SPADLET |a| (QCDR |y|)) 'T)) - (EXIT (SEQ (|optimize| (CDR |x|)) - (IF (BOOT-EQUAL |argl| '|ignore|) - (EXIT (RPLAC (CAR |x|) |body|))) - (IF (NULL (<= (LENGTH |argl|) (LENGTH |a|))) - (SEQ (SAY - "length mismatch in XLAM expression") - (EXIT (PRETTYPRINT |y|))) - NIL) - (EXIT (RPLAC (CAR |x|) - (|optimize| - (|optXLAMCond| - (SUBLIS - (|pairList| |argl| |a|) - |body|)))))))) - (IF (ATOM |y|) - (EXIT (SEQ (|optimize| (CDR |x|)) - (IF (BOOT-EQUAL |y| '|true|) - (EXIT (RPLAC (CAR |x|) '''T))) - (EXIT (IF (BOOT-EQUAL |y| '|false|) - (EXIT (RPLAC (CAR |x|) NIL))))))) - (IF (BOOT-EQUAL (CAR |y|) 'IF) - (SEQ (RPLAC (CAR |x|) (|optIF2COND| |y|)) - (EXIT (SPADLET |y| (CAR |x|)))) - NIL) - (IF (SPADLET |op| (GETL (|subrname| (CAR |y|)) 'OPTIMIZE)) - (EXIT (SEQ (|optimize| (CDR |x|)) - (EXIT (RPLAC (CAR |x|) - (FUNCALL |op| - (|optimize| (CAR |x|)))))))) - (RPLAC (CAR |x|) (|optimize| (CAR |x|))) - (EXIT (|optimize| (CDR |x|))))))) - -(DEFUN |optimize| (|x|) (PROGN (|optimize,opt| |x|) |x|)) - -; -;subrname u == -; IDENTP u => u -; COMPILED_-FUNCTION_-P u or MBPIP u => BPINAME u -; nil - -(DEFUN |subrname| (|u|) - (COND - ((IDENTP |u|) |u|) - ((OR (COMPILED-FUNCTION-P |u|) (MBPIP |u|)) (BPINAME |u|)) - ('T NIL))) - ;optCatch (x is ["CATCH",g,a]) == ; $InteractiveMode => x ; atom a => a @@ -1543,17 +1349,17 @@ ; ) ; -(EVALANDFILEACTQ - (REPEAT (IN |x| - '((|call| |optCall|) (SEQ |optSEQ|) (EQ |optEQ|) - (MINUS |optMINUS|) (QSMINUS |optQSMINUS|) (- |opt-|) - (LESSP |optLESSP|) (SPADCALL |optSPADCALL|) - (|\|| |optSuchthat|) (CATCH |optCatch|) - (COND |optCond|) (|mkRecord| |optMkRecord|) - (RECORDELT |optRECORDELT|) - (SETRECORDELT |optSETRECORDELT|) - (RECORDCOPY |optRECORDCOPY|))) - (MAKEPROP (CAR |x|) 'OPTIMIZE (CADR |x|)))) +;(EVALANDFILEACTQ +; (REPEAT (IN |x| +; '((|call| |optCall|) (SEQ |optSEQ|) (EQ |optEQ|) +; (MINUS |optMINUS|) (QSMINUS |optQSMINUS|) (- |opt-|) +; (LESSP |optLESSP|) (SPADCALL |optSPADCALL|) +; (|\|| |optSuchthat|) (CATCH |optCatch|) +; (COND |optCond|) (|mkRecord| |optMkRecord|) +; (RECORDELT |optRECORDELT|) +; (SETRECORDELT |optSETRECORDELT|) +; (RECORDCOPY |optRECORDCOPY|))) +; (MAKEPROP (CAR |x|) 'OPTIMIZE (CADR |x|)))) \end{chunk} \eject