; .EnTete "Le-Lisp (c) version 15.2" " " "Le chargeur me'moire SPS9"
; .EnPied " " "%" " "
; .sp 2
; .SuperTitre "Le Chargeur Me'moire SPS9"
;
; .Centre "*****************************************************************"
; .Centre " Ce fichier est en lecture seule hors du projet ALE de l'INRIA. "
; .Centre " Il est maintenu par ILOG SA, 2 Avenue Gallie'ni, 94250 Gentilly "
; .Centre " (c) Le-Lisp est une marque de'pose'e de l'INRIA "
; .Centre "*****************************************************************"
; .Centre "$Header: lapsps9.ll,v 4.1 88/01/13 12:21:17 kuczynsk Rel $"
; Assemble et charge pour un SPS9 une liste d'instructions LLM3
; en 1 seule passe et avec du code relogeable.
(unless (>= (version) 15.2)
(error 'load 'erricf 'lapsps9))
(defvar #:sys-package:colon 'ldsps9)
(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 (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` 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)
(defvar #:ld:special-case-loader ()) ; cas spe'cial pour charger le chargeur
(defvar #:ld:shared-strings ()) ; rend les constantes de chai↑ne EQ
; .Section "Les variables globales du chargeur"
(defvar :Ecode
; fin de la zone code.
(subadr (#:system:ecode) 64))
(defvar :mem-access
; noms symboliques des acce`s indexe's
'(val car cdr cval pname
plist fval alink pkgc oval typ))
(defvar :locnil (loc ())) ; adresse du symbole ()
(defvar :adrBVAR `(adr ,(loc 'sys-package))) ; a modifier si modif dans llinit
(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 :localstack :valaux :f :nwl obj
obj1 obj2 obj3])))
; .Section "Les constantes propres au SPS9"
(dmd :defvalue (nom val)
; de'finition d'une constante SPS9
`(putprop ',nom ,val ':value))
(de :getvalue (nom)
; recherche d'une constante SPS9
(cond ((null nom) (:error ':getvalue nom))
((fixp nom) nom)
((symbolp nom)
(let ((val (getprop nom ':value)))
(if val (:getvalue val)
(:error ':getvalue nom))))
(t (:error ':getvalue nom))))
; .SSection "Les registres"
(de :register? (obj)
; teste si l'argument est un registre SPS9
(memq obj '(x1 a1 a4 sp a2 a3 x2
rbfloat rbvect rbstrg KNIL rbsymb rbcons x3 x4 x5)))
(:defvalue x1 0)
(:defvalue x2 1)
(:defvalue x3 2)
(:defvalue x4 3)
(:defvalue rbstrg 4)
(:defvalue a1 5)
(:defvalue a2 6)
(:defvalue a3 7)
(:defvalue a4 8)
(:defvalue rbfloat 9)
(:defvalue rbvect 10)
(:defvalue x5 11)
(:defvalue KNIL 12)
(:defvalue rbsymb 12)
(:defvalue rbcons 13)
(:defvalue sp 15)
; .SSection "Les constantes d'acce`s"
(:defvalue car 0)
(:defvalue cdr 4)
(:defvalue cval 0)
(:defvalue plist 4)
(:defvalue fval 8)
(:defvalue pkgc 12)
(:defvalue oval 16)
(:defvalue alink 20)
(:defvalue pname 28)
(:defvalue val 0)
(:defvalue typ 4)
; .SSection "Les instructions par ordre alpha"
(:defvalue add #$03)
(:defvalue addi #$13)
(:defvalue and #$0B)
(:defvalue br<>s #$8A)
(:defvalue br<>simm #$8E)
(:defvalue br<simm #$85)
(:defvalue br=s #$82)
(:defvalue br=simm #$86)
(:defvalue br>s #$80)
(:defvalue br>simm #$84)
(:defvalue br>=simm #$8D)
(:defvalue br<=s #$88)
(:defvalue br<=simm #$8C)
(:defvalue brs #$8B)
(:defvalue div #$06)
(:defvalue drcomp #$3A)
(:defvalue laddr16 #$CE)
(:defvalue laddr16r #$CF)
(:defvalue laddr32 #$DE)
(:defvalue laddrp16 #$EE)
(:defvalue laddrp16r #$EF)
(:defvalue load #$C7) ; complet indexe' + short
(:defvalue load32abs #$D6)
(:defvalue loadb16r #$C1)
(:defvalue loadhp16r #$E3)
(:defvalue loadp16r #$C7)
(:defvalue lsl #$60)
(:defvalue lsli #$70)
(:defvalue lsr #$61)
(:defvalue lsri #$71)
(:defvalue move #$01)
(:defvalue movei #$11)
(:defvalue mpy #$05)
(:defvalue neg #$02)
(:defvalue radd #$23)
(:defvalue rsub #$24)
(:defvalue rdiv #$26)
(:defvalue rem #$07)
(:defvalue rmpy #$25)
(:defvalue rcomp #$2A)
(:defvalue or #$09)
(:defvalue ret #$57)
(:defvalue sbit #$0D)
(:defvalue seh #$7A)
(:defvalue storabs #$B6) ; store absolu adresse 32 bits
(:defvalue store16r #$A7)
(:defvalue storeb16r #$A1)
(:defvalue sub #$04)
(:defvalue subi #$14)
(:defvalue xor #$0A)
(de :immbr (cond)
(cassq cond '((br=s . br=simm) (br<>s . br<>simm)
(br<=s . br<=simm) (br>s . br>simm)
(br>=s . br>=simm) (br<s . br<simm))))
(de :error (f a)
; erreur dans la fonction "f" sur l'argument "a"
(print "** loader : " f " : " a)
(error 'loader f a))
; .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)
(:solverel obj))
(t (setq :codop (car obj)
:arg1 (cadr obj)
:arg2 (caddr obj)
:arg3 (cadddr obj)
:localstack 0)
(selectq :codop
;
; les pseudos-instructions de de'claration
;
(ABORT ; Pour re'cupe'rer de la me'moire en cas scraschhhh.
)
(ENTRY ; (ENTRY <name> <ftype> <lparam>)
; 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.
(:solventry :arg1)
(putprop :arg1 (copylist :PCcurrent) ':fval)
(setq :fntname :arg1))
(ENDL ; fin d'une fonction locale
(when :talkp (terpri))
(when :llabels-nr
(:error "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)))
(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>)
; 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 obj))))))
(de :machins (obj)
; re'alise le chargement de l'instruction obj
(let ((obj1 (cadr obj)) (obj2 (caddr obj)) (obj3 (cadddr obj)))
(selectq (car obj)
(MOV ; (MOV source dest)
(if (:register? obj2)
(:movsrc obj1 obj2)
(:movdest (:prepsrc obj1 'X1) obj2)))
(PUSH
; (PUSH <op>) == subi SP 4
; store16r (prepsrc obj1 'X1) SP 0
(setq obj1 (:prepsrc obj1 'X1))
(:inst 'subi 'SP 4)
(:inst 'store16r obj1 'SP)
(:val16abs 0))
(JCALL ; (JCALL <sym>) == jsb (FVAL :arg1)
(:inst 'subi 'SP 4)
(:inst 'laddrp16 'X1 0)
(:1word 16)
(:inst 'store16r 'X1 'SP)
(:val16abs 0)
(:movsrc (list 'fvalq obj1) 'X1)
(:inst 'ret 'X1 'X1))
(JMP ; (JUMP <sym>) == (JMP) (FVALQ <sym>)
; en fait pour rester en absolu : laddr puis ret
(:movsrc (list 'fvalq obj1) 'X1)
(:inst 'ret 'X1 'X1))
(CAR
; (CAR A1/A2/A3) == load rx,rx,0 ?!?!? obsolete
(:inst 'load obj1 obj1)
(:val16abs 0))
(CDR
; (CDR A1/A2/A3) == load rx,rx,4 ?!?!?!? obsolete
(:inst 'load obj1 obj1)
(:val16abs 4))
(CABNE ; (CABNE op1 op2 lab)
; br<>s op1 op2 lab
(:instbr 'br<>s (:prepsrc obj1 'X1) (:prepsrc obj2 'X2))
(:val16rel obj3))
(RETURN
; (RETURN) == load 'X1 SP 0; addi SP 4; ret X1 X1
(:inst 'load 'X1 'SP)
(:val16abs 0)
(:inst 'addi 'SP 4)
(:inst 'ret 'X1 'X1))
(BRA
; (BRA <lab>) == br lab
(:inst 'brs 0 0)
(:val16rel obj1))
(BTNIL ; (BTNIL op lab)
(:btf1xx 'KNIL 'br=s t))
(CABEQ ; (CABEQ op1 op2 lab)
; br=s op1 op2 lab
(:instbr 'br=s (:prepsrc obj1 'X1) (:prepsrc obj2 'X2))
(:val16rel obj3))
(POP
; (POP <op>) == load obj1 SP 0; addi SP 4
(cond ((:register? obj1)
(:inst 'load obj1 'SP)
(:val16abs 0)
(:inst 'addi 'SP 4))
(t
(:inst 'load 'X1 'SP)
(:val16abs 0)
(:inst 'addi 'SP 4)
(:movdest 'X1 obj1))))
(BFNIL ; (BFNIL op lab)
(:btf1xx 'KNIL 'br<>s ()))
(BTCONS ; (BTCONS op lab)
(:btf1xx 'RBCONS 'br>=s t))
(BFCONS ; (BFCONS op lab)
(:btf1xx 'RBCONS 'br<s ()))
;
; les tests de type
;
(BTFIX ; (BTNUMB op lab)
#-:31bitfloats
(:btf1xx 'RBFLOAT 'br<s t)
#+:31bitfloats
(:bt2xx ''0 'RBFLOAT))
(BFFIX ; (BFNUMB op lab)
#-:31bitfloats
(:btf1xx 'RBFLOAT 'br>=s ())
#+:31bitfloats
(:bf2xx ''0 'RBFLOAT))
(BTFLOAT ; (BTFLOAT op1 lab)
#+:31bitfloats
(:btf1xx ''0 'br<s t)
#-:31bitfloats
(:bt2xx 'RBFLOAT 'RBVECT))
(BFFLOAT ; (BFFLOAT op1 lab)
#+:31bitfloats
(:btf1xx ''0 'br>=s ())
#-:31bitfloats
(:bf2xx 'RBFLOAT 'RBVECT))
(BTSTRG ; (BTSTRG op1 lab)
(:bt2xx 'RBSTRG 'RBSYMB))
(BFSTRG ; (BFSTRG op1 lab)
(:bf2xx 'RBSTRG 'RBSYMB))
(BTVECT ; (BTVECT op1 lab)
(:bt2xx 'RBVECT 'RBSTRG))
(BFVECT ; (BFVECT op1 lab)
(:bf2xx 'RBVECT 'RBSTRG))
(BTSYMB ; (BTSYMB op1 lab)
(:bt2xx 'RBSYMB 'RBCONS))
(BFSYMB ; (BFSYMB op1 lab)
(:bf2xx 'RBSYMB 'RBCONS))
(BTVAR ; (BTVAR op1 lab)
(:bt2xx :adrBVAR 'RBCONS))
(BFVAR ; (BFVAR op1 lab)
(:bf2xx :adrBVAR 'RBCONS))
;
; Les comparaisons entieres
;
(CNBEQ ; (CNBEQ op1 op2 lab)
(:cnbxxieqn 'br=s t))
(CNBNE ; (CNBNE op1 op2 lab)
(:cnbxxieqn 'br<>s ()))
(CNBLT ; (CNBLT op1 op2 lab)
(:cnbxx 'br<s t))
(CNBLE ; (CNBLE op1 op2 lab)
(:cnbxx 'br<=s ()))
(CNBGT ; (CNBGT op1 op2 lab)
(:cnbxx 'br>s t))
(CNBGE ; (CNBGE op1 op2 lab)
(:cnbxx 'br>=s ()))
;
; Les comparaisons arithme'tiques flottantes.
;
(CFBEQ ; (CFBEQ op1 op2 lab)
(:comp2float 'br=s 0))
(CFBNE ; (CFBNE op1 op2 lab)
(:comp2float 'br<>s 0))
(CFBLT ; (CFBLT op1 op2 lab)
(:comp2float 'br=s -1))
(CFBLE ; (CFBLE op1 op2 lab)
(:comp2float 'br<>s 1))
(CFBGT ; (CFBGT op1 op2 lab)
(:comp2float 'br=s 1))
(CFBGE ; (CFBGE op1 op2 lab)
(:comp2float 'br<>s -1))
;
; Les instructions arithme'tiques
;
(DECR ; (DECR op)
(:macaro1op 'subi 1))
(DIFF ; (DIFF op1 op2)
(:macaro2op 'sub))
(INCR ; (INCR op)
(:macaro1op 'addi 1))
(LAND ; (LAND op1 op2)
(:macaro2op 'and))
(LOR ; (LOR op1 op2)
(:macaro2op 'or))
(LXOR ; (LXOR op1 op2)
(:macaro2op 'xor))
(LSHIFT ; (LSHIFT circ op)
(:inst 'seh 'X2 (:prepsrc obj1 'X2))
(:inst 'seh 'X1 (:prepsrc obj2 'X1))
(:inst 'br>=simm 'X2 0)
(:val16abs 12)
(:inst 'neg 'X2 'X2)
(:inst 'lsr 'X1 'X2)
(:inst 'brs 0 0)
(:val16abs 6)
(:inst 'lsl 'X1 'X2)
(:convnb 'X1)
(:movdest 'X1 obj2))
(NEGATE ; (NEGATE op)
(setq obj2 obj1)
(:macaro2op 'neg))
(PLUS ; (PLUS op1 op2)
(:macaro2op 'add))
(REM
(:macaro2op 'rem))
(QUO
(:macaro2op 'div))
(TIMES
(:macaro2op 'mpy))
;
; Les instructions arithme'tiques flottantes
;
(FPLUS (:instr2float 'radd))
(FDIFF (:instr2float 'rsub))
(FTIMES (:instr2float 'rmpy))
(FQUO (:instr2float 'rdiv))
;
; Les autres instructions (par ordre alpha)
;
(ADJSTK ; (ADJSTK 'nb)
(if (:immediat? obj1)
(cond ((and (ge (cadr obj1) 0) (lt (cadr obj1) 4))
(:inst 'addi 'SP (mul 4 (cadr obj1))))
((and (le (cadr obj1) 0) (gt (cadr obj1) -4))
(:inst 'subi 'SP (mul 4 (sub 0 (cadr obj1)))))
(t
(:inst 'laddr16r 'SP 'SP)
(:val16abs (mul 4 (cadr obj1)))))
(:movsrc obj1 'X1)
(:inst 'lsli 'X1 2)
(:inst 'seh 'X1 'X1)
(:inst 'add 'SP 'X1)))
(BRI
(:inst 'ret 'X1 (:prepsrc obj1 'X1)))
(BRX ; (BRX (l1 ... ln) index)
(:inst 'move 'X1 (:prepsrc obj2 'X1))
(:inst 'lsli 'X1 3)
(:inst 'laddrp16r 'X1 'X1)
(:1word 6)
(:inst 'ret 'X1 'X1)
(while obj1
(:inst 'brs 0 0)
(:val16rel (cadr (nextl obj1)))
(:1word 0)))
(CALL
; (CALL <sym>)
(:inst 'subi 'SP 4)
(:inst 'laddrp16 'X1 0)
(:1word 14)
(:inst 'store16r 'X1 'SP)
(:val16abs 0)
(:inst 'brs 0 0)
(:val16rel obj1))
(HBMOVX ; (HPMOVX val string index)
(cond ((:small-pos? obj3)
; index constant
(:inst 'load 'X2 (:prepsrc obj2 'X2))
(:val16abs 0)
(:inst 'storeb16r (:prepsrc obj1 'X1) 'X2)
(:val16abs (add 8 (cadr obj3))))
(t ; index calcule'
(:movaheabix obj2 obj3 'X2)
(:inst 'storeb16r (:prepsrc obj1 'X1) 'X2)
(:val16abs 0))))
(HBXMOV ; (HBXMOV string index dest) string[index] -> dest
(:movaheabix obj1 obj2 'X2)
(if (:register? obj3)
(progn
(:inst 'loadb16r obj3 'X2)
(:val16abs 0))
(:inst 'loadb16r 'X1 'X2)
(:val16abs 0)
(:movdest 'X1 obj3)))
(HGSIZE ; (HGSIZE vector/string arg2)
(:inst 'load 'X1 (:prepsrc obj1 'X1))
(:val16abs 0)
(if (:register? obj2)
(progn (:inst 'load obj2 'X1) (:val16abs 4))
(:inst 'load 'X2 'X1) (:val16abs 4)
(:movdest 'X2 obj2)))
(HPMOVX ; (HPMOVX val vector index)
(:movaheap obj2 obj3 'X2)
(:inst 'store16r (:prepsrc obj1 'X1) 'X2)
(:val16abs 0))
(HPXMOV ; (HPXMOV vector index val)
(:movaheap obj1 obj2 'X2)
(if (:register? obj3)
(progn (:inst 'load obj3 'X2)
(:val16abs 0))
(progn (:inst 'load 'X1 'X2)
(:val16abs 0)
(:movdest 'X1 obj3))))
(MOVXSP ; (MOVXSP val depl)
; on ajoute le de'placement au haut de pile
(:movsrc obj2 'X2)
(:inst 'lsli 'X2 2)
(:inst 'add 'X2 'SP)
(:inst 'store16r (:prepsrc obj1 'X1) 'X2)
(:val16abs 0))
(NOP
(:inst 'move 'X1 'X1))
(SOBGEZ ; (SOBGEZ op lab)
(let ((r1 (:prepsrc obj1 'X1)))
(:inst 'seh r1 r1)
(:inst 'subi r1 1)
(unless (eq r1 obj1)
(:movdest r1 obj1))
(:inst 'br>=simm r1 0)
(:val16rel obj2)
(:convnb r1)
(unless (eq r1 obj1)
(:movdest r1 obj1))))
(SSTACK ; (SSTACK <op>) movl op,sp
(:movsrc obj1 'SP))
(STACK
(:movdest 'SP obj1))
(XSPMOV ; (XSPMOV depl val)
(:movsrc obj1 'X1)
(:inst 'lsli 'X1 2)
(:inst 'add 'X1 'SP)
(if (:register? obj2)
(progn (:inst 'load obj2 'X1)
(:val16abs 0))
(progn (:inst 'load 'X2 'X1)
(:val16abs 0)
(:movdest 'X2 obj2))))
(t ; c'est donc une erreur
(:error ':machins obj1)))))
; .Section "Auxiliaires de chargement"
(de :immediat? (val)
(and (consp val)
(eq (car val) 'quote)
(fixp (cadr val))
(neqn (cadr val) #$8000)))
(de :small-pos? (val)
; teste si l'argument est un nb positif sur 15 bits
(and (consp val)
(eq (car val) 'quote)
(fixp (cadr val))
(neqn (cadr val) #$8000)
(ge (cadr val) 0)))
(de :small-imm? (val)
; teste si l'argument est une petite valeur imme'diate (4 bits)
(and (:small-pos? val)
(lt (cadr val) 16)))
(de :alignd ()
(when (neqn 0 (logand 3 (or (fixp :PCcurrent) (cdr :PCcurrent))))
(:inst 'or 'X1 'X1)))
(de :PCalignd (pc)
(if (neqn 0 (logand 3 (or (fixp :PCcurrent) (cdr :PCcurrent))))
(addadr pc 2)
pc))
(de :movaheabix (op ind reg)
; charge l'adresse heap d'octet "op+ind" dans "reg"
(:inst 'load reg (:prepsrc op reg))
(:val16abs 0)
(if (:small-pos? ind)
(if (< (cadr ind) 8)
(:inst 'addi reg (add 8 (cadr ind)))
(:inst 'laddr16r reg reg)
(:val16abs (add 8 (cadr ind))))
(:inst 'addi reg 8)
(:inst 'add reg (:prepsrc ind 'X1))))
(de :instr2float (instr)
; appel d'un instruction de base (en direct!) a` 2 arguments
#+:31bitfloats
(cond ((:register? obj2)
(:unrolfloat obj1 'X1)
(:unrolfloat obj2 obj2)
(:inst instr obj2 'X1)
(:rolfloat obj2 'X1))
(t
(:unrolfloat obj1 'X1)
(:unrolfloat obj2 'X2)
(:inst instr 'X2 'X1)
(:rolfloat 'X2 'X1)
(:movdest 'X2 obj2)))
#-:31bitfloats
(:error ':instr2float instr))
(de :unrolfloat (src reg)
; de'code le flottant 31 bits src et le met dans le
; registre reg.
(unless (eq reg src) (:movsrc src reg))
(:inst 'lsli reg 1))
(de :rolfloat (reg via)
(ifn (:register? reg)
(:error 'rolfloat reg))
(if (eq reg via)
(:error 'rolfloat (list reg via)))
; encode un flottant en flottant 31bits dans le registre reg
; en utilisant e'ventuellemtn le scratch via
(:inst 'movei via 0)
(:inst 'lsri reg 1)
(:inst 'sbit reg via))
(de :comp2float (oper cond)
; appel d'une comparaison de base (en direct) a` 2 arguments flottants
; "oper" est l'ope'rateur, "cond" la condition.
#+:31bitfloats
(progn
(:unrolfloat obj1 'X1)
(:unrolfloat obj2 'X2)
(:inst 'rcomp 'X1 'X2))
#-:31bitfloats
(progn
(:loadvalfloat obj1 'X3 'X1 'X2)
(:loadvalfloat obj2 'X4 'X3 'X4)
(:inst 'drcomp 'X1 'X3))
(:inst 'laddr16 'X4 0) (:val16abs cond)
(:instbr oper 'X1 'X4)
(:val16rel obj3))
(de :cnbxx (cond pred)
; comparaison arithme'tique sur 16 bits signe's
; on suppose que s'il y a une constante c'est en 2e`me ope'rande.
(:inst 'seh 'X1 (:prepsrc obj1 'X1))
(cond ((:small-imm? obj2)
; petit entier sur 4 bits
(:instbr (:immbr cond) 'X1 (cadr obj2)))
((:small-pos? obj2)
; pas la peine d'e'tendre le signe de la constante 15 bits
(:instbr cond 'X1 (:prepsrc obj2 'X2)))
(t ; cas le plus long
(:inst 'seh 'X2 (:prepsrc obj2 'X2))
(:instbr cond 'X1 'X2)))
(:val16rel obj3))
(de :cnbxxieqn (cond pred)
; comparaison arithme'tique sur 32 bits si = ou /=
(cond ((:small-imm? obj1)
(:instbr (:immbr cond) (:prepsrc obj2 'X2) (cadr obj1)))
((:small-imm? obj2)
(:instbr (:immbr cond) (:prepsrc obj1 'X1) (cadr obj2)))
(t
(:instbr cond (:prepsrc obj1 'X1) (:prepsrc obj2 'X2))))
(:val16rel obj3))
(de :btf1xx (borne cond pred)
(:instbr cond (:prepsrc obj1 'X1) (:prepsrc borne 'X2))
(:val16rel obj2))
(de :bf2xx (btype etype)
(unless (:register? etype) (:error ':bf2xx etype))
(setq obj1 (:prepsrc obj1 'X1))
(if (:small-imm? btype)
(:instbr 'br<simm obj1 (cadr btype))
(:instbr 'br<s obj1 (:prepsrc btype 'X2)))
(:val16rel obj2)
(:instbr 'br>=s obj1 etype)
(:val16rel obj2))
(de :bt2xx (btype etype)
(unless (:register? etype) (:error ':bt2xx etype))
(setq obj1 (:prepsrc obj1 'X1))
(if (:small-imm? btype)
(:instbr 'br<simm obj1 (cadr btype))
(:instbr 'br<s obj1 (:prepsrc btype 'X2)))
(:1word 10)
(:instbr 'br<s obj1 (:prepsrc etype 'X2))
(:val16rel obj2))
; .Section "Les fonctions de chargement des ope'randes"
(de :prepsrc (arg reg)
; pre'pare l'argument source "arg"
; s'il le faut range l'argument dans l'auxiliaire "reg"
; retourne le nume'ro de registre qui contient l'argument
(cond ((eq arg 'nil)
; ope'rande nil (en fait ||)
'KNIL)
((:register? arg)
; c'est de'ja` un registre
arg)
((atom arg)
; c'est un mot me'moire.
(cond ((memq arg '(LLINK DLINK ITCOUNT))
(:inst 'load32abs reg 0)
(:val32abs (symeval (symbol 'llcp arg)))
reg)
((memq arg '(CBINDN TAG LOCK PROT))
(:inst 'laddr32 reg 0)
(:val32abs (symeval (symbol 'llcp arg)))
reg)
(t
; ne doit jamais arriver pour le compilo
; sauf en cas de nouvelles de'finitions.
(if (and (symbolp arg)
(getfn1 'ld-dir arg))
(funcall (getfn1 'ld-dir arg) arg)
(:error ':prepsrc arg)))))
((memq (car arg) :mem-access)
; acce`s a` la me'moire indirect par registre
(:inst 'load reg (cadr arg))
(:val16abs (:getvalue (car arg)))
reg)
(t
(selectq (car arg)
(quote
; constante Lisp
(unless (or (fixp (cadr arg))
#+:31bitfloats
(floatp (cadr arg))
)
; c'est un litte'ral a` sauver
(ifn (stringp (cadr arg))
(:add-llitt (cadr arg))
(:add-llitts arg)))
(cond ((fixp (cadr arg))
(if (and (/= (cadr arg) #$8000)
(>= (cadr arg) 0))
(if (< (cadr arg) 16)
; constante sur 4 bits
(:inst 'movei reg (cadr arg))
; constante sur 16 bits
(:inst 'laddr16 reg 0)
(:val16abs (cadr arg)))
; constante sur 32 bits
; car extension de signe
(:inst 'laddr32 reg 0)
(:val16abs 0)
(:val16abs (cadr arg))))
(t ; constante symbolique sur 32 bits
(:inst 'laddr32 reg 0)
(:val32abs (loc (cadr arg)))))
reg)
(cvalq
; adresse d'une CVAL de symbole
(ifn (symbolp (cadr arg))
(:error ':prepsrc arg)
(:inst 'load32abs reg 0)
(:val32abs (loc (cadr arg)))
(:add-llitt (cadr arg)))
reg)
(fvalq
; adresse d'une FVAL de symbole
(ifn (symbolp (cadr arg))
(:error ':prepsrc arg)
(:inst 'load32abs reg 0)
(:val32abs
(addadr (loc (cadr arg)) (:getvalue 'fval)))
(:add-llitt (cadr arg)))
reg)
(|&|
(:inst 'load reg 'SP)
(:val16abs (mul 4 (cadr arg)))
reg)
(|@|
(:inst 'laddrp16 reg 0)
(:val16rel (cadr arg))
reg)
(eval
; Pour calculer des ope'randes a` load time.
(:prepsrc (eval (cadr arg)) reg))
(adr
(:inst 'laddr32 reg 0)
(:val32abs (cadr arg))
reg)
(t (:error ':prepsrc arg))))))
(de :movsrc (arg regin)
; transporte l'ope'rande "arg" de n'importe quel type
; dans le registre de nom "regin".
; retourne toujours "regin" en valeur.
(setq arg (:prepsrc arg regin))
(unless (eq arg regin) (:inst 'move regin arg))
regin)
(de :movdest (src dest)
; transporte "src" (toujours registre) vers "dest"
(cond ((:register? dest)
; reg -> reg
(:inst 'move dest src))
((atom dest)
(ifn (memq dest '(LLINK DLINK ITCOUNT))
(:error 'movdest dest)
(:inst 'storabs src 0)
(:val32abs (symeval (symbol 'llcp dest)))))
((memq (car dest) :mem-access)
; reg -> mem
(:inst 'store16r src (cadr dest))
(:val16abs (:getvalue (car dest))))
((eq (car dest) 'cvalq)
; reg -> CVAL symbole
(ifn (symbolp (cadr dest))
(:error ':movdest dest)
(:inst 'storabs src 0)
(:val32abs (loc (cadr dest)))
(:add-llitt (cadr dest))))
((eq (car dest) '|&|)
(:inst 'store16r src 'SP)
(:val16abs (mul 4 (cadr dest))))
((eq (car dest) 'eval)
; Pour calculer des ope'randes a` load time.
(:movdest src (eval (cadr dest))))
(t (:error ':movdest dest))))
; .Section "Les fonctions auxiliares de ge'ne'ration"
(de :macaheap (op reg)
; charge dans "reg" l'adresse heap de op
(setq op (:prepsrc op reg))
(:inst 'load reg op)
(:val16abs 0)
(:inst 'addi reg 8))
(de :movaheab (op ind reg)
; charge l'adresse heap d'octet op+ind dans reg
(:macaheap op reg)
(:inst 'add reg (:prepsrc ind 'X1)))
(de :movaheap (op ind reg)
; charge l'adresse heap de mot op+ind dans reg
(:macaheap op reg)
(:movsrc ind 'X1)
(:inst 'lsli 'X1 2)
(:inst 'add reg 'X1))
(de :convnb (reg)
; repasse en format 16 bits
(:inst 'laddr32 'X3 0)
(:val32abs '(0 . #$FFFF))
(:inst 'and reg 'X3))
(de :macaro1op (op 2nd)
(:movsrc obj1 'X1)
(:inst op 'X1 2nd)
(:convnb 'X1)
(:movdest 'X1 obj1))
(de :macaro2op (op)
(:inst 'seh 'X1 (:prepsrc obj2 'X1))
(:inst 'seh 'X2 (:prepsrc obj1 'X2))
(:inst op 'X1 'X2)
(:convnb 'X1)
(:movdest 'X1 obj2))
; .Section "Les fonctions auxiliaires de chargement me'moire"
(de :instbr (code op1 op2)
; l'instruction br<s dans le cas ou` op2 est un registre doit d'assembler
; en permutant op1 et op2.
(when (and (eq code 'br<s) (:register? op2))
(setq code 'br>s)
(psetq op1 op2 op2 op1))
; de meme pout br>=s
(when (and (eq code 'br>=s) (:register? op2))
(setq code 'br<=s)
(psetq op1 op2 op2 op1))
(:inst code op1 op2))
(de :inst (code op1 op2)
; charge une instruction de codop "code" avec 2 ope'randes.
(:1word
(logor (logshift (:getvalue code) 8)
(logor (logshift (:getvalue op1) 4) (:getvalue op2)))))
(de :val16abs (obj)
; chargement d'une valeur absolue de 16 bits
(:1word obj))
(de :val32abs (obj)
; chargement d'une valeur absolue de 32 bits
(cond ((fixp obj)
(:1word 0)
(:1word obj))
((consp obj)
(:1word (car obj))
(:1word (cdr obj)))
(t (:error ':val32abs obj))))
(de :1word (obj)
; chargement d'un mot de 16 bits en me'moire a` l'adresse
; contenue dans :PCcurrent, et gestion de cette valeur.
(when :talkp
; impression du code en hexade'cimal.
(when (> :nwl 6)
(setq :nwl 0)
(terpri)
(outpos 30)
(:prinhex :PCcurrent)
(prin " "))
(incr :nwl)
(prin " ")
(:prinhex obj))
(if (gtadr :PCcurrent :Ecode)
(with ((outchan ()))
(print ERRFCOD)
(exit #:system:toplevel-tag))
(memory :PCcurrent obj)
(setq :PCcurrent (incradr :PCcurrent 2))))
(de :patch32rel ()
(let ((PCprevious (:sa :PCcurrent 2)))
(memory PCprevious (logor #$1000 (memory PCprevious)))))
(de :val16rel (adr)
; charge un de'placement sur 16 bits (en fait toujours sur 32 bits!)
(let ((l (:aa (:valrel adr) 2)))
(:patch32rel) ; rajoute le bit rel 32 dans le mot pre'ce'dent
(:1word (car l))
(:1word (cdr l))))
; .Section "Fonctions de calcul d'adresse"
; .SSection "Les adresses absolues sur 32 bits"
(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 :valrel (adr)
; retourne un de'placement par rapport a` PC ou ()
(let ((valadr (:valadr adr)))
(if valadr
(:sa valadr :PCcurrent)
(if (and (symbolp adr) (null (assq adr :llabels)))
(:addentry adr (copy :PCcurrent))
(:addlabel adr (copy :PCcurrent)))
0)))
(de :solve16rel (ref)
(let ((relval
(:aa (:sa :PCcurrent ref) 2)))
(memory ref (car relval))
(memory (addadr ref 2) (cdr relval))))
(de :solverel (obj)
(mapc ':solve16rel
(cassq obj :llabels-nr))
(setq :llabels-nr
(delete (assq obj :llabels-nr) :llabels-nr)))
(de :solventry (obj)
(mapc ':solve16rel
(cassq obj :entries-not-resolved))
(setq :entries-not-resolved
(delete (assq obj :entries-not-resolved) :entries-not-resolved)))
(de :aa (a1 a2)
(setq #:ex:regret 0)
(xcons (ex+
(if (consp a1) (cdr a1) a1)
(if (consp a2) (cdr a2) a2))
(ex+
(if (consp a1) (car a1) 0)
(if (consp a2) (car a2) 0))))
(de :sa (a1 a2)
(:aa (:aa a1 1)
(cons (if (consp a2) (ex- (car a2)) -1)
(if (consp a2) (ex- (cdr a2)) (ex- a2)))))
; .Section "Gestion des tables"
(de :addlabel (sym adr)
; rajoute le symbole <sym> (a l'adresse <adr>)
; dans la table des e'tiquettes locales
(let ((val (assq sym :llabels-nr)))
(if val
(rplacd val (cons adr (cdr val)))
(newl :llabels-nr (list sym adr)))))
(de :addentry (sym adr)
; rajoute le symbole <sym> (a l'adresse <adr>)
; dans la table des entre'es locales
(let ((val (assq sym :entries-not-resolved)))
(if val
(rplacd val (cons adr (cdr val)))
(newl :entries-not-resolved (list sym adr)))))
(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)))))
; .Section "Sorties et Dumps Hexade'cimal"
(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 ':prinhex n))))
(de :prinhexb (n)
; imprime sur 2 chiffres hexa le nb n
(cond ((not (fixp n)) (:error ':prinhexb n))
((< n 0) (setq n 255))
((< n 16) (princn #/0)))
(with ((obase 16)) (prin n)))
(de :memory-dump (adr n)
; dump la memoire en hexa de <adr> sur <n> mots
; attention au SWAB du SPS9! octet de poids faibles a gauche!
(setq adr (copy adr)) ; pour le incradr
(until (<= n 0)
(:prinhex adr)
(outpos 10)
(repeat 8 (:prinhex (memory adr))
(prin " ")
(incradr adr 2)
(decr n))
(terpri)))
; .Section "Chargement des points d'entree speciaux du lap/llcp"
; .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
:localstack ; ?!?!?!?!?!?
:valaux ; itou pour des valeurs locales.
:f ; itou (pour des getfn1)
(:nwl 0) ; itou pour tabler le code produit.
(#:ex:regret)) ; pour rester propre
; 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)))
()))
; .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) )
() ))
(unless (or (eq (typefn 'loaderesolve) 'expr) (get 'loaderesolve 'resetfn))
(mapc
(lambda (m)
(when (typefn m)
(remfn m)
(remprop m '#:system:loaded-from-file)))
(oblist '#.#:sys-package:colon)))