; .EnTete "Le_Lisp (c) version 15.2" " " "Le chargeur me'moire 68000" ; .SuperTitre "Le Chargeur Me'moire 68000" ; ; .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 "*****************************************************************" ; $Header: lap68k.ll,v 4.9 89/01/11 15:52:24 nuyens Exp $ ; Assemble et charge pour un 68000 une liste d'instructions LLM3 ; en 1 seule passe et avec du code relogeable. ; Optimisations: ; Dans certains cas operandes immediates peuvent passer directement ; (sans le cout de 32bits) dans un registre data (cf MOVQ). ; LSHIFT a` refaire ; Le code peut etre factorise'. ; Tester le cout dans le cas ou :arg* est passer en parametre (lex) (unless (>= (version) 15.2) (error 'load 'erricf 'lap68k)) (defvar #:sys-package:colon 'ld68k) (add-feature 'loader) ; .Section "Strate'gie de la re'solution des e'tiquettes" ; 1 - les e'tiquettes locales a` une fonction ; 2 - les e'tiquettes locales a` un module ; 3 - les e'tiquettes globales a` tout le syste`me Le_Lisp ; Ce chargeur est capable de produire du code relogeable, ce qui va ; permettre de compacter la zone code. ; .SSection "Les e'tiquettes locales a` une fonction (LOCAL)" ; Une e'tiquette nume'rique est toujours de type LOCAL. Ce trait est ; utilise' par le compilateur pour engendrer des e'tiquettes a` peu de frais. ; Une e'tiquette symbolique locale doit e^tre de'clare'e avant sa premie`re ; utilisation au moyen de la pseudo LOCAL. Cette de'claration permet ; d'e'viter des conflits de noms, mais le compilateur n'utilise jamais ; ce trait. ; Toute re'fe'rence a` ce type d'e'tiquette engendre un de'placement ; par rapport au PC (de 8 ou de 16 bits) [cf :notoofar]. ; Ces e'tiquettes doivent e^tre re'solues a` la fin ; de la liste des instructions ou a` l'apparition de la pseudo ENDL. ; Si elles ne le sont pas, le chargeur de'clenche une erreur. ; .SSection "Les e'tiquettes locales a` un module" ; Les e'tiquettes de ce type, toujours symboliques, ne sont pas de'clare'es. ; Elles sont de'finies au moyen de la pseudo ENTRY. ; Elles peuvent ne pas e^tre re'solues entre deux appels du chargeur mais ; doivent l'e^tre a` l'apparition de la pseudo END. ; Si elles ne le sont pas, le chargeur de'clenche une erreur. ; Ces e'tiquettes sont dans un des 2 e'tats suivants : ; 1 - elles ne sont pas de'finies : leur nom est dans la A-liste ; :entries-not-resolved qui contient en valeur la liste des adresses ; ou` il faudra charger la ve'ritable adresse quand elle apparaitra. ; Ces de'placements sont sur 16 bits actuellement! ; ?!?!? Que se passe-il avec des modules limite's a` 32k ?!?!? ; ?!?!? Y a t il beaucoup de gens que cela generait ?!?!? ; 2 - elles viennent d'apparai^tre (ENTRY). Il n'y a plus qu'un seul ; indicateur :fval qui contient la ve'ritable adresse. ; De plus le symbole est enleve' de :entries-not-resolved et est ajoute' ; dans la liste :entry-list. ; 3 - le END survient, toutes ces e'tiquettes sont de'truites ; de la liste :entry-list, les indicateurs :fval sont de'truits. ; S'il reste des noms dans :entries-not-resolved une erreur est ; de'clenche'e. Rien ne reste donc de propre au chargeur, ces ; e'tiquettes sont des candidats de choix pour le prochain GC. ; .SSection "Les e'tiquettes globales" ; Les e'tiquettes de ce type, toujours symboliques, ne sont utilise'es ; qu'avec les instructions JCALL et JMP. ; Elles sont de'finies au moyen de la pseudo FENTRY qui charge, de`s ; cette de'finition, la FVAL/FTYPE de cette fonction. ; Elles peuvent ne pas e^tre re'solues entre deux appels du chargeur ; qui ne s'en appercoit jamais car il engendre toujours un acce`s ; correspondant a` (FVAL 'symb), ce qui permet en plus de les rede'finir ; et de les recompiler (i.e. si je recharge le module pretty avec pprint ; comme externe, tous les autres modules continueront a` fonctionner ; avec ce nouveau module). ; Les noms des fonctions standard sont des e'tiquettes globales. ; .bp ; .Section "Les variables globales du chargeur" ; .SSection "Les indicateurs conditionnels du chargeur" (defvar :31BITFLOATS (eq 0. 0.)) ; les nbs flottants sur 31 bits ; (utile pour rendre les floats non litteraux) (unless (boundp ':MC68881) (defvar :MC68881 ())) (unless (boundp ':MC68020) (defvar :MC68020 t)) (defvar :stopcopy (typefn '#:ld:gcafter-daemon)) ; pour le Stop & Copy ;; if T, don't resolve references until the end of loading. (unless (boundp '#:ld:special-case-loader) (defvar #:ld:special-case-loader ())) ; Pour permettre d'aligner les instructions sur des frontieres de mots 32 bits: (defvar :align-flag ()) ; .SSection "Les autres variables globales" (defvar :Ecode ; Fin de la zone code (subadr (#:system:ecode) 64)) (defvar :locnil (loc ())) ; adresse du symbole () (defvar :entry-list ()) ; Liste des points d'entre'e locaux (defvar :entries-not-resolved ()) ; A-liste des ENTRIES non re'solus (unless (boundp ':module) ; Le nom du module en cours de charg. (defvar :module ())) (unless (boundp ':saved-by-loader) (defvar :saved-by-loader ())) ; Liste de vecteurs de litte'raux ; entre 2 ENDs. (unless (boundp ':global-saved-by-loader) ; liste de vecteurs de litte'raux. (defvar :global-saved-by-loader '( ; Ces variables ne sont pas sauve'es par :clean-litt (dynamique). #[:lobj :talkp :PCcurrent :llabels :llabels-nr :fntname :codop :arg1 :arg2 :arg3 :localstack :valaux :f :nwl obj]))) (defvar :lobj) (defvar :talkp) (defvar :PCcurrent) (defvar :llabels) (defvar :llabels-nr) (defvar :fntname) (defvar :codop) (defvar :arg1) (defvar :arg2) (defvar :arg3) (defvar :localstack) (defvar :valaux) (defvar :f) (defvar :nwl) ;; il faut package' celui-la! (defvar obj) (unless (boundp '#:ld:cons-llitt) (defvar #:ld:cons-llitt ())) (unless (boundp ':local-cons-llitt) (defvar :local-cons-llitt ())) ; La valeur de <:max-lap-dpl8> est heuristique. Si ce n'est pas assez grand ; la fonction :1byterelPC ra^le un bon coup. ; Remarque: 13 est la valeur "normale", et si le MC68881 est utilise' ; on revient a` 12, car les instructions sur les flottants ; sont beaucoup + gourmandes! (defvar :max-lap-dpl8 13) ; .Section "De'finition des constantes machines" ; .SSection "Les registres" ; Registres de la machine: (defvar :rgA0 0)(defvar :eaA0 #$8) ; adresse effective A0: 001 000 (defvar :rgA1 1)(defvar :eaA1 #$9) ; adresse effective A1: 001 001 (defvar :rgA2 2)(defvar :eaA2 #$A) ; adresse effective A2: 001 010 (defvar :rgA3 3)(defvar :eaA3 #$B) ; adresse effective A3: 001 011 (defvar :rgA4 4)(defvar :eaA4 #$C) ; adresse effective A4: 001 100 (defvar :rgA5 5)(defvar :eaA5 #$D) ; adresse effective A5: 001 101 (defvar :rgA6 6)(defvar :eaA6 #$E) ; adresse effective A6: 001 110 (defvar :rgA7 7)(defvar :eaA7 #$F) ; adresse effective A7: 001 111 (defvar :rgD0 0)(defvar :eaD0 0) ; adresse effective D0: 000 000 (defvar :rgD1 1)(defvar :eaD1 1) ; adresse effective D1: 000 001 (defvar :D0_dst_field 0) ;(logshift :rgD0 9) (defvar :D1_dst_field #$0200) ;(logshift :rgD1 9) (defvar :rgD2 2)(defvar :eaD2 2) (defvar :rgD3 3)(defvar :eaD3 3) (defvar :rgD4 4)(defvar :eaD4 4) (defvar :rgD5 5)(defvar :eaD5 5) (defvar :rgD6 6)(defvar :eaD6 6) (defvar :rgD7 7)(defvar :eaD7 7) ; Registres de Lisp: ; Attention a` AUX0 et SP qui sont souvent code's en dur! ; (pour e'viter de calculer des constantes!) ; AUX0,AUX1 doivent e^tre des registres d'adresse. (defvar :rgAUX0 :rgA0) ; A0 (defvar :eaAUX0 :eaA0) ; adresse effective AUX0 (defvar :rgAUX1 :rgA6) ; (defvar :eaAUX1 :eaA6) ; adresse effective AUX1 ; Si on arrive a liberer D5, on peut tjrs essayer: ;(defvar :rgDLINK :rgD5) ; nume'ro du registre DLINK ;(defvar :eaDLINK :eaD5) ; adresse effective (defvar :rgSP :rgA7) ; nume'ro du registre SP (A7) (defvar :eaSP :eaA7) ; adresse effective SP (defvar :rgBFLOAT :rgD2) ; nume'ro du registre BFLOAT (defvar :eaBFLOAT :eaD2) ; adresse effective BFLOAT (defvar :rgBVECT :rgD3) ; nume'ro du registre BVECT (defvar :eaBVECT :eaD3) ; adresse effective BVECT (defvar :rgBSTRG :rgD4) ; nume'ro du registre BSTRG (defvar :eaBSTRG :eaD4) ; adresse effective BSTRG ; RBSYMB est conseille' dans un registre d'adresse (cf :op68kquotesymb) (defvar :rgBSYMB :rgA5) ; nume'ro du registre RBSYMB (defvar :eaBSYMB :eaA5) ; adresse effective RBSYMB (defvar :rgNIL :rgBSYMB); NIL c'est le debut des symboles. (defvar :eaNIL :eaBSYMB); adresse effective NIL (defvar :rgBVAR :rgD6) ; nume'ro du registre RBVAR (defvar :eaBVAR :eaD6) ; adresse effective RBVAR (defvar :rgBCONS :rgD7) ; nume'ro du registre RBCONS (defvar :eaBCONS :eaD7) ; adresse effective RBCONS ; .SSection "Les constantes de masque pour les adresses effectives" ; Register direct mode: ; Address register direct: (defvar :direct-add-mask #$0008) ;xxxx xxxx xx00 1xxx ; Register indirect mode: ; Address register indirect: (defvar :indirect-add-mask #$0010) ;xxxx xxxx xx01 0xxx ; Address register indirect with displacement: (defvar :indirect-add-disp-mask #$0028) ;xxxx xxxx xx10 1xxx ; Register indirect with index modes: ; Address register indirect with index (8 bits displacement): (defvar :indirect-add-indx-mask #$0030) ;xxxx xxxx xx11 0xxx ; Absolute address modes: ; Absolute long address: (defvar :abs-long-add-mask #$0039) ;xxxx xxxx xx11 1001 ; Program Counter indirect with displacement mode: (defvar :indirect-pc-disp-mask #$003A) ;xxxx xxxx xx11 1010 ; Program Counter memory indirect modes: ; Program Counter memory indirect post-indexed: (defvar :indirect-pcm-pindx-mask #$003B) ;xxxx xxxx xx11 1011 ; Immediate data: (defvar :data-mask #$003C) ;xxxx xxxx xx11 1100 ; .SSection "Les instructions" (defvar :ADD.L #$D080) ;ADD.L D0,D0 (defvar :ADD.W #$D040) ;ADD.W D0,D0 (defvar :ADDA.L #$D1C0) ;ADDA.L D0,A0 (defvar :ADDA.W #$D0C0) ;ADDA.W D0,A0 (defvar :ADDI.W #$0640) ;ADDA.W D0,A0 (defvar :ADDQ.L #$5080) ;ADDQ.L #0,D0 ;;#0 => cte dans l'instruction (defvar :ADDQ.W #$5040) ;ADDQ.W #0,D0 (defvar :AND.W #$C040) ;AND.W D0,D0 (defvar :ANDI.L #$0280) ;ANDI.L #0,D0 (defvar :ANDI.W #$0240) ;ANDI.W #0,D0 (defvar :BEQ #$6700) (defvar :BGE #$6C00) (defvar :BGT #$6E00) (defvar :BHI #$6200) (defvar :BLE #$6F00) (defvar :BLS #$6300) (defvar :BLT #$6D00) (defvar :BNE #$6600) (defvar :BRA #$6000) (defvar :BSET.Ld #$08C0) ;BSET.L #n,D0 ;;#n => cte suit l'instruction (defvar :BSR #$6100) (defvar :CLR.L #$4280) ;CLR.L D0 (defvar :CMP.B #$B000) ;CMP.B D0,D0 (defvar :CMP.L #$B080) ;CMP.L D0,D0 (defvar :CMP.W #$B040) ;CMP.W D0,D0 (defvar :CMPA.L #$B1C0) ;CMPA.L D0,A0 (defvar :CMPI.L #$0C80) ;CMPI.L #n,D0 (defvar :DIVS.W #$81C0) ;DIVS.W D0,D0 (defvar :EOR.W #$B140) ;EOR.W D0,D0 (defvar :EORI.W #$0A40) ;EORI.W #0,D0 (defvar :EXT.L #$48C0) ;EXT.L D0 (defvar :JMP #$4ED0) ;JMP (A0) (defvar :LEA #$41D0) ;LEA (A0),A0 (defvar :LSL.Ld #$E188) ;LSL.L #0,D0 (defvar :LSR.Ld #$E088) ;LSR.L #0,D0 (defvar :LSL.W #$E168) ;LSL.W D0,D0 (defvar :LSR.W #$E068) ;LSR.W D0,D0 (defvar :LSL.Wd #$E148) ;LSL.W #0,D0 (defvar :LSR.Wd #$E048) ;LSR.W #0,D0 (defvar :MOVE.B #$1000) ;MOVE.B D0,D0 (defvar :MOVE.L #$2000) ;MOVE.L D0,D0 (defvar :MOVE.W #$3000) ;MOVE.W D0,D0 (defvar :MOVEA.L #$2040) ;MOVEA.L D0,A0 (defvar :MOVEQ #$7000) ;MOVEQ #0,D0 (defvar :MULS.W #$C1C0) ;MULS.W D0,D0 (defvar :NEG.W #$4440) ;NEG.W A0 (defvar :NOP #$4E71) ;NOP (defvar :OR.W #$8040) ;OR.W D0,D0 (defvar :ORI.W #$0040) ;ORI.W #0,D0 (defvar :PEA #$4850) ;PEA (A0) (defvar :POP #$201F) ;POP A0 (defvar :PUSH #$2F00) ;PUSH A0 (defvar :ROR.Ld #$E098) ;ROR.L #n,D0 (defvar :RTS #$4E75) ;RTS (defvar :SUB.W #$9040) ;SUB.W D0,D0 (defvar :SUBA.L #$91C0) ;SUBA.L D0,A0 (defvar :SUBI.W #$0440) ;SUBI.W #n,D0 (defvar :SUBQ.L #$5180) ;SUBQ.L #0,D0 (defvar :SUBQ.W #$5140) ;SUBQ.W #0,D0 (defvar :SWAP.W #$4840) ;SWAP.W D0 (defvar :TST.L #$4A80) ;TST.L A0 ; Instructions du processeur flottant spe'cialise' 68881: (defvar :F68881.1 #$F200) ;16 bits pour pre'venir! (defvar :F68881.2 #$F228) ;16 bits pour pre'venir! (defvar :FADD.S #$4422) ;FADD.S D0,FP0 (defvar :FSUB.S #$4428) ;FSUB.S D0,FP0 (defvar :FMUL.S #$4423) ;FMUL.S D0,FP0 (defvar :FDIV.S #$4420) ;FDIV.S D0,FP0 (defvar :FBEQ #$F281) ;FBEQ D0,FP0 (defvar :FBNE #$F28E) ;FBNE D0,FP0 (defvar :FBGT #$F292) ;FBGT D0,FP0 (defvar :FBGE #$F293) ;FBGE D0,FP0 (defvar :FBLT #$F294) ;FBLT D0,FP0 (defvar :FBLE #$F295) ;FBLE D0,FP0 (defvar :FCMP.S #$4438) ;FCMP.S D0,FP0 (defvar :FCMP.D #$5438) ;FCMP.D n(A0),FP0 (defvar :FMOVE.S #$4400) ;FMOVE.S D0,FP0 (defvar :FMOVE.D #$4400) ;???? ; .Section "Interpre'tation d'un objet" (de :ins (obj) ; charge un objet (instruction ou pseudo) en me'moire (when :talkp (if (consp obj) (outpos 4)) (prin obj) (when (>= (outpos) 30) (terpri)) (outpos 30) (:prinhex :PCcurrent) (prin " ")) (cond ((null obj) ()) ((atom obj) ; une e'tiquette locale (symbole ou nb) : ; on la rajoute dans :llabels (newl :llabels (cons obj (copylist :PCcurrent))) ; re'solution des re'fe'rences avants (relatives) (mapc (lambda (l) (selectq (car l) (8 ; c'est une r.n.r. relative sur 8 bits (:1byterelPC (cdr l))) (16 ; c'est une r.n.r. relative sur 16 bits (:1wordrelPC (cdr l))) (t (:error "RESOL" l)))) (cassq obj :llabels-nr)) (setq :llabels-nr (delete (assq obj :llabels-nr) :llabels-nr))) (t (setq :codop (car obj) :arg1 (cadr obj) :arg2 (caddr obj) :arg3 (cadddr obj) :localstack 0) (selectq :codop ; ; les pseudos-instructions (par ordre alphabe'tique) ; (ABORT ; Pour re'cupe'rer de la me'moire en cas craschhhh. ) (ENTRY ; (ENTRY ) (:align) ; charge les indicateurs (newl :entry-list (list :arg1 (if (memq :arg2 '(SUBR0 SUBR1 SUBR2 SUBR3 NSUBR FSUBR MSUBR DMSUBR )) :arg2 (:error "ENTRY" obj)) :arg3)) ; re'solution des re'fe'rences avants. (mapc ':1wordrelPC (cassq :arg1 :entries-not-resolved)) (setq :entries-not-resolved (delete (assq :arg1 :entries-not-resolved) :entries-not-resolved)) (putprop :arg1 (copylist :PCcurrent) ':fval) (setq :fntname :arg1)) (ENDL ; fin d'une fonction locale (when :talkp (terpri)) (when :llabels-nr (:error "Il reste des references locales non resolues " :llabels-nr))) (END ; fin d'un module ; ve'rification de l'entry-list (:ins '(ENDL)) (when :entries-not-resolved (:error "Il reste des ENTRY non resolus " :entries-not-resolved)) (while :entry-list (remprop (caar :entry-list) ':fval) (remprop (caar :entry-list) '#:llcp:fval) (remprop (caar :entry-list) '#:llcp:ftype) (remprop (caar :entry-list) '#:system:loaded-from-file) (nextl :entry-list)) (when #:ld:special-case-loader (while (and (consp #:ld:special-case-loader) (consp (car #:ld:special-case-loader))) (if (and :stopcopy (typefn ':patch-cons-llitt)) (:patch-cons-llitt)) (apply 'setfn (nextl #:ld:special-case-loader)))) (:clean-llitt)) (EVAL ; (EVAL s) e'valuation a` LOAD-TIME (catcherror t (eval :arg1))) (FENTRY ; (FENTRY ) (:align) ; enle`ve les indicateurs (a` ve'rifier ?!?!?) (remprop :arg1 '#:system:loaded-from-file) (if #:ld:special-case-loader (newl #:ld:special-case-loader (list :arg1 :arg2 (copylist :PCcurrent))) (remprop :arg1 '#:llcp:ftype) (remprop :arg1 '#:llcp:fval) (setfn :arg1 :arg2 :PCcurrent)) (newl :llabels (cons :arg1 (copylist :PCcurrent))) (setq :fntname :arg1)) (LOCAL ; (LOCAL ) ; rend le symbole local a` une fonction. (newl :llabels (ncons :arg1))) (TITLE ; (TITLE de'finition du nom du module) (setq :module :arg1)) ; ; appel de la partie de'pendante des machines! ; :machins contient le ge'ne'rateur. ; (t (:machins obj)) )))) (de :machins (obj) ; re'alise le chargement de l'instruction (selectq :codop ; ; les tests de type. ; (BTNIL ; (BTNIL op lab) == CMP op,NIL / BEQ lab (:brtf1 (:what-cmp :eaNIL) :BEQ)) (BFNIL ; (BFNIL op lab) == CMP op,NIL / BNE lab (:brtf1 (:what-cmp :eaNIL) :BNE)) (BTCONS ; (BTCONS op lab) == CMP op,BCONS / BLE lab (:brtf1 (:what-cmp :eaBCONS) :BLE)) (BFCONS ; (BFCONS op lab) == CMP op,BCONS / BGT lab (:brtf1 (:what-cmp :eaBCONS) :BGT)) (BTFIX ; (BTNUMB op lab) == CMP op,[BVECT ! BFLOAT] / BHI lab (:brtf1 (:what-cmp (if :31BITFLOATS :eaBVECT :eaBFLOAT)) :BHI)) (BFFIX ; (BFNUMB op lab) == CMP op,[BVECT ! BFLOAT] / BLS lab (:brtf1 (:what-cmp (if :31BITFLOATS :eaBVECT :eaBFLOAT)) :BLS)) (BTFLOAT ; (BTFLOAT op lab) (ifn :31BITFLOATS ; CMP op1,BFLOAT / BHI @ / CMP op1,BVECT / BHI :arg2 / @ (:brt2 (:what-cmp :eaBFLOAT) (:what-cmp :eaBVECT)) ; MOVE op,D0 / TST D0 / BLT lab (:ins68k-src :MOVE.L :arg1) (:1word :TST.L) (:brarel :BLT :arg2))) (BFFLOAT ; (BFFLOAT op1 lab) (ifn :31BITFLOATS ; CMP :arg1,BFLOAT / BHI :arg2 / CMP :arg1,BVECT / BLS :arg2 (:brf2 (:what-cmp :eaBFLOAT) (:what-cmp :eaBVECT)) ; MOVE op,D0 / TST D0 / BGE lab (:ins68k-src :MOVE.L :arg1) (:1word :TST.L) (:brarel :BGE :arg2))) (BTSTRG ; (BTSTRG op1 lab) ; CMP :arg1,BSTRG / BHI @ / CMP :arg1,BSYMB / BHI :arg2 / @ (:brt2 (:what-cmp :eaBSTRG) (:what-cmp :eaBSYMB))) (BFSTRG ; (BFSTRG op1 lab) ; CMP :arg1,BSTRG / BHI :arg2 / CMP :arg1,BSYMB / BLS :arg2 (:brf2 (:what-cmp :eaBSTRG) (:what-cmp :eaBSYMB))) (BTVECT ; (BTVECT op1 lab) ; CMP :arg1,BVECT / BHI @ / CMP :arg1,BSTRG / BHI :arg2 / @ (:brt2 (:what-cmp :eaBVECT) (:what-cmp :eaBSTRG))) (BFVECT ; (BFVECT op1 lab) ; CMP :arg1,BVECT / BHI :arg2 / CMP :arg1,BSTRG / BLS :arg2 (:brf2 (:what-cmp :eaBVECT) (:what-cmp :eaBSTRG))) (BTSYMB ; (BTSYMB op1 lab) ; CMP :arg1,BSYMB / BHI @ / CMP :arg1,BCONS / BHI :arg2 / @ (:brt2 (:what-cmp :eaBSYMB) (:what-cmp :eaBCONS))) (BFSYMB ; (BFSYMB op1 lab) ; CMP :arg1,BSYMB / BHI :arg2 / CMP :arg1,BCONS / BLS :arg2 (:brf2 (:what-cmp :eaBSYMB) (:what-cmp :eaBCONS))) (BTVAR ; (BTVAR op1 lab) ; CMP :arg1,BVAR / BHI @ / CMP :arg1,BCONS / BHI :arg2 / @ (:brt2 (:what-cmp :eaBVAR) (:what-cmp :eaBCONS))) (BFVAR ; (BFVAR op1 lab) ; CMP :arg1,BVAR / BHI :arg2 / CMP :arg1,BCONS / BLS :arg2 (:brf2 (:what-cmp :eaBVAR) (:what-cmp :eaBCONS))) (CABEQ ; (CABEQ op1 op2 lab) (:cmpeq-ne :arg1 :arg2) (:brarel :BEQ :arg3)) (CABNE ; (CABNE op1 op2 lab) (:cmpeq-ne :arg1 :arg2) (:brarel :BNE :arg3)) ; ; Les comparaisons arithme'tiques. ; (CNBEQ ; (CNBEQ op1 op2 lab) (:cmp-numerical-and-branch :BEQ :BEQ)) (CNBNE ; (CNBNE op1 op2 lab) (:cmp-numerical-and-branch :BNE :BNE)) (CNBLT ; (CNBLT op1 op2 lab) (:cmp-numerical-and-branch :BLT :BGT)) (CNBLE ; (CNBLE op1 op2 lab) (:cmp-numerical-and-branch :BLE :BGE)) (CNBGT ; (CNBGT op1 op2 lab) (:cmp-numerical-and-branch :BGT :BLT)) (CNBGE ; (CNBGE op1 op2 lab) (:cmp-numerical-and-branch :BGE :BLE)) ; ; Les comparaisons arithme'tiques flottantes. ; (CFBEQ ; (CFBEQ op1 op2 lab) (cond ((and :MC68881 :31BITFLOATS) (:float32>31 :arg1 ()) (:float32>31 :arg2 '#:llcp:fcmp) (:cfltxx '#:llcp:FBEQ)) (:MC68881 (:float64 :arg1 ()) (:float64 :arg2 '#:llcp:fcmp) (:cfltxx '#:llcp:FBEQ)) (t (:generatecall2subr '#:llcp:feqn :arg3)))) (CFBNE ; (CFBNE op1 op2 lab) (cond ((and :MC68881 :31BITFLOATS) (:float32>31 :arg1 ()) (:float32>31 :arg2 '#:llcp:fcmp) (:cfltxx '#:llcp:FBNE)) (:MC68881 (:float64 :arg1 ()) (:float64 :arg2 '#:llcp:fcmp) (:cfltxx '#:llcp:FBNE)) (t (:generatecall2subr '#:llcp:fneqn :arg3)))) (CFBLT ; (CFBLT op1 op2 lab) (cond ((and :MC68881 :31BITFLOATS) (:float32>31 :arg1 ()) (:float32>31 :arg2 '#:llcp:fcmp) (:cfltxx '#:llcp:FBLT)) (:MC68881 (:float64 :arg1 ()) (:float64 :arg2 '#:llcp:fcmp) (:cfltxx '#:llcp:FBLT)) (t (:generatecall2subr '#:llcp:flt :arg3)))) (CFBLE ; (CFBLE op1 op2 lab) (cond ((and :MC68881 :31BITFLOATS) (:float32>31 :arg1 ()) (:float32>31 :arg2 '#:llcp:fcmp) (:cfltxx '#:llcp:FBLE)) (:MC68881 (:float64 :arg1 ()) (:float64 :arg2 '#:llcp:fcmp) (:cfltxx '#:llcp:FBLE)) (t (:generatecall2subr '#:llcp:fle :arg3)))) (CFBGT ; (CFBGT op1 op2 lab) (cond ((and :MC68881 :31BITFLOATS) (:float32>31 :arg1 ()) (:float32>31 :arg2 '#:llcp:fcmp) (:cfltxx '#:llcp:FBGT)) (:MC68881 (:float64 :arg1 ()) (:float64 :arg2 '#:llcp:fcmp) (:cfltxx '#:llcp:FBGT)) (t (:generatecall2subr '#:llcp:fgt :arg3)))) (CFBGE ; (CFBGE op1 op2 lab) (cond ((and :MC68881 :31BITFLOATS) (:float32>31 :arg1 ()) (:float32>31 :arg2 '#:llcp:fcmp) (:cfltxx '#:llcp:FBGE)) (:MC68881 (:float64 :arg1 ()) (:float64 :arg2 '#:llcp:fcmp) (:cfltxx '#:llcp:FBGE)) (t (:generatecall2subr '#:llcp:fge :arg3)))) ; ; Les instructions arithme'tiques (par ordre alpha) ; (DECR ; == (DIFF '1 arg1) (:arithm 'diff ''1 :arg1) ) (DIFF ; (DIFF A2 A1) (:arithm :codop :arg1 :arg2) ) (INCR ; == (PLUS '1 arg1) (:arithm 'plus ''1 :arg1) ) (NEGATE ; (NEGATE op) (ifn (:reg-operand? :arg1) ; NEG.W op (:ins68k-src-word :NEG.W :arg1 ()) ; MOVE.L op,D0 / NEG.W D0 / MOVE.L D0,op2 (:ins68k-src :MOVE.L :arg1) (:1word :NEG.W) ; de'faut D0 (:ins68k-dst :MOVE.L :arg1 ()) )) (PLUS ; (PLUS A2 A1) (:arithm :codop :arg1 :arg2) ) (QUO ; (QUO op1 op2) ; MOVE.L op1,D1 / MOVE.L op2,D0 / EXT.L D0 / DIVS D1,D0 ; AND.L 0000FFFF,D0 / MOVE.L D0,op2 (:ins68k-src (:fill-field :MOVE.L :D1_dst_field) :arg1) (:ins68k-src :MOVE.L :arg2) (:1word :EXT.L) (:1word (:fill-field :DIVS.W :rgD1)) (:1word :ANDI.L) (:1long -1) (:ins68k-dst :MOVE.L :arg2 ()) ) (REM ; (REM op1 op2) ; MOVE.L op1,D1 / MOVE.L op2,D0 / EXT.L D0 / DIVS D1,D0 ; SWAP D0 / AND.L 0000FFFF,D0 / MOVE.L D0,op2 (:ins68k-src (:fill-field :MOVE.L :D1_dst_field) :arg1) (:ins68k-src :MOVE.L :arg2) (:1word :EXT.L) (:1word (:fill-field :DIVS.W :rgD1)) (:1word :SWAP.W) (:1word :ANDI.L) (:1long -1) (:ins68k-dst :MOVE.L :arg2 ()) ) (TIMES ; (TIMES op1 op2) ; Faut-il re'ellement faire le masque a` la sortie?? ; MOVE.L op1,D0 / MOVE.L op2,D1 / MULS D1,D0 / ; AND.L 0000FFFF,D0 / MOVE.L D0,op2 (:ins68k-src :MOVE.L :arg1) (:ins68k-src (:fill-field :MOVE.L :D1_dst_field) :arg2) (:1word (:fill-field :MULS.W :rgD1)) (:1word :ANDI.L) (:1long -1) (:ins68k-dst :MOVE.L :arg2 ()) ) ; ; Les instructions arithme'tiques flottantes ; (FPLUS (cond ((and :MC68881 :31BITFLOATS) ; arg2 float32 -> fp0 float31 (:float32>31 :arg2 ()) ; arg1 float32 + fp0 -> fp0 float31 (:float32>31 :arg1 '#:llcp:fadd) ; fp0 float31 -> arg2 float32 (:float31>32 :arg2)) (t (:generatecall2subr '#:llcp:fadd ())) )) (FDIFF (cond ((and :MC68881 :31BITFLOATS) ; arg2 float32 -> fp0 float31 (:float32>31 :arg2 ()) ; arg1 - fp0 -> fp0 (:float32>31 :arg1 '#:llcp:fsub) ; fp0 float31 -> arg2 float32 (:float31>32 :arg2)) (t (:generatecall2subr '#:llcp:fsub ())) )) (FTIMES (cond ((and :MC68881 :31BITFLOATS) ; arg2 float32 -> fp0 float31 (:float32>31 :arg2 ()) ; arg1 * fp0 -> fp0 (:float32>31 :arg1 '#:llcp:fmul) ; fp0 float31 -> arg2 float32 (:float31>32 :arg2)) (t (:generatecall2subr '#:llcp:fmul ())) )) (FQUO (cond ((and :MC68881 :31BITFLOATS) ; arg2 float32 -> fp0 float31 (:float32>31 :arg2 ()) ; arg1 / fp0 -> fp0 (:float32>31 :arg1 '#:llcp:fdiv) ; fp0 float31 -> arg2 float32 (:float31>32 :arg2)) (t (:generatecall2subr '#:llcp:fdiv ())) )) ; ; Les ope'rations logiques. ; (LAND ; (LAND A2 A1) (:logxx :ANDI.W :AND.W ()) ) (LOR ; (LOR A2 A1) (:logxx :ORI.W :OR.W ()) ) (LSHIFT ; (LSHIFT n op) (ifn (:fixp :arg1) (:generatecall2subr '#:llcp:logshift ()) (setq :arg3 (cadr :arg1)) (setq :arg1 (if (lt :arg3 0) (sub 0 :arg3) :arg3)) (cond ((eq :arg3 0)) ((ge :arg1 32) ; MOVEQ #0,D0 / MOVE.L D0,op (:1word :MOVEQ) (:ins68k-dst :MOVE.L :arg2 ()) ) (t (:ins68k-src :MOVE.L :arg2) ; :MOVE.L op,D0 (:1word (cond ((eq :arg1 8) ; LSR/L.W #n,D1 (if (ge :arg3 0) :LSL.Wd :LSR.Wd) ) ((gt :arg1 8) ; MOVE.W #n,D1 / LSR/L.W D1,D0 (:1word (:data-mode :MOVE.W :rgD1));MOVE (:1word :arg1);#data (if (ge :arg3 0) (:fill-field :LSL.W :D1_dst_field) (:fill-field :LSR.W :D1_dst_field)) ) (t ; LSR/L.W #n,:arg1 (:dst-field (if (ge :arg3 0) :LSL.Wd :LSR.Wd) :arg1)) )) (:ins68k-dst :MOVE.L :arg2 ()) )))) ; MOVE.L D0,op (LXOR ; (LXOR A2 A1) (:logxx :EORI.W :EOR.W t) ) ; ; Les autres instructions (par ordre alpha) ; (ADJSTK ; (ADJSTK 'nb) (if (:fixp :arg1) (let ( (n (mul 4 (cadr :arg1))) ) (unless (eq n 0) (if (gt n 0) (if (le n 8) ; ADDQ.L #n,A7 (:1word (:dst-field (:fill-field :ADDQ.L :eaSP) n)) ; ADDA.L #n,A7 (:1word (:data-mode :ADDA.L :rgSP)) (:1long n) ) (setq n (sub 0 n)) (if (le n 8) ; SUBQ.L #n,A7 (:1word (:dst-field (:fill-field :SUBQ.L :eaSP) n)) ; SUBA.L #n,A7 (:1word (:data-mode :SUBA.L :rgSP)) (:1long n) )))) ; MOVE.L arg,D0 / LSL #2,D0 / ADDA.L D0,A7 (:ins68k-src :MOVE.L :arg1) (:1word (:dst-field :LSL.Ld 2)) (:1word (:dst-field :ADDA.L :rgSP)) )) (BRA ; (BRA ) == BRA lab (:brarel :BRA :arg1) (:align)) (BRI ; (BRI ) (if (:reg-operand? :arg1) ; JMP (reg) (:ins68k-src :JMP `(val ,:arg1)) ; MOVE.L op,A0 / JMP (A0) (:ins68k-src (:direct-add-mode :MOVE.L :rgAUX0 t) :arg1) (:1word :JMP)) (:align)) (BRX ; (BRX table registre) ; MOVE.L registre,D0 / ADD.L D0,D0 / LEA.L 6(PC,D0.L),A0 (:ins68k-src :MOVE.L :arg2) (:1word :ADD.L) (:1word (:fill-field :LEA :indirect-pcm-pindx-mask)) (:1word (+ #$0800 6)) ; ADDA.W (A0),A0 / JMP (A0) (:1word (:indirect-add-mode :ADDA.W :rgAUX0)) (:1word :JMP) (let ((val)) (mapc (lambda (etq) (setq val (:valadrel (cadr etq))) (cond ((:check16 val) (:1word val)) (t (:addlabel (cadr etq) 16) (:1word 0)) )) :arg1 )) (:align)) (CALL ; (CALL ) (:brarel :BSR :arg1)) (CAR ; (CAR A1/A2/A3) == MOV (Ax),Ax ?!?!? obsolete (:ins `(MOV (CAR ,:arg1) ,:arg1)) ) (CDR ; (CDR A1/A2/A3) == MOV 4(Ax),Ax ?!?!?!? obsolete (:ins `(MOV (CDR ,:arg1) ,:arg1)) ) (HBMOVX ; (HBMOVX val string index) ; On met le pointeur sur le heap dans A0. (:load-heap-address-in-A0 :arg2) ; MOVE.L val,D0 (:ins68k-src :MOVE.L :arg1) (cond ((:fixp :arg3) ; MOVE.B D0,index(A0) (:1word (:indirect-add-disp-mode :MOVE.B :rgAUX0 t));#$1140 (:1word (add 8 (cadr :arg3))) ) ((:reg-operand? :arg3) ; MOVE.B D0,8(A0,Ax.L) (:1word (:indirect-add-indx-mode :MOVE.B :rgAUX0 t));#$1180 (:1word (:indirect-index :arg3 8 0)) ) (t ; MOVE.L index,D1 / MOVE.B D0,8(A0,D1.L) (:ins68k-src (:fill-field :MOVE.L :D1_dst_field) :arg3) (:1word (:indirect-add-indx-mode :MOVE.B :rgAUX0 t));#$1180 (:1word (:indirect-index 'D1 8 0)) ))) (HBXMOV ; (HBXMOV string index val) ; On met le pointeur sur le heap dans A0. (:load-heap-address-in-A0 :arg1) ; CLR.L D0 (:1word :CLR.L) (cond ((:fixp :arg2) ; MOVE.B index(A0),D0 (:1word (:indirect-add-disp-mode :MOVE.B :rgAUX0)) (:1word (add 8 (cadr :arg2))) ) ((:reg-operand? :arg2) ; MOVE.B 8(A0,Ax.L),D0 (:1word (:indirect-add-indx-mode :MOVE.B :rgAUX0));#$1030) (:1word (:indirect-index :arg2 8 0)) ) (t ; MOVE.L index,D1 / MOVE.B 8(A0,D1.L),D0 (:ins68k-src (:fill-field :MOVE.L :D1_dst_field) :arg2) (:1word (:indirect-add-indx-mode :MOVE.B :rgAUX0));#$1030) (:1word (:indirect-index 'D1 8 0)) )) ; MOVE.L D0,val (:ins68k-dst :MOVE.L :arg3 ()) ) (HGSIZE ; (HGSIZE ) ; On met le pointeur sur le heap dans A0. (:load-heap-address-in-A0 :arg1) ; MOVE.L 4(A0), (:ins68k-dst (:indirect-add-disp-mode :MOVE.L :rgAUX0);#$2028 :arg2 4) ) (HPMOVX ; (HPMOVX val vect index) ; On met le pointeur sur le heap dans A0. (:load-heap-address-in-A0 :arg2) (cond ((and (:fixp :arg3) (lt (cadr :arg3) #.(- #$4000 8)));0011 1111 1111 1000=16376 ; index constant sur 16 bits ; MOVE.L val,index(A0) (:ins68k-src (:indirect-add-disp-mode :MOVE.L :rgAUX0 t);#$2140 :arg1) (:1word (add 8 (mul 4 (cadr :arg3)))) ) ((:fixp :arg3) ; index constant sur 32 bits ; MOVE.L 8+4*index,D0 / :MOVE.L val,0(A0,D0.L) (:1word (:data-mode :MOVE.L :rgD0));#$203C) (:1long (add 8 (mul 4 (cadr :arg3)))) (:ins68k-src (:indirect-add-indx-mode :MOVE.L :rgAUX0 t);#$2180 :arg1) (:1word (:indirect-index 'D0 0 0)) ) (:MC68020 ; index variable avec 68020 (indirect index scaled) (cond ((:reg-operand? :arg3) ; MOVE.L val,8(A0,:arg3.L*4) (:ins68k-src (:indirect-add-indx-mode :MOVE.L :rgAUX0 t) :arg1) (:1word (:indirect-index :arg3 8 2))) (t ; MOVE.L :arg3,D0 ; MOVE.L val,8(A0,D0.L*4) (:ins68k-src :MOVE.L :arg3) (:ins68k-src (:indirect-add-indx-mode :MOVE.L :rgAUX0 t) :arg1) (:1word (:indirect-index 'D0 8 2))))) (t ; index variable sans scaling ; MOVE.L index,D0 / LSL #2,D0 / MOVE.L val,8(A0,D0.L) (:ins68k-src :MOVE.L :arg3) (:1word (:dst-field :LSL.Ld 2)) (:ins68k-src (:indirect-add-indx-mode :MOVE.L :rgAUX0 t);#$2180 :arg1) (:1word (:indirect-index 'D0 8 0)) ))) (HPXMOV ; (HPXMOV vect index val) ; On met le pointeur sur le heap dans A0. (:load-heap-address-in-A0 :arg1) (cond ((and (:fixp :arg2) (lt (cadr :arg2) #.(- #$4000 8))) ; MOVE.L index(A0),val (:ins68k-dst (:indirect-add-disp-mode :MOVE.L :rgAUX0) :arg3 (add 8 (mul 4 (cadr :arg2)))) ) ((:fixp :arg2) ; MOVE.L 8+4*index,D0 / MOVE.L 0(A0,D0.L),val (:1word (:data-mode :MOVE.L :rgD0));#$203C) (:1long (add 8 (mul 4 (cadr :arg2)))) (:ins68k-dst (:indirect-add-indx-mode :MOVE.L :rgAUX0) :arg3 (:indirect-index 'D0 0 0)) ) (:MC68020 ; index variable avec 68020 (indirect index scaled) (cond ((:reg-operand? :arg2) ; MOVE.L 8(A0,:arg2.L*4),val (:ins68k-dst (:indirect-add-indx-mode :MOVE.L :rgAUX0) :arg3 (:indirect-index :arg2 8 2))) (t ; MOVE.L :arg2,D0 ; MOVE.L 8(A0,D0.L*4),val (:ins68k-src :MOVE.L :arg2) (:ins68k-dst (:indirect-add-indx-mode :MOVE.L :rgAUX0) :arg3 (:indirect-index 'D0 8 2))))) (t ; MOVE.L index,D0 / LSL #2,D0 / MOVE.L 8(A0,D0.L),val (:ins68k-src :MOVE.L :arg2) (:1word (:dst-field :LSL.Ld 2)) (:ins68k-dst (:indirect-add-indx-mode :MOVE.L :rgAUX0) :arg3 (:indirect-index 'D0 8 0)) ))) ((JCALL JMP) ; (JCALL ) == jsr (FVALQ :arg1) ; (JUMP ) == jmp (FVALQ :arg1) (:ins68k-jump-or-call :codop :arg1) ) (MOV ; (MOV source dest) (if (and (consp :arg1) ;(MOV (@ arg1) arg2) (eq (car :arg1) '@)); ; C'est un LEA relatif a` PC. (let ((:reg (:cmp-reg? :arg2))) (if :reg ; LEA d(PC),reg (:1word (logor (:fill-field :LEA :indirect-pc-disp-mask) :reg)) ; LEA d(PC),A0 (:1word (:fill-field :LEA :indirect-pc-disp-mask)) ) (let* ((adr (cadr :arg1)) (val (:valadrel adr))) (if (:check16 val) ; Deplacement en arrie`re. (:1word val) ; Deplacement en avant d'une adresse locale. (if (and (symbolp adr) (null (assq adr :llabels))) ; dans les ENTRY (:addentry adr) ; dans les LOCAL (:addlabel adr 16) ) (:1word 0) )) (unless :reg ; MOV A0,dest (:ins68k-dst (:direct-add-mode :MOVE.L :rgAUX0) :arg2 ()))) (ifn (and (:fixp :arg1) (ge (cadr :arg1) 0) (lt (cadr :arg1) 127)) ; Le MOV normal. (:ins68k-src-dst :MOVE.L :arg1 :arg2) ; MOVEQ #source,D0 / MOVE.L D0,dest ; On gagne 4 ticks (1 acces 32b) et 16bits de code !! (:1word (logor :MOVEQ (logand (cadr :arg1) #$FF))) (:ins68k-dst :MOVE.L :arg2 ())))) (MOVXSP ; (MOVXSP val index) (cond ((:fixp :arg2) ; MOVE.L val,index(SP) (:ins `(mov ,:arg1 (& ,(cadr :arg2)))) ) (:MC68020 (cond ((:reg-operand? :arg2) ; MOVE.L val,0(SP,index.L*4) (:ins68k-src (:indirect-add-indx-mode :MOVE.L :rgSP t) :arg1) (:1word (:indirect-index :arg2 0 2))) (t ; MOVE.L index,D0 ; MOVE.L val,0(SP,D0.L*4) (:ins68k-src :MOVE.L :arg2) (:ins68k-src (:indirect-add-indx-mode :MOVE.L :rgSP t) :arg1) (:1word (:indirect-index 'D0 0 2))))) (t ; MOVE.L index,D0 / LSL #2.D0 / MOVE.L val,0(SP,D0.L) (:ins68k-src :MOVE.L :arg2) (:1word (:dst-field :LSL.Ld 2));#$E588 (:ins68k-src (:indirect-add-indx-mode :MOVE.L :rgSP t) :arg1) (:1word (:indirect-index 'D0 0 0)) ))) (NOP ; (NOP) ne fait rien mais perd du temps et de la place (:1word :NOP)) (POP ; (POP ) = MOVE.L (A7)+,op = MOVEA.L (A7)+,op (:ins68k-dst :POP :arg1 ())) (PUSH ; (PUSH ) (ifn (and (consp :arg1) (eq (car :arg1) '@)) ; Le PUSH normal = MOVE.L op,-(A7) (:ins68k-src :PUSH :arg1) ; C'est un PEA relatif a` PC. (:1word (:fill-field :PEA :indirect-pc-disp-mask));#$487A (let* ((adr (cadr :arg1)) (val (:valadrel (cadr :arg1)))) (if (:check16 val) ; Deplacement en arrie`re. (:1word val) ; Deplacement en avant d'une adresse locale. (if (and (symbolp adr) (null (assq adr :llabels))) ; dans les ENTRY (:addentry adr) ; dans les LOCAL (:addlabel adr 16) ) (:1word 0) )))) (RETURN ; (RETURN) (:1word :RTS) (:align)) (SOBGEZ ; (SOBGEZ op lab) ; DECR op (:arithm 'diff ''1 :arg1) ; BGE lab (:brarel :BGE :arg2) ) (SSTACK ; (SSTACK op) == MOVE.L op,A7 (:ins68k-src (:direct-add-mode :MOVE.L :rgSP t) :arg1) ) (STACK ; (STACK op) == MOVE.L A7,op (:ins68k-dst (:direct-add-mode :MOVE.L :rgSP) :arg1 ()) ) (XSPMOV ; (XSPMOV index val) (cond ((:fixp :arg1) ; MOVE.L index(SP),val (:ins `(mov (& ,(cadr :arg1)) ,:arg2)) ) (:MC68020 (cond ((:reg-operand? :arg1) ; MOVE.L 0(SP,index.L:4),val (:ins68k-dst (:indirect-add-indx-mode :MOVE.L :rgSP) :arg2 (:indirect-index :arg1 0 2))) (t ; MOVE.L index,D0 ; MOVE.L 0(SP,D0.L*4),val (:ins68k-src :MOVE.L :arg1) (:ins68k-dst (:indirect-add-indx-mode :MOVE.L :rgSP) :arg2 (:indirect-index 'D0 0 2))))) (t ; MOVE.L index,D0 / LSL #2.D0 / MOVE.L 0(SP,D0.L),val (:ins68k-src :MOVE.L :arg1) (:1word (:dst-field :LSL.Ld 2)) (:ins68k-dst (:indirect-add-indx-mode :MOVE.L :rgSP);#$2037 :arg2 (:indirect-index 'D0 0 0)) ))) ; ; c'est donc une erreur ; (t (if (setq :f (getfn1 'ld-codop :codop)) (apply :f obj) (:error "MACHINS" obj))) )) ; .Section "Les fonctions auxiliaires de ge'ne'ration" (de :generatecall2subr (fnt lab) ; engendre un appel a` la fonction #:llcp:"fnt" avec les arguments ; :arg1 :arg2, i.e. :arg2 op :arg1 -> :arg2. ; Avec une pile de la forme suivante : ; ... / :arg2 / adr-ret / :arg1 // ; La valeur de retour remplace :arg2, adr-ret et :arg1 sont de'pile's. ; Si est pre'sent, branchement a` si la valeur retourne'e ; par la fonction est = a` 0, sinon si = (), chargement de la ; valeur de tretour dans :arg2. (:ins68k-src :PUSH :arg2) ; PUSH arg2 (:1word (:fill-field :PEA :indirect-pc-disp-mask)) ; PEA ad (let ((pc (:copyPC)) (:localstack (add :localstack 2))) (:1word 0) ; sera re'solu a` la fin. (:ins68k-src :PUSH :arg1) ; PUSH arg1 (:ins68k-jump-or-call 'JMP fnt) ; JMP (memory pc (subadr :PCcurrent pc)) ) (ifn lab (:ins68k-dst :POP :arg2 ()) ; POP arg2 (:1word :POP) ; POP D0 (:brarel :BNE lab) )) ; BNE lab (dmd :fixp (arg) ; Teste si l'ope'rande est un entier (ou pluto^t "(QUOTE entier)") ; attention a` la triple e'valuation ... `(and (consp ,arg) (eq (car ,arg) 'QUOTE) (fixp (cadr ,arg)))) (dmd :reg-operand? (r) `(memq ,r '(a1 a2 a3 a4)) ) (dmd :copyPC () ; Rame`ne une copie du compteur ordinal. `(cons (car :PCcurrent) (cdr :PCcurrent))) (de :check8 (n) ; teste si l'adresse ou le nb tient sur 8 bits ; Attention a` la tole'rance (de 3 octets de chaque co^te'). (if (and (fixp n) (ge n -125) (le n 124)) n ())) (de :check16 (n) ; teste si l'adresse ou le nb tient sur 16 bits ; ?!?!?!? a` revoir le coup du 15e`me bit!!! (0 . #$8000) (cond ((null n) ()) ((fixp n) n) ((consp n) (if (or (eq (car n) 0) (eq (car n) -1)) (cdr n) (:error "CHECK16" (list obj n)) 0)) (t (:error "CHECK16" n) 0))) (defmacro :data-reg? (r) `(le ,r :eaD7)) ; :eaAi >> :eaD7 (de :what-cmp (dst) ; genere le CMP adequat, selon l'adresse effective du registre destination. ; : :eaDi / :eaAi (if (:data-reg? dst) (:dst-field :CMP.L dst) (:dst-field :CMPA.L ; On ne garde que le numero de reg: (logand dst #$0007)) ; xxxx xxxx xxxx xrrr )) (de :brtf1 (cmpreg br) ; CMP :arg1,REG / br :arg2 (:ins68k-src cmpreg :arg1) (:brarel br :arg2)) (de :brt2 (cmpreg1 cmpreg2) ; CMP :arg1,REG1 / BHI @ / CMP :arg1,REG2 / BHI :arg2 / @ (:ins68k-src cmpreg1 :arg1) (let ( (pc (:copyPC)) ) ; Reserve la place pour le BHI sur 8 bits. (:1word 0) (:ins68k-src cmpreg2 :arg1) (:brarel :BHI :arg2) (memory pc (logor :BHI (subadr (subadr :PCcurrent pc) 2))) )) (de :brf2 (cmpreg1 cmpreg2) ; CMP :arg1,REG1 / BHI :arg2 / CMP :arg1,REG2 / BLS :arg2 (:ins68k-src cmpreg1 :arg1) (:brarel :BHI :arg2) (:ins68k-src cmpreg2 :arg1) (:brarel :BLS :arg2) ) (de :cmpeq-ne (op1 op2) ; Pour generer un CMPx.x selon les arguments, ; pour les EQ et NEQ (operations commutatives!) (let ( (:reg (:cmp-reg? op2)) ) (cond (:reg ; CMPA.L op1,reg (:ins68k-src (logor :CMPA.L :reg) op1) ) ((setq :reg (:cmp-reg? op1)) ; CMPA.L op2,reg (:ins68k-src (logor :CMPA.L :reg) op2) ) ((:fixp op1) (if (:fixp op2) (if (eq (cadr op2) (cadr op1)) ; CMP.B D0,D0 (:1word :CMP.B) ; CMP.L NIL,RBCONS (:1word (:fill-field (:what-cmp :rgBCONS) :rgNIL)) ) ; CMPI #op1,op2 (:ins68k-src+2 :CMPI.L op2 (cadr op1)) )) ((:fixp op2) ; CMPI #op2,op1 (:ins68k-src+2 :CMPI.L op1 (cadr op2)) ) (t ; MOV op1,D0 / CMP.L op2,D0 (:ins68k-src :MOVE.L op1) (:ins68k-src :CMP.L op2) )))) (de :cmp-reg? (op) ; si est un registre, retourne son code de'cale' de 9 ; sinon retourne (). (selectq op (a1 #.(logshift :rgA1 9));#$0200 (a2 #.(logshift :rgA2 9));#$0400 (a3 #.(logshift :rgA3 9));#$0600 (a4 #.(logshift :rgA4 9));#$0800 (t ()))) (de :cmp-numerical-and-branch (branch1 branch2) ; branch1 si les arguments ne sont pas inverse's ; branch2 si les arguments sont inverse's ; MOVE arg1,D0 / CMP.W arg2,D0 / Bbranch arg3 (when (and (consp :arg1) (eq (car :arg1) 'QUOTE)) ; :ins68k-src-word est plus efficace si l'argument est ; imme'diat (constante sur 16 bits). (psetq :arg1 :arg2 :arg2 :arg1) (setq branch1 branch2)) (:ins68k-src :MOVE.L :arg1) (:ins68k-src-word :CMP.W :arg2 ()) (:brarel branch1 :arg3) ) (de :arithm (fnt op1 op2) ; = 'plus ! 'diff (let ((:reg (:cmp-reg? op2)) (cop1 (if (eq fnt 'plus) :ADDQ.W :SUBQ.W)) ; [ADD/SUB]Q.W (cop2 (if (eq fnt 'plus) :ADD.W :SUB.W)) ; [ADD/SUB].W (cop3 (if (eq fnt 'plus) :ADDI.W :SUBI.W))) ; [ADD/SUB]I.W (cond ((and (:fixp op1) (le (cadr op1) 8) (gt (cadr op1) 0)) ; petite constante sur 3 bits ; ]0,,8] (ifn :reg ; ADDQ.W #op1,op2 (:ins68k-src-word (:dst-field cop1 (cadr op1)) op2 ()) ; Il n'est pas possible d'utiliser ADDQW sur les registres Ax ; car en cas de de'bordement il pollue la partie haute ; du registre Ax : (INCR -1) -> #$1!0000 ; MOVE.L op2,D0 / ADDQ.W #op1,D0 / MOVE.L D0,op2 (:ins68k-src :MOVE.L op2) (:1word (:dst-field cop1 (cadr op1))) (:ins68k-dst :MOVE.L op2 ()) )) ((:fixp op1) (ifn :reg ; ADDI.W #op1.W,op2 (:ins68k-src-word cop3 op2 (cadr op1)) ; MOVE.L op2,D0 / ADDI.W #op1,D0 / MOVE.L D0,op2 (:ins68k-src :MOVE.L op2) (:1word cop3) (:1word (cadr op1)) (:ins68k-dst :MOVE.L op2 ()) )) (t ; MOVE.L op2,D0 / ADD.W op1,D0 / MOVE.L D0,op2 (:ins68k-src :MOVE.L op2) (:ins68k-src-word cop2 op1 ()) (:ins68k-dst :MOVE.L op2 ()) )))) (de :logxx (cop1 cop2 flag) ; & decrivent les code operation de AND{I}.W ou OR{I}.W ; ou encore EOR{I}.W ; Dans les comentaire, on trouve ANDI.W. (cond ((:fixp :arg1) (ifn (:reg-operand? :arg2) ; ANDI.W #arg1,arg2 (:ins68k-src-word cop1 :arg2 (cadr :arg1)) ; MOVE.L An,D0 / ANDI.W #arg1,D0 / MOVE.L D0,An (:ins68k-src :MOVE.L :arg2) (:1word cop1) (:1word (cadr :arg1)) (:ins68k-dst :MOVE.L :arg2 ()) )) ((not (:reg-operand? :arg2)) ; MOVE.L arg1,D0 / AND.W D0,arg2 (:ins68k-src :MOVE.L :arg1) (:ins68k-src-word (logor cop2 #$0100) :arg2 ()) ) ((or flag (:reg-operand? :arg1)) ; MOVE.L arg1,D1 / MOVE arg2,D0 / AND.W D1,D0 / MOVE.L D0,arg2 (:ins68k-src (:dst-field :MOVE.L :rgD1) :arg1) (:ins68k-src :MOVE.L :arg2) (:1word (logor cop2 (if flag #$0101 #$0001))) (:ins68k-dst (if flag (:fill-field :MOVE.L :rgD1) :MOVE.L) :arg2 ()) ) (t ; MOVE.L An,D0 / AND.W arg1,D0 / MOVE.L D0,An (:ins68k-src :MOVE.L :arg2) (:ins68k-src-word cop2 :arg1 ()) (:ins68k-dst :MOVE.L :arg2 ()) ))) (de :load-heap-address-in-A0 (op) (if (:reg-operand? op) ; MOVE.L op,A0 (:ins68k-src (:direct-add-mode :MOVE.L :rgAUX0 t);#$2040 `(val ,op)) ; MOVE.L op,A0 / MOVE.L (A0),A0 (:ins68k-src (:direct-add-mode :MOVE.L :rgAUX0 t) op) (:1word (:indirect-add-mode ; MOVE.L (A0),... (:direct-add-mode :MOVE.L :rgAUX0 t) ; ...,A0 :rgAUX0)))) (dmd :indirect-index (:reg d scale) ; Le mot supple'mentaire pour un d(A0,reg.L*scale). ; 15 14 13 12 11 10 09 08 07 06 05 04 03 02 01 00 : default pour D = 0800 ;D/A r r r W/L scale 0 d d d d d d d d : default pour A = 8800 ; un diffe'rent de 0 n'est pre'sent que sur ; le 68020: Valeurs possibles : 0 1 2 3 (if (and (fixp d)(fixp scale) (memq :reg '(D0 D1 A1 A2 A3 A4))) (logor (logor (selectq :reg (D0 #.(logor #$0800 (logshift :rgD0 12))) (D1 #.(logor #$0800 (logshift :rgD1 12))) (A1 #.(logor #$8800 (logshift :rgA1 12))) (A2 #.(logor #$8800 (logshift :rgA2 12))) (A3 #.(logor #$8800 (logshift :rgA3 12))) (A4 #.(logor #$8800 (logshift :rgA4 12)))) d) (logshift scale 9)) `(logor (logor (selectq ,:reg (D0 #.(logor #$0800 (logshift :rgD0 12))) (D1 #.(logor #$0800 (logshift :rgD1 12))) (A1 #.(logor #$8800 (logshift :rgA1 12))) (A2 #.(logor #$8800 (logshift :rgA2 12))) (A3 #.(logor #$8800 (logshift :rgA3 12))) (A4 #.(logor #$8800 (logshift :rgA4 12))) (t (:error "INDIRECT-INDEX " ,:reg))) ,d) (logshift ,scale 9)) )) (de :cfltxx (instr) ; Une instruction de comparaison "speciale 68881". (selectq instr (#:llcp:FBEQ (:1word :FBEQ)); #$F281 (#:llcp:FBNE (:1word :FBNE)); #$F28E (#:llcp:FBGT (:1word :FBGT)); #$F292 (#:llcp:FBGE (:1word :FBGE)); #$F293 (#:llcp:FBLT (:1word :FBLT)); #$F294 (#:llcp:FBLE (:1word :FBLE)); #$F295 ) ; label = :arg3 (:fdplrel :arg3) ) (de :fdplrel (adr) ; engendre le dpl/adr utilise' par le saut des floattants 68881 ; ?!?! ERREUR si un module > 64k (cf ENTRY) ?!?!? (let ((dpl (:valadrel adr))) (cond ((:check8 dpl) ; Branchement en arrie`re de 8 bits. (:1word dpl)) ((:check16 dpl) ; Branchement en arrie`re de 16 bits. (ifn (and (fixp dpl) (le dpl 0)) ; C'est plus que 15 bits (:error "Module trop gros" :module) (:1word dpl))) ; ((:notoofar adr :lobj) ; ; Branchement en avant de 8 bits. ; (:addlabel adr 8) ; (:1word codop) ) (t ; Branchement en avant de 16 bits. (if (and (symbolp adr) (null (assq adr :llabels))) ; dans les ENTRY (:addentry adr) ; dans les LOCAL (:addlabel adr 16) ) (:1word 0))))) ; Les ope'rations sur les flottants. ; Les flottants 31 bits. (de :float32>31 (x op?) ; transforme l'operande 32 bits en 31 bits dans FP0 ; ou l'applique a FP0 via l'instruction ; MOVE.L operand,D0 / LSL.L #1,D0 / (:ins68k-src :MOVE.L x) (:1word (:dst-field :LSL.Ld 1));#$E388 (selectq op? (#:llcp:fadd ; FADD.S D0,FP0 (:1word :F68881.1)(:1word :FADD.S)) (#:llcp:fsub ; FSUB.S D0,FP0 (:1word :F68881.1)(:1word :FSUB.S)) (#:llcp:fmul ; FMUL.S D0,FP0 (:1word :F68881.1)(:1word :FMUL.S)) (#:llcp:fdiv ; FDIV.S D0,FP0 (:1word :F68881.1)(:1word :FDIV.S)) (#:llcp:fcmp ; FCMP.S D0,FP0 (:1word :F68881.1)(:1word :FCMP.S)) (t ; FMOVE.S D0,FP0 (:1word :F68881.1)(:1word :FMOVE.S)) )) (de :float31>32 (:reg) ; Transforme un float 31 bits present dans FP0 en float 32 bits dans . ;FMOVE.D FP0,D0 (:1word :F68881.1)(:1word (:fill-field :FMOVE.D #$2000)) ;BSET #0,D0 / ROR.L #1,D0 (:1word :BSET.Ld)(:1word #$0000) (:1word (:dst-field :ROR.Ld 1)) ;MOVE.L D0,reg (:ins68k-dst :MOVE.L :reg ()) ) ; Les flottants 64 bits. (de :float64 (arg op?) ; Transfert l'operande pointe par dans FP0, ou bien ; realise l'instruction entre l'operande pointe par et FP0. ; MOVE.L arg,A0 (:ins68k-src :MOVEA.L arg) (selectq op? (#:llcp:fcmp ; FCMP.D A0(0),fp0 (:1word :F68881.2)(:1word :FCMP.D)(:1word #$0000)) (t ; FMOVE.D (A0),fp0 (:1word :F68881.2)(:1word (:fill-field :FMOVE.D #$1000))(:1word #$0000)) )) ; .Section "Les fonctions de chargement des ope'randes" (de :ins68k-src-dst (cop src dest) ; Charge l'instruction 68000 avec ses deux ope'randes. ; Doit avoir le format du MOVE: ccccDDDDddddSSSSssss (let ( (pc1 (car :PCcurrent)) (pc2 (cdr :PCcurrent)) ) (:1word cop) (setq src (:op68k src ())) (setq dest (:op68k dest ())) (:1word_pc pc1 pc2 (logor (logor cop src) (logand (logor (logshift dest 3) (logshift dest 9)) #$0FC0))))) (de :ins68k-src (cop op) ; Charge l'instruction 68000 avec son ope'rande source. (let ( (pc1 (car :PCcurrent)) (pc2 (cdr :PCcurrent)) ) (:1word cop) (:1word_pc pc1 pc2 (logor cop (:op68k op ()))) )) (de :ins68k-src+2 (cop op n) ; Charge l'instruction 68000 avec son ope'rande source. ; Charge avant la source l'immediat 32bits n (let ( (pc1 (car :PCcurrent)) (pc2 (cdr :PCcurrent)) ) (:1word cop) (:1long n) (:1word_pc pc1 pc2 (logor cop (:op68k op ()))) )) (de :ins68k-src-word (cop op n) ; Charge l'instruction 68000 avec son ope'rande source. ; On charge si il y lieu le mot n avant l'ope'rande source. (let ((pc1 (car :PCcurrent)) (pc2 (cdr :PCcurrent))) (:1word cop) (when n (:1word n)) (:1word_pc pc1 pc2 (logor cop (:op68k op t))) )) (de :ins68k-dst (cop op n) ; Charge l'instruction 68000 avec son ope'rande destination. ; On charge si il y lieu le mot n avant l'ope'rande destination. (let ( (pc1 (car :PCcurrent)) (pc2 (cdr :PCcurrent)) ) (:1word cop) (when n (:1word n)) (setq op (:op68k op ())) (:1word_pc pc1 pc2 (logor cop (logand (logor (logshift op 3) (logshift op 9)) #$0FC0 ))))) (de :op68k (operand word?) ; Retourne un ope'rande sur 6 bits : [ mod ! reg ] ; word? = T, s'il s'agit d'un ope'rande de type mot de 16 bits ; (utilise' dans les acce`s me'moire). (cond ((eq operand 'nil) ; ope'rande nil (en fait !!) :eaNIL ) ((eq operand 'A1) ; ope'rande direct registre = A1 :eaA1 ) ((eq operand 'A2) ; ope'rande direct registre = A2 :eaA2 ) ((eq operand 'A3) ; ope'rande direct registre = A3 :eaA3 ) ((eq operand 'A4) ; ope'rande direct registre = A4 :eaA4 ) ((eq operand 'AUX0) ; ope'rande direct registre :eaAUX0 ) ; ((and (eq operand 'DLINK) ; (boundp ':rgDLINK)) ;DLINK est-il dans un registre? ; ; operande direct registre = DLINK ; :eaDLINK) ((memq operand '(LLINK DLINK CBINDN TAG LOCK PROT)) (:1long (symeval (symbol 'llcp operand))) (if (memq operand '(LLINK DLINK));ce ne sont pas des registres... ; ...Ce sont des mots me'moire. #$39 ; Les autres sont des adresses immediates. @cbindx. :data-mask ) ) ((atom operand) ; ne doit jamais arriver pour le compilo ; sauf en cas de nouvelles de'finitions. (if (and (symbolp operand) (setq :f (getfn1 'ld-dir operand))) (funcall :f operand) (:error ':op68k operand) )) ((eq (car operand) 'QUOTE) ; une constante lisp imme'diate sur 32 bits! (unless (or (and :31BITFLOATS (floatp (cadr operand))) (fixp (cadr operand)) ) ; c'est un litte'ral a` sauver (if (and :stopcopy (consp (cadr operand))) (:add-cons-llitt (cadr operand) :PCcurrent) (:add-llitt (cadr operand)))) (if word? (progn (if (fixp (cadr operand)) (:1word (cadr operand)) (:error ':op68k (list operand word?))) #$3C) (progn (:1long (loc (cadr operand))) #$3C ))) ((eq (car operand) '@) ; une constante adresse me'moire code machine ; est touours une e'tiquette locale; ; engendre TOUJOURS un de'placement par rapport au PC. ; Les cas utilis'es par le compilateur sont : ; MOV, PUSH et BRX qui sont traite's directement. ; ?!?! a` terminer ?!?! (:error ':op68k operand)) ((eq (car operand) '&) ; (& ) Le nie`me pointeur de la pile (if (or (not (fixp (cadr operand))) (lt (cadr operand) 0)) (:error ':op68k operand) (let ((n (add (mul 4 (add (cadr operand) :localstack)) (if word? 2 0)))) (if (eq n 0) #$17 (:1word n) #$2F)))) ((and (not word?) (memq (car operand) '(CAR VAL CVAL))) ; adressage indirect simple (selectq (cadr operand) (A1 #$11) (A2 #$12) (A3 #$13) (A4 #$14) (t (:error ':op68k operand)) )) ((memq (car operand) '(CAR VAL CVAL CDR PLIST FVAL PKGC OVAL ALINK PNAME)) ; adressage indirect indexe' (let ((n ())) (setq n (selectq (car operand) (car 0) (val 0) (cval 0) (cdr 4) (plist 4) (fval 8) (pkgc 12) (oval 16) (alink 20) (pname 28) (t (:error ':op68k operand)) )) (when word? (setq n (add n 2))) (:1word n) ) (selectq (cadr operand) (A1 #$29) (A2 #$2A) (A3 #$2B) (A4 #$2C) (t (:error ':op68k operand)) )) ((eq (car operand) 'CVALQ) ; la C-valeur Lisp d'un symbole (ifn (symbolp (cadr operand)) (:error ':op68k operand) (:op68kquotesymb (cadr operand) (if word? 2 0)) )) ((eq (car operand) 'FVALQ) ; la F-valeur Lisp d'un symbole (if (or word? (not (symbolp (cadr operand)))) (:error ':op68k operand) (:op68kquotesymb (cadr operand) 8) )) ((eq (car operand) 'eval) ; Pour calculer des ope'randes a` load time. (or (car (catcherror () (:op68k (eval (cadr operand)) word?))) (:error ':op68k operand) )) (t (if (and (symbolp (car operand)) (setq :f (getfn1 'ld-ind (car operand))) ) (funcall :f operand) (:error ':op68k operand) )))) (dmd :fill-field (cop reg) ; Genere le code de l'instruction dont le code operation est , ; et le registre [data!adresse] deja prepare [source!destination],est . ; cccc cccc cccc cccc OR rrrr rrrr rrrr rrrr (if (and (fixp cop)(fixp reg)) (logor cop reg) `(logor ,cop ,reg))) (dmd :dst-field (cop reg) ; Genere le code de l'instruction dont le code operation est , ; et le registre destination, en mode d'adressage direct est . ; cccc cccc cccc cccc OR rrrr rrr0 0000 0000 (if (fixp reg) (if (fixp cop) (logor cop logshift reg 9) `(logor ,cop ,(logshift reg 9))) `(logor ,cop (logshift ,reg 9)))) (dmd :guts-mode (cop modifcop reg flag) ; Cette macros decrit le corps commun a toutes les macros xxx-mode ; ci-dessous. (if (fixp reg) (if (fixp cop) (logor (logor cop modifcop) ; (if flag (logshift reg 9) reg));Une constante `(logor (logor ,cop ,modifcop) ; ,(if flag (logshift reg 9) reg)) );2 logor (if (fixp cop) `(logor ,(logor cop modifcop) ; ,(if flag `(logshift ,reg 9) reg));1 logor 1 logshift `(logor (logor ,cop ,modifcop) ; ,(if flag `(logshift ,reg 9) reg)) ))));2 logor 1 logshift ; ATTENTION: toutes les macros qui suivent [xxx-add-???-mode] pre'-supposent ; que les registres AUX0 et SP sont des registres d'adresse[A0-A7]! (dmd :direct-add-mode (cop reg . dest?) ; A0 ; Genere le code de l'instruction dont le code operation est , ; avec mode d'adressage direct sur registre d'adresse ; (champ ea: 001 xxx): . ; = t : cela concerne l'adresse effective destination, d'un MOVE ; = (): cela concerne l'adresse effective habituelle d'une instruct. `(:guts-mode ,cop ,(if dest? #.(logshift :direct-add-mask 3) ;xxxx rrr0 01xx xxxx :direct-add-mask) ;xxxx xxxx xx00 1rrr ,reg ,dest?)) (dmd :indirect-add-mode (cop reg . dest?) ; (A0) ; Genere le code de l'instruction dont le code operation est , ; avec mode d'adressage indirect sur registre d'adresse ; (champ ea: 010 xxx): . ; = t : cela concerne l'adresse effective destination, d'un MOVE ; = (): cela concerne l'adresse effective habituelle d'une instruct. `(:guts-mode ,cop ,(if dest? #.(logshift :indirect-add-mask 3) ;xxxx rrr0 10xx xxxx :indirect-add-mask) ;xxxx xxxx xx01 0rrr ,reg ,dest?)) (dmd :indirect-add-disp-mode (cop reg . dest?) ; n(Di,Xi) ; Genere le code de l'instruction dont le code operation est , ; avec mode d'adressage indirect et deplacement sur registre d'adresse ; (champ ea: 101 xxx): . ; = t : cela concerne l'adresse effective destination, d'un MOVE ; = (): cela concerne l'adresse effective habituelle d'une instruct. `(:guts-mode ,cop ,(if dest? #.(logshift :indirect-add-disp-mask 3) ;xxxx rrr1 01xx xxxx :indirect-add-disp-mask) ;xxxx xxxx xx10 1rrr ,reg ,dest?)) (dmd :indirect-add-indx-mode (cop reg . dest?) ; n(Di,Xi.f*s) ; Genere le code de l'instruction dont le code operation est , ; avec mode d'adressage indirect avec index sur registre d'adresse ; (champ ea: 110 xxx): . ; = t : cela concerne l'adresse effective destination, d'un MOVE ; = (): cela concerne l'adresse effective habituelle d'une instruct. `(:guts-mode ,cop ,(if dest? #.(logshift :indirect-add-indx-mask 3) ;xxxx rrr1 10xx xxxx :indirect-add-indx-mask) ;xxxx xxxx xx11 0rrr ,reg ,dest?)) (dmd :data-mode (cop reg) ; #data,Di ; Genere le code de l'instruction dont le code operation est , ; le champs source configure une data qui suit l'instruction ; (champ ea: 111 100), et le registre destination est . `(:guts-mode ,cop :data-mask ;xxxx rrrx xx11 1100 ,reg t)) ; .SSection "Ope'rande de type adresse de symbole Lisp" (de :op68kquotesymb (symb displacement) ; charge un ope'rande de type "adresse de symbole" ; est toujours de type symbole. ; est une petite constante a` rajouter a` ; la base du symbole. (:add-llitt symb) ; 2 cas : ; 1 - les 1000 1ers symboles ; numero_du_symbole*32+displacement (BSYMB) ; 2 - tous les autres symboles ; numero_du_symbole*32+displacement (BSYMB) (setq :valaux (subadr (loc symb) :locnil)) (cond ((and (fixp :valaux) (gt :valaux 0) (not (:data-reg? :eaBSYMB))); BSYMB doit etre un reg. d'adresse ; chouette 1 des 1000 1er symboles : (:1word (addadr :valaux displacement)) (logor :rgBSYMB :indirect-add-disp-mask)) (t ; too bad (:1long (if displacement (addadr displacement (loc symb)) (loc symb))) #$39 ))) ; .Section "Gestion des e'tiquettes" ; .SSection "Les e'tiquettes globales (JCALL/JMP)" (de :ins68k-jump-or-call (type symb) ; la F-valeur Lisp d'un symbole pour un JCALL/JMP ; type = JMP ou JCALL (cond ((and (setq :valaux (cassq symb :llabels)) (fixp (setq :valaux (subadr :valaux :PCcurrent)))) ; FENTRY si de'ja` de'fini dans le me^me module et pas loin. ; C'est un BRA / CALL (:brarel (if (eq type 'JMP) :BRA :BSR) symb) (when (eq type 'JMP) (:align))) (t ; Etiquette globale : indirect par la FVAL. (:ins68k-src-dst :MOVE.L `(FVALQ ,symb) 'AUX0) (:1word (if (eq type 'JMP) #$4ED0 #$4E90)) (when (eq type 'JMP) (:align)) ))) ; .SSection "Calcul de la valeur d'une e'tiquette qui existe" (de :valadr (adr) ; calcule la valeur d'une adresse, locale a` un module, de type : ; symbol numb ou constante de type (nh . nl) ; retourne une adresse (h . l) ou bien () si non de'finie (cond ((atom adr) ; e'tiquette symbolique ou nume'rique (cond ((cassq adr :llabels) ; e'tiquette locale re'solue ) ((and (symbolp adr) (getprop adr ':fval)) ; Les fonctions ENTRY de'ja` charge'es (avant END!) ) (t ; sinon non de'finie () ))) (t ; les constantes adresses de type (h . l) (if (and (fixp (car adr)) (fixp (cdr adr))) adr (:error ':valadr adr) )))) (de :valadrel (adr) ; retourne un de'placement par rapport a` PC ou () (when (setq adr (:valadr adr)) (subadr adr :PCcurrent))) ; .SSection "Les e'tiquettes locales BRA/CALL sur 8/16 bits" (de :brarel (codop adr) ; engendre un appel de BRA/CALL ou Bcc sur 8 ou 16 bits ; le est sur 8 bits. :brarel engendre un de'placement ; - sur 8 bits (dans le codop) ; - sur 16 bits (mot suivant) ; ?!?!?! a` faire ?!?!?! ; - sur 32 bits si MC68020 et e'vite l'erreur "module trop gros" (let ((val (:valadrel adr))) (cond ((:check8 val) ; Branchement en arrie`re de 8 bits. (:1word (logor codop (logand #$FF (sub val 2)))) ) ((:check16 val) ; Branchement en arrie`re de 16 bits. (ifn (and (fixp val) (le val 0)) ; C'est plus que 15 bits (:error "Module trop gros" :module) (:1word codop) (:1word (sub val 2)) )) ((:notoofar adr :lobj) ; Branchement en avant de 8 bits. (:addlabel adr 8) (:1word codop) ) (t ; Branchement en avant de 16 bits. (:1word codop) (if (and (symbolp adr) (null (assq adr :llabels))) ; dans les ENTRY (:addentry adr) ; dans les LOCAL (:addlabel adr 16) ) (:1word 0) )))) ; .Section "Les fonctions auxiliaires de chargement me'moire" (de :align () ; aligne le compteur de chargement sur une ; frontie`re de mots de 32 bits (merci 68020) (when (and :align-flag :MC68020 (neq (logand 3 (if (fixp :PCcurrent) :PCcurrent (cdr :PCcurrent))) 0)) (:1word :NOP))) ; charge un NOP! (de :1word (obj) ; charge 1 mot de 16 bits : obj (when :talkp (when (> :nwl 6) (setq :nwl 0) (terpri) (outpos 30) (:prinhex :PCcurrent) (prin " ")) (incr :nwl) (prin " ") (:prinhex obj)) (memory :PCcurrent obj) (incradr :PCcurrent 2)) (de :1word_pc (pc1 pc2 n) ; charge sur 16 bits a` l'adresse (pc1 . pc2) ; essaie de ne pas conser pour refabriquer une adresse. (let ((adr '(0 . 0))) (rplacd (rplaca adr pc1) pc2) (memory adr n) )) (de :1wordrelPC (adr) ; Correspond toujours a` 1 branchement en avant de 16 bits. (let ((n (subadr :PCcurrent adr))) (if (and (fixp n) (ge n 0)) (if (evenp n) (memory adr n) (error ':1wordrelPC "ODD address" (list n adr :PCcurrent))) (:error "Module trop gros" :module) ))) (de :1byterelPC (adr) ; Correspond toujours a` 1 branchement en avant de 8 bits. (let ( (n (subadr (subadr :PCcurrent adr) 2)) ) (cond ((eq n 0) ; On enleve le branchement pour mettre un NOP. (memory adr :NOP) ) ((:check8 n) (memory adr (logor (memory adr) n)) ) ; En cas de proble`me, voir :max-lap-dpl8 (t (:error "BYTErelPC" n)) ))) ; .SSSection "Chargement par paquet de 32 bits" (de :1long (val) ; charge la valeur sur 32 bits (cond ((fixp val) (:1word 0) (:1word val)) ((consp val) (:1word (car val)) (:1word (cdr val))) (t (:error "1LONG" val)))) ;---- Gestion de la table des litte'raux (de :clean-llitt () ; nettoie et sauve la table des litte'raux :saved-by-loader ; dans :global-saved-by-loader sous forme d'un vecteur. ; ne doir e^tre fait qu'au END. (let ((l :saved-by-loader) (i -1) v) (while l (if (and (symbolp (car l)) (or (boundp (car l)) (typefn (car l)))) (setq :saved-by-loader (delq (nextl l) :saved-by-loader)) (nextl l))) (when (gt (length :saved-by-loader) 0) (setq v (makevector (length :saved-by-loader) ())) (while :saved-by-loader (vset v (setq i (add1 i)) (nextl :saved-by-loader))) (if :module (progn (when (get :module ':saved-by-loader) (printerror 'loader "Module de'ja` utilise'" :module)) (putprop :module v ':saved-by-loader)) (newl :global-saved-by-loader v))) (setq :module ()) )) (de :add-llitt (obj) ; rajoute un litte'ral a` la table des litte'raux :saved-by-loader (cond ((memq obj :saved-by-loader)) (t (newl :saved-by-loader obj)))) (de :add-cons-llitt (c a) (newl :local-cons-llitt (cons (vag a) c))) ; .Section "Fonctions de gestion des tables d'e'tiquettes" ; L'algorithme des poids n'est pas utilise' car conside're' comme ; couteux (environ 5% a` 10% du temps de chargement!). ; Le (repeat ...) reste simple, rapide et de bon gou^t ; me^me s'il n'est pas infaillible. ;; Les poids des instructions en octets ;(defvar :weight 8) ; le poids moyen d'une instruction ;(defvar :expansive-weight 24) ; le poids d'1 instruction LAP cou^teuse. ;(defvar :very-expansive-weight 32);le poids d'1 instruction LAP tres couteuse. ; ;(de :notoofar (adr lobj) ; ; Le 680x0 a 2 types de de'placements relatifs : sur 8 et 16 bits. ; ; Pour pouvoir utiliser un petit de'placement, ; ; les branchements en avant utilisent un algorithme: ; ; Les instruction LAP "valent" un poids moyen en octets, ; ; et certaines valent + che`res que d'autres (voire tre`s che`re!) ; (tag ok ; (let ((o 126)) ; pour 8bits ; (mapc (lambda (i) ; (cond ; ((le o 0) ; On est alle trop loin: KO ; (exit ok ())) ; ((eq i adr) ; on a trouve l'etiquette: OK ; (exit ok t)) ; ((consp i) ; (cond ; ((memq (car i) ; '(QUO REM TIMES ; CFBEQ CFBNE CFBGT CFBGE CFBLT CFBLE)) ; ; Instruction LAP qui cou^te che`re ; (decr o :expansive-weight)) ; ((and :MC68881 ; (memq (car i) ; '(FPLUS FDIFF FTIMES FQUO))) ; ; Instruction LAP qui cou^te tre`s che`re ; (decr o :very-expansive-weight)) ; (t ; ; Instruction LAP de cou^t normal ; (decr o :weight))) ))) ; lobj) ; ()))) (de :notoofar (adr lobj) ; Le 680x0 a 2 types de de'placements relatifs : sur 8 et 16 bits. ; Pour pouvoir utiliser un petit de'placement, ; les branchements en avant utilisent une heuristique : ; l'e'tiquette doit e^tre a` moins de instructions LAP ; pour utiliser un de'placement sur 8 bits!!! ; En cas de proble`me, diminuer <:max-lap-dpl8>! (tag ok (repeat :max-lap-dpl8 (when (eq (nextl lobj) adr) (exit ok t)) ) ())) (de :addlabel (sym n) ; rajoute le symbole dans la table des e'tiquettes locales ; (n = 8/16 ) : ce choix est fait par l'appelant de ':addlabel' (let ( (val (assq sym :llabels-nr)) (adr (cons n (:copyPC))) ) (if val (rplacd val (cons adr (cdr val))) (newl :llabels-nr (list sym adr)) ) 0 )) (de :addentry (sym) ; rajoute le symbole une dans la table des re'fe'rences avants ; des ENTRY non re'solus a` l'adresse du PCcurrent. ; retourne 0 (adresse inconnue) (let ((val (assq sym :entries-not-resolved))) (if val (rplacd val (cons (:copyPC) (cdr val))) (newl :entries-not-resolved (list sym (:copyPC)))) 0 )) ;----- Fonction d'impression hexa (de :prinhex (n) ; imprime sur 4 ou 8 chiffres hexa le nb ou l'adresse n (cond ((numberp n) (:prinhexb (logand (logshift n -8) #$FF)) (:prinhexb (logand n #$FF))) ((consp n) (:prinhex (car n)) (:prinhex (cdr n))) (t (error 'memory-dump 'errnna n)))) (de :prinhexb (n) ; imprime sur 2 chiffres hexa le nb n (cond ((not (numberp n)) (error 'memory-dump 'errnna n)) ((< n 0) (setq n 255)) ((< n 16) (princn #/0))) (with ((obase 16)) (prin n))) ;----- Fonction de debbug (de memory-dump (adr n) ; dump la memoire en hexa de sur mots ; attention au SWAB du 68K! octet de poids faibles a gauche! (until (<= n 0) (:prinhex adr) (outpos 10) (let ((adr (copylist adr))) (repeat 8 (:prinhex (memory adr)) (prin " ") (incradr adr 2) )) (decr n) (terpri))) ;----- Fonction auxiliaire d'erreur (de :error (f a) ; erreur dans la fonction f arguments defectueux a (terpri) (print "***** Loader Error in : " f " : " a) (exit :tagerr)) ; .Section "Fonctions principales de chargement" (de loaderesolve () (loader '((end)))) (de loader (:lobj . :talkp) ; <:lobj> est la liste des objets a` charger ; <:talkp> = T si on de'sire un listage hexa du chargement (when (consp :talkp) ; l'argument est optionnel! (setq :talkp (car :talkp))) (let ((:PCcurrent (#:system:ccode)) ; le compteur ordinal courant (:llabels) ; AL des e'tiquette locales (:llabels-nr) ; AL des e'tiquettes locales non re'solues (:llitt) ; liste des litte'raux de la fonction (:fntname 'loader) ; fonction ou` on charge les litte'raux :codop ; variable globale opcode symbolique :arg1 ; itou :arg2 ; itou :arg3 ; itou :localstack ; itou :valaux ; itou pour des valeurs locales. :f ; itou (pour des getfn1) (:nwl 0) ; itou pour tabler le code produit. :local-cons-llitt) ; le re'cupe'rateur d'erreur syste`me (catcherror t ; le re'cupe'rateur des erreurs du chargeur (tag :tagerr ; #:system:ccode ne sera actualise' ; que si tout se passe bien sans erreur (while :lobj (when (gtadr :PCcurrent :Ecode) (with ((outchan ())) (print ERRFCOD) (exit #:system:toplevel-tag))) (setq :nwl 0) ; sert pour tabler le code produit (:ins (nextl :lobj)) (when :talkp (terpri))) ; test des re'fe'rences non re'solues (:ins '(ENDL)) ) ; actualise le nouveau de'but de la zone code (#:system:ccode :PCcurrent) ; actualise les literaux cons (if (and :stopcopy (typefn ':patch-cons-llitt)) (:patch-cons-llitt)) ; actualise #:ld:cons-llitt (setq #:ld:cons-llitt (nconc :local-cons-llitt #:ld:cons-llitt))) ())) ; .Section "Bootstrap" ;;; un peu de texte pour le compilateur, apres l'avoir lu, il ne rale plus ;;; si patch-cons-llitt n'est defini qu'au chargement. (defun #:ld68k:patch-cons-llitt () ()) (when (neq (typefn '#:llcp:nlist) 'subr0) ; Les fonctions internes du compilateur (loader '( (fentry #:llcp:nlist subr0) (pop a3) (mov nil a1) (bra 4) 3 (pop a2) (jcall xcons) 4 (sobgez a4 3) (bri a3) (fentry #:llcp:errwna subr2) ; A1 <- fnt; A2 <- bad-nb-arg (mov a2 a3) (mov 'errwna a2) (jmp error) (end) ) () ) (if :stopcopy (loader '( (fentry #:ld:gcafter-daemon subr0) ; le daemon !!! (mov (cvalq #:ld:cons-llitt) a4) ; les literaux a patcher 5 (btnil a4 6) ; il en reste ? (mov (car a4) a1) ; A1 = (code . cons) (mov (cdr a4) a4) ; la suite (mov (cdr a1) a2) ; A2 = le cons (mov (car a1) a1) ; A1 = le code (mov a2 (car a1)) ; cons -> *code (bra 5) ; on continue 6 (return) ; c'est fini (fentry :patch-cons-llitt subr0) ; contre les courses (push a1) ; sauve les registres (push a2) (push a3) (push a4) (mov (cvalq :local-cons-llitt) a4) ; les literaux locaux (call 5) ; patche (pop a4) ; remet les registres (pop a3) (pop a2) (pop a1) (return) (end) ) () ))) ;;; After loading the compiled version of the loader, we must remove ;;; the expr definitions of all the internal functions. ;;; However, if special-case-loader is positioned, we must ensure that ;;; the loading of this module is completed first. (loader '((end))) (unless (or (eq (typefn 'loaderesolve) 'expr) (get 'loaderesolve 'resetfn)) ; (print "removing internal loader functions") (mapc (lambda (m) (when (typefn m) (remfn m) (remprop m '#:system:loaded-from-file) )) (delq '#:ld68k:ins (oblist 'ld68k) )))