; .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 <name> <ftype> <lparam>)
(: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 <name> <ftype> <lparam>)
(: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 <name>)
; 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 <obj>
(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 <lab>) == BRA lab
(:brarel :BRA :arg1)
(:align))
(BRI ; (BRI <op>)
(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 <sym>)
(: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 <obj> <op>)
; On met le pointeur sur le heap dans A0.
(:load-heap-address-in-A0 :arg1)
; MOVE.L 4(A0),<obj>
(: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 <sym>) == jsr (FVALQ :arg1)
; (JUMP <sym>) == 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 <op>) = MOVE.L (A7)+,op = MOVEA.L (A7)+,op
(:ins68k-dst :POP :arg1 ()))
(PUSH ; (PUSH <op>)
(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 <lab> est pre'sent, branchement a` <lab> si la valeur retourne'e
; par la fonction est = a` 0, sinon si <lab> = (), 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 <fnt>
(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 <n> 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 <n> 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.
; <dst> : :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 <op> 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)
; <fnt> = '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)
; <cop1> & <cop2> 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 <scale> 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 <x> en 31 bits dans FP0
; ou l'applique a FP0 via l'instruction <op?>
; 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 <reg>.
;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 <arg> dans FP0, ou bien
; realise l'instruction <op?> entre l'operande pointe par <arg> 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 <cop> 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 <cop> 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 <cop> 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 <cop> 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 <cop> 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
; <lab> 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) '&)
; (& <n>) 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 <cop>,
; et le registre [data!adresse] deja prepare [source!destination],est <reg>.
; 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 <cop>,
; et le registre destination, en mode d'adressage direct est <reg>.
; 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 <cop>,
; avec mode d'adressage direct sur registre d'adresse
; (champ ea: 001 xxx): <reg>.
; <dest?> = t : cela concerne l'adresse effective destination, d'un MOVE
; <dest?> = (): 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 <cop>,
; avec mode d'adressage indirect sur registre d'adresse
; (champ ea: 010 xxx): <reg>.
; <dest?> = t : cela concerne l'adresse effective destination, d'un MOVE
; <dest?> = (): 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 <cop>,
; avec mode d'adressage indirect et deplacement sur registre d'adresse
; (champ ea: 101 xxx): <reg>.
; <dest?> = t : cela concerne l'adresse effective destination, d'un MOVE
; <dest?> = (): 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 <cop>,
; avec mode d'adressage indirect avec index sur registre d'adresse
; (champ ea: 110 xxx): <reg>.
; <dest?> = t : cela concerne l'adresse effective destination, d'un MOVE
; <dest?> = (): 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 <cop>,
; le champs source configure une data qui suit l'instruction
; (champ ea: 111 100), et le registre destination est <reg>.
`(: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"
; <symb> est toujours de type symbole.
; <displacement> 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 <sur 16 bits> (BSYMB)
; 2 - tous les autres symboles
; numero←du←symbole*32+displacement <sur 32 bits> (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 <codop> 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 <n> 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 <val> 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 <n> ...) 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 <max-lap-dpl8> 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 <sym> dans la table des e'tiquettes locales
; (n = 8/16 <adr>) : 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 <sym> 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 <adr> sur <n> 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) )))