428 lines
14 KiB
Common Lisp
428 lines
14 KiB
Common Lisp
(require 'match "match")
|
|
(require 'util "util")
|
|
(require 'squash-lisp "implementation/squash-lisp")
|
|
|
|
;; TODO !! ATTENTION !! Quand onc récupère des données qui font 1 octet de large, en fait on récupère 4 octets !
|
|
|
|
;; TODO !! ATTENTION !! Tout multiplier par 4 (octets)
|
|
|
|
(defvar *asm-sections* '(code data)) ;; Note : l'assembleur sera produit dans cet ordre
|
|
|
|
(defvar *sys-labels*)
|
|
(defun syslabel (label)
|
|
(assoc-or-push label (derived-symbol label) *sys-labels*))
|
|
|
|
(defvar *global-labels*)
|
|
(defun global-label (label)
|
|
(assoc-or-push label (list (derived-symbol label)
|
|
(derived-symbol label)
|
|
(derived-symbol label))
|
|
*global-labels*))
|
|
|
|
(defun global-label-symbol (label) (car (global-label label)))
|
|
(defun global-label-variable (label) (cadr (global-label label)))
|
|
(defun global-label-function (label) (caddr (global-label label)))
|
|
|
|
(defun assembly-label-or-number-p (expr)
|
|
(or (numberp expr)
|
|
(match (label $$ $n) expr)))
|
|
|
|
(defun immutable-assembly-place-p (expr)
|
|
(match (constant (? assembly-label-or-number-p)) expr))
|
|
|
|
(defun mutable-assembly-place-p (expr)
|
|
(cond-match
|
|
expr
|
|
((register (? (member x '(r0 r1 r2 sp bp fp)))) t)
|
|
((constant (? assembly-label-or-number-p)) t)
|
|
((memory (? assembly-label-or-number-p)) t)
|
|
((indexed (? assembly-label-or-number-p)) t)
|
|
((indirect-register (? (member x '(r0 r1 r2 sp bp fp)))) t)
|
|
((indirect-constant (? assembly-label-or-number-p)) t)
|
|
((indirect-indexed $n (? (member x '(r0 r1 r2 sp bp fp)))) t)))
|
|
|
|
(defun assembly-place-p (expr)
|
|
(or (immutable-assembly-place-p expr)
|
|
(mutable-assembly-place-p expr)))
|
|
|
|
(defun assembly-instruction-p (expr)
|
|
(cond-match
|
|
expr
|
|
((mov :src $ap :dst $map) t)
|
|
((push :src $ap) t)
|
|
((pop :dst $map) t)
|
|
((jmp :to $ap) t)
|
|
((add :src $ap :dst $map) t)
|
|
((sub :src $ap :dst $map) t)
|
|
((call :fun $ap) t)))
|
|
|
|
(defun compilo-check (asm)
|
|
(let ((non-empty nil)
|
|
(etiquettes nil)
|
|
(res nil))
|
|
;; TODO : vérification de l'existance des étiquettes
|
|
(labels ((compilo-check-1 (asm)
|
|
(cond-match
|
|
asm
|
|
((section (? $$ (member x *asm-sections*)) :body . @)
|
|
(every #'compilo-check-1 body))
|
|
((label :l $$)
|
|
(push l etiquettes)
|
|
t)
|
|
(_
|
|
(if (assembly-instruction-p asm)
|
|
(progn
|
|
(setq non-empty t)
|
|
t)
|
|
(progn
|
|
(warn "compilo-check : this should not be here : ~a" asm)
|
|
nil))))))
|
|
(setq res (compilo-check-1 asm)))
|
|
(unless non-empty
|
|
(warn "compilo-check : Le code assembleur est vide ! Il n'y a aucune instruction.")
|
|
(setq res nil))
|
|
(unless (match (section (? $$ (member x *asm-sections*)) . @) asm)
|
|
(warn "compilo-check : malformed top-level assembly structure.")
|
|
(setq res nil))
|
|
res))
|
|
|
|
(defun flatten-asm (asm)
|
|
(let ((res (mapcar #'list *asm-sections*))
|
|
(current nil))
|
|
(labels ((flatten-asm-1 (asm)
|
|
(cond-match
|
|
asm
|
|
((section :sec $$ :body)
|
|
(setq current (assoc sec res))
|
|
(unless current
|
|
(error "flatten-asm : invalid section : ~a" sec)))
|
|
((:mnemonique $$ :args $ap*)
|
|
(push asm current)))))
|
|
(flatten-asm-1 asm))
|
|
(apply #'append (mapcar (lambda (x) (cons (list 'section (car x)) (reverse (cdr x)))) res))))
|
|
|
|
|
|
(defun compilo-2 (expr variables)
|
|
"Vérifie si expr est bien un résultat valable de squash-lisp-1.
|
|
Permet aussi d'avoir une «grammaire» du simple-lisp niveau 1.
|
|
Attention : il y a quelques invariants qui ne sont pas présents dans cette vérification."
|
|
(labels ((compilo-3 (expr)
|
|
(cond-match
|
|
expr
|
|
;; simple-tagbody est équivalent à un progn, mais nécessaire pour les macrolet.
|
|
(((? (member x '(progn simple-tagbody))) :body _*)
|
|
`(section code
|
|
,@(mapcar #'compilo-2 body)))
|
|
((if :condition _ :si-vrai _ :si-faux _)
|
|
(and (compilo-2 condition)
|
|
(compilo-2 si-vrai)
|
|
(compilo-2 si-faux)))
|
|
((unwind-protect :body _ :cleanup _)
|
|
(and (compilo-2 body)
|
|
(compilo-2 cleanup)))
|
|
;; tagbody-unwind-catch est équivalent à unwind-catch, mais nécessaire pour les macrolet.
|
|
(((? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body (progn _*) :catch-code _)
|
|
(and (compilo-2 object)
|
|
(compilo-2 body)
|
|
(compilo-2 catch-code)))
|
|
((unwind :object _)
|
|
(compilo-2 object))
|
|
((unwind-for-tagbody :object _ :post-unwind-code _)
|
|
(and (compilo-2 object)
|
|
(compilo-2 post-unwind-code)))
|
|
((jump-label :name $$)
|
|
t)
|
|
((jump :dest $$)
|
|
t)
|
|
((funcall :fun _ :params _*)
|
|
;; calculer les paramètres un à un
|
|
;; à chaque fois, ajouter leur valeur dans une liste, par chirurgie svp.
|
|
;; maintenir quelque part dans la pile un pointeur vers le premier paramètre
|
|
;; et un pointeur vers le dernier cons de la liste de paramètres
|
|
;; calculer la fonction
|
|
;; push ip
|
|
;; jmp r0
|
|
(every #'compilo-2 (cons fun params)))
|
|
((quote _)
|
|
;; récupérer le code de l'ancien compilo
|
|
t)
|
|
((get-var :name $$)
|
|
`(section code (mov (indexed ,(cdr (assoc name variables)) (register bp)) (register r0))))
|
|
((setq :name $$ :value _)
|
|
`(section code
|
|
,(compilo-2 value)
|
|
(mov (register r0) (indexed ,(cdr (assoc name variables)) (register bp)))))
|
|
((fdefinition (quote :name $$))
|
|
`(section code (mov (memory ,(global-label-function name)) (register r0))))
|
|
((symbol-value (quote :name $$))
|
|
`(section code (mov (memory ,(global-label-variable name)) (register r0))))
|
|
((set (quote :name $$) :value _)
|
|
`(section code
|
|
,(compilo-2 value)
|
|
(mov (register r0) (memory ,(global-label-variable name)))))
|
|
((make-captured-var :name $$)
|
|
;; allouer 5 octets du tas
|
|
;; si nécessaire gc
|
|
;; affecter le type captured-var au premier
|
|
;; affecter le pointeur nil aux 4 suivants
|
|
t)
|
|
((get-captured-var :name $$)
|
|
`(section code
|
|
(mov (indexed ,(cdr (assoc name variables)) (register bp)) (register r0))
|
|
(mov (indexed 1 (register r0)) (register r0)))) ;; Pas de test de type
|
|
((set-captured-var :name $$ :value _)
|
|
`(section code
|
|
,(compilo-2 value)
|
|
(mov (indexed ,(cdr (assoc name variables)) (register bp)) (register r1))
|
|
(mov (register r0) (indexed 1 (register r1)))))
|
|
(_
|
|
(warn "compilo-2: Assertion failed ! This should not be here : ~w" expr)
|
|
nil))))
|
|
(compilo-3 expr)))
|
|
|
|
(defun compilo-1 (expr)
|
|
(match
|
|
(top-level :main $$ (progn (set :names $$ (lambda (:closure-names $$ &rest :params-names $$) (get-var $$) (get-var $$) (let :vars ($$*) :bodys _)))*))
|
|
expr
|
|
(loop
|
|
for name in names
|
|
and closure-name in closure-names
|
|
and params-name in params-names
|
|
and var in vars
|
|
and body in bodys
|
|
for nbvars = (length var)
|
|
collect `(section code
|
|
(label name)
|
|
;; +1 pour la closure (non)
|
|
;; +1 pour les paramètres (non)
|
|
;; +1 pour le bp
|
|
;; +1 pour le begin-frame
|
|
;; +1 pour le marker-end-frame
|
|
(mov (constant ,(+ 3 nbvars)) (register r0))
|
|
(push (register ip)) ;; call
|
|
(mov (register sp) (register r0)) ;; begin-frame : Va avec le marker-end-frame
|
|
(push (register bp))
|
|
(mov (register sp) (register bp))
|
|
(add (constant ,nbvars) (register sp))
|
|
(push (register r0)) ;; Permet à unwind de sauter directement jusqu'au begin-frame.
|
|
(push (constant ,(syslabel 'marker-end-frame)))
|
|
(jmp (constant (label ,(syslabel 'reserve-stack)))) ;; lance le gc pour re-dimensionner le tas si nécessaire / ou bien erreur si dépassement.
|
|
(sub (constant ,nbvars) (register sp)) ;; TODO ! vérifier le sens du sub
|
|
,(compilo-2 body (loop
|
|
with hole = (make-symbol "HOLE")
|
|
for v in (append (list closure-name params-name hole hole hole) var)
|
|
for i upfrom -2
|
|
collect `(,var . ,i)))
|
|
(add (constant ,nbvars) (register sp))
|
|
(pop (register bp))
|
|
(pop (register r1)) ;; params
|
|
(pop (register r1)) ;; closure
|
|
(pop (register r1)) ;; ip
|
|
(jmp (register r1))) ;; ret
|
|
into res
|
|
finally (return
|
|
`(section code
|
|
(push ,(syslabel nil)) ;; closure
|
|
(push ,(syslabel nil)) ;; paramètres
|
|
(push (register ip))
|
|
(jmp main)
|
|
(label ,(syslabel 'end-halt))
|
|
(mov (constant 0) (register r0)) ;; valeur de retour : 0 = success
|
|
(halt) ;; TODO : dépendant de vm / os
|
|
,@res)))))
|
|
|
|
(defun compilo (expr)
|
|
(setq *sys-labels* nil)
|
|
(flatten-asm (compilo-1 (squash-lisp-1+3 expr))))
|
|
|
|
#|
|
|
|
|
La pile (en bas = le plus récent) :
|
|
|
|
========== xx
|
|
closure
|
|
params
|
|
old-bp <--------------------- bp here
|
|
begin-frame = addr xx
|
|
marker-end-frame
|
|
[var0]
|
|
[var1]
|
|
[var2]
|
|
[var3]
|
|
...
|
|
[var (- nb-vars 1)] <-------- sp here when body executed (next push will be underneath).
|
|
|
|
(squash-lisp-1+3 '(+ 2 3))
|
|
|
|
# |
|
|
;;; Exemples
|
|
|
|
(my-compile '(1 2 3))
|
|
|
|
(my-compile 3)
|
|
;; section .data
|
|
;; fixnum-constant-1
|
|
;; db 0
|
|
;; db 3
|
|
|
|
(my-compile (+ 2 3))
|
|
;; =>
|
|
;; section .data
|
|
;; fixnum-constant-1:
|
|
;; db 1
|
|
;; db 2
|
|
;; section .data
|
|
;; fixnum-constant-2:
|
|
;; db 1
|
|
;; db 3
|
|
;; section .code
|
|
;; code-1:
|
|
;; load @global-1 r0
|
|
;; push r0
|
|
;; load @global-2 r0
|
|
;; push r0
|
|
;; push 2
|
|
;; jsr @fn-+
|
|
;; retn
|
|
;; section .text
|
|
;; :fn-+
|
|
;; pop r1
|
|
;; pop r0
|
|
;; add r1 r0
|
|
;; retn
|
|
|#
|
|
|
|
(provide 'compilation)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
#|
|
|
(defvar *asm-fixnum-size* 32)
|
|
(defvar *asm-max-fixnum* (expt 2 *asm-fixnum-size*))
|
|
(defun type-number (type)
|
|
(position type '(placeholder fixnum bignum symbol string cons nil)))
|
|
(defvar *label-ctr* 0)
|
|
|
|
(defmacro fasm (&rest stuff)
|
|
`(format nil ,@stuff))
|
|
(defun db-type (type)
|
|
(fasm "db ~a" (type-number type)))
|
|
|
|
;; My-compile
|
|
|
|
(defvar *result-asm* nil)
|
|
(defvar *asm-sections* '(code data)) ;; Note : l'assembleur sera produit dans cet ordre
|
|
|
|
(defun real-asm-block (section label body)
|
|
(when (not (member section *sections*))
|
|
(error "Section assembleur inconnue : ~w" section))
|
|
(push (format nil "section .~w" section) *result-asm*)
|
|
(push (format nil "~a:" label) *result-asm*)
|
|
(mapcar (lambda (x) (push x *result-asm*)) body)
|
|
label)
|
|
|
|
(defun asm-block (section label-base &rest body)
|
|
(real-asm-block
|
|
section
|
|
(format nil "~a-~a" label-base (incf *label-ctr*))
|
|
body))
|
|
|
|
(defvar *asm-once* nil)
|
|
(defun asm-once (section label &rest body)
|
|
(unless (member label asm-once :test #'string-equal)
|
|
(push label asm-once)
|
|
(real-asm-block section label body))
|
|
label)
|
|
|
|
(defmacro my-compile (expr)
|
|
`(progn (setq *result-asm* nil)
|
|
(setq asm-once nil)
|
|
(my-compile-1 `(:main ,(lisp2cli ',expr)))
|
|
(format nil "~&~{~%~a~}" (flatten (reverse *result-asm*)))))
|
|
|
|
;;; Règles de compilation
|
|
|
|
(defmatch my-compile-1)
|
|
|
|
;; fixnum
|
|
(defmatch my-compile-1 (:nil :const :num . (? numberp (< x *asm-max-fixnum*)))
|
|
(asm-block 'data "fixnum-constant"
|
|
(db-type 'fixnum)
|
|
(fasm "db ~a" num)))
|
|
|
|
;; bignum
|
|
(defmatch my-compile-1 (:nil :const :num . (? numberp (>= x *asm-max-fixnum*)))
|
|
(asm-block 'data "bignum-constant"
|
|
(db-type 'bignum)
|
|
(let ((lst (split-bytes num *asm-fixnum-size*)))
|
|
(fasm "~{~&db ~a~}" (cons (length lst) lst)))))
|
|
|
|
;; string
|
|
(defmatch my-compile-1 (:nil :const :str . (? stringp))
|
|
(asm-block 'data "string-constant"
|
|
(db-type 'string)
|
|
(fasm "db ~a" (length str))
|
|
(fasm "~{~&db ~a~}" (map 'list #'char-code str))))
|
|
|
|
;; symbol
|
|
(defmatch my-compile-1 (:nil :const :sym . (? symbolp))
|
|
(asm-once 'data (format nil "symbol-~w" sym)
|
|
(db-type 'symbol)
|
|
(fasm "db @~a" (my-compile-1 (string sym)))))
|
|
|
|
;; cons
|
|
(defmatch my-compile-1 (:nil :const . (:car _ :cdr . _))
|
|
(asm-block 'data "cons-cell-constant"
|
|
(db-type 'cons)
|
|
(fasm "db @~a" (my-compile-1 `(:const . ,car)))
|
|
(fasm "db @~a" (my-compile-1 `(:const . ,cdr)))))
|
|
|
|
(defun compile-get-val (cli)
|
|
(if (match (:nil :const . _) cli)
|
|
(list (fasm "load @~a r0" (my-compile-1 cli))
|
|
(fasm "push r0"))
|
|
(list (my-compile-1 cli)
|
|
(fasm "push r0"))))
|
|
|
|
;; call
|
|
(defmatch my-compile-1 (:nil :call :name _ :params . _)
|
|
(list
|
|
(mapcar #'compile-get-val params)
|
|
(fasm "push ~a" (length params))
|
|
(fasm "jsr function-~a" name)))
|
|
|
|
;; main
|
|
(defmatch my-compile-1 (:nil :main :body _*)
|
|
(asm-once 'code "main"
|
|
(mapcar #'my-compile-1 body)))
|
|
|
|
|
|
;; if
|
|
((if :condition _ :si-vrai _ :si-faux _)
|
|
(let ((else-label (gen-label "else"))
|
|
(end-if-label (gen-label "end-if")))
|
|
(compile condition)
|
|
(fasm "cmp r0 @nil")
|
|
(fasm "jeq @~a" else-label)
|
|
(compile si-vrai)
|
|
(fasm "jmp @~a" end-if-label)
|
|
(fasm "label @~a" else-label)
|
|
(compile si-faux)
|
|
(fasm "label @~a" end-if-label)))
|
|
|
|
|#
|