gcl-devel
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Gcl-devel] GCL meets scheme: mutual-recursion, automatic state machine


From: Camm Maguire
Subject: [Gcl-devel] GCL meets scheme: mutual-recursion, automatic state machine conversion -- help
Date: Thu, 08 Jun 2006 13:51:00 -0400

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                                            address@hidden
==========================================================================
"The earth is but one country, and mankind its citizens."  --  Baha'u'llah




reply via email to

[Prev in Thread] Current Thread [Next in Thread]