; .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 brs #$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= (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 ) ; 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 ) ; 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 ) ; 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 ) == 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 ) == 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 ) == (JMP) (FVALQ ) ; 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 ) == 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 ) == 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 ()) #+:31bitfloats (:bf2xx ''0 'RBFLOAT)) (BTFLOAT ; (BTFLOAT 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 'brs 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 ) (: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 ) 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=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= (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 brs) (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 (a l'adresse ) ; 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 (a l'adresse ) ; 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 sur 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)))