[movitz-cvs] CVS movitz
ffjeld
ffjeld at common-lisp.net
Mon Feb 4 07:45:09 UTC 2008
Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv14780
Modified Files:
asm.lisp
Log Message:
Added support for sub-program operands.
--- /project/movitz/cvsroot/movitz/asm.lisp 2008/02/03 10:23:05 1.6
+++ /project/movitz/cvsroot/movitz/asm.lisp 2008/02/04 07:45:08 1.7
@@ -6,7 +6,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef at acm.org>
;;;; Distribution: See the accompanying file COPYING.
;;;;
-;;;; $Id: asm.lisp,v 1.6 2008/02/03 10:23:05 ffjeld Exp $
+;;;; $Id: asm.lisp,v 1.7 2008/02/04 07:45:08 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -27,7 +27,8 @@
#:*pc*
#:*symtab*
#:*instruction-compute-extra-prefix-map*
- #:*position-independent-p*))
+ #:*position-independent-p*
+ #:*sub-program-instructions*))
(in-package asm)
@@ -35,16 +36,36 @@
(defvar *symtab* nil "Current symbol table.")
(defvar *instruction-compute-extra-prefix-map* nil)
(defvar *position-independent-p* t)
+(defvar *sub-program-instructions* '(:jmp :ret)
+ "Instruction operators after which to insert sub-programs.")
-(deftype symbol-reference ()
+(deftype simple-symbol-reference ()
'(cons (eql quote) (cons symbol null)))
-(defun symbol-reference-p (expr)
- (typep expr 'symbol-reference))
+(deftype sub-program-operand ()
+ '(cons (eql quote)
+ (cons
+ (cons (eql :sub-program))
+ null)))
+
+(deftype symbol-reference ()
+ '(or simple-symbol-reference sub-program-operand))
+
+(defun sub-program-operand-p (expr)
+ (typep expr 'sub-program-operand))
+
+(defun sub-program-label (operand)
+ (car (cadadr operand)))
+
+(defun sub-program-program (operand)
+ (cddadr operand))
(defun symbol-reference-symbol (expr)
- (check-type expr symbol-reference)
- (second expr))
+ (etypecase expr
+ (simple-symbol-reference
+ (second expr))
+ (sub-program-operand
+ (sub-program-label expr))))
(deftype immediate-operand ()
'(or integer symbol-reference))
@@ -87,72 +108,90 @@
(*pc* start-pc)
(*symtab* corrections)
(assumptions nil)
- (new-corrections nil))
- (values (loop for instruction in proglist
- appending
- (etypecase instruction
- (symbol
- (let ((previous-definition (assoc instruction *symtab*)))
- (cond
- ((null previous-definition)
- (push (cons instruction *pc*)
- *symtab*))
- ((assoc instruction new-corrections)
- (error "prev-def in new-corrections?? new: ~S, old: ~S"
- *pc*
- (cdr (assoc instruction new-corrections))))
- ((member previous-definition assumptions)
- (setf (cdr previous-definition) *pc*)
- (setf assumptions (delete previous-definition assumptions))
- (push previous-definition new-corrections))
- ((member previous-definition corrections)
- (cond
- ((> *pc* (cdr previous-definition))
-;; (warn "correcting ~S from ~D to ~D" instruction (cdr previous-definition) *pc*)
- (setf (cdr previous-definition) *pc*)
- (push previous-definition new-corrections))
- ((< *pc* (cdr previous-definition))
-;; (warn "Definition for ~S shrunk from ~S to ~S (corrections: ~{~D~}."
-;; instruction
-;; (cdr previous-definition)
-;; *pc*
-;; corrections)
-;; (warn "prg: ~{~%~A~}" proglist)
-;; (warn "Definition for ~S shrunk from ~S to ~S."
-;; instruction
-;; (cdr previous-definition)
-;; *pc*)
-;; (break "Definition for ~S shrunk from ~S to ~S."
-;; instruction
-;; (cdr previous-definition)
-;; *pc*)
- (setf (cdr previous-definition) *pc*)
- (push previous-definition new-corrections))))
- (t (error "Label ~S doubly defined. Old value: ~S, new value: ~S"
- instruction
- (cdr previous-definition)
- *pc*))))
- nil)
- (cons
- (let ((code (handler-bind
- ((unresolved-symbol (lambda (c)
- (let ((a (cons (unresolved-symbol c) *pc*)))
-;; (warn "assuming ~S for ~S" (unresolved-symbol c) *pc*)
- (push a assumptions)
- (push a *symtab*)
- (invoke-restart 'retry-symbol-resolve)))))
- (funcall encoder instruction))))
- (incf *pc* (length code))
- code)))
- finally
- (cond
- ((not (null assumptions))
- (error "Undefined symbol~P: ~{~S~^, ~}"
- (length assumptions)
- (mapcar #'car assumptions)))
- ((not (null new-corrections))
- (return (proglist-encode proglist
- :start-pc start-pc
- :cpu-package cpu-package
- :corrections (nconc new-corrections corrections))))))
- *symtab*)))
+ (new-corrections nil)
+ (sub-programs nil))
+ (flet ((process-instruction (instruction)
+ (etypecase instruction
+ (symbol
+ (let ((previous-definition (assoc instruction *symtab*)))
+ (cond
+ ((null previous-definition)
+ (push (cons instruction *pc*)
+ *symtab*))
+ ((assoc instruction new-corrections)
+ (break "prev-def ~S in new-corrections?? new: ~S, old: ~S"
+ instruction
+ *pc*
+ (cdr (assoc instruction new-corrections))))
+ ((member previous-definition assumptions)
+ (setf (cdr previous-definition) *pc*)
+ (setf assumptions (delete previous-definition assumptions))
+ (push previous-definition new-corrections))
+ ((member previous-definition corrections)
+ (cond
+ ((> *pc* (cdr previous-definition))
+ ;; (warn "correcting ~S from ~D to ~D" instruction (cdr previous-definition) *pc*)
+ (setf (cdr previous-definition) *pc*)
+ (push previous-definition new-corrections))
+ ((< *pc* (cdr previous-definition))
+ ;; (warn "Definition for ~S shrunk from ~S to ~S (corrections: ~{~D~}."
+ ;; instruction
+ ;; (cdr previous-definition)
+ ;; *pc*
+ ;; corrections)
+ ;; (warn "prg: ~{~%~A~}" proglist)
+ ;; (warn "Definition for ~S shrunk from ~S to ~S."
+ ;; instruction
+ ;; (cdr previous-definition)
+ ;; *pc*)
+ ;; (break "Definition for ~S shrunk from ~S to ~S."
+ ;; instruction
+ ;; (cdr previous-definition)
+ ;; *pc*)
+ (setf (cdr previous-definition) *pc*)
+ (push previous-definition new-corrections))))
+ (t (error "Label ~S doubly defined. Old value: ~S, new value: ~S"
+ instruction
+ (cdr previous-definition)
+ *pc*))))
+ nil)
+ (cons
+ (let ((code (handler-bind
+ ((unresolved-symbol (lambda (c)
+ (let ((a (cons (unresolved-symbol c) *pc*)))
+ ;; (warn "assuming ~S for ~S" (unresolved-symbol c) *pc*)
+ (push a assumptions)
+ (push a *symtab*)
+ (invoke-restart 'retry-symbol-resolve)))))
+ (funcall encoder instruction))))
+ (incf *pc* (length code))
+ code)))))
+ (values (loop for instruction in proglist
+ for operands = (when (consp instruction)
+ instruction)
+ for operator = (when (consp instruction)
+ (let ((x (pop operands)))
+ (if (not (listp x)) x (pop operands))))
+ append (process-instruction instruction)
+ do (loop for operand in operands
+ do (when (sub-program-operand-p operand)
+ (push (cons (sub-program-label operand)
+ (sub-program-program operand))
+ sub-programs)))
+ when (and (not (null sub-programs))
+ (member operator *sub-program-instructions*))
+ append (loop for sub-program in (nreverse sub-programs)
+ append (mapcan #'process-instruction sub-program)
+ finally (setf sub-programs nil))
+ finally
+ (cond
+ ((not (null assumptions))
+ (error "Undefined symbol~P: ~{~S~^, ~}"
+ (length assumptions)
+ (mapcar #'car assumptions)))
+ ((not (null new-corrections))
+ (return (proglist-encode proglist
+ :start-pc start-pc
+ :cpu-package cpu-package
+ :corrections (nconc new-corrections corrections))))))
+ *symtab*))))
More information about the Movitz-cvs
mailing list