; .EnTete "Le-Lisp (c) version 15.2" " " "Le Compilateur Standard"
; .EnPied " " "%" " "
; .sp 2
; .SuperTitre "Le Compilateur 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: llcp.ll,v 4.2 88/04/06 15:44:57 kuczynsk Rel213 $"
(unless (>= (version) 15.2)
(error 'load 'erricf 'llcp))
; Tous les symboles pre'fixe's par : seront cre'e's dans le package LLCP.
(defvar #:sys-package:colon 'llcp)
(add-feature 'compiler)
; Compilateur LLM3 : traduction d'une (ou plusieurs) fonction Le-Lisp,
; pre'sente en me'moire, en une liste d'instructions LLM3 pre'vue pour
; e↑tre charge'e en me'moire par le chargeur : LAPxxx.LL
; Il est e'galement capable de compiler un fichier ou bien l'ensemble
; des fonctions pre'sentes en me'moire.
;
; Ce compilateur suppose charge' :
; - un chargeur/assembleur me'moire LAPxxx
; - le fichier de de'finition des macros du compilateur : ../llib/cpmac.ll
; - l'optimiseur standard : ../llib/peephole.ll
; Ce compilateur est minimum, mono-passe, avec de le'gers retours
; arrie`res et totalement (sauf en mode #:compiler:open-p) compatible
; avec l'interpre`te. En particulier la liaison des variables est
; toujours dynamique. Pour une compilation plus rapide, il faut
; utiliser COMPLICE qui re'alise une analyse d'un ensemble de fonctions
; pour permettre une compilation lexicale.
; LLCP re'alise une allocation de registres minimum.
; .Section "De'clarations"
; .SSection "Les variables globales externes du compilateur"
; #:compiler:open-p : indique que les compilations open
; (voir la section suivante) sont autorise'es.
; Une compilation open peut donner des re'sultats
; diffe'rents de ceux de l'interpre`te en cas de mauvais type d'arguments.
(defvar #:compiler:open-p t)
; .SSection "Les variables globales de debug du compilateur
; Quand l'indicateur suivant est positionne' LLCP calcule
; un certain nombre de statistiques pour juger de l'inte're↑t
; de certaines optimisations.
(unless (boundp ':stat-flag)
(defvar :stat-flag ()))
#+:stat-flag (defvar :stat-exp 0.)
#+:stat-flag (defvar :stat-exp0 0.)
#+:stat-flag (defvar :stat-exp1 0.)
#+:stat-flag (defvar :stat-expif 0.)
#+:stat-flag (defvar :stat-expsel 0.)
#+:stat-flag (defvar :stat-expoa 0.)
#+:stat-flag (defvar :stat-expwu 0.)
#+:stat-flag (defvar :stat-exprep 0.)
#+:stat-flag (defvar :stat-expp1 0.)
#+:stat-flag (defvar :stat-exppr 0.)
#+:stat-flag (defvar :stat-expsq 0.)
#+:stat-flag (defvar :stat-expnx 0.)
#+:stat-flag (defvar :stat-expfa1 0.)
#+:stat-flag (defvar :stat-open 0.)
#+:stat-flag (defvar :stat-macex 0.)
#+:stat-flag (defvar :stat-open0 0.)
#+:stat-flag (defvar :stat-open1 0.)
#+:stat-flag (defvar :stat-open2 0.)
#+:stat-flag (defvar :stat-open3 0.)
#+:stat-flag (defvar :stat-open31 0.)
#+:stat-flag (defvar :stat-open32 0.)
#+:stat-flag (defvar :stat-open4 0.)
#+:stat-flag (defvar :stat-open41 0.)
#+:stat-flag (defvar :stat-open42 0.)
#+:stat-flag (defvar :stat-open5 0.)
#+:stat-flag (defvar :stat-open51 0.)
#+:stat-flag (defvar :stat-open52 0.)
#+:stat-flag (defvar :stat-open6 0.)
#+:stat-flag (defvar :stat-open61 0.)
#+:stat-flag (defvar :stat-open62 0.)
#+:stat-flag (defvar :stat-subr 0.)
#+:stat-flag (defvar :stat-subr0 0.)
#+:stat-flag (defvar :stat-subr1 0.)
#+:stat-flag (defvar :stat-subr2 0.)
#+:stat-flag (defvar :stat-subr3 0.)
#+:stat-flag (defvar :stat-subrn 0.)
#+:stat-flag (defvar :stat-subrn0 0.)
#+:stat-flag (defvar :stat-subrn1 0.)
#+:stat-flag (defvar :stat-subrn2 0.)
#+:stat-flag (defvar :stat-subrn3 0.)
#+:stat-flag (defvar :stat-subrn4 0.)
#+:stat-flag (defvar :stat-subrf 0.)
#+:stat-flag (defvar :stat-subrp 0.)
#+:stat-flag (defvar :stat-exp-any 0.)
#+:stat-flag (defvar :stat-exp-any1 0.)
#+:stat-flag (defvar :stat-exp-any2 0.)
#+:stat-flag (defvar :stat-exp-2 0.)
#+:stat-flag (defvar :stat-exp-20 0.)
#+:stat-flag (defvar :stat-exp-21 0.)
#+:stat-flag (defvar :stat-exp-3 0.)
#+:stat-flag (defvar :stat-exp-30 0.)
#+:stat-flag (defvar :stat-exp-31 0.)
#+:stat-flag (defvar :stat-pred 0.)
#+:stat-flag (defvar :stat-pred1 0.)
#+:stat-flag (defvar :stat-pred2 0.)
#+:stat-flag (defvar :stat-pred3 0.)
#+:stat-flag (defvar :stat-pred4 0.)
#+:stat-flag (defvar :stat-pred5 0.)
#+:stat-flag (defvar :stat-pred6 0.)
#+:stat-flag (defvar :stat-pred7 0.)
#+:stat-flag (defvar :stat-pred8 0.)
#+:stat-flag (defvar :stat-predlist2 0.)
#+:stat-flag (defvar :stat-predlist3 0.)
#+:stat-flag (defvar :stat-predlist31 0.)
#+:stat-flag (defvar :stat-predlist32 0.)
#+:stat-flag (defvar :stat-diropreg 0.)
#+:stat-flag (defvar :stat-diropreg0 0.)
#+:stat-flag (defvar :stat-diropreg1 0.)
#+:stat-flag (defvar :stat-diropreg2 0.)
#+:stat-flag (defvar :stat-diropreg3 0.)
#+:stat-flag (defvar :stat-diropreg4 0.)
#+:stat-flag (defvar :stat-dirop 0.)
#+:stat-flag (defvar :stat-dirop-nil 0.)
#+:stat-flag (defvar :stat-dirop-a1 0.)
#+:stat-flag (defvar :stat-dirop-a2 0.)
#+:stat-flag (defvar :stat-dirop-a3 0.)
#+:stat-flag (defvar :stat-dirop-a4 0.)
#+:stat-flag (defvar :stat-dirop-t 0.)
#+:stat-flag (defvar :stat-dirop-symb 0.)
#+:stat-flag (defvar :stat-dirop-atom 0.)
#+:stat-flag (defvar :stat-dirop-cons 0.)
#+:stat-flag (defvar :stat-dirop-quote 0.)
#+:stat-flag (defvar :stat-dirop-cd 0.)
#+:stat-flag (defvar :stat-dirop-cd1 0.)
#+:stat-flag (defvar :stat-dirop-rate 0.)
#+:stat-flag (defvar :stat-diropordest 0.)
#+:stat-flag (defvar :stat-diroporany 0.)
#+:stat-flag (defvar :stat-diroporany1 0.)
#+:stat-flag (defvar :stat-diroporany2 0.)
#+:stat-flag (defvar :stat-diroporany3 0.)
#+:stat-flag (defvar :stat-diroporany4 0.)
#+:stat-flag (de :stat-print ()
(print "Nb d'appel EXP " :stat-exp)
(print " Nb d'appel EXP0 " :stat-exp0)
(print " Nb d'appel EXP1 " :stat-exp1)
(print " Nb d'appel EXPIF " :stat-expif)
(print " Nb d'appel EXPSEL " :stat-expsel)
(print " Nb d'appel EXPOA " :stat-expoa)
(print " Nb d'appel EXPWU " :stat-expwu)
(print " Nb d'appel EXPREP " :stat-exprep)
(print " Nb d'appel EXPP1 " :stat-expp1)
(print " Nb d'appel EXPPR " :stat-exppr)
(print " Nb d'appel EXPSQ " :stat-expsq)
(print " Nb d'appel EXPNX " :stat-expnx)
(print " Nb d'appel EXPFA1 " :stat-expfa1)
(print "Nb d'appel MACEXP " :stat-macex)
(print "Nb d'appel OPEN " :stat-open)
(print " Nb d'appel OPEN0 " :stat-open0)
(print " Nb d'appel OPEN1 " :stat-open1)
(print " Nb d'appel OPEN2 " :stat-open2)
(print " Nb d'appel OPEN3 " :stat-open3)
(print " Nb d'appel OPEN31 " :stat-open31)
(print " Nb d'appel OPEN32 " :stat-open32)
(print " Nb d'appel OPEN4 " :stat-open4)
(print " Nb d'appel OPEN41 " :stat-open41)
(print " Nb d'appel OPEN42 " :stat-open42)
(print " Nb d'appel OPEN5 " :stat-open5)
(print " Nb d'appel OPEN51 " :stat-open51)
(print " Nb d'appel OPEN52 " :stat-open52)
(print " Nb d'appel OPEN6 " :stat-open6)
(print " Nb d'appel OPEN61 " :stat-open61)
(print " Nb d'appel OPEN62 " :stat-open62)
(print)
(print "Nb d'appel SUBR " :stat-subr)
(print " Nb d'appel SUBR0 " :stat-subr0)
(print " Nb d'appel SUBR1 " :stat-subr1)
(print " Nb d'appel SUBR2 " :stat-subr2)
(print " Nb d'appel SUBR3 " :stat-subr3)
(print " Nb d'appel SUBRN " :stat-subrn)
(print " Nb d'appel SUBRN0 " :stat-subrn0)
(print " Nb d'appel SUBRN1 " :stat-subrn1)
(print " Nb d'appel SUBRN2 " :stat-subrn2)
(print " Nb d'appel SUBRN3 " :stat-subrn3)
(print " Nb d'appel SUBRN4 " :stat-subrn4)
(print " Nb d'appel SUBRF " :stat-subrf)
(print " Nb d'appel PARANO " :stat-subrp)
(print)
(print "Nb d'appel EXP-ANY " :stat-exp-any)
(print " Nb d'appel EXP-ANY1 " :stat-exp-any1)
(print " Nb d'appel EXP-ANY2 " :stat-exp-any2)
(print)
(print "Nb d'appel EXP-2 " :stat-exp-2)
(print " Nb d'appel EXP-20 " :stat-exp-20)
(print " Nb d'appel EXP-21 " :stat-exp-21)
(print)
(print "Nb d'appel EXP-3 " :stat-exp-3)
(print " Nb d'appel EXP-30 " :stat-exp-30)
(print " Nb d'appel EXP-31 " :stat-exp-31)
(print)
(print "Nb d'appel PRED " :stat-pred)
(print " Nb d'appel PRED1 " :stat-pred1)
(print " Nb d'appel PRED2 " :stat-pred2)
(print " Nb d'appel PRED3 " :stat-pred3)
(print " Nb d'appel PRED4 " :stat-pred4)
(print " Nb d'appel PRED5 " :stat-pred5)
(print " Nb d'appel PRED6 " :stat-pred6)
(print " Nb d'appel PRED7 " :stat-pred7)
(print " Nb d'appel PRED8 " :stat-pred8)
(print " Nb d'appel PREDLIST2 " :stat-predlist2)
(print " Nb d'appel PREDLIST3 " :stat-predlist3)
(print " PREDLIST31 " :stat-predlist31)
(print " PREDLIST32 " :stat-predlist32)
(print "Nb d'appel DIROPREG " :stat-diropreg)
(print " Nb d'appel DIROPREG0 " :stat-diropreg0)
(print " Nb d'appel DIROPREG1 " :stat-diropreg1)
(print " Nb d'appel DIROPREG2 " :stat-diropreg2)
(print " Nb d'appel DIROPREG3 " :stat-diropreg3)
(print " Nb d'appel DIROPREG4 " :stat-diropreg4)
(print "Nb d'appel DIROP " :stat-dirop)
(print " Nb DIROP-NIL " :stat-dirop-nil)
(print " Nb DIROP-A1 " :stat-dirop-a1)
(print " Nb DIROP-A2 " :stat-dirop-a2)
(print " Nb DIROP-A3 " :stat-dirop-a3)
(print " Nb DIROP-A4 " :stat-dirop-a4)
(print " Nb DIROP-T " :stat-dirop-t)
(print " Nb DIROP-SYMB " :stat-dirop-symb)
(print " Nb DIROP-ATOM " :stat-dirop-atom)
(print " Nb DIROP-CONS " :stat-dirop-cons)
(print " Nb DIROP-QUOTE " :stat-dirop-quote)
(print " Nb DIROP-CD " :stat-dirop-cd)
(print " Nb DIROP-CD1 " :stat-dirop-cd1)
(print " Nb DIROP-RATE " :stat-dirop-rate)
(print "Nb d'appel DIROPORDEST " :stat-diropordest)
(print "Nb d'appel DIROPORANY " :stat-diroporany)
(print " Nb d'appel DIROPORANY1 " :stat-diroporany1)
(print " Nb d'appel DIROPORANY2 " :stat-diroporany2)
(print " Nb d'appel DIROPORANY3 " :stat-diroporany3)
(print " Nb d'appel DIROPORANY4 " :stat-diroporany4)
)
; .SSection "Autres variables (pour rendre Complice heureuse ...)"
(defvar :A1 ())
(defvar :A2 ())
(defvar :A3 ())
(defvar :A4 ())
(defvar :deep ())
(defvar :lex ())
(defvar :lap ())
(defvar #:ld:talkp ())
(defvar :list-commutp ; liste des fonctions commutatives
'(ADD MUL FADD FMUL LOGAND LOGOR LOGXOR
EQ EQUAL))
(defvar :list-subr-open '( ; voir la fonction :expsubr-open
(IDENTITY 0 ())
(CAR 1 CAR)
(CDR 1 CDR)
(VLENGTH 2 HGSIZE)
(SLEN 2 HGSIZE)
(ADD 3 PLUS)
(SUB 3 DIFF)
(MUL 3 TIMES)
(DIV 3 QUO)
(REM 3 REM)
(FADD 3 FPLUS)
(FSUB 3 FDIFF)
(FMUL 3 FTIMES)
(FDIV 3 FQUO)
(LOGAND 3 LAND)
(LOGOR 3 LOR)
(LOGXOR 3 LXOR)
(LOGSHIFT 3 LSHIFT)
(VREF 4 HPXMOV)
(SREF 4 HBXMOV)
(RPLACA 5 CAR)
(RPLACD 5 CDR)
(VSET 6 HPMOVX)
(SSET 6 HBMOVX)))
; .SSection "Les macros du compilateur spe'cifiques"
(unless (featurep 'complice)
; Pour ne pas perturber Complice.
(defmacro-open NEXTL (var1 . var2)
; c'est une forme spe'ciale de ce compilateur
()))
; .Section "Les Fonctions de lancement du compilateur"
; .SSection "Les fonctions de compilation simple"
(df dont-compile #:system:l
; pose l'indicateur "dont-compile" sur les symboles de l
(while #:system:l (putprop (nextl #:system:l) t 'dont-compile)))
(dmd compile (:xrefnt . :i)
; (compile foo t/nil t/nil t/nil)
; la version sans quote de la fonction suivante.
`(compiler ',:xrefnt ',(car :i) ',(cadr :i) ',(caddr :i)))
(de compiler (:xrefnt . :l)
; <:xrefnt> liste des fonctions a` compiler
; <:l> les indicateurs optionnels
(let ((:all-p) (:talkp) (#:ld:talkp))
; <:all-p> liste des fonctions a` ne pas compiler
; <:talkp> le compilateur raconte sa vie
; <#:ld:talkp> le chargeur raconte sa vie.
(when (consp :l) (setq :all-p (nextl :l)))
(when (consp :l) (setq :talkp (nextl :l)))
(when (consp :l) (setq #:ld:talkp (nextl :l)))
;
(:compileready)
; la compilation proprement dite
(while :xrefnt
(when (or :talkp (debug))
(princn #/;)
(print (car :xrefnt) " se compile."))
(setq :l (:compiledef (nextl :xrefnt)))
(loader :l #:ld:talkp))
(loader '((END))))
:xrefnt)
(de compilefiles (lfilesin fileout)
; compile la liste des fichiers <lfilesin> dans le fichier <fileout>
(let ((llist))
(when (atom lfilesin)
(setq lfilesin (list lfilesin)))
(mapc (lambda (f)
(let ((#:sys-package:colon #:sys-package:colon))
(unless (probefile f)
(if (probefile (catenate f #:system:lelisp-extension))
(setq f (catenate f #:system:lelisp-extension))
(error 'compilefiles 'errfile f)))
(with ((inchan (openi f)))
(untilexit eof
; doit expanser la lecture
(let ((l (#:compiler:macroexpand (read))))
#+:stat-flag (incr :stat-macex)
(eval l)
(when (consp l)
(:compilefile-intrf l)))))))
lfilesin)
(:compilerout fileout (nreverse llist) () ())))
(de :compilefile-intrf (l)
; l est la valeur expanse'e d'une forme lue
; rajoute dans la variable "llist" le nom des
; fonctions a` compiler ou bien l tel quel si ce
; n'est pas une fonction compilable.
(cond ((memq (car l) '(de defun df dm dmd defmacro))
(newl llist (cadr l)))
((and (eq (car l) 'setfn) (consp (cadr l)) (eq (caadr l) 'quote))
(newl llist (cadadr l)))
((eq (car l) 'progn)
(mapc ':compilefile-intrf (cdr l)))
(t (newl llist l))))
(de :compilerout (:filout :xrefnt :all-p :talkp)
; <:xrefnt> liste des fonctions a` compiler (ou d'expressions)
; <:all-p> liste des fonctions a` ne pas compiler
;
(setq :talkp ())
(:compileready)
(let ((#:system:print-for-read t))
(with ((obase 10)
(printlevel 1000)
(printlength 30000))
(output :filout)
; la compilation proprement dite
(let ((:xrefnt :xrefnt))
(while :xrefnt
(let ((f (nextl :xrefnt)))
; le nextl doit e↑tre fait avant la compilation!
(if (null (symbolp f))
(print f)
(print `(loader ',(:compiledef f) ()))))))
(print '(loader '((end))))
(output ()))))
(de :compileready ()
; pre'pare les variables et les indicateurs
; pour compiler la liste de fonctions :xrefnt.
; s'il n'y a qu'une seule fonction a` compiler.
(when (and :xrefnt (symbolp :xrefnt))
(setq :xrefnt (list :xrefnt)))
; les fonctions a` ne pas compiler
(when (consp :all-p)
(mapc (lambda (x) (putprop x t 'dont-compile)) :all-p))
; les 1ers indicateurs
(let ((:l :xrefnt))
(while :l
(if (symbolp (car :l))
(if (:compilindic (car :l))
(nextl :l)
(setq :xrefnt (delq (nextl :l) :xrefnt)))
(nextl :l)))))
; .SSection "Fonction de compilation de toute l'oblist"
(de compile-all-in-core i
; compile tout ce qui se trouve de compilable dans l'oblist!
; et la nettoie un brin.
; D'abord les EXPR/FEXPR (si les macros les utilisent)
(let ((i1 (car i)) (i2 (cadr i)))
(compiler (maploblist (lambda (x)
(remprop x '#:system:loaded-from-file)
(and (null (getprop x 'dont-compile))
(memq (or (car (getprop x 'resetfn))
(typefn x))
'(EXPR FEXPR)))))
t
i1
i2)
; Puis toutes les macros sans risque.
(compiler (maploblist (lambda (x)
(remprop x '#:system:loaded-from-file)
(and (null (getprop x 'dont-compile))
(memq (or (car (getprop x 'resetfn))
(typefn x))
'(MACRO DMACRO)))))
t
i1
i2)))
; .SSection "Les fonctions de lancement du compilateur"
(de :compilindic (:fnt)
; pose tous les indicateurs de la fonction <:fnt> :
; :fval la fval (accessible par :getfval)
; :ftype le type (accessible par :getftype/:setftype)
; qui n'est pas encore compile'e (mais ca ne va pas tarder)
; retourne () si la fonction ne peut pas e↑tre compile'e
; et T si c'est une EXPR/FEXPR/MACRO/DMACRO qui peut l'e↑tre.
(if (getprop :fnt 'resetfn)
(let (((typefn . valfn) (getprop :fnt 'resetfn)))
(remprop :fnt 'resetfn)
(:compilindicaux :fnt typefn valfn))
(:compilindicaux :fnt (typefn :fnt) (valfn :fnt))))
(de :compilindicaux (:fnt typefn valfn)
(putprop :fnt valfn ':fval)
(cond ((eq typefn 'EXPR)
(let ((larg (car valfn)))
(cond
((null larg)
(:setftype :fnt 'SUBR0))
((symbolp larg)
(:setftype :fnt 'NSUBR))
((and (null (cdr larg)) (variablep (car larg)))
(:setftype :fnt 'SUBR1))
((and (consp (cdr larg)) (null (cddr larg))
(variablep (car larg))
(variablep (cadr larg)))
(:setftype :fnt 'SUBR2))
((and (consp (cdr larg)) (consp (cddr larg))
(null (cdddr larg)) (variablep (car larg))
(variablep (cadr larg))
(variablep (caddr larg)))
(:setftype :fnt 'SUBR3))
(T (:setftype :fnt 'NSUBR)) )))
((eq (typefn :fnt) 'FEXPR)
(:setftype :fnt 'FSUBR))
((eq (typefn :fnt) 'MACRO)
(:setftype :fnt 'MSUBR))
((eq (typefn :fnt) 'DMACRO)
(:setftype :fnt 'DMSUBR))
(t (:warning ":COMPILINDIC" "fonction de type" (typefn :fnt))
())))
(de :compiledef (sym)
; compile et charge une fonction de nom <sym>
(let ((fval (:getfval sym)) ; la fval a` compiler.
(aux1) ; variable globale de tout le ge'ne'rateur.
(aux2) ; variable globale de tout le ge'ne'rateur.
(aux3)) ; variable globale de tout le ge'ne'rateur.
(selectq (:getftype sym)
(SUBR0 (:compilefnt sym (car fval) (cdr fval)
`((FENTRY ,sym SUBR0)
(MOV (@ ,sym) A4)
(JCALL :CBIND0))
() () () () ))
(SUBR1 (:compilefnt sym (car fval) (cdr fval)
`((FENTRY ,sym SUBR1)
(MOV (@ ,sym) A4)
(MOV ',(car fval) A3)
(JCALL :CBIND1))
(caar fval) () () () ))
(SUBR2 (:compilefnt sym (car fval) (cdr fval)
`((FENTRY ,sym SUBR2)
(MOV (@ ,sym) A4)
(MOV ',(car fval) A3)
(JCALL :CBIND2))
(caar fval) (cadar fval) () () ))
(SUBR3 (:compilefnt sym (car fval) (cdr fval)
`((FENTRY ,sym SUBR3)
(PUSH (@ ,sym))
(MOV ',(car fval) A4)
(JCALL :CBIND3))
(caar fval)
(cadar fval)
(caddar fval) () ))
(NSUBR (:compilefnt sym (car fval) (cdr fval)
`((FENTRY ,sym NSUBR)
(MOV (@ ,sym) A2)
(MOV ',(car fval) A3)
(JCALL :CBINDN))
() () () ()))
((FSUBR MSUBR DMSUBR)
(:compilefnt sym (car fval) (cdr fval)
`((FENTRY ,sym ,(:getftype sym))
(MOV (@ ,sym) A2)
(MOV ',(car fval) A3)
(JCALL :CBINDS))
() () () () ))
(t (:error (list ":COMPILEFNT " sym
" type " (:getftype sym)))))))
(de :compilefnt (:fnt :larg l :headlap :A1 :A2 :A3 :A4)
; fonction de compilation principale, retourne une liste d'instructions.
; <:fnt> : est le nom de la fonction
; <:larg> : est la liste d'arguments de la fonction
; <l> : est le corps a` compiler
; <:headlap> : le de'but de la liste LAP
; <:A1> : le contenu actuel de A1
; <:A2> : le contenu actuel de A2
; <:A3> : le contenu actuel de A3
; <:A4> : le contenu actuel de A4
(let ((:deep 0) ; profondeur actuelle de la pile
(:lap ()) ; liste (inverse des instructions)
(:lex ()) ; environnement lexical de compilation
(:gencount 1000)) ; pour le ge'ne'rateur d'e'tiquettes
(when :talkp (pprint (mcons 'de :fnt :larg l)))
(:progn-last l 'A1 ())
(setq :lap (nreverse (#:compiler:peephole :lap)))
(setq :lap (append :headlap :lap))
(when (and :talkp (not #:ld:talkp))
(terpri)
(pprint :lap))
(when (neq :deep 0)
(:error "DEEP"))
:lap))
; .SSection "Les erreurs du compilateur"
; Il y a trois types d'erreurs :
; - :ERROR les erreurs graves internes du compilateur; il n'y a
; rien a` faire d'autre que de debugger le compilateur ...
; - :RERROR les erreurs durant des appels internes de EVAL. Le
; compilateur n'est pas mort mais je ne sais pas quoi compiler.
; - :WARNING il y a un proble`me : le code resultant risque de ne pas
; marcher ou de marcher differemment que l'interprete.
; Ce type d'erreur n'est visible qu'en mode DEBUG.
; le nom de la fonction en cours de compilation (s'il existe)
(defvar :fnt ())
(de :error (f . lmsg)
; erreur grave du compilateur lui-me↑me ...
(with ((outchan ()))
(when (debug)
(print)
(print ";***** ERREUR INTERNE DU COMPILATEUR LLCP")
(print "; veuillez envoyer ce message a` :")
(print "; ..!mcvax!inria!lelisp")
(print "; avec la fonction en cours de compilation.")
(print)
(print "; type de l'erreur " f)
(print "; arguments defectueux " lmsg)
(print "; dans la compilation de " :fnt)
(print "; contenu des registres "
(list :A1 :A2 :A3 :A4))
(print "; etat de la pile " :deep)
(print "; environnement lexical " :lex)
(print "; fin des instructions "
(reverse (firstn 20 :lap))))))
(de :rerror (l)
; une erreur s'est produite dans un appel
; de EVAL interne au compilateur
; (e.g. durant une macro-expansion).
; Doit retourner () pour pouvoir continuer.
(with ((outchan ()))
(print "***** Erreur durant la compilation.")
(print "***** La forme a compiler etait : " l)
(print "***** dans la fonction : " :fnt)
()))
(de #:compiler:macro-expand-error (l)
; erreur spe'cifique dans une macro-expansion
(:rerror l))
(de :warning (f msg arg)
; imprime un avertissement si on se trouve en mode "debug"
(with ((outchan ()))
(when (debug)
(princn #/;)
(print f " dans " :fnt " : " msg " : " arg))))
; .Section "Les Fonctions de ge'ne'ration du code"
; .SSection "Fonctions de chargement du code dans la liste :lap"
; Tout le code produit par le compilateur est emmagasine' dans la
; variable :lap qui est lie'e dans la fonction :compilefnt.
; A cause de l'utilisation de l'optimiseur "peephole"
; il est impossible d'engendrer les instructions :
; JCALL/CALL/ADJSTK
; sous forme de constante ainsi que des ope'rande de type :
; etiq
; (@ etiq)
; car le peephole est suceptible de les modifier physiquement !!
(de :add-code (l)
; ajoute a` <:lap> une instruction <l>
; le passage en DMD coute beaucoup en place et ne fait
; rien gagner en temps .... ne pas changer en DMD quoi.
(newl :lap l))
(de :call (x)
; rajoute un CALL
(newl :lap (list 'JCALL x)))
(de :mov (source dest)
; engendre une instruction MOV
(newl :lap (list 'MOV source dest)))
(de :movq (source dest)
; engendre une instruction MOV quote'e.
(newl :lap (list 'MOV (kwote source) dest)))
; .SSection "Gestion du contenu des registres"
; Le contenu actuel des registres est en permanence dans les
; variables :A1 :A2 :A3 :A4.
; Les fonctions qui suivent permettent de les ge'rer.
(de :cr (reg val)
; remet a` jour le contenu d'un registre
(selectq reg
(A1 (setq :A1 val))
(A2 (setq :A2 val))
(A3 (setq :A3 val))
(A4 (setq :A4 val))
(t (:error ":CR" reg val))))
(de :cr-all-nil ()
; remet a` () tous les contenus des registres
(setq :A1 () :A2 () :A3 () :A4 ()))
(de :cr-forget (symb)
; oublie qu'un registre peut contenir un symbole
; (a` utiliser apre`s un SETQ, NEXTL ...)
(when (eq :A1 symb) (setq :A1 ()))
(when (eq :A2 symb) (setq :A2 ()))
(when (eq :A3 symb) (setq :A3 ()))
(when (eq :A4 symb) (setq :A4 ())))
(de :cr-forget-cons ()
; oublie qu'un registre peut contenir une liste
; de la forme (CAR/CDR x)
; a` utiliser apre`s un RPLACA/RPLACD
(when (consp :A1) (setq :A1 ()))
(when (consp :A2) (setq :A2 ()))
(when (consp :A3) (setq :A3 ()))
(when (consp :A4) (setq :A4 ())))
(de :cr-list ()
; retourne la liste de tous les contenus actuels des registres
; sous la forme ((a1 . a2) . (a3 . a4))
(cons (cons :A1 :A2) (cons :A3 :A4)))
(de :cr-intersect-list (l)
; l est une liste de contenus (((a1.a2).(a3.a4))...((a1.a2).(a3.a4)))
; retourne l'intersection de tous ces contenus avec les
; contenus actuels.
(while (consp l)
(:cr-intersect (nextl l))))
(de :cr-intersect (l)
; mise a` jour des contenus de :A1 :A2 :A3 :A4
; avec les valeurs stocke'es dans <l>
; sous la forme ((a1.a2).(a3.a4))
(when (and :A1 (nequal (caar l) :A1)) (setq :A1 ()))
(when (and :A2 (nequal (cdar l) :A2)) (setq :A2 ()))
(when (and :A3 (nequal (cadr l) :A3)) (setq :A3 ()))
(when (and :A4 (nequal (cddr l) :A4)) (setq :A4 ())))
(de :cr-any-reg (reg)
; retourne un registre libre, directement supe'rieur a` <reg>
; et toujours diffe'rent de <reg>. Dans les plus mauvais cas
; on utilise A4.
(selectq reg
(A1 (if (null :A2) 'A2 (if (null :A3) 'A3 'A4)))
(A2 (if (null :A3) 'A3 'A4))
(t 'A4))))
; .SSection "Fonctions de gestion de la pile"
; Le compilateur tient a` jour le nombre d'objets qui ont e'te'
; empile's dans la variable :deep, pour pouvoir acce'der a` des
; valeurs empile'es au de'but de la fonction.
(dmd :return ()
; ajoute le code 'RETURN'
`(:add-code '(RETURN)))
(de :push (oper)
; empile l'operande
(:add-code (list 'PUSH oper))
(setq :deep (add1 :deep)))
(de :pushq (oper)
; empile un ope'rande quote'
(:add-code (list 'PUSH (kwote oper)))
(setq :deep (add1 :deep)))
(de :pop (oper)
; de'pile l'operande
(when (le :deep 0)
(:error ":POP" oper))
(:add-code (list 'POP oper))
(setq :deep (sub1 :deep)))
; .SSection "Gestion des ftypes propres au compilateur"
(dmd :setftype (sym val)
`(putprop ,sym ,val ':ftype))
(dmd :getftype (sym)
`(getprop ,sym ':ftype))
(dmd :getfval (sym)
`(getprop ,sym ':fval))
; .SSection "Gestion des types des ope'randes et des e'tiquettes locales"
(de :eqp (x)
; quelque chose sur lequel on peut faire CABEQ
(if (or (symbolp x) (fixp x))
t
()))
(de :quotep (x)
; teste s'il s'agit d'un objet self-evalue'.
(if (or (and (atomp x) (not (symbolp x)))
(eq x T)
(and (consp x) (eq (car x) 'quote)))
t
()))
(dmd :genlab ()
`(setq :gencount (add1 :gencount)))
; .SSection "Fonction de ge'ne'ration du code brut"
(de :exp (l dest :effectp)
; compile l'expression <l>
; le re'sultat se retrouve dans le registre <dest> (A1, A2, A3 ou A4)
; :effectp = T si on ne compile que pour les effets
;
#+:stat-flag (incr :stat-exp)
;
(cond
;
; chaque clause de ce COND doit mettre a` jour :
; - le contenu des registres (:A1 :A2 :A3 :A4)
;
; traite le cas de tous les atomes
;
((setq aux1 (:dirop l))
#+:stat-flag (incr :stat-exp0)
(if :effectp
(:warning ":EXPU" "valeur inutilisee" l)
(when (neq aux1 dest)
(:mov aux1 dest))
(:cr dest l)))
;
; le cas tragique des fonctions non symboliques
;
((not (symbolp (car l)))
#+:stat-flag (incr :stat-exp1)
(unless (eq dest 'A1) (exit not-in-A1))
(if (and (consp (car l)) (eq (caar l) 'LAMBDA))
(:app-lambda (cadar l) (cdr l) (cddar l))
(:parano ':exp "fonction calculee" (car l) l)))
;
; la grande se'rie des FSUBR
;
((eq (car l) 'IF)
; la fonction conditionnelle unique IF :
; tout est la` dedans (en to pan)
#+:stat-flag (incr :stat-expif)
(let ((et1 (:genlab)) ; e'tiquette du sinon
(et2 (:genlab)) ; e'tiquette du fin du IF
lcr ; contenu des registres apre`s alors
deep) ; :deep apre`s alors
; compilation du pre'dicat
(:pred (cadr l) () et1 dest)
(let ((:A1 :A1)
(:A2 :A2)
(:A3 :A3)
(:A4 :A4)
(:deep :deep))
; compilation du alors
(:exp (caddr l) dest :effectp)
(:add-code `(BRA ,et2))
(:add-code et1)
(setq lcr (:cr-list)
deep :deep))
; compilation du sinon.
(when (or (null :effectp) (cdddr l))
(:progn (cdddr l) dest :effectp))
(:add-code et2)
(when (neq :deep deep)
(:error 'if :deep deep))
(:cr-intersect lcr)))
((eq (car l) 'SELECTQ)
; le super-selecteur : pour des raisons de place c'est devenu
; une fonction inde'pendante mais sans argument.
#+:stat-flag (incr :stat-expsel)
(:selectq))
((memq (car l) '(AND OR))
; il s'agit de structure de contro↑le (pas de pre'dicat)
#+:stat-flag (incr :stat-expoa)
(let ((et1 (:genlab))
(type (eq (car l) 'AND)))
(let ((l (cdr l))
lcr
(inst (list (if type 'BTNIL 'BFNIL) dest et1)))
(while (consp (cdr l))
; au moins 2 e'le'ments
(:exp (nextl l) dest ())
(:add-code inst)
(newl lcr (:cr-list)))
(if (consp l)
; le dernier
(:exp (car l) dest ())
; pas d'arguments!
(:mov (if type ''T 'NIL) dest)
(:cr dest ()))
(:cr-intersect-list lcr)
(:add-code et1))))
((memq (car l) '(WHILE UNTIL))
; les boucles simples : les valeurs retourne'es
; sont conformes a` celles de l'interpre`te.
#+:stat-flag (incr :stat-expwu)
(let ((et1 (:genlab)) (et2 (:genlab)))
(:add-code `(BRA ,et2))
(:add-code et1)
(:cr-all-nil)
(:progn (cddr l) dest T)
(:add-code et2)
(:cr-all-nil)
(cond ((eq (car l) 'WHILE)
(:pred (cadr l) t et1 dest)
(unless :effectp
(:mov 'NIL dest)
(:cr dest ())))
(t ; c'est donc UNTIL
(if :effectp
(:pred (cadr l) () et1 dest)
(:exp (cadr l) dest ())
(:add-code `(BTNIL ,dest ,et1)))))
(:cr-all-nil)))
((eq (car l) 'REPEAT)
; le se'quenceur / compteur / de'cre'menteur
#+:stat-flag (incr :stat-exprep)
(let ((et1 (:genlab)) (et2 (:genlab)))
(:exp (cadr l) dest ())
(:add-code `(BRA ,et2))
(:add-code et1)
(:push dest)
(:cr-all-nil)
(:progn (cddr l) dest T)
(:pop dest)
(:add-code et2)
(:add-code `(SOBGEZ ,dest ,et1))
(unless :effectp
; REPEAT retourne T par de'faut.
(:movq 'T dest))
(:cr dest ())))
((eq (car l) 'PROG1)
; le se'quenceur spe'cial PROG1
#+:stat-flag (incr :stat-expp1)
(:expush (cadr l) dest)
(:progn (cddr l) dest T)
(:pop dest)
(:cr dest ()))
((eq (car l) 'PROGN)
; le se'quenceur PROGN ;
#+:stat-flag (incr :stat-exppr)
(:progn (cdr l) dest :effectp))
((eq (car l) 'SETQ)
; l'affectation SETQ multiple ;
#+:stat-flag (incr :stat-expsq)
(if (or :effectp (cdddr l))
; pas oblige' de charger "dest" avec la valeur.
(progn (:mov (setq aux1 (:diropordest (caddr l) dest))
`(CVALQ ,(cadr l)))
; on invalide les registres qui contenaient "var"
(:cr-forget (cadr l))
(when (and (symbolp aux1) (neq aux1 'nil))
(:cr aux1 (cadr l))))
; oblige' de charger "dest" avec la valeur.
(progn (:exp (caddr l) dest ())
(:mov dest `(CVALQ ,(cadr l)))
; on invalide les registres qui contenaient "var"
(:cr-forget (cadr l))
(:cr dest (cadr l))))
(when (cdddr l)
; SETQ multiple
(:exp (cons 'SETQ (cdddr l)) dest :effectp)))
((eq (car l) 'NEXTL)
; ce n'est pas une macro du compilateur mais
; une forme spe'ciale pour ne pas engendrer
; un PROG1 syste'matiquement.
#+:stat-flag (incr :stat-expnx)
(:exp (if :effectp
`(SETQ ,@(when (consp (cddr l))
`(,(caddr l) (CAR ,(cadr l))))
,(cadr l) (CDR ,(cadr l)))
`(PROG1 ,(if (consp (cddr l))
`(SETQ ,(caddr l) (CAR ,(cadr l)))
`(CAR ,(cadr l)))
(SETQ ,(cadr l) (CDR ,(cadr l)))))
dest
:effectp))
((eq (car l) 'COMMENT)
(unless :effectp
(:movq (car l) dest)
(:cr dest ())))
((eq (car l) 'LAMBDA)
; lambda explicite (comme dans les MAPs et autres fonctionnelles)
; en attendant de remonter le type de la fonction engendre'e
(let ((f (symbol (packagecell :fnt)
(concat :fnt "-lambda-" (gensym)))))
(setfn f 'EXPR (cdr l))
(when (:compilindic f)
(newl :xrefnt f))
(:movq f dest)
(:cr dest ())))
;
; le pre'compilateur ?
;
((eq (car l) 'PRECOMPILE)
(let ((l (caddr l)))
(while (consp l) (:add-code (nextl l))))
(eval (cadddr l))
(let ((l (cddddr l)))
(when l
(unless :effectp
(when (neq (car l) dest)
(:mov (car l) dest))
(:cr dest ())))))
;
; essayons donc les macros
;
((neq l (setq aux1 (#:compiler:macroexpand l)))
#+:stat-flag (incr :stat-macex)
(:exp aux1 dest :effectp))
;
; les fonctions SUBR open
;
((and #:compiler:open-p
(setq aux1 (cassq (car l) :list-subr-open)))
(:expsubr-open (cdr l) (car aux1) (cadr aux1)))
;
((neq dest 'A1)
; on ne va pas plus loin si dest <> A1
(exit not-in-A1))
;
; les fonctions de contro↑le chevelues (dans A1)
; avec appel de modules de l'interpre`te et fabrication
; d'un bloc d'activation spe'cial.
;
((memq (car l) '(TAG EVTAG))
; les e'chappements simples/calcule's
#+:stat-flag (incr :stat-expfa1)
(if (eq (car l) 'evtag)
(:exp (cadr l) 'A1 ())
(:movq (cadr l) 'A1)
(:cr 'A1 ()))
(:specforminter ':TAG 'TAG))
((eq (car l) 'EXIT)
; retour d'un e'chappement simple
#+:stat-flag (incr :stat-expfa1)
(:progn (cddr l) 'A1 () )
(:movq (cadr l) 'A2)
(:add-code '(JMP :EXIT))
(:cr-all-nil))
((eq (car l) 'EVEXIT)
; retour d'un e'chappement calcule'
#+:stat-flag (incr :stat-expfa1)
(:expush (cadr l) 'A1)
(:progn (cddr l) 'A1 () )
(:pop 'A2)
(:add-code '(JMP :EXIT))
(:cr-all-nil))
((eq (car l) 'PROTECT)
#+:stat-flag (incr :stat-expfa1)
(let ((et1 (:genlab))
(et2 (:genlab))
(:deep :deep)
(:lex (cons 'PROTECT :lex)))
(:push `(@ ,et2))
(setq :deep (add :deep 2)) ; :PROT
(:mov `(@ ,et1) 'A3)
(:add-code (list 'JCALL ':PROT))
(:cr-all-nil)
(:pop 'A1)
(:push 'A3)
(:push 'A1)
(:push 'A2)
(:progn (cddr l) 'A1 T)
(:add-code '(POP A2))
(:add-code '(POP A1))
(:return)
(:add-code et1)
(:cr-all-nil)
(:exp (cadr l) 'A1 ())
(:return)
(:add-code et2)))
((eq (car l) 'LOCK)
; les verrouillages
#+:stat-flag (incr :stat-expfa1)
(:exp (cadr l) 'A1 ())
(:specforminter ':LOCK 'LOCK))
((eq (car l) 'SCHEDULE)
; les se'quenceurs
#+:stat-flag (incr :stat-expfa1)
(:exp (cadr l) 'A1 ())
(:specforminter ':SCHEDULE 'SCHEDULE))
((eq (car l) 'BLOCK)
; les se'quenceurs
#+:stat-flag (incr :stat-expfa1)
(:movq (cadr l) 'A1)
(:specforminter ':BLOCK 'BLOCK))
((eq (car l) 'RETURN-FROM)
; retour d'un se'quenceur lexical (idem a` EXIT)
#+:stat-flag (incr :stat-expfa1)
(when (not (memq 'BLOCK :lex))
(:warning ":RETURN-FROM" "pas de portee lexicale" l))
(:progn (cddr l) 'A1 ())
(:movq (cadr l) 'A2)
(:add-code '(JMP :RETFROM))
(:cr-all-nil))
((eq (car l) 'TAGBODY)
; fabrique un corps de PROG et ge`re les e'tiquettes.
#+:stat-flag (incr :stat-expfa1)
(let ((:deep :deep) ; rien ne bouge apres le TAGBODY
(et (:genlab)) ; adresse fin de corps
al) ; la A-liste des e'tiquettes locales
(:push `(@ ,et))
; fabrication du bloc de contro↑le TAGBODY
(let ((l (cdr l)) (n 0) et)
(while (consp l)
(when (atom (car l))
(setq et (:genlab))
(newl al (cons (car l) et))
(:push `(@ ,et))
(:pushq (car l))
(setq n (add1 n)))
(setq l (cdr l)))
(:pushq n))
(:add-code (list 'JCALL ':TAGBODY))
; compilation du corps
(let ((:lex (cons (list 'TAGBODY :deep al) :lex))
(l (cdr l)))
(while (consp l)
(if (consp (car l))
(:exp (car l) dest T)
(:add-code (cassq (car l) al))
(:cr-all-nil))
(setq l (cdr l)))
(if :effectp
; pour e'viter le pb du peephole qui enle`ve les
; (PUSH @ ret) du bloc de contro↑le :
(:add-code '(EVAL 'PEEPHOLE))
; la valeur de TAGBODY est toujours ()
(:mov 'NIL dest))
(:cr-all-nil)
; de'lie le bloc
(:return)
(:add-code et))))
((eq (car l) 'GO)
; branchement a` une e'tiquette lexicale.
#+:stat-flag (incr :stat-expfa1)
(cond ((and (consp (car :lex))
(eq (caar :lex) 'TAGBODY)
(assq (cadr l) (caddar :lex)))
(when (neq (sub :deep (cadar :lex)) 0)
(:add-code
`(ADJSTK (kwote (sub :deep (cadar :lex)))))
(setq :deep (cadar :lex)))
(:add-code `(BRA ,(cassq (cadr l) (caddar :lex)))))
(t ; pas assez visible
(:movq (cadr l) 'A1)
(:cr-all-nil)
(:add-code '(JMP :GO))))
(:cr-all-nil))
(T ;
; les fonctions standards de type xSUBR
;
(:expsubr)))
))
; .SSection "fonctions de ge'ne'ration des SUBRs"
(de :expsubr-open (larg type inst)
; compile "open" la liste d'arguments "larg"
; en utilisant l'instruction machine "inst"
; le type code' est retrouve' dans :list-subr-open
#+:stat-flag (incr :stat-open)
(selectq type
(0 ; SUBR1 LLM3-0 : IDENTITY
#+:stat-flag (incr :stat-open0)
(:exp (car larg) dest :effectp))
(1 ; SUBR1 LLM3-1 :CAR CDR
#+:stat-flag (incr :stat-open1)
(let ((op (:diropreg (car larg))))
(when (null op)
(setq op (:exp-any (car larg) dest ())))
; op contient un registre sur lequel faire CAR ou CDR
(:mov (list inst op) dest)
(:cr dest
; dest n'est charge' que s'il s'agit d'une forme
; de type (cxr s), (cxr (cxr s)) ou (cxr (cxr (cxr s)))
(if (or (symbolp (car larg))
(and (consp (car larg))
(memq (caar larg) '(CAR CDR))
(or (symbolp (cadar larg))
(and (consp (cadar larg))
(memq (caadar larg) '(CAR CDR))
(symbolp (cadr (cadar larg)))))))
(list inst (car larg))
()))))
(2 ; SUBR1 LLM3-2 :VLENGTH SLEN
#+:stat-flag (incr :stat-open2)
(:add-code (list inst (:diroporany (car larg) dest) dest))
(:cr dest ()))
(3 ; SUBR2 LLM3-2 : ADD SUB MUL DIV REM ...
#+:stat-flag (incr :stat-open3)
(cond ((atom (cadr larg))
#+:stat-flag (incr :stat-open31)
; cas simpliste : (dirop (cadr larg)) ne va pas car
; la compilation du (:exp suivant peut perturber le
; re'sultat du (:dirop (cadr suivant!
(:exp (car larg) dest ())
(:add-code (list inst (:dirop (cadr larg)) dest))
(:cr dest ()))
((neq dest 'A1) (exit not-in-A1))
(t #+:stat-flag (incr :stat-open32)
; dest = A1 avant d'appeler :exp-2.
(:exp-2 (car l) (car larg) (cadr larg))
(:add-code `(,inst A2 A1))
(:cr dest ()))))
(4 ; SUBR2 LLM3-3 : VREF SREF
#+:stat-flag (incr :stat-open4)
(cond ((and (setq aux1 (:dirop (car larg)))
(setq aux2 (:dirop (cadr larg))))
#+:stat-flag (incr :stat-open41)
(:add-code (list inst aux1 aux2 dest))
(:cr dest ()))
((neq dest 'A1) (exit not-in-A1))
(t #+:stat-flag (incr :stat-open42)
; dest = A1 avant d'appeler :exp-2.
(:exp-2 (car l) (car larg) (cadr larg))
(:add-code `(,inst A1 A2 A1))
(:cr dest ()))))
(5 ; SUBR2 LLM3-2 special : RPLACA RPLACD
#+:stat-flag (incr :stat-open5)
(cond ((and (symbolp (setq aux1 (:dirop (car larg))))
aux1 ; doit aussi e↑tre diffe'rent de ()
(setq aux2 (:dirop (cadr larg))))
#+:stat-flag (incr :stat-open51)
(:mov aux2 (list inst aux1))
(unless :effectp
(when (neq aux1 dest)
; retourne la liste modifie'e en valeur
(:mov aux1 dest)
(:cr dest aux1))))
((neq dest 'A1) (exit not-in-A1))
(t #+:stat-flag (incr :stat-open52)
; dest = A1 avant d'appeler :exp-2.
(:exp-2 (car l) (car larg) (cadr larg))
(:mov 'A2 (list inst 'A1))))
; pour de'sactiver les (CAR ..) dans les :Ax
(:cr-forget-cons))
(6 ; SUBR3 LLM3-3 : VSET SSET
#+:stat-flag (incr :stat-open6)
(cond ((and (setq aux1 (:dirop (car larg)))
(setq aux2 (:dirop (cadr larg)))
(setq aux3 (:dirop (caddr larg))))
#+:stat-flag (incr :stat-open61)
(:add-code (list inst aux3 aux1 aux2))
(when (and (symbolp aux3) (neq aux3 'nil))
(:cr aux3 ()))
(unless :effectp
(when (neq aux3 dest)
(:mov aux3 dest)
(:cr dest ()))))
((neq dest 'A1) (exit not-in-A1))
(t #+:stat-flag (incr :stat-open62)
; dest = A1 avant d'appeler :exp-3.
(:exp-3 (car larg) (cadr larg) (caddr larg))
(:add-code `(,inst A3 A1 A2))
(unless :effectp
(:mov 'A3 'A1)
(:cr 'A1 :A3)))))
(t (:error ":EXPSUBR-OPEN" (list l inst type)))))
(de :expsubr ()
;
; Les fonctions standards de type xSUBR.
; Fonctionne dans le me↑me contexte que la fonctionk :exp
; dest = A1 avant d'appeler :exp-2 ou 3.
;
#+:stat-flag (incr :stat-subr)
(selectq (or (:getftype (car l)) (typefn (car l)))
; les fonctions standards de type xSUBR ;
(SUBR0
#+:stat-flag (incr :stat-subr0)
(:call (car l)))
(SUBR1
#+:stat-flag (incr :stat-subr1)
(:exp (cadr l) 'a1 ())
(:call (car l)))
(SUBR2
#+:stat-flag (incr :stat-subr2)
(:exp-2 (car l) (cadr l) (caddr l))
(:call (car l)))
(SUBR3
#+:stat-flag (incr :stat-subr3)
(:exp-3 (cadr l) (caddr l) (cadddr l))
(:call (car l)))
(NSUBR
#+:stat-flag (incr :stat-subrn)
; pour avoir une ide'e du nb d'args des NSUBRs
#+:stat-flag (if (= (length l) 1) (incr :stat-subrn0))
#+:stat-flag (if (= (length l) 2) (incr :stat-subrn1))
#+:stat-flag (if (= (length l) 3) (incr :stat-subrn2))
#+:stat-flag (if (= (length l) 4) (incr :stat-subrn3))
#+:stat-flag (if (= (length l) 5) (incr :stat-subrn4))
(if (consp (cdr l))
; il y a au - 1 argument
(let ((narg 0)
(:deep :deep)
(fnt (car l))
(larg (cdr l))
(et (:genlab)))
(:push `(@ ,et))
(while (consp larg)
(:expush (nextl larg) 'A1)
(setq narg (add1 narg)))
(:movq narg 'A4)
(:add-code `(JMP ,fnt))
(:add-code et))
; pas d'arguments (plus simple)
(:add-code '(MOV '0 A4))
(:call (car l))))
(FSUBR
#+:stat-flag (incr :stat-subrf)
(:movq (cdr l) 'A1)
(:warning ":EXPSUBR" "appel d'une FSUBR" (car l))
(:call (car l)))
(T ; type de fonction inconnu ..
#+:stat-flag (incr :stat-subrp)
(if (numberp l)
; cas tragique des nbs e'tendus sous forme de TCONS
(:movq l 'A1)
(:parano ':expsubr "fonction inconnue" (car l) l))))
(:cr-all-nil))
(de :exp-any (l dest :effectp)
; compile <l> dans n'importe quel registre.
; retourne toujours un registre!
#+:stat-flag (incr :stat-exp-any)
(let ((destany (:cr-any-reg dest)))
(or (:backtrack (progn (:exp l destany :effectp)
#+:stat-flag (incr :stat-exp-any1)
destany)
())
(progn (:exp l dest :effectp)
#+:stat-flag (incr :stat-exp-any2)
dest))))
(de :exp-2 (fnt arg1 arg2)
; compile les 2 arguments 'arg1' et 'arg2' de la fonction 'fnt'
; dans A1 et A2 respectivement
; dest = toujours A1.
#+:stat-flag (incr :stat-exp-2)
(:backtrack (progn #+:stat-flag (incr :stat-exp-20)
(:exp arg1 'A1 ())
(:exp arg2 'A2 ()))
(progn #+:stat-flag (incr :stat-exp-21)
(:expush arg1 'A1)
(:exp arg2 'A1 ())
(if (memq fnt :list-commutp)
(progn (:pop 'A2)
(:cr 'A2 ()))
(progn (:mov 'A1 'A2)
(:cr 'A2 :A1)
(:pop 'A1)
(:cr 'A1 ()))))))
(de :exp-3 (arg1 arg2 arg3)
; compile les 3 arguments 'arg1' 'arg2' 'arg3'
; respectivement dans A1 A2 et A3.
; dest = toujours A1.
#+:stat-flag (incr :stat-exp-3)
(:backtrack ; A1 A2 A3 passent
(progn #+:stat-flag (incr :stat-exp-30)
(:exp arg1 'A1 ())
(:exp arg2 'A2 ())
(:exp arg3 'A3 ()))
; rien ne passe
(progn #+:stat-flag (incr :stat-exp-31)
(:expush arg1 'A1)
(:expush arg2 'A1)
(:exp arg3 'A1 ())
(:mov 'A1 'A3)
(:cr 'A3 :A1)
(:pop 'A2)
(:cr 'A2 ())
(:pop 'A1)
(:cr 'A1 ()))))
; .SSection "Autres fonctions de generation du code brut"
(de :specforminter (adr lex)
; appel la routine de l'interpre`te <adr>, modifie l'environnement
; lexical de compilation avec <lex>, puis compile un corps normal.
(let ((:lex (cons lex :lex)) ; nouvel env lexical du compilo
(:deep :deep) ; sauve la profondeur de la pile
(et (:genlab))) ; variable locale d'e'tiquette
(:push `(@ ,et))
(:add-code `(JCALL ,adr))
(:cr-all-nil)
(:progn-last (cddr l) 'A1 :effectp)
(:cr-all-nil)
(:add-code et)))
(de :parano (call msg arg l)
; quand j'ai vraiment tre`s peur pour compiler <l>
; et que j'appelle l'interpre`te.
(if (and :all-p
(symbolp (car l))
(null (getprop (car l) 'dont-compile))
(memq (typefn (car l)) '(EXPR FEXPR MACRO DMACRO)))
; je la rajoute dans la liste de EXTERNs
(progn
(when (:compilindic (car l))
(newl :xrefnt (car l)))
(:exp l dest :effectp))
(progn
(unless (and (symbolp (car l))
(getprop (car l) 'dont-compile))
(:warning call (catenate "PARANO : " msg) arg))
(let ((et (:genlab))
(:deep :deep))
(:push `(@ ,et))
(:pushq l)
(:movq 1 'A4)
(:add-code '(JMP EVAL))
(:add-code et))))
(:cr-all-nil))
(de :app-lambda (lvar lval body)
; compile un appel de LAMBDA (de type LET)
; <lvar> est l'arbre des variables
; <lval> est la liste des valeurs non e'value'es
; <body> le corps a` e'xecuter apre`s.
; fabrique un bloc d'activation, pre↑t pour :CBINDL
;
; en attendant de remonter le type de la fonction engendre'e
;
(let ((:deep :deep)
(:lex (cons 'lambda :lex))
(narg 0)
(et1 (:genlab))
(et2 (:genlab)))
(:add-code et1)
(:push `(@ ,et2))
(while (consp lval)
(:expush (nextl lval) 'A1)
(setq narg (add1 narg)))
(:movq narg 'A4)
(:mov `(@ ,et1) 'A2)
(:movq lvar 'A3)
(:add-code (list 'JCALL ':CBINDL))
(:cr-all-nil)
(:progn-last body 'A1 ())
(:cr-all-nil)
(:add-code et2)))
(de :selectq ()
; le spe'cialiste du SELECTQ (travaille dans le me↑me environnement
; que la fonction : :exp
; Tant qu'il n'y a pas de LET lexicaux il faudra en passer par la`!
(let ((selector (cadr l)) ; le se'lecteur
(etfin (:genlab)) ; e'tiquette de fin de SELECTQ
(indict ()) ; indicateur pre'sence de T
et1 ; e'tiquette de la clause suivante
lcr) ; liste des contenus des registres
; apres chaque clause
(:exp selector dest ()) ; le selecteur
(setq l (cddr l)) ; les clauses
(while (consp l)
(tag :selectq
(setq et1 (:genlab)) ; e'tiquette de la clause suivante
(cond
((atom (car l)) ; il faut vraiment une liste!
(:warning 'selectq "mauvaise clause" l)
(exit :selectq))
((eq (caar l) 't)
(setq indict t)) ; le 'otherwise' : juste le progn final
((:eqp (caar l))
; cas d'un test simple
(:add-code `(CABNE ,dest ,(kwote (caar l)) ,et1)))
((and (consp (caar l)) (every ':eqp (caar l)))
; cas d'un MEMQ ouvert
(let ((l (caar l)) (et2 (:genlab)))
(while (consp (cdr l))
(:add-code
`(CABEQ ,dest ,(kwote (nextl l)) ,et2)))
(:add-code `(CABNE ,dest ,(kwote (car l)) ,et1))
(:add-code et2)))
(t ; le cas EQUAL/MEMBER
(unless (eq dest 'A1) (exit not-in-A1))
(:push 'A1)
(:movq (caar l) 'A2)
(:add-code `(JCALL ,(if (atom (caar l)) 'EQUAL 'MEMBER)))
(:mov 'A1 'A2)
(:pop 'A1)
(:cr-all-nil)
(:add-code `(BTNIL A2 ,et1))))
; compilation du corps d'une clause
(let ((:A1 :A1)
(:A2 :A2)
(:A3 :A3)
(:A4 :A4))
(:progn (cdar l) dest :effectp)
(when (or (cdr l) (null (or indict :effectp)))
(:add-code `(BRA ,etfin)))
(newl lcr (:cr-list))))
(setq l (cdr l))
(:add-code et1))
; tenir compte du passage au travers le SELECTQ!
(:cr-intersect-list lcr)
(unless (or indict :effectp)
; doit retourner () en fin des clauses
(:mov 'NIL dest)
(:cr dest ()))
(:add-code etfin))))
(de :expush (l dest)
; compile 'l' puis l'empile
; utilise le registre 'dest' s'il le faut
(:push (:diroporany l dest)))
(de :progn (l dest :effectp)
; compile le PROGN : <l>
; dans la destination : <dest>
; doit appeler :exp pour re-lier :effectp
; pour l'e'valuation de la dernie`re expression.
(while (consp (cdr l)) (:exp (nextl l) dest T))
(:exp (car l) dest :effectp))
(de :progn-last (l dest :effectp)
; compile le PROGN en position terminale
; et ajoute un RETURN si necessaire
(:progn l dest :effectp)
(:return))
; .SSection "Ge'ne'ration des pre'dicats"
(de :pred (l ind etiq dest)
; compile le pre'dicat : 'l'
; si le test retourne : 'ind', branchement a` l'e'tiquette : 'etiq'
; la valeur du test se retrouve dans 'dest' (si c'est utile et si
; c'est le cas actualise le contenu des registres).
#+:stat-flag (incr :stat-pred)
(cond
;
; les cas triviaux et les macros
;
((null l)
#+:stat-flag (incr :stat-pred1)
(if ind () (:add-code `(BRA ,etiq))))
((:quotep l)
#+:stat-flag (incr :stat-pred2)
(if ind (:add-code `(BRA ,etiq)) () ))
((setq aux1 (:dirop l))
; ope'rande directe possible
#+:stat-flag (incr :stat-pred3)
(:add-code `(,(if ind 'BFNIL 'BTNIL) ,aux1 ,etiq)))
((neq l (setq aux1 (#:compiler:macroexpand l)))
#+:stat-flag (incr :stat-pred4)
#+:stat-flag (incr :stat-macex)
(:pred aux1 ind etiq dest))
((atom l)
; je veux un CONS
(:error l))
(t ; j'e'clate CAR CDR
(:pred-list (car l) (cdr l)))))
(de :pred-list (fnt larg)
(cond
;
; connecteurs de pre'dicats
;
((eq fnt 'NOT)
#+:stat-flag (incr :stat-pred5)
(:pred (car larg) (not ind) etiq dest))
((memq fnt '(AND OR))
#+:stat-flag (incr :stat-pred6)
(let (lcr)
(if (if (eq fnt 'AND) (NOT ind) ind)
(progn
(while (consp larg) (:pred (nextl larg) ind etiq dest)
(newl lcr (:cr-list))))
(let ((et (:genlab)))
(while (consp (cdr larg))
(:pred (nextl larg) (not ind) et dest)
(newl lcr (:cr-list)))
(:pred (car larg) ind etiq dest)
(:add-code et)))
(:cr-intersect-list lcr)))
;
; pre'dicats open-coded dans 'dest'
;
((eq fnt 'FIXP) (:pred-list-aux2 'BTFIX 'BFFIX))
((eq fnt 'FLOATP) (:pred-list-aux2 'BTFLOAT 'BFFLOAT))
((eq fnt 'STRINGP) (:pred-list-aux2 'BTSTRG 'BFSTRG))
((eq fnt 'VECTORP) (:pred-list-aux2 'BTVECT 'BFVECT))
((eq fnt 'VARIABLEP) (:pred-list-aux2 'BTVAR 'BFVAR))
((eq fnt 'SYMBOLP) (:pred-list-aux2 'BTSYMB 'BFSYMB))
((eq fnt 'ATOM) (:pred-list-aux2 'BFCONS 'BTCONS))
((eq fnt 'CONSP) (:pred-list-aux2 'BTCONS 'BFCONS))
;
; comparaison de pointeurs et comparaison arithme'tique
;
((eq fnt 'EQ) (:pred-list-aux3 'CABEQ 'CABNE))
; NEQ est une macro du compilateur.
((eq fnt 'EQN) (:pred-list-aux3 'CNBEQ 'CNBNE))
((eq fnt 'NEQN) (:pred-list-aux3 'CNBNE 'CNBEQ))
((eq fnt 'LT) (:pred-list-aux3 'CNBLT 'CNBGE))
((eq fnt 'LE) (:pred-list-aux3 'CNBLE 'CNBGT))
((eq fnt 'GT) (:pred-list-aux3 'CNBGT 'CNBLE))
((eq fnt 'GE) (:pred-list-aux3 'CNBGE 'CNBLT))
;
((eq fnt 'FEQN) (:pred-list-aux3 'CFBEQ 'CFBNE))
((eq fnt 'FNEQN) (:pred-list-aux3 'CFBNE 'CFBEQ))
((eq fnt 'FLT) (:pred-list-aux3 'CFBLT 'CFBGE))
((eq fnt 'FLE) (:pred-list-aux3 'CFBLE 'CFBGT))
((eq fnt 'FGT) (:pred-list-aux3 'CFBGT 'CFBLE))
((eq fnt 'FGE) (:pred-list-aux3 'CFBGE 'CFBLT))
;
; cas du MEMQ open lorsque l'on selectionne dans une liste
; de constantes, et que l'on a tout sous la main
; cas typique du SELECTQ.
;
((and (eq fnt 'MEMQ) (:quotep (cadr larg)))
#+:stat-flag (incr :stat-pred7)
(:exp (car larg) dest ())
(setq larg (cadadr larg))
(if ind
(while (consp larg)
(:add-code (list 'CABEQ dest (kwote (nextl larg)) etiq)))
(let ((et (:genlab)))
(while (consp (cdr larg))
(:add-code (list 'CABEQ dest
(kwote (nextl larg)) et)))
(:add-code (list 'CABNE dest (kwote (car larg)) etiq))
(:add-code et))))
;
; fin des pre'dicats open-coded
;
(t ; et dans tous les autres cas,
#+:stat-flag (incr :stat-pred8)
(:exp l dest ())
(:add-code (list (if ind 'BFNIL 'BTNIL) dest etiq))))))))
(de :pred-list-aux2 (codop1 codop2)
#+:stat-flag (incr :stat-predlist2)
(:add-code (list (if ind codop1 codop2)
(:diroporany (car larg) dest)
etiq)))
(de :pred-list-aux3 (codop1 codop2)
; ca c'est deja plus fin : instruction a` 2 op qcq
#+:stat-flag (incr :stat-predlist3)
(let ((op1 (:dirop (car larg)))
(op2 (:dirop (cadr larg))))
(unless (and op1 op2)
#+:stat-flag (incr :stat-predlist31)
(unless (eq dest 'A1) (exit not-in-A1))
#+:stat-flag (incr :stat-predlist32)
; dest = A1 avant d'appeler :exp-2.
(:exp-2 fnt (car larg) (cadr larg))
(setq op1 'A1 op2 'A2)
(:cr-all-nil))
(:add-code (list (if ind codop1 codop2) op1 op2 etiq))))
; .SSection "de'termination des ope'randes"
(de :diropreg (l)
; retourne () si aucun registre n'est pre'charge' avec la
; valeur de <l>, sinon retourne le nom du registre concerne'.
#+:stat-flag (incr :stat-diropreg)
(cond ((equal l :A1)
#+:stat-flag (incr :stat-diropreg1)
'A1)
((equal l :A2)
#+:stat-flag (incr :stat-diropreg2)
'A2)
((equal l :A3)
#+:stat-flag (incr :stat-diropreg3)
'A3)
((equal l :A4)
#+:stat-flag (incr :stat-diropreg4)
'A4)
(t #+:stat-flag (incr :stat-diropreg0)
())))
(de :dirop (l)
; retourne (s'il existe) l'ope'rande LLM3 contenant
; l'objet <l> et on garantit qu'aucun registre de
; la machine ni que la pile ne seront modifies.
; :dirop retourne un symbole si l'ope'rande est un registre!
; c'est vraissemblablement la fonction la plus utilise'e
; durant la phase de ge'ne'ration de code .....
#+:stat-flag (incr :stat-dirop)
(if (atom l)
(cond ((null l)
; attention l'ope'rande 'NIL n'est pas () !!!
#+:stat-flag (incr :stat-dirop-nil)
'NIL)
((eq l :A1)
#+:stat-flag (incr :stat-dirop-a1)
'A1)
((eq l :A2)
#+:stat-flag (incr :stat-dirop-a2)
'A2)
((eq l :A3)
#+:stat-flag (incr :stat-dirop-a3)
'A3)
((eq l :A4)
#+:stat-flag (incr :stat-dirop-a4)
'A4)
((eq l 'T)
; 'T est plus rapide que (cvalq t)
#+:stat-flag (incr :stat-dirop-t)
''T)
((symbolp l)
; les variables
#+:stat-flag (incr :stat-dirop-symb)
`(CVALQ ,l))
(t ; de belles constantes : vector/string/numb
#+:stat-flag (incr :stat-dirop-atom)
`(quote ,l)))
(cond ((equal l :A1)
#+:stat-flag (incr :stat-dirop-a1)
#+:stat-flag (incr :stat-dirop-cons)
'A1)
((equal l :A2)
#+:stat-flag (incr :stat-dirop-a2)
#+:stat-flag (incr :stat-dirop-cons)
'A2)
((equal l :A3)
#+:stat-flag (incr :stat-dirop-a3)
#+:stat-flag (incr :stat-dirop-cons)
'A3)
((equal l :A4)
#+:stat-flag (incr :stat-dirop-a4)
#+:stat-flag (incr :stat-dirop-cons)
'A4)
((eq (car l) 'QUOTE)
; d'autres constantes
#+:stat-flag (incr :stat-dirop-quote)
`,(kwote (cadr l)))
((and #:compiler:open-p
(memq (car l) '(CAR CDR)))
; les CAR et CDR open (a` voir pour PLIST ...)
#+:stat-flag (incr :stat-dirop-cd)
(let ((op (:diropreg (cadr l))))
(if op
(progn #+:stat-flag (incr :stat-dirop-cd1)
(list (if (eq (car l) 'car) 'CAR 'CDR) op))
(progn #+:stat-flag (incr :stat-dirop-rate)
()))))
(t #+:stat-flag (incr :stat-dirop-rate)
()))))
(de :diropordest (l dest)
; retourne l'ope'rande direct ou bien <dest> apre`s
; la compilation de <l>
#+:stat-flag (incr :stat-diropordest)
#+:stat-flag (incr :stat-macex)
(setq l (#:compiler:macroexpand l))
(cond ((:dirop l))
((and #:compiler:open-p
(consp l)
(memq (car l) '(CAR CDR)))
(:exp (cadr l) dest ())
(list (if (eq (car l) 'car) 'CAR 'CDR) dest))
(t (:exp l dest ())
dest)))
(de :diroporany (l dest)
; retourne l'ope'rande direct ou bien un registre
; quelconque plus haut que <dest> ou bien <dest>
; pour la compilation de <l>
#+:stat-flag (incr :stat-diroporany)
#+:stat-flag (incr :stat-macex)
(setq l (#:compiler:macroexpand l))
(or (:dirop l)
(let ((op (:cr-any-reg dest)))
(:backtrack
(progn #+:stat-flag (incr :stat-diroporany1)
(if (and #:compiler:open-p
(consp l)
(memq (car l) '(CAR CDR)))
(progn #+:stat-flag (incr :stat-diroporany2)
(:exp (cadr l) op ())
(list (if (eq (car l) 'car)
'CAR
'CDR)
op))
(progn #+:stat-flag (incr :stat-diroporany3)
(:exp l op ())
op)))
()))
(progn #+:stat-flag (incr :stat-diroporany4)
(:exp l dest ())
dest)))
; .Section "La gestion du Backtrack du compilateur"
(dmd :backtrack body
`(tag backtrack
(let ((:save-lap :lap)
(:save-A1 :A1)
(:save-A2 :A2)
(:save-A3 :A3)
(:save-A4 :A4)
(:save-deep :deep))
,@(mapcan (lambda (e)
; celui qui mets un backquote ici est un homme mort!
(list (list 'tag 'not-in-A1 (list 'exit 'backtrack e))
(list 'setq ':lap ':save-lap
':A1 ':save-A1
':A2 ':save-A2
':A3 ':save-A3
':A4 ':save-A4
':deep ':save-deep)))
body)))))