; .EnTete "Le-Lisp (c) version 15.2" " " "L'Optimiseur Standard"
; .EnPied " " "%" " "
; .sp 2
; .SuperTitre "L'Optimiseur Standard"
;
; .Centre "*****************************************************************"
; .Centre " Ce fichier est en lecture seule hors du projet ALE de l'INRIA. "
; .Centre " Il est maintenu par ILOG SA, 2 Avenue Gallie'ni, 94250 Gentilly "
; .Centre " (c) Le-Lisp est une marque de'pose'e de l'INRIA "
; .Centre "*****************************************************************"
; .Centre "$Header: peephole.ll,v 4.1 88/01/13 12:22:58 kuczynsk Rel $"
(unless (>= (version) 15.2)
(error 'load 'erricf 'peephole))
; Tous les symboles pre'fixe's par : seront cre'e's dans le package COMPILER
(defvar #:sys-package:colon 'compiler)
; Petit Peep-Hole optimiseur de LAP simple et rapide : ne re`gle que :
; - les JRST Hacks
; - le branch tensioning
; - l'e'limation des RETURNS en trop
; - la fusion des ADJSTK
; Tient compte des boucles infinies dans la re'solution des e'tiquettes.
; Travaille sur une liste LAP inverse'e!
; .Section "Les variables globales de l'optimisateur"
(unless (boundp ':ph-debug)
(defvar :ph-debug ())) ; visualise le travail
(unless (boundp ':ph-stat) ; donne des stats.
(defvar :ph-stat ()))
#+ :ph-stat (defvar :ph-call 0.0) ; nb d'appels a` peephole
#+ :ph-stat (defvar :ph-len1 0.0) ; longeur LAP avant
#+ :ph-stat (defvar :ph-len2 0.0) ; longeur LAP apre`s
#+ :ph-stat (defvar :ph-lab0 0.0)
#+ :ph-stat (defvar :ph-lab1 0.0)
#+ :ph-stat (defvar :ph-lab2 0.0)
#+ :ph-stat (defvar :ph-lab3 0.0)
#+ :ph-stat (defvar :ph-opt0 0.0)
#+ :ph-stat (defvar :ph-opt1 0.0)
#+ :ph-stat (defvar :ph-opt2 0.0)
#+ :ph-stat (defvar :ph-tns1 0.0)
#+ :ph-stat (defvar :ph-bra0 0.0)
#+ :ph-stat (defvar :ph-bra1 0.0)
#+ :ph-stat (defvar :ph-bra2 0.0)
#+ :ph-stat (defvar :ph-bra3 0.0)
#+ :ph-stat (defvar :ph-psh0 0.0)
#+ :ph-stat (defvar :ph-psh1 0.0)
#+ :ph-stat (defvar :ph-psh2 0.0)
#+ :ph-stat (defvar :ph-psh3 0.0)
#+ :ph-stat (defvar :ph-mov0 0.0)
#+ :ph-stat (defvar :ph-mov1 0.0)
#+ :ph-stat (defvar :ph-ret0 0.0)
#+ :ph-stat (defvar :ph-ret1 0.0)
#+ :ph-stat (defvar :ph-ret2 0.0)
#+ :ph-stat (defvar :ph-ret3 0.0)
#+ :ph-stat (defvar :ph-ret4 0.0)
#+ :ph-stat (defvar :ph-adj1 0.0)
#+ :ph-stat (de :ph-stat-print ()
(print "nb total d'appels :ph-call= " :ph-call)
(print "taille lap avant :ph-len1 = " :ph-len1)
(print "taille lap apres :ph-len2 = " :ph-len2)
(print " et = () :ph-lab0 = " :ph-lab0)
(print " et1: et2: :ph-lab1 = " :ph-lab1)
(print " et1: return :ph-lab2 = " :ph-lab2)
(print " et1: bra et2 :ph-lab3 = " :ph-lab3)
(print "nb total opt et: :ph-opt0 = " :ph-opt0)
(print " bra xx xx: :ph-opt1 = " :ph-opt1)
(print " normal :ph-opt2 = " :ph-opt2)
(print "branch tensionning :ph-tns1 = " :ph-tns1)
(print "nb total de bra :ph-bra0 = " :ph-bra0)
(print " bra xx...xx:return :ph-bra1 = " :ph-bra1)
(print " bra bra/jmp/ret :ph-bra2 = " :ph-bra2)
(print " normal :ph-bra3 = " :ph-bra3)
(print "nb total de push @ :ph-psh0 = " :ph-psh0)
(print " @ ret enleves :ph-psh1 = " :ph-psh1)
(print " @ et modifies :ph-psh2 = " :ph-psh2)
(print " normal :ph-psh3 = " :ph-psh3)
(print "nb total de mov @ :ph-mov0 = " :ph-mov0)
(print " @ et modifies :ph-mov1 = " :ph-mov1)
(print "nb total de return :ph-ret0 = " :ph-ret0)
(print " ret bra/jmp/ret :ph-ret1 = " :ph-ret1)
(print " jcall ret :ph-ret2 = " :ph-ret2)
(print " call ret :ph-ret3 = " :ph-ret3)
(print " normal :ph-ret4 = " :ph-ret4)
(print " ajdstk 'n adjstk 'n :ph-adj1 = " :ph-adj1)
)
#+ :ph-debug (de :voir-lap (l)
; pour faire jouli ...
(pprint (mcons 'tagbody (reverse l))))
; .Section "Les Variables Globales"
; Les fonctions pour lesquelles il n'est pas possible de
; re'aliser un JRST Hack car elles supposent qu'une adresse
; de retour a e'te' empile'e et elles sont susceptibles de
; modifier la pile. Ces fonctions sont toujours des fonctions
; internes et spe'cifiques des compilateurs.
(defvar :no-jrst-hack
'(#:llcp:nlist #:llcp:cbindl #:llcp:cbinds #:llcp:tagbody
#:llcp:with-interrupts #:llcp:without-interrupts
#:llcp:schedule #:llcp:block #:llcp:protect #:llcp:tag))
; .Section "La Fonction de Lancement"
(de :peephole (lap)
; peep-hole optimiseur sur une liste LAP
#+ :ph-stat (incr :ph-call)
(let ((:aph ())
(:ret 29999) ; adresse de la premie`re e'tiquette "return"
(:retp ()) ; indic : :ret a` e'te' utilise'.
(:loop 29998) ; adresse d'une boucle
(:loopp) ; indic : on a utilise' une boucle!
(et1) ; e'tiquette de travail
(et2) ; itou
(l) ; listes de travail
(la) ; itou
(ld)) ; itou
;
; I - Premie`re Passe
; ===================
;
; Fabrication de la A-Liste des e'quivalences d'e'tiquettes :
; (etiq1 . etiq2) ou (etiq1 . :ret) ou (etiq1 . :loop)
;
; si je rencontre :
; et1: et1: et1:
; et2: (BRA et2) (RETURN)
; je fais l'e'quivalence et1 = et2 (ou return) et je saque
; tout de suite et1 pour ne garder que les e'tiquettes
; suceptibles d'e↑tre appele'es.
; De plus j'enle`ve toutes les e'tiquettes = ().
#+ :ph-debug (:voir-lap lap)
#+ :ph-stat (incr :ph-len1 (length lap))
(setq l lap)
(while (consp l)
(setq la (car l) ld (cdr l))
(cond ((and (consp ld) (null (car ld)))
#+ :ph-stat (incr :ph-lab0)
; pour Bernard ...
(rplacd l (cdr ld)))
((null la)
#+ :ph-stat (incr :ph-lab0)
; pour Bernard itou ...
(if (consp ld)
(rplac l (car ld) (cdr ld))
(setq l ())))
((atom la)
; e'tiquette engendre'e par le compilo.
(ifn (and (car ld) (atom (car ld)))
(setq l ld)
#+ :ph-stat (incr :ph-lab1)
(setq :aph (acons (car ld) la :aph))
(rplacd l (cdr ld))))
((eq (car la) 'RETURN)
(ifn (and (car ld) (atom (car ld)))
; pas et: suivi de (return)
(setq l ld)
; c'est et: suivi de (return)
#+ :ph-stat (incr :ph-lab2)
(setq :aph (acons (car ld) :ret :aph))
(rplacd l (cdr ld))))
((eq (car la) 'BRA)
(ifn (and (car ld) (atom (car ld)))
(setq l ld)
#+ :ph-stat (incr :ph-lab3)
(setq :aph (acons (car ld)
(if (eq (car ld) (cadr la))
:loop
(cadr la))
:aph))
(rplacd l (cdr ld))))
(t (setq l ld))))
#+ :ph-debug (:voir-lap lap)
;
; II - Re'solution de la table
; ============================
;
#+ :ph-debug (pprint :aph)
(let ((al :aph))
(while (consp al)
(if (setq et2 (cassq (cdar al) :aph))
(rplacd (car al)
(if (neq et2 (caar al))
; test des boucles re: go re
et2
:loop))
(setq al (cdr al)))))
#+ :ph-debug (pprint :aph)
;
; III - Simplification de la liste LAP
; ====================================
;
(setq l lap)
(while (consp l)
(setq la (car l) ld (cdr l))
(cond ;
; une e'tiquette
;
((atom la)
#+ :ph-stat (incr :ph-opt0)
(cond ((and (consp (car ld))
(eq (caar ld) 'BRA)
(or (eq (cadar ld) la)
(eq (cassq (cadar ld) :aph) la)))
; (BRA xx) xx == xx
#+ :ph-stat (incr :ph-opt1)
(rplacd l (cdr ld)))
(t #+ :ph-stat (incr :ph-opt2)
(setq l ld))))
;
; BRA
;
((eq (car la) 'BRA)
#+ :ph-stat (incr :ph-bra0)
(cond ((eq (setq et2 (cassq (cadr la) :aph)) :ret)
; (BRA xx) ... xx (RETURN) == (RETURN)
#+ :ph-stat (incr :ph-bra1)
(rplaca l '(RETURN)))
((and (consp (car ld))
(memq (caar ld) '(BRA JMP RETURN)))
; unreachable code.
; (RETURN) (BRA xxx) == (RETURN)
; (BRA xx) (BRA yy) == (BRA xx)
; (JMP xx) (BRA yy) == (JMP xx)
#+ :ph-stat (incr :ph-bra2)
(rplac l (car ld) (cdr ld)))
(et2
; il y a une e'tiquette a` changer
#+ :ph-stat (incr :ph-tns1)
(rplaca (last la) et2)
(when (eq et2 :loop)
(setq :loopp t))
(setq l ld))
(t #+ :ph-stat (incr :ph-bra3)
(setq l ld))))
;
; PUSH
;
((and (eq (car la) 'PUSH)
(consp (cadr la))
(eq (caadr la) '|@|))
#+ :ph-stat (incr :ph-psh0)
(setq et1 (cassq (cadadr la) :aph))
(cond ((eq et1 :ret)
#+ :ph-stat (incr :ph-psh1)
(rplac l (car ld) (cdr ld)))
(et1 (rplaca (cdadr la) et1)
#+ :ph-stat (incr :ph-psh2)
(setq l ld))
(t #+ :ph-stat (incr :ph-psh3)
(setq l ld))))
;
; MOV
;
((and (eq (car la) 'MOV)
(consp (cadr la))
(eq (caadr la) '|@|))
#+ :ph-stat (incr :ph-mov0)
(setq et1 (cassq (cadadr la) :aph))
(when et1
#+ :ph-stat (incr :ph-mov1)
(rplaca (cdadr la) et1)
(when (eq et1 :ret) (setq :retp t)))
(setq l ld))
;
; RETURN
;
((and (eq (car la) 'RETURN)
(consp (car ld)))
#+ :ph-stat (incr :ph-ret0)
(cond ((memq (caar ld) '(BRA JMP RETURN))
; unreachable code.
; (RETURN) (RETURN) == (RETURN)
; (BRA xx) (RETURN) == (BRA xx)
; (JMP xx) (RETURN) == (JMP xx)
#+ :ph-stat (incr :ph-ret1)
(rplac l (car ld) (cdr ld)))
((and (eq (caar ld) 'JCALL)
(not (memq (cadar ld) :no-jrst-hack)))
; (JCALL xx) (RETURN) == (JMP xx)
; sauf le cas particulier de #:llcp:nlist
#+ :ph-stat (incr :ph-ret2)
(rplac l (car ld) (cdr ld))
(rplaca (car l) 'JMP))
((eq (caar ld) 'CALL)
; (CALL xx) (RETURN) == (BRA xx)
; pas de limitations pour les
; e'tiquettes locales.
#+ :ph-stat (incr :ph-ret3)
(rplac l (car ld) (cdr ld))
(rplaca (car l) 'BRA))
(t #+ :ph-stat (incr :ph-ret4)
(setq l ld))))
;
; ADJSTK
;
;
((and (eq (car la) 'ADJSTK)
(consp (car ld))
(eq (caar ld) 'ADJSTK)
(consp (cadr la))
(eq (caadr la) 'QUOTE)
(fixp (cadadr la))
(consp (cadar ld))
(eq (caadar ld) 'QUOTE)
(fixp (cadr (cadar ld))))
; (ADJSTK 'n) (ADJSTK 'n)
#+ :ph-stat (incr :ph-adj1)
(rplaca (cdadar ld)
(add (cadadr la) (cadr (cadar ld))))
(rplac l (car ld) (cdr ld)))
;
; une adresse de branchement
;
((and (fixp (setq et1 (car (last (cdr la)))))
(neq et1 :ret)
(setq et2 (cassq et1 :aph)))
; (Byyy .. xx) == (Byyy .. zz)
#+ :ph-stat (incr :ph-tns1)
(rplaca (last la)
(cond ((eq et2 :ret) (setq :retp t) :ret)
((eq et2 :loop) (setq :loopp t) :loop)
(t et2))))
; pas d'optmisations a` faire
;
(t (setq l ld))))
(when :retp
; j'ai utilise' l'e'tiquette "return" :ret
(setq lap (mcons '(return) :ret lap)))
(when :loopp
; j'ai utilise' l'e'tiquette "loop" :loop
(setq lap (mcons `(bra ,:loop) :loop lap)))
#+ :ph-debug (:voir-lap lap)
#+ :ph-stat (incr :ph-len2 (length lap))
lap))