; .EnTete "Le←Lisp version 15.2" " " "Le chargeur me'moire NS 32032"
; .sp 2
; .SuperTitre "Le Chargeur Me'moire NS"
; .Auteur "Francis Dupont"
; .INRIA
; $Header: lapns.ll,v 4.1 88/01/13 12:21:03 kuczynsk Rel $
; Assemble et charge pour un NS 32032 une liste d'instructions LLM3
; en 1 seule passe et avec du code relogeable.
(unless (= (version) 15.2)
(error 'load 'erricf 'lapns))
(defvar #:sys-package:colon 'ldns)
(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).
; 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` 8k ?!?!?
; ?!?!? 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)
(defvar :stopcopy (typefn '#:ld:gcafter-daemon)) ; pour le Stop & Copy
(defvar #:ld:special-case-loader ()) ; cas spe'cial pour charger le chargeur
(defvar #:ld:shared-strings ()) ; rend les constantes de chai↑ne EQ
; .SSection "Les autres variables globales"
; adresse du de'but des flottants
(unless (boundp ':bfloat)
(defvar :bfloat (getglobal "bfloat")))
; adresse du de'but des vecteurs
(unless (boundp ':bvect)
(defvar :bvect (getglobal "bvect")))
; adresse du de'but des chai↑nes
(unless (boundp ':bstrg)
(defvar :bstrg (getglobal "bstrg")))
; adresse du de'but des variables
(unless (boundp ':bvar)
(defvar :bvar (getglobal "bvar")))
(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) ; liste des litte'raux entre 2 ENDs.
(defvar :saved-by-loader ()))
(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 :valaux :f :nwl obj])))
(unless (boundp '#:ld:cons-llitt) (defvar #:ld:cons-llitt ()))
(unless (boundp ':local-cons-llitt) (defvar :local-cons-llitt ()))
; .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)))
(32 ; c'est une r.n.r relative sur 32 bits
(:1doublerelPC (cdr l)))
(0 ; c'est une r.n.r absolue sur 32 bits
(:1doublePC (cdr l)))
(t ; c'est pour un BRX
(:1wordrel (car l) (cdr 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))
(selectq :codop
;
; les pseudos-instructions (par ordre alphabe'tique)
;
(ABORT) ; Pour re'cupe'rer de la me'moire en cas scraschhhh.
(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 (lambda (l)
(selectq (car l)
(16 ; c'est une r.n.r. relative sur 16 bits
(:1wordrelPC (cdr l)))
(32 ; c'est une r.n.r. relative sur 32 bits
(:1doublerelPC (cdr l)))
(0 ; c'est une r.n.r. absolue sur 32 bits
(:1doublePC (cdr l)))
(t ; c'est pour un BRX
(:1wordrel (car l) (cdr l)))))
(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:ftype)
(remprop (caar :entry-list) '#:llcp:fval)
(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))
(remprop (caar #:ld:special-case-loader)
':fval )
(remprop (caar #:ld:special-case-loader)
'#:llcp:ftype )
(remprop (caar #:ld:special-case-loader)
'#:llcp:fval )
(remprop (caar #:ld:special-case-loader)
'#:system:loaded-from-file )
(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)
(setq :valaux :PCcurrent)
(if #:ld:special-case-loader
(newl #:ld:special-case-loader
(list :arg1 :arg2 (copylist :valaux)))
(remprop :arg1 '#:llcp:ftype)
(remprop :arg1 '#:llcp:fval)
(setfn :arg1 :arg2 :valaux))
(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 d'instructions.
;
(t (:machins))))))
(de :machins ()
; re'alise le chargement de l'instruction <obj>. Fonctionne dans
; le me↑me environnement que la fonction pre'ce'dente : obj :codop .....
(selectq :codop
;
; A tout seigneur tout honneur : l'instruction la plus utilise'e
;
(MOV ; (MOV source dest)
(cond ((and (consp :arg1) (eq (car :arg1) '@))
(:opnsn #$27 #$A8) ; addr src,r0 / movd r0,dst
(:opns-pos-depl :arg1)
(:opns-dst #$17 #$00 :arg2))
((and (consp :arg1)
(eq (car :arg1) 'QUOTE)
(cadr :arg1)
(symbolp (cadr :arg1)))
(:opnsn #$27 #$68) ; addr n(r5),r0 / movd r0,dst
(:opnsquotesymb (cadr :arg1))
(:opns-dst #$17 #$00 :arg2))
(t
(:opns-src-dst #$17 #$00 :arg1 :arg2)))) ; movd src,dst
;
; Les instructions de contro↑le
;
(BRA ; (BRA <lab>) == br lab
(:opns-branch #$EA :arg1))
(BRI ; (BRI <op>) == movd op,r0 / jump 0(r0)
(:1byte #$17)
(:opns-src #$00 :arg1 ())
(:opnsn #$7F #$42 #$00))
(BRX ; (BRX (<lab1> <lab2> ... <labn>) <index>)
(unless (:register :arg2)
(:1byte #$17) ; movd index,r0
(:opns-src #$00 :arg2 ()))
(let ((pc (copylist :PCcurrent)))
(:opnsn #$7D #$EF) ; casew *+4[r0:w]
(:1byte (selectq :arg2
(A1 #$D9) (A2 #$DA) (A3 #$DB) (A4 #$DC) (t #$D8)))
(:1byte #$04)
(mapc ':opns-brx (cirlist pc) :arg1)))
(CALL ; (CALL etiq) == bsr etiq
(:opns-branch #$02 :arg1))
(JCALL ; (JCALL <sym>) == jsr (FVAL :arg1)
(:opnsfvalq :codop :arg1)) ; jsr 0(n(r5))
(JMP ; (JMP <sym>) == jump (FVAL <sym>)
(:opnsfvalq :codop :arg1)) ; jump 0(n(r5))
(RETURN ; (RETURN) == ret 0
(:opnsn #$12 #$00))
(SOBGEZ ; (SOBGEZ op lab) addqw -1,op / cmpqw 0,op / ble lab
(:1byte #$8D)
(:opns-src #$07 :arg1 ())
(:1byte #$1D)
(:opns-src #$00 :arg1 ())
(:opns-branch #$7A :arg2))
;
; les instructions sur la pile de donne'e
;
(POP ; (POP <op>) == movd tos,op
(ifn (and (consp :arg1) (eq (car :arg1) '&))
(:opns-dst #$17 #$B8 :arg1)
; le cas vicieux du (pop (& <n>))
(:opnsn #$57 #$BE)
(:opns-depl (mul 4 (add1 (cadr :arg1))))))
(PUSH ; (PUSH <op>)
(cond ((and (consp :arg1) (eq (car :arg1) '@))
(:opnsn #$E7 #$AD) ; addr src,tos
(:opns-pos-depl :arg1))
((and (consp :arg1)
(eq (car :arg1) 'QUOTE)
(cadr :arg1)
(symbolp (cadr :arg1)))
(:opnsn #$E7 #$6D) ; addr n(r5),tos
(:opnsquotesymb (cadr :arg1)))
(t
(:1byte #$D7) ; movd src,tos
(:opns-src #$05 :arg1 ()))))
(SSTACK ; (SSTACK <op>) lprd sp,op
(:1byte #$EF)
(:opns-src #$04 :arg1 ()))
(STACK ; (STACK <op>) == sprd sp,op
(:1byte #$AF)
(:opns-src #$04 :arg1 ()))
(XSPMOV ; (XSPMOV depl val)
(cond ((:fixp :arg1)
(:opnsn #$17 #$C8) ; movd n(sp),r0
(:opns-pos-depl (mul 4 (cadr :arg1))))
(t
(:1byte #$17) ; movd depl,r0
(:opns-src #$00 :arg1 ())
(:opnsn #$17 #$F0 #$C8 #$00))) ; movd 0(sp)[r0:d],r0
(:opns-dst #$17 #$00 :arg2)) ; movd r0,val
;
; les tests de type
;
(BTNIL ; (BTNIL op lab) == cmpd op,r5 / beq lab
(:1byte #$47)
(:opns-src #$01 :arg1 ())
(:opns-branch #$0A :arg2))
(BFNIL ; (BFNIL op lab) == cmpd op,r5 / bne lab
(:1byte #$47)
(:opns-src #$01 :arg1 ())
(:opns-branch #$1A :arg2))
(BTCONS ; (BTCONS op lab) == cmpd op,r6 / bge lab
(:1byte #$87)
(:opns-src #$01 :arg1 ())
(:opns-branch #$DA :arg2))
(BFCONS ; (BFCONS op lab) == cmpd op,r6 / blt lab
(:1byte #$87)
(:opns-src #$01 :arg1 ())
(:opns-branch #$CA :arg2))
(BTFIX ; (BTFIX op1 lab) == movd op,r0 / cmpd bfloat,r0 / bhi lab
(:1byte #$17)
(:opns-src #$00 :arg1 ())
(:opnsn #$07 #$A8)
(:opns-pos-depl :bfloat)
(:opns-branch #$4A :arg2))
(BFFIX ; (BFFIX op1 lab) == movd op,r0 / cmpd bfloat,r0 / bls lab
(:1byte #$17)
(:opns-src #$00 :arg1 ())
(:opnsn #$07 #$A8)
(:opns-pos-depl :bfloat)
(:opns-branch #$5A :arg2))
(BTFLOAT ; (BTFLOAT op1 lab)
(ifn :31bitfloats
(:brt2 :bfloat :bvect)
(:1byte #$1F) ; cmpqd 0,op1
(:opns-src #$00 :arg1 ())
(:opns-branch #$6A :arg2))) ; bgt lab
(BFFLOAT ; (BFFLOAT op1 lab)
(ifn :31bitfloats
(:brf2 :bfloat :bvect)
(:1byte #$1F) ; cmpqd 0,op1
(:opns-src #$00 :arg1 ())
(:opns-branch #$7A :arg2))) ; ble lab
(BTSTRG ; (BTSTRG op1 lab)
(:1byte #$17) ; movd op,r0
(:opns-src #$00 :arg1 ())
(:opnsn #$07 #$A8) ; cmpd bstrg,r0
(:opns-pos-depl :bstrg)
(:1byte #$4A) ; bhi end
(let ((pc (copy :PCcurrent)))
(:1byte #$00) ; sera resolu a la fin
(:opnsn #$47 #$01) ; cmpd r0,r5
(:opns-branch #$AA :arg2) ; blo lab
(memory pc (add1 (subadr :PCcurrent pc)))))
(BFSTRG ; (BFSTRG op1 lab)
(:1byte #$17) ; movd op,r0
(:opns-src #$00 :arg1 ())
(:opnsn #$07 #$A8) ; cmpd bstrg,r0
(:opns-pos-depl :bstrg)
(:opns-branch #$4A :arg2) ; bhi lab
(:opnsn #$47 #$01) ; cmpd r0,r5
(:opns-branch #$BA :arg2)) ; bhs lab
(BTVECT ; (BTVECT op1 lab)
(:brt2 :bvect :bstrg))
(BFVECT ; (BFVECT op1 lab)
(:brf2 :bvect :bstrg))
(BTSYMB ; (BTSYMB op1 lab)
(:1byte #$17) ; movd op,r0
(:opns-src #$00 :arg1 ())
(:opnsn #$47 #$01) ; cmpd r0,r5
(:1byte #$AA) ; blo end
(let ((pc (copy :PCcurrent)))
(:1byte #$00) ; sera resolu a la fin
(:opnsn #$87 #$01) ; cmpd r0,r6
(:opns-branch #$AA :arg2) ; blo lab
(memory pc (add1 (subadr :PCcurrent pc)))))
(BFSYMB ; (BFSYMB op1 lab)
(:1byte #$17) ; movd op,r0
(:opns-src #$00 :arg1 ())
(:opnsn #$47 #$01) ; cmpd r0,r5
(:opns-branch #$AA :arg2) ; blo lab
(:opnsn #$87 #$01) ; cmpd r0,r6
(:opns-branch #$BA :arg2)) ; bhs lab
(BTVAR ; (BTVAR op1 lab)
(:1byte #$17) ; movd op,r0
(:opns-src #$00 :arg1 ())
(:opnsn #$07 #$A8) ; cmpd bvar,r0
(:opns-pos-depl :bvar)
(:1byte #$4A) ; bhi end
(let ((pc (copy :PCcurrent)))
(:1byte #$00) ; sera resolu a la fin
(:opnsn #$87 #$01) ; cmpd op,r6
(:opns-branch #$AA :arg2) ; blo lab
(memory pc (add1 (subadr :PCcurrent pc)))))
(BFVAR ; (BFVAR op1 lab)
(:1byte #$17) ; movd op,r0
(:opns-src #$00 :arg1 ())
(:opnsn #$07 #$A8) ; cmpd bvar,r0
(:opns-pos-depl :bvar)
(:opns-branch #$4A :arg2) ; bhi lab
(:opnsn #$87 #$01) ; cmpd r0,r6
(:opns-branch #$BA :arg2)) ; bhs lab
(CABEQ ; (CABEQ op1 op2 lab) == cmpd op1,op2 / beq lab
(:opns-src-dst #$07 #$00 :arg1 :arg2)
(:opns-branch #$0A :arg3))
(CABNE ; (CABNE op1 op2 lab) == cmpd op1,op2 / bne lab
(:opns-src-dst #$07 #$00 :arg1 :arg2)
(:opns-branch #$1A :arg3))
;
; Les autres instructions (par ordre alpha)
;
(ADJSTK ; (ADJSTK 'nb)
(if (:fixp :arg1)
(cond ((eq (cadr :arg1) 0))
((and (ge (cadr :arg1) -32) (lt (cadr :arg1) 32))
(:opnsn #$7C #$A5) ; adjspb n
(:1byte (sub 0 (mul 4 (cadr :arg1)))))
(t (:opnsn #$7D #$A5) ; adjspw n
(:1word (sub 0 (mul 4 (cadr :arg1))))))
(:opnsn #$CE #$1D) ; movxwd nb,r0
(:opns-src #$00 :arg1 ())
(:opnsn #$4E #$23 #$00) ; negd r0,r0
(:opnsn #$4E #$17 #$A0 #$02) ; lshd 2,r0
(:opnsn #$7F #$05))) ; adjspd r0
(CAR ; (CAR A1/A2/A3/A4) == MOV 0(Ax),Ax ?!?!? obsolete
(:ins `(MOV (CAR ,:arg1) ,:arg1)))
(CDR ; (CDR A1/A2/A3/A4) == MOV 4(Ax),Ax ?!?!? obsolete
(:ins `(MOV (CDR ,:arg1) ,:arg1)))
(HBMOVX ; (HBMOVX val string index) val -> string[index]
(:adrheap-r7 :arg2) ; r7 <- adr heap de arg2
(cond ((:fixp :arg3)
(:1byte #$17) ; movd val,r0
(:opns-src #$00 :arg1 ())
(:opnsn #$D4 #$03) ; movb r0,n(r7)
(:opns-pos-depl (cadr :arg3)))
(t (:opnsn #$17) ; movd depl,r0
(:opns-src #$00 :arg3 ())
(:1byte #$14) ; movb val,0(r7)[r0:b]
(:opns-src #$07 :arg1 #$78)
(:1byte #$00))))
(HBXMOV ; (HBXMOV string index dest) string[index] -> dest
(:adrheap-r7 :arg1) ; r7 <- adr heap de arg2
(cond ((:fixp :arg2)
(:opnsn #$14 #$78) ; movb n(r7),r0
(:opns-pos-depl (cadr :arg2)))
(t (:1byte #$17) ; movd index,r0
(:opns-src #$00 :arg2 ())
(:opnsn #$14 #$E0 #$78 #$00))) ; movb 0(r7)[r0:b],r0
(:1byte #$CE)
(:opns-dst #$18 #$00 :arg3)) ; movzbd r0,dest
(HGSIZE ; (HGSIZE vector/string arg2)
(:adrind-r0 :arg1) ; r0 <- adr ind de arg1
(:opnsn #$17 #$40 #$04) ; movd 4(r0),r0
(:opns-dst #$17 #$00 :arg2)) ; movd r0,dst
(HPMOVX ; (HPMOVX val vector index)
(:adrheap-r7 :arg2) ; r7 <- adr heap de arg2
(cond ((:fixp :arg3)
(:1byte #$17) ; movd val,r0
(:opns-src #$00 :arg1 ())
(:opnsn #$D7 #$03) ; movd r0,n(r7)
(:opns-pos-depl (mul 4 (cadr :arg3))))
(t (:1byte #$17) ; movd depl,r0
(:opns-src #$00 :arg3 ())
(:1byte #$97) ; movd val,0(r7)[r0:d]
(:opns-src #$07 :arg1 #$78)
(:1byte #$00))))
(HPXMOV ; (HPXMOV vector index val)
(:adrheap-r7 :arg1) ; r7 <- adr heap de arg2
(cond ((:fixp :arg2)
(:opnsn #$17 #$78) ; movd n(r7),r0
(:opns-pos-depl (mul 4 (cadr :arg2))))
(t (:1byte #$17) ; movd index,r0
(:opns-src #$00 :arg2 ())
(:opnsn #$17 #$F0 #$78 #$00))) ; movd 0(r7)[r0:d],r0
(:opns-dst #$17 #$00 :arg3)) ; movd r0,val
(MOVXSP ; (MOVXSP val depl)
(:1byte #$D7) ; movd val,r7
(:opns-src #$01 :arg1 ())
(cond ((:fixp :arg2)
(:opnsn #$57 #$3E) ; movd r7,n(sp)
(:opns-pos-depl (mul 4 (cadr :arg2))))
(t (:1byte #$17) ; movd depl,r0
(:opns-src #$00 :arg2 ())
(:opnsn #$97 #$3F #$C8 #$00)))) ; movd r7,0(sp)[r0:d]
(NOP ; (NOP) ne fait rien mais perd du temps et de la place
(:1byte #$A2))
(XTOPST ; (XTOPST :arg1) echange du sommet de pile avec :arg1
(:opnsn #$17 #$B8) ; movd tos,r0
(:1byte #$D7) ; movd arg,tos
(:opns-src #$05 :arg1 ())
(:opns-dst #$17 #$00 :arg1)) ; movd r0,arg
;
; Les comparaisons arithme'tiques entieres. cmpw op1 op2 / bnxx lab
;
(CNBEQ ; (CNBEQ op1 op2 lab)
(:cnbxx #$0A))
(CNBNE ; (CNBNE op1 op2 lab)
(:cnbxx #$1A))
(CNBLT ; (CNBLT op1 op2 lab)
(:cnbxx #$CA))
(CNBLE ; (CNBLE op1 op2 lab)
(:cnbxx #$7A))
(CNBGT ; (CNBGT op1 op2 lab)
(:cnbxx #$6A))
(CNBGE ; (CNBGE op1 op2 lab)
(:cnbxx #$DA))
;
; Les comparaisons arithme'tiques flottantes.
;
(CFBEQ ; (CFBEQ op1 op2 lab)
(if :31bitfloats
(:generatecall2subr '#:llcp:feqn :arg3)
(:cfbxx #$0A)))
(CFBNE ; (CFBNE op1 op2 lab)
(if :31bitfloats
(:generatecall2subr '#:llcp:fneqn :arg3)
(:cfbxx #$1A)))
(CFBLT ; (CFBLT op1 op2 lab)
(if :31bitfloats
(:generatecall2subr '#:llcp:flt :arg3)
(:cfbxx #$CA)))
(CFBLE ; (CFBLE op1 op2 lab)
(if :31bitfloats
(:generatecall2subr '#:llcp:fle :arg3)
(:cfbxx #$7A)))
(CFBGT ; (CFBGT op1 op2 lab)
(if :31bitfloats
(:generatecall2subr '#:llcp:fgt :arg3)
(:cfbxx #$6A)))
(CFBGE ; (CFBGE op1 op2 lab)
(if :31bitfloats
(:generatecall2subr '#:llcp:fge :arg3)
(:cfbxx #$DA)))
;
; Les instructions arithme'tiques (par ordre alpha)
;
(DECR ; (DECR op) == addqw -1,op
(:1byte #$8D)
(:opns-src #$07 :arg1 ()))
(DIFF ; (DIFF op1 op2) == subw op1 op2 ; op2 - op1 -> op2
(:opns-arith #$21 #$00 :arg1 :arg2))
(INCR ; (INCR op) == addqw 1,op
(:1byte #$8D)
(:opns-src #$00 :arg1 ()))
(LAND ; (LAND op1 op2) == andw op1,op2
(:opns-arith #$29 #$00 :arg1 :arg2))
(LOR ; (LOR op1 op2) == orw op1 op2
(:opns-arith #$19 #$00 :arg1 :arg2))
(LXOR ; (LXOR op1 op2) == xorw op1 op2
(:opns-arith #$39 #$00 :arg1 :arg2))
(LSHIFT ; (LSHIFT circ op) == lshw circ,op
(:1byte #$4E)
(ifn (:fixp :arg1)
(:opns-arith #$15 #$00 :arg1 :arg2)
(ifn (:register :arg2)
(:error "LSHIFT" :arg2))
(:opns-dst #$15 #$A0 :arg2)
(:1byte (logand #$FF (cadr :arg1)))))
(NEGATE ; (NEGATE op) == negw op,op
(:1byte #$4E)
(:opns-arith #$21 #$00 :arg1 :arg1))
(PLUS ; (PLUS op1 op2) == addw op1 op2
(:opns-arith #$01 #$00 :arg1 :arg2))
(REM ; (REM op1 op2) == modw op1,op2
(:1byte #$CE)
(:opns-arith #$35 #$00 :arg1 :arg2))
(QUO ; (QUO op1 op2) == divw op1 op2
(:1byte #$CE)
(:opns-arith #$31 #$00 :arg1 :arg2))
(TIMES ; (TIMES op1 op2) == mulw op1 op2
(:1byte #$CE)
(:opns-arith #$21 #$00 :arg1 :arg2))
;
; Les instructions arithme'tiques flottantes
;
(FPLUS (:macflotop '#:llcp:fadd)) ;
(FDIFF (:macflotop '#:llcp:fsub)) ;
(FTIMES (:macflotop '#:llcp:fmul)) ;
(FQUO (:macflotop '#:llcp:fdiv)) ;
;
; c'est donc une erreur
;
(t (if (setq :f (getfn1 'ld-codop (car obj)))
(apply :f obj)
(:error "MACHINS" obj)))))
;.Section "Les fonctions auxiliaires de ge'ne'ration"
(de :register (arg)
; Teste si l'argument est un registre.
(memq arg '(A1 A2 A3 A4)))
(de :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))))
(de :check8 (n)
; teste si le deplacement <n> tient sur 8 bits (en fait 7)
; Attention a` la tole'rance (de 3 octets de chaque co↑te').
(and (fixp n) (ge n -61) (le n 60) n))
(de :check16 (n)
; teste si le deplacement <n> tient sur 16 bits (en fait 14)
; Attention a` la tole'rance (de 3 octets de chaque co↑te').
(and (fixp n) (ge n -8190) (lt n 8190) n))
(de :adrind-r0 (arg)
; charge dans "r0" l'adresse heap de l'objet "arg"
(if (:register arg)
(:opnsn #$17 ; movd 0(AX),r0
(selectq arg (A1 #$48) (A2 #$50) (A3 #$58) (A4 #$60))
#$00)
(:1byte #$17) ; movd arg,r0
(:opns-src #$00 arg ())
(:opnsn #$17 #$40 #$00))) ; movd 0(r0),r0
(de :adrheap-r7 (arg)
; Charge dans "r7" l'adresse heap sur la premier valeur de "arg"
(if (:register arg)
(:opnsn #$D7 ; movd 0(AX),r7
(selectq arg (A1 #$49) (A2 #$51) (A3 #$59) (A4 #$61))
#$00)
(:1byte #$D7) ; movd arg,r7
(:opns-src #$01 arg ())
(:opnsn #$D7 #$79 #$00)) ; movd 0(r7),r7
(:opnsn #$0F #$3A #$0F #$3A)) ; addqd 4,r7 / addqd 4,r7
(de :brt2 (b1 b2)
; test de type de :arg1 a` 2 bornes : b1, b2
; branchement a` :arg2 si vrai.
(:1byte #$17) ; movd op,r0
(:opns-src #$00 :arg1 ())
(:opnsn #$07 #$A8) ; cmpd b1,r0
(:opns-pos-depl b1)
(:1byte #$4A) ; bhi end
(let ((pc (copy :PCcurrent)))
(:1byte #$00) ; sera resolu a la fin
(:opnsn #$07 #$A8) ; cmpd b2,r0
(:opns-pos-depl b2)
(:opns-branch #$4A :arg2) ; bhi lab
(memory pc (add1 (subadr :PCcurrent pc)))))
(de :brf2 (b1 b2)
; test de type a` 2 bornes de :arg1 avec b1 et b2
; branchement a` :arg2 si faux.
(:1byte #$17) ; movd op,r0
(:opns-src #$00 :arg1 ())
(:opnsn #$07 #$A8) ; cmpd b1,r0
(:opns-pos-depl b1)
(:opns-branch #$4A :arg2) ; bhi lab
(:opnsn #$07 #$A8) ; cmpd b2,r0
(:opns-pos-depl b2)
(:opns-branch #$5A :arg2)) ; bls lab
(de :cnbxx (op)
; Comparaison nume'rique entie`re.
(:opns-arith #$05 #$00 :arg1 :arg2) ; cmpw arg1,arg2
(:opns-branch op :arg3))
(de :cfbxx (op)
; Comparaison nume'rique flottants
(:1byte #$17) ; movd arg1,r0
(:opns-src #$00 :arg1 ())
(:1byte #$D7) ; movd arg2,r7
(:opns-src #$01 :arg2 ())
(:opnsn #$BE #$C8 #$43 #$04 #$04) ; cmpl 4(r0),4(r7)
(:opns-branch op :arg3))
(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.
; chargement de la valeur de retour dans :arg2.
; Si lab, branchement a` lab si la valeur retourne'e n'est pas 0
(:1byte #$17) ; movd \1,r0
(:opns-src #$00 :arg1 ())
(let ((:arg2 :arg2)) ; protege arg2
(:ins `(PUSH ,:arg2))) ; movd \2,tos
(:opnsn #$D7 #$A5) ; movd imm,tos
(:1double (addadr (copylist :PCcurrent) 15))
(:opnsn #$D7 #$05) ; movd r0,tos
(:opnsfvalq 'JMP fnt) ; jump fnt
(if (and (consp :arg2) (eq (car :arg2) '&)) ; le cas vicieux
(setq :arg2 (list '& (add (cadr :arg2) 1))))
(ifn lab
(:opns-dst #$17 #$B8 :arg2) ; movd tos,\2
(:opnsn #$17 #$B8 #$1F #$00) ; movd tos,r0 / cmpqd 0,r0
(:opns-branch #$1A lab))) ; bne lab
(de :macflotop (fnt)
; ope'ration nume'rique flottante.
(:generatecall2subr fnt ()))
;.Section "Les fonctions de chargement des ope'randes"
(de :opns-src-dst (b0 b1 src dst)
; charge l'instruction NS b0/b1 avec ces deux operandes
(let ((pc1 (car :PCcurrent))(pc2 (cdr :PCcurrent)))
(:1byte b0)
(:1byte b1)
(setq src (:opns src))
(setq dst (:opns dst))
(:1bytePC pc1 pc2 (logor b0 (logand #$FF (logshift dst 6))))
(:1bytePC+ pc1 pc2
(logor b1 (logor (logshift src 3) (logshift dst -2))))))
(de :opns-arith (b0 b1 src dst)
; charge l'instruction NS b0/b1 avec ces deux operandes
(let ((pc1 (car :PCcurrent))(pc2 (cdr :PCcurrent)))
(:1byte b0)
(:1byte b1)
(ifn (:fixp src)
(setq src (:opns src))
(:1word (cadr src))
(setq src #$14))
(ifn (:fixp dst)
(setq dst (:opns dst))
(:1word (cadr dst))
(setq dst #$14))
(:1bytePC pc1 pc2 (logor b0 (logand #$FF (logshift dst 6))))
(:1bytePC+ pc1 pc2
(logor b1 (logor (logshift src 3) (logshift dst -2))))))
(de :opns-src (byte src idst)
; charge l'instruction de deuxieme octet byte avec comme source src
(let ((pc1 (car :PCcurrent))(pc2 (cdr :PCcurrent)))
(:1byte byte)
; cas ou il y a un octet d'index pour la destination
(if idst (:1byte idst))
; :opns ne genere jamais d'octet d'index
(setq src (:opns src))
(:1bytePC pc1 pc2 (logor byte (logshift src 3)))))
(de :opns-dst (b0 b1 dst)
; charge l'instruction NS b0/b1 avec comme destination dst
(let ((pc1 (car :PCcurrent))(pc2 (cdr :PCcurrent)))
(:1byte b0)
(:1byte b1)
(setq dst (:opns dst))
(:1bytePC pc1 pc2 (logor b0 (logand #$FF (logshift dst 6))))
(:1bytePC+ pc1 pc2 (logor b1 (logshift dst -2)))))
; .SSection "L'ope'rande NS ge'ne'rique"
(de :opns (op)
; charge l'ope'rande NS <op>
(cond
((eq op 'nil)
; ope'rande nil (en fait ||)
#$05)
((eq op 'A1)
; accu Le←Lisp
#$01)
((eq op 'A2)
; accu Le←Lisp
#$02)
((eq op 'A3)
; accu Le←Lisp
#$03)
((eq op 'A4)
; accu Le←Lisp
#$04)
((memq op '(LLINK DLINK ITCOUNT))
(:opns-pos-depl (symeval (symbol 'llcp op)))
#$15)
((memq op '(CBINDN TAG LOCK PROT))
(:1double (symeval (symbol 'llcp op)))
#$14)
((atom op)
; ne doit jamais arriver pour le compilo
; sauf en cas de nouvelles de'finitions.
(if (and (symbolp op)
(setq :f (getfn1 'ld-dir op)))
(funcall :f op)
(:error "OPNS" op)))
((eq (car op) 'quote)
; une constante lisp imme'diate
(if (and (null (cadr op)) (null (cddr op)))
; c'est en fait l'ope'rande nil (ou ||)
#$05
(unless (or (fixp (cadr op))
(and :31bitfloats (floatp (cadr op))))
; c'est un litte'ral a` sauver
(if (stringp (cadr op))
(:add-llitts op)
(if (and :stopcopy (consp (cadr op)))
(:add-cons-llitt (cadr op) :PCcurrent)
(:add-llitt (cadr op)))))
(:1double (loc (cadr op)))
#$14))
((eq (car op) '@)
; une constante adresse me'moire code machine
; <lab> est touours une e'tiquette locale;
; engendre TOUJOURS un de'placement par rapport au PC.
; dans le cas du VAX doit e↑tre un de'placement 32 bits...
; Les cas utilis'es par le compilateur sont :
; MOV, PUSH et BRX qui sont traite's directement.
; ?!?! a` terminer ?!?!
(:error "OPNS@" op))
((eq (car op) '&)
; (& <n>) Le nie`me pointeur de la pile
(if (or (not (fixp (cadr op))) (lt (cadr op) 0))
(:error "OPNS" op)
(:opns-pos-depl (mul 4 (cadr op)))
#$19))
((memq (car op)
'(CAR VAL CVAL CDR PLIST FVAL PKGC OVAL ALINK PNAME TYP))
; adressage indirect indexe'
(:1byte (selectq (car op)
((car val cval) 0)
((cdr typ plist) 4)
(fval 8)
(pkgc 12)
(oval 16)
(alink 20)
(pname 28)
(t (:error "OPNS" op))))
(selectq (cadr op)
(A1 #$09)
(A2 #$0A)
(A3 #$0B)
(A4 #$0C)
(t (:error "OPNS" op))))
((eq (car op) 'CVALQ)
; la C-valeur Lisp d'un symbole
(ifn (symbolp (cadr op))
(:error "OPNS" op)
(:opnsquotesymb (cadr op))))
((eq (car op) 'FVALQ)
; la F-valeur Lisp d'un symbole
(ifn (symbolp (cadr op))
(:error "OPNS" op)
(:opnsquotesymb+8 (cadr op))))
((eq (car op) 'EVAL)
; Pour calculer des ope'randes a` load time.
(or (car (catcherror t (:opns (eval (cadr op)))))
(:error "OPNS" op)))
(t (if (and (symbolp (car op))
(setq :f (getfn1 'ld-ind (car op))))
(funcall :f op)
(:error "OPNS" op)))))
; .SSection "Appel multiple de 1BYTE ou OPNS"
(dmd :opnsn l
; appels multiples de :1byte ou :opns
`(progn ,@(mapcar (lambda (l) `(:1byte ,l)) l)))
; .SSection "Ope'rande de type adresse de symbole Lisp"
(de :opnsquotesymb (symb)
; charge un ope'rande de type "adresse de symbole"
; <symb> est toujours de type symbole.
(:add-llitt symb)
(setq :valaux (subadr (loc symb) :locnil))
(:opns-pos-depl :valaux)
#$0D)
(de :opnsquotesymb+8 (symb)
; charge un ope'rande de type "adresse de symbole" + 8
; <symb> est toujours de type symbole.
(:add-llitt symb)
(setq :valaux (incradr (subadr (loc symb) :locnil) 8))
(:opns-pos-depl :valaux)
#$0D)
; .Section "Gestion des e'tiquettes"
; .SSection "Les e'tiquettes globales (JCALL/JMP)"
(de :opnsfvalq (type symb)
; la F-valeur Lisp d'un symbole pour un JCALL/JMP
; type = JMP ou JCALL
(:add-llitt symb) ; temporairement (il de'gage avec :clean-llitt)
(cond ((and (setq :valaux (cassq symb :llabels))
(:check16 (setq :valaux (subadr :valaux :PCcurrent))))
; FENTRY si de'ja` de'fini dans le me↑me module et pas loin.
; Un call/jmp relatif sur 16 bits est moins cher que FVALQ
(:1byte (if (eq type 'JMP) #$EA #$02)) ; br / bsr
(if (:check8 :valaux)
; cas br avec byte displ
(:1byte (logand #$7F :valaux))
; cas br avec word displ
(:1word (logor #$8000 (logand #$3FFF :valaux)))))
(t
; Etiq globale : direct sur la FVAL
; ca coute une indirection mais fait gagner parfois (pour les
; fonctions standard toujours) 2 octets.
; gain de 6k nets apre`s llcp-std!
(:opnsn #$17 #$68) ; movd n(r5),r0
(setq :valaux (subadr (loc symb) :locnil))
(:opns-pos-depl (incradr :valaux 8))
(:1byte #$7F)
(:1byte (if (eq type 'JMP) #$42 #$46)) ; jump / jsr 0(r0)
(:1byte #$00))))
; .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 :
; symbole, 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)))
(de :opns-brx (base adr)
; le cas special pour le BRX
(if (and (consp adr) (eq (car adr) '@))
(setq adr (cadr adr))
(:error "OPNS-BRX" adr))
(setq :valaux (:valadr adr))
(if :valaux
; existe deja
(ifn (:check16 (setq :valaux (subadr :valaux base)))
(:error "BRX too long" adr)
(:1byte (logand #$FF :valaux))
(:1byte (logand #$FF (logshift :valaux -8))))
(if (and (symbolp adr) (null (assq adr :llabels)))
; dans les ENTRY
(:addentry adr base)
; dans les LOCAL
(:addlabel adr base))
(:1word 0)))
; .SSection "Branchements conditionnels locaux"
(de :opns-branch (code adr)
; charge le code <code> de branchement conditionnel vers <adr>.
; L'e'tiquette <adr> est toujours locale.
(setq :valaux (:valadrel adr))
(cond
((:check8 :valaux)
; branchement arriere sur 8 bits
(:1byte code)
(:1byte (logand #$7F :valaux)))
((:check16 :valaux)
; branchement arriere sur 16 bits
(:1byte code)
(:1byte (logor #$80 (logand #$3F (logshift :valaux -8))))
(:1byte (logand #$FF :valaux)))
(:valaux
; branchement arriere sur 32 bits
(:1byte code)
(cond
((consp :valaux)
(:1word (logor #$C000 (logand #$3FFF (car :valaux))))
(setq :valaux (cdr :valaux)))
((ge :valaux 0) (:1word #$C000))
(t (:1word #$FFFF)))
(:1word :valaux))
((:notoofar8 adr :lobj)
; branchement avant sur 8 bits
(:1byte code)
(:addlabel adr 8)
(:1byte 0))
((and (or (fixp adr) (assq adr :llabels)) (:notoofar16 adr :lobj))
; branchement avant sur 16 bits
(:1byte code)
(:addlabel adr 16)
(:1word 0))
((and (symbolp adr) (not (assq adr :llabels)) (:notoofar adr :lobj))
; branchement avant sur 16 bits
(:1byte code)
(:addentry adr 16)
(:1word 0))
(t ; branchement avant sur 32 bits
(:1byte code)
(if (and (symbolp adr) (null (assq adr :llabels)))
; dans les ENTRY
(:addentry adr 32)
; dans les LOCAL
(:addlabel adr 32))
(:1double 0))))
; .Section "Les fonctions auxiliaires de chargement me'moire"
(de :opns-depl (val)
; charge le deplacement val
(cond
((fixp val)
(cond
((and (ge val -64) (lt val 64))
(:1byte (logand #$7F val)))
((and (ge val -8192) (lt val 8192))
(:1word (logor #$8000 (logand #$3FFF val))))
(t (if (ge val 0) (:1word #$C000) (:1word #$FFFF))
(:1word val))))
((and (consp val) (fixp (car val)))
(:1word (logor #$C000 (logand #$3FFF (car val))))
(:1word (cdr val)))
((and (consp val) (eq (car val) '@))
(setq :valaux (:valadr (cadr val)))
(if :valaux
(:opns-depl :valaux)
(if (and (symbolp (cadr val)) (null (assq (cadr val) :llabels)))
(:addentry (cadr val) 0)
(:addlabel (cadr val) 0))
(:1double 0)))
(t (:error "Opns-Depl" val))))
(de :opns-pos-depl (val)
; charge le deplacement positif val
(cond
((fixp val)
(cond
((and (ge val 0) (lt val 64))
(:1byte (logand #$3F val)))
((and (ge val 0) (lt val 8192))
(:1word (logor #$8000 (logand #$1FFF val))))
(t (:1word #$C000)
(:1word val))))
((and (consp val) (fixp (car val)))
(:1word (logor #$C000 (logand #$1FFF (car val))))
(:1word (cdr val)))
((and (consp val) (eq (car val) '@))
(setq :valaux (:valadr (cadr val)))
(if :valaux
(:opns-pos-depl :valaux)
(if (and (symbolp (cadr val)) (null (assq (cadr val) :llabels)))
(:addentry (cadr val) 0)
(:addlabel (cadr val) 0))
(:1double 0)))
(t (:error "Opns-Pos-Depl" val))))
;.SSection "chargement d'1 octet"
(de :1byte (obj)
; charge l'octet obj
(when :talkp
(when (gt :nwl 10)
(setq :nwl 0)
(terpri)
(outpos 30)
(:prinhex :PCcurrent)
(prin " "))
(incr :nwl)
(prin " ")
(:prinhexb obj))
(memory :PCcurrent obj)
(incradr :PCcurrent 1))
(de :1bytePC (pc1 pc2 val)
; ne cons pas !
(let ((adr '(0 . 0)))
(rplac adr pc1 pc2)
(memory adr val)))
(de :1bytePC+ (pc1 pc2 val)
; ne cons pas !
(let ((adr '(0 . 0)))
(rplac adr pc1 pc2)
(incradr adr 1)
(memory adr val)))
(de :1byterelPC (adr)
; charge le de'placement relatif a` PCcurrent pour l'adresse adr
(setq :valaux (incradr (subadr :PCcurrent adr) 1))
(if (or (not (fixp :valaux)) (lt :valaux -64) (ge :valaux 64))
(:error "1byterelPC" :module))
(memory adr (logand #$7F :valaux)))
(de :align ()
; aligne le compteur de chargement sur une
; frontie`re de mots de 32 bits (merci NS)
(until (eq (logand 3 (if (fixp :PCcurrent)
:PCcurrent
(cdr :PCcurrent)))
0)
(:1byte #$A2))) ; charge un NOP!
;.SSection "chargement d'1 seul mot de 16 bits"
(de :1word (obj)
; charge 1 mot obj : attention a` l'ordre.
(:1byte (logand (logshift obj -8) #$FF))
(:1byte (logand obj #$FF)))
(de :1wordrel (base adr)
; charge le de'placement relatif a PCcurrent et base pour adr
(setq :valaux (subadr :PCcurrent base))
(if (or (not (fixp :valaux)) (lt :valaux -8192) (ge :valaux 8192))
(:error "Brx trop gros" :module))
(memory adr (logand #$FF :valaux))
(memory (incradr adr 1) (logand #$FF (logshift :valaux -8))))
(de :1wordrelPC (adr)
; charge le de'placement relatif a` PCcurrent pour l'adresse adr
(setq :valaux (incradr (subadr :PCcurrent adr) 1))
(if (or (not (fixp :valaux)) (lt :valaux -8192) (ge :valaux 8192))
(:error "Module trop gros" :module))
(memory adr (logor #$80 (logand #$3F (logshift :valaux -8))))
(memory (incradr adr 1) (logand #$FF :valaux)))
; .SSSection "Chargement par paquet de 32 bits"
(de :1double (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 "1DOUBLE" val))))
(de :1doublePC (where)
; charge PCcurrent a where
(let ((adr (copylist where)))
(memory adr (logor #$C0 (logand #$3F (logshift (car :PCcurrent) -8))))
(incradr adr 1)
(memory adr (logand #$FF (car :PCcurrent)))
(incradr adr 1)
(memory adr (logshift (cdr :PCcurrent) -8))
(incradr adr 1)
(memory adr (logand #$FF (cdr :PCcurrent)))))
(de :1doublerelPC (adr)
; charge le de'placement relatif a` PCcurrent pour l'adresse adr
(setq :valaux (incradr (subadr :PCcurrent adr) 1))
(if (fixp :valaux) (setq :valaux (cons (if (ge :valaux 0) 0 -1) :valaux)))
(memory adr (logor #$C0 (logand #$3F (logshift (car :valaux) -8))))
(memory (incradr adr 1) (logand #$FF (car :valaux)))
(memory (incradr adr 1) (logand #$FF (logshift (cdr :valaux) -8)))
(memory (incradr adr 1) (logand #$FF (cdr :valaux))))
; .Section "Fonctions de gestion des tables d'e'tiquettes"
(defvar :long-ins '(HBMOVX HBXMOV HPMOVX HPXMOV FPLUS FDIFF FTIMES FQUO))
(de :notoofar8 (adr lobj)
; heuristique pour les branchements sur 8 bits
(tag ok
(let ((count 7)(e))
(while (and (gt count 0) (consp lobj))
(nextl lobj e)
(cond
((atom e) (if (eq e adr) (exit ok t)))
((eq (car e) 'BRX) (exit ok ()))
((memq (car e) :long-ins)
(setq count (sub count 3)))
(t (setq count (sub1 count)))))
())))
(de :notoofar16 (adr lobj)
; heuristique pour les branchements sur 16 bits
(tag ok
(repeat 500
(when (eq (nextl lobj) adr)
(exit ok t)))
()))
(de :notoofar (adr lobj)
; heuristique pour les branchements (etiquette symbolique)
(tag ok
(repeat 500
(nextl lobj :valaux)
(if (and (consp :valaux)
(eq (car :valaux) 'entry)
(eq (cadr :valaux) adr))
(exit ok t)))
()))
(de :addlabel (sym depl)
; rajoute le symbole <sym> dans la table des re'fe'rences avants
; locales non re'solues a` l'adresse PCcurrent.
; Avec un deplacement de <depl> (8/16/32) ou 0 pour absolu
; retourne 0 (adresse inconnue)
(setq :valaux (assq sym :llabels-nr))
(setq depl (cons depl (copylist :PCcurrent)))
(if :valaux
(rplacd :valaux (cons depl (cdr :valaux)))
(newl :llabels-nr (list sym depl)))
0)
(de :addentry (sym depl)
; 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)
(setq :valaux (assq sym :entries-not-resolved))
(setq depl (cons depl (copylist :PCcurrent)))
(if :valaux
(rplacd :valaux (cons depl (cdr :valaux)))
(newl :entries-not-resolved (list sym depl)))
0)
; .Section "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 si
; si il n'y a pas eu de TITLE dans :module sinon.
; ne doit 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 (add i 1)) (nextl :saved-by-loader)))
(if :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-llitts (obj)
; rajoute une chai↑ne de caracte`res a` la table des litte'raux
; en essayant de partager les chai↑nes.
; ?!?!?! Cette ide'e d'Ascander est toujours en discussion ?!?!?
(let ((s (and #:ld:shared-strings (member (cadr obj) :saved-by-loader))))
(ifn s
(newl :saved-by-loader (cadr obj))
(rplaca (cdr obj) (car s)))))
(de :add-cons-llitt (c a)
(newl :local-cons-llitt (cons (vag a) c)))
; .Section "Fonction d'impression hexa"
(de :prinhex (n)
; imprime sur 4 ou 8 chiffres hexa le nb ou l'adresse n
(cond ((fixp 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 (fixp n)) (error 'memory-dump 'errnna n))
((lt n 0) (setq n 255))
((lt n 16) (princn #/0)))
(with ((obase 16)) (prin n)))
; .Section "Fonction de debug"
(de memory-dump (adr n)
; dump la memoire en hexa de <adr> sur <n> mots
; attention au SWAB du NS! octet de poids faibles a gauche!
(setq adr (copy adr)) ; pour le incradr
(until (< n 0)
(:prinhex adr)
(outpos 10)
(let ((adr (copylist adr)))
(repeat 16
(:prinhexb (memory adr))
(prin " ")
(incradr adr 1)))
(prin " ")
(repeat 16
(if (and (> (memory adr) 32) (< (memory adr) 128))
(princn (memory adr))
(princn #/.))
(incradr adr 1) )
(decr n)
(terpri)))
; .Section "Fonction auxiliaire d'erreur"
(de :error (f a)
; erreur de type <f> les argments de'fecteux sont dans <a>
(terpri)
(print "***** LOADER : erreur durant le chargement de : " :fntname)
(print " type de l'erreur : " f)
(print " arguments de'fecteux : " 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) ; A-liste des e'tiquettes locales
(:llabels-nr) ; A-L. des e'tiq. loc. non re'solues
(:fntname 'loader) ; fonction en cours de chargement
:codop ; variable globale de travail
:arg1 ; itou
:arg2 ; itou
:arg3 ; itou
:valaux ; itou pour des valeurs locales.
:f ; itou (pour des getfn1)
(:nwl 0) ; itou pour tabler le code produit.
:local-cons-llitt) ; les literaux cons locaux
; 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
(setq :nwl 0)
(when (gtadr :PCcurrent :Ecode)
(with ((outchan ()))
(print ERRFCOD)
(exit #:system:toplevel-tag)))
(: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"
(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
; INVERSION
(push '0)
(push a2)
(eval (:opnsn #$54 #$CE 0 7))
(eval (:opnsn #$54 #$CE 1 6))
(eval (:opnsn #$54 #$CE 2 5))
(eval (:opnsn #$54 #$CE 3 4))
(adjstk '1)
(pop a2)
; INVERSE
(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) )
() )))
(unless (or (eq (typefn 'loaderesolve) 'expr) (get 'loaderesolve 'resetfn))
(mapc
(lambda (m)
(when (typefn m)
(remfn m)
(remprop m '#:system:loaded-from-file) ))
(oblist 'ldns) ))