smalltalk-tng

annotate experiments/codegen/codegen.scm @ 321:c4a0718c2d3c

find changesets by author, revision, files, or words in the commit message
Sketch of dependencies
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
date Sat Oct 08 15:36:03 2011 -0400 (7 months ago)
parents e50fccd8b2ca
children
rev   line source
tonyg@243 1 (load "tinyscheme+cvs20090722/init.scm")
tonyg@244 2
tonyg@244 3 (define (check-arg pred val caller) #t)
tonyg@268 4 (macro (:optional form)
tonyg@268 5 `(if (null? ,(cadr form)) ,(caddr form) (car ,(cadr form))))
tonyg@244 6 (load "srfi-1.scm")
tonyg@244 7
tonyg@269 8 (define (symbol-append . syms)
tonyg@269 9 (if (null? syms)
tonyg@269 10 (error "No symbols supplied to symbol-append")
tonyg@269 11 (string->symbol
tonyg@269 12 (fold-right (lambda (sym acc)
tonyg@269 13 (if (zero? (string-length acc))
tonyg@269 14 (symbol->string sym)
tonyg@269 15 (string-append (symbol->string sym) acc)))
tonyg@269 16 ""
tonyg@269 17 syms))))
tonyg@252 18
tonyg@269 19 (macro (cheap-struct form)
tonyg@269 20 (let ((record-name (cadr form))
tonyg@269 21 (field-names (caddr form)))
tonyg@269 22 (let ((maker-name (symbol-append 'make- record-name))
tonyg@269 23 (predicate-name (symbol-append record-name '?)))
tonyg@269 24 `(begin
tonyg@269 25 (define (,maker-name ,@field-names)
tonyg@269 26 (vector ',record-name ,@field-names))
tonyg@269 27 (define (,predicate-name x)
tonyg@269 28 (and (vector? x)
tonyg@269 29 (eq? (vector-ref x 0) ',record-name)))
tonyg@269 30 ,@(let loop ((field-names field-names)
tonyg@269 31 (counter 1))
tonyg@269 32 (if (null? field-names)
tonyg@269 33 '()
tonyg@269 34 (cons `(define (,(symbol-append record-name '- (car field-names)) x)
tonyg@269 35 (vector-ref x ,counter))
tonyg@269 36 (loop (cdr field-names) (+ counter 1)))))))))
tonyg@269 37
tonyg@269 38 (define (filter-map-alist predicate transformer l)
tonyg@269 39 (filter-map (lambda (entry) (and (predicate (car entry))
tonyg@269 40 (if transformer
tonyg@269 41 (transformer (car entry) (cdr entry))
tonyg@269 42 entry))) l))
tonyg@269 43
tonyg@269 44 (cheap-struct relocation (target))
tonyg@269 45 (cheap-struct label-reference (name is-8bit))
tonyg@269 46 (cheap-struct label-anchor (name))
tonyg@252 47
tonyg@253 48 (define (flatten-and-pre-relocate instrs k)
tonyg@269 49 (define (walk instrs acc pos marks k)
tonyg@252 50 (if (null? instrs)
tonyg@269 51 (k acc pos marks)
tonyg@252 52 (let ((instr (car instrs))
tonyg@252 53 (rest (cdr instrs)))
tonyg@252 54 (cond
tonyg@269 55 ((or (relocation? instr)
tonyg@269 56 (label-anchor? instr)
tonyg@269 57 (label-reference? instr))
tonyg@269 58 (walk rest acc pos (cons (cons instr pos) marks) k))
tonyg@269 59 ((list? instr) (walk instr acc pos marks
tonyg@269 60 (lambda (acc pos marks)
tonyg@269 61 (walk rest acc pos marks k))))
tonyg@269 62 ((number? instr) (walk rest (cons instr acc) (+ pos 1) marks k))
tonyg@252 63 ((string? instr) (walk rest
tonyg@252 64 (append (reverse (map char->integer (string->list instr))) acc)
tonyg@252 65 (+ pos (string-length instr))
tonyg@269 66 marks
tonyg@252 67 k))
tonyg@252 68 (else (error "Invalid instruction in stream" instr))))))
tonyg@252 69 (walk instrs '() 0 '()
tonyg@269 70 (lambda (reversed-code final-length reversed-marks)
tonyg@269 71 (let* ((code (list->vector (reverse reversed-code)))
tonyg@269 72 (marks (reverse reversed-marks))
tonyg@269 73 (relocations (filter-map-alist relocation?
tonyg@269 74 (lambda (r p) (cons (relocation-target r) p))
tonyg@269 75 marks))
tonyg@269 76 (anchors (filter-map-alist label-anchor?
tonyg@269 77 (lambda (a p) (cons (label-anchor-name a) p))
tonyg@269 78 marks))
tonyg@269 79 (refs (filter-map-alist label-reference? #f marks)))
tonyg@269 80 (define (anchor-pos name)
tonyg@269 81 (cond
tonyg@269 82 ((assq name anchors) => cdr)
tonyg@269 83 (else (error "Undefined label-anchor" name))))
tonyg@269 84 (write `(code ,code))(newline)
tonyg@269 85 (write `(marks ,marks))(newline)
tonyg@269 86 (for-each (lambda (entry)
tonyg@269 87 (let ((name (label-reference-name (car entry)))
tonyg@269 88 (is-8bit (label-reference-is-8bit (car entry)))
tonyg@269 89 (pos (cdr entry)))
tonyg@269 90 (if is-8bit
tonyg@269 91 (let ((delta (- (anchor-pos name) (+ pos 1))))
tonyg@269 92 (if (onebyte-immediate? delta)
tonyg@269 93 (vector-set! code pos delta)
tonyg@269 94 (error "Short jump out of range" entry)))
tonyg@269 95 (let ((v (list->vector (imm32* (- (anchor-pos name) (+ pos 4))))))
tonyg@269 96 (vector-set! code (+ pos 0) (vector-ref v 0))
tonyg@269 97 (vector-set! code (+ pos 1) (vector-ref v 1))
tonyg@269 98 (vector-set! code (+ pos 2) (vector-ref v 2))
tonyg@269 99 (vector-set! code (+ pos 3) (vector-ref v 3))))))
tonyg@269 100 refs)
tonyg@269 101 (k code
tonyg@269 102 relocations)))))
tonyg@244 103
tonyg@254 104 (define (*ret) #xC3)
tonyg@244 105
tonyg@245 106 (define regs '((eax 0)
tonyg@245 107 (ecx 1)
tonyg@245 108 (edx 2)
tonyg@245 109 (ebx 3)
tonyg@245 110 (esp 4)
tonyg@245 111 (ebp 5)
tonyg@245 112 (esi 6)
tonyg@245 113 (edi 7)))
tonyg@244 114
tonyg@245 115 (define (reg-num reg)
tonyg@245 116 (cond
tonyg@245 117 ((assq reg regs) => cadr)
tonyg@245 118 (else (error "Invalid register" reg))))
tonyg@244 119
tonyg@246 120 (define %eax 'eax)
tonyg@246 121 (define %ecx 'ecx)
tonyg@246 122 (define %edx 'edx)
tonyg@246 123 (define %ebx 'ebx)
tonyg@246 124 (define %esp 'esp)
tonyg@246 125 (define %ebp 'ebp)
tonyg@246 126 (define %esi 'esi)
tonyg@246 127 (define %edi 'edi)
tonyg@246 128
tonyg@269 129 (define condition-codes '#((o)
tonyg@269 130 (no)
tonyg@269 131 (b nae)
tonyg@269 132 (nb ae)
tonyg@269 133 (e z)
tonyg@269 134 (ne nz)
tonyg@269 135 (be na)
tonyg@269 136 (nbe a)
tonyg@269 137 (s)
tonyg@269 138 (ns)
tonyg@269 139 (p pe)
tonyg@269 140 (np po)
tonyg@269 141 (l nge)
tonyg@269 142 (nl ge)
tonyg@269 143 (le ng)
tonyg@269 144 (nle g)))
tonyg@269 145
tonyg@269 146 (define (condition-code-num code-sym)
tonyg@269 147 (let loop ((i 0))
tonyg@269 148 (cond
tonyg@269 149 ((>= i 16) (error "Invalid condition-code" code-sym))
tonyg@269 150 ((member code-sym (vector-ref condition-codes i)) i)
tonyg@269 151 (else (loop (+ i 1))))))
tonyg@269 152
tonyg@269 153 (define specials '((undefined 0)
tonyg@269 154 (true 1)
tonyg@269 155 (false 2)
tonyg@269 156 (nil 3)))
tonyg@269 157
tonyg@269 158 (define (special-oop special-name)
tonyg@269 159 (cond
tonyg@269 160 ((assq special-name specials) =>
tonyg@269 161 (lambda (entry)
tonyg@269 162 (let ((special-num (cadr entry)))
tonyg@269 163 (+ 3 (* special-num 8)))))
tonyg@269 164 (else (error "Invalid special name" special-name))))
tonyg@269 165
tonyg@246 166 (define (register=? x y)
tonyg@246 167 (eq? x y))
tonyg@246 168
tonyg@245 169 (define (register? x)
tonyg@245 170 (symbol? x))
tonyg@245 171
tonyg@245 172 (define (immediate? x)
tonyg@252 173 (or (number? x)
tonyg@269 174 (relocation? x)
tonyg@269 175 (label-reference? x)))
tonyg@245 176
tonyg@245 177 (define (memory? x)
tonyg@245 178 (and (pair? x)
tonyg@245 179 (eq? (car x) '@)
tonyg@245 180 (pair? (cdr x))))
tonyg@245 181
tonyg@246 182 (define (@ base-reg . maybe-offset)
tonyg@246 183 (cond
tonyg@246 184 ((and (number? base-reg) (null? maybe-offset))
tonyg@246 185 (list '@ base-reg))
tonyg@246 186 ((and (register? base-reg) (pair? maybe-offset) (number? (car maybe-offset)))
tonyg@246 187 (list '@ base-reg (car maybe-offset)))
tonyg@246 188 (else
tonyg@246 189 (error "Invalid/unsupported memory reference" `(@ ,base-reg ,@maybe-offset)))))
tonyg@246 190
tonyg@245 191 (define (memory-base-reg-or-absolute x)
tonyg@245 192 (cadr x))
tonyg@245 193
tonyg@245 194 (define (absolute-memory? x)
tonyg@245 195 (and (memory? x)
tonyg@245 196 (number? (memory-base-reg-or-absolute x))))
tonyg@245 197
tonyg@245 198 (define (bitfield . args)
tonyg@245 199 (define (loop acc args)
tonyg@245 200 ;;(write `(bitfield-loop ,acc ,args))(newline)
tonyg@245 201 (if (null? args)
tonyg@245 202 acc
tonyg@245 203 (let* ((width-parameter (car args))
tonyg@245 204 (signed? (negative? width-parameter))
tonyg@245 205 (width-in-bits (abs width-parameter))
tonyg@245 206 (limit (inexact->exact (expt 2 width-in-bits))))
tonyg@245 207 (let ((value (cadr args)))
tonyg@245 208 (if (if signed?
tonyg@245 209 (let ((half-limit (quotient limit 2)))
tonyg@245 210 (or (>= value half-limit)
tonyg@245 211 (< value (- half-limit))))
tonyg@245 212 (or (>= value limit)
tonyg@245 213 (< value 0)))
tonyg@245 214 (error "Value exceeds bitfield width" (list width-parameter value))
tonyg@245 215 (loop (+ (* acc limit) (modulo value limit))
tonyg@245 216 (cddr args)))))))
tonyg@245 217 ;;(write `(bitfield ,@args))(newline)
tonyg@245 218 (loop 0 args))
tonyg@245 219
tonyg@245 220 ;; In 32-bit mode, #x66 is the 16-bit-operand override prefix
tonyg@245 221
tonyg@245 222 (define (mod-r-m* mod reg rm)
tonyg@245 223 (bitfield 2 mod 3 reg 3 rm))
tonyg@245 224
tonyg@252 225 (define (onebyte-immediate? n)
tonyg@252 226 (and (number? n) (< n 128) (>= n -128)))
tonyg@252 227
tonyg@252 228 (define (imm8 i)
tonyg@252 229 (modulo i 256))
tonyg@252 230
tonyg@252 231 (define (imm32* i)
tonyg@252 232 (list (modulo i 256)
tonyg@252 233 (modulo (shr i 8) 256)
tonyg@252 234 (modulo (shr i 16) 256)
tonyg@252 235 (modulo (shr i 24) 256)))
tonyg@244 236
tonyg@244 237 (define (imm32 i)
tonyg@269 238 (if (or (relocation? i) (label-reference? i))
tonyg@269 239 (list i 0 0 0 0)
tonyg@252 240 (imm32* i)))
tonyg@244 241
tonyg@245 242 (define (imm32-if test-result i)
tonyg@252 243 (if test-result (imm32 i) (imm8 i)))
tonyg@244 244
tonyg@256 245 ;; Mod values:
tonyg@256 246 ;; 00 - no displacement, [reg]
tonyg@256 247 ;; 01 - 8bit displacement, [reg + n]
tonyg@256 248 ;; 10 - 32bit displacement, [reg + n]
tonyg@256 249 ;; 11 - direct, reg
tonyg@245 250 (define (mod-r-m reg modrm)
tonyg@245 251 (let ((reg (cond
tonyg@245 252 ((number? reg) reg)
tonyg@245 253 ((register? reg) (reg-num reg))
tonyg@245 254 (else (error "mod-r-m needs a number or a register for reg" reg)))))
tonyg@245 255 (cond
tonyg@245 256 ((register? modrm)
tonyg@245 257 (mod-r-m* 3 reg (reg-num modrm)))
tonyg@245 258 ((memory? modrm)
tonyg@245 259 (let ((base-reg (memory-base-reg-or-absolute modrm))
tonyg@245 260 (offset (if (null? (cddr modrm)) 0 (caddr modrm))))
tonyg@245 261 (if (absolute-memory? modrm)
tonyg@245 262 ;; raw absolute address, always 32 bits
tonyg@245 263 (list (mod-r-m* 0 reg 5) (imm32 base-reg))
tonyg@245 264 (let ((mod (cond
tonyg@245 265 ((zero? offset) 0)
tonyg@252 266 ((onebyte-immediate? offset) 1)
tonyg@245 267 (else 2)))
tonyg@245 268 (offset-bytes (cond
tonyg@245 269 ((zero? offset) '())
tonyg@252 270 ((onebyte-immediate? offset) (imm8 offset))
tonyg@245 271 (else (imm32 offset)))))
tonyg@246 272 (if (register=? base-reg %esp)
tonyg@245 273 ;; can't directly use base reg, must use scaled indexing
tonyg@245 274 (list (mod-r-m* mod reg 4) #x24 offset-bytes)
tonyg@245 275 ;; normal
tonyg@245 276 (list (mod-r-m* mod reg (reg-num base-reg)) offset-bytes))))))
tonyg@245 277 (else (error "mod-r-m needs a register or memory for modrm" modrm)))))
tonyg@252 278
tonyg@245 279 (define (arithmetic-opcode opcode)
tonyg@245 280 (cond
tonyg@245 281 ((assq opcode '((add 0) (or 1) (adc 2) (sbb 3) (and 4) (sub 5) (xor 6) (cmp 7))) => cadr)
tonyg@245 282 (else (error "arithmetic-opcode: Invalid opcode" opcode))))
tonyg@244 283
tonyg@249 284 (define (*op opcode source target . maybe-8bit)
tonyg@245 285 (let ((opcode (arithmetic-opcode opcode))
tonyg@245 286 (w-bit (if (null? maybe-8bit) 1 (if (car maybe-8bit) 0 1))))
tonyg@245 287 (cond
tonyg@245 288 ((immediate? source)
tonyg@252 289 (let ((s-bit (if (and (= w-bit 1) (onebyte-immediate? source)) 1 0)))
tonyg@246 290 (if (register=? target %eax)
tonyg@245 291 (list (bitfield 2 0 3 opcode 2 2 1 w-bit)
tonyg@245 292 (imm32-if (= w-bit 1) source))
tonyg@245 293 (list (bitfield 2 2 3 0 1 0 1 s-bit 1 w-bit)
tonyg@245 294 (mod-r-m opcode target)
tonyg@252 295 (imm32-if (and (= w-bit 1) (not (onebyte-immediate? source))) source)))))
tonyg@245 296 ((memory? source)
tonyg@245 297 (cond
tonyg@245 298 ((not (register? target))
tonyg@246 299 (error "*op: Cannot have memory source and non-register target"
tonyg@249 300 (list opcode source target)))
tonyg@245 301 (else
tonyg@245 302 (list (bitfield 2 0 3 opcode 2 1 1 w-bit) (mod-r-m target source)))))
tonyg@245 303 ((register? source)
tonyg@245 304 (cond
tonyg@245 305 ((or (memory? target) (register? target))
tonyg@245 306 (list (bitfield 2 0 3 opcode 2 0 1 w-bit) (mod-r-m source target)))
tonyg@245 307 (else
tonyg@246 308 (error "*op: Cannot have register source and non-mem, non-reg target"
tonyg@249 309 (list opcode source target)))))
tonyg@245 310 (else
tonyg@246 311 (error "*op: Invalid source"
tonyg@249 312 (list opcode source target))))))
tonyg@244 313
tonyg@249 314 (define (*mov source target . maybe-8bit)
tonyg@245 315 (let ((w-bit (if (null? maybe-8bit) 1 (if (car maybe-8bit) 0 1))))
tonyg@245 316 (cond
tonyg@245 317 ((immediate? source)
tonyg@245 318 (if (register? target)
tonyg@245 319 ;; special alternate encoding
tonyg@245 320 (list (bitfield 4 #b1011 1 w-bit 3 (reg-num target))
tonyg@245 321 (imm32-if (= w-bit 1) source))
tonyg@245 322 (list (bitfield 2 3 3 0 2 3 1 w-bit)
tonyg@269 323 (mod-r-m 0 target)
tonyg@245 324 (imm32-if (= w-bit 1) source))))
tonyg@245 325 ((memory? source)
tonyg@245 326 (cond
tonyg@246 327 ((and (absolute-memory? source) (register=? target %eax))
tonyg@245 328 ;; special alternate encoding
tonyg@245 329 (list (bitfield 7 #b1010000 1 w-bit) (imm32 (memory-base-reg-or-absolute source))))
tonyg@245 330 ((not (register? target))
tonyg@249 331 (error "*mov: Cannot have memory source and non-register target" (list source target)))
tonyg@245 332 (else
tonyg@245 333 (list (bitfield 2 2 3 1 2 1 1 w-bit) (mod-r-m target source)))))
tonyg@245 334 ((register? source)
tonyg@245 335 (cond
tonyg@246 336 ((and (absolute-memory? target) (register=? source %eax))
tonyg@245 337 ;; special alternate encoding
tonyg@245 338 (list (bitfield 7 #b1010001 1 w-bit) (imm32 (memory-base-reg-or-absolute target))))
tonyg@245 339 ((or (memory? target) (register? target))
tonyg@245 340 (list (bitfield 2 2 3 1 2 0 1 w-bit) (mod-r-m source target)))
tonyg@245 341 (else
tonyg@245 342 (error "*mov: Cannot have register source and non-mem, non-reg target"
tonyg@249 343 (list source target)))))
tonyg@245 344 (else
tonyg@249 345 (error "*mov: Invalid source" (list source target))))))
tonyg@244 346
tonyg@269 347 (define (*call-or-jmp-like immediate-opcode indirect-mod loc)
tonyg@252 348 (cond
tonyg@252 349 ((immediate? loc)
tonyg@269 350 (list immediate-opcode (imm32 loc)))
tonyg@252 351 ((or (register? loc) (memory? loc))
tonyg@269 352 (list #xFF (mod-r-m indirect-mod loc)))
tonyg@252 353 (else
tonyg@269 354 (error "*call/*jmp: Invalid location" loc))))
tonyg@269 355
tonyg@269 356 (define (*call loc)
tonyg@269 357 (*call-or-jmp-like #xE8 2 loc))
tonyg@269 358
tonyg@269 359 (define (is-short-jump? loc)
tonyg@269 360 (and (label-reference? loc)
tonyg@269 361 (label-reference-is-8bit loc)))
tonyg@269 362
tonyg@269 363 (define (*jmp loc)
tonyg@269 364 (if (is-short-jump? loc)
tonyg@269 365 (list #xEB loc 0)
tonyg@269 366 (*call-or-jmp-like #xE9 4 loc)))
tonyg@269 367
tonyg@269 368 (define (*jmp-cc code loc)
tonyg@269 369 (write `(*jmp-cc ,code ,loc))(newline)
tonyg@269 370 (let ((tttn (condition-code-num code)))
tonyg@269 371 (if (is-short-jump? loc)
tonyg@269 372 (list (bitfield 4 7 4 tttn) loc 0)
tonyg@269 373 (list #x0F (bitfield 4 8 4 tttn) (imm32 loc)))))
tonyg@252 374
tonyg@244 375 (define (push32 reg)
tonyg@245 376 (mod-r-m* 1 2 (reg-num reg)))
tonyg@244 377
tonyg@244 378 (define (pop32 reg)
tonyg@245 379 (mod-r-m* 1 3 (reg-num reg)))
tonyg@244 380
tonyg@249 381 (define (_CAR) (*mov (@ %eax 4) %eax))
tonyg@249 382 (define (_CDR) (*mov (@ %eax 8) %eax))
tonyg@244 383
tonyg@252 384 (define (*getip reg)
tonyg@252 385 (list (*call 0)
tonyg@252 386 (pop32 reg)))
tonyg@252 387
tonyg@244 388 (define (code->binary codevec)
tonyg@269 389 (list->string (map integer->char (vector->list codevec))))
tonyg@244 390
tonyg@244 391 (define (simple-function . instrs)
tonyg@253 392 (flatten-and-pre-relocate
tonyg@253 393 instrs
tonyg@253 394 (lambda (code relocs)
tonyg@253 395 (write `((code ,code) (relocs ,relocs))) (newline)
tonyg@253 396 (let ((bin (code->binary code)))
tonyg@253 397 (disassemble bin)
tonyg@253 398 (build-native-function bin relocs)))))
tonyg@244 399
tonyg@255 400 (define (round-up-to-nearest n val)
tonyg@255 401 (let ((temp (+ val n -1)))
tonyg@255 402 (- temp (remainder temp n))))
tonyg@255 403
tonyg@255 404 (define (prelude-function locals-frame-size . instrs)
tonyg@255 405 (let* ((existing-unaccounted-for-padding 8) ;; eip and ebp, just before stack adjustment
tonyg@255 406 (total-required-space (+ existing-unaccounted-for-padding locals-frame-size))
tonyg@255 407 (total-adjustment (- (round-up-to-nearest 16 total-required-space)
tonyg@255 408 existing-unaccounted-for-padding)))
tonyg@255 409 (simple-function (push32 %ebp)
tonyg@255 410 (*mov %esp %ebp)
tonyg@255 411 (*op 'sub total-adjustment %esp)
tonyg@255 412 instrs
tonyg@255 413 (*mov %ebp %esp)
tonyg@255 414 (pop32 %ebp)
tonyg@255 415 (*ret))))
tonyg@255 416
tonyg@244 417 (define x (simple-function
tonyg@249 418 (*mov (@ %esp 8) %eax)
tonyg@244 419 (_CAR)
tonyg@254 420 (*ret)))
tonyg@244 421
tonyg@244 422 (define real-code (list #x55 #x89 #xe5 #x83 #xec #x08 #x8b #x45 #x0c #xc9 #xc3))
tonyg@244 423
tonyg@255 424 (define y (prelude-function 0
tonyg@249 425 (*mov (@ %ebp 12) %eax)
tonyg@255 426 (_CAR)))
tonyg@254 427
tonyg@254 428 (define mk_integer-addr (lookup-native-symbol "mk_integer"))
tonyg@254 429 (define get-native-function-addr
tonyg@255 430 (prelude-function 8
tonyg@254 431 (*mov (@ %ebp 8) %ecx)
tonyg@254 432 (*mov (@ %ebp 12) %eax)
tonyg@254 433 (_CAR)
tonyg@254 434 (_CAR) ;; function pointer is in car slot
tonyg@254 435 (*mov %ecx (@ %esp 0))
tonyg@254 436 (*mov %eax (@ %esp 4))
tonyg@269 437 (*call (make-relocation mk_integer-addr))))
tonyg@252 438
tonyg@252 439 (define puts-addr (lookup-native-symbol "puts"))
tonyg@255 440 (define puts (prelude-function 4
tonyg@252 441 (*mov (@ %ebp 12) %eax)
tonyg@252 442 (_CAR)
tonyg@252 443 (*mov (@ %eax 4) %eax)
tonyg@252 444 (*mov %eax (@ %esp 0))
tonyg@252 445
tonyg@252 446 ;(*mov puts-addr %eax)
tonyg@252 447 ;(*call %eax)
tonyg@269 448 (*call (make-relocation puts-addr))
tonyg@252 449
tonyg@255 450 (*mov (@ %ebp 12) %eax)))
tonyg@252 451
tonyg@252 452 (puts "Hello world")
tonyg@258 453
tonyg@258 454 (load "evaluator.scm")
tonyg@258 455
tonyg@258 456 (define (make-parameter v)
tonyg@258 457 (lambda args
tonyg@258 458 (if (null? args)
tonyg@258 459 v
tonyg@258 460 (begin
tonyg@258 461 (set! v (car args))
tonyg@258 462 v))))
tonyg@258 463
tonyg@258 464 (macro (parameterize form)
tonyg@258 465 (let ((bindings0 (cadr form))
tonyg@258 466 (body (cddr form)))
tonyg@258 467 (let ((bindings (map (lambda (entry) (cons (gensym "p") entry)) bindings0))
tonyg@258 468 (retval (gensym "prv")))
tonyg@258 469 `(let ,(map (lambda (entry)
tonyg@258 470 `(,(car entry) (,(cadr entry))))
tonyg@258 471 bindings)
tonyg@258 472 ,@(map (lambda (entry)
tonyg@258 473 `(,(cadr entry) ,(caddr entry)))
tonyg@258 474 bindings)
tonyg@258 475 (let ((,retval (begin ,@body)))
tonyg@258 476 ,@(map (lambda (entry)
tonyg@258 477 `(,(cadr entry) ,(car entry)))
tonyg@258 478 bindings)
tonyg@258 479 ,retval)))))
tonyg@258 480
tonyg@258 481 (define-global! 'jit-compile
tonyg@258 482 (lambda (exp)
tonyg@269 483 (let ((env-accumulator #f)
tonyg@269 484
tonyg@269 485 (continuation-depth (make-parameter 0))
tonyg@269 486 (instruction-rev-acc (make-parameter '()))
tonyg@269 487 (frame-depth (make-parameter 0))
tonyg@269 488 (frame-stack (make-parameter '())))
tonyg@269 489
tonyg@269 490 (define (dp term)
tonyg@269 491 (display (make-string (* 2 (length (frame-stack))) #\ ))
tonyg@269 492 (write term)
tonyg@269 493 (newline))
tonyg@269 494
tonyg@269 495 ;; -- Data types used to represent partial values
tonyg@269 496
tonyg@269 497 (cheap-struct argument (number))
tonyg@269 498 (cheap-struct literal (number))
tonyg@269 499 (cheap-struct recursive-binding (number frame-depth))
tonyg@269 500
tonyg@269 501 ;; -- Interface to assembler
tonyg@269 502
tonyg@269 503 (define (emit! . instrs)
tonyg@269 504 (dp `(emit! ,@instrs))
tonyg@269 505 (instruction-rev-acc (cons instrs (instruction-rev-acc))))
tonyg@269 506
tonyg@269 507 (define (*mov-to-eax source)
tonyg@269 508 (if (and (register? source)
tonyg@269 509 (register=? source %eax))
tonyg@269 510 '()
tonyg@269 511 (*mov source %eax)))
tonyg@269 512
tonyg@269 513 (define (location-for-value v)
tonyg@269 514 (cond
tonyg@269 515 ((argument? v) (@ %esp (+ (frame-depth) (* (+ (argument-number v) 1) 4))))
tonyg@269 516 ((literal? v) (literal-number v))
tonyg@269 517 ((recursive-binding? v) (@ %esp (+ (- (frame-depth) (recursive-binding-frame-depth v))
tonyg@269 518 (* (+ (recursive-binding-number v) 1) -4))))
tonyg@269 519 ((or (register? v) (memory? v) (immediate? v)) v)
tonyg@269 520 (else (error "Invalid PE value" v))))
tonyg@269 521
tonyg@269 522 (define (move-esp-by! slot-count)
tonyg@269 523 (when (not (zero? slot-count))
tonyg@269 524 (let ((nbytes (abs (* slot-count 4))))
tonyg@269 525 (emit! (*op (if (positive? slot-count) 'add 'sub) nbytes %esp))
tonyg@269 526 (frame-depth ((if (positive? slot-count) - +) (frame-depth) nbytes)))))
tonyg@269 527
tonyg@269 528 (define (allocate! nwords)
tonyg@269 529 (let ((ok-label (gensym "allocok")))
tonyg@269 530 (emit! (*mov %esi %eax)
tonyg@269 531 (*op 'add (* nwords 4) %esi)
tonyg@269 532 (*op 'cmp %esi %edi)
tonyg@269 533 (*jmp-cc 'ge (make-label-reference ok-label #t))
tonyg@269 534 (*mov %eax %esi)
tonyg@269 535 (*mov (* nwords 4) %eax))
tonyg@269 536 (trap! 0)
tonyg@269 537 (emit! (make-label-anchor ok-label))))
tonyg@269 538
tonyg@269 539 (define (push-frame* count)
tonyg@269 540 (dp `(push-frame* ,count (frame-stack ,(frame-stack))))
tonyg@269 541 (when (positive? count)
tonyg@269 542 (move-esp-by! (- count)))
tonyg@269 543 (frame-stack (cons count (frame-stack))))
tonyg@269 544
tonyg@269 545 (define (pop-frame*)
tonyg@269 546 (dp `(pop-frame* (frame-stack ,(frame-stack))))
tonyg@269 547 (let ((count (car (frame-stack))))
tonyg@269 548 (when (positive? count)
tonyg@269 549 (move-esp-by! (car (frame-stack))))
tonyg@269 550 (frame-stack (cdr (frame-stack)))))
tonyg@269 551
tonyg@269 552 ;; -- Interpreter-core API
tonyg@269 553
tonyg@269 554 ;;(define (error key val)
tonyg@269 555 ;;...?)
tonyg@269 556
tonyg@269 557 (define (undefined)
tonyg@269 558 (special-oop 'undefined))
tonyg@269 559
tonyg@269 560 (define (begin-env is-recursive env)
tonyg@269 561 (dp `(begin-env ,is-recursive))
tonyg@269 562 (set! env-accumulator (if is-recursive 0 #f))
tonyg@269 563 env)
tonyg@269 564
tonyg@258 565 (define (allocate-env name v)
tonyg@269 566 (dp `(allocate-env ,name ,v))
tonyg@269 567 (if env-accumulator
tonyg@269 568 (let ((a (make-recursive-binding env-accumulator (frame-depth))))
tonyg@269 569 (set! env-accumulator (+ env-accumulator 1))
tonyg@269 570 a)
tonyg@269 571 (or v (undefined))))
tonyg@269 572
tonyg@269 573 (define (end-env is-recursive env)
tonyg@269 574 (dp `(end-env ,is-recursive (env-accumulator ,env-accumulator)))
tonyg@269 575 (when is-recursive
tonyg@269 576 (push-frame* env-accumulator)
tonyg@269 577 (set! env-accumulator #f))
tonyg@269 578 env)
tonyg@269 579
tonyg@269 580 (define (leave-env is-recursive v k)
tonyg@269 581 (dp `(leave-env ,is-recursive ,v))
tonyg@269 582 (when is-recursive
tonyg@269 583 (pop-frame*))
tonyg@269 584 (k v))
tonyg@269 585
tonyg@258 586 (define (update-env name old-annotation v)
tonyg@269 587 (dp `(update-env ,name ,old-annotation ,v))
tonyg@269 588 v)
tonyg@269 589
tonyg@258 590 (define (load-env name annotation v)
tonyg@269 591 (dp `(load-env ,name ,annotation ,v))
tonyg@269 592 (let ((loc (location-for-value annotation)))
tonyg@269 593 (if (immediate? loc)
tonyg@269 594 loc
tonyg@269 595 (begin
tonyg@269 596 (emit! (*mov-to-eax loc))
tonyg@269 597 %eax))))
tonyg@269 598
tonyg@258 599 (define (unbound-variable-read name)
tonyg@269 600 (dp `(load-implicit-global ,name))
tonyg@269 601 (let ((symloc (load-literal name)))
tonyg@269 602 (emit! (*mov (@ %eax 8) %eax)) ;; symbol's value -- FIXME, guessing about future
tonyg@269 603 %eax))
tonyg@269 604
tonyg@258 605 (define (load-literal x)
tonyg@269 606 (dp `(load-literal ,x))
tonyg@269 607 (let ((value (cond
tonyg@269 608 ((number? x) (+ 1 (* 4 x)))
tonyg@269 609 ((symbol? x) #x42424242)
tonyg@269 610 ((eq? x #t) (special-oop 'true))
tonyg@269 611 ((eq? x #f) (special-oop 'false))
tonyg@269 612 (else (error "Unsupported literal type" x)))))
tonyg@269 613 ;;(emit! (*mov-to-eax value))
tonyg@269 614 ;;%eax
tonyg@269 615 value))
tonyg@269 616
tonyg@258 617 (define (load-closure formals f)
tonyg@269 618 (dp `(load-closure ,formals))
tonyg@269 619 (parameterize ((continuation-depth 0)
tonyg@269 620 (instruction-rev-acc '())
tonyg@269 621 (frame-depth 0)
tonyg@269 622 (frame-stack '()))
tonyg@269 623 (dp `=============================================)
tonyg@269 624 (f (do ((number 0 (+ number 0))
tonyg@269 625 (acc '() (cons (make-argument number) acc))
tonyg@269 626 (formals formals (cdr formals)))
tonyg@269 627 ((null? formals) (reverse acc)))
tonyg@269 628 (lambda (v)
tonyg@269 629 (dp `---------------------------------------------)
tonyg@269 630 (emit! (*mov-to-eax v)
tonyg@269 631 (*ret))
tonyg@269 632 (get-native-function-addr
tonyg@269 633 (simple-function (reverse (instruction-rev-acc))))))))
tonyg@269 634
tonyg@269 635 (define (do-if v tg fg k)
tonyg@269 636 (let ((false-label (gensym "testfalse"))
tonyg@269 637 (done-label (gensym "testdone")))
tonyg@269 638 (dp `(do-if ,v))
tonyg@269 639 (emit! (*op 'cmp (special-oop 'false) v)
tonyg@269 640 (*jmp-cc 'e (make-label-reference false-label #f)))
tonyg@269 641 (dp `tg)
tonyg@269 642 (tg (lambda (true-v)
tonyg@269 643 (emit! (*mov-to-eax true-v)
tonyg@269 644 (*jmp (make-label-reference done-label #f))
tonyg@269 645 (make-label-anchor false-label))
tonyg@269 646 (dp `fg)
tonyg@269 647 (fg (lambda (false-v)
tonyg@269 648 (emit! (*mov-to-eax false-v)
tonyg@269 649 (make-label-anchor done-label))
tonyg@269 650 (dp `done-if)
tonyg@269 651 (k %eax)))))))
tonyg@269 652
tonyg@258 653 (define (push-frame count k)
tonyg@269 654 (dp `(push-frame ,count))
tonyg@269 655 (push-frame* count)
tonyg@258 656 k)
tonyg@269 657
tonyg@258 658 (define (update-frame index v)
tonyg@269 659 (dp `(update-frame ,index ,v))
tonyg@269 660 (let ((loc (@ %esp (* index 4))))
tonyg@269 661 (emit! (*mov v loc))
tonyg@269 662 loc))
tonyg@269 663
tonyg@258 664 (define (do-primitive names vals expressions k)
tonyg@269 665 (dp `(%assemble ,names ,vals ,expressions))
tonyg@258 666 (k 'primitive-result))
tonyg@269 667
tonyg@258 668 (define (do-call operator operands k)
tonyg@269 669 (dp `(do-call ,(if (= (continuation-depth) 0)
tonyg@258 670 'tailcall
tonyg@258 671 'normalcall) ,operator ,operands))
tonyg@269 672 (let ((loc (location-for-value operator)))
tonyg@269 673 (if (immediate? loc)
tonyg@269 674 ;; Always absolute
tonyg@269 675 (emit! (*call (make-relocation loc)))
tonyg@269 676 (emit! (*call loc))))
tonyg@269 677 (pop-frame*)
tonyg@269 678 (k %eax)) ;;;;;;'do-call-result))
tonyg@269 679
tonyg@258 680 (define (push-continuation k)
tonyg@258 681 (continuation-depth (+ (continuation-depth) 1))
tonyg@269 682 ;;(dp `(push-continuation ,(continuation-depth)))
tonyg@258 683 (lambda (v)
tonyg@269 684 ;;(dp `(pop-continuation ,(continuation-depth) ,v))
tonyg@258 685 (continuation-depth (- (continuation-depth) 1))
tonyg@258 686 (k v)))
tonyg@269 687
tonyg@269 688 ((make-eval error undefined begin-env allocate-env end-env leave-env update-env load-env
tonyg@269 689 unbound-variable-read load-literal load-closure do-if push-frame update-frame
tonyg@258 690 do-primitive do-call push-continuation)
tonyg@258 691 exp))))
tonyg@258 692
tonyg@269 693 (define (t1)
tonyg@269 694 (jit-compile '(lambda (num)
tonyg@269 695 (= num 0))))
tonyg@269 696
tonyg@269 697 (define (t2)
tonyg@269 698 (jit-compile '(lambda (num)
tonyg@269 699 (define (f n) (if (zero? n) 1 (* n (f (- n 1)))))
tonyg@269 700 (f num))))
tonyg@269 701