Common Lisp 入門 の番外編です。前回はＣ言語の標準ライブラリ関数 malloc と free を参考にして、簡単なメモリ管理プログラムを Common Lisp で作りました。今回は COMET2A でプログラムを作りましょう。
最初に、ヒープ領域を初期化するサブルーチン initialize-heap を作ります。次のリストを見てください。
リスト : ヒープ領域の初期化
; 初期化
initialize-heap
(lad gr1 heap-top)
(xor gr0 gr0)
(st gr0 0 gr1) ; null で終端
(lad gr0 #xe000) ; heap-top から #xe000 までがヒープ
(subl gr0 gr1)
(srl gr0 1) ; word -> unit
(st gr0 1 gr1) ; unit をセット
(ret)
;;;
;;; ヒープ領域
;;;
(align 2) ; 偶数番地に割り当てる
heap-head
(dc heap-top 0) ; header のみ
heap-top
;;; これ以降にプログラムを書いてはいけない
;;; heap-top
;;; : ヒープ領域
;;; #xe000
;;; : スタック領域 (8 k word)
;;; #xffff
メモリ管理ルーチンはライブラリ lib.cas に追加します。ヒープの本体は lib.cas の最後に定義します。ライブラリを一番最後にリンクすると、ヒープ領域の先頭アドレス heap-top がプログラムの一番最後になります。このアドレスから #xe000 - 1 番地までをヒープ領域に設定します。スタック領域は #xe0000 番地から #xffff 番地までとなります。
heap-head にダミーヘッダをセットします。1 word 目にヒープ領域の本体である heap-top を、2 word 目には 0 をセットします。あとは initialize-heap で heap-top の 1 word 目を null で初期化し、2 word 目に unit 数をセットします。
ヒープ領域は 2 word を 1 unit として管理します。今後のことを考えて、ヒープ領域は偶数番地から割り当てることにしましょう。このため、アセンブラに align 擬似命令を追加します。
(align num) ; num (2 - 16)
align 擬似命令は、次の命令やデータが num の倍数のアドレスに置かれるように調整します。たとえば、(align 2) と指定すると、次に配置される命令やラベルのアドレスは偶数になり、dc や ds で指定されるデータも偶数アドレスから配置されます。
関数 assemble に align 擬似命令の処理を追加します。次のリストを見てください。
リスト : align 擬似命令
(defun assemble (ls &optional (start 0))
(do ((ls ls (cdr ls))
(wp start)
(label nil)
(code nil))
((null ls) (sublis label (nreverse code)))
(cond ((symbolp (car ls))
(push (cons (car ls) wp) label))
((consp (car ls))
(case (caar ls)
((align)
(let ((n (mod wp (get-align-number (car ls)))))
(when (plusp n)
(push (list 'ds n) code)
(incf wp n))))
・・・省略・・・
align の処理は簡単です。次の命令は wp 番地に書き込まれます。align で指定された数値を関数 get-align-number で取り出し、mod で wp の剰余 n を求めます。0 であれば条件を満たしているので、何もする必要はありません。n が正の値であれば、(ds n) を追加して、wp の値を num の倍数にそろえます。
次はヒープからメモリを取得するサブルーチン malloc を作ります。
リスト : メモリの取得
; メモリの取得 (first-fit 法)
; 入力 +2) : サイズ (word)
; 出力 gr0 : アドレス
malloc
(link gr7 0)
(push 0 gr2)
(push 0 gr3)
(ld gr1 2 gr7) ; size を取得
(lad gr1 1 gr1)
(srl gr1 1) ; (size + 1) / 2 => unit
(lad gr1 1 gr1) ; header 分を加算
(lad gr2 heap-head) ; q (一つ前のブロック)
(ld gr3 heap-head) ; p (調べるブロック)
malloc-loop
(jze malloc-error) ; 空きメモリがない
(cpl gr1 1 gr3)
(jze malloc-lab1) ; 大きさが等しい
(jmi malloc-lab2) ; ブロックを分割する
; 次のブロックを探す
(ld gr2 gr3) ; p -> q
(ld gr3 0 gr3) ; p の次のブロック -> p
(jump malloc-loop)
malloc-lab1
; リンクをはずすだけ
(ld gr0 0 gr3) ; p の次のブロック -> gr0
(st gr0 0 gr2) ; q を書き換える
(xor gr0 gr0)
(st gr0 0 gr3) ; リンクを null でクリア
(lad gr0 2 gr3) ; アドレス p + 2 を返す
(jump malloc-exit)
malloc-lab2
; ブロックの後半を割り当てる
(ld gr0 1 gr3)
(subl gr0 gr1) ; 残りの units を計算 -> gr0
(st gr0 1 gr3) ; gr0 -> (gr3 + 1)
(sll gr0 1) ; units -> word
(addl gr3 gr0) ; 切り出すブロックの先頭アドレス
(xor gr0 gr0)
(st gr0 0 gr3) ; リンクを null でクリア
(st gr1 1 gr3) ; units をセット
(lad gr0 2 gr3) ; アドレス p + 2 を返す
malloc-exit
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
malloc-error
(xor gr0 gr0) ; null を返す
(jump malloc-exit)
Common Lisp 版とほとんど同じなので、難しいところはないと思います。コメントをみながらリストを読んでみてください。
次はメモリを解放するサブルーチン free を作ります。
リスト : メモリの解放
; メモリの統合
; 入力 +2) : block p
; +3) : block q
; 出力 None
append-block
(link gr7 0)
(push 0 gr2)
(ld gr1 2 gr7) ; gr1 is p
(ld gr2 3 gr7) ; gr2 is q
(ld gr0 1 gr1) ; punits
(sll gr0 1) ; word へ変換
(addl gr0 gr1)
(cpl gr0 gr2) ; 等しい場合は統合する
(jnz append-block-lab1)
(ld gr0 1 gr1) ; p の units
(addl gr0 1 gr2) ; q の units を加算
(st gr0 1 gr1)
(ld gr0 0 gr2) ; q の next block
(st gr0 0 gr1) ; p にセット
append-block-exit
(pop gr2)
(unlk gr7)
(ret)
append-block-lab1
; リンクするだけ
(st gr2 0 gr1)
(jump append-block-exit)
; メモリの解放
; 入力 +2) : アドレス
; 出力 None
free
(link gr7 0)
(push 0 gr2)
(push 0 gr3)
(push 0 gr4)
(ld gr4 2 gr7) ; 解放するメモリのアドレス
(jze free-exit) ; null check
(lad gr4 -2 gr4)
(lad gr2 heap-head) ; q (一つ前のブロック)
(ld gr3 heap-head) ; p (調査中のブロック)
free-loop
(jze free-lab1) ; 末尾に追加
(cpl gr4 gr3) ; gr4 < gr3 を探す
(jmi free-lab2)
; 次のセルへ
(ld gr2 gr3)
(ld gr3 0 gr3)
(jump free-loop)
free-lab2
(lad sp -2 sp)
(st gr4 0 sp) ; 解放するブロックと
(st gr3 1 sp) ; 後ろのブロック p を
(call append-block) ; 統合する
(lad sp 2 sp)
free-lab1
(lad sp -2 sp)
(st gr2 0 sp) ; 前のブロック q と
(st gr4 1 sp) ; 解放するブロックを
(call append-block) ; 統合する
(lad sp 2 sp)
free-exit
(pop gr4)
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
free と append-block も Common Lisp 版のプログラムとほとんど同じです。難しいところはないと思うので説明は割愛いたします。リストをお読みくださいませ。
それでは実際に実行してみましょう。Common Lisp 版と同様のテストプログラムを作成しました。
リスト : 簡単なテスト
test-malloc
(call initialize-heap)
(call print-free-block)
(call newline)
(xor gr5 gr5)
test-malloc-loop
(cpl gr5 len)
(jze test-malloc-exit)
(call random)
(ld gr2 gr0)
(ld gr3 gr0)
(and gr2 mask)
(lad gr2 1 gr2) ; 大きさ (1 - 1024)
(srl gr3 10) ; 位置 (0 - 63)
;
(lad sp -1 sp)
(ld gr0 buff gr3)
(jze test-malloc-lab1)
(st gr0 0 sp)
(call free) ; メモリの解放
test-malloc-lab1
(st gr2 0 sp)
(call malloc) ; メモリを取得
(st gr0 buff gr3) ; メモリをセット
(lad sp 1 sp)
(lad gr5 1 gr5)
(jump test-malloc-loop)
test-malloc-exit
(call print-free-block)
(call newline)
;
(xor gr5 gr5)
test-malloc-loop2
(cpl gr5 buff-size)
(jze test-malloc-exit1)
(ld gr0 buff gr5)
(jze test-malloc-lab2)
(lad sp -1 sp)
(st gr0 0 sp)
(call free)
(lad sp 1 sp)
test-malloc-lab2
(lad gr5 1 gr5)
(jump test-malloc-loop2)
test-malloc-exit1
(call print-free-block)
(call newline)
(halt)
len (dc 10000)
buff-size
(dc 64)
buff (ds 64)
mask (dc #x3ff)
; 簡単な 16 bit 線形合同法
; Xn+1 = 13 * Xn + 12345
random
(lad gr1 13)
(ld gr0 random-seed)
(mull gr0 gr1) ; -> gr0 (low), gr1(high)
(addl gr0 random-constant)
(st gr0 random-seed)
(ret)
random-constant
(dc 12345)
random-seed
(dc 1)
; フリーブロックの表示
print-free-block
(push 0 gr2)
(ld gr2 heap-head)
print-free-block-loop
(jze print-free-block-exit)
(lad sp -2 sp)
(st gr2 0 sp)
(lad gr0 16)
(st gr0 1 sp)
(call printu)
(lad gr0 32)
(st gr0 0 sp)
(call write-char)
(ld gr0 1 gr2)
(st gr0 0 sp)
(call print)
(call newline)
(lad sp 2 sp)
(ld gr2 0 gr2)
(jump print-free-block-loop)
print-free-block-exit
(pop gr2)
(ret)
print-free-block はフリーブロックを表示するサブルーチンです。random は乱数を線形合同法で発生させるサブルーチンです。16 bit の線形合同法なので、乱数の質はあまりよくありません。また、乱数の種 (seed) は書き換えていないので、実行するたびに同じ乱数列が発生します。seed の値を書き換えて再実行するか、SVC 命令に乱数の seed を取得する命令を追加する、もしくは乱数を取得する命令を追加するとよいでしょう。
実行結果は次のようになりました。
* (asm-run "malloc.cas") 244 28382 244 2 360 13 514 2 714 88 82C 34 93A 23 D86 152 1274 13 149C 185 16AC 112 1BD4 61 22CC 38 2460 96 267C 5 2928 6 2BBA 54 3376 171 405E 133 445C 67 482E 58 52E0 155 5708 23 5B02 313 62D8 171 688E 12 736E 8 79A0 101 82FE 26 870A 156 8BB0 337 9232 5218 C4FE 418 CB16 2677 244 28382 NIL
フリーリストの前のほうに小さなブロックが集まる傾向がみられるのは Common Lisp 版のプログラムと同じです。メモリの取得と解放は正しく動作しているようです。
今回はここまでです。次回は malloc と free を使った簡単なサンプルプログラムを作ってみましょう。
;
; COMET2A.l : 仮想計算機 COMET2A 簡易シミュレータ
; (COMET2A は COMET2 の独自拡張)
;
; 1. GR0, SP をインデックスレジスタとして使用できる
; 2. link, unlk 命令の追加
; 3. mula, mull, diva, divl 命令の追加
; 4. アセンブラに align 擬似命令を追加 (2011/01/23)
;
; 修正 2011/01/22
; LINK 命令 : (logand #xffff ...) を計算していなかったため
; 局所変数の確保に失敗していた
;
; Copyright (C) 2011 Makoto Hiroi
;
;;;
;;; アセンブラ
;;;
;;; コード表
(defvar *op-table0*
'((nop . #x0000) ; NOP
(ret . #x8100) ; RET
(halt . #xf100) ; HALT (終了命令を追加)
))
(defvar *op-table1*
'((pop . #x7100) ; POP r
(unlk . #x8300) ; UNLK r
))
(defvar *op-table2*
'((ld . #x1400) ; LD r1,r2
(adda . #x2400) ; ADDA r1,r2
(suba . #x2500) ; SUBA r1,r2
(addl . #x2600) ; ADDL r1,r2
(subl . #x2700) ; SUBL r1,r2
(mula . #x2800) ; MULA r1,r2
(mull . #x2900) ; MULL r1,r2
(diva . #x2A00) ; DIVA r1,r2
(divl . #x2B00) ; DIVL r1,r2
(and . #x3400) ; AND r1,r2
(or . #x3500) ; OR r1,r2
(xor . #x3600) ; XOR r1,r2
(cpa . #x4400) ; CPA r1,r2
(cpl . #x4500) ; CPL r1,r2
))
(defvar *op-table21*
'((jmi . #x6100) ; JMI adr,r2
(jnz . #x6200) ; JNZ adr,r2
(jze . #x6300) ; JZE adr,r2
(jump . #x6400) ; JUMP adr,r2
(jpl . #x6500) ; JPL adr,r2
(jov . #x6600) ; JOV adr,r2
(push . #x7000) ; PUSH adr,r2
(call . #x8000) ; CALL adr,r2
(svc . #xf000) ; SVC adr,r2
))
(defvar *op-table3*
'((ld . #x1000) ; LD r1,adr,r2
(st . #x1100) ; ST r1,adr,r2
(lad . #x1200) ; LAD r1,adr,r2
(adda . #x2000) ; ADDA r1,adr,r2
(suba . #x2100) ; SUBA r1,adr,r2
(addl . #x2200) ; ADDL r1,adr,r2
(subl . #x2300) ; SUBL r1,adr,r2
(and . #x3000) ; AND r1,adr,r2
(or . #x3100) ; OR r1,adr,r2
(xor . #x3200) ; XOR r1,adr,r2
(cpa . #x4000) ; CPA r1,adr,r2
(cpl . #x4100) ; CPL r1,adr,r2
(sla . #x5000) ; SLA r1,adr,r2
(sra . #x5100) ; SRA r1,adr,r2
(sll . #x5200) ; SLL r1,adr,r2
(srl . #x5300) ; SRL r1,adr,r2
(link . #x8200) ; LINK r1,adr,r2
))
; アセンブルエラー
(defun asm-error (code)
(error "assemble error: ~S~%" code))
; 汎用レジスタの番号を取得
(defun get-gr-number (gr)
(position gr '(gr0 gr1 gr2 gr3 gr4 gr5 gr6 gr7 sp)))
; main op を求める
(defun get-main-opcode (ls table)
(let ((op (assoc (car ls) table)))
(if op
(cdr op)
(asm-error ls))))
; 1st op の生成
(defun make-op1 (op r1 r2)
(+ op (ash r1 4) r2))
; code の生成
; ls = (op r1 adr r2)
(defun make-opcode (ls)
(case (length (cdr ls))
((0) ; (op)
(values (make-op1 (get-main-opcode ls *op-table0*) #x0f #x0f) nil))
((1) ; (op r1), (op adr)
(let ((r1 (get-gr-number (second ls))))
(if r1
(values (make-op1 (get-main-opcode ls *op-table1*) r1 #x0f)
nil)
(values (make-op1 (get-main-opcode ls *op-table21*) #x0f #x0f)
(second ls)))))
((2)
(let ((r1 (get-gr-number (second ls)))
(r2 (get-gr-number (third ls))))
(if r1
(if r2
; (op r1 r2)
(values (make-op1 (get-main-opcode ls *op-table2*) r1 r2)
nil)
; (op r1 adr)
(values (make-op1 (get-main-opcode ls *op-table3*) r1 #x0f)
(third ls)))
; (op adr r2)
(progn
(unless r2
(asm-error ls))
(values (make-op1 (get-main-opcode ls *op-table21*) #x0f r2)
(second ls))))))
((3) ; (op r1 adr r2)
(let ((r1 (get-gr-number (second ls)))
(r2 (get-gr-number (fourth ls))))
(unless (and r1 r2)
(asm-error ls))
(values (make-op1 (get-main-opcode ls *op-table3*) r1 r2)
(third ls))))
(t (asm-error ls))))
; 文字、文字列を数値に変換
(defun to-number (ls)
(apply #'append
(mapcar #'(lambda (x)
(cond ((stringp x)
(mapcar #'char-code (coerce x 'list)))
((characterp x)
(list (char-code x)))
(t (list x))))
ls)))
; ds の大きさを取得
(defun get-ds-size (ls)
(let ((size (second ls)))
(if (and (integerp size)
(<= 0 size #xffff))
size
(asm-error ls))))
; align の指定を取得
(defun get-align-number (ls)
(let ((n (second ls)))
(if (and (integerp n) (<= 1 n 16))
n
(asm-error ls))))
; アセンブラ
(defun assemble (ls &optional (start 0))
(do ((ls ls (cdr ls))
(wp start)
(label nil)
(code nil))
((null ls) (sublis label (nreverse code)))
(cond ((symbolp (car ls))
(push (cons (car ls) wp) label))
((consp (car ls))
(case (caar ls)
((align)
(let ((n (mod wp (get-align-number (car ls)))))
(when (plusp n)
(push (list 'ds n) code)
(incf wp n))))
((ds)
(let ((size (get-ds-size (car ls))))
(push (car ls) code)
(incf wp size)))
((dc)
(let ((xs (to-number (car ls))))
(push xs code)
(incf wp (length (cdr xs)))))
(t
(multiple-value-bind (op1 op2)
(make-opcode (car ls))
(push op1 code)
(incf wp)
(when op2
(push op2 code)
(incf wp))))))
(t (asm-error (car ls))))))
; プログラムファイルの読み込み
(defun read-casl2-file (filename)
(with-open-file (in filename :direction :input)
(let ((data nil) (a nil))
(loop
(setf data (read in nil))
(unless data
(return (nreverse a)))
(push data a)))))
;;;
;;; 仮想マシン
;;;
; レジスタの定義
(defvar *gr* (make-array 9
:element-type '(unsigned-byte 16)
:initial-element 0))
(defvar *pr* 0)
(defvar *fr* 0)
(defvar *sp* 8) ; スタックポインタの番号
; メモリの定義
(defvar *memory* (make-array 65536
:element-type '(unsigned-byte 16)
:initial-element 0))
; レジスタの操作
(defun get-gr (reg) (aref *gr* reg))
(defun set-gr (reg value)
(setf (aref *gr* reg) value))
; スタックポインタの操作
(defun push-stack (val)
(decf (aref *gr* *sp*))
(setf (aref *memory* (aref *gr* *sp*)) val))
(defun pop-stack ()
(prog1
(aref *memory* (aref *gr* *sp*))
(incf (aref *gr* *sp*))))
; レジスタの表示
(defun display-register ()
(format t "PR=~4,'0X " *pr*)
(format t "SP=~4,'0X " (get-gr *sp*))
(format t "FR(OF,SF,ZF)=~3,'0B~%" *fr*)
(dotimes (n 8 (terpri))
(format t "GR~D=~4,'0X " n (aref *gr* n))))
; メモリの表示
(defun dump (s n)
(dotimes (x n (terpri))
(if (zerop (mod x 8)) (format t "~%~4,'0X: " (+ s x)))
(format t "~4,'0X " (aref *memory* (+ s x)))))
; 整数の型変換
(defun to-signed (n)
(if (zerop (logand #x8000 n))
n
(- n #x10000)))
(defun to-unsigned (n) (logand n #xffff))
; メモリの操作
(defun read-memory (adr) (aref *memory* adr))
(defun write-memory (adr value)
(setf (aref *memory* adr) value))
(defun fetch ()
(prog1
(aref *memory* *pr*)
(incf *pr*)))
(defun fetch2 (reg)
(logand (+ (fetch) (if (<= 0 reg *sp*) (get-gr reg) 0))
#xffff))
; 追加 2011/01/23
(defun fetch3 (reg)
(logand (+ (fetch)
(get-gr *sp*)
(if (<= 0 reg *sp*) (get-gr reg) 0))
#xffff))
; op の操作
(defun get-main-op (op)
(ash op -12))
(defun get-sub-op (op)
(logand (ash op -8) #x0f))
(defun get-r1 (op)
(logand (ash op -4) #x0f))
(defun get-r2 (op)
(logand op #x0f))
; フラグの設定 (over sign zero)
(defun set-flag (val &optional (over 0))
(if (zerop val)
(setf *fr* (logior *fr* #b001))
(setf *fr* (logand *fr* #b110)))
(if (logbitp 15 val)
(setf *fr* (logior *fr* #b010))
(setf *fr* (logand *fr* #b101)))
(if (zerop over)
(setf *fr* (logand *fr* #b011))
(setf *fr* (logior *fr* #b100)))
val)
; 算術演算用
(defun set-flag-a (val)
(if (<= -32768 val 32767)
(set-flag val)
(set-flag (logand val #xffff) 1)))
(defun set-flag-l (val)
(if (<= 0 val 65535)
(set-flag val)
(set-flag (logand val #xffff) 1)))
; 比較用
(defun set-flag-cmp (val)
(cond ((zerop val)
(setf *fr* #b001))
((plusp val)
(setf *fr* #b000))
(t
(setf *fr* #b010))))
; 加算
(defun adda (val1 val2)
(to-unsigned (set-flag-a (+ (to-signed val1) (to-signed val2)))))
(defun addl (val1 val2)
(set-flag-l (+ val1 val2)))
; 減算
(defun suba (val1 val2)
(to-unsigned (set-flag-a (- (to-signed val1) (to-signed val2)))))
(defun subl (val1 val2)
(set-flag-l (- val1 val2)))
; 乗算
(defun set-flag-mul (val)
(cond ((logbitp 31 val)
(setf *fr* #b010))
((zerop val)
(setf *fr* #b001))
(t
(setf *fr* #b000)))
val)
(defun mula (val1 val2)
(set-flag-mul (logand (* (to-signed val1) (to-signed val2))
#xffffffff)))
(defun mull (val1 val2)
(set-flag-mul (* val1 val2)))
; 論理演算
(defun log-op (func val1 val2)
(set-flag (funcall func val1 val2)))
; シフト演算
(defun shift-right-a (val k)
(let* ((val0 (to-signed val))
(val1 (to-unsigned (ash val0 (- k)))))
(if (and (plusp k) (logbitp (1- k) val0))
(set-flag val1 1)
(set-flag val1 0))))
(defun shift-left-a (val k)
(let* ((val0 (logand val #x7fff))
(flag (logand val #x8000))
(val1 (logior flag (logand (ash val0 k) #x7fff))))
(if (and (<= 1 k 15) (logbitp (- 15 k) val0))
(set-flag val1 1)
(set-flag val1 0))))
(defun shift-right-l (val k)
(let ((val1 (ash val (- k))))
(if (and (<= 1 k 16) (logbitp (1- k) val))
(set-flag val1 1)
(set-flag val1 0))))
(defun shift-left-l (val k)
(let ((val1 (logand (ash val k) #xffff)))
(if (and (<= 1 k 16) (logbitp (- 16 k) val))
(set-flag val1 1)
(set-flag val1 0))))
; 初期化
(defun init-vm (start)
(fill *gr* 0)
(set-gr *sp* #xffff) ; SP の初期化
(setf *pr* start
*fr* 0))
; エラー
(defun error-operation-code (op)
(error "vm : error operation ~4,'0X~%" op))
;;; 仮想マシンの実行
(defun vm (start &optional (dump-num 32))
(init-vm start)
(loop
; (display-register)
(let* ((op (fetch))
(r1 (get-r1 op))
(r2 (get-r2 op)))
(case (get-main-op op)
((0) nil) ; NOP
((1)
(case (get-sub-op op)
((0) ; LD r,adr,x
(set-gr r1 (set-flag (read-memory (fetch2 r2)))))
((1) ; ST r,adr,x
(write-memory (fetch2 r2) (get-gr r1)))
((2) ; LAD r,adr,x
(set-gr r1 (fetch2 r2)))
((4) ; LD r1,r2
(set-gr r1 (set-flag (get-gr r2))))
(t (error-operation-code op))))
((2)
(case (get-sub-op op)
((0) ; ADDA r,adr,x
(set-gr r1 (adda (get-gr r1) (read-memory (fetch2 r2)))))
((1) ; SUBA r,adr,x
(set-gr r1 (suba (get-gr r1) (read-memory (fetch2 r2)))))
((2) ; ADDL r,adr,x
(set-gr r1 (addl (get-gr r1) (read-memory (fetch2 r2)))))
((3) ; SUBL r,adr,x
(set-gr r1 (subl (get-gr r1) (read-memory (fetch2 r2)))))
((4) ; ADDA r1,r2
(set-gr r1 (adda (get-gr r1) (get-gr r2))))
((5) ; SUBA r1,r2
(set-gr r1 (suba (get-gr r1) (get-gr r2))))
((6) ; ADDl r1,r2
(set-gr r1 (addl (get-gr r1) (get-gr r2))))
((7) ; SUBL r1,r2
(set-gr r1 (subl (get-gr r1) (get-gr r2))))
((8) ; MULA r1, r2
(let ((val (mula (get-gr r1) (get-gr r2))))
(set-gr r1 (logand val #xffff)) ; 下位 word セット
(set-gr r2 (ash val -16)))) ; 上位 word セット
((9) ; MULL r1, r2
(let ((val (mull (get-gr r1) (get-gr r2))))
(set-gr r1 (logand val #xffff)) ; 下位 word セット
(set-gr r2 (ash val -16)))) ; 上位 word セット
((10) ; DIVA r1, r2
(multiple-value-bind (p q)
(truncate (to-signed (get-gr r1))
(to-signed (get-gr r2)))
(set-gr r1 (to-unsigned (set-flag p))) ; 商
(set-gr r2 (to-unsigned q)))) ; 余り
((11) ; DIVL r1, r2)
(multiple-value-bind (p q)
(truncate (get-gr r1) (get-gr r2))
(set-gr r1 (set-flag p)) ; 商
(set-gr r2 q))) ; 余り
(t (error-operation-code op))))
((3)
(case (get-sub-op op)
((0) ; AND r,adr,x
(set-gr r1 (log-op #'logand (get-gr r1) (read-memory (fetch2 r2)))))
((1) ; OR r,adr,x
(set-gr r1 (log-op #'logior (get-gr r1) (read-memory (fetch2 r2)))))
((2) ; XOR r,adr,x
(set-gr r1 (log-op #'logxor (get-gr r1) (read-memory (fetch2 r2)))))
((4) ; AND r1,r2
(set-gr r1 (log-op #'logand (get-gr r1) (get-gr r2))))
((5) ; OR r1,r2
(set-gr r1 (log-op #'logior (get-gr r1) (get-gr r2))))
((6) ; XOR r1,r2
(set-gr r1 (log-op #'logxor (get-gr r1) (get-gr r2))))
(t (error-operation-code op))))
((4)
(case (get-sub-op op)
((0) ; CPA r,adr,x
(set-flag-cmp (- (to-signed (get-gr r1))
(to-signed (read-memory (fetch2 r2))))))
((1) ; CPL r,adr,x
(set-flag-cmp (- (get-gr r1)
(read-memory (fetch2 r2)))))
((4) ; CPA r1,r2
(set-flag-cmp (- (to-signed (get-gr r1))
(to-signed (get-gr r2)))))
((5) ; CPL r1,r2
(set-flag-cmp (- (get-gr r1) (get-gr r2))))
(t (error-operation-code op))))
((5)
(case (get-sub-op op)
((0) ; SLA r,adr,x
(set-gr r1 (shift-left-a (get-gr r1) (fetch2 r2))))
((1) ; SRA r,adr,x
(set-gr r1 (shift-right-a (get-gr r1) (fetch2 r2))))
((2) ; SLL r,adr,x
(set-gr r1 (shift-left-l (get-gr r1) (fetch2 r2))))
((3) ; SRL r,adr,x
(set-gr r1 (shift-right-l (get-gr r1) (fetch2 r2))))
(t (error-operation-code op))))
((6)
(let ((jump-adr (fetch2 r2)))
(case (get-sub-op op)
((1) ; JMI adr,x
(when (logbitp 1 *fr*)
(setf *pr* jump-adr)))
((2) ; JNZ adr,x
(unless (logbitp 0 *fr*)
(setf *pr* jump-adr)))
((3) ; JZE adr,x
(when (logbitp 0 *fr*)
(setf *pr* jump-adr)))
((4) ; JUMP adr,x
(setf *pr* jump-adr))
((5) ; JPL adr,x
(unless (logbitp 1 *fr*)
(setf *pr* jump-adr)))
((6) ; JOV adr,x
(when (logbitp 2 *fr*)
(setf *pr* jump-adr)))
(t (error-operation-code op)))))
((7)
(case (get-sub-op op)
((0) ; PUSH adr,x
(push-stack (fetch2 r2)))
((1) ; POP r
(set-gr r1 (pop-stack)))
(t (error-operation-code op))))
((8)
(case (get-sub-op op)
((0) ; CALL adr,x
(let ((jump-adr (fetch2 r2)))
(push-stack *pr*)
(setf *pr* jump-adr)))
((1) ; RET
(setf *pr* (pop-stack)))
((2) ; LINK r1,adr,x
; 1. 指定されたレジスタをスタックに退避
; 2. SP の値を指定したレジスタに代入
; 3. SP にローカルエリアサイズ (adr,x) を加える
(push-stack (get-gr r1))
(set-gr r1 (get-gr *sp*))
; 修正 2011/01/23
(set-gr *sp* (fetch3 r2)))
((3) ; UNLK r1
; 1. 指定されたレジスタの値を SP に代入
; 2. 指定されたレジスタを元の値に戻す
(set-gr *sp* (get-gr r1))
(set-gr r1 (pop-stack)))
(t (error-operation-code op))))
((15)
(case (get-sub-op op)
((0) ; SVC adr,x
(case (fetch2 r2)
((0) ; for debug
(display-register))
((1) ; for debug
(dump (get-gr 0) dump-num))
((2) ; read-char
(set-gr 0 (char-code (read-char))))
((3) ; write-byte
(write-char (code-char (get-gr 0))))
(t (error-operation-code op))))
((1) ; HALT
(return))
(t (error-operation-code op))))
(t (error-operation-code op))))))
; ロード
(defun load-code (code &optional (wp 0))
(dolist (x code wp)
(if (consp x)
(case (car x)
((ds)
(dotimes (m (cadr x))
(setf (aref *memory* wp) 0)
(incf wp)))
((dc)
(dolist (m (cdr x))
(setf (aref *memory* wp)
(if (<= 0 m)
m
(to-unsigned m)))
(incf wp)))
(t
(asm-error x)))
(progn
(setf (aref *memory* wp)
(if (minusp x) (to-unsigned x) x))
(incf wp)))))
; 実行
(defun asm-run (name &optional (dump-num 32))
(load-code (assemble (append (read-casl2-file name)
(read-casl2-file "lib.cas"))))
; 0 から開始
(vm 0 dump-num))
;
; lib.cas : COMET2A 簡易シミュレータ用ライブラリ
;
; Copyright (C) 2011 Makoto Hiroi
;
; 2011/01/23
; ver a : 動的メモリ割り当てを追加
;
; 2011/01/22
; 規約の変更 : gr0 と gr1 は保存しなくてもよい
;
; 文字の入力
; 入力 : 無し
; 出力 : gr0 文字
read-char
(svc 2)
(ret)
; 文字の出力
; 入力 : sp + 0) リターンアドレス
; + 1) 文字
; 出力 : 無し
write-char
(ld gr0 1 sp) ; 引数取得
(svc 3)
(ret)
; 改行を出力
newline
(lad gr0 10)
(svc 3)
(ret)
; 無符号整数の N 進表示
; 入力 a + 0) : gr7
; a + 1) : ret adr
; a + 2) : 整数
; a + 3) : 基数 N
; 出力 : None
printu
(link gr7 0)
(ld gr0 2 gr7) ; 整数
(ld gr1 3 gr7) ; 基数
(divl gr0 gr1) ; gr0 / gr1 -> gr0 商, gr1 余り
(jze printu-l1)
(push 0 gr1) ; 余りを保存
(lad sp -2 sp) ; 引数領域を確保
(st gr0 0 sp) ; 商をセット
(ld gr0 3 gr7)
(st gr0 1 sp) ; 基数をセット
(call printu)
(lad sp 2 sp) ; 引数領域を解放
(pop gr1)
printu-l1
(ld gr1 code-table gr1)
(push 0 gr1) ; 引数セット
(call write-char)
(pop gr1) ; 引数を取り除く
(unlk gr7)
(ret)
code-table
(dc "0123456789ABCDEF")
; 符号付き整数の 10 進表示
; 入力 a + 0) : gr7
; + 1) : ret adr
; + 2) : 整数
; 出力 : None
print
(link gr7 0)
(push 0 gr2)
(ld gr2 2 gr7)
(jpl print-l1) ; flag check
; 符号を反転する
(lad gr0 #xffff)
(xor gr2 gr0) ; bit を反転
(lad gr2 1 gr2) ; 1 を足す
(push 45)
(call write-char) ; '-' を出力
(pop gr0)
print-l1
(lad sp -2 sp) ; 引数領域確保
(st gr2 0 sp) ; 整数をセット
(lad gr0 10)
(st gr0 1 sp) ; 基数 10 をセット
(call printu)
(lad sp 2 sp) ; 引数領域解放
(pop gr2)
(unlk gr7)
(ret)
; データの探索
; 入力 +2) : データ
; +3) ; バッファ
; +4) : 個数
; 出力 : gr0 位置 (0 以上の数値), -1 失敗
position
(link gr7 0)
(push 0 gr2)
(ld gr0 2 gr7) ; データ
(ld gr1 3 gr7) ; 先頭アドレス
(ld gr2 4 gr7) ; 個数
(addl gr2 gr1) ; 末尾アドレス
position-loop
(cpl gr1 gr2)
(jze position-false) ; 探索失敗
(cpa gr0 0 gr1)
(jze position-true) ; 探索成功
(lad gr1 1 gr1)
(jump position-loop)
position-true
(ld gr0 gr1) ; 位置を求める
(subl gr0 3 gr7)
position-exit
(pop gr2)
(unlk gr7)
(ret)
position-false
(lad gr0 -1)
(jump position-exit)
; バッファの初期化
; 入力 : +2) 初期値
; : +3) バッファ
; : +4) 個数
fill
(link gr7 0)
(push 0 gr2)
(ld gr0 2 gr7)
(ld gr1 3 gr7)
(ld gr2 4 gr7)
(addl gr2 gr1) ; 末尾アドレス
fill-loop
(cpl gr1 gr2)
(jze fill-exit)
(st gr0 0 gr1)
(lad gr1 1 gr1)
(jump fill-loop)
fill-exit
(pop gr2)
(unlk gr7)
(ret)
; ベクタの表示
; 入力 +2) バッファアドレス
; +3) 個数
; 出力 : None
print-vector
(link gr7 0)
(push 0 gr2)
(push 0 gr3)
(ld gr2 2 gr7) ; 先頭アドレス
(ld gr3 3 gr7) ; 個数
(addl gr3 gr2) ; 末尾アドレス
print-vector-loop
(cpl gr2 gr3)
(jze print-vector-exit)
(lad sp -1 sp)
(ld gr0 0 gr2)
(st gr0 0 sp)
(call print)
(lad gr0 32) ; 空白を出力
(st gr0 0 sp)
(call write-char)
(lad sp 1 sp)
(lad gr2 1 gr2)
(jump print-vector-loop)
print-vector-exit
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
; ビット 1 を数える (4 bit ずつ処理する)
; 入力 (gr7 + 2) : データ
; 出力 gr0 : ビット 1 の個数
logcount
(link gr7 0)
(push 0 gr2)
(xor gr0 gr0)
(ld gr1 2 gr7)
logcount-loop
(ld gr2 gr1)
(and gr2 logcount-mask)
(addl gr0 logcount-table gr2)
(srl gr1 4)
(jnz logcount-loop)
(pop gr2)
(unlk gr7)
(ret)
logcount-mask
(dc 15)
logcount-table
; 0 1 2 3 4 5 6 7 8 9 a b c d e f
(dc 0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4)
;;;
;;; 動的メモリ割り当て
;;;
; 初期化
initialize-heap
(lad gr1 heap-top)
(xor gr0 gr0)
(st gr0 0 gr1) ; null で終端
(lad gr0 #xe000) ; heap-top から #xe000 までがヒープ
(subl gr0 gr1)
(srl gr0 1) ; word -> unit
(st gr0 1 gr1) ; unit をセット
(ret)
; メモリの取得 (first-fit 法)
; 入力 +2) : サイズ (word)
; 出力 gr0 : アドレス
malloc
(link gr7 0)
(push 0 gr2)
(push 0 gr3)
(ld gr1 2 gr7) ; size を取得
(lad gr1 1 gr1)
(srl gr1 1) ; (size + 1) / 2 => unit
(lad gr1 1 gr1) ; header 分を加算
(lad gr2 heap-head) ; q (一つ前のブロック)
(ld gr3 heap-head) ; p (調べるブロック)
malloc-loop
(jze malloc-error) ; 空きメモリがない
(cpl gr1 1 gr3)
(jze malloc-lab1) ; 大きさが等しい
(jmi malloc-lab2) ; ブロックを分割する
; 次のブロックを探す
(ld gr2 gr3) ; p -> q
(ld gr3 0 gr3) ; p の次のブロック -> p
(jump malloc-loop)
malloc-lab1
; リンクをはずすだけ
(ld gr0 0 gr3) ; p の次のブロック -> gr0
(st gr0 0 gr2) ; q を書き換える
(xor gr0 gr0)
(st gr0 0 gr3) ; リンクを null でクリア
(lad gr0 2 gr3) ; アドレス p + 2 を返す
(jump malloc-exit)
malloc-lab2
; ブロックの後半を割り当てる
(ld gr0 1 gr3)
(subl gr0 gr1) ; 残りの units を計算 -> gr0
(st gr0 1 gr3) ; gr0 -> (gr3 + 1)
(sll gr0 1) ; units -> word
(addl gr3 gr0) ; 切り出すブロックの先頭アドレス
(xor gr0 gr0)
(st gr0 0 gr3) ; リンクを null でクリア
(st gr1 1 gr3) ; units をセット
(lad gr0 2 gr3) ; アドレス p + 2 を返す
malloc-exit
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
malloc-error
(xor gr0 gr0) ; null を返す
(jump malloc-exit)
; メモリの統合
; 入力 +2) : block p
; +3) : block q
; 出力 None
append-block
(link gr7 0)
(push 0 gr2)
(ld gr1 2 gr7) ; gr1 is p
(ld gr2 3 gr7) ; gr2 is q
(ld gr0 1 gr1) ; punits
(sll gr0 1) ; words へ変換
(addl gr0 gr1)
(cpl gr0 gr2) ; 等しい場合は統合する
(jnz append-block-lab1)
(ld gr0 1 gr1) ; p の units
(addl gr0 1 gr2) ; q の units を加算
(st gr0 1 gr1)
(ld gr0 0 gr2) ; q の next block
(st gr0 0 gr1) ; p にセット
append-block-exit
(pop gr2)
(unlk gr7)
(ret)
append-block-lab1
; リンクするだけ
(st gr2 0 gr1)
(jump append-block-exit)
; メモリの解放
; 入力 +2) : アドレス
; 出力 None
free
(link gr7 0)
(push 0 gr2)
(push 0 gr3)
(push 0 gr4)
(ld gr4 2 gr7) ; 解放するメモリのアドレス
(jze free-exit) ; null check
(lad gr4 -2 gr4)
(lad gr2 heap-head) ; q (一つ前のブロック)
(ld gr3 heap-head) ; p (調査中のブロック)
free-loop
(jze free-lab1) ; 末尾に追加
(cpl gr4 gr3) ; gr4 < gr3 を探す
(jmi free-lab2)
; 次のセルへ
(ld gr2 gr3)
(ld gr3 0 gr3)
(jump free-loop)
free-lab2
(lad sp -2 sp)
(st gr4 0 sp) ; 解放するブロックと
(st gr3 1 sp) ; 後ろのブロック p を
(call append-block) ; 統合する
(lad sp 2 sp)
free-lab1
(lad sp -2 sp)
(st gr2 0 sp) ; 前のブロック q と
(st gr4 1 sp) ; 解放するブロックを
(call append-block) ; 統合する
(lad sp 2 sp)
free-exit
(pop gr4)
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
;;;
;;; ヒープ領域
;;;
(align 2) ; 偶数番地に割り当てる
heap-head
(dc heap-top 0) ; header のみ
heap-top
;;; これ以降にプログラムを書いてはいけない
;;; heap-top
;;; : ヒープ領域
;;; #xe000
;;; : スタック領域 (8 k word)
;;; #xffff