Posted to tcl by GPS at Wed Nov 07 09:15:47 GMT 2007view raw

  1. #Tclas (a runtime assembler written in Tcl)
  2. #By George Peter Staplin
  3.  
  4. #INSTRUCTION PREFIXES
  5. set prefixes(lock) 0xf0
  6. set prefixes(repne) 0xf2
  7. set prefixes(repnz) 0xf2
  8. set prefixes(rep) 0xf3
  9. set prefixes(repe) 0xf3
  10. set prefixes(repz) 0xf3
  11.  
  12. #SEGMENT OVERRIDE PREFIXES
  13. set sop(cs) 0x2e
  14. set sop(ss) 0x36
  15. set sop(ds) 0x3e
  16. set sop(es) 0x26
  17. set sop(fs) 0x64
  18. set sop(gs) 0x65
  19.  
  20. set branch_hints(not_taken) 0x2e
  21. set branch_hints(taken) 0x3e
  22.  
  23. proc reg32 {name value} {
  24. global regs
  25. set regs($name) $value
  26. set regs($name,type) 32
  27. }
  28.  
  29. proc reg16 {name value} {
  30. global regs
  31. set regs($name) $value
  32. set regs($name,type) 16
  33. }
  34.  
  35. proc reg8 {name value} {
  36. global regs
  37. set regs($name) $value
  38. set regs($name,type) 8
  39. }
  40.  
  41. reg32 eax 0
  42. reg32 ecx 1
  43. reg32 edx 2
  44. reg32 ebx 3
  45. reg32 esp 4
  46. reg32 ebp 5
  47. reg32 esi 6
  48. reg32 edi 7
  49.  
  50. reg16 ax 0
  51. reg16 cx 1
  52. reg16 dx 2
  53. reg16 bx 3
  54. reg16 sp 4
  55. reg16 bp 5
  56. reg16 si 6
  57. reg16 di 7
  58.  
  59. reg8 al 0
  60. reg8 cl 1
  61. reg8 dl 2
  62. reg8 bl 3
  63. reg8 ah 4
  64. reg8 ch 5
  65. reg8 dh 6
  66. reg8 bh 7
  67.  
  68. proc op {name opvec} {
  69. global ops
  70. set ops($name) 1
  71. lappend ops($name,data) $opvec
  72. interp alias {} $name {} opcall $name
  73. }
  74.  
  75. proc opvec {base reqarg size types} {
  76. list $base $reqarg $size $types
  77. }
  78.  
  79. # Operands with a % prefix are assumed to be registers.
  80. # Operands with a ~ prefix are symbols. TODO use dlopen/dlsym to lookup symbols.
  81. # Operands with a @ prefix are assumed to be absolute addresses.
  82. # Operands with no prefix are assumed to be immediate values.
  83. proc typeof {o resultvar} {
  84. upvar $resultvar result
  85. global regs
  86. set c [string index $o 0]
  87. switch -- $c {
  88. % {
  89. set regname [string range $o 1 end]
  90. if {![info exists regs($regname)]} {
  91. return -code error "invalid register name: $regname"
  92. }
  93. set result $regname
  94. return register
  95. }
  96. ~ {
  97. set result [string range $o 1 end]
  98. return symbol
  99. }
  100. @ {
  101. set result [string range $o 1 end]
  102. return address
  103. }
  104. ( {
  105. if {")" ne [string index $o end]} {
  106. return -code error "missing closing ) in memory operand"
  107. }
  108. set result [string range $o 2 end-1]
  109. return memory
  110. }
  111. default {
  112. set result $o
  113. return immediate
  114. }
  115. }
  116. }
  117.  
  118. proc find-matching-instruction {name atype btype} {
  119. global ops
  120. set l [list $atype $btype]
  121. foreach oplist $ops($name,data) {
  122. if {[lindex $oplist 3] eq $l} {
  123. return $oplist
  124. }
  125. }
  126. return ""
  127. }
  128.  
  129. proc binout out {
  130. puts BINOUT:0x[format %x $out]
  131. flush stdout
  132. }
  133.  
  134. proc binout-long out {
  135. puts BINOUT:0x[format %8.8x $out]
  136. }
  137.  
  138. proc opcall-2 {name a b} {
  139. global ops regs
  140.  
  141. puts "OPERANDS:$a $b"
  142.  
  143. set atype [typeof $a ares]
  144. set btype [typeof $b bres]
  145. if {"" eq [set oplist [find-matching-instruction $name $atype $btype]]} {
  146. return -code error "invalid instruction pattern: $name with $atype $btype :: $args"
  147. }
  148. lassign $oplist code operandcount sizes types
  149. lassign $sizes asize bsize
  150.  
  151. puts "TYPES:$atype $btype"
  152.  
  153. switch -- $atype {
  154. immediate {
  155. binout [expr {$code + $regs($bres)}]
  156. if {32 == $bsize} {
  157. binout-long $ares
  158. } else {
  159. binout [expr {$ares & 0xff}]
  160. }
  161. }
  162. memory {
  163. binout $code ;#opcode
  164. binout $regs($bres) ;#modrm
  165. }
  166. register {
  167. if {"register" eq $btype} {
  168. binout $code
  169. binout [expr {(1 << 6 | 1 << 7) + (8 * $regs($ares)) + $regs($bres)}] ;#modrm
  170. } else {
  171. #memory
  172. binout $code
  173. binout [expr {(8 * $regs($ares)) + $regs($bres)}] ;#modrm
  174. }
  175. }
  176. }
  177. }
  178.  
  179. proc opcall-0 name {
  180. global ops
  181. lassign [lindex $ops($name,data) 0] code operandcount sizes types
  182. binout $code
  183. }
  184.  
  185. proc opcall {name args} {
  186. switch -- [llength $args] {
  187. 0 {
  188. opcall-0 $name
  189. }
  190. 2 {
  191. opcall-2 $name {*}$args
  192. }
  193. default {
  194. return -code error "invalid arguments: $name $args"
  195. }
  196. }
  197. }
  198.  
  199. #set item from-type
  200. op movb [opvec 0xb0 2 [list 8 8] [list immediate register]]
  201. op movb [opvec 0x88 2 [list 8 8] [list register register]]
  202. op movb [opvec 0x8a 2 [list 32 8] [list memory register]]
  203. op movb [opvec 0x88 2 [list 8 32] [list register memory]]
  204.  
  205. op movl [opvec 0xb8 2 [list 32 32] [list immediate register]]
  206. op movl [opvec 0x89 2 [list 32 32] [list register register]]
  207. op movl [opvec 0x8b 2 [list 32 32] [list memory register]]
  208. op movl [opvec 0x89 2 [list 32 32] [list register memory]]
  209.  
  210. op movzbl [opvec 0x0fb6 2 [list 8 32] [list register register]]
  211.  
  212. op addb [opvec 0x04 2 [list 8 8] [list immediate register]]
  213. op addb [opvec 0x00 2 [list 8 8] [list register register]]
  214. op addb [opvec 0x02 2 [list 32 8] [list memory register]]
  215. op addb [opvec 0x00 2 [list 8 32] [list register memory]]
  216.  
  217. op addl [opvec 0x05 2 [list 32 8] [list immediate register]]
  218. op addl [opvec 0x01 2 [list 32 32] [list register register]]
  219. op addl [opvec 0x03 2 [list 32 32] [list memory register]]
  220. op addl [opvec 0x01 2 [list 32 32] [list register memory]]
  221.  
  222. op nop [opvec 0x90 0 [list] [list]]
  223.  
  224. #Test code
  225. movl 0xffaaddee %eax
  226. nop
  227. movl (%eax) %eax
  228. movl (%ecx) %ecx
  229. nop
  230.  
  231. movl %eax %eax
  232. movl %ecx %eax
  233. movl %edx %eax
  234. movl %eax %ecx
  235.  
  236. movl %eax (%eax)
  237. movl %eax (%ecx)
  238. movl %ecx (%eax)
  239.  
  240. movl %ebp (%eax)
  241.  
  242. movb %al %al
  243. movzbl %al %eax
  244.  
  245. nop
  246. nop
  247. nop
  248. #addl 0xffeeeedd %eax
  249.