Greetings! This is working out quite well so far -- I just don't know
when to 'turn it on' automatically:
=============================================================================
SYSTEM>(load "../bench/takr.o")
Loading ../bench/takr.o
Callee COMMON-LISP-USER::TAK65 sigchange NIL to ((FIXNUM FIXNUM FIXNUM)
*), recompiling
COMMON-LISP-USER::TAK64
...
SYSTEM>(time (dotimes (i 100) (user::tak0 18 12 6)))
real time : 0.470 secs
run-gbc time : 0.470 secs
child run time : 0.000 secs
gbc time : 0.000 secs
NIL
SYSTEM>(convert-to-state 'user::tak0)
COMMON-LISP-USER::TAK04463
SYSTEM>(compile 'COMMON-LISP-USER::TAK04463)
;; Compiling /tmp/gazonk_19962_0.lsp.
;; End of Pass 1.
;; End of Pass 2.
;; OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3,
(Debug quality ignored)
;; Finished compiling /tmp/gazonk_19962_0.o.
Loading /tmp/gazonk_19962_0.o
Callee COMMON-LISP-USER::TAK04463 sigchange NIL to ((FIXNUM FIXNUM
FIXNUM FIXNUM)
FIXNUM), recompiling
COMMON-LISP-USER::TAK24
...
SYSTEM>(time (dotimes (i 100) (user::tak0 18 12 6)))
real time : 0.190 secs
run-gbc time : 0.190 secs
child run time : 0.000 secs
gbc time : 0.000 secs
NIL
=============================================================================
Here are the main functions, (surprisingly concise!):
(defun inlinef (n syms)
(let* ((fns (mapcar 'si::function-src syms))
(sts (let (sts) (dotimes (i (length syms) (nreverse sts)) (push i
sts))))
(lsst (1- (length sts)))
(ll (cadr (car fns))))
`(defun ,n ,(append ll '(state))
(declare (fixnum state))
,@(let (d (z (cddr (car fns))))
(when (stringp (car z)) (pop z))
(do nil ((or (not z) (not (consp (car z))) (not (eq (caar z)
'declare))) (nreverse d)) (push (pop z) d)))
(macrolet ,(mapcan (lambda (x y z) `((,x ,(cadr y) `(,',n ,,@(cadr y)
,,z)))) syms fns sts)
(case state
,@(mapcar (lambda (x y) `(,(if (= x lsst) 'otherwise x) (funcall ,y
,@ll))) sts fns))))))
(defun convert-to-state (sym)
(let* ((n (intern (symbol-name (gensym (symbol-name sym))) (symbol-package
sym)))
(syms (intersection (all-callees sym nil) (all-callers sym nil)))
(sts (let (sts) (dotimes (i (length syms) (nreverse sts)) (push i
sts))))
(ns (inlinef n syms)))
(eval ns)
(mapc (lambda (x y) (let ((z (butlast (caddr ns)))) (eval `(defun ,x ,z (,n
,@z ,y))))) syms sts)
(dolist (l syms) (add-hash l nil (list (list n)) nil))
n))
=============================================================================
The idea is that one makes an automatic state machine containing the
function bodies of the intersection of all the callees of sym and all
the callers of sym, where 'all' here means inclusing recursive callees
and callers. This is done by creating a simple function which
macrolets all the function calls into calls of the new function with
the appropriate state variable, and then ends with an integer case
statement funcalling the relevant function's source. GCL converts
such case statements to fast C switch statements. The original
functions are now redefined to call the new state machine with the
appropriate state integer.
I thought that basically this would be appropriate:
1) Ideally whenever there was an intersection between the
recursive callers and the recursive callees
2) More practically when the signatures of the above all match
3) More practically when the intersection contains more than
just the function itself
4) More practically, when all the arguments are fixed, as GCL
does not yet do tail recursion on optional argument functions
(on my
todo list)
This leaves still quite a lot. Hmm ... advice most appreciated ...
(maphash (lambda (x y)
(let ((z (remove-if (lambda (x)
(not (equal (call-sig y)
(call-sig (gethash x
*call-hash-table*)))))
(intersection (all-callers x nil) (all-callees x
nil)))))
(when (and (remove x z)
(not (member '* (car (call-sig y)))))
(print (list x (call-sig y) z))))) *call-hash-table*)
(COMPILER::C2DM-BIND-INIT ((T T) T)
(COMPILER::C2DM-BIND-VL COMPILER::C2DM-BIND-LOC))
(COMPILER::C2DM-BIND-LOC ((T T) T)
(COMPILER::C2DM-BIND-VL COMPILER::C2DM-BIND-INIT
COMPILER::C2DM-BIND-LOC))
(COMPILER::C2DM-RESERVE-V ((T) T)
(COMPILER::C2DM-RESERVE-VL COMPILER::C2DM-RESERVE-V))
(COMPILER::C2DM-RESERVE-VL ((T) T) (COMPILER::C2DM-RESERVE-V))
(COMPILER::C2DM-BIND-VL ((T T) T)
(COMPILER::C2DM-BIND-INIT COMPILER::C2DM-BIND-LOC))
(SLOOP::PARSE-ONE-WHEN-CLAUSE (NIL T) (SLOOP::PARSE-LOOP-WHEN))
(SLOOP::PARSE-LOOP-WHEN (NIL T)
(SLOOP::PARSE-ONE-WHEN-CLAUSE SLOOP::PARSE-LOOP-WHEN))
(SEQUENCE-TYPE-ELEMENT-TYPE ((T) T)
(NTP-LOAD NPROCESS-TYPE RESOLVE-TYPE BEST-ARRAY-ELEMENT-TYPE
SEQUENCE-TYPE-ELEMENT-TYPE-INT FIND-STANDARD-CLASS
COERCE-TO-STANDARD-CLASS))
(FIND-STANDARD-CLASS ((T) T) (COERCE-TO-STANDARD-CLASS))
(PCL::FIND-STRUCTURE-CLASS ((T) T)
(PCL::WRAPPER-FOR-STRUCTURE CONDITIONS::CONDITION-CLASS-P NTP-LOAD
CONDITIONP PCL::BUILT-IN-WRAPPER-OF CLASS-OF NPROCESS-TYPE
RESOLVE-TYPE SEQUENCE-TYPE-ELEMENT-TYPE BEST-ARRAY-ELEMENT-TYPE
SEQUENCE-TYPE-ELEMENT-TYPE-INT FIND-STANDARD-CLASS
COERCE-TO-STANDARD-CLASS))
(NTP-LOAD ((T) T)
(NPROCESS-TYPE RESOLVE-TYPE SEQUENCE-TYPE-ELEMENT-TYPE
BEST-ARRAY-ELEMENT-TYPE SEQUENCE-TYPE-ELEMENT-TYPE-INT))
(COERCE-TO-STANDARD-CLASS ((T) T)
(NTP-LOAD RESOLVE-TYPE SEQUENCE-TYPE-ELEMENT-TYPE
SEQUENCE-TYPE-ELEMENT-TYPE-INT NPROCESS-TYPE))
(COSH ((T) T) (SINH COSH))
(NORMALIZE-TYPE-INT ((T T) T) (NORMALIZE-TYPE-INT SUBTYPEP1))
(NPROCESS-TYPE ((T) T)
(NPROCESS-TYPE RESOLVE-TYPE SEQUENCE-TYPE-ELEMENT-TYPE
BEST-ARRAY-ELEMENT-TYPE SEQUENCE-TYPE-ELEMENT-TYPE-INT))
(SEQUENCE-TYPE-ELEMENT-TYPE-INT ((T) T)
(SEQUENCE-TYPE-ELEMENT-TYPE-INT BEST-ARRAY-ELEMENT-TYPE))
(BEST-ARRAY-ELEMENT-TYPE ((T) T)
(NTP-LOAD NPROCESS-TYPE RESOLVE-TYPE FIND-STANDARD-CLASS
COERCE-TO-STANDARD-CLASS))
(SUBTYPEP1 ((T T) T) (NORMALIZE-TYPE-INT))
(IN-INTERVAL-P ((T T) T)
(TYPEP-INT IN-INTERVAL-P NORMALIZE-TYPE-INT SUBTYPEP1))
(TYPEP-INT ((T T) T)
(TYPEP-INT IN-INTERVAL-P NORMALIZE-TYPE-INT SUBTYPEP1))
(CLASS-OF ((T) T)
(NTP-LOAD PCL::BUILT-IN-WRAPPER-OF NPROCESS-TYPE RESOLVE-TYPE
SEQUENCE-TYPE-ELEMENT-TYPE BEST-ARRAY-ELEMENT-TYPE
SEQUENCE-TYPE-ELEMENT-TYPE-INT PCL::FIND-STRUCTURE-CLASS
PCL::STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST
PCL::WRAPPER-FOR-STRUCTURE FIND-STANDARD-CLASS
COERCE-TO-STANDARD-CLASS))
(PCL::BUILT-IN-WRAPPER-OF ((T) T) (CLASS-OF))
(PCL::WRAPPER-FOR-STRUCTURE ((T) T)
(CLASS-OF NTP-LOAD CONDITIONS::CONDITION-CLASS-P CONDITIONP
PCL::BUILT-IN-WRAPPER-OF NPROCESS-TYPE RESOLVE-TYPE
SEQUENCE-TYPE-ELEMENT-TYPE BEST-ARRAY-ELEMENT-TYPE
SEQUENCE-TYPE-ELEMENT-TYPE-INT PCL::FIND-STRUCTURE-CLASS
PCL::STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST FIND-STANDARD-CLASS
COERCE-TO-STANDARD-CLASS))
(PCL::NET-CONSTANT-CONVERTER ((T T) T) (PCL::METHODS-CONVERTER))
(PCL::METHODS-CONVERTER ((T T) T) (PCL::NET-CONSTANT-CONVERTER))
(PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-INTERNAL ((T T T T) T)
(PCL::MAKE-EFFECTIVE-METHOD-FUNCTION1))
(PCL::ACCESSOR-MISS ((T T T T) *)
(PCL::MAKE-ONE-CLASS-ACCESSOR-DFUN
PCL::MAKE-FINAL-ONE-INDEX-ACCESSOR-DFUN))
(PCL::CHECKING-MISS ((T T T) *) (PCL::MAKE-FINAL-CONSTANT-VALUE-DFUN))
(PCL::CACHING-MISS ((T T T) *) (PCL::MAKE-FINAL-CACHING-DFUN))
(PCL::CONSTANT-VALUE-MISS ((T T T) *)
(PCL::MAKE-FINAL-CONSTANT-VALUE-DFUN))
(PCL::SAUT-AND ((T T) *)
(PCL::SPECIALIZER-APPLICABLE-USING-TYPE-P PCL::SAUT-AND))
(PCL::MAKE-FINAL-CONSTANT-VALUE-DFUN ((T T T) *)
(PCL::CONSTANT-VALUE-MISS PCL::CACHING-MISS
PCL::MAKE-FINAL-CONSTANT-VALUE-DFUN))
(PCL::MAKE-FINAL-CACHING-DFUN ((T T T) *)
(PCL::CONSTANT-VALUE-MISS PCL::CACHING-MISS))
(PCL::MAKE-FINAL-N-N-ACCESSOR-DFUN ((T T T) *) (PCL::CHECKING-MISS))
(PCL::MAKE-FINAL-ONE-INDEX-ACCESSOR-DFUN ((T T T T) *)
(PCL::ACCESSOR-MISS))
(PCL::MAKE-ONE-CLASS-ACCESSOR-DFUN ((T T T T) *) (PCL::ACCESSOR-MISS))
(PCL::STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST ((T) T)
(PCL::FIND-STRUCTURE-CLASS PCL::WRAPPER-FOR-STRUCTURE
CONDITIONS::CONDITION-CLASS-P NTP-LOAD CONDITIONP
PCL::BUILT-IN-WRAPPER-OF CLASS-OF NPROCESS-TYPE RESOLVE-TYPE
SEQUENCE-TYPE-ELEMENT-TYPE BEST-ARRAY-ELEMENT-TYPE
SEQUENCE-TYPE-ELEMENT-TYPE-INT FIND-STANDARD-CLASS
COERCE-TO-STANDARD-CLASS))
(COMPILER::C1EXPR ((T) T) (COMPILER::C1PROGN))
(COMPILER::C2EXPR ((T) T)
(COMPILER::C2EXPR* COMPILER::PUSH-ARGS
COMPILER::PUSH-ARGS-LISPCALL))
(COMPILER::C2CALL-UNKNOWN-GLOBAL ((T T T T) T)
(COMPILER::C2CALL-GLOBAL COMPILER::C2CALL-UNKNOWN-GLOBAL))
(COMPILER::C2PSETQ ((T T) T) (COMPILER::GET-INLINE-LOC))
(COMPILER::PUSH-ARGS ((T) T)
(COMPILER::C2EXPR COMPILER::C2EXPR* COMPILER::PUSH-ARGS
COMPILER::PUSH-ARGS-LISPCALL))
(COMPILER::C2CALL-GLOBAL ((T T T T) T)
(COMPILER::C2CALL-UNKNOWN-GLOBAL))
(COMPILER::COERCE-LOC-STRUCTURE-REF ((T T) T)
(COMPILER::GET-INLINE-LOC))
(COMPILER::C2EXPR* ((T) T)
(COMPILER::PUSH-ARGS COMPILER::PUSH-ARGS-LISPCALL COMPILER::C2EXPR
COMPILER::C2EXPR*))
(PCL::SPECIALIZER-APPLICABLE-USING-TYPE-P ((T T) *) (PCL::SAUT-AND))
(COMPILER::C1EXPR* ((T T) T)
(COMPILER::C1ARGS COMPILER::C1LAMBDA-FUN COMPILER::C1EXPR*
COMPILER::C1CONSTANT-VALUE COMPILER::C1DECL-BODY))
(COMPILER::C1ARGS ((T T) T)
(COMPILER::C1LAMBDA-FUN COMPILER::C1EXPR*
COMPILER::C1CONSTANT-VALUE COMPILER::C1DECL-BODY
COMPILER::C1ARGS))
(COMPILER::C1LAMBDA-FUN ((T T) T)
(COMPILER::C1EXPR* COMPILER::C1CONSTANT-VALUE COMPILER::C1DECL-BODY
COMPILER::C1ARGS))
(COMPILER::C1CONSTANT-VALUE ((T T) T)
(COMPILER::C1EXPR* COMPILER::C1LAMBDA-FUN COMPILER::C1DECL-BODY
COMPILER::C1ARGS))
(PCL::MAKE-INSTANCE-FUNCTION-SIMPLE ((T T T T T) T)
(PCL::GET-MAKE-INSTANCE-FUNCTION-INTERNAL
PCL::MAKE-INSTANCE-FUNCTION-COMPLEX))
(SINH ((T) T) (SINH COSH))
(PCL::MAKE-INSTANCE-FUNCTION-COMPLEX ((T T T T T) T)
(PCL::GET-MAKE-INSTANCE-FUNCTION-INTERNAL))
(PCL::GET-MAKE-INSTANCE-FUNCTION-INTERNAL ((T T T T T) T)
(PCL::MAKE-INSTANCE-FUNCTION-COMPLEX))
(PCL::GET-MAKE-INSTANCE-FUNCTION ((T) T) (PCL::RESET-INITIALIZE-INFO))
(COMPILER::CJT ((T T T) T) (COMPILER::CJF COMPILER::CJT))
(COMPILER::CJF ((T T T) T) (COMPILER::CJF COMPILER::CJT))
(COMPILER::TYPE-OR1 ((T T) T) (COMPILER::TYPE-OR1-INT))
(COMPILER::TYPE-AND ((T T) T) (COMPILER::TYPE-AND-INT))
(COMPILER::TYPE-OR1-INT ((T T) T) (COMPILER::TYPE-OR1))
(COMPILER::TYPE-AND-INT ((T T) T) (COMPILER::TYPE-AND))
(CONDITIONS::CONDITION-CLASS-P ((T) T)
(NTP-LOAD CONDITIONP PCL::BUILT-IN-WRAPPER-OF CLASS-OF
NPROCESS-TYPE RESOLVE-TYPE SEQUENCE-TYPE-ELEMENT-TYPE
BEST-ARRAY-ELEMENT-TYPE SEQUENCE-TYPE-ELEMENT-TYPE-INT))
(CONDITIONP ((T) T)
(NPROCESS-TYPE RESOLVE-TYPE SEQUENCE-TYPE-ELEMENT-TYPE
BEST-ARRAY-ELEMENT-TYPE SEQUENCE-TYPE-ELEMENT-TYPE-INT
PCL::FIND-STRUCTURE-CLASS
PCL::STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST
PCL::WRAPPER-FOR-STRUCTURE FIND-STANDARD-CLASS
COERCE-TO-STANDARD-CLASS))
(INSPECT-ARRAY ((T) T)
(INSPECT-NUMBER INSPECT-CONS INSPECT-SYMBOL INSPECT-VECTOR
INSPECT-STRING INSPECT-PACKAGE))
(INSPECT-VECTOR ((T) T)
(INSPECT-NUMBER INSPECT-ARRAY INSPECT-CONS INSPECT-SYMBOL
INSPECT-STRING INSPECT-PACKAGE))
(INSPECT-STRING ((T) T)
(INSPECT-NUMBER INSPECT-ARRAY INSPECT-CONS INSPECT-SYMBOL
INSPECT-VECTOR INSPECT-PACKAGE))
(INSPECT-CONS ((T) T)
(INSPECT-NUMBER INSPECT-ARRAY INSPECT-CONS INSPECT-SYMBOL
INSPECT-VECTOR INSPECT-STRING INSPECT-PACKAGE))
(INSPECT-NUMBER ((T) T)
(INSPECT-ARRAY INSPECT-CONS INSPECT-SYMBOL INSPECT-VECTOR
INSPECT-STRING INSPECT-PACKAGE))
(INSPECT-CHARACTER ((T) T)
(INSPECT-NUMBER INSPECT-ARRAY INSPECT-CONS INSPECT-SYMBOL
INSPECT-VECTOR INSPECT-STRING INSPECT-PACKAGE))
(INSPECT-SYMBOL ((T) T)
(INSPECT-NUMBER INSPECT-ARRAY INSPECT-CONS INSPECT-VECTOR
INSPECT-STRING INSPECT-PACKAGE))
(NTHCDR ((T T) T) (NORMALIZE-TYPE-INT TYPEP-INT SUBTYPEP1))
NIL
Take care,
--
Camm Maguire [EMAIL PROTECTED]
==========================================================================
"The earth is but one country, and mankind its citizens." -- Baha'u'llah
_______________________________________________
Gcl-devel mailing list
Gcl-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/gcl-devel
