conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Added a disassembler tool for 64-bit code (using macos otool64). Also, 

passed more tests in 64-bit mode.
This commit is contained in:
Abdulaziz Ghuloum 2008-01-03 23:03:22 -05:00
parent 3b8eb4bbd4
commit 5d2f14c523
4 changed files with 179 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

144
scheme/ikarus.intel-assembler.ss
View File

@ -191,25 +191,29 @@
(cons (byte #x24) ac) (cons (byte #x24) ac)
ac)))) ac))))
(define IMM32 (define IMM
(lambda (n ac) (lambda (n ac)
(cond (cond
[(int? n) [(int? n)
(if (fixnum? n) (case wordsize
(cons* [(4)
(byte n) (cons*
(byte (sra n 8)) (byte n)
(byte (sra n 16)) (byte (sra n 8))
(byte (sra n 24)) (byte (sra n 16))
ac) (byte (sra n 24))
(let* ([lo (remainder n 256)] ac)]
[hi (quotient (if (< n 0) (- n 255) n) 256)]) [else
(cons* (cons*
(byte lo) (byte n)
(byte hi) (byte (sra n 8))
(byte (sra hi 8)) (byte (sra n 16))
(byte (sra hi 16)) (byte (sra n 24))
ac)))] (byte (sra n 32))
(byte (sra n 40))
(byte (sra n 48))
(byte (sra n 56))
ac)])]
[(obj? n) [(obj? n)
(let ([v (cadr n)]) (let ([v (cadr n)])
(if (immediate? v) (if (immediate? v)
@ -224,7 +228,7 @@
(cons (cons 'foreign-label (label-name n)) ac)] (cons (cons 'foreign-label (label-name n)) ac)]
[(label? n) [(label? n)
(cons (cons 'relative (label-name n)) ac)] (cons (cons 'relative (label-name n)) ac)]
[else (die 'IMM32 "invalid" n)]))) [else (die 'IMM "invalid" n)])))
(define IMM8 (define IMM8
@ -280,7 +284,7 @@
[(imm8? i) [(imm8? i)
(CODE c (ModRM 1 d s (IMM8 i ac)))] (CODE c (ModRM 1 d s (IMM8 i ac)))]
[(imm? i) [(imm? i)
(CODE c (ModRM 2 d s (IMM32 i ac)))] (CODE c (ModRM 2 d s (IMM i ac)))]
[else (die 'CODErri "invalid i" i)]))) [else (die 'CODErri "invalid i" i)])))
(define CODErr (define CODErr
@ -299,14 +303,14 @@
(fxsll (register-index r3) 3))) (fxsll (register-index r3) 3)))
ac)]))) ac)])))
(define IMM32*2 (define IMM*2
(lambda (i1 i2 ac) (lambda (i1 i2 ac)
(cond (cond
[(and (int? i1) (obj? i2)) [(and (int? i1) (obj? i2))
(let ([d i1] [v (cadr i2)]) (let ([d i1] [v (cadr i2)])
(cons (reloc-word+ v d) ac))] (cons (reloc-word+ v d) ac))]
[(and (int? i2) (obj? i1)) (IMM32*2 i2 i1 ac)] [(and (int? i2) (obj? i1)) (IMM*2 i2 i1 ac)]
[else (die 'assemble "invalid IMM32*2" i1 i2)]))) [else (die 'assemble "invalid IMM*2" i1 i2)])))
(define (SIB s i b ac) (define (SIB s i b ac)
(cons (byte (cons (byte
@ -317,6 +321,13 @@
(fxsll s 6)))) (fxsll s 6))))
ac)) ac))
(define (imm32? x)
(case wordsize
[(4) (imm? x)]
[(8)
(and (integer? x)
(<= (- (expt 2 31)) x (- (expt 2 31) 1)))]
[else (error 'imm32? "invalid wordsize" wordsize)]))
(define *cogen* (gensym "*cogen*")) (define *cogen* (gensym "*cogen*"))
@ -368,15 +379,15 @@
[(and (imm8? a0) (reg32? a1)) [(and (imm8? a0) (reg32? a1))
(ModRM 1 /d a1 (IMM8 a0 ac))] (ModRM 1 /d a1 (IMM8 a0 ac))]
[(and (imm? a0) (reg32? a1)) [(and (imm? a0) (reg32? a1))
(ModRM 2 /d a1 (IMM32 a0 ac))] (ModRM 2 /d a1 (IMM a0 ac))]
[(and (imm8? a1) (reg32? a0)) [(and (imm8? a1) (reg32? a0))
(ModRM 1 /d a0 (IMM8 a1 ac))] (ModRM 1 /d a0 (IMM8 a1 ac))]
[(and (imm? a1) (reg32? a0)) [(and (imm? a1) (reg32? a0))
(ModRM 2 /d a0 (IMM32 a1 ac))] (ModRM 2 /d a0 (IMM a1 ac))]
[(and (reg32? a0) (reg32? a1)) [(and (reg32? a0) (reg32? a1))
(RegReg /d a0 a1 ac)] (RegReg /d a0 a1 ac)]
[(and (imm? a0) (imm? a1)) [(and (imm? a0) (imm? a1))
(ModRM 0 /d '/5 (IMM32*2 a0 a1 ac))] (ModRM 0 /d '/5 (IMM*2 a0 a1 ac))]
[else (die 'RM "unhandled" a0 a1)])))] [else (die 'RM "unhandled" a0 a1)])))]
[(reg? dst) (ModRM 3 /d dst ac)] [(reg? dst) (ModRM 3 /d dst ac)]
[else (die 'RM "unhandled" dst)])) [else (die 'RM "unhandled" dst)]))
@ -384,14 +395,6 @@
(module () (module ()
(define who 'assembler) (define who 'assembler)
(define (REX.R bits ac)
(cons (fxlogor #b01000000 bits) ac))
(define (REX+r r ac)
(cond
[(reg-requires-REX? r) (REX.R #b001 ac)]
[else ac]))
(define (REX+RM r rm ac) (define (REX+RM r rm ac)
(define (C n ac) (define (C n ac)
(printf "CASE ~s\n" n) (printf "CASE ~s\n" n)
@ -455,30 +458,45 @@
ac))] ac))]
[else (die 'REX+RM "unhandled" rm)])) [else (die 'REX+RM "unhandled" rm)]))
(define (REX.R bits ac)
(when (eqv? wordsize 4)
(error 'ikarus "BUG: REX.R invalid in 32-bit mode"))
(cons (fxlogor #b01001000 bits) ac))
(define (REX+r r ac)
(cond
[(eqv? wordsize 4) ac]
[(reg-requires-REX? r) (REX.R #b001 ac)]
[else (REX.R #b000 ac)]))
(define (CR c r ac) (define (CR c r ac)
(REX+r r (CODE+r c r ac))) (REX+r r (CODE+r c r ac)))
(define (CR* c r rm ac) (define (CR* c r rm ac)
(REX+RM r rm (CODE c (RM r rm ac)))) (CODE c (RM r rm ac)))
;(REX+RM r rm (CODE c (RM r rm ac))))
(define (CCR* c0 c1 r rm ac) (define (CCR* c0 c1 r rm ac)
(REX+RM r rm (CODE c0 (CODE c1 (RM r rm ac))))) (CODE c0 (CODE c1 (RM r rm ac))))
;(REX+RM r rm (CODE c0 (CODE c1 (RM r rm ac)))))
(define (CCR c0 c1 r ac) (define (CCR c0 c1 r ac)
(REX+r r (CODE c0 (CODE+r c1 r ac)))) (CODE c0 (CODE+r c1 r ac)))
;(REX+r r (CODE c0 (CODE+r c1 r ac))))
(define (CCCR* c0 c1 c2 r rm ac) (define (CCCR* c0 c1 c2 r rm ac)
(REX+RM r rm (CODE c0 (CODE c1 (CODE c2 (RM r rm ac)))))) (CODE c0 (CODE c1 (CODE c2 (RM r rm ac)))))
;(REX+RM r rm (CODE c0 (CODE c1 (CODE c2 (RM r rm ac))))))
(define (CCI32 c0 c1 i32 ac) (define (CCI32 c0 c1 i32 ac)
(CODE c0 (CODE c1 (IMM32 i32 ac)))) (CODE c0 (CODE c1 (IMM i32 ac))))
(add-instructions instr ac (add-instructions instr ac
[(ret) (CODE #xC3 ac)] [(ret) (CODE #xC3 ac)]
[(cltd) (CODE #x99 ac)] [(cltd) (CODE #x99 ac)]
[(movl src dst) [(movl src dst)
(cond (cond
[(and (imm? src) (reg32? dst)) (CR #xB8 dst (IMM32 src ac))] [(and (imm? src) (reg? dst)) (CR #xB8 dst (IMM src ac))]
[(and (imm? src) (mem? dst)) (CR* #xC7 '/0 dst (IMM32 src ac))] [(and (imm? src) (mem? dst)) (CR* #xC7 '/0 dst (IMM src ac))]
[(and (reg32? src) (reg32? dst)) (CR* #x89 src dst ac)] [(and (reg32? src) (reg32? dst)) (CR* #x89 src dst ac)]
[(and (reg32? src) (mem? dst)) (CR* #x89 src dst ac)] [(and (reg32? src) (mem? dst)) (CR* #x89 src dst ac)]
[(and (mem? src) (reg32? dst)) (CR* #x8B dst src ac)] [(and (mem? src) (reg32? dst)) (CR* #x8B dst src ac)]
@ -492,21 +510,21 @@
[(addl src dst) [(addl src dst)
(cond (cond
[(and (imm8? src) (reg32? dst)) (CR* #x83 '/0 dst (IMM8 src ac))] [(and (imm8? src) (reg32? dst)) (CR* #x83 '/0 dst (IMM8 src ac))]
[(and (imm? src) (eq? dst '%eax)) (CODE #x05 (IMM32 src ac))] [(and (imm? src) (eq? dst '%eax)) (CODE #x05 (IMM src ac))]
[(and (imm? src) (reg32? dst)) (CR* #x81 '/0 dst (IMM32 src ac))] [(and (imm? src) (reg32? dst)) (CR* #x81 '/0 dst (IMM src ac))]
[(and (reg32? src) (reg32? dst)) (CR* #x01 src dst ac)] [(and (reg32? src) (reg32? dst)) (CR* #x01 src dst ac)]
[(and (mem? src) (reg32? dst)) (CR* #x03 dst src ac)] [(and (mem? src) (reg32? dst)) (CR* #x03 dst src ac)]
[(and (imm? src) (mem? dst)) (CR* #x81 '/0 dst (IMM32 src ac))] [(and (imm? src) (mem? dst)) (CR* #x81 '/0 dst (IMM src ac))]
[(and (reg32? src) (mem? dst)) (CR* #x01 src dst ac)] [(and (reg32? src) (mem? dst)) (CR* #x01 src dst ac)]
[else (die who "invalid" instr)])] [else (die who "invalid" instr)])]
[(subl src dst) [(subl src dst)
(cond (cond
[(and (imm8? src) (reg32? dst)) (CR* #x83 '/5 dst (IMM8 src ac))] [(and (imm8? src) (reg32? dst)) (CR* #x83 '/5 dst (IMM8 src ac))]
[(and (imm? src) (eq? dst '%eax)) (CODE #x2D (IMM32 src ac))] [(and (imm? src) (eq? dst '%eax)) (CODE #x2D (IMM src ac))]
[(and (imm? src) (reg32? dst)) (CR* #x81 '/5 dst (IMM32 src ac))] [(and (imm? src) (reg32? dst)) (CR* #x81 '/5 dst (IMM src ac))]
[(and (reg32? src) (reg32? dst)) (CR* #x29 src dst ac)] [(and (reg32? src) (reg32? dst)) (CR* #x29 src dst ac)]
[(and (mem? src) (reg32? dst)) (CR* #x2B dst src ac)] [(and (mem? src) (reg32? dst)) (CR* #x2B dst src ac)]
[(and (imm? src) (mem? dst)) (CR* #x81 '/5 dst (IMM32 src ac))] [(and (imm? src) (mem? dst)) (CR* #x81 '/5 dst (IMM src ac))]
[(and (reg32? src) (mem? dst)) (CR* #x29 src dst ac)] [(and (reg32? src) (mem? dst)) (CR* #x29 src dst ac)]
[else (die who "invalid" instr)])] [else (die who "invalid" instr)])]
[(sall src dst) [(sall src dst)
@ -535,21 +553,21 @@
[else (die who "invalid" instr)])] [else (die who "invalid" instr)])]
[(andl src dst) [(andl src dst)
(cond (cond
[(and (imm? src) (mem? dst)) (CR* #x81 '/4 dst (IMM32 src ac))] [(and (imm? src) (mem? dst)) (CR* #x81 '/4 dst (IMM src ac))]
[(and (imm8? src) (reg32? dst)) (CR* #x83 '/4 dst (IMM8 src ac))] [(and (imm8? src) (reg32? dst)) (CR* #x83 '/4 dst (IMM8 src ac))]
[(and (imm? src) (eq? dst '%eax)) (CODE #x25 (IMM32 src ac))] [(and (imm? src) (eq? dst '%eax)) (CODE #x25 (IMM src ac))]
[(and (imm? src) (reg32? dst)) (CR* #x81 '/4 dst (IMM32 src ac))] [(and (imm? src) (reg32? dst)) (CR* #x81 '/4 dst (IMM src ac))]
[(and (reg32? src) (reg32? dst)) (CR* #x21 src dst ac)] [(and (reg32? src) (reg32? dst)) (CR* #x21 src dst ac)]
[(and (reg32? src) (mem? dst)) (CR* #x21 src dst ac)] [(and (reg32? src) (mem? dst)) (CR* #x21 src dst ac)]
[(and (mem? src) (reg32? dst)) (CR* #x23 dst src ac)] [(and (mem? src) (reg32? dst)) (CR* #x23 dst src ac)]
[else (die who "invalid" instr)])] [else (die who "invalid" instr)])]
[(orl src dst) [(orl src dst)
(cond (cond
[(and (imm? src) (mem? dst)) (CR* #x81 '/1 dst (IMM32 src ac))] [(and (imm? src) (mem? dst)) (CR* #x81 '/1 dst (IMM src ac))]
[(and (reg32? src) (mem? dst)) (CR* #x09 src dst ac)] [(and (reg32? src) (mem? dst)) (CR* #x09 src dst ac)]
[(and (imm8? src) (reg32? dst)) (CR* #x83 '/1 dst (IMM8 src ac))] [(and (imm8? src) (reg32? dst)) (CR* #x83 '/1 dst (IMM8 src ac))]
[(and (imm? src) (eq? dst '%eax)) (CODE #x0D (IMM32 src ac))] [(and (imm? src) (eq? dst '%eax)) (CODE #x0D (IMM src ac))]
[(and (imm? src) (reg32? dst)) (CR* #x81 '/1 dst (IMM32 src ac))] [(and (imm? src) (reg32? dst)) (CR* #x81 '/1 dst (IMM src ac))]
[(and (reg32? src) (reg32? dst)) (CR* #x09 src dst ac)] [(and (reg32? src) (reg32? dst)) (CR* #x09 src dst ac)]
[(and (mem? src) (reg32? dst)) (CR* #x0B dst src ac)] [(and (mem? src) (reg32? dst)) (CR* #x0B dst src ac)]
[else (die who "invalid" instr)])] [else (die who "invalid" instr)])]
@ -557,7 +575,7 @@
(cond (cond
[(and (imm8? src) (reg32? dst)) (CR* #x83 '/6 dst (IMM8 src ac))] [(and (imm8? src) (reg32? dst)) (CR* #x83 '/6 dst (IMM8 src ac))]
[(and (imm8? src) (mem? dst)) (CR* #x83 '/6 dst (IMM8 src ac))] [(and (imm8? src) (mem? dst)) (CR* #x83 '/6 dst (IMM8 src ac))]
[(and (imm? src) (eq? dst '%eax)) (CODE #x35 (IMM32 src ac))] [(and (imm? src) (eq? dst '%eax)) (CODE #x35 (IMM src ac))]
[(and (reg32? src) (reg32? dst)) (CR* #x31 src dst ac)] [(and (reg32? src) (reg32? dst)) (CR* #x31 src dst ac)]
[(and (mem? src) (reg32? dst)) (CR* #x33 dst src ac)] [(and (mem? src) (reg32? dst)) (CR* #x33 dst src ac)]
[(and (reg32? src) (mem? dst)) (CR* #x31 src dst ac)] [(and (reg32? src) (mem? dst)) (CR* #x31 src dst ac)]
@ -569,17 +587,17 @@
[(cmpl src dst) [(cmpl src dst)
(cond (cond
[(and (imm8? src) (reg32? dst)) (CR* #x83 '/7 dst (IMM8 src ac))] [(and (imm8? src) (reg32? dst)) (CR* #x83 '/7 dst (IMM8 src ac))]
[(and (imm? src) (eq? dst '%eax)) (CODE #x3D (IMM32 src ac))] [(and (imm? src) (eq? dst '%eax)) (CODE #x3D (IMM src ac))]
[(and (imm? src) (reg32? dst)) (CR* #x81 '/7 dst (IMM32 src ac))] [(and (imm? src) (reg32? dst)) (CR* #x81 '/7 dst (IMM src ac))]
[(and (reg32? src) (reg32? dst)) (CR* #x39 src dst ac)] [(and (reg32? src) (reg32? dst)) (CR* #x39 src dst ac)]
[(and (mem? src) (reg32? dst)) (CR* #x3B dst src ac)] [(and (mem? src) (reg32? dst)) (CR* #x3B dst src ac)]
[(and (imm8? src) (mem? dst)) (CR* #x83 '/7 dst (IMM8 src ac))] [(and (imm8? src) (mem? dst)) (CR* #x83 '/7 dst (IMM8 src ac))]
[(and (imm? src) (mem? dst)) (CR* #x81 '/8 dst (IMM32 src ac))] [(and (imm? src) (mem? dst)) (CR* #x81 '/8 dst (IMM src ac))]
[else (die who "invalid" instr)])] [else (die who "invalid" instr)])]
[(imull src dst) [(imull src dst)
(cond (cond
[(and (imm8? src) (reg32? dst)) (CR* #x6B dst dst (IMM8 src ac))] [(and (imm8? src) (reg32? dst)) (CR* #x6B dst dst (IMM8 src ac))]
[(and (imm? src) (reg32? dst)) (CR* #x69 dst dst (IMM32 src ac))] [(and (imm? src) (reg32? dst)) (CR* #x69 dst dst (IMM src ac))]
[(and (reg32? src) (reg32? dst)) (CCR* #x0F #xAF dst src ac)] [(and (reg32? src) (reg32? dst)) (CCR* #x0F #xAF dst src ac)]
[(and (mem? src) (reg32? dst)) (CCR* #x0F #xAF dst src ac)] [(and (mem? src) (reg32? dst)) (CCR* #x0F #xAF dst src ac)]
[else (die who "invalid" instr)])] [else (die who "invalid" instr)])]
@ -591,7 +609,7 @@
[(pushl dst) [(pushl dst)
(cond (cond
[(imm8? dst) (CODE #x6A (IMM8 dst ac))] [(imm8? dst) (CODE #x6A (IMM8 dst ac))]
[(imm? dst) (CODE #x68 (IMM32 dst ac))] [(imm? dst) (CODE #x68 (IMM dst ac))]
[(reg32? dst) (CR #x50 dst ac)] [(reg32? dst) (CR #x50 dst ac)]
[(mem? dst) (CR* #xFF '/6 dst ac)] [(mem? dst) (CR* #xFF '/6 dst ac)]
[else (die who "invalid" instr)])] [else (die who "invalid" instr)])]
@ -615,12 +633,12 @@
[else (die who "invalid" instr)])] [else (die who "invalid" instr)])]
[(jmp dst) [(jmp dst)
(cond (cond
[(imm? dst) (CODE #xE9 (IMM32 dst ac))] [(imm? dst) (CODE #xE9 (IMM dst ac))]
[(mem? dst) (CR* #xFF '/4 dst ac)] [(mem? dst) (CR* #xFF '/4 dst ac)]
[else (die who "invalid jmp target" dst)])] [else (die who "invalid jmp target" dst)])]
[(call dst) [(call dst)
(cond (cond
[(imm? dst) (CODE #xE8 (IMM32 dst ac))] [(imm? dst) (CODE #xE8 (IMM dst ac))]
[(mem? dst) (CR* #xFF '/2 dst ac)] [(mem? dst) (CR* #xFF '/2 dst ac)]
[(reg32? dst) (CR* #xFF '/2 dst ac)] [(reg32? dst) (CR* #xFF '/2 dst ac)]
[else (die who "invalid jmp target" dst)])] [else (die who "invalid jmp target" dst)])]
@ -692,7 +710,7 @@
(unless (byte? x) (die who "not a byte" x)) (unless (byte? x) (die who "not a byte" x))
(cons (byte x) ac)] (cons (byte x) ac)]
[(byte-vector x) (append (map (lambda (x) (byte x)) (vector->list x)) ac)] [(byte-vector x) (append (map (lambda (x) (byte x)) (vector->list x)) ac)]
[(int a) (IMM32 a ac)] [(int a) (IMM a ac)]
[(label L) [(label L)
(unless (symbol? L) (die who "label is not a symbol" L)) (unless (symbol? L) (die who "label is not a symbol" L))
(cons (cons 'label L) ac)] (cons (cons 'label L) ac)]
@ -713,11 +731,11 @@
(fx+ ac 1) (fx+ ac 1)
(case (car x) (case (car x)
[(byte) (fx+ ac 1)] [(byte) (fx+ ac 1)]
[(word reloc-word reloc-word+ label-addr foreign-label [(reloc-word reloc-word+ label-addr foreign-label
local-relative) local-relative)
(fx+ ac 4)] (fx+ ac 4)]
[(label) ac] [(label) ac]
[(relative current-frame-offset) (+ ac wordsize)] [(word relative current-frame-offset) (+ ac wordsize)]
[else (die 'compute-code-size "unknown instr" x)]))) [else (die 'compute-code-size "unknown instr" x)])))
0 0
ls))) ls)))
@ -796,7 +814,7 @@
[(word) [(word)
(let ([v (cdr a)]) (let ([v (cdr a)])
(set-code-word! x idx v) (set-code-word! x idx v)
(f (cdr ls) (fx+ idx 4) reloc))] (f (cdr ls) (fx+ idx wordsize) reloc))]
[(current-frame-offset) [(current-frame-offset)
(set-code-word! x idx idx) ;;; FIXME 64bit (set-code-word! x idx idx) ;;; FIXME 64bit
(f (cdr ls) (fx+ idx wordsize) reloc)] (f (cdr ls) (fx+ idx wordsize) reloc)]

2
scheme/last-revision
View File

@ -1 +1 @@
1317 1318

35
scheme/test64.ss
View File

@ -17,6 +17,7 @@
;;; vim:syntax=scheme ;;; vim:syntax=scheme
(import (import
(ikarus compiler) (ikarus compiler)
(match)
(except (ikarus) assembler-output)) (except (ikarus) assembler-output))
(define (compile1 x) (define (compile1 x)
@ -30,23 +31,43 @@
(compile1 x) (compile1 x)
(let ([rs (system "../src/ikarus -b test64.boot > test64.out")]) (let ([rs (system "../src/ikarus -b test64.boot > test64.out")])
(unless (= rs 0) (error 'run1 "died")) (unless (= rs 0) (error 'run1 "died"))
(with-input-from-file "test64.out" read))) (with-input-from-file "test64.out"
(lambda () (get-string-all (current-input-port))))))
(define (compile-test-and-run expr expected) (define (compile-test-and-run expr expected)
(let ([val (compile-and-run expr)]) (let ([val (compile-and-run expr)])
(unless (equal? val expected) (unless (equal? val expected)
(error 'compile-test-and-run "failed:got:expected" val expected)))) (error 'compile-test-and-run "failed:got:expected" val expected))))
(define (test-all)
(for-each
(lambda (x)
(compile-test-and-run (car x) (cadr x)))
all-tests))
(define all-tests (define all-tests
'([(quote 42) 42] '([(quote 42) "42\n"]
[(quote #f) #f] [(quote #f) "#f\n"]
[(quote ()) ()])) [(quote ()) "()\n"]))
(for-each (define (fixup x)
(match x
[,n (guard (number? n)) `(quote ,n)]
[,_ (error 'fixup "invalid expression" _)]))
(define-syntax add-tests-with-string-output
(lambda (x) (lambda (x)
(compile-test-and-run (car x) (cadr x))) (syntax-case x (=>)
all-tests) [(_ name [test => string] ...)
#'(set! all-tests
(append all-tests
(list
(list (fixup 'test) string)
...)))])))
(include "tests/tests-1.1-req.scm")
(test-all)
(printf "Passed ~s tests\n" (length all-tests))
(printf "Happy Happy Joy Joy\n") (printf "Happy Happy Joy Joy\n")

69
scheme/x86-64-repl.ss Executable file
View File

@ -0,0 +1,69 @@
#!/usr/bin/env scheme-script
;;; This is a debugging tool for developing the 64-bit
;;; ikarus. It only works on Mac OS.
(import (ikarus))
(define stub1
'(#xcf #xfa #xed #xfe #x07 #x00 #x00 #x01
#x03 #x00 #x00 #x00 #x01 #x00 #x00 #x00
#x01 #x00 #x00 #x00 #x98 #x00 #x00 #x00
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
#x19 #x00 #x00 #x00 #x98 #x00 #x00 #x00
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
#x08 #x00 #x00 #x00 #x00 #x00 #x00 #x00
#xb8 #x00 #x00 #x00 #x00 #x00 #x00 #x00
#x08 #x00 #x00 #x00 #x00 #x00 #x00 #x00
#x07 #x00 #x00 #x00 #x07 #x00 #x00 #x00
#x01 #x00 #x00 #x00 #x00 #x00 #x00 #x00
#x5f #x5f #x74 #x65 #x78 #x74 #x00 #x00
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
#x5f #x5f #x54 #x45 #x58 #x54 #x00 #x00
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
))
(define stub2
'(#x08 #x00 #x00 #x00 #x00 #x00 #x00 #x00))
(define (mkstub2 len)
(bytevector->u8-list
(let ([v (make-bytevector 8)])
(bytevector-u64-set! v 0 len 'little)
v)))
(define stub3
'(#xb8 #x00 #x00 #x00 #x00 #x00 #x00 #x00
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
#x00 #x04 #x00 #x80 #x00 #x00 #x00 #x00
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
))
(define (gen ls)
(let ([p (open-file-output-port "tmp.o" (file-options no-fail))])
(for-each
(lambda (b)
(put-u8 p b))
(append stub1 (mkstub2 (length ls)) stub3 ls))
(close-output-port p))
(system "otool64 -tv tmp.o"))
(printf "Trying a simple sequence ...\n")
(gen '(#x48 #xc7 #xc3 #x50 #x01 #x00 #x00 #xc3))
(printf "That should've printed the following: \n\
tmp.o: \n\
(__TEXT,__text) section\n\
0000000000000000 movq $0x00000150,%rbx\n\
0000000000000007 ret\n\n\
OK, now you can enter byte sequences like\n\
\x20; (72 199 195 80 1 0 0 195)\n\n")
(new-cafe gen)