compilation.lisp (31934B)
1 (require 'match "match") 2 (require 'util "util") ;; split-bytes & d'autres 3 (require 'squash-lisp "implementation/squash-lisp") 4 5 ;; TODO !! ATTENTION !! Quand onc récupère des données qui font 1 octet de large, en fait on récupère 4 octets ! 6 7 ;; TODO !! ATTENTION !! Tout multiplier par 4 (octets) 8 9 ;; TODO ! chercher "sens de la soustraction" dans ce fichier 10 11 (defvar *asm-sections* '(code data)) ;; Note : l'assembleur sera produit dans cet ordre 12 13 (defvar *label-ctr* 0) 14 15 (defvar *sys-labels*) 16 (defun syslabel (label) 17 `(label ,@(assoc-or-push label (list (derived-symbol label) (incf *label-ctr*)) *sys-labels*))) 18 19 (defvar *code-labels*) 20 (defun code-label (label) 21 `(label ,@(assoc-or-push label (list (derived-symbol label) (incf *label-ctr*)) *code-labels*))) 22 23 (defvar *global-labels*) 24 (defun global-label (label) 25 (assoc-or-push label (list (list (derived-symbol label) (incf *label-ctr*)) 26 (list (derived-symbol label) (incf *label-ctr*)) 27 (list (derived-symbol label) (incf *label-ctr*))) 28 *global-labels*)) 29 30 (defun global-label-symbol (label) `(label ,@(car (global-label label)))) 31 (defun global-label-variable (label) `(label ,@(cadr (global-label label)))) 32 (defun global-label-function (label) `(label ,@(caddr (global-label label)))) 33 34 (defvar *res-asm-constants* nil) 35 36 (defun type-number (type) 37 (or (position type '(nil fixnum bignum symbol string cons closure-object captured-var)) 38 (error "type-number : unknown type : ~a" type))) 39 40 (defun error-code (err) 41 (position err '(normal-exit 42 unwind-for-tagbody--doit-contenir-un-jump))) 43 44 (defun assembly-label-or-number-p (expr) 45 (or (numberp expr) 46 (match (label $$ $n) expr))) 47 48 (defun immutable-assembly-place-p (expr) 49 (cond-match 50 expr 51 ((constant (? assembly-label-or-number-p)) t) 52 ((register (? (member x '(ip)))) t))) 53 54 (defun mutable-assembly-place-p (expr) 55 (cond-match 56 expr 57 ((register (? (member x '(r0 r1 r2 sp bp fp)))) t) 58 ((constant (? assembly-label-or-number-p)) t) 59 ((memory (? assembly-label-or-number-p)) t) 60 ((indexed (? assembly-label-or-number-p) 61 (? (member x '(r0 r1 r2 sp bp fp)))) 62 t) 63 ((indirect-register (? (member x '(r0 r1 r2 sp bp fp)))) t) 64 ((indirect-constant (? assembly-label-or-number-p)) t) 65 ((indirect-indexed (? assembly-label-or-number-p) 66 (? (member x '(r0 r1 r2 sp bp fp)))) 67 t))) 68 69 (defun assembly-place-p (expr) 70 (or (immutable-assembly-place-p expr) 71 (mutable-assembly-place-p expr))) 72 73 (defun assembly-instruction-p (expr) 74 (cond-match 75 expr 76 ((mov :src $ap :dst $map) t) 77 ((movb :src $ap :dst $map) t) 78 ((push :src $ap) t) 79 ((pop :dst $map) t) 80 (((? (member x '(jmp jeq jpp jpg jpe jge jne))) :to $ap) t) 81 ((add :src $ap :dst $map) t) 82 ((sub :src $ap :dst $map) t) 83 ((cmp :src1 $ap :src2 $ap) t) 84 (((? or (eq x 'db) (eq x 'dl)) (constant (? assembly-label-or-number-p)))) 85 ((halt) t))) 86 87 (defun compilo-check-0 (asm) 88 (let ((non-empty nil) 89 (etiquettes nil) 90 (res nil)) 91 ;; TODO : vérification de l'existance des étiquettes 92 (labels ((compilo-check-1 (asm) 93 (cond-match 94 asm 95 ((section (? $$ (member x *asm-sections*)) :body . @) 96 (every #'compilo-check-1 body)) 97 ((label :l $$ :n $n) 98 (push n etiquettes) 99 t) 100 (_ 101 (if (assembly-instruction-p asm) 102 (progn 103 (setq non-empty t) 104 t) 105 (progn 106 (warn "compilo-check-0 : this should not be here :~&~w" asm) 107 nil)))))) 108 (setq res (compilo-check-1 asm))) 109 (unless non-empty 110 (warn "compilo-check-0 : Le code assembleur est vide ! Il n'y a aucune instruction.") 111 (setq res nil)) 112 (unless (match (section (? $$ (member x *asm-sections*)) . @) asm) 113 (warn "compilo-check-0 : malformed top-level assembly structure.") 114 (setq res nil)) 115 res)) 116 117 (defun flatten-asm (asm) 118 (let ((res (mapcar #'list *asm-sections*)) 119 (current nil)) 120 (labels ((flatten-asm-1 (asm) 121 (cond-match 122 asm 123 ((section :sec $$ :body _*) 124 (setq current (assoc sec res)) 125 (unless current 126 (error "flatten-asm : invalid section : ~w" sec)) 127 (mapcar #'flatten-asm-1 body)) 128 ((label :nice-name $$ :number $n) 129 (push asm (cdr current))) 130 ((:mnemonique $$ :args $ap*) 131 (push asm (cdr current))) 132 (_ 133 (error "flatten-asm : assertion failed ! this should not be here :~&~w" asm))))) 134 (flatten-asm-1 asm)) 135 (apply #'append (mapcar (lambda (x) (cons (list 'section (car x)) (reverse (cdr x)))) res)))) 136 137 (defmacro with-label (l* &rest body) 138 `(let ,(mapcar (lambda (l) `(,(car l) (code-label (make-symbol (string ,(cadr l)))))) l*) 139 ,@body)) 140 141 (defun compilo-init (main) 142 `(section code 143 ;; TODO : variables : top-heap max-top-heap bottom-stack min-bottom-stack nil 144 ;; démarrer avec un bottom-stack = 1k (on se réserve une petite marge pour les fuites mémoire :) + push & pop temporaires). 145 ;; TODO : fonctions : (do-gc param;r0=taille heap nécessaire, doit conserver tous les registres à l'identique.) 146 ;; TODO : fonctions : (do-gc-redim-heap param:r0=supplément stack à allouer (au minimum). Doit préserver r1 (ou bien on peut affecter bottom-stack dans cette fonction)) 147 ;; TODO : root-set-gc (la liste de symboles, principalement). 148 (push (constant ,(syslabel nil))) ;; paramètres 149 (push (constant ,(syslabel nil))) ;; closure 150 (push (register ip)) 151 (jmp (constant ,(code-label main))) 152 ,(syslabel 'end-halt) 153 (mov (constant ,(error-code 'normal-exit)) (register r0)) 154 (halt))) ;; TODO : dépendant de vm / os 155 156 (defun compilo-alloc-tas () 157 "param:r1=taille à allouer, «returns» allocated adress in r0, clobbers r1" 158 (with-label ((l-alloc 'jump-dest-alloc)) 159 `(section code 160 ,(syslabel 'alloc-tas) 161 (push (register r2)) 162 (mov (memory ,(syslabel 'top-heap)) (register r0)) 163 (add (register r1) (register r0)) 164 (mov (memory ,(syslabel 'max-top-heap)) (register r2)) 165 (cmp (register r0) (register r2)) 166 (jpp (constant ,l-alloc)) 167 (push ip) 168 (jmp (constant ,(syslabel 'do-gc))) 169 ,l-alloc 170 (mov (register r0) (memory ,(syslabel 'top-heap))) 171 (sub (register r1) (register r0)) ;; sens de la soustraction 172 (pop (register r2)) 173 (pop (register r1)) 174 (jmp (register r1))))) 175 176 (defun compilo-alloc-pile () 177 "param:r0=size, «returns» nothing, clobbers r0" 178 (with-label ((l-alloc 'jump-dest-alloc)) 179 `(section code 180 ,(syslabel 'alloc-pile) 181 (push (register r1)) 182 (push (register r2)) 183 (mov (memory ,(syslabel 'bottom-stack)) (register r1)) 184 (sub (register r0) (register r1)) ;; sens de la soustraction 185 (mov (memory ,(syslabel 'min-bottom-stack)) (register r2)) 186 (cmp (register r1) (register r2)) 187 (jpg (constant ,l-alloc)) 188 (push ip) 189 (jmp (constant ,(syslabel 'do-gc-redim-heap))) 190 ,l-alloc 191 (mov (register r1) (memory ,(syslabel 'bottom-stack))) 192 (pop (register r2)) 193 (pop (register r1)) 194 (pop (register r0)) 195 (jmp (register r0))))) 196 197 (defun db-type (type) 198 `(db (constant ,(type-number type)))) 199 200 (defvar *asm-fixnum-size* 32) 201 (defvar *asm-max-fixnum* (- (expt 2 *asm-fixnum-size*) 1)) 202 (defun compilo-encode-constant (val) 203 ;; TODO ! 204 (cond 205 ;; fixnum 206 ((and (numberp val) (<= val *asm-max-fixnum*)) 207 (with-label ((l 'fixnum-constant)) 208 (push `(section data 209 ,l 210 ,(db-type 'fixnum) 211 (dl (constant ,val))) 212 *res-asm-constants*) 213 l)) 214 215 ;; bignum 216 ((and (numberp val) (> val *asm-max-fixnum*)) 217 (with-label ((l 'bignum-constant)) 218 (push `(section data 219 ,l 220 ,(db-type 'bignum) 221 ,@(let ((lst (split-bytes val (+ 1 *asm-fixnum-size*)))) 222 (mapcar (lambda (x) `(dl (constant ,x))) 223 (cons (length lst) lst)))) 224 *res-asm-constants*) 225 l)) 226 227 ;; string 228 ((stringp val) 229 (with-label ((l 'string-constant)) 230 (push `(section data 231 ,l 232 ,(db-type 'string) 233 (dl (constant ,(length val))) 234 ,@(map 'list (lambda (x) `(dl (constant ,(char-code x)))) val)) 235 *res-asm-constants*) 236 l)) 237 238 ;; nil 239 ((null val) 240 (syslabel nil)) 241 242 ;; symbol 243 ((symbolp val) 244 (let ((l (global-label-symbol val))) 245 (push `(section data 246 ,l 247 ,(db-type 'symbol) 248 (dl (constant ,(compilo-encode-constant (string val)))) ;; pointeur vers nom du symbole 249 (dl (constant ,(syslabel nil))) ;; intern ? ;; TODO !!!!!!! 250 (dl (constant ,(syslabel nil))) ;; fdefinition ;; TODO 251 (dl (constant ,(syslabel nil))) ;; global value 252 (dl (constant ,(syslabel nil)))) ;; plist 253 *res-asm-constants*) 254 l)) 255 256 ;; array 257 ((arrayp val) 258 (with-label ((l 'cons-cell-constant)) 259 (push `(section data 260 ,l 261 ,(db-type 'array) 262 (dl (constant ,(length val))) 263 ,@(map 'list (lambda (x) `(dl (constant ,(compilo-encode-constant x)))) val)) 264 *res-asm-constants*) 265 l)) 266 267 ;; cons 268 ((consp val) 269 (with-label ((l 'cons-cell-constant)) 270 (push `(section data 271 ,l 272 ,(db-type 'cons) 273 (dl (constant ,(compilo-encode-constant (car val)))) 274 (dl (constant ,(compilo-encode-constant (cdr val))))) 275 *res-asm-constants*) 276 l)))) 277 278 (defun compilo-2 (expr variables) 279 "Vérifie si expr est bien un résultat valable de squash-lisp-1. 280 Permet aussi d'avoir une «grammaire» du simple-lisp niveau 1. 281 Attention : il y a quelques invariants qui ne sont pas présents dans cette vérification." 282 (labels ((compilo-3 (expr) 283 (cond-match 284 expr 285 ;; simple-tagbody est équivalent à un progn, mais nécessaire pour les macrolet. 286 (((? (member x '(progn simple-tagbody))) :body _*) 287 `(section code ,@(mapcar #'compilo-3 body))) 288 ((if :condition _ :si-vrai _ :si-faux _) 289 (with-label ((after-if 'after-if) (after-else 'after-else)) 290 `(section code 291 ,(compilo-3 condition) 292 (cmp (register r0) (constant ,(syslabel nil))) 293 (jeq ,after-if) 294 ,(compilo-3 si-vrai) 295 (jmp (constant ,after-else)) 296 ,after-if 297 ,(compilo-3 si-faux) 298 ,after-else))) 299 ((unwind-protect :body _ :cleanup _) 300 (with-label ((l-protect-code 'protect-code) (l-after-protect-code 'after-protect-code)) 301 `(section code 302 (push (constant ,l-protect-code)) 303 (push (constant ,(syslabel 'marker-unwind-protect))) 304 ,(compilo-3 body) 305 (pop (register r2)) 306 (pop (register r2)) 307 (jmp (constant ,l-after-protect-code)) 308 ,l-protect-code 309 ,(compilo-3 cleanup) 310 (jmp (constant ,(syslabel 'start-unwind))) 311 ,l-after-protect-code))) 312 ;; tagbody-unwind-catch est équivalent à unwind-catch, mais nécessaire pour les macrolet. 313 (((? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body (progn _*) :catch-code _) 314 (with-label ((l-catch-code 'catch-code) (l-after-catch-code 'after-catch-code)) 315 `(section code 316 ;; TODO !!! prendre en compte ces push dans la taille de l'environnement ! 317 (push (constant ,l-catch-code)) 318 ,(compilo-3 object) 319 (push (register r0)) 320 (push (constant ,(syslabel 'marker-unwind-destination))) 321 ,(compilo-3 body) 322 (pop (register r2)) 323 (pop (register r2)) 324 (pop (register r2)) 325 (jmp (constant ,l-after-catch-code)) 326 ,l-catch-code 327 ,(compilo-3 catch-code) 328 ,l-after-catch-code))) 329 ((unwind :object _) 330 `(section code 331 ,(compilo-3 object) 332 (push (register ip)) 333 (jmp (constant ,(syslabel 'find-unwind-destination))) ;; renvoie le haut de la pile dans r1. TODO ATTENTION À LA PLACE PRISE PAR LE PUSH 334 (mov (register sp) (memory ,(syslabel 'singleton-unwind-destination))) 335 (mov (register r1) (register sp)) ;; On remonte en haut de la pile 336 (jmp (constant ,(syslabel 'start-unwind))))) 337 338 ((unwind-for-tagbody :object _ :post-unwind-code _) 339 (with-label ((l-post-unwind-code 'post-unwind-code)) 340 `(section code 341 (compilo-3 object) 342 (push (register ip)) 343 (jmp (constant ,(syslabel 'find-unwind-destination))) ;; renvoie le haut de la pile dans r1. TODO ATTENTION À LA PLACE PRISE PAR LE PUSH 344 (mov (constant ,l-post-unwind-code) (memory ,(syslabel 'singleton-post-unwind-code))) 345 (add (constant 3) (register sp)) ;; On "re-push" l'adresse de la cible, l'objet et le marqueur, mettre 2 au lieu de 3 si on n'a pas de marqueur. 346 (mov (register sp) (memory ,(syslabel 'singleton-unwind-destination))) 347 (mov (register r1) (register sp) ;; On remonte en haut de la pile 348 (jmp (constant ,(syslabel 'start-unwind))) 349 ,l-post-unwind-code 350 ,(compilo-3 post-unwind-code) ;; DOIT contenir un jump ! 351 (mov (constant ,(error-code 'unwind-for-tagbody--doit-contenir-un-jump)) r0) ;; valeur de retour pour la vm 352 (halt))))) ;; Sinon contenait pas de jump, on quite "brutalement" 353 ((jump-label :name $$) 354 `(section code ,(code-label name))) 355 ((jump :dest $$) 356 `(section code (jmp (constant ,(code-label dest))))) 357 ;; TODO : cas particulier funcall car 358 ;; TODO : cas particulier funcall cdr 359 ((funcall :fun _ :params _*) 360 `(section code 361 ;; Sommaire : 362 ;; - calculer les paramètres un à un 363 ;; - à chaque fois, ajouter leur valeur dans une liste, par chirurgie svp. 364 ;; - maintenir quelque part dans la pile un pointeur vers le premier paramètre 365 ;; - et un pointeur vers le dernier cons de la liste de paramètres 366 ;; - calculer la fonction 367 ;; - push ip 368 ;; - jmp r0 369 370 ;; Note : on pourrait tout allouer d'un coup, et setter tout la liste avec des nil immédiatement après. 371 ;; TODO : si aucun paramètre 372 373 ;; premier paramètre : 374 ,(compilo-3 (car params)) 375 (push (register r0)) ;; (r0 vaut la valeur du paramètre) 376 ;; alloc 1+4+4 bytes of memory for a cons 377 (mov (constant ,(+ 1 4 4)) (register r1)) 378 (push (register ip)) 379 (jmp (constant ,(syslabel 'alloc-tas))) 380 ;; On push la liste des paramètres (encore incomplète) 381 (push (register r0)) 382 ;; set cons type byte : 383 (movb (constant ,(type-number 'cons)) (indirect-register r0)) 384 ;; set car of new cons to value : 385 (pop (register r2)) ;; r2 := value 386 (mov (register r2) (indexed 1 r0)) 387 ;; allways set cdr to nil, in case the gc came by : 388 (mov (constant ,(syslabel nil)) (indexed 5 r0)) 389 ;; le cons courant devient l'ancien 390 (mov (register r0) (register r1)) 391 392 ,@(loop 393 for i in (cdr params) 394 append `((push (register r1)) ;; (r1 vaut old-cons) 395 ,(compilo-3 i) 396 (push (register r0)) ;; (r0 vaut la valeur du paramètre) 397 ;; alloc-tas 1+4+4 bytes of memory for a cons 398 (mov (constant ,(+ 1 4 4)) (register r1)) 399 (push (register ip)) 400 (jmp (constant ,(syslabel 'alloc-tas))) 401 ;; set cons type byte : 402 (movb (constant ,(type-number 'cons)) (indirect-register r0)) 403 ;; set cdr of old last to new cons : 404 (pop (register r2)) ;; r2 := value 405 (pop (register r1)) ;; r1 := old-cons 406 (mov (register r0) (indexed 5 r2)) 407 ;; set car of new cons to value : 408 (mov (register r2) (indexed 1 r0)) 409 ;; allways set cdr to nil, in case the gc came by : 410 (mov (constant ,(syslabel 'nil)) (indexed 5 r0)) 411 ;; le cons courant devient l'ancien 412 (mov (register r0) (register r1)))) 413 414 ;; On calcule la fonction : 415 ,(compilo-3 fun) 416 417 ;; Facultatif : 418 ;; On teste si le premier octet de *r0 est bien closure-object (sait-on jamais…) 419 (mov (indirect-register r0) (register r1)) 420 (cmp (constant ,(type-number 'closure-object)) (register r1)) 421 (jne (constant ,(syslabel 'invalid-closure-object))) 422 ;; Fin facultatif 423 424 ;; On récupère la closure 425 (mov (indexed 5 r0) (register r1)) 426 (push (register r1)) ;; on push la closure (2e paramètre) 427 ;; TODO !!! la closure et les paramètres sont dans le mauvais ordre ! corriger ça dans le préambule de la fonction 428 ;; On récupère la fonction 429 (mov (indexed 1 r0) (register r0)) 430 ;; On appelle la fonction 431 (push (register ip)) 432 (jmp (register r0)))) 433 ((quote :val _) 434 (compilo-encode-constant val)) 435 ((get-var :name $$) 436 (let ((assoc (assoc name variables))) 437 (unless assoc (error "compilo-3 : get-var sur ~a, mais n'est pas présente dans les variables:~&~a" name variables)) 438 `(section code (mov (indexed ,(cdr assoc) bp) (register r0))))) 439 ((setq :name $$ :value _) 440 (let ((assoc (assoc name variables))) 441 (unless assoc (error "compilo-3 : setq sur ~a, mais n'est pas présente dans les variables:~&~a" name variables)) 442 `(section code 443 ,(compilo-3 value) 444 (mov (register r0) (indexed ,(cdr assoc) bp))))) 445 ((fdefinition (quote :name $$)) 446 `(section code (mov (memory ,(global-label-function name)) (register r0)))) 447 ((symbol-value (quote :name $$)) 448 `(section code (mov (memory ,(global-label-variable name)) (register r0)))) 449 ((set (quote :name $$) :value _) 450 `(section code 451 ,(compilo-3 value) 452 (mov (register r0) (memory ,(global-label-variable name))))) 453 ((make-closure :fun $$ :vars $$*) 454 `(section code 455 ;; On alloue 1+4+4 octets pour un objet closure, et 9*(length vars) pour les cons. 456 (mov (constant ,(+ 1 4 4 (* 9 (length vars)))) (register r1)) 457 (push (register ip)) 458 (jmp (constant ,(syslabel 'alloc-tas))) 459 ;; set type = closure-object 460 (movb (constant ,(type-number 'captured-var)) (indirect-register r0)) 461 ;; set mot1 = adresse de la fonction 462 (mov (constant ,(global-label-variable fun)) (indexed 1 r0)) 463 ;; set mot2 = on construit une liste de longueur (length vars) en la remplissant avec les valeurs des vars. 464 (mov (register r0) (register r1)) 465 466 ,@(loop 467 for i from 0 below (- (length vars) 1) 468 append `((add (constant 9) (register r1)) 469 (mov (register r1) (indexed ,(+ 5 (* 9 i)) r0)))) 470 ;; nil final 471 (mov (constant ,(syslabel nil)) (indexed ,(+ 5 (* 9 (- (length vars) 1))) r0)) 472 ,@(loop 473 for i from 1 to (length vars) 474 and name in vars 475 for not-captured = (code-label (make-symbol "NOT-CAPTURED")) 476 for assoc = (assoc name variables) 477 unless assoc do (error "compilo-3 : make-closure sur ~a, mais n'est pas présente dans les variables:~&~a" name variables) 478 append `((mov (indexed ,(cdr assoc) bp) (register r2)) 479 (cmp (indirect-register r2) (constant ,(type-number 'captured-var))) 480 (jne (constant ,not-captured)) 481 (mov (indexed 1 r2) (register r2)) 482 ,not-captured 483 (mov (register r2) (indexed ,(+ 1 (* 9 i)) r0)))))) 484 ((make-captured-var :name $$) 485 `(section code 486 ;; allouer 5 octets 487 (mov (constant 5) (register r0)) 488 (push ip) 489 (jmp (constant ,(syslabel 'alloc-tas))) ;; => adresse dans r0 490 ;; affecter le pointeur à la variable 491 ,(let ((assoc (assoc name variables))) 492 (unless assoc (error "compilo-3 : make-captured-var sur ~a, mais n'est pas présente dans les variables:~&~a" name variables)) 493 `(mov (register r0) (indexed ,(cdr assoc) bp))) 494 ;; affecter le type captured-var au premier 495 (movb (constant ,(type-number 'captured-var)) (indirect-register r0)) 496 ;; affecter le pointeur nil aux 4 suivants 497 (mov (constant ,(global-label-symbol nil)) (indirect-register r0)))) 498 ((get-captured-var :name $$) 499 (let ((assoc (assoc name variables))) 500 (unless assoc (error "compilo-3 : get-captured-var sur ~a, mais n'est pas présente dans les variables:~&~a" name variables)) 501 `(section code 502 (mov (indexed ,(cdr assoc) bp) (register r0)) 503 (mov (indexed 1 (register r0)) (register r0))))) ;; TODO ! actuellement : Pas de test de type 504 ((set-captured-var :name $$ :value _) 505 (let ((assoc (assoc name variables))) 506 (unless assoc (error "compilo-3 : set-captured-var sur ~a, mais n'est pas présente dans les variables:~&~a" name variables)) 507 `(section code 508 ,(compilo-3 value) 509 (mov (indexed ,(cdr assoc) bp) (register r1)) 510 (mov (register r0) (indexed 1 (register r1)))))) 511 (_ 512 (warn "compilo-3: Assertion failed ! This should not be here :~&~w" expr) 513 nil)))) 514 (compilo-3 expr))) 515 516 (defun compilo-1 (expr) 517 (cond-match 518 expr 519 ((top-level :main $$ :globals (($$*) . ($$*)) (progn (set (quote :names $$) (lambda (:closure-names $$ &rest :params-names $$) (get-var $$) (get-var $$) (let :vars ($$*) :bodys _)))*)) 520 (loop 521 for name in names 522 and closure-name in closure-names 523 and params-name in params-names 524 and var in vars 525 and body in bodys 526 for nbvars = (length var) 527 collect `(section code 528 ,(code-label name) 529 ;; +1 pour les paramètres (non) 530 ;; +1 pour la closure (non) 531 ;; TODO : + autant que nécessaire pour les différents funcall et unwind 532 ;; +1 pour le bp 533 ;; +1 pour le begin-frame 534 ;; +1 pour le marker-end-frame 535 (mov (constant ,(+ 3 nbvars)) (register r0)) 536 (push (register ip)) ;; call 537 (mov (register sp) (register r0)) ;; begin-frame : Va avec le marker-end-frame 538 (push (register bp)) 539 (mov (register sp) (register bp)) 540 (add (constant ,nbvars) (register sp)) 541 (push (register r0)) ;; Permet à unwind de sauter directement jusqu'au begin-frame. 542 (push (constant ,(syslabel 'marker-end-frame))) 543 (jmp (constant ,(syslabel 'reserve-stack))) ;; lance le gc pour re-dimensionner le tas si nécessaire / ou bien erreur si dépassement. 544 (sub (constant ,nbvars) (register sp)) ;; TODO ! vérifier le sens du sub 545 ,(compilo-2 body (loop 546 with hole = (make-symbol "HOLE") 547 for v in (append (list params-name closure-name hole hole hole) var) 548 for i upfrom -2 549 collect `(,v . ,i))) 550 (add (constant ,nbvars) (register sp)) 551 (pop (register bp)) 552 (pop (register r1)) ;; params 553 (pop (register r1)) ;; closure 554 (pop (register r1)) ;; ip 555 (jmp (register r1))) ;; ret 556 into res 557 finally (return 558 `(section code 559 ,(compilo-init main) 560 ,@res 561 ,@(reverse *res-asm-constants*))))) 562 (_ 563 (error "compilo-1 : malformed top-level : ~w" expr)))) 564 565 (defun compilo-0 (expr) 566 (setq *label-ctr* 0) 567 (setq *sys-labels* nil) 568 (setq *global-labels* nil) 569 (setq *code-labels* nil) 570 (setq *res-asm-constants* nil) 571 (compilo-1 (squash-lisp-1+3 expr))) 572 573 (defun compilo (expr) 574 (flatten-asm (compilo-0 expr))) 575 576 (defun compilo-check (expr) 577 (compilo-check-0 (compilo-0 expr))) 578 579 #| 580 581 La pile (en bas = le plus récent) : 582 583 ========== xx 584 closure 585 params 586 old-bp <--------------------- bp here 587 begin-frame = addr xx 588 marker-end-frame 589 [var0] 590 [var1] 591 [var2] 592 [var3] 593 ... 594 [var (- nb-vars 1)] <-------- sp here when body executed (next push will be underneath). 595 596 (squash-lisp-1+3 '(+ 2 3)) 597 598 # | 599 ;;; Exemples 600 601 (my-compile '(1 2 3)) 602 603 (my-compile 3) 604 ;; section .data 605 ;; fixnum-constant-1 606 ;; db 0 607 ;; db 3 608 609 (my-compile (+ 2 3)) 610 ;; => 611 ;; section .data 612 ;; fixnum-constant-1: 613 ;; db 1 614 ;; db 2 615 ;; section .data 616 ;; fixnum-constant-2: 617 ;; db 1 618 ;; db 3 619 ;; section .code 620 ;; code-1: 621 ;; load @global-1 r0 622 ;; push r0 623 ;; load @global-2 r0 624 ;; push r0 625 ;; push 2 626 ;; jsr @fn-+ 627 ;; retn 628 ;; section .text 629 ;; :fn-+ 630 ;; pop r1 631 ;; pop r0 632 ;; add r1 r0 633 ;; retn 634 |# 635 636 (provide 'compilation) 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 #| 655 (defmacro fasm (&rest stuff) 656 `(format nil ,@stuff)) 657 (defun db-type (type) 658 (fasm "db ~a" (type-number type))) 659 660 ;; My-compile 661 662 (defvar *result-asm* nil) 663 (defvar *asm-sections* '(code data)) ;; Note : l'assembleur sera produit dans cet ordre 664 665 (defun real-asm-block (section label body) 666 (when (not (member section *sections*)) 667 (error "Section assembleur inconnue : ~w" section)) 668 (push (format nil "section .~w" section) *result-asm*) 669 (push (format nil "~a:" label) *result-asm*) 670 (mapcar (lambda (x) (push x *result-asm*)) body) 671 label) 672 673 (defun asm-block (section label-base &rest body) 674 (real-asm-block 675 section 676 (format nil "~a-~a" label-base (incf *label-ctr*)) 677 body)) 678 679 (defvar *asm-once* nil) 680 (defun asm-once (section label &rest body) 681 (unless (member label asm-once :test #'string-equal) 682 (push label asm-once) 683 (real-asm-block section label body)) 684 label) 685 686 (defmacro my-compile (expr) 687 `(progn (setq *result-asm* nil) 688 (setq asm-once nil) 689 (my-compile-1 `(:main ,(lisp2cli ',expr))) 690 (format nil "~&~{~%~a~}" (flatten (reverse *result-asm*))))) 691 692 ;;; Règles de compilation 693 694 (defmatch my-compile-1) 695 696 (defun compile-get-val (cli) 697 (if (match (:nil :const . _) cli) 698 (list (fasm "load @~a r0" (my-compile-1 cli)) 699 (fasm "push r0")) 700 (list (my-compile-1 cli) 701 (fasm "push r0")))) 702 703 ;; call 704 (defmatch my-compile-1 (:nil :call :name _ :params . _) 705 (list 706 (mapcar #'compile-get-val params) 707 (fasm "push ~a" (length params)) 708 (fasm "jsr function-~a" name))) 709 710 ;; main 711 (defmatch my-compile-1 (:nil :main :body _*) 712 (asm-once 'code "main" 713 (mapcar #'my-compile-1 body))) 714 715 716 ;; if 717 ((if :condition _ :si-vrai _ :si-faux _) 718 (let ((else-label (gen-label "else")) 719 (end-if-label (gen-label "end-if"))) 720 (compile condition) 721 (fasm "cmp r0 @nil") 722 (fasm "jeq @~a" else-label) 723 (compile si-vrai) 724 (fasm "jmp @~a" end-if-label) 725 (fasm "label @~a" else-label) 726 (compile si-faux) 727 (fasm "label @~a" end-if-label))) 728 729 |#