#lang typed/racket

(require x64asm)

(define-cast adder

#:type (Fixnum -> Fixnum)

#:ctype (_fun _int -> _int))

(define-cast adder-get

#:type (-> Fixnum)

#:ctype (_fun -> _int))

(define arg0 (if (eq? (system-type) 'windows) ecx edi))

(define (make-adder/get [init : Integer])

(parameterize ([current-context (make-context)])

(with-labels #:captured ()

(:! (label inc))

(add (mref 32 rip + (rel32 (label d))) arg0)

(mov eax (imm32 init #:! (label d)))

(ret)

(:! (label get))

(mov eax (moff 32 (imm64 (label d))))

(ret)

(emit-code!)

(values (adder (label-addr (label inc)))

(adder-get (label-addr (label get)))))))

#lang typed/racket

(require x64asm)

(define-cast int->int

#:type (Integer -> Integer)

#:ctype (_fun _int64 -> _int64))

(define arg0 (if (eq? (system-type) 'windows) rcx rdi))

(define-λ! f int->int #:captured

(mov rax (imm64 (label data)))

(jmp (mref 64 rax + arg0 * 8))

(:! (label here))

(mov eax (imm32 100))

(ret)

(:! (label l1))

(mov eax (imm32 200))

(ret)

(:! (label l2))

(mov eax (imm32 300))

(ret)

(:! (label data))

(data!

(imm64 (label here))

(imm64 (label l1))

(imm64 (label l2))))

;;; This one use a smaller table

(define-λ! g int->int #:captured

(lea rdx (mref 64 rip + (rel32 (label data))))

(movzx rdx (mref 8 rdx + arg0 * 1))

(lea rax (mref 64 rip + (rel32 (label here))))

(add rax rdx)

(jmp rax)

(:! (label here))

(mov eax (imm32 100))

(ret)

(:! (label l1))

(mov eax (imm32 200))

(ret)

(:! (label l2))

(mov eax (imm32 300))

(ret)

(:! (label data))

(define (dist [a : Label] [b : Label])

(latent-imm 8 (λ ()

(- (label-addr b)

(label-addr a)))))

(data!

(imm8 0)

(dist (label here) (label l1))

(dist (label here) (label l2))))

#lang typed/racket

(module asin racket/base

(require ffi/unsafe)

(define asin

(cast (ffi-obj-ref "asin" #f)

_pointer _uintptr))

(provide asin))

(require/typed 'asin [asin Integer])

(require x64asm)

(define-cast ->d

#:type (-> Flonum Flonum)

#:ctype (_fun _double -> _double))

(define-λ! tail ->d

(mov rax (imm64 asin))

(jmp rax))

(define-λ! non-tail ->d

(push rbp)

(mov rbp rsp)

;;shadow space

(when (eq? (system-type) 'windows)

(sub rsp (imm8 32)))

(mov rax (imm64 asin))

(call rax)

(addsd xmm0 xmm0)

(leave)

(ret))

#lang racket

(require ffi/unsafe x64asm/untyped)

(define err-offset

(let ([asm (make-assembler)]

[ctx (make-context)]

[l (label)]

[i (label)])

(:! l #:ctx ctx)

(nop #:ctx ctx (mref 32 + (imm32 0 #:! i)))

(emit-code! asm ctx)

(assembler-shutdown-all! asm)

(- (label-addr i) (label-addr l))))

(define (call/on-error target err)

(call (rel32 target))

(define here (label))

(:! here)

(nop (mref 32 + (latent-imm 32 (λ ()

(- (label-addr err)

(label-addr here)))))))

(define (ret-error)

(pop r8)

(mov r9d (mref 32 r8 + (imm8 err-offset)))

(add r8 r9)

(jmp r8))

;;; defines some helper functions to handle platform specific thing as much as possible

(define ptr-false

(case (system-type 'gc)

[(3m)

(cast #f _racket _uintptr)]

[(cs) 6]))

(define notpairp

(case (system-type 'gc)

[(3m)

(λ (p)

(mov r8w (mref 16 p))

(cmp r8w (imm8 62))

jne)]

[(cs)

(λ (p)

(mov r8 p)

(and r8b (imm8 7))

(cmp r8b (imm8 1))

jne)]))

(define notfixp

(case (system-type 'gc)

[(3m)

(λ (p)

(mov r8 p)

(and r8b (imm8 1))

jz)]

[(cs)

(λ (p)

(mov r8 p)

(and r8b (imm8 7))

jnz)]))

(define unfix

(case (system-type 'gc)

[(3m)

(λ (p)

(sar p (imm8 1)))]

[(cs)

(λ (p)

(sar p (imm8 3)))]))

(define fix

(case (system-type 'gc)

[(3m)

(λ (p)

(shl p (imm8 1))

(or p (imm8 1)))]

[(cs)

(λ (p)

(shl p (imm8 3)))]))

(define arg0 (if (eq? (system-type) 'windows)

rcx

rdi))

(define-values (car-offset cdr-offset)

(case (system-type 'gc)

[(3m) (values 8 16)]

[(cs) (values 7 15)]))

;;; Since interior nodes don't do anything but pop on error in this example,

;;; an alternative approach may be recording the stack pointer at the beginning,

;;; restoring it when a object neighter pair nor fixnum is encountered,

;;; and then return with false.

(define-cast a->a

#:type (Any -> Any)

#:ctype (_fun _racket -> _racket))

(define-λ! sum-tree-fixnums a->a #:captured

(push rbp)

(mov rbp rsp)

(call/on-error (label inner) (label err))

(fix rax)

(:! (label err))

(leave)

(ret)

(:! (label inner))

((notfixp arg0) (rel8 (label not-fix)))

(mov rax arg0)

(unfix rax)

(ret)

(:! (label not-fix))

((notpairp arg0) (rel8 (label invalid)))

(push arg0)

(mov arg0 (mref 64 arg0 + (imm8 car-offset)))

(call/on-error (label inner) (label child-err))

(pop arg0)

(mov arg0 (mref 64 arg0 + (imm8 cdr-offset)))

(push rax)

(call/on-error (label inner) (label child-err))

(pop r8)

(add rax r8)

(ret)

(:! (label child-err))

(pop r8)

(ret-error)

(:! (label invalid))

(mov rax (imm64 ptr-false))

(ret-error))