Commit 490010d9 authored by cvs-fast-export's avatar cvs-fast-export
Browse files

Synthetic commit for tag start

parent 91645f3f
This diff is collapsed.
;;;;------------------------------------------------------------------
;;;;
;;;; Copyright (C) 2007 Frode V. Fjeld
;;;;
;;;; Description: Assembly syntax etc.
;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: asm.lisp,v 1.17 2008/03/06 19:18:51 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
(defpackage asm
(:use :common-lisp)
(:export #:symbol-reference-p
#:symbol-reference
#:symbol-reference-symbol
#:immediate-p
#:immediate-operand
#:indirect-operand-p
#:indirect-operand
#:indirect-operand-offset
#:instruction-operands
#:instruction-operator
#:register-operand
#:resolve-operand
#:unresolved-symbol
#:retry-symbol-resolve
#:pc-relative-operand
#:assemble-proglist
#:disassemble-proglist
#:*pc*
#:*symtab*
#:*instruction-compute-extra-prefix-map*
#:*position-independent-p*
#:*sub-program-instructions*))
(in-package asm)
(defvar *pc* nil "Current program counter.")
(defvar *symtab* nil "Current symbol table.")
(defvar *instruction-compute-extra-prefix-map* nil)
(defvar *position-independent-p* t)
(defvar *sub-program-instructions* '(:jmp :ret :iretd)
"Instruction operators after which to insert sub-programs.")
(defvar *anonymous-sub-program-identities* nil)
(defun quotep (x)
"Is x a symbol (in any package) named 'quote'?"
;; This is required because of Movitz package-fiddling.
(and (symbolp x)
(string= x 'quote)))
(deftype simple-symbol-reference ()
'(cons (satisfies quotep) (cons symbol null)))
(deftype sub-program-operand ()
'(cons (satisfies quotep)
(cons
(cons (eql :sub-program))
null)))
(deftype funcall-operand ()
'(cons (satisfies quotep)
(cons
(cons (eql :funcall))
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)
(let ((x (cadadr operand)))
(if (not (eq '() x))
(car x)
(cdr (or (assoc operand *anonymous-sub-program-identities*)
(car (push (cons operand (gensym "sub-program-"))
*anonymous-sub-program-identities*)))))))
(defun sub-program-program (operand)
(cddadr operand))
(defun symbol-reference-symbol (expr)
(etypecase expr
(simple-symbol-reference
(second expr))
(sub-program-operand
(sub-program-label expr))))
(defun funcall-operand-operator (operand)
(cadadr operand))
(defun funcall-operand-operands (operand)
(cddadr operand))
(deftype immediate-operand ()
'(or integer symbol-reference funcall-operand))
(defun immediate-p (expr)
(typep expr 'immediate-operand))
(deftype register-operand ()
'keyword)
(defun register-p (operand)
(typep operand 'register-operand))
(deftype indirect-operand ()
'(and cons (not (cons (satisfies quotep)))))
(defun indirect-operand-p (operand)
(typep operand 'indirect-operand))
(defun indirect-operand-offset (operand)
(check-type operand indirect-operand)
(reduce #'+ operand
:key (lambda (x)
(if (integerp x) x 0))))
(deftype pc-relative-operand ()
'(cons (eql :pc+)))
(defun pc-relative-operand-p (operand)
(typep operand 'pc-relative-operand))
(defun pc-relative-operand-offset (operand)
(check-type operand pc-relative-operand)
(second operand))
(define-condition unresolved-symbol ()
((symbol
:initarg :symbol
:reader unresolved-symbol))
(:report (lambda (c s)
(format s "Unresolved symbol ~S." (unresolved-symbol c)))))
(defun resolve-operand (operand)
(typecase operand
(integer
operand)
(symbol-reference
(let ((s (symbol-reference-symbol operand)))
(loop (with-simple-restart (retry-symbol-resolve "Retry resolving ~S." s)
(return (cdr (or (assoc s *symtab*)
(error 'unresolved-symbol
:symbol s))))))))
(funcall-operand
(apply (funcall-operand-operator operand)
(mapcar #'resolve-operand
(funcall-operand-operands operand))))
(t operand)))
;;;;;;;;;;;;
(defun assemble-proglist (proglist &key ((:symtab incoming-symtab) *symtab*) corrections (start-pc 0) (cpu-package '#:asm-x86))
"Encode a proglist, using instruction-encoder in symbol assemble-instruction from cpu-package."
(let ((encoder (find-symbol (string '#:assemble-instruction) cpu-package))
(*pc* start-pc)
(*symtab* (append incoming-symtab corrections))
(*anonymous-sub-program-identities* *anonymous-sub-program-identities*)
(assumptions nil)
(new-corrections nil)
(sub-programs nil))
(flet ((process-instruction (instruction)
(etypecase instruction
((or symbol integer) ; a label?
(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))
;; (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 ; a bona fide instruction?
(let ((code (funcall encoder instruction)))
(incf *pc* (length code))
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)))))
(let ((code (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)))))
(cond
((not (null assumptions))
(error "Undefined symbol~P: ~{~S~^, ~}"
(length assumptions)
(mapcar #'car assumptions)))
((not (null new-corrections))
(assemble-proglist proglist
:symtab incoming-symtab
:start-pc start-pc
:cpu-package cpu-package
:corrections (nconc new-corrections corrections)))
(t (values code *symtab*))))))))
(defun instruction-operator (instruction)
(if (listp (car instruction)) ; skip any instruction prefixes etc.
(cadr instruction)
(car instruction)))
(defun instruction-operands (instruction)
(if (listp (car instruction)) ; skip any instruction prefixes etc.
(cddr instruction)
(cdr instruction)))
(defun instruction-modifiers (instruction)
(if (listp (car instruction))
(car instruction)
nil))
(defun disassemble-proglist (code &key (cpu-package '#:asm-x86) (pc (or *pc* 0)) (symtab *symtab*) collect-data collect-labels)
"Return a proglist (i.e. a list of instructions), or a list of (cons instruction data) if collect-data is true,
data being the octets corresponding to that instruction. Labels will be included in the proglist if collect-labels is true.
Secondarily, return the symtab."
(let* ((instruction-disassembler (find-symbol (string '#:disassemble-instruction)
cpu-package))
(proglist0 (loop while code
collect pc
collect (multiple-value-bind (instruction new-code)
(funcall instruction-disassembler
code)
(when (eq code new-code)
(loop-finish))
(let* ((data (loop until (eq code new-code)
do (incf pc)
collect (pop code)))
(operands (instruction-operands instruction)))
(cons data
(if (notany #'pc-relative-operand-p operands)
instruction
(nconc (loop until (eq instruction operands)
collect (pop instruction))
(loop for operand in operands
collect (if (not (pc-relative-operand-p operand))
operand
(let* ((location (+ pc (pc-relative-operand-offset operand)))
(entry (or (rassoc location symtab)
(car (push (cons (gensym) location)
symtab)))))
`(quote ,(car entry)))))))))))))
(values (loop for (pc data-instruction) on proglist0 by #'cddr
for instruction = (cdr data-instruction)
for label = (when collect-labels
(rassoc pc symtab))
when label
collect (if (not collect-data)
(car label)
(cons nil (car label)))
collect (if (not collect-data)
instruction
data-instruction))
symtab)))
(defun disassemble-proglist* (code &key (cpu-package '#:asm-x86) (pc 0))
"Print a human-readable disassembly of code."
(multiple-value-bind (proglist symtab)
(disassemble-proglist code
:cpu-package cpu-package
:collect-data t)
(format t "~&~:{~4X: ~20<~{ ~2,'0X~}~;~> ~A~%~}"
(loop with pc = pc
for (data . instruction) in proglist
when (let ((x (find pc symtab :key #'cdr)))
(when x (list pc (list (format nil " ~A" (car x))) "")))
collect it
collect (list pc data instruction)
do (incf pc (length data))))))
;;;;------------------------------------------------------------------
;;;;
;;;; Copyright (C) 20012000, 2004,
;;;; Department of Computer Science, University of Tromso, Norway
;;;; Department of Computer Science, University of Troms, Norway
;;;;
;;;; Filename: assembly-syntax.lisp
;;;; Description:
......@@ -9,7 +9,7 @@
;;;; Created at: Thu Nov 9 17:34:37 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: assembly-syntax.lisp,v 1.3 2004/04/21 15:05:39 ffjeld Exp $
;;;; $Id: assembly-syntax.lisp,v 1.3 2004/01/08 19:50:38 frodef Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -25,19 +25,29 @@
(setf (gethash symbol (assembly-macro-environment-expanders amenv))
expander))
;;;(defun assembly-macroexpand (prg amenv)
;;; (cond
;;; ((and (consp prg) (symbolp (car prg)))
;;; (let ((expander (assembly-macro-expander (car prg) amenv)))
;;; (if expander
;;; (assembly-macroexpand (funcall expander prg) amenv)
;;; #0=(cons (assembly-macroexpand (car prg) amenv)
;;; (assembly-macroexpand (cdr prg) amenv)))))
;;; ((consp prg) #0#)
;;; (t prg)))
(defun assembly-macroexpand (prg amenv)
#+cmu (declare (optimize (safety 0))) ; Circumvent CMUCL bug in loop for-as-on-list.
(loop for (p . tail) on prg
(loop for p in prg
as expander = (and (consp p)
(symbolp (car p))
(assembly-macro-expander (car p) amenv))
if expander
append (funcall expander p) into result
append (funcall expander p)
else if (consp p)
append (list (assembly-macroexpand p amenv)) into result
else append (list p) into result
when (not (listp tail))
do (setf (cdr (last result)) tail)
(return result)
finally (return result)))
append (list (assembly-macroexpand p amenv))
else append (list p)))
;;;(defmacro with-assembly-syntax (&body body)
;;; `(let ((*readtable* (copy-readtable nil)))
;;; (set-dispatch-macro-character
######################################################################
##
## Copyright (C) 2003-2004,
## Department of Computer Science, University of Tromso, Norway.
##
## For distribution policy, see the accompanying file COPYING.
##
## Filename: bochsrc.txt
## Description: Bochs configuration file for frodef's Movitz setup.
## You can use this as a template, but you'll need to
## change the file paths etc.
## Author: Frode Vatvedt Fjeld <frodef@acm.org>
## Created at: Wed Jul 21 13:41:59 2004
##
######################################################################
###############################################################
# bochsrc.txt file for DLX Linux disk image.
###############################################################
# how much memory the emulated machine will have
megs: 64
megs: 32
# filename of ROM images
#romimage: file=/usr/local/bochs/1.2.1/BIOS-bochs-latest, address=0xf0000
......@@ -23,9 +11,6 @@ megs: 64
romimage: file=../../tmp/bochs-cvs/bios/BIOS-bochs-latest, address=0xf0000
vgaromimage: ../../tmp/bochs-cvs/bios/VGABIOS-elpin-2.40
# This is just to make X11 clipboard pasting into bochs work.
keyboard_mapping: enabled=1, map=../../tmp/bochs-cvs/gui/keymaps/x11-pc-us.map
# what disk images will be used
floppya: 1_44=los0-image, status=inserted
#floppya: 1_44=grub, status=inserted
......@@ -33,7 +18,6 @@ floppya: 1_44=los0-image, status=inserted
#diskc: file=hd10meg.img, cyl=306, heads=4, spt=17
#newharddrivesupport: enabled=1
# choose the boot disk.
boot: a
......@@ -45,11 +29,12 @@ vga_update_interval: 100000
# disable the mouse, since DLX is text only
mouse: enabled=0
ne2k: ioaddr=0x300, irq=3, mac=00:40:05:18:66:d9, ethmod=fbsd, ethdev=nge0
ne2k: ioaddr=0x280, irq=9, mac=00:40:05:18:66:d8, ethmod=fbsd, ethdev=xl0
ne2k: ioaddr=0x300, irq=3, mac=00:40:05:18:66:d9, ethmod=fbsd, ethdev=xl0
# panic: action=report
error: action=report
# debug: action=report
ips: 2000000
ips: 3000000
# com1: dev=/dev/ptypv
1882
\ No newline at end of file
This diff is collapsed.
;;;;------------------------------------------------------------------
;;;;
;;;; Copyright (C) 2001-2002, 2004,
;;;; Department of Computer Science, University of Tromso, Norway.
;;;; Department of Computer Science, University of Troms, Norway.
;;;;
;;;; For distribution policy, see the accompanying file COPYING.
;;;;
;;;; Filename: browser.lisp
;;;; Description: A CLIM browser/inspector of Movitz images.
;;;; Description:
;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Created at: Thu Jun 14 15:14:35 2001
;;;;
;;;; $Id: browser.lisp,v 1.1.1.1 2004/01/13 11:04:59 ffjeld Exp $
;;;; $Id: browser.lisp,v 1.22 2004/01/09 12:31:23 frodef Exp $
;;;;
;;;;------------------------------------------------------------------
......
;;;;------------------------------------------------------------------
;;;;
;;;; Copyright (C) 2001-2005,
;;;; Department of Computer Science, University of Tromso, Norway.
;;;; Copyright (C) 2001-2004,
;;;; Department of Computer Science, University of Troms, Norway.
;;;;
;;;; For distribution policy, see the accompanying file COPYING.
;;;;
......@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Created at: Wed Oct 10 13:02:03 2001
;;;;
;;;; $Id: compiler-protocol.lisp,v 1.4 2005/08/20 20:30:03 ffjeld Exp $
;;;; $Id: compiler-protocol.lisp,v 1.30 2004/01/08 19:50:38 frodef Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -30,9 +30,7 @@
:boolean-zf=0
:boolean-cf=1
:boolean-cf=0
:boolean-ecx
:boolean-overflow
:boolean-no-overflow))
:boolean-ecx))
(defconstant +multiple-value-result-modes+
'(:multiple-values
......@@ -126,20 +124,20 @@ COMPILER-VALUES."
,@(unless type-p (list type))
,@(unless final-form-p (list final-form))))
,@body)
`(multiple-value-bind (,code ,returns ,functional-p ,producer ,modifies ,type ,final-form)
,form
(declare (ignorable ,@(unless code-p (list code))
,@(unless returns-p (list returns))
,@(unless functional-p-p (list functional-p))
,@(unless producer-p (list producer))
,@(unless modifies-p (list modifies))
,@(unless type-p (list type))
,@(unless final-form-p (list final-form))))
(macrolet ((,all (x)
(ecase x
(:code ',code) (:returns ',returns) (:functional-p ',functional-p)
(:producer ',producer) (:modifies ',modifies) (:type ',type)
(:final-form ',final-form))))
`(macrolet ((,all (x)
(ecase x
(:code ',code) (:returns ',returns) (:functional-p ',functional-p)
(:producer ',producer) (:modifies ',modifies) (:type ',type)
(:final-form ',final-form))))
(multiple-value-bind (,code ,returns ,functional-p ,producer ,modifies ,type ,final-form)
,form
(declare (ignorable ,@(unless code-p (list code))
,@(unless returns-p (list returns))
,@(unless functional-p-p (list functional-p))
,@(unless producer-p (list producer))
,@(unless modifies-p (list modifies))
,@(unless type-p (list type))
,@(unless final-form-p (list final-form))))
,@body))))
(defmacro compiler-values-list (&rest compiler-values-spec)
......@@ -161,29 +159,26 @@ COMPILER-VALUES."
((&funobj funobj-var) (copy-symbol 'funobj) funobj-p)
((&env env-var) (copy-symbol 'env) env-p)
((&top-level-p top-level-p-var) (copy-symbol 'top-level-p) top-level-p-p)
((&result-mode result-mode-var) (copy-symbol 'result-mode) result-mode-p)
((&extent extent-var) (copy-symbol 'extent) extent-p))
((&result-mode result-mode-var) (copy-symbol 'result-mode) result-mode-p))
&body defun-body)
(multiple-value-bind (body docstring)
(if (and (cdr defun-body)
(stringp (car defun-body)))
(values (cdr defun-body) (list (car defun-body)))
(values defun-body nil))
`(defun ,name (,form-var ,funobj-var ,env-var ,top-level-p-var ,result-mode-var ,extent-var)
`(defun ,name (,form-var ,funobj-var ,env-var ,top-level-p-var ,result-mode-var)
,@docstring
(declare (,(if all-p 'ignorable 'ignore)
,@(unless form-p (list form-var))
,@(unless funobj-p (list funobj-var))
,@(unless env-p (list env-var))
,@(unless top-level-p-p (list top-level-p-var))
,@(unless result-mode-p (list result-mode-var))
,@(unless extent-p (list extent-var))))
,@(unless result-mode-p (list result-mode-var))))
(macrolet ((default-compiler-values-producer () '',name)
,@(when all-p
`((,all-var (v) (ecase v (:form ',form-var) (:funobj ',funobj-var)
(:env ',env-var) (:top-level-p ',top-level-p-var)
(:result-mode ',result-mode-var)
(:extent ',extent-var))))))
(:result-mode ',result-mode-var))))))
,@body))))
(defmacro compiler-call (compiler-name &rest all-keys
......@@ -191,7 +186,6 @@ COMPILER-VALUES."
((:form form-var) nil form-p)
((:funobj funobj-var) nil funobj-p)
((:env env-var) nil env-p)
((:extent extent-var) nil extent-p)
((:top-level-p top-level-p-var) nil top-level-p-p)
((:result-mode result-mode-var) :ignore result-mode-p))
(assert (not (and defaults forward)) ()
......@@ -214,8 +208,7 @@ COMPILER-VALUES."
,(if funobj-p funobj-var `(,defaults :funobj))
inner-env
,(when top-level-p-p top-level-p-var) ; default to nil, no forwarding.
,(if result-mode-p result-mode-var `(,defaults :result-mode))
,(if extent-p extent-var `(,defaults :extent)))))
,(if result-mode-p result-mode-var `(,defaults :result-mode)))))
(forward
`(let* ((outer-env ,(if env-p env-var `(,forward :env)))
(inner-env ,(if (not with-stack-used)
......@@ -229,17 +222,15 @@ COMPILER-VALUES."
,(if funobj-p funobj-var `(,forward :funobj))
inner-env
,(if top-level-p-p top-level-p-var `(,forward :top-level-p))
,(if result-mode-p result-mode-var `(,forward :result-mode))
,(if extent-p extent-var `(,forward :extent)))))
,(if result-mode-p result-mode-var `(,forward :result-mode)))))
((not with-stack-used)
`(funcall ,compiler-name ,form-var ,funobj-var ,env-var
,top-level-p-var ,result-mode-var ,extent-var))
`(funcall ,compiler-name ,form-var ,funobj-var ,env-var ,top-level-p-var ,result-mode-var))
(t (assert env-p () ":env is required when with-stack-used is given.")
`(funcall ,compiler-name ,form-var ,funobj-var
(make-instance 'with-things-on-stack-env
:uplink ,env-var :stack-used ,with-stack-used
:funobj (movitz-environment-funobj ,env-var))
,top-level-p-var ,result-mode-var ,extent-var))))
,top-level-p-var ,result-mode-var))))
(defmacro define-special-operator (name formals &body body)
(let* ((movitz-name (intern (symbol-name (translate-program name :cl :muerte.cl))
......
This diff is collapsed.
This diff is collapsed.
2004-01-12 Frode Vatvedt Fjeld <frodef@cs.uit.no>
* Fixed the floppy bootloader so that it will work with BIOSes
whose int13 messes with the GS segment register, like apparently
the Compaq and some others do.
2004-01-09 Frode Vatvedt Fjeld <frodef@cs.uit.no>
* A disclaimer has been added to the file COPYING.
2004-01-06 Frode Vatvedt Fjeld <frodef@cs.uit.no>
* Rewrote the floppy bootloader so that it is now only limited by
the size of floppies rather than the previous about 600 KB
real-mode buffer limit. For some time I've been forced to remove
some features from los0.img in order to squeeze it into 600 KB,
but no more. Bloat is bliss. However, booting with GRUB is always
an option, and probably the best one in the long run, and
certainly for stable installations (should there ever be