Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
168 lines (130 sloc) 5.39 KB
#lang pyramid
(require psl "primitives.pmd")
(require psl "syntax.pmd")
(require ceagle "builtins.c")
(defmacro (%c-define-word-assign-unop assign-op base-op)
`(defmacro (,assign-op x)
`(%c-word-write! ,x (,,base-op ,x))))
(defmacro (%c-define-word-assign-binop assign-op base-op)
`(defmacro (,assign-op x y)
`(%c-word-write! ,x (,,base-op ,x ,y))))
; Unary operators
(%c-define-word-assign-unop %c-word-op-- '%c-word-op-1)
(%c-define-word-assign-unop %c-word-op++ '%c-word-op+1)
; Binary operators
(%c-define-word-assign-binop %c-word-op*= '%c-word-op*)
(%c-define-word-assign-binop %c-word-op+= '%c-word-op+)
(%c-define-word-assign-binop %c-word-op-= '%c-word-op-)
(%c-define-word-assign-binop %c-word-op/= '%c-word-op/)
(%c-define-word-assign-binop %c-word-op= '%c-word-opright)
(defmacro (%c-word-op-1 x) `(%#-- ,x (unbox 1)))
(defmacro (%c-word-op+1 x) `(%#-+ ,x (unbox 1)))
(defmacro (%c-word-opdereference x) `(%c-word-read ,x))
(defmacro (%c-word-op! x) `(%#-not ,x))
(defmacro (%c-word-op~ x) `(%#-negate ,x))
(defmacro (%c-word-op&& x y) `(%#-not (%#-not (%#-and (%#-not (%#-not ,x)) (%#-not (%#-not ,y))))))
(defmacro (%c-word-op\|\| x y) `(%#-not (%#-not (%#-or (%#-not (%#-not ,x)) (%#-not (%#-not ,y))))))
(defmacro (%c-word-op& x y) `(%#-and ,x ,y))
(defmacro (%c-word-op\| x y) `(%#-or ,x ,y))
(defmacro (%c-word-op^ x y) `(%#-xor ,x ,y))
(defmacro (%c-word-op== x y) `(%#-bool->word (%#-= ,x ,y)))
(defmacro (%c-word-op!= x y) `(%#-bool->word (%#-not (%#-= ,x ,y))))
(defmacro (%c-word-opu>= x y) `(%#-bool->word (%#-u>= ,x ,y)))
(defmacro (%c-word-opu> x y) `(%#-bool->word (%#-u> ,x ,y)))
(defmacro (%c-word-opu<= x y) `(%#-bool->word (%#-u<= ,x ,y)))
(defmacro (%c-word-opu< x y) `(%#-bool->word (%#-u< ,x ,y)))
(defmacro (%c-word-opu> x y) `(%#-bool->word (%#-u> ,x ,y)))
(defmacro (%c-word-ops>= x y) `(%#-bool->word (%#-s>= ,x ,y)))
(defmacro (%c-word-ops> x y) `(%#-bool->word (%#-s> ,x ,y)))
(defmacro (%c-word-ops<= x y) `(%#-bool->word (%#-s<= ,x ,y)))
(defmacro (%c-word-ops< x y) `(%#-bool->word (%#-s< ,x ,y)))
(defmacro (%c-word-ops> x y) `(%#-bool->word (%#-s> ,x ,y)))
(defmacro (%c-word-opraw+ x y) `(%#-+ ,x ,y))
(defmacro (%c-word-opraw- x y) `(%#-- ,x ,y))
(defmacro (%c-word-op* x y) `(%#-* ,x ,y))
(defmacro (%c-word-op/ x y) `(%#-u/ ,x ,y))
(defmacro (%c-word-op% x y) `(%#-u% ,x ,y))
(defmacro (%c-word-op>> x y) `(%#-bitshiftr ,x ,y))
(defmacro (%c-word-op<< x y) `(%#-bitshiftl ,x ,y))
(defmacro (%c-restrict-bytes x num-bytes signed?)
(if signed?
`(%#-sign-extend ,x ,num-bytes)
`(%#-zero-extend ,x ,num-bytes)))
; Other utilities
(defmacro (%c-loop-forever body)
`((λ ()
(define (loop) ,body (loop))
(loop))))
(defmacro (%c-allocate-fixnum)
`(%#-mem-alloc %#-WORD))
(defmacro (%c-allocate-struct size)
`(%#-mem-alloc (unbox ,size)))
(defmacro (%c-struct-field ptr os size)
`(%#-+ ,ptr ,os))
(defmacro (%c-word-read ptr)
`(%#-mem-read ,ptr (unbox 0)))
(define-syntax (%c-word-write! stx)
(syntax-case stx ()
[(_ ptr val) #'(%#-mem-write! ptr (unbox 0) val)]
))
(defmacro (%c-word-opright x y) y)
(defmacro (%c-noinline var) `(set! ,var ,var))
(define-syntax (%c-define-arg stx)
(syntax-case stx ()
[(_ name init) #'(begin (define name (%c-allocate-fixnum))
(%c-noinline name)
(%c-word-write! name init))]
))
(define-syntax (%c-struct-copy stx)
(syntax-case stx ()
[(_ size from to) #'(%#-memcpy to from size)]
))
(define-syntax (%c-define-fixnum stx)
(syntax-case stx ()
[(_ name init) #'(begin (define name (let ([ ptr (%c-allocate-fixnum) ])
(%c-word-write! ptr init)
ptr))
(%c-noinline name))]
))
(defmacro (%c-define-struct name init)
`(begin (define ,name ,init)
(%c-noinline ,name)))
(defmacro (%c-define-pointer name init)
`(begin (%c-define-fixnum ,name ,init)
(%c-noinline ,name)))
(defmacro (%c-define-union name init)
`(begin (define ,name ,init)
(%c-noinline ,name)))
(defmacro (%c-case e . xs)
`(%#-case ,e ,@xs))
; GCC compatability
(defmacro (__builtin_trap)
`(begin ;(%#-ioctl-print-symbol (%-unbox (%-lexical-value '%c-function-name)))
(%-throw))
)
(define (__builtin_bswap64 x) (psnip_builtin_bswap64 x))
(define (__builtin_ctzll x) (psnip_builtin_ctz64 x))
(define (__builtin_clzll x) (psnip_builtin_clz64 x))
; Debug utilities
(define (__builtin_print_word x) (%#-ioctl-print-word x))
(define (__builtin_print_string x) (%#-ioctl-print-string x))
(define (__builtin_print_char x) (%#-ioctl-print-char x))
(define-syntax (%c-strip-runtime-annotations stx)
(syntax-case stx (%c-restrict-bytes)
[(_ (%c-restrict-bytes val _)) #'(%c-strip-runtime-annotations val)]
[(_ val) #'val]
))
(define-syntax (__builtin_set_max_iterations stx)
(syntax-case stx ()
[(_ n)
#`(%#-set-max-iterations! #,(simplify-syntax #'(%c-strip-runtime-annotations n)))]
))
(define-syntax (__builtin_set_max_simulator_memory stx)
(syntax-case stx ()
[(_ n) #`(%#-set-max-simulator-memory! #,(simplify-syntax #'(%c-strip-runtime-annotations n)))]
))
(define-syntax (__builtin_set_test_result stx)
(syntax-case stx ()
[(_ n)
#`(set-test-result! #,(shrink-pyramid (simplify-macros (make-macro-application #'(%c-strip-runtime-annotations n)))))]
))