Common Lisp 入門 の番外編です。今回は COMETⅡの機能を拡張して、引数をスタックに積んでサブルーチンを呼び出す方法と、サブルーチンで使用する局所変数をスタック上に確保する方法について説明します。なお、本ドキュメントでは機能を拡張した COMETⅡを COMET2A と呼ぶことにします。
スタック領域にアクセスするための最も簡単な方法は、スタックポインタを汎用レジスタとして扱うことです。スタックポインタを sp という名前の汎用レジスタでアクセスできるようにすると、引数をスタックに積んでサブルーチンに渡す方法は次のようになります。
リスト : 引数をスタックに積んで渡す方法 (1)
; スタック
; [ 引数 a ] <= sp + 0 = sp0 - 3
; [ 引数 b ] sp + 1
; [ 引数 c ] sp + 2
; [ xxxxxx ] <= sp0
test-foo
(lad sp -3 sp) ; 引数領域を確保
(lad gr0 10)
(st gr0 0 sp) ; 引数 a をセット
(lad gr0 20)
(st gr0 1 sp) ; 引数 b をセット
(lad gr0 30)
(st gr0 2 sp) ; 引数 c をセット
(call foo)
(lad sp 3 sp) ; スタックポインタの補正
(svc 0)
(halt)
; 3 つの引数を加算して返す
; foo(a, b, c) => gr0 (a + b + c)
;
; スタック
; [ ret adr ] <= sp
; [ 引数 a ] sp + 1
; [ 引数 b ] sp + 2
; [ 引数 c ] sp + 3
foo
(ld gr0 1 sp)
(adda gr0 2 sp)
(adda gr0 3 sp)
(ret)
サブルーチン foo は 3 つの引数を受け取り、その合計値を計算して返します。引数を 3 つスタックに積む場合、 LAD 命令でスタックポインタを 3 つ減らして引数を格納する領域を確保します。それから、それぞれの引数を sp + 0, sp + 1, sp + 2 にセットします。LAD ではなく PUSH を使ってもかまいませんが、引数を PUSH する順番に気をつけてください。
サブルーチン foo を呼び出すと、スタックにはリターンアドレスがセットされます。sp の位置にリターンアドレスが格納されているので、引数の位置は a が sp + 1, b が sp + 2, c が sp + 3 になります。サブルーチンの呼び出しから戻ってきたら、スタックの補正を行います。この場合、sp を 3 つ減らしているので、sp を 3 つ増やせばいいわけです。これでスタックに積んだ引数を削除することができます。
このように、sp を指標レジスタとして用いることで、スタック上で簡単に引数の受け渡しを行うことができるのですが、実はこのままではちょっと不都合なことがあるのです。
サブルーチンで局所変数を使うことを考えてみましょう。たとえば、サブルーチン foo1 は引数を 2 つ受け取り、局所変数を 2 つ使って処理を行うものとします。局所変数は次のようにスタック上に確保することができます。
リスト : スタック上に局所変数を確保する
; [ 変数 m ] <= sp = sp0 - 2
; [ 変数 n ]
; [ ret adr ] <= sp0
; [ 引数 a ]
; [ 引数 b ]
foo1
(lad sp -2 sp) ; 局所変数の確保
...
スタック上に局所変数を確保すると、その分だけ sp の値が変化します。sp に対する引数 a, b の相対位置も当然ですが変化することになります。局所変数 m, n は sp + 0, sp + 1 の位置になりますが、引数 a, b は sp + 3, sp + 4 の位置になります。局所変数を 2 つ確保することで、引数 a, b の位置が 2 word 分ずれることになるのです。
局所変数だけではなく、レジスタの値も保護する必要があると、状況はさらに複雑になります。たとえば、foo1 で gr1, gr2, gr3 の値を保護すると、次のようになります。
リスト : 局所変数の確保とレジスタの退避
; [ gr3の値 ] <= sp = sp1 - 3 = sp0 - 5
; [ gr2の値 ]
; [ gr1の値 ]
; [ 変数 m ] <= sp1
; [ 変数 n ]
; [ ret adr ] <= sp0
; [ 引数 a ]
; [ 引数 b ]
foo1
(lad sp -2 sp) ; 局所変数の確保
(push 0 gr1) ; レジスタの保護
(push 1 gr2)
(push 2 gr3)
...
今度は引数 a, b だけではなく、確保した局所変数 m, n の位置も変化します。また、foo1 の中で他のサブルーチンを呼び出す場合も、引数を渡すために sp の値は変化します。このとき、当然ですが引数 a, b と局所変数 m, n の相対位置も変化するので、これらの変数にアクセスするときには十分な注意が必要になります。
そして何よりも、RET 命令を実行するときにスタックポインタをリターンアドレスの位置に正しく戻さないと、プログラムは暴走してしまうでしょう。このように、スタックポインタを基準にすると、引数や局所変数の管理がちょっと面倒になるだけではなく、スタックポインタの操作を間違えるとプログラムを暴走させる危険性があるのです。
そこで、「フレームポインタ (frame pointer : FP) 」というレジスタを導入します。次の図を見てください。
スタック
アドレス Low
[ gr3の値 ] SP2
[ gr2の値 ]
[ gr1の値 ]
[ m ] SP1 - 2
[ n ] - 1
[ FPの値 ] SP0 => FP + 0
[リターンアドレス] SP + 1
[ a ] + 2
[ b ] + 3
High [ ]
図 : フレームポインタを用いた局所変数の管理
スタック上に局所変数を確保する場合、まず FP の値をスタックに退避して、スタックポインタの値を FP にセットします。上図では、サブルーチンを呼び出したときのスタックポインタの値は SP です。次に、フレームポインタの値を退避するので、スタックポインタの値は SP0 になります。この値がフレームポインタ FP の値になります。
次に、局所変数 m, n をスタック上に確保すると、スタックポインタの値は SP1 になり、gr1, gr2, gr3 を退避するとスタックポインタの値は SP2 になりますが、フレームポインタの値は当然ですが変化しません。フレームポインタの値を基準にすると、引数 a, b は FP + 2, FP + 3 の位置に、局所変数 m, n は FP - 2, FP - 1 の位置になり、スタックポインタの値が変化しても、サブルーチン内では同じようにアクセスすることができます。
呼び出し元に戻るときは、まず FP の値をスタックポインタにセットします。するとスタックポインタは SP0 の位置に戻るので、そこに格納されている旧フレームポインタの値をポップして FP にセットします。するとスタックポインタは SP の位置にもどり、そこにはリターンアドレスが積まれています。スタックからそのアドレスを取り出してジャンプすれば、サブルーチンを呼び出したところに戻ることができます。
フレームポインタは指標レジスタとして機能しなければいけません。そこで、既存の指標レジスタをフレームポインタに割り当てる命令 LINK と、それを元に戻す命令 UNLK を新しく追加することにしましょう。なお、LINK と UNLK はモトローラ社製の MPU 68000 の命令を参考にしました。
LINK GRx, adr, GRy UNLK GRx
LINK 命令はレジスタ GRx の値をスタックに退避します。次に、スタックポインタの値を取り出して、レジスタ GRx にセットします。それから、adr + GRy を計算してその値をスタックポインタに加算します。UNLK 命令はレジスタ GRx の値をスタックポインタに代入します。そして、スタックから値をポップして、それをレジスタ GRx にセットします。
一般的には、LINK と UNLK は次のように使います。
リスト : LINK と UNLK の使い方
; Adr
; FFF1 : [ gr3の値 ] <= sp
; FFF2 : [ gr2の値 ]
; FFF3 : [ gr1の値 ]
; FFF4 : [ 変数 n ] gr7 - 2
; FFF5 : [ 変数 m ] - 1
; FFF6 : [ gr7の値 ] <= gr7 (フレームポインタ)
; FFF7 : [ ret adr ]
; FFF8 : [ 引数 a ] gr7 + 2
; FFF9 : [ 引数 b ] + 3
foo1
(link gr7 -2) ; フレームポインタの設定
(push 0 gr1) ; レジスタの退避
(push 0 gr2)
(push 0 gr3)
.....
(pop gr3) ; レジスタの復旧
(pop gr2)
(pop gr1)
(unlk gr7) ; 局所変数の廃棄と gr7 の復旧
(ret)
foo1 を呼び出したときのスタックポインタの値は FFF7 番地とします。まず最初に、LINK 命令でフレームポインタと局所変数のサイズを設定します。フレームポインタは指標レジスタとして使える汎用レジスタであれば何でもかまいませんが、ここでは GR7 を指定しました。局所変数のサイズは LAD 命令と同じく負の値で指定してください。ここでは m, n の領域を確保するため -2 を指定しました。サイズに 0 を指定すると、局所変数の領域は確保されません。
LINK 命令は GR7 の値をスタックに退避し、スタックポインタの値を GR7 にセットします。上図では、GR7 の値は FFF6 番地に格納され、GR7 の値は FFF6 になります。LINK 命令を実行したあと、スタックポインタの値は FFF4 になります。次に、レジスタ gr1, gr2, gr3 を退避します。すると、スタックポインタの値は FFF1 になりますが、フレームポインタの値は FFF6 のままです。引数 a, b のアドレスは GR7 + 2 = FFF8 番地、GR7 + 3 = FFF9 番地、変数 m, n のアドレスは GR7 - 2 = FFF4 番地、GR7 - 1 = FFF3 番地とフレームポインタから求めることができます。
呼び出し元に戻るときは、まず退避したレジスタの値を POP で復旧します。それから UNLK 命令を使います。UNLK は GR7 の値をスタックポインタにセットします。これでスタックポインタは FFF6 番地を指すようになり、局所変数として確保した領域も解放されます。次に、スタックから値をポップして GR7 にセットします。これで GR7 を元の値に戻すことができ、スタックポインタの値が -1 されて、リターンアドレスが格納されている FFF7 番地を指すようになります。あとは RET 命令を実行すれば呼び出し元に正しく戻ることができます。
それから、乗算と除算を行う命令を追加します。
MULA GRn, GRm ; GRn * GRm -> GRn (low), GRm (high) MULL GRn, GRm DIVA GRn, GRm ; GRn / GRm -> GRn (商), GRm (余り) DIVL GRn, GRm
MULL は無符号整数の乗算、MULA は符号付き整数の乗算を行います。GRn * GRm の計算結果は 32 bit 整数で返されます。第 1 オペランドの GRn に下位 16 bit がセットされ、第 2 オペランドの GRm に上位 16 bit がセットされます。結果が 0 の場合はゼロフラグがセットされ、GRm の MSB が 1 の場合 (32 bit 整数で負の場合) はサインフラグがセットされます。オーバーフローフラグはリセットされます。
DIVL は無符号整数の除算、DIVA は符号付き整数の除算を行います。GRn / GRm の商は第 1 オペランドの GRn にセットされ、余りは第 2 オペランドの GRm にセットされます。商の結果がゼロの場合はゼロフラグがセットされ、商の MSB が 1 の場合はサインフラグがセットされます。オーバーフローフラグはリセットされます。
このほかに、レジスタ GR0 を指標レジスタとして使用できるように修正します。
それではプログラムを修正しましょう。最初に命令語を追加します。
リスト : 命令語の追加
(defvar *op-table1*
'((pop . #x7100) ; POP r
(unlk . #x8300) ; UNLK r (追加)
))
(defvar *op-table2*
'((ld . #x1400) ; LD r1,r2
・・・省略・・・
(mula . #x2800) ; MULA r1,r2 (追加)
(mull . #x2900) ; MULL r1,r2 (追加)
(diva . #x2A00) ; DIVA r1,r2 (追加)
(divl . #x2B00) ; DIVL r1,r2 (追加)
・・・省略・・・
))
(defvar *op-table3*
'((ld . #x1000) ; LD r1,adr,r2
・・・省略・・・
(link . #x8200) ; LINK r1,adr,r2 追加
))
次に、スタックポインタ SP を汎用レジスタに登録します。
リスト : 汎用レジスタの番号を取得 (defun get-gr-number (gr) (position gr '(gr0 gr1 gr2 gr3 gr4 gr5 gr6 gr7 sp)))
これで sp は 8 番目の汎用レジスタとしてアセンブルされます。
それから、GR0 を指標レジスタとして使用できるように修正します。具体的には関数 make-opcode でレジスタの値 r2 のゼロチェックをはずすだけです。この修正は簡単なので説明は割愛いたします。アセンブラの修正はこれだけです。
次は仮想マシン本体を修正します。最初に、レジスタの定義を修正します。
リスト : レジスタの定義
(defvar *gr* (make-array 9
:element-type '(unsigned-byte 16)
:initial-element 0))
(defvar *pr* 0)
(defvar *fr* 0)
(defvar *sp* 8) ; スタックポインタの番号
スタックポインタを汎用レジスタとして使うので、*gr* にセットするベクタのサイズは 9 になります。スペシャル変数 *sp* はスタックポインタとして使う汎用レジスタの番号を格納します。この場合、番号は 8 になります。
次に、2 word 目の命令を取り出す関数 fetch2 を修正します。
リスト : 2 word 目の命令を取り出す
(defun fetch2 (reg)
(logand (+ (fetch) (if (<= 0 reg *sp*) (get-gr reg) 0))
#xffff))
レジスタ reg の範囲を 1 <= reg <= 7 から 0 <= reg <= *sp* に変更します。これで間接アドレッシングに GR0 と SP を使うことができます。
次は乗算と除算を行う処理を追加します。次のリストを見てください。
リスト : 乗算と除算の処理
((2)
(case (get-sub-op op)
((0) ; ADDA r,adr,x
(set-gr r1 (adda (get-gr r1) (read-memory (fetch2 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))))
乗算は関数 mula と mull で行います。結果を word (16 bit) で分割して、low word をレジスタ r1 に、high word をレジスタ r2 にセットします。除算は Common Lisp の関数 truncate を呼び出し、商 p をレジスタ r1 に、余り q をレジスタ r2 にセットします。
最後に LINK 命令と UNLK 命令を追加します。次のリストを見てください。
リスト : LINK と UNLK の追加
((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/22
(set-gr *sp* (+ (get-gr *sp*) (fetch2 r2))))
(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))))
LINK 命令はレジスタ r1 の値を関数 push-stack でスタックに退避します。次に、スタックポインタの値を取り出して、レジスタ r1 にセットします。そして、関数 fetch3 で局所変数の領域を計算し、その値をスタックポインタにセットします。UNLK 命令はレジスタ r1 の値をスタックポインタに代入します。そして、関数 pop-stack でスタックから値を取り出して、それをレジスタ r1 にセットするだけです。
fetch3 は次のようになります。
リスト : 局所変数の領域を計算する
(defun fetch3 (reg)
(logand (+ (fetch)
(get-gr *sp*)
(if (<= 0 reg *sp*) (get-gr reg) 0))
#xffff))
fetch で求めた値とスタックポインタとレジスタ reg の値を足し算し、その結果と #xffff の論理積を求めるだけです。
関数 push-stack と pop-stack は次のようになります。
リスト : スタックの操作
(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*))))
push-stack はスタックポインタを -1 してから、val をスタックポインタの位置にセットします。pop-stack はスタックポインタの位置に格納されている値を取り出してから、スタックポインタの値を +1 します。
大きな修正はこれだけです。あとはとくに難しいところはないので、説明は割愛いたします。詳細は プログラムリスト をお読みください。
それでは実際に、前々回のサンプルプログラム (オンビットを数える logcount) を書き直してみましょう。
リスト : サンプルプログラム
;
; sample.cas
;
(lad gr2 0)
sample-loop
(ld gr1 data gr2)
(lad sp -1 sp) ; (push 0 gr1)
(st gr1 0 sp) ; (call logcount)
(call logcount) ; (pop gr1)
(lad sp 1 sp) ; としても動作する
(st gr0 ans gr2)
(lad gr2 1 gr2)
(cpl gr2 len)
(jmi sample-loop)
(lad gr0 data)
(svc 1)
(halt)
len (dc 4)
data (dc #x0123 #x4567 #x89ab #xcdef)
ans (ds 4)
; ビット 1 を数える (4 bit ずつ処理する)
; 入力 (gr7 + 2) : データ
; 出力 gr0 : ビット 1 の個数
logcount
(link gr7 0)
(push 0 gr1)
(push 0 gr2)
(xor gr0 gr0)
(ld gr1 2 gr7)
loop
(ld gr2 gr1)
(and gr2 mask)
(addl gr0 table gr2)
(srl gr1 4)
(jnz loop)
(pop gr2)
(pop gr1)
(unlk gr7)
(ret)
mask (dc 15)
; 0 1 2 3 4 5 6 7 8 9 a b c d e f
table (dc 0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4)
サブルーチン logcount は link 命令で gr7 をフレームポインタに割り当て、(gr7 + 2) から引数を取り出して gr1 にセットします。あとの処理は今までと同じですが、最後に unlk 命令を実行することを忘れないでください。logcount を呼び出す側では、引数を格納するスタック領域を確保し、そこに引数をセットしてから logcount を呼び出します。そのあと、確保したスタック領域を解放します。
実行結果は次のようになります。
* (asm-run "sample.cas") 001A: 0123 4567 89AB CDEF 0004 0008 0008 000C 0022: 827F 0000 70F1 0000 70F2 0000 3600 1017 002A: 0002 1421 302F 0038 2202 0039 531F 0004 0032: 62FF 002B 712F 711F 837F 81FF 000F 0000 NIL
data のアドレスが #x001A で ans のアドレスが #x001E です。#x0123, #x4567, #x89ab, #xcdef のオンビットの個数が ans の領域にセットされ、値が #x0004, #x0008, #x0008, #x000C になっています。正常に動作していますね。
今回はここまでです。次回は簡単なサンプルプログラムをいくつか作ってみましょう。
;
; COMET2A.L : 仮想計算機 COMET2A 簡易シミュレータ
; (COMET2A は COMET2 の独自拡張)
;
; 1. GR0, SP をインデックスレジスタとして使用できる
; 2. link, unlk 命令の追加
; 3. mula, mull, diva, divl 命令の追加
;
; 修正 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))))
; アセンブラ
(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)
((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/22
(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/22
(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 (read-casl2-file name)))
; 0 から開始
(vm 0 dump-num))